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

section\<open>Introducing New Types\<close>

text\<open>\label{sec:adv-typedef}
For most applications, a combination of predefined types like \<^typ>\<open>bool\<close> and
\<open>\<Rightarrow>\<close> with recursive datatypes and records is quite sufficient. Very
occasionally you may feel the need for a more advanced type.  If you
are certain that your type is not definable by any of the
standard means, then read on.
\begin{warn}
  Types in HOL must be non-empty; otherwise the quantifier rules would be
  unsound, because $\exists x.\ x=x$ is a theorem.
\end{warn}
\<close>

subsection\<open>Declaring New Types\<close>

text\<open>\label{sec:typedecl}
\index{types!declaring|(}%
\index{typedecl@\isacommand {typedecl} (command)}%
The most trivial way of introducing a new type is by a \textbf{type
declaration}:\<close>

typedecl my_new_type

text\<open>\noindent
This does not define \<^typ>\<open>my_new_type\<close> at all but merely introduces its
name. Thus we know nothing about this type, except that it is
non-empty. Such declarations without definitions are
useful if that type can be viewed as a parameter of the theory.
A typical example is given in \S\ref{sec:VMC}, where we define a transition
relation over an arbitrary type of states.

In principle we can always get rid of such type declarations by making those
types parameters of every other type, thus keeping the theory generic. In
practice, however, the resulting clutter can make types hard to read.

If you are looking for a quick and dirty way of introducing a new type
together with its properties: declare the type and state its properties as
axioms. Example:
\<close>

axiomatization where
just_one: "\<exists>x::my_new_type. \<forall>y. x = y"

text\<open>\noindent
However, we strongly discourage this approach, except at explorative stages
of your development. It is extremely easy to write down contradictory sets of
axioms, in which case you will be able to prove everything but it will mean
nothing.  In the example above, the axiomatic approach is
unnecessary: a one-element type called \<^typ>\<open>unit\<close> is already defined in HOL.
\index{types!declaring|)}
\<close>

subsection\<open>Defining New Types\<close>

