section{*\label{sec_Refinement}Refinement Calculus and Monotonic Predicate Transformers*}

theory Refinement imports Main
begin
text{*
  In this section we introduce the basics of refinement calculus \cite{back-wright-98}.
  Part of this theory is a reformulation of some definitions from \cite{preoteasa:back:2010a},
  but here they are given for predicates, while \cite{preoteasa:back:2010a} uses
  sets.
*}

notation
    bot ("\<bottom>") and
    top ("\<top>") and
    inf (infixl "\<sqinter>" 70)
    and sup (infixl "\<squnion>" 65)

subsection{*Basic predicate transformers*}

definition
    demonic :: "('a => 'b::lattice) => 'b => 'a \<Rightarrow> bool" ("[: _ :]" [0] 1000) where
    "[:Q:] p s = (Q s \<le> p)"

definition
    assert::"'a::semilattice_inf => 'a => 'a" ("{. _ .}" [0] 1000) where
    "{.p.} q \<equiv>  p \<sqinter> q"

definition
    "assume"::"('a::boolean_algebra) => 'a => 'a" ("[. _ .]" [0] 1000) where
    "[.p.] q \<equiv>  (-p \<squnion> q)"

definition
    angelic :: "('a \<Rightarrow> 'b::{semilattice_inf,order_bot}) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool" ("{: _ :}" [0] 1000) where
    "{:Q:} p s = (Q s \<sqinter> p \<noteq> \<bottom>)"

syntax
    "_assert" :: "patterns => logic => logic"    ("(1{._._.})")
translations
    "_assert x P" == "CONST assert (_abs x P)"

syntax
    "_demonic" :: "patterns => patterns => logic => logic" ("([:_\<leadsto>_._:])")
translations
    "_demonic x y t" == "(CONST demonic (_abs x (_abs y t)))"

syntax
    "_angelic" :: "patterns => patterns => logic => logic" ("({:_ \<leadsto> _._:})")
translations
    "_angelic x y t" == "(CONST angelic (_abs x (_abs y t)))"

lemma assert_o_def: "{.f o g.} = {.(\<lambda> x . f (g x)).}"
  by (simp add: o_def)

lemma demonic_demonic: "[:r:] o [:r':] = [:r OO r':]"
  by (simp add: fun_eq_iff le_fun_def demonic_def, auto)

