subsection \<open>Integration algorithm \label{sec:integrate}\<close>

text \<open>In this section we describe the algorithm to integrate a received message into a peers'
  state.\<close>

theory IntegrateAlgorithm
  imports BasicAlgorithms Data
begin

fun fromSome :: "'a option \<Rightarrow> error + 'a"
  where
    "fromSome (Some x) = return x" |
    "fromSome None = error (STR ''Expected Some'')"

lemma fromSome_ok_simp [simp]: "(fromSome x = Inr y) = (x = Some y)"
  by (cases x, simp+)

fun substr :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list" where
  "substr s l u = take (u - (Suc l)) (drop l s)"

fun concurrent ::
  "('a, 's) woot_character list
  \<Rightarrow> nat
  \<Rightarrow> nat
  \<Rightarrow> ('a, 's) woot_character
  \<Rightarrow> error + ('a extended list)"
  where
    "concurrent s l u w =
      do {
        p_pos \<leftarrow> idx s (P w);
        s_pos \<leftarrow> idx s (S w);
        return (if (p_pos \<le> l \<and> s_pos \<ge> u) then [\<lbrakk>I w\<rbrakk>] else [])
      }"

function integrate_insert
  where
    "integrate_insert m w p s =
      do {
        l \<leftarrow> idx w p;
        u \<leftarrow> idx w s;
        assert (l < u);
        if Suc l = u then
          return ((take l w)@[to_woot_char m]@(drop l w))
        else do {
          d \<leftarrow> mapM (concurrent w l u) (substr w l u);
          assert (concat d \<noteq> []);
          (p', s') \<leftarrow> fromSome (find ((\<lambda>x.\<lbrakk>I m\<rbrakk> < x \<or> x = s) \<circ> snd)
                        (zip (p#concat d) (concat d@[s])));
          integrate_insert m w p' s'
        }
      }"
  by fastforce+

fun integrate_delete ::
  "('a :: linorder) delete_message
  \<Rightarrow> ('a, 's) woot_character list
  \<Rightarrow> error + ('a, 's) woot_character list"
  where
    "integrate_delete (DeleteMessage i) s =
      do {
        k \<leftarrow> idx s \<lbrakk>i\<rbrakk>;
        w \<leftarrow> nth s k;
        list_update s k
          (case w of (InsertMessage p i u _) \<Rightarrow> InsertMessage p i u None)
      }"

fun integrate ::
  "('a, 's) woot_character list
  \<Rightarrow> ('a :: linorder, 's) message
  \<Rightarrow> error + ('a, 's) woot_character list"
  where
    "integrate s (Insert m) = integrate_insert m s (P m) (S m)" |
    "integrate s (Delete m) = integrate_delete m s"

text \<open>Algorithm @{term integrate} describes the main function that is called when a new message
  @{term m} has to be integrated into the state @{term s} of a peer.
  It is called both when @{term m} was generated locally or received from another peer.
  Note that we require that the antecedant messages have already been integrated. See also
  Section \ref{sec:networkModel} for the delivery assumptions that ensure this requirement.

  Algorithm @{term integrate_delete} describes the procedure to integrate a delete message:
  @{term "DeleteMessage i"}.
  The algorithm just replaces the symbol of the W-character with identifier @{term i} with the value
  @{term "None"}.
  It is not possible to entirely remove a W-character if it is deleted, since there might be
  unreceived insertion messages that depend on its position.

  Algorithm @{term integrate_insert} describes the procedure to integrate an insert message:
  @{term "m = InsertMessage p i s \<sigma>"}.
  Since insertion operations can happen concurrently and the order of message delivery is not fixed,
  it can happen that a remote peer receiving @{term m} finds multiple possible insertion points
  between the predecessor @{term p} and successor @{term s} that were recorded when the message
  was generated.
  An example of this situation is the conflict between
  @{term "InsertMessage \<turnstile> (A,0 :: nat) \<stileturn> (CHR ''I'')"} and @{term "InsertMessage \<turnstile> (B,0 :: nat) \<stileturn> (CHR ''N'')"}
  in Figure~\ref{fig:session}.

  A first attempt to resolve this would be to insert the W-characters by choosing an insertion point
  using the order induced by their identifiers to achieve a consistent ordering.
  But this method fails in some cases: a counter-example was found by
  Oster et al.~\cite[section 2]{oster2006data}.

  The solution introduced by the authors of WOOT is to restrict the identifier comparison to the
  set of W-characters in the range @{term "substr l u s"} whose predecessor and successor are
  outside of the possible range, i.e. @{text "idx s (P w) \<le> l"} and @{text "idx s (S w) \<ge> u"}.

  New narrowed bounds are selected by finding the first W-character within that restricted set
  with an identifier strictly larger than the identifier of the new W-character.

  This leads to a narrowed range where the found character forms an upper bound and its immediately
  preceeding character the lower bound. The method is applied recursively until the insertion point
  is uniquely determined.

  Note that the fact that this strategy leads to a consistent ordering has only been verified for a
  bounded model.
  One of the contributions of this paper is to provide a complete proof for it.\<close>

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* Author: Gerwin Klein and Thomas Sewell
   Type class for enumerations.
*)

header "Enumerations"

theory Enumeration
imports "~~/src/HOL/Main"
begin

abbreviation
  "enum \<equiv> enum_class.enum"
abbreviation
  "enum_all \<equiv> enum_class.enum_all"
abbreviation
  "enum_ex \<equiv> enum_class.enum_ex"

primrec
  the_index :: "'a list \<Rightarrow> 'a \<Rightarrow> nat"
where
  "the_index (x # xs) y = (if x = y then 0 else Suc (the_index xs y))"

lemma the_index_bounded:
  "x \<in> set xs \<Longrightarrow> the_index xs x < length xs"
  by (induct xs, clarsimp+)

lemma nth_the_index:
  "x \<in> set xs \<Longrightarrow> xs ! the_index xs x = x"
  by (induct xs, clarsimp+)

lemma distinct_the_index_is_index[simp]:
  "\<lbrakk> distinct xs ; n < length xs \<rbrakk> \<Longrightarrow> the_index xs (xs ! n) = n"
  apply (subst nth_eq_iff_index_eq[symmetric])
     apply assumption
    apply (rule the_index_bounded)
   apply simp_all
  apply (rule nth_the_index)
  apply simp
  done

lemma the_index_last_distinct:
  "distinct xs \<and> xs \<noteq> [] \<Longrightarrow> the_index xs (last xs) = length xs - 1"
  apply safe
  apply (subgoal_tac "xs ! (length xs - 1) = last xs")
   apply (subgoal_tac "xs ! the_index xs (last xs) = last xs")
    apply (subst nth_eq_iff_index_eq[symmetric])
       apply assumption
      apply (rule the_index_bounded)
      apply simp_all
   apply (rule nth_the_index)
   apply simp
  apply (induct xs, auto)
  done

context enum begin

  (* These two are added for historical reasons.
   * We had an enum class first, and these are the two
   * assumptions we had, which were added to the simp set.
   *)
  lemmas enum_surj[simp] = enum_UNIV
  declare enum_distinct[simp]

lemma enum_nonempty[simp]: "(enum :: 'a list) \<noteq> []"
  apply (rule classical, simp)
  apply (subgoal_tac "\<exists>X. X \<in> set (enum :: 'a list)")
   apply simp
  apply (subst enum_surj)
  apply simp
  done

definition
  maxBound :: 'a where
  "maxBound \<equiv> last enum"

definition
  minBound :: 'a where
  "minBound \<equiv> hd enum"
definition
  toEnum :: "nat \<Rightarrow> 'a" where
  "toEnum n \<equiv> if n < length (enum :: 'a list) then enum ! n else the None"

definition
  fromEnum :: "'a \<Rightarrow> nat" where
  "fromEnum x \<equiv> the_index enum x"

lemma maxBound_is_length:
  "fromEnum maxBound = length (enum :: 'a list) - 1"
  apply (simp add: maxBound_def fromEnum_def)
  apply (subst the_index_last_distinct)
   apply simp
  apply simp
  done

lemma maxBound_less_length:
  "(x \<le> fromEnum maxBound) = (x < length (enum :: 'a list))"
  apply (simp only: maxBound_is_length)
  apply (case_tac "length (enum :: 'a list)")
   apply simp
  apply simp
  apply arith
  done

lemma maxBound_is_bound [simp]:
 "fromEnum x \<le> fromEnum maxBound"
  apply (simp only: maxBound_less_length)
  apply (simp add: fromEnum_def)
  apply (rule the_index_bounded)
  by simp

lemma to_from_enum [simp]:
  fixes x :: 'a
  shows "toEnum (fromEnum x) = x"
proof -
  have "x \<in> set enum" by simp
  thus ?thesis
    by (simp add: toEnum_def fromEnum_def nth_the_index the_index_bounded)
qed

lemma from_to_enum [simp]:
  "x \<le> fromEnum maxBound \<Longrightarrow> fromEnum (toEnum x) = x"
  apply (simp only: maxBound_less_length)
  apply (simp add: toEnum_def fromEnum_def)
  done

lemma map_enum:
  fixes x :: 'a
  shows "map f enum ! fromEnum x = f x"
proof -
  have "fromEnum x \<le> fromEnum (maxBound :: 'a)"
    by (rule maxBound_is_bound)
  hence "fromEnum x < length (enum::'a list)"
    by (simp add: maxBound_less_length)
  hence "map f enum ! fromEnum x = f (enum ! fromEnum x)" by simp
  also
  have "x \<in> set enum" by simp
  hence "enum ! fromEnum x = x"
    by (simp add: fromEnum_def nth_the_index)
  finally
  show ?thesis .
qed

definition
  assocs :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'b) list" where
 "assocs f \<equiv> map (\<lambda>x. (x, f x)) enum"

end

(* For historical naming reasons. *)
lemmas enum_bool = enum_bool_def

lemma fromEnumTrue [simp]: "fromEnum True = 1"
  by (simp add: fromEnum_def enum_bool)

lemma fromEnumFalse [simp]: "fromEnum False = 0"
  by (simp add: fromEnum_def enum_bool)

class enum_alt =
  fixes enum_alt :: "nat \<Rightarrow> 'a option"

class enumeration_alt = enum_alt +
  assumes enum_alt_one_bound:
    "enum_alt x = (None :: 'a option) \<Longrightarrow> enum_alt (Suc x) = (None :: 'a option)"
  assumes enum_alt_surj: "range enum_alt \<union> {None} = UNIV"
  assumes enum_alt_inj:
    "(enum_alt x :: 'a option) = enum_alt y \<Longrightarrow> (x = y) \<or> (enum_alt x = (None :: 'a option))"
begin

lemma enum_alt_inj_2:
  "\<lbrakk> enum_alt x = (enum_alt y :: 'a option);
     enum_alt x \<noteq> (None :: 'a option) \<rbrakk>
    \<Longrightarrow> x = y"
  apply (subgoal_tac "(x = y) \<or> (enum_alt x = (None :: 'a option))")
   apply clarsimp
  apply (rule enum_alt_inj)
  apply simp
  done

lemma enum_alt_surj_2:
  "\<exists>x. enum_alt x = Some y"
  apply (subgoal_tac "Some y \<in> range enum_alt")
   apply (erule rangeE)
   apply (rule exI)
   apply simp
  apply (subgoal_tac "Some y \<in> range enum_alt \<union> {None}")
   apply simp
  apply (subst enum_alt_surj)
  apply simp
  done

end

definition
  alt_from_ord :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" where
 "alt_from_ord L \<equiv> \<lambda>n. if (n < length L) then Some (L ! n) else None"

lemma handy_enum_lemma1: "((if P then Some A else None) = None) = (\<not> P)"
  apply simp
  done

lemma handy_enum_lemma2: "Some x \<notin> empty ` S"
  apply safe
  done

lemma handy_enum_lemma3: "((if P then Some A else None) = Some B) = (P \<and> (A = B))"
  apply simp
  done

class enumeration_both = enum_alt + enum +
  assumes enum_alt_rel: "enum_alt = alt_from_ord enum"

instance enumeration_both < enumeration_alt
  apply (intro_classes)
    apply (simp_all add: enum_alt_rel alt_from_ord_def)
    apply (simp add: handy_enum_lemma1)
   apply (safe, simp_all)
   apply (simp add: handy_enum_lemma2)
   apply (rule rev_image_eqI, simp_all)
   defer
   apply (subst nth_the_index, simp_all)
   apply (simp add: handy_enum_lemma3)
   apply (subst nth_eq_iff_index_eq[symmetric], simp_all)
   apply safe
  apply (rule the_index_bounded)
  apply simp
  done

instantiation bool :: enumeration_both
begin

definition
  enum_alt_bool: "enum_alt \<equiv> alt_from_ord [False, True]"

instance
  by (intro_classes, simp add: enum_bool_def enum_alt_bool)
end

definition
  toEnumAlt :: "nat \<Rightarrow> ('a :: enum_alt)" where
 "toEnumAlt n \<equiv> the (enum_alt n)"

definition
  fromEnumAlt :: "('a :: enum_alt) \<Rightarrow> nat" where
 "fromEnumAlt x \<equiv> THE n. enum_alt n = Some x"

definition
  upto_enum :: "('a :: enumeration_alt) \<Rightarrow> 'a \<Rightarrow> 'a list" ("(1[_.e._])") where
 "upto_enum n m \<equiv> map toEnumAlt [fromEnumAlt n ..< Suc (fromEnumAlt m)]"

lemma fromEnum_alt_red[simp]:
  "fromEnumAlt = (fromEnum :: ('a :: enumeration_both) \<Rightarrow> nat)"
  apply (rule ext)
  apply (simp add: fromEnumAlt_def fromEnum_def)
  apply (simp add: enum_alt_rel alt_from_ord_def)
  apply (rule theI2)
    apply safe
     apply (rule nth_the_index, simp)
    apply (rule the_index_bounded, simp)
   apply simp_all
  done

lemma toEnum_alt_red[simp]:
  "toEnumAlt = (toEnum :: nat \<Rightarrow> ('a :: enumeration_both))"
  apply (rule ext)
  apply (unfold toEnum_def toEnumAlt_def)
  apply (simp add: enum_alt_rel alt_from_ord_def)
  done

lemma upto_enum_red:
  "[(n :: ('a :: enumeration_both)) .e. m] = map toEnum [fromEnum n ..< Suc (fromEnum m)]"
  apply (unfold upto_enum_def)
  apply simp
  done

instantiation nat :: enumeration_alt
begin

definition
  enum_alt_nat: "enum_alt \<equiv> Some"

instance
  apply (intro_classes)
    apply (simp_all add: enum_alt_nat)
   apply (safe, simp_all)
   apply (case_tac x, simp_all)
  done

end

lemma toEnumAlt_nat[simp]: "toEnumAlt = id"
  apply (rule ext)
  apply (simp add: toEnumAlt_def enum_alt_nat)
  done

lemma fromEnumAlt_nat[simp]: "fromEnumAlt = id"
  apply (rule ext)
  apply (simp add: fromEnumAlt_def enum_alt_nat)
  done

lemma upto_enum_nat[simp]: "[n .e. m] = [n ..< Suc m]"
  apply (subst upto_enum_def)
  apply simp
  done

definition
  zipE1 :: "('a :: enum_alt) \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where
 "zipE1 x L \<equiv> zip (map toEnumAlt [(fromEnumAlt x) ..< (fromEnumAlt x) + length L]) L"

definition
  zipE2 :: "('a :: enum_alt) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where
 "zipE2 x xn L \<equiv> zip (map (\<lambda>n. toEnumAlt ((fromEnumAlt x) + ((fromEnumAlt xn) - (fromEnumAlt x)) * n)) [0 ..< length L]) L"

definition
  zipE3 :: "'a list \<Rightarrow> ('b :: enum_alt) \<Rightarrow> ('a \<times> 'b) list" where
 "zipE3 L x \<equiv> zip L (map toEnumAlt [(fromEnumAlt x) ..< (fromEnumAlt x) + length L])"

definition
  zipE4 :: "'a list \<Rightarrow> ('b :: enum_alt) \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list" where
 "zipE4 L x xn \<equiv> zip L (map (\<lambda>n. toEnumAlt ((fromEnumAlt x) + ((fromEnumAlt xn) - (fromEnumAlt x)) * n)) [0 ..< length L])"

lemma handy_lemma: "a = Some b \<Longrightarrow> the a = b"
  by (simp)

lemma to_from_enum_alt[simp]:
 "toEnumAlt (fromEnumAlt x) = (x :: ('a :: enumeration_alt))"
  apply (simp add: fromEnumAlt_def toEnumAlt_def)
  apply (rule handy_lemma)
  apply (rule theI')
  apply safe
   apply (rule enum_alt_surj_2)
  apply (rule enum_alt_inj_2)
   apply auto
  done

end


(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

header {* Representing state in TLA*  *}

theory State
imports Liveness
begin

text{*
  We adopt the hidden state appraoch, as used in the existing
  Isabelle/HOL TLA embedding \cite{Merz98}. This approach is also used
  in \cite{Ehmety01}.
  Here, a state space is defined by its projections, and everything else is
  unknown. Thus, a variable is a projection of the state space, and has the same
  type as a state function. Moreover, strong typing is achieved, since the projection
  function may have any result type. To achieve this, the state space is represented
  by an undefined type, which is an instance of the @{text world} class to enable
  use with the @{text Intensional} theory.
*}

typedecl state

instance state :: world ..

type_synonym 'a statefun = "(state,'a) stfun"
type_synonym statepred  = "bool statefun"
type_synonym 'a tempfun = "(state,'a) formfun"
type_synonym temporal = "state formula"

text {*
  Formalizing type state would require formulas to be tagged with
  their underlying state space and would result in a system that is
  much harder to use. (Unlike Hoare logic or Unity, TLA has quantification
  over state variables, and therefore one usually works with different
  state spaces within a single specification.) Instead, state is just
  an anonymous type whose only purpose is to provide Skolem constants.
  Moreover, we do not define a type of state variables separate from that
  of arbitrary state functions, again in order to simplify the definition
  of flexible quantification later on. Nevertheless, we need to distinguish
  state variables, mainly to define the enabledness of actions. The user
  identifies (tuples of) ``base'' state variables in a specification via the
  ``meta predicate'' @{text basevars}, which is defined here.
*}

definition stvars    :: "'a statefun \<Rightarrow> bool"
where basevars_def:  "stvars \<equiv> surj"

syntax
  "PRED"    :: "lift \<Rightarrow> 'a"                          ("PRED _")
  "_stvars" :: "lift \<Rightarrow> bool"                        ("basevars _")

translations
  "PRED P"   \<rightharpoonup>  "(P::state => _)"
  "_stvars"  \<rightleftharpoons>  "CONST stvars"

text {*
  Base variables may be assigned arbitrary (type-correct) values.
  In the following lemma, note that @{text vs} may be a tuple of variables.
  The correct identification of base variables is up to the user who must
  take care not to introduce an inconsistency. For example, @{term "basevars (x,x)"}
  would definitely be inconsistent.
*}

lemma basevars: "basevars vs \<Longrightarrow> \<exists>u. vs u = c"
proof (unfold basevars_def surj_def)
  assume "\<forall>y. \<exists>x. y = vs x"
  then obtain x where "c = vs x" by blast
  thus "\<exists>u. vs u = c" by blast
qed

lemma baseE:
  assumes H1: "basevars v" and H2:"\<And>x. v x = c \<Longrightarrow> Q"
  shows "Q"
  using H1[THEN basevars] H2 by auto

text {* A variant written for sequences rather than single states. *}
lemma first_baseE:
  assumes H1: "basevars v" and H2: "\<And>x. v (first x) = c \<Longrightarrow> Q"
  shows "Q"
  using H1[THEN basevars] H2 by (force simp: first_def)

lemma base_pair1:
  assumes h: "basevars (x,y)"
  shows "basevars x"
proof (auto simp: basevars_def)
  fix c
  from h[THEN basevars] obtain s where "(LIFT (x,y)) s = (c, arbitrary)" by auto
  thus "c \<in> range x" by auto
qed

lemma base_pair2:
  assumes h: "basevars (x,y)"
  shows "basevars y"
proof (auto simp: basevars_def)
  fix d
  from h[THEN basevars] obtain s where "(LIFT (x,y)) s = (arbitrary, d)" by auto
  thus "d \<in> range y" by auto
qed

lemma base_pair: "basevars (x,y) \<Longrightarrow> basevars x \<and> basevars y"
  by (auto elim: base_pair1 base_pair2)

text {*
  Since the @{typ unit} type has just one value, any state function of unit type
  satisfies the predicate @{text basevars}. The following theorem can sometimes
  be useful because it gives a trivial solution for @{text basevars} premises.
*}

lemma unit_base: "basevars (v::state \<Rightarrow> unit)"
  by (auto simp: basevars_def)

text {*
  A pair of the form @{text "(x,x)"} will generally not satisfy the predicate
  @{text basevars} -- except for pathological cases such as @{text "x::unit"}.
*}
lemma
  fixes x :: "state \<Rightarrow> bool"
  assumes h1: "basevars (x,x)"
  shows "False"
proof -
  from h1 have "\<exists>u. (LIFT (x,x)) u = (False,True)" by (rule basevars)
  thus False by auto
qed

lemma
  fixes x :: "state \<Rightarrow> nat"
  assumes h1: "basevars (x,x)"
  shows "False"
proof -
  from h1 have "\<exists>u. (LIFT (x,x)) u = (0,1)" by (rule basevars)
  thus False by auto
qed

text {*
  The following theorem reduces the reasoning about the existence of a
  state sequence satisfiyng an enabledness predicate to finding a suitable
  value @{text c} at the successor state for the base variables of the
  specification. This rule is intended for reasoning about standard TLA
  specifications, where @{text Enabled} is applied to actions, not arbitrary
  pre-formulas.
*}
lemma base_enabled:
  assumes h1: "basevars vs"
  and h2: "\<And>u. vs (first u) = c \<Longrightarrow> ((first s) ## u) \<Turnstile> F"
  shows "s \<Turnstile> Enabled F"
using h1 proof (rule first_baseE)
  fix t
  assume "vs (first t) = c"
  hence "((first s) ## t) \<Turnstile> F" by (rule h2)
  thus "s \<Turnstile> Enabled F" unfolding enabled_def by blast
qed

subsection "Temporal Quantifiers"

text{*
  In \cite{Lamport94}, Lamport gives a stuttering invariant definition
  of quantification over (flexible) variables. It relies on similarity
  of two sequences (as supported in our @{theory Sequence} theory), and
  equivalence of two sequences up to a variable (the bound variable).
  However, sequence equaivalence up to a variable, requires state
  equaivalence up to a variable. Our state representation above does not
  support this, hence we cannot encode Lamport's definition in our theory.
  Thus, we need to axiomatise quantification over (flexible) variables.
  Note that with a state representation supporting this, our theory should
  allow such an encoding.
*}

consts
  EEx        :: "('a statefun \<Rightarrow> temporal) \<Rightarrow> temporal"       (binder "Eex " 10)
  AAll       :: "('a statefun \<Rightarrow> temporal) \<Rightarrow> temporal"       (binder "Aall " 10)

syntax
 "_EEx"     :: "[idts, lift] \<Rightarrow> lift"                ("(3EEX _./ _)" [0,10] 10)
  "_AAll"    :: "[idts, lift] \<Rightarrow> lift"                ("(3AALL _./ _)" [0,10] 10)

translations
  "_EEx v A"  ==   "Eex v. A"
  "_AAll v A" ==   "Aall v. A"

syntax (xsymbols)
  "_EEx"     :: "[idts, lift] => lift"                ("(3\<exists>\<exists> _./ _)" [0,10] 10)
  "_AAll"    :: "[idts, lift] => lift"                ("(3\<forall>\<forall> _./ _)" [0,10] 10)

axiomatization where
     eexI: "\<turnstile> F x \<longrightarrow> (\<exists>\<exists> x. F x)"
and  eexE: "\<lbrakk>s \<Turnstile> (\<exists>\<exists> x. F x) ; basevars vs; (!! x. \<lbrakk> basevars (x,vs); s \<Turnstile> F x \<rbrakk> \<Longrightarrow> s \<Turnstile> G)\<rbrakk>
            \<Longrightarrow> (s \<Turnstile> G)"
and  all_def: "\<turnstile> (\<forall>\<forall> x. F x) = (\<not>(\<exists>\<exists> x. \<not>(F x)))"
and  eexSTUT: "STUTINV F x \<Longrightarrow> STUTINV (\<exists>\<exists> x. F x)"
and  history: "\<turnstile> (I \<and> \<box>[A]_v) = (\<exists>\<exists> h. ($h = ha) \<and> I \<and> \<box>[A \<and> h$=hb]_(h,v))"

lemmas eexI_unl = eexI[unlift_rule] --{* @{text "w \<Turnstile> F x \<Longrightarrow> w \<Turnstile> (\<exists>\<exists> x. F x)"} *}

text {*
  @{text tla_defs} can be used to unfold TLA definitions into lowest predicate level.
  This is particularly useful for reasoning about enabledness of formulas.
*}
lemmas tla_defs = unch_def before_def after_def first_def second_def suffix_def
                  tail_def nexts_def app_def angle_actrans_def actrans_def

end


(*  Title:      statecharts/SA/SA.thy

    Author:     Steffen Helke and Florian Kammüller, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

header {* Sequential Automata *}
theory SA
imports Expr
begin

definition
  SeqAuto :: "['s set,
               's,
               (('s,'e,'d)label) set,
               (('s,'e,'d)trans) set]
              => bool" where
  "SeqAuto S I L D =  (I \<in> S \<and> S \<noteq> {} \<and>  finite S \<and> finite D \<and>
                       (\<forall> (s,l,t) \<in> D. s \<in> S \<and> t \<in> S \<and> l \<in> L))"

lemma SeqAuto_EmptySet:
 "({@x .True}, (@x .True), {}, {}) \<in> {(S,I,L,D) | S I L D. SeqAuto S I L D}"
by (unfold SeqAuto_def, auto)

definition
  "seqauto =
    { (S,I,L,D) |
              (S::'s set)
              (I::'s)
              (L::(('s,'e,'d)label) set)
              (D::(('s,'e,'d)trans) set).
             SeqAuto S I L D}"

typedef ('s,'e,'d) seqauto =
    "seqauto :: ('s set * 's * (('s,'e,'d)label) set * (('s,'e,'d)trans) set) set"
  unfolding seqauto_def
  apply (rule exI)
  apply (rule SeqAuto_EmptySet)
  done

definition
 States :: "(('s,'e,'d)seqauto) => 's set" where
 "States = fst o Rep_seqauto"

definition
 InitState :: "(('s,'e,'d)seqauto) => 's" where
 "InitState = fst o snd o Rep_seqauto"

definition
 Labels :: "(('s,'e,'d)seqauto) => (('s,'e,'d)label) set" where
 "Labels = fst o snd o snd o Rep_seqauto"

definition
 Delta :: "(('s,'e,'d)seqauto) => (('s,'e,'d)trans) set" where
 "Delta = snd o snd o snd o Rep_seqauto"

definition
 SAEvents :: "(('s,'e,'d)seqauto) => 'e set" where
 "SAEvents SA = (\<Union> l \<in> Label (Delta SA). (fst (action l)) \<union> (ExprEvents (expr l)))"

lemma Rep_seqauto_tuple:
  "Rep_seqauto SA = (States SA, InitState SA, Labels SA, Delta SA)"
by (unfold States_def InitState_def Labels_def Delta_def, auto)

lemma Rep_seqauto_select:
  "(States SA,InitState SA,Labels SA,Delta SA) \<in>  seqauto"
by (rule Rep_seqauto_tuple [THEN subst], rule Rep_seqauto)

lemma SeqAuto_select:
  "SeqAuto (States SA) (InitState SA) (Labels SA) (Delta SA)"
by (cut_tac SA=SA in Rep_seqauto_select, unfold seqauto_def, auto)

lemma neq_States [simp]:
  "States SA \<noteq> {}";
apply (cut_tac Rep_seqauto_select)
apply auto
apply (unfold seqauto_def SeqAuto_def)
apply auto
done

lemma SA_States_disjunct :
 "(States A) \<inter> (States A') = {} \<Longrightarrow> A' \<noteq> A";
by auto

lemma SA_States_disjunct2 :
 "\<lbrakk> (States A) \<inter> C = {}; States B \<subseteq> C \<rbrakk> \<Longrightarrow> B \<noteq> A"
apply (rule SA_States_disjunct)
apply auto
done

lemma SA_States_disjunct3 :
 "\<lbrakk> C \<inter> States A = {}; States B \<subseteq> C \<rbrakk> \<Longrightarrow>  States A \<inter> States B = {}"
apply (cut_tac SA=B in neq_States)
apply fast
done

lemma EX_State_SA [simp]:
  "\<exists> S. S \<in> States SA"
apply (cut_tac Rep_seqauto_select)
apply (unfold seqauto_def SeqAuto_def)
apply auto
done

lemma finite_States [simp]:
  "finite (States A)";
apply (cut_tac Rep_seqauto_select)
apply (unfold seqauto_def SeqAuto_def)
apply auto
done

lemma finite_Delta [simp]:
  "finite (Delta A)"
apply (cut_tac Rep_seqauto_select)
apply (unfold seqauto_def SeqAuto_def)
apply auto
done

lemma InitState_States [simp]:
  "InitState A \<in> States A";
apply (cut_tac Rep_seqauto_select)
apply (unfold seqauto_def SeqAuto_def)
apply auto
done

lemma SeqAuto_EmptySet_States [simp]:
 "(States (Abs_seqauto ({@x. True}, (@x. True), {}, {}))) = {(@x. True)}"
apply (unfold States_def)
apply (simp)
apply (subst Abs_seqauto_inverse)
apply (unfold seqauto_def)
apply (rule SeqAuto_EmptySet)
apply auto
done

lemma SeqAuto_EmptySet_SAEvents [simp]:
 "(SAEvents (Abs_seqauto ({@x. True}, (@x. True), {}, {}))) = {}";
apply (unfold SAEvents_def Delta_def)
apply simp
apply (subst Abs_seqauto_inverse)
apply (unfold seqauto_def)
apply (rule SeqAuto_EmptySet)
apply auto
done

lemma Label_Delta_subset [simp]:
  "(Label (Delta SA)) \<subseteq> Labels SA";
apply (unfold Label_def label_def)
apply auto
apply (cut_tac SA=SA in SeqAuto_select)
apply (unfold SeqAuto_def)
apply auto
done

lemma Target_SAs_Delta_States:
  "Target (UNION (SAs HA) Delta) \<subseteq> UNION (SAs HA) States";
apply (unfold image_def Target_def target_def)
apply auto
apply (rename_tac SA Source Trigger Guard Action Update Target)
apply (cut_tac SA=SA in SeqAuto_select)
apply (unfold SeqAuto_def)
apply auto
done

lemma States_Int_not_mem:
 "(UNION F States Int States SA) = {} \<Longrightarrow> SA \<notin> F";
apply (unfold Int_def)
apply auto
apply (subgoal_tac "\<exists> S. S \<in> States SA")
prefer 2
apply (rule EX_State_SA)
apply (erule exE)
apply (rename_tac T)
apply (erule_tac x=T in allE)
apply auto
done

lemma Delta_target_States [simp]:
  "\<lbrakk> T \<in> Delta A\<rbrakk> \<Longrightarrow> target T \<in> States A"
apply (cut_tac SA=A in SeqAuto_select)
apply (unfold SeqAuto_def source_def target_def)
apply auto
done

lemma Delta_source_States [simp]:
  "\<lbrakk> T \<in> Delta A \<rbrakk> \<Longrightarrow> source T \<in> States A"
apply (cut_tac SA=A in SeqAuto_select)
apply (unfold SeqAuto_def source_def target_def)
apply auto
done

end


subsection "Big step Semantics on partial states"

theory Big_StepT_Partial
imports Partial_Evaluation Big_StepT "SepLogAdd/Sep_Algebra_Add"
    "HOL-Eisbach.Eisbach"
begin

type_synonym lvname = string
type_synonym pstate_t = "partstate * nat"
type_synonym assnp = "partstate \<Rightarrow> bool"
type_synonym assn2 = "pstate_t \<Rightarrow> bool"

subsubsection \<open>helper functions\<close>

paragraph \<open>restrict\<close>

definition restrict where "restrict S s = (%x. if x:S then Some (s x) else None)"

lemma restrictI: "\<forall>x\<in>S. s1 x = s2 x \<Longrightarrow> restrict S s1 = restrict S s2"
  unfolding restrict_def by fastforce

lemma restrictE: "restrict S s1 = restrict S s2 \<Longrightarrow> s1 = s2 on S"
  unfolding restrict_def by (meson option.inject)

lemma dom_restrict[simp]: "dom (restrict S s) = S"
  unfolding restrict_def
  using domIff by fastforce

lemma restrict_less_part: "restrict S t \<preceq> part t"
  unfolding restrict_def map_le_substate_conv[symmetric] map_le_def part_def apply auto
  by (metis option.simps(3))

paragraph \<open>Heap helper functions\<close>

fun lmaps_to_expr :: "aexp \<Rightarrow> val \<Rightarrow> assn2" where
  "lmaps_to_expr a v = (%(s,c). dom s = vars a \<and> paval a s = v \<and> c = 0)"

fun lmaps_to_expr_x :: "vname \<Rightarrow> aexp \<Rightarrow> val \<Rightarrow> assn2" where
  "lmaps_to_expr_x x a v = (%(s,c). dom s = vars a \<union> {x} \<and> paval a s = v \<and> c = 0)"

lemma subState: "x \<preceq> y \<Longrightarrow> v \<in> dom x \<Longrightarrow> x v = y v" unfolding map_le_substate_conv[symmetric] map_le_def
  by blast

lemma  fixes ps:: partstate
    and s::state
  assumes "vars a \<subseteq> dom ps" "ps \<preceq> part s"
  shows emb_update: "emb [x \<mapsto> paval a ps] s = (emb ps s) (x := aval a (emb ps s))"
    using assms
      unfolding emb_def apply auto apply (rule ext)
      apply(case_tac "v=x")
        apply(simp add: paval_aval)
      apply(simp) unfolding part_def apply(case_tac "v \<in> dom ps")
      using subState apply fastforce
      by (simp add: domIff)

lemma paval_aval2: "vars a \<subseteq> dom ps \<Longrightarrow> ps \<preceq> part s \<Longrightarrow> paval a ps = aval a s"
  apply(induct a) using subState unfolding part_def apply auto
  by fastforce

lemma  fixes ps:: partstate
    and s::state
  assumes "vars a \<subseteq> dom ps" "ps \<preceq> part s"
  shows emb_update2: "emb (ps(x \<mapsto> paval a ps)) s = (emb ps s)(x := aval a (emb ps s))"
    using assms
      unfolding emb_def apply auto apply (rule ext)
      apply(case_tac "v=x")
        apply(simp add: paval_aval)
      by (simp)

subsubsection "Big step Semantics on partial states"

inductive
  big_step_t_part :: "com \<times> partstate \<Rightarrow> nat \<Rightarrow> partstate \<Rightarrow> bool"  ("_ \<Rightarrow>\<^sub>A _ \<Down> _" 55)
where
Skip: "(SKIP,s) \<Rightarrow>\<^sub>A Suc 0 \<Down> s" |
Assign: "\<lbrakk> vars a \<union> {x} \<subseteq> dom ps; paval a ps = v ; ps' = ps(x \<mapsto> v) \<rbrakk> \<Longrightarrow> (x ::= a,ps) \<Rightarrow>\<^sub>A Suc 0 \<Down> ps'" |

Seq: "\<lbrakk> (c1,s1) \<Rightarrow>\<^sub>A x \<Down> s2;  (c2,s2) \<Rightarrow>\<^sub>A y \<Down> s3 ; z=x+y \<rbrakk> \<Longrightarrow> (c1;;c2, s1) \<Rightarrow>\<^sub>A z \<Down> s3" |

IfTrue: "\<lbrakk> vars b \<subseteq> dom ps ; dom ps' = dom ps ; pbval b ps;  (c1,ps) \<Rightarrow>\<^sub>A x \<Down> ps'; y=x+1 \<rbrakk> \<Longrightarrow> (IF b THEN c1 ELSE c2, ps) \<Rightarrow>\<^sub>A y \<Down> ps'" |
IfFalse: "\<lbrakk> vars b \<subseteq> dom ps ; dom ps' = dom ps ; \<not> pbval b ps;  (c2,ps) \<Rightarrow>\<^sub>A x \<Down> ps'; y=x+1  \<rbrakk> \<Longrightarrow> (IF b THEN c1 ELSE c2, ps) \<Rightarrow>\<^sub>A y \<Down> ps'" |
WhileFalse: "\<lbrakk> vars b \<subseteq> dom s; \<not> pbval b s \<rbrakk> \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow>\<^sub>A Suc 0 \<Down> s" |
WhileTrue: "\<lbrakk> pbval b s1; vars b \<subseteq> dom s1;  (c,s1) \<Rightarrow>\<^sub>A x \<Down> s2;  (WHILE b DO c, s2) \<Rightarrow>\<^sub>A y \<Down> s3; 1+x+y=z  \<rbrakk>
          \<Longrightarrow> (WHILE b DO c, s1) \<Rightarrow>\<^sub>A z \<Down> s3"

declare big_step_t_part.intros [intro]

inductive_cases Skip_tE3[elim!]: "(SKIP,s) \<Rightarrow>\<^sub>A x \<Down> t"
thm Skip_tE3
inductive_cases Assign_tE3[elim!]: "(x ::= a,s) \<Rightarrow>\<^sub>A p \<Down> t"
thm Assign_tE3
inductive_cases Seq_tE3[elim!]: "(c1;;c2,s1) \<Rightarrow>\<^sub>A p \<Down> s3"
thm Seq_tE3
inductive_cases If_tE3[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow>\<^sub>A x \<Down> t"
thm If_tE3
inductive_cases While_tE3[elim]: "(WHILE b DO c,s) \<Rightarrow>\<^sub>A x \<Down> t"
thm While_tE3

lemmas big_step_t_part_induct = big_step_t_part.induct[split_format(complete)]

lemma big_step_t3_post_dom_conv: "(c,ps) \<Rightarrow>\<^sub>A t \<Down> ps' \<Longrightarrow> dom ps' = dom ps"
apply(induct rule: big_step_t_part_induct) apply (auto simp: sep_disj_fun_def plus_fun_def)
  apply metis   done

lemma add_update_distrib: "ps1 x1 = Some y \<Longrightarrow> ps1 ## ps2 \<Longrightarrow> vars x2 \<subseteq> dom ps1 \<Longrightarrow> ps1(x1 \<mapsto> paval x2 ps1) + ps2  = (ps1 + ps2)(x1 \<mapsto> paval x2 ps1)"
  apply (rule ext)
  apply (auto simp: sep_disj_fun_def plus_fun_def)
  by (metis disjoint_iff_not_equal domI domain_conv)

lemma paval_extend:  "ps1 ## ps2 \<Longrightarrow> vars a \<subseteq> dom ps1 \<Longrightarrow> paval a (ps1 + ps2) = paval a ps1"
apply(induct a) apply (auto simp: sep_disj_fun_def domain_conv)
  by (metis domI map_add_comm map_add_dom_app_simps(1) option.sel plus_fun_conv)

lemma pbval_extend: "ps1 ## ps2 \<Longrightarrow> vars b \<subseteq> dom ps1 \<Longrightarrow> pbval b (ps1 + ps2) = pbval b ps1"
apply(induct b)  by (auto simp: paval_extend)

lemma Framer: "(C, ps1) \<Rightarrow>\<^sub>A m \<Down> ps1' \<Longrightarrow> ps1 ## ps2 \<Longrightarrow> (C, ps1 + ps2) \<Rightarrow>\<^sub>A m \<Down>  ps1'+ps2"
proof (induct rule: big_step_t_part_induct)
  case (Skip s)
  then show ?case by (auto simp: big_step_t_part.Skip)
next
  case (Assign a x ps v ps')
  show ?case apply(rule big_step_t_part.Assign)
    using Assign
     apply (auto simp: plus_fun_def)
    apply(rule ext)
    apply(case_tac "xa=x")
    subgoal apply (auto simp: ) subgoal using paval_extend[unfolded plus_fun_def] by auto
       unfolding sep_disj_fun_def
       by (metis disjoint_iff_not_equal domI domain_conv)
   subgoal by auto
     done
next
  case (IfTrue b ps ps' c1 x y c2)
  then show ?case apply (auto ) apply(subst big_step_t_part.IfTrue)
         apply (auto simp: pbval_extend)
      subgoal      by (auto simp: plus_fun_def)
      subgoal      by (auto simp: plus_fun_def)
      subgoal      by (auto simp: plus_fun_def)
          done
next
  case (IfFalse b ps ps' c2 x y c1)
  then show ?case apply (auto ) apply(subst big_step_t_part.IfFalse)
         apply (auto simp: pbval_extend)
      subgoal      by (auto simp: plus_fun_def)
      subgoal      by (auto simp: plus_fun_def)
      subgoal      by (auto simp: plus_fun_def)
          done
next
  case (WhileFalse b s c)
  then show ?case apply(subst big_step_t_part.WhileFalse)
      subgoal      by (auto simp: plus_fun_def)
      subgoal      by (auto simp: pbval_extend)
          by auto
next
  case (WhileTrue b s1 c x s2 y s3 z)
  from big_step_t3_post_dom_conv[OF WhileTrue(3)]  have "dom s2 = dom s1" by auto
  with WhileTrue(8) have "s2 ## ps2" unfolding sep_disj_fun_def domain_conv by auto
  with WhileTrue show ?case apply auto apply(subst big_step_t_part.WhileTrue)
      subgoal      by (auto simp: pbval_extend)
      subgoal      by (auto simp: plus_fun_def)
             apply (auto) done
next
  case (Seq c1 s1 x s2 c2 y s3 z)
  from big_step_t3_post_dom_conv[OF Seq(1)]  have "dom s2 = dom s1" by auto
  with Seq(6) have "s2 ## ps2" unfolding sep_disj_fun_def domain_conv by auto
  with Seq show ?case apply (subst big_step_t_part.Seq)
      by auto
qed

lemma Framer2: "(C, ps1) \<Rightarrow>\<^sub>A m \<Down> ps1' \<Longrightarrow> ps1 ## ps2 \<Longrightarrow> ps = ps1 + ps2 \<Longrightarrow> ps' = ps1'+ps2 \<Longrightarrow> (C, ps) \<Rightarrow>\<^sub>A m \<Down> ps' "
  using Framer by auto

(* connection to bigstep2 *)

subsubsection \<open>Relation to BigStep Semantic on full states\<close>

lemma paval_aval_part: "paval a (part s) = aval a s"
  apply(induct a) by (auto simp: part_def)
lemma pbval_bval_part: "pbval b (part s) = bval b s"
  apply(induct b) by (auto simp: paval_aval_part)

lemma part_paval_aval: "part (s(x := aval a s)) = part s(x \<mapsto> paval a (part s))"
  apply(rule ext)
  apply(case_tac "xa=x")
    unfolding part_def apply auto by (metis (full_types) domIff map_le_def map_le_substate_conv option.distinct(1) part_def paval_aval2 subsetI)

lemma full_to_part: "(C, s) \<Rightarrow> m \<Down> s' \<Longrightarrow>  (C, part s) \<Rightarrow>\<^sub>A m \<Down> part s' "
apply(induct rule: big_step_t_induct)
  using Skip apply simp
       apply (subst Assign)
          using part_paval_aval apply(simp_all add: )
    apply(rule Seq) apply auto
    apply(rule IfTrue) apply (auto simp: pbval_bval_part)
    apply(rule IfFalse) apply (auto simp: pbval_bval_part)
    apply(rule WhileFalse) apply (auto simp: pbval_bval_part)
  apply(rule WhileTrue) apply (auto simp: pbval_bval_part)
  done

lemma part_to_full': "(C, ps) \<Rightarrow>\<^sub>A m \<Down> ps' \<Longrightarrow> (C, emb ps s) \<Rightarrow> m \<Down> emb ps' s"
proof (induct rule: big_step_t_part_induct)
  case (Assign a x ps v ps')
  have z: "paval a ps = aval a (emb ps s)"
    apply(rule paval_aval_vars) using Assign(1) by auto
  have g :"emb ps' s = (emb ps s)(x:=aval a (emb ps s) )"
    apply(simp only: Assign z[symmetric])
      unfolding emb_def by auto
  show ?case apply(simp only: g) by(rule big_step_t.Assign)
qed (auto simp: pbval_bval_vars[symmetric])

lemma part_to_full: "(C, part s) \<Rightarrow>\<^sub>A m \<Down> part s' \<Longrightarrow> (C, s) \<Rightarrow> m \<Down> s'"
proof -
  assume "(C, part s) \<Rightarrow>\<^sub>A m \<Down> part s'"
  then have "(C, emb (part s) s) \<Rightarrow> m \<Down> emb (part s') s" by (rule part_to_full')
  then show "(C, s) \<Rightarrow> m \<Down> s'" by auto
qed

lemma part_full_equiv: "(C, s) \<Rightarrow> m \<Down> s' \<longleftrightarrow> (C, part s) \<Rightarrow>\<^sub>A m \<Down> part s'"
using part_to_full full_to_part by metis

subsubsection \<open>more properties\<close>

lemma big_step_t3_gt0: "(C, ps) \<Rightarrow>\<^sub>A x \<Down> ps' \<Longrightarrow> x > 0"
apply(induct rule: big_step_t_part_induct) apply auto done

lemma big_step_t3_same: "(C, ps) \<Rightarrow>\<^sub>A m \<Down> ps' ==>  ps = ps' on UNIV - lvars C"
apply(induct rule: big_step_t_part_induct) by (auto simp: sep_disj_fun_def plus_fun_def)

lemma avalDirekt3_correct: " (x ::= N v, ps) \<Rightarrow>\<^sub>A m \<Down> ps' \<Longrightarrow> paval' a ps = Some v \<Longrightarrow>  (x ::= a, ps) \<Rightarrow>\<^sub>A m \<Down> ps'"
apply(auto) apply(subst Assign) by (auto simp: paval_paval' paval'dom)

subsection \<open>Partial State\<close>

(* partialstate and nat is a separation algebra ! *)
lemma
  fixes h :: "(vname \<Rightarrow> val option) * nat"
  shows "(P ** Q ** H) h = (Q ** H ** P) h"
  by (simp add: sep_conj_ac)

lemma separate_othogonal_commuted': assumes
    "\<And>ps n. P (ps,n) \<Longrightarrow> ps = 0"
    "\<And>ps n. Q (ps,n) \<Longrightarrow> n = 0"
  shows "(P ** Q) s \<longleftrightarrow> P (0,snd s) \<and> Q (fst s,0)"
  using assms unfolding sep_conj_def by force

lemma separate_othogonal_commuted: assumes
    "\<And>ps n. P (ps,n) \<Longrightarrow> ps = 0"
    "\<And>ps n. Q (ps,n) \<Longrightarrow> n = 0"
  shows "(P ** Q) (ps,n) \<longleftrightarrow> P (0,n) \<and> Q (ps,0)"
  using assms unfolding sep_conj_def by force

lemma separate_othogonal: assumes
    "\<And>ps n. P (ps,n) \<Longrightarrow> n = 0"
    "\<And>ps n. Q (ps,n) \<Longrightarrow> ps = 0"
  shows "(P ** Q) (ps,n) \<longleftrightarrow> P (ps,0) \<and> Q (0,n)"
  using assms unfolding sep_conj_def by force

lemma assumes "  ((\<lambda>(s, n). P (s, n) \<and> vars b \<subseteq> dom s) \<and>* (\<lambda>(s, c). s = 0 \<and> c = Suc 0)) (ps, n)"
shows "\<exists> n'. P (ps, n') \<and> vars b \<subseteq> dom ps \<and> n = Suc n'"
proof -
  from assms obtain x y where " x ## y" and "(ps, n) = x + y"
      and 2: "(case x of (s, n) \<Rightarrow> P (s, n) \<and> vars b \<subseteq>  dom s)"
      and "(case y of (s, c) \<Rightarrow> s = 0 \<and> c = Suc 0)"
    unfolding sep_conj_def by blast
  then have "y = (0, Suc 0)" and f: "fst x = ps" and n: "n = snd x + Suc 0" by auto

  with 2 have "P (ps, snd x) \<and> vars b \<subseteq> dom ps \<and> n = Suc (snd x)"
    by auto
  then show ?thesis by simp
qed

subsection \<open>Dollar and Pointsto\<close>

definition dollar :: "nat \<Rightarrow> assn2" ("$") where
  "dollar q = (%(s,c). s = 0 \<and> c=q)"

lemma sep_reorder_dollar_aux:
    "NO_MATCH ($X) A \<Longrightarrow> ($B ** A) = (A ** $B)"
    "($X ** $Y) = $(X+Y)"
   apply (auto simp: sep_simplify)
    unfolding dollar_def sep_conj_def sep_disj_prod_def sep_disj_nat_def by auto

lemmas sep_reorder_dollar = sep_conj_assoc sep_reorder_dollar_aux

lemma stardiff: assumes "(P \<and>* $m) (ps, n)"
  shows  P: "P (ps, n - m)" and "m\<le>n" using assms unfolding sep_conj_def dollar_def by auto

definition cnv where "cnv x y == x = y"

lemma cnv_I: "cnv x x"
  unfolding cnv_def by simp

lemma Frame'_conv: "Frame P Q F = Frame' (P ** \<box>) \<box> (Q ** \<box>) F"
  unfolding Frame_def Frame'_def apply auto done

lemma Frame'I: "Frame' (P ** \<box>) \<box> (Q ** \<box>) F \<Longrightarrow> cnv F F' \<Longrightarrow> Frame P Q F'"
  unfolding Frame_def Frame'_def cnv_def apply auto done

lemma FrameD: assumes "Frame P Q F" " P s "
  shows "(F ** Q) s"
  using assms unfolding Frame_def by (auto simp: sep_conj_commute)

lemma Frame'_match: "Frame' (P ** P') \<box> Q F \<Longrightarrow> Frame' (x \<hookrightarrow> v ** P) P' (x \<hookrightarrow> v ** Q) F"
  unfolding Frame_def Frame'_def apply (auto simp: sep_conj_ac)
  by (metis (no_types, hide_lams) prod.collapse sep.mult_assoc sep_conj_impl1)

lemma R: assumes "\<And>s. (A imp B) s" shows "((A ** $n) imp (B ** $n)) s"
proof (safe)
  assume "(A \<and>* $ n) s"
  then obtain h1 h2 where A: "A h1"  and n: "$n h2" and disj: "h1 ## h2" "s = h1+h2" unfolding sep_conj_def by blast
  from assms A have B: "B h1" by auto
  show "(B ** $n) s" using B n disj unfolding sep_conj_def by blast
qed

lemma Frame'_matchdollar:  assumes "Frame' (P ** P' ** $(n-m)) \<box> Q F" and nm: "n\<ge>m"
  shows "Frame' ($n ** P) P' ($m ** Q) F"
 using assms(1) unfolding Frame_def Frame'_def apply (auto simp: sep_conj_ac)
proof (goal_cases)
  case (1 a b)
  have g: "((P \<and>* P' \<and>* $ n) imp (F \<and>* Q \<and>* $ m)) (a, b)
        \<longleftrightarrow> (((P \<and>* P' \<and>* $(n-m)) ** $m) imp ((F \<and>* Q) \<and>* $ m)) (a, b)"
    by(simp add: nm sep_reorder_dollar)
  have "((P \<and>* P' \<and>* $ n) imp (F \<and>* Q \<and>* $ m)) (a, b)"
    apply(subst g)
      apply(rule R) using 1(1) by auto
  then have "(P \<and>* P' \<and>* $ n) (a, b) \<longrightarrow> (F \<and>* Q \<and>* $ m) (a, b)"
    by blast
  then show ?case using 1(2) by auto
qed

lemma Frame'_nomatch: " Frame' P (p ** P') (x \<hookrightarrow> v ** Q) F\<Longrightarrow> Frame' (p ** P) P' (x \<hookrightarrow> v ** Q) F"
  unfolding  Frame'_def by (auto simp: sep_conj_ac)

lemma Frame'_nomatchempty: " Frame' P P' (x \<hookrightarrow> v ** Q) F\<Longrightarrow> Frame' (\<box> ** P) P' (x \<hookrightarrow> v ** Q) F"
  unfolding  Frame'_def by (auto simp: sep_conj_ac)

(* this will only be reached after a Frame'_match move, where P' is \<box> *)
lemma Frame'_end: " Frame' P \<box> \<box> P"
  unfolding  Frame'_def by (auto simp: sep_conj_ac)

schematic_goal "Frame (x \<hookrightarrow> v1 \<and>* y \<hookrightarrow> v2)  (x \<hookrightarrow> ?v) ?F"
  apply(rule Frame'I) apply(simp only: sep_conj_assoc)
  apply(rule Frame'_match)
  apply(rule Frame'_end) apply(simp only: sep_conj_ac sep_conj_empty' sep_conj_empty) apply(rule cnv_I) done

schematic_goal "Frame (x \<hookrightarrow> v1 \<and>* y \<hookrightarrow> v2)  (y \<hookrightarrow> ?v) ?F"
  apply(rule Frame'I) apply(simp only: sep_conj_assoc)
   apply(rule Frame'_end Frame'_match Frame'_nomatchempty Frame'_nomatch; (simp only: sep_conj_assoc)?)+
    apply(simp only: sep_conj_ac sep_conj_empty' sep_conj_empty) apply(rule cnv_I)
   done

method frame_inference_init = (rule Frame'I, (simp only: sep_conj_assoc)?)

method frame_inference_solve = (rule Frame'_matchdollar Frame'_end Frame'_match Frame'_nomatchempty Frame'_nomatch; (simp only: sep_conj_assoc)?)+

method frame_inference_cleanup = ( (simp only: sep_conj_ac sep_conj_empty' sep_conj_empty)?; rule cnv_I)

method frame_inference = (frame_inference_init, (frame_inference_solve; fail), (frame_inference_cleanup; fail))
method frame_inference_debug = (frame_inference_init, frame_inference_solve)

subsubsection \<open>tests\<close>

schematic_goal "Frame (x \<hookrightarrow> v1 \<and>* y \<hookrightarrow> v2)  (y \<hookrightarrow> ?v) ?F"
  by frame_inference

schematic_goal "Frame (x \<hookrightarrow> v1 ** P ** \<box> ** y \<hookrightarrow> v2 \<and>* z \<hookrightarrow> v2 ** Q)  (z \<hookrightarrow> ?v ** y \<hookrightarrow> ?v2) ?F"
  by frame_inference

(* with dollar *)

schematic_goal " 1 \<le> v \<Longrightarrow> Frame ($ (2 * v) \<and>* ''x'' \<hookrightarrow> int v) ($ 1 \<and>* ''x'' \<hookrightarrow> ?d) ?F"
  apply(rule Frame'I) apply(simp only: sep_conj_assoc)
   apply(rule  Frame'_matchdollar Frame'_end Frame'_match Frame'_nomatchempty Frame'_nomatch; (simp only: sep_conj_assoc)?)+
  apply (simp only: sep_conj_ac sep_conj_empty' sep_conj_empty)?
  apply (rule cnv_I) done

schematic_goal " 0 < v \<Longrightarrow> Frame ($ (2 * v) \<and>* ''x'' \<hookrightarrow> int v) ($ 1 \<and>* ''x'' \<hookrightarrow> ?d) ?F"
    apply frame_inference done

subsection \<open>Expression evaluation\<close>

definition symeval where "symeval P e v \<equiv> (\<forall>s n. P (s,n) \<longrightarrow> paval' e s = Some v)"
definition symevalb where "symevalb P e v \<equiv> (\<forall>s n. P (s,n) \<longrightarrow> pbval' e s = Some v)"

lemma symeval_c: "symeval P (N v) v"
  unfolding symeval_def apply auto done

lemma symeval_v: assumes "Frame P (x \<hookrightarrow> v) F"
  shows "symeval P (V x) v"
  unfolding symeval_def apply auto
  apply (drule FrameD[OF assms])  unfolding sep_conj_def pointsto_def
  apply (auto simp: plus_fun_conv) done

lemma symeval_plus: assumes "symeval P e1 v1" "symeval P e2 v2"
  shows "symeval P (Plus e1 e2) (v1+v2)"
  using assms unfolding symeval_def by auto

lemma symevalb_c: "symevalb P (Bc v) v"
  unfolding symevalb_def apply auto done

lemma symevalb_and: assumes "symevalb P e1 v1" "symevalb P e2 v2"
  shows "symevalb P (And e1 e2) (v1 \<and> v2)"
  using assms unfolding symevalb_def  by auto

lemma symevalb_not:  assumes "symevalb P e v"
  shows "symevalb P (Not e) (\<not> v)"
  using assms unfolding symevalb_def  by auto

lemma symevalb_less: assumes "symeval P e1 v1" "symeval P e2 v2"
  shows "symevalb P (Less e1 e2) (v1 < v2)"
  using assms unfolding symevalb_def symeval_def by auto

lemmas symeval = symeval_c symeval_v symeval_plus symevalb_c symevalb_and symevalb_not symevalb_less

schematic_goal "symevalb ( (x \<hookrightarrow> v1) ** (y \<hookrightarrow> v2) ) (Less (Plus (V x) (V y)) (N 5)) ?g"
  apply(rule symeval | frame_inference)+ done

end


theory "Identifiers"
imports Complex_Main
begin
subsection \<open>Identifier Namespace Configuration\<close>

text \<open>Different configurations are possible for the namespace of identifiers. Finite support is the only important aspect of it.\<close>

(* Identifiers, easiest finite case *)
type_synonym ident = char

(* Identifiers, bigger finite case with longer identifiers *)
(*
definition max_str:"MAX_STR = 1"
typedef ident = "{s::string. size s \<le> MAX_STR}"
  morphisms Rep_ident Abs_ident
  apply(auto)
  apply(rule exI[where x=Nil])
  by(auto simp add: max_str)

setup_lifting  ident.type_definition_ident

lift_definition ilength::"ident \<Rightarrow> nat" is size done

lemma ident_bounded_length: "ilength x \<le> MAX_STR"
  apply (transfer fixing: s)
  apply (auto)
  done

lemma finite_identifiers [simp]: "finite {x:ident . True}"
using ident_bounded_length

lifting_update ident.lifting
lifting_forget ident.lifting
*)

text \<open>The identifier used for the replacement marker in uniform substitutions\<close>
abbreviation dotid:: "ident"
where "dotid \<equiv> CHR ''.''"

end


(******************************************************************************)
(* Submission: "The Interchange Law: A Principle of Concurrent Programming"   *)
(* Authors: Tony Hoare, Bernard Möller, Georg Struth, and Frank Zeyda         *)
(* File: Partiality.thy                                                       *)
(******************************************************************************)
(* LAST REVIEWED: 11 July 2017 *)

section {* Partiality *}

theory Partiality
imports Preliminaries ICL
begin

subsection {* Type Definition *}

text \<open>We define a datatype \<open>'a partial\<close> that adds a distinct \<open>\<bottom>\<close> and \<open>\<top>\<close> to a type \<open>'a\<close>.\<close>

datatype 'a partial =
  Bot | Value "'a" | Top

text \<open>The notation \<open>\<bottom>\<close> is introduced for the constructor @{const Bot}.\<close>

adhoc_overloading global_bot Bot

text \<open>The notation \<open>\<top>\<close> is introduced for the constructor @{const Top}.\<close>

adhoc_overloading global_top Top

subsection {* Proof Support *}

text \<open>Attribute used to collect definitional laws for operators.\<close>

named_theorems partial_ops "definitional laws for operators on partial values"

text \<open>Tactic that facilitates proofs about @{type partial} values.\<close>

lemma split_partial_all:
"(\<forall>x::'a partial. P x) = (P Bot \<and> P Top \<and> (\<forall>x::'a. P (Value x)))"
apply (safe; simp?)
apply (case_tac x)
apply (simp_all)
done

lemma split_partial_ex:
"(\<exists>x::'a partial. P x) = (P Bot \<or> P Top \<or> (\<exists>x::'a. P (Value x)))"
apply (safe; simp?)
apply (case_tac x)
apply (simp_all) [3]
apply (auto)
done

lemmas split_partial =
  split_partial_all
  split_partial_ex

method partial_tac = (
  (atomize (full))?,
  (simp add: split_partial partial_ops),
  (clarsimp; simp?)?)

subsection {* Monadic Constructors *}

text \<open>Note that we have to ensure strictness in both \<open>\<bottom>\<close> and \<open>\<top>\<close>.\<close>

primrec partial_bind ::
  "'a partial \<Rightarrow> ('a \<Rightarrow> 'b partial) \<Rightarrow> 'b partial" where
"partial_bind Bot f = Bot" |
"partial_bind (Value x) f = f x" |
"partial_bind Top f = Top"

adhoc_overloading bind partial_bind

definition partial_return :: "'a  \<Rightarrow> 'a partial" where
[simp]: "partial_return x = Value x"

adhoc_overloading return partial_return

subsection {* Generic Lifting *}

text \<open>We use the constant below for ad hoc overloading to avoid ambiguities.\<close>

consts lift_partial :: "'a \<Rightarrow> 'b" ("_\<up>\<^sub>p" [1000] 1000)

fun ulift_partial :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a partial \<Rightarrow> 'b partial)" where
"ulift_partial f Bot = Bot" |
"ulift_partial f (Value x) = Value (f x)" |
"ulift_partial f Top = Top"

fun blift_partial ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a partial \<Rightarrow> 'b partial \<Rightarrow> 'c partial)" where
"blift_partial f Bot Bot = Bot" |
"blift_partial f Bot (Value y) = Bot" |
"blift_partial f Bot Top = Bot" | -- \<open>@{const Bot} dominates.\<close>
"blift_partial f (Value x) Bot = Bot" |
"blift_partial f (Value x) (Value y) = Value (f x y)" |
"blift_partial f (Value x) Top = Top" |
"blift_partial f Top Bot = Bot" | -- \<open>@{const Bot} dominates.\<close>
"blift_partial f Top (Value y) = Top" |
"blift_partial f Top Top = Top"

adhoc_overloading lift_partial ulift_partial
adhoc_overloading lift_partial blift_partial

subsection {* Lifted Operators *}

text \<open>What about relational operators? How do we lift those? [TODO]\<close>

paragraph {* Addition and Subtraction *}

definition plus_partial :: "'a::plus partial binop" (infixl "+\<^sub>p" 70) where
"(op +\<^sub>p) = (op +)\<up>\<^sub>p"

definition minus_partial :: "'a::minus partial binop" (infixl "-\<^sub>p" 70) where
"(op -\<^sub>p) = (op -)\<up>\<^sub>p"

paragraph {* Multiplication and Division *}

definition times_partial :: "'a::times partial binop" (infixl "*\<^sub>p" 70) where
"(op *\<^sub>p) = (op *)\<up>\<^sub>p"

definition divide_partial :: "'a::{divide, zero} partial binop" (infixl "'/\<^sub>p" 70) where
"x /\<^sub>p y = do {x' \<leftarrow> x; y' \<leftarrow> y; if y' \<noteq> 0 then return (x' div y') else \<bottom>}"

paragraph {* Union and Disjoint Union *}

definition union_partial :: "'a set partial binop" (infixl "\<union>\<^sub>p" 70) where
"(op \<union>\<^sub>p) = (op \<union>)\<up>\<^sub>p"

definition disjoint_union :: "'a set partial binop" (infixl "\<oplus>\<^sub>p" 70) where
"x \<oplus>\<^sub>p y = do {x' \<leftarrow> x; y' \<leftarrow> y; if x' \<inter> y' = {} then return (x' \<union> y') else \<bottom>}"

paragraph {* Proof Support *}

declare plus_partial_def [partial_ops]
declare minus_partial_def [partial_ops]
declare times_partial_def [partial_ops]
declare divide_partial_def [partial_ops]
declare union_partial_def [partial_ops]
declare disjoint_union_def [partial_ops]

subsection {* Ordering Relation *}

primrec partial_ord :: "'a partial \<Rightarrow> nat" where
"partial_ord Bot = 0" |
"partial_ord (Value x) = 1" |
"partial_ord Top = 2"

instantiation partial :: (ord) ord
begin
fun less_eq_partial :: "'a partial \<Rightarrow> 'a partial \<Rightarrow> bool" where
"(Value x) \<le> (Value y) \<longleftrightarrow> x \<le> y" |
"a \<le> b \<longleftrightarrow> (partial_ord a) \<le> (partial_ord b)"

fun less_partial :: "'a partial \<Rightarrow> 'a partial \<Rightarrow> bool" where
"(Value x) < (Value y) \<longleftrightarrow> x < y" |
"a < b \<longleftrightarrow> (partial_ord a) < (partial_ord b)"
instance ..
end

subsection {* Class Instantiations *}

subsubsection {* Preorder *}

instance partial :: (preorder) preorder
apply (intro_classes)
-- {* Subgoal 1 *}
apply (partial_tac)
apply (rule less_le_not_le)
-- {* Subgoal 2 *}
apply (partial_tac)
-- {* Subgoal 3 *}
apply (partial_tac)
apply (erule order_trans)
apply (assumption)
done

subsubsection {* Partial Order *}

instance partial :: (order) order
apply (intro_classes)
apply (partial_tac)
done

subsubsection {* Linear Order *}

instance partial :: (linorder) linorder
apply (intro_classes)
apply (partial_tac)
done

subsubsection {* Lattice *}

instantiation partial :: (type) bot
begin
definition bot_partial :: "'a partial" where
[partial_ops]: "bot_partial = Bot"
instance ..
end

instantiation partial :: (type) top
begin
definition top_partial :: "'a partial" where
[partial_ops]: "top_partial = Top"
instance ..
end

instantiation partial :: (lattice) lattice
begin
fun inf_partial :: "'a partial \<Rightarrow> 'a partial \<Rightarrow> 'a partial" where
"Bot \<sqinter> Bot = Bot" |
"Bot \<sqinter> (Value y) = Bot" |
"Bot \<sqinter> Top = Bot" |
"(Value x) \<sqinter> Bot = Bot" |
"(Value x) \<sqinter> (Value y) = Value (x \<sqinter> y)" |
"(Value x) \<sqinter> Top = (Value x)" |
"Top \<sqinter> Bot = Bot" |
"Top \<sqinter> Value y = Value y" |
"Top \<sqinter> Top = Top"

fun sup_partial :: "'a partial \<Rightarrow> 'a partial \<Rightarrow> 'a partial" where
"Bot \<squnion> Bot = Bot" |
"Bot \<squnion> (Value y) = (Value y)" |
"Bot \<squnion> Top = Top" |
"(Value x) \<squnion> Bot = (Value x)" |
"(Value x) \<squnion> (Value y) = Value (x \<squnion> y)" |
"(Value x) \<squnion> Top = Top" |
"Top \<squnion> Bot = Top" |
"Top \<squnion> (Value y) = Top" |
"Top \<squnion> Top = Top"
instance
apply (intro_classes)
-- {* Subgoal 1 *}
apply (partial_tac)
-- {* Subgoal 2 *}
apply (partial_tac)
-- {* Subgoal 3 *}
apply (partial_tac)
-- {* Subgoal 4 *}
apply (partial_tac)
-- {* Subgoal 5 *}
apply (partial_tac)
-- {* Subgoal 6 *}
apply (partial_tac)
done
end

text \<open>Validation of the definition of meet and join above.\<close>

lemma partial_ord_inf_

lemma partial_ord_sup_lemma [simp]:
"\<forall>a b. partial_ord (a \<squnion> b) = max (partial_ord a) (partial_ord b)"
apply (partial_tac)
done

subsubsection {* Complete Lattice *}

instantiation partial :: (complete_lattice) complete_lattice
begin
definition Inf_partial :: "'a partial set \<Rightarrow> 'a partial" where
[partial_ops]:
"Inf_partial xs =
  (if Bot \<in> xs then Bot else
    let values = {x. Value x \<in> xs} in
      if values = {} then Top else Value (Inf values))"

definition Sup_partial :: "'a partial set \<Rightarrow> 'a partial" where
[partial_ops]:
"Sup_partial xs =
  (if Top \<in> xs then Top else
    let values = {x. Value x \<in> xs} in
      if values = {} then Bot else Value (Sup values))"
instance
apply (intro_classes)
-- {* Subgoal 1 *}
apply (partial_tac)
apply (simp add: Inf_lower)
-- {* Subgoal 2 *}
apply (partial_tac)
apply (metis Inf_greatest mem_Collect_eq)
-- {* Subgoal 3 *}
apply (partial_tac)
apply (simp add: Sup_upper)
-- {* Subgoal 4 *}
apply (partial_tac)
apply (metis Sup_least mem_Collect_eq)
-- {* Subgoal 5 *}
apply (partial_tac)
-- {* Subgoal 6 *}
apply (partial_tac)
done
end

subsection {* ICL Lifting Lemmas *}

lemma iclaw_eq_lift_partial [simp]:
"iclaw (op =) seq_op par_op \<Longrightarrow>
 iclaw (op =) seq_op\<up>\<^sub>p par_op\<up>\<^sub>p"
apply (unfold iclaw_def iclaw_axioms_def)
apply (partial_tac)
done

lemma preorder_less_eq_lift_partial [simp]:
"preorder (op \<le>::'a::ord relop) \<Longrightarrow>
 preorder (op \<le>::'a::ord partial relop)"
apply (unfold_locales)
apply (partial_tac)
apply (meson preorder.refl)
apply (partial_tac)
apply (meson preorder.trans)
done

lemma iclaw_less_eq_lift_partial [simp]:
"iclaw (op \<le>) seq_op par_op \<Longrightarrow>
 iclaw (op \<le>) seq_op\<up>\<^sub>p par_op\<up>\<^sub>p"
apply (unfold iclaw_def iclaw_axioms_def)
apply (partial_tac)
done
end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

section "Induction"

theory Induction
  imports Expectations Transformers
begin

text_raw \<open>\label{s:induction}\<close>

subsection \<open>The Lattice of Expectations\<close>

text_raw \<open>\label{s:exp_induct}\<close>

text \<open>Defining recursive (or iterative) programs requires us to reason about
fixed points on the semantic objects, in this case expectations.  The
complication here, compared to the standard Knaster-Tarski theorem (for example,
as shown in @{theory HOL.Inductive}), is that we do not have a complete lattice.

Finding a lower bound is easy (it's @{term "\<lambda>_. 0"}), but as we do not insist
on any global bound on expectations (and work directly in HOL's real type, rather
than extending it with a point at infinity), there is no top element.  We solve
the problem by defining the least (greatest) fixed point, restricted to an
internally-bounded set, allowing us to substitute this bound for the top element.
This works as long as the set contains at least one fixed point, which appears
as an extra assumption in all the theorems.

This also works semantically, thanks to the definition of healthiness.  Given a
healthy transformer parameterised by some sound expectation:
@{term "t::('s \<Rightarrow> real) \<Rightarrow> ('s \<Rightarrow> real) \<Rightarrow> 's \<Rightarrow> real"}.  Imagine that we wish to find
the least fixed point of @{term "t P"}.  In practice, @{term t} is generally
doubly healthy, that is @{term "\<forall>P. sound P \<longrightarrow> healthy (t P)"} and
@{term "\<forall>Q. sound Q \<longrightarrow> healthy (\<lambda>P. t P Q)"}.  Thus by feasibility, @{term "t P Q"}
must be bounded by @{term "bound_of P"}.  Thus, as by definition @{term "x \<le> t P x"}
for any fixed point, all must lie in the
set of sound expectations bounded above by @{term "\<lambda>_. bound_of P"}.\<close>

definition Inf_exp :: "'s expect set \<Rightarrow> 's expect"
where "Inf_exp S = (\<lambda>s. Inf {f s |f. f \<in> S})"

lemma Inf_exp_lower:
  "\<lbrakk> P \<in> S; \<forall>P\<in>S. nneg P \<rbrakk> \<Longrightarrow> Inf_exp S \<le> P"
  unfolding Inf_exp_def
  by(intro le_funI cInf_lower bdd_belowI[where m=0], auto)

lemma Inf_exp_greatest:
  "\<lbrakk> S \<noteq> {}; \<forall>P\<in>S. Q \<le> P \<rbrakk> \<Longrightarrow> Q \<le> Inf_exp S"
  unfolding Inf_exp_def by(auto intro!:le_funI[OF cInf_greatest])

definition Sup_exp :: "'s expect set \<Rightarrow> 's expect"
where "Sup_exp S = (if S = {} then \<lambda>s. 0 else (\<lambda>s. Sup {f s |f. f \<in> S}))"

lemma Sup_exp_upper:
  "\<lbrakk> P \<in> S; \<forall>P\<in>S. bounded_by b P \<rbrakk> \<Longrightarrow> P \<le> Sup_exp S"
  unfolding Sup_exp_def
  by(cases "S={}", simp_all, intro le_funI cSup_upper bdd_aboveI[where M=b], auto)

lemma Sup_exp_least:
  "\<lbrakk> \<forall>P\<in>S. P \<le> Q; nneg Q \<rbrakk> \<Longrightarrow> Sup_exp S \<le> Q"
  unfolding Sup_exp_def
  by(cases "S={}", auto intro!:le_funI[OF cSup_least])

lemma Sup_exp_sound:
  assumes sS: "\<And>P. P\<in>S \<Longrightarrow> sound P"
      and bS: "\<And>P. P\<in>S \<Longrightarrow> bounded_by b P"
  shows "sound (Sup_exp S)"
proof(cases "S={}", simp add:Sup_exp_def, blast,
      intro soundI2 bounded_byI2 nnegI2)
  assume neS: "S \<noteq> {}"
  then obtain P where Pin: "P \<in> S" by(auto)
  with sS bS have nP: "nneg P" "bounded_by b P" by(auto)
  hence nb: "0 \<le> b" by(auto)

  from bS nb show "Sup_exp S \<tturnstile> \<lambda>s. b"
    by(auto intro:Sup_exp_least)

  from nP have "\<lambda>s. 0 \<tturnstile> P" by(auto)
  also from Pin bS have "P \<tturnstile> Sup_exp S"
    by(auto intro:Sup_exp_upper)
  finally show "\<lambda>s. 0 \<tturnstile> Sup_exp S" .
qed

definition lfp_exp :: "'s trans \<Rightarrow> 's expect"
where "lfp_exp t = Inf_exp {P. sound P \<and> t P \<le> P}"

lemma lfp_exp_lowerbound:
  "\<lbrakk> t P \<le> P; sound P \<rbrakk> \<Longrightarrow> lfp_exp t \<le> P"
  unfolding lfp_exp_def by(auto intro:Inf_exp_lower)

lemma lfp_exp_greatest:
  "\<lbrakk> \<And>P. \<lbrakk> t P \<le> P; sound P \<rbrakk> \<Longrightarrow> Q \<le> P; sound Q; t R \<tturnstile> R; sound R \<rbrakk> \<Longrightarrow> Q \<le> lfp_exp t"
  unfolding lfp_exp_def by(auto intro:Inf_exp_greatest)

lemma feasible_lfp_exp_sound:
  "feasible t \<Longrightarrow> sound (lfp_exp t)"
  by(intro soundI2 bounded_byI2 nnegI2, auto intro!:lfp_exp_lowerbound lfp_exp_greatest)

lemma lfp_exp_sound:
  assumes fR: "t R \<tturnstile> R" and sR: "sound R"
  shows "sound (lfp_exp t)"
proof(intro soundI2)
  from fR sR have "lfp_exp t \<tturnstile> R"
    by(auto intro:lfp_exp_lowerbound)
  also from sR have "R \<tturnstile> \<lambda>s. bound_of R" by(auto)
  finally show "bounded_by (bound_of R) (lfp_exp t)" by(auto)
  from fR sR show "nneg (lfp_exp t)" by(auto intro:lfp_exp_greatest)
qed

lemma lfp_exp_bound:
  "(\<And>P. unitary P \<Longrightarrow> unitary (t P)) \<Longrightarrow> bounded_by 1 (lfp_exp t)"
  by(auto intro!:lfp_exp_lowerbound)

lemma lfp_exp_unitary:
  "(\<And>P. unitary P \<Longrightarrow> unitary (t P)) \<Longrightarrow> unitary (lfp_exp t)"
proof(intro unitaryI[OF lfp_exp_sound lfp_exp_bound], simp_all)
  assume IH: "\<And>P. unitary P \<Longrightarrow> unitary (t P)"
  have "unitary (\<lambda>s. 1)" by(auto)
  with IH have "unitary (t (\<lambda>s. 1))" by(auto)
  thus "t (\<lambda>s. 1) \<tturnstile> \<lambda>s. 1" by(auto)
  show "sound (\<lambda>s. 1)" by(auto)
qed

lemma lfp_exp_lemma2:
  fixes t::"'s trans"
  assumes st: "\<And>P. sound P \<Longrightarrow> sound (t P)"
      and mt: "mono_trans t"
      and fR: "t R \<tturnstile> R" and sR: "sound R"
  shows "t (lfp_exp t) \<le> lfp_exp t"
proof(rule lfp_exp_greatest[of t, OF _ _ fR sR])
  from fR sR show "sound (t (lfp_exp t))" by(auto intro:lfp_exp_sound st)

  fix P::"'s expect"
  assume fP: "t P \<tturnstile> P" and sP: "sound P"
  hence "lfp_exp t \<tturnstile> P" by(rule lfp_exp_lowerbound)
  with fP sP have "t (lfp_exp t) \<tturnstile> t P" by(auto intro:mono_transD[OF mt] lfp_exp_sound)
  also note fP
  finally show "t (lfp_exp t) \<tturnstile> P" .
qed

lemma lfp_exp_lemma3:
  assumes st: "\<And>P. sound P \<Longrightarrow> sound (t P)"
      and mt: "mono_trans t"
      and fR: "t R \<tturnstile> R" and sR: "sound R"
  shows "lfp_exp t \<le> t (lfp_exp t)"
  by(iprover intro:lfp_exp_lowerbound lfp_exp_sound lfp_exp_lemma2 assms
                   mono_transD[OF mt])

lemma lfp_exp_unfold:
  assumes nt: "\<And>P. sound P \<Longrightarrow> sound (t P)"
      and mt: "mono_trans t"
      and fR: "t R \<tturnstile> R" and sR: "sound R"
  shows "lfp_exp t = t (lfp_exp t)"
  by(iprover intro:antisym lfp_exp_lemma2 lfp_exp_lemma3 assms)

definition gfp_exp :: "'s trans \<Rightarrow> 's expect"
where "gfp_exp t = Sup_exp {P. unitary P \<and> P \<le> t P}"

lemma gfp_exp_upperbound:
  "\<lbrakk> P \<le> t P; unitary P \<rbrakk> \<Longrightarrow> P \<le> gfp_exp t"
  by(auto simp:gfp_exp_def intro:Sup_exp_upper)

lemma gfp_exp_least:
  "\<lbrakk> \<And>P. \<lbrakk> P \<le> t P; unitary P \<rbrakk> \<Longrightarrow> P \<le> Q; unitary Q \<rbrakk> \<Longrightarrow> gfp_exp t \<le> Q"
  unfolding gfp_exp_def by(auto intro:Sup_exp_least)

lemma gfp_exp_bound:
  "(\<And>P. unitary P \<Longrightarrow> unitary (t P)) \<Longrightarrow> bounded_by 1 (gfp_exp t)"
  unfolding gfp_exp_def
  by(rule bounded_byI2[OF Sup_exp_least], auto)

lemma gfp_exp_nneg[iff]:
  "nneg (gfp_exp t)"
proof(intro nnegI2, simp add:gfp_exp_def, cases)
  assume empty: "{P. unitary P \<and> P \<tturnstile> t P} = {}"
  show "\<lambda>s. 0 \<tturnstile> Sup_exp {P. unitary P \<and> P \<tturnstile> t P}"
    by(simp only:empty Sup_exp_def, auto)
next
  assume "{P. unitary P \<and> P \<tturnstile> t P} \<noteq> {}"
  then obtain Q where Qin: "Q \<in> {P. unitary P \<and> P \<tturnstile> t P}" by(auto)
  hence "\<lambda>s. 0 \<tturnstile> Q" by(auto)
  also from Qin have "Q \<tturnstile> Sup_exp {P. unitary P \<and> P \<tturnstile> t P}"
    by(auto intro:Sup_exp_upper)
  finally show "\<lambda>s. 0 \<tturnstile> Sup_exp {P. unitary P \<and> P \<tturnstile> t P}" .
qed

lemma gfp_exp_unitary:
  "(\<And>P. unitary P \<Longrightarrow> unitary (t P)) \<Longrightarrow> unitary (gfp_exp t)"
  by(iprover intro:gfp_exp_nneg gfp_exp_bound unitaryI2)

lemma gfp_exp_lemma2:
  assumes ft: "\<And>P. unitary P \<Longrightarrow> unitary (t P)"
      and mt: "\<And>P Q. \<lbrakk> unitary P; unitary Q; P \<tturnstile> Q \<rbrakk> \<Longrightarrow> t P \<tturnstile> t Q"
  shows "gfp_exp t \<le> t (gfp_exp t)"
proof(rule gfp_exp_least)
  show "unitary (t (gfp_exp t))" by(auto intro:gfp_exp_unitary ft)
  fix P
  assume fp: "P \<le> t P" and uP: "unitary P"
  with ft have "P \<le> gfp_exp t" by(auto intro:gfp_exp_upperbound)
  with uP gfp_exp_unitary ft
  have "t P \<le> t (gfp_exp t)" by(blast intro: mt)
  with fp show "P \<le> t (gfp_exp t)" by(auto)
qed

lemma gfp_exp_lemma3:
  assumes ft: "\<And>P. unitary P \<Longrightarrow> unitary (t P)"
      and mt: "\<And>P Q. \<lbrakk> unitary P; unitary Q; P \<tturnstile> Q \<rbrakk> \<Longrightarrow> t P \<tturnstile> t Q"
  shows "t (gfp_exp t) \<le> gfp_exp t"
  by(iprover intro:gfp_exp_upperbound unitary_sound
                   gfp_exp_unitary gfp_exp_lemma2 assms)

lemma gfp_exp_unfold:
  "(\<And>P. unitary P \<Longrightarrow> unitary (t P)) \<Longrightarrow> (\<And>P Q. \<lbrakk> unitary P; unitary Q; P \<tturnstile> Q \<rbrakk> \<Longrightarrow> t P \<tturnstile> t Q) \<Longrightarrow>
   gfp_exp t = t (gfp_exp t)"
  by(iprover intro:antisym gfp_exp_lemma2 gfp_exp_lemma3)

subsection \<open>The Lattice of Transformers\<close>

text_raw \<open>\label{s:trans_induct}\<close>

text \<open>In addition to fixed points on expectations, we also need
to reason about fixed points on expectation transformers.  The
interpretation of a recursive program in pGCL is as a fixed
point of a function from transformers to transformers.  In contrast
to the case of expectations, \emph{healthy} transformers do form
a complete lattice, where the bottom element is @{term "\<lambda>_. (\<lambda>_. 0)"},
and the top element is the greatest allowed by feasibility:
@{term "\<lambda>P. (\<lambda>_. bound_of P)"}.\<close>

definition Inf_trans :: "'s trans set \<Rightarrow> 's trans"
where "Inf_trans S = (\<lambda>P. Inf_exp {t P |t. t \<in> S})"

lemma Inf_trans_lower:
  "\<lbrakk> t \<in> S; \<forall>u\<in>S. \<forall>P. sound P \<longrightarrow> sound (u P) \<rbrakk> \<Longrightarrow> le_trans (Inf_trans S) t"
  unfolding Inf_trans_def
  by(rule le_transI[OF Inf_exp_lower], blast+)

lemma Inf_trans_greatest:
  "\<lbrakk> S \<noteq> {}; \<forall>t\<in>S. \<forall>P. le_trans u t \<rbrakk> \<Longrightarrow> le_trans u (Inf_trans S)"
  unfolding Inf_trans_def by(auto intro!:le_transI[OF Inf_exp_greatest])

definition Sup_trans :: "'s trans set \<Rightarrow> 's trans"
where "Sup_trans S = (\<lambda>P. Sup_exp {t P |t. t \<in> S})"

lemma Sup_trans_upper:
  "\<lbrakk> t \<in> S; \<forall>u\<in>S. \<forall>P. unitary P \<longrightarrow> unitary (u P) \<rbrakk> \<Longrightarrow> le_utrans t (Sup_trans S)"
  unfolding Sup_trans_def
  by(intro le_utransI[OF Sup_exp_upper], auto intro:unitary_bound)

lemma Sup_trans_upper2:
  "\<lbrakk> t \<in> S; \<forall>u\<in>S. \<forall>P. (nneg P \<and> bounded_by b P) \<longrightarrow> (nneg (u P) \<and> bounded_by b (u P));
     nneg P; bounded_by b P \<rbrakk> \<Longrightarrow> t P \<tturnstile> Sup_trans S P"
  unfolding Sup_trans_def by(blast intro:Sup_exp_upper)

lemma Sup_trans_least:
  "\<lbrakk> \<forall>t\<in>S. le_utrans t u; \<And>P. unitary P \<Longrightarrow> unitary (u P) \<rbrakk> \<Longrightarrow> le_utrans (Sup_trans S) u"
  unfolding Sup_trans_def
  by(auto intro!:sound_nneg[OF unitary_sound] le_utransI[OF Sup_exp_least])

lemma Sup_trans_least2:
  "\<lbrakk> \<forall>t\<in>S. \<forall>P. nneg P \<longrightarrow> bounded_by b P \<longrightarrow> t P \<tturnstile> u P;
     \<forall>u\<in>S. \<forall>P. (nneg P \<and> bounded_by b P) \<longrightarrow> (nneg (u P) \<and> bounded_by b (u P));
     nneg P; bounded_by b P; \<And>P. \<lbrakk> nneg P; bounded_by b P \<rbrakk> \<Longrightarrow> nneg (u P) \<rbrakk> \<Longrightarrow> Sup_trans S P \<tturnstile> u P"
   unfolding Sup_trans_def by(blast intro!:Sup_exp_least)

lemma feasible_Sup_trans:
  fixes S::"'s trans set"
  assumes fS: "\<forall>t\<in>S. feasible t"
  shows "feasible (Sup_trans S)"
proof(cases "S={}", simp add:Sup_trans_def Sup_exp_def, blast, intro feasibleI)
  fix b::real and P::"'s expect"
  assume bP: "bounded_by b P" and nP: "nneg P"
     and neS: "S \<noteq> {}"

  from neS obtain t where tin: "t \<in> S" by(auto)
  with fS have ft: "feasible t" by(auto)
  with bP nP have "\<lambda>s. 0 \<tturnstile> t P" by(auto)
  also {
    from bP nP have "sound P" by(auto)
    with tin fS have "t P \<tturnstile> Sup_trans S P"
      by(auto intro!:Sup_trans_upper2)
  }
  finally show "nneg (Sup_trans S P)" by(auto)

  from fS bP nP
  show "bounded_by b (Sup_trans S P)"
    by(auto intro!:bounded_byI2[OF Sup_trans_least2])
qed

definition lfp_trans :: "('s trans \<Rightarrow> 's trans) \<Rightarrow> 's trans"
where "lfp_trans T = Inf_trans {t. (\<forall>P. sound P \<longrightarrow> sound (t P)) \<and> le_trans (T t) t}"

lemma lfp_trans_lowerbound:
  "\<lbrakk> le_trans (T t) t; \<And>P. sound P \<Longrightarrow> sound (t P) \<rbrakk> \<Longrightarrow> le_trans (lfp_trans T) t"
  unfolding lfp_trans_def
  by(auto intro:Inf_trans_lower)

lemma lfp_trans_greatest:
  "\<lbrakk> \<And>t P. \<lbrakk> le_trans (T t) t; \<And>P. sound P \<Longrightarrow> sound (t P) \<rbrakk> \<Longrightarrow> le_trans u t;
     \<And>P. sound P \<Longrightarrow> sound (v P); le_trans (T v) v \<rbrakk> \<Longrightarrow>
   le_trans u (lfp_trans T)"
  unfolding lfp_trans_def by(rule Inf_trans_greatest, auto)

lemma lfp_trans_sound:
  fixes P Q::"'s expect"
  assumes sP: "sound P"
      and fv: "le_trans (T v) v"
      and sv: "\<And>P. sound P \<Longrightarrow> sound (v P)"
  shows  "sound (lfp_trans T P)"
proof(intro soundI2 bounded_byI2 nnegI2)
  from fv sv have "le_trans (lfp_trans T) v"
    by(iprover intro:lfp_trans_lowerbound)
  with sP have "lfp_trans T P \<tturnstile> v P" by(auto)
  also {
    from sv sP have "sound (v P)" by(iprover)
    hence "v P \<tturnstile> \<lambda>s. bound_of (v P)" by(auto)
  }
  finally show "lfp_trans T P \<tturnstile> \<lambda>s. bound_of (v P)" .

  have "le_trans (\<lambda>P s. 0) (lfp_trans T)"
  proof(intro lfp_trans_greatest)
    fix t::"'s trans"
    assume "\<And>P. sound P \<Longrightarrow> sound (t P)"
    hence "\<And>P. sound P \<Longrightarrow> \<lambda>s. 0 \<tturnstile> t P" by(auto)
    thus "le_trans (\<lambda>P s. 0) t" by(auto)
  next
    fix P::"'s expect"
    assume "sound P" thus "sound (v P)" by(rule sv)
  next
    show "le_trans (T v) v" by(rule fv)
  qed
  with sP show "\<lambda>s. 0 \<tturnstile> lfp_trans T P" by(auto)
qed

lemma lfp_trans_unitary:
  fixes P Q::"'s expect"
  assumes uP: "unitary P"
      and fv: "le_trans (T v) v"
      and sv: "\<And>P. sound P \<Longrightarrow> sound (v P)"
      and fT: "le_trans (T (\<lambda>P s. bound_of P)) (\<lambda>P s. bound_of P)"
  shows  "unitary (lfp_trans T P)"
proof(rule unitaryI)
  from unitary_sound[OF uP] fv sv show "sound (lfp_trans T P)"
    by(rule lfp_trans_sound)

  show "bounded_by 1 (lfp_trans T P)"
  proof(rule bounded_byI2)
    from fT have "le_trans (lfp_trans T) (\<lambda>P s. bound_of P)"
      by(auto intro: lfp_trans_lowerbound)
    with uP have "lfp_trans T P \<tturnstile> \<lambda>s. bound_of P" by(auto)
    also from uP have "... \<tturnstile> \<lambda>s. 1" by(auto)
    finally show "lfp_trans T P \<tturnstile> \<lambda>s. 1" .
  qed
qed

lemma lfp_trans_lemma2:
  fixes v::"'s trans"
  assumes mono: "\<And>t u. \<lbrakk> le_trans t u; \<And>P. sound P \<Longrightarrow> sound (t P);
                         \<And>P. sound P \<Longrightarrow> sound (u P) \<rbrakk> \<Longrightarrow> le_trans (T t) (T u)"
      and nT:   "\<And>t P. \<lbrakk> \<And>Q. sound Q \<Longrightarrow> sound (t Q); sound P \<rbrakk> \<Longrightarrow> sound (T t P)"
      and fv:   "le_trans (T v) v"
      and sv:   "\<And>P. sound P \<Longrightarrow> sound (v P)"
  shows "le_trans (T (lfp_trans T)) (lfp_trans T)"
proof(rule lfp_trans_greatest[where T=T and v=v], simp_all add:assms)
  fix t::"'s trans" and P::"'s expect"
  assume ft: "le_trans (T t) t" and st: "\<And>P. sound P \<Longrightarrow> sound (t P)"
  hence "le_trans (lfp_trans T) t" by(auto intro!:lfp_trans_lowerbound)
  with ft st have "le_trans (T (lfp_trans T)) (T t)"
    by(iprover intro:mono lfp_trans_sound fv sv)
  also note ft
  finally show "le_trans (T (lfp_trans T)) t" .
qed

lemma lfp_trans_lemma3:
  fixes v::"'s trans"
  assumes mono: "\<And>t u. \<lbrakk> le_trans t u; \<And>P. sound P \<Longrightarrow> sound (t P);
                         \<And>P. sound P \<Longrightarrow> sound (u P) \<rbrakk> \<Longrightarrow> le_trans (T t) (T u)"
      and sT:   "\<And>t P. \<lbrakk> \<And>Q. sound Q \<Longrightarrow> sound (t Q); sound P \<rbrakk> \<Longrightarrow> sound (T t P)"
      and fv:   "le_trans (T v) v"
      and sv:   "\<And>P. sound P \<Longrightarrow> sound (v P)"
  shows "le_trans (lfp_trans T) (T (lfp_trans T))"
proof(rule lfp_trans_lowerbound)
  fix P::"'s expect"
  assume sP: "sound P"
  have n1: "\<And>P. sound P \<Longrightarrow> sound (lfp_trans T P)"
    by(iprover intro:lfp_trans_sound fv sv)
  with sP have n2: "sound (lfp_trans T P)"
    by(iprover intro:lfp_trans_sound fv sv sT)
  with n1 sP show n3: "sound (T (lfp_trans T) P)"
    by(iprover intro: sT)
  next
  show "le_trans (T (T (lfp_trans T))) (T (lfp_trans T))"
    by(rule mono[OF lfp_trans_lemma2, OF mono],
            (iprover intro:assms lfp_trans_sound)+)
qed

lemma lfp_trans_unfold:
  fixes P::"'s expect"
  assumes mono: "\<And>t u. \<lbrakk> le_trans t u; \<And>P. sound P \<Longrightarrow> sound (t P);
                         \<And>P. sound P \<Longrightarrow> sound (u P) \<rbrakk> \<Longrightarrow> le_trans (T t) (T u)"
      and sT:   "\<And>t P. \<lbrakk> \<And>Q. sound Q \<Longrightarrow> sound (t Q); sound P \<rbrakk> \<Longrightarrow> sound (T t P)"
      and fv:   "le_trans (T v) v"
      and sv:   "\<And>P. sound P \<Longrightarrow> sound (v P)"
  shows "equiv_trans (lfp_trans T) (T (lfp_trans T))"
  by(rule le_trans_antisym,
     rule lfp_trans_lemma3[OF mono], (iprover intro:assms)+,
     rule lfp_trans_lemma2[OF mono], (iprover intro:assms)+)

definition gfp_trans :: "('s trans \<Rightarrow> 's trans) \<Rightarrow> 's trans"
where "gfp_trans T = Sup_trans {t. (\<forall>P. unitary P \<longrightarrow> unitary (t P)) \<and> le_utrans t (T t)}"

lemma gfp_trans_upperbound:
  "\<lbrakk> le_utrans t (T t); \<And>P. unitary P \<Longrightarrow> unitary (t P) \<rbrakk> \<Longrightarrow> le_utrans t (gfp_trans T)"
  unfolding gfp_trans_def by(auto intro:Sup_trans_upper)

lemma gfp_trans_least:
  "\<lbrakk> \<And>t. \<lbrakk> le_utrans t (T t); \<And>P. unitary P \<Longrightarrow> unitary (t P) \<rbrakk> \<Longrightarrow> le_utrans t u;
     \<And>P. unitary P \<Longrightarrow> unitary (u P) \<rbrakk> \<Longrightarrow>
   le_utrans (gfp_trans T) u"
  unfolding gfp_trans_def by(auto intro:Sup_trans_least)

lemma gfp_trans_unitary:
  fixes P::"'s expect"
  assumes uP: "unitary P"
  shows "unitary (gfp_trans T P)"
proof(intro unitaryI2 nnegI2 bounded_byI2)
  show "gfp_trans T P \<tturnstile> \<lambda>s. 1"
  unfolding gfp_trans_def Sup_trans_def
  proof(rule Sup_exp_least, clarify)
    fix t::"'s trans"
    assume "\<forall>P. unitary P \<longrightarrow> unitary (t P)"
    with uP have "unitary (t P)" by(auto)
    thus "t P \<tturnstile> \<lambda>s. 1" by(auto)
  next
    show "nneg (\<lambda>s. 1::real)" by(auto)
  qed
  let ?S = "{t P |t. t \<in> {t. (\<forall>P. unitary P \<longrightarrow> unitary (t P)) \<and> le_utrans t (T t)}}"
  show "\<lambda>s. 0 \<tturnstile> gfp_trans T P"
  unfolding gfp_trans_def Sup_trans_def
  proof(cases)
    assume empty: "?S = {}"
    show "\<lambda>s. 0 \<tturnstile> Sup_exp ?S"
      by(simp only:empty Sup_exp_def, auto)
  next
    assume "?S \<noteq> {}"
    then obtain Q where Qin: "Q \<in> ?S" by(auto)
    with uP have "unitary Q" by(auto)
    hence "\<lambda>s. 0 \<tturnstile> Q" by(auto)
    also with uP Qin have "Q \<tturnstile> Sup_exp ?S"
    proof(intro Sup_exp_upper, blast, clarify)
      fix t::"'s trans"
      assume "\<forall>Q. unitary Q \<longrightarrow> unitary (t Q)"
      with uP show "bounded_by 1 (t P)" by(auto)
    qed
    finally show "\<lambda>s. 0 \<tturnstile> Sup_exp ?S" .
  qed
qed

lemma gfp_trans_lemma2:
  assumes mono: "\<And>t u. \<lbrakk> le_utrans t u; \<And>P. unitary P \<Longrightarrow> unitary (t P);
                         \<And>P. unitary P \<Longrightarrow> unitary (u P) \<rbrakk> \<Longrightarrow> le_utrans (T t) (T u)"
      and hT:   "\<And>t P. \<lbrakk> \<And>Q. unitary Q \<Longrightarrow> unitary (t Q); unitary P \<rbrakk> \<Longrightarrow> unitary (T t P)"
  shows "le_utrans (gfp_trans T) (T (gfp_trans T))"
proof(rule gfp_trans_least, simp_all add:hT gfp_trans_unitary)
  fix t
  assume fp: "le_utrans t (T t)" and ht: "\<And>P. unitary P \<Longrightarrow> unitary (t P)"

  note fp
  also {
    from fp ht have "le_utrans t (gfp_trans T)"by(rule gfp_trans_upperbound)
    moreover note ht gfp_trans_unitary
    ultimately have "le_utrans (T t) (T (gfp_trans T))" by(rule mono)
  }
  finally show "le_utrans t (T (gfp_trans T))" .
qed

lemma gfp_trans_lemma3:
  assumes mono: "\<And>t u. \<lbrakk> le_utrans t u; \<And>P. unitary P \<Longrightarrow> unitary (t P);
                         \<And>P. unitary P \<Longrightarrow> unitary (u P) \<rbrakk> \<Longrightarrow> le_utrans (T t) (T u)"
      and hT:   "\<And>t P. \<lbrakk> \<And>Q. unitary Q \<Longrightarrow> unitary (t Q); unitary P \<rbrakk> \<Longrightarrow> unitary (T t P)"
  shows "le_utrans (T (gfp_trans T)) (gfp_trans T)"
  by(blast intro!:mono gfp_trans_unitary gfp_trans_upperbound gfp_trans_lemma2 mono hT)

lemma gfp_trans_unfold:
  assumes mono: "\<And>t u. \<lbrakk> le_utrans t u; \<And>P. unitary P \<Longrightarrow> unitary (t P);
                         \<And>P. unitary P \<Longrightarrow> unitary (u P) \<rbrakk> \<Longrightarrow> le_utrans (T t) (T u)"
      and hT:   "\<And>t P. \<lbrakk> \<And>Q. unitary Q \<Longrightarrow> unitary (t Q); unitary P \<rbrakk> \<Longrightarrow> unitary (T t P)"
  shows "equiv_utrans (gfp_trans T) (T (gfp_trans T))"
  using assms by(auto intro!: le_utrans_antisym gfp_trans_lemma2 gfp_trans_lemma3)

subsection \<open>Tail Recursion\<close>

text_raw \<open>\label{s:tail}\<close>

text \<open>The least (greatest) fixed point of a tail-recursive expression on transformers is
equivalent (given appropriate side conditions) to the least (greatest) fixed point on
expectations.\<close>

lemma lfp_pulldown:
  fixes P::"'s expect" and t::"'s expect \<Rightarrow> 's trans"
    and T::"'s trans \<Rightarrow> 's trans"
  assumes tailcall:  "\<And>u P. sound P \<Longrightarrow> T u P = t P (u P)"
      and st:        "\<And>P Q. sound P \<Longrightarrow> sound Q \<Longrightarrow> sound (t P Q)"
      and mt:        "\<And>P. sound P \<Longrightarrow> mono_trans (t P)"
      and monoT: "\<And>t u. \<lbrakk> le_trans t u; \<And>P. sound P \<Longrightarrow> sound (t P);
                          \<And>P. sound P \<Longrightarrow> sound (u P) \<rbrakk> \<Longrightarrow> le_trans (T t) (T u)"
      and nT:   "\<And>t P. \<lbrakk> \<And>Q. sound Q \<Longrightarrow> sound (t Q); sound P \<rbrakk> \<Longrightarrow> sound (T t P)"
      and fv:   "le_trans (T v) v"
      and sv:   "\<And>P. sound P \<Longrightarrow> sound (v P)"
      and sP:   "sound P"
  shows "lfp_trans T P = lfp_exp (t P)" (is "?X P = ?Y P")
proof(rule antisym)
  show "?Y P \<le> ?X P"
  proof(rule lfp_exp_lowerbound)
    from sP have "t P (lfp_trans T P) = (T (lfp_trans T)) P" by(rule tailcall[symmetric])
    also have "(T (lfp_trans T)) P \<le> (lfp_trans T) P"
      by(rule le_transD[OF lfp_trans_lemma2[OF monoT]], (iprover intro:assms)+)
    finally show "t P (lfp_trans T P) \<le> lfp_trans T P" .
    from sP show "sound (lfp_trans T P)"
      by(iprover intro:lfp_trans_sound assms)
  qed

  have "\<And>P. sound P \<Longrightarrow> t P (v P) = T v P" by(simp add:tailcall)
  also have "\<And>P. sound P \<Longrightarrow> ... P \<tturnstile> v P" by(auto intro:le_transD[OF fv])
  finally have fvP: "\<And>P. sound P \<Longrightarrow> t P (v P) \<tturnstile> v P" .
  have svP: "\<And>P. sound P \<Longrightarrow> sound (v P)" by(rule sv)

  show "?X P \<le> ?Y P"
  proof(rule le_transD[OF lfp_trans_lowerbound, OF _ _ sP])
    show "le_trans (T (\<lambda>a. lfp_exp (t a))) (\<lambda>a. lfp_exp (t a))"
    proof(rule le_transI)
      fix P::"'s expect"
      assume sP: "sound P"

      from sP have "T (\<lambda>a. lfp_exp (t a)) P = t P (lfp_exp (t P))" by(rule tailcall)
      also have "t P (lfp_exp (t P)) = lfp_exp (t P)"
        by(iprover intro: lfp_exp_unfold[symmetric] sP st mt fvP svP)
      finally show "T (\<lambda>a. lfp_exp (t a)) P \<tturnstile> lfp_exp (t P)" by(simp)
    qed
    fix P::"'s expect"
    assume "sound P"
    with fvP svP show "sound (lfp_exp (t P))"
      by(blast intro:lfp_exp_sound)
  qed
qed

definition Inf_utrans :: "'s trans set \<Rightarrow> 's trans"
where "Inf_utrans S = (if S = {} then \<lambda>P s. 1 else Inf_trans S)"

lemma Inf_utrans_lower:
  "\<lbrakk> t \<in> S; \<forall>t\<in>S. \<forall>P. unitary P \<longrightarrow> unitary (t P) \<rbrakk> \<Longrightarrow> le_utrans (Inf_utrans S) t"
  unfolding Inf_utrans_def
  by(cases "S={}",
     auto intro!:le_utransI Inf_exp_lower sound_nneg unitary_sound
          simp:Inf_trans_def)

lemma Inf_utrans_greatest:
  "\<lbrakk> \<And>P. unitary P \<Longrightarrow> unitary (t P); \<forall>u\<in>S. le_utrans t u \<rbrakk> \<Longrightarrow> le_utrans t (Inf_utrans S)"
  unfolding Inf_utrans_def Inf_trans_def
  by(cases "S={}", simp_all, (blast intro!:le_utransI Inf_exp_greatest)+)

end


theory Prelude_Eq
imports "$HETS_ISABELLE_LIB/MainHC"
uses "$HETS_ISABELLE_LIB/prelude"
begin

setup "Header.initialize
       [\"NotFalse\", \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\",
        \"OrDef\", \"OtherwiseDef\", \"NotFalse1\", \"NotTrue1\",
        \"notNot1\", \"notNot2\", \"EqualTDef\", \"EqualSymDef\",
        \"EqualReflex\", \"EqualTransT\", \"DiffDef\", \"IBE3\",
        \"DiffSymDef\", \"DiffTDef\", \"DiffFDef\", \"TE1\", \"TE2\",
        \"TE3\", \"TE4\", \"IUE1\", \"IUE2\", \"IBE1\", \"IBE2\", \"IBE4\",
        \"IBE5\", \"IBE6\", \"IBE7\", \"IBE8\"]"

typedecl Bool
typedecl Unit

consts
X__XAmpXAmp__X :: "bool => bool => bool" ("(_/ &&/ _)" [54,54] 52)
X__XEqXEq__X :: "'a partial => 'a partial => bool" ("(_/ ==''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a partial => 'a partial => bool" ("(_/ '/=/ _)" [54,54] 52)
X__XVBarXVBar__X :: "bool => bool => bool" ("(_/ ||/ _)" [54,54] 52)
notH__X :: "bool => bool" ("(notH/ _)" [56] 56)
otherwiseH :: "bool"

axioms
NotFalse [rule_format] : "notH False"

NotTrue [rule_format] : "~ notH True"

AndFalse [rule_format] : "ALL (x :: bool). ~ False && x"

AndTrue [rule_format] : "ALL (x :: bool). True && x = x"

AndSym [rule_format] :
"ALL (x :: bool). ALL (y :: bool). x && y = y && x"

OrDef [rule_format] :
"ALL (x :: bool).
 ALL (y :: bool). x || y = notH (notH x && notH y)"

OtherwiseDef [rule_format] : "otherwiseH"

NotFalse1 [rule_format] : "ALL (x :: bool). notH x = (~ x)"

NotTrue1 [rule_format] : "ALL (x :: bool). ~ notH x = x"

notNot1 [rule_format] : "ALL (x :: bool). (~ x) = notH x"

notNot2 [rule_format] : "ALL (x :: bool). (~ ~ x) = (~ notH x)"

EqualTDef [rule_format] :
"ALL (x :: 'a partial). ALL (y :: 'a partial). x = y --> x ==' y"

EqualSymDef [rule_format] :
"ALL (x :: 'a partial). ALL (y :: 'a partial). x ==' y = y ==' x"

EqualReflex [rule_format] : "ALL (x :: 'a partial). x ==' x"

EqualTransT [rule_format] :
"ALL (x :: 'a partial).
 ALL (y :: 'a partial).
 ALL (z :: 'a partial). x ==' y & y ==' z --> x ==' z"

DiffDef [rule_format] :
"ALL (x :: 'a partial).
 ALL (y :: 'a partial). x /= y = notH (x ==' y)"

IBE3 [rule_format] : "~ undefinedOp ==' makePartial ()"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare OtherwiseDef [simp]
declare NotTrue1 [simp]
declare EqualReflex [simp]
declare IBE3 [simp]

theorem DiffSymDef :
"ALL (x :: 'a partial). ALL (y :: 'a partial). x /= y = y /= x"
apply(auto)
apply(simp add: DiffDef)
apply(simp add: EqualSymDef)
apply(simp add: DiffDef)
apply(simp add: EqualSymDef)
done

setup "Header.record \"DiffSymDef\""

theorem DiffTDef :
"ALL (x :: 'a partial).
 ALL (y :: 'a partial). x /= y = notH (x ==' y)"
apply(auto)
apply(simp add: DiffDef)
apply(simp add: DiffDef)
done

setup "Header.record \"DiffTDef\""

theorem DiffFDef :
"ALL (x :: 'a partial).
 ALL (y :: 'a partial). (~ x /= y) = x ==' y"
apply(auto)
apply(simp add: DiffDef)
apply(simp add: NotFalse1)
apply(simp add: DiffDef)
done

setup "Header.record \"DiffFDef\""

theorem TE1 :
"ALL (x :: 'a partial).
 ALL (y :: 'a partial). ~ x ==' y --> ~ x = y"
by (auto)

setup "Header.record \"TE1\""

theorem TE2 :
"ALL (x :: 'a partial).
 ALL (y :: 'a partial). notH (x ==' y) = (~ x ==' y)"
by (auto)

setup "Header.record \"TE2\""

theorem TE3 :
"ALL (x :: 'a partial).
 ALL (y :: 'a partial). (~ notH (x ==' y)) = x ==' y"
apply(auto)
apply(case_tac "x ==' y")
by (auto)

setup "Header.record \"TE3\""

theorem TE4 :
"ALL (x :: 'a partial).
 ALL (y :: 'a partial). (~ x ==' y) = (~ x ==' y)"
by (auto)

setup "Header.record \"TE4\""

theorem IUE1 : "makePartial () ==' makePartial ()"
by (auto)

setup "Header.record \"IUE1\""

theorem IUE2 : "~ makePartial () /= makePartial ()"
apply(simp add: DiffDef)
done

setup "Header.record \"IUE2\""

theorem IBE1 : "makePartial () ==' makePartial ()"
by (auto)

setup "Header.record \"IBE1\""

theorem IBE2 : "undefinedOp ==' undefinedOp"
by (auto)

setup "Header.record \"IBE2\""

theorem IBE4 : "~ makePartial () ==' undefinedOp"
apply (auto)
apply(simp add: EqualSymDef)
done

setup "Header.record \"IBE4\""

theorem IBE5 : "makePartial () /= undefinedOp"
apply(simp add: DiffDef)
apply(simp add: NotFalse1)
apply(simp add: EqualSymDef)
done

setup "Header.record \"IBE5\""

theorem IBE6 : "undefinedOp /= makePartial ()"
apply(simp add: DiffDef)
done

setup "Header.record \"IBE6\""

theorem IBE7 : "notH (makePartial () ==' undefinedOp)"
apply(simp add: NotFalse1)
apply(simp add: EqualSymDef)
done

setup "Header.record \"IBE7\""

theorem IBE8 : "~ notH notH (makePartial () ==' undefinedOp)"
apply(simp add: EqualSymDef)
done

setup "Header.record \"IBE8\""

end