text\<open>\label{sec:typedef}
\index{types!defining|(}%
\index{typedecl@\isacommand {typedef} (command)|(}%
Now we come to the most general means of safely introducing a new type, the
\textbf{type definition}. All other means, for example
\isacommand{datatype}, are based on it. The principle is extremely simple:
any non-empty subset of an existing type can be turned into a new type.
More precisely, the new type is specified to be isomorphic to some
non-empty subset of an existing type.

Let us work a simple example, the definition of a three-element type.
It is easily represented by the first three natural numbers:
\<close>

typedef three = "{0::nat, 1, 2}"

txt\<open>\noindent
In order to enforce that the representing set on the right-hand side is
non-empty, this definition actually starts a proof to that effect:
@{subgoals[display,indent=0]}
Fortunately, this is easy enough to show, even \isa{auto} could do it.
In general, one has to provide a witness, in our case 0:
\<close>

apply(rule_tac x = 0 in exI)
by simp

text\<open>
This type definition introduces the new type \<^typ>\<open>three\<close> and asserts
that it is a copy of the set \<^term>\<open>{0::nat,1,2}\<close>. This assertion
is expressed via a bijection between the \emph{type} \<^typ>\<open>three\<close> and the
\emph{set} \<^term>\<open>{0::nat,1,2}\<close>. To this end, the command declares the following
constants behind the scenes:
\begin{center}
\begin{tabular}{rcl}
\<^term>\<open>Rep_three\<close> &::& \<^typ>\<open>three \<Rightarrow> nat\<close>\\
\<^term>\<open>Abs_three\<close> &::& \<^typ>\<open>nat \<Rightarrow> three\<close>
\end{tabular}
\end{center}
The situation is best summarized with the help of the following diagram,
where squares denote types and the irregular region denotes a set:
\begin{center}
\includegraphics[scale=.8]{typedef}
\end{center}
Finally, \isacommand{typedef} asserts that \<^term>\<open>Rep_three\<close> is
surjective on the subset and \<^term>\<open>Abs_three\<close> and \<^term>\<open>Rep_three\<close> are inverses of each other:
\begin{center}
\begin{tabular}{@ {}r@ {\qquad\qquad}l@ {}}
@{thm Rep_three[no_vars]} & (@{thm[source]Rep_three}) \\
@{thm Rep_three_inverse[no_vars]} & (@{thm[source]Rep_three_inverse}) \\
@{thm Abs_three_inverse[no_vars]} & (@{thm[source]Abs_three_inverse})
\end{tabular}
\end{center}
%
From this example it should be clear what \isacommand{typedef} does
in general given a name (here \<open>three\<close>) and a set
(here \<^term>\<open>{0::nat,1,2}\<close>).

Our next step is to define the basic functions expected on the new type.
Although this depends on the type at hand, the following strategy works well:
\begin{itemize}
\item define a small kernel of basic functions that can express all other
functions you anticipate.
\item define the kernel in terms of corresponding functions on the
representing type using \<^term>\<open>Abs\<close> and \<^term>\<open>Rep\<close> to convert between the
two levels.
\end{itemize}
In our example it suffices to give the three elements of type \<^typ>\<open>three\<close>
names:
\<close>

definition A :: three where "A \<equiv> Abs_three 0"
definition B :: three where "B \<equiv> Abs_three 1"
definition C :: three where "C \<equiv> Abs_three 2"

text\<open>
So far, everything was easy. But it is clear that reasoning about \<^typ>\<open>three\<close> will be hell if we have to go back to \<^typ>\<open>nat\<close> every time. Thus our
aim must be to raise our level of abstraction by deriving enough theorems
about type \<^typ>\<open>three\<close> to characterize it completely. And those theorems
should be phrased in terms of \<^term>\<open>A\<close>, \<^term>\<open>B\<close> and \<^term>\<open>C\<close>, not \<^term>\<open>Abs_three\<close> and \<^term>\<open>Rep_three\<close>. Because of the simplicity of the example,
we merely need to prove that \<^term>\<open>A\<close>, \<^term>\<open>B\<close> and \<^term>\<open>C\<close> are distinct
and that they exhaust the type.

In processing our \isacommand{typedef} declaration,
Isabelle proves several helpful lemmas. The first two
express injectivity of \<^term>\<open>Rep_three\<close> and \<^term>\<open>Abs_three\<close>:
\begin{center}
\begin{tabular}{@ {}r@ {\qquad}l@ {}}
@{thm Rep_three_inject[no_vars]} & (@{thm[source]Rep_three_inject}) \\
\begin{tabular}{@ {}l@ {}}
\<open>\<lbrakk>x \<in> {0, 1, 2}; y \<in> {0, 1, 2} \<rbrakk>\<close> \\
\<open>\<Longrightarrow> (Abs_three x = Abs_three y) = (x = y)\<close>
\end{tabular} & (@{thm[source]Abs_three_inject}) \\
\end{tabular}
\end{center}
The following ones allow to replace some \<open>x::three\<close> by
\<open>Abs_three(y::nat)\<close>, and conversely \<^term>\<open>y\<close> by \<^term>\<open>Rep_three x\<close>:
\begin{center}
\begin{tabular}{@ {}r@ {\qquad}l@ {}}
@{thm Rep_three_cases[no_vars]} & (@{thm[source]Rep_three_cases}) \\
@{thm Abs_three_cases[no_vars]} & (@{thm[source]Abs_three_cases}) \\
@{thm Rep_three_induct[no_vars]} & (@{thm[source]Rep_three_induct}) \\
@{thm Abs_three_induct[no_vars]} & (@{thm[source]Abs_three_induct}) \\
\end{tabular}
\end{center}
These theorems are proved for any type definition, with \<open>three\<close>
replaced by the name of the type in question.

Distinctness of \<^term>\<open>A\<close>, \<^term>\<open>B\<close> and \<^term>\<open>C\<close> follows immediately
if we expand their definitions and rewrite with the injectivity
of \<^term>\<open>Abs_three\<close>:
\<close>

lemma "A \<noteq> B \<and> B \<noteq> A \<and> A \<noteq> C \<and> C \<noteq> A \<and> B \<noteq> C \<and> C \<noteq> B"
by(simp add: Abs_three_inject A_def B_def C_def)

text\<open>\noindent
Of course we rely on the simplifier to solve goals like \<^prop>\<open>(0::nat) \<noteq> 1\<close>.

The fact that \<^term>\<open>A\<close>, \<^term>\<open>B\<close> and \<^term>\<open>C\<close> exhaust type \<^typ>\<open>three\<close> is
best phrased as a case distinction theorem: if you want to prove \<^prop>\<open>P x\<close>
(where \<^term>\<open>x\<close> is of type \<^typ>\<open>three\<close>) it suffices to prove \<^prop>\<open>P A\<close>,
\<^prop>\<open>P B\<close> and \<^prop>\<open>P C\<close>:\<close>

lemma three_cases: "\<lbrakk> P A; P B; P C \<rbrakk> \<Longrightarrow> P x"

txt\<open>\noindent Again this follows easily using the induction principle stemming from the type definition:\<close>

apply(induct_tac x)

txt\<open>
@{subgoals[display,indent=0]}
Simplification leads to the disjunction \<^prop>\<open>y
= 0 \<or> y = 1 \<or> y = (2::nat)\<close> which \isa{auto} separates into three
subgoals, each of which is easily solved by simplification:\<close>

apply(auto simp add: A_def B_def C_def)
done

text\<open>\noindent
This concludes the derivation of the characteristic theorems for
type \<^typ>\<open>three\<close>.

The attentive reader has realized long ago that the
above lengthy definition can be collapsed into one line:
\<close>

datatype better_three = A | B | C

text\<open>\noindent
In fact, the \isacommand{datatype} command performs internally more or less
the same derivations as we did, which gives you some idea what life would be
like without \isacommand{datatype}.

Although \<^typ>\<open>three\<close> could be defined in one line, we have chosen this
example to demonstrate \isacommand{typedef} because its simplicity makes the
key concepts particularly easy to grasp. If you would like to see a
non-trivial example that cannot be defined more directly, we recommend the
definition of \emph{finite multisets} in the Library~\<^cite>\<open>"HOL-Library"\<close>.

Let us conclude by summarizing the above procedure for defining a new type.
Given some abstract axiomatic description $P$ of a type $ty$ in terms of a
set of functions $F$, this involves three steps:
\begin{enumerate}
\item Find an appropriate type $\tau$ and subset $A$ which has the desired
  properties $P$, and make a type definition based on this representation.
\item Define the required functions $F$ on $ty$ by lifting
analogous functions on the representation via $Abs_ty$ and $Rep_ty$.
\item Prove that $P$ holds for $ty$ by lifting $P$ from the representation.
\end{enumerate}
You can now forget about the representation and work solely in terms of the
abstract functions $F$ and properties $P$.%
\index{typedecl@\isacommand {typedef} (command)|)}%
\index{types!defining|)}
\<close>

