theory Deque
  imports Nat_Language
begin

section \<open>Define the variables\<close>
datatype addr = h | t | task | level | head | tail | r | l\<^sub>0 | l\<^sub>1 | l\<^sub>2 | t\<^sub>0 | t\<^sub>1 | t\<^sub>2 | public | z | x
definition all_vars
  where "all_vars = [h, t, task, level, head, tail, r, l\<^sub>0, l\<^sub>1, l\<^sub>2, t\<^sub>0, t\<^sub>1, t\<^sub>2, public, z, x]"
definition locals
  where "locals = [h, t, task, level, r]"

section \<open>Establish the language & logic\<close>
global_interpretation natlang: nat_language all_vars locals
  defines \<Gamma>\<^sub>a = natlang.\<Gamma>\<^sub>a
      and \<Gamma>\<^sub>b = natlang.\<Gamma>\<^sub>b
      and wp = natlang.wp
      and stabilize = natlang.stabilize
      and wp\<^sub>Q = natlang.wp\<^sub>Q
      and guar = natlang.guar
      and PO = natlang.PO
      and secureUpd = natlang.secureUpd
      and ctrled = natlang.ctrled
      and if_secure = natlang.if_secure
      and wellformed = natlang.wellformed
      and negate = natlang.negate
      and var_policy = natlang.var_policy
      and \<Gamma>\<^sub>e = natlang.\<Gamma>\<^sub>e
      and invar = natlang.invar
      and low\<^sub>v = natlang.low\<^sub>v
      and wf\<^sub>\<L> = natlang.wf\<^sub>\<L>
      and step = natlang.step
      and str_env = natlang.str_env
      and onlyGlobals = natlang.onlyGlobals
  apply unfold_locales unfolding all_vars_def by allvars_tac

syntax
  "_Assign" :: "'addr \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang"
    ("(_ :=/ _)" [70, 65] 61)
  "_Store" :: "'addr \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang"
    ("(_ IN _ :=/ _)" [70, 70, 65] 61)
  "_Load" :: "'addr \<Rightarrow> ('addr) list \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang"
    ("(_ :=/ _ IN/ _)" [70, 70, 70] 61)
  "_Secure" :: "('addr,nat) rpred \<Rightarrow> ('addr,nat) rpred \<Rightarrow> ('addr \<Rightarrow> 'addr bexp) \<Rightarrow> ('addr,nat) pred \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang \<Rightarrow> bool"
    ("(0_,_ \<turnstile> R: _ /G: _ /{_})" [0, 0, 0, 0, 0] 61)

translations
  "x := a" \<rightharpoonup> "CONST Act (CONST Assign x a)"
  "x IN i := a" \<rightharpoonup> "CONST Act (CONST Store x i a)"
  "r := a IN i" \<rightharpoonup> "CONST Act (CONST Action.Load r a i)"
  "L,P \<turnstile> R: RP G: GP {c}" \<rightharpoonup> "CONST if_secure RP GP L P c"

section \<open>Example\<close>

subsection \<open>Specification\<close>

fun \<L> :: "addr \<Rightarrow> addr bexp" where
  "\<L> tail = true" |
  "\<L> head = true" |
  "\<L> l\<^sub>0 = true" |
  "\<L> l\<^sub>1 = true" |
  "\<L> l\<^sub>2 = true" |
  "\<L> t\<^sub>0 = UCmp (\<lambda>x. x = 0) (Load l\<^sub>0)" |
  "\<L> t\<^sub>1 = UCmp (\<lambda>x. x = 0) (Load l\<^sub>1)" |
  "\<L> t\<^sub>2 = UCmp (\<lambda>x. x = 0) (Load l\<^sub>2)" |
  "\<L> public = true" |
  "\<L> z = true" |
  "\<L> _ = false"

definition P\<^sub>0 :: "(addr,nat) pred"
  where "P\<^sub>0 \<equiv> PCmp (\<lambda>x y. even x) (Var z) (Const 0)"

definition "R \<equiv>  (const z) \<and>\<^sub>p (const t\<^sub>0) \<and>\<^sub>p (const l\<^sub>0) \<and>\<^sub>p (const t\<^sub>1) \<and>\<^sub>p (const l\<^sub>1) \<and>\<^sub>p (const t\<^sub>2) \<and>\<^sub>p (const l\<^sub>2)"

definition "G \<equiv> inc z
            \<and>\<^sub>p ((PCmp (\<lambda>x y. even x) (Var z\<^sup>o) (Const 0) \<and>\<^sub>p PCmp (=) (Var (Orig z)) (Var (Prime z))) \<longrightarrow>\<^sub>p (PCmp (=) (Var (Orig l\<^sub>0)) (Var (Prime l\<^sub>0))))
            \<and>\<^sub>p ((PCmp (\<lambda>x y. even x) (Var z\<^sup>o) (Const 0) \<and>\<^sub>p PCmp (=) (Var (Orig z)) (Var (Prime z))) \<longrightarrow>\<^sub>p (PCmp (=) (Var (Orig l\<^sub>1)) (Var (Prime l\<^sub>1))))
            \<and>\<^sub>p ((PCmp (\<lambda>x y. even x) (Var z\<^sup>o) (Const 0) \<and>\<^sub>p PCmp (=) (Var (Orig z)) (Var (Prime z))) \<longrightarrow>\<^sub>p (PCmp (=) (Var (Orig l\<^sub>2)) (Var (Prime l\<^sub>2))))"

lemma [natlang.RGSpec]:
  "transitive G"
  by natlang.wf_spec (intro conjI impI; auto)

lemma [natlang.RGSpec]:
  "str_env (step G)"
  by natlang.wf_spec (auto simp: G_def)

declare G_def [natlang.RGSimp]
declare R_def [natlang.RGSimp]

subsection \<open>Constants\<close>

definition "levels = [l\<^sub>0, l\<^sub>1, l\<^sub>2]"
definition "tasks = [t\<^sub>0, t\<^sub>1, t\<^sub>2]"
definition "L = Nat 3"
definition "fail = Nat 0"
definition "none = Nat 0"

subsection \<open>Functions\<close>

lemma put:
  "\<L>,P\<^sub>0 \<and>\<^sub>p Low level \<and>\<^sub>p (PCmp (=) (Var level) (Const 0) \<longrightarrow>\<^sub>p (Low task)) \<turnstile>
   R: R
   G: G
   {
    t := Load tail;
    z := BExp (Load z) (+) (Nat 1);
    tasks IN (BExp (Load t) (mod) L) := Nat 0;
    levels IN (BExp (Load t) (mod) L) := Load level;
    tasks IN (BExp (Load t) (mod) L) := Load task;
    z := BExp (Load z) (+) (Nat 1);
    tail := BExp (Load t) (+) (Nat 1)}"
  by natlang.vcgsolve (metis mod_Suc n_not_Suc_n numeral_2_eq_2)+

lemma take:
  "\<L>,P\<^sub>0 \<turnstile>
   R: Pb True
   G: G
   {
    t := BExp (Load tail) (-) (Nat 1);
    tail := Load t;
    h := Load head;
    IF \<lbrace>BCmp (Load h) (\<le>) (Load t)\<rbrace>
    THEN
      task := tasks IN BExp (Load t) (mod) L;
      IF \<lbrace>BCmp (Load h) (=) (Load t)\<rbrace>
      THEN
        IF NCAS head (Load h) (BExp (Load h) (+) (Nat 1))
        THEN task := Nat 0
        ELSE Skip
        FI ;
        tail := BExp (Load h) (+) (Nat 1)
      ELSE Skip
      FI
    ELSE
      task := Nat 0;
      tail := Load h
    FI
   }"
  by natlang.vcgsolve

lemma steal:
  "\<L>,P\<^sub>0 \<turnstile>
   R: G
   G: R
   {
    h := Load head;
    t := Load tail;
    IF \<lbrace>BCmp (Load h) (<) (Load t)\<rbrace>
    THEN
      DO
        DO
          r := Load z
        INV {Low r \<and>\<^sub>p Low h \<and>\<^sub>p PCmp (\<le>) (Var r) (Var z)}
        WHILE \<lbrace>Not (UCmp even (Load r))\<rbrace>;
        level := levels IN BExp (Load h) (mod) L;
        IF \<lbrace>BCmp (Load level) (=) (Nat 0)\<rbrace>
        THEN task := tasks IN BExp (Load h) (mod) L
        ELSE task := fail
        FI
      INV {Low r \<and>\<^sub>p Low h \<and>\<^sub>p (PCmp (=) (Var r) (Var z) \<longrightarrow>\<^sub>p Low task)}
      WHILE \<lbrace>BCmp (Load z) (\<noteq>) (Load r)\<rbrace>;
      IF NCAS head (Load h) (BExp (Load h) (+) (Nat 1))
      THEN task := fail
      ELSE Skip
      FI
    ELSE
      task := none
    FI ;
    public := Load task
   }"
  by natlang.vcgsolve (metis (no_types, lifting) le_antisym le_trans)+

end


(******************************************************************************
 * Orca: A Functional Correctness Verifier for Imperative Programs
 *       Based on Isabelle/UTP
 *
 * Copyright (c) 2016-2018 Virginia Tech, USA
 *               2016-2018 Technische Universität München, Germany
 *               2016-2018 University of York, UK
 *               2016-2018 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * This software may be distributed and modified according to the terms of
 * the GNU Lesser General Public License version 3.0 or any later version.
 * Note that NO WARRANTY is provided.
 *
 * See CONTRIBUTORS, LICENSE and CITATION files for details.
 ******************************************************************************)

section \<open>Algebraic laws of programming\<close>

text \<open>In this section we introduce the semantic rules related to the different
      statements of IMP. In the literature this also known as the algebraic laws of programming.
      In our framework we will use these rules in order to optimize a given program written in our
      language, and this before any deductive proof verification activity or formal testing.\<close>

theory Algebraic_Laws
  imports "../../Isabelle-UTP/utp/utp_urel_laws"
begin

named_theorems symbolic_exec and symbolic_exec_assign_uop and symbolic_exec_assign_bop and
               symbolic_exec_assign_trop and symbolic_exec_assign_qtop and symbolic_exec_ex
(* Usage of symbolic_exec_ex for the simp lemmas avoids annoying warnings about duplicate theorems
when using `simp add: symbolic_exec` *)

subsection \<open>SKIP Laws\<close>
text \<open>In this section we introduce the algebraic laws of programming related to the SKIP
      statement.\<close>

lemma pre_skip_post: "(\<lceil>b\<rceil>\<^sub>< \<and> II) = (II \<and> \<lceil>b\<rceil>\<^sub>>)"
  by rel_auto

lemma skip_var:
  fixes x :: "(bool \<Longrightarrow> '\<alpha>)"
  shows "($x \<and> II) = (II \<and> $x\<acute>)"
  by rel_auto

lemma assign_r_alt_def [symbolic_exec]:
  fixes x :: "('a \<Longrightarrow>'\<alpha>)"
  shows "x :== v = II\<lbrakk>\<lceil>v\<rceil>\<^sub></$x\<rbrakk>"
  by rel_auto

