(*<*)
theory QML
imports Relations
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3, atoms e = a b c d]
(*>*)

section \<open>Embedding of Quantified Modal Logic\<close>
text\<open>\noindent{As is well known, the Isabelle proof assistant \<^cite>\<open>"Isabelle"\<close> does not natively support modal logics, so
we have used a technique known as \emph{shallow semantic embedding}, which allows us
to take advantage of the expressive power of higher-order logic in order to embed the semantics
of an object language. We draw on previous work on the embedding of multimodal logics in HOL \<^cite>\<open>"J23"\<close>,
which has successfully been applied to the analysis and verification of ontological arguments
(e.g. \<^cite>\<open>C55 and J32 and J35\<close>).}\<close>

subsection \<open>Type Declarations\<close>

typedecl e                        \<comment> \<open>Type for entities\<close>
typedecl w                        \<comment> \<open>Type for worlds\<close>
type_synonym wo = "w\<Rightarrow>bool" \<comment> \<open>Type for world-dependent formulas\<close>

subsection \<open>Logical Constants as Truth-Sets\<close>
text\<open>\noindent{Using the technique of \emph{shallow semantic embedding} each operator gets defined as a function
on world-dependent formulas or \emph{truth sets}.}\<close>

abbreviation mand::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<^bold>\<and>"(*<*)51(*>*))
  where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<and>(\<psi> w)"
abbreviation mor::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<^bold>\<or>"(*<*)50(*>*))
  where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<or>(\<psi> w)"
abbreviation mimp::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<^bold>\<rightarrow>"(*<*)49(*>*))
  where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<longrightarrow>(\<psi> w)"
abbreviation mequ::"wo\<Rightarrow>wo\<Rightarrow>wo" (infix "\<^bold>\<leftrightarrow>"(*<*)48(*>*))
  where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<longleftrightarrow>(\<psi> w)"
abbreviation mnot::"wo\<Rightarrow>wo" ("\<^bold>\<not>_"(*<*)[52]53(*>*))
  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>(\<phi> w)"
(*<*)
abbreviation xor:: "bool\<Rightarrow>bool\<Rightarrow>bool" (infix"\<oplus>"50) where "\<phi>\<oplus>\<psi> \<equiv>  (\<phi>\<or>\<psi>) \<and> \<not>(\<phi>\<and>\<psi>)"
abbreviation mxor::"wo\<Rightarrow>wo\<Rightarrow>wo" (infix"\<^bold>\<oplus>"50) where "\<phi>\<^bold>\<oplus>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<oplus>(\<psi> w)"
(*>*)