(*<*)end(*>*)


(* Author: Dmitriy Traytel *)

theory WS1S_Examples
imports WS1S_Equivalence_Checking "~~/src/HOL/Library/Char_ord"
    "~~/src/HOL/Library/Product_Lexorder"
begin

abbreviation FALSE where "FALSE \<equiv> FExists (FLess 0 0)"
abbreviation TRUE where "TRUE \<equiv> FNot FALSE"
abbreviation All where "All \<phi> \<equiv> FNot (FExists (FNot \<phi>))"
abbreviation AL where "AL \<phi> \<equiv> FNot (FEXISTS (FNot \<phi>))"
abbreviation Imp where "Imp \<phi> \<psi> \<equiv> FOr (FNot \<phi>) \<psi>"
abbreviation Iff where "Iff \<phi> \<psi> \<equiv> FAnd (Imp \<phi> \<psi>) (Imp \<psi> \<phi>)"
abbreviation Ball where "Ball X \<phi> \<equiv> All (Imp (FIn 0 (X+1)) \<phi>)"
abbreviation Bex where "Bex X \<phi> \<equiv> FExists (FAnd (FIn 0 (X+1)) \<phi>)"

abbreviation Eq where "Eq x y \<equiv> FAnd (FNot (FLess x y)) (FNot (FLess y x))"
abbreviation SUBSET where "SUBSET X Y \<equiv> Ball X (FIn 0 (Y+1))"
abbreviation EQ where "EQ X Y \<equiv> FAnd (SUBSET X Y) (SUBSET Y X)"
abbreviation First where "First x \<equiv> FNot (FExists (FLess 0 (x+1)))"
abbreviation Last where "Last x \<equiv> FNot (FExists (FLess (x+1) 0))"
abbreviation Suc where "Suc sucx x \<equiv> FAnd (FLess x sucx) (FNot (FExists (FAnd (FLess (x+1) 0) (FLess 0 (sucx+1)))))"