lemma skip_r_alpha_eq:
  "II = ($\<Sigma>\<acute> =\<^sub>u $\<Sigma>)"
  by rel_auto

lemma skip_r_refine_orig:
  "(p \<Rightarrow> p) \<sqsubseteq> II"
  by pred_blast

lemma skip_r_eq[simp]: "\<lbrakk>II\<rbrakk>\<^sub>e (a, b) \<longleftrightarrow> a = b"
  by rel_auto

lemma skip_refine_join:
  "(p \<Rightarrow> q) \<sqsubseteq> II \<longleftrightarrow> `((p \<squnion> II) \<Rightarrow> q)`"
  by pred_auto

lemma skip_refine_rel:
  "`(II \<Rightarrow> (p \<Rightarrow> q))` \<Longrightarrow> (p \<Rightarrow> q) \<sqsubseteq> II"
  by pred_auto

lemma skip_r_refine_pred:
  "`(p \<Rightarrow> q)` \<Longrightarrow> (\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> II"
  by rel_auto

subsection \<open>Assignment Laws\<close>
text \<open>In this section we introduce the algebraic laws of programming related to the assignment
      statement.\<close>

lemma "&v\<lbrakk>expr/v\<rbrakk> = [v \<mapsto>\<^sub>s expr] \<dagger> &v" ..

lemma usubst_cancel[usubst,symbolic_exec]:
  assumes 1:"weak_lens v"
  shows "(&v)\<lbrakk>expr/v\<rbrakk> = expr"
  using 1
  by transfer' rel_auto

lemma usubst_cancel_r[usubst,symbolic_exec]:
  assumes 1:"weak_lens v"
  shows "($v)\<lbrakk>\<lceil>expr\<rceil>\<^sub></$v\<rbrakk>= \<lceil>expr\<rceil>\<^sub><"
  using 1
  by  rel_auto

lemma assign_test[symbolic_exec]:
  assumes 1:"mwb_lens x"
  shows     "(x :== \<guillemotleft>u\<guillemotright> ;; x :== \<guillemotleft>v\<guillemotright>) = (x :== \<guillemotleft>v\<guillemotright>)"
  using 1
  by (simp add: assigns_comp subst_upd_comp subst_lit usubst_upd_idem)

lemma assign_r_comp[symbolic_exec]:
  "(x :== u ;; P) = P\<lbrakk>\<lceil>u\<rceil>\<^sub></$x\<rbrakk>"
  by (simp add: assigns_r_comp usubst)

lemma assign_twice[symbolic_exec]:
  assumes "mwb_lens x" and  "x \<sharp> f"
  shows "(x :== e ;; x :== f) = (x :== f)"
  using assms
  by (simp add: assigns_comp usubst)

lemma assign_commute:
  assumes "x \<bowtie> y" "x \<sharp> f" "y \<sharp> e"
  shows "(x :== e ;; y :== f) = (y :== f ;; x :== e)"
  using assms
  by (rel_auto, simp_all add: lens_indep_comm)

lemma assign_cond:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "out\<alpha> \<sharp> b"
  shows "(x :== e ;; (P \<triangleleft> b \<triangleright> Q)) =
         ((x :== e ;; P) \<triangleleft>b\<lbrakk>\<lceil>e\<rceil>\<^sub></$x\<rbrakk>\<triangleright> (x :== e ;; Q))"
  by rel_auto

lemma assign_rcond[symbolic_exec]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "(x :== e ;; (P \<triangleleft> b \<triangleright>\<^sub>r Q)) = ((x :== e ;; P) \<triangleleft> (b\<lbrakk>e/x\<rbrakk>) \<triangleright>\<^sub>r (x :== e ;; Q))"
  by rel_auto

lemma assign_uop1[symbolic_exec_assign_uop]:
  assumes 1: "mwb_lens v"
  shows "(v :== e1 ;; v :== (uop F (&v))) = (v :== (uop F e1))"
  using 1
  by rel_auto

