(*  Title:       X86 instruction semantics and basic block symbolic execution
    Authors:     Freek Verbeek, Abhijith Bharadwaj, Joshua Bockenek, Ian Roessle, Timmy Weerwag, Binoy Ravindran
    Year:        2020
    Maintainer:  Freek Verbeek (freek@vt.edu)
*)

section "Bit and byte-level theorems"

theory BitByte
  imports Main "Word_Lib.Syntax_Bundles" "Word_Lib.Bit_Shifts_Infix_Syntax" "Word_Lib.Bitwise"
begin

subsection \<open>Basics\<close>

unbundle bit_operations_syntax
unbundle bit_projection_infix_syntax

definition take_bits :: "nat \<Rightarrow> nat \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word" ("\<langle>_,_\<rangle>_" 51) \<comment> \<open>little-endian\<close>
  where "take_bits l h w \<equiv> (w >> l) AND mask (h-l)"

text \<open>
  @{term "take_bits l h w"} takes a subset of bits from word @{term w}, from low (inclusive) to high (exclusive).
  For example, @{term [show_types] "take_bits 2 5 (28::8word) = 7"}.
\<close>

definition take_byte :: "nat \<Rightarrow> 'a::len word \<Rightarrow> 8word" \<comment> \<open>little-endian\<close>
  where "take_byte n w \<equiv> ucast (\<langle>n*8,n*8+8\<rangle>w)"

text \<open>
  @{term "take_byte n w"} takes the nth byte from word @{term w}.
  For example, @{term [show_types] "take_byte 1 (42 << 8::16word) = 42"}.
\<close>

definition overwrite :: "nat \<Rightarrow> nat \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word"
  where "overwrite l h w0 w1 \<equiv> ((\<langle>h,LENGTH('a)\<rangle>w0) << h) OR ((\<langle>l,h\<rangle>w1) << l) OR (\<langle>0,l\<rangle>w0)"

text \<open>
  @{term "overwrite l h w0 w1"} overwrites low (inclusive) to high (exclusive) bits in
  word @{term w0} with bits from word @{term w1}.
  For example, @{term [show_types] "(overwrite 2 4 28 227 :: 8word) = 16"}.
\<close>

text \<open>We prove some theorems about taking the nth bit/byte of an operation. These are useful to prove
      equaltiy between different words, by first applying rule @{thm word_eqI}.\<close>