definition "Thm (type :: 'a :: {enum, linorder} itself) n \<phi> = fast.check_eqv n (FNot \<phi> :: 'a formula) FALSE"
definition "Thm_slow (type :: 'a :: {enum, linorder} itself) n \<phi> = slow.check_eqv n (FNot \<phi> :: 'a formula) FALSE"
definition "Thm_dual (type :: 'a :: {enum, linorder} itself) n \<phi> = dual.check_eqv n (FNot \<phi> :: 'a formula) FALSE"

definition "M2L = (FEXISTS (All (FIn 0 1)) :: Enum.finite_1 formula)"

lemma "Thm TYPE(Enum.finite_1) 0 (FNot M2L)" by eval
lemma "Thm TYPE(Enum.finite_1) 0 (All (FExists (FLess 1 0)))" by eval
lemma "Thm (TYPE(bool)) 0 (FNot (FExists (FExists (FAnd (FLess 0 1) (FLess 1 0)))))" by eval
lemma Drinker: "Thm (TYPE(bool)) 1 (FExists (Imp (FIn 0 1) (All (FIn 0 2))))" by eval
lemma "Thm (TYPE(bool)) 1 (Imp (All (FIn 0 1)) (FExists (FIn 0 1)))" by eval

(*
definition "mod_two a b c d = Iff a (Iff b (Iff c d))"
definition "at_least_two a b c d = Iff d (FOr (FAnd a b) (FOr (FAnd b c) (FAnd a c)))"

definition "ADD S A B = FEXISTS (FAnd (All (Imp (First 0) (FNot (FIn 0 1))))
  (All (FAnd (mod_two (FIn 0 (A+2)) (FIn 0 (B+2)) (FIn 0 1) (FIn 0 (S+2)))
       (Imp (FExists (FAnd (Last 0) (FLess 1 0)))
            (at_least_two (FIn 0 (A+2)) (FIn 0 (B+2)) (FIn 0 1) (All (Imp (Suc 0 1) (FIn 0 2))))))))"

definition Comm_Lemma :: "Enum.finite_1 formula" where
  "Comm_Lemma = AL (AL (FEXISTS (FAnd (ADD 0 1 2) (FEXISTS (FAnd (ADD 0 3 2) (EQ 0 1))))))"

lemma "Thm TYPE(bool) 0 (AL (AL (FEXISTS (ADD 0 1 2))))"
  by eval

lemma "Thm TYPE(Enum.finite_1) 0 Comm_Lemma"
  by eval
*)

abbreviation Globally ("\<box>_" [40] 40) where "Globally P == %n. All (Imp (FNot (FLess (n+1) 0)) (P 0))"
abbreviation Future ("\<diamondsuit>_" [40] 40) where "Future P == %n. FExists (FAnd (FNot (FLess (n+1) 0)) (P 0))"
abbreviation IMP (infixr "\<rightarrow>" 50) where "IMP P1 P2 == %n. Imp (P1 n) (P2 n)"

abbreviation "FOR xs n \<equiv> rexp_of_list FOr FALSE (map (\<lambda>x. FQ x n) xs)"

abbreviation \<Phi>0 :: "bool formula" where "\<Phi>0 \<equiv>
  (All (((\<box>(FOR [(True)])) \<rightarrow> (\<box>(FOR [(True)]))) 0))"

abbreviation \<Phi>1 :: "(bool \<times> bool) formula" where "\<Phi>1 \<equiv>
  (All (((\<box>(FOR [(True, True), (True, False)] \<rightarrow>
            FOR [(True, True), (False, True)])) \<rightarrow>
         (\<box>(FOR [(True, True), (True, False)])) \<rightarrow>
         (\<box>(FOR [(True, True), (False, True)]))) 0))"

abbreviation \<Phi>2 :: "(bool \<times> bool \<times> bool) formula" where "\<Phi>2 \<equiv>
  (All (((\<box>(FOR [(True, True, True), (True, True, False), (True, False, True), (True, False, False)] \<rightarrow>
            FOR [(True, True, True), (True, True, False), (False, True, True), (False, True, False)] \<rightarrow>
            FOR [(True, True, True), (True, False, True), (False, True, True), (False, False, True)])) \<rightarrow>
        (\<box>(FOR [(True, True, True), (True, True, False), (True, False, True), (True, False, False)])) \<rightarrow>
        (\<box>(FOR [(True, True, True), (True, True, False), (False, True, True), (False, True, False)])) \<rightarrow>
        (\<box>(FOR [(True, True, True), (True, True, False), (False, True, True), (False, True, False)]))) 0))"

