(*  Title:      Presburger-Automata/Exec.thy
    Author:     Stefan Berghofer, TU Muenchen, 2008-2009
*)

theory Exec
imports Presburger_Automata "~~/src/HOL/Library/Efficient_Nat"
begin

declare gen_dfs_simps [code]

lemma [code_unfold]: "op \<longrightarrow> = (\<lambda>P. op \<or> (\<not> P))"
  by (simp add: fun_eq_iff)

lemma "\<forall>x. (\<exists>xa. int xa - int x = 5) \<or> (\<forall>xa xb. \<not> 6 \<le> int xb \<longrightarrow> int xb + (6 * int xa - int x) = 0 \<longrightarrow> int xa = 1)"
proof -
  have "?thesis = eval_pf (Forall (Exist (Or (Eq [1, -1] 5)
    (Forall (Forall (Imp (Neg (Le [-1, 0] -6)) (Imp (Eq [1, 6, 0, -1] 0) (Eq [0, 1] 1)))))))) []"
    (is "_ = eval_pf ?P []")
    by simp
  also have "\<dots> = dfa_accepts (dfa_of_pf 0 ?P) []"
    by (simp add: dfa_of_pf_correctness del: dfa_of_pf.simps)
  also have "\<dots>" by eval
  finally show ?thesis .
qed

lemma "\<forall>x xa xb. \<not> 2 \<le> int xb \<longrightarrow> int xb + (2 * int xa - int x) = 1 \<longrightarrow>
  (\<forall>xb xc. \<not> 2 \<le> int xc \<longrightarrow> int xc + (2 * int xb - int x) = 0 \<longrightarrow> (\<exists>xa. 2 * int xa = int x) \<longrightarrow> xb = xa)"
proof -
  have "?thesis = eval_pf (Forall (Forall (Forall (Imp (Neg (Le [-1] -2))
    (Imp (Eq [1, 2, -1] 1) (Forall (Forall (Imp (Neg (Le [-1] -2))
      (Imp (Eq [1, 2, 0, 0, -1] 0) (Imp (Exist (Eq [2, 0, 0, 0, 0, -1] 0)) (Eq [0, 1, 0, -1] 0))))))))))) []"
    (is "_ = eval_pf ?P []")
    by simp
  also have "\<dots> = dfa_accepts (dfa_of_pf 0 ?P) []"
    by (simp add: dfa_of_pf_correctness del: dfa_of_pf.simps)
  also have "\<dots>" by eval
  finally show ?thesis .
qed

definition "mk_dfa = dfa_of_pf 0"

definition "stamp = Forall (Imp (Le [-1] -8) (Exist (Exist (Eq [5, 3, -1] 0))))"
definition "stamp_false = Forall (Imp (Le [-1] -7) (Exist (Exist (Eq [5, 3, -1] 0))))"
definition "example = Forall (Exist (Or (Eq [1, -1] 5)
  (Forall (Forall (Imp (Neg (Le [-1, 0] -6)) (Imp (Eq [1, 6, 0, -1] 0) (Eq [0, 1] 1)))))))"
definition "example2 = Forall (Forall (Forall (Imp (Neg (Le [-1] -2))
  (Imp (Eq [1, 2, -1] 1) (Forall (Forall (Imp (Neg (Le [-1] -2))
    (Imp (Eq [1, 2, 0, 0, -1] 0) (Imp (Exist (Eq [2, 0, 0, 0, 0, -1] 0)) (Eq [0, 1, 0, -1] 0))))))))))"
definition "example2_false = Forall (Forall (Forall (Imp (Neg (Le [-1] -2))
  (Imp (Eq [1, 2, -1] 1) (Forall (Forall (Imp (Neg (Le [-1] -2))
    (Imp (Eq [1, 2, 0, 0, -1] 0) (Imp (Exist (Eq [3, 0, 0, 0, 0, -1] 0)) (Eq [0, 1, 0, -1] 0))))))))))"
definition "harrison1 = Exist (Forall (Imp (Le [-1, 1] 0) (Exist (Exist
  (And (Le [0, -1] 0) (And (Le [-1] 0) (Eq [8, 3, -1] 0)))))))"
definition "harrison2 = Exist (Forall (Imp (Le [-1, 1] 0) (Exist (Exist
  (And (Le [0, -1] 0) (And (Le [-1] 0) (Eq [8, 7, -1] 0)))))))"

value "mk_dfa stamp"
value "min_dfa (mk_dfa stamp)"
value "mk_dfa stamp_false"
value "mk_dfa example"
value "mk_dfa example2"
value "mk_dfa example2_false"
value "mk_dfa harrison1"
value "mk_dfa harrison2"

end


(* VDM to Isabelle Translation @2021-12-17T14:01:51.178771Z
   Copyright 2021, Leo Freitas, leo.freitas@newcastle.ac.uk

in 'TestV2IExprsComplex' (./src/test/resources/TestV2IExprsComplex.vdmsl) at line 20:15
files = [./src/test/resources/TestV2IExprsComplex.vdmsl]
*)
theory TestV2IExprsComplex_PO
imports TestV2IExprsComplex
begin

\<comment>\<open>VDM source: vc31 = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplex' (./src/test/resources/TestV2IExprsComplex.vdmsl) at line 20:15\<close>
theorem vc31_FINITE_SET:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (finmap1 :: (VDMNat \<rightharpoonup> VDMNat))  . ((((inv_Map (inv_VDMNat) (inv_VDMNat) finmap1))) \<longrightarrow> (\<forall> (x :: VDMNat)  . ((((inv_VDMNat x))) \<longrightarrow> ((x > (10::VDMNat1)) \<longrightarrow> (\<exists> findex2 \<in> (dom finmap1)  . ((the(finmap1 findex2)) = x))))))))"

	oops

\<comment>\<open>VDM source: vc32 = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplex' (./src/test/resources/TestV2IExprsComplex.vdmsl) at line 24:15\<close>
theorem vc32_FINITE_SET:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (finmap1 :: (VDMNat \<rightharpoonup> VDMNat))  . ((((inv_Map (inv_VDMNat) (inv_VDMNat) finmap1))) \<longrightarrow> (\<forall> (x :: VDMNat)  (y :: VDMNat)  . ((((inv_VDMNat x))) \<and>  (((inv_VDMNat y))) \<longrightarrow> ((x > y) \<longrightarrow> (\<exists> findex2 \<in> (dom finmap1)  . ((the(finmap1 findex2)) = (x + y)))))))))"

	oops

\<comment>\<open>VDM source: vc41 = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplex' (./src/test/resources/TestV2IExprsComplex.vdmsl) at line 32:15\<close>
theorem vc41_FINITE_SET:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (finmap1 :: (VDMNat \<rightharpoonup> VDMNat))  . ((((inv_Map (inv_VDMNat) (inv_VDMNat) finmap1))) \<longrightarrow> (\<forall> (x :: VDMNat)  . ((((inv_VDMNat x))) \<longrightarrow> ((x > (10::VDMNat1)) \<longrightarrow> (\<exists> findex2 \<in> (dom finmap1)  . ((the(finmap1 findex2)) = x))))))))"

	oops

\<comment>\<open>VDM source: vc42 = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplex' (./src/test/resources/TestV2IExprsComplex.vdmsl) at line 36:15\<close>
theorem vc42_FINITE_SET:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (finmap1 :: (VDMNat \<rightharpoonup> VDMNat1))  . ((((inv_Map (inv_VDMNat) (inv_VDMNat1) finmap1))) \<longrightarrow> (\<forall> x :: VDMNat  . (\<forall> y \<in> {(1::VDMNat1), (2::VDMNat1), (3::VDMNat1)}  . (((inv_VDMNat x)) \<and>  (y \<in>{(1::VDMNat1), (2::VDMNat1), (3::VDMNat1)}) \<longrightarrow> ((x > y) \<longrightarrow> (\<exists> findex2 \<in> (dom finmap1)  . ((the(finmap1 findex2)) = (x + y))))))))))"

	oops

\<comment>\<open>VDM source: vc5 = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplex' (./src/test/resources/TestV2IExprsComplex.vdmsl) at line 44:15\<close>
theorem vc5_UNIQUE_EXISTENCE:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists>! (var :: VDMNat)  . ((((inv_VDMNat var))) \<longrightarrow> (var < (1::VDMNat1)))))"

	oops

\<comment>\<open>VDM source: vc51 = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplex' (./src/test/resources/TestV2IExprsComplex.vdmsl) at line 48:16\<close>
theorem vc51_UNIQUE_EXISTENCE:
	"((\<exists>! var \<in> {(1::VDMNat1), (2::VDMNat1), (3::VDMNat1)}  . (var < (1::VDMNat1))))"

	oops

\<comment>\<open>VDM source: vc6 = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplex' (./src/test/resources/TestV2IExprsComplex.vdmsl) at line 51:5\<close>
theorem vc6_SUB_TYPE:
	"((((
	\<lambda> (var :: VDMNat)  (var2 :: VDMNat) .
		(if (((inv_VDMNat var))) \<and>  (((inv_VDMNat var2))) \<and> (inv_VDMNat (var + var2)) then
		(var + var2)
	 else
		undefined
	)
	) (10::VDMNat1)  (20::VDMNat1)) > (0::VDMNat)))"

	oops

\<comment>\<open>VDM source: f = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplex' (./src/test/resources/TestV2IExprsComplex.vdmsl) at line 59:5\<close>
theorem f_FUNC_POST_CONDITION:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (x :: VDMNat)  (y :: VDMNat1)  . ((((inv_VDMNat x))) \<and>  (((inv_VDMNat1 y))) \<longrightarrow> ((pre_f x  y) \<longrightarrow> (post_f x  y  (x + y))))))"

	oops

\<comment>\<open>Processing VDM exports as Isabelle hidden declarations\<close>
hide_const "vc51"
hide_const "vc41"
hide_const "vc31"
hide_const "vc42"
hide_const "vc32"
hide_const "f"
hide_const "vc6"
hide_const "vc5"

end


subsection {* Refinement Calculus *}

theory utp_rcalc
  imports utp_prog
begin

subsection {* Operators *}

lift_definition spec :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred \<Rightarrow> ('\<alpha> \<Rightarrow> '\<alpha> upred) \<Rightarrow> '\<alpha> prog"
is "\<lambda> x p q. (\<Squnion> v \<bullet> ((p \<and> &\<^bold>v =\<^sub>u \<guillemotleft>v\<guillemotright>) \<turnstile>\<^sub>n x:[\<lceil>q(v)\<rceil>\<^sub>>]))"
  by (simp add: closure)

lift_definition log_const :: "('a \<Rightarrow> '\<alpha> prog) \<Rightarrow> '\<alpha> prog"
is "\<lambda> P. \<Squnion> i \<bullet> P i" by (simp add: closure)

declare spec.rep_eq [prog_rep_eq]
declare log_const.rep_eq [prog_rep_eq]

subsection {* Syntax Translations *}

syntax
  "_init_var"  :: "logic"
  "_spec"      :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_:[_,/ _]" [99,0,0] 100)
  "_log_const" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("con _ \<bullet> _" [0, 10] 10)

translations
  "_spec x p q" => "CONST spec x p (\<lambda> _init_var. q)"
  "_spec (_salphaset (_salphamk x)) p q" <= "CONST spec x p (\<lambda> iv. q)"
  "_log_const x P" == "CONST log_const (\<lambda> x. P)"

parse_translation {*
let
  fun init_var_tr [] = Syntax.free "iv"
    | init_var_tr _  = raise Match;
in
[(@{syntax_const "_init_var"}, K init_var_tr)]
end
*}

abbreviation "chose x \<equiv> {&x}:[true,true]"

subsection {* Refinement Laws *}

lemma spec_abort:
  "x:[false,post] = abort"
  by pauto

lemma spec_skip:
  "\<emptyset>:[true,true] = skip"
  by (pauto)

lemma rc_strengthen_post:
  assumes "`post' \<Rightarrow> post`"
  shows "w:[pre, post] \<sqsubseteq> w:[pre, post']"
  using assms by (pauto)

lemma rc_weaken_pre:
  assumes "`pre \<Rightarrow> pre'`"
  shows "w:[pre, post] \<sqsubseteq> w:[pre', post]"
  using assms by prefine

lemma rc_skip:
  assumes "vwb_lens w" "`pre \<Rightarrow> post`"
  shows "w:[pre, post] \<sqsubseteq> skip"
  using assms by prefine

lemma rc_assign:
  assumes "vwb_lens x" "vwb_lens w" "x \<bowtie> w" "`pre \<Rightarrow> post\<lbrakk>e/w\<rbrakk>`"
  shows "{&w,&x}:[pre,post] \<sqsubseteq> w := e"
  using assms by prefine

lemma rc_seq:
  assumes "vwb_lens w" "w \<natural> mid"
  shows "w:[pre, post] \<sqsubseteq> w:[pre, mid] ; w:[mid, post]"
  using assms by prefine