lemma bit_take_bits_iff [bit_simps]:
  \<open>(\<langle>l,h\<rangle>w) !! n \<longleftrightarrow> n < LENGTH('a) \<and> n < h - l \<and> w !! (n + l)\<close> for w :: \<open>'a::len word\<close>
  by (simp add: take_bits_def bit_simps ac_simps)

lemma bit_take_byte_iff [bit_simps]:
  \<open>take_byte m w !! n \<longleftrightarrow> n < LENGTH('a) \<and> n < 8 \<and> w !! (n + m * 8)\<close> for w :: \<open>'a::len word\<close>
  by (auto simp add: take_byte_def bit_simps)

lemma bit_overwrite_iff [bit_simps]:
  \<open>overwrite l h w0 w1 !! n \<longleftrightarrow> n < LENGTH('a) \<and>
    (if l \<le> n \<and> n < h then w1 else w0) !! n\<close>
    for w0 w1 :: \<open>'a::len word\<close>
  by (auto simp add: overwrite_def bit_simps)

lemma nth_takebits:
  fixes w :: "'a::len word"
  shows "(\<langle>l,h\<rangle>w) !! n = (if n < LENGTH('a) \<and> n < h - l then w !! (n + l) else False)"
  by (auto simp add: bit_simps)

lemma nth_takebyte:
  fixes w :: "'a::len word"
  shows "take_byte (n div 8) w !! (n mod 8) = (if n mod 8 < LENGTH('a) then w!!n else False )"
  by (simp add: bit_simps)

lemma nth_take_byte_overwrite:
  fixes v v' :: "'a::len word"
  shows "take_byte n (overwrite l h v v') !! i = (if i + n * 8 < l \<or> i + n * 8 \<ge> h then take_byte n v !! i else take_byte n v' !! i)"
  by (auto simp add: bit_simps dest: bit_imp_le_length)

lemma nth_bitNOT:
  fixes a :: "'a::len word"
  shows "(NOT a) !! n \<longleftrightarrow> (if n < LENGTH('a)  then \<not>(a !! n) else False)"
  by (simp add: bit_simps)

text \<open>Various simplification rules\<close>

lemma ucast_take_bits:
  fixes w :: "'a::len word"
  assumes "h = LENGTH('b)"
      and "LENGTH('b) \<le> LENGTH('a)"
    shows "ucast (\<langle>0,h\<rangle>w) = (ucast w ::'b :: len word)"
  apply (rule bit_word_eqI)
  using assms
  apply (simp add: bit_simps)
  done

lemma take_bits_ucast:
  fixes w :: "'b::len word"
  assumes "h = LENGTH('b)"
  shows "(\<langle>0,h\<rangle> (ucast w ::'a :: len word)) = (ucast w ::'a :: len word)"
  apply (rule bit_word_eqI)
  using assms
  apply (auto simp add: bit_simps dest: bit_imp_le_length)
  done

lemma take_bits_take_bits:
  fixes w :: "'a::len word"
  shows "(\<langle>l,h\<rangle>(\<langle>l',h'\<rangle>w)) = (if min LENGTH('a) h \<ge> h' - l' then \<langle>l+l',h'\<rangle>w else (\<langle>l+l',l'+min LENGTH('a) h\<rangle>w))"
  apply (rule bit_word_eqI)
  apply (simp add: bit_simps ac_simps)
  apply auto
  done

lemma take_bits_overwrite:
  shows "\<langle>l,h\<rangle>(overwrite l h w0 w1) = \<langle>l,h\<rangle>w1"
  apply (rule bit_word_eqI)
  apply (simp add: bit_simps ac_simps)
  apply (auto dest: bit_imp_le_length)
  done

lemma overwrite_0_take_bits_0:
  shows "overwrite 0 h (\<langle>0,h\<rangle>w0) w1 = \<langle>0,h\<rangle>w1"
  apply (rule bit_word_eqI)
  apply (simp add: bit_simps ac_simps)
  done

lemma take_byte_shiftlr_256:
  fixes v :: "256 word"
  assumes "m \<le> n"
  shows "take_byte n (v << m*8) = (if (n+1)*8 \<le> 256 then take_byte (n-m) v else 0)"
  apply (rule bit_word_eqI)
  using assms
  apply (simp add: bit_simps)
  apply (simp add: algebra_simps)
  done

subsection \<open> Take\_Bits and arithmetic\<close>

text \<open>This definition is based on @{thm to_bl_plus_carry}, which formulates addition as bitwise operations using @{term xor3} and @{term carry}.\<close>

definition bitwise_add :: "(bool \<times> bool) list \<Rightarrow> bool \<Rightarrow> bool list"
  where "bitwise_add x c \<equiv> foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car)) x (\<lambda>_. []) c"

lemma length_foldr_bitwise_add:
  shows "length (bitwise_add x c) = length x"
  unfolding bitwise_add_def
  by(induct x arbitrary: c) auto

text \<open>This is the "heart" of the proof: bitwise addition of two appended zipped lists can be expressed as
      two consecutive bitwise additions.
      Here, I need to make the assumption that the final carry is False.
 \<close>
lemma bitwise_add_append:
  assumes "x = [] \<or> \<not>carry (fst (last x)) (snd (last x)) True"
  shows "bitwise_add (x @ y) (x\<noteq>[] \<and> c) = bitwise_add x (x\<noteq>[] \<and> c) @ bitwise_add y False"
  using assms
  unfolding bitwise_add_def
  by(induct x arbitrary: c) (auto simp add: case_prod_unfold xor3_def carry_def split: if_split_asm)

lemma bitwise_add_take_append:
  shows "take (length x) (bitwise_add (x @ y) c) = bitwise_add x c"
  unfolding bitwise_add_def
  by(induct x arbitrary: c) (auto simp add: case_prod_unfold xor3_def carry_def split: if_split_asm)

lemma bitwise_add_zero:
  shows "bitwise_add (replicate n (False, False)) False = replicate n False "
  unfolding bitwise_add_def
  by(induct n) (auto simp add: xor3_def carry_def)

lemma bitwise_add_take:
  shows "take n (bitwise_add x c) = bitwise_add (take n x) c"
  unfolding bitwise_add_def
  by (induct n arbitrary: x c,auto)
     (metis append_take_drop_id bitwise_add_def bitwise_add_take_append diff_is_0_eq' length_foldr_bitwise_add length_take nat_le_linear rev_min_pm1 take_all)

lemma fst_hd_drop_zip:
  assumes "n < length x"
      and "length x = length y"
  shows "fst (hd (drop n (zip x y))) = hd (drop n x)"
  using assms
  by (induct x arbitrary: n y,auto)
     (metis (no_types, lifting) Cons_nth_drop_Suc drop_zip fst_conv length_Cons list.sel(1) zip_Cons_Cons)

lemma snd_hd_drop_zip:
  assumes "n < length x"
      and "length x = length y"
  shows "snd (hd (drop n (zip x y))) = hd (drop n y)"
  using assms
  by (induct x arbitrary: n y,auto)
     (metis (no_types, lifting) Cons_nth_drop_Suc drop_zip snd_conv length_Cons list.sel(1) zip_Cons_Cons)

text \<open>
  Ucasting of @{term "a+b"} can be rewritten to taking bits of @{term a} and @{term b}.
\<close>

lemma ucast_plus:
  fixes a b :: "'a::len word"
  assumes "LENGTH('a) > LENGTH('b)"
  shows "(ucast (a + b) ::'b::len word) = (ucast a + ucast b::'b::len word)"
proof-
  have "to_bl (ucast (a + b) ::'b::len word) = to_bl (ucast a + ucast b::'b::len word)"
    using assms
    apply (auto simp add: to_bl_ucast to_bl_plus_carry word_rep_drop length_foldr_bitwise_add drop_zip[symmetric] rev_drop bitwise_add_def simp del: foldr_replicate foldr_append)
    apply (simp only: bitwise_add_def[symmetric] length_foldr_bitwise_add)
    by (auto simp add: drop_take bitwise_add_take[symmetric] rev_take length_foldr_bitwise_add)
  thus ?thesis
    using word_bl.Rep_eqD
    by blast
qed

lemma ucast_uminus:
  fixes a b :: "'a::len word"
assumes "LENGTH('a) > LENGTH('b)"
  shows "ucast (- a) = (- ucast a :: 'b::len word)"
  apply (subst twos_complement)+
  apply (subst word_succ_p1)+
  apply (subst ucast_plus)
  apply (rule assms)
   apply simp
   apply (rule word_eqI)
   apply (auto simp add: word_size nth_ucast nth_bitNOT)
   using assms order.strict_trans
   by blast

lemma ucast_minus:
  fixes a b :: "'a::len word"
  assumes "LENGTH('a) > LENGTH('b)"
  shows "(ucast (a - b) ::'b::len word) = (ucast a - ucast b::'b::len word)"
  using ucast_plus[OF assms,of a "-b"] ucast_uminus[OF assms,of b]
  by auto

lemma to_bl_takebits:
  fixes a :: "'a::len word"
  shows "to_bl (\<langle>0,h\<rangle>a) = replicate (LENGTH('a) - h) False @ drop (LENGTH('a) - h) (to_bl a)"
  apply (auto simp add: take_bits_def bl_word_and to_bl_mask)
  apply (rule nth_equalityI)
  by (auto simp add: min_def nth_append)

text \<open> All simplification rules that are used during symbolic execution.\<close>
lemmas BitByte_simps = ucast_plus ucast_minus ucast_uminus take_bits_overwrite take_bits_take_bits
  ucast_take_bits overwrite_0_take_bits_0 mask_eq_exp_minus_1
  ucast_down_ucast_id is_down take_bits_ucast ucast_up_ucast_id is_up

text \<open>Simplification for immediate (numeral) values.\<close>
lemmas take_bits_numeral[simp] = take_bits_def[of _ _ "numeral n"] for n
lemmas take_bits_num0[simp] = take_bits_def[of _ _ "0"] for n
lemmas take_bits_num1[simp] = take_bits_def[of _ _ "1"] for n
lemmas overwrite_numeral_numeral[simp] = overwrite_def[of _ _ "numeral n" "numeral m"] for n m
lemmas overwrite_num0_numeral[simp] = overwrite_def[of _ _ 0 "numeral m"] for n m
lemmas overwrite_numeral_num0[simp] = overwrite_def[of _ _ "numeral m" 0] for n m
lemmas overwrite_numeral_00[simp] = overwrite_def[of _ _ 0 0]

end


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

(* Authors: Gerwin Klein and Rafal Kolanski, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter "Abstract Separation Algebra"

theory Separation_Algebra
imports
  Arbitrary_Comm_Monoid
  "~~/src/Tools/Adhoc_Overloading"
begin

text {* This theory is the main abstract separation algebra development *}

section {* Input syntax for lifting boolean predicates to separation predicates *}

abbreviation (input)
  pred_and :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (infixr "and" 35) where
  "a and b \<equiv> \<lambda>s. a s \<and> b s"

abbreviation (input)
  pred_or :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (infixr "or" 30) where
  "a or b \<equiv> \<lambda>s. a s \<or> b s"

abbreviation (input)
  pred_not :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" ("not _" [40] 40) where
  "not a \<equiv> \<lambda>s. \<not>a s"

abbreviation (input)
  pred_imp :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (infixr "imp" 25) where
  "a imp b \<equiv> \<lambda>s. a s \<longrightarrow> b s"

abbreviation (input)
  pred_K :: "'b \<Rightarrow> 'a \<Rightarrow> 'b" ("\<langle>\<langle>_\<rangle>\<rangle>") where
  "\<langle>\<langle>f\<rangle>\<rangle> \<equiv> \<lambda>s. f"

abbreviation (input)
  pred_ex :: "('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (binder "EXS " 10) where
  "EXS x. P x \<equiv> \<lambda>s. \<exists>x. P x s"

abbreviation (input)
  pred_all :: "('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (binder "ALLS " 10) where
  "ALLS x. P x \<equiv> \<lambda>s. \<forall>x. P x s"

section {* Associative/Commutative Monoid Basis of Separation Algebras *}

class pre_sep_algebra = zero + plus +
  fixes sep_disj :: "'a => 'a => bool" (infix "##" 60)

  assumes sep_disj_zero [simp]: "x ## 0"
  assumes sep_disj_commuteI: "x ## y \<Longrightarrow> y ## x"

  assumes sep_add_zero [simp]: "x + 0 = x"
  assumes sep_add_commute: "x ## y \<Longrightarrow> x + y = y + x"

  assumes sep_add_assoc:
    "\<lbrakk> x ## y; y ## z; x ## z \<rbrakk> \<Longrightarrow> (x + y) + z = x + (y + z)"
begin

lemma sep_disj_commute: "x ## y = y ## x"
  by (blast intro: sep_disj_commuteI)

lemma sep_add_left_commute:
  assumes a: "a ## b" "b ## c" "a ## c"
  shows "b + (a + c) = a + (b + c)" (is "?lhs = ?rhs")
proof -
  have "?lhs = b + a + c" using a
    by (simp add: sep_add_assoc[symmetric] sep_disj_commute)
  also have "... = a + b + c" using a
    by (simp add: sep_add_commute sep_disj_commute)
  also have "... = ?rhs" using a
    by (simp add: sep_add_assoc sep_disj_commute)
  finally show ?thesis .
qed

lemmas sep_add_ac = sep_add_assoc sep_add_commute sep_add_left_commute
                    sep_disj_commute (* nearly always necessary *)

end

section {* Separation Algebra as Defined by Calcagno et al. *}

class sep_algebra = pre_sep_algebra +
  assumes sep_disj_addD1: "\<lbrakk> x ## y + z; y ## z \<rbrakk> \<Longrightarrow> x ## y"
  assumes sep_disj_addI1: "\<lbrakk> x ## y + z; y ## z \<rbrakk> \<Longrightarrow> x + y ## z"
begin

subsection {* Basic Construct Definitions and Abbreviations *}

(* Lower precedence than pred_conj, otherwise "P \<and>* Q and R" is ambiguous,
 * (noting that Isabelle turns "(P \<and>* Q) and R" into "P \<and>* Q and R").
 *)
definition
  sep_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixr "**" 36)
  where
  "P ** Q \<equiv> \<lambda>h. \<exists>x y. x ## y \<and> h = x + y \<and> P x \<and> Q y"

notation
  sep_conj (infixr "\<and>*" 36)
notation (latex output)
  sep_conj (infixr "\<and>\<^sup>*" 36)

definition
  sep_empty :: "'a \<Rightarrow> bool" ("\<box>") where
  "\<box> \<equiv> \<lambda>h. h = 0"

definition
  sep_impl :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixr "\<longrightarrow>*" 25)
  where
  "P \<longrightarrow>* Q \<equiv> \<lambda>h. \<forall>h'. h ## h' \<and> P h' \<longrightarrow> Q (h + h')"

definition
  sep_substate :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>" 60) where
  "x \<preceq> y \<equiv> \<exists>z. x ## z \<and> x + z = y"

(* We want these to be abbreviations not definitions, because basic True and
   False will occur by simplification in sep_conj terms *)
abbreviation
  "sep_true \<equiv> \<langle>\<langle>True\<rangle>\<rangle>"

abbreviation
  "sep_false \<equiv> \<langle>\<langle>False\<rangle>\<rangle>"

subsection {* Disjunction/Addition Properties *}

lemma disjoint_zero_sym [simp]: "0 ## x"
  by (simp add: sep_disj_commute)

lemma sep_add_zero_sym [simp]: "0 + x = x"
  by (simp add: sep_add_commute)

lemma sep_disj_addD2: "\<lbrakk> x ## y + z; y ## z \<rbrakk> \<Longrightarrow> x ## z"
  by (metis sep_add_commute sep_disj_addD1 sep_disj_commuteI)

lemma sep_disj_addD: "\<lbrakk> x ## y + z; y ## z \<rbrakk> \<Longrightarrow> x ## y \<and> x ## z"
  by (metis sep_disj_addD1 sep_disj_addD2)

lemma sep_add_disjD: "\<lbrakk> x + y ## z; x ## y \<rbrakk> \<Longrightarrow> x ## z \<and> y ## z"
  by (metis sep_disj_addD sep_disj_commuteI)

lemma sep_disj_addI2:
  "\<lbrakk> x ## y + z; y ## z \<rbrakk> \<Longrightarrow> x + z ## y"
  using sep_add_commute sep_disj_addI1 sep_disj_commuteI by presburger

lemma sep_add_disjI1:
  "\<lbrakk> x + y ## z; x ## y \<rbrakk> \<Longrightarrow> x + z ## y"
  by (metis sep_add_commute sep_disj_addI1 sep_disj_commuteI sep_add_disjD)

lemma sep_add_disjI2:
  "\<lbrakk> x + y ## z; x ## y \<rbrakk> \<Longrightarrow> z + y ## x"
  by (metis sep_add_commute sep_disj_addI1 sep_disj_commuteI sep_add_disjD)

lemma sep_disj_addI3:
  "x + y ## z \<Longrightarrow> x ## y \<Longrightarrow> x ## y + z"
  by (metis sep_add_commute sep_disj_addI1 sep_disj_commuteI sep_add_disjD)

lemma sep_disj_add:
  "\<lbrakk> y ## z; x ## y \<rbrakk> \<Longrightarrow> x ## y + z = x + y ## z"
  by (metis sep_disj_addI1 sep_disj_addI3)

subsection {* Substate Properties *}

lemma sep_substate_disj_add:
  "x ## y \<Longrightarrow> x \<preceq> x + y"
  unfolding sep_substate_def by blast

lemma sep_substate_disj_add':
  "x ## y \<Longrightarrow> x \<preceq> y + x"
  by (simp add: sep_add_ac sep_substate_disj_add)

subsection {* Separating Conjunction Properties *}

lemma sep_conjD:
  "(P \<and>* Q) h \<Longrightarrow> \<exists>x y. x ## y \<and> h = x + y \<and> P x \<and> Q y"
  by (simp add: sep_conj_def)

lemma sep_conjE:
  "\<lbrakk> (P ** Q) h; \<And>x y. \<lbrakk> P x; Q y; x ## y; h = x + y \<rbrakk> \<Longrightarrow> X \<rbrakk> \<Longrightarrow> X"
  by (auto simp: sep_conj_def)

lemma sep_conjI:
  "\<lbrakk> P x; Q y; x ## y; h = x + y \<rbrakk> \<Longrightarrow> (P ** Q) h"
  by (auto simp: sep_conj_def)

lemma sep_conj_commuteI:
  "(P ** Q) h \<Longrightarrow> (Q ** P) h"
  by (auto intro!: sep_conjI elim!: sep_conjE simp: sep_add_ac)

lemma sep_conj_commute:
  "(P ** Q) = (Q ** P)"
  by (rule ext) (auto intro: sep_conj_commuteI)

lemma sep_conj_assoc:
  "((P ** Q) ** R) = (P ** Q ** R)" (is "?lhs = ?rhs")
proof (rule ext, rule iffI)
  fix h
  assume a: "?lhs h"
  then obtain x y z where "P x" and "Q y" and "R z"
                      and "x ## y" and "x ## z" and "y ## z" and "x + y ## z"
                      and "h = x + y + z"
    by (auto dest!: sep_conjD dest: sep_add_disjD)
  moreover
  then have "x ## y + z"
    by (simp add: sep_disj_add)
  ultimately
  show "?rhs h"
    by (auto simp: sep_add_ac intro!: sep_conjI)
next
  fix h
  assume a: "?rhs h"
  then obtain x y z where "P x" and "Q y" and "R z"
                      and "x ## y" and "x ## z" and "y ## z" and "x ## y + z"
                      and "h = x + y + z"
    by (fastforce elim!: sep_conjE simp: sep_add_ac dest: sep_disj_addD)
  thus "?lhs h"
    by (metis sep_conj_def sep_disj_addI1)
qed

lemma sep_conj_impl:
  "\<lbrakk> (P ** Q) h; \<And>h. P h \<Longrightarrow> P' h; \<And>h. Q h \<Longrightarrow> Q' h \<rbrakk> \<Longrightarrow> (P' ** Q') h"
  by (erule sep_conjE, auto intro!: sep_conjI)

lemma sep_conj_impl1:
  assumes P: "\<And>h. P h \<Longrightarrow> I h"
  shows "(P ** R) h \<Longrightarrow> (I ** R) h"
  by (auto intro: sep_conj_impl P)

lemma sep_globalise:
  "\<lbrakk> (P ** R) h; (\<And>h. P h \<Longrightarrow> Q h) \<rbrakk> \<Longrightarrow> (Q ** R) h"
  by (fast elim: sep_conj_impl)

lemma sep_conj_trivial_strip1:
  "Q = R \<Longrightarrow> (P ** Q) = (P ** R)" by simp

lemma sep_conj_trivial_strip2:
  "Q = R \<Longrightarrow> (Q ** P) = (R ** P)" by simp

lemma disjoint_subheaps_exist:
  "\<exists>x y. x ## y \<and> h = x + y"
  by (rule_tac x=0 in exI, auto)

lemma sep_conj_left_commute: (* for permutative rewriting *)
  "(P ** (Q ** R)) = (Q ** (P ** R))" (is "?x = ?y")
proof -
  have "?x = ((Q ** R) ** P)" by (simp add: sep_conj_commute)
  also have "\<dots> = (Q ** (R ** P))" by (subst sep_conj_assoc, simp)
  finally show ?thesis by (simp add: sep_conj_commute)
qed

lemmas sep_conj_ac = sep_conj_commute sep_conj_assoc sep_conj_left_commute

lemma sep_empty_zero [simp,intro!]: "\<box> 0"
  by (simp add: sep_empty_def)

subsection {* Properties of @{text sep_true} and @{text sep_false} *}

lemma sep_conj_sep_true:
  "P h \<Longrightarrow> (P ** sep_true) h"
  by (simp add: sep_conjI[where y=0])

lemma sep_conj_sep_true':
  "P h \<Longrightarrow> (sep_true ** P) h"
  by (simp add: sep_conjI[where x=0])

lemma sep_conj_true [simp]:
  "(sep_true ** sep_true) = sep_true"
  unfolding sep_conj_def
  by (auto intro: disjoint_subheaps_exist)

lemma sep_conj_false_right [simp]:
  "(P ** sep_false) = sep_false"
  by (force elim: sep_conjE)

lemma sep_conj_false_left [simp]:
  "(sep_false ** P) = sep_false"
  by (subst sep_conj_commute) (rule sep_conj_false_right)

subsection {* Properties of @{const sep_empty} *}

lemma sep_conj_empty [simp]:
  "(P ** \<box>) = P"
  by (simp add: sep_conj_def sep_empty_def)

lemma sep_conj_empty'[simp]:
  "(\<box> ** P) = P"
  by (subst sep_conj_commute, rule sep_conj_empty)

lemma sep_conj_sep_emptyI:
  "P h \<Longrightarrow> (P ** \<box>) h"
  by simp

lemma sep_conj_sep_emptyE:
  "\<lbrakk> P s; (P ** \<box>) s \<Longrightarrow> (Q ** R) s \<rbrakk> \<Longrightarrow> (Q ** R) s"
  by simp

subsection {* Properties of top (@{text sep_true}) *}

lemma sep_conj_true_P [simp]:
  "(sep_true ** (sep_true ** P)) = (sep_true ** P)"
  by (simp add: sep_conj_assoc[symmetric])

lemma sep_conj_disj:
  "((P or Q) ** R) = ((P ** R) or (Q ** R))"
  by (rule ext, auto simp: sep_conj_def)

lemma sep_conj_sep_true_left:
  "(P ** Q) h \<Longrightarrow> (sep_true ** Q) h"
  by (erule sep_conj_impl, simp+)

lemma sep_conj_sep_true_right:
  "(P ** Q) h \<Longrightarrow> (P ** sep_true) h"
  by (subst (asm) sep_conj_commute, drule sep_conj_sep_true_left,
      simp add: sep_conj_ac)

subsection {* Separating Conjunction with Quantifiers *}

lemma sep_conj_conj:
  "((P and Q) ** R) h \<Longrightarrow> ((P ** R) and (Q ** R)) h"
  by (force intro: sep_conjI elim!: sep_conjE)

lemma sep_conj_exists1:
  "((EXS x. P x) ** Q) = (EXS x. (P x ** Q))"
  by (force intro: sep_conjI elim: sep_conjE)

lemma sep_conj_exists2:
  "(P ** (EXS x. Q x)) = (EXS x. P ** Q x)"
  by (force intro!: sep_conjI elim!: sep_conjE)

lemmas sep_conj_exists = sep_conj_exists1 sep_conj_exists2

lemma sep_conj_spec1:
  "((ALLS x. P x) ** Q) h \<Longrightarrow> (P x ** Q) h"
  by (force intro: sep_conjI elim: sep_conjE)

lemma sep_conj_spec2:
  "(P ** (ALLS x. Q x)) h \<Longrightarrow> (P ** Q x) h"
  by (force intro: sep_conjI elim: sep_conjE)

lemmas sep_conj_spec = sep_conj_spec1 sep_conj_spec2

subsection {* Properties of Separating Implication *}

lemma sep_implI:
  assumes a: "\<And>h'. \<lbrakk> h ## h'; P h' \<rbrakk> \<Longrightarrow> Q (h + h')"
  shows "(P \<longrightarrow>* Q) h"
  unfolding sep_impl_def by (auto elim: a)

lemma sep_implD:
  "(x \<longrightarrow>* y) h \<Longrightarrow> \<forall>h'. h ## h' \<and> x h' \<longrightarrow> y (h + h')"
  by (force simp: sep_impl_def)

lemma sep_implE:
  "(x \<longrightarrow>* y) h \<Longrightarrow> (\<forall>h'. h ## h' \<and> x h' \<longrightarrow> y (h + h') \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (auto dest: sep_implD)

lemma sep_impl_sep_true [simp]:
  "(P \<longrightarrow>* sep_true) = sep_true"
  by (force intro!: sep_implI)

lemma sep_impl_sep_false [simp]:
  "(sep_false \<longrightarrow>* P) = sep_true"
  by (force intro!: sep_implI)

lemma sep_impl_sep_true_P:
  "(sep_true \<longrightarrow>* P) h \<Longrightarrow> P h"
  by (clarsimp dest!: sep_implD elim!: allE[where x=0])

lemma sep_impl_sep_true_false [simp]:
  "(sep_true \<longrightarrow>* sep_false) = sep_false"
  by (force dest: sep_impl_sep_true_P)

lemma sep_conj_sep_impl:
  "\<lbrakk> P h; \<And>h. (P ** Q) h \<Longrightarrow> R h \<rbrakk> \<Longrightarrow> (Q \<longrightarrow>* R) h"
proof (rule sep_implI)
  fix h' h
  assume "P h" and "h ## h'" and "Q h'"
  hence "(P ** Q) (h + h')" by (force intro: sep_conjI)
  moreover assume "\<And>h. (P ** Q) h \<Longrightarrow> R h"
  ultimately show "R (h + h')" by simp
qed

lemma sep_conj_sep_impl2:
  "\<lbrakk> (P ** Q) h; \<And>h. P h \<Longrightarrow> (Q \<longrightarrow>* R) h \<rbrakk> \<Longrightarrow> R h"
  by (force dest: sep_implD elim: sep_conjE)

lemma sep_conj_sep_impl_sep_conj2:
  "(P ** R) h \<Longrightarrow> (P ** (Q \<longrightarrow>* (Q ** R))) h"
  by (erule (1) sep_conj_impl, erule sep_conj_sep_impl, simp add: sep_conj_ac)

subsection {* Pure assertions *}

definition
  pure :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "pure P \<equiv> \<forall>h h'. P h = P h'"

lemma pure_sep_true:
  "pure sep_true"
  by (simp add: pure_def)

lemma pure_sep_false:
  "pure sep_false"
  by (simp add: pure_def)

lemma pure_split:
  "pure P = (P = sep_true \<or> P = sep_false)"
  by (force simp: pure_def)

lemma pure_sep_conj:
  "\<lbrakk> pure P; pure Q \<rbrakk> \<Longrightarrow> pure (P \<and>* Q)"
  by (force simp: pure_split)

lemma pure_sep_impl:
  "\<lbrakk> pure P; pure Q \<rbrakk> \<Longrightarrow> pure (P \<longrightarrow>* Q)"
  by (force simp: pure_split)

lemma pure_conj_sep_conj:
  "\<lbrakk> (P and Q) h; pure P \<or> pure Q \<rbrakk> \<Longrightarrow> (P \<and>* Q) h"
  by (metis pure_def sep_add_zero sep_conjI sep_conj_commute sep_disj_zero)

lemma pure_sep_conj_conj:
  "\<lbrakk> (P \<and>* Q) h; pure P; pure Q \<rbrakk> \<Longrightarrow> (P and Q) h"
  by (force simp: pure_split)

lemma pure_conj_sep_conj_assoc:
  "pure P \<Longrightarrow> ((P and Q) \<and>* R) = (P and (Q \<and>* R))"
  by (auto simp: pure_split)

lemma pure_sep_impl_impl:
  "\<lbrakk> (P \<longrightarrow>* Q) h; pure P \<rbrakk> \<Longrightarrow> P h \<longrightarrow> Q h"
  by (force simp: pure_split dest: sep_impl_sep_true_P)

lemma pure_impl_sep_impl:
  "\<lbrakk> P h \<longrightarrow> Q h; pure P; pure Q \<rbrakk> \<Longrightarrow> (P \<longrightarrow>* Q) h"
  by (force simp: pure_split)

lemma pure_conj_right: "(Q \<and>* (\<langle>\<langle>P'\<rangle>\<rangle> and Q')) = (\<langle>\<langle>P'\<rangle>\<rangle> and (Q \<and>* Q'))"
  by (rule ext, rule, rule, clarsimp elim!: sep_conjE)
     (erule sep_conj_impl, auto)

lemma pure_conj_right': "(Q \<and>* (P' and \<langle>\<langle>Q'\<rangle>\<rangle>)) = (\<langle>\<langle>Q'\<rangle>\<rangle> and (Q \<and>* P'))"
  by (simp add: conj_comms pure_conj_right)

lemma pure_conj_left: "((\<langle>\<langle>P'\<rangle>\<rangle> and Q') \<and>* Q) = (\<langle>\<langle>P'\<rangle>\<rangle> and (Q' \<and>* Q))"
  by (simp add: pure_conj_right sep_conj_ac)

lemma pure_conj_left': "((P' and \<langle>\<langle>Q'\<rangle>\<rangle>) \<and>* Q) = (\<langle>\<langle>Q'\<rangle>\<rangle> and (P' \<and>* Q))"
  by (subst conj_comms, subst pure_conj_left, simp)

lemmas pure_conj = pure_conj_right pure_conj_right' pure_conj_left
    pure_conj_left'

declare pure_conj[simp add]

subsection {* Intuitionistic assertions *}

definition intuitionistic :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "intuitionistic P \<equiv> \<forall>h h'. P h \<and> h \<preceq> h' \<longrightarrow> P h'"

lemma intuitionisticI:
  "(\<And>h h'. \<lbrakk> P h; h \<preceq> h' \<rbrakk> \<Longrightarrow> P h') \<Longrightarrow> intuitionistic P"
  by (unfold intuitionistic_def, fast)

lemma intuitionisticD:
  "\<lbrakk> intuitionistic P; P h; h \<preceq> h' \<rbrakk> \<Longrightarrow> P h'"
  by (unfold intuitionistic_def, fast)

lemma pure_intuitionistic:
  "pure P \<Longrightarrow> intuitionistic P"
  by (clarsimp simp: intuitionistic_def pure_def, fast)

lemma intuitionistic_conj:
  "\<lbrakk> intuitionistic P; intuitionistic Q \<rbrakk> \<Longrightarrow> intuitionistic (P and Q)"
  by (force intro: intuitionisticI dest: intuitionisticD)

lemma intuitionistic_disj:
  "\<lbrakk> intuitionistic P; intuitionistic Q \<rbrakk> \<Longrightarrow> intuitionistic (P or Q)"
  by (force intro: intuitionisticI dest: intuitionisticD)

lemma intuitionistic_forall:
  "(\<And>x. intuitionistic (P x)) \<Longrightarrow> intuitionistic (ALLS x. P x)"
  by (force intro: intuitionisticI dest: intuitionisticD)

lemma intuitionistic_exists:
  "(\<And>x. intuitionistic (P x)) \<Longrightarrow> intuitionistic (EXS x. P x)"
  by (force intro: intuitionisticI dest: intuitionisticD)

lemma intuitionistic_sep_conj_sep_true:
  "intuitionistic (sep_true \<and>* P)"
proof (rule intuitionisticI)
  fix h h' r
  assume a: "(sep_true \<and>* P) h"
  then obtain x y where P: "P y" and h: "h = x + y" and xyd: "x ## y"
    by - (drule sep_conjD, clarsimp)
  moreover assume a2: "h \<preceq> h'"
  then obtain z where h': "h' = h + z" and hzd: "h ## z"
    by (clarsimp simp: sep_substate_def)

  moreover have "(P \<and>* sep_true) (y + (x + z))"
    using P h hzd xyd
    by (metis sep_add_disjI1 sep_disj_commute sep_conjI)
  ultimately show "(sep_true \<and>* P) h'" using hzd
    by (auto simp: sep_conj_commute sep_add_ac dest!: sep_disj_addD)
qed

lemma intuitionistic_sep_impl_sep_true:
  "intuitionistic (sep_true \<longrightarrow>* P)"
proof (rule intuitionisticI)
  fix h h'
  assume imp: "(sep_true \<longrightarrow>* P) h" and hh': "h \<preceq> h'"

  from hh' obtain z where h': "h' = h + z" and hzd: "h ## z"
    by (clarsimp simp: sep_substate_def)
  show "(sep_true \<longrightarrow>* P) h'" using imp h' hzd
    apply (clarsimp dest!: sep_implD)
    apply (metis sep_add_assoc sep_add_disjD sep_disj_addI3 sep_implI)
    done
qed

lemma intuitionistic_sep_conj:
  assumes ip: "intuitionistic (P::('a \<Rightarrow> bool))"
  shows "intuitionistic (P \<and>* Q)"
proof (rule intuitionisticI)
  fix h h'
  assume sc: "(P \<and>* Q) h" and hh': "h \<preceq> h'"

  from hh' obtain z where h': "h' = h + z" and hzd: "h ## z"
    by (clarsimp simp: sep_substate_def)

  from sc obtain x y where px: "P x" and qy: "Q y"
                       and h: "h = x + y" and xyd: "x ## y"
    by (clarsimp simp: sep_conj_def)

  have "x ## z" using hzd h xyd
    by (metis sep_add_disjD)

  with ip px have "P (x + z)"
    by (fastforce elim: intuitionisticD sep_substate_disj_add)

  thus "(P \<and>* Q) h'" using h' h hzd qy xyd
    by (metis (full_types) sep_add_commute sep_add_disjD sep_add_disjI2
              sep_add_left_commute sep_conjI)
qed

lemma intuitionistic_sep_impl:
  assumes iq: "intuitionistic Q"
  shows "intuitionistic (P \<longrightarrow>* Q)"
proof (rule intuitionisticI)
  fix h h'
  assume imp: "(P \<longrightarrow>* Q) h" and hh': "h \<preceq> h'"

  from hh' obtain z where h': "h' = h + z" and hzd: "h ## z"
    by (clarsimp simp: sep_substate_def)

  {
    fix x
    assume px: "P x" and hzx: "h + z ## x"

    have "h + x \<preceq> h + x + z" using hzx hzd
    by (metis sep_add_disjI1 sep_substate_def)

    with imp hzd iq px hzx
    have "Q (h + z + x)"
    by (metis intuitionisticD sep_add_assoc sep_add_ac sep_add_disjD sep_implE)
  }

  with imp h' hzd iq show "(P \<longrightarrow>* Q) h'"
    by (fastforce intro: sep_implI)
qed

lemma strongest_intuitionistic:
  "\<not>(\<exists>Q. (\<forall>h. (Q h \<longrightarrow> (P \<and>* sep_true) h)) \<and> intuitionistic Q \<and> Q \<noteq> (P \<and>* sep_true) \<and> (\<forall>h. P h \<longrightarrow> Q h))"
  by (fastforce intro!: ext sep_substate_disj_add dest!: sep_conjD intuitionisticD)

lemma weakest_intuitionistic:
  "\<not> (\<exists>Q. (\<forall>h. ((sep_true \<longrightarrow>* P) h \<longrightarrow> Q h)) \<and> intuitionistic Q \<and>
      Q \<noteq> (sep_true \<longrightarrow>* P) \<and> (\<forall>h. Q h \<longrightarrow> P h))"
  apply (clarsimp)
  apply (rule ext)
  apply (rule iffI)
   apply (rule sep_implI)
   apply (drule_tac h="x" and h'="x + h'" in intuitionisticD)
     apply (clarsimp simp: sep_add_ac sep_substate_disj_add)+
  done

lemma intuitionistic_sep_conj_sep_true_P:
  "\<lbrakk> (P \<and>* sep_true) s; intuitionistic P \<rbrakk> \<Longrightarrow> P s"
  by (force dest: intuitionisticD elim: sep_conjE sep_substate_disj_add)

lemma intuitionistic_sep_conj_sep_true_simp:
  "intuitionistic P \<Longrightarrow> (P \<and>* sep_true) = P"
  by (fast intro!: sep_conj_sep_true
           elim: intuitionistic_sep_conj_sep_true_P)

lemma intuitionistic_sep_impl_sep_true_P:
  "\<lbrakk> P h; intuitionistic P \<rbrakk> \<Longrightarrow> (sep_true \<longrightarrow>* P) h"
  by (force intro!: sep_implI dest: intuitionisticD
            intro: sep_substate_disj_add)

lemma intuitionistic_sep_impl_sep_true_simp:
  "intuitionistic P \<Longrightarrow> (sep_true \<longrightarrow>* P) = P"
  by (fast elim: sep_impl_sep_true_P intuitionistic_sep_impl_sep_true_P)

subsection {* Strictly exact assertions *}

definition strictly_exact :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "strictly_exact P \<equiv> \<forall>h h'. P h \<and> P h' \<longrightarrow> h = h'"

lemma strictly_exactD:
  "\<lbrakk> strictly_exact P; P h; P h' \<rbrakk> \<Longrightarrow> h = h'"
  by (unfold strictly_exact_def, fast)

lemma strictly_exactI:
  "(\<And>h h'. \<lbrakk> P h; P h' \<rbrakk> \<Longrightarrow> h = h') \<Longrightarrow> strictly_exact P"
  by (unfold strictly_exact_def, fast)

lemma strictly_exact_sep_conj:
  "\<lbrakk> strictly_exact P; strictly_exact Q \<rbrakk> \<Longrightarrow> strictly_exact (P \<and>* Q)"
  apply (rule strictly_exactI)
  apply (erule sep_conjE)+
  apply (drule_tac h="x" and h'="xa" in strictly_exactD, assumption+)
  apply (drule_tac h="y" and h'="ya" in strictly_exactD, assumption+)
  apply clarsimp
  done

lemma strictly_exact_conj_impl:
  "\<lbrakk> (Q \<and>* sep_true) h; P h; strictly_exact Q \<rbrakk> \<Longrightarrow> (Q \<and>* (Q \<longrightarrow>* P)) h"
  by (force intro: sep_conjI sep_implI dest: strictly_exactD elim!: sep_conjE
            simp: sep_add_commute sep_add_assoc)

end

section {* Separation Algebra with Stronger, but More Intuitive Disjunction Axiom *}

class stronger_sep_algebra = pre_sep_algebra +
  assumes sep_add_disj_eq [simp]: "y ## z \<Longrightarrow> x ## y + z = (x ## y \<and> x ## z)"
begin

lemma sep_disj_add_eq [simp]: "x ## y \<Longrightarrow> x + y ## z = (x ## z \<and> y ## z)"
  by (metis sep_add_disj_eq sep_disj_commute)

subclass sep_algebra by standard auto

end

interpretation sep: ab_semigroup_mult "op **"
  by unfold_locales (simp add: sep_conj_ac)+

interpretation sep: comm_monoid "op **" \<box>
  by unfold_locales simp

interpretation sep: comm_monoid_mult "op **" \<box>
  by unfold_locales simp

section {* Folding separating conjunction over lists and sets of predicates *}

definition
  sep_list_conj :: "('a::sep_algebra \<Rightarrow> bool) list \<Rightarrow> ('a \<Rightarrow> bool)"  where
  "sep_list_conj Ps \<equiv> foldl (op **) \<box> Ps"

abbreviation
  sep_map_list_conj :: "('b \<Rightarrow> 'a::sep_algebra \<Rightarrow> bool) \<Rightarrow> 'b list \<Rightarrow> ('a \<Rightarrow> bool)"
where
  "sep_map_list_conj g S \<equiv> sep_list_conj (map g S)"

abbreviation
  sep_map_set_conj :: "('b \<Rightarrow> 'a::sep_algebra \<Rightarrow> bool) \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> bool)"
where
  "sep_map_set_conj g S \<equiv> sep.prod g S"

definition
  sep_set_conj :: "('a::sep_algebra \<Rightarrow> bool) set \<Rightarrow> ('a \<Rightarrow> bool)"  where
  "sep_set_conj S \<equiv> sep.prod id S"

(* Notation. *)
consts
  sep_conj_lifted :: "'b \<Rightarrow> ('a::sep_algebra \<Rightarrow> bool)" ("\<And>* _" [60] 90)
notation (latex output) sep_conj_lifted ("\<And>\<^sup>* _" [60] 90)
notation (latex output) sep_map_list_conj ("\<And>\<^sup>* _" [60] 90)

adhoc_overloading sep_conj_lifted sep_list_conj
adhoc_overloading sep_conj_lifted sep_set_conj

(* FIXME. Add notation for sep_map_list_conj, and consider unifying with sep_map_set_conj. *)

text{* Now: lots of fancy syntax. First, @{term "sep_map_set_conj (%x. g) A"} is written @{text"\<And>+x\<in>A. g"}. *}

(* Clagged from Big_Operators. *)
syntax
  "_sep_map_set_conj" :: "pttrn => 'a set => 'b => 'b::comm_monoid_add"    ("(3SETSEPCONJ _:_. _)" [0, 51, 10] 10)
syntax (xsymbols)
  "_sep_map_set_conj" :: "pttrn => 'a set => 'b => 'b::comm_monoid_add"    ("(3\<And>*_\<in>_. _)" [0, 51, 10] 10)
syntax (HTML output)
  "_sep_map_set_conj" :: "pttrn => 'a set => 'b => 'b::comm_monoid_add"    ("(3\<And>*_\<in>_. _)" [0, 51, 10] 10)
syntax (latex output)
  "_sep_map_set_conj" :: "pttrn => 'a set => 'b => 'b::comm_monoid_add"    ("(3\<And>\<^sup>*(00\<^bsub>_\<in>_\<^esub>) _)" [0, 51, 10] 10)

translations -- {* Beware of argument permutation! *}
  "SETSEPCONJ x:A. g" == "CONST sep_map_set_conj (%x. g) A"
  "\<And>* x\<in>A. g" == "CONST sep_map_set_conj (%x. g) A"

text{* Instead of @{term"\<And>*x\<in>{x. P}. g"} we introduce the shorter @{text"\<And>+x|P. g"}. *}

syntax
  "_qsep_map_set_conj" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a" ("(3SETSEPCONJ _ |/ _./ _)" [0,0,10] 10)
syntax (xsymbols)
  "_qsep_map_set_conj" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a" ("(3\<And>*_ | (_)./ _)" [0,0,10] 10)
syntax (HTML output)
  "_qsep_map_set_conj" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a" ("(3\<And>*_ | (_)./ _)" [0,0,10] 10)
syntax (latex output)
  "_qsep_map_set_conj" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a" ("(3\<And>\<^sup>*(00\<^bsub>_ | (_)\<^esub>) /_)" [0,0,10] 10)

translations
  "SETSEPCONJ x|P. g" => "CONST sep_map_set_conj (%x. g) {x. P}"
  "\<And>*x|P. g" => "CONST sep_map_set_conj (%x. g) {x. P}"

print_translation {*
let
  fun setsepconj_tr' [Abs (x, Tx, t), Const (@{const_syntax Collect}, _) $ Abs (y, Ty, P)] =
        if x <> y then raise Match
        else
          let
            val x' = Syntax_Trans.mark_bound_body (x, Tx);
            val t' = subst_bound (x', t);
            val P' = subst_bound (x', P);
          in
            Syntax.const @{syntax_const "_qsep_map_set_conj"} $ Syntax_Trans.mark_bound_abs (x, Tx) $ P' $ t'
          end
    | setsepconj_tr' _ = raise Match;
in [(@{const_syntax sep_map_set_conj}, K setsepconj_tr')] end
*}

interpretation sep: folding "op \<and>*" \<box>
  by unfold_locales (simp add: comp_def sep_conj_ac)

lemma "\<And>* [\<box>,P] = P"
  by (simp add: sep_list_conj_def)

lemma "\<And>* {\<box>} = \<box>"
  by (simp add: sep_set_conj_def)

lemma "\<And>* {P,\<box>} = P"
  by (cases "P = \<box>", auto simp: sep_set_conj_def)

lemma "(\<And>* x\<in>{0,1::nat}. if x=0 then \<box> else P) = P"
  by auto

lemma map_sep_list_conj_cong:
  "(\<And>x. x \<in> set xs \<Longrightarrow> f x = g x) \<Longrightarrow> \<And>* map f xs = \<And>* map g xs"
  by (metis map_cong)

lemma sep_list_conj_Nil [simp]: "\<And>* [] = \<box>"
  by (simp add: sep_list_conj_def)

(* apparently these two are rarely used and had to be removed from List.thy *)
lemma (in semigroup) foldl_assoc:
   "foldl f (f x y) zs = f x (foldl f y zs)"
   by (induct zs arbitrary: y) (simp_all add:assoc)

lemma (in monoid) foldl_absorb1:
  "f x (foldl f z zs) = foldl f x zs"
  by (induct zs) (simp_all add:foldl_assoc)

context comm_monoid
begin

lemma foldl_map_filter:
  "f (foldl f z (map P (filter t xs))) (foldl f z (map P (filter (not t) xs))) = foldl f z (map P xs)"
proof (induct xs)
  case Nil thus ?case by clarsimp
next
  case (Cons x xs)
  hence IH:
    "foldl f z (map P xs) =  f (foldl f z (map P (filter t xs))) (foldl f z (map P [x\<leftarrow>xs . \<not> t x]))"
    by (simp only: eq_commute)

  have foldl_Cons':
    "\<And>x xs. foldl f z (x # xs) = f x (foldl f z xs)"
    by (simp, subst foldl_absorb1[symmetric], rule refl)

  { assume "t x"
    hence ?case by (auto simp del: foldl_Cons simp add: foldl_Cons' IH ac_simps)
  } moreover {
    assume "\<not> t x"
    hence ?case by (auto simp del: foldl_Cons simp add: foldl_Cons' IH ac_simps)
  }
  ultimately show ?case by blast
qed

lemma foldl_map_add:
  "foldl f z (map (\<lambda>x. f (P x) (Q x)) xs) = f (foldl f z (map P xs)) (foldl f z (map Q xs))"
  apply (induct xs)
   apply clarsimp
  apply simp
  by (metis (full_types) commute foldl_absorb1 foldl_assoc)

lemma foldl_map_remove1:
  "x \<in> set xs \<Longrightarrow> foldl f z (map P xs) = f (P x) (foldl f z (map P (remove1 x xs)))"
  apply (induction xs, simp)
  apply clarsimp
  by (metis foldl_absorb1 left_commute)

end

lemma sep_list_conj_Cons [simp]: "\<And>* (x#xs) = (x ** \<And>* xs)"
  by (simp add: sep_list_conj_def sep.foldl_absorb1)

lemma sep_list_conj_append [simp]: "\<And>* (xs @ ys) = (\<And>* xs ** \<And>* ys)"
  by (simp add: sep_list_conj_def sep.foldl_absorb1)

lemma sep_list_conj_map_append:
  "\<And>* map f (xs @ ys) = (\<And>* map f xs \<and>* \<And>* map f ys)"
  by (metis map_append sep_list_conj_append)

lemma sep_list_con_map_filter:
  "(\<And>* map P (filter t xs) \<and>* \<And>* map P (filter (not t) xs))
   = \<And>* map P xs"
  apply (simp add: sep_list_conj_def)
  apply (rule sep.foldl_map_filter)
  done

lemma union_filter:
  "({x \<in> xs. P x} \<union> {x \<in> xs. \<not> P x}) = xs"
  by fast

lemma sep_map_set_conj_restrict:
  "finite xs \<Longrightarrow>
    sep_map_set_conj P xs =
   (sep_map_set_conj P {x \<in> xs. t x} \<and>*
    sep_map_set_conj P {x \<in> xs. \<not> t x})"
  by (subst sep.prod.union_disjoint [symmetric], (fastforce simp: union_filter)+)

lemma sep_list_conj_map_add:
  "\<And>* map (\<lambda>x. f x \<and>* g x) xs = (\<And>* map f xs \<and>* \<And>* map g xs)"
  apply (simp add: sep_list_conj_def)
  apply (rule sep.foldl_map_add)
  done

lemma filter_empty:
  "x \<notin> set xs \<Longrightarrow> filter (op = x) xs = []"
  by (induct xs, clarsimp+)

lemma filter_singleton:
  "\<lbrakk>x \<in> set xs; distinct xs\<rbrakk> \<Longrightarrow> [x'\<leftarrow>xs . x = x'] = [x]"
  by (induct xs, auto simp: filter_empty)

lemma remove1_filter:
  "distinct xs \<Longrightarrow> remove1 x xs = filter (\<lambda>y. x \<noteq> y) xs"
  apply (induct xs)
   apply simp
  apply clarsimp
  apply (rule sym, rule filter_True)
  apply clarsimp
  done

lemma sep_list_conj_map_remove1:
  "x \<in> set xs \<Longrightarrow> \<And>* map P xs = (P x \<and>* \<And>* map P (remove1 x xs))"
  apply (simp add: sep_list_conj_def)
  apply (erule sep.foldl_map_remove1)
  done

lemma sep_map_take_Suc:
  "i < length xs \<Longrightarrow>
  \<And>* map P (take (Suc i) xs) = (\<And>* map P (take i xs) \<and>* P (xs ! i))"
  by (subst take_Suc_conv_app_nth, simp+)

lemma sep_conj_map_split:
  "(\<And>* map f xs \<and>* f a \<and>* \<And>* map f ys)
  = (\<And>* map f (xs @ a # ys))"
  by (metis list.map(2) map_append sep_list_conj_Cons sep_list_conj_append)

section "Separation predicates on sets"

lemma sep_map_set_conj_cong:
  "\<lbrakk>P = Q; xs = ys\<rbrakk> \<Longrightarrow> sep_map_set_conj P xs = sep_map_set_conj Q ys"
  by simp

lemma sep_set_conj_empty [simp]:
  "sep_set_conj {} = \<box>"
  by (simp add: sep_set_conj_def)

(* FIXME: We should be able to pull this from the "comm_monoid_big"
 * or "comm_monoid_add" locales, but I can't work out how... *)
lemma sep_map_set_conj_reindex_cong:
   "\<lbrakk>inj_on f A; B = f ` A; \<And>a. a \<in> A \<Longrightarrow> g a = h (f a)\<rbrakk>
    \<Longrightarrow> sep_map_set_conj h B = sep_map_set_conj g A"
  by (simp add: sep.prod.reindex)

lemma sep_list_conj_sep_map_set_conj:
  "distinct xs
  \<Longrightarrow> \<And>* (map P xs) = (\<And>* x \<in> set xs. P x)"
  by (induct xs, simp_all)

lemma sep_list_conj_sep_set_conj:
  "\<lbrakk>distinct xs; inj_on P (set xs)\<rbrakk>
  \<Longrightarrow> \<And>* (map P xs) = \<And>* (P ` set xs)"
  apply (subst sep_list_conj_sep_map_set_conj, assumption)
  apply (clarsimp simp: sep_set_conj_def sep.prod.reindex)
  done

lemma sep_map_set_conj_sep_list_conj:
  "finite A \<Longrightarrow>
   \<exists>xs. set xs = A \<and> distinct xs \<and> sep_map_set_conj P A = \<And>* map P xs"
  apply (frule finite_distinct_list)
  apply (erule exE)
  apply (rule_tac x=xs in exI)
  apply clarsimp
  apply (erule sep_list_conj_sep_map_set_conj [symmetric])
  done

lemma sep_list_conj_eq:
  "\<lbrakk>distinct xs; distinct ys; set xs = set ys\<rbrakk> \<Longrightarrow>
  \<And>* (map P xs) = \<And>* (map P ys)"
  apply (drule sep_list_conj_sep_map_set_conj [where P=P])
  apply (drule sep_list_conj_sep_map_set_conj [where P=P])
  apply simp
  done

lemma sep_list_conj_impl:
  "\<lbrakk> list_all2 (\<lambda>x y. \<forall>s. x s \<longrightarrow> y s) xs ys; (\<And>* xs) s \<rbrakk> \<Longrightarrow> (\<And>* ys) s"
  apply (induct arbitrary: s rule: list_all2_induct)
   apply simp
  apply simp
  apply (erule sep_conj_impl, simp_all)
  done

lemma sep_list_conj_exists:
  "(\<exists>x. (\<And>* map (\<lambda>y s. P x y s) ys) s) \<Longrightarrow> ((\<And>* map (\<lambda>y s. \<exists>x. P x y s) ys) s)"
  apply clarsimp
  apply (erule sep_list_conj_impl[rotated])
  apply (rule list_all2I, simp_all)
  by (fastforce simp: in_set_zip)

lemma sep_list_conj_map_impl:
  "\<lbrakk>\<And>s x. \<lbrakk>x \<in> set xs; P x s\<rbrakk> \<Longrightarrow> Q x s; (\<And>* map P xs) s\<rbrakk>
  \<Longrightarrow> (\<And>* map Q xs) s"
  apply (erule sep_list_conj_impl[rotated])
  apply (rule list_all2I, simp_all)
  by (fastforce simp: in_set_zip)

lemma sep_map_set_conj_impl:
  "\<lbrakk>sep_map_set_conj P A s; \<And>s x. \<lbrakk>x \<in> A; P x s\<rbrakk> \<Longrightarrow> Q x s; finite A\<rbrakk>
  \<Longrightarrow> sep_map_set_conj Q A s"
  apply (frule sep_map_set_conj_sep_list_conj [where P=P])
  apply (drule sep_map_set_conj_sep_list_conj [where P=Q])
  by (metis sep_list_conj_map_impl sep_list_conj_sep_map_set_conj)

lemma set_sub_sub:
  "\<lbrakk>zs \<subseteq> ys\<rbrakk> \<Longrightarrow> (xs - zs) - (ys - zs) = (xs - ys)"
  by blast

lemma sep_map_set_conj_sub_sub_disjoint:
  "\<lbrakk>finite xs; zs \<subseteq> ys; ys \<subseteq> xs\<rbrakk>
  \<Longrightarrow> sep_map_set_conj P (xs - zs) = (sep_map_set_conj P (xs - ys) \<and>* sep_map_set_conj P (ys - zs))"
  apply (cut_tac sep.prod.subset_diff [where A="xs-zs" and B="ys-zs" and g=P])
    apply (subst (asm) set_sub_sub, fast+)
  done

lemma foldl_use_filter_map:
  "foldl op \<and>* Q (map (\<lambda>x. if T x then P x else \<box>) xs) =
   foldl op \<and>* Q (map P (filter T xs))"
  by (induct xs arbitrary: Q, simp_all)

lemma sep_list_conj_filter_map:
  "\<And>* (map (\<lambda>x. if T x then P x else \<box>) xs) =
   \<And>* (map P (filter T xs))"
  by (clarsimp simp: sep_list_conj_def foldl_use_filter_map)

lemma sep_map_set_conj_restrict_predicate:
  "finite A \<Longrightarrow> (\<And>* x\<in>A. if T x then P x else \<box>) = (\<And>* x\<in>(Set.filter T A). P x)"
  by (simp add: Set.filter_def sep.prod.inter_filter)

lemma distinct_filters:
  "\<lbrakk>distinct xs; \<And>x. (f x \<and> g x) = False\<rbrakk> \<Longrightarrow>
  set [x\<leftarrow>xs . f x \<or> g x] = set [x\<leftarrow>xs . f x] \<union> set [x\<leftarrow>xs . g x]"
  by auto

lemma sep_list_conj_distinct_filters:
  "\<lbrakk>distinct xs; \<And>x. (f x \<and> g x) = False\<rbrakk> \<Longrightarrow>
  \<And>* map P [x\<leftarrow>xs . f x \<or> g x] = (\<And>* map P [x\<leftarrow>xs . f x] \<and>* \<And>* map P [x\<leftarrow>xs . g x])"
  apply (subst sep_list_conj_sep_map_set_conj, simp)+
  apply (subst distinct_filters, simp+)
  apply (subst sep.prod.union_disjoint, auto)
  done

lemma sep_map_set_conj_set_disjoint:
  "\<lbrakk>finite {x. P x}; finite {x. Q x}; \<And>x. (P x \<and> Q x) = False\<rbrakk>
 \<Longrightarrow> sep_map_set_conj g {x. P x \<or> Q x} =
  (sep_map_set_conj g {x. P x} \<and>* sep_map_set_conj g {x. Q x})"
  apply (subst sep.prod.union_disjoint [symmetric], simp+)
   apply blast
  apply simp
  by (metis Collect_disj_eq)

section {* Separation Algebra with a Cancellative Monoid *}

text {*
  Separation algebra with a cancellative monoid. The results of being a precise
  assertion (distributivity over separating conjunction) require this.
  *}
class cancellative_sep_algebra = sep_algebra +
  assumes sep_add_cancelD: "\<lbrakk> x + z = y + z ; x ## z ; y ## z \<rbrakk> \<Longrightarrow> x = y"
begin

definition
  (* In any heap, there exists at most one subheap for which P holds *)
  precise :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "precise P = (\<forall>h hp hp'. hp \<preceq> h \<and> P hp \<and> hp' \<preceq> h \<and> P hp' \<longrightarrow> hp = hp')"

lemma "precise (op = s)"
  by (metis (full_types) precise_def)

lemma sep_add_cancel:
  "x ## z \<Longrightarrow> y ## z \<Longrightarrow> (x + z = y + z) = (x = y)"
  by (metis sep_add_cancelD)

lemma precise_distribute:
  "precise P = (\<forall>Q R. ((Q and R) \<and>* P) = ((Q \<and>* P) and (R \<and>* P)))"
proof (rule iffI)
  assume pp: "precise P"
  {
    fix Q R
    fix h hp hp' s

    { assume a: "((Q and R) \<and>* P) s"
      hence "((Q \<and>* P) and (R \<and>* P)) s"
        by (fastforce dest!: sep_conjD elim: sep_conjI)
    }
    moreover
    { assume qs: "(Q \<and>* P) s" and qr: "(R \<and>* P) s"

      from qs obtain x y where sxy: "s = x + y" and xy: "x ## y"
                           and x: "Q x" and y: "P y"
        by (fastforce dest!: sep_conjD)
      from qr obtain x' y' where sxy': "s = x' + y'" and xy': "x' ## y'"
                           and x': "R x'" and y': "P y'"
        by (fastforce dest!: sep_conjD)

      from sxy have ys: "y \<preceq> x + y" using xy
        by (fastforce simp: sep_substate_disj_add' sep_disj_commute)
      from sxy' have ys': "y' \<preceq> x' + y'" using xy'
        by (fastforce simp: sep_substate_disj_add' sep_disj_commute)

      from pp have yy: "y = y'" using sxy sxy' xy xy' y y' ys ys'
        by (fastforce simp: precise_def)

      hence "x = x'" using sxy sxy' xy xy'
        by (fastforce dest!: sep_add_cancelD)

      hence "((Q and R) \<and>* P) s" using sxy x x' yy y' xy'
        by (fastforce intro: sep_conjI)
    }
    ultimately
    have "((Q and R) \<and>* P) s = ((Q \<and>* P) and (R \<and>* P)) s" using pp by blast
  }
  thus "\<forall>Q R. ((Q and R) \<and>* P) = ((Q \<and>* P) and (R \<and>* P))" by blast

next
  assume a: "\<forall>Q R. ((Q and R) \<and>* P) = ((Q \<and>* P) and (R \<and>* P))"
  thus "precise P"
  proof (clarsimp simp: precise_def)
    fix h hp hp' Q R
    assume hp: "hp \<preceq> h" and hp': "hp' \<preceq> h" and php: "P hp" and php': "P hp'"

    obtain z where hhp: "h = hp + z" and hpz: "hp ## z" using hp
      by (clarsimp simp: sep_substate_def)
    obtain z' where hhp': "h = hp' + z'" and hpz': "hp' ## z'" using hp'
      by (clarsimp simp: sep_substate_def)

    have h_eq: "z' + hp' = z + hp" using hhp hhp' hpz hpz'
      by (fastforce simp: sep_add_ac)

    from hhp hhp' a hpz hpz' h_eq
    have "\<forall>Q R. ((Q and R) \<and>* P) (z + hp) = ((Q \<and>* P) and (R \<and>* P)) (z' + hp')"
      by (fastforce simp: h_eq sep_add_ac sep_conj_commute)

    hence "((op = z and op = z') \<and>* P) (z + hp) =
           ((op = z \<and>* P) and (op = z' \<and>* P)) (z' + hp')" by blast

    thus  "hp = hp'" using php php' hpz hpz' h_eq
      by (fastforce dest!: iffD2 cong: conj_cong
                    simp: sep_add_ac sep_add_cancel sep_conj_def)
  qed
qed

lemma strictly_precise: "strictly_exact P \<Longrightarrow> precise P"
  by (metis precise_def strictly_exactD)

end

end


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

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

section \<open>Determinism\<close>

theory Determinism imports WellDefined begin

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

text \<open>We provide a set of lemmas for establishing that
  appropriately restricted programs are fully additive, and
  maximal in the refinement order.  This is particularly useful
  with data refinement, as it implies correspondence.\<close>

subsection  \<open>Additivity\<close>

lemma additive_wp_Abort:
  "additive (wp (Abort))"
  by(auto simp:wp_eval)

text \<open>@{term "wlp Abort"} is not additive.\<close>

lemma additive_wp_Skip:
  "additive (wp (Skip))"
  by(auto simp:wp_eval)

lemma additive_wp_Apply:
  "additive (wp (Apply f))"
  by(auto simp:wp_eval)

lemma additive_wp_Seq:
  fixes a::"'s prog"
  assumes adda: "additive (wp a)"
      and addb: "additive (wp b)"
      and wb:   "well_def b"
  shows "additive (wp (a ;; b))"
proof(rule additiveI, unfold wp_eval o_def)
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  assume sP: "sound P" and sQ: "sound Q"

  note hb = well_def_wp_healthy[OF wb]

  from addb sP sQ
  have "wp b (\<lambda>s. P s + Q s) = (\<lambda>s. wp b P s + wp b Q s)"
    by(blast dest:additiveD)
  with adda sP sQ hb
  show "wp a (wp b (\<lambda>s. P s + Q s)) s =
        wp a (wp b P) s + (wp a (wp b Q)) s"
    by(auto intro:fun_cong[OF additiveD])
qed

lemma additive_wp_PC:
  "\<lbrakk> additive (wp a); additive (wp b) \<rbrakk> \<Longrightarrow> additive (wp (a \<^bsub>P\<^esub>\<oplus> b))"
  by(rule additiveI, simp add:additiveD field_simps wp_eval)

text \<open>@{term DC} is not additive.\<close>

lemma additive_wp_SetPC:
  "\<lbrakk> \<And>x s. x \<in> supp (p s) \<Longrightarrow> additive (wp (a x)); \<And>s. finite (supp (p s)) \<rbrakk> \<Longrightarrow>
   additive (wp (SetPC a p))"
  by(rule additiveI,
     simp add:wp_eval additiveD distrib_left sum.distrib)

lemma additive_wp_Bind:
  "\<lbrakk> \<And>x. additive (wp (a (f x))) \<rbrakk> \<Longrightarrow> additive (wp (Bind f a))"
  by(simp add:wp_eval additive_def)

lemma additive_wp_Embed:
  "\<lbrakk> additive t \<rbrakk> \<Longrightarrow> additive (wp (Embed t))"
  by(simp add:wp_eval)

lemma additive_wp_repeat:
  "additive (wp a) \<Longrightarrow> well_def a \<Longrightarrow> additive (wp (repeat n a))"
  by(induct n, auto simp:additive_wp_Skip intro:additive_wp_Seq wd_intros)

lemmas fa_intros =
  additive_wp_Abort additive_wp_Skip
  additive_wp_Apply additive_wp_Seq
  additive_wp_PC    additive_wp_SetPC
  additive_wp_Bind  additive_wp_Embed
  additive_wp_repeat

subsection \<open>Maximality\<close>

lemma max_wp_Skip:
  "maximal (wp Skip)"
  by(simp add:maximal_def wp_eval)

lemma max_wp_Apply:
  "maximal (wp (Apply f))"
  by(auto simp:wp_eval o_def)

lemma max_wp_Seq:
  "\<lbrakk> maximal (wp a); maximal (wp b) \<rbrakk> \<Longrightarrow> maximal (wp (a ;; b))"
  by(simp add:wp_eval maximal_def)

lemma max_wp_PC:
  "\<lbrakk> maximal (wp a); maximal (wp b) \<rbrakk> \<Longrightarrow> maximal (wp (a \<^bsub>P\<^esub>\<oplus> b))"
  by(rule maximalI, simp add:maximalD field_simps wp_eval)

lemma max_wp_DC:
  "\<lbrakk> maximal (wp a); maximal (wp b) \<rbrakk> \<Longrightarrow> maximal (wp (a \<Sqinter> b))"
  by(rule maximalI, simp add:wp_eval maximalD)

lemma max_wp_SetPC:
  "\<lbrakk> \<And>s a. a \<in> supp (P s) \<Longrightarrow> maximal (wp (p a)); \<And>s. (\<Sum>a\<in>supp (P s). P s a) = 1 \<rbrakk> \<Longrightarrow>
  maximal (wp (SetPC p P))"
  by(auto simp:maximalD wp_def SetPC_def sum_distrib_right[symmetric])

lemma max_wp_SetDC:
  fixes p::"'a \<Rightarrow> 's prog"
  assumes mp: "\<And>s a. a \<in> S s \<Longrightarrow> maximal (wp (p a))"
      and ne: "\<And>s. S s \<noteq> {}"
  shows "maximal (wp (SetDC p S))"
proof(rule maximalI, rule ext, unfold wp_eval)
  fix c::real and s::'s
  assume "0 \<le> c"
  hence "Inf ((\<lambda>a. wp (p a) (\<lambda>_. c) s) ` S s) = Inf ((\<lambda>_. c) ` S s)"
    using mp by(simp add:maximalD cong:image_cong)
  also {
    from ne obtain a where "a \<in> S s" by blast
    hence "Inf ((\<lambda>_. c) ` S s) = c"
      by (auto simp add: image_constant_conv cong del: INF_cong_simp)
  }
  finally show "Inf ((\<lambda>a. wp (p a) (\<lambda>_. c) s) ` S s) = c" .
qed

lemma max_wp_Embed:
  "maximal t \<Longrightarrow> maximal (wp (Embed t))"
  by(simp add:wp_eval)

lemma max_wp_repeat:
  "maximal (wp a) \<Longrightarrow> maximal (wp (repeat n a))"
  by(induct n, simp_all add:max_wp_Skip max_wp_Seq)

lemma max_wp_Bind:
  assumes ma: "\<And>s. maximal (wp (a (f s)))"
  shows "maximal (wp (Bind f a))"
proof(rule maximalI, rule ext, simp add:wp_eval)
  fix c::real and s
  assume "0 \<le> c"
  with ma have "wp (a (f s)) (\<lambda>_. c) = (\<lambda>_. c)" by(blast)
  thus "wp (a (f s)) (\<lambda>_. c) s = c" by(auto)
qed

lemmas max_intros =
  max_wp_Skip  max_wp_Apply
  max_wp_Seq   max_wp_PC
  max_wp_DC    max_wp_SetPC
  max_wp_SetDC max_wp_Embed
  max_wp_Bind  max_wp_repeat

text \<open>A healthy transformer that terminates is maximal.\<close>
lemma healthy_term_max:
  assumes ht: "healthy t"
      and trm: "\<lambda>s. 1 \<tturnstile> t (\<lambda>s. 1)"
  shows "maximal t"
proof(intro maximalI ext)
  fix c::real and s
  assume nnc: "0 \<le> c"

  have "t (\<lambda>s. c) s = t (\<lambda>s. 1 * c) s" by(simp)
  also from nnc healthy_scalingD[OF ht]
  have "... = c * t (\<lambda>s. 1) s" by(simp add:scalingD)
  also {
    from ht have "t (\<lambda>s. 1) \<tturnstile> \<lambda>s. 1" by(auto)
    with trm have "t (\<lambda>s. 1) = (\<lambda>s. 1)" by(auto)
    hence "c * t (\<lambda>s. 1) s = c" by(simp)
  }
  finally show "t (\<lambda>s. c) s = c" .
qed

subsection \<open>Determinism\<close>

lemma det_wp_Skip:
  "determ (wp Skip)"
  using max_intros fa_intros by(blast)

lemma det_wp_Apply:
  "determ (wp (Apply f))"
  by(intro determI fa_intros max_intros)

lemma det_wp_Seq:
  "determ (wp a) \<Longrightarrow> determ (wp b) \<Longrightarrow> well_def b \<Longrightarrow> determ (wp (a ;; b))"
  by(intro determI fa_intros max_intros, auto)

lemma det_wp_PC:
  "determ (wp a) \<Longrightarrow> determ (wp b) \<Longrightarrow> determ (wp (a \<^bsub>P\<^esub>\<oplus> b))"
  by(intro determI fa_intros max_intros, auto)

lemma det_wp_SetPC:
  "(\<And>x s. x \<in> supp (p s) \<Longrightarrow> determ (wp (a x))) \<Longrightarrow>
   (\<And>s. finite (supp (p s))) \<Longrightarrow>
   (\<And>s. sum (p s) (supp (p s)) = 1) \<Longrightarrow>
   determ (wp (SetPC a p))"
  by(intro determI fa_intros max_intros, auto)

lemma det_wp_Bind:
  "(\<And>x. determ (wp (a (f x)))) \<Longrightarrow> determ (wp (Bind f a))"
  by(intro determI fa_intros max_intros, auto)

lemma det_wp_Embed:
  "determ t \<Longrightarrow> determ (wp (Embed t))"
  by(simp add:wp_eval)

lemma det_wp_repeat:
  "determ (wp a) \<Longrightarrow> well_def a \<Longrightarrow> determ (wp (repeat n a))"
  by(intro determI fa_intros max_intros, auto)

lemmas determ_intros =
  det_wp_Skip det_wp_Apply
  det_wp_Seq  det_wp_PC
  det_wp_SetPC det_wp_Bind
  det_wp_Embed det_wp_repeat

end


section \<open>Data: Bool\<close>

theory Data_Bool
  imports Type_Classes
begin

subsection \<open>Class instances\<close>

text \<open>Eq\<close>

lemma eq_eqI[case_names bottomLTR bottomRTL LTR RTL]:
  "(x = \<bottom> \<Longrightarrow> y = \<bottom>) \<Longrightarrow> (y = \<bottom> \<Longrightarrow> x = \<bottom>) \<Longrightarrow> (x = TT \<Longrightarrow> y = TT) \<Longrightarrow> (y = TT \<Longrightarrow> x = TT) \<Longrightarrow> x = y"
by (metis Exh_tr)

text \<open>Ord\<close>

lemma compare_tr_simps [simp]:
  "compare\<cdot>FF\<cdot>FF = EQ"
  "compare\<cdot>FF\<cdot>TT = LT"
  "compare\<cdot>TT\<cdot>FF = GT"
  "compare\<cdot>TT\<cdot>TT = EQ"
  unfolding TT_def FF_def compare_lift_def
  by simp_all

subsection \<open>Lemmas\<close>

lemma andalso_eq_TT_iff [simp]:
  "(x andalso y) = TT \<longleftrightarrow> x = TT \<and> y = TT"
  by (cases x, simp_all)

lemma andalso_eq_FF_iff [simp]:
  "(x andalso y) = FF \<longleftrightarrow> x = FF \<or> (x = TT \<and> y = FF)"
  by (cases x, simp_all)

lemma andalso_eq_bottom_iff [simp]:
  "(x andalso y) = \<bottom> \<longleftrightarrow> x = \<bottom> \<or> (x = TT \<and> y = \<bottom>)"
  by (cases x, simp_all)

lemma orelse_eq_FF_iff [simp]:
  "(x orelse y) = FF \<longleftrightarrow> x = FF \<and> y = FF"
  by (cases x, simp_all)

lemma orelse_assoc [simp]:
  "((x orelse y) orelse z) = (x orelse y orelse z)"
  by (cases x) auto

lemma neg_orelse [simp]:
  "neg\<cdot>(x orelse y) = (neg\<cdot>x andalso neg\<cdot>y)"
  by (cases x) auto

lemma neg_andalso [simp]:
  "neg\<cdot>(x andalso y) = (neg\<cdot>x orelse neg\<cdot>y)"
  by (cases x) auto

text \<open>Not suitable as default simp rules, because they cause the
  simplifier to loop:\<close>
lemma neg_eq_simps:
  "neg\<cdot>x = TT \<Longrightarrow> x = FF"
  "neg\<cdot>x = FF \<Longrightarrow> x = TT"
  "neg\<cdot>x = \<bottom> \<Longrightarrow> x = \<bottom>"
  by (cases x, simp_all)+

lemma neg_eq_TT_iff [simp]: "neg\<cdot>x = TT \<longleftrightarrow> x = FF"
  by (cases x, simp_all)+

lemma neg_eq_FF_iff [simp]: "neg\<cdot>x = FF \<longleftrightarrow> x = TT"
  by (cases x, simp_all)+

lemma neg_eq_bottom_iff [simp]: "neg\<cdot>x = \<bottom> \<longleftrightarrow> x = \<bottom>"
  by (cases x, simp_all)+

(* TODO: set up reorient_proc for TT and FF *)

lemma neg_eq [simp]:
  "neg\<cdot>x = neg\<cdot>y \<longleftrightarrow> x = y"
  by (cases y, simp_all)

lemma neg_neg [simp]:
  "neg\<cdot>(neg\<cdot>x) = x"
  by (cases x, auto)

lemma neg_comp_neg [simp]:
  "neg oo neg = ID"
  by (metis cfun_eqI cfcomp2 neg_neg ID1)

end


section \<open>Lassos\<close>
(* Author: Peter Lammich *)
theory Lasso
imports Automata
begin

  record 'v lasso =
    lasso_reach :: "'v list"
    lasso_va :: "'v"
    lasso_cysfx :: "'v list"

  definition "lasso_v0 L \<equiv> case lasso_reach L of [] \<Rightarrow> lasso_va L | (v0#_) \<Rightarrow> v0"
  definition lasso_cycle where "lasso_cycle L = lasso_va L # lasso_cysfx L"

  definition "lasso_of_prpl prpl \<equiv> case prpl of (pr,pl) \<Rightarrow> \<lparr>
    lasso_reach = pr,
    lasso_va = hd pl,
    lasso_cysfx = tl pl \<rparr>"

  definition "prpl_of_lasso L \<equiv> (lasso_reach L, lasso_va L # lasso_cysfx L)"

  lemma prpl_of_lasso_simps[simp]:
    "fst (prpl_of_lasso L) = lasso_reach L"
    "snd (prpl_of_lasso L) = lasso_va L # lasso_cysfx L"
    unfolding prpl_of_lasso_def by auto

  lemma lasso_of_prpl_simps[simp]:
    "lasso_reach (lasso_of_prpl prpl) = fst prpl"
    "snd prpl \<noteq> [] \<Longrightarrow> lasso_cycle (lasso_of_prpl prpl) = snd prpl"
    unfolding lasso_of_prpl_def lasso_cycle_def by (auto split: prod.split)

  definition run_of_lasso :: "'q lasso \<Rightarrow> 'q word"
    \<comment> \<open>Run described by a lasso\<close>
    where "run_of_lasso L \<equiv> lasso_reach L \<frown> (lasso_cycle L)\<^sup>\<omega>"

  lemma run_of_lasso_of_prpl:
    "pl \<noteq> [] \<Longrightarrow> run_of_lasso (lasso_of_prpl (pr, pl)) = pr \<frown> pl\<^sup>\<omega>"
    unfolding run_of_lasso_def lasso_of_prpl_def lasso_cycle_def
    by auto

  definition "map_lasso f L \<equiv> \<lparr>
    lasso_reach = map f (lasso_reach L),
    lasso_va = f (lasso_va L),
    lasso_cysfx = map f (lasso_cysfx L)
  \<rparr>"

  lemma map_lasso_simps[simp]:
    "lasso_reach (map_lasso f L) = map f (lasso_reach L)"
    "lasso_va (map_lasso f L) = f (lasso_va L)"
    "lasso_cysfx (map_lasso f L) = map f (lasso_cysfx L)"
    "lasso_v0 (map_lasso f L) = f (lasso_v0 L)"
    "lasso_cycle (map_lasso f L) = map f (lasso_cycle L)"
    unfolding map_lasso_def lasso_v0_def lasso_cycle_def
    by (auto split: list.split)

  lemma map_lasso_run[simp]:
    shows "run_of_lasso (map_lasso f L) = f o (run_of_lasso L)"
    by (auto simp add: map_lasso_def run_of_lasso_def conc_def iter_def
      lasso_cycle_def lasso_v0_def fun_eq_iff not_less nth_Cons'
      nz_le_conv_less)

  context graph begin
    definition is_lasso_pre :: "'v lasso \<Rightarrow> bool"
      where "is_lasso_pre L \<equiv>
        lasso_v0 L \<in> V0
      \<and> path E (lasso_v0 L) (lasso_reach L) (lasso_va L)
      \<and> path E (lasso_va L) (lasso_cycle L) (lasso_va L)"

    definition "is_lasso_prpl_pre prpl \<equiv> case prpl of (pr, pl) \<Rightarrow> \<exists>v0 va.
      v0\<in>V0
      \<and> pl \<noteq> []
      \<and> path E v0 pr va
      \<and> path E va pl va"

    lemma is_lasso_pre_prpl_of_lasso[simp]:
      "is_lasso_prpl_pre (prpl_of_lasso L) \<longleftrightarrow> is_lasso_pre L"
      unfolding is_lasso_pre_def prpl_of_lasso_def is_lasso_prpl_pre_def
      unfolding lasso_v0_def lasso_cycle_def
      by (auto simp: path_simps split: list.split)

    lemma is_lasso_prpl_pre_conv:
      "is_lasso_prpl_pre prpl
      \<longleftrightarrow> (snd prpl\<noteq>[] \<and> is_lasso_pre (lasso_of_prpl prpl))"
      unfolding is_lasso_pre_def lasso_of_prpl_def is_lasso_prpl_pre_def
      unfolding lasso_v0_def lasso_cycle_def
      apply (cases prpl)
      apply (rename_tac a b)
      apply (case_tac b)
      apply (auto simp: path_simps split: list.splits)
      done

    lemma is_lasso_pre_empty[simp]: "V0 = {} \<Longrightarrow> \<not>is_lasso_pre L"
      unfolding is_lasso_pre_def by auto

    lemma run_of_lasso_pre:
      assumes "is_lasso_pre L"
      shows "is_run (run_of_lasso L)"
      and "run_of_lasso L 0 \<in> V0"
      using assms
      unfolding is_lasso_pre_def is_run_def run_of_lasso_def
        lasso_cycle_def lasso_v0_def
      by (auto simp: ipath_conc_conv ipath_iter_conv path_cons_conv conc_fst
        split: list.splits)

  end

  context gb_graph begin
    definition is_lasso
      :: "'Q lasso \<Rightarrow> bool"
      \<comment> \<open>Predicate that defines a lasso\<close>
      where "is_lasso L \<equiv>
        is_lasso_pre L
      \<and> (\<forall>A\<in>F. (set (lasso_cycle L)) \<inter> A \<noteq> {})"

    definition "is_lasso_prpl prpl \<equiv>
      is_lasso_prpl_pre prpl
      \<and> (\<forall>A\<in>F. set (snd prpl) \<inter> A \<noteq> {})"

    lemma is_lasso_prpl_of_lasso[simp]:
      "is_lasso_prpl (prpl_of_lasso L) \<longleftrightarrow> is_lasso L"
      unfolding is_lasso_def is_lasso_prpl_def
      unfolding lasso_v0_def lasso_cycle_def
      by auto

    lemma is_lasso_prpl_conv:
      "is_lasso_prpl prpl \<longleftrightarrow> (snd prpl\<noteq>[] \<and> is_lasso (lasso_of_prpl prpl))"
      unfolding is_lasso_def is_lasso_prpl_def is_lasso_prpl_pre_conv
      apply safe
      apply simp_all
      done

    lemma is_lasso_empty[simp]: "V0 = {} \<Longrightarrow> \<not>is_lasso L"
      unfolding is_lasso_def by auto

    lemma lasso_accepted:
      assumes L: "is_lasso L"
      shows "is_acc_run (run_of_lasso L)"
    proof -
      obtain "pr" va pls where
        [simp]: "L = \<lparr>lasso_reach = pr,lasso_va = va,lasso_cysfx = pls\<rparr>"
        by (cases L)

      from L have "is_run (run_of_lasso L)"
        unfolding is_lasso_def by (auto simp: run_of_lasso_pre)
      moreover from L have "(\<forall>A\<in>F. set (va#pls) \<inter> A \<noteq> {})"
        by (auto simp: is_lasso_def lasso_cycle_def)
      moreover from L have "(run_of_lasso L) 0 \<in> V0"
        unfolding is_lasso_def by (auto simp: run_of_lasso_pre)
      ultimately show "is_acc_run (run_of_lasso L)"
        unfolding is_acc_run_def is_acc_def run_of_lasso_def
          lasso_cycle_def lasso_v0_def
        by (fastforce intro: limit_inter_INF)
    qed

    lemma lasso_prpl_acc_run:
      "is_lasso_prpl (pr, pl) \<Longrightarrow> is_acc_run (pr \<frown> iter pl)"
      apply (clarsimp simp: is_lasso_prpl_conv)
      apply (drule lasso_accepted)
      apply (simp add: run_of_lasso_of_prpl)
      done

  end

  context gb_graph
  begin
    lemma accepted_lasso:
      assumes [simp, intro]: "finite (E\<^sup>* `` V0)"
      assumes A: "is_acc_run r"
      shows "\<exists>L. is_lasso L"
    proof -
      from A have
        RUN: "is_run r"
        and ACC: "\<forall>A\<in>F. limit r \<inter> A \<noteq> {}"
        by (auto simp: is_acc_run_limit_alt)
      from RUN have [simp]: "r 0 \<in> V0" and RUN': "ipath E r"
        by (simp_all add: is_run_def)

      txt \<open>Choose a node that is visited infinitely often\<close>
      from RUN have RAN_REACH: "range r \<subseteq> E\<^sup>*``V0"
        by (auto simp: is_run_def dest: ipath_to_rtrancl)
      hence "finite (range r)" by (auto intro: finite_subset)
      then obtain u where "u\<in>limit r" using limit_nonempty by blast
      hence U_REACH: "u\<in>E\<^sup>*``V0" using RAN_REACH limit_in_range by force
      then obtain v0 "pr" where PR: "v0\<in>V0" "path E v0 pr u"
        by (auto intro: rtrancl_is_path)
      moreover
      txt \<open>Build a path from \<open>u\<close> to \<open>u\<close>, that contains nodes from
        each acceptance set\<close>
      have "\<exists>pl. pl\<noteq>[] \<and> path E u pl u \<and> (\<forall>A\<in>F. set pl \<inter> A \<noteq> {})"
        using finite_F ACC
      proof (induction rule: finite_induct)
        case empty
        from run_limit_two_connectedI[OF RUN' \<open>u\<in>limit r\<close> \<open>u\<in>limit r\<close>]
        obtain p where [simp]: "p\<noteq>[]" and P: "path E u p u"
          by (rule trancl_is_path)
        thus ?case by blast
      next
        case (insert A F)
        from insert.IH insert.prems obtain pl where
          [simp]: "pl\<noteq>[]"
            and P: "path E u pl u"
            and ACC: "(\<forall>A'\<in>F. set pl \<inter> A' \<noteq> {})"
          by auto
        from insert.prems obtain v where VACC: "v\<in>A" "v\<in>limit r" by auto
        from run_limit_two_connectedI[OF RUN' \<open>u\<in>limit r\<close> \<open>v\<in>limit r\<close>]
        obtain p1 where [simp]: "p1\<noteq>[]"
          and P1: "path E u p1 v"
          by (rule trancl_is_path)

        from run_limit_two_connectedI[OF RUN' \<open>v\<in>limit r\<close> \<open>u\<in>limit r\<close>]
        obtain p2 where [simp]: "p2\<noteq>[]"
          and P2: "path E v p2 u"
          by (rule trancl_is_path)

        note P also note P1 also (path_conc) note P2 finally (path_conc)
        have "path E u (pl@p1@p2) u" by simp
        moreover from P2 have "v\<in>set (p1@p2)"
          by (cases p2) (auto simp: path_cons_conv)
        with ACC VACC have "(\<forall>A'\<in>insert A F. set (pl@p1@p2) \<inter> A' \<noteq> {})" by auto
        moreover have "pl@p1@p2 \<noteq> []" by auto
        ultimately show ?case by (intro exI conjI)
      qed
      then obtain pl where "pl \<noteq> []" "path E u pl u" "(\<forall>A\<in>F. set pl \<inter> A \<noteq> {})"
        by blast
      then obtain pls where "path E u (u#pls) u" "\<forall>A\<in>F. set (u#pls) \<inter> A \<noteq> {}"
        by (cases pl) (auto simp add: path_simps)
      ultimately show ?thesis
        apply -
        apply (rule
          exI[where x="\<lparr>lasso_reach = pr,lasso_va = u,lasso_cysfx = pls\<rparr>"])
        unfolding is_lasso_def lasso_v0_def lasso_cycle_def is_lasso_pre_def
        apply (cases "pr")
        apply (simp_all add: path_simps)
        done
    qed
  end

  context b_graph
  begin
    definition is_lasso where "is_lasso L \<equiv>
      is_lasso_pre L
      \<and> (set (lasso_cycle L)) \<inter> F \<noteq> {}"

    definition is_lasso_prpl where "is_lasso_prpl L \<equiv>
      is_lasso_prpl_pre L
      \<and> (set (snd L)) \<inter> F \<noteq> {}"

    lemma is_lasso_pre_ext[simp]:
      "gbg.is_lasso_pre T m = is_lasso_pre"
      unfolding gbg.is_lasso_pre_def[abs_def] is_lasso_pre_def[abs_def]
      unfolding to_gbg_ext_def
      by auto

    lemma is_lasso_gbg:
      "gbg.is_lasso T m = is_lasso"
      unfolding is_lasso_def[abs_def] gbg.is_lasso_def[abs_def]
      apply simp
      apply (auto simp: to_gbg_ext_def lasso_cycle_def)
      done

    lemmas lasso_accepted = gbg.lasso_accepted[unfolded to_gbg_alt is_lasso_gbg]
    lemmas accepted_lasso = gbg.accepted_lasso[unfolded to_gbg_alt is_lasso_gbg]

    lemma is_lasso_prpl_of_lasso[simp]:
      "is_lasso_prpl (prpl_of_lasso L) \<longleftrightarrow> is_lasso L"
      unfolding is_lasso_def is_lasso_prpl_def
      unfolding lasso_v0_def lasso_cycle_def
      by auto

    lemma is_lasso_prpl_conv:
      "is_lasso_prpl prpl \<longleftrightarrow> (snd prpl\<noteq>[] \<and> is_lasso (lasso_of_prpl prpl))"
      unfolding is_lasso_def is_lasso_prpl_def is_lasso_prpl_pre_conv
      apply safe
      apply auto
      done

    lemma lasso_prpl_acc_run:
      "is_lasso_prpl (pr, pl) \<Longrightarrow> is_acc_run (pr \<frown> iter pl)"
      apply (clarsimp simp: is_lasso_prpl_conv)
      apply (drule lasso_accepted)
      apply (simp add: run_of_lasso_of_prpl)
      done

  end

  context igb_graph begin
    definition "is_lasso L \<equiv>
      is_lasso_pre L
      \<and> (\<forall>i<num_acc. \<exists>q\<in>set (lasso_cycle L). i\<in>acc q)"

    definition "is_lasso_prpl L \<equiv>
      is_lasso_prpl_pre L
      \<and> (\<forall>i<num_acc. \<exists>q\<in>set (snd L). i\<in>acc q)"

    lemma is_lasso_prpl_of_lasso[simp]:
      "is_lasso_prpl (prpl_of_lasso L) \<longleftrightarrow> is_lasso L"
      unfolding is_lasso_def is_lasso_prpl_def
      unfolding lasso_v0_def lasso_cycle_def
      by auto

    lemma is_lasso_prpl_conv:
      "is_lasso_prpl prpl \<longleftrightarrow> (snd prpl\<noteq>[] \<and> is_lasso (lasso_of_prpl prpl))"
      unfolding is_lasso_def is_lasso_prpl_def is_lasso_prpl_pre_conv
      apply safe
      apply auto
      done

    lemma is_lasso_pre_ext[simp]:
      "gbg.is_lasso_pre T m = is_lasso_pre"
      unfolding gbg.is_lasso_pre_def[abs_def] is_lasso_pre_def[abs_def]
      unfolding to_gbg_ext_def
      by auto

    lemma is_lasso_gbg: "gbg.is_lasso T m = is_lasso"
      unfolding is_lasso_def[abs_def] gbg.is_lasso_def[abs_def]
      apply simp
      apply (simp_all add: to_gbg_ext_def)
      apply (intro ext)
      apply (fo_rule arg_cong | intro ext)+
      apply (auto simp: F_def accn_def intro!: ext)
      done

    lemmas lasso_accepted = gbg.lasso_accepted[unfolded to_gbg_alt is_lasso_gbg]
    lemmas accepted_lasso = gbg.accepted_lasso[unfolded to_gbg_alt is_lasso_gbg]

    lemma lasso_prpl_acc_run:
      "is_lasso_prpl (pr, pl) \<Longrightarrow> is_acc_run (pr \<frown> iter pl)"
      apply (clarsimp simp: is_lasso_prpl_conv)
      apply (drule lasso_accepted)
      apply (simp add: run_of_lasso_of_prpl)
      done

    lemma degen_lasso_sound:
      assumes A: "degen.is_lasso T m L"
      shows "is_lasso (map_lasso fst L)"
    proof -

      from A have
        V0: "lasso_v0 L \<in> degen.V0 T m" and
        REACH: "path (degen.E T m)
                 (lasso_v0 L) (lasso_reach L) (lasso_va L)" and
        LOOP: "path (degen.E T m)
                  (lasso_va L) (lasso_cycle L) (lasso_va L)" and
        ACC: "(set (lasso_cycle L)) \<inter> degen.F T m \<noteq> {}"
        unfolding degen.is_lasso_def degen.is_lasso_pre_def by auto

      {
        fix i
        assume "i<num_acc"
        hence "\<exists>q\<in>set (lasso_cycle L). i \<in> local.acc (fst q) \<and> snd q = i"
        proof (induction i)
          case 0
          thus ?case using ACC unfolding degeneralize_ext_def by fastforce
        next
          case (Suc i)
          then obtain q where "(q,i)\<in>set (lasso_cycle L)" and "i\<in>acc q" by auto
          with LOOP obtain pl' where SPL: "set (lasso_cycle L) = set pl'"
            and PS: "path (degen.E T m) (q,i) pl' (q,i)"
            by (blast elim: path_loop_shift)
          from SPL have "pl'\<noteq>[]" by (auto simp: lasso_cycle_def)
          then obtain pl'' where [simp]: "pl'=(q,i)#pl''"
            using PS by (cases pl') (auto simp: path_simps)
          then obtain q2 pl''' where
            [simp]: "pl'' = (q2,(i + 1) mod num_acc)#pl'''"
            using PS \<open>i\<in>acc q\<close> \<open>Suc i < num_acc\<close>
            apply (cases pl'')
            apply (auto
              simp: path_simps degeneralize_ext_def
              split: if_split_asm)
            done
          from PS have
            "path (degen.E T m) (q2,Suc i) pl'' (q,i)"
            using \<open>Suc i < num_acc\<close>
            by (auto simp: path_simps)
          from degen_visit_acc[OF this] obtain qa
            where "(qa,Suc i)\<in>set pl''" "Suc i \<in> acc qa"
            by auto
          thus ?case
            by (rule_tac bexI[where x="(qa,Suc i)"]) (auto simp: SPL)
        qed
      } note aux=this

      from degen_V0_sound[OF V0]
        degen_path_sound[OF REACH]
        degen_path_sound[OF LOOP] aux
      show ?thesis
        unfolding is_lasso_def is_lasso_pre_def
        by auto
    qed

  end

  definition lasso_rel_ext_internal_def: "\<And>Re R. lasso_rel_ext Re R \<equiv> {
    (\<lparr> lasso_reach = r', lasso_va = va', lasso_cysfx = cysfx', \<dots>=m' \<rparr>,
     \<lparr> lasso_reach = r, lasso_va = va, lasso_cysfx = cysfx, \<dots>=m \<rparr>) |
      r' r va' va cysfx' cysfx m' m.
      (r',r) \<in> \<langle>R\<rangle>list_rel
    \<and> (va',va)\<in>R
    \<and> (cysfx', cysfx) \<in> \<langle>R\<rangle>list_rel
    \<and> (m',m) \<in> Re
    }"

  lemma lasso_rel_ext_def: "\<And> Re R. \<langle>Re,R\<rangle>lasso_rel_ext = {
    (\<lparr> lasso_reach = r', lasso_va = va', lasso_cysfx = cysfx', \<dots>=m' \<rparr>,
     \<lparr> lasso_reach = r, lasso_va = va, lasso_cysfx = cysfx, \<dots>=m \<rparr>) |
      r' r va' va cysfx' cysfx m' m.
      (r',r) \<in> \<langle>R\<rangle>list_rel
    \<and> (va',va)\<in>R
    \<and> (cysfx', cysfx) \<in> \<langle>R\<rangle>list_rel
    \<and> (m',m) \<in> Re
    }"
    unfolding lasso_rel_ext_internal_def relAPP_def by auto

  lemma lasso_rel_ext_sv[relator_props]:
    "\<And> Re R. \<lbrakk> single_valued Re; single_valued R \<rbrakk> \<Longrightarrow> single_valued (\<langle>Re,R\<rangle>lasso_rel_ext)"
    unfolding lasso_rel_ext_def
    apply (rule single_valuedI)
    apply safe
    apply (blast dest: single_valuedD list_rel_sv[THEN single_valuedD])+
    done

  lemma lasso_rel_ext_id[relator_props]:
    "\<And>Re R. \<lbrakk> Re=Id; R=Id \<rbrakk> \<Longrightarrow> \<langle>Re,R\<rangle>lasso_rel_ext = Id"
    unfolding lasso_rel_ext_def
    apply simp
    apply safe
    by (metis lasso.surjective)

  consts i_lasso_ext :: "interface \<Rightarrow> interface \<Rightarrow> interface"

  lemmas [autoref_rel_intf] = REL_INTFI[of lasso_rel_ext i_lasso_ext]

  find_consts "(_,_) lasso_scheme"
  term lasso_reach_update

  lemma lasso_param[param, autoref_rules]:
    "\<And>Re R. (lasso_reach, lasso_reach) \<in> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>R\<rangle>list_rel"
    "\<And>Re R. (lasso_va, lasso_va) \<in> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> R"
    "\<And>Re R. (lasso_cysfx, lasso_cysfx) \<in> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>R\<rangle>list_rel"
    "\<And>Re R. (lasso_ext, lasso_ext)
      \<in> \<langle>R\<rangle>list_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> Re \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext"
    "\<And>Re R. (lasso_reach_update, lasso_reach_update)
      \<in> (\<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel) \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext"
    "\<And>Re R. (lasso_va_update, lasso_va_update)
      \<in> (R\<rightarrow>R) \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext"
    "\<And>Re R. (lasso_cysfx_update, lasso_cysfx_update)
      \<in> (\<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel) \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext"
    "\<And>Re R. (lasso.more_update, lasso.more_update)
      \<in> (Re\<rightarrow>Re) \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext"
    unfolding lasso_rel_ext_def
    by (auto dest: fun_relD)

  lemma lasso_param2[param, autoref_rules]:
    "\<And>Re R. (lasso_v0, lasso_v0) \<in> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> R"
    "\<And>Re R. (lasso_cycle, lasso_cycle) \<in> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>R\<rangle>list_rel"
    "\<And>Re R. (map_lasso, map_lasso)
      \<in> (R\<rightarrow>R') \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>unit_rel,R'\<rangle>lasso_rel_ext"
    unfolding lasso_v0_def[abs_def] lasso_cycle_def[abs_def] map_lasso_def[abs_def]
    by parametricity+

  lemma lasso_of_prpl_param: "\<lbrakk>(l',l)\<in>\<langle>R\<rangle>list_rel \<times>\<^sub>r \<langle>R\<rangle>list_rel; snd l \<noteq> []\<rbrakk>
    \<Longrightarrow> (lasso_of_prpl l', lasso_of_prpl l) \<in> \<langle>unit_rel,R\<rangle>lasso_rel_ext"
    unfolding lasso_of_prpl_def
    apply (cases l, cases l', clarsimp)
    apply (case_tac b, simp, case_tac ba, clarsimp_all)
    apply parametricity
    done

  context begin interpretation autoref_syn .

  lemma lasso_of_prpl_autoref[autoref_rules]:
    assumes "SIDE_PRECOND (snd l \<noteq> [])"
    assumes "(l',l)\<in>\<langle>R\<rangle>list_rel \<times>\<^sub>r \<langle>R\<rangle>list_rel"
    shows "(lasso_of_prpl l',
      (OP lasso_of_prpl
        ::: \<langle>R\<rangle>list_rel \<times>\<^sub>r \<langle>R\<rangle>list_rel \<rightarrow> \<langle>unit_rel,R\<rangle>lasso_rel_ext)$l)
      \<in> \<langle>unit_rel,R\<rangle>lasso_rel_ext"
    using assms
    apply (simp add: lasso_of_prpl_param)
    done

  end

  subsection \<open>Implementing runs by lassos\<close>

  definition lasso_run_rel_def_internal:
    "lasso_run_rel R \<equiv> br run_of_lasso (\<lambda>_. True) O (nat_rel \<rightarrow> R)"
  lemma lasso_run_rel_def:
    "\<langle>R\<rangle>lasso_run_rel = br run_of_lasso (\<lambda>_. True) O (nat_rel \<rightarrow> R)"
    unfolding lasso_run_rel_def_internal relAPP_def by simp

  lemma lasso_run_rel_sv[relator_props]:
    "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>lasso_run_rel)"
    unfolding lasso_run_rel_def
    by tagged_solver

  consts i_run :: "interface \<Rightarrow> interface"

  lemmas [autoref_rel_intf] = REL_INTFI[of lasso_run_rel i_run]

  definition [simp]: "op_map_run \<equiv> (o)"

  lemma map_lasso_run_refine[autoref_rules]:
    shows "(map_lasso,op_map_run) \<in> (R\<rightarrow>R') \<rightarrow> \<langle>R\<rangle>lasso_run_rel \<rightarrow> \<langle>R'\<rangle>lasso_run_rel"
    unfolding lasso_run_rel_def op_map_run_def
  proof (intro fun_relI)
    fix f f' l r
    assume [param]: "(f,f')\<in>R\<rightarrow>R'" and
      "(l, r) \<in> br run_of_lasso (\<lambda>_. True) O (nat_rel \<rightarrow> R)"
    then obtain r' where [param]: "(r',r)\<in>nat_rel \<rightarrow> R"
      and [simp]: "r' = run_of_lasso l"
      by (auto simp: br_def)

    have "(map_lasso f l, f o r') \<in> br run_of_lasso (\<lambda>_. True)"
      by (simp add: br_def)
    also have "(f o r', f' o r) \<in> nat_rel \<rightarrow> R'" by parametricity
    finally (relcompI) show
      "(map_lasso f l, f' o r) \<in> br run_of_lasso (\<lambda>_. True) O (nat_rel \<rightarrow> R')"
      .
  qed

end