definition \<Psi> :: "nat \<Rightarrow> Enum.finite_1 formula" where
  "\<Psi> n = All (((\<box>(foldr (\<lambda>i \<phi>. (\<lambda>m. FIn m (2 + i)) \<rightarrow> \<phi>) [0..<n] (\<lambda>m. FIn m (n + 2)))) \<rightarrow>
     foldr (\<lambda>i \<phi>. (\<box>(\<lambda>m. FIn m (2 + i))) \<rightarrow> \<phi>) [0..<n] (\<box>(\<lambda>m. FIn m (n + 2)))) 0)"

definition "Thm1 n = Thm (TYPE(Enum.finite_1)) (n + 1) (\<Psi> n)"
definition "Thm1_slow n = Thm_slow (TYPE(Enum.finite_1)) (n + 1) (\<Psi> n)"
definition "Thm1_dual n = Thm_dual (TYPE(Enum.finite_1)) (n + 1) (\<Psi> n)"

lemma "Thm1_dual 0" by eval
lemma "Thm1_dual 1" by eval
(*
lemma "Thm1 2" by eval
*)

lemma "Thm_dual (TYPE(bool)) 0 \<Phi>0" by eval
lemma "Thm_dual (TYPE(bool * bool)) 0 \<Phi>1" by eval
(*
lemma "Thm (TYPE(bool * bool * bool)) 0 \<Phi>2" by eval
*)

(*
export_code Thm1 Nat in SML module_name WS1S_Thm1 file "WS1S_Thm1.ML"
export_code Thm1_slow Nat in SML module_name WS1S_Thm1_slow file "WS1S_Thm1_slow.ML"
export_code Thm1_dual Nat in SML module_name WS1S_Thm1_dual file "WS1S_Thm1_dual.ML"

ML_file "WS1S_Thm1.ML"
ML_file "WS1S_Thm1_slow.ML"
ML_file "WS1S_Thm1_dual.ML"

ML {* PolyML.timing true; open WS1S_Thm1_dual; thm1_dual (Nat 0); thm1_dual (Nat 1); *}
ML {* PolyML.timing true; open WS1S_Thm1; thm1 (Nat 0); thm1 (Nat 1); *}
ML {* PolyML.timing true; open WS1S_Thm1_slow; thm1_slow (Nat 0); *}
*)

end


(*
Copyright 2009-2014 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

header {* Instances of the Show Class for Standard Types *}

theory Show_Instances
imports
  Show_Generator
  "~~/src/HOL/Rat"
begin

text {*
  For several types, we just derive the show function.
*}

derive "show" bool
derive "show" option
derive "show" sum

text {*
  The derive-command is not used for @{type unit}, @{type prod}, and numbers: for @{type unit} and
  @{type prod}, we do not want to display ``Unity'' and ``Pair''; for @{type nat}, we do not want to
  display ``Suc (Suc ... Suc (0))''; and neither @{type int} nor @{type rat} are datatypes.
*}

instantiation unit :: "show"
begin

definition "shows_prec d (x::unit) = shows_string ''()''"

lemma assoc_unit:
  "shows_prec d (x::unit) r @ s = shows_prec d x (r @ s)"
  by (simp add: shows_prec_unit_def)

standard_shows_list assoc_unit

end

instantiation prod :: ("show", "show") "show"
begin

definition "shows_prec d (p :: 'a \<times> 'b) = shows_paren (shows (fst p) +@+ '','' +#+ shows (snd p))"

lemma assoc_prod:
  "shows_prec d (p::('a::show \<times> 'b::show)) r @ s = shows_prec d p (r @ s)"
  by (cases p) (simp add: shows_prec_prod_def show_defs)

standard_shows_list assoc_prod

end

instantiation nat :: "show"
begin

fun
  digit2string :: "nat \<Rightarrow> string"
where
  "digit2string n = (
    if n = 0 then ''0''
    else if n = 1 then ''1''
    else if n = 2 then ''2''
    else if n = 3 then ''3''
    else if n = 4 then ''4''
    else if n = 5 then ''5''
    else if n = 6 then ''6''
    else if n = 7 then ''7''
    else if n = 8 then ''8''
    else ''9'')"

fun shows_nat :: "nat \<Rightarrow> shows"
where
  "shows_nat (n::nat) = (
    if n < 10 then shows_string (digit2string n)
    else shows_nat (n div 10) \<circ> shows_string (digit2string (n mod 10)))"