lemma assert_demonic_comp: "{.p.} o [:r:] o {.p'.} o [:r':] =
      {.x . p x \<and> (\<forall> y . r x y \<longrightarrow> p' y).} o [:r OO r':]"
  by (auto simp add: fun_eq_iff le_fun_def assert_def demonic_def)

lemma demonic_assert_comp: "[:r:] o {.p.} = {.x.(\<forall> y . r x y \<longrightarrow> p y).} o [:r:]"
  by (auto simp add: fun_eq_iff le_fun_def assert_def demonic_def)

lemma assert_assert_comp: "{.p::'a::lattice.} o {.p'.} = {.p \<sqinter> p'.}"
  by (simp add: fun_eq_iff le_fun_def assert_def demonic_def inf_assoc)

lemma assert_assert_comp_pred: "{.p.} o {.p'.} = {.x . p x \<and> p' x.}"
  by (simp add: fun_eq_iff le_fun_def assert_def demonic_def inf_assoc)

lemma demonic_refinement: "r' \<le> r \<Longrightarrow> [:r:] \<le> [:r':]"
  apply (simp add: le_fun_def demonic_def)
  using order_trans by blast

definition "inpt r x = (\<exists> y . r x y)"

definition trs ::  "('a => 'b \<Rightarrow> bool) => ('b \<Rightarrow> bool) => 'a \<Rightarrow> bool" ("{: _ :]" [0] 1000) where
  "trs r = {. inpt r.} o [:r:]"

syntax
    "_trs" :: "patterns => patterns => logic => logic" ("({:_\<leadsto>_._:])")
translations
    "_trs x y t" == "(CONST trs (_abs x (_abs y t)))"

lemma assert_demonic_prop: "{.p.} o [:r:] = {.p.} o [:(\<lambda> x y . p x) \<sqinter> r:]"
  by (auto simp add: fun_eq_iff assert_def demonic_def)

lemma trs_trs: "(trs r) o (trs r')
  = trs ((\<lambda> s t. (\<forall> s' . r s s' \<longrightarrow> (inpt r' s'))) \<sqinter> (r OO r'))" (is "?S = ?T")
  by (simp add: trs_def inpt_def fun_eq_iff demonic_def assert_def le_fun_def, blast)

lemma prec_inpt_equiv: "p \<le> inpt r \<Longrightarrow> r' = (\<lambda> x y . p x \<and> r x y) \<Longrightarrow> {.p.} o [:r:] = {:r':]"
  by (simp add: fun_eq_iff demonic_def assert_def le_fun_def inpt_def trs_def, auto)

lemma assert_demonic_refinement: "({.p.} o [:r:] \<le> {.p'.} o [:r':]) = (p \<le> p' \<and> (\<forall> x . p x \<longrightarrow> r' x \<le> r x))"
  by  (auto simp add: le_fun_def assert_def demonic_def)

lemma spec_demonic_refinement: "({.p.} o [:r:] \<le> [:r':]) = (\<forall> x . p x \<longrightarrow> r' x \<le> r x)"
  by  (auto simp add: le_fun_def assert_def demonic_def)

lemma trs_refinement: "(trs r \<le> trs r') = ((\<forall> x . inpt r x \<longrightarrow> inpt r' x) \<and> (\<forall> x . inpt r x \<longrightarrow> r' x \<le> r x))"
  by (simp add: trs_def assert_demonic_refinement, simp add: le_fun_def)

lemma demonic_choice: "[:r:] \<sqinter> [:r':] = [:r \<squnion> r':]"
  by (simp add: fun_eq_iff demonic_def)

lemma spec_demonic_choice: "({.p.} o [:r:]) \<sqinter> ({.p'.} o [:r':]) = ({.p \<sqinter> p'.} o [:r \<squnion> r':])"
  by (auto simp add: fun_eq_iff demonic_def assert_def)

lemma trs_demonic_choice: "trs r \<sqinter> trs r' = trs ((\<lambda> x y . inpt r x \<and> inpt r' x) \<sqinter> (r \<squnion> r'))"
  by (simp add: trs_def inpt_def fun_eq_iff demonic_def assert_def le_fun_def, blast)

lemma spec_angelic: "p \<sqinter> p' = \<bottom> \<Longrightarrow> ({.p.} o [:r:]) \<squnion> ({.p'.} o [:r':])
    = {.p \<squnion> p'.} o [:(\<lambda> x y . p x \<longrightarrow> r x y) \<sqinter> ((\<lambda> x y . p' x \<longrightarrow> r' x y)):]"
  by (simp add: fun_eq_iff assert_def demonic_def, auto)

  subsection{*Conjunctive predicate transformers*}

definition "conjunctive (S::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) = (\<forall> Q . S (Inf Q) = INFIMUM Q S)"

definition "sconjunctive (S::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) = (\<forall> Q . (\<exists> x . x \<in> Q) \<longrightarrow> S (Inf Q) = INFIMUM Q S)"

lemma conjunctive_sconjunctive[simp]: "conjunctive S \<Longrightarrow> sconjunctive S"
  by (simp add: conjunctive_def sconjunctive_def)

lemma conjuncive_demonic [simp]: "conjunctive [:r:]"
  apply (simp add: conjunctive_def demonic_def fun_eq_iff)
  using le_Inf_iff by blast

lemma sconjunctive_assert [simp]: "sconjunctive {.p.}"
  apply (simp add: sconjunctive_def assert_def, safe)
  apply (rule antisym)
   apply (meson inf_le1 inf_le2 le_INF_iff le_Inf_iff le_infI)
  by (metis (mono_tags, lifting) Inf_greatest le_INF_iff le_inf_iff order_refl)

lemma sconjunctive_simp: "x \<in> Q \<Longrightarrow> sconjunctive S \<Longrightarrow> S (Inf Q) = INFIMUM Q S"
  by (auto simp add: sconjunctive_def)

lemma sconjunctive_INF_simp: "x \<in> X \<Longrightarrow> sconjunctive S \<Longrightarrow> S (INFIMUM X Q) = INFIMUM (Q`X) S"
  by (cut_tac x = "Q x" and Q = "Q ` X" in sconjunctive_simp, auto)

lemma demonic_comp [simp]: "sconjunctive S \<Longrightarrow> sconjunctive S' \<Longrightarrow> sconjunctive (S o S')"
proof (subst sconjunctive_def, safe)
  fix X :: "'c set"
  fix a :: 'c
  assume [simp]: "sconjunctive S"
  assume [simp]: "sconjunctive S'"
  assume [simp]: "a \<in> X"
  have A: "S' (Inf X) = INFIMUM X S'"
    by (rule_tac x = a in sconjunctive_simp, auto)
  also have B: "S (INFIMUM X S') = INFIMUM (S' ` X) S"
    by (rule_tac x = "S' a" in sconjunctive_simp, auto)
  finally show "(S o S') (Inf X) = INFIMUM X (S \<circ> S')" by simp
qed

lemma conjunctive_INF[simp]:"conjunctive S \<Longrightarrow> S (INFIMUM X Q) = (INFIMUM X (S o Q))"
  by (metis INF_image conjunctive_def)

lemma conjunctive_simp: "conjunctive S \<Longrightarrow>  S (Inf Q) = INFIMUM Q S"
  by (metis conjunctive_def)

lemma conjunctive_monotonic [simp]: "sconjunctive S \<Longrightarrow> mono S"
  proof (rule monoI)
    fix a b :: 'a
    assume [simp]: "a \<le> b"
    assume [simp]: "sconjunctive S"
    have [simp]: "a \<sqinter> b = a"
      by (rule antisym, auto)
    have A: "S a = S a \<sqinter> S b"
      by (cut_tac S = S and x = a and Q = "{a, b}" in sconjunctive_simp, auto )
    show "S a \<le> S b"
      by (subst A, simp)
  qed

definition "grd S = - S \<bottom>"

lemma grd_demonic: "grd [:r:] = inpt r"
  by (simp add: fun_eq_iff grd_def demonic_def le_fun_def inpt_def)

lemma "(S::'a::bot \<Rightarrow> 'b::boolean_algebra) \<le> S' \<Longrightarrow> grd S' \<le> grd S"
  by (simp add: grd_def le_fun_def)

lemma [simp]: "inpt (\<lambda>x y. p x \<and> r x y) = p \<sqinter> inpt r"
  by (simp add: fun_eq_iff inpt_def)

(*to remove*)
lemma [simp]: "p \<le> inpt r \<Longrightarrow> p \<sqinter> inpt r = p"
  by (simp add: fun_eq_iff le_fun_def, auto)

lemma grd_spec: "grd ({.p.} o [:r:]) = -p \<squnion> inpt r"
  by (simp add: grd_def fun_eq_iff demonic_def assert_def le_fun_def inpt_def)

definition "fail S = -(S \<top>)"
definition "term S = (S \<top>)"
definition "prec S = - (fail S)"
definition "rel S = (\<lambda> x y . \<not> S (\<lambda> z . y \<noteq> z) x)"

lemma rel_spec: "rel ({.p.} o [:r:]) x y = (p x \<longrightarrow> r x y)"
  by (simp add: rel_def demonic_def assert_def le_fun_def)

lemma prec_spec: "prec ({.p.} o [:r::'a\<Rightarrow>'b\<Rightarrow>bool:]) = p"
  by (auto simp add: prec_def fail_def demonic_def assert_def le_fun_def fun_eq_iff)

lemma fail_spec: "fail ({.p.} o [:(r::'a\<Rightarrow>'b::boolean_algebra):]) = -p"
  by (simp add: fail_def fun_eq_iff assert_def demonic_def le_fun_def top_fun_def)

lemma [simp]: "prec ({.p.} o [:(r::'a\<Rightarrow>'b::boolean_algebra):]) = p"
  by (simp add: prec_def fail_spec)

lemma [simp]: "prec (T::('a::boolean_algebra \<Rightarrow> 'b::boolean_algebra)) = \<top> \<Longrightarrow> prec (S o T) = prec S"
  by (simp add: prec_def fail_def)

lemma [simp]: "prec [:r::'a \<Rightarrow> 'b::boolean_algebra:] = \<top>"
  by (simp add: demonic_def prec_def fail_def fun_eq_iff)

lemma prec_rel: "{. p .} \<circ> [: \<lambda>x y. p x \<and> r x y :] = {.p.} o [:r:]"
  by (simp add: fun_eq_iff le_fun_def demonic_def assert_def, auto)

definition "Fail = \<bottom>"

lemma Fail_assert_demonic: "Fail = {.\<bottom>.} o [:r:]"
  by (simp add: fun_eq_iff Fail_def assert_def)

lemma Fail_assert: "Fail = {.\<bottom>.} o [:\<bottom>:]"
  by (rule Fail_assert_demonic)

lemma fail_comp[simp]: "\<bottom> o S = \<bottom>"
  by (simp add: fun_eq_iff)

lemma Fail_fail: "mono (S::'a::boolean_algebra \<Rightarrow> 'b::boolean_algebra) \<Longrightarrow> (S = Fail) = (fail S = \<top>)"
proof auto
  show "fail (Fail::'a \<Rightarrow> 'b) = \<top>"
    by (metis Fail_def bot_apply compl_bot_eq fail_def)
next
  assume A: "mono S"
  assume B: "fail S = \<top>"
  show "S = Fail"
  proof (rule antisym)
    show "S \<le> Fail"
      by (metis (hide_lams, no_types) A B bot.extremum_unique compl_le_compl_iff fail_def le_fun_def monoD top_greatest)
    next
      show "Fail \<le> S"
        by (metis Fail_def bot.extremum)
  qed
qed

lemma sconjunctive_spec: "sconjunctive S \<Longrightarrow> S = {.prec S.} o [:rel S:]"
proof (simp add: fun_eq_iff assert_def rel_def demonic_def prec_def fail_def le_fun_def, safe)
  fix x xa
  assume  "sconjunctive S"
  from this have mono: "mono S"
    by (rule conjunctive_monotonic)
  from this have A: "S x \<le> S \<top>"
    by (simp add: monoD)
  assume C: "S x xa"
  from this and A show "S \<top> xa"
    by blast
  fix xb
  from mono have B: "\<not> x xb \<Longrightarrow> S x \<le> S ((\<noteq>) xb)"
    by (rule monoD, blast)
  assume "\<not> S ((\<noteq>) xb) xa"
  from this B C show "x xb"
    by blast
next
  fix xa x
  assume  sconj: "sconjunctive S"
  assume B: "S \<top> xa"
  assume D: "\<forall>xb. \<not> S ((\<noteq>) xb) xa \<longrightarrow> x xb"
  define Q where "Q = { (\<noteq>) b | b . \<not> x b}"
  from sconj have A: "(\<exists>x. x \<in> Q) \<Longrightarrow> S (Inf Q) = (INF x:Q. S x)"
    by (simp add: sconjunctive_def)
  have C: "Inf Q = x"
    apply (simp add: Q_def fun_eq_iff, safe)
    by (drule_tac x = "(\<noteq>) xa" in spec, auto)
  show "S x xa"
  proof cases
    assume "x = \<top>"
    from this B show ?thesis by simp
  next
    assume "x \<noteq> \<top>"
    from this have [simp]: "S x = (INF x:Q. S x)"
      apply (unfold C [symmetric])
      by (rule A, blast)
    show ?thesis
      apply simp
      using D by (simp add: Q_def, blast)
  qed
qed

definition "non_magic S = (S \<bottom> = \<bottom>)"

lemma non_magic_spec: "non_magic ({.p.} o [:r:]) = (p \<le> inpt r)"
  by (simp add: non_magic_def fun_eq_iff inpt_def demonic_def assert_def le_fun_def)

lemma sconjunctive_non_magic: "sconjunctive S \<Longrightarrow> non_magic S = (prec S \<le> inpt (rel S))"
  apply (subst non_magic_spec [THEN sym])
  apply (subst sconjunctive_spec [THEN sym])
  by simp_all

definition "implementable S = (sconjunctive S \<and> non_magic S)"

lemma implementable_spec: "implementable S \<Longrightarrow> \<exists> p r . S = {.p.} o [:r:] \<and> p \<le> inpt r"
  apply (simp add: implementable_def)
  apply (rule_tac x = "prec S" in exI)
  apply (rule_tac x = "rel S" in exI, safe)
  apply (rule sconjunctive_spec, simp)
  by (drule sconjunctive_non_magic, auto)

definition "Skip = (id:: ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool))"

lemma assert_true_skip: "{.\<top>::'a \<Rightarrow> bool.} = Skip"
  by (simp add: fun_eq_iff assert_def Skip_def)

lemma skip_comp [simp]: "Skip o S = S"
  by (simp add: fun_eq_iff assert_def Skip_def)

lemma comp_skip[simp]:"S o Skip = S"
  by (simp add: fun_eq_iff assert_def Skip_def)

lemma assert_rel_skip[simp]: "{. \<lambda> (x, y) . True .} = Skip"
  by (simp add: fun_eq_iff Skip_def assert_def)

lemma [simp]: "mono S \<Longrightarrow> mono S' \<Longrightarrow> mono (S o S')"
  by (simp add: mono_def)

lemma [simp]: "mono {.p::('a \<Rightarrow> bool).}"
  by simp

lemma [simp]: "mono [:r::('a \<Rightarrow> 'b \<Rightarrow> bool):]"
  by simp

lemma assert_true_skip_a: "{. x . True .} = Skip"
  by (simp add: fun_eq_iff assert_def Skip_def)

lemma assert_false_fail: "{.\<bottom>::'a::boolean_algebra.}  = \<bottom>"
  by (simp add: fun_eq_iff assert_def)

lemma magoc_comp[simp]: "\<top> o S = \<top>"
  by (simp add: fun_eq_iff)

lemma left_comp: "T o U = T' o U' \<Longrightarrow> S o T o U = S o T' o U'"
  by (simp add: comp_assoc)

lemma assert_demonic: "{.p.} o [:r:] = {.p.} o [:x  \<leadsto> y . p x \<and> r x y:]"
  by (auto simp add: fun_eq_iff assert_def demonic_def le_fun_def)

lemma "trs r \<sqinter> trs r' = trs (\<lambda> x y . inpt r x \<and> inpt r' x \<and> (r x y \<or> r' x y))"
  by (auto simp add: fun_eq_iff trs_def assert_def demonic_def inpt_def)

lemma mono_assert[simp]: "mono {.p.}"
  by (metis (no_types, lifting) assert_def inf.cobounded1 inf_le2 le_infI monoI order_trans)

lemma mono_assume[simp]: "mono [.p.]"
  by (metis assume_def monoI sup.orderI sup_idem sup_mono)

lemma mono_demonic[simp]: "mono [:r:]"
  by  (auto simp add: mono_def demonic_def le_fun_def)

lemma mono_comp_a[simp]: "mono S \<Longrightarrow> mono T \<Longrightarrow> mono (S o T)"
  by simp

lemma mono_demonic_choice[simp]: "mono S \<Longrightarrow> mono T \<Longrightarrow> mono (S \<sqinter> T)"
  apply (simp add: mono_def)
  apply auto
   apply (rule_tac y = "S x" in order_trans, simp_all)
  by (rule_tac y = "T x" in order_trans, simp_all)

lemma mono_Skip[simp]: "mono Skip"
  by (simp add: mono_def Skip_def)

lemma mono_comp: "mono S \<Longrightarrow> S \<le> S' \<Longrightarrow> T \<le> T' \<Longrightarrow> S o T \<le> S' o T'"
  proof (simp add: le_fun_def, safe)
    fix x
    assume A: "mono S"
    assume B: "\<forall>x. S x \<le> S' x"
    assume "\<forall>x. T x \<le> T' x"
    from this have "T x \<le> T' x" by simp
    from A and this have C: "S (T x) \<le> S (T' x)"
      by (simp add: mono_def)
    from B also have "... \<le> S' (T' x)" by simp
    from C and this show "S (T x) \<le> S' (T' x)" by (rule order_trans)
  qed

lemma sconjunctive_simp_a: "sconjunctive S \<Longrightarrow> prec S = p \<Longrightarrow> rel S = r \<Longrightarrow> S = {.p.} o [:r:]"
  by (subst sconjunctive_spec, simp_all)

lemma sconjunctive_simp_b: "sconjunctive S \<Longrightarrow> prec S = \<top> \<Longrightarrow> rel S = r \<Longrightarrow> S = [:r:]"
  by (subst sconjunctive_spec, simp_all add: assert_true_skip)

lemma sconj_Fail[simp]: "sconjunctive Fail"
  by (metis Fail_def INF_eq_const all_not_in_conv bot_apply sconjunctive_def)

lemma sconjunctive_simp_c: "sconjunctive (S::('a \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> bool) \<Longrightarrow> prec S = \<bottom> \<Longrightarrow> S = Fail"
  by (drule sconjunctive_spec, simp add: Fail_assert_demonic [THEN sym])

lemma demonic_eq_skip: "[: (=) :] = Skip"
  apply (simp add: fun_eq_iff)
  by (metis (mono_tags) Skip_def demonic_def id_apply predicate1D predicate1I)

definition "Havoc = [:\<top>:]"

definition "Magic = [:\<bottom>::'a \<Rightarrow> 'b::boolean_algebra:]"

lemma Magic_top: "Magic = \<top>"
  by (simp add: fun_eq_iff Magic_def demonic_def)

lemma [simp]: "Magic \<noteq> Fail"
  by (simp add: Magic_top Fail_def fun_eq_iff)

lemma Havoc_Fail[simp]: "Havoc o (Fail::'a \<Rightarrow> 'b \<Rightarrow> bool) = Fail"
  by (simp add: Havoc_def fun_eq_iff Fail_def demonic_def le_fun_def)

lemma demonic_havoc: "[: \<lambda>x (x', y). True :] = Havoc"
  by (simp add: fun_eq_iff demonic_def le_fun_def top_fun_def Havoc_def)

lemma [simp]: "mono Magic"
  by (simp add: Magic_def)

lemma demonic_false_magic: "[: \<lambda>(x, y) (u, v). False :] = Magic"
  by (simp add: fun_eq_iff demonic_def le_fun_def top_fun_def Magic_def)

lemma demonic_magic[simp]: "[:r:] o Magic = Magic"
  by (simp add:  fun_eq_iff demonic_def le_fun_def top_fun_def bot_fun_def Magic_def product_def Skip_def)

lemma magic_comp[simp]: "Magic o S = Magic"
  by (simp add:  fun_eq_iff demonic_def le_fun_def top_fun_def Magic_def product_def Skip_def)

lemma hvoc_magic[simp]: "Havoc \<circ> Magic = Magic"
  by (simp add: Havoc_def)

lemma "Havoc \<top> = \<top>"
  by (simp add: Havoc_def fun_eq_iff demonic_def le_fun_def top_fun_def)

lemma Skip_id[simp]: "Skip p = p"
  by (simp add: Skip_def)

lemma demonic_pair_skip: "[: x, y \<leadsto> u, v. x = u \<and> y = v :] = Skip"
  by (simp add: fun_eq_iff demonic_def Skip_def le_fun_def)

lemma comp_demonic_demonic: "S o [:r:] o [:r':] = S o [:r OO r':]"
  by (simp add: comp_assoc demonic_demonic)

lemma comp_demonic_assert: "S o [:r:] o {.p.} = S o {. x. \<forall>y . r x y \<longrightarrow> p y .} o [:r:]"
  by (simp add: comp_assoc demonic_assert_comp)

lemma assert_demonic_eq_demonic: "({.p.} o [:r::'a \<Rightarrow> 'b \<Rightarrow> bool:] = [:r:]) = (\<forall> x . p x)"
  by (simp add: fun_eq_iff demonic_def assert_def le_fun_def, blast)

lemma trs_inpt_top: "inpt r = \<top> \<Longrightarrow> trs r = [:r:]"
  by (simp add: trs_def assert_true_skip)

subsection{*Product and Fusion of predicate transformers*}

  text{*
  In this section we define the fusion and product operators from \cite{back:butler:1995}.
  The fusion of two programs $S$ and $T$ is intuitively equivalent with the parallel execution
  of the two programs. If $S$ and $T$ assign nondeterministically some value to some program
  variable $x$, then the fusion of $S$ and $T$ will assign a value to $x$ which can be assigned
  by both $S$ and $T$.
*}

definition fusion :: "(('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool)) \<Rightarrow> (('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool)) \<Rightarrow> (('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool))" (infixl "\<parallel>" 70) where
  "(S \<parallel> S') q x = (\<exists> (p::'a\<Rightarrow>bool) p' . p \<sqinter> p' \<le> q \<and> S p x \<and> S' p' x)"

lemma fusion_demonic: "[:r:] \<parallel> [:r':] = [:r \<sqinter> r':]"
  by (auto simp add: fun_eq_iff fusion_def demonic_def le_fun_def)

lemma fusion_spec: "({.p.} \<circ> [:r:]) \<parallel> ({.p'.} \<circ> [:r':]) = ({.p \<sqinter> p'.} \<circ> [:r \<sqinter> r':])"
  by (auto simp add: fun_eq_iff fusion_def assert_def demonic_def le_fun_def)

lemma fusion_assoc: "S \<parallel> (T \<parallel> U) = (S \<parallel> T) \<parallel> U"
proof (rule antisym, auto simp add: fusion_def)
  fix p p' q s s' :: "'a \<Rightarrow> bool"
  fix a
  assume A: "p \<sqinter> p' \<le> q" and B: "s \<sqinter> s' \<le> p'"
  assume C: "S p a" and D: "T s a" and E: "U s' a"
  from A and B  have F: "(p \<sqinter> s) \<sqinter> s' \<le> q"
    by (simp add: le_fun_def)
  have "(\<exists>v v'. v \<sqinter> v' \<le> (p \<sqinter> s) \<and> S v a \<and> T v' a)"
    by (metis C D order_refl)
  show "\<exists>u u' . u \<sqinter> u' \<le> q \<and> (\<exists>v v'. v \<sqinter> v' \<le> u \<and> S v a \<and> T v' a) \<and> U u' a"
    by (metis F C D E order_refl)
next
  fix p p' q s s' :: "'a \<Rightarrow> bool"
  fix a
  assume A: "p \<sqinter> p' \<le> q" and B: "s \<sqinter> s' \<le> p"
  assume C: "S s a" and D: "T s' a" and E: "U p' a"
  from A and B  have F: "s \<sqinter> (s' \<sqinter> p')  \<le> q"
    by (simp add: le_fun_def)
  have "(\<exists>v v'. v \<sqinter> v' \<le> s' \<sqinter> p' \<and> T v a \<and> U v' a)"
    by (metis D E eq_iff)
  show "\<exists>u u'. u \<sqinter> u' \<le> q \<and> S u a \<and> (\<exists>v v'. v \<sqinter> v' \<le> u' \<and> T v a \<and> U v' a)"
    by (metis F C D E order_refl)
qed

lemma fusion_refinement: "S \<le> T \<Longrightarrow> S' \<le> T' \<Longrightarrow> S \<parallel> S' \<le> T \<parallel> T'"
  by (simp add: le_fun_def fusion_def, metis)

lemma "conjunctive S \<Longrightarrow> S \<parallel> \<top> = \<top>"
  by (auto simp add: fun_eq_iff fusion_def le_fun_def conjunctive_def)

lemma fusion_spec_local: "a \<in> init \<Longrightarrow> ([: x \<leadsto> u, y . u \<in> init \<and> x = y :] \<circ> {.p.} \<circ> [:r:]) \<parallel> ({.p'.} \<circ> [:r':])
    = [: x \<leadsto> u, y . u \<in> init \<and> x = y :] \<circ> {.u,x . p (u, x) \<and> p' x.} \<circ> [:u, x \<leadsto> y . r (u, x) y \<and> r' x y:]" (is "?p \<Longrightarrow> ?S = ?T")
proof -
  assume "?p"
  from this have [simp]: "(\<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) \<and> p' x) = (\<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x)) \<sqinter> p'"
     by auto
  have [simp]: "(\<lambda>x (u, y). u \<in> init \<and> x = y) OO (\<lambda>(u, x) y. r (u, x) y \<and> r' x y) = (\<lambda>x (u, y). u \<in> init \<and> x = y) OO r \<sqinter> r'"
    by auto
  have "?S =
    ({. \<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) .} \<circ> [: \<lambda>x (u, y). u \<in> init \<and> x = y :] \<circ> [: r :]) \<parallel> ({. p' .} \<circ> [: r' :])"
    by (simp add: demonic_assert_comp)
  also have "... =  {. (\<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x)) \<sqinter> p' .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO r \<sqinter> r' :]"
    by (simp add: comp_assoc demonic_demonic fusion_spec)
  also have "... = ?T"
    by (simp add: demonic_assert_comp comp_assoc demonic_demonic fusion_spec)
  finally show ?thesis by simp
qed

lemma fusion_demonic_idemp [simp]: "[:r:] \<parallel> [:r:] = [:r:]"
  by (simp add: fusion_demonic)

lemma fusion_spec_local_a: "a \<in> init \<Longrightarrow> ([:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:r:]) \<parallel> [:r':]
    = ([:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:u, x \<leadsto> y . r (u, x) y \<and> r' x y:])"
  by (cut_tac p' = "\<top>" and init = init and p = p and r = r and r' = r' in fusion_spec_local, auto simp add:  assert_true_skip)

lemma fusion_local_refinement:
  "a \<in> init \<Longrightarrow> (\<And> x u y . u \<in> init \<Longrightarrow> p' x \<Longrightarrow> r (u, x) y \<Longrightarrow> r' x y) \<Longrightarrow>
    {.p'.} o (([:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:r:]) \<parallel> [:r':]) \<le> [:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:r:]"
proof -
 assume A: "a \<in> init"
 assume [simp]: "(\<And> x u y . u \<in> init \<Longrightarrow> p' x \<Longrightarrow> r (u, x) y \<Longrightarrow> r' x y)"
 have " {. x. p' x \<and> (\<forall>a. a \<in> init \<longrightarrow> p (a, x)) .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO (\<lambda>(u, x) y. r (u, x) y \<and> r' x y) :]
          \<le> {. \<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO r :]"
  by (auto simp add: assert_demonic_refinement)
from this have " {. x. p' x \<and> (\<forall>a. a \<in> init \<longrightarrow> p (a, x)) .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO (\<lambda>(u, x) y. r (u, x) y \<and> r' x y) :]
        \<le> {. \<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) .} \<circ> [: \<lambda>x (u, y). u \<in> init \<and> x = y :] \<circ> [: r :]"
  by (simp add: comp_assoc demonic_demonic)
from this have "{. p' .} \<circ> [: \<lambda>x (u, y). u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: \<lambda>(u, x) y. r (u, x) y \<and> r' x y :]
        \<le> [: x \<leadsto> u, y. u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: r :]"
  by (simp add: demonic_assert_comp assert_demonic_comp)
from this have "{. p' .} \<circ> ([: x \<leadsto> (u, y) . u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: (u, x) \<leadsto> y . r (u, x) y \<and> r' x y :])
      \<le> [: x \<leadsto> (u, y) . u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: r :]"
  by (simp add: comp_assoc [THEN sym])
from A and this show ?thesis
  by  (unfold fusion_spec_local_a, simp)
qed

lemma fusion_spec_demonic: "({.p.} o [:r:]) \<parallel> [:r':] = {.p.} o [:r \<sqinter> r':]"
  by (cut_tac p = p and p' = \<top> and r = r and r' = r' in fusion_spec, simp add: assert_true_skip)

definition Fusion :: "('c \<Rightarrow> (('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool))) \<Rightarrow> (('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool))" where
   "Fusion S q x = (\<exists> (p::'c \<Rightarrow> 'a \<Rightarrow> bool) . (INF c . p c) \<le> q \<and> (\<forall> c . (S c) (p c) x))"

lemma Fusion_spec: "Fusion (\<lambda> n . {.p n.} \<circ> [:r n:]) = ({.INFIMUM UNIV p.} \<circ> [:INFIMUM UNIV r:])"
  apply (simp add: fun_eq_iff Fusion_def assert_def demonic_def le_fun_def)
  apply safe
  apply blast
  apply blast
  by (rule_tac x = "\<lambda> x y . r x xa y" in exI, auto)

lemma Fusion_demonic: "Fusion (\<lambda> n . [:r n:]) = [:INF n . r n:]"
  apply (cut_tac r = r and p = \<top> in Fusion_spec)
  by (simp add: assert_true_skip)

lemma Fusion_refinement: "(\<And> i . S i \<le> T i) \<Longrightarrow> Fusion S \<le> Fusion T"
  apply (simp add: le_fun_def Fusion_def, safe)
  by (rule_tac x = p in exI, auto)

lemma mono_fusion[simp]: "mono (S \<parallel> T)"
  apply (auto simp add: mono_def fusion_def)
  using order_trans by auto

lemma mono_Fusion: "mono (Fusion S)"
  by (simp add: mono_def Fusion_def le_fun_def, auto)

definition "prod_pred A B = (\<lambda>(a, b). A a \<and> B b)"
definition Prod :: "(('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool)) \<Rightarrow> (('c \<Rightarrow> bool) \<Rightarrow> ('d \<Rightarrow> bool)) \<Rightarrow> (('a \<times> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<times> 'd \<Rightarrow> bool))"
   (infixr "**" 70)
  where
  "(S ** T) q = (\<lambda> (x, y) . \<exists> p p' . prod_pred p p' \<le> q \<and> S p x \<and> T p' y)"

lemma mono_prod[simp]: "mono (S ** T)"
  by (auto simp add: mono_def Prod_def)

lemma Prod_spec: "({.p.} o [:r:]) ** ({.p'.} o [:r':]) = {.x,y . p x \<and> p' y.} o [:x, y \<leadsto> u, v . r x u \<and> r' y v:]"
  apply (simp add: Prod_def fun_eq_iff prod_pred_def demonic_def assert_def le_fun_def)
  apply safe
  apply metis
  by metis

lemma Prod_demonic: "[:r:] ** [:r':] = [:x, y \<leadsto> u, v . r x u \<and> r' y v:]"
  apply (simp add: Prod_def fun_eq_iff prod_pred_def demonic_def le_fun_def)
  apply safe
  apply metis
  by metis

lemma Prod_spec_Skip: "({.p.} o [:r:]) ** Skip = {.x,y . p x.} o [:x, y \<leadsto> u, v . r x u \<and> v = y:]"
  apply (cut_tac p = p and r = r and p' = \<top> and r' = "\<lambda> (x::'b) y . x = y" in Prod_spec)
  apply auto
  apply (subgoal_tac "(\<lambda>(x::'c, y::'b) (u::'a, v::'b). r x u \<and> y = v)
     = (\<lambda>(x::'c, y::'b) (u::'a, v::'b). r x u \<and> v = y)")
  by (auto simp add: fun_eq_iff assert_true_skip demonic_eq_skip)

lemma Prod_Skip_spec: "Skip ** ({.p.} o [:r:]) = {.x,y . p y.} o [:x, y \<leadsto> u, v . x = u \<and> r y v:]"
  apply (cut_tac p = \<top> and r = "\<lambda> (x::'a) y . x = y" and p' = p and r' = r in Prod_spec)
  by (auto simp add:assert_true_skip demonic_eq_skip)

 lemma Prod_skip_demonic: "Skip ** [:r:] = [:x, y \<leadsto> u, v . x = u \<and> r y v:]"
  by (cut_tac r = "(=)" and r' = r in Prod_demonic, simp add: demonic_eq_skip)

 lemma Prod_demonic_skip: "[:r:] ** Skip = [:x, y \<leadsto> u, v . r x u \<and>  y = v:]"
  by (cut_tac r' = "(=)" and r = r in Prod_demonic, simp add: demonic_eq_skip)

lemma Prod_spec_demonic: "({.p.} o [:r:]) **  [:r':] = {.x, y . p x.} o [:x, y \<leadsto> u, v . r x u \<and> r' y v:]"
  by (cut_tac p = p and p' = \<top> and r = r and r' = r' in Prod_spec, simp add: assert_true_skip)

lemma Prod_demonic_spec: "[:r:] ** ({.p.} o [:r':]) = {.x, y . p y.} o [:x, y \<leadsto> u, v . r x u \<and> r' y v:]"
  by (cut_tac p = \<top> and p' = p and r = r and r' = r' in Prod_spec, simp add: assert_true_skip)

lemma pair_eq_demonic_skip: "[: \<lambda>(x, y) (u, v). x = u \<and> v = y :] = Skip"
  by (simp add: fun_eq_iff demonic_def le_fun_def assert_def)

lemma Prod_assert_skip: "{.p.} ** Skip = {.x,y . p x.}"
  apply (cut_tac p = p and  r = "(=)" in Prod_spec_Skip)
  by (simp add: demonic_eq_skip pair_eq_demonic_skip)

lemma Prod_skip_assert: "Skip ** {.p.} = {.x,y . p y.}"
  apply (cut_tac p = p and  r = "(=)" in Prod_Skip_spec)
  by (simp add: demonic_eq_skip demonic_pair_skip)

lemma fusion_comute: "S \<parallel> T = T \<parallel> S"
  by (simp add: fusion_def fun_eq_iff, metis inf_commute)

lemma fusion_mono1: "S \<le> S' \<Longrightarrow> S \<parallel> T \<le> S' \<parallel> T"
  by (auto simp add: le_fun_def fusion_def)

lemma prod_mono1: "S \<le> S' \<Longrightarrow> S ** T \<le> S' ** T"
  by (auto simp add: Prod_def le_fun_def)

lemma prod_mono2: "S \<le> S' \<Longrightarrow> T ** S \<le> T ** S'"
  by (auto simp add: Prod_def le_fun_def)

lemma Prod_fusion: "S ** T = ([:x,y \<leadsto> x' . x = x':] o S o [:x \<leadsto> x', y . x = x':]) \<parallel> ([:x, y \<leadsto> y' . y = y':] o T o [:y \<leadsto> x, y' . y = y':])"
proof (simp add: fun_eq_iff Prod_def prod_pred_def fusion_def demonic_def le_fun_def, safe)
  fix x::"'a \<times> 'b \<Rightarrow> bool" fix a :: 'c fix b::'d fix p::"'a \<Rightarrow> bool" fix p' :: "'b \<Rightarrow> bool"
  assume [simp]: "\<forall>a b. p a \<and> p' b \<longrightarrow> x (a, b)"
  assume [simp]: "S p a"
  assume [simp]: "T p' b"
  have [simp]: "[:x\<leadsto>(x', y).x = x':] (\<lambda>x. p (fst x)) = p"
    by (simp add: fun_eq_iff demonic_def, auto)
  have [simp]: "[:y\<leadsto>(x, ya).y = ya:] (\<lambda>x. p' (snd x)) = p'"
    by (simp add: fun_eq_iff demonic_def, auto)
  show "\<exists>p p'. (\<forall>a b. p (a, b) \<and> p' (a, b) \<longrightarrow> x (a, b)) \<and> S ([:x\<leadsto>(x', y).x = x':] p) a \<and> T ([:y\<leadsto>(x, ya).y = ya:] p') b"
    apply (rule_tac x = "\<lambda> x . p (fst x)" in exI)
    apply (rule_tac x = "\<lambda> x . p' (snd x)" in exI)
    by simp
next
  fix x::"'a \<times> 'b \<Rightarrow> bool" fix a :: 'c fix b::'d fix p::"'a \<times> 'b \<Rightarrow> bool" fix p' :: "'a \<times> 'b \<Rightarrow> bool"
  assume [simp]: "  \<forall>a b. p (a, b) \<and> p' (a, b) \<longrightarrow> x (a, b)"
  assume [simp]: "S ([:x\<leadsto>(x', y).x = x':] p) a"
  assume [simp]: " T ([:y\<leadsto>(x, ya).y = ya:] p') b"
  have [simp]: "(\<lambda>a. \<forall>b. p (a, b)) = [:x\<leadsto>(x', y).x = x':] p"
    by (simp add: fun_eq_iff demonic_def, auto)
  have [simp]: "(\<lambda>b. \<forall>a. p' (a, b)) = [:y\<leadsto>(x, ya).y = ya:] p'"
    by (simp add: fun_eq_iff demonic_def, auto)
  show "\<exists>p p'. (\<forall>a b. p a \<and> p' b \<longrightarrow> x (a, b)) \<and> S p a \<and> T p' b"
    apply (rule_tac x = "\<lambda> a . \<forall> b . p (a, b)" in exI)
    apply (rule_tac x = "\<lambda> b . \<forall> a . p' (a, b)" in exI)
    by simp
qed

lemma refin_comp_right: "(S::'a \<Rightarrow> 'b::order) \<le> T \<Longrightarrow> S o X \<le> T o X"
  by (simp add: le_fun_def)

lemma refin_comp_left: "mono X \<Longrightarrow> (S::'a \<Rightarrow> 'b::order) \<le> T \<Longrightarrow> X o S  \<le> X o T"
  apply (simp add: le_fun_def)
  by (simp add: monoD)

lemma mono_angelic[simp]: "mono {:r:}"
  apply (simp add: angelic_def mono_def le_fun_def)
  by (metis bot.extremum_uniqueI inf.absorb1 inf_le1 inf_left_commute)

lemma [simp]: "Skip ** Magic = Magic"
  by (auto simp add: fun_eq_iff demonic_def le_fun_def top_fun_def Magic_def Prod_def prod_pred_def Skip_def)

lemma [simp]: "S ** Fail = Fail"
  by (auto simp add: fun_eq_iff Prod_def prod_pred_def Fail_def)

lemma [simp]: "Fail ** S = Fail"
  by (auto simp add: fun_eq_iff  Prod_def prod_pred_def Fail_def)

lemma demonic_conj: "[:(r::'a \<Rightarrow> 'b \<Rightarrow> bool):] o (S \<sqinter> S') = ([:r:] o S) \<sqinter> ([:r:] o  S')"
  by (simp add: fun_eq_iff demonic_def product_def Skip_def prod_pred_def le_fun_def assert_def, auto)

 lemma demonic_assume: "[:r:] o [.p.] = [:x \<leadsto> y . r x y \<and> p y:]"
    by (simp add: fun_eq_iff demonic_def product_def Skip_def le_fun_def assume_def, auto)

lemma assume_demonic: "[.p.] o [:r:] = [:x \<leadsto> y . p x \<and> r x y:]"
  by (simp add: fun_eq_iff demonic_def product_def Skip_def le_fun_def assume_def, auto)

lemma [simp]: "(Fail::'a::boolean_algebra) \<le> S"
  by (simp add: Fail_def)

lemma prod_skip_skip[simp]: "Skip ** Skip = Skip"
  apply (cut_tac r = "(=)" and r' = "(=)" in Prod_demonic)
  by (simp add: demonic_eq_skip demonic_pair_skip)

lemma fusion_prod: "S \<parallel> T = [:x \<leadsto> y, z . x = y \<and> x = z:] o Prod S T o [:y , z \<leadsto> x . y = x \<and> z = x:]"
  by (simp add: fun_eq_iff fusion_def Prod_def demonic_def prod_pred_def le_fun_def)

lemma [simp]: "prec S = \<top> \<Longrightarrow> prec T = \<top> \<Longrightarrow> prec (S ** T) = \<top>"
  apply (simp add: prec_def fail_def Prod_def fun_eq_iff, safe)
  apply (rule_tac x = \<top> in exI, simp)
  by (rule_tac x = \<top> in exI, simp)

lemma prec_skip[simp]: "prec Skip = (\<top>::'a\<Rightarrow>bool)"
  by (simp add: fun_eq_iff prec_def fail_def Skip_def)

lemma [simp]: "prec S = \<top> \<Longrightarrow> prec T = \<top> \<Longrightarrow> prec (S \<parallel> T) = \<top>"
  by (simp add: fusion_prod)

subsection{*Functional Update*}

definition update :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" ("[-_-]") where
    "[-f-] = [:x \<leadsto> y . y = f x:]"
syntax
    "_update" :: "patterns \<Rightarrow> tuple_args \<Rightarrow> logic"    ("(1[- _ \<leadsto> _ -])")
translations
    "_update x (_tuple_args f F)" == "CONST update ((_abs x (_tuple f F)))"
    "_update x (_tuple_arg F)" == "CONST update (_abs x F)"

lemma update_o_def: "[-f o g-] = [-x \<leadsto> f (g x)-]"
  by (simp add: o_def)

lemma update_simp: "[-f-] q = (\<lambda> x . q (f x))"
  by (simp add: demonic_def update_def fun_eq_iff, auto)

lemma update_assert_comp: "[-f-] o {.p.} = {.p o f.} o [-f-]"
  by (simp add: fun_eq_iff update_def demonic_def assert_def le_fun_def)

lemma update_demonic_comp: "[-f-] o [:r:] = [:x \<leadsto> y . r (f x) y:]"
  by (simp add: fun_eq_iff update_def demonic_def le_fun_def)

lemma demonic_update_comp: "[:r:] o [-f-] = [:x \<leadsto> y . \<exists> z . r x z \<and> y = f z:]"
  by (simp add: fun_eq_iff update_def demonic_def le_fun_def, auto)

lemma comp_update_demonic: "S o [-f-] o [:r:] = S o [:x \<leadsto> y . r (f x) y:]"
  by (simp add: comp_assoc update_demonic_comp)

lemma comp_demonic_update: "S o [:r:] o [-f-] = S o [:x \<leadsto> y . \<exists> z . r x z \<and> y = f z:]"
  by (simp add: comp_assoc demonic_update_comp)

lemma convert: "(\<lambda> x y . (S::('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool)) x (f y)) = [-f-] o S"
  by (simp add: fun_eq_iff update_def demonic_def le_fun_def)

lemma prod_update: "[-f-] ** [-g-] = [-x, y \<leadsto> f x, g y -]"
  apply (simp add: update_def Prod_demonic)
  apply (rule_tac f = demonic in  HOL.arg_cong)
  by fast

lemma prod_update_skip: "[-f-] ** Skip = [- x, y \<leadsto> f x, y-]"
  apply (simp add: update_def Prod_demonic_skip)
  apply (rule_tac f = demonic in  HOL.arg_cong)
  by fast

lemma prod_skip_update: "Skip ** [-f-] = [- x, y \<leadsto> x, f y-]"
  apply (simp add: update_def Prod_skip_demonic)
  apply (rule_tac f = demonic in  HOL.arg_cong)
  by fast

lemma prod_assert_update_skip: "({.p.} o [-f-]) ** Skip = {.x,y . p x.} o [- x, y \<leadsto> f x, y-]"
  apply (simp add: update_def Prod_spec_Skip)
  apply (rule_tac f = "(o)  {. \<lambda>(x, y). p x .}" in  HOL.arg_cong)
  apply (rule_tac f = "demonic" in  HOL.arg_cong)
  by fast

lemma prod_skip_assert_update: "Skip ** ({.p.} o [-f-]) = {.x,y . p y.} o [-\<lambda> (x, y) . (x, f y)-]"
  apply (simp add: update_def Prod_Skip_spec)
  apply (rule_tac f = "(o)  {. \<lambda>(x, y). p y .}" in  HOL.arg_cong)
  apply (rule_tac f = "demonic" in  HOL.arg_cong)
  by fast

lemma prod_assert_update: "({.p.} o [-f-]) ** ({.p'.} o [-f'-]) = {.x,y . p x \<and> p' y.} o [-\<lambda> (x, y) . (f x, f' y)-]"
  apply (simp add: update_def Prod_spec)
  apply (rule_tac f = "(o)  {. \<lambda>(x, y). p x \<and> p' y .}" in  HOL.arg_cong)
  apply (rule_tac f = "demonic" in  HOL.arg_cong)
  by (simp add: fun_eq_iff)

lemma update_id_Skip: "[-id-] = Skip"
  by (simp add: update_def fun_eq_iff demonic_def le_fun_def)

lemma prod_assert_assert_update: "{.p.} ** ({.p'.} o [-f-]) = {.x,y . p x \<and> p' y.} o [- x, y \<leadsto> x, f y-]"
  apply (cut_tac p = p and p' = p' and f = id and f' = f in prod_assert_update)
  by (simp add: update_id_Skip)

lemma prod_assert_update_assert: "({.p.} o [-f-])** {.p'.} = {.x,y . p x \<and> p' y.} o [- x, y \<leadsto> f x, y-]"
  apply (cut_tac p = p and p' = p' and f = f and f' = id in prod_assert_update)
  by (simp add: update_id_Skip)

lemma prod_update_assert_update: "[-f-] ** ({.p.} o [-f'-]) = {.x,y . p y.} o [-x, y \<leadsto> f x, f' y-]"
  apply (cut_tac p = \<top> and p' = p and f = f and f' = f' in prod_assert_update)
  by (simp add: assert_true_skip)

lemma prod_assert_update_update: "({.p.} o [-f-])** [-f'-] = {.x,y . p x .} o [- x, y \<leadsto> f x, f' y-]"
  apply (cut_tac p = p and p' = \<top> and f = f and f' = f' in prod_assert_update)
  by (simp add: assert_true_skip)

lemma Fail_assert_update: "Fail = {.\<bottom>.} o [- (Eps \<top>) -]"
  by (simp add: fun_eq_iff Fail_def assert_def)

lemma fail_assert_update: "\<bottom> = {.\<bottom>.} o [- (Eps \<top>) -]"
  by (simp add: fun_eq_iff assert_def)

lemma update_fail: "[-f-] o \<bottom> = \<bottom>"
  by (simp add: update_def demonic_def fun_eq_iff le_fun_def)

lemma fail_assert_demonic: "\<bottom> = {.\<bottom>.} o [:\<bottom>:]"
  by (simp add: fun_eq_iff assert_def)

lemma false_update_fail: "{.\<lambda>x. False.} o [-f-] = \<bottom>"
  by (simp add: fail_assert_update fun_eq_iff assert_def)

lemma comp_update_update: "S \<circ> [-f-] \<circ> [-f'-] = S \<circ> [- f' o f -]"
  by (simp add: comp_assoc update_comp)

lemma comp_update_assert: "S \<circ> [-f-] \<circ> {.p.} = S \<circ> {.p o f.} o [-f-]"
  by (simp add: comp_assoc update_assert_comp)

lemma prod_fail: "\<bottom> ** S = \<bottom>"
  by (simp add: fun_eq_iff Prod_def prod_pred_def)

lemma fail_prod: "S ** \<bottom> = \<bottom>"
  by (simp add: fun_eq_iff Prod_def prod_pred_def)

lemma assert_fail: "{.p::'a::boolean_algebra.} o \<bottom> = \<bottom>"
  by (simp add: assert_def fun_eq_iff)

lemma angelic_assert: "{:r:} o {.p.} = {:x \<leadsto> y . r x y \<and> p y:}"
  by (simp add: fun_eq_iff angelic_def demonic_def assert_def)

lemma Prod_Skip_angelic_demonic: "Skip ** ({:r:} o [:r':]) = {:s,x \<leadsto> s',y . r x y \<and> s' = s:} o [:s,x \<leadsto> s',y . r' x y \<and> s' = s:]"
  apply (simp add: fun_eq_iff Prod_def Skip_def angelic_def demonic_def le_fun_def prod_pred_def)
  apply safe
  apply metis
  apply (rule_tac x = "\<lambda> x . x = a" in exI)
  apply (rule_tac x = "\<lambda> b . x (a, b)" in exI)
  by metis

lemma Prod_angelic_demonic_Skip: "({:r:} o [:r':]) ** Skip = {:x, u \<leadsto> y, u' . r x y \<and> u = u':} o  [:x, u \<leadsto> y, u' . r' x y \<and> u = u':]"
  apply (simp add: fun_eq_iff demonic_def angelic_def le_fun_def Skip_def Prod_def prod_pred_def, auto)
  apply (rule_tac x = "\<lambda> a . r' aa a" in exI)
  apply (rule_tac x = "\<lambda> a . a = b" in exI, simp_all)
  by metis

lemma prec_rel_eq: "p = p' \<Longrightarrow> r = r' \<Longrightarrow> {.p.} o [:r:] = {.p'.} o [:r':]"
  by simp

lemma prec_rel_le: "p \<le> p' \<Longrightarrow> (\<And> x . p x \<Longrightarrow> r' x \<le> r x) \<Longrightarrow> {.p.} o [:r:] \<le> {.p'.} o [:r':]"
  apply (simp add: le_fun_def demonic_def assert_def, auto)
  by (rule_tac y = "r xa" in order_trans, simp_all)

lemma assert_update_eq: "({.p.} o [-f-] = {.p'.} o [-f'-]) = (p = p' \<and> (\<forall> x. p x \<longrightarrow> f x = f' x))"
  apply (simp add: fun_eq_iff assert_def demonic_def update_def le_fun_def)
  by auto

lemma update_eq: "([-f-] = [-f'-]) = (f = f')"
  apply (simp add: fun_eq_iff assert_def demonic_def update_def le_fun_def)
  by auto

lemma spec_eq_iff:
  shows spec_eq_iff_1: "p = p' \<Longrightarrow> f = f' \<Longrightarrow> {.p.} o [-f-] = {.p'.} o [-f'-]"
  and spec_eq_iff_2: "f = f' \<Longrightarrow> [-f-] = [-f'-]"
  and spec_eq_iff_3: "p = (\<lambda> x . True) \<Longrightarrow> f = f' \<Longrightarrow> {.p.} o [-f-] = [-f'-]"
  and spec_eq_iff_4: "p = (\<lambda> x . True) \<Longrightarrow> f = f' \<Longrightarrow> [-f-] = {.p.} o [-f'-]"
  by (simp_all add: assert_true_skip_a)

lemma spec_eq_iff_a:
  shows"(\<And> x . p x = p' x) \<Longrightarrow> (\<And> x . f x = f' x) \<Longrightarrow> {.p.} o [-f-] = {.p'.} o [-f'-]"
  and "(\<And> x . f x = f' x) \<Longrightarrow> [-f-] = [-f'-]"
  and "(\<And> x . p x) \<Longrightarrow> (\<And> x . f x = f' x) \<Longrightarrow> {.p.} o [-f-] = [-f'-]"
  and "(\<And> x . p x) \<Longrightarrow>(\<And> x . f x = f' x) \<Longrightarrow> [-f-] = {.p.} o [-f'-]"
  apply (subgoal_tac "p = p' \<and> f = f'")
  apply simp
  apply (simp add: fun_eq_iff)
  apply (subgoal_tac "f = f'")
  apply simp
  apply (simp add: fun_eq_iff)

  apply (subgoal_tac "p = (\<lambda> x. True) \<and> f = f'")
  apply (simp add: assert_true_skip_a)
  apply (simp add: fun_eq_iff)
  apply (subgoal_tac "p = (\<lambda> x. True) \<and> f = f'")
  apply (simp add: assert_true_skip_a)
  by (simp add: fun_eq_iff)

lemma spec_eq_iff_prec: "p = p' \<Longrightarrow> (\<And> x . p x \<Longrightarrow> f x = f' x) \<Longrightarrow> {.p.} o [-f-] = {.p'.} o [-f'-]"
  by (simp add: update_def fun_eq_iff assert_def demonic_def le_fun_def, auto)

lemma trs_prod: "trs r ** trs r' = trs (\<lambda> (x,x') (y,y') . r x y \<and> r' x' y')"
  apply (simp add: trs_def)
  apply (simp add: Prod_spec)
  apply (subgoal_tac "(\<lambda> (x, y).inpt r x \<and> inpt r' y) = ( inpt (\<lambda>(x, x') (y, y'). r x y \<and> r' x' y'))")
  apply (simp_all)
  by (simp add: fun_eq_iff inpt_def)

lemma sconjunctiveE: "sconjunctive S \<Longrightarrow> (\<exists> p r . S = {. p .} o [: r ::'a \<Rightarrow> 'b \<Rightarrow> bool:])"
  by (drule sconjunctive_spec, blast)

lemma sconjunctive_prod [simp]: "sconjunctive S \<Longrightarrow> sconjunctive S' \<Longrightarrow> sconjunctive (S ** S')"
  apply (drule sconjunctiveE)
  apply (drule sconjunctiveE)
  apply safe
  by (simp add: Prod_spec)

lemma nonmagic_prod [simp]: "non_magic S \<Longrightarrow> non_magic S' \<Longrightarrow> non_magic (S ** S')"
  apply (simp add: non_magic_def)
  apply (simp add: Prod_def)
  apply (simp add: fun_eq_iff prod_pred_def le_fun_def, safe)
  apply (case_tac "p = \<bottom>", simp_all)
  apply (simp add: fun_eq_iff)
  apply (case_tac "p' = \<bottom>", simp_all)
  by (simp add: fun_eq_iff)

lemma non_magic_comp [simp]: "non_magic S \<Longrightarrow> non_magic S' \<Longrightarrow> non_magic (S o S')"
  by (simp add: non_magic_def)

lemma implementable_pred [simp]: "implementable S \<Longrightarrow> implementable S' \<Longrightarrow> implementable (S ** S')"
  by (simp add: implementable_def)

lemma implementable_comp[simp]: "implementable S \<Longrightarrow> implementable S' \<Longrightarrow> implementable (S o S')"
  by (simp add: implementable_def)

lemma nonmagic_assert: "non_magic {.p::'a::boolean_algebra.}"
  by (simp add: non_magic_def assert_def)

subsection {*Control Statements*}

definition "if_stm p S T = ([.p.] o S) \<sqinter> ([.-p.] o T)"

definition "while_stm p S = lfp (\<lambda> X . if_stm p (S o X) Skip)"

definition "Sup_less x (w::'b::wellorder) = Sup {(x v)::'a::complete_lattice | v . v < w}"

lemma Sup_less_upper: "v < w \<Longrightarrow> P v \<le> Sup_less P w"
  by (simp add: Sup_less_def, rule Sup_upper, blast)

lemma Sup_less_least: "(\<And> v . v < w \<Longrightarrow> P v \<le> Q) \<Longrightarrow> Sup_less P w \<le> Q"
  by (simp add: Sup_less_def, rule Sup_least, blast)

theorem fp_wf_induction:
  "f x  = x \<Longrightarrow> mono f \<Longrightarrow> (\<forall> w . (y w) \<le> f (Sup_less y w)) \<Longrightarrow> Sup (range y) \<le> x"
  apply (rule Sup_least)
  apply (simp add: image_def, safe, simp)
  apply (rule less_induct, simp_all)
  apply (rule_tac y = "f (Sup_less y xa)" in order_trans, simp)
  apply (drule_tac x = "Sup_less y xa" and y = "x" in monoD)
  by (simp add: Sup_less_least, auto)

theorem lfp_wf_induction: "mono f \<Longrightarrow> (\<forall> w . (p w) \<le> f (Sup_less p w)) \<Longrightarrow> Sup (range p) \<le> lfp f"
  apply (rule fp_wf_induction, simp_all)
  by (drule lfp_unfold, simp)

theorem lfp_wf_induction_a: "mono f \<Longrightarrow> (\<forall> w . (p w) \<le> f (Sup_less p w)) \<Longrightarrow> (SUP a. p a) \<le> lfp f"
  apply (rule fp_wf_induction, simp_all)
  by (drule lfp_unfold, simp)

theorem lfp_wf_induction_b: "mono f \<Longrightarrow> (\<forall> w . (p w) \<le> f (Sup_less p w)) \<Longrightarrow> S \<le> (SUP a. p a) \<Longrightarrow> S \<le> lfp f"
  apply (rule_tac y = "(SUP a. p a)" in order_trans)
   apply simp
    by (rule lfp_wf_induction, simp_all)

lemma [simp]: "mono S \<Longrightarrow> mono (\<lambda>X. if_stm b (S \<circ> X) T)"
  apply (simp add: if_stm_def mono_def le_fun_def)
  apply auto
  by (metis (no_types, lifting) assume_def dual_order.trans inf.coboundedI1 le_supI sup_ge1 sup_ge2)

definition  "mono_mono F = (mono F \<and> (\<forall> f . mono f \<longrightarrow> mono (F f)))"

theorem lfp_mono [simp]:
  "mono_mono F \<Longrightarrow> mono (lfp F)"
  apply (simp add: mono_mono_def)
  apply (rule_tac f="F" and P = "mono" in lfp_ordinal_induct)
  apply (simp_all add: mono_def)
  apply (intro allI impI SUP_least)
  apply (rule_tac y = "f y" in order_trans)
  apply (auto intro: SUP_upper)
  done

lemma if_mono[simp]: "mono S \<Longrightarrow> mono T \<Longrightarrow> mono (if_stm b S T)"
  by (simp add: if_stm_def)

subsection{*Hoare Total Correctness Rules*}

definition "Hoare p S q = (p \<le> S q)"

definition "post_fun (p::'a::order) q = (if p \<le> q then \<top> else \<bottom>)"

lemma post_mono [simp]: "mono (post_fun p :: (_::{order_bot,order_top}))"
   apply (simp add: post_fun_def  mono_def, safe)
   apply (subgoal_tac "p \<le> y", simp)
   by (rule_tac y = x in order_trans, simp_all)

lemma post_refin [simp]: "mono S \<Longrightarrow> ((S p)::'a::bounded_lattice) \<sqinter> (post_fun p) x \<le> S x"
  apply (simp add: le_fun_def post_fun_def, safe)
  by (rule_tac f = S in monoD, simp_all)

  lemma Sup_range_comp: "(Sup (range p)) o S = Sup (range (\<lambda> w . ((p w) o S)))"
    by (simp add: fun_eq_iff)

lemma Sup_less_comp: "(Sup_less P) w o S = Sup_less (\<lambda> w . ((P w) o S)) w"
  apply (simp add: Sup_less_def fun_eq_iff, safe)
  apply (rule antisym)
   apply (rule SUP_least, safe, simp)
    apply (rule_tac i = "\<lambda> x . f (S x)" in SUP_upper2, blast, simp)
   apply (rule SUP_least, safe, simp)
  by (rule_tac i = "P v" in SUP_upper2, auto)

  lemma assert_Sup: "{.Sup (X::'a::complete_distrib_lattice set).} = Sup (assert ` X)"
    by (simp add: fun_eq_iff assert_def Sup_inf)

lemma Sup_less_assert: "Sup_less (\<lambda>w. {. (p w)::'a::complete_distrib_lattice .}) w = {.Sup_less p w.}"
  apply (simp add: Sup_less_def assert_Sup image_def)
  by (simp add: setcompr_eq_image)

lemma [simp]: "Sup_less (\<lambda>n x. t x = n) n = (\<lambda> x . (t x < n))"
  by (simp add: Sup_less_def, auto)

lemma [simp]: "Sup_less (\<lambda>n. {.x. t x = n.} \<circ> S) n = {.x. t x < n.} \<circ> S"
  apply (simp add: Sup_less_comp [THEN sym])
  by (simp add: Sup_less_assert)

lemma [simp]: "(SUP a. {.x .t x = a.} \<circ> S) = S"
  by (simp add: fun_eq_iff assert_def)

theorem hoare_fixpoint:
  "mono_mono F \<Longrightarrow>
     (\<forall> f w . mono f \<longrightarrow> (Hoare (Sup_less p w) f y \<longrightarrow> Hoare ((p w)::'a \<Rightarrow> bool) (F f) y)) \<Longrightarrow> Hoare(Sup (range p)) (lfp F) y"
  apply (simp add: mono_mono_def hoare_refinement_post assert_Sup_range Sup_range_comp del: )
  apply (rule lfp_wf_induction)
  apply auto
  apply (simp add: Sup_less_comp [THEN sym])
  apply (simp add: Sup_less_assert)
  apply (drule_tac x = "{. Sup_less p w .} \<circ> post_fun y" in spec, safe)
  apply simp_all
  apply (drule_tac x = "w" in spec, safe)
  by (simp add: le_fun_def)

  theorem hoare_sequential:
    "mono S \<Longrightarrow> (Hoare p (S o T) r) = ( (\<exists> q. Hoare p S q \<and> Hoare q T r))"
    by (metis (no_types) Hoare_def monoD o_def order_refl order_trans)

  theorem hoare_choice:
    "Hoare  p (S \<sqinter> T) q = (Hoare p S q \<and> Hoare p T q)"
    by (simp_all add: Hoare_def inf_fun_def)

  theorem hoare_assume:
    "(Hoare P [.R.] Q) = (P \<sqinter> R \<le> Q)"
    apply (simp add: Hoare_def assume_def)
    apply safe
    apply (case_tac "(inf P R) \<le> (inf (sup (- R) Q) R)")
    apply (simp add: inf_sup_distrib2)
    apply (simp add: le_infI1)
    apply (case_tac "(sup (-R) (inf P R)) \<le> sup (- R) Q")
    apply (simp add: sup_inf_distrib1)
    by (simp add: le_supI2)

  lemma hoare_if: "mono S \<Longrightarrow> mono T \<Longrightarrow> Hoare (p \<sqinter> b) S q \<Longrightarrow> Hoare (p \<sqinter> -b) T q \<Longrightarrow> Hoare p (if_stm b S T) q"
    apply (simp add: if_stm_def)
    apply (simp add: hoare_choice, safe)
    apply (simp_all add:  hoare_sequential)
    apply (rule_tac x = " (p \<sqinter> b)" in exI, simp)
    apply (simp add: hoare_assume)
    apply (rule_tac x = " (p \<sqinter> -b)" in exI, simp)
    by (simp add: hoare_assume)

lemma [simp]: "mono x \<Longrightarrow> mono_mono (\<lambda>X . if_stm b (x \<circ> X) Skip)"
  by (simp add: mono_mono_def)

  lemma hoare_while:
      "mono x \<Longrightarrow> (\<forall> w . Hoare ((p w) \<sqinter> b) x (Sup_less p w)) \<Longrightarrow>  Hoare  (Sup (range p)) (while_stm b x) ((Sup (range p)) \<sqinter> -b)"
    apply (cut_tac y = " ((SUP x. p x) \<sqinter> - b)" and p = p and F = "\<lambda> X . if_stm b (x o X) Skip" in hoare_fixpoint, simp_all)
      apply safe
    apply (rule hoare_if, simp_all)
    apply (simp_all add:  hoare_sequential)
    apply (rule_tac x = " (Sup_less p w)" in exI, simp_all)
    apply (simp add: Hoare_def Skip_def, auto)
    by (simp add: while_stm_def)

  lemma hoare_prec_post: "mono S \<Longrightarrow> p \<le> p' \<Longrightarrow> q' \<le> q \<Longrightarrow> Hoare p' S q' \<Longrightarrow> Hoare p S q"
    apply (simp add: Hoare_def)
    apply (rule_tac y = p' in order_trans, simp_all)
    apply (rule_tac y = "S q'" in order_trans, simp_all)
    using monoD by auto

  lemma [simp]: "mono x \<Longrightarrow>  mono (while_stm b x)"
    by (simp add: while_stm_def)

  lemma hoare_while_a:
    "mono x \<Longrightarrow> (\<forall> w . Hoare ((p w) \<sqinter> b) x (Sup_less p w)) \<Longrightarrow> p' \<le>  (Sup (range p)) \<Longrightarrow> ((Sup (range p)) \<sqinter> -b) \<le> q
      \<Longrightarrow>  Hoare p' (while_stm b x) q"
    apply (rule hoare_prec_post, simp_all)
    by (drule hoare_while, simp_all)

  lemma hoare_update: "p \<le> q o f \<Longrightarrow> Hoare p [-f-] q"
    by (simp add: Hoare_def update_def demonic_def le_fun_def)

  lemma hoare_demonic: "(\<And> x y . p x \<Longrightarrow> r x y \<Longrightarrow> q y) \<Longrightarrow> Hoare p [:r:] q"
    by (simp add: Hoare_def demonic_def le_fun_def)

lemma refinement_hoare: "S \<le> T \<Longrightarrow> Hoare (p::'a::order) S (q) \<Longrightarrow> Hoare p T q"
  apply (simp add: Hoare_def le_fun_def)
  by (rule_tac y = "S q" in order_trans, simp_all)

lemma refinement_hoare_iff: "(S \<le> T) = (\<forall> p q . Hoare (p::'a::order) S (q) \<longrightarrow> Hoare p T q)"
  apply safe
   apply (rule refinement_hoare, simp_all)
  by (simp add: Hoare_def le_fun_def)

subsection{*Data Refinement*}

lemma data_refinement: "mono S' \<Longrightarrow> (\<forall> x a . \<exists> u . R x a u) \<Longrightarrow>
    {:x, a \<leadsto> x', u . x = x' \<and> R x a u:} o S \<le> S' o {:y, b \<leadsto> y', v . y = y' \<and> R' y b v:} \<Longrightarrow>
    [:x \<leadsto> x', u . x = x':] o S o [:y, v \<leadsto> y' . y = y' :]
    \<le> [:x \<leadsto> x', a . x = x':] o S' o [:y, b \<leadsto> y' . y = y' :]"
proof (simp add: fun_eq_iff demonic_def le_fun_def, safe)
  fix x xa b
  assume A: "\<forall>x a. \<exists>u. R x a u"
  assume B: "\<forall>b. S ([: \<lambda>(y, v). (=) y :] x) (xa, b)"
  assume "\<forall>x a b. {:(x, a) \<leadsto> (x', u).x = x' \<and> R x a u:} (S x) (a, b) \<longrightarrow>
                      S' ({:(y, b) \<leadsto> (y', v).y = y' \<and> R' y b v:} x) (a, b)"

  from this have C: "{:(x, a) \<leadsto> (x', u).x = x' \<and> R x a u:} (S ([: \<lambda>(y, v). (=) y :] x)) (xa, b) \<Longrightarrow>
                      S' ({:(y, b) \<leadsto> (y', v).y = y' \<and> R' y b v:} ([: \<lambda>(y, v). (=) y :] x)) (xa, b)"

    by simp
  from A obtain u where "R xa b u"
    by blast

  from this and B have "{:(x, a) \<leadsto> (x', u).x = x' \<and> R x a u:} (S ([: \<lambda>(y, v). (=) y :] x)) (xa, b)"
    apply (simp add: angelic_def fun_eq_iff)
    by blast

  from this and C have D: "S' ({:(y, b) \<leadsto> (y', v).y = y' \<and> R' y b v:} ([: \<lambda>(y, v). (=) y :] x)) (xa, b)"
    by simp

  have [simp]: "\<And> s t . {:(y, b) \<leadsto> (y', v).y = y' \<and> R' y b v:} ([: \<lambda>(y, v). (=) y :] x) (s,t)
    \<Longrightarrow> [: \<lambda>(y, b). (=) y :] x (s, t)"
    by (simp add: le_fun_def demonic_def angelic_def fun_eq_iff)

  assume "mono S'"
  from this have "S' ({:(y, b) \<leadsto> (y', v).y = y' \<and> R' y b v:} ([: \<lambda>(y, v). (=) y :] x)) \<le> S' ([: \<lambda>(y, b). (=) y :] x)"
    by (rule monoD, simp add: le_fun_def)

  from D and this show "S' ([: \<lambda>(y, b). (=) y :] x) (xa, b)"
    by (simp add: le_fun_def)
qed

lemma mono_update[simp]: "mono [- f -]"
  by (simp add: update_def)

end


(* Author: Alexander Maletzky *)

section \<open>Integer Binomial Coefficients\<close>

theory Binomial_Int
  imports Complex_Main
begin

lemma upper_le_binomial:
  assumes "0 < k" and "k < n"
  shows "n \<le> n choose k"
proof -
  from assms have "1 \<le> n" by simp
  define k' where "k' = (if n div 2 \<le> k then k else n - k)"
  from assms have 1: "k' \<le> n - 1" and 2: "n div 2 \<le> k'" by (auto simp: k'_def)
  from assms(2) have "k \<le> n" by simp
  have "n choose k = n choose k'" by (simp add: k'_def binomial_symmetric[OF \<open>k \<le> n\<close>])
  have "n = n choose 1" by (simp only: choose_one)
  also from \<open>1 \<le> n\<close> have "\<dots> = n choose (n - 1)" by (rule binomial_symmetric)
  also from 1 2 have "\<dots> \<le> n choose k'" by (rule binomial_antimono) simp
  also have "\<dots> = n choose k" by (simp add: k'_def binomial_symmetric[OF \<open>k \<le> n\<close>])
  finally show ?thesis .
qed

text \<open>Restore original sort constraints:\<close>
setup \<open>Sign.add_const_constraint (@{const_name gbinomial}, SOME @{typ "'a::{semidom_divide,semiring_char_0} \<Rightarrow> nat \<Rightarrow> 'a"})\<close>

lemma gbinomial_0_left: "0 gchoose k = (if k = 0 then 1 else 0)"
  by (cases k) simp_all

lemma gbinomial_eq_0_int:
  assumes "n < k"
  shows "(int n) gchoose k = 0"
proof -
  have "\<exists>a\<in>{0..<k}. int n - int a = 0"
  proof
    show "int n - int n = 0" by simp
  next
    from assms show "n \<in> {0..<k}" by simp
  qed
  with finite_atLeastLessThan have eq: "prod (\<lambda>i. int n - int i) {0..<k} = 0" by (rule prod_zero)
  show ?thesis by (simp add: gbinomial_prod_rev eq)
qed

corollary gbinomial_eq_0: "0 \<le> a \<Longrightarrow> a < int k \<Longrightarrow> a gchoose k = 0"
  by (metis nat_eq_iff2 nat_less_iff gbinomial_eq_0_int)

lemma int_binomial: "int (n choose k) = (int n) gchoose k"
proof (cases "k \<le> n")
  case True
  from refl have eq: "(\<Prod>i = 0..<k. int (n - i)) = (\<Prod>i = 0..<k. int n - int i)"
  proof (rule prod.cong)
    fix i
    assume "i \<in> {0..<k}"
    with True show "int (n - i) = int n - int i" by simp
  qed
  show ?thesis
    by (simp add: gbinomial_binomial[symmetric] gbinomial_prod_rev zdiv_int eq)
next
  case False
  thus ?thesis by (simp add: gbinomial_eq_0_int)
qed

lemma falling_fact_pochhammer: "prod (\<lambda>i. a - int i) {0..<k} = (- 1) ^ k * pochhammer (- a) k"
proof -
  have eq: "z ^ Suc n * prod f {0..n} = prod (\<lambda>x. z * f x) {0..n}" for z::int and n f
    by (induct n) (simp_all add: ac_simps)
  show ?thesis
  proof (cases k)
    case 0
    thus ?thesis by (simp add: pochhammer_minus)
  next
    case (Suc n)
    thus ?thesis
      by (simp only: pochhammer_prod atLeastLessThanSuc_atLeastAtMost
          prod.atLeast_Suc_atMost_Suc_shift eq flip: power_mult_distrib) (simp add: of_nat_diff)
  qed
qed

lemma falling_fact_pochhammer': "prod (\<lambda>i. a - int i) {0..<k} = pochhammer (a - int k + 1) k"
  by (simp add: falling_fact_pochhammer pochhammer_minus')

lemma gbinomial_int_pochhammer: "(a::int) gchoose k = (- 1) ^ k * pochhammer (- a) k div fact k"
  by (simp only: gbinomial_prod_rev falling_fact_pochhammer)

lemma gbinomial_int_pochhammer': "a gchoose k = pochhammer (a - int k + 1) k div fact k"
  by (simp only: gbinomial_prod_rev falling_fact_pochhammer')

lemma fact_dvd_pochhammer: "fact k dvd pochhammer (a::int) k"
proof -
  have dvd: "y \<noteq> 0 \<Longrightarrow> ((of_int (x div y))::'a::field_char_0) = of_int x / of_int y \<Longrightarrow> y dvd x"
    for x y :: int
    by (smt dvd_triv_left mult.commute nonzero_eq_divide_eq of_int_eq_0_iff of_int_eq_iff of_int_mult)
  show ?thesis
  proof (cases "0 < a")
    case True
    moreover define n where "n = nat (a - 1) + k"
    ultimately have a: "a = int n - int k + 1" by simp
    from fact_nonzero show ?thesis unfolding a
    proof (rule dvd)
      have "of_int (pochhammer (int n - int k + 1) k div fact k) = (of_int (int n gchoose k)::rat)"
        by (simp only: gbinomial_int_pochhammer')
      also have "\<dots> = of_int (int (n choose k))" by (simp only: int_binomial)
      also have "\<dots> = of_nat (n choose k)" by simp
      also have "\<dots> = (of_nat n) gchoose k" by (fact binomial_gbinomial)
      also have "\<dots> = pochhammer (of_nat n - of_nat k + 1) k / fact k"
        by (fact gbinomial_pochhammer')
      also have "\<dots> = pochhammer (of_int (int n - int k + 1)) k / fact k" by simp
      also have "\<dots> = (of_int (pochhammer (int n - int k + 1) k)) / (of_int (fact k))"
        by (simp only: of_int_fact pochhammer_of_int)
      finally show "of_int (pochhammer (int n - int k + 1) k div fact k) =
                      of_int (pochhammer (int n - int k + 1) k) / rat_of_int (fact k)" .
    qed
  next
    case False
    moreover define n where "n = nat (- a)"
    ultimately have a: "a = - int n" by simp
    from fact_nonzero have "fact k dvd (-1)^k * pochhammer (- int n) k"
    proof (rule dvd)
      have "of_int ((-1)^k * pochhammer (- int n) k div fact k) = (of_int (int n gchoose k)::rat)"
        by (simp only: gbinomial_int_pochhammer)
      also have "\<dots> = of_int (int (n choose k))" by (simp only: int_binomial)
      also have "\<dots> = of_nat (n choose k)" by simp
      also have "\<dots> = (of_nat n) gchoose k" by (fact binomial_gbinomial)
      also have "\<dots> = (-1)^k * pochhammer (- of_nat n) k / fact k"
        by (fact gbinomial_pochhammer)
      also have "\<dots> = (-1)^k * pochhammer (of_int (- int n)) k / fact k" by simp
      also have "\<dots> = (-1)^k * (of_int (pochhammer (- int n) k)) / (of_int (fact k))"
        by (simp only: of_int_fact pochhammer_of_int)
      also have "\<dots> = (of_int ((-1)^k * pochhammer (- int n) k)) / (of_int (fact k))" by simp
      finally show "of_int ((- 1) ^ k * pochhammer (- int n) k div fact k) =
                    of_int ((- 1) ^ k * pochhammer (- int n) k) / rat_of_int (fact k)" .
    qed
    thus ?thesis unfolding a by (metis dvdI dvd_mult_unit_iff' minus_one_mult_self)
  qed
qed

lemma gbinomial_int_negated_upper: "(a gchoose k) = (-1) ^ k * ((int k - a - 1) gchoose k)"
  by (simp add: gbinomial_int_pochhammer pochhammer_minus algebra_simps fact_dvd_pochhammer div_mult_swap)

lemma gbinomial_int_mult_fact: "fact k * (a gchoose k) = (\<Prod>i = 0..<k. a - int i)"
  by (simp only: gbinomial_int_pochhammer' fact_dvd_pochhammer dvd_mult_div_cancel falling_fact_pochhammer')

corollary gbinomial_int_mult_fact': "(a gchoose k) * fact k = (\<Prod>i = 0..<k. a - int i)"
  using gbinomial_int_mult_fact[of k a] by (simp add: ac_simps)

lemma gbinomial_int_binomial:
  "a gchoose k = (if 0 \<le> a then int ((nat a) choose k) else (-1::int)^k * int ((k + (nat (- a)) - 1) choose k))"
  by (auto simp: int_binomial gbinomial_int_negated_upper[of a] int_ops(6))

corollary gbinomial_nneg: "0 \<le> a \<Longrightarrow> a gchoose k = int ((nat a) choose k)"
  by (simp add: gbinomial_int_binomial)

corollary gbinomial_neg: "a < 0 \<Longrightarrow> a gchoose k = (-1::int)^k * int ((k + (nat (- a)) - 1) choose k)"
  by (simp add: gbinomial_int_binomial)

lemma of_int_gbinomial: "of_int (a gchoose k) = (of_int a :: 'a::field_char_0) gchoose k"
proof -
  have of_int_div: "y dvd x \<Longrightarrow> of_int (x div y) = of_int x / (of_int y :: 'a)" for x y :: int by auto
  show ?thesis
    by (simp add: gbinomial_int_pochhammer' gbinomial_pochhammer' of_int_div fact_dvd_pochhammer
        pochhammer_of_int[symmetric])
qed

lemma uminus_one_gbinomial [simp]: "(- 1::int) gchoose k = (- 1) ^ k"
  by (simp add: gbinomial_int_binomial)

lemma gbinomial_int_Suc_Suc: "(x + 1::int) gchoose (Suc k) = (x gchoose k) + (x gchoose (Suc k))"
proof (rule linorder_cases)
  assume 1: "x + 1 < 0"
  hence 2: "x < 0" by simp
  then obtain n where 3: "nat (- x) = Suc n" using not0_implies_Suc by fastforce
  hence 4: "nat (- x - 1) = n" by simp
  show ?thesis
  proof (cases k)
    case 0
    show ?thesis by (simp add: \<open>k = 0\<close>)
  next
    case (Suc k')
    from 1 2 3 4 show ?thesis by (simp add: \<open>k = Suc k'\<close> gbinomial_int_binomial int_distrib(2))
  qed
next
  assume "x + 1 = 0"
  hence "x = - 1" by simp
  thus ?thesis by simp
next
  assume "0 < x + 1"
  hence "0 \<le> x + 1" and "0 \<le> x" and "nat (x + 1) = Suc (nat x)" by simp_all
  thus ?thesis by (simp add: gbinomial_int_binomial)
qed

corollary plus_Suc_gbinomial:
  "(x + (1 + int k)) gchoose (Suc k) = ((x + int k) gchoose k) + ((x + int k) gchoose (Suc k))"
    (is "?l = ?r")
proof -
  have "?l = (x + int k + 1) gchoose (Suc k)" by (simp only: ac_simps)
  also have "\<dots> = ?r" by (fact gbinomial_int_Suc_Suc)
  finally show ?thesis .
qed

lemma gbinomial_int_n_n [simp]: "(int n) gchoose n = 1"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc n)
  have "int (Suc n) gchoose Suc n = (int n + 1) gchoose Suc n" by (simp add: add.commute)
  also have "\<dots> = (int n gchoose n) + (int n gchoose (Suc n))" by (fact gbinomial_int_Suc_Suc)
  finally show ?case by (simp add: Suc gbinomial_eq_0)
qed

lemma gbinomial_int_Suc_n [simp]: "(1 + int n) gchoose n = 1 + int n"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc n)
  have "1 + int (Suc n) gchoose Suc n = (1 + int n) + 1 gchoose Suc n" by simp
  also have "\<dots> = (1 + int n gchoose n) + (1 + int n gchoose (Suc n))" by (fact gbinomial_int_Suc_Suc)
  also have "\<dots> = 1 + int n + (int (Suc n) gchoose (Suc n))" by (simp add: Suc)
  also have "\<dots> = 1 + int (Suc n)" by (simp only: gbinomial_int_n_n)
  finally show ?case .
qed

lemma zbinomial_eq_0_iff [simp]: "a gchoose k = 0 \<longleftrightarrow> (0 \<le> a \<and> a < int k)"
proof
  assume a: "a gchoose k = 0"
  have 1: "b < int k" if "b gchoose k = 0" for b
  proof (rule ccontr)
    assume "\<not> b < int k"
    hence "0 \<le> b" and "k \<le> nat b" by simp_all
    from this(1) have "int ((nat b) choose k) = b gchoose k" by (simp add: gbinomial_int_binomial)
    also have "\<dots> = 0" by (fact that)
    finally show False using \<open>k \<le> nat b\<close> by simp
  qed
  show "0 \<le> a \<and> a < int k"
  proof
    show "0 \<le> a"
    proof (rule ccontr)
      assume "\<not> 0 \<le> a"
      hence "(-1) ^ k * ((int k - a - 1) gchoose k) = a gchoose k"
        by (simp add: gbinomial_int_negated_upper[of a])
      also have "\<dots> = 0" by (fact a)
      finally have "(int k - a - 1) gchoose k = 0" by simp
      hence "int k - a - 1 < int k" by (rule 1)
      with \<open>\<not> 0 \<le> a\<close> show False by simp
    qed
  next
    from a show "a < int k" by (rule 1)
  qed
qed (auto intro: gbinomial_eq_0)

subsection \<open>Sums\<close>

lemma gchoose_rising_sum_nat: "(\<Sum>j\<le>n. int j + int k gchoose k) = (int n + int k + 1) gchoose (Suc k)"
proof -
  have "(\<Sum>j\<le>n. int j + int k gchoose k) = int (\<Sum>j\<le>n. k + j choose k)"
    by (simp add: int_binomial add.commute)
  also have "(\<Sum>j\<le>n. k + j choose k) = (k + n + 1) choose (k + 1)" by (fact choose_rising_sum(1))
  also have "int \<dots> = (int n + int k + 1) gchoose (Suc k)"
    by (simp add: int_binomial ac_simps del: binomial_Suc_Suc)
  finally show ?thesis .
qed

lemma gchoose_rising_sum:
  assumes "0 \<le> n"   \<comment>\<open>Necessary condition.\<close>
  shows "(\<Sum>j=0..n. j + int k gchoose k) = (n + int k + 1) gchoose (Suc k)"
proof -
  from _ refl have "(\<Sum>j=0..n. j + int k gchoose k) = (\<Sum>j\<in>int ` {0..nat n}. j + int k gchoose k)"
  proof (rule sum.cong)
    from assms show "{0..n} = int ` {0..nat n}" by (simp add: image_int_atLeastAtMost)
  qed
  also have "\<dots> = (\<Sum>j\<le>nat n. int j + int k gchoose k)" by (simp add: sum.reindex atMost_atLeast0)
  also have "\<dots> = (int (nat n) + int k + 1) gchoose (Suc k)" by (fact gchoose_rising_sum_nat)
  also from assms have "\<dots> = (n + int k + 1) gchoose (Suc k)" by (simp add: add.assoc add.commute)
  finally show ?thesis .
qed

subsection \<open>Inequalities\<close>

lemma binomial_mono:
  assumes "m \<le> n"
  shows "m choose k \<le> n choose k"
proof -
  define l where "l = n - m"
  with assms have n: "n = m + l" by simp
  have "m choose k \<le> (m + l) choose k"
  proof (induct l)
    case 0
    show ?case by simp
  next
    case *: (Suc l)
    show ?case
    proof (cases k)
      case 0
      thus ?thesis by simp
    next
      case k: (Suc k0)
      note *
      also have "m + l choose k \<le> m + l choose k + (m + l choose k0)" by simp
      also have "\<dots> = m + Suc l choose k" by (simp add: k)
      finally show ?thesis .
    qed
  qed
  thus ?thesis by (simp only: n)
qed

lemma binomial_plus_le:
  assumes "0 < k"
  shows "(m choose k) + (n choose k) \<le> (m + n) choose k"
proof -
  define k0 where "k0 = k - 1"
  with assms have k: "k = Suc k0" by simp
  show ?thesis unfolding k
  proof (induct n)
    case 0
    show ?case by simp
  next
    case (Suc n)
    have "m choose Suc k0 + (Suc n choose Suc k0) = m choose Suc k0 + (n choose Suc k0) + (n choose k0)"
      by (simp only: binomial_Suc_Suc)
    also from Suc have "\<dots> \<le> (m + n) choose Suc k0 + ((m + n) choose k0)"
    proof (rule add_mono)
      have "n \<le> m + n" by simp
      thus "n choose k0 \<le> m + n choose k0" by (rule binomial_mono)
    qed
    also have "\<dots> = m + Suc n choose Suc k0" by simp
    finally show ?case .
  qed
qed

lemma gbinomial_int_nonneg:
  assumes "0 \<le> (x::int)"
  shows "0 \<le> x gchoose k"
proof -
  have "0 \<le> int (nat x choose k)" by simp
  also from assms have "\<dots> = x gchoose k" by (simp add: int_binomial)
  finally show ?thesis .
qed

lemma gbinomial_int_mono:
  assumes "0 \<le> x" and "x \<le> (y::int)"
  shows "x gchoose k \<le> y gchoose k"
proof -
  from assms have "nat x \<le> nat y" by simp
  hence "nat x choose k \<le> nat y choose k" by (rule binomial_mono)
  hence "int (nat x choose k) \<le> int (nat y choose k)" by (simp only: zle_int)
  hence "int (nat x) gchoose k \<le> int (nat y) gchoose k" by (simp only: int_binomial)
  with assms show ?thesis by simp
qed

lemma gbinomial_int_plus_le:
  assumes "0 < k" and "0 \<le> x" and "0 \<le> (y::int)"
  shows "(x gchoose k) + (y gchoose k) \<le> (x + y) gchoose k"
proof -
  from assms(1) have "nat x choose k + (nat y choose k) \<le> nat x + nat y choose k"
    by (rule binomial_plus_le)
  hence "int (nat x choose k + (nat y choose k)) \<le> int (nat x + nat y choose k)"
    by (simp only: zle_int)
  hence "int (nat x) gchoose k + (int (nat y) gchoose k) \<le> int (nat x) + int (nat y) gchoose k"
    by (simp only: int_plus int_binomial)
  with assms(2, 3) show ?thesis by simp
qed

lemma binomial_int_ineq_1:
  assumes "0 \<le> x" and "0 \<le> (y::int)"
  shows "2 * (x + y gchoose k) \<le> x gchoose k + ((x + 2 * y) gchoose k)"
proof -
  from binomial_ineq_1[of "nat x" "nat y" k]
  have "int (2 * (nat x + nat y choose k)) \<le> int (nat x choose k + (nat x + 2 * nat y choose k))"
    by (simp only: zle_int)
  hence "2 * (int (nat x) + int (nat y) gchoose k) \<le> int (nat x) gchoose k + (int (nat x) + 2 * int (nat y) gchoose k)"
    by (simp only: int_binomial int_plus int_ops(7)) simp
  with assms show ?thesis by simp
qed

corollary binomial_int_ineq_2:
  assumes "0 \<le> y" and "y \<le> (x::int)"
  shows "2 * (x gchoose k) \<le> x - y gchoose k + (x + y gchoose k)"
proof -
  from assms(2) have "0 \<le> x - y" by simp
  hence "2 * ((x - y) + y gchoose k) \<le> x - y gchoose k + ((x - y + 2 * y) gchoose k)"
    using assms(1) by (rule binomial_int_ineq_1)
  thus ?thesis by smt
qed

corollary binomial_int_ineq_3:
  assumes "0 \<le> y" and "y \<le> 2 * (x::int)"
  shows "2 * (x gchoose k) \<le> y gchoose k + (2 * x - y gchoose k)"
proof (cases "y \<le> x")
  case True
  hence "0 \<le> x - y" by simp
  moreover from assms(1) have "x - y \<le> x" by simp
  ultimately have "2 * (x gchoose k) \<le> x - (x - y) gchoose k + (x + (x - y) gchoose k)"
    by (rule binomial_int_ineq_2)
  thus ?thesis by simp
next
  case False
  hence "0 \<le> y - x" by simp
  moreover from assms(2) have "y - x \<le> x" by simp
  ultimately have "2 * (x gchoose k) \<le> x - (y - x) gchoose k + (x + (y - x) gchoose k)"
    by (rule binomial_int_ineq_2)
  thus ?thesis by simp
qed

subsection \<open>Backward Difference Operator\<close>

definition bw_diff :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a::{ab_group_add,one}"
  where "bw_diff f x = f x - f (x - 1)"

lemma bw_diff_const [simp]: "bw_diff (\<lambda>_. c) = (\<lambda>_. 0)"
  by (rule ext) (simp add: bw_diff_def)

lemma bw_diff_id [simp]: "bw_diff (\<lambda>x. x) = (\<lambda>_. 1)"
  by (rule ext) (simp add: bw_diff_def)

lemma bw_diff_plus [simp]: "bw_diff (\<lambda>x. f x + g x) = (\<lambda>x. bw_diff f x + bw_diff g x)"
  by (rule ext) (simp add: bw_diff_def)

lemma bw_diff_uminus [simp]: "bw_diff (\<lambda>x. - f x) = (\<lambda>x. - bw_diff f x)"
  by (rule ext) (simp add: bw_diff_def)

lemma bw_diff_minus [simp]: "bw_diff (\<lambda>x. f x - g x) = (\<lambda>x. bw_diff f x - bw_diff g x)"
  by (rule ext) (simp add: bw_diff_def)

lemma bw_diff_const_pow: "(bw_diff ^^ k) (\<lambda>_. c) = (if k = 0 then \<lambda>_. c else (\<lambda>_. 0))"
  by (induct k, simp_all)

lemma bw_diff_id_pow:
  "(bw_diff ^^ k) (\<lambda>x. x) = (if k = 0 then (\<lambda>x. x) else if k = 1 then (\<lambda>_. 1) else (\<lambda>_. 0))"
  by (induct k, simp_all)

lemma bw_diff_plus_pow [simp]:
  "(bw_diff ^^ k) (\<lambda>x. f x + g x) = (\<lambda>x. (bw_diff ^^ k) f x + (bw_diff ^^ k) g x)"
  by (induct k, simp_all)

lemma bw_diff_uminus_pow [simp]: "(bw_diff ^^ k) (\<lambda>x. - f x) = (\<lambda>x. - (bw_diff ^^ k) f x)"
  by (induct k, simp_all)

lemma bw_diff_minus_pow [simp]:
  "(bw_diff ^^ k) (\<lambda>x. f x - g x) = (\<lambda>x. (bw_diff ^^ k) f x - (bw_diff ^^ k) g x)"
  by (induct k, simp_all)

lemma bw_diff_sum_pow [simp]:
  "(bw_diff ^^ k) (\<lambda>x. (\<Sum>i\<in>I. f i x)) = (\<lambda>x. (\<Sum>i\<in>I. (bw_diff ^^ k) (f i) x))"
  by (induct I rule: infinite_finite_induct, simp_all add: bw_diff_const_pow)

lemma bw_diff_gbinomial:
  assumes "0 < k"
  shows "bw_diff (\<lambda>x::int. (x + n) gchoose k) = (\<lambda>x. (x + n - 1) gchoose (k - 1))"
proof (rule ext)
  fix x::int
  from assms have eq: "Suc (k - Suc 0) = k" by simp
  have "x + n gchoose k = (x + n - 1) + 1 gchoose (Suc (k - 1))" by (simp add: eq)
  also have "\<dots> = (x + n - 1) gchoose (k - 1) + ((x + n - 1) gchoose (Suc (k - 1)))"
    by (fact gbinomial_int_Suc_Suc)
  finally show "bw_diff (\<lambda>x. x + n gchoose k) x = x + n - 1 gchoose (k - 1)"
    by (simp add: eq bw_diff_def algebra_simps)
qed

lemma bw_diff_gbinomial_pow:
  "(bw_diff ^^ l) (\<lambda>x::int. (x + n) gchoose k) =
      (if l \<le> k then (\<lambda>x. (x + n - int l) gchoose (k - l)) else (\<lambda>_. 0))"
proof -
  have *: "l0 \<le> k \<Longrightarrow> (bw_diff ^^ l0) (\<lambda>x::int. (x + n) gchoose k) = (\<lambda>x. (x + n - int l0) gchoose (k - l0))"
    for l0
  proof (induct l0)
    case 0
    show ?case by simp
  next
    case (Suc l0)
    from Suc.prems have "0 < k - l0" and "l0 \<le> k" by simp_all
    from this(2) have eq: "(bw_diff ^^ l0) (\<lambda>x. x + n gchoose k) = (\<lambda>x. x + n - int l0 gchoose (k - l0))"
      by (rule Suc.hyps)
    have "(bw_diff ^^ Suc l0) (\<lambda>x. x + n gchoose k) = bw_diff (\<lambda>x. x + (n - int l0) gchoose (k - l0))"
      by (simp add: eq algebra_simps)
    also from \<open>0 < k - l0\<close> have "\<dots> = (\<lambda>x. (x + (n - int l0) - 1) gchoose (k - l0 - 1))"
      by (rule bw_diff_gbinomial)
    also have "\<dots> = (\<lambda>x. x + n - int (Suc l0) gchoose (k - Suc l0))" by (simp add: algebra_simps)
    finally show ?case .
  qed
  show ?thesis
  proof (simp add: * split: if_split, intro impI)
    assume "\<not> l \<le> k"
    hence "(l - k) + k = l" and "l - k \<noteq> 0" by simp_all
    hence "(bw_diff ^^ l) (\<lambda>x. x + n gchoose k) = (bw_diff ^^ ((l - k) + k)) (\<lambda>x. x + n gchoose k)"
      by (simp only:)
    also have "\<dots> = (bw_diff ^^ (l - k)) (\<lambda>_. 1)" by (simp add: * funpow_add)
    also from \<open>l - k \<noteq> 0\<close> have "\<dots> = (\<lambda>_. 0)" by (simp add: bw_diff_const_pow)
    finally show "(bw_diff ^^ l) (\<lambda>x. x + n gchoose k) = (\<lambda>_. 0)" .
  qed
qed

end (* theory *)


(*  Title:      HOL/Library/Inner_Product.thy
    Author:     Brian Huffman
*)

section {* Inner Product Spaces and the Gradient Derivative *}

theory Inner_Product
imports "~~/src/HOL/Complex_Main"
begin

subsection {* Real inner product spaces *}

text {*
  Temporarily relax type constraints for @{term "open"},
  @{term dist}, and @{term norm}.
*}

setup {* Sign.add_const_constraint
  (@{const_name "open"}, SOME @{typ "'a::open set \<Rightarrow> bool"}) *}

setup {* Sign.add_const_constraint
  (@{const_name dist}, SOME @{typ "'a::dist \<Rightarrow> 'a \<Rightarrow> real"}) *}

setup {* Sign.add_const_constraint
  (@{const_name norm}, SOME @{typ "'a::norm \<Rightarrow> real"}) *}

class real_inner = real_vector + sgn_div_norm + dist_norm + open_dist +
  fixes inner :: "'a \<Rightarrow> 'a \<Rightarrow> real"
  assumes inner_commute: "inner x y = inner y x"
  and inner_add_left: "inner (x + y) z = inner x z + inner y z"
  and inner_scaleR_left [simp]: "inner (scaleR r x) y = r * (inner x y)"
  and inner_ge_zero [simp]: "0 \<le> inner x x"
  and inner_eq_zero_iff [simp]: "inner x x = 0 \<longleftrightarrow> x = 0"
  and norm_eq_sqrt_inner: "norm x = sqrt (inner x x)"
begin

lemma inner_zero_left [simp]: "inner 0 x = 0"
  using inner_add_left [of 0 0 x] by simp

lemma inner_minus_left [simp]: "inner (- x) y = - inner x y"
  using inner_add_left [of x "- x" y] by simp

lemma inner_diff_left: "inner (x - y) z = inner x z - inner y z"
  using inner_add_left [of x "- y" z] by simp

lemma inner_setsum_left: "inner (\<Sum>x\<in>A. f x) y = (\<Sum>x\<in>A. inner (f x) y)"
  by (cases "finite A", induct set: finite, simp_all add: inner_add_left)

text {* Transfer distributivity rules to right argument. *}

lemma inner_add_right: "inner x (y + z) = inner x y + inner x z"
  using inner_add_left [of y z x] by (simp only: inner_commute)

lemma inner_scaleR_right [simp]: "inner x (scaleR r y) = r * (inner x y)"
  using inner_scaleR_left [of r y x] by (simp only: inner_commute)

lemma inner_zero_right [simp]: "inner x 0 = 0"
  using inner_zero_left [of x] by (simp only: inner_commute)

lemma inner_minus_right [simp]: "inner x (- y) = - inner x y"
  using inner_minus_left [of y x] by (simp only: inner_commute)

lemma inner_diff_right: "inner x (y - z) = inner x y - inner x z"
  using inner_diff_left [of y z x] by (simp only: inner_commute)

lemma inner_setsum_right: "inner x (\<Sum>y\<in>A. f y) = (\<Sum>y\<in>A. inner x (f y))"
  using inner_setsum_left [of f A x] by (simp only: inner_commute)

lemmas inner_add [algebra_simps] = inner_add_left inner_add_right
lemmas inner_diff [algebra_simps]  = inner_diff_left inner_diff_right
lemmas inner_scaleR = inner_scaleR_left inner_scaleR_right

text {* Legacy theorem names *}
lemmas inner_left_distrib = inner_add_left
lemmas inner_right_distrib = inner_add_right
lemmas inner_distrib = inner_left_distrib inner_right_distrib

lemma inner_gt_zero_iff [simp]: "0 < inner x x \<longleftrightarrow> x \<noteq> 0"
  by (simp add: order_less_le)

lemma power2_norm_eq_inner: "(norm x)\<^sup>2 = inner x x"
  by (simp add: norm_eq_sqrt_inner)

lemma Cauchy_Schwarz_ineq2:
  "\<bar>inner x y\<bar> \<le> norm x * norm y"
proof (rule power2_le_imp_le)
  have "(inner x y)\<^sup>2 \<le> inner x x * inner y y"
    using Cauchy_Schwarz_ineq .
  thus "\<bar>inner x y\<bar>\<^sup>2 \<le> (norm x * norm y)\<^sup>2"
    by (simp add: power_mult_distrib power2_norm_eq_inner)
  show "0 \<le> norm x * norm y"
    unfolding norm_eq_sqrt_inner
    by (intro mult_nonneg_nonneg real_sqrt_ge_zero inner_ge_zero)
qed

lemma norm_cauchy_schwarz: "inner x y \<le> norm x * norm y"
  using Cauchy_Schwarz_ineq2 [of x y] by auto

subclass real_normed_vector
proof
  fix a :: real and x y :: 'a
  show "norm x = 0 \<longleftrightarrow> x = 0"
    unfolding norm_eq_sqrt_inner by simp
  show "norm (x + y) \<le> norm x + norm y"
    proof (rule power2_le_imp_le)
      have "inner x y \<le> norm x * norm y"
        by (rule norm_cauchy_schwarz)
      thus "(norm (x + y))\<^sup>2 \<le> (norm x + norm y)\<^sup>2"
        unfolding power2_sum power2_norm_eq_inner
        by (simp add: inner_add inner_commute)
      show "0 \<le> norm x + norm y"
        unfolding norm_eq_sqrt_inner by simp
    qed
  have "sqrt (a\<^sup>2 * inner x x) = \<bar>a\<bar> * sqrt (inner x x)"
    by (simp add: real_sqrt_mult_distrib)
  then show "norm (a *\<^sub>R x) = \<bar>a\<bar> * norm x"
    unfolding norm_eq_sqrt_inner
    by (simp add: power2_eq_square mult.assoc)
qed

end

text {*
  Re-enable constraints for @{term "open"},
  @{term dist}, and @{term norm}.
*}

setup {* Sign.add_const_constraint
  (@{const_name "open"}, SOME @{typ "'a::topological_space set \<Rightarrow> bool"}) *}

setup {* Sign.add_const_constraint
  (@{const_name dist}, SOME @{typ "'a::metric_space \<Rightarrow> 'a \<Rightarrow> real"}) *}

setup {* Sign.add_const_constraint
  (@{const_name norm}, SOME @{typ "'a::real_normed_vector \<Rightarrow> real"}) *}

lemma bounded_bilinear_inner:
  "bounded_bilinear (inner::'a::real_inner \<Rightarrow> 'a \<Rightarrow> real)"
proof
  fix x y z :: 'a and r :: real
  show "inner (x + y) z = inner x z + inner y z"
    by (rule inner_add_left)
  show "inner x (y + z) = inner x y + inner x z"
    by (rule inner_add_right)
  show "inner (scaleR r x) y = scaleR r (inner x y)"
    unfolding real_scaleR_def by (rule inner_scaleR_left)
  show "inner x (scaleR r y) = scaleR r (inner x y)"
    unfolding real_scaleR_def by (rule inner_scaleR_right)
  show "\<exists>K. \<forall>x y::'a. norm (inner x y) \<le> norm x * norm y * K"
  proof
    show "\<forall>x y::'a. norm (inner x y) \<le> norm x * norm y * 1"
      by (simp add: Cauchy_Schwarz_ineq2)
  qed
qed

lemmas tendsto_inner [tendsto_intros] =
  bounded_bilinear.tendsto [OF bounded_bilinear_inner]

lemmas isCont_inner [simp] =
  bounded_bilinear.isCont [OF bounded_bilinear_inner]

lemmas has_derivative_inner [derivative_intros] =
  bounded_bilinear.FDERIV [OF bounded_bilinear_inner]

lemmas bounded_linear_inner_left =
  bounded_bilinear.bounded_linear_left [OF bounded_bilinear_inner]

lemmas bounded_linear_inner_right =
  bounded_bilinear.bounded_linear_right [OF bounded_bilinear_inner]

lemmas has_derivative_inner_right [derivative_intros] =
  bounded_linear.has_derivative [OF bounded_linear_inner_right]

lemmas has_derivative_inner_left [derivative_intros] =
  bounded_linear.has_derivative [OF bounded_linear_inner_left]

lemma differentiable_inner [simp]:
  "f differentiable (at x within s) \<Longrightarrow> g differentiable at x within s \<Longrightarrow> (\<lambda>x. inner (f x) (g x)) differentiable at x within s"
  unfolding differentiable_def by (blast intro: has_derivative_inner)

subsection {* Class instances *}

instantiation real :: real_inner
begin

definition inner_real_def [simp]: "inner = op *"

instance proof
  fix x y z r :: real
  show "inner x y = inner y x"
    unfolding inner_real_def by (rule mult.commute)
  show "inner (x + y) z = inner x z + inner y z"
    unfolding inner_real_def by (rule distrib_right)
  show "inner (scaleR r x) y = r * inner x y"
    unfolding inner_real_def real_scaleR_def by (rule mult.assoc)
  show "0 \<le> inner x x"
    unfolding inner_real_def by simp
  show "inner x x = 0 \<longleftrightarrow> x = 0"
    unfolding inner_real_def by simp
  show "norm x = sqrt (inner x x)"
    unfolding inner_real_def by simp
qed

end

instantiation complex :: real_inner
begin

definition inner_complex_def:
  "inner x y = Re x * Re y + Im x * Im y"

instance proof
  fix x y z :: complex and r :: real
  show "inner x y = inner y x"
    unfolding inner_complex_def by (simp add: mult.commute)
  show "inner (x + y) z = inner x z + inner y z"
    unfolding inner_complex_def by (simp add: distrib_right)
  show "inner (scaleR r x) y = r * inner x y"
    unfolding inner_complex_def by (simp add: distrib_left)
  show "0 \<le> inner x x"
    unfolding inner_complex_def by simp
  show "inner x x = 0 \<longleftrightarrow> x = 0"
    unfolding inner_complex_def
    by (simp add: add_nonneg_eq_0_iff complex_Re_Im_cancel_iff)
  show "norm x = sqrt (inner x x)"
    unfolding inner_complex_def complex_norm_def
    by (simp add: power2_eq_square)
qed

end

lemma complex_inner_1 [simp]: "inner 1 x = Re x"
  unfolding inner_complex_def by simp

lemma complex_inner_1_right [simp]: "inner x 1 = Re x"
  unfolding inner_complex_def by simp

lemma complex_inner_ii_left [simp]: "inner ii x = Im x"
  unfolding inner_complex_def by simp

lemma complex_inner_ii_right [simp]: "inner x ii = Im x"
  unfolding inner_complex_def by simp

subsection {* Gradient derivative *}

definition
  gderiv ::
    "['a::real_inner \<Rightarrow> real, 'a, 'a] \<Rightarrow> bool"
          ("(GDERIV (_)/ (_)/ :> (_))" [1000, 1000, 60] 60)
where
  "GDERIV f x :> D \<longleftrightarrow> FDERIV f x :> (\<lambda>h. inner h D)"

lemma gderiv_deriv [simp]: "GDERIV f x :> D \<longleftrightarrow> DERIV f x :> D"
  by (simp only: gderiv_def has_field_derivative_def inner_real_def mult_commute_abs)

lemma GDERIV_DERIV_compose:
    "\<lbrakk>GDERIV f x :> df; DERIV g (f x) :> dg\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. g (f x)) x :> scaleR dg df"
  unfolding gderiv_def has_field_derivative_def
  apply (drule (1) has_derivative_compose)
  apply (simp add: ac_simps)
  done

lemma has_derivative_subst: "\<lbrakk>FDERIV f x :> df; df = d\<rbrakk> \<Longrightarrow> FDERIV f x :> d"
  by simp

lemma GDERIV_subst: "\<lbrakk>GDERIV f x :> df; df = d\<rbrakk> \<Longrightarrow> GDERIV f x :> d"
  by simp

lemma GDERIV_const: "GDERIV (\<lambda>x. k) x :> 0"
  unfolding gderiv_def inner_zero_right by (rule has_derivative_const)

lemma GDERIV_add:
    "\<lbrakk>GDERIV f x :> df; GDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. f x + g x) x :> df + dg"
  unfolding gderiv_def inner_add_right by (rule has_derivative_add)

lemma GDERIV_minus:
    "GDERIV f x :> df \<Longrightarrow> GDERIV (\<lambda>x. - f x) x :> - df"
  unfolding gderiv_def inner_minus_right by (rule has_derivative_minus)

lemma GDERIV_diff:
    "\<lbrakk>GDERIV f x :> df; GDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. f x - g x) x :> df - dg"
  unfolding gderiv_def inner_diff_right by (rule has_derivative_diff)

lemma GDERIV_scaleR:
    "\<lbrakk>DERIV f x :> df; GDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. scaleR (f x) (g x)) x
      :> (scaleR (f x) dg + scaleR df (g x))"
  unfolding gderiv_def has_field_derivative_def inner_add_right inner_scaleR_right
  apply (rule has_derivative_subst)
  apply (erule (1) has_derivative_scaleR)
  apply (simp add: ac_simps)
  done

lemma GDERIV_mult:
    "\<lbrakk>GDERIV f x :> df; GDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. f x * g x) x :> scaleR (f x) dg + scaleR (g x) df"
  unfolding gderiv_def
  apply (rule has_derivative_subst)
  apply (erule (1) has_derivative_mult)
  apply (simp add: inner_add ac_simps)
  done

lemma GDERIV_inverse:
    "\<lbrakk>GDERIV f x :> df; f x \<noteq> 0\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. inverse (f x)) x :> - (inverse (f x))\<^sup>2 *\<^sub>R df"
  apply (erule GDERIV_DERIV_compose)
  apply (erule DERIV_inverse [folded numeral_2_eq_2])
  done

lemma GDERIV_norm:
  assumes "x \<noteq> 0" shows "GDERIV (\<lambda>x. norm x) x :> sgn x"
proof -
  have 1: "FDERIV (\<lambda>x. inner x x) x :> (\<lambda>h. inner x h + inner h x)"
    by (intro has_derivative_inner has_derivative_ident)
  have 2: "(\<lambda>h. inner x h + inner h x) = (\<lambda>h. inner h (scaleR 2 x))"
    by (simp add: fun_eq_iff inner_commute)
  have "0 < inner x x" using `x \<noteq> 0` by simp
  then have 3: "DERIV sqrt (inner x x) :> (inverse (sqrt (inner x x)) / 2)"
    by (rule DERIV_real_sqrt)
  have 4: "(inverse (sqrt (inner x x)) / 2) *\<^sub>R 2 *\<^sub>R x = sgn x"
    by (simp add: sgn_div_norm norm_eq_sqrt_inner)
  show ?thesis
    unfolding norm_eq_sqrt_inner
    apply (rule GDERIV_subst [OF _ 4])
    apply (rule GDERIV_DERIV_compose [where g=sqrt and df="scaleR 2 x"])
    apply (subst gderiv_def)
    apply (rule has_derivative_subst [OF _ 2])
    apply (rule 1)
    apply (rule 3)
    done
qed

lemmas has_derivative_norm = GDERIV_norm [unfolded gderiv_def]

end


theory WordInterval_Lists
imports "../../IP_Addresses/WordInterval"
  Negation_Type
begin

fun l2wi_negation_type_union :: "('a::len word \<times> 'a::len word) negation_type list \<Rightarrow> 'a::len wordinterval" where
  "l2wi_negation_type_union [] = Empty_WordInterval" |
  "l2wi_negation_type_union ((Pos (s,e))#ls) = wordinterval_union (WordInterval s e) (l2wi_negation_type_union ls)" |
  "l2wi_negation_type_union ((Neg (s,e))#ls) = wordinterval_union (wordinterval_invert (WordInterval s e)) (l2wi_negation_type_union ls)"

lemma l2wi_negation_type_union: "wordinterval_to_set (l2wi_negation_type_union l) =
                      (\<Union> (i,j) \<in> set (getPos l). {i .. j}) \<union> (\<Union> (i,j) \<in> set (getNeg l). - {i .. j})"
apply(simp add: l2wi)
apply(induction l rule: l2wi_negation_type_union.induct)
  apply(simp_all)
 apply fast+
done

definition l2wi_intersect :: "('a::len word \<times> 'a::len word) list \<Rightarrow> 'a::len wordinterval" where
  "l2wi_intersect = foldl (\<lambda> acc (s,e). wordinterval_intersection (WordInterval s e) acc) wordinterval_UNIV"

lemma l2wi_intersect: "wordinterval_to_set (l2wi_intersect l) = (\<Inter> (i,j) \<in> set l. {i .. j})"
  proof -
  { fix U --\<open>@{const wordinterval_UNIV} generalized\<close>
    have "wordinterval_to_set (foldl (\<lambda>acc (s, e). wordinterval_intersection (WordInterval s e) acc) U l) = (wordinterval_to_set U) \<inter> (\<Inter>(i, j)\<in>set l. {i..j})"
        apply(induction l arbitrary: U)
         apply(simp)
        by force
  } thus ?thesis
    unfolding l2wi_intersect_def by simp
  qed

fun l2wi_negation_type_intersect :: "('a::len word \<times> 'a::len word) negation_type list \<Rightarrow> 'a::len wordinterval" where
  "l2wi_negation_type_intersect [] = wordinterval_UNIV" |
  "l2wi_negation_type_intersect ((Pos (s,e))#ls) = wordinterval_intersection (WordInterval s e) (l2wi_negation_type_intersect ls)" |
  "l2wi_negation_type_intersect ((Neg (s,e))#ls) = wordinterval_intersection (wordinterval_invert (WordInterval s e)) (l2wi_negation_type_intersect ls)"

lemma l2wi_negation_type_intersect_alt: "wordinterval_to_set (l2wi_negation_type_intersect l) =
                wordinterval_to_set (wordinterval_setminus (l2wi_intersect (getPos l)) (l2wi (getNeg l)))"
  apply(simp add: l2wi_intersect l2wi)
  apply(induction l rule :l2wi_negation_type_intersect.induct)
     apply(simp_all)
    apply(fast)+
  done

lemma l2wi_negation_type_intersect: "wordinterval_to_set (l2wi_negation_type_intersect l) =
                      (\<Inter> (i,j) \<in> set (getPos l). {i .. j}) - (\<Union> (i,j) \<in> set (getNeg l). {i .. j})"
  by(simp add: l2wi_negation_type_intersect_alt l2wi_intersect l2wi)

end


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

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

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun insert :: "Nat => Nat list => Nat list" where
"insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
"isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (isort xs) xs"
  oops

end


theory MinimalHEAP0
imports Nat Finite_Set Set_Interval
begin

type_synonym Loc = nat
type_synonym F0 = "Loc set"

definition
  nat1 :: "nat \<Rightarrow> bool"
where
  (*<*) [iff]: (*>*) "nat1 n \<equiv> n > 0"

definition
  locs_of :: "Loc \<Rightarrow> nat \<Rightarrow> (Loc set)"
where
  (*"locs_of l n \<equiv> (if nat1 n then { i. i \<ge> l \<and> i < (l + n) } else undefined)"*)
  "locs_of l n \<equiv> (if nat1 n then {l ..< l+n} else undefined)"

definition
  is_block :: "Loc \<Rightarrow> nat \<Rightarrow> (Loc set) \<Rightarrow> bool"
where
	"is_block l n ls \<equiv> nat1 n \<and> locs_of l n \<subseteq> ls"

definition
  F0_inv :: "F0 \<Rightarrow> bool"
where
  [intro!]: "F0_inv f \<equiv> finite f"

definition
  new0_pre :: "F0 \<Rightarrow> nat \<Rightarrow> bool"
where
  "new0_pre f s \<equiv> (\<exists> l. (is_block l s f))"

definition
   new0_post :: "F0 \<Rightarrow> nat \<Rightarrow> F0 \<Rightarrow> Loc \<Rightarrow> bool"
where
   "new0_post f s f' r \<equiv> (is_block r s f) \<and> f' = f - (locs_of r s)"

definition
   dispose0_pre :: "F0 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> bool"
where
  "dispose0_pre f d s \<equiv> locs_of d s \<inter> f = {}"

definition
   dispose0_post :: "F0 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> F0 \<Rightarrow> bool"
where
   "dispose0_post f d s f' \<equiv> f' = f \<union> locs_of d s"

definition
  PO_new0_fsb :: "bool"
where
  "PO_new0_fsb \<equiv> (\<forall> f s . F0_inv f \<and> nat1 s \<and> new0_pre f s \<longrightarrow>
                        (\<exists> f' r' . new0_post f s f' r' \<and> F0_inv f'))"

definition
  PO_dispose0_fsb :: "bool"
where
  "PO_dispose0_fsb \<equiv> (\<forall> f d s . F0_inv f \<and> nat1 s \<and> dispose0_pre f d s \<longrightarrow>
                        (\<exists> f' . dispose0_post f d s f' \<and> F0_inv f'))"

(*********************************************************************)
section {* Voila! Translate to Haskell please! *}

(*
export_code nat1 locs_of is_block (*F0_inv*) in Haskell module_name MinimalHEAP0 file "haskell/"
*)

lemma "PO_new0_fsb"
unfolding PO_new0_fsb_def
(* (prov_test FEAS new0) and \<not> (prov_test EXPOSE_POST new0) *)
unfolding new0_post_def
(* (prov_test EXPOSE_POST new0) and \<not> (prov_test FULLY_WITNESSED new0) *)
apply simp
(* ONE_POINT_WITNESS? *)
(* INV_BREAK_DOWN? + ONE_POINT_WITNESS *)
unfolding F0_inv_def
apply simp
(* STRUCTURAL_BREAK_DOWN + FULLY_WITNESSED *)
unfolding is_block_def
apply simp
apply (intro allI impI, elim conjE)
oops

lemma "PO_new0_fsb"
unfolding PO_new0_fsb_def
(* (prov_test FEAS new0) and \<not> (prov_test EXPOSE_POST new0) *)
unfolding new0_post_def
(* (prov_test EXPOSE_POST new0) and \<not> (prov_test FULLY_WITNESSED new0) *)
apply simp
(* ONE_POINT_WITNESS? *)
(* INV_BREAK_DOWN? + ONE_POINT_WITNESS *)
unfolding F0_inv_def
apply simp
(* EXPOSE_PRE + STRUCTURAL_BREAKDOWN *)
unfolding new0_pre_def
apply (intro allI impI, elim conjE exE)
(* FULLY_WITNESSED *)
apply (intro exI)
apply simp
done

end