lemma assign_bop1[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2"
  shows "(v :== e1 ;; v :== (bop bp (&v) e2)) = (v :== (bop bp e1 e2))"
  using 1 2
  by rel_auto

lemma assign_bop2[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2"
  shows "(v :== e1 ;; v :== (bop bp e2 (&v))) = (v :== (bop bp e2 e1))"
  using 1 2
  by rel_auto

lemma assign_trop1[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v :== e1 ;; v :== (trop tp (&v) e2 e3)) =
         (v :== (trop tp e1 e2 e3))"
  using 1 2 3
  by rel_auto

lemma assign_trop2[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v :== e1 ;; v :== (trop tp e2 (&v) e3)) =
         (v :== (trop tp e2 e1 e3))"
  using 1 2 3
  by rel_auto

lemma assign_trop3[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v :== e1 ;; v :== (trop tp e2 e3 (&v))) =
         (v :== (trop tp e2 e3 e1))"
  using 1 2 3
  by rel_auto

lemma assign_qtop1[symbolic_exec_assign_qtop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v :== e1 ;; v :== (qtop tp (&v) e2 e3 e4)) =
         (v :== (qtop tp e1 e2 e3 e4))"
  using 1 2 3 4
  by rel_auto

lemma assign_qtop2[symbolic_exec_assign_qtop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v :== e1 ;; v :== (qtop tp e2 (&v) e3 e4)) =
         (v :== (qtop tp e2 e1 e3 e4))"
  using 1 2 3 4
  by rel_auto

lemma assign_qtop3[symbolic_exec_assign_qtop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v :== e1 ;; v :== (qtop tp e2 e3 (&v) e4)) =
         (v :== (qtop tp e2 e3 e1 e4))"
  using 1 2 3 4
  by rel_auto

lemma assign_qtop4[symbolic_exec_assign_qtop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v :== e1 ;; v :== (qtop tp e2 e3 e4 (&v))) =
         (v :== (qtop tp e2 e3 e4 e1))"
  using 1 2 3 4
  by rel_auto

lemma assign_cond_seqr_dist:
  "(v :== e ;; (P \<triangleleft> b \<triangleright> Q)) = ((v :== e ;; P) \<triangleleft> b\<lbrakk>\<lceil>e\<rceil>\<^sub></$v\<rbrakk> \<triangleright> (v :== e ;; Q))"
  by rel_auto

text \<open>In the sequel we find assignment laws proposed by Hoare\<close>

lemma assign_vwb_skip:
  assumes 1: "vwb_lens v"
  shows "(v :== &v) = II"
  by (simp add: assms skip_r_def usubst_upd_var_id)

lemma assign_simultaneous:
  assumes  1: "vwb_lens v2"
  and      2: "v1 \<bowtie> v2"
  shows "(v1,v2 :== e, (&v2)) =  (v1 :== e)"
  by (simp add: 1 2 usubst_upd_comm usubst_upd_var_id)

lemma assign_seq:
  assumes  1: "vwb_lens var2"
  shows"(var1:== expr);; (var2 :== &var2) = (var1:== expr)"
  using 1 by rel_auto

lemma assign_cond_uop[symbolic_exec_assign_uop]:
  assumes 1: "weak_lens v"
  shows "v :== expr ;; (C1 \<triangleleft>uop F (&v)\<triangleright>\<^sub>r  C2)  =
         (v :== expr ;; C1) \<triangleleft>uop F expr\<triangleright>\<^sub>r (v :== expr ;; C2)"
  using 1
  by rel_auto

lemma assign_cond_bop1[symbolic_exec_assign_bop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2"
  shows "(v :== expr ;; (C1 \<triangleleft>(bop bp (&v) exp2)\<triangleright>\<^sub>r C2)) =
         ((v :== expr ;; C1) \<triangleleft>(bop bp expr exp2)\<triangleright>\<^sub>r  (v :== expr ;; C2))"
  using 1 2
  by rel_auto

lemma assign_cond_bop2[symbolic_exec_assign_bop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2"
  shows "(v :== exp1 ;; (C1 \<triangleleft>(bop bp exp2 (&v))\<triangleright>\<^sub>r C2)) =
         ((v :== exp1 ;; C1) \<triangleleft>(bop bp exp2 exp1)\<triangleright>\<^sub>r (v :== exp1 ;; C2))"
  using 1 2
  by rel_auto

lemma assign_cond_trop1[symbolic_exec_assign_trop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "(v :== expr ;; (C1 \<triangleleft>(trop tp (&v) exp2 exp3)\<triangleright>\<^sub>r C2)) =
         ((v :== expr ;; C1) \<triangleleft>(trop tp expr exp2 exp3)\<triangleright>\<^sub>r (v :== expr ;; C2))"
  using 1 2 3
  by rel_auto

lemma assign_cond_trop2[symbolic_exec_assign_trop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "(v :== exp1 ;; (C1 \<triangleleft>(trop tp exp2 (&v) exp3)\<triangleright>\<^sub>r C2)) =
         ((v :== exp1 ;; C1) \<triangleleft>(trop tp exp2 exp1 exp3)\<triangleright>\<^sub>r (v :== exp1 ;; C2))"
  using 1 2 3
  by rel_auto

lemma assign_cond_trop3[symbolic_exec_assign_trop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "(v :== exp1 ;; (C1 \<triangleleft>(trop bp exp2 exp3 (&v))\<triangleright>\<^sub>r C2)) =
         ((v :== exp1 ;; C1) \<triangleleft>(trop bp exp2 exp3 exp1)\<triangleright>\<^sub>r (v :== exp1 ;; C2))"
  using 1 2 3
  by rel_auto

lemma assign_cond_qtop1[symbolic_exec_assign_qtop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "(v :== exp1 ;; (C1 \<triangleleft>(qtop tp (&v) exp2 exp3 exp4)\<triangleright>\<^sub>r C2)) =
         ((v :== exp1 ;; C1) \<triangleleft>(qtop tp exp1 exp2 exp3  exp4)\<triangleright>\<^sub>r (v :== exp1 ;; C2))"
  using 1 2 3 4
  by rel_auto

lemma assign_cond_qtop2[symbolic_exec_assign_qtop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4:"v \<sharp> exp4"
  shows "(v :== exp1 ;; (C1 \<triangleleft>(qtop tp exp2 (&v) exp3 exp4)\<triangleright>\<^sub>r C2)) =
         ((v :== exp1 ;; C1) \<triangleleft>(qtop tp exp2 exp1 exp3 exp4)\<triangleright>\<^sub>r  (v :== exp1 ;; C2))"
  using 1 2 3 4
  by rel_auto

lemma assign_cond_qtop3[symbolic_exec_assign_qtop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "(v :== exp1 ;; (C1 \<triangleleft>(qtop bp exp2 exp3 (&v) exp4)\<triangleright>\<^sub>r C2)) =
         ((v :== exp1 ;; C1) \<triangleleft>(qtop bp exp2 exp3 exp1  exp4)\<triangleright>\<^sub>r (v :== exp1 ;; C2))"
  using 1 2 3 4
  by rel_auto

lemma assign_cond_qtop4[symbolic_exec_assign_qtop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "(v :== exp1 ;; (C1 \<triangleleft>(qtop bp exp2 exp3 exp4 (&v))\<triangleright>\<^sub>r C2)) =
         ((v :== exp1 ;; C1) \<triangleleft>(qtop bp exp2 exp3  exp4 exp1)\<triangleright>\<^sub>r (v :== exp1 ;; C2))"
  using 1 2 3 4
  by rel_auto

lemma assign_cond_If [symbolic_exec]:
  "((v :== exp1) \<triangleleft> bexp\<triangleright>\<^sub>r (v :== exp2)) =
   (v :== (trop If bexp exp1 exp2))"
  by rel_auto

lemma assign_cond_If_uop[symbolic_exec_assign_uop]:
  assumes 1: "mwb_lens v"
  shows "(v :== E;;
         ((v :== uop F (&v)) \<triangleleft>uop F (&v)\<triangleright>\<^sub>r (v :== uop G (&v)))) =
         (v :== trop If (uop F E) (uop F E) (uop G E))"
  using 1
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> expr"
  shows "((v :== E);;
          ((v :== (bop F expr (&v))) \<triangleleft>bop F expr (&v)\<triangleright>\<^sub>r (v :== (bop G expr (&v))))) =
         (v :== (trop If (bop F expr E) (bop F expr E) (bop G expr E)))"
  using 1 2
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop1[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> expr"
  shows "((v :== E);;
          ((v :== (bop F (&v) expr)) \<triangleleft>bop F (&v) expr\<triangleright>\<^sub>r (v :== (bop G (&v) expr)))) =
         (v :== (trop If (bop F E expr) (bop F E expr) (bop G E expr)))"
  using 1 2
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop2[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v :== E);;
          ((v :== (bop F (&v) exp1)) \<triangleleft>bop F (&v) exp1\<triangleright>\<^sub>r (v :== (bop G (&v) exp2)))) =
         (v :== (trop If (bop F E exp1) (bop F E exp1) (bop G E exp2)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop4[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v :== E);;
          ((v :== (bop F (&v) exp1)) \<triangleleft>bop F (&v) exp1\<triangleright>\<^sub>r (v :== (bop G exp2 (&v))))) =
         (v :== (trop If (bop F E exp1) (bop F E exp1) (bop G exp2 E)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop5[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v :== E);;
          ((v :== (bop F exp1 (&v))) \<triangleleft>bop F exp1 (&v)\<triangleright>\<^sub>r (v :== (bop G (&v) exp2)))) =
         (v :== (trop If (bop F exp1 E) (bop F exp1 E) (bop G E exp2)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop6[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v :== E);;
          ((v :== (bop F exp1 (&v))) \<triangleleft>bop F exp1 (&v)\<triangleright>\<^sub>r (v :== (bop G exp2 (&v))))) =
         (v :== (trop If (bop F exp1 E) (bop F exp1 E) (bop G exp2 E)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v :== E);;
         ((v :== (trop F exp1 exp2 (&v))) \<triangleleft>trop F exp1 exp2 (&v)\<triangleright>\<^sub>r (v :== (trop G exp1 exp2 (&v))))) =
         (v :== (trop If (trop F exp1 exp2 E) (trop F exp1 exp2 E) (trop G exp1 exp2 E)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop1[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v :== E);;
          ((v :== (trop F exp1 (&v) exp2)) \<triangleleft>trop F exp1 (&v) exp2\<triangleright>\<^sub>r (v :== (trop G exp1 (&v) exp2)))) =
         (v :== (trop If (trop F exp1 E exp2) (trop F exp1 E exp2) (trop G exp1 E exp2)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop2[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v :== E);;
          ((v :== (trop F (&v) exp1 exp2)) \<triangleleft>trop F (&v) exp1 exp2\<triangleright>\<^sub>r (v :== (trop G (&v) exp1 exp2)))) =
         (v :== (trop If (trop F E exp1 exp2) (trop F E exp1 exp2) (trop G E exp1 exp2)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop3[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2" and 4:"v \<sharp> exp3" and 5:"v \<sharp> exp4"
  shows "((v :== E);;
          ((v :== (trop F exp1 exp2 (&v))) \<triangleleft>trop F exp1 exp2 (&v)\<triangleright>\<^sub>r (v :== (trop G exp3 exp4 (&v))))) =
         (v :== (trop If (trop F exp1 exp2 E) (trop F exp1 exp2 E) (trop G exp3 exp4 E)))"
  using 1 2 3 4 5
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop4[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2" and 4:"v \<sharp> exp3" and 5:"v \<sharp> exp4"
  shows "((v :== E);;
         ((v :== (trop F exp1 (&v) exp2)) \<triangleleft>trop F exp1 (&v) exp2\<triangleright>\<^sub>r (v :== (trop G exp3 (&v) exp4)))) =
         (v :== (trop If (trop F exp1 E exp2) (trop F exp1 E exp2) (trop G exp3 E exp4)))"
  using 1 2 3 4 5
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop5[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2" and 4:"v \<sharp> exp3" and 5:"v \<sharp> exp4"
  shows "((v :== E);;
          ((v :== (trop F (&v) exp1 exp2)) \<triangleleft>trop F (&v) exp1 exp2\<triangleright>\<^sub>r (v :== (trop G (&v) exp3 exp4)))) =
         (v :== (trop If (trop F E exp1 exp2) (trop F E exp1 exp2) (trop G E exp3 exp4)))"
  using 1 2 3 4 5
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

subsection \<open>Conditional Laws\<close>
text \<open>In this section we introduce the algebraic laws of programming related to the conditional
      statement.\<close>
named_theorems urel_cond
lemma cond_idem[urel_cond]:
  "(P \<triangleleft> b \<triangleright> P) = P"
  by rel_auto

lemma cond_symm:
  "(P \<triangleleft> b \<triangleright> Q) = (Q \<triangleleft>\<not> b\<triangleright> P)"
  by rel_auto

lemma cond_assoc:
  "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = ((P \<triangleleft> b \<triangleright> Q) \<triangleleft> b \<triangleright>  R)"
  by rel_auto

lemma cond_distr[urel_cond]:
  "((P \<triangleleft> b'\<triangleright> R) \<triangleleft> b \<triangleright> (Q \<triangleleft> b'\<triangleright> R))= ((P \<triangleleft> b \<triangleright> Q) \<triangleleft> b'\<triangleright> R)"
  by rel_auto

lemma cond_unit_T:
  "(P \<triangleleft>true\<triangleright> Q) = P"
  by auto

lemma cond_unit_F:
  "(P \<triangleleft>false\<triangleright> Q) = Q"
  by auto

lemma cond_and_T_integrate[urel_cond]:
  "((P \<and> b) \<or> (Q \<triangleleft> b \<triangleright> R)) = ((P \<or> Q) \<triangleleft> b \<triangleright> R)"
  by rel_auto

lemma cond_L6[urel_cond]:
  "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = (P \<triangleleft> b \<triangleright> R)"
  by rel_auto

lemma cond_L7[urel_cond]:
  "(P \<triangleleft> b \<triangleright> (P \<triangleleft> c \<triangleright> Q)) = (P \<triangleleft> b \<or> c \<triangleright> Q)"
  by rel_auto

lemma cond_and_distr[urel_cond]:
  "((P \<and> Q) \<triangleleft> b \<triangleright> (R \<and> S)) = ((P \<triangleleft> b \<triangleright> R) \<and> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_or_distr[urel_cond]:
  "((P \<or> Q) \<triangleleft> b \<triangleright> (R \<or> S)) = ((P \<triangleleft> b \<triangleright> R) \<or> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_imp_distr[urel_cond]:
  "((P \<Rightarrow> Q) \<triangleleft> b \<triangleright> (R \<Rightarrow> S)) =
   ((P \<triangleleft> b \<triangleright> R) \<Rightarrow> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_eq_distr[urel_cond]:
  "((P \<Leftrightarrow> Q) \<triangleleft> b \<triangleright> (R \<Leftrightarrow> S)) =
   ((P \<triangleleft> b \<triangleright> R) \<Leftrightarrow> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_ueq_distr[urel_cond]:
  "((P =\<^sub>u Q) \<triangleleft> b \<triangleright> (R =\<^sub>u S)) =
   ((P \<triangleleft> b \<triangleright> R) =\<^sub>u (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_conj_distr[urel_cond]:
  "((P \<and> Q) \<triangleleft> b \<triangleright> (P \<and> S)) = (P \<and> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_disj_distr [urel_cond]:
  "((P \<or> Q) \<triangleleft> b \<triangleright> (P \<or> S)) = (P \<or> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_neg[urel_cond]:
  "\<not> (P \<triangleleft> b \<triangleright> Q) = ((\<not> P) \<triangleleft> b \<triangleright> (\<not> Q))"
  by rel_auto

lemma cond_conj[urel_cond]:
  "(P \<triangleleft>b \<and> c\<triangleright> Q) = (P \<triangleleft> c \<triangleright> Q) \<triangleleft> b \<triangleright> Q"
  by rel_auto

(*IF Theorem by Hoare: It optimize nested IF*)
theorem COND12[urel_cond]:
  "((C1 \<triangleleft>bexp2\<triangleright> C3) \<triangleleft>bexp1\<triangleright> (C2 \<triangleleft>bexp3\<triangleright> C3)) =
   ((C1 \<triangleleft>bexp1\<triangleright> C2) \<triangleleft>(bexp2 \<triangleleft>bexp1\<triangleright>bexp3)\<triangleright> C3)"
  by rel_auto

lemma comp_cond_left_distr:
  "((P \<triangleleft> b \<triangleright>\<^sub>r Q) ;; R) = ((P ;; R) \<triangleleft> b \<triangleright>\<^sub>r (Q ;; R))"
  by rel_auto

lemma cond_var_subst_left[urel_cond]:
  assumes "vwb_lens x"
  shows "(P\<lbrakk>true/x\<rbrakk> \<triangleleft>&x \<triangleright> Q) = (P \<triangleleft>&x \<triangleright> Q)"
  using assms
  apply rel_auto apply transfer
  using vwb_lens.put_eq by fastforce

lemma cond_var_subst_right[urel_cond]:
  assumes "vwb_lens x"
  shows "(P \<triangleleft>&x \<triangleright> Q\<lbrakk>false/x\<rbrakk>) = (P \<triangleleft>&x \<triangleright> Q)"
  using assms
  apply pred_auto apply transfer
  by (metis (full_types) vwb_lens.put_eq)

lemma cond_var_split[urel_cond]:
  "vwb_lens x \<Longrightarrow> (P\<lbrakk>true/x\<rbrakk> \<triangleleft>&x \<triangleright> P\<lbrakk>false/x\<rbrakk>) = P"
  by (rel_auto, (metis (full_types) vwb_lens.put_eq)+)

lemma cond_seq_left_distr[urel_comp]:
  "out\<alpha> \<sharp> b \<Longrightarrow> ((P \<triangleleft> b \<triangleright> Q) ;; R) = ((P ;; R) \<triangleleft> b \<triangleright> (Q ;; R))"
  by rel_auto

lemma cond_seq_right_distr[urel_comp]:
  "in\<alpha> \<sharp> b \<Longrightarrow> (P ;; (Q \<triangleleft> b \<triangleright> R)) = ((P ;; Q) \<triangleleft> b \<triangleright> (P ;; R))"
  by rel_auto

subsection \<open>Sequential Laws\<close>
text \<open>In this section we introduce the algebraic laws of programming related to the sequential
      composition of statements.\<close>

lemma seqr_exists_left[symbolic_exec]:
  "((\<exists> $x \<bullet> P) ;; Q) = (\<exists> $x \<bullet> (P ;; Q))"
  by rel_auto

lemma seqr_exists_right[symbolic_exec]:
  "(P ;; (\<exists> $x\<acute> \<bullet> Q)) = (\<exists> $x\<acute> \<bullet> (P ;; Q))"
  by rel_auto

lemma seqr_left_zero [simp, symbolic_exec_ex]:
  "false ;; P = false"
  by pred_auto

lemma seqr_right_zero [simp, symbolic_exec_ex]:
  "P ;; false = false"
  by pred_auto

lemma seqr_or_distr[urel_comp]:
  "(P ;; (Q \<or> R)) = ((P ;; Q) \<or> (P ;; R))"
  by rel_auto

lemma seqr_unfold:
  "(P ;; Q) = (\<^bold>\<exists> v \<bullet> P\<lbrakk>\<guillemotleft>v\<guillemotright>/$\<Sigma>\<acute>\<rbrakk> \<and> Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$\<Sigma>\<rbrakk>)"
  by rel_auto

lemma seqr_middle:
  assumes "vwb_lens x"
  shows "(P ;; Q) = (\<^bold>\<exists> v \<bullet> P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>)"
  using assms
  apply (rel_auto robust)
  apply (rename_tac xa P Q a b y)
  apply (rule_tac x="get\<^bsub>xa\<^esub> y" in exI)
  apply (rule_tac x="y" in exI)
  apply (simp)
done

lemma seqr_left_one_point[urel_comp]:
  assumes "vwb_lens x"
  shows "((P \<and> $x\<acute> =\<^sub>u \<guillemotleft>v\<guillemotright>) ;; Q) = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>)"
  using assms
  by (rel_auto, metis vwb_lens_wb wb_lens.get_put)

lemma seqr_right_one_point[urel_comp]:
  assumes "vwb_lens x"
  shows "(P ;; ($x =\<^sub>u \<guillemotleft>v\<guillemotright> \<and> Q)) = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>)"
  using assms
  by (rel_auto, metis vwb_lens_wb wb_lens.get_put)

lemma seqr_insert_ident_left[urel_comp]:
  assumes "vwb_lens x" "$x\<acute> \<sharp> P" "$x \<sharp> Q"
  shows "(($x\<acute> =\<^sub>u $x \<and> P) ;; Q) = (P ;; Q)"
  using assms
  by (rel_auto, meson vwb_lens_wb wb_lens_weak weak_lens.put_get)

lemma seqr_insert_ident_right[urel_comp]:
  assumes "vwb_lens x" "$x\<acute> \<sharp> P" "$x \<sharp> Q"
  shows "(P ;; ($x\<acute> =\<^sub>u $x \<and> Q)) = (P ;; Q)"
  using assms
  by (rel_auto, metis (no_types, hide_lams) vwb_lens_def wb_lens_def weak_lens.put_get)

lemma seq_var_ident_lift[urel_comp]:
  assumes "vwb_lens x" "$x\<acute> \<sharp> P" "$x \<sharp> Q"
  shows "(($x\<acute> =\<^sub>u $x \<and> P) ;; ($x\<acute> =\<^sub>u $x \<and> Q)) = ($x\<acute> =\<^sub>u $x \<and> (P ;; Q))"
  using assms
  by (rel_auto, metis (no_types, lifting) vwb_lens_wb wb_lens_weak weak_lens.put_get)

lemma seqr_skip: "II ;; C = C ;; II"
  by (metis seqr_left_unit seqr_right_unit)

(*The rules SEQ6 SEQ7 related to SEQ and non-deterministic choice are missing for now*)

subsection \<open>While laws for normal designs\<close>

text \<open>In this section we introduce the algebraic laws of programming related to the while
      statement.\<close>

lemma while_gfp_rel_def_alt:
  "(while\<^sup>\<top> b do body od) = (\<nu> X \<bullet> bif b then (body ;; X) else SKIP\<^sub>r eif)"
  unfolding from_until_gfp_rel_def while_gfp_rel_def
  by simp

lemma while_lfp_rel_def_alt:
  "(while\<^sub>\<bottom> b do body od) = (\<mu> X \<bullet> bif b then (body ;; X) else SKIP\<^sub>r eif)"
  unfolding from_until_lfp_rel_def while_lfp_rel_def
  by simp

theorem while_gfp_rel_unfold:
  "while\<^sup>\<top> b do body od = (bif b then (body ;; while\<^sup>\<top> b do body od) else SKIP\<^sub>r eif)"
proof -
  have m:"mono (\<lambda>X. bif b then (body ;; X) else SKIP\<^sub>r eif)"
    by (auto intro: monoI seqr_mono cond_mono)
  have "(while\<^sup>\<top> b do body od) = (\<nu> X \<bullet> bif b then (body;; X) else SKIP\<^sub>r eif)"
    by (simp add: while_gfp_rel_def_alt)
  also have "... = (bif b then (body ;; (\<nu> X \<bullet> bif b then (body ;; X) else SKIP\<^sub>r eif)) else SKIP\<^sub>r eif)"
    by (rule lfp_fixpoint[THEN sym, OF m])
  also have "... = (bif b then (body ;; while\<^sup>\<top> b do body od) else SKIP\<^sub>r eif)"
    by (simp add: while_gfp_rel_def_alt)
  finally show ?thesis .
qed

theorem while_lfp_rel_unfold:
  "while\<^sub>\<bottom> b do body od = (bif b then (body;; while\<^sub>\<bottom> b do body od) else SKIP\<^sub>r eif)"
proof -
  have m:"mono (\<lambda>X. bif b then (body ;; X) else SKIP\<^sub>r eif)"
    by (auto intro: monoI seqr_mono cond_mono)
  have "(while\<^sub>\<bottom> b do body od) = (\<mu> X \<bullet> bif b then (body ;; X) else SKIP\<^sub>r eif)"
    by (simp add: while_lfp_rel_def_alt)
  also have "... = (bif b then (body ;; (\<mu> X \<bullet> bif b then (body ;; X) else SKIP\<^sub>r eif)) else SKIP\<^sub>r eif)"
     by (rule gfp_fixpoint[THEN sym, OF m])
  also have "... = (bif b then (body ;; while\<^sub>\<bottom> b do body od) else SKIP\<^sub>r eif)"
    by (simp add: while_lfp_rel_def_alt)
  finally show ?thesis .
qed

theorem while_lfp_rel_true:
  "while\<^sub>\<bottom> true do body od = (\<mu> X \<bullet> (body;; X))"
  by (simp add: while_lfp_rel_def_alt alpha)

lemma while_lfp_rel_false:
  "(while\<^sub>\<bottom> false do body od) = SKIP\<^sub>r"
  by (simp add: while_lfp_rel_def_alt alpha gfp_const)

theorem while_gfp_rel_false:
 "while\<^sup>\<top> false do body od = SKIP\<^sub>r"
 by (simp add: while_gfp_rel_def_alt alpha lfp_const)

theorem while_gfp_rel_non_termination: (*because of this lemma and the lemma utp_designs.design_top we do not use gfp for capturing termination *)
  "while\<^sup>\<top> true do SKIP\<^sub>r od = false"
  unfolding while_gfp_rel_def_alt
proof (rule lfp_eqI[of "(\<lambda>X. bif true then SKIP\<^sub>r ;; X else SKIP\<^sub>r eif)"] , goal_cases)
  case 1
  then show ?case by (auto intro: monoI seqr_mono cond_mono)
next
  case 2
  then show ?case by rel_simp
next
  case 3
  then show ?case by simp
qed

theorem while_lfp_rel_non_termination:
  "while\<^sub>\<bottom> true do SKIP\<^sub>r od = true"
  unfolding while_lfp_rel_def_alt
proof (rule gfp_eqI[of "(\<lambda>X. bif true then SKIP\<^sub>r ;; X else SKIP\<^sub>r eif)"] , goal_cases)
  case 1
  then show ?case by (auto intro: monoI seqr_mono cond_mono)
next
  case 2
  then show ?case  by rel_simp
next
  case 3
  then show ?case by simp
qed

text \<open>An infinite loop with a feasible body corresponds to a program error (non-termination).\<close>

theorem while_infinite:
  assumes is_in_abort_situation: "P ;; true\<^sub>h = true"
  shows "while\<^sub>\<bottom> true do P od = true"
  apply (simp add: while_lfp_rel_true)
  apply (rule antisym)
  apply (simp)
  apply (rule gfp_upperbound)
  apply (simp add: assms)
  done

subsection \<open>Other Iteration laws for relations\<close>

theorem from_until_gfp_rel_alt_def:
  "from\<^sup>\<top> init until exit do body od = init ;; while\<^sup>\<top> \<not> exit do body od"
  unfolding while_gfp_rel_def_alt from_until_gfp_rel_def
  by simp

lemma from_until_while_gfp_rel:
  "from\<^sup>\<top> SKIP\<^sub>r until exit do body od = while\<^sup>\<top> \<not> exit do body od"
  unfolding from_until_gfp_rel_alt_def
  by simp

theorem from_until_gfp_rel_unfold:
  "from\<^sup>\<top> init until exit do body od =
   init ;; (bif \<not> exit then (body;; while\<^sup>\<top> \<not> exit do body od) else SKIP\<^sub>r eif)"
  unfolding from_until_gfp_rel_alt_def using while_gfp_rel_unfold[of "\<not>exit"]
  by simp

theorem from_until_lfp_rel_alt_def:
  "from\<^sub>\<bottom> init until exit do body od = init ;; while\<^sub>\<bottom> \<not> exit do body od"
  unfolding while_lfp_rel_def_alt from_until_lfp_rel_def
  by simp

lemma from_until_while_lfp_rel:
  "from\<^sub>\<bottom> SKIP\<^sub>r until exit do body od = while\<^sub>\<bottom> \<not> exit do body od"
  unfolding from_until_lfp_rel_alt_def
  by simp

theorem from_until_lfp_rel_unfold:
  "from\<^sub>\<bottom> init until exit do body od =
   init ;; (bif \<not> exit then (body;; while\<^sub>\<bottom> \<not> exit do body od) else SKIP\<^sub>r eif)"
  unfolding from_until_lfp_rel_alt_def using while_lfp_rel_unfold[of "\<not>exit"]
  by simp

theorem do_while_gfp_rel_alt_def:
  "do body while\<^sup>\<top> exit od = body ;; while\<^sup>\<top> exit do body od"
  unfolding  do_while_gfp_rel_def from_until_gfp_rel_alt_def
  by simp

theorem do_while_gfp_rel_unfold:
  "do body while\<^sup>\<top> exit od =
   body ;; (bif exit then (body;; while\<^sup>\<top> exit do body od) else SKIP\<^sub>r eif)"
  unfolding do_while_gfp_rel_alt_def using while_gfp_rel_unfold[of exit]
  by simp

theorem do_while_lfp_rel_alt_def:
  "do body while\<^sub>\<bottom> exit od = body ;; while\<^sub>\<bottom> exit do body od"
  unfolding  do_while_lfp_rel_def from_until_lfp_rel_alt_def
  by simp

theorem do_while_lfp_rel_unfold:
  "do body while\<^sub>\<bottom> exit od =
   body ;; (bif exit then (body;; while\<^sub>\<bottom> exit do body od) else SKIP\<^sub>r eif)"
  unfolding do_while_lfp_rel_alt_def using while_lfp_rel_unfold[of exit]
  by simp

theorem for_gfp_rel_alt_def:
  "for\<^sup>\<top> (init, exit, incr) do body od = init ;; while\<^sup>\<top> exit do body;;incr od"
  unfolding  for_gfp_rel_def from_until_gfp_rel_alt_def
  by simp

theorem for_gfp_rel_unfold:
  shows "for\<^sup>\<top> (init, exit, incr) do body od =
         init ;; (bif exit then (body;;incr;;while\<^sup>\<top> exit do body ;; incr od) else SKIP\<^sub>r eif)"
  unfolding for_gfp_rel_alt_def using while_gfp_rel_unfold
  by (metis seqr_assoc)

theorem for_lfp_rel_alt_def:
 "for\<^sub>\<bottom> (init, exit, incr) do body od = init ;; while\<^sub>\<bottom> exit do body;;incr od"
  unfolding  for_lfp_rel_def from_until_lfp_rel_alt_def
  by simp

theorem for_lfp_rel_unfold:
  "for\<^sub>\<bottom> (init, exit, incr) do body od =
   init ;; (bif exit then (body;;incr;;while\<^sub>\<bottom> exit do body ;; incr od) else SKIP\<^sub>r eif)"
  unfolding for_lfp_rel_alt_def using while_lfp_rel_unfold
  by (metis seqr_assoc)

subsection \<open>assume and assert laws\<close>

lemma assume_twice[urel_comp]: "(b\<^sup>\<top> ;; c\<^sup>\<top>) = (b \<and> c)\<^sup>\<top>"
  by rel_auto

lemma assert_twice[urel_comp]: "(b\<^sub>\<bottom> ;; c\<^sub>\<bottom>) = (b \<and> c)\<^sub>\<bottom>"
  by rel_auto

subsection \<open>Relation algebra laws\<close>

theorem RA1: "(P ;; (Q ;; R)) = ((P ;; Q) ;; R)"
  using seqr_assoc by auto

theorem RA2: "(P ;; II) = P" "(II ;; P) = P"
  by simp_all

theorem RA3: "P\<^sup>-\<^sup>- = P"
  by simp

theorem RA4: "(P ;; Q)\<^sup>- = (Q\<^sup>- ;; P\<^sup>-)"
  by simp

theorem RA5: "(P \<or> Q)\<^sup>- = (P\<^sup>- \<or> Q\<^sup>-)"
  by (rel_auto)

theorem RA6[urel_comp]: "((P \<or> Q) ;; R) = ((P;;R) \<or> (Q;;R))"
  using seqr_or_distl by blast

subsection \<open>Refinement rules\<close>

lemma reverse_impl_refine:
  "`Q2 \<Rightarrow> Q1`  = (Q1 \<sqsubseteq> Q2)"
  by pred_auto

lemma pre_weak_rel:
  assumes "`Pre \<Rightarrow> I`"
  and     "(I \<Rightarrow> Post) \<sqsubseteq> P"
  shows "(Pre \<Rightarrow> Post) \<sqsubseteq> P"
 using assms
  by(rel_auto)

lemma post_str_rel:
  "(p\<Rightarrow>q) \<sqsubseteq> P \<Longrightarrow> `q\<Rightarrow>r` \<Longrightarrow> (p\<Rightarrow>r) \<sqsubseteq> P"
  by pred_blast

lemma cond_refine_rel:
  assumes "(b \<and> p \<Rightarrow> q) \<sqsubseteq> C\<^sub>1" and "(\<not>b \<and> p \<Rightarrow> q)\<sqsubseteq> C\<^sub>2"
  shows "(p \<Rightarrow> q) \<sqsubseteq> (C\<^sub>1 \<triangleleft> b \<triangleright> C\<^sub>2)"
  using assms by rel_auto

lemma cond_refine_pred:
  assumes "(\<lceil>b \<and> p\<rceil>\<^sub><\<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> C\<^sub>1" and "(\<lceil>\<not>b \<and> p\<rceil>\<^sub><\<Rightarrow> \<lceil>q\<rceil>\<^sub>>)\<sqsubseteq> C\<^sub>2"
  shows "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> (C\<^sub>1 \<triangleleft> \<lceil>b\<rceil>\<^sub>< \<triangleright> C\<^sub>2)"
  using assms by rel_auto

lemma seq_refine_pred:
  assumes "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>s\<rceil>\<^sub>>) \<sqsubseteq> f" and "(\<lceil>s\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> fa"
  shows "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> (f ;; fa)"
  using assms by rel_auto

lemma seq_refine_unrest:
  assumes "out\<alpha> \<sharp> p" "in\<alpha> \<sharp> q"
  assumes "(p \<Rightarrow> \<lceil>s\<rceil>\<^sub>>) \<sqsubseteq> f" and "(\<lceil>s\<rceil>\<^sub>< \<Rightarrow> q) \<sqsubseteq> fa"
  shows "(p \<Rightarrow> q) \<sqsubseteq> (f ;; fa)"
  using assms by rel_blast

lemmas skip_refine' = post_str_rel[OF skip_r_refine_orig]

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      HoareTotalDef.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

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

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

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section {* Hoare Logic for Total Correctness *}

theory HoareTotalDef imports HoarePartialDef Termination begin

subsection {* Validity of Hoare Tuples: @{text  "\<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"} *}

definition
  validt :: "[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com,'s assn,'s assn] \<Rightarrow> bool"
                ("_\<Turnstile>\<^sub>t\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A \<equiv> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A \<and> (\<forall>s \<in> Normal ` P. \<Gamma>\<turnstile>c\<down>s)"

definition
  cvalidt::
  "[('s,'p,'f) body,('s,'p) quadruple set,'f set,
    's assn,('s,'p,'f) com,'s assn,'s assn] \<Rightarrow> bool"
                ("_,_\<Turnstile>\<^sub>t\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60, 60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A \<equiv> (\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A) \<longrightarrow> \<Gamma> \<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"

notation (ascii)
  validt  ("_|=t'/_/ _ _ _,_"  [61,60,1000, 20, 1000,1000] 60) and
  cvalidt  ("_,_|=t'/_ / _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60)

subsection {* Properties of Validity *}

lemma validtI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t;s \<in> P;t \<notin> Fault ` F\<rbrakk> \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A;
   \<And>s. s \<in> P \<Longrightarrow> \<Gamma>\<turnstile> c\<down>(Normal s) \<rbrakk>
  \<Longrightarrow> \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: validt_def valid_def)

lemma cvalidtI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A;\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t;s \<in> P;
          t \<notin> Fault ` F\<rbrakk>
          \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A;
   \<And>s. \<lbrakk>\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A; s\<in>P\<rbrakk> \<Longrightarrow>  \<Gamma>\<turnstile>c\<down>(Normal s)\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: cvalidt_def validt_def valid_def)

lemma cvalidt_postD:
 "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A; \<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A;\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t;
   s \<in> P;t \<notin> Fault ` F\<rbrakk>
  \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A"
  by (simp add: cvalidt_def validt_def valid_def)

lemma cvalidt_termD:
 "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A; \<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A;s \<in> P\<rbrakk>
  \<Longrightarrow> \<Gamma>\<turnstile>c\<down>(Normal s)"
  by (simp add: cvalidt_def validt_def valid_def)

lemma validt_augment_Faults:
  assumes valid:"\<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F \<subseteq> F'"
  shows "\<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F'\<^esub> P c Q,A"
  using valid F'
  by (auto intro: valid_augment_Faults simp add: validt_def)

subsection {* The Hoare Rules: @{text "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A" } *}

inductive "hoaret"::"[('s,'p,'f) body,('s,'p) quadruple set,'f set,
                        's assn,('s,'p,'f) com,'s assn,'s assn]
                       => bool"
    ("(3_,_/\<turnstile>\<^sub>t\<^bsub>'/_\<^esub> (_/ (_)/ _,_))" [61,60,60,1000,20,1000,1000]60)
   for \<Gamma>::"('s,'p,'f) body"
where
  Skip: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> Q Skip Q,A"

| Basic: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> {s. f s \<in> Q} (Basic f) Q,A"

| Spec: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> {s. (\<forall>t. (s,t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s,t) \<in> r)} (Spec r) Q,A"

| Seq: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk>
        \<Longrightarrow>
        \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Seq c\<^sub>1 c\<^sub>2 Q,A"

| Cond: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P \<inter> b) c\<^sub>1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P \<inter> - b) c\<^sub>2 Q,A\<rbrakk>
         \<Longrightarrow>
         \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"

| While: "\<lbrakk>wf r; \<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P \<inter> b) c ({t. (t,\<sigma>)\<in>r} \<inter> P),A\<rbrakk>
          \<Longrightarrow>
          \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (While b c) (P \<inter> - b),A"

| Guard: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (g \<inter> P) c Q,A
          \<Longrightarrow>
          \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (g \<inter> P) Guard f g c Q,A"

| Guarantee: "\<lbrakk>f \<in> F; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (g \<inter> P) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Guard f g c) Q,A"

| CallRec:
  "\<lbrakk>(P,p,Q,A) \<in> Specs;
    wf r;
    Specs_wf = (\<lambda>p \<sigma>. (\<lambda>(P,q,Q,A). (P \<inter> {s. ((s,q),(\<sigma>,p)) \<in> r},q,Q,A)) ` Specs);
    \<forall>(P,p,Q,A)\<in> Specs.
      p \<in> dom \<Gamma> \<and> (\<forall>\<sigma>. \<Gamma>,\<Theta> \<union> Specs_wf p \<sigma>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P) (the (\<Gamma> p)) Q,A)
    \<rbrakk>
    \<Longrightarrow>
    \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A"

| DynCom:  "\<forall>s \<in> P. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (c s) Q,A
            \<Longrightarrow>
            \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (DynCom c) Q,A"

| Throw: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> A Throw Q,A"

| Catch: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c\<^sub>1 Q,R; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk> \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Catch c\<^sub>1 c\<^sub>2 Q,A"

| Conseq: "\<forall>s \<in> P. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' c Q',A' \<and> s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A
           \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"

| Asm: "(P,p,Q,A) \<in> \<Theta>
        \<Longrightarrow>
        \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A"

| ExFalso: "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A; \<not> \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  -- {* This is a hack rule that enables us to derive completeness for
        an arbitrary context @{text "\<Theta>"}, from completeness for an empty context.*}

text {* Does not work, because of rule ExFalso, the context @{text \<Theta>} is to blame.
 A weaker version with empty context can be derived from soundness
 later on. *}
lemma hoaret_to_hoarep:
  assumes hoaret: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P p Q,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
using hoaret
proof (induct)
  case Skip thus ?case by (rule hoarep.intros)
next
  case Basic thus ?case by (rule hoarep.intros)
next
  case Seq thus ?case by - (rule hoarep.intros)
next
  case Cond thus ?case by - (rule hoarep.intros)
next
  case (While r \<Theta> F P b c A)
  hence "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P \<inter> b) c ({t. (t, \<sigma>) \<in> r} \<inter> P),A"
    by iprover
  hence "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c P,A"
    by (rule HoarePartialDef.conseq) blast
  then show "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P While b c (P \<inter> - b),A"
    by (rule hoarep.While)
next
  case Guard thus ?case by - (rule hoarep.intros)
(*next
  case (CallRec A F P Procs Q Z \<Theta>  p r)
  hence hyp: "\<forall>p\<in>Procs. \<forall>\<tau> Z.
           \<Gamma>,\<Theta> \<union> (\<Union>q\<in>Procs. \<Union>Z. {(P q Z \<inter> {s. ((s, q), \<tau>, p) \<in> r},
                      Call q, Q q Z,A q Z)})\<turnstile>\<^bsub>/F\<^esub>
              ({\<tau>} \<inter> P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
    by blast
  have "\<forall>p\<in>Procs. \<forall>Z.
           \<Gamma>,\<Theta> \<union> (\<Union>q\<in>Procs. \<Union>Z. {(P q Z,
                      Call q, Q q Z,A q Z)})\<turnstile>\<^bsub>/F\<^esub>
              (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
  proof (intro ballI allI)
    fix p Z
    assume "p \<in> Procs"
    with hyp
    have hyp': "\<And> \<tau>.
           \<Gamma>,\<Theta> \<union> (\<Union>q\<in>Procs. \<Union>Z. {(P q Z \<inter> {s. ((s, q), \<tau>, p) \<in> r},
                      Call q, Q q Z, A q Z)})\<turnstile>\<^bsub>/F\<^esub>
              ({\<tau>} \<inter> P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
      by blast
    have "\<forall>\<tau>.
           \<Gamma>,\<Theta> \<union> (\<Union>q\<in>Procs. \<Union>Z. {(P q Z,
                      Call q, Q q Z,A q Z)})\<turnstile>\<^bsub>/F\<^esub>
              ({\<tau>} \<inter> P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
      (is "\<forall>\<tau>. \<Gamma>,?\<Theta>'\<turnstile>\<^bsub>/F\<^esub> ({\<tau>} \<inter> P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)")
    proof (rule allI, rule WeakenContext [OF hyp'],clarify)
      fix \<tau> P' c Q' A'
      assume "(P', c, Q', A') \<in> \<Theta> \<union>
         (\<Union>q\<in>Procs.
             \<Union>Z. {(P q Z \<inter> {s. ((s, q), \<tau>, p) \<in> r},
                  Call q, Q q Z,
                  A q Z)})" (is "(P', c, Q', A') \<in> \<Theta> \<union> ?Spec")
      then show "\<Gamma>,?\<Theta>'\<turnstile>\<^bsub>/F\<^esub> P' c Q',A'"
      proof (cases rule: UnE [consumes 1])
        assume "(P',c,Q',A') \<in> \<Theta>"
        then show ?thesis
          by (blast intro: HoarePartialDef.Asm)
      next
        assume "(P',c,Q',A') \<in> ?Spec"
        then show ?thesis
        proof (clarify)
          fix q Z
          assume q: "q \<in> Procs"
          show "\<Gamma>,?\<Theta>'\<turnstile>\<^bsub>/F\<^esub> (P q Z \<inter> {s. ((s, q), \<tau>, p) \<in> r})
                         Call  q
                        (Q q Z),(A q Z)"
          proof -
            from q
            have "\<Gamma>,?\<Theta>'\<turnstile>\<^bsub>/F\<^esub> (P q Z) Call q (Q q Z),(A q Z)"
              by - (rule HoarePartialDef.Asm,blast)
            thus ?thesis
              by (rule HoarePartialDef.conseqPre) blast
          qed
        qed
      qed
    qed
    then show "\<Gamma>,\<Theta> \<union> (\<Union>q\<in>Procs. \<Union>Z. {(P q Z, Call q, Q q Z,A q Z)})
                \<turnstile>\<^bsub>/F\<^esub> (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
      by (rule HoarePartialDef.conseq) blast
  qed
  thus ?case
    by - (rule hoarep.CallRec)*)
next
  case DynCom thus ?case by (blast intro: hoarep.DynCom)
next
  case Throw thus ?case by - (rule hoarep.Throw)
next
  case Catch thus ?case by - (rule hoarep.Catch)
next
  case Conseq thus ?case by - (rule hoarep.Conseq,blast)
next
  case Asm thus ?case by (rule HoarePartialDef.Asm)
next
  case (ExFalso \<Theta> F P c Q A)
  assume "\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  hence "\<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
    oops

lemma hoaret_augment_context:
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P p Q,A"
  shows "\<And>\<Theta>'. \<Theta> \<subseteq> \<Theta>' \<Longrightarrow> \<Gamma>,\<Theta>'\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P p Q,A"
using deriv
proof (induct)
  case (CallRec P p Q A Specs r Specs_wf \<Theta> F \<Theta>')
  have aug: "\<Theta> \<subseteq> \<Theta>'" by fact
  then
  have h: "\<And>\<tau> p. \<Theta> \<union> Specs_wf p \<tau>
       \<subseteq> \<Theta>' \<union> Specs_wf p \<tau>"
    by blast
  have "\<forall>(P,p,Q,A)\<in>Specs. p \<in> dom \<Gamma> \<and>
     (\<forall>\<tau>. \<Gamma>,\<Theta> \<union> Specs_wf p \<tau>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<tau>} \<inter> P) (the (\<Gamma> p)) Q,A \<and>
           (\<forall>x. \<Theta> \<union> Specs_wf p \<tau>
                 \<subseteq> x \<longrightarrow>
                 \<Gamma>,x\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<tau>} \<inter> P) (the (\<Gamma> p)) Q,A))" by fact
  hence "\<forall>(P,p,Q,A)\<in>Specs. p \<in> dom \<Gamma> \<and>
         (\<forall>\<tau>. \<Gamma>,\<Theta>'\<union> Specs_wf p \<tau> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<tau>} \<inter> P) (the (\<Gamma> p)) Q,A)"
    apply (clarify)
    apply (rename_tac P p Q A)
    apply (drule (1) bspec)
    apply (clarsimp)
    apply (erule_tac x=\<tau> in allE)
    apply clarify
    apply (erule_tac x="\<Theta>' \<union> Specs_wf p \<tau>" in allE)
    apply (insert aug)
    apply auto
    done
  with CallRec show ?case by - (rule hoaret.CallRec)
next
  case DynCom thus ?case by (blast intro: hoaret.DynCom)
next
  case (Conseq P \<Theta> F c Q A \<Theta>')
  from Conseq
  have "\<forall>s \<in> P. (\<exists>P' Q' A'. (\<Gamma>,\<Theta>' \<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' c Q',A') \<and> s \<in> P'\<and> Q' \<subseteq> Q \<and> A' \<subseteq> A)"
    by blast
  with Conseq show ?case by - (rule hoaret.Conseq)
next
  case (ExFalso \<Theta> F P  c Q A \<Theta>')
  have "\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A" "\<not> \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A" "\<Theta> \<subseteq> \<Theta>'"  by fact+
  then show ?case
    by (fastforce intro: hoaret.ExFalso simp add: cvalidt_def)
qed (blast intro: hoaret.intros)+

subsection {* Some Derived Rules *}

lemma  Conseq': "\<forall>s. s \<in> P \<longrightarrow>
            (\<exists>P' Q' A'.
              (\<forall> Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z)) \<and>
                    (\<exists>Z. s \<in> P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A)))
           \<Longrightarrow>
           \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
apply (rule Conseq)
apply (rule ballI)
apply (erule_tac x=s in allE)
apply (clarify)
apply (rule_tac x="P' Z" in exI)
apply (rule_tac x="Q' Z" in exI)
apply (rule_tac x="A' Z" in exI)
apply blast
done

lemma conseq:"\<lbrakk>\<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z);
              \<forall>s. s \<in> P \<longrightarrow> (\<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q)\<and> (A' Z \<subseteq> A))\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (rule Conseq) blast

theorem conseqPrePost:
  "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' c Q',A' \<Longrightarrow> P \<subseteq> P' \<Longrightarrow>  Q' \<subseteq> Q \<Longrightarrow> A' \<subseteq> A \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq [where ?P'="\<lambda>Z. P'" and ?Q'="\<lambda>Z. Q'"]) auto

lemma conseqPre: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' c Q,A \<Longrightarrow> P \<subseteq> P' \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
by (rule conseq) auto

lemma conseqPost: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q',A'\<Longrightarrow> Q' \<subseteq> Q \<Longrightarrow> A' \<subseteq> A \<Longrightarrow>   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq) auto

lemma Spec_wf_conv:
  "(\<lambda>(P, q, Q, A). (P \<inter> {s. ((s, q), \<tau>, p) \<in> r}, q, Q, A)) `
                (\<Union>p\<in>Procs. \<Union>Z. {(P p Z, p, Q p Z, A p Z)}) =
        (\<Union>q\<in>Procs. \<Union>Z. {(P q Z \<inter> {s. ((s, q), \<tau>, p) \<in> r}, q, Q q Z, A q Z)})"
apply (rule)
apply  fastforce
apply (fastforce simp add: image_def)
done

lemma CallRec':
  "\<lbrakk>p\<in>Procs; Procs \<subseteq> dom \<Gamma>;
    wf r;
   \<forall>p\<in>Procs. \<forall>\<tau> Z.
   \<Gamma>,\<Theta>\<union>(\<Union>q\<in>Procs. \<Union>Z.
    {((P q Z) \<inter> {s. ((s,q),(\<tau>,p)) \<in> r},q,Q q Z,(A q Z))})
     \<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<tau>} \<inter> (P p Z)) (the (\<Gamma> p)) (Q p Z),(A p Z)\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P p Z) (Call p) (Q p Z),(A p Z)"
apply (rule CallRec [where Specs="\<Union>p\<in>Procs. \<Union>Z. {((P p Z),p,Q p Z,A p Z)}" and
         r=r])
apply    blast
apply   assumption
apply  (rule refl)
apply (clarsimp)
apply (rename_tac p')
apply (rule conjI)
apply  blast
apply (intro allI)
apply (rename_tac Z \<tau>)
apply (drule_tac x=p' in bspec, assumption)
apply (erule_tac x=\<tau> in allE)
apply (erule_tac x=Z in allE)
apply (fastforce simp add: Spec_wf_conv)
done

end


theory TA_Impl_Misc2
  imports
    TA_Impl.TA_Impl_Misc
    "HOL-Library.Sublist"
    "List-Index.List_Index"
    Automatic_Refinement.Misc
begin

lemma mem_nth:
  "x \<in> set xs \<Longrightarrow> \<exists> i < length xs. xs ! i = x"
  by (metis index_less_size_conv nth_index)

lemma union_subsetI:
  "A \<union> B \<subseteq> C \<union> D" if "A \<subseteq> C" "B \<subseteq> D"
  using that by blast

lemma map_eq_imageD:
  "f ` set xs = set ys" if "map f xs = ys"
  using that by auto

lemma if_contract:
  "(if a then x else if b then x else y) = (if a \<or> b then x else y)" for a x b y
  by (rule SMT.z3_rule)

paragraph \<open>More intros\<close>

named_theorems more_intros
named_theorems more_elims
lemmas [more_intros] =
  image_eqI[rotated] CollectI subsetI

lemmas [more_elims] =
  CollectE

paragraph \<open>Finiteness\<close>

lemma finite_prodI:
  "finite {(a,b). P a \<and> Q b}" if "finite {a. P a}" "finite {a. Q a}"
  using that by simp

lemma finite_prodI3:
  "finite {(a,b,c). P a \<and> Q b \<and> Q1 c}"
  if "finite {a. P a}" "finite {a. Q a}" "finite {a. Q1 a}"
  using that by simp

lemma finite_prodI4:
  "finite {(a,b,c,d). P a \<and> Q b \<and> Q1 c \<and> Q2 d}"
  if "finite {a. P a}" "finite {a. Q a}" "finite {a. Q1 a}" "finite {a. Q2 a}"
  using that by simp

named_theorems finite_intros
named_theorems more_finite_intros

lemmas [finite_intros] =
  finite_UnI finite_Union finite_imageI
  finite_lists_length_eq finite_lists_length_le
  distinct_finite_subset distinct_finite_set

lemmas [more_finite_intros] =
  finite_prodI finite_prodI3 finite_prodI4

paragraph \<open>Lists\<close>

(* XXX Merge with the variants from TA_Impl_Misc *)
lemma fold_evD2:
  assumes
    "P y (fold f xs acc)" "\<not> P y acc"
    "\<And> acc x. \<not> P y acc \<Longrightarrow> Q acc \<Longrightarrow> P y (f x acc) \<Longrightarrow> x \<in> set xs \<Longrightarrow> x = y"
    "Q acc" "\<And> acc x. Q acc \<Longrightarrow> Q (f x acc)"
    "\<And> acc x. \<not> P y acc \<Longrightarrow> Q acc \<Longrightarrow> P y (f x acc) \<Longrightarrow> R y"
  shows "\<exists> ys zs. xs = ys @ y # zs \<and> \<not> P y (fold f ys acc) \<and> P y (f y (fold f ys acc)) \<and> R y"
proof -
  from fold_evD'[OF assms(2,1)] obtain x ys zs where *:
    "xs = ys @ x # zs" "\<not> P y (fold f ys acc)" "P y (f x (fold f ys acc))"
    by auto
  moreover from assms(4-) have "Q (fold f ys acc)" by (auto intro: fold_acc_preserv)
  moreover from \<open>xs = _\<close> have "x \<in> set xs"
    by auto
  ultimately show ?thesis using assms(3,6) by auto
qed

lemmas fold_evD2' = fold_evD2[where R = "\<lambda> _. True", simplified]

lemma filter_map_map_filter:
  "filter P (map f xs) = List.map_filter (\<lambda> x. let y = f x in if P y then Some y else None) xs"
  by (induction xs; simp add: Let_def List.map_filter_simps)

lemma distinct_map_filterI:
  "distinct (List.map_filter f xs)"
  if "\<forall>x \<in> set xs. \<forall>y \<in> set xs. \<forall>a. f x = Some a \<and> f y = Some a \<longrightarrow> x = y" "distinct xs"
  using that by (induction xs) (auto simp: map_filter_simps set_map_filter split: option.split)

lemma filter_eqI:
  assumes
    "subseq ys xs" "\<forall>x \<in> set ys. P x"
    "\<forall>zs. subseq zs xs \<and> length zs > length ys \<longrightarrow> (\<exists> x \<in> set zs. \<not> P x)"
  shows "filter P xs = ys"
  using assms
proof (induction xs arbitrary: ys rule: list.induct)
  case Nil
  then show ?case
    by - (cases ys; simp)
next
  case (Cons x xs)
  show ?case
  proof (cases "P x")
    case True
    show ?thesis
    proof (cases ys)
      case Nil
      have "subseq [x] (x # xs)"
        by auto
      with Cons.prems Nil \<open>P x\<close> show ?thesis
        by fastforce
    next
      case (Cons y ys')
      have "x = y"
      proof (rule ccontr)
        assume "x \<noteq> y"
        with \<open>subseq ys (x # xs)\<close> \<open>ys = _\<close> have "subseq (x # ys) (x # xs)"
          by simp
        with Cons.prems(2-) \<open>P x\<close> show False
          by fastforce
      qed
      have "\<exists>x\<in>set zs. \<not> P x" if "subseq zs xs" and "length ys' < length zs" for zs
      proof -
        from \<open>subseq zs xs\<close> have "subseq (x # zs) (x # xs)"
          by simp
        with \<open>length ys' < length zs\<close> Cons.prems(3) \<open>ys = _\<close> have "\<exists>x\<in>set (x # zs). \<not> P x"
          by (intro Cons.prems(3)[rule_format]; simp)
        with \<open>P x\<close> show ?thesis
          by auto
      qed
      with Cons.prems \<open>P x\<close> \<open>ys = _\<close> \<open>x = y\<close> show ?thesis
        by (auto intro!: Cons.IH)
    qed
  next
    case False
    with Cons.prems show ?thesis
      by (cases ys) (auto split: if_split_asm intro!: Cons.IH)
  qed
qed

lemma filter_greatest_subseqD:
  "\<exists> x \<in> set zs. \<not> P x" if "subseq zs xs" "length zs > length (filter P xs)"
  using that by (metis filter_id_conv not_subseq_length subseq_filter)

lemma filter_eq_iff_greatest_subseq:
  "filter P xs = ys \<longleftrightarrow>
  subseq ys xs \<and> (\<forall>x \<in> set ys. P x) \<and>
  (\<forall>zs. subseq zs xs \<and> length zs > length ys \<longrightarrow> (\<exists> x \<in> set zs. \<not> P x))"
  using filter_greatest_subseqD filter_eqI by auto

lemma subseq_subsetD:
  "set xs \<subseteq> set ys" if "subseq xs ys"
  using that
  by (intro subsetI) (unfold subseq_singleton_left[symmetric], erule subseq_order.order.trans)

lemma subseq_distinct:
  "distinct xs" if "distinct ys" "subseq xs ys"
  using subseqs_distinctD that by simp

(* XXX Move *)
lemma filter_distinct_eqI:
  assumes
    "subseq ys xs" "\<forall>x \<in> set ys. P x" "\<forall>x \<in> set xs. x \<notin> set ys \<longrightarrow> \<not> P x" "distinct xs"
  shows "filter P xs = ys"
proof (intro filter_eqI, safe)
  fix zs assume prems: "subseq zs xs" "length ys < length zs"
  obtain x where "x \<in> set zs" "x \<notin> set ys"
  proof (atomize_elim, rule ccontr)
    assume "\<nexists>x. x \<in> set zs \<and> x \<notin> set ys"
    then have "set zs \<subseteq> set ys"
      by auto
    moreover from prems assms have "distinct zs" "distinct ys"
      by (blast intro: subseq_distinct)+
    ultimately show False
      using \<open>length ys < length zs\<close>
      by (auto dest: card_mono[rotated] simp: distinct_card[symmetric])
  qed
  with prems assms show "\<exists>x\<in>set zs. \<not> P x"
    by (auto 4 3 dest: subseq_subsetD)
qed (use assms in blast)+

lemma subseq_sorted_wrt:
  "sorted_wrt R xs" if "sorted_wrt R ys" "subseq xs ys"
  using that
  by (induction xs arbitrary: ys)
     (auto 0 4 dest: subseq_subsetD list_emb_ConsD subseq_Cons' simp: sorted_wrt_append)

lemma subseq_sorted:
  "sorted xs" if "sorted ys" "subseq xs ys"
  using that unfolding sorted_sorted_wrt by (rule subseq_sorted_wrt)

lemma sorted_distinct_subset_subseqI:
  assumes "sorted xs" "distinct xs" "sorted ys" "set xs \<subseteq> set ys"
  shows "subseq xs ys"
  using assms
proof (induction ys arbitrary: xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons y ys xs)
  from Cons.prems show ?case
    by (cases xs; simp) (safe; rule Cons.IH; auto 4 4)
qed

lemma sorted_distinct_subseq_iff:
  assumes "sorted ys" "distinct ys"
  shows "subseq xs ys \<longleftrightarrow> (sorted xs \<and> distinct xs \<and> set xs \<subseteq> set ys)"
  using assms
  by safe
     (erule
       subseq_subsetD[THEN subsetD] sorted_distinct_subset_subseqI subseq_distinct subseq_sorted;
       assumption
     )+

lemma list_all2_map_fst_aux:
  assumes "list_all2 (\<lambda>x y. x \<in> Pair y ` (zs y)) xs ys"
  shows "list_all2 (=) (map fst xs) ys"
  using assms by (smt fstI imageE list.rel_mono_strong list_all2_map1)

end


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

theory ExtraSpecs

imports
  "CParser.TypHeapLib"

begin

definition
  "simple_simpl_refines \<Gamma> com com'
    = (\<forall>s. (\<exists>ft. \<Gamma> \<turnstile> \<langle>com', Normal s\<rangle> \<Rightarrow> Fault ft)
        \<or> ((\<forall>xs. \<Gamma> \<turnstile> \<langle>com, Normal s\<rangle> \<Rightarrow> xs \<longrightarrow> \<Gamma> \<turnstile> \<langle>com', Normal s\<rangle> \<Rightarrow> xs)
            \<and> (\<not> terminates \<Gamma> com (Normal s) \<longrightarrow> \<not> terminates \<Gamma> com' (Normal s))))"

lemma simple_simpl_refines_no_fault_execD:
  "\<Gamma> \<turnstile> \<langle>com,Normal s\<rangle> \<Rightarrow> xs
    \<Longrightarrow> simple_simpl_refines \<Gamma> com com'
    \<Longrightarrow> (\<forall>ft. \<not> \<Gamma> \<turnstile> \<langle>com',Normal s\<rangle> \<Rightarrow> Fault ft)
    \<Longrightarrow> \<Gamma> \<turnstile> \<langle>com', Normal s\<rangle> \<Rightarrow> xs"
  by (auto simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_no_fault_terminatesD:
  "simple_simpl_refines \<Gamma> com com'
    \<Longrightarrow> (\<forall>ft. \<not> \<Gamma> \<turnstile> \<langle>com',Normal s\<rangle> \<Rightarrow> Fault ft)
    \<Longrightarrow> \<not> terminates \<Gamma> com (Normal s) \<longrightarrow> \<not> terminates \<Gamma> com' (Normal s)"
  by (auto simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_refl:
  "simple_simpl_refines \<Gamma> com com"
  by (auto simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_from_def_eq:
  "body \<equiv> body' \<Longrightarrow> simple_simpl_refines \<Gamma> body' body"
  (* these are flipped, because the "implementation" is on the rhs of
     definitional equalities, but the lhs of refinement thms. *)
  by (simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_trans:
  "simple_simpl_refines \<Gamma> com com' \<Longrightarrow> simple_simpl_refines \<Gamma> com' com''
    \<Longrightarrow> simple_simpl_refines \<Gamma> com com''"
  by (simp add: simple_simpl_refines_def, metis)

lemma simple_simpl_refines_drop_Guard:
  "simple_simpl_refines \<Gamma> com (Guard F G com)"
  apply (clarsimp simp add: simple_simpl_refines_def)
  apply (case_tac "s \<in> G")
  apply (auto intro: exec.Guard exec.GuardFault
              elim!: terminates_Normal_elim_cases)
  done

lemma simple_simpl_refines_guarded_Basic_guarded_spec_body:
  "(\<forall>s s'. (s, s') \<in> R \<longrightarrow> (s \<in> G \<and> (s, f s) \<in> R))
    \<Longrightarrow> simple_simpl_refines \<Gamma> (Guard F' G (Basic f)) (guarded_spec_body F R)"
  apply (simp add: guarded_spec_body_def simple_simpl_refines_def)
  apply (intro allI, drule_tac x=s in spec)
  apply (erule impCE)
   apply (rule disjI1)
   apply (fastforce intro: exec.GuardFault)
  apply (rule disjI2)
  apply (auto intro!: exec.Guard terminates.Guard
               intro: exec.GuardFault exec.Spec terminates.Basic image_eqI[rotated]
              elim!: exec_Normal_elim_cases terminates_Normal_elim_cases)
  done

lemmas simple_simpl_refines_Basic_guarded_spec_body
    = simple_simpl_refines_trans[OF
        simple_simpl_refines_drop_Guard[where G=UNIV]
        simple_simpl_refines_guarded_Basic_guarded_spec_body
        ]

ML \<open>
structure Get_Body_Refines = struct

fun get ctxt name = let
    fun pget sfx = try (Proof_Context.get_thm ctxt o suffix sfx) name
    val eqv = pget "_body_refines"
    val def = pget "_body_def"
  in case (eqv, def) of
      (SOME eqvt, _) => eqvt
    | (_, SOME deft) => (deft RS @{thm simple_simpl_refines_from_def_eq})
    | _ => raise THM ("Get_Body_Refines.get: "
          ^ "no body_def or body_refines: " ^ name, 1, [])
  end

end
\<close>

end


(* Title:     Check_Monad
   Author:    Christian Sternagel
   Author:    René Thiemann
*)

section \<open>A Special Error Monad for Certification with Informative Error Messages\<close>

theory Check_Monad
imports Error_Monad
begin

text \<open>A check is either successful or fails with some error.\<close>
type_synonym
  'e check = "'e + unit"

abbreviation succeed :: "'e check"
where
  "succeed \<equiv> return ()"

definition check :: "bool \<Rightarrow> 'e \<Rightarrow> 'e check"
where
  "check b e = (if b then succeed else error e)"

lemma isOK_check [simp]:
  "isOK (check b e) = b" by (simp add: check_def)

lemma isOK_check_catch [simp]:
  "isOK (try check b e catch f) \<longleftrightarrow> b \<or> isOK (f e)"
  by (auto simp add: catch_def check_def)

definition check_return :: "'a check \<Rightarrow> 'b \<Rightarrow> 'a + 'b"
where
  "check_return chk res = (chk \<then> return res)"

lemma check_return [simp]:
  "check_return chk res = return res' \<longleftrightarrow> isOK chk \<and> res' = res"
  unfolding check_return_def by (cases chk) auto

lemma [code_unfold]:
  "check_return chk res = (case chk of Inr _ \<Rightarrow> Inr res | Inl e \<Rightarrow> Inl e)"
  unfolding check_return_def bind_def ..

abbreviation check_allm :: "('a \<Rightarrow> 'e check) \<Rightarrow> 'a list \<Rightarrow> 'e check"
where
  "check_allm f xs \<equiv> forallM f xs <+? snd"

abbreviation check_exm :: "('a \<Rightarrow> 'e check) \<Rightarrow> 'a list \<Rightarrow> ('e list \<Rightarrow> 'e) \<Rightarrow> 'e check"
where
  "check_exm f xs fld \<equiv> existsM f xs <+? fld"

lemma isOK_check_allm:
  "isOK (check_allm f xs) \<longleftrightarrow> (\<forall>x \<in> set xs. isOK (f x))"
  by simp

abbreviation check_allm_index :: "('a \<Rightarrow> nat \<Rightarrow> 'e check) \<Rightarrow> 'a list \<Rightarrow> 'e check"
where
  "check_allm_index f xs \<equiv> forallM_index f xs <+? snd"

abbreviation check_all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a check"
where
  "check_all f xs \<equiv> check_allm (\<lambda>x. if f x then succeed else error x) xs"

abbreviation check_all_index :: "('a \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> ('a \<times> nat) check"
where
  "check_all_index f xs \<equiv> check_allm_index (\<lambda>x i. if f x i then succeed else error (x, i)) xs"

lemma isOK_check_all_index [simp]:
  "isOK (check_all_index f xs) \<longleftrightarrow> (\<forall>i < length xs. f (xs ! i) i)"
  by auto

text \<open>The following version allows to modify the index during the check.\<close>
definition
  check_allm_gen_index ::
    "('a \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> ('a \<Rightarrow> nat \<Rightarrow> 'e check) \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'e check"
where
  "check_allm_gen_index g f n xs = snd (foldl (\<lambda>(i, m) x. (g x i, m \<then> f x i)) (n, succeed) xs)"

lemma foldl_error:
  "snd (foldl (\<lambda>(i, m) x . (g x i, m \<then> f x i)) (n, error e) xs) = error e"
  by (induct xs arbitrary: n) auto

lemma isOK_check_allm_gen_index [simp]:
  assumes "isOK (check_allm_gen_index g f n xs)"
  shows "\<forall>x\<in>set xs. \<exists>i. isOK (f x i)"
using assms
proof (induct xs arbitrary: n)
  case (Cons x xs)
  show ?case
  proof (cases "isOK (f x n)")
    case True
    then have "\<exists>i. isOK (f x i)" by auto
    with True Cons show ?thesis
      unfolding check_allm_gen_index_def by (force simp: isOK_iff)
  next
    case False
    then obtain e where "f x n = error e" by (cases "f x n") auto
    with foldl_error [of g f _ e] and Cons show ?thesis
      unfolding check_allm_gen_index_def by auto
  qed
qed simp

lemma check_allm_gen_index [fundef_cong]:
  fixes f :: "'a \<Rightarrow> nat \<Rightarrow> 'e check"
  assumes "\<And>x n. x \<in> set xs \<Longrightarrow> g x n = g' x n"
    and "\<And>x n. x \<in> set xs \<Longrightarrow> f x n = f' x n"
  shows "check_allm_gen_index g f n xs = check_allm_gen_index g' f' n xs"
proof -
  { fix n m
    have "foldl (\<lambda>(i, m) x. (g x i, m \<then> f x i)) (n, m) xs =
      foldl (\<lambda>(i, m) x. (g' x i, m \<then> f' x i)) (n, m) xs"
      using assms by (induct xs arbitrary: n m) auto }
  then show ?thesis unfolding check_allm_gen_index_def by simp
qed

definition check_subseteq :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a check"
where
  "check_subseteq xs ys = check_all (\<lambda>x. x \<in> set ys) xs"

lemma isOK_check_subseteq [simp]:
  "isOK (check_subseteq xs ys) \<longleftrightarrow> set xs \<subseteq> set ys"
  by (auto simp: check_subseteq_def)

definition check_same_set :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a check"
where
  "check_same_set xs ys = (check_subseteq xs ys \<then> check_subseteq ys xs)"

lemma isOK_check_same_set [simp]:
  "isOK (check_same_set xs ys) \<longleftrightarrow> set xs = set ys"
  unfolding check_same_set_def by auto

definition check_disjoint :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a check"
where
  "check_disjoint xs ys = check_all (\<lambda>x. x \<notin> set ys) xs"

lemma isOK_check_disjoint [simp]:
  "isOK (check_disjoint xs ys) \<longleftrightarrow> set xs \<inter> set ys = {}"
  unfolding check_disjoint_def by (auto)

definition check_all_combinations :: "('a \<Rightarrow> 'a \<Rightarrow> 'b check) \<Rightarrow> 'a list \<Rightarrow> 'b check"
where
  "check_all_combinations c xs = check_allm (\<lambda>x. check_allm (c x) xs) xs"

lemma isOK_check_all_combinations [simp]:
  "isOK (check_all_combinations c xs) \<longleftrightarrow> (\<forall>x \<in> set xs. \<forall>y \<in> set xs. isOK (c x y))"
  unfolding check_all_combinations_def by simp

fun check_pairwise :: "('a \<Rightarrow> 'a \<Rightarrow> 'b check) \<Rightarrow> 'a list \<Rightarrow> 'b check"
where
  "check_pairwise c [] = succeed" |
  "check_pairwise c (x # xs) = (check_allm (c x) xs \<then> check_pairwise c xs)"

lemma pairwise_aux:
  "(\<forall>j<length (x # xs). \<forall>i<j. P ((x # xs) ! i) ((x # xs) ! j))
     = ((\<forall>j<length xs. P x (xs ! j)) \<and> (\<forall>j<length xs. \<forall>i<j. P (xs ! i) (xs ! j)))"
  (is "?C = (?A \<and> ?B)")
proof (intro iffI conjI)
  assume *: "?A \<and> ?B"
  show "?C"
  proof (intro allI impI)
    fix i j
    assume "j < length (x # xs)" and "i < j"
    then show "P ((x # xs) ! i) ((x # xs) ! j)"
    proof (induct j)
      case (Suc j)
      then show ?case
        using * by (induct i) simp_all
    qed simp
  qed
qed force+

lemma isOK_check_pairwise [simp]:
  "isOK (check_pairwise c xs) \<longleftrightarrow> (\<forall>j<length xs. \<forall>i<j. isOK (c (xs ! i) (xs ! j)))"
proof (induct xs)
  case (Cons x xs)
  have "isOK (check_allm (c x) xs) = (\<forall>j<length xs. isOK (c x (xs ! j)))"
    using all_set_conv_all_nth [of xs "\<lambda>y. isOK (c x y)"] by simp
  then have "isOK (check_pairwise c (x # xs)) =
    ((\<forall>j<length xs. isOK (c x (xs ! j))) \<and> (\<forall>j<length xs. \<forall>i<j. isOK (c (xs ! i) (xs ! j))))"
    by (simp add: Cons)
  then show ?case using pairwise_aux [of x xs "\<lambda>x y. isOK (c x y)"] by simp
qed auto

abbreviation check_exists :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> ('a list) check"
where
  "check_exists f xs \<equiv> check_exm (\<lambda>x. if f x then succeed else error [x]) xs concat"

lemma isOK_choice [simp]:
  "isOK (choice []) \<longleftrightarrow> False"
  "isOK (choice (x # xs)) \<longleftrightarrow> isOK x \<or> isOK (choice xs)"
  by (auto simp: choice.simps isOK_def split: sum.splits)

fun or_ok :: "'a check \<Rightarrow> 'a check \<Rightarrow> 'a check" where
  "or_ok (Inl a) b = b" |
  "or_ok (Inr a) b = Inr a"

end