definition "shows_prec (d::nat) (n::nat) = shows_nat n"

lemma assoc_nat: "shows_prec d (n::nat) r @ s = shows_prec d n (r @ s)"
proof (induct n arbitrary: r s rule: nat_less_induct)
  case (1 n)
  show ?case
  proof (cases "n < 10")
    case True thus ?thesis unfolding shows_prec_nat_def by simp
  next
    let ?m = "n div 10"
    case False
    hence "?m < n" by simp
    with 1 have "\<And>s t. shows_prec d ?m s @ t = shows_prec d ?m (s @ t)" by simp
    thus ?thesis unfolding shows_prec_nat_def by auto
  qed
qed

standard_shows_list assoc_nat

end

instantiation int :: "show"
begin

definition "shows_prec (d::nat) (i::int) = (
  if i < 0 then shows (CHR ''-'') \<circ> shows (nat (- i))
  else shows (nat i))"

lemma assoc_int:
  "shows_prec d (i::int) r @ s = shows_prec d i (r @ s)"
  by (simp add: shows_prec_int_def)

standard_shows_list assoc_int

end

instantiation rat :: "show"
begin

definition "shows_prec (d::nat) (x::rat) =
  (case quotient_of x of
    Pair den num \<Rightarrow>
    if num = 1 then shows den else shows den \<circ> shows (CHR ''/'') \<circ> shows num)"

lemma assoc_rat:
  "shows_prec d (x::rat) r @ s = shows_prec d x (r @ s)"
  unfolding shows_prec_rat_def by (cases "quotient_of x") auto

standard_shows_list assoc_rat

end

end