end


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

section \<open>The Sum Type as Error Monad\<close>

theory Error_Monad
imports
  "HOL-Library.Monad_Syntax"
  Error_Syntax
begin

text \<open>Make monad syntax (including do-notation) available for the sum type.\<close>
definition bind :: "'e + 'a \<Rightarrow> ('a \<Rightarrow> 'e + 'b) \<Rightarrow> 'e + 'b"
where
  "bind m f = (case m of Inr x \<Rightarrow> f x | Inl e \<Rightarrow> Inl e)"

adhoc_overloading
  Monad_Syntax.bind bind

abbreviation (input) "return \<equiv> Inr"
abbreviation (input) "error \<equiv> Inl"
abbreviation (input) "run \<equiv> projr"

subsection \<open>Monad Laws\<close>

lemma return_bind [simp]:
  "(return x \<bind> f) = f x"
  by (simp add: bind_def)

lemma bind_return [simp]:
  "(m \<bind> return) = m"
  by (cases m) (simp_all add: bind_def)

lemma error_bind [simp]:
  "(error e \<bind> f) = error e"
  by (simp add: bind_def)

lemma bind_assoc [simp]:
  fixes m :: "'a + 'b"
  shows "((m \<bind> f) \<bind> g) = (m \<bind> (\<lambda>x. f x \<bind> g))"
  by (cases m) (simp_all add: bind_def)

definition catch_error :: "'e + 'a \<Rightarrow> ('e \<Rightarrow> 'f + 'a) \<Rightarrow> 'f + 'a"
where
  catch_def: "catch_error m f = (case m of Inl e \<Rightarrow> f e | Inr x \<Rightarrow> Inr x)"

adhoc_overloading
  Error_Syntax.catch catch_error

lemma bind_splits:
  "P (m \<bind> f) \<longleftrightarrow> (\<forall>e. m = Inl e \<longrightarrow> P (Inl e)) \<and> (\<forall>x. m = Inr x \<longrightarrow> P (f x))"
  "P (m \<bind> f) \<longleftrightarrow> (\<not> ((\<exists>e. m = Inl e \<and> \<not> P (Inl e)) \<or> (\<exists>x. m = Inr x \<and> \<not> P (f x))))"
  by (case_tac [!] m) simp_all

lemma catch_splits:
  "P (try m catch f) \<longleftrightarrow> (\<forall>e. m = Inl e \<longrightarrow> P (f e)) \<and> (\<forall>x. m = Inr x \<longrightarrow> P (Inr x))"
  "P (try m catch f) \<longleftrightarrow> (\<not> ((\<exists>e. m = Inl e \<and> \<not> P (f e)) \<or> (\<exists>x. m = Inr x \<and> \<not> P (Inr x))))"
  by (case_tac [!] m) (simp_all add: catch_def)

abbreviation update_error :: "'e + 'a \<Rightarrow> ('e \<Rightarrow> 'f) \<Rightarrow> 'f + 'a"
where
  "update_error m f \<equiv> try m catch (\<lambda>x. error (f x))"

adhoc_overloading
  Error_Syntax.update_error update_error

lemma catch_return [simp]:
  "(try return x catch f) = return x" by (simp add: catch_def)

lemma catch_error [simp]:
  "(try error e catch f) = f e" by (simp add: catch_def)

lemma update_error_return [simp]:
  "(m <+? c = return x) \<longleftrightarrow> (m = return x)"
  by (cases m) simp_all

definition "isOK m \<longleftrightarrow> (case m of Inl e \<Rightarrow> False | Inr x \<Rightarrow> True)"

lemma isOK_E [elim]:
  assumes "isOK m"
  obtains x where "m = return x"
  using assms by (cases m) (simp_all add: isOK_def)

lemma isOK_I [simp, intro]:
  "m = return x \<Longrightarrow> isOK m"
  by (cases m) (simp_all add: isOK_def)

lemma isOK_iff:
  "isOK m \<longleftrightarrow> (\<exists>x. m = return x)"
  by blast

lemma isOK_error [simp]:
  "isOK (error x) = False"
  by blast

lemma isOK_bind [simp]:
  "isOK (m \<bind> f) \<longleftrightarrow> isOK m \<and> isOK (f (run m))"
  by (cases m) simp_all

lemma isOK_update_error [simp]:
  "isOK (m <+? f) \<longleftrightarrow> isOK m"
  by (cases m) simp_all

lemma isOK_case_prod [simp]:
  "isOK (case lr of (l, r) \<Rightarrow> P l r) = (case lr of (l, r) \<Rightarrow> isOK (P l r))"
  by (rule prod.case_distrib)

lemma isOK_case_option [simp]:
  "isOK (case x of None \<Rightarrow> P | Some v \<Rightarrow> Q v) = (case x of None \<Rightarrow> isOK P | Some v \<Rightarrow> isOK (Q v))"
  by (cases x) (auto)

lemma isOK_Let [simp]:
  "isOK (Let s f) = isOK (f s)"
  by (simp add: Let_def)

lemma run_bind [simp]:
  "isOK m \<Longrightarrow> run (m \<bind> f) = run (f (run m))"
  by auto

lemma run_catch [simp]:
  "isOK m \<Longrightarrow> run (try m catch f) = run m"
  by auto

fun foldM :: "('a \<Rightarrow> 'b \<Rightarrow> 'e + 'a) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> 'e + 'a"
where
  "foldM f d [] = return d" |
  "foldM f d (x # xs) = do { y \<leftarrow> f d x; foldM f y xs }"

fun forallM_index_aux :: "('a \<Rightarrow> nat \<Rightarrow> 'e + unit) \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> (('a \<times> nat) \<times> 'e) + unit"
where
  "forallM_index_aux P i [] = return ()" |
  "forallM_index_aux P i (x # xs) = do {
    P x i <+? Pair (x, i);
    forallM_index_aux P (Suc i) xs
  }"

lemma isOK_forallM_index_aux [simp]:
  "isOK (forallM_index_aux P n xs) = (\<forall>i < length xs. isOK (P (xs ! i) (i + n)))"
proof (induct xs arbitrary: n)
  case (Cons x xs)
  have "(\<forall>i < length (x # xs). isOK (P ((x # xs) ! i) (i + n))) \<longleftrightarrow>
    (isOK (P x n) \<and> (\<forall>i < length xs. isOK (P (xs ! i) (i + Suc n))))"
    by (auto, case_tac i) (simp_all)
  then show ?case
    unfolding Cons [of "Suc n", symmetric] by simp
qed auto

definition forallM_index :: "('a \<Rightarrow> nat \<Rightarrow> 'e + unit) \<Rightarrow> 'a list \<Rightarrow> (('a \<times> nat) \<times> 'e) + unit"
where
  "forallM_index P xs = forallM_index_aux P 0 xs"

lemma isOK_forallM_index [simp]:
  "isOK (forallM_index P xs) \<longleftrightarrow> (\<forall>i < length xs. isOK (P (xs ! i) i))"
  unfolding forallM_index_def isOK_forallM_index_aux by simp

lemma forallM_index [fundef_cong]:
  fixes c :: "'a \<Rightarrow> nat \<Rightarrow> 'e + unit"
  assumes "\<And>x i. x \<in> set xs \<Longrightarrow> c x i = d x i"
  shows "forallM_index c xs = forallM_index d xs"
proof -
  { fix n
    have "forallM_index_aux c n xs = forallM_index_aux d n xs"
      using assms by (induct xs arbitrary: n) simp_all }
  then show ?thesis by (simp add: forallM_index_def)
qed

hide_const forallM_index_aux

text \<open>
  Check whether @{term f} succeeds for all elements of a given list. In case it doesn't,
  return the first offending element together with the produced error.
\<close>
fun forallM :: "('a \<Rightarrow> 'e + unit) \<Rightarrow> 'a list \<Rightarrow> ('a * 'e) + unit"
where
  "forallM f [] = return ()" |
  "forallM f (x # xs) = f x <+? Pair x \<then> forallM f xs"

lemma isOK_forallM [simp]:
  "isOK (forallM f xs) \<longleftrightarrow> (\<forall>x \<in> set xs. isOK (f x))"
  by (induct xs) (simp_all)

text \<open>
  Check whether @{term f} succeeds for at least one element of a given list.
  In case it doesn't, return the list of produced errors.
\<close>
fun existsM :: "('a \<Rightarrow> 'e + unit) \<Rightarrow> 'a list \<Rightarrow> 'e list + unit"
where
  "existsM f [] = error []" |
  "existsM f (x # xs) = (try f x catch (\<lambda>e. existsM f xs <+? Cons e))"

lemma isOK_existsM [simp]:
  "isOK (existsM f xs) \<longleftrightarrow> (\<exists>x\<in>set xs. isOK (f x))"
proof (induct xs)
  case (Cons x xs)
  show ?case
  proof (cases "f x")
    case (Inl e)
    with Cons show ?thesis by simp
  qed (auto simp add: catch_def)
qed simp

lemma is_OK_if_return [simp]:
  "isOK (if b then return x else m) \<longleftrightarrow> b \<or> isOK m"
  "isOK (if b then m else return x) \<longleftrightarrow> \<not> b \<or> isOK m"
  by simp_all

lemma isOK_if_error [simp]:
  "isOK (if b then error e else m) \<longleftrightarrow> \<not> b \<and> isOK m"
  "isOK (if b then m else error e) \<longleftrightarrow> b \<and> isOK m"
  by simp_all

lemma isOK_if:
  "isOK (if b then x else y) \<longleftrightarrow> b \<and> isOK x \<or> \<not> b \<and> isOK y"
  by simp

fun sequence :: "('e + 'a) list \<Rightarrow> 'e + 'a list"
where
  "sequence [] = Inr []" |
  "sequence (m # ms) = do {
    x \<leftarrow> m;
    xs \<leftarrow> sequence ms;
    return (x # xs)
  }"

subsection \<open>Monadic Map for Error Monad\<close>

fun mapM :: "('a \<Rightarrow> 'e + 'b) \<Rightarrow> 'a list \<Rightarrow> 'e + 'b list"
where
  "mapM f [] = return []" |
  "mapM f (x#xs) = do {
    y \<leftarrow> f x;
    ys \<leftarrow> mapM f xs;
    Inr (y # ys)
  }"

lemma mapM_error:
  "(\<exists>e. mapM f xs = error e) \<longleftrightarrow> (\<exists>x\<in>set xs. \<exists>e. f x = error e)"
proof (induct xs)
  case (Cons x xs)
  then show ?case
    by (cases "f x", simp_all, cases "mapM f xs", simp_all)
qed simp

lemma mapM_return:
  assumes "mapM f xs = return ys"
  shows "ys = map (run \<circ> f) xs \<and> (\<forall>x\<in>set xs. \<forall>e. f x \<noteq> error e)"
using assms
proof (induct xs arbitrary: ys)
  case (Cons x xs ys)
  then show ?case
    by (cases "f x", simp, cases "mapM f xs", simp_all)
qed simp

lemma mapM_return_idx:
  assumes *: "mapM f xs = Inr ys" and "i < length xs"
  shows "\<exists>y. f (xs ! i) = Inr y \<and> ys ! i = y"
proof -
  note ** = mapM_return [OF *, unfolded set_conv_nth]
  with assms have "\<And>e. f (xs ! i) \<noteq> Inl e" by auto
  then obtain y where "f (xs ! i) = Inr y" by (cases "f (xs ! i)") auto
  then have "f (xs ! i) = Inr y \<and> ys ! i = y" unfolding ** [THEN conjunct1] using assms by auto
  then show ?thesis ..
qed

lemma mapM_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "mapM f xs = mapM g ys"
  unfolding assms(1) using assms(2) by (induct ys) auto

lemma bindE [elim]:
  assumes "(p \<bind> f) = return x"
  obtains y where "p = return y" and "f y = return x"
  using assms by (cases p) simp_all

lemma then_return_eq [simp]:
  "(p \<then> q) = return f \<longleftrightarrow> isOK p \<and> q = return f"
  by (cases p) simp_all

fun choice :: "('e + 'a) list \<Rightarrow> 'e list + 'a"
where
  "choice [] = error []" |
  "choice (x # xs) = (try x catch (\<lambda>e. choice xs <+? Cons e))"

declare choice.simps [simp del]

lemma isOK_mapM:
  assumes "isOK (mapM f xs)"
  shows "(\<forall>x. x \<in> set xs \<longrightarrow> isOK (f x)) \<and> run (mapM f xs) = map (\<lambda>x. run (f x)) xs"
  using assms mapM_return[of f xs] by (force simp: isOK_def split: sum.splits)+

fun firstM
  where
    "firstM f [] = error []"
  | "firstM f (x # xs) = (try f x \<then> return x catch (\<lambda>e. firstM f xs <+? Cons e))"