text\<open>\noindent{We embed a modal logic \emph{K} by defining the box and diamond operators using restricted quantification
over the set of `accessible' worlds (using an \emph{accessibility} relation \emph{R} as a guard).}\<close>

consts R::"w\<Rightarrow>w\<Rightarrow>bool" (infix "r"(*<*)70(*>*)) \<comment> \<open>Accessibility relation\<close>
abbreviation mbox :: "wo\<Rightarrow>wo" ("\<^bold>\<box>_"(*<*)[52]53(*>*))
  where "\<^bold>\<box>\<phi> \<equiv> \<lambda>w.\<forall>v. (w r v)\<longrightarrow>(\<phi> v)"
abbreviation mdia :: "wo\<Rightarrow>wo" ("\<^bold>\<diamond>_"(*<*)[52]53(*>*))
  where "\<^bold>\<diamond>\<phi> \<equiv> \<lambda>w.\<exists>v. (w r v)\<and>(\<phi> v)"

subsection \<open>Quantification\<close>
text\<open>\noindent{Quantifiers are defined analogously.}\<close>

abbreviation mforall::"('t\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<forall>")
  where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
abbreviation mexists::"('t\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<exists>")
  where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
abbreviation mforallB  :: "('t\<Rightarrow>wo)\<Rightarrow>wo" (binder "\<^bold>\<forall>"(*<*)[8]9(*>*))
  where "\<^bold>\<forall>x. (\<phi> x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation mexistsB  :: "('t\<Rightarrow>wo)\<Rightarrow>wo" (binder "\<^bold>\<exists>"(*<*)[8]9(*>*))
  where "\<^bold>\<exists>x. (\<phi> x) \<equiv> \<^bold>\<exists>\<phi>"

subsection \<open>Equality\<close>
text\<open>\noindent{Two different definitions of equality are given. The first one is an extension of standard
equality for use in world-dependent formulas. The second is the well-known Leibniz equality.}\<close>
abbreviation meq:: "'t\<Rightarrow>'t\<Rightarrow>wo" (infix "\<^bold>\<approx>"(*<*)60(*>*))
  where "x \<^bold>\<approx> y \<equiv> \<lambda>w. x = y"
abbreviation meqL:: "e\<Rightarrow>e\<Rightarrow>wo" (infix "\<^bold>\<approx>\<^sup>L"(*<*)52(*>*))
  where "x \<^bold>\<approx>\<^sup>L y \<equiv> \<lambda>w. \<forall>\<phi>. (\<phi> x w)\<longrightarrow>(\<phi> y w)"

subsection \<open>Validity\<close>
text\<open>\noindent{Validity is defined as truth in \emph{all} worlds and represented by wrapping the formula
in special brackets (\<open>\<lfloor>-\<rfloor>\<close>).}\<close>
abbreviation valid::"wo\<Rightarrow>bool" ("\<lfloor>_\<rfloor>") where "\<lfloor>\<psi>\<rfloor> \<equiv>  \<forall>w.(\<psi> w)"

subsection \<open>Verifying the Embedding\<close>
text\<open>\noindent{The above definitions introduce modal logic \emph{K} with quantification,
as evidenced by the following tests.}\<close>

text\<open>\noindent{(Converse-)Barcan formulas are validated in this embedding.}\<close>
lemma "\<lfloor>(\<^bold>\<forall>x.\<^bold>\<box>(\<phi> x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x.(\<phi> x))\<rfloor>" by simp
lemma "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>x.(\<phi> x)) \<^bold>\<rightarrow> (\<^bold>\<forall>x.\<^bold>\<box>(\<phi> x))\<rfloor>" by simp

text\<open>\noindent{\<open>\<beta>\<close>-redex is valid.}\<close>
lemma "\<lfloor>(\<lambda>\<alpha>. \<phi> \<alpha>) (\<tau>::w\<Rightarrow>e) \<^bold>\<leftrightarrow> (\<phi>  \<tau>)\<rfloor>" by simp
lemma "\<lfloor>(\<lambda>\<alpha>. \<phi> \<alpha>) (\<tau>::e) \<^bold>\<leftrightarrow> (\<phi>  \<tau>)\<rfloor>" by simp
lemma "\<lfloor>(\<lambda>\<alpha>. \<^bold>\<box>\<phi> \<alpha>) (\<tau>::w\<Rightarrow>e) \<^bold>\<leftrightarrow> (\<^bold>\<box>\<phi> \<tau>)\<rfloor>" by simp
lemma "\<lfloor>(\<lambda>\<alpha>. \<^bold>\<box>\<phi> \<alpha>) (\<tau>::e) \<^bold>\<leftrightarrow> (\<^bold>\<box>\<phi> \<tau>)\<rfloor>" by simp

text\<open>\noindent{Modal collapse is countersatisfiable, as shown by Nitpick \<^cite>\<open>"Nitpick"\<close>.}\<close>
lemma "\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<phi>\<rfloor>" nitpick oops

subsection \<open>Axiomatization of Further Logics\<close>

text\<open>\noindent{The best-known normal logics (\emph{K4, K5, KB, K45, KB5, D, D4, D5, ...}) can be obtained by
combinations of the following axioms.}\<close>
abbreviation T  where "T \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<phi>"
abbreviation B  where "B \<equiv> \<^bold>\<forall>\<phi>. \<phi> \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<diamond>\<phi>"
abbreviation D  where "D \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<diamond>\<phi>"
abbreviation IV where "IV \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<box>\<phi> \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<box>\<phi>"
abbreviation V  where "V \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<diamond>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<diamond>\<phi>"

text\<open>\noindent{Instead of postulating combinations of the above  axioms we make use of
the well-known \emph{Sahlqvist correspondence}, which links axioms to constraints on a model's accessibility
relation (cf. \<^cite>\<open>"J23"\<close> for further details).
We show  that  reflexivity, symmetry, seriality, transitivity and euclideanness imply
axioms \emph{T, B, D, IV, V} respectively.\footnote{Implication can also be proven in the reverse direction
(which is not needed for our purposes).
Using these definitions, we can derive axioms for the most common modal logics (see also \<^cite>\<open>"C47"\<close>).
Thereby we are free to use either the semantic constraints or the related \emph{Sahlqvist} axioms. Here we provide
both versions. In what follows we use the semantic constraints for improved performance.}}\<close>
lemma "reflexive R  \<Longrightarrow>  \<lfloor>T\<rfloor>" by blast
lemma "symmetric R \<Longrightarrow> \<lfloor>B\<rfloor>" by blast
lemma "serial R  \<Longrightarrow> \<lfloor>D\<rfloor>" by blast
lemma "transitive R  \<Longrightarrow> \<lfloor>IV\<rfloor>" by blast
lemma "euclidean R \<Longrightarrow> \<lfloor>V\<rfloor>" by blast
lemma "preorder R \<Longrightarrow> \<lfloor>T\<rfloor> \<and> \<lfloor>IV\<rfloor>" by blast \<comment> \<open>S4: reflexive + transitive\<close>
lemma "equivalence R \<Longrightarrow> \<lfloor>T\<rfloor> \<and> \<lfloor>V\<rfloor>" by blast \<comment> \<open>S5: preorder + symmetric\<close>
(*<*)
end
(*>*)


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_12
  imports "../../Test_Base"
begin

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

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

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

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

theorem property0 :
  "((qrev y z) = (x (rev y) z))"
  oops

end


theory int_right_distrib
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Sign = Pos | Neg

datatype Nat = Zero | Succ "Nat"

datatype Z = P "Nat" | N "Nat"

fun toInteger :: "Sign => Nat => Z" where
"toInteger (Pos) y = P y"
| "toInteger (Neg) (Zero) = P Zero"
| "toInteger (Neg) (Succ m) = N m"

fun sign2 :: "Z => Sign" where
"sign2 (P y) = Pos"
| "sign2 (N z) = Neg"

fun plus2 :: "Nat => Nat => Nat" where
"plus2 (Zero) y = y"
| "plus2 (Succ n) y = Succ (plus2 n y)"

fun opposite :: "Sign => Sign" where
"opposite (Pos) = Neg"
| "opposite (Neg) = Pos"

fun timesSign :: "Sign => Sign => Sign" where
"timesSign (Pos) y = y"
| "timesSign (Neg) y = opposite y"

fun mult :: "Nat => Nat => Nat" where
"mult (Zero) y = Zero"
| "mult (Succ n) y = plus2 y (mult n y)"

fun minus :: "Nat => Nat => Z" where
"minus (Zero) (Zero) = P Zero"
| "minus (Zero) (Succ n) = N n"
| "minus (Succ m) (Zero) = P (Succ m)"
| "minus (Succ m) (Succ o) = minus m o"

fun plus :: "Z => Z => Z" where
"plus (P m) (P n) = P (plus2 m n)"
| "plus (P m) (N o) = minus m (Succ o)"
| "plus (N m2) (P n2) = minus n2 (Succ m2)"
| "plus (N m2) (N n3) = N (Succ (plus2 m2 n3))"

fun absVal :: "Z => Nat" where
"absVal (P n) = n"
| "absVal (N m) = Succ m"

fun times :: "Z => Z => Z" where
"times x y =
   toInteger
     (timesSign (sign2 x) (sign2 y)) (mult (absVal x) (absVal y))"

(*hipster toInteger
          sign2
          plus2
          opposite
          timesSign
          mult
          minus
          plus
          absVal
          times *)

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

end


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

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

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

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

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

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

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

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

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

function stooge2sort2 :: "int list => int list"
         and stoogesort2 :: "int list => int list"
         and stooge2sort1 :: "int list => int list" where
"stooge2sort2 y =
   (case splitAt ((op div) ((2 * (length y)) + 1) 3) y of
      pair2 ys2 zs1 => x (stoogesort2 ys2) zs1)"
| "stoogesort2 (nil2) = nil2"
| "stoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge2sort1 y =
     (case splitAt ((op div) (length y) 3) y of
        pair2 ys2 zs1 => x ys2 (stoogesort2 zs1))"
by pat_completeness auto

fun count :: "'a => 'a list => int" where
"count y (nil2) = 0"
| "count y (cons2 z2 ys) =
     (if (y = z2) then 1 + (count y ys) else count y ys)"

theorem property0 :
  "((count y (stoogesort2 xs)) = (count y xs))"
  oops

end


(* Title:      Hoare Calculus
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Hoare Calculus\<close>

theory Hoare

imports Complete_Tests Preconditions

begin

class ite =
  fixes ite :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("_ \<lhd> _ \<rhd> _" [58,58,58] 57)

class hoare_triple =
  fixes hoare_triple :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<lbrace> _ \<rbrace> _" [54,54,54] 53)

class ifthenelse = precondition + ite +
  assumes ite_pre: "x\<lhd>-p\<rhd>y\<guillemotleft>-q = -p*(x\<guillemotleft>-q) \<squnion> --p*(y\<guillemotleft>-q)"
begin

text \<open>Theorem 40.2\<close>

lemma ite_pre_then:
  "-p*(x\<lhd>-p\<rhd>y\<guillemotleft>-q) = -p*(x\<guillemotleft>-q)"
proof -
  have "-p*(x\<lhd>-p\<rhd>y\<guillemotleft>-q) = -p*(x\<guillemotleft>-q) \<squnion> bot*(y\<guillemotleft>-q)"
    by (smt (z3) ite_pre pre_closed tests_dual.sba_dual.sup_right_unit tests_dual.sub_commutative tests_dual.sup_left_zero tests_dual.sup_right_dist_inf tests_dual.top_double_complement tests_dual.wnf_lemma_1)
  thus ?thesis
    by (metis pre_closed tests_dual.sba_dual.sup_right_unit tests_dual.sub_sup_closed tests_dual.sup_left_zero)
qed

text \<open>Theorem 40.3\<close>

lemma ite_pre_else:
  "--p*(x\<lhd>-p\<rhd>y\<guillemotleft>-q) = --p*(y\<guillemotleft>-q)"
proof -
  have "--p*(x\<lhd>-p\<rhd>y\<guillemotleft>-q) = bot*(x\<guillemotleft>-q) \<squnion> --p*(y\<guillemotleft>-q)"
    by (smt (z3) ite_pre pre_closed tests_dual.sub_commutative tests_dual.sub_inf_left_zero tests_dual.sup_left_zero tests_dual.sup_right_dist_inf tests_dual.top_double_complement tests_dual.wnf_lemma_3)
  thus ?thesis
    by (metis pre_closed tests_dual.sba_dual.sub_sup_demorgan tests_dual.sub_inf_left_zero tests_dual.sup_left_zero)
qed

lemma ite_import_mult_then:
  "-p*-q \<le> x\<guillemotleft>-r \<Longrightarrow> -p*-q \<le> x\<lhd>-p\<rhd>y\<guillemotleft>-r"
  by (smt ite_pre_then leq_def pre_closed sub_assoc sub_comm sub_mult_closed)

lemma ite_import_mult_else:
  "--p*-q \<le> y\<guillemotleft>-r \<Longrightarrow> --p*-q \<le> x\<lhd>-p\<rhd>y\<guillemotleft>-r"
  by (smt ite_pre_else leq_def pre_closed sub_assoc sub_comm sub_mult_closed)

text \<open>Theorem 40.1\<close>

lemma ite_import_mult:
  "-p*-q \<le> x\<guillemotleft>-r \<Longrightarrow> --p*-q \<le> y\<guillemotleft>-r \<Longrightarrow> -q \<le> x\<lhd>-p\<rhd>y\<guillemotleft>-r"
  by (smt (verit) ite_import_mult_else ite_import_mult_then pre_closed tests_dual.sba_dual.inf_less_eq_cases)

end

class whiledo = ifthenelse + while +
  assumes while_pre: "-p\<star>x\<guillemotleft>-q = -p*(x\<guillemotleft>-p\<star>x\<guillemotleft>-q) \<squnion> --p*-q"
  assumes while_post: "-p\<star>x\<guillemotleft>-q = -p\<star>x\<guillemotleft>--p*-q"
begin

text \<open>Theorem 40.4\<close>

lemma while_pre_then:
  "-p*(-p\<star>x\<guillemotleft>-q) = -p*(x\<guillemotleft>-p\<star>x\<guillemotleft>-q)"
  by (smt pre_closed tests_dual.sub_commutative while_pre tests_dual.wnf_lemma_1)

text \<open>Theorem 40.5\<close>

lemma while_pre_else:
  "--p*(-p\<star>x\<guillemotleft>-q) = --p*-q"
  by (smt pre_closed tests_dual.sub_commutative while_pre tests_dual.wnf_lemma_3)

text \<open>Theorem 40.6\<close>

lemma while_pre_sub_1:
  "-p\<star>x\<guillemotleft>-q \<le> x*(-p\<star>x)\<lhd>-p\<rhd>1\<guillemotleft>-q"
  by (smt (z3) ite_import_mult pre_closed pre_one_increasing pre_seq tests_dual.sba_dual.transitive tests_dual.sub_sup_closed tests_dual.upper_bound_right while_pre_else while_pre_then)

text \<open>Theorem 40.7\<close>

lemma while_pre_sub_2:
  "-p\<star>x\<guillemotleft>-q \<le> x\<lhd>-p\<rhd>1\<guillemotleft>-p\<star>x\<guillemotleft>-q"
  by (smt (z3) ite_import_mult pre_closed pre_one_increasing tests_dual.sba_dual.transitive tests_dual.sub_sup_closed tests_dual.upper_bound_right while_pre_then)

text \<open>Theorem 40.8\<close>

lemma while_pre_compl:
  "--p \<le> -p\<star>x\<guillemotleft>--p"
  by (metis pre_closed tests_dual.sup_idempotent tests_dual.upper_bound_right while_pre_else)

lemma while_pre_compl_one:
  "--p \<le> -p\<star>x\<guillemotleft>1"
  by (metis tests_dual.sba_dual.top_double_complement while_post tests_dual.sup_right_unit while_pre_compl)

text \<open>Theorem 40.10\<close>

lemma while_export_equiv:
  "-q \<le> -p\<star>x\<guillemotleft>1 \<longleftrightarrow> -p*-q \<le> -p\<star>x\<guillemotleft>1"
  by (smt pre_closed tests_dual.sba_dual.shunting tests_dual.sba_dual.sub_less_eq_def tests_dual.sba_dual.top_double_complement while_pre_compl_one)

lemma nat_test_pre:
  assumes "nat_test t s"
      and "-q \<le> s"
      and "\<forall>n . t n*-p*-q \<le> x\<guillemotleft>pSum t n*-q"
    shows "-q \<le> -p\<star>x\<guillemotleft>--p*-q"
proof -
  have 1: "-q*--p \<le> -p\<star>x\<guillemotleft>--p*-q"
    by (metis pre_closed tests_dual.sub_commutative while_post tests_dual.upper_bound_right while_pre_else)
  have "\<forall>n . t n*-p*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
  proof
    fix n
    show "t n*-p*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
    proof (induct n rule: nat_less_induct)
      fix n
      have 2: "t n = --(t n)"
        using assms(1) nat_test_def by auto
      assume "\<forall>m<n . t m*-p*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
      hence "\<forall>m<n . t m*-p*-q \<squnion> t m*--p*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
        using 1 by (smt (verit, del_insts) assms(1) tests_dual.greatest_lower_bound leq_def nat_test_def pre_closed tests_dual.sub_associative tests_dual.sub_commutative sub_mult_closed)
      hence "\<forall>m<n . t m*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
        by (smt (verit, del_insts) assms(1) tests_dual.sup_right_unit tests_dual.sup_left_dist_inf tests_dual.sup_right_dist_inf nat_test_def tests_dual.inf_complement sub_mult_closed)
      hence "pSum t n*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
        by (smt assms(1) pSum_below_nat pre_closed sub_mult_closed)
      hence "t n*-p*-q*(-p\<star>x\<guillemotleft>--p*-q) = t n*-p*-q"
        using 2 by (smt assms(1,3) leq_def pSum_test_nat pre_closed pre_sub_distr sub_assoc sub_comm sub_mult_closed transitive while_pre_then)
      thus "t n*-p*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
        using 2 by (smt (z3) pre_closed tests_dual.sub_sup_closed tests_dual.upper_bound_right)
    qed
  qed
  hence "-q*-p \<le> -p\<star>x\<guillemotleft>--p*-q"
    by (smt (verit, del_insts) assms(1,2) leq_def nat_test_def pre_closed tests_dual.sub_associative tests_dual.sub_commutative sub_mult_closed)
  thus ?thesis
    using 1 by (smt (z3) pre_closed tests_dual.sba_dual.inf_less_eq_cases tests_dual.sub_commutative tests_dual.sub_sup_closed)
qed

lemma nat_test_pre_1:
  assumes "nat_test t s"
      and "-r \<le> s"
      and "-r \<le> -q"
      and "\<forall>n . t n*-p*-q \<le> x\<guillemotleft>pSum t n*-q"
    shows "-r \<le> -p\<star>x\<guillemotleft>--p*-q"
proof -
  let ?qs = "-q*s"
  have 1: "-r \<le> ?qs"
    by (metis assms(1-3) nat_test_def tests_dual.least_upper_bound)
  have "\<forall>n . t n*-p*?qs \<le> x\<guillemotleft>pSum t n*?qs"
  proof
    fix n
    have 2: "pSum t n \<le> s"
      by (simp add: assms(1) pSum_below_sum)
    have "t n = t n * s"
      by (metis assms(1) nat_test_def tests_dual.sba_dual.less_eq_inf)
    hence "t n*-p*?qs = t n*-p*-q"
      by (smt (verit, ccfv_threshold) assms(1) nat_test_def tests_dual.sub_sup_closed tests_dual.sub_associative tests_dual.sub_commutative)
    also have "t n*-p*-q \<le> x\<guillemotleft>pSum t n*-q"
      by (simp add: assms(4))
    also have "x\<guillemotleft>pSum t n*-q = x\<guillemotleft>pSum t n*?qs"
      using 2 by (smt (verit, ccfv_SIG) assms(1) leq_def nat_test_def pSum_test_nat tests_dual.sub_associative tests_dual.sub_commutative)
    finally show "t n*-p*?qs \<le> x\<guillemotleft>pSum t n*?qs"
      .
  qed
  hence 3: "?qs \<le> -p\<star>x\<guillemotleft>--p*?qs"
    by (smt (verit, ccfv_threshold) assms(1) tests_dual.upper_bound_left tests_dual.upper_bound_right nat_test_def nat_test_pre pSum_test_nat pre_closed tests_dual.sub_associative sub_mult_closed transitive)
  have "-p\<star>x\<guillemotleft>--p*?qs \<le> -p\<star>x\<guillemotleft>--p*-q"
    by (metis assms(1) nat_test_def pre_lower_bound_left tests_dual.sub_sup_closed while_post)
  thus ?thesis
    using 1 3 by (smt (verit, del_insts) leq_def tests_dual.sub_associative assms(1) nat_test_def pre_closed sub_mult_closed)
qed

lemma nat_test_pre_2:
  assumes "nat_test t s"
      and "-r \<le> s"
      and "\<forall>n . t n*-p \<le> x\<guillemotleft>pSum t n"
    shows "-r \<le> -p\<star>x\<guillemotleft>1"
proof -
  have 1: "-r \<le> -p\<star>x\<guillemotleft>--p*s"
    by (smt (verit, ccfv_threshold) assms leq_def nat_test_def nat_test_pre_1 pSum_below_sum pSum_test_nat tests_dual.sub_associative tests_dual.sub_commutative)
  have "-p\<star>x\<guillemotleft>--p*s \<le> -p\<star>x\<guillemotleft>1"
    by (metis assms(1) nat_test_def pre_below_pre_one while_post)
  thus ?thesis
    using 1 by (smt (verit) assms(1) nat_test_def pre_closed tests_dual.sba_dual.top_double_complement while_post tests_dual.transitive)
qed

lemma nat_test_pre_3:
  assumes "nat_test t s"
      and "-q \<le> s"
      and "\<forall>n . t n*-p*-q \<le> x\<guillemotleft>pSum t n*-q"
    shows "-q \<le> -p\<star>x\<guillemotleft>1"
proof -
  have "-p\<star>x\<guillemotleft>--p*-q \<le> -p\<star>x\<guillemotleft>1"
    by (metis pre_below_pre_one sub_mult_closed)
  thus ?thesis
    by (smt (verit, ccfv_threshold) assms pre_closed tests_dual.sba_dual.top_double_complement tests_dual.sba_dual.transitive tests_dual.sub_sup_closed nat_test_pre)
qed

definition aL :: "'a"
  where "aL \<equiv> 1\<star>1\<guillemotleft>1"

lemma aL_test:
  "aL = --aL"
  by (metis aL_def one_def pre_closed)

end

class atoms = tests +
  fixes Atomic_program :: "'a set"
  fixes Atomic_test :: "'a set"
  assumes one_atomic_program: "1 \<in> Atomic_program"
  assumes zero_atomic_test: "bot \<in> Atomic_test"
  assumes atomic_test_test: "p \<in> Atomic_test \<longrightarrow> p = --p"

class while_program = whiledo + atoms + power
begin

inductive_set Test_expression :: "'a set"
  where atom_test: "p \<in> Atomic_test \<Longrightarrow> p \<in> Test_expression"
      | neg_test:  "p \<in> Test_expression \<Longrightarrow> -p \<in> Test_expression"
      | conj_test: "p \<in> Test_expression \<Longrightarrow> q \<in> Test_expression \<Longrightarrow> p*q \<in> Test_expression"

lemma test_expression_test:
  "p \<in> Test_expression \<Longrightarrow> p = --p"
  apply (induct rule: Test_expression.induct)
  apply (simp add: atomic_test_test)
  apply simp
  by (metis tests_dual.sub_sup_closed)

lemma disj_test:
  "p \<in> Test_expression \<Longrightarrow> q \<in> Test_expression \<Longrightarrow> p\<squnion>q \<in> Test_expression"
  by (smt conj_test neg_test tests_dual.sub_inf_def test_expression_test)

lemma zero_test_expression:
  "bot \<in> Test_expression"
  by (simp add: Test_expression.atom_test zero_atomic_test)

lemma one_test_expression:
  "1 \<in> Test_expression"
  using Test_expression.simps tests_dual.sba_dual.one_def zero_test_expression by blast

lemma pSum_test_expression:
  "(\<forall>n . t n \<in> Test_expression) \<Longrightarrow> pSum t m \<in> Test_expression"
  apply (induct m)
  apply (simp add: zero_test_expression)
  by (simp add: disj_test)

inductive_set While_program :: "'a set"
  where atom_prog:  "x \<in> Atomic_program \<Longrightarrow> x \<in> While_program"
      | seq_prog:   "x \<in> While_program \<Longrightarrow> y \<in> While_program \<Longrightarrow> x*y \<in> While_program"
      | cond_prog:  "p \<in> Test_expression \<Longrightarrow> x \<in> While_program \<Longrightarrow> y \<in> While_program \<Longrightarrow> x\<lhd>p\<rhd>y \<in> While_program"
      | while_prog: "p \<in> Test_expression \<Longrightarrow> x \<in> While_program \<Longrightarrow> p\<star>x \<in> While_program"

lemma one_while_program:
  "1 \<in> While_program"
  by (simp add: While_program.atom_prog one_atomic_program)

lemma power_while_program:
  "x \<in> While_program \<Longrightarrow> x^m \<in> While_program"
  apply (induct m)
  apply (simp add: one_while_program)
  by (simp add: While_program.seq_prog)

inductive_set Pre_expression :: "'a set"
  where test_pre: "p \<in> Test_expression \<Longrightarrow> p \<in> Pre_expression"
      | neg_pre:  "p \<in> Pre_expression \<Longrightarrow> -p \<in> Pre_expression"
      | conj_pre: "p \<in> Pre_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> p*q \<in> Pre_expression"
      | pre_pre:  "p \<in> Pre_expression \<Longrightarrow> x \<in> While_program \<Longrightarrow> x\<guillemotleft>p \<in> Pre_expression"

lemma pre_expression_test:
  "p \<in> Pre_expression \<Longrightarrow> p = --p"
  apply (induct rule: Pre_expression.induct)
  apply (simp add: test_expression_test)
  apply simp
  apply (metis sub_mult_closed)
  by (metis pre_closed)

lemma disj_pre:
  "p \<in> Pre_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> p\<squnion>q \<in> Pre_expression"
  by (smt conj_pre neg_pre tests_dual.sub_inf_def pre_expression_test)

lemma zero_pre_expression:
  "bot \<in> Pre_expression"
  by (simp add: Pre_expression.test_pre zero_test_expression)

lemma one_pre_expression:
  "1 \<in> Pre_expression"
  by (simp add: Pre_expression.test_pre one_test_expression)

lemma pSum_pre_expression:
  "(\<forall>n . t n \<in> Pre_expression) \<Longrightarrow> pSum t m \<in> Pre_expression"
  apply (induct m)
  apply (simp add: zero_pre_expression)
  by (simp add: disj_pre)

lemma aL_pre_expression:
  "aL \<in> Pre_expression"
  by (simp add: Pre_expression.pre_pre While_program.while_prog aL_def one_pre_expression one_test_expression one_while_program)

end

class hoare_calculus = while_program + complete_tests
begin

definition tfun :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "tfun p x q r \<equiv> p \<squnion> (x\<guillemotleft>q*r)"

lemma tfun_test:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> r = --r \<Longrightarrow> tfun p x q r = --tfun p x q r"
  by (smt tfun_def sub_mult_closed pre_closed tests_dual.inf_closed)

lemma tfun_pre_expression:
  "x \<in> While_program \<Longrightarrow> p \<in> Pre_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> r \<in> Pre_expression \<Longrightarrow> tfun p x q r \<in> Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.pre_pre disj_pre tfun_def)

lemma tfun_iso:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> r = --r \<Longrightarrow> s = --s \<Longrightarrow> r \<le> s \<Longrightarrow> tfun p x q r \<le> tfun p x q s"
  by (smt tfun_def tests_dual.sub_sup_right_isotone pre_iso sub_mult_closed tests_dual.sub_inf_right_isotone pre_closed)

definition tseq :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"
  where "tseq p x q r m \<equiv> (tfun p x q ^ m) r"

lemma tseq_test:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> r = --r \<Longrightarrow> tseq p x q r m = --tseq p x q r m"
  apply (induct m)
  apply (smt tseq_def tfun_test power_zero_id id_def)
  by (metis tseq_def tfun_test power_succ_unfold_ext)

lemma tseq_test_seq:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> r = --r \<Longrightarrow> test_seq (tseq p x q r)"
  using test_seq_def tseq_test by auto

lemma tseq_pre_expression:
  "x \<in> While_program \<Longrightarrow> p \<in> Pre_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> r \<in> Pre_expression \<Longrightarrow> tseq p x q r m \<in> Pre_expression"
  apply (induct m)
  apply (smt tseq_def id_def power_zero_id)
  by (smt tseq_def power_succ_unfold_ext tfun_pre_expression)

definition tsum :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "tsum p x q r \<equiv> Sum (tseq p x q r)"

lemma tsum_test:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> r = --r \<Longrightarrow> tsum p x q r = --tsum p x q r"
  using Sum_test tseq_test_seq tsum_def by auto

lemma t_fun_test:
  "q = --q \<Longrightarrow> tfun (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) = --tfun (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL))"
  by (metis aL_test pre_closed tests_dual.sba_dual.double_negation tfun_def tfun_test)

lemma t_fun_pre_expression:
  "x \<in> While_program \<Longrightarrow> p \<in> Test_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> tfun (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) \<in> Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tfun_pre_expression)

lemma t_seq_test:
  "q = --q \<Longrightarrow> tseq (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) m = --tseq (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) m"
  by (metis aL_test pre_closed tests_dual.sba_dual.double_negation tfun_def tfun_test tseq_test)

lemma t_seq_test_seq:
  "q = --q \<Longrightarrow> test_seq (tseq (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)))"
  using test_seq_def t_seq_test by auto

lemma t_seq_pre_expression:
  "x \<in> While_program \<Longrightarrow> p \<in> Test_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> tseq (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) m \<in> Pre_expression"
  using Pre_expression.pre_pre Pre_expression.test_pre Test_expression.neg_test While_program.while_prog aL_pre_expression tfun_def tfun_pre_expression tseq_pre_expression by auto

lemma t_sum_test:
  "q = --q \<Longrightarrow> tsum (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) = --tsum (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL))"
  using Sum_test t_seq_test_seq tsum_def by auto

definition tfun2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "tfun2 p q x r s \<equiv> p \<squnion> q*(x\<guillemotleft>r*s)"

lemma tfun2_test:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> r = --r \<Longrightarrow> s = --s \<Longrightarrow> tfun2 p q x r s = --tfun2 p q x r s"
  by (smt tfun2_def sub_mult_closed pre_closed tests_dual.inf_closed)

lemma tfun2_pre_expression:
  "x \<in> While_program \<Longrightarrow> p \<in> Pre_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> r \<in> Pre_expression \<Longrightarrow> s \<in> Pre_expression \<Longrightarrow> tfun2 p q x r s \<in> Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.pre_pre disj_pre tfun2_def)

lemma tfun2_iso:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> r = --r \<Longrightarrow> s1 = --s1 \<Longrightarrow> s2 = --s2 \<Longrightarrow> s1 \<le> s2 \<Longrightarrow> tfun2 p q x r s1 \<le> tfun2 p q x r s2"
  by (smt tfun2_def tests_dual.sub_inf_right_isotone pre_iso sub_mult_closed tests_dual.sub_sup_right_isotone pre_closed)

definition tseq2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"
  where "tseq2 p q x r s m \<equiv> (tfun2 p q x r ^ m) s"

lemma tseq2_test:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> r = --r \<Longrightarrow> s = --s \<Longrightarrow> tseq2 p q x r s m = --tseq2 p q x r s m"
  apply (induct m)
  apply (smt tseq2_def power_zero_id id_def)
  by (smt tseq2_def tfun2_test power_succ_unfold_ext)

lemma tseq2_test_seq:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> r = --r \<Longrightarrow> s = --s \<Longrightarrow> test_seq (tseq2 p q x r s)"
  using test_seq_def tseq2_test by force

lemma tseq2_pre_expression:
  "x \<in> While_program \<Longrightarrow> p \<in> Pre_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> r \<in> Pre_expression \<Longrightarrow> s \<in> Pre_expression \<Longrightarrow> tseq2 p q x r s m \<in> Pre_expression"
  apply (induct m)
  apply (smt tseq2_def id_def power_zero_id)
  by (smt tseq2_def power_succ_unfold_ext tfun2_pre_expression)

definition tsum2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "tsum2 p q x r s \<equiv> Sum (tseq2 p q x r s)"

lemma tsum2_test:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> r = --r \<Longrightarrow> s = --s \<Longrightarrow> tsum2 p q x r s = --tsum2 p q x r s"
  using Sum_test tseq2_test_seq tsum2_def by force

lemma t_fun2_test:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> tfun2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) = --tfun2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL))"
  by (smt (z3) aL_test pre_closed tests_dual.sub_sup_closed tfun2_def tfun2_test)

lemma t_fun2_pre_expression:
  "x \<in> While_program \<Longrightarrow> p \<in> Test_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> tfun2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) \<in> Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tfun2_pre_expression)

lemma t_seq2_test:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) m = --tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) m"
  by (smt (z3) aL_test pre_closed tests_dual.sub_sup_closed tfun2_def tfun2_test tseq2_test)

lemma t_seq2_test_seq:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> test_seq (tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)))"
  using test_seq_def t_seq2_test by auto

lemma t_seq2_pre_expression:
  "x \<in> While_program \<Longrightarrow> p \<in> Test_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) m \<in> Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tseq2_pre_expression)

lemma t_sum2_test:
  "p = --p \<Longrightarrow> q = --q \<Longrightarrow> tsum2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) = --tsum2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL))"
  using Sum_test t_seq2_test_seq tsum2_def by auto

lemma t_seq2_below_t_seq:
  assumes "p \<in> Test_expression"
      and "q \<in> Pre_expression"
    shows "tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) m \<le> tseq (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) m"
proof -
  let ?t2 = "tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL))"
  let ?t = "tseq (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL))"
  show "?thesis"
  proof (induct m)
    case 0
    show "?t2 0 \<le> ?t 0"
      by (smt assms aL_test id_def tests_dual.upper_bound_left tests_dual.upper_bound_right tests_dual.inf_isotone power_zero_id pre_closed pre_expression_test sub_mult_closed test_pre tseq2_def tseq_def)
  next
    fix m
    assume "?t2 m \<le> ?t m"
    hence 1: "?t2 (Suc m) \<le> tfun2 (- p * q) p x (p \<star> x \<guillemotleft> q) (?t m)"
      by (smt assms power_succ_unfold_ext pre_closed pre_expression_test sub_mult_closed t_seq2_test t_seq_test test_pre tfun2_iso tseq2_def)
    have "... \<le> ?t (Suc m)"
      by (smt assms tests_dual.upper_bound_left tests_dual.upper_bound_right tests_dual.inf_isotone power_succ_unfold_ext pre_closed pre_expression_test sub_mult_closed t_seq_test test_pre tfun2_def tfun_def tseq_def)
    thus "?t2 (Suc m) \<le> ?t (Suc m)"
      using 1 by (smt (verit, del_insts) assms pre_closed pre_expression_test test_expression_test tests_dual.sba_dual.transitive tests_dual.sub_sup_closed t_seq2_test t_seq_test tfun2_test)
  qed
qed

lemma t_seq2_below_t_sum:
  "p \<in> Test_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> x \<in> While_program \<Longrightarrow> tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) m \<le> tsum (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL))"
   by (smt (verit, del_insts) Sum_upper pre_expression_test t_seq2_below_t_seq t_seq2_test t_seq_test t_sum_test test_pre test_seq_def tsum_def leq_def tests_dual.sub_associative)

lemma t_sum2_below_t_sum:
  "p \<in> Test_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> x \<in> While_program \<Longrightarrow> tsum2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) \<le> tsum (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL))"
  by (smt Sum_least pre_expression_test t_seq2_below_t_sum t_seq2_test t_sum_test test_pre test_seq_def tsum2_def)

lemma t_seq2_below_w:
  "p \<in> Test_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> x \<in> While_program \<Longrightarrow> tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) m \<le> p\<star>x\<guillemotleft>q"
  apply (cases m)
  apply (smt aL_test id_def tests_dual.upper_bound_left tests_dual.sub_sup_right_isotone tests_dual.inf_commutative tests_dual.sub_inf_right_isotone power_zero_id pre_closed pre_expression_test pre_iso sub_mult_closed test_pre tseq2_def while_pre)
  by (smt tseq2_def power_succ_unfold_ext tests_dual.upper_bound_left tests_dual.sub_sup_right_isotone tests_dual.inf_commutative tests_dual.sub_inf_right_isotone pre_closed pre_expression_test pre_iso sub_mult_closed t_seq2_test test_pre tseq2_def while_pre tfun2_def)

lemma t_sum2_below_w:
  "p \<in> Test_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> x \<in> While_program \<Longrightarrow> tsum2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) \<le> p\<star>x\<guillemotleft>q"
  by (smt Sum_least pre_closed pre_expression_test t_seq2_below_w t_seq2_test_seq test_pre tsum2_def)

lemma t_sum2_w:
  assumes "aL = 1"
      and "p \<in> Test_expression"
      and "q \<in> Pre_expression"
      and "x \<in> While_program"
    shows "tsum2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) = p\<star>x\<guillemotleft>q"
proof -
  let ?w = "p\<star>x\<guillemotleft>q"
  let ?s = "-p*q\<squnion>p*(x\<guillemotleft>?w*aL)"
  have "?w = tseq2 (-p*q) p x ?w ?s 0"
    by (smt assms(1-3) tests_dual.sup_right_unit id_def tests_dual.inf_commutative power_zero_id pre_closed pre_expression_test sub_mult_closed test_expression_test tseq2_def while_pre)
  hence "?w \<le> tsum2 (-p*q) p x ?w ?s"
    by (smt assms(2,3) Sum_upper pre_expression_test t_seq2_test_seq test_pre tsum2_def)
  thus ?thesis
    by (smt assms(2-4) tests_dual.antisymmetric pre_closed pre_expression_test t_sum2_test t_sum2_below_w test_pre)
qed

inductive derived_hoare_triple :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<lparr> _ \<rparr> _" [54,54,54] 53)
  where atom_trip:  "p \<in> Pre_expression \<Longrightarrow> x \<in> Atomic_program \<Longrightarrow> x\<guillemotleft>p\<lparr>x\<rparr>p"
      | seq_trip:   "p\<lparr>x\<rparr>q \<and> q\<lparr>y\<rparr>r \<Longrightarrow> p\<lparr>x*y\<rparr>r"
      | cond_trip:  "p \<in> Test_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> p*q\<lparr>x\<rparr>r \<and> -p*q\<lparr>y\<rparr>r \<Longrightarrow> q\<lparr>x\<lhd>p\<rhd>y\<rparr>r"
      | while_trip: "p \<in> Test_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> test_seq t \<and> q \<le> Sum t \<Longrightarrow> t 0*p*q\<lparr>x\<rparr>aL*q \<Longrightarrow> (\<forall>n>0 . t n*p*q\<lparr>x\<rparr>pSum t n*q) \<Longrightarrow> q\<lparr>p\<star>x\<rparr>-p*q"
      | cons_trip:  "p \<in> Pre_expression \<Longrightarrow> s \<in> Pre_expression \<Longrightarrow> p \<le> q \<and> q\<lparr>x\<rparr>r \<Longrightarrow> r \<le> s \<Longrightarrow> p\<lparr>x\<rparr>s"

lemma derived_type:
  "p\<lparr>x\<rparr>q \<Longrightarrow> p \<in> Pre_expression \<and> q \<in> Pre_expression \<and> x \<in> While_program"
  apply (induct rule: derived_hoare_triple.induct)
  apply (simp add: Pre_expression.pre_pre While_program.atom_prog)
  using While_program.seq_prog apply blast
  using While_program.cond_prog apply blast
  using Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.test_pre While_program.while_prog apply simp
  by blast

lemma cons_pre_trip:
  "p \<in> Pre_expression \<Longrightarrow> q\<lparr>y\<rparr>r \<Longrightarrow> p*q\<lparr>y\<rparr>r"
  by (metis cons_trip derived_type Pre_expression.conj_pre pre_expression_test tests_dual.sba_dual.reflexive tests_dual.upper_bound_right)

lemma cons_post_trip:
  "q \<in> Pre_expression \<Longrightarrow> r \<in> Pre_expression \<Longrightarrow> p\<lparr>y\<rparr>q*r \<longrightarrow> p\<lparr>y\<rparr>r"
  by (metis cons_trip derived_type pre_expression_test tests_dual.sba_dual.reflexive tests_dual.upper_bound_right)

definition valid_hoare_triple :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<langle> _ \<rangle> _" [54,54,54] 53)
  where "p\<langle>x\<rangle>q \<equiv> (p \<in> Pre_expression \<and> q \<in> Pre_expression \<and> x \<in> While_program \<and> p \<le> x\<guillemotleft>q)"

end

class hoare_calculus_sound = hoare_calculus +
  assumes while_soundness: "-p*-q \<le> x\<guillemotleft>-q \<longrightarrow> aL*-q \<le> -p\<star>x\<guillemotleft>-q"
begin

lemma while_soundness_0:
  "-p*-q \<le> x\<guillemotleft>-q \<Longrightarrow> -q*aL \<le> -p\<star>x\<guillemotleft>--p*-q"
  by (smt while_soundness aL_test sub_comm while_post)

lemma while_soundness_1:
  assumes "test_seq t"
      and "-q \<le> Sum t"
      and "t 0*-p*-q \<le> x\<guillemotleft>aL*-q"
      and "\<forall>n>0 . t n*-p*-q \<le> x\<guillemotleft>pSum t n*-q"
    shows "-q \<le> -p\<star>x\<guillemotleft>--p*-q"
proof -
  have "\<forall>n . t n*-p*-q \<le> x\<guillemotleft>-q"
  proof
    fix n
    show "t n*-p*-q \<le> x\<guillemotleft>-q"
    proof (cases n)
      case 0
      thus ?thesis
        by (smt (z3) assms(1) assms(3) aL_test leq_def pre_closed pre_lower_bound_right test_seq_def tests_dual.sub_associative tests_dual.sub_sup_closed)
    next
      case (Suc m)
      hence 1: "t n*-p*-q \<le> x\<guillemotleft>pSum t n*-q"
        using assms(4) by blast
      have "x\<guillemotleft>pSum t n*-q \<le> x\<guillemotleft>-q"
        by (metis assms(1) pSum_test pre_lower_bound_right)
      thus ?thesis
        using 1 by (smt (verit, del_insts) assms(1) pSum_test pre_closed sub_mult_closed test_seq_def leq_def tests_dual.sub_associative)
    qed
  qed
  hence 2: "-p*-q \<le> x\<guillemotleft>-q"
    by (smt assms(1,2) Sum_test leq_def mult_right_dist_Sum pre_closed sub_assoc sub_comm sub_mult_closed test_seq_def)
  have "\<forall>n . t n*-q \<le> -p\<star>x\<guillemotleft>--p*-q \<and> pSum t n*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
  proof
    fix n
    show "t n*-q \<le> -p\<star>x\<guillemotleft>--p*-q \<and> pSum t n*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
    proof (induct n rule: nat_less_induct)
      fix n
      assume 3: "\<forall>m<n . t m*-q \<le> -p\<star>x\<guillemotleft>--p*-q \<and> pSum t m*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
      have 4: "pSum t n*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
      proof (cases n)
        case 0
        thus ?thesis
          by (metis pSum.simps(1) pre_closed sub_mult_closed tests_dual.top_greatest tests_dual.sba_dual.less_eq_inf tests_dual.top_double_complement)
      next
        case (Suc m)
        hence "pSum t n*-q = (pSum t m \<squnion> t m)*-q"
          by simp
        also have "... = pSum t m*-q \<squnion> t m*-q"
          by (metis (full_types) assms(1) pSum_test test_seq_def tests_dual.sup_right_dist_inf)
        also have "... \<le> -p\<star>x\<guillemotleft>--p*-q"
        proof -
          have "pSum t m*-q = --(pSum t m*-q) \<and> t m*-q = --(t m*-q) \<and> -p\<star>x\<guillemotleft>--p*-q = --(-p\<star>x\<guillemotleft>--p*-q)"
            apply (intro conjI)
            apply (metis assms(1) pSum_test tests_dual.sub_sup_closed)
            apply (metis assms(1) test_seq_def tests_dual.sub_sup_closed)
            by (metis pre_closed tests_dual.sub_sup_closed)
          thus ?thesis
            using 3 by (smt (z3) lessI Suc tests_dual.greatest_lower_bound sub_mult_closed)
        qed
        finally show ?thesis
          .
      qed
      hence 5: "x\<guillemotleft>pSum t n*-q \<le> x\<guillemotleft>-p\<star>x\<guillemotleft>--p*-q"
        by (smt assms pSum_test pre_closed pre_iso sub_mult_closed)
      have 6: "-p*(t n*-q) \<le> -p*(-p\<star>x\<guillemotleft>--p*-q)"
      proof (cases n)
        case 0
        thus ?thesis
          using 2 by (smt assms(1,3) aL_test leq_def tests_dual.sup_idempotent tests_dual.sub_sup_right_isotone pre_closed pre_lower_bound_left sub_assoc sub_comm sub_mult_closed test_seq_def transitive while_pre_then while_soundness_0)
      next
        case (Suc m)
        hence "-p*(t n*-q) \<le> x\<guillemotleft>pSum t n*-q"
          by (smt assms(1,4) test_seq_def tests_dual.sub_associative tests_dual.sub_commutative zero_less_Suc)
        hence "-p*(t n*-q) \<le> x\<guillemotleft>-p\<star>x\<guillemotleft>--p*-q"
          using 5 by (smt assms(1) tests_dual.least_upper_bound pSum_test pre_closed sub_mult_closed test_seq_def leq_def)
        hence "-p*(t n*-q) \<le> -p*(x\<guillemotleft>-p\<star>x\<guillemotleft>--p*-q)"
          by (smt assms(1) tests_dual.upper_bound_left pre_closed sub_mult_closed test_seq_def leq_def tests_dual.sub_associative)
        thus ?thesis
          using while_post while_pre_then by auto
      qed
      have "--p*(t n*-q) \<le> --p*(-p\<star>x\<guillemotleft>--p*-q)"
        by (smt assms(1) leq_def tests_dual.upper_bound_right sub_assoc sub_comm sub_mult_closed test_seq_def while_pre_else)
      thus "t n*-q \<le> -p\<star>x\<guillemotleft>--p*-q \<and> pSum t n*-q \<le> -p\<star>x\<guillemotleft>--p*-q"
        using 4 6 by (smt assms(1) tests_dual.sup_less_eq_cases_2 pre_closed sub_mult_closed test_seq_def)
    qed
  qed
  thus ?thesis
    by (smt assms(1,2) Sum_test leq_def mult_right_dist_Sum pre_closed sub_comm sub_mult_closed)
qed

lemma while_soundness_2:
  assumes "test_seq t"
      and "-r \<le> Sum t"
      and "\<forall>n . t n*-p \<le> x\<guillemotleft>pSum t n"
    shows "-r \<le> -p\<star>x\<guillemotleft>1"
proof -
  have 1: "\<forall>n>0 . t n*-p*Sum t \<le> x\<guillemotleft>pSum t n*Sum t"
    by (smt (z3) assms(1,3) Sum_test Sum_upper leq_def pSum_below_Sum pSum_test test_seq_def tests_dual.sub_associative tests_dual.sub_commutative)
  have 2: "t 0*-p*Sum t \<le> x\<guillemotleft>bot"
    by (smt assms(1,3) Sum_test Sum_upper leq_def sub_assoc sub_comm test_seq_def pSum.simps(1))
  have "x\<guillemotleft>bot \<le> x\<guillemotleft>aL*Sum t"
    by (smt assms(1) Sum_test aL_test pre_iso sub_mult_closed tests_dual.top_double_complement tests_dual.top_greatest)
  hence "t 0*-p*Sum t \<le> x\<guillemotleft>aL*Sum t"
    using 2 by (smt (z3) assms(1) Sum_test aL_test leq_def pSum.simps(1) pSum_test pre_closed test_seq_def tests_dual.sub_associative tests_dual.sub_sup_closed)
  hence 3: "Sum t \<le> -p\<star>x\<guillemotleft>--p*Sum t"
    using 1 by (smt (verit, del_insts) assms(1) Sum_test tests_dual.sba_dual.one_def tests_dual.sup_right_unit tests_dual.upper_bound_left while_soundness_1)
  have "-p\<star>x\<guillemotleft>--p*Sum t \<le> -p\<star>x\<guillemotleft>1"
    by (metis assms(1) Sum_test pre_below_pre_one tests_dual.sub_sup_closed)
  hence "Sum t \<le> -p\<star>x\<guillemotleft>1"
    using 3 by (smt (z3) assms(1) Sum_test pre_closed tests_dual.sba_dual.one_def while_post tests_dual.transitive)
  thus ?thesis
    by (smt (z3) assms(1,2) Sum_test pre_closed tests_dual.sba_dual.one_def tests_dual.transitive)
qed

theorem soundness:
  "p\<lparr>x\<rparr>q \<Longrightarrow> p\<langle>x\<rangle>q"
  apply (induct rule: derived_hoare_triple.induct)
  apply (metis Pre_expression.pre_pre While_program.atom_prog pre_expression_test tests_dual.sba_dual.reflexive valid_hoare_triple_def)
  apply (metis valid_hoare_triple_def pre_expression_test pre_compose While_program.seq_prog)
  apply (metis valid_hoare_triple_def ite_import_mult pre_expression_test cond_prog test_pre)
  apply (smt (verit, del_insts) Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.test_pre While_program.while_prog pre_expression_test valid_hoare_triple_def while_soundness_1)
  by (metis pre_expression_test pre_iso pre_pre tests_dual.sba_dual.transitive valid_hoare_triple_def)

end

class hoare_calculus_pre_complete = hoare_calculus +
  assumes aL_pre_import: "(x\<guillemotleft>-q)*aL \<le> x\<guillemotleft>-q*aL"
  assumes pre_right_dist_Sum: "x \<in> While_program \<and> ascending_chain t \<and> test_seq t \<longrightarrow> x\<guillemotleft>Sum t = Sum (\<lambda>n . x\<guillemotleft>t n)"
begin

lemma aL_pre_import_equal:
  "(x\<guillemotleft>-q)*aL = (x\<guillemotleft>-q*aL)*aL"
proof -
  have 1: "(x\<guillemotleft>-q)*aL \<le> (x\<guillemotleft>-q*aL)*aL"
    by (smt (z3) aL_pre_import aL_test pre_closed tests_dual.sub_sup_closed tests_dual.least_upper_bound tests_dual.upper_bound_right)
  have "(x\<guillemotleft>-q*aL)*aL \<le> (x\<guillemotleft>-q)*aL"
    by (smt (verit, ccfv_threshold) aL_test pre_closed pre_lower_bound_left tests_dual.sba_dual.inf_isotone tests_dual.sba_dual.reflexive tests_dual.sub_sup_closed)
  thus ?thesis
    using 1 by (smt (z3) tests_dual.antisymmetric aL_test pre_closed tests_dual.sub_sup_closed)
qed

lemma aL_pre_below_t_seq2:
  assumes "p \<in> Test_expression"
      and "q \<in> Pre_expression"
    shows "(p\<star>x\<guillemotleft>q)*aL \<le> tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) 0"
proof (unfold tseq2_def power_zero_id id_def while_pre)
  have "(p\<star>x\<guillemotleft>q)*aL = (p*(x\<guillemotleft>p\<star>x\<guillemotleft>q) \<squnion> -p*q)*aL"
    by (metis assms while_pre test_pre pre_expression_test)
  also have "... = p*(x\<guillemotleft>p\<star>x\<guillemotleft>q)*aL \<squnion> -p*q*aL"
    by (smt (z3) assms aL_test tests_dual.sup_right_dist_inf pre_closed pre_expression_test sub_mult_closed test_pre)
  also have "... = p*((x\<guillemotleft>p\<star>x\<guillemotleft>q)*aL) \<squnion> -p*q*aL"
    by (smt assms aL_test pre_closed pre_expression_test test_pre sub_assoc)
  also have "... \<le> p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL) \<squnion> -p*q"
  proof -
    have 1: "(x\<guillemotleft>p\<star>x\<guillemotleft>q)*aL \<le> x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL"
      by (metis assms(2) pre_closed pre_expression_test aL_pre_import)
    have "-p*q*aL \<le> -p*q"
      by (metis assms(2) aL_test pre_expression_test tests_dual.sub_sup_closed tests_dual.upper_bound_left)
    thus ?thesis
      using 1 by (smt assms aL_test pre_closed pre_expression_test test_pre tests_dual.sub_sup_closed tests_dual.sub_sup_right_isotone tests_dual.inf_isotone)
  qed
  also have "... = -p*q \<squnion> p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)"
    by (smt assms aL_test tests_dual.inf_commutative pre_closed pre_expression_test test_pre tests_dual.sub_sup_closed)
  finally show "(p\<star>x\<guillemotleft>q)*aL \<le> -p*q \<squnion> p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)"
    .
qed

lemma t_seq2_ascending:
  assumes "p \<in> Test_expression"
      and "q \<in> Pre_expression"
      and "x \<in> While_program"
    shows "tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) m \<le> tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)) (Suc m)"
proof (induct m)
  let ?w = "p\<star>x\<guillemotleft>q"
  let ?r = "-p*q\<squnion>p*(x\<guillemotleft>?w*aL)"
  case 0
  have 1: "?w*aL = --(?w*aL)"
    by (simp add: assms Pre_expression.conj_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression pre_expression_test)
  have 2: "?r = --?r"
    by (simp add: assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test)
  have "?w*aL \<le> ?r"
    by (metis aL_pre_below_t_seq2 assms(1,2) id_def tseq2_def power_zero_id)
  hence "?w*aL \<le> ?w*?r"
    using 1 2 by (smt (verit, ccfv_threshold) assms Pre_expression.pre_pre While_program.while_prog aL_test pre_expression_test tests_dual.sub_associative tests_dual.sub_sup_right_isotone tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.reflexive)
  hence "x\<guillemotleft>?w*aL \<le> x\<guillemotleft>(?w*?r)"
    by (smt (verit, ccfv_threshold) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test pre_iso test_pre)
  hence "p*(x\<guillemotleft>?w*aL) \<le> p*(x\<guillemotleft>(?w*?r))"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sub_sup_right_isotone)
  hence "?r \<le> -p*q\<squnion>p*(x\<guillemotleft>(?w*?r))"
    by (smt (verit, del_insts) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sba_dual.reflexive tests_dual.inf_isotone)
  thus ?case
    by (unfold tseq2_def power_zero_id power_succ_unfold_ext id_def tfun2_def)
next
  let ?w = "p\<star>x\<guillemotleft>q"
  let ?r = "-p*q\<squnion>p*(x\<guillemotleft>?w*aL)"
  let ?t = "tseq2 (-p*q) p x ?w ?r"
  case (Suc m)
  hence "?w*?t m \<le> ?w*?t (Suc m)"
    by (smt (z3) assms(1,2) pre_closed pre_expression_test t_seq2_test test_expression_test tests_dual.sub_sup_right_isotone)
  hence "x\<guillemotleft>?w*?t m \<le> x\<guillemotleft>?w*?t (Suc m)"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test pre_iso test_pre tseq2_pre_expression)
  hence "p*(x\<guillemotleft>?w*?t m) \<le> p*(x\<guillemotleft>?w*?t (Suc m))"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sub_sup_right_isotone tseq2_pre_expression)
  hence "-p*q\<squnion>p*(x\<guillemotleft>?w*?t m) \<le> -p*q\<squnion>p*(x\<guillemotleft>?w*?t (Suc m))"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sba_dual.reflexive tests_dual.inf_isotone tseq2_pre_expression)
  thus ?case
    by (smt tseq2_def power_succ_unfold_ext tfun2_def)
qed

lemma t_seq2_ascending_chain:
  "p \<in> Test_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> x \<in> While_program \<Longrightarrow> ascending_chain (tseq2 (-p*q) p x (p\<star>x\<guillemotleft>q) (-p*q\<squnion>p*(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL)))"
  by (simp add: ord.ascending_chain_def t_seq2_ascending)

end

class hoare_calculus_complete = hoare_calculus_pre_complete +
  assumes while_completeness: "-p*(x\<guillemotleft>-q) \<le> -q \<longrightarrow> -p\<star>x\<guillemotleft>-q \<le> -q\<squnion>aL"
begin

lemma while_completeness_var:
  assumes "-p*(x\<guillemotleft>-q)\<squnion>-r \<le> -q"
    shows "-p\<star>x\<guillemotleft>-r \<le> -q\<squnion>aL"
proof -
  have 1: "-p\<star>x\<guillemotleft>-q \<le> -q\<squnion>aL"
    by (smt assms pre_closed tests_dual.sub_sup_closed tests_dual.greatest_lower_bound while_completeness)
  have "-p\<star>x\<guillemotleft>-r \<le> -p\<star>x\<guillemotleft>-q"
    by (smt assms pre_closed tests_dual.sub_sup_closed tests_dual.greatest_lower_bound pre_iso)
  thus ?thesis
    using 1 by (smt (z3) aL_test pre_closed tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.transitive)
qed

lemma while_completeness_sum:
  assumes "p \<in> Test_expression"
      and "q \<in> Pre_expression"
      and "x \<in> While_program"
    shows "p\<star>x\<guillemotleft>q \<le> tsum (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL))"
proof -
  let ?w = "p\<star>x\<guillemotleft>q"
  let ?r = "-p*q\<squnion>p*(x\<guillemotleft>?w*aL)"
  let ?t = "tseq2 (-p*q) p x ?w ?r"
  let ?ts = "tsum2 (-p*q) p x ?w ?r"
  have 1: "?w = --?w"
    by (metis assms(2) pre_expression_test pre_closed)
  have 2: "?r = --?r"
    by (simp add: assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test)
  have 3: "?ts = --?ts"
    by (meson assms(1) assms(2) pre_expression_test t_sum2_test test_expression_test)
  have 4: "test_seq ?t"
    by (simp add: assms(1) assms(2) pre_expression_test t_seq2_test_seq test_expression_test)
  have "-p*q \<le> ?r"
    by (smt (z3) assms(1,2) aL_test pre_closed pre_expression_test sub_mult_closed test_pre tests_dual.lower_bound_left)
  hence 5: "-p*q \<le> ?ts"
    using 1 2 3 by (smt assms Sum_upper id_def tests_dual.sba_dual.transitive power_zero_id pre_expression_test sub_mult_closed test_pre tseq2_def tseq2_test_seq tsum2_def)
  have "\<forall>n . p*(x\<guillemotleft>?t n) \<le> ?ts"
  proof (rule allI, unfold tsum2_def)
    fix n
    have 6: "p*(x\<guillemotleft>?t n) \<le> ?t (Suc n)"
      using 4 by (smt assms leq_def power_succ_unfold_ext pre_closed pre_expression_test tests_dual.sub_commutative sub_mult_closed t_seq2_below_w test_pre test_seq_def tfun2_def tseq2_def tests_dual.lower_bound_right)
    have "?t (Suc n) \<le> Sum ?t"
      using 4 Sum_upper by auto
    thus "p*(x\<guillemotleft>?t n) \<le> Sum ?t"
      using 3 4 6 by (smt assms(1) pre_closed pre_expression_test sub_mult_closed test_pre test_seq_def tests_dual.transitive tsum2_def)
  qed
  hence "p*(x\<guillemotleft>?ts) \<le> ?ts"
    using 3 4 by (smt assms mult_left_dist_Sum pre_closed pre_right_dist_Sum t_seq2_ascending_chain test_expression_test test_seq_def tsum2_def)
  hence "p*(x\<guillemotleft>?ts)\<squnion>-p*q \<le> ?ts"
    using 3 5 by (smt assms(1,2) tests_dual.greatest_lower_bound pre_closed pre_expression_test sub_mult_closed test_pre)
  hence "?w \<le> ?ts\<squnion>aL"
    using 1 3 by (smt assms(1,2) pre_expression_test while_post sub_mult_closed t_sum2_below_t_sum t_sum_test test_pre transitive while_completeness_var)
  hence "?w = ?w*(?ts\<squnion>aL)"
    using 1 3 by (smt aL_test tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.sub_sup_closed)
  also have "... = ?w*?ts\<squnion>?w*aL"
    using 1 3 by (smt aL_test tests_dual.sup_left_dist_inf)
  also have "... \<le> ?ts\<squnion>?t 0"
    using 1 3 4 by (smt (z3) assms(1,2) aL_pre_below_t_seq2 tests_dual.upper_bound_right aL_test test_seq_def tests_dual.sub_sup_closed tests_dual.inf_isotone)
  also have "... = ?ts"
    using 3 4 by (smt Sum_upper tsum2_def test_seq_def tests_dual.less_eq_inf)
  finally have "?w \<le> ?ts"
    .
  thus ?thesis
    using 1 3 by (metis assms t_sum2_below_t_sum t_sum2_below_w tests_dual.antisymmetric)
qed

lemma while_complete:
  assumes "p \<in> Test_expression"
      and "q \<in> Pre_expression"
      and "x \<in> While_program"
      and "\<forall>r\<in>Pre_expression . x\<guillemotleft>r\<lparr>x\<rparr>r"
    shows "p\<star>x\<guillemotleft>q\<lparr>p\<star>x\<rparr>q"
proof -
  let ?w = "p\<star>x\<guillemotleft>q"
  let ?t = "tseq (-p) x ?w (-p\<squnion>(x\<guillemotleft>?w*aL))"
  have 1: "?w \<in> Pre_expression"
    by (simp add: assms(1-3) Pre_expression.pre_pre While_program.while_prog)
  have 2: "test_seq ?t"
    by (simp add: assms(2) pre_expression_test t_seq_test_seq)
  hence 3: "?w \<le> Sum ?t"
    using assms(1-3) tsum_def while_completeness_sum by auto
  have 4: "p = --p"
    by (simp add: assms(1) test_expression_test)
  have "x\<guillemotleft>?w*aL = --(x\<guillemotleft>?w*aL)"
    using 1 by (simp add: assms(3) Pre_expression.conj_pre Pre_expression.pre_pre aL_pre_expression pre_expression_test)
  hence 5: "(-p\<squnion>(x\<guillemotleft>?w*aL))*p = (x\<guillemotleft>?w*aL)*p"
    using 4 by (metis tests_dual.sba_dual.inf_complement_intro)
  have "x\<guillemotleft>aL*?w\<lparr>x\<rparr>aL*?w"
    using 1 by (simp add: assms(4) Pre_expression.conj_pre aL_pre_expression)
  hence "x\<guillemotleft>?w*aL\<lparr>x\<rparr>aL*?w"
    using 1 by (metis aL_test pre_expression_test sub_comm)
  hence "(x\<guillemotleft>?w*aL)*p*?w\<lparr>x\<rparr>aL*?w"
    using 1 by (smt (z3) assms(1) Pre_expression.conj_pre Pre_expression.test_pre derived_hoare_triple.cons_trip derived_type pre_expression_test sub_assoc tests_dual.sba_dual.reflexive tests_dual.upper_bound_left)
  hence "(-p\<squnion>(x\<guillemotleft>?w*aL))*p*?w\<lparr>x\<rparr>aL*?w"
    using 5 by simp
  hence 6: "?t 0*p*?w\<lparr>x\<rparr>aL*?w"
    by (unfold tseq_def power_zero_id id_def)
  have "\<forall>n>0 . ?t n*p*?w\<lparr>x\<rparr>pSum ?t n*?w"
  proof (rule allI, rule impI)
    fix n
    assume "0<(n::nat)"
    from this obtain m where 7: "n = Suc m"
      by (auto dest: less_imp_Suc_add)
    hence "?t m*?w \<le> pSum ?t n*?w"
      using 1 2 by (smt pSum.simps(2) pSum_test pre_expression_test test_seq_def tests_dual.lower_bound_right tests_dual.sba_dual.inf_isotone tests_dual.sba_dual.reflexive)
    thus "?t n*p*?w\<lparr>x\<rparr>pSum ?t n*?w"
      using 1 7 by (smt assms conj_pre cons_trip tests_dual.upper_bound_left tests_dual.sba_dual.inf_complement_intro pSum_pre_expression power_succ_unfold_ext pre_closed pre_expression_test sub_assoc sub_comm t_seq_pre_expression test_pre tfun_def tseq_def)
  qed
  hence "?w\<lparr>p\<star>x\<rparr>-p*?w"
    using 1 2 3 6 assms while_trip by auto
  hence "?w\<lparr>p\<star>x\<rparr>-p*q"
    using 4 by (metis assms(2) while_pre_else pre_expression_test while_pre_else)
  thus ?thesis
    using assms(1,2) Pre_expression.neg_pre Pre_expression.test_pre cons_post_trip by blast
qed

lemma pre_completeness:
  "x \<in> While_program \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> x\<guillemotleft>q\<lparr>x\<rparr>q"
  apply (induct arbitrary: q rule: While_program.induct)
  apply (simp add: derived_hoare_triple.atom_trip)
  apply (metis pre_pre pre_seq seq_trip pre_expression_test)
  apply (smt cond_prog cond_trip cons_pre_trip ite_pre_else ite_pre_then neg_pre pre_pre pre_expression_test test_pre)
  by (simp add: while_complete)

theorem completeness:
  "p\<langle>x\<rangle>q \<Longrightarrow> p\<lparr>x\<rparr>q"
  by (metis valid_hoare_triple_def pre_completeness tests_dual.reflexive pre_expression_test cons_trip)

end

class hoare_calculus_sound_complete = hoare_calculus_sound + hoare_calculus_complete
begin

text \<open>Theorem 41\<close>

theorem soundness_completeness:
  "p\<lparr>x\<rparr>q \<longleftrightarrow> p\<langle>x\<rangle>q"
  using completeness soundness by blast

end

class hoare_rules = whiledo + complete_tests + hoare_triple +
  assumes rule_pre:   "x\<guillemotleft>-q\<lbrace>x\<rbrace>-q"
  assumes rule_seq:   "-p\<lbrace>x\<rbrace>-q \<and> -q\<lbrace>y\<rbrace>-r \<longrightarrow> -p\<lbrace>x*y\<rbrace>-r"
  assumes rule_cond:  "-p*-q\<lbrace>x\<rbrace>-r \<and> --p*-q\<lbrace>y\<rbrace>-r \<longrightarrow> -q\<lbrace>x\<lhd>-p\<rhd>y\<rbrace>-r"
  assumes rule_while: "test_seq t \<and> -q \<le> Sum t \<and> t 0*-p*-q\<lbrace>x\<rbrace>aL*-q \<and> (\<forall>n>0 . t n*-p*-q\<lbrace>x\<rbrace>pSum t n*-q) \<longrightarrow> -q\<lbrace>-p\<star>x\<rbrace>--p*-q"
  assumes rule_cons:  "-p \<le> -q \<and> -q\<lbrace>x\<rbrace>-r \<and> -r \<le> -s \<longrightarrow> -p\<lbrace>x\<rbrace>-s"
  assumes rule_disj:  "-p\<lbrace>x\<rbrace>-r \<and> -q\<lbrace>x\<rbrace>-s \<longrightarrow> -p\<squnion>-q\<lbrace>x\<rbrace>-r\<squnion>-s"
begin

lemma rule_cons_pre:
  "-p \<le> -q \<Longrightarrow> -q\<lbrace>x\<rbrace>-r \<Longrightarrow> -p\<lbrace>x\<rbrace>-r"
  using rule_cons tests_dual.sba_dual.reflexive by blast

lemma rule_cons_pre_mult:
  "-q\<lbrace>x\<rbrace>-r \<Longrightarrow> -p*-q\<lbrace>x\<rbrace>-r"
  by (metis tests_dual.sub_sup_closed rule_cons_pre tests_dual.upper_bound_right)

lemma rule_cons_pre_plus:
  "-p\<squnion>-q\<lbrace>x\<rbrace>-r \<Longrightarrow> -p\<lbrace>x\<rbrace>-r"
  by (metis tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left rule_cons_pre)

lemma rule_cons_post:
  "-q\<lbrace>x\<rbrace>-r \<Longrightarrow> -r \<le> -s \<Longrightarrow> -q\<lbrace>x\<rbrace>-s"
  using rule_cons tests_dual.sba_dual.reflexive by blast

lemma rule_cons_post_mult:
  "-q\<lbrace>x\<rbrace>-r*-s \<Longrightarrow> -q\<lbrace>x\<rbrace>-s"
  by (metis rule_cons_post tests_dual.upper_bound_left sub_comm sub_mult_closed)

lemma rule_cons_post_plus:
  "-q\<lbrace>x\<rbrace>-r \<Longrightarrow> -q\<lbrace>x\<rbrace>-r\<squnion>-s"
  by (metis tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left rule_cons_post)

lemma rule_disj_pre:
 "-p\<lbrace>x\<rbrace>-r \<Longrightarrow> -q\<lbrace>x\<rbrace>-r \<Longrightarrow> -p\<squnion>-q\<lbrace>x\<rbrace>-r"
  by (metis rule_disj tests_dual.sba_dual.sup_idempotent)

end

class hoare_calculus_valid = hoare_calculus_sound_complete + hoare_triple +
  assumes hoare_triple_valid: "-p\<lbrace>x\<rbrace>-q \<longleftrightarrow> -p \<le> x\<guillemotleft>-q"
begin

lemma valid_hoare_triple_same:
  "p \<in> Pre_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> x \<in> While_program \<Longrightarrow> p\<lbrace>x\<rbrace>q = p\<langle>x\<rangle>q"
  by (metis valid_hoare_triple_def hoare_triple_valid pre_expression_test)

lemma derived_hoare_triple_same:
  "p \<in> Pre_expression \<Longrightarrow> q \<in> Pre_expression \<Longrightarrow> x \<in> While_program \<Longrightarrow> p\<lbrace>x\<rbrace>q = p\<lparr>x\<rparr>q"
  by (simp add: soundness_completeness valid_hoare_triple_same)

lemma valid_rule_disj:
  assumes "-p\<lbrace>x\<rbrace>-r"
      and "-q\<lbrace>x\<rbrace>-s"
    shows "-p\<squnion>-q\<lbrace>x\<rbrace>-r\<squnion>-s"
proof -
  have "x\<guillemotleft>-r \<le> x\<guillemotleft>-r\<squnion>-s \<and> x\<guillemotleft>-s \<le> x\<guillemotleft>-r\<squnion>-s"
    by (metis pre_iso tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left tests_dual.sba_dual.upper_bound_right)
  thus ?thesis
    by (smt assms hoare_triple_valid tests_dual.greatest_lower_bound tests_dual.sba_dual.sub_sup_closed pre_closed tests_dual.transitive)
qed

subclass hoare_rules
  apply unfold_locales
  apply (metis hoare_triple_valid pre_closed tests_dual.sba_dual.reflexive)
  apply (meson hoare_triple_valid pre_compose)
  apply (smt hoare_triple_valid ite_import_mult sub_mult_closed)
  apply (smt (verit, del_insts) hoare_triple_valid aL_test pSum_test sba_dual.sub_sup_closed sub_mult_closed test_seq_def while_soundness_1)
  apply (smt hoare_triple_valid pre_iso tests_dual.transitive pre_closed)
  by (simp add: valid_rule_disj)

lemma nat_test_rule_while:
  "nat_test t s \<Longrightarrow> -q \<le> s \<Longrightarrow> (\<forall>n . t n*-p*-q\<lbrace>x\<rbrace>pSum t n*-q) \<Longrightarrow> -q\<lbrace>-p\<star>x\<rbrace>--p*-q"
  by (smt (verit, ccfv_threshold) hoare_triple_valid nat_test_def nat_test_pre pSum_test_nat sub_mult_closed)

lemma test_seq_rule_while:
  "test_seq t \<Longrightarrow> -q \<le> Sum t \<Longrightarrow> t 0*-p*-q\<lbrace>x\<rbrace>aL*-q \<Longrightarrow> (\<forall>n>0 . t n*-p*-q\<lbrace>x\<rbrace>pSum t n*-q) \<Longrightarrow> -q\<lbrace>-p\<star>x\<rbrace>--p*-q"
  by (smt (verit, del_insts) hoare_triple_valid aL_test pSum_test sub_mult_closed test_seq_def while_soundness_1)

lemma rule_bot:
  "bot\<lbrace>x\<rbrace>-p"
  by (metis hoare_triple_valid pre_closed tests_dual.top_double_complement tests_dual.top_greatest)

lemma rule_skip:
  "-p\<lbrace>1\<rbrace>-p"
  by (simp add: hoare_triple_valid pre_one_increasing)

lemma rule_example_4:
  assumes "test_seq t"
      and "Sum t = 1"
      and "t 0*-p1*-p3 = bot"
      and "-p1\<lbrace>z1\<rbrace>-p1*-p2"
      and "\<forall>n>0 . t n*-p1*-p2*-p3\<lbrace>z2\<rbrace>pSum t n*-p1*-p2"
    shows "-p1\<lbrace>z1*(-p3\<star>z2)\<rbrace>-p2*--p3"
proof -
  have "t 0*-p3*(-p1*-p2) = bot"
    by (smt (verit, ccfv_threshold) assms(1,3) sub_assoc sub_comm sub_mult_closed test_seq_def tests_dual.sup_right_zero)
  hence 1: "t 0*-p3*(-p1*-p2)\<lbrace>z2\<rbrace>aL*(-p1*-p2)"
    by (metis aL_test sub_mult_closed rule_bot)
  have "\<forall>n>0 . t n*-p3*(-p1*-p2)\<lbrace>z2\<rbrace>pSum t n*(-p1*-p2)"
    by (smt assms(1,5) lower_bound_left pSum_test rule_cons_pre sub_assoc sub_comm sub_mult_closed test_seq_def)
  hence "-p1*-p2\<lbrace>-p3\<star>z2\<rbrace>--p3*(-p1*-p2)"
    using 1 by (smt (verit, del_insts) assms(1,2) tests_dual.sub_bot_least rule_while sub_mult_closed)
  thus ?thesis
    by (smt assms(4) tests_dual.upper_bound_left rule_cons_post rule_seq sub_assoc sub_comm sub_mult_closed)
qed

end

class hoare_calculus_pc_2 = hoare_calculus_sound + hoare_calculus_pre_complete +
  assumes aL_one: "aL = 1"
begin

subclass hoare_calculus_sound_complete
  apply unfold_locales
  by (simp add: aL_one pre_below_one)

lemma while_soundness_pc:
  assumes "-p*-q \<le> x\<guillemotleft>-q"
  shows "-q \<le> -p\<star>x\<guillemotleft>--p*-q"
proof -
  let ?t = "\<lambda>x . 1"
  have 1: "test_seq ?t"
    by (simp add: test_seq_def)
  hence 2: "-q \<le> Sum ?t"
    by (metis Sum_test Sum_upper tests_dual.sba_dual.one_def tests_dual.antisymmetric tests_dual.sub_bot_least)
  have 3: "?t 0*-p*-q \<le> x\<guillemotleft>aL*-q"
    using 1 by (simp add: assms aL_one)
  have "\<forall>n>0 . ?t n*-p*-q \<le> x\<guillemotleft>pSum ?t n*-q"
    using 1 by (metis assms pSum_test pSum_upper tests_dual.sba_dual.one_def tests_dual.antisymmetric tests_dual.sub_bot_least tests_dual.sup_left_unit)
  thus ?thesis
    using 1 2 3 aL_one while_soundness_0 by auto
qed

end

class hoare_calculus_pc = hoare_calculus_sound + hoare_calculus_pre_complete +
  assumes pre_one_one: "x\<guillemotleft>1 = 1"
begin

subclass hoare_calculus_pc_2
  apply unfold_locales
  by (simp add: aL_def pre_one_one)

end

class hoare_calculus_pc_valid = hoare_calculus_pc + hoare_calculus_valid
begin

lemma rule_while_pc:
  "-p*-q\<lbrace>x\<rbrace>-q \<Longrightarrow> -q\<lbrace>-p\<star>x\<rbrace>--p*-q"
  by (metis hoare_triple_valid sub_mult_closed while_soundness_pc)

lemma rule_alternation:
  "-p\<lbrace>x\<rbrace>-q \<Longrightarrow> -q\<lbrace>y\<rbrace>-p \<Longrightarrow> -p\<lbrace>-r\<star>x*y\<rbrace>--r*-p"
  by (meson rule_cons_pre_mult rule_seq rule_while_pc)

lemma rule_alternation_context:
  "-p\<lbrace>v\<rbrace>-p \<Longrightarrow> -p\<lbrace>w\<rbrace>-q \<Longrightarrow> -q\<lbrace>x\<rbrace>-q \<Longrightarrow> -q\<lbrace>y\<rbrace>-p \<and> -p\<lbrace>z\<rbrace>-p \<Longrightarrow> -p\<lbrace>-r\<star>v*w*x*y*z\<rbrace>--r*-p"
  by (meson rule_cons_pre_mult rule_seq rule_while_pc)

lemma rule_example_3:
  assumes "-p*-q\<lbrace>x\<rbrace>--p*-q"
      and "--p*-r\<lbrace>x\<rbrace>-p*-r"
      and "-p*-r\<lbrace>y\<rbrace>-p*-q"
      and "--p*-q\<lbrace>z\<rbrace>--p*-r"
    shows "-p*-q\<squnion>--p*-r\<lbrace>-s\<star>x*(y\<lhd>-p\<rhd>z)\<rbrace>--s*(-p*-q\<squnion>--p*-r)"
proof -
  have t1: "-p*-q\<squnion>--p*-r\<lbrace>x\<rbrace>--p*-q\<squnion>-p*-r"
    by (smt assms(1,2) rule_disj sub_mult_closed)
  have "-p*-r\<lbrace>y\<rbrace>-p*-q\<squnion>--p*-r"
    by (smt assms(3) rule_cons_post_plus sub_mult_closed)
  hence t2: "-p*(--p*-q\<squnion>-p*-r)\<lbrace>y\<rbrace>-p*-q\<squnion>--p*-r"
    by (smt (z3) tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.reflexive tests_dual.sba_dual.sub_sup_closed tests_dual.sub_associative tests_dual.sub_sup_closed tests_dual.upper_bound_left tests_dual.wnf_lemma_3)
  have "--p*-q\<lbrace>z\<rbrace>-p*-q\<squnion>--p*-r"
    by (smt assms(4) tests_dual.inf_commutative rule_cons_post_plus sub_mult_closed)
  hence "--p*(--p*-q\<squnion>-p*-r)\<lbrace>z\<rbrace>-p*-q\<squnion>--p*-r"
    by (smt (z3) tests_dual.sba_dual.one_def tests_dual.sba_dual.sup_absorb tests_dual.sba_dual.sup_complement_intro tests_dual.sba_dual.sup_right_unit tests_dual.sub_sup_closed tests_dual.sup_complement_intro tests_dual.sup_left_dist_inf tests_dual.sup_right_unit tests_dual.top_double_complement)
  hence "--p*-q\<squnion>-p*-r\<lbrace>y\<lhd>-p\<rhd>z\<rbrace>-p*-q\<squnion>--p*-r"
    using t2 by (smt tests_dual.inf_closed rule_cond sub_mult_closed)
  hence "-s*(-p*-q\<squnion>--p*-r)\<lbrace>x*(y\<lhd>-p\<rhd>z)\<rbrace>-p*-q\<squnion>--p*-r"
    using t1 by (smt tests_dual.inf_closed rule_cons_pre_mult rule_seq sub_mult_closed)
  thus ?thesis
    by (smt tests_dual.inf_closed rule_while_pc sub_mult_closed)
qed

end

class hoare_calculus_tc = hoare_calculus + precondition_test_test + precondition_distr_mult +
  assumes while_bnd: "p \<in> Test_expression \<and> q \<in> Pre_expression \<and> x \<in> While_program \<longrightarrow> p\<star>x\<guillemotleft>q \<le> Sum (\<lambda>n . (p*x)^n\<guillemotleft>bot)"
begin

lemma
  assumes "p \<in> Test_expression"
      and "q \<in> Pre_expression"
      and "x \<in> While_program"
    shows "p\<star>x\<guillemotleft>q \<le> tsum (-p) x (p\<star>x\<guillemotleft>q) (-p\<squnion>(x\<guillemotleft>(p\<star>x\<guillemotleft>q)*aL))"
proof -
  let ?w = "p\<star>x\<guillemotleft>q"
  let ?s = "-p\<squnion>(x\<guillemotleft>?w*aL)"
  let ?t = "tseq (-p) x ?w ?s"
  let ?b = "\<lambda>n . (p*x)^n\<guillemotleft>bot"
  have 2: "test_seq ?t"
    by (simp add: assms(2) pre_expression_test t_seq_test_seq)
  have 3: "test_seq ?b"
    using pre_closed test_seq_def tests_dual.sba_dual.complement_top by blast
  have 4: "?w = --?w"
    by (metis assms(2) pre_expression_test pre_closed)
  have "?w \<le> Sum ?b"
    using assms while_bnd by blast
  hence 5: "?w = Sum ?b*?w"
    using 3 4 by (smt Sum_test leq_def sub_comm)
  have "\<forall>n . ?b n*?w \<le> ?t n"
  proof
    fix n
    show "?b n*?w \<le> ?t n"
    proof (induct n)
      show "?b 0*?w \<le> ?t 0"
        using 2 4 by (metis power.power_0 pre_one test_seq_def tests_dual.sup_left_zero tests_dual.top_double_complement tests_dual.top_greatest)
    next
      fix n
      assume 6: "?b n*?w \<le> ?t n"
      have "-p \<le> ?t (Suc n)"
        apply (unfold tseq_def power_succ_unfold_ext)
        by (smt assms(2) pre_expression_test t_seq_test pre_closed sub_mult_closed tfun_def tseq_def tests_dual.lower_bound_left)
      hence 7: "-p*?b (Suc n)*?w \<le> ?t (Suc n)"
        using 2 3 4 by (smt tests_dual.upper_bound_left sub_mult_closed test_seq_def tests_dual.transitive)
      have 8: "p*?b (Suc n)*?w \<le> x\<guillemotleft>?w*(?b n*?w)"
        by (smt assms(1,2) tests_dual.upper_bound_right tests_dual.sup_idempotent power_Suc pre_closed pre_distr_mult pre_expression_test pre_import_composition sub_assoc sub_comm sub_mult_closed test_expression_test while_pre_then tests_dual.top_double_complement)
      have 9: "... \<le> x\<guillemotleft>?w*?t n"
        using 2 3 4 6 by (smt tests_dual.sub_sup_right_isotone pre_iso sub_mult_closed test_seq_def)
      have "... \<le> ?t (Suc n)"
        using 2 4 by (smt power_succ_unfold_ext pre_closed sub_mult_closed test_seq_def tfun_def tseq_def tests_dual.lower_bound_right)
      hence "p*?b (Suc n)*?w \<le> ?t (Suc n)"
        using 2 3 4 8 9 by (smt assms(1) pre_closed sub_mult_closed test_expression_test test_seq_def tests_dual.transitive)
      thus "?b (Suc n)*?w \<le> ?t (Suc n)"
        using 2 3 4 7 by (smt assms(1) tests_dual.sup_less_eq_cases sub_assoc sub_mult_closed test_expression_test test_seq_def)
    qed
  qed
  hence "Sum ?b*?w \<le> tsum (-p) x ?w ?s"
    using 3 4 by (smt assms(2) Sum_upper mult_right_dist_Sum pre_expression_test sub_mult_closed t_seq_test t_sum_test test_seq_def tests_dual.transitive tsum_def)
  thus ?thesis
    using 5 by auto
qed

end

class complete_pre = complete_tests + precondition + power
begin

definition bnd :: "'a \<Rightarrow> 'a"
  where "bnd x \<equiv> Sup { x^n\<guillemotleft>bot | n::nat . True }"

lemma bnd_test_set:
  "test_set { x^n\<guillemotleft>bot | n::nat . True }"
  by (smt (verit, del_insts) CollectD pre_closed test_set_def tests_dual.top_double_complement)

lemma bnd_test:
  "bnd x = --bnd x"
  using bnd_def bnd_test_set sup_test by auto

lemma bnd_upper:
  "x^m\<guillemotleft>bot \<le> bnd x"
proof -
  have "x^m\<guillemotleft>bot \<in> { x^m\<guillemotleft>bot | m::nat . True }"
    by auto
  thus ?thesis
    using bnd_def bnd_test_set sup_upper by auto
qed

lemma bnd_least:
  assumes "\<forall>n . x^n\<guillemotleft>bot \<le> -p"
    shows "bnd x \<le> -p"
proof -
  have "\<forall>y\<in>{ x^n\<guillemotleft>bot | n::nat . True } . y \<le> -p"
    using assms by blast
  thus ?thesis
    using bnd_def bnd_test_set sup_least by auto
qed

lemma mult_right_dist_bnd:
  assumes "\<forall>n . (x^n\<guillemotleft>bot)*-p \<le> -q"
    shows "bnd x*-p \<le> -q"
proof -
  have "Sup { y*-p | y . y \<in> { x^n\<guillemotleft>bot | n::nat . True } } \<le> -q"
    by (smt assms mem_Collect_eq tests_dual.complement_bot pre_closed sub_mult_closed sup_least test_set_def)
  thus ?thesis
    using bnd_test_set bnd_def mult_right_dist_sup by simp
qed

lemma tests_complete:
  "nat_test (\<lambda>n . (-p*x)^n\<guillemotleft>bot) (bnd(-p*x))"
  using bnd_test bnd_upper mult_right_dist_bnd nat_test_def tests_dual.complement_bot pre_closed by blast

end

end


subsection \<open>Equivalence of register machine and arithmetizing equations\<close>

theory Machine_Equation_Equivalence imports All_Equations
                                            "../Register_Machine/MachineEquations"
                                            "../Register_Machine/MultipleToSingleSteps"

begin

context register_machine
begin

lemma conclusion_4_5:
  assumes is_val: "is_valid_initial ic p a"
  and n_def: "n \<equiv> length (snd ic)"
  shows "(\<exists>q. terminates ic p q) = rm_equations a"
proof (rule)
  assume "\<exists>q. terminates ic p q"
  then obtain q::nat where terminates: "terminates ic p q" by auto
  hence "q>0" using terminates_def by auto

  have "\<exists>c>1. cells_bounded ic p c"
    using terminate_c_exists terminates is_val is_valid_initial_def by blast
  then obtain c where c: "cells_bounded ic p c \<and> c > 1" by auto

  define b where "b \<equiv> B c"
  define d where "d \<equiv> D q c b"
  define e where "e \<equiv> E q b"
  define f where "f \<equiv> F q c b"

  have "c>1" using c by auto

  have "b>1" using c b_def B_def
    using nat_neq_iff by fastforce

  define r where "r \<equiv> RLe ic p b q"
  define s where "s \<equiv> SKe ic p b q"
  define z where "z \<equiv> ZLe ic p b q"

  interpret equations: rm_eq_fixes p n a b c d e f q r z s by unfold_locales

  have "equations.mask_equations"
  proof -
    have "\<forall>l<n. r l \<preceq> d"
      using lm04_15_register_masking[of "ic" "p" "c" _ "q"] r_def n_def d_def b_def c by auto
    moreover have "\<forall>l<n. z l \<preceq> e"
      using lm04_15_zero_masking z_def n_def e_def b_def c by auto
    moreover have "\<forall>l<n. 2 ^ c * z l = r l + d && f"
      using lm04_20_zero_definition r_def z_def n_def d_def f_def b_def c by auto
    ultimately show ?thesis unfolding equations.mask_equations_def equations.register_mask_def
      equations.zero_indicator_mask_def equations.zero_indicator_0_or_1_def by auto
  qed

  moreover have "equations.register_equations"
  proof -
    have "r 0 = a + b * r 0 + b * \<Sum>R+ p 0 s - b * \<Sum>R- p 0 (\<lambda>k. s k && z 0)"
      using lm04_23_multiple_register1[of "ic" "p" "a" "c" "0" "q"] is_val c terminates `q>0` r_def
            s_def z_def b_def bitAND_commutes by auto
    moreover have "\<forall>l>0. l < n \<longrightarrow> r l = b * r l + b * \<Sum>R+ p l s - b * \<Sum>R- p l (\<lambda>k. s k && z l)"
      using lm04_22_multiple_register[of "ic" "p" "a" "c" _ "q"]
            b_def c terminates r_def s_def z_def is_val bitAND_commutes n_def `q>0` by auto
    moreover have "l<n \<Longrightarrow> r l < b^q" for l
      proof -
        assume "l<n"
        hence Rlq: "R ic p l q = 0"
          using terminates terminates_def correct_halt_def R_def n_def by auto
        have c_ineq: "(2::nat)^c \<le> 2 ^ Suc c - Suc 0" using `c>1` by auto
        have "\<forall>t. R ic p l t < 2 ^ c" using c `l<n` n_def by auto
        hence R_bound: " \<forall>t. R ic p l t < 2 ^ Suc c - Suc 0" using c_ineq
          by (metis dual_order.strict_trans linorder_neqE_nat not_less)
        have "(\<Sum>t = 0..q. b ^ t * R ic p l t) = (\<Sum>t = 0..(Suc (q-1)). b ^ t * R ic p l t)"
          using `q>0` by auto
        also have "... = (\<Sum>t = 0..q-1. b ^ t * R ic p l t) + b^q * R ic p l q"
          using Set_Interval.comm_monoid_add_class.sum.atLeast0_atMost_Suc[of _ "q-1"] `q>0` by auto
        also have "... = (\<Sum>t = 0..q-1. b ^ t * R ic p l t)" using Rlq by auto
        also have "... < b ^ q" using b_def R_bound
           base_summation_bound[of "R ic p l" "c" "q-1"] `q>0` by (auto simp: mult.commute)
        finally show ?thesis using r_def RLe_def by auto
      qed
    ultimately show ?thesis unfolding equations.register_equations_def equations.register_0_def
      equations.register_l_def equations.register_bound_def by auto
  qed

  moreover have "equations.state_equations"
  proof -
    have "equations.state_relations_from_recursion"
    proof -
      have "\<forall>d>0. d\<le>m \<longrightarrow> s d = b*\<Sum>S+ p d (\<lambda>k. s k) + b*\<Sum>S- p d (\<lambda>k. s k && z (modifies (p!k)))
                              + b*\<Sum>S0 p d (\<lambda>k. s k && (e - z (modifies (p!k))))"
        apply (auto simp: s_def z_def)
        using lm04_24_multiple_step_states[of "ic" "p" "a" "c" _ "q"]
              b_def c terminates s_def z_def is_val bitAND_commutes m_def `q>0` e_def E_def by auto
      moreover have "s 0 = 1 + b*\<Sum>S+ p 0 (\<lambda>k. s k) + b*\<Sum>S- p 0 (\<lambda>k. s k && z (modifies (p!k)))
                             + b*\<Sum>S0 p 0 (\<lambda>k. s k && (e - z (modifies (p!k))))"
        using lm04_25_multiple_step_state1[of "ic" "p" "a" "c" _ "q"]
              b_def c terminates s_def z_def is_val bitAND_commutes m_def `q>0` e_def E_def by auto
      ultimately show ?thesis unfolding equations.state_relations_from_recursion_def
        equations.state_0_def equations.state_d_def equations.state_m_def by auto
    qed

    moreover have "equations.state_unique_equations"
    proof -
      have "k<m \<longrightarrow> s k < b ^ q" for k
        using state_q_bound is_val terminates \<open>q>0\<close> b_def s_def m_def c by auto
      moreover have "k\<le>m \<longrightarrow> s k \<preceq> e" for k
        using state_mask is_val terminates \<open>q>0\<close> b_def e_def s_def c by auto
      ultimately show ?thesis unfolding equations.state_unique_equations_def
        equations.state_mask_def equations.state_bound_def by auto
    qed

    moreover have "\<forall>M\<le>m. sum s {..M} \<preceq> e"
      using state_sum_mask is_val terminates \<open>q>0\<close> b_def e_def s_def c `b>1` m_def by auto

    moreover have "s m = b^q"
        using halting_condition_04_27[of "ic" "p" "a" "q" "c"] m_def b_def is_val `q>0` terminates
              s_def by auto

    ultimately show ?thesis unfolding equations.state_equations_def
      equations.state_partial_sum_mask_def equations.state_m_def by auto
  qed

  moreover have "equations.constants_equations"
    unfolding equations.constants_equations_def equations.constant_b_def
    equations.constant_d_def equations.constant_e_def equations.constant_f_def
    using b_def d_def e_def f_def by auto

  moreover have "equations.miscellaneous_equations"
  proof -
    have tapelength: "length (snd ic) > 0"
      using is_val is_valid_initial_def[of "ic" "p" "a"] by auto
    have "R ic p 0 0 = a" using is_val is_valid_initial_def[of "ic" "p" "a"]
      R_def List.hd_conv_nth[of "snd ic"] by auto
    moreover have "R ic p 0 0 < 2^c" using c tapelength by auto
    ultimately have "a < 2^c" by auto
    thus ?thesis unfolding equations.miscellaneous_equations_def equations.c_gt_0_def
      equations.a_bound_def equations.q_gt_0_def
    using \<open>q > 0\<close> \<open>c > 1\<close> by auto
  qed

  ultimately show "rm_equations a" unfolding rm_equations_def all_equations_def by blast
next
  assume "rm_equations a"

  then obtain q b c d e f r z s where
    reg: "rm_eq_fixes.register_equations p n a b q r z s" and
    state: "rm_eq_fixes.state_equations p b e q z s" and
    mask: "rm_eq_fixes.mask_equations n c d e f r z" and
    const: "rm_eq_fixes.constants_equations b c d e f q" and
    misc: "rm_eq_fixes.miscellaneous_equations a c q"
    unfolding rm_equations_def all_equations_def by auto

  have fx: "rm_eq_fixes p n"
    unfolding rm_eq_fixes_def using local.register_machine_axioms by auto

  have "q>0" using misc fx rm_eq_fixes.miscellaneous_equations_def
    rm_eq_fixes.q_gt_0_def by auto
  have "b>1" using B_def const rm_eq_fixes.constants_equations_def
    rm_eq_fixes.constant_b_def fx
    by (metis One_nat_def Zero_not_Suc less_one n_not_Suc_n nat_neq_iff nat_power_eq_Suc_0_iff
        numeral_2_eq_2 of_nat_0 of_nat_power_eq_of_nat_cancel_iff of_nat_zero_less_power_iff pos2)
  have "n>0" using is_val is_valid_initial_def[of "ic" "p" "a"] n_def by auto
  have "m>0" using m_def is_val is_valid_initial_def[of "ic" "p"] is_valid_def[of "ic" "p"] by auto

  define Seq where "Seq \<equiv> (\<lambda>k t. nth_digit (s k) t b)"
  define Req where "Req \<equiv> (\<lambda>l t. nth_digit (r l) t b)"
  define Zeq where "Zeq \<equiv> (\<lambda>l t. nth_digit (z l) t b)"

  (* Quick and dirty: :\<acute>|  *)
  have mask_old: "mask_equations n r z c d e f" and
       reg_old: "reg_equations p r z s b a (length (snd ic)) q" and
       state_old: "state_equations p s z b e q (length p - 1)" and
       const_old: "rm_constants q c b d e f a"
    subgoal
      using mask rm_eq_fixes.mask_equations_def rm_eq_fixes.register_mask_def fx
      mask_equations_def rm_eq_fixes.zero_indicator_0_or_1_def rm_eq_fixes.zero_indicator_mask_def
      by simp
    subgoal
      using reg state mask const misc using rm_eq_fixes.register_equations_def
      rm_eq_fixes.register_0_def rm_eq_fixes.register_l_def rm_eq_fixes.register_bound_def
      reg_equations_def n_def fx by simp
    subgoal
      using state fx state_equations_def rm_eq_fixes.state_equations_def
      rm_eq_fixes.state_relations_from_recursion_def rm_eq_fixes.state_0_def rm_eq_fixes.state_m_def
      rm_eq_fixes.state_d_def rm_eq_fixes.state_unique_equations_def rm_eq_fixes.state_mask_def
      rm_eq_fixes.state_bound_def rm_eq_fixes.state_partial_sum_mask_def m_def by simp
    subgoal unfolding rm_constants_def
      using const misc fx rm_eq_fixes.constants_equations_def
      rm_eq_fixes.miscellaneous_equations_def rm_eq_fixes.constant_b_def rm_eq_fixes.constant_d_def
      rm_eq_fixes.constant_e_def rm_eq_fixes.constant_f_def rm_eq_fixes.c_gt_0_def
      rm_eq_fixes.q_gt_0_def rm_eq_fixes.a_bound_def by simp
    done

  hence RZS_eq: "l<n \<Longrightarrow> j\<le>m \<Longrightarrow> t\<le>q \<Longrightarrow>
                R ic p l t = Req l t \<and> Z ic p l t = Zeq l t \<and> S ic p j t = Seq j t" for l j t
    using rzs_eq[of "m" "p" "n" "ic" "a" "r" "z"] mask_old reg_old state_old const_old
          m_def n_def is_val `q>0` Seq_def Req_def Zeq_def by auto

  have R_eq: "l<n \<Longrightarrow> t\<le>q \<Longrightarrow> R ic p l t = Req l t" for l t using RZS_eq by auto
  have Z_eq: "l<n \<Longrightarrow> t\<le>q \<Longrightarrow> Z ic p l t = Zeq l t" for l t using RZS_eq by auto
  have S_eq: "j\<le>m \<Longrightarrow> t\<le>q \<Longrightarrow> S ic p j t = Seq j t" for j t using RZS_eq[of "0"] `n>0` by auto

  have  "ishalt (p!m)" using m_def is_val
        is_valid_initial_def[of "ic" "p" "a"] is_valid_def[of "ic" "p"] by auto
  have "Seq m q = 1" using state nth_digit_def Seq_def `b>1`
    using fx rm_eq_fixes.state_equations_def
             rm_eq_fixes.state_relations_from_recursion_def
             rm_eq_fixes.state_m_def by auto
  hence "S ic p m q = 1" using S_eq by auto
  hence "fst (steps ic p q) = m" using S_def by(cases "fst (steps ic p q) = m"; auto)
  hence qhalt: "ishalt (p ! (fst (steps ic p q)))" using S_def `ishalt (p!m)` by auto

  hence rempty: "snd (steps ic p q) ! l = 0" if "l < n" for l
    unfolding R_def[symmetric]
    using R_eq[of l q] \<open>l < n\<close> apply auto
    using reg Req_def nth_digit_def
    using rm_eq_fixes.register_equations_def
          rm_eq_fixes.register_l_def
          rm_eq_fixes.register_0_def
          rm_eq_fixes.register_bound_def
    by auto (simp add: fx)

  have state_m_0: "t<q \<Longrightarrow> S ic p m t = 0" for t
    proof -
      assume "t<q"
      have "b ^ q div b ^ t = b^(q-t)"
        by (metis \<open>1 < b\<close> \<open>t < q\<close> less_imp_le not_one_le_zero power_diff)
      also have "... mod b = 0" using \<open>1 < b\<close> \<open>t < q\<close> by simp
      finally have mod: "b^q div b^t mod b = 0" by auto
      have "s m = b^q" using state fx rm_eq_fixes.state_equations_def
        rm_eq_fixes.state_m_def
        rm_eq_fixes.state_relations_from_recursion_def by auto
      hence "Seq m t = 0" using Seq_def nth_digit_def mod by auto
      with S_eq `t < q` show ?thesis by auto
    qed
  have "\<forall>k<m. \<not> ishalt (p!k)"
    using is_val is_valid_initial_def[of "ic" "p" "a"] is_valid_def[of "ic" "p"] m_def by auto
  moreover have "t<q \<longrightarrow> fst (steps ic p t) < length p - 1" for t
    proof (rule ccontr)
      assume asm: "\<not> (t < q \<longrightarrow> fst (steps ic p t) < length p - 1)"
      hence "t<q" by auto
      with asm have "fst (steps ic p t) \<ge> length p - 1" by auto
      moreover have "fst (steps ic p t) \<le> length p - 1"
        using p_contains[of "ic" "p" "a" "t"] is_val by auto
      ultimately have "fst (steps ic p t) = m" using m_def by auto
      hence "S ic p m t = 1" using S_def by auto
      thus "False" using state_m_0[of "t"] `t<q` by auto
    qed
  ultimately have "t<q \<longrightarrow> \<not> ishalt (p ! (fst (steps ic p t)))" for t using m_def by auto
  hence no_early_halt: "t<q \<longrightarrow> \<not> ishalt (p ! (fst (steps ic p t)))" for t using state_m_0 by auto

  have "correct_halt ic p q" using qhalt rempty correct_halt_def n_def by auto
  thus "(\<exists>q. terminates ic p q)" using no_early_halt terminates_def `q>0` by auto
qed

end

end