(* Title:      Pre-Post Specifications and Modal Operators
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Pre-Post Specifications and Modal Operators\<close>

theory Pre_Post_Modal

imports Pre_Post Hoare_Modal

begin

class pre_post_spec_whiledo = pre_post_spec_greatest + whiledo
begin

lemma nat_test_pre_post:
  "nat_test t s \<Longrightarrow> -q \<le> s \<Longrightarrow> (\<forall>n . x \<le> t n*-p*-q\<stileturn>(pSum t n*-q)) \<Longrightarrow> -p\<star>x \<le> -q\<stileturn>--p*-q"
  by (smt (verit, ccfv_threshold) nat_test_def nat_test_pre pSum_test_nat pre_post_galois tests_dual.sub_sup_closed)

lemma nat_test_pre_post_2:
  "nat_test t s \<Longrightarrow> -r \<le> s \<Longrightarrow> (\<forall>n . x \<le> t n*-p\<stileturn>(pSum t n)) \<Longrightarrow> -p\<star>x \<le> -r\<stileturn>1"
  by (smt (verit, ccfv_threshold) nat_test_def nat_test_pre_2 one_def pSum_test_nat pre_post_galois tests_dual.sub_sup_closed)

end

class pre_post_spec_hoare = pre_post_spec_whiledo + hoare_calculus_sound
begin

lemma pre_post_while:
  "x \<le> -p*-q\<stileturn>-q \<longrightarrow> -p\<star>x \<le> aL*-q\<stileturn>-q"
  by (smt aL_test pre_post_galois sub_mult_closed while_soundness)

text \<open>Theorem 43.1\<close>

lemma while_soundness_3:
  "test_seq t \<Longrightarrow> -q \<le> Sum t \<Longrightarrow> x \<le> t 0*-p*-q\<stileturn>aL*-q \<Longrightarrow> (\<forall>n>0 . x \<le> t n*-p*-q\<stileturn>pSum t n*-q) \<Longrightarrow> -p\<star>x \<le> -q\<stileturn>--p*-q"
  by (smt (verit, del_insts) aL_test pSum_test tests_dual.inf_closed pre_post_galois sub_mult_closed test_seq_def while_soundness_1)

text \<open>Theorem 43.2\<close>

lemma while_soundness_4:
  "test_seq t \<Longrightarrow> -r \<le> Sum t \<Longrightarrow> (\<forall>n . x \<le> t n*-p\<stileturn>pSum t n) \<Longrightarrow> -p\<star>x \<le> -r\<stileturn>1"
  by (smt one_def pSum_test pre_post_galois sub_mult_closed test_seq_def while_soundness_2)

end

class pre_post_spec_hoare_pc_2 = pre_post_spec_hoare + hoare_calculus_pc_2
begin

text \<open>Theorem 43.3\<close>

lemma pre_post_while_pc:
  "x \<le> -p*-q\<stileturn>-q \<longrightarrow> -p\<star>x \<le> -q\<stileturn>--p*-q"
  by (metis pre_post_galois sub_mult_closed while_soundness_pc)

end

class pre_post_spec_hoare_pc = pre_post_spec_hoare + hoare_calculus_pc
begin

subclass pre_post_spec_hoare_pc_2 ..

lemma pre_post_one_one_top:
  "1\<stileturn>1 = top"
  using order.eq_iff pre_one_one pre_post_one_one by auto

end

class pre_post_spec_H = pre_post_spec_greatest + box_precondition + havoc +
  assumes H_zero_2: "H * bot = bot"
  assumes H_split_2: "x \<le> x * -q * top \<squnion> H * --q"
begin

subclass idempotent_left_semiring_H
  apply unfold_locales
  apply (rule H_zero_2)
  by (smt H_split_2 tests_dual.complement_bot mult_assoc mult_left_zero mult_1_right one_def)

lemma pre_post_def_iff:
  "-p * x * --q \<le> Z \<longleftrightarrow> x \<le> Z \<squnion> --p * top \<squnion> H * -q"
proof (rule iffI)
  assume "-p * x * --q \<le> Z"
  hence "x * --q * top \<le> Z \<squnion> --p * top"
    by (smt (verit, ccfv_threshold) Z_left_zero_above_one case_split_left_sup mult_assoc mult_left_isotone mult_right_dist_sup mult_right_isotone top_greatest top_mult_top)
  thus "x \<le> Z \<squnion> --p * top \<squnion> H * -q"
    by (metis sup_left_isotone order_trans H_split_2 tests_dual.double_negation)
next
  assume "x \<le> Z \<squnion> --p * top \<squnion> H * -q"
  hence "-p * x * --q \<le> -p * (Z * --q \<squnion> --p * top * --q \<squnion> H * -q * --q)"
    by (metis mult_left_isotone mult_right_dist_sup mult_right_isotone mult_assoc)
  thus "-p * x * --q \<le> Z"
    by (metis H_zero_2 Z_mult_decreasing sup_commute sup_bot_left mult_assoc mult_right_dist_sup mult_right_isotone order_trans test_mult_left_dist_shunt test_mult_left_sub_dist_shunt tests_dual.top_def)
qed

lemma pre_post_def:
  "-p\<stileturn>-q = Z \<squnion> --p*top \<squnion> H*-q"
  by (meson order.antisym order_refl pre_Z pre_post_galois pre_post_def_iff)

end

class pre_post_L = pre_post_spec_greatest + box_while + left_conway_semiring_L + left_kleene_conway_semiring +
  assumes circ_below_L_add_star: "x\<^sup>\<circ> \<le> L \<squnion> x\<^sup>\<star>"
begin

text \<open>a loop does not abort if its body does not abort\<close>
text \<open>this avoids abortion from all states* alternatively from states in -r if -r is an invariant\<close>

lemma body_abort_loop:
  assumes "Z = L"
      and "x \<le> -p\<stileturn>1"
    shows "-p\<star>x \<le> 1\<stileturn>1"
proof -
  have "-p * x * bot \<le> L"
    by (metis assms pre_Z pre_post_galois tests_dual.sba_dual.one_def tests_dual.top_double_complement)
  hence "(-p * x)\<^sup>\<star> * bot \<le> L"
    by (metis L_split le_iff_sup star_left_induct sup_bot_left)
  hence "(-p * x)\<^sup>\<circ> * bot \<le> L"
    by (smt L_left_zero L_split sup_commute circ_below_L_add_star le_iff_sup mult_right_dist_sup)
  thus ?thesis
    by (metis assms(1) a_restrict mult_isotone pre_pc_Z pre_post_compose_2 pre_post_one_one tests_dual.sba_dual.one_def while_def tests_dual.sup_right_zero)
qed

end

class pre_post_spec_Hd = pre_post_spec_least + diamond_precondition + idempotent_left_semiring_Hd +
  assumes d_mult_top: "d(x) * top = x * top"
begin

subclass pre_post_spec_least_Hd
  apply unfold_locales
  by (simp add: d_mult_top diamond_x_1 pre_def)

end

end