lemma firstM:
  "isOK (firstM f xs) \<longleftrightarrow> (\<exists>x\<in>set xs. isOK (f x))"
  by (induct xs) (auto simp: catch_def split: sum.splits)

lemma firstM_return:
  assumes "firstM f xs = return y"
  shows "isOK (f y) \<and> y \<in> set xs"
  using assms by (induct xs) (auto simp: catch_def split: sum.splits)

end


theory Init_ODE_Solver
imports
  Concrete_Reachability_Analysis_C1
  Refine_Reachability_Analysis_C1
  Refine_Rigorous_Numerics_Aform
begin

subsection \<open>``Final'' Theorems, stated outside of refinement framework.\<close>

lemma br_Times_Univ: "br a I \<times>\<^sub>r (UNIV::(_ \<times> unit) set) = br (\<lambda>(x, _). (a x, ())) (\<lambda>(x, _). I x)"
  by (auto simp: br_def)

lemma TRANSFER_refl: "TRANSFER (x \<le> (x::_nres))" by auto
lemma init_ode_ops: "(y \<Longrightarrow> x) \<Longrightarrow> (init_ode_ops x y odo, odo) \<in> ode_ops_rel"
  by (auto simp: ode_ops_rel_def init_ode_ops_def)

context approximate_sets begin

context includes autoref_syntax begin

theorem solves_poincare_map_ncc:
  fixes sctni pos ivli ssc XS ph rl ru dRi CXS X0 S trap
  defines "P \<equiv> set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni)"
  defines "Sa \<equiv> below_halfspace (map_sctn eucl_of_list S)::'n::enum rvec set"
  defines "X0 \<equiv> c1_info_of_apprse XS"
  defines "X1 \<equiv> flow1_of_vec1 ` ({eucl_of_list rl .. eucl_of_list ru} \<times> set_of_lvivl' dRi)"
  assumes ncc: "ncc_precond TYPE('n rvec)" "ncc_precond TYPE('n vec1)"
  assumes ret: "solves_poincare_map odo symstart [S] guards ivli sctni roi XS (rl, ru) dRi"
  assumes symstart: "(symstart, symstarta::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres) \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>dres_nres_rel"
  assumes symstart_spec: "\<And>X0. X0 \<subseteq> Csafe odo \<times> UNIV \<Longrightarrow> symstarta X0 \<le> SPEC (\<lambda>(CX, X). flowsto odo (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
  assumes trapprop: "stable_on odo (Csafe odo - P) trap"
  assumes invar: "\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invare CARD('n) X"
  assumes lens: "length (ode_e odo) = CARD('n)" "length (normal sctni) = CARD('n)" "length (fst ivli) = CARD('n)" "length (snd ivli) = CARD('n)"
    "length (normal S) = CARD('n)" "length rl = CARD('n)" "length ru = CARD('n)"
     "lvivl'_invar (CARD('n)*CARD('n)) dRi"
    "\<And>a xs b ba ro. (xs, ro) \<in> set guards \<Longrightarrow> ((a, b), ba) \<in> set xs \<Longrightarrow> length a = CARD('n) \<and> length b = CARD('n) \<and> length (normal ba) = CARD('n)"
  shows "poincare_mapsto odo P (X0 - trap \<times> UNIV) Sa (Csafe odo - P) X1"
