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

header "Abstract Separation Logic, Alternative Definition"

theory Separation_Algebra_Alt
imports Main
begin

text {*
  This theory contains an alternative definition of speration algebra,
  following Calcagno et al very closely. While some of the abstract
  development is more algebraic, it is cumbersome to instantiate.
  We only use it to prove equivalence and to give an impression of how
  it would look like.
*}

(* The @{text "++"} notation is a horrible choice, but this theory is
   only intended to show how the development would look like, not to
   actually use it. We remove the notation for map-add so it doesn't
   conflict.
*)
no_notation map_add (infixl "++" 100)

definition
  lift2 :: "('a => 'b => 'c option) \<Rightarrow> 'a option => 'b option => 'c option"
where
  "lift2 f a b \<equiv> case (a,b) of (Some a, Some b) \<Rightarrow> f a b | _ \<Rightarrow> None"

class sep_algebra_alt = zero +
  fixes add :: "'a => 'a => 'a option" (infixr "\<oplus>" 65)

  assumes add_zero [simp]: "x \<oplus> 0 = Some x"
  assumes add_comm: "x \<oplus> y = y \<oplus> x"
  assumes add_assoc: "lift2 add a (lift2 add b c) = lift2 add (lift2 add a b) c"

begin

definition
  disjoint :: "'a => 'a => bool" (infix "##" 60)
where
  "a ## b \<equiv> a \<oplus> b \<noteq> None"

lemma disj_com: "x ## y = y ## x"
  by (auto simp: disjoint_def add_comm)

lemma disj_zero [simp]: "x ## 0"
  by (auto simp: disjoint_def)

lemma disj_zero2 [simp]: "0 ## x"
  by (subst disj_com) simp

lemma add_zero2 [simp]: "0 \<oplus> x = Some x"
  by (subst add_comm) auto

definition
  substate :: "'a => 'a => bool" (infix "\<preceq>" 60) where
  "a \<preceq> b \<equiv> \<exists>c. a \<oplus> c = Some b"

definition
  sep_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "**" 61)
  where
  "P ** Q \<equiv> \<lambda>s. \<exists>p q. p \<oplus> q = Some s \<and> P p \<and> Q q"

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

definition
  sep_impl :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixr "\<longrightarrow>\<^sup>*" 25)
  where
  "P \<longrightarrow>\<^sup>* Q \<equiv> \<lambda>h. \<forall>h' h''. h \<oplus> h' = Some h'' \<and> P h' \<longrightarrow> Q h''"

definition
  "sep_true \<equiv> \<lambda>s. True"

definition
  "sep_false \<equiv> \<lambda>s. False"

abbreviation
  add2 :: "'a option => 'a option => 'a option" (infixr "++" 65)
where
  "add2 == lift2 add"

lemma add2_None [simp]:
  "x ++ None = None"
  by (simp add: lift2_def split: option.splits)

lemma None_add2 [simp]:
  "None ++ x = None"
  by (simp add: lift2_def split: option.splits)

lemma add2_Some_Some:
  "Some x ++ Some y = x \<oplus> y"
  by (simp add: lift2_def)

lemma add2_zero [simp]:
  "Some x ++ Some 0 = Some x"
  by (simp add: add2_Some_Some)

lemma zero_add2 [simp]:
  "Some 0 ++ Some x = Some x"
  by (simp add: add2_Some_Some)

lemma sep_conjE:
  "\<lbrakk> (P ** Q) s; \<And>p q. \<lbrakk> P p; Q q; p \<oplus> q = Some s \<rbrakk> \<Longrightarrow> X \<rbrakk> \<Longrightarrow> X"
  by (auto simp: sep_conj_def)

lemma sep_conjI:
  "\<lbrakk> P p; Q q; p \<oplus> q = Some s \<rbrakk> \<Longrightarrow> (P ** Q) s"
  by (auto simp: sep_conj_def)

lemma sep_conj_comI:
  "(P ** Q) s \<Longrightarrow> (Q ** P) s"
  by (auto intro!: sep_conjI elim!: sep_conjE simp: add_comm)

lemma sep_conj_com:
  "P ** Q = Q ** P"
  by (auto intro: sep_conj_comI intro!: ext)

lemma lift_to_add2:
  "\<lbrakk>z \<oplus> q = Some s; x \<oplus> y = Some q\<rbrakk> \<Longrightarrow> Some z ++ Some x ++ Some y = Some s"
  by (simp add: add2_Some_Some)

lemma lift_to_add2':
  "\<lbrakk>q \<oplus> z = Some s; x \<oplus> y = Some q\<rbrakk> \<Longrightarrow> (Some x ++ Some y) ++ Some z = Some s"
  by (simp add: add2_Some_Some)

lemma add2_Some:
  "(x ++ Some y = Some z) = (\<exists>x'. x = Some x' \<and> x' \<oplus> y = Some z)"
  by (simp add: lift2_def split: option.splits)

lemma Some_add2:
  "(Some x ++ y = Some z) = (\<exists>y'. y = Some y' \<and> x \<oplus> y' = Some z)"
  by (simp add: lift2_def split: option.splits)

lemma sep_conj_assoc:
  "P ** (Q ** R) = (P ** Q) ** R"
  unfolding sep_conj_def
  apply (rule ext)
  apply (rule iffI)
   apply clarsimp
   apply (drule (1) lift_to_add2)
   apply (subst (asm) add_assoc)
   apply (fastforce simp: add2_Some_Some add2_Some)
  apply clarsimp
  apply (drule (1) lift_to_add2')
  apply (subst (asm) add_assoc [symmetric])
  apply (fastforce simp: add2_Some_Some Some_add2)
  done

lemma sep_true[simp]: "sep_true s" by (simp add: sep_true_def)
lemma sep_false[simp]: "\<not>sep_false x" by (simp add: sep_false_def)

lemma sep_conj_sep_true:
  "P s \<Longrightarrow> (P ** sep_true) s"
  by (auto simp: sep_conjI [where q=0])

lemma sep_conj_sep_true':
  "P s \<Longrightarrow> (sep_true ** P) s"
  by (auto simp: sep_conjI [where p=0])

lemma disjoint_submaps_exist:
  "\<exists>h\<^sub>0 h\<^sub>1. h\<^sub>0 \<oplus> h\<^sub>1 = Some h"
  by (rule_tac x=0 in exI, auto)

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

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

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

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

lemmas sep_conj_ac = sep_conj_com sep_conj_assoc sep_conj_left_com

lemma empty_empty[simp]: "\<box> 0"
  by (simp add: emp_def)

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

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

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

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

lemma sep_conj_disj:
  "((\<lambda>s. P s \<or> Q s) ** R) s = ((P ** R) s \<or> (Q ** R) s)" (is "?x = (?y \<or> ?z)")
  by (auto simp: sep_conj_def)

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

lemma sep_conj_exists1:
  "((\<lambda>s. \<exists>x. P x s) ** Q) s = (\<exists>x. (P x ** Q) s)"
  by (force intro: sep_conjI elim: sep_conjE)

lemma sep_conj_exists2:
  "(P ** (\<lambda>s. \<exists>x. Q x s)) = (\<lambda>s. (\<exists>x. (P ** Q x) s))"
  by (force intro!: sep_conjI ext elim!: sep_conjE)

lemmas sep_conj_exists = sep_conj_exists1 sep_conj_exists2

lemma sep_conj_forall:
  "((\<lambda>s. \<forall>x. P x s) ** Q) s \<Longrightarrow> (P x ** Q) s"
  by (force intro: sep_conjI elim: sep_conjE)

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

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

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

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

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

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

lemma sep_implD:
  "(x \<longrightarrow>\<^sup>* y) h \<Longrightarrow> \<forall>h' h''. h \<oplus> h' = Some h'' \<and> x h' \<longrightarrow> y h''"
  by (force simp: sep_impl_def)

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

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

lemma sep_impl_sep_true_P:
  "(sep_true \<longrightarrow>\<^sup>* P) s \<Longrightarrow> P s"
  apply (drule sep_implD)
  apply (erule_tac x=0 in allE)
  apply simp
  done

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

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

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

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

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

end

end


theory Demo3 imports Main begin

consts sep :: "'a \<times> 'a list \<Rightarrow> 'a list"
recdef sep "measure (\<lambda>(a, xs). size xs)"
  "sep (a, x#y#zs) = x # a # sep (a,y#zs)"
  "sep (a, xs) = xs"

print_theorems

lemma "map f (sep (x,xs)) = sep (f x, map f xs)"

oops
-- solution

lemma "map f (sep (x,xs)) = sep (f x, map f xs)"
  apply (induct x xs rule: sep.induct)
  apply auto
  done

end


(* Author: Tobias Nipkow *)

theory Abs_Int1_ITP
imports Abs_State_ITP
begin

subsection "Computable Abstract Interpretation"

text{* Abstract interpretation over type @{text st} instead of
functions. *}

context Gamma
begin

fun aval' :: "aexp \<Rightarrow> 'av st \<Rightarrow> 'av" where
"aval' (N n) S = num' n" |
"aval' (V x) S = lookup S x" |
"aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"

lemma aval'_sound: "s : \<gamma>\<^sub>f S \<Longrightarrow> aval a s : \<gamma>(aval' a S)"
by (induction a) (auto simp: gamma_num' gamma_plus' \<gamma>_st_def lookup_def)

end

text{* The for-clause (here and elsewhere) only serves the purpose of fixing
the name of the type parameter @{typ 'av} which would otherwise be renamed to
@{typ 'a}. *}

locale Abs_Int = Gamma where \<gamma>=\<gamma> for \<gamma> :: "'av::SL_top \<Rightarrow> val set"
begin

fun step' :: "'av st option \<Rightarrow> 'av st option acom \<Rightarrow> 'av st option acom" where
"step' S (SKIP {P}) = (SKIP {S})" |
"step' S (x ::= e {P}) =
  x ::= e {case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(update S x (aval' e S))}" |
"step' S (c1;; c2) = step' S c1;; step' (post c1) c2" |
"step' S (IF b THEN c1 ELSE c2 {P}) =
  (let c1' = step' S c1; c2' = step' S c2
   in IF b THEN c1' ELSE c2' {post c1 \<squnion> post c2})" |
"step' S ({Inv} WHILE b DO c {P}) =
   {S \<squnion> post c} WHILE b DO step' Inv c {Inv}"

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI = lpfp\<^sub>c (step' \<top>)"

lemma strip_step'[simp]: "strip(step' S c) = strip c"
by(induct c arbitrary: S) (simp_all add: Let_def)

text{* Soundness: *}

lemma in_gamma_update:
  "\<lbrakk> s : \<gamma>\<^sub>f S; i : \<gamma> a \<rbrakk> \<Longrightarrow> s(x := i) : \<gamma>\<^sub>f(update S x a)"
by(simp add: \<gamma>_st_def lookup_update)

text{* The soundness proofs are textually identical to the ones for the step
function operating on states as functions. *}

lemma step_preserves_le:
  "\<lbrakk> S \<subseteq> \<gamma>\<^sub>o S'; c \<le> \<gamma>\<^sub>c c' \<rbrakk> \<Longrightarrow> step S c \<le> \<gamma>\<^sub>c (step' S' c')"
proof(induction c arbitrary: c' S S')
  case SKIP thus ?case by(auto simp:SKIP_le map_acom_SKIP)
next
  case Assign thus ?case
    by (fastforce simp: Assign_le  map_acom_Assign intro: aval'_sound in_gamma_update
      split: option.splits del:subsetD)
next
  case Seq thus ?case apply (auto simp: Seq_le map_acom_Seq)
    by (metis le_post post_map_acom)
next
  case (If b c1 c2 P)
  then obtain c1' c2' P' where
      "c' = IF b THEN c1' ELSE c2' {P'}"
      "P \<subseteq> \<gamma>\<^sub>o P'" "c1 \<le> \<gamma>\<^sub>c c1'" "c2 \<le> \<gamma>\<^sub>c c2'"
    by (fastforce simp: If_le map_acom_If)
  moreover have "post c1 \<subseteq> \<gamma>\<^sub>o(post c1' \<squnion> post c2')"
    by (metis (no_types) `c1 \<le> \<gamma>\<^sub>c c1'` join_ge1 le_post mono_gamma_o order_trans post_map_acom)
  moreover have "post c2 \<subseteq> \<gamma>\<^sub>o(post c1' \<squnion> post c2')"
    by (metis (no_types) `c2 \<le> \<gamma>\<^sub>c c2'` join_ge2 le_post mono_gamma_o order_trans post_map_acom)
  ultimately show ?case using `S \<subseteq> \<gamma>\<^sub>o S'` by (simp add: If.IH subset_iff)
next
  case (While I b c1 P)
  then obtain c1' I' P' where
    "c' = {I'} WHILE b DO c1' {P'}"
    "I \<subseteq> \<gamma>\<^sub>o I'" "P \<subseteq> \<gamma>\<^sub>o P'" "c1 \<le> \<gamma>\<^sub>c c1'"
    by (fastforce simp: map_acom_While While_le)
  moreover have "S \<union> post c1 \<subseteq> \<gamma>\<^sub>o (S' \<squnion> post c1')"
    using `S \<subseteq> \<gamma>\<^sub>o S'` le_post[OF `c1 \<le> \<gamma>\<^sub>c c1'`, simplified]
    by (metis (no_types) join_ge1 join_ge2 le_sup_iff mono_gamma_o order_trans)
  ultimately show ?case by (simp add: While.IH subset_iff)
qed

lemma AI_sound: "AI c = Some c' \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c c'"
proof(simp add: CS_def AI_def)
  assume 1: "lpfp\<^sub>c (step' \<top>) c = Some c'"
  have 2: "step' \<top> c' \<sqsubseteq> c'" by(rule lpfpc_pfp[OF 1])
  have 3: "strip (\<gamma>\<^sub>c (step' \<top> c')) = c"
    by(simp add: strip_lpfpc[OF _ 1])
  have "lfp (step UNIV) c \<le> \<gamma>\<^sub>c (step' \<top> c')"
  proof(rule lfp_lowerbound[simplified,OF 3])
    show "step UNIV (\<gamma>\<^sub>c (step' \<top> c')) \<le> \<gamma>\<^sub>c (step' \<top> c')"
    proof(rule step_preserves_le[OF _ _])
      show "UNIV \<subseteq> \<gamma>\<^sub>o \<top>" by simp
      show "\<gamma>\<^sub>c (step' \<top> c') \<le> \<gamma>\<^sub>c c'" by(rule mono_gamma_c[OF 2])
    qed
  qed
  from this 2 show "lfp (step UNIV) c \<le> \<gamma>\<^sub>c c'"
    by (blast intro: mono_gamma_c order_trans)
qed

end

subsubsection "Monotonicity"

locale Abs_Int_mono = Abs_Int +
assumes mono_plus': "a1 \<sqsubseteq> b1 \<Longrightarrow> a2 \<sqsubseteq> b2 \<Longrightarrow> plus' a1 a2 \<sqsubseteq> plus' b1 b2"
begin

lemma mono_aval': "S \<sqsubseteq> S' \<Longrightarrow> aval' e S \<sqsubseteq> aval' e S'"
by(induction e) (auto simp: le_st_def lookup_def mono_plus')

lemma mono_update: "a \<sqsubseteq> a' \<Longrightarrow> S \<sqsubseteq> S' \<Longrightarrow> update S x a \<sqsubseteq> update S' x a'"
by(auto simp add: le_st_def lookup_def update_def)

lemma mono_step': "S \<sqsubseteq> S' \<Longrightarrow> c \<sqsubseteq> c' \<Longrightarrow> step' S c \<sqsubseteq> step' S' c'"
apply(induction c c' arbitrary: S S' rule: le_acom.induct)
apply (auto simp: Let_def mono_update mono_aval' mono_post le_join_disj
            split: option.split)
done

end

subsubsection "Ascending Chain Condition"

abbreviation "strict r == r \<inter> -(r^-1)"
abbreviation "acc r == wf((strict r)^-1)"

lemma strict_inv_image: "strict(inv_image r f) = inv_image (strict r) f"
by(auto simp: inv_image_def)

lemma acc_inv_image:
  "acc r \<Longrightarrow> acc (inv_image r f)"
by (metis converse_inv_image strict_inv_image wf_inv_image)

text{* ACC for option type: *}

lemma acc_option: assumes "acc {(x,y::'a::preord). x \<sqsubseteq> y}"
shows "acc {(x,y::'a::preord option). x \<sqsubseteq> y}"
proof(auto simp: wf_eq_minimal)
  fix xo :: "'a option" and Qo assume "xo : Qo"
  let ?Q = "{x. Some x \<in> Qo}"
  show "\<exists>yo\<in>Qo. \<forall>zo. yo \<sqsubseteq> zo \<and> ~ zo \<sqsubseteq> yo \<longrightarrow> zo \<notin> Qo" (is "\<exists>zo\<in>Qo. ?P zo")
  proof cases
    assume "?Q = {}"
    hence "?P None" by auto
    moreover have "None \<in> Qo" using `?Q = {}` `xo : Qo`
      by auto (metis not_Some_eq)
    ultimately show ?thesis by blast
  next
    assume "?Q \<noteq> {}"
    with assms show ?thesis
      apply(auto simp: wf_eq_minimal)
      apply(erule_tac x="?Q" in allE)
      apply auto
      apply(rule_tac x = "Some z" in bexI)
      by auto
  qed
qed

text{* ACC for abstract states, via measure functions. *}

lemma measure_st: assumes "(strict{(x,y::'a::SL_top). x \<sqsubseteq> y})^-1 <= measure m"
and "\<forall>x y::'a::SL_top. x \<sqsubseteq> y \<and> y \<sqsubseteq> x \<longrightarrow> m x = m y"
shows "(strict{(S,S'::'a::SL_top st). S \<sqsubseteq> S'})^-1 \<subseteq>
  measure(%fd. \<Sum>x| x\<in>set(dom fd) \<and> ~ \<top> \<sqsubseteq> fun fd x. m(fun fd x)+1)"
proof-
  { fix S S' :: "'a st" assume "S \<sqsubseteq> S'" "~ S' \<sqsubseteq> S"
    let ?X = "set(dom S)" let ?Y = "set(dom S')"
    let ?f = "fun S" let ?g = "fun S'"
    let ?X' = "{x:?X. ~ \<top> \<sqsubseteq> ?f x}" let ?Y' = "{y:?Y. ~ \<top> \<sqsubseteq> ?g y}"
    from `S \<sqsubseteq> S'` have "ALL y:?Y'\<inter>?X. ?f y \<sqsubseteq> ?g y"
      by(auto simp: le_st_def lookup_def)
    hence 1: "ALL y:?Y'\<inter>?X. m(?g y)+1 \<le> m(?f y)+1"
      using assms(1,2) by(fastforce)
    from `~ S' \<sqsubseteq> S` obtain u where u: "u : ?X" "~ lookup S' u \<sqsubseteq> ?f u"
      by(auto simp: le_st_def)
    hence "u : ?X'" by simp (metis preord_class.le_trans top)
    have "?Y'-?X = {}" using `S \<sqsubseteq> S'` by(fastforce simp: le_st_def lookup_def)
    have "?Y'\<inter>?X <= ?X'" apply auto
      apply (metis `S \<sqsubseteq> S'` le_st_def lookup_def preord_class.le_trans)
      done
    have "(\<Sum>y\<in>?Y'. m(?g y)+1) = (\<Sum>y\<in>(?Y'-?X) \<union> (?Y'\<inter>?X). m(?g y)+1)"
      by (metis Un_Diff_Int)
    also have "\<dots> = (\<Sum>y\<in>?Y'\<inter>?X. m(?g y)+1)"
      using `?Y'-?X = {}` by (metis Un_empty_left)
    also have "\<dots> < (\<Sum>x\<in>?X'. m(?f x)+1)"
    proof cases
      assume "u \<in> ?Y'"
      hence "m(?g u) < m(?f u)" using assms(1) `S \<sqsubseteq> S'` u
        by (fastforce simp: le_st_def lookup_def)
      have "(\<Sum>y\<in>?Y'\<inter>?X. m(?g y)+1) < (\<Sum>y\<in>?Y'\<inter>?X. m(?f y)+1)"
        using `u:?X` `u:?Y'` `m(?g u) < m(?f u)`
        by(fastforce intro!: sum_strict_mono_ex1[OF _ 1])
      also have "\<dots> \<le> (\<Sum>y\<in>?X'. m(?f y)+1)"
        by(simp add: sum_mono3[OF _ `?Y'\<inter>?X <= ?X'`])
      finally show ?thesis .
    next
      assume "u \<notin> ?Y'"
      with `?Y'\<inter>?X <= ?X'` have "?Y'\<inter>?X - {u} <= ?X' - {u}" by blast
      have "(\<Sum>y\<in>?Y'\<inter>?X. m(?g y)+1) = (\<Sum>y\<in>?Y'\<inter>?X - {u}. m(?g y)+1)"
      proof-
        have "?Y'\<inter>?X = ?Y'\<inter>?X - {u}" using `u \<notin> ?Y'` by auto
        thus ?thesis by metis
      qed
      also have "\<dots> < (\<Sum>y\<in>?Y'\<inter>?X-{u}. m(?g y)+1) + (\<Sum>y\<in>{u}. m(?f y)+1)" by simp
      also have "(\<Sum>y\<in>?Y'\<inter>?X-{u}. m(?g y)+1) \<le> (\<Sum>y\<in>?Y'\<inter>?X-{u}. m(?f y)+1)"
        using 1 by(blast intro: sum_mono)
      also have "\<dots> \<le> (\<Sum>y\<in>?X'-{u}. m(?f y)+1)"
        by(simp add: sum_mono3[OF _ `?Y'\<inter>?X-{u} <= ?X'-{u}`])
      also have "\<dots> + (\<Sum>y\<in>{u}. m(?f y)+1)= (\<Sum>y\<in>(?X'-{u}) \<union> {u}. m(?f y)+1)"
        using `u:?X'` by(subst sum.union_disjoint[symmetric]) auto
      also have "\<dots> = (\<Sum>x\<in>?X'. m(?f x)+1)"
        using `u : ?X'` by(simp add:insert_absorb)
      finally show ?thesis by (blast intro: add_right_mono)
    qed
    finally have "(\<Sum>y\<in>?Y'. m(?g y)+1) < (\<Sum>x\<in>?X'. m(?f x)+1)" .
  } thus ?thesis by(auto simp add: measure_def inv_image_def)
qed

text{* ACC for acom. First the ordering on acom is related to an ordering on
lists of annotations. *}

(* FIXME mv and add [simp] *)
lemma listrel_Cons_iff:
  "(x#xs, y#ys) : listrel r \<longleftrightarrow> (x,y) \<in> r \<and> (xs,ys) \<in> listrel r"
by (blast intro:listrel.Cons)

lemma listrel_app: "(xs1,ys1) : listrel r \<Longrightarrow> (xs2,ys2) : listrel r
  \<Longrightarrow> (xs1@xs2, ys1@ys2) : listrel r"
by(auto simp add: listrel_iff_zip)

lemma listrel_app_same_size: "size xs1 = size ys1 \<Longrightarrow> size xs2 = size ys2 \<Longrightarrow>
  (xs1@xs2, ys1@ys2) : listrel r \<longleftrightarrow>
  (xs1,ys1) : listrel r \<and> (xs2,ys2) : listrel r"
by(auto simp add: listrel_iff_zip)

lemma listrel_converse: "listrel(r^-1) = (listrel r)^-1"
proof-
  { fix xs ys
    have "(xs,ys) : listrel(r^-1) \<longleftrightarrow> (ys,xs) : listrel r"
      apply(induct xs arbitrary: ys)
      apply (fastforce simp: listrel.Nil)
      apply (fastforce simp: listrel_Cons_iff)
      done
  } thus ?thesis by auto
qed

(* It would be nice to get rid of refl & trans and build them into the proof *)
lemma acc_listrel: fixes r :: "('a*'a)set" assumes "refl r" and "trans r"
and "acc r" shows "acc (listrel r - {([],[])})"
proof-
  have refl: "!!x. (x,x) : r" using `refl r` unfolding refl_on_def by blast
  have trans: "!!x y z. (x,y) : r \<Longrightarrow> (y,z) : r \<Longrightarrow> (x,z) : r"
    using `trans r` unfolding trans_def by blast
  from assms(3) obtain mx :: "'a set \<Rightarrow> 'a" where
    mx: "!!S x. x:S \<Longrightarrow> mx S : S \<and> (\<forall>y. (mx S,y) : strict r \<longrightarrow> y \<notin> S)"
    by(simp add: wf_eq_minimal) metis
  let ?R = "listrel r - {([], [])}"
  { fix Q and xs :: "'a list"
    have "xs \<in> Q \<Longrightarrow> \<exists>ys. ys\<in>Q \<and> (\<forall>zs. (ys, zs) \<in> strict ?R \<longrightarrow> zs \<notin> Q)"
      (is "_ \<Longrightarrow> \<exists>ys. ?P Q ys")
    proof(induction xs arbitrary: Q rule: length_induct)
      case (1 xs)
      { have "!!ys Q. size ys < size xs \<Longrightarrow> ys : Q \<Longrightarrow> EX ms. ?P Q ms"
          using "1.IH" by blast
      } note IH = this
      show ?case
      proof(cases xs)
        case Nil with `xs : Q` have "?P Q []" by auto
        thus ?thesis by blast
      next
        case (Cons x ys)
        let ?Q1 = "{a. \<exists>bs. size bs = size ys \<and> a#bs : Q}"
        have "x : ?Q1" using `xs : Q` Cons by auto
        from mx[OF this] obtain m1 where
          1: "m1 \<in> ?Q1 \<and> (\<forall>y. (m1,y) \<in> strict r \<longrightarrow> y \<notin> ?Q1)" by blast
        then obtain ms1 where "size ms1 = size ys" "m1#ms1 : Q" by blast+
        hence "size ms1 < size xs" using Cons by auto
        let ?Q2 = "{bs. \<exists>m1'. (m1',m1):r \<and> (m1,m1'):r \<and> m1'#bs : Q \<and> size bs = size ms1}"
        have "ms1 : ?Q2" using `m1#ms1 : Q` by(blast intro: refl)
        from IH[OF `size ms1 < size xs` this]
        obtain ms where 2: "?P ?Q2 ms" by auto
        then obtain m1' where m1': "(m1',m1) : r \<and> (m1,m1') : r \<and> m1'#ms : Q"
          by blast
        hence "\<forall>ab. (m1'#ms,ab) : strict ?R \<longrightarrow> ab \<notin> Q" using 1 2
          apply (auto simp: listrel_Cons_iff)
          apply (metis `length ms1 = length ys` listrel_eq_len trans)
          by (metis `length ms1 = length ys` listrel_eq_len trans)
        with m1' show ?thesis by blast
      qed
    qed
  }
  thus ?thesis unfolding wf_eq_minimal by (metis converse_iff)
qed

lemma le_iff_le_annos: "c1 \<sqsubseteq> c2 \<longleftrightarrow>
 (annos c1, annos c2) : listrel{(x,y). x \<sqsubseteq> y} \<and> strip c1 = strip c2"
apply(induct c1 c2 rule: le_acom.induct)
apply (auto simp: listrel.Nil listrel_Cons_iff listrel_app size_annos_same2)
apply (metis listrel_app_same_size size_annos_same)+
done

lemma le_acom_subset_same_annos:
 "(strict{(c,c'::'a::preord acom). c \<sqsubseteq> c'})^-1 \<subseteq>
  (strict(inv_image (listrel{(a,a'::'a). a \<sqsubseteq> a'} - {([],[])}) annos))^-1"
by(auto simp: le_iff_le_annos)

lemma acc_acom: "acc {(a,a'::'a::preord). a \<sqsubseteq> a'} \<Longrightarrow>
  acc {(c,c'::'a acom). c \<sqsubseteq> c'}"
apply(rule wf_subset[OF _ le_acom_subset_same_annos])
apply(rule acc_inv_image[OF acc_listrel])
apply(auto simp: refl_on_def trans_def intro: le_trans)
done

text{* Termination of the fixed-point finders, assuming monotone functions: *}

lemma pfp_termination:
fixes x0 :: "'a::preord"
assumes mono: "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y" and "acc {(x::'a,y). x \<sqsubseteq> y}"
and "x0 \<sqsubseteq> f x0" shows "EX x. pfp f x0 = Some x"
proof(simp add: pfp_def, rule wf_while_option_Some[where P = "%x. x \<sqsubseteq> f x"])
  show "wf {(x, s). (s \<sqsubseteq> f s \<and> \<not> f s \<sqsubseteq> s) \<and> x = f s}"
    by(rule wf_subset[OF assms(2)]) auto
next
  show "x0 \<sqsubseteq> f x0" by(rule assms)
next
  fix x assume "x \<sqsubseteq> f x" thus "f x \<sqsubseteq> f(f x)" by(rule mono)
qed

lemma lpfpc_termination:
  fixes f :: "(('a::SL_top)option acom \<Rightarrow> 'a option acom)"
  assumes "acc {(x::'a,y). x \<sqsubseteq> y}" and "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
  and "\<And>c. strip(f c) = strip c"
  shows "\<exists>c'. lpfp\<^sub>c f c = Some c'"
unfolding lpfp\<^sub>c_def
apply(rule pfp_termination)
  apply(erule assms(2))
 apply(rule acc_acom[OF acc_option[OF assms(1)]])
apply(simp add: bot_acom assms(3))
done

context Abs_Int_mono
begin

lemma AI_Some_measure:
assumes "(strict{(x,y::'a). x \<sqsubseteq> y})^-1 <= measure m"
and "\<forall>x y::'a. x \<sqsubseteq> y \<and> y \<sqsubseteq> x \<longrightarrow> m x = m y"
shows "\<exists>c'. AI c = Some c'"
unfolding AI_def
apply(rule lpfpc_termination)
apply(rule wf_subset[OF wf_measure measure_st[OF assms]])
apply(erule mono_step'[OF le_refl])
apply(rule strip_step')
done

end

end


subsection\<open>Conjunctive Normal Forms\<close>
theory CNF
imports Main "HOL-Library.Simps_Case_Conv"
begin

datatype 'a literal = Pos 'a ("(_\<^sup>+)" [1000] 999) | Neg 'a ("(_\<inverse>)" [1000] 999)

type_synonym 'a clause = "'a literal set"
abbreviation empty_clause ("\<box>" (* \box *)) where "\<box> \<equiv> {} :: 'a clause"
(* unfortunately, we'll also have those as lists, occasionally. *)

primrec atoms_of_lit where
"atoms_of_lit (Pos k) = k" |
"atoms_of_lit (Neg k) = k"
case_of_simps lit_atoms_cases: atoms_of_lit.simps

definition "atoms_of_cnf c = atoms_of_lit ` \<Union>c"
lemma atoms_of_cnf_alt: "atoms_of_cnf c = \<Union>(((`) atoms_of_lit) ` c)"
  unfolding atoms_of_cnf_def by blast (* alt as in the German alt *)

lemma atoms_of_cnf_Un: "atoms_of_cnf (S \<union> T) = atoms_of_cnf S \<union> atoms_of_cnf T"
  unfolding atoms_of_cnf_def by auto

(* unbreak set printing *)
term "{0\<^sup>+}::nat clause"
translations
  "{x}" <= "CONST insert x \<box>"
term "{0\<^sup>+}::nat clause"
(* hope nobody ever loads this with some other definition for \<box> *)

end


section \<open>Graph Powers\label{sec:graph_power}\<close>

theory Expander_Graphs_Power_Construction
  imports
    Expander_Graphs_Walks
    Graph_Theory.Arc_Walk
begin

unbundle intro_cong_syntax

fun is_arc_walk :: "('a, 'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> bool"
  where
    "is_arc_walk G _ [] = True" |
    "is_arc_walk G y (x#xs) = (is_arc_walk G (head G x) xs \<and> tail G x = y \<and> x \<in> arcs G)"

definition arc_walk_head :: "('a, 'b) pre_digraph \<Rightarrow> ('a \<times> 'b list) \<Rightarrow> 'a"
  where
    "arc_walk_head G x = (if snd x = [] then fst x else head G (last (snd x)))"

lemma is_arc_walk_snoc:
  "is_arc_walk G y (xs@[x]) \<longleftrightarrow> is_arc_walk G y xs \<and> x \<in> out_arcs G (arc_walk_head G (y,xs))"
  by (induction xs arbitrary: y, simp_all add:ac_simps arc_walk_head_def)

lemma is_arc_walk_set:
  assumes "is_arc_walk G u w"
  shows "set w \<subseteq> arcs G"
  using assms by (induction w arbitrary: u, auto)

lemma (in wf_digraph) awalk_is_arc_walk:
  assumes "u \<in> verts G"
  shows "is_arc_walk G u w \<longleftrightarrow> awalk u w (awlast u w)"
  using assms unfolding awalk_def by (induction w arbitrary: u, auto)

definition arc_walks :: "('a, 'b) pre_digraph \<Rightarrow> nat \<Rightarrow> ('a \<times> 'b list) set"
  where
    "arc_walks G l = {(u,w). u \<in> verts G \<and> is_arc_walk G u w \<and> length w = l}"

lemma arc_walks_len:
  assumes "x \<in> arc_walks G l"
  shows "length (snd x) = l"
  using assms unfolding arc_walks_def by auto

lemma (in wf_digraph) awhd_of_arc_walk:
  assumes "w \<in> arc_walks G l"
  shows "awhd (fst w) (snd w) = fst w"
  using assms unfolding arc_walks_def awalk_verts_def
  by (cases "snd w", auto)

lemma (in wf_digraph) awlast_of_arc_walk:
  assumes "w \<in> arc_walks G l"
  shows "awlast (fst w) (snd w) = arc_walk_head G w"
  unfolding awalk_verts_conv arc_walk_head_def by simp

lemma (in wf_digraph) arc_walk_head_wellformed:
  assumes "w \<in> arc_walks G l"
  shows "arc_walk_head G w \<in> verts G"
proof (cases "snd w = []")
  case True
  then show ?thesis
    using assms unfolding arc_walks_def arc_walk_head_def by auto
next
  case False
  have 0:"is_arc_walk G (fst w) (snd w)" using assms unfolding arc_walks_def by auto
  have "last (snd w) \<in> set (snd w)"
    using False last_in_set by auto
  also have "... \<subseteq> arcs G"
    by (intro is_arc_walk_set[OF 0])
  finally have "last (snd w) \<in> arcs G" by simp
  thus ?thesis unfolding arc_walk_head_def using False by simp
qed

lemma (in wf_digraph) arc_walk_tail_wellformed:
  assumes "w \<in> arc_walks G l"
  shows "fst w \<in> verts G"
  using assms unfolding arc_walks_def by auto

lemma (in fin_digraph) arc_walks_fin:
  "finite (arc_walks G l)"
proof -
  have 0:"finite (verts G \<times> {w. set w \<subseteq> arcs G \<and> length w = l})"
    by (intro finite_cartesian_product finite_lists_length_eq) auto
  show "finite (arc_walks G l)"
    unfolding arc_walks_def using is_arc_walk_set[where G="G"]
    by (intro finite_subset[OF _ 0] subsetI) auto
qed

lemma (in wf_digraph) awalk_verts_unfold:
  assumes "w \<in> arc_walks G l"
  shows "awalk_verts (fst w) (snd w) = fst w#map (head G) (snd w)" (is "?L = ?R")
proof -
  obtain u v where w_def: "w = (u,v)" by fastforce

  have "awalk u v (awlast u v)"
    using assms unfolding w_def arc_walks_def
    by (intro iffD1[OF awalk_is_arc_walk]) auto
  hence cas: "cas u v (awlast u v)"
    unfolding awalk_def by simp

  have 0: "tail G (hd v) = u" if "v \<noteq> []"
    using cas that by (cases v) auto

  have "?L = awalk_verts u v"
    unfolding w_def by simp
  also have "... = (if v = [] then [u] else tail G (hd v) # map (head G) v)"
    by (intro awalk_verts_conv'[OF cas])
  also have "... = u# map (head G) v"
    using 0 by simp
  also have "... = ?R"
    unfolding w_def by simp
  finally show ?thesis by simp
qed

lemma (in fin_digraph) arc_walks_map_walks':
  "walks' G l = image_mset (case_prod awalk_verts) (mset_set (arc_walks G l))"
proof (induction l)
  case 0
  let ?g = "\<lambda>x. fst x#map (head G) (snd x)"

  have "walks' G 0 = {#[x]. x \<in># mset_set (verts G)#}"
    by simp
  also have "... = image_mset ?g (image_mset (\<lambda>x. (x,[])) (mset_set (verts G)))"
    unfolding image_mset.compositionality by (simp add:comp_def)
  also have "... = image_mset ?g (mset_set ((\<lambda>x. (x,[])) ` verts G))"
    by (intro arg_cong2[where f="image_mset"] image_mset_mset_set inj_onI) auto
  also have "... = image_mset ?g (mset_set ({(u, w). u \<in> verts G \<and> w = []}))"
    by (intro_cong "[\<sigma>\<^sub>2 image_mset]") auto
  also have "... = image_mset ?g (mset_set (arc_walks G 0))"
    unfolding arc_walks_def by (intro_cong "[\<sigma>\<^sub>2 image_mset,\<sigma>\<^sub>1 mset_set]") auto
  also have "... = image_mset (case_prod awalk_verts) (mset_set (arc_walks G 0))"
    using arc_walks_fin by (intro image_mset_cong) (simp add:case_prod_beta awalk_verts_unfold)
  finally show ?case by simp
next
  case (Suc l)
  let ?f = "\<lambda>(u,w) a. (u,w@[a])"
  let ?g = "\<lambda>x. fst x#map (head G) (snd x)"

  have "arc_walks G (l+1) = case_prod ?f ` {(x,y). ?f x y \<in> arc_walks G (l+1)}"
    using arc_walks_len[where G="G" and l="Suc l", THEN iffD1[OF length_Suc_conv_rev]]
    by force
  also have "... = case_prod ?f ` {(x,y). x \<in> arc_walks G l \<and> y \<in> out_arcs G (arc_walk_head G x)}"
    unfolding arc_walks_def using is_arc_walk_snoc[where G="G"]
    by (intro_cong "[\<sigma>\<^sub>2 image]")  auto
  also have "... = (\<Union>w \<in> arc_walks G l. ?f w ` out_arcs G (arc_walk_head G w))"
    by (auto simp add:image_iff)
  finally have 0:"arc_walks G (l+1) = (\<Union>w \<in> arc_walks G l. ?f w ` out_arcs G (arc_walk_head G w))"
    by simp

  have "mset_set (arc_walks G (l+1)) = concat_mset (image_mset (mset_set \<circ>
    (\<lambda>w. ?f w ` out_arcs G (arc_walk_head G w))) (mset_set (arc_walks G l)))"
    unfolding 0 by (intro concat_disjoint_union_mset arc_walks_fin finite_imageI) auto
  also have "... = concat_mset {# mset_set (?f x ` out_arcs G (arc_walk_head G x)).
    x\<in>#mset_set(arc_walks G l)#}"
    by (simp add:comp_def case_prod_beta)
  also have "... = concat_mset {# {# ?f x y. y \<in># mset_set (out_arcs G (arc_walk_head G x))#}.
    x \<in># mset_set (arc_walks G l)#}"
    by (intro_cong "[\<sigma>\<^sub>1 concat_mset]" more:image_mset_cong image_mset_mset_set[symmetric] inj_onI)
     auto
  finally have 1:"mset_set (arc_walks G (l+1)) = concat_mset
    {# {# ?f x y. y \<in># mset_set (out_arcs G (arc_walk_head G x))#}. x \<in># mset_set (arc_walks G l)#}"
    by simp

  have "walks' G (l+1)=concat_mset {#{#w @ [z]. z\<in># vertices_from G (last w)#}. w \<in># walks' G l#}"
    by simp
  also have "... = concat_mset {#
      {#awalk_verts (fst x) (snd x) @ [z]. z \<in># vertices_from G (awlast (fst x) (snd x))#}.
      x \<in># mset_set (arc_walks G l)#}"
    unfolding Suc by (simp add:image_mset.compositionality comp_def case_prod_beta)
  also have "... = concat_mset {#
      {#?g x @ [z]. z \<in># vertices_from G (awlast (fst x) (snd x))#}.
      x \<in># mset_set (arc_walks G l)#}"
    using arc_walks_fin
    by (intro_cong "[\<sigma>\<^sub>1 concat_mset]" more:image_mset_cong) (auto simp: awalk_verts_unfold)
  also have "... = concat_mset {# {#?g x @ [z]. z \<in># vertices_from G (arc_walk_head G x)#}.
      x \<in># mset_set (arc_walks G l)#}"
    using arc_walks_fin awlast_of_arc_walk
    by (intro_cong "[\<sigma>\<^sub>1 concat_mset, \<sigma>\<^sub>2 image_mset]" more: image_mset_cong) auto
  also have "... = (concat_mset {# {# ?g (fst x, snd x@[y]).
    y \<in># mset_set (out_arcs G (arc_walk_head G x))#}. x \<in># mset_set (arc_walks G l)#})"
    unfolding verts_from_alt by (simp add:image_mset.compositionality comp_def)
  also have "... = image_mset ?g (concat_mset {# {# ?f x y.
    y \<in># mset_set (out_arcs G (arc_walk_head G x))#}. x \<in># mset_set (arc_walks G l)#})"
    unfolding image_concat_mset
    by (auto simp add:comp_def case_prod_beta image_mset.compositionality)
  also have "... = image_mset ?g (mset_set (arc_walks G (l+1)))"
    unfolding 1 by simp
  also have "... = image_mset (case_prod awalk_verts) (mset_set (arc_walks G (l+1)))"
    using arc_walks_fin by (intro image_mset_cong) (simp add:case_prod_beta awalk_verts_unfold)
  finally show ?case by simp
qed

lemma (in fin_digraph) arc_walks_map_walks:
  "walks G (l+1) = image_mset (case_prod awalk_verts) (mset_set (arc_walks G l))"
  using arc_walks_map_walks' unfolding walks_def by simp

lemma (in wf_digraph)
  assumes "awalk u a v " "length a = l" "l > 0"
  shows awalk_ends: "tail G (hd a) = u" "head G (last a) = v"
proof -
  have 0:"cas u a v"
    using assms unfolding awalk_def by simp
  have 1: "a \<noteq> []" using assms(2,3) by auto

  show "tail G (hd a) = u"
    using 0 unfolding cas_simp[OF 1] by auto

  show "head G (last a) = v"
    using 1 0 by (induction a arbitrary:u rule:list_nonempty_induct) auto
qed

definition graph_power :: "('a, 'b) pre_digraph \<Rightarrow> nat \<Rightarrow> ('a, ('a \<times> 'b list)) pre_digraph"
  where "graph_power G l =
    \<lparr> verts = verts G, arcs = arc_walks G l, tail = fst, head = arc_walk_head G \<rparr>"

lemma (in wf_digraph) graph_power_wf:
  "wf_digraph (graph_power G l)"
proof -
  have "tail (graph_power G l) a \<in> verts (graph_power G l)"
       "head (graph_power G l) a \<in> verts (graph_power G l)"
       if "a \<in> arcs (graph_power G l)" for a
    using that arc_walk_head_wellformed arc_walk_tail_wellformed
    unfolding graph_power_def by simp_all
  thus ?thesis
    unfolding wf_digraph_def by auto
qed

lemma (in fin_digraph) graph_power_fin:
  "fin_digraph (graph_power G l)"
proof -
  interpret H:wf_digraph "graph_power G l"
    using graph_power_wf by auto

  have "finite (arcs (graph_power G l))"
    using arc_walks_fin
    unfolding graph_power_def by simp

  moreover have "finite (verts (graph_power G l))"
    unfolding graph_power_def by simp
  ultimately show ?thesis
    by unfold_locales auto
qed

lemma (in fin_digraph) graph_power_count_edges:
  fixes l v w
  defines "S \<equiv> {x. length x=l+1\<and>set x\<subseteq>verts G\<and>hd x=v\<and>last x=w}"
  shows "count (edges (graph_power G l)) (v,w) = (\<Sum>x \<in> S.(\<Prod>i<l. count(edges G)(x!i,x!(i+1))))"
    (is "?L = ?R")
proof -
  interpret H:fin_digraph "graph_power G l"
    using graph_power_fin by auto

  have 0:"finite {x. set x \<subseteq> verts G \<and> length x = l+1}"
    by (intro finite_lists_length_eq) auto
  have fin_S: "finite S"
    unfolding S_def by (intro finite_subset[OF _ 0]) auto

  have "?L = size {#x \<in># mset_set (arc_walks G l). fst x = v \<and> arc_walk_head G x = w#}"
    unfolding graph_power_def edges_def arc_to_ends_def
    by (simp add:count_mset_exp image_mset_filter_mset_swap[symmetric])
  also have "... = size
    {#x \<in># mset_set (arc_walks G l). awhd (fst x) (snd x) = v \<and> awlast (fst x) (snd x) = w#}"
    using awlast_of_arc_walk awhd_of_arc_walk arc_walks_fin
    by (intro arg_cong[where f="size"] filter_mset_cong refl) simp
  also have "... = size {#x \<in># walks G (l+1). hd x = v \<and> last x = w#}"
    unfolding arc_walks_map_walks
    by (simp add:image_mset_filter_mset_swap[symmetric] case_prod_beta)
  also have "...=size{#x\<in># walks G (l+1).x \<in> S#}"
    unfolding S_def using set_walks_3
    by (intro arg_cong[where f="size"] filter_mset_cong refl) auto
  also have "...=sum (count (walks G (l+1))) S"
    by (intro sum_count_2[symmetric] fin_S)
  also have "...=(\<Sum>x\<in>S.(\<Prod>i<l+1-1. count (edges G) (x!i,x!(i+1))))"
    unfolding S_def
    by (intro sum.cong refl count_walks) auto
  also have "...=?R"
    by simp
  finally show ?thesis by simp
qed

lemma (in fin_digraph) graph_power_sym_aux:
  assumes "symmetric_multi_graph G"
  assumes "v \<in> verts (graph_power G l)"  "w \<in> verts (graph_power G l)"
  shows "card (arcs_betw (graph_power G l) v w) = card (arcs_betw (graph_power G l) w v)"
    (is "?L = ?R")
proof -
  interpret H:fin_digraph "graph_power G l"
    using graph_power_fin by auto

  define S where "S v w = {x. length x=l+1 \<and> set x \<subseteq> verts G \<and> hd x = v \<and> last x = w}" for v w

  have 0: "bij_betw rev (S w v) (S v w)"
    unfolding S_def by (intro bij_betwI[where g="rev"]) (auto simp add:hd_rev last_rev)

  have 1: "bij_betw ((-) (l - 1)) {..<l} {..<l}"
    by (intro bij_betwI[where g="\<lambda>x. (l-1-x)"]) auto

  have "?L = count (edges (graph_power G l)) (v, w)"
    unfolding H.count_edges by simp
  also have "... = (\<Sum>x \<in> S v w. (\<Prod>i<l. count (edges G) (x!i,x!(i+1))))"
    unfolding S_def graph_power_count_edges by simp
  also have "... = (\<Sum>x \<in> S w v. (\<Prod>i<l. count (edges G) (rev x!i,rev x!(i+1))))"
    by (intro sum.reindex_bij_betw[symmetric] 0)
  also have "... = (\<Sum>x \<in> S w v. (\<Prod>i<l. count (edges G) (x!((l-1-i)+1),x!(l-1-i))))"
    unfolding S_def by (intro sum.cong refl prod.cong) (simp_all add: rev_nth Suc_diff_Suc)
  also have "... = (\<Sum>x \<in> S w v. (\<Prod>i<l. count (edges G) (x!(i+1),x!i)))"
    by (intro sum.cong prod.reindex_bij_betw refl 1)
  also have "... = (\<Sum>x \<in> S w v. (\<Prod>i<l. count (edges G) (x!i,x!(i+1))))"
    by (intro sum.cong prod.cong count_edges_sym[OF assms(1)] refl)
  also have "... = count (edges (graph_power G l)) (w, v)"
    unfolding S_def graph_power_count_edges by simp
  also have "... = ?R"
    unfolding H.count_edges by simp
  finally show ?thesis by simp
qed

lemma (in fin_digraph) graph_power_sym:
  assumes "symmetric_multi_graph G"
  shows "symmetric_multi_graph (graph_power G l)"
proof -
  interpret H:fin_digraph "graph_power G l"
    using graph_power_fin by auto

  show ?thesis
    using graph_power_sym_aux[OF assms]
    unfolding symmetric_multi_graph_def by auto
qed

lemma  (in fin_digraph) graph_power_out_degree':
  assumes reg: "\<And>v. v \<in> verts G \<Longrightarrow> out_degree G v = d"
  assumes "v \<in> verts (graph_power G l)"
  shows "out_degree (graph_power G l) v = d ^ l"  (is "?L = ?R")
proof -
  interpret H:fin_digraph "graph_power G l"
    using graph_power_fin by auto

  have v_vert: "v \<in> verts G"
    using assms unfolding graph_power_def by simp

  have "?L = size (vertices_from (graph_power G l) v)"
    unfolding out_degree_def H.verts_from_alt by simp
  also have "... = size ({# e \<in># edges (graph_power G l). fst e = v #})"
    unfolding vertices_from_def by simp
  also have "... = size {#w \<in># mset_set (arc_walks G l). fst w = v#}"
    unfolding graph_power_def edges_def arc_to_ends_def
    by (simp add:count_mset_exp image_mset_filter_mset_swap[symmetric])
  also have "... = size {#w \<in># mset_set (arc_walks G l). awhd (fst w) (snd w) = v#}"
    using awlast_of_arc_walk awhd_of_arc_walk arc_walks_fin
    by (intro arg_cong[where f="size"] filter_mset_cong refl) simp
  also have "... = size {#x \<in># walks' G l. hd x = v #}"
    unfolding arc_walks_map_walks'
    by (simp add:image_mset_filter_mset_swap[symmetric] case_prod_beta)
  also have "... = d^l"
  proof (induction l)
    case 0
    have "size {#x \<in># walks' G 0. hd x = v#} = card {x. x = v \<and> x \<in> verts G}"
      by (simp add:image_mset_filter_mset_swap[symmetric])
    also have "... = card {v}"
      using v_vert by (intro arg_cong[where f="card"]) auto
    also have "... = d^0" by simp
    finally show ?case by simp
  next
    case (Suc l)
    have "size {#x \<in># walks' G (Suc l). hd x = v#} =
      (\<Sum>x\<in>#walks' G l. size {#y \<in># vertices_from G (last x). hd (x @ [y]) = v#})"
      by (simp add:size_concat_mset image_mset_filter_mset_swap[symmetric]
          filter_concat_mset image_mset.compositionality comp_def)
    also have "... = (\<Sum>x\<in>#walks' G l. size {#y \<in># vertices_from G (last x). hd x = v#})"
      using set_walks_2
      by (intro_cong "[\<sigma>\<^sub>1 sum_mset, \<sigma>\<^sub>1 size]" more:image_mset_cong filter_mset_cong) auto
    also have "... = (\<Sum>x\<in>#walks' G l. (if hd x = v then out_degree G (last x) else 0))"
      unfolding verts_from_alt out_degree_def
      by (simp add:filter_mset_const if_distribR if_distrib cong:if_cong)
    also have "... = (\<Sum>x\<in>#walks' G l. d * of_bool (hd x = v))"
      using set_walks_2[where l="l"] last_in_set
      by (intro arg_cong[where f="sum_mset"] image_mset_cong) (auto intro!:reg)
    also have "... = d * (\<Sum>x\<in>#walks' G l. of_bool (hd x = v))"
      by (simp add:sum_mset_distrib_left image_mset.compositionality comp_def)
    also have "... = d * (size {#x \<in># walks' G l. hd x = v#})"
      by (simp add:size_filter_mset_conv)
    also have "... = d * d ^ l"
      using Suc by simp
    also have "... = d^Suc l"
      by simp
    finally show ?case by simp
  qed

  finally show ?thesis by simp
qed

lemma  (in regular_graph) graph_power_out_degree:
  assumes "v \<in> verts (graph_power G l)"
  shows "out_degree (graph_power G l) v = d ^ l"  (is "?L = ?R")
  by (intro graph_power_out_degree' assms reg) auto

lemma (in regular_graph) graph_power_regular:
  "regular_graph (graph_power G l)"
proof -
  interpret H:fin_digraph "graph_power G l"
    using graph_power_fin by auto

  have "verts (graph_power G l) \<noteq> {}"
    using verts_non_empty unfolding graph_power_def by simp

  moreover have "0 < d^l"
    using d_gt_0 by simp

  ultimately show ?thesis
    using graph_power_out_degree
    by (intro regular_graphI[where d="d^l"] graph_power_sym sym)
qed

lemma (in regular_graph) graph_power_degree:
  "regular_graph.d (graph_power G l) = d^l" (is "?L = ?R")
proof -
  interpret H:regular_graph "graph_power G l"
    using graph_power_regular by auto
  obtain v where v_set: "v \<in> verts (graph_power G l)"
    using H.verts_non_empty by auto
  hence "?L = out_degree (graph_power G l) v"
    using v_set H.reg by auto
  also have "... =?R"
    by (intro graph_power_out_degree[OF v_set])
  finally show ?thesis by simp
qed

lemma (in regular_graph) graph_power_step:
  assumes "x \<in> verts G"
  shows "regular_graph.g_step (graph_power G l) f x = (g_step^^l) f x"
  using assms
proof (induction l arbitrary: x)
  case 0
  let ?H = "graph_power G 0"
  interpret H:regular_graph "?H"
    using graph_power_regular by auto
  have "regular_graph.g_step (graph_power G 0) f x = H.g_step f x"
    by simp
  have "H.g_step f x = (\<Sum>x\<in>in_arcs ?H x. f (tail ?H x))"
    unfolding H.g_step_def graph_power_degree by simp
  also have "... = (\<Sum>v\<in>{e \<in> arc_walks G 0. arc_walk_head G e = x}. f (fst v))"
    unfolding in_arcs_def graph_power_def by (simp add:case_prod_beta)
  also have "... = (\<Sum>v\<in>{x}. f v)"
    unfolding arc_walks_def using 0
    by (intro sum.reindex_bij_betw bij_betwI[where g="(\<lambda>x. (x,[]))"])
      (auto simp add:arc_walk_head_def)
  also have "... = f x"
    by simp
  also have "... = (g_step^^0) f x"
    by simp
  finally show ?case by simp
next
  case (Suc l)
  let ?H = "graph_power G l"
  interpret H:regular_graph "?H"
    using graph_power_regular by auto
  let ?HS = "graph_power G (l+1)"
  interpret HS:regular_graph "?HS"
    using graph_power_regular by auto

  let ?bij = "(\<lambda>(x,(y1,y2)). (y1,y2@[x]))"
  let ?bijr = "(\<lambda>(y1,y2). (last y2, (y1,butlast y2)))"

  define S where "S = {y. fst y \<in> in_arcs G x \<and> snd y \<in> in_arcs ?H (tail G (fst y))}"

  have "S = {(u,v). u \<in> arcs G \<and> head G u = x \<and> v \<in> arc_walks G l \<and> arc_walk_head G v = tail G u}"
    unfolding S_def graph_power_def in_arcs_def by auto
  also have "... = {(u,v). (fst v,snd v@[u]) \<in> arc_walks G (l+1) \<and> arc_walk_head G (fst v,snd v@[u]) = x}"
    unfolding arc_walks_def by (intro iffD2[OF set_eq_iff] allI)
      (auto simp add: is_arc_walk_snoc case_prod_beta arc_walk_head_def)
  also have "... = {(u,v). (fst v,snd v@[u]) \<in> in_arcs ?HS x}"
    unfolding in_arcs_def graph_power_def by auto
  finally have S_alt: "S = {(u,v). (fst v,snd v@[u]) \<in> in_arcs ?HS x}" by simp

  have len_in_arcs: "a \<in> in_arcs ?HS x \<Longrightarrow> snd a \<noteq> []" for a
    unfolding in_arcs_def graph_power_def arc_walks_def by auto

  have 0:"bij_betw ?bij S (in_arcs ?HS x)"
    unfolding S_alt using len_in_arcs
    by (intro bij_betwI[where g="?bijr"]) auto

  have "HS.g_step f x = (\<Sum>y\<in>in_arcs ?HS x. f (tail ?HS y)/ d^(l+1))"
    unfolding HS.g_step_def graph_power_degree by simp
  also have "... = (\<Sum>y\<in>in_arcs ?HS x. f (fst y)/ d^(l+1))"
    unfolding graph_power_def by simp
  also have "... = (\<Sum>y \<in> S. f (fst (?bij y))/ d^(l+1))"
    by (intro sum.reindex_bij_betw[symmetric] 0)
  also have "... = (\<Sum>y \<in> S. f (fst (snd y))/ d^(l+1))"
    by (intro_cong "[\<sigma>\<^sub>2 (/),\<sigma>\<^sub>1 f]" more: sum.cong) (simp add:case_prod_beta)
  also have "...=(\<Sum>y\<in>(\<Union>a\<in>in_arcs G x. (Pair a)`in_arcs ?H (tail G a)). f (fst (snd y))/ d^(l+1))"
    unfolding S_def by (intro sum.cong) auto
  also have "...=(\<Sum>a\<in>in_arcs G x. (\<Sum>y\<in>(Pair a)`in_arcs ?H (tail G a). f (fst (snd y))/ d^(l+1)))"
    by (intro sum.UNION_disjoint) auto
  also have "... = (\<Sum>a \<in> in_arcs G x. (\<Sum>b \<in> in_arcs ?H (tail G a). f (fst b) / d^(l+1)))"
    by (intro sum.cong sum.reindex_bij_betw) (auto simp add:bij_betw_def inj_on_def image_iff)
  also have "... = (\<Sum>a \<in> in_arcs G x. (\<Sum>b \<in> in_arcs ?H (tail G a). f (tail ?H b) / d^l)/d)"
    unfolding graph_power_def
    by (simp add:sum_divide_distrib algebra_simps)
  also have "... = (\<Sum>a \<in> in_arcs G x. H.g_step f (tail G a)/ d)"
    unfolding H.g_step_def graph_power_degree by simp
  also have "... = (\<Sum>a \<in> in_arcs G x. (g_step^^l) f (tail G a)/ d)"
    by (intro sum.cong refl arg_cong2[where f="(/)"] Suc) auto
  also have "... = g_step ((g_step^^l) f) x"
    unfolding g_step_def by simp
  also have "... = (g_step^^(l+1)) f x"
    by simp
  finally show ?case by simp
qed

lemma (in regular_graph) graph_power_expansion:
  "regular_graph.\<Lambda>\<^sub>a (graph_power G l) \<le> \<Lambda>\<^sub>a^l"
proof -
  interpret H:regular_graph "graph_power G l"
    using graph_power_regular by auto

  have "\<bar>H.g_inner f (H.g_step f)\<bar> \<le> \<Lambda>\<^sub>a ^ l * (H.g_norm f)\<^sup>2" (is "?L \<le> ?R")
    if "H.g_inner f (\<lambda>_. 1) = 0"  for f
  proof -
    have "g_inner f (\<lambda>_. 1) = H.g_inner f (\<lambda>_.1)"
      unfolding g_inner_def H.g_inner_def
      by (intro sum.cong) (auto simp add:graph_power_def)
    also have "... = 0" using that by simp
    finally have 1:"g_inner f (\<lambda>_. 1) = 0" by simp

    have 2: "g_inner ((g_step^^l) f) (\<lambda>_. 1) = 0" for l
      using g_step_remains_orth 1 by (induction l, auto)

    have 0: "g_norm ((g_step^^l) f) \<le> \<Lambda>\<^sub>a ^ l * g_norm f"
    proof (induction l)
      case 0
      then show ?case by simp
    next
      case (Suc l)
      have "g_norm ((g_step ^^ Suc l) f) = g_norm (g_step ((g_step ^^ l) f))"
        by simp
      also have "... \<le> \<Lambda>\<^sub>a * g_norm (((g_step ^^ l) f))"
        by (intro expansionD2 2)
      also have "... \<le> \<Lambda>\<^sub>a * (\<Lambda>\<^sub>a^l * g_norm f)"
        by (intro mult_left_mono \<Lambda>_ge_0 Suc)
      also have "... = \<Lambda>\<^sub>a^(l+1) * g_norm f" by simp
      finally show ?case by simp
    qed

    have "?L = \<bar>g_inner f (H.g_step f)\<bar>"
      unfolding H.g_inner_def g_inner_def
      by (intro_cong "[\<sigma>\<^sub>1 abs]" more:sum.cong) (auto simp add:graph_power_def)
    also have "... = \<bar>g_inner f ((g_step^^l) f)\<bar>"
      by (intro_cong "[\<sigma>\<^sub>1 abs]" more:g_inner_cong graph_power_step) auto
    also have "... \<le> g_norm f * g_norm ((g_step^^l) f)"
      by (intro g_inner_cauchy_schwartz)
    also have "... \<le> g_norm f * (\<Lambda>\<^sub>a ^ l * g_norm f)"
      by (intro mult_left_mono 0 g_norm_nonneg)
    also have "... = \<Lambda>\<^sub>a ^ l * g_norm f^2"
      by (simp add:power2_eq_square)
    also have "... = ?R"
      unfolding g_norm_sq H.g_norm_sq g_inner_def H.g_inner_def
      by (intro_cong "[\<sigma>\<^sub>2 (*)]" more:sum.cong) (auto simp add:graph_power_def)
    finally show ?thesis by simp
  qed
  moreover have " 0 \<le> \<Lambda>\<^sub>a ^ l"
    using \<Lambda>_ge_0 by simp

  ultimately show ?thesis
    by (intro H.expander_intro_1) auto
qed

unbundle no_intro_cong_syntax

end


(*  Title:        C2KA Behaviour Structure (Concurrent Kleene Algebra)
    Author:       Maxime Buyse <maxime.buyse at polytechnique.edu>, 2019
    Maintainers:  Maxime Buyse <maxime.buyse at polytechnique.edu> and Jason Jaskolka <jason.jaskolka at carleton.ca>
*)

section \<open>Behaviour Structure \label{sec:behaviour_structure}\<close>

text \<open>
Hoare et al.~\<^cite>\<open>"Hoare2011aa"\<close> presented the framework of Concurrent Kleene Algebra (\CKAabbrv) which captures the concurrent
behaviour of agents. The framework of \CKAabbrv is adopted to describe agent behaviours in distributed
systems. For a \CKAabbrv~$\CKAstructure$,~$\CKAset$ is a set of possible behaviours. The operator~$+$ is
interpreted as a choice between two behaviours, the operator~$\CKAseq$ is interpreted as a sequential
composition of two behaviours, and the operator~$\CKApar$ is interpreted as a parallel composition of
two behaviours. The operators~$\CKAiterSeq{\,}$ and~$\CKAiterPar{\,}$ are interpreted as a finite sequential
iteration and a finite parallel iteration of behaviours, respectively. The element~$0$ represents the
behaviour of the \emph{inactive agent} and the element~$1$ represents the behaviour of the \emph{idle agent}.
Associated with a \CKAabbrv~$\cka$ is a natural ordering relation~$\CKAle$ related to the semirings upon which the
\CKAabbrv is built which is called the sub-behaviour relation. For behaviours~$a,b \in \CKAset$, we
write~$a \CKAle b$ and say that~$a$ is a sub-behaviour of~$b$ if and only if~$a + b = b$.
\<close>

theory CKA
  imports Main
begin

no_notation
rtrancl ("(_\<^sup>*)" [1000] 999)

notation
times (infixl "*" 70)
and less_eq  ("'(\<le>\<^sub>\<K>')")
and less_eq  ("(_/ \<le>\<^sub>\<K> _)"  [51, 51] 50)

text \<open>
The class \emph{cka} contains an axiomatisation of Concurrent Kleene Algebras and a selection of useful theorems.\<close>

class join_semilattice = ordered_ab_semigroup_add +
  assumes leq_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and le_def: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
  and add_idem [simp]: "x + x = x"
begin

lemma inf_add_K_right: "a \<le>\<^sub>\<K> a + b"
  unfolding leq_def
  by (simp add:  add_assoc[symmetric])

lemma inf_add_K_left: "a \<le>\<^sub>\<K> b + a"
  by (simp only: add_commute, fact inf_add_K_right)

end

class dioid = semiring + one + zero + join_semilattice +
  assumes par_onel [simp]: "1 * x = x"
  and par_oner [simp]: "x * 1 = x"
  and add_zerol [simp]: "0 + x = x"
  and annil [simp]: "0 * x = 0"
  and annir [simp]: "x * 0 = 0"

class kleene_algebra = dioid +
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>*" [101] 100)
  assumes star_unfoldl: "1 + x * x\<^sup>* \<le>\<^sub>\<K> x\<^sup>*"
  and star_unfoldr: "1 + x\<^sup>* * x \<le>\<^sub>\<K> x\<^sup>*"
  and star_inductl: "z + x * y \<le>\<^sub>\<K> y \<Longrightarrow> x\<^sup>* * z \<le>\<^sub>\<K> y"
  and star_inductr: "z + y * x \<le>\<^sub>\<K> y \<Longrightarrow> z * x\<^sup>* \<le>\<^sub>\<K> y"

class cka = kleene_algebra +
  fixes seq :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl ";" 70)
  and seqstar :: "'a \<Rightarrow> 'a" ("_\<^sup>;" [101] 100)
  assumes seq_assoc: "x ; (y ; z) = (x ; y) ; z"
  and seq_rident [simp]: "x ; 1 = x"
  and seq_lident [simp]: "1 ; x = x"
  and seq_rdistrib [simp]: "(x + y);z = x;z + y;z"
  and seq_ldistrib [simp]: "x;(y + z) = x;y + x;z"
  and seq_annir [simp]: "x ; 0 = 0"
  and seq_annil [simp]: "0 ; x = 0"
  and seqstar_unfoldl: "1 + x ; x\<^sup>; \<le>\<^sub>\<K> x\<^sup>;"
  and seqstar_unfoldr: "1 + x\<^sup>; ; x \<le>\<^sub>\<K> x\<^sup>;"
  and seqstar_inductl: "z + x ; y \<le>\<^sub>\<K> y \<Longrightarrow> x\<^sup>; ; z \<le>\<^sub>\<K> y"
  and seqstar_inductr: "z + y ; x \<le>\<^sub>\<K> y \<Longrightarrow> z ; x\<^sup>; \<le>\<^sub>\<K> y"
  and exchange: "(a*b) ; (c*d) \<le>\<^sub>\<K> (b;c) * (a;d)"
begin

interpretation cka: kleene_algebra plus less_eq less "1" "0" seq seqstar
  by (unfold_locales, simp_all add: seq_assoc seqstar_unfoldl seqstar_unfoldr seqstar_inductl seqstar_inductr)

lemma par_comm: "a * b = b * a"
proof -
  have "(b*a) ; (1*1) \<le>\<^sub>\<K> (a;1) * (b;1)" by (simp only:  exchange)
  hence "b * a \<le>\<^sub>\<K> a * b" by (simp)
  hence "a * b \<le>\<^sub>\<K> b * a \<longleftrightarrow> a * b  = b * a" by (rule antisym_conv)
  moreover have "a * b \<le>\<^sub>\<K> b * a" proof -
  have "(a*b) ; (1*1) \<le>\<^sub>\<K> (b;1) * (a;1)" by (rule  exchange)
    thus ?thesis  by (simp)
  qed
  ultimately show ?thesis by (auto)
qed

lemma exchange_2: "(a*b) ; (c*d) \<le>\<^sub>\<K> (a;c) * (b;d)"
proof -
  have "(b*a) ; (c*d) \<le>\<^sub>\<K> (a;c) * (b;d)" by (rule exchange)
  thus ?thesis by (simp add: par_comm)
qed

lemma seq_inf_par: "a ; b \<le>\<^sub>\<K> a * b"
proof -
  have "(1*a) ; (1*b) \<le>\<^sub>\<K> (a;1) * (1;b)" by (rule exchange)
  thus ?thesis by simp
qed

lemma add_seq_inf_par: "a;b + b;a \<le>\<^sub>\<K> a*b"
proof -
  have "a;b \<le>\<^sub>\<K> a*b" by (rule seq_inf_par)
  moreover have "b;a \<le>\<^sub>\<K> b*a" by (rule seq_inf_par)
  ultimately have "a;b + b;a \<le>\<^sub>\<K> a*b + b*a" by (simp add: add_mono)
  thus ?thesis by (simp add: par_comm)
qed

lemma exchange_3: "(a*b) ; c \<le>\<^sub>\<K> a * (b;c)"
proof -
  have "(a*b) ; (1*c) \<le>\<^sub>\<K> (a;1) * (b;c)" by (rule exchange_2)
  thus ?thesis by simp
qed

lemma exchange_4: "a ; (b*c) \<le>\<^sub>\<K> (a;b) * c"
proof -
  have "(1*a) ; (b*c) \<le>\<^sub>\<K> (a;b) * (1;c)" by (rule exchange)
  thus ?thesis by simp
qed

lemma seqstar_inf_parstar: "a\<^sup>; \<le>\<^sub>\<K> a\<^sup>*"
proof -
  have "a ; a\<^sup>* \<le>\<^sub>\<K> a * a\<^sup>*" by (rule seq_inf_par)
  hence "1 + a ; a\<^sup>* \<le>\<^sub>\<K> 1 + a * a\<^sup>*" by (simp add: add_left_mono)
  hence "1 + a ; a\<^sup>* \<le>\<^sub>\<K> a\<^sup>*" by (simp add: star_unfoldl order_trans)
  hence "a\<^sup>; ; 1 \<le>\<^sub>\<K> a\<^sup>*" by (rule seqstar_inductl)
  thus ?thesis by simp
qed

end

end


header {* \isaheader{Generic Recursion Combinator for Complete Lattice Structured Domains} *}
theory RefineG_Recursion
imports "../Refine_Misc" RefineG_Transfer
begin

text {*
  We define a recursion combinator that asserts monotonicity.
*}

(* TODO: Once complete_lattice and ccpo typeclass are unified,
  we should also define a REC-combinator for ccpos! *)

definition REC where "REC B x \<equiv> if (mono B) then (lfp B x) else top"
definition RECT ("REC\<^sub>T") where "RECT B x \<equiv> if (mono B) then (gfp B x) else top"

lemma RECT_unfold: "mono B \<Longrightarrow> RECT B x = B (RECT B) x"
  unfolding RECT_def [abs_def]
  by (simp add: gfp_unfold[symmetric])

lemma REC_mono[refine_mono]:
  assumes [simp]: "mono B"
  assumes LE: "\<And>F x. B F x \<le> B' F x"
  shows "REC B x \<le> REC B' x"
  unfolding REC_def
  apply clarsimp
  apply (rule lfp_mono[THEN le_funD])
  apply (rule le_funI[OF LE])
  done

lemma RECT_mono[refine_mono]:
  assumes [simp]: "mono B"
  assumes LE: "\<And>F x. B F x \<le> B' F x"
  shows "RECT B x \<le> RECT B' x"
  unfolding RECT_def
  apply clarsimp
  apply (rule gfp_mono[THEN le_funD])
  apply (rule le_funI[OF LE])
  done

lemma REC_le_RECT: "REC body x \<le> RECT body x"
  unfolding REC_def RECT_def
  apply clarsimp
  apply (erule lfp_le_gfp')
  done

text {* The following lemma shows that greatest and least fixed point are equal,
  if we can provide a variant. *}
lemma RECT_eq_REC:
  assumes WF: "wf V"
  assumes I0: "I x"
  assumes IS: "\<And>f x. I x \<Longrightarrow>
    body (\<lambda>x'. if (I x' \<and> (x',x)\<in>V) then f x' else top) x \<le> body f x"
  shows "RECT body x = REC body x"
proof (cases "mono body")
  assume "\<not>mono body"
  thus ?thesis unfolding REC_def RECT_def by simp
next
  assume MONO: "mono body"

  from lfp_le_gfp' MONO have "lfp body x \<le> gfp body x" .
  moreover have "I x \<longrightarrow> gfp body x \<le> lfp body x"
    using WF
    apply (induct rule: wf_induct[consumes 1])
    apply (rule impI)
    apply (subst lfp_unfold[OF MONO])
    apply (subst gfp_unfold[OF MONO])
    apply (rule order_trans[OF _ IS])
    apply (rule monoD[OF MONO,THEN le_funD])
    apply (rule le_funI)
    apply simp
    apply simp
    done
  ultimately show ?thesis
    unfolding REC_def RECT_def
    apply (rule_tac antisym)
    using I0 MONO by auto
qed

text {*
  The following lemma is a stronger version of @{thm [source] "RECT_eq_REC"},
  which allows to keep track of a function specification, that can be used to
  argue about nested recursive calls.
*}
lemma RECT_eq_REC':
  assumes MONO: "mono body"
  assumes WF: "wf R"
  assumes I0: "I x"
  assumes IS: "\<And>f x. \<lbrakk>I x;
    \<And>x'. \<lbrakk> I x'; (x',x)\<in>R \<rbrakk> \<Longrightarrow> f x' \<le> M x'
  \<rbrakk> \<Longrightarrow>
    body (\<lambda>x'. if (I x' \<and> (x',x)\<in>R) then f x' else top) x \<le> body f x \<and>
    body f x \<le> M x"
  shows "RECT body x = REC body x \<and> RECT body x \<le> M x"
proof -
  (*assume MONO: "mono body"'*)

  from lfp_le_gfp' MONO have "lfp body x \<le> gfp body x" .
  moreover have "I x \<longrightarrow> gfp body x \<le> lfp body x \<and> lfp body x \<le> M x"
    using WF
    apply (induct rule: wf_induct[consumes 1])
    apply (rule impI)
    apply (rule conjI)
    apply (subst lfp_unfold[OF MONO])
    apply (subst gfp_unfold[OF MONO])
    apply (rule order_trans[OF _ conjunct1[OF IS]])
    apply (rule monoD[OF MONO,THEN le_funD])
    apply (rule le_funI)
    apply simp
    apply simp
    apply simp

    apply (subst lfp_unfold[OF MONO])
    apply (rule conjunct2[OF IS])
    apply simp
    apply simp
    done
  ultimately show ?thesis
    unfolding REC_def RECT_def
    using I0 MONO by auto
qed

lemma REC_rule_arb:
  fixes x::"'x" and arb::'arb
  assumes M: "mono body"
  assumes I0: "\<Phi> arb x"
  assumes IS: "\<And>f arb x. \<lbrakk>
    \<And>arb' x. \<Phi> arb' x \<Longrightarrow> f x \<le> M arb' x; \<Phi> arb x;
    f \<le> REC body
  \<rbrakk> \<Longrightarrow> body f x \<le> M arb x"
  shows "REC body x \<le> M arb x"
proof -
  have "(\<forall>arb x. \<Phi> arb x \<longrightarrow> lfp body x \<le> M arb x) \<and> lfp body \<le> REC body"
    apply (rule lfp_cadm_induct[OF _ _ M])
      apply rule
      apply rule
      apply rule
      apply rule
      apply rule
      apply (unfold Sup_fun_def) []
      apply (rule SUP_least)
      apply simp
      apply (rule Sup_least)
      apply simp

      apply (simp add: le_funI)

      apply (rule)
      apply (rule)
      apply (rule)
      apply (rule)
      apply (rule IS)
      apply blast
      apply blast
      apply (blast)
      apply (subst REC_unfold[OF M])
      apply (rule monoD[OF M])
      apply simp
    done
  thus ?thesis
    unfolding REC_def
    by (auto simp: I0 M)
qed

lemma RECT_rule_arb:
  assumes M: "mono body"
  assumes WF: "wf (V::('x\<times>'x) set)"
  assumes I0: "\<Phi> (arb::'arb) (x::'x)"
  assumes IS: "\<And>f arb x. \<lbrakk>
      \<And>arb' x'. \<lbrakk>\<Phi> arb' x'; (x',x)\<in>V\<rbrakk> \<Longrightarrow> f x' \<le> M arb' x';
      \<Phi> arb x;
      f \<le> RECT body
    \<rbrakk>  \<Longrightarrow> body f x \<le> M arb x"
  shows "RECT body x \<le> M arb x"
proof -
  have "(\<forall>arb. \<Phi> arb x \<longrightarrow> gfp body x \<le> M arb x)"
    using WF
    apply (induct x rule: wf_induct[consumes 1])
    apply (intro allI impI)
    apply (subst gfp_unfold[OF M])
    apply (rule IS)
    apply (simp)
    apply simp
    apply (simp add: RECT_def le_funI)
    done
  with I0 M show ?thesis unfolding RECT_def by auto
qed

lemma REC_rule:
  fixes x::"'x"
  assumes M: "mono body"
  assumes I0: "\<Phi> x"
  assumes IS: "\<And>f x. \<lbrakk> \<And>x. \<Phi> x \<Longrightarrow> f x \<le> M x; \<Phi> x; f \<le> REC body \<rbrakk>
    \<Longrightarrow> body f x \<le> M x"
  shows "REC body x \<le> M x"
  by (rule REC_rule_arb[where \<Phi>="\<lambda>_. \<Phi>" and M="\<lambda>_. M", OF assms])

lemma RECT_rule:
  assumes M: "mono body"
  assumes WF: "wf (V::('x\<times>'x) set)"
  assumes I0: "\<Phi> (x::'x)"
  assumes IS: "\<And>f x. \<lbrakk> \<And>x'. \<lbrakk>\<Phi> x'; (x',x)\<in>V\<rbrakk> \<Longrightarrow> f x' \<le> M x'; \<Phi> x;
                        f \<le> RECT body
    \<rbrakk> \<Longrightarrow> body f x \<le> M x"
  shows "RECT body x \<le> M x"
  by (rule RECT_rule_arb[where \<Phi>="\<lambda>_. \<Phi>" and M="\<lambda>_. M", OF assms])

(* TODO: Can we set-up induction method to work with such goals? *)
lemma REC_rule_arb2:
  assumes M: "mono body"
  assumes I0: "\<Phi> (arb::'arb) (arc::'arc) (x::'x)"
  assumes IS: "\<And>f arb arc x. \<lbrakk>
      \<And>arb' arc' x'. \<lbrakk>\<Phi> arb' arc' x' \<rbrakk> \<Longrightarrow> f x' \<le> M arb' arc' x';
      \<Phi> arb arc x; f \<le> REC body
    \<rbrakk>  \<Longrightarrow> body f x \<le> M arb arc x"
  shows "REC body x \<le> M arb arc x"
  apply (rule order_trans)
  apply (rule REC_rule_arb[
    where \<Phi>="split \<Phi>" and M="split M" and arb="(arb, arc)",
    OF M])
  by (auto intro: assms)

lemma REC_rule_arb3:
  assumes M: "mono body"
  assumes I0: "\<Phi> (arb::'arb) (arc::'arc) (ard::'ard) (x::'x)"
  assumes IS: "\<And>f arb arc ard x. \<lbrakk>
      \<And>arb' arc' ard' x'. \<lbrakk>\<Phi> arb' arc' ard' x'\<rbrakk> \<Longrightarrow> f x' \<le> M arb' arc' ard' x';
      \<Phi> arb arc ard x; f \<le> REC body
    \<rbrakk>  \<Longrightarrow> body f x \<le> M arb arc ard x"
  shows "REC body x \<le> M arb arc ard x"
  apply (rule order_trans)
  apply (rule REC_rule_arb2[
    where \<Phi>="split \<Phi>" and M="split M" and arb="(arb, arc)" and arc="ard",
    OF M])
  by (auto intro: assms)

lemma RECT_rule_arb2:
  assumes M: "mono body"
  assumes WF: "wf (V::'x rel)"
  assumes I0: "\<Phi> (arb::'arb) (arc::'arc) (x::'x)"
  assumes IS: "\<And>f arb arc x. \<lbrakk>
      \<And>arb' arc' x'. \<lbrakk>\<Phi> arb' arc' x'; (x',x)\<in>V\<rbrakk> \<Longrightarrow> f x' \<le> M arb' arc' x';
      \<Phi> arb arc x;
      f \<le> RECT body
    \<rbrakk>  \<Longrightarrow> body f x \<le> M arb arc x"
  shows "RECT body x \<le> M arb arc x"
  apply (rule order_trans)
  apply (rule RECT_rule_arb[
    where \<Phi>="split \<Phi>" and M="split M" and arb="(arb, arc)",
    OF M WF])
  by (auto intro: assms)

lemma RECT_rule_arb3:
  assumes M: "mono body"
  assumes WF: "wf (V::'x rel)"
  assumes I0: "\<Phi> (arb::'arb) (arc::'arc) (ard::'ard) (x::'x)"
  assumes IS: "\<And>f arb arc ard x. \<lbrakk>
      \<And>arb' arc' ard' x'. \<lbrakk>\<Phi> arb' arc' ard' x'; (x',x)\<in>V\<rbrakk> \<Longrightarrow> f x' \<le> M arb' arc' ard' x';
    \<Phi> arb arc ard x;
    f \<le> RECT body
  \<rbrakk>  \<Longrightarrow> body f x \<le> M arb arc ard x"
  shows "RECT body x \<le> M arb arc ard x"
  apply (rule order_trans)
  apply (rule RECT_rule_arb2[
    where \<Phi>="split \<Phi>" and M="split M" and arb="(arb, arc)" and arc="ard",
    OF M WF])
  by (auto intro: assms)

subsection {* Transfer *}

lemma (in transfer) transfer_RECT'[refine_transfer]:
  assumes REC_EQ: "\<And>x. fr x = b fr x"
  assumes REF: "\<And>F f x. \<lbrakk>\<And>x. \<alpha> (f x) \<le> F x \<rbrakk> \<Longrightarrow> \<alpha> (b f x) \<le> B F x"
  shows "\<alpha> (fr x) \<le> RECT B x"
  unfolding RECT_def
proof clarsimp
  assume MONO: "mono B"
  show "\<alpha> (fr x) \<le> gfp B x"
    apply (rule_tac x=x in spec)
    apply (rule gfp_cadm_induct[where f=B])
    apply rule
    apply (intro allI)

    apply (unfold Inf_fun_def INF_def)
    apply (drule chain_dualI)
    apply (drule_tac x=x in point_chainI)

    apply (case_tac "A={}")
    apply simp
    apply (rule Inf_greatest)
    apply (auto intro: le_funI) []

    apply simp

    apply fact

    using REF REC_EQ by force
qed

lemma (in ordered_transfer) transfer_RECT[refine_transfer]:
  assumes REF: "\<And>F f x. \<lbrakk>\<And>x. \<alpha> (f x) \<le> F x \<rbrakk> \<Longrightarrow> \<alpha> (b f x) \<le> B F x"
  assumes "mono b"
  shows "\<alpha> (RECT b x) \<le> RECT B x"
  apply (rule transfer_RECT')
  apply (rule RECT_unfold[OF `mono b`])
  by fact

lemma (in dist_transfer) transfer_REC[refine_transfer]:
  assumes REF: "\<And>F f x. \<lbrakk>\<And>x. \<alpha> (f x) \<le> F x \<rbrakk> \<Longrightarrow> \<alpha> (b f x) \<le> B F x"
  assumes "mono b"
  shows "\<alpha> (REC b x) \<le> REC B x"
  unfolding REC_def
proof (clarsimp simp add: `mono b`)
  assume "mono B"
  show "\<alpha> (lfp b x) \<le> lfp B x"
    apply (rule_tac x=x in spec)
    apply (rule lfp_cadm_induct[OF _ _ `mono b`])

    apply rule
    apply clarsimp

    apply (unfold Sup_fun_def SUP_def)
    apply (drule_tac x=x in point_chainI)
    apply (simp only: \<alpha>_dist)
    apply (rule Sup_least)
    apply auto []

    apply simp

    apply clarsimp
    apply (subst lfp_unfold[OF `mono B`])
    apply (rule REF)
    apply simp
    done
qed

end


section \<open> Extensional Mereology \<close>

(*<*)
theory EM
  imports MM
begin
(*>*)

text \<open> Extensional mereology adds to ground mereology the axiom of strong supplementation.\footnote{
See @{cite "simons_parts:_1987"} p. 29, @{cite "varzi_parts_1996"} p. 262 and @{cite "casati_parts_1999"}
p. 39-40.} \<close>

locale EM = M +
  assumes strong_supplementation:
    "\<not> P x y \<Longrightarrow> (\<exists>z. P z x \<and> \<not> O z y)"
begin

text \<open> Strong supplementation entails weak supplementation.\footnote{See @{cite "simons_parts:_1987"}
p. 29 and @{cite "casati_parts_1999"} p. 40.} \<close>

lemma weak_supplementation: "PP x y \<Longrightarrow> (\<exists>z. P z y \<and> \<not> O z x)"
proof -
  assume "PP x y"
  hence "\<not> P y x" by (rule proper_implies_not_part)
  thus "\<exists>z. P z y \<and> \<not> O z x" by (rule strong_supplementation)
qed

end

text \<open> So minimal mereology is a subtheory of extensional mereology.\footnote{@{cite "casati_parts_1999"} p. 40.} \<close>

sublocale EM \<subseteq> MM
proof
  fix y x
  show "PP y x \<Longrightarrow> \<exists>z. P z x \<and> \<not> O z y" using weak_supplementation.
qed

text \<open> Strong supplementation also entails the proper parts principle.\footnote{See @{cite "simons_parts:_1987"}
pp. 28-9 and @{cite "varzi_parts_1996"} p. 263.} \<close>

context EM
begin

lemma proper_parts_principle:
"(\<exists>z. PP z x) \<Longrightarrow> (\<forall>z. PP z x \<longrightarrow> P z y) \<Longrightarrow> P x y"
proof -
  assume "\<exists>z. PP z x"
  then obtain v where v: "PP v x"..
  hence "P v x" by (rule proper_implies_part)
  assume antecedent: "\<forall>z. PP z x \<longrightarrow> P z y"
  hence "PP v x \<longrightarrow> P v y"..
  hence "P v y" using `PP v x`..
  with `P v x` have "P v x \<and> P v y"..
  hence "\<exists>v. P v x \<and> P v y"..
  with overlap_eq have "O x y"..
  show "P x y"
  proof (rule ccontr)
    assume "\<not> P x y"
    hence "\<exists>z. P z x \<and> \<not> O z y"
      by (rule strong_supplementation)
    then obtain z where z: "P z x \<and> \<not> O z y"..
    hence "P z x"..
    moreover have "z \<noteq> x"
    proof
      assume "z = x"
      moreover from z have "\<not> O z y"..
      ultimately have "\<not> O x y" by (rule subst)
      thus "False"  using `O x y`..
    qed
    ultimately have "P z x \<and> z \<noteq> x"..
    with nip_eq have "PP z x"..
    from antecedent have "PP z x \<longrightarrow> P z y"..
    hence "P z y" using `PP z x`..
    hence "O z y" by (rule part_implies_overlap)
    from z have "\<not> O z y"..
    thus "False" using `O z y`..
  qed
qed

text \<open> Which with antisymmetry entails the extensionality of proper parthood.\footnote{See
@{cite "simons_parts:_1987"} p. 28, @{cite "varzi_parts_1996"} p. 263 and @{cite "casati_parts_1999"}
p. 40.} \<close>

theorem proper_part_extensionality:
"(\<exists>z. PP z x \<or> PP z y) \<Longrightarrow> x = y \<longleftrightarrow> (\<forall>z. PP z x \<longleftrightarrow> PP z y)"
proof -
  assume antecedent: "\<exists>z. PP z x \<or> PP z y"
  show "x = y \<longleftrightarrow> (\<forall>z. PP z x \<longleftrightarrow> PP z y)"
  proof
    assume "x = y"
    moreover have "\<forall>z. PP z x \<longleftrightarrow> PP z x" by simp
    ultimately show "\<forall>z. PP z x \<longleftrightarrow> PP z y" by (rule subst)
  next
    assume right: "\<forall>z. PP z x \<longleftrightarrow> PP z y"
    have "\<forall>z. PP z x \<longrightarrow> P z y"
    proof
      fix z
      show "PP z x \<longrightarrow> P z y"
      proof
        assume "PP z x"
        from right have "PP z x \<longleftrightarrow> PP z y"..
        hence "PP z y" using `PP z x`..
        thus "P z y" by (rule proper_implies_part)
      qed
    qed
    have "\<forall>z. PP z y \<longrightarrow> P z x"
    proof
      fix z
      show "PP z y \<longrightarrow> P z x"
      proof
        assume "PP z y"
        from right have "PP z x \<longleftrightarrow> PP z y"..
        hence "PP z x" using `PP z y`..
        thus "P z x" by (rule proper_implies_part)
      qed
    qed
    from antecedent obtain z where z: "PP z x \<or> PP z y"..
    thus "x = y"
    proof (rule disjE)
      assume "PP z x"
      hence "\<exists>z. PP z x"..
      hence "P x y" using `\<forall>z. PP z x \<longrightarrow> P z y`
        by (rule proper_parts_principle)
      from right have "PP z x \<longleftrightarrow> PP z y"..
      hence "PP z y" using `PP z x`..
      hence "\<exists>z. PP z y"..
      hence "P y x" using `\<forall>z. PP z y \<longrightarrow> P z x`
        by (rule proper_parts_principle)
      with `P x y` show "x = y"
        by (rule part_antisymmetry)
    next
      assume "PP z y"
      hence "\<exists>z. PP z y"..
      hence "P y x" using `\<forall>z. PP z y \<longrightarrow> P z x`
        by (rule proper_parts_principle)
      from right have "PP z x \<longleftrightarrow> PP z y"..
      hence "PP z x" using `PP z y`..
      hence "\<exists>z. PP z x"..
      hence "P x y" using `\<forall>z. PP z x \<longrightarrow> P z y`
          by (rule proper_parts_principle)
      thus "x = y"
        using `P y x` by (rule part_antisymmetry)
    qed
  qed
qed

text \<open> It also follows from strong supplementation that parthood is definable in terms of overlap.\footnote{
See @{cite "parsons_many_2014"} p. 4.}  \<close>

lemma part_overlap_eq: "P x y \<longleftrightarrow> (\<forall>z. O z x \<longrightarrow> O z y)"
proof
  assume "P x y"
  show "(\<forall>z. O z x \<longrightarrow> O z y)"
  proof
    fix z
    show "O z x \<longrightarrow> O z y"
    proof
      assume "O z x"
      with `P x y` show "O z y"
        by (rule overlap_monotonicity)
    qed
  qed
next
  assume right: "\<forall>z. O z x \<longrightarrow> O z y"
  show "P x y"
  proof (rule ccontr)
    assume "\<not> P x y"
    hence "\<exists>z. P z x \<and> \<not> O z y"
      by (rule strong_supplementation)
    then obtain z where z: "P z x \<and> \<not> O z y"..
    hence "\<not> O z y"..
    from right have "O z x \<longrightarrow> O z y"..
    moreover from z have "P z x"..
    hence "O z x" by (rule part_implies_overlap)
    ultimately have "O z y"..
    with `\<not> O z y` show "False"..
  qed
qed

text \<open> Which entails the extensionality of overlap. \<close>

theorem overlap_extensionality: "x = y \<longleftrightarrow> (\<forall>z. O z x \<longleftrightarrow> O z y)"
proof
  assume "x = y"
  moreover have "\<forall>z. O z x \<longleftrightarrow> O z x"
  proof
    fix z
    show "O z x \<longleftrightarrow> O z x"..
  qed
  ultimately show "\<forall>z. O z x \<longleftrightarrow> O z y"
    by (rule subst)
next
  assume right: "\<forall>z. O z x \<longleftrightarrow> O z y"
  have "\<forall>z. O z y \<longrightarrow> O z x"
  proof
    fix z
    from right have "O z x \<longleftrightarrow> O z y"..
    thus "O z y \<longrightarrow> O z x"..
  qed
  with part_overlap_eq have "P y x"..
  have "\<forall>z. O z x \<longrightarrow> O z y"
  proof
    fix z
    from right have "O z x \<longleftrightarrow> O z y"..
    thus "O z x \<longrightarrow> O z y"..
  qed
  with part_overlap_eq have "P x y"..
  thus "x = y"
    using `P y x` by (rule part_antisymmetry)
qed

end

(*<*) end (*>*)


(* Author:     Johannes Hoelzl <hoelzl@in.tum.de> 2009 *)

theory Approximation_Ex
imports Complex_Main "../Approximation"
begin

text {*

Here are some examples how to use the approximation method.

The approximation method has the following syntax:

approximate "prec" (splitting: "x" = "depth" and "y" = "depth" ...)? (taylor: "z" = "derivates")?

Here "prec" specifies the precision used in all computations, it is specified as
number of bits to calculate. In the proposition to prove an arbitrary amount of
variables can be used, but each one need to be bounded by an upper and lower
bound.

To specify the bounds either @{term "l\<^sub>1 \<le> x \<and> x \<le> u\<^sub>1"},
@{term "x \<in> { l\<^sub>1 .. u\<^sub>1 }"} or @{term "x = bnd"} can be used. Where the
bound specification are again arithmetic formulas containing variables. They can
be connected using either meta level or HOL equivalence.

To use interval splitting add for each variable whos interval should be splitted
to the "splitting:" parameter. The parameter specifies how often each interval
should be divided, e.g. when x = 16 is specified, there will be @{term "65536 = 2^16"}
intervals to be calculated.

To use taylor series expansion specify the variable to derive. You need to
specify the amount of derivations to compute. When using taylor series expansion
only one variable can be used.

*}

section "Compute some transcendental values"

lemma "\<bar> ln 2 - 544531980202654583340825686620847 / 785593587443817081832229725798400 \<bar> < inverse (2^51) "
  by (approximation 60)

lemma "\<bar> exp 1.626 - 5.083499996273 \<bar> < (inverse 10 ^ 10 :: real)"
  by (approximation 40)

lemma "\<bar> sqrt 2 - 1.4142135623730951 \<bar> < inverse 10 ^ 16"
  by (approximation 60)

lemma "\<bar> pi - 3.1415926535897932385 \<bar> < inverse 10 ^ 18"
  by (approximation 70)

lemma "\<bar> sin 100 + 0.50636564110975879 \<bar> < inverse 10 ^ 17"
  by (approximation 70)

section "Use variable ranges"

lemma "0.5 \<le> x \<and> x \<le> 4.5 \<Longrightarrow> \<bar> arctan x - 0.91 \<bar> < 0.455"
  by (approximation 10)

lemma "x \<in> {0.5 .. 4.5} \<longrightarrow> \<bar> arctan x - 0.91 \<bar> < 0.455"
  by (approximation 10)

lemma "0.49 \<le> x \<and> x \<le> 4.49 \<Longrightarrow> \<bar> arctan x - 0.91 \<bar> < 0.455"
  by (approximation 20)

lemma "1 / 2^1 \<le> x \<and> x \<le> 9 / 2^1 \<Longrightarrow> \<bar> arctan x - 0.91 \<bar> < 0.455"
  by (approximation 10)

lemma "3.2 \<le> x \<and> x \<le> 6.2 \<Longrightarrow> sin x \<le> 0"
  by (approximation 10)

lemma
  defines "g \<equiv> 9.80665" and "v \<equiv> 128.61" and "d \<equiv> pi / 180"
  shows "g / v * tan (35 * d) \<in> { 3 * d .. 3.1 * d }"
  using assms by (approximation 20)

lemma "x \<in> { 0 .. 1 :: real } \<longrightarrow> x\<^sup>2 \<le> x"
  by (approximation 30 splitting: x=1 taylor: x = 3)

approximate "10"

end


section \<open>Section 10.4\<close>

theory Ex1
imports "../LCF"
begin

axiomatization
  P     :: "'a \<Rightarrow> tr" and
  G     :: "'a \<Rightarrow> 'a" and
  H     :: "'a \<Rightarrow> 'a" and
  K     :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
where
  P_strict:     "P(UU) = UU" and
  K:            "K = (\<lambda>h x. P(x) \<Rightarrow> x | h(h(G(x))))" and
  H:            "H = FIX(K)"

declare P_strict [simp] K [simp]

lemma H_unfold: "H = K(H)"
  apply (simplesubst H)
  apply (rule FIX_eq [symmetric])
  done

lemma H_strict [simp]: "H(UU)=UU"
  apply (simplesubst H_unfold)
  apply simp
  done

lemma H_idemp_lemma: "\<forall>x. H(FIX(K,x)) = FIX(K,x)"
  apply (induct K)
  apply simp
  apply (simp split: COND_cases_iff)
  apply (intro strip)
  apply (subst H_unfold)
  apply simp
  done

lemma H_idemp: "\<forall>x. H(H(x)) = H(x)"
  apply (rule H_idemp_lemma [folded H])
  done

end