proof -
  define guardsa::"('n rvec set \<times> unit) list"  where "guardsa \<equiv> map (\<lambda>(x, y). (\<Union>x\<in>set x. case x of (x, y) \<Rightarrow> (case x of (x, y) \<Rightarrow> set_of_ivl (eucl_of_list x, eucl_of_list y)) \<inter> plane_of (map_sctn eucl_of_list y), ())) guards"
  define roa where "roa = ()"
  have spm:
    "(XS, X0) \<in> clw_rel (appr1e_rel)"
    "([S], Sa) \<in> \<langle>lv_rel\<rangle>halfspaces_rel"
    "(guards, guardsa) \<in> \<langle>clw_rel (iplane_rel lvivl_rel) \<times>\<^sub>r reach_optns_rel\<rangle>list_rel"
    "(ivli, set_of_lvivl ivli::'n rvec set) \<in> lvivl_rel"
    "(sctni, map_sctn eucl_of_list sctni::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
    "(roi, roa) \<in> reach_optns_rel"
    "(\<lambda>x. nres_of (symstart x), symstarta) \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
    "((), trap) \<in> ghost_rel"
    using lens symstart[THEN dres_nres_rel_nres_relD]
    by (auto simp: X0_def X1_def Sa_def P_def appr_rel_br set_rel_br
        br_chain o_def clw_rel_br  lv_rel_def sctn_rel_br ivl_rel_br set_of_lvivl_def
        halfspaces_rel_def list_set_rel_brp below_halfspaces_def ghost_relI
        br_rel_prod br_list_rel guardsa_def Id_br inter_rel_br plane_rel_br
        roa_def br_Times_Univ reach_options_rel_def
        split: sctn.splits
        intro!: brI list_allI clw_rel_appr1e_relI assms)

  have ivls: "((rl, ru), {eucl_of_list rl .. eucl_of_list ru::'n rvec}) \<in> lvivl_rel"
    "(dRi, set_of_lvivl' dRi::(('n rvec), 'n) vec set) \<in> \<langle>lvivl_rel\<rangle>default_rel UNIV"
    by (auto intro!: lvivl_relI lvivl_default_relI lens simp: lens set_of_lvivl_def set_of_ivl_def
        split: option.splits)

  from lens(1) have wd: "wd odo TYPE('n rvec)" by (auto simp: wd_def)
  from lens(1) have DIM_precond: "DIM_precond TYPE('n rvec) (D odo)"
    by (auto simp: D_def)
  have pmspec: "poincare_onto_from_in_ivl $ odo $ symstarta $ trap $ S $ guards $ ivl $ sctn $ ro $ XS0 $ IVL $ dIVL
  \<le> SPEC (\<lambda>b. b \<longrightarrow> poincare_mapsto odo (ivl \<inter> plane_of sctn) (XS0 - trap \<times> UNIV) S (Csafe odo - ivl \<inter> plane_of sctn)
                      (flow1_of_vec1 ` (IVL \<times> dIVL)))"
    if trapprop: "stable_on odo (Csafe odo - ivl \<inter> plane_of sctn) trap"
    for ivl sctn XS0 S guards ro IVL dIVL
    using poincare_onto_from_in_ivl[OF wd symstart_spec trapprop order_refl,
        of S guards ro XS0 IVL dIVL]
    by auto

  have odo_init: "(init_ode_ops True (carries_c1 (hd XS)) odo, odo) \<in> ode_ops_rel"
    by (auto simp: intro!: init_ode_ops)
  from nres_rel_trans2[OF
      pmspec
      poincare_onto_from_in_ivl_impl.refine[OF DIM_precond ncc odo_init spm(1-7) TRANSFER_refl spm(8) ivls]
      ] ret trapprop
  show ?thesis
    by (auto simp: solves_poincare_map_def nres_rel_def P_def X1_def)
qed

lemma solves_poincare_map'_ncc:
  "ncc_precond TYPE('n::enum rvec) \<Longrightarrow>
  ncc_precond TYPE('n vec1) \<Longrightarrow>
  solves_poincare_map' odo S guards ivli sctni roi XS (rl, ru) dRi \<Longrightarrow>
  (\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invare CARD('n) X) \<Longrightarrow>
  length (ode_e odo) = CARD('n) \<Longrightarrow>
  length (normal sctni) = CARD('n) \<Longrightarrow>
  length (fst ivli) = CARD('n) \<Longrightarrow>
  length (snd ivli) = CARD('n) \<Longrightarrow>
  length (normal S) = CARD('n) \<Longrightarrow>
  length (rl) = CARD('n) \<Longrightarrow>
  length (ru) = CARD('n) \<Longrightarrow>
  lvivl'_invar (CARD('n)*CARD('n)) dRi \<Longrightarrow>
  (\<And>a xs b ba ro.
      (xs, ro) \<in> set guards \<Longrightarrow>
      ((a, b), ba) \<in> set xs \<Longrightarrow>
      length a = CARD('n) \<and>
      length b = CARD('n) \<and> length (normal ba) = CARD('n)) \<Longrightarrow>
  poincare_mapsto odo
   (set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni)::'n rvec set)
   (c1_info_of_apprse XS) (below_halfspace (map_sctn eucl_of_list S))
   (Csafe odo - set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni))
   (flow1_of_vec1 ` ({eucl_of_list rl .. eucl_of_list ru} \<times> set_of_lvivl' dRi))"
  by (rule solves_poincare_map_ncc[OF _ _ _
        empty_symstart_dres_nres_rel[unfolded empty_symstart_def op_empty_coll_def mk_coll_def]
         empty_symstart_flowsto,
    folded solves_poincare_map'_def, simplified])
    auto

lemma one_step_until_time_ivl_in_ivl_spec[le, refine_vcg]:
  "one_step_until_time_ivl_in_ivl odo (X0::'n::enum eucl1 set) t1 t2 R dR \<le> SPEC (\<lambda>b. b \<longrightarrow>
    (\<forall>(x0, d0) \<in> X0. {t1 .. t2} \<subseteq> existence_ivl0 odo x0 \<and>
      (\<forall>t \<in> {t1 .. t2}. (flow0 odo x0 t, Dflow odo x0 t o\<^sub>L d0) \<in> flow1_of_vec1 ` (R \<times> dR))))"
  if [simp]: "length (ode_e odo) = CARD('n::enum)"
proof -
  have wd[refine_vcg]: "wd odo TYPE((real, 'n) vec)" by (simp add: wd_def)
  show ?thesis
    unfolding one_step_until_time_ivl_in_ivl_def
    apply (refine_vcg, clarsimp_all)
    subgoal for X CX Y CY CY' x0 d0
        apply (drule bspec, assumption, clarsimp)
      subgoal for t
          apply (drule bspec[where x=t], force)
        by (simp add: subset_iff )
      done
    done
qed

theorem one_step_in_ivl_ncc:
  "t \<in> existence_ivl0 odo x0 \<and> (flow0 odo x0 t::'n rvec) \<in> R \<and> Dflow odo x0 t o\<^sub>L d0 \<in> dR"
  if ncc: "ncc_precond TYPE('n::enum rvec)" "ncc_precond TYPE('n vec1)"
   and t: "t \<in> {t0 .. t1}"
   and x0: "(x0, d0) \<in> c1_info_of_appre X"
   and invar: "c1_info_invare CARD('n) X"
   and R: "{eucl_of_list rl .. eucl_of_list ru} \<subseteq> R"
   and lens: "length rl = CARD('n)" "length ru = CARD('n)"
   and dRinvar: "lvivl'_invar (CARD('n)*CARD('n)) dRi"
   and dR: "blinfun_of_vmatrix ` set_of_lvivl' dRi \<subseteq> dR"
   and len_ode: "length (ode_e odo) = CARD('n)"
   and chk: "one_step_until_time_ivl_in_ivl_check odo X t0 t1 (rl, ru) dRi"
proof -
  have ivl: "((rl, ru), {eucl_of_list rl .. eucl_of_list ru::'n rvec}) \<in> \<langle>lv_rel\<rangle>ivl_rel"
    apply (rule lv_relivl_relI)
    using lens
    by auto
  from dRinvar have "lvivl'_invar DIM(((real, 'n) vec, 'n) vec) dRi" by simp
  note dRi = lvivl_default_relI[OF this]
  from len_ode have DIM_precond: "DIM_precond TYPE('n rvec) (D odo)"
    by (auto simp: D_def)
  have odo: "(init_ode_ops True (carries_c1 X) odo, odo) \<in> ode_ops_rel"
    by (auto intro!: init_ode_ops)
  from one_step_until_time_ivl_in_ivl_impl_refine[param_fo, OF DIM_precond ncc odo appr1e_relI[OF invar] IdI IdI ivl dRi, of t0 t1]
  have "nres_of (one_step_until_time_ivl_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 X) odo) X t0 t1 (rl, ru) dRi)
    \<le> one_step_until_time_ivl_in_ivl odo (c1_info_of_appre X) t0 t1 {eucl_of_list rl::'n rvec..eucl_of_list ru} (set_of_lvivl' dRi)"
    by (auto simp: nres_rel_def)
  also note one_step_until_time_ivl_in_ivl_spec[OF len_ode order_refl]
  also have "one_step_until_time_ivl_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 X) odo) X t0 t1 (rl, ru) dRi = dRETURN True"
    unfolding one_step_until_time_ivl_in_ivl_check_def[symmetric]
    using chk .
  finally show ?thesis
    using t R dR
    by (auto dest!: bspec[OF _ x0] bspec[where x=t] simp: vec1_of_flow1_def)
qed

subsection \<open>Poincare onto (from the outside)\<close>

theorem solves_poincare_map_onto_ncc:
  fixes sctni pos ivli ssc XS ph rl ru dRi CXS X0
  defines "P \<equiv> set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni)"
  defines "X0 \<equiv> c1_info_of_apprse XS"
  defines "X1 \<equiv> flow1_of_vec1 ` ({eucl_of_list rl .. eucl_of_list ru} \<times> set_of_lvivl' dRi)"
  assumes ncc: "ncc_precond TYPE('n::enum rvec)" "ncc_precond TYPE('n vec1)"
  assumes ret: "solves_poincare_map_onto odo guards ivli sctni roi XS (rl, ru) dRi"
  assumes invar: "\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invare CARD('n) X"
  assumes lens: "length (ode_e odo) = CARD('n)" "length (normal sctni) = CARD('n)" "length (fst ivli) = CARD('n)" "length (snd ivli) = CARD('n)"
    "length rl = CARD('n)" "length ru = CARD('n)"
     "lvivl'_invar (CARD('n)*CARD('n)) dRi"
    "\<And>a xs b ba ro. (xs, ro) \<in> set guards \<Longrightarrow> ((a, b), ba) \<in> set xs \<Longrightarrow> length a = CARD('n) \<and> length b = CARD('n) \<and> length (normal ba) = CARD('n)"
  shows "poincare_maps_onto odo P (X0::('n rvec \<times> _)set) X1"
proof -
  define guardsa::"('n rvec set \<times> unit) list"  where "guardsa \<equiv> map (\<lambda>(x, y). (\<Union>x\<in>set x. case x of (x, y) \<Rightarrow> (case x of (x, y) \<Rightarrow> set_of_ivl (eucl_of_list x, eucl_of_list y)) \<inter> plane_of (map_sctn eucl_of_list y), ())) guards"
  define roa where "roa = ()"
  have spm:
    "(XS, X0) \<in> clw_rel (appr1e_rel)"
    "(guards, guardsa) \<in> \<langle>clw_rel (iplane_rel lvivl_rel) \<times>\<^sub>r reach_optns_rel\<rangle>list_rel"
    "(ivli, set_of_lvivl ivli::'n rvec set) \<in> lvivl_rel"
    "(sctni, map_sctn eucl_of_list sctni::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
    "(roi, roa) \<in> reach_optns_rel"
    using lens
    by (auto simp: X0_def X1_def P_def appr_rel_br set_rel_br
        br_chain o_def clw_rel_br  lv_rel_def sctn_rel_br ivl_rel_br set_of_lvivl_def
        halfspaces_rel_def list_set_rel_brp below_halfspaces_def ghost_relI
        br_rel_prod br_list_rel guardsa_def Id_br inter_rel_br plane_rel_br
        reach_options_rel_def br_Times_Univ
        split: sctn.splits
        intro!: brI list_allI clw_rel_appr1e_relI assms)

  have ivls: "((rl, ru), {eucl_of_list rl .. eucl_of_list ru::'n rvec}) \<in> lvivl_rel"
    "(dRi, set_of_lvivl' dRi::(('n rvec), 'n) vec set) \<in> \<langle>lvivl_rel\<rangle>default_rel UNIV"
    by (auto intro!: lvivl_relI lvivl_default_relI lens simp: lens set_of_lvivl_def set_of_ivl_def
        split: option.splits)

  have pmspec: "poincare_onto_in_ivl odo guards ivl sctn ro XS0 IVL dIVL
  \<le> SPEC (\<lambda>b. b \<longrightarrow> poincare_mapsto odo (ivl \<inter> plane_of sctn) (XS0) UNIV (Csafe odo - ivl \<inter> plane_of sctn)
                      (flow1_of_vec1 ` (IVL \<times> dIVL)))"
    for ivl::"'n rvec set" and sctn XS0 guards ro IVL dIVL
    using poincare_onto_in_ivl[OF lens(1) order_refl, of guards ivl sctn ro XS0 IVL dIVL]
    by auto
  from lens(1) have DIM_precond: "DIM_precond TYPE('n rvec) (D odo)"
    by (auto simp: D_def)
  have odo: "(init_ode_ops True (carries_c1 (hd XS)) odo, odo) \<in> ode_ops_rel"
    by (auto intro!: init_ode_ops)
  from nres_rel_trans2[OF
      pmspec
      poincare_onto_in_ivl_impl.refine[OF DIM_precond ncc odo spm(1-5) ivls]
      ] ret
  show ?thesis
    by (auto simp: poincare_maps_onto_def solves_poincare_map_onto_def nres_rel_def P_def X1_def)
qed

end
end

subsection \<open>Executable definitions for ODE solver based on affine arithmetic\<close>

global_interpretation aform: approximate_sets aform_ops Joints aforms_rel optns for optns
  defines solves_poincare_map_aform = aform.solves_poincare_map
    and solves_poincare_map_aform' = aform.solves_poincare_map'
    and solves_poincare_map_onto_aform = aform.solves_poincare_map_onto
    and solves_one_step_until_time_aform = aform.one_step_until_time_ivl_in_ivl_check
    and solve_poincare_map_aform = aform.poincare_onto_from_impl
    and one_step_until_time_ivl_in_ivl_impl_aform = aform.one_step_until_time_ivl_in_ivl_impl
    and poincare_onto_from_in_ivl_impl_aform = aform.poincare_onto_from_in_ivl_impl
    and poincare_onto_in_ivl_impl_aform = aform.poincare_onto_in_ivl_impl
    and solve_poincare_onto_aform = aform.poincare_onto_impl
    and solve_one_step_until_time_aform = aform.one_step_until_time_ivl
    and one_step_until_time_impl_aform = aform.one_step_until_time_impl
    and op_image_fst_coll_nres_impl_aform = aform.op_image_fst_coll_nres_impl
    and poincare_onto_series_impl_aform = aform.poincare_onto_series_impl
    and poincare_start_on_impl_aform = aform.poincare_start_on_impl
    and leaves_halfspace_impl_aform = aform.leaves_halfspace_impl
    and approximate_sets_aform = aform.subset_spec_ivl_collc
    and subset_spec_plane_impl_aform = aform.subset_spec_plane_impl
    and disjoints_spec_impl_aform = aform.disjoints_spec_impl
    and partition_set_impl_aform = aform.partition_set_impl
    and fst_safe_coll_impl_aform = aform.fst_safe_coll_impl
    and choose_step1_impl_aform = aform.choose_step1_impl
    and ivl_rep_of_set_coll_impl_aform = aform.ivl_rep_of_set_coll_impl
    and ode_set_impl_aform = aform.ode_set_impl
    and mk_safe_impl_aform = aform.mk_safe_impl
    and subset_spec_ivlc_aform = aform.subset_spec_ivlc
    and sbelow_sctn_impl_aform = aform.sbelow_sctn_impl
    and below_sctn_impl_aform = aform.below_sctn_impl
    and split_under_threshold_impl_aform = aform.split_under_threshold_impl
    and do_intersection_coll_impl_aform = aform.do_intersection_coll_impl
    and partition_ivl_impl_aform = aform.partition_ivl_impl
    and mk_safe_coll_impl_aform = aform.mk_safe_coll_impl
    and choose_step_impl_aform = aform.choose_step_impl
    and reach_cont_impl_aform = aform.reach_cont_impl
    and vec1reps_impl_aform = aform.vec1reps_impl
    and ivl_rep_of_sets_impl_aform = aform.ivl_rep_of_sets_impl
    and ivl_rep_of_set_impl_aform = aform.ivl_rep_of_set_impl
    and ivls_of_sets_impl_aform = aform.ivls_of_sets_impl
    and tolerate_error_impl_aform = aform.tolerate_error_impl
    and tolerate_error1_impl_aform = aform.tolerate_error1_impl
    and pre_intersection_step_impl_aform = aform.pre_intersection_step_impl
    and split_spec_param1_impl_aform = aform.split_spec_param1_impl
    and do_intersection_impl_aform = aform.do_intersection_impl
    and resolve_step_impl_aform = aform.resolve_step_impl
    and euler_step_impl_aform = aform.euler_step_impl
    and rk2_step_impl_aform = aform.rk2_step_impl
    and op_eventually_within_sctn_impl_aform = aform.op_eventually_within_sctn_impl
    and solve_poincare_plane_impl_aform = aform.solve_poincare_plane_impl
    and cert_stepsize_impl_dres_aform = aform.cert_stepsize_impl_dres
    and step_adapt_time_impl_aform = aform.step_adapt_time_impl
    and inter_sctn1_impl_aform = aform.inter_sctn1_impl
    and step_split_impl_aform = aform.step_split_impl
    and intersects_impl_aform = aform.intersects_impl
    and above_sctn_impl_aform = aform.above_sctn_impl
    and nonzero_component_impl_aform = aform.nonzero_component_impl
    and P_iter_impl_aform = aform.P_iter_impl
    and partition_sets_impl_aform = aform.partition_sets_impl
    and reach_conts_impl_aform = aform.reach_conts_impl
    and subsets_iplane_coll_impl_aform = aform.subsets_iplane_coll_impl
    and reach_cont_symstart_impl_aform = aform.reach_cont_symstart_impl
    and subset_iplane_coll_impl_aform = aform.subset_iplane_coll_impl
    and symstart_coll_impl_aform = aform.symstart_coll_impl
    and subset_spec_ivls_clw_impl_aform = aform.subset_spec_ivls_clw_impl
    and poincare_onto2_impl_aform = aform.poincare_onto2_impl
    and poincare_onto_empty_impl_aform = aform.poincare_onto_empty_impl
    and resolve_ivlplanes_impl_aform = aform.resolve_ivlplanes_impl
    and empty_remainders_impl_aform = aform.empty_remainders_impl
    and adapt_stepsize_fa_aform = aform.adapt_stepsize_fa
    and split_spec_param1e_impl_aform = aform.split_spec_param1e_impl
    and setse_of_ivlse_impl_aform = aform.setse_of_ivlse_impl
    and ivlse_of_setse_impl_aform = aform.ivlse_of_setse_impl
    and choose_step1e_impl_aform = aform.choose_step1e_impl
    and vec1repse_impl_aform = aform.vec1repse_impl
    and scaleR2_rep1_impl_aform = aform.scaleR2_rep1_impl
    and list_of_appr1e_aform = aform.list_of_appr1e
    and list_of_appr1_aform = aform.list_of_appr1
    and nonzero_component_within_impl_aform = aform.nonzero_component_within_impl
    and approx_fas_impl_aform = aform.approx_slp_appr_impl
    and mig_set_impl_aform = aform.mig_set_impl
    and op_eucl_of_list_image_pad_aform = aform.op_eucl_of_list_image_pad
    and reach_cont_par_impl_aform = aform.reach_cont_par_impl
    and do_intersection_core_impl_aform = aform.do_intersection_core_impl
    and reduce_spec1e_impl_aform = aform.reduce_spec1e_impl
    and reduce_spec1_impl_aform = aform.reduce_spec1_impl
    and one_step_until_time_ivl_impl_aform = aform.one_step_until_time_ivl_impl
    and subset_spec1_collc_aform = aform.subset_spec1_collc
    and ivl_of_appr1_coll_impl_aform = aform.ivl_of_appr1_coll_impl
    and do_intersection_body_impl_aform = aform.do_intersection_body_impl
    and ode_slp_impl_aform = aform.ode_slp_impl
    and print_msg_impl_aform = aform.print_msg_impl
    and ode_e_impl_aform = aform.ode_e_impl
    and safe_form_impl_aform = aform.safe_form_impl
    and D_impl_aform = aform.D_impl
    and safe_set_appr_aform = aform.safe_set_appr
    and var_ode_ops_impl = aform.var_ode_ops_impl
    and start_stepsize_impl_aform = aform.start_stepsize_impl
    and poincare_slp_impl_aform = aform.poincare_slp_impl
    and rk2_param_impl_aform = aform.rk2_param_impl

  unfolding aform_approximate_sets_def[symmetric]
  by (rule aform_approximate_sets)

lemma aform_ncc[autoref_rules_raw]: "aform.ncc_precond TYPE('a::executable_euclidean_space)"
  using aform.appr_rel_nonempty
  by (auto simp: aform.ncc_precond_def aform.ncc_def aform.appr_rel_br br_def compact_Affine
    convex_Affine
      eucl_of_list_image_Joints)

fun parts::"nat\<Rightarrow>'a list\<Rightarrow>'a list list"
  where
    "parts n [] = []"
| "parts 0 xs = [xs]"
| "parts n xs = take n xs # parts n (drop n xs)"

lemma Joints_in_lv_rel_set_relD:
  "(Joints xs, X) \<in> \<langle>lv_rel\<rangle>set_rel \<Longrightarrow> X = Affine (eucl_of_list_aform xs)"
  apply auto
   apply (subst eucl_of_list_image_Joints[symmetric])
  unfolding lv_rel_def set_rel_br
    apply (auto simp: br_def )
  using aform.length_set_of_appr apply auto[1]
  apply (subst (asm) eucl_of_list_image_Joints[symmetric])
  unfolding lv_rel_def set_rel_br
   apply (auto simp: br_def )
  using aform.length_set_of_appr apply auto[1]
  done

lemma ncc_precond: "aform.ncc_precond TYPE('a::executable_euclidean_space)"
  apply (auto simp: aform.ncc_precond_def aform.ncc_def aform.appr_rel_def)
  apply (auto simp: aforms_rel_def br_def)
  subgoal by (auto simp: compact_Affine dest!: Joints_in_lv_rel_set_relD)
  subgoal by (auto simp: convex_Affine dest!: Joints_in_lv_rel_set_relD)
  done

lemma fst_eucl_of_list_aform_map: "fst (eucl_of_list_aform (map (\<lambda>x. (fst x, asdf x)) x)) =
  fst (eucl_of_list_aform x)"
  by (auto simp: eucl_of_list_aform_def o_def)

lemma
  Affine_pdevs_of_list:\<comment> \<open>TODO: move!\<close>
  "Affine (fst x, pdevs_of_list (map snd (list_of_pdevs (snd x)))) = Affine x"
  by (auto simp: Affine_def valuate_def aform_val_def
      elim: pdevs_val_of_list_of_pdevs2[where X = "snd x"]
        pdevs_val_of_list_of_pdevs[where X = "snd x"])

lemmas one_step_in_ivl = aform.one_step_in_ivl_ncc[OF ncc_precond ncc_precond]
lemmas solves_poincare_map = aform.solves_poincare_map_ncc[OF ncc_precond ncc_precond]
lemmas solves_poincare_map' = aform.solves_poincare_map'_ncc[OF ncc_precond ncc_precond]
lemmas solves_poincare_map_onto = aform.solves_poincare_map_onto_ncc[OF ncc_precond ncc_precond]

end


section \<open>Writer monad\<close>

theory Writer_Monad
imports Monad
begin

subsection \<open>Monoid class\<close>

class monoid = "domain" +
  fixes mempty :: "'a"
  fixes mappend :: "'a \<rightarrow> 'a \<rightarrow> 'a"
  assumes mempty_left: "\<And>ys. mappend\<cdot>mempty\<cdot>ys = ys"
  assumes mempty_right: "\<And>xs. mappend\<cdot>xs\<cdot>mempty = xs"
  assumes mappend_assoc:
    "\<And>xs ys zs. mappend\<cdot>(mappend\<cdot>xs\<cdot>ys)\<cdot>zs = mappend\<cdot>xs\<cdot>(mappend\<cdot>ys\<cdot>zs)"

subsection \<open>Writer monad type\<close>

text \<open>Below is the standard Haskell definition of a writer monad
type; it is an isomorphic copy of the lazy pair type \texttt{(a, w)}.
\<close>

text_raw \<open>
\begin{verbatim}
newtype Writer w a = Writer { runWriter :: (a, w) }
\end{verbatim}
\<close>

text \<open>Since HOLCF does not have a pre-defined lazy pair type, we
will base this formalization on an equivalent, more direct definition:
\<close>

text_raw \<open>
\begin{verbatim}
data Writer w a = Writer w a
\end{verbatim}
\<close>

text \<open>We can directly translate the above Haskell type definition
using \<open>tycondef\<close>. \medskip\<close>

tycondef 'a\<cdot>'w writer = Writer (lazy "'w") (lazy "'a")

lemma coerce_writer_abs [simp]: "coerce\<cdot>(writer_abs\<cdot>x) = writer_abs\<cdot>(coerce\<cdot>x)"
apply (simp add: writer_abs_def coerce_def)
apply (simp add: emb_prj_emb prj_emb_prj DEFL_eq_writer)
done

lemma coerce_Writer [simp]:
  "coerce\<cdot>(Writer\<cdot>w\<cdot>x) = Writer\<cdot>(coerce\<cdot>w)\<cdot>(coerce\<cdot>x)"
unfolding Writer_def by simp

lemma fmapU_writer_simps [simp]:
  "fmapU\<cdot>f\<cdot>(\<bottom>::udom\<cdot>'w writer) = \<bottom>"
  "fmapU\<cdot>f\<cdot>(Writer\<cdot>w\<cdot>x) = Writer\<cdot>w\<cdot>(f\<cdot>x)"
unfolding fmapU_writer_def writer_map_def fix_const
apply simp
apply (simp add: Writer_def)
done

subsection \<open>Class instance proofs\<close>

instance writer :: ("domain") "functor"
proof
  fix f g :: "udom \<rightarrow> udom" and xs :: "udom\<cdot>'a writer"
  show "fmapU\<cdot>f\<cdot>(fmapU\<cdot>g\<cdot>xs) = fmapU\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
    by (induct xs rule: writer.induct) simp_all
qed

instantiation writer :: (monoid) monad
begin

fixrec bindU_writer ::
    "udom\<cdot>'a writer \<rightarrow> (udom \<rightarrow> udom\<cdot>'a writer) \<rightarrow> udom\<cdot>'a writer"
  where "bindU_writer\<cdot>(Writer\<cdot>w\<cdot>x)\<cdot>f =
    (case f\<cdot>x of Writer\<cdot>w'\<cdot>y \<Rightarrow> Writer\<cdot>(mappend\<cdot>w\<cdot>w')\<cdot>y)"

lemma bindU_writer_strict [simp]: "bindU\<cdot>\<bottom>\<cdot>k = (\<bottom>::udom\<cdot>'a writer)"
by fixrec_simp

definition
  "returnU = Writer\<cdot>mempty"

instance proof
  fix f :: "udom \<rightarrow> udom" and m :: "udom\<cdot>'a writer"
  show "fmapU\<cdot>f\<cdot>m = bindU\<cdot>m\<cdot>(\<Lambda> x. returnU\<cdot>(f\<cdot>x))"
    by (induct m rule: writer.induct)
       (simp_all add: returnU_writer_def mempty_right)
next
  fix f :: "udom \<rightarrow> udom\<cdot>'a writer" and x :: "udom"
  show "bindU\<cdot>(returnU\<cdot>x)\<cdot>f = f\<cdot>x"
    by (cases "f\<cdot>x" rule: writer.exhaust)
       (simp_all add: returnU_writer_def mempty_left)
next
  fix m :: "udom\<cdot>'a writer" and f g :: "udom \<rightarrow> udom\<cdot>'a writer"
  show "bindU\<cdot>(bindU\<cdot>m\<cdot>f)\<cdot>g = bindU\<cdot>m\<cdot>(\<Lambda> x. bindU\<cdot>(f\<cdot>x)\<cdot>g)"
    apply (induct m rule: writer.induct, simp)
    apply (case_tac "f\<cdot>a" rule: writer.exhaust, simp)
    apply (case_tac "g\<cdot>aa" rule: writer.exhaust, simp)
    apply (simp add: mappend_assoc)
    done
qed

end

subsection \<open>Transfer properties to polymorphic versions\<close>

lemma fmap_writer_simps [simp]:
  "fmap\<cdot>f\<cdot>(\<bottom>::'a\<cdot>'w writer) = \<bottom>"
  "fmap\<cdot>f\<cdot>(Writer\<cdot>w\<cdot>x :: 'a\<cdot>'w writer) = Writer\<cdot>w\<cdot>(f\<cdot>x)"
unfolding fmap_def [where 'f="'w writer"]
by (simp_all add: coerce_simp)

lemma return_writer_def: "return = Writer\<cdot>mempty"
unfolding return_def returnU_writer_def
by (simp add: coerce_simp eta_cfun)

lemma bind_writer_simps [simp]:
  "bind\<cdot>(\<bottom> :: 'a\<cdot>'w::monoid writer)\<cdot>f = \<bottom>"
  "bind\<cdot>(Writer\<cdot>w\<cdot>x :: 'a\<cdot>'w::monoid writer)\<cdot>k =
    (case k\<cdot>x of Writer\<cdot>w'\<cdot>y \<Rightarrow> Writer\<cdot>(mappend\<cdot>w\<cdot>w')\<cdot>y)"
unfolding bind_def
apply (simp add: coerce_simp)
apply (cases "k\<cdot>x" rule: writer.exhaust)
apply (simp_all add: coerce_simp)
done

lemma join_writer_simps [simp]:
  "join\<cdot>\<bottom> = (\<bottom> :: 'a\<cdot>'w::monoid writer)"
  "join\<cdot>(Writer\<cdot>w\<cdot>(Writer\<cdot>w'\<cdot>x)) = Writer\<cdot>(mappend\<cdot>w\<cdot>w')\<cdot>x"
unfolding join_def by simp_all

subsection \<open>Extra operations\<close>

definition tell :: "'w \<rightarrow> unit\<cdot>('w::monoid writer)"
  where "tell = (\<Lambda> w. Writer\<cdot>w\<cdot>())"

end


section \<open>The Observing Quorums Model\<close>

theory Observing_Quorums
imports Same_Vote
begin

subsection \<open>Model definition\<close>
(******************************************************************************)

text \<open>The state adds one field to the Voting model state:\<close>
record obsv_state = v_state +
  obs :: "round \<Rightarrow> (process, val) map"

text \<open>For the observation mechanism to work, we need monotonicity of quorums.\<close>
context mono_quorum begin

definition obs_safe
  where
  "obs_safe r s v \<equiv> (\<forall>r' < r. \<exists>p. obs s r' p \<in> {None, Some v})"

definition obsv_round
  :: "round \<Rightarrow> process set \<Rightarrow> val \<Rightarrow> (process, val)map \<Rightarrow> process set \<Rightarrow> (obsv_state \<times> obsv_state) set"
  where
  "obsv_round r S v r_decisions Os = {(s, s').
     \<comment> \<open>guards\<close>
     r = next_round s
     \<and> (S \<noteq> {} \<longrightarrow> obs_safe r s v)
     \<and> d_guard r_decisions (const_map v S)
     \<and> (S \<in> Quorum \<longrightarrow> Os = UNIV)
     \<and> (Os \<noteq> {} \<longrightarrow> S \<noteq> {})
     \<and> \<comment> \<open>actions\<close>
     s' = s\<lparr>
       next_round := Suc r
       , votes := (votes s)(r := const_map v S)
       , decisions := decisions s ++ r_decisions
       , obs := (obs s)(r := const_map v Os)
     \<rparr>
  }"

definition obsv_trans :: "(obsv_state \<times> obsv_state) set" where
  "obsv_trans = (\<Union>r S v d_f Os. obsv_round r S v d_f Os) \<union> Id"

definition obsv_init :: "obsv_state set" where
  "obsv_init = { \<lparr> next_round = 0, votes = \<lambda>r a. None, decisions = Map.empty, obs = \<lambda>r a. None \<rparr> }"

definition obsv_TS :: "obsv_state TS" where
  "obsv_TS = \<lparr> init = obsv_init, trans = obsv_trans \<rparr>"

lemmas obsv_TS_defs = obsv_TS_def obsv_init_def obsv_trans_def

subsection \<open>Invariants\<close>
(******************************************************************************)

definition OV_inv1 where
  "OV_inv1 = {s. \<forall>r Q v. quorum_for Q v (votes s r) \<longrightarrow>
    (\<forall>Q' \<in> Quorum. quorum_for Q' v (obs s r))}"

lemmas OV_inv1I = OV_inv1_def [THEN setc_def_to_intro, rule_format]
lemmas OV_inv1E [elim] = OV_inv1_def [THEN setc_def_to_elim, rule_format]
lemmas OV_inv1D = OV_inv1_def [THEN setc_def_to_dest, rule_format]

subsubsection \<open>Proofs of invariants\<close>
(******************************************************************************)

lemma OV_inv1_obsv_round:
  "{OV_inv1} obsv_round r S v d_f Ob {> OV_inv1}"
proof(clarsimp simp add: PO_hoare_defs intro!: OV_inv1I)
  fix v' s s' Q Q' r'
  assume
    Q: "quorum_for Q v' (votes s' r')"
    and inv: "s \<in> OV_inv1"
    and step: "(s, s') \<in> obsv_round r S v d_f Ob"
    and quorum: "Q' \<in> Quorum"
  from Q inv[THEN OV_inv1D] step quorum
  show "quorum_for Q' v' (obs s' r')"
  proof(cases "r'=r")
    case True
    with step and Q have "S \<in> Quorum"
      by(fastforce simp add: obsv_round_def obs_safe_def quorum_for_def const_map_is_Some
        ball_conj_distrib subset_eq[symmetric] intro: mono_quorum[where Q'=S])
    thus ?thesis using step inv[THEN OV_inv1D] Q quorum
      by(clarsimp simp add: obsv_round_def obs_safe_def quorum_for_def const_map_is_Some
        ball_conj_distrib subset_eq[symmetric] dest!: quorum_non_empty)
  qed(clarsimp simp add: obsv_round_def obs_safe_def quorum_for_def)
qed

lemma OV_inv1_inductive:
  "init obsv_TS \<subseteq> OV_inv1"
  "{OV_inv1} trans obsv_TS {> OV_inv1}"
  apply (simp add: obsv_TS_defs OV_inv1_def)
   apply (auto simp add: obsv_TS_defs OV_inv1_obsv_round quorum_for_def dest: empty_not_quorum)
  done

lemma quorum_for_const_map:
  "(quorum_for Q w (const_map v S)) = (Q \<in> Quorum \<and> Q \<subseteq> S \<and> w = v)"
  by(auto simp add: quorum_for_def const_map_is_Some dest: quorum_non_empty)

subsection \<open>Refinement\<close>
(******************************************************************************)

definition obsv_ref_rel where
  "obsv_ref_rel \<equiv> {(sa, sc).
    sa = v_state.truncate sc
  }"

lemma obsv_round_refines:
  "{obsv_ref_rel \<inter> UNIV \<times> OV_inv1} sv_round r S v dec_f, obsv_round r S v dec_f Ob {> obsv_ref_rel}"
  apply(clarsimp simp add: PO_rhoare_defs sv_round_def obsv_round_def safe_def obsv_ref_rel_def
    v_state.truncate_def obs_safe_def quorum_for_def OV_inv1_def)
  by (metis UNIV_I UNIV_quorum  option.distinct(1) option.inject)

lemma Observable_Refines:
  "PO_refines (obsv_ref_rel \<inter> UNIV \<times> OV_inv1) sv_TS obsv_TS"
proof(rule refine_using_invariants)
  show "init obsv_TS \<subseteq> obsv_ref_rel `` init sv_TS"
  by(auto simp add: PO_refines_def sv_TS_defs  obsv_TS_defs  obsv_ref_rel_def
    v_state.truncate_def)
next
  show "{obsv_ref_rel \<inter> UNIV \<times> OV_inv1} trans sv_TS, trans obsv_TS {> obsv_ref_rel}"
    by(auto simp add: PO_refines_def sv_TS_defs  obsv_TS_defs intro!:
      obsv_round_refines relhoare_refl)
qed(auto intro: OV_inv1_inductive del: subsetI)

subsection \<open>Additional invariants\<close>
(******************************************************************************)

definition OV_inv2 where
  "OV_inv2 = {s. \<forall>r \<ge> next_round s. obs s r = Map.empty }"

lemmas OV_inv2I = OV_inv2_def [THEN setc_def_to_intro, rule_format]
lemmas OV_inv2E [elim] = OV_inv2_def [THEN setc_def_to_elim, rule_format]
lemmas OV_inv2D = OV_inv2_def [THEN setc_def_to_dest, rule_format]

definition OV_inv3 where
  "OV_inv3 = {s. \<forall>r p v. obs s r p = Some v \<longrightarrow>
    obs_safe r s v}"

lemmas OV_inv3I = OV_inv3_def [THEN setc_def_to_intro, rule_format]
lemmas OV_inv3E [elim] = OV_inv3_def [THEN setc_def_to_elim, rule_format]
lemmas OV_inv3D = OV_inv3_def [THEN setc_def_to_dest, rule_format]

definition OV_inv4 where
  "OV_inv4 = {s. \<forall>r p q v w. obs s r p = Some v \<and> obs s r q = Some w \<longrightarrow>
    w = v}"

lemmas OV_inv4I = OV_inv4_def [THEN setc_def_to_intro, rule_format]
lemmas OV_inv4E [elim] = OV_inv4_def [THEN setc_def_to_elim, rule_format]
lemmas OV_inv4D = OV_inv4_def [THEN setc_def_to_dest, rule_format]

subsubsection \<open>Proofs of additional invariants\<close>
(******************************************************************************)

lemma OV_inv2_inductive:
  "init obsv_TS \<subseteq> OV_inv2"
  "{OV_inv2} trans obsv_TS {> OV_inv2}"
  by(auto simp add: PO_hoare_defs OV_inv2_def obsv_TS_defs obsv_round_def const_map_is_Some)

lemma SVinv3_inductive:
  "init obsv_TS \<subseteq> SV_inv3"
  "{SV_inv3} trans obsv_TS {> SV_inv3}"
  by(auto simp add: PO_hoare_defs SV_inv3_def obsv_TS_defs obsv_round_def const_map_is_Some)

lemma OV_inv3_obsv_round:
  "{OV_inv3 \<inter> OV_inv2} obsv_round r S v D Ob {> OV_inv3}"
proof(clarsimp simp add: PO_hoare_defs intro!: OV_inv3I)
  fix s s' r_w p w
  assume Assms:
    "obs s' r_w p = Some w"
    "s \<in> OV_inv3"
    "(s, s') \<in> obsv_round r S v D Ob"
    "s \<in> OV_inv2"
  hence "s' \<in> OV_inv2"
    by(force simp add: obsv_TS_defs intro: OV_inv2_inductive(2)[THEN hoareD, OF \<open>s \<in> OV_inv2\<close>])
  hence "r_w \<le> next_round s'" using Assms
    by(auto simp add: OV_inv2_def intro!: leI)
  hence r_w_le: "r_w \<le> next_round s" using Assms
    by(auto simp add: obsv_round_def le_Suc_eq)
  show "obs_safe r_w s' w"
  proof(cases "r_w = next_round s")
    case True
    thus ?thesis using Assms
      by(auto simp add: obsv_round_def const_map_is_Some obs_safe_def)
  next
    case False
    hence "r_w < next_round s" using r_w_le
      by(metis less_le)
    moreover have "\<forall>r'. r' \<noteq> next_round s \<longrightarrow> obs s' r' = obs s r'" using Assms(3)
      by(auto simp add: obsv_round_def)
    ultimately have
      "\<forall>r' \<le> r_w. obs s' r' = obs s r'"
      by(auto)
    thus ?thesis using Assms
      by(auto simp add: OV_inv3_def obs_safe_def)
  qed
qed

lemma OV_inv3_inductive:
  "init obsv_TS \<subseteq> OV_inv3"
  "{OV_inv3 \<inter> OV_inv2} trans obsv_TS {> OV_inv3}"
  apply(auto simp add: obsv_TS_def obsv_trans_def intro: OV_inv3_obsv_round)
  apply(auto simp add: obsv_init_def OV_inv3_def)
  done

lemma OV_inv4_inductive:
  "init obsv_TS \<subseteq> OV_inv4"
  "{OV_inv4} trans obsv_TS {> OV_inv4}"
  by(auto simp add: PO_hoare_defs OV_inv4_def obsv_TS_defs obsv_round_def const_map_is_Some)

end

end


(*  Title:      HOL/Nitpick_Examples/Pattern_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick's "destroy_constrs" optimization.
*)

section {* Examples Featuring Nitpick's \textit{destroy\_constrs} Optimization *}

theory Pattern_Nits
imports Main
begin

nitpick_params [verbose, card = 8, max_potential = 0, sat_solver = MiniSat_JNI,
                max_threads = 1, timeout = 240]

lemma "x = (case u of () \<Rightarrow> y)"
nitpick [expect = genuine]
oops

lemma "x = (case b of True \<Rightarrow> x | False \<Rightarrow> y)"
nitpick [expect = genuine]
oops

lemma "x = (case p of (x, y) \<Rightarrow> y)"
nitpick [expect = genuine]
oops

lemma "x = (case n of 0 \<Rightarrow> x | Suc n \<Rightarrow> n)"
nitpick [expect = genuine]
oops

lemma "x = (case opt of None \<Rightarrow> x | Some y \<Rightarrow> y)"
nitpick [expect = genuine]
oops

lemma "x = (case xs of [] \<Rightarrow> x | y # ys \<Rightarrow> y)"
nitpick [expect = genuine]
oops

lemma "x = (case xs of
              [] \<Rightarrow> x
            | y # ys \<Rightarrow>
              (case ys of
                 [] \<Rightarrow> x
               | z # zs \<Rightarrow>
                 (case z of
                    None \<Rightarrow> x
                  | Some p \<Rightarrow>
                    (case p of
                       (a, b) \<Rightarrow> b))))"
nitpick [expect = genuine]
oops

fun f1 where
"f1 x () = x"

lemma "x = f1 y u"
nitpick [expect = genuine]
oops

fun f2 where
"f2 x _ True = x" |
"f2 _ y False = y"

lemma "x = f2 x y b"
nitpick [expect = genuine]
oops

fun f3 where
"f3 (_, y) = y"

lemma "x = f3 p"
nitpick [expect = genuine]
oops

fun f4 where
"f4 x 0 = x" |
"f4 _ (Suc n) = n"

lemma "x = f4 x n"
nitpick [expect = genuine]
oops

fun f5 where
"f5 x None = x" |
"f5 _ (Some y) = y"

lemma "x = f5 x opt"
nitpick [expect = genuine]
oops

fun f6 where
"f6 x [] = x" |
"f6 _ (y # ys) = y"

lemma "x = f6 x xs"
nitpick [expect = genuine]
oops

fun f7 where
"f7 _ (y # Some (a, b) # zs) = b" |
"f7 x (y # None # zs) = x" |
"f7 x [y] = x" |
"f7 x [] = x"

lemma "x = f7 x xs"
nitpick [expect = genuine]
oops

lemma "u = ()"
nitpick [expect = none]
sorry

lemma "\<exists>y. (b::bool) = y"
nitpick [expect = none]
sorry

lemma "\<exists>x y. p = (x, y)"
nitpick [expect = none]
sorry

lemma "\<exists>x. n = Suc x"
nitpick [expect = genuine]
oops

lemma "\<exists>y. x = Some y"
nitpick [expect = genuine]
oops

lemma "\<exists>y ys. xs = y # ys"
nitpick [expect = genuine]
oops

lemma "\<exists>y a b zs. x = y # Some (a, b) # zs"
nitpick [expect = genuine]
oops

end


theory v3_isar
  imports Main "../QML_S5"
begin

text \<open>
@{text "Compossibility\<^sub>3'"}: If a table @{term x} is originally made from matter @{term y} and it
is possible for a table to be the only table  originally made from matter @{term z} according to plan @{term p},
then it is also possible for table @{term x} to be originally made from matter @{term y} and in
addition some table or other @{term x'} to be the only table  originally made from matter @{term z}
according to plan @{term p}.

@{text "Origin Uniqueness\<^sub>1'"}: It is impossible that a single table @{term x} is originally made from
matter @{term y} and in addition is originally made from matter @{term z}.

@{text "Sufficiency\<^sub>3'"}: If it is possible that a table @{term x'} is the only table originally made from matter @{term z}
according to plan @{term p}, then necessarily any table that is the only table originally made from matter @{term z}
according to plan @{term p} is the very table @{term x'} and no other.
\<close>

text \<open>
@{text "Origin Essentialism\<^sub>3'"}: If a given table is originally made from certain matter, then it is necessary
that the given table is not the only table  originally made from any non-overlapping matter according to any plan.
\<close>

consts planTable :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>" ("P")

(* (P x y p) \<equiv> x made from y according to p *)
lemma
assumes compossibilty3: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p))))))\<rfloor>"
assumes sufficiency3: "\<lfloor>(\<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>p. \<^bold>\<diamond>(P x' y p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t y p)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. (P x y p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t y p)))) \<^bold>\<rightarrow> (x\<^bold>=\<^sup>Lx')))\<rfloor>"
assumes origin_uniqueness3: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y\<^bold>=\<^sup>L z)))\<rfloor>"
shows origin_essentialism3: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p'))))))\<rfloor>"

proof (rule allI)
  fix w
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
  proof (rule allI)
    fix x
    show "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
    proof (rule allI)
      fix y
      show "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
      proof  (rule allI)
        fix z
        show "(\<^bold>\<forall>p. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
        proof (rule allI)
          fix p
          show "(\<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
          proof  (rule impI)
            assume antecedent: "(\<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p))) w"
            show  "(\<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
            proof  (rule notI)
              assume n_consequent: "(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p'))))) w"

              from antecedent obtain w where w:  "((\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p))) w" by (rule exE)
              then have non_overlapping: "(\<^bold>\<not>(y \<^bold>=\<^sup>L z)) w" by simp
              have table_x_from_y: "(P x y p) w" using `((\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p))) w` by simp

              from n_consequent have "(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p'))))) w" by simp
              then obtain v where v: "((\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p'))))) v" by (rule exE)
              then have "((P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p))))) v" by (rule allE)
              then have possibility: "(\<^bold>\<diamond>(P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p))))) w" by (rule exI)

              have compossibilty3_ante: "((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) w"
                using non_overlapping and table_x_from_y and possibility by auto

              from compossibilty3 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w"..
              then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w" by (rule allE)
              then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w" by (rule allE)
              then have "(\<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w" by (rule allE)
              then have "(((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w" by (rule allE)

              then have "(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w"
                using compossibilty3_ante by (rule mp)
              then obtain u where u: "(((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) u" by (rule exE)
              then have "(\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))) u" by (rule conjE)
              then obtain x' where x': "((P x' z p) \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))) u" by (rule exE)
              then have sufficiency3_cons_ante: "((P x' z p) \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))) u" by simp

              from sufficiency3 have "(\<^bold>\<forall>z. \<^bold>\<forall>x. \<^bold>\<forall>p. \<^bold>\<diamond>(P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w"..
              then have "(\<^bold>\<forall>x. \<^bold>\<forall>p. \<^bold>\<diamond>(P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
              then have "(\<^bold>\<forall>p. \<^bold>\<diamond>(P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
              then have "(\<^bold>\<diamond>(P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
              then have "(\<^bold>\<box>(\<^bold>\<forall>x'. (P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w"
                using possibility by auto
              then have "(\<^bold>\<forall>x'. ((P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) u" by (rule allE)
              then have "((P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx)) u" by (rule allE)
              then have identity: "(x'\<^bold>=\<^sup>Lx) u" using sufficiency3_cons_ante by (rule mp)

              from sufficiency3_cons_ante have "(P x' z p) u" by auto
              then have "(P x z p) u" using identity by auto
              moreover from u have "(P x y p) u" by auto
              then have conj_existence: "(P x y p \<^bold>\<and> P x z p) u" using `(P x z p) u` by simp
              then have impossible_arg: "(P x y p u) \<and> (P x z p u) \<and> \<not>((y \<^bold>=\<^sup>L z) u)"
                using non_overlapping by auto

              from origin_uniqueness3 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"
                 by simp
               then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p.\<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by (rule allE)
               then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by (rule allE)
               then have "(\<^bold>\<forall>p. \<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by (rule allE)
               then have "(\<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by (rule allE)
               then have "(\<^bold>\<box>(\<^bold>\<not>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by auto
               then have "(\<^bold>\<not>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by (rule allE)
               then have "\<not>((P x y p u) \<and> (P x z p u) \<and> \<not>((y \<^bold>=\<^sup>L z) u))" by simp
               then show "False" using impossible_arg by (rule notE)

             qed
           qed
         qed
       qed
     qed
   qed
 qed

end


theory MVector
  imports IO
begin

datatype 'a mvector = MVector addr nat

primrec addr_of_mvector where
  "addr_of_mvector (MVector a _) = a"

primrec size_of_mvector where
  "size_of_mvector (MVector _ s) = s"

definition alloc :: "nat \<Rightarrow> heap \<Rightarrow> 'a::heap mvector \<times> heap" where
  "alloc n h = (let l = lim h; r = MVector l n in (r, h \<lparr> lim := lim h + n \<rparr>))"

definition get_at :: "heap \<Rightarrow> 'a::heap mvector \<Rightarrow> nat \<Rightarrow> 'a" where
  "get_at h v i = from_nat (memory h (addr_of_mvector v + i))"

definition set_at :: "'a::heap mvector \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> heap \<Rightarrow> heap" where
  "set_at r j v h = h \<lparr> memory := (\<lambda>i. if i = addr_of_mvector r + j then to_nat v else memory h i) \<rparr>"

definition new :: "nat \<Rightarrow> 'a::heap mvector io" where
  "new n = IO (alloc n)"

definition read :: "'a::heap mvector \<Rightarrow> nat \<Rightarrow> 'a io" where
  "read vec i = tap (\<lambda>h. get_at h vec i)"

definition writ :: "'a::heap mvector \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> unit io" where
  "writ vec i v = IO (\<lambda>h. ((), set_at vec i v h))"

definition modify :: "'a::heap mvector \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> unit io" where
  "modify vec f i = read vec i \<bind> (\<lambda>x. writ vec i (f x))"

definition swap :: "'a::heap mvector \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit io" where
  "swap arr i j = do {
    valI \<leftarrow> read arr i;
    valJ \<leftarrow> read arr j;
    writ arr j valI;
    writ arr i valJ;
    return ()
  }"

lemma get_set_eq [simp]: "get_at (set_at r i x h) r i = x"
  by (simp add: get_at_def set_at_def)

lemma set_get_get_same [simp]:
  fixes arr :: "nat mvector" and j :: "'a::heap"
  assumes "memory h (addr_of_mvector arr + i) = to_nat j"
  shows "set_at arr i (get_at h arr i) h = h"
  using assms
  apply (simp add: set_at_def get_at_def IO.get_def)
  apply (induct h, auto)
  apply (rule, auto)
proof-
  fix memory
  have "from_nat (to_nat j) = j"
    by simp
  hence p: "\<And>P. P (from_nat (to_nat j)) = P j"
    by simp
  show "to_nat (from_nat (to_nat j)) = to_nat j"
    using p [of "to_nat"]
    sorry
qed

lemma get_set_neq: "i \<noteq> j \<Longrightarrow> get_at (set_at r i x h) r j = get_at h r j"
  apply (auto simp add: get_at_def set_at_def)
  done

lemma set_same [simp]: "set_at r j x (set_at r j y h) = set_at r j x h"
  apply (simp add: set_at_def)
proof-
  have "\<And>P x y. P x \<Longrightarrow> (\<And>y. x \<noteq> y \<Longrightarrow> P y) \<Longrightarrow> (\<And>z. P z)"
    by metis
  hence "\<And>f g. f (addr_of_mvector r + j) = g (addr_of_mvector r + j)
    \<Longrightarrow> (\<And>x. x \<noteq> addr_of_mvector r + j \<Longrightarrow> f x = g x) \<Longrightarrow> (\<And>z. f z = g z)"
    by smt
  hence "\<And>z. (\<lambda>i. if i = addr_of_mvector r + j then to_nat x else memory (h\<lparr>memory := \<lambda>i. if i = addr_of_mvector r + j then to_nat y else memory h i\<rparr>) i) z
    = (\<lambda>i. if i = addr_of_mvector r + j then to_nat x else memory h i) z"
    by auto
  thus "h\<lparr>memory := \<lambda>i. if i = addr_of_mvector r + j then to_nat x else memory (h\<lparr>memory := \<lambda>i. if i = addr_of_mvector r + j then to_nat y else memory h i\<rparr>) i\<rparr>
    = h\<lparr>memory := \<lambda>i. if i = addr_of_mvector r + j then to_nat x else memory h i\<rparr>"
    by simp
qed

lemma execute_new: "execute (new n) h = alloc n h"
  by (simp add: new_def)

lemma execute_read: "execute (read v i) h = (get_at h v i, h)"
  by (simp add: read_def execute_def get_at_def tap_def)

lemma execute_writ: "execute (writ r i v) h = ((), set_at r i v h)"
  by (simp add: writ_def)

lemma effect_read:
  assumes "effect (read arr i) h h' r"
  shows "r = get_at h arr i" "h = h'"
  apply (metis assms effectE execute_read prod.sel(1))
  apply (metis assms effectE execute_tap read_def snd_conv)
  done

lemma effect_writ:
  assumes "effect (writ arr i v) h h' ()"
  shows "h' = set_at arr i v h"
  by (metis (full_types) assms effectE execute_writ snd_conv)

lemma effect_swap_same:
  assumes "effect (swap arr i i) h h' ()"
  shows "h = h'"
  using assms
  apply (simp add: effect_def swap_def)
  apply (simp add: execute_bind execute_read execute_writ)

lemma effect_swap:
  assumes "effect (swap arr i j) h h' ()"
  and "i \<noteq> j"
  shows "get_at h' arr i = get_at h arr j" and "get_at h' arr j = get_at h arr i"
proof-
  obtain h1 ri rj where
    "effect (read arr i) h h ri"
    "effect (read arr j) h h rj"
    "effect (writ arr j ri) h h1 ()"
    "effect (writ arr i rj) h1 h' ()"
  proof-
    have "effect (do {
      ri \<leftarrow> read arr i;
      rj \<leftarrow> read arr j;
      writ arr j ri;
      writ arr i rj;
      return ()
    }) h h' ()"
      using assms
      by (simp add: swap_def)
    then obtain ri where
      e1: "effect (read arr i) h h ri"
      "effect (do {
        rj \<leftarrow> read arr j;
        writ arr j ri;
        writ arr i rj;
        return ()
      }) h h' ()"
      by (metis (no_types, lifting) effect_bind effect_read(2))
    then obtain rj where
      e2: "effect (read arr j) h h rj"
      "effect (do {
        writ arr j ri;
        writ arr i rj;
        return ()
      }) h h' ()"
      by (metis (no_types, lifting) effect_bind effect_read(2))
    then obtain h1 where
      e3: "effect (writ arr j ri) h h1 ()"
      "effect (do { writ arr i rj; return () }) h1 h' ()"
      using effect_bind by force
    hence e4: "effect (writ arr i rj) h1 h' ()"
      by simp

    assume H: "(\<And>ri rj h1. effect (read arr i) h h ri \<Longrightarrow> effect (read arr j) h h rj \<Longrightarrow> effect (writ arr j ri) h h1 () \<Longrightarrow> effect (writ arr i rj) h1 h' () \<Longrightarrow> thesis)"
    show ?thesis
      apply (rule H)
      apply (rule e1)
      apply (rule e2)
      apply (rule e3)
      apply (rule e4)
      done
  qed

  have "ri = get_at h arr i"
    using \<open>effect (read arr i) h h ri\<close> effect_read(1) by blast
  have "rj = get_at h arr j"
    using \<open>effect (read arr j) h h rj\<close> effect_read(1) by blast
  have h': "h' = set_at arr i rj (set_at arr j ri h)"
    using \<open>effect (writ arr i rj) h1 h' ()\<close> \<open>effect (writ arr j ri) h h1 ()\<close> effect_writ by blast

  show "get_at h' arr i = get_at h arr j"
    apply (simp add: h')
    by (simp add: \<open>rj = get_at h arr j\<close>)
  show "get_at h' arr j = get_at h arr i"
    apply (simp add: h')
    by (simp add: \<open>ri = get_at h arr i\<close> assms(2) get_set_neq)
qed

(*
fast implementation

definition from_list :: "'a::heap list \<Rightarrow> 'a mvector io" where
  "from_list xs = fold (\<lambda>(i,x) m. m \<bind> (\<lambda>vec. writ vec i x \<bind> (\<lambda>_. return vec))) (enumerate 0 xs) (new (size xs))"
*)

primrec from_list_pr :: "'a::heap mvector \<Rightarrow> 'a::heap list \<Rightarrow> nat \<Rightarrow> 'a mvector io" where
  "from_list_pr mvec [] n = return mvec"
| "from_list_pr mvec (x#xs) n = writ mvec n x \<bind> (\<lambda>_. from_list_pr mvec xs (Suc n))"

definition from_list :: "'a::heap list \<Rightarrow> 'a mvector io" where
  "from_list xs = new (size xs) \<bind> (\<lambda>mvec. from_list_pr mvec xs 0)"

definition to_list :: "'a::heap mvector \<Rightarrow> 'a list io" where
  "to_list vec = (let s = size_of_mvector vec in mapM (read vec) [0..<s])"

definition set_over :: "'a::heap mvector \<Rightarrow> 'a::heap list \<Rightarrow> heap \<Rightarrow> heap" where
  "set_over r xs h = h \<lparr> memory := (\<lambda>i. if lim h < i \<and> i < lim h + size xs then to_nat (get_at h r (i - lim h)) else memory h i) \<rparr>"

lemma execute_from_list: "execute (from_list xs) h = (case alloc (size xs) h of (mvec,h0) \<Rightarrow> (mvec, fold (\<lambda>(i,x) h. set_at mvec i x h) (enumerate 0 xs) h0))"
proof-
  have "\<And>mvec h' i. execute (from_list_pr mvec xs i) h' = (mvec, fold (\<lambda>(i, x). set_at mvec i x) (enumerate i xs) h')"
    apply (induct xs, simp add: return_def)
    apply (simp add: execute_writ execute_bind)
    done
  thus "execute (from_list xs) h = (case alloc (size xs) h of (mvec,h0) \<Rightarrow> (mvec, fold (\<lambda>(i,x) h. set_at mvec i x h) (enumerate 0 xs) h0))"
    apply (simp add: from_list_def execute_new execute_bind)
    done
qed

definition get_over_internal where
  "get_over_internal mvec h n = map (get_at h mvec) [0..<n]"

definition get_over :: "'a::heap mvector \<Rightarrow> heap \<Rightarrow> 'a list" where
  "get_over mvec h = get_over_internal mvec h (size_of_mvector mvec)"

lemma mapM_append: "execute (mapM f (xs @ ys)) h = execute (do {
  rx \<leftarrow> mapM f xs;
  ry \<leftarrow> mapM f ys;
  return (rx @ ry)
}) h"
  apply (induct xs arbitrary: ys h, simp)
proof-
  have f: "\<And>x y z h. execute (x \<bind> (\<lambda>b. (y \<bind> (\<lambda>rx. z \<bind> (\<lambda>ry. return (rx @ ry)))) \<bind> (\<lambda>c. return (b # c)))) h =
                     execute (x \<bind> (\<lambda>b. y \<bind> (\<lambda>rx. z \<bind> (\<lambda>ry. return (rx @ ry) \<bind> (\<lambda>c. return (b # c)))))) h"
    by (smt execute_bind split_def)

  fix a xs ys h
  assume p: "\<And>ys h. execute (mapM f (xs @ ys)) h = execute (do {
    rx \<leftarrow> mapM f xs;
    ry \<leftarrow> mapM f ys;
    return (rx @ ry)
  }) h"
  have "execute (mapM f ((a # xs) @ ys)) h = execute (do {
    b \<leftarrow> f a;
    c \<leftarrow> mapM f (xs @ ys);
    return (b#c)
  }) h"
    by (simp)
  also have "\<dots> = execute (do {
    b \<leftarrow> f a;
    c \<leftarrow> do {
      rx \<leftarrow> mapM f xs;
      ry \<leftarrow> mapM f ys;
      return (rx @ ry)
    };
    return (b#c)
  }) h"
    by (simp add: p return_def execute_bind)
  also have "\<dots> = execute (do {
    b \<leftarrow> f a;
    rx \<leftarrow> mapM f xs;
    ry \<leftarrow> mapM f ys;
    c \<leftarrow> return (rx @ ry);
    return (b#c)
  }) h"
    using f [of "f a" "mapM f xs" "mapM f ys" h] by simp
  also have "\<dots> = execute (do {
    b \<leftarrow> f a;
    rx \<leftarrow> mapM f xs;
    ry \<leftarrow> mapM f ys;
    return ((b # rx) @ ry)
  }) h"
  proof-
    have "\<And>rx ry b h. execute (do { c \<leftarrow> return (rx @ ry); return (b#c) }) h = execute (do { return (b # rx @ ry) }) h"
      by (simp add: return_def execute_bind)
    hence "\<And>x p q h. execute (do { b \<leftarrow> x; rx \<leftarrow> p; ry \<leftarrow> q; c \<leftarrow> return (rx @ ry); return (b#c) }) h
                   = execute (do { b \<leftarrow> x; rx \<leftarrow> p; ry \<leftarrow> q; return (b # (rx @ ry)) }) h"
      by (simp add: return_def execute_bind)
    thus ?thesis
      by (simp add: return_def)
  qed
  also have "\<dots> = execute (do {
    b \<leftarrow> f a;
    rx \<leftarrow> mapM f xs;
    brx \<leftarrow> return (b # rx);
    ry \<leftarrow> mapM f ys;
    return (brx @ ry)
  }) h"
  proof-
    have "\<And>b rx. do { ry \<leftarrow> mapM f ys; return (b # rx @ ry) } = do { brx \<leftarrow> return (b # rx); ry \<leftarrow> mapM f ys; return (brx @ ry) }"
      by (simp)
    thus ?thesis
      by simp
  qed
  also have "\<dots> = execute (do {
    brx \<leftarrow> mapM f (a # xs);
    ry \<leftarrow> mapM f ys;
    return (brx @ ry)
  }) h"
  proof-
    have hyp: "do { b \<leftarrow> f a; rx \<leftarrow> mapM f xs; return (b # rx) } = do { mapM f (a # xs) }"
      by simp
    show ?thesis
      apply (subst hyp [symmetric])
      by (smt execute_bind split_def)
  qed
  finally show "execute (mapM f ((a # xs) @ ys)) h = execute (mapM f (a # xs) \<bind> (\<lambda>rx. mapM f ys \<bind> (\<lambda>ry. return (rx @ ry)))) h"
    by simp
qed

lemma execute_to_list: "execute (to_list mvec) h = (get_over mvec h, h)"
  apply (simp add: to_list_def get_over_def)
proof-
  have "\<And>n. execute (mapM (read mvec) [0..<n]) h = (get_over_internal mvec h n, h)"
  proof-
    fix n
    show "execute (mapM (read mvec) [0..<n]) h = (get_over_internal mvec h n, h)"
      apply (induct n arbitrary: h)
      apply (simp add: get_over_internal_def return_def)
      apply (simp add: get_over_internal_def mapM_append)
    proof-
      fix n h
      assume "\<And>h. execute (mapM (read mvec) [0..<n]) h = (map (get_at h mvec) [0..<n], h)"
      hence "execute (mapM (read mvec) [0..<n] \<bind> (\<lambda>rx. read mvec n \<bind> (\<lambda>x. return (rx @ [x])))) h = (let rx = map (get_at h mvec) [0..<n] in execute (read mvec n \<bind> (\<lambda>x. return (rx @ [x]))) h)"
        by (simp add: execute_bind)
      also have "\<dots> = (map (get_at h mvec) [0..<n] @ [get_at h mvec n], h)"
        by (simp add: execute_bind execute_read return_def)
      finally show "execute (mapM (read mvec) [0..<n] \<bind> (\<lambda>rx. read mvec n \<bind> (\<lambda>x. return (rx @ [x])))) h = (map (get_at h mvec) [0..<n] @ [get_at h mvec n], h)"
        by simp
    qed
  qed

  thus "execute (mapM (read mvec) [0..<size_of_mvector mvec]) h = (get_over_internal mvec h (size_of_mvector mvec), h)"
    by simp
qed

definition ref_not_in :: "'a::heap ref \<Rightarrow> 'b::heap mvector \<Rightarrow> bool" where
  "ref_not_in r arr = (\<forall>i\<in>set [0..<size_of_mvector arr]. r =!= (Ref (addr_of_mvector arr + i) :: 'b::heap ref))"

lemma get_at_as_ref:
  "get_at h arr i = IO.get h (Ref (addr_of_mvector arr + i))"
  apply (simp add: get_at_def IO.get_def)
  done

lemma set_at_as_ref:
  "set_at arr i val h = IO.set (Ref (addr_of_mvector arr + i)) val h"
  apply (simp add: set_at_def IO.set_def)
  done

definition present_in where
  "present_in arr n = (n \<in> set [0..<size_of_mvector arr])"

lemma ref_not_in_irrelative:
  assumes "ref_not_in r arr"
  and "present_in arr i"
  shows "get_at (IO.set r val h) arr i = get_at h arr i"
  and "IO.get (set_at arr i val h) r = IO.get h r"
proof-
  have "r =!= Ref (addr_of_mvector arr + i)"
    by (metis addr_of_ref.simps assms(1) assms(2) noteq_def ref_not_in_def present_in_def)
  show "get_at (IO.set r val h) arr i = get_at h arr i"
    apply (simp add: get_at_as_ref)
    apply (simp add: \<open>r =!= Ref (addr_of_mvector arr + i)\<close> noteq_set_get)
    done
next
  have "r =!= Ref (addr_of_mvector arr + i)"
    by (metis addr_of_ref.simps assms(1) assms(2) noteq_def ref_not_in_def present_in_def)
  show "IO.get (set_at arr i val h) r = IO.get h r"
    apply (simp add: set_at_as_ref)
    apply (simp add: \<open>r =!= Ref (addr_of_mvector arr + i)\<close> noteq_set_get noteq_sym)
    done
qed

lemma alloc_ref_not_in:
  assumes "IO.alloc v h = (r,h')"
  and "\<And>i. i < size_of_mvector arr \<Longrightarrow> IO.present h (Ref (addr_of_mvector arr + i))"
  shows "ref_not_in r arr"
  using assms
  apply (simp add: IO.alloc_def IO.present_def ref_not_in_def)
  apply (metis Pair_inject addr_of_ref.simps atLeast0LessThan lessThan_iff less_irrefl_nat noteq_def)
  done

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)
 *)

(*
   Miscellaneous library definitions and lemmas.
*)

header "Library"

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

lemma hd_map_simp:
  "b \<noteq> [] \<Longrightarrow> hd (map a b) = a (hd b)"
  by (induct b,auto)

(* FIXME: could be added to Set.thy *)
lemma Collect_eq:
  "{x. P x} = {x. Q x} \<longleftrightarrow> (\<forall>x. P x = Q x)"
  by (rule iffI) auto

(* FIXME: move next to HOL.iff_allI *)
lemma iff_impI: "\<lbrakk>P \<Longrightarrow> Q = R\<rbrakk> \<Longrightarrow> (P \<longrightarrow> Q) = (P \<longrightarrow> R)" by blast

definition
  fun_app :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "$" 10) where
  "f $ x \<equiv> f x"

declare fun_app_def [iff]

lemma fun_app_cong[fundef_cong]:
  "\<lbrakk> f x = f' x' \<rbrakk> \<Longrightarrow> (f $ x) = (f' $ x')"
  by simp

lemma fun_app_apply_cong[fundef_cong]:
  "f x y = f' x' y' \<Longrightarrow> (f $ x) y = (f' $ x') y'"
  by simp

lemma if_apply_cong[fundef_cong]:
  "\<lbrakk> P = P'; x = x'; P' \<Longrightarrow> f x' = f' x'; \<not> P' \<Longrightarrow> g x' = g' x' \<rbrakk>
     \<Longrightarrow> (if P then f else g) x = (if P' then f' else g') x'"
  by simp

lemma split_apply_cong[fundef_cong]:
  "\<lbrakk> f (fst p) (snd p) s = f' (fst p') (snd p') s' \<rbrakk> \<Longrightarrow> split f p s = split f' p' s'"
  by (simp add: split_def)

definition
  pred_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "and" 35)
where
  "pred_conj P Q \<equiv> \<lambda>x. P x \<and> Q x"

definition
  pred_disj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "or" 30)
where
  "pred_disj P Q \<equiv> \<lambda>x. P x \<or> Q x"

definition
  pred_neg :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" ("not _" [40] 40)
where
  "pred_neg P \<equiv> \<lambda>x. \<not> P x"

definition "K \<equiv> \<lambda>x y. x"

definition
  zipWith :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
  "zipWith f xs ys \<equiv> map (split f) (zip xs ys)"

primrec
  delete :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "delete y [] = []"
| "delete y (x#xs) = (if y=x then xs else x # delete y xs)"

primrec
  find :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option"
where
  "find f [] = None"
| "find f (x # xs) = (if f x then Some x else find f xs)"

definition
 "swp f \<equiv> \<lambda>x y. f y x"

primrec
  theRight :: "'a + 'b \<Rightarrow> 'b" where
  "theRight (Inr x) = x"

primrec
  theLeft :: "'a + 'b \<Rightarrow> 'a" where
  "theLeft (Inl x) = x"

definition
 "isLeft x \<equiv> (\<exists>y. x = Inl y)"

definition
 "isRight x \<equiv> (\<exists>y. x = Inr y)"

definition
 "const x \<equiv> \<lambda>y. x"

lemma tranclD2:
  "(x, y) \<in> R\<^sup>+ \<Longrightarrow> \<exists>z. (x, z) \<in> R\<^sup>* \<and> (z, y) \<in> R"
  by (erule tranclE) auto

lemma linorder_min_same1 [simp]:
  "(min y x = y) = (y \<le> (x::'a::linorder))"
  by (auto simp: min_def linorder_not_less)

lemma linorder_min_same2 [simp]:
  "(min x y = y) = (y \<le> (x::'a::linorder))"
  by (auto simp: min_def linorder_not_le)

text {* A combinator for pairing up well-formed relations.
        The divisor function splits the population in halves,
        with the True half greater than the False half, and
        the supplied relations control the order within the halves. *}

definition
  wf_sum :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
where
  "wf_sum divisor r r' \<equiv>
     ({(x, y). \<not> divisor x \<and> \<not> divisor y} \<inter> r')
   \<union>  {(x, y). \<not> divisor x \<and> divisor y}
   \<union> ({(x, y). divisor x \<and> divisor y} \<inter> r)"

lemma wf_sum_wf:
  "\<lbrakk> wf r; wf r' \<rbrakk> \<Longrightarrow> wf (wf_sum divisor r r')"
  apply (simp add: wf_sum_def)
  apply (rule wf_Un)+
      apply (erule wf_Int2)
     apply (rule wf_subset
             [where r="measure (\<lambda>x. If (divisor x) 1 0)"])
      apply simp
     apply clarsimp
    apply blast
   apply (erule wf_Int2)
  apply blast
  done

abbreviation(input)
 "option_map == map_option"

lemmas option_map_def = map_option_case

lemma False_implies_equals [simp]:
  "((False \<Longrightarrow> P) \<Longrightarrow> PROP Q) \<equiv> PROP Q"
  apply (rule equal_intr_rule)
   apply (erule meta_mp)
   apply simp
  apply simp
  done

lemma split_paired_Ball:
  "(\<forall>x \<in> A. P x) = (\<forall>x y. (x,y) \<in> A \<longrightarrow> P (x,y))"
  by auto

lemma split_paired_Bex:
  "(\<exists>x \<in> A. P x) = (\<exists>x y. (x,y) \<in> A \<and> P (x,y))"
  by auto

end