(* Author: Tobias Nipkow *)

subsection "Abstract Interpretation"

theory Abs_Int0
imports "HOL-IMP.Abs_Int_init"
begin

subsubsection "Orderings"

text\<open>The basic type classes \<^class>\<open>order\<close>, \<^class>\<open>semilattice_sup\<close> and \<^class>\<open>order_top\<close> are
defined in \<^theory>\<open>Main\<close>, more precisely in theories \<^theory>\<open>HOL.Orderings\<close> and \<^theory>\<open>HOL.Lattices\<close>.
If you view this theory with jedit, just click on the names to get there.\<close>

class semilattice_sup_top = semilattice_sup + order_top

instance "fun" :: (type, semilattice_sup_top) semilattice_sup_top ..

instantiation option :: (order)order
begin

fun less_eq_option where
"Some x \<le> Some y = (x \<le> y)" |
"None \<le> y = True" |
"Some _ \<le> None = False"

definition less_option where "x < (y::'a option) = (x \<le> y \<and> \<not> y \<le> x)"

lemma le_None[simp]: "(x \<le> None) = (x = None)"
by (cases x) simp_all

lemma Some_le[simp]: "(Some x \<le> u) = (\<exists>y. u = Some y \<and> x \<le> y)"
by (cases u) auto

instance
proof (standard, goal_cases)
  case 1 show ?case by(rule less_option_def)
next
  case (2 x) show ?case by(cases x, simp_all)
next
  case (3 x y z) thus ?case by(cases z, simp, cases y, simp, cases x, auto)
next
  case (4 x y) thus ?case by(cases y, simp, cases x, auto)
qed

end

instantiation option :: (sup)sup
begin

fun sup_option where
"Some x \<squnion> Some y = Some(x \<squnion> y)" |
"None \<squnion> y = y" |
"x \<squnion> None = x"

lemma sup_None2[simp]: "x \<squnion> None = x"
by (cases x) simp_all

instance ..

end

instantiation option :: (semilattice_sup_top)semilattice_sup_top
begin

definition top_option where "\<top> = Some \<top>"

instance
proof (standard, goal_cases)
  case (4 a) show ?case by(cases a, simp_all add: top_option_def)
next
  case (1 x y) thus ?case by(cases x, simp, cases y, simp_all)
next
  case (2 x y) thus ?case by(cases y, simp, cases x, simp_all)
next
  case (3 x y z) thus ?case by(cases z, simp, cases y, simp, cases x, simp_all)
qed

end

instantiation option :: (order)order_bot
begin

definition bot_option :: "'a option" where
"\<bottom> = None"

instance
proof (standard, goal_cases)
  case 1 thus ?case by(auto simp: bot_option_def)
qed

end

definition bot :: "com \<Rightarrow> 'a option acom" where
"bot c = annotate (\<lambda>p. None) c"

lemma bot_least: "strip C = c \<Longrightarrow> bot c \<le> C"
by(auto simp: bot_def less_eq_acom_def)

lemma strip_bot[simp]: "strip(bot c) = c"
by(simp add: bot_def)

subsubsection "Pre-fixpoint iteration"

definition pfp :: "(('a::order) \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
"pfp f = while_option (\<lambda>x. \<not> f x \<le> x) f"

lemma pfp_pfp: assumes "pfp f x0 = Some x" shows "f x \<le> x"
using while_option_stop[OF assms[simplified pfp_def]] by simp

lemma while_least:
fixes q :: "'a::order"
assumes "\<forall>x\<in>L.\<forall>y\<in>L. x \<le> y \<longrightarrow> f x \<le> f y" and "\<forall>x. x \<in> L \<longrightarrow> f x \<in> L"
and "\<forall>x \<in> L. b \<le> x" and "b \<in> L" and "f q \<le> q" and "q \<in> L"
and "while_option P f b = Some p"
shows "p \<le> q"
using while_option_rule[OF _  assms(7)[unfolded pfp_def],
                        where P = "%x. x \<in> L \<and> x \<le> q"]
by (metis assms(1-6) order_trans)

lemma pfp_bot_least:
assumes "\<forall>x\<in>{C. strip C = c}.\<forall>y\<in>{C. strip C = c}. x \<le> y \<longrightarrow> f x \<le> f y"
and "\<forall>C. C \<in> {C. strip C = c} \<longrightarrow> f C \<in> {C. strip C = c}"
and "f C' \<le> C'" "strip C' = c" "pfp f (bot c) = Some C"
shows "C \<le> C'"
by(rule while_least[OF assms(1,2) _ _ assms(3) _ assms(5)[unfolded pfp_def]])
  (simp_all add: assms(4) bot_least)

lemma pfp_inv:
  "pfp f x = Some y \<Longrightarrow> (\<And>x. P x \<Longrightarrow> P(f x)) \<Longrightarrow> P x \<Longrightarrow> P y"
unfolding pfp_def by (blast intro: while_option_rule)

lemma strip_pfp:
assumes "\<And>x. g(f x) = g x" and "pfp f x0 = Some x" shows "g x = g x0"
using pfp_inv[OF assms(2), where P = "%x. g x = g x0"] assms(1) by simp

subsubsection "Abstract Interpretation"

definition \<gamma>_fun :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'b)set" where
"\<gamma>_fun \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(F x)}"

fun \<gamma>_option :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a option \<Rightarrow> 'b set" where
"\<gamma>_option \<gamma> None = {}" |
"\<gamma>_option \<gamma> (Some a) = \<gamma> a"

text\<open>The interface for abstract values:\<close>

locale Val_semilattice =
fixes \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
  assumes mono_gamma: "a \<le> b \<Longrightarrow> \<gamma> a \<le> \<gamma> b"
  and gamma_Top[simp]: "\<gamma> \<top> = UNIV"
fixes num' :: "val \<Rightarrow> 'av"
  and plus' :: "'av \<Rightarrow> 'av \<Rightarrow> 'av"
  and less' :: "'av \<Rightarrow> 'av \<Rightarrow> bool option"
assumes gamma_num': "i \<in> \<gamma>(num' i)"
  and gamma_plus': "\<lbrakk>i1 \<in> \<gamma> a1; i2 \<in> \<gamma> a2\<rbrakk> \<Longrightarrow> i1+i2 \<in> \<gamma>(plus' a1 a2)"
  and gamma_less': "\<lbrakk>i1 \<in> \<gamma> a1; i2 \<in> \<gamma> a2\<rbrakk> \<Longrightarrow> less' a1 a2 = None \<or> less' a1 a2 = Some (i1 < i2)"

type_synonym 'av st = "(vname \<Rightarrow> 'av)"

text\<open>The for-clause (here and elsewhere) only serves the purpose of fixing
the name of the type parameter \<^typ>\<open>'av\<close> which would otherwise be renamed to
\<^typ>\<open>'a\<close>.\<close>

locale Abs_Int_fun = Val_semilattice where \<gamma>=\<gamma>
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
begin

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

definition "asem x e S = (case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(S(x := aval' e S)))"

definition "step' = Step asem (\<lambda>b S. S)"

lemma strip_step'[simp]: "strip(step' S C) = strip C"
by(simp add: step'_def)

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

abbreviation \<gamma>\<^sub>s :: "'av st \<Rightarrow> state set"
where "\<gamma>\<^sub>s == \<gamma>_fun \<gamma>"

abbreviation \<gamma>\<^sub>o :: "'av st option \<Rightarrow> state set"
where "\<gamma>\<^sub>o == \<gamma>_option \<gamma>\<^sub>s"

abbreviation \<gamma>\<^sub>c :: "'av st option acom \<Rightarrow> state set acom"
where "\<gamma>\<^sub>c == map_acom \<gamma>\<^sub>o"

lemma gamma_s_Top[simp]: "\<gamma>\<^sub>s \<top> = UNIV"
by(simp add: top_fun_def \<gamma>_fun_def)

lemma gamma_o_Top[simp]: "\<gamma>\<^sub>o \<top> = UNIV"
by (simp add: top_option_def)

lemma mono_gamma_s: "f1 \<le> f2 \<Longrightarrow> \<gamma>\<^sub>s f1 \<subseteq> \<gamma>\<^sub>s f2"
by(auto simp: le_fun_def \<gamma>_fun_def dest: mono_gamma)

lemma mono_gamma_o:
  "S1 \<le> S2 \<Longrightarrow> \<gamma>\<^sub>o S1 \<subseteq> \<gamma>\<^sub>o S2"
by(induction S1 S2 rule: less_eq_option.induct)(simp_all add: mono_gamma_s)

lemma mono_gamma_c: "C1 \<le> C2 \<Longrightarrow> \<gamma>\<^sub>c C1 \<le> \<gamma>\<^sub>c C2"
by (simp add: less_eq_acom_def mono_gamma_o size_annos anno_map_acom size_annos_same[of C1 C2])

text\<open>Correctness:\<close>

lemma aval'_correct: "s \<in> \<gamma>\<^sub>s S \<Longrightarrow> aval a s \<in> \<gamma>(aval' a S)"
by (induct a) (auto simp: gamma_num' gamma_plus' \<gamma>_fun_def)

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

lemma gamma_Step_subcomm:
  assumes "\<And>x e S. f1 x e (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (f2 x e S)"  "\<And>b S. g1 b (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (g2 b S)"
  shows "Step f1 g1 (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (Step f2 g2 S C)"
by (induction C arbitrary: S) (auto simp: mono_gamma_o assms)

lemma step_step': "step (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' S C)"
unfolding step_def step'_def
by(rule gamma_Step_subcomm)
  (auto simp: aval'_correct in_gamma_update asem_def split: option.splits)

lemma AI_correct: "AI c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
proof(simp add: CS_def AI_def)
  assume 1: "pfp (step' \<top>) (bot c) = Some C"
  have pfp': "step' \<top> C \<le> C" by(rule pfp_pfp[OF 1])
  have 2: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"  \<comment> \<open>transfer the pfp'\<close>
  proof(rule order_trans)
    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' \<top> C)" by(rule step_step')
    show "... \<le> \<gamma>\<^sub>c C" by (metis mono_gamma_c[OF pfp'])
  qed
  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp[OF _ 1] step'_def)
  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 2])
  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
qed

end

subsubsection "Monotonicity"

locale Abs_Int_fun_mono = Abs_Int_fun +
assumes mono_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> plus' a1 a2 \<le> plus' b1 b2"
begin

lemma mono_aval': "S \<le> S' \<Longrightarrow> aval' e S \<le> aval' e S'"
by(induction e)(auto simp: le_fun_def mono_plus')

lemma mono_update: "a \<le> a' \<Longrightarrow> S \<le> S' \<Longrightarrow> S(x := a) \<le> S'(x := a')"
by(simp add: le_fun_def)

lemma mono_step': "S1 \<le> S2 \<Longrightarrow> C1 \<le> C2 \<Longrightarrow> step' S1 C1 \<le> step' S2 C2"
unfolding step'_def
by(rule mono2_Step)
  (auto simp: mono_update mono_aval' asem_def split: option.split)

lemma mono_step'_top: "C \<le> C' \<Longrightarrow> step' \<top> C \<le> step' \<top> C'"
by (metis mono_step' order_refl)

lemma AI_least_pfp: assumes "AI c = Some C" "step' \<top> C' \<le> C'" "strip C' = c"
shows "C \<le> C'"
by(rule pfp_bot_least[OF _ _ assms(2,3) assms(1)[unfolded AI_def]])
  (simp_all add: mono_step'_top)

end

instantiation acom :: (type) vars
begin

definition "vars_acom = vars o strip"

instance ..

end

lemma finite_Cvars: "finite(vars(C::'a acom))"
by(simp add: vars_acom_def)

subsubsection "Termination"

lemma pfp_termination:
fixes x0 :: "'a::order" and m :: "'a \<Rightarrow> nat"
assumes mono: "\<And>x y. I x \<Longrightarrow> I y \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
and m: "\<And>x y. I x \<Longrightarrow> I y \<Longrightarrow> x < y \<Longrightarrow> m x > m y"
and I: "\<And>x y. I x \<Longrightarrow> I(f x)" and "I x0" and "x0 \<le> f x0"
shows "\<exists>x. pfp f x0 = Some x"
proof(simp add: pfp_def, rule wf_while_option_Some[where P = "%x. I x & x \<le> f x"])
  show "wf {(y,x). ((I x \<and> x \<le> f x) \<and> \<not> f x \<le> x) \<and> y = f x}"
    by(rule wf_subset[OF wf_measure[of m]]) (auto simp: m I)
next
  show "I x0 \<and> x0 \<le> f x0" using \<open>I x0\<close> \<open>x0 \<le> f x0\<close> by blast
next
  fix x assume "I x \<and> x \<le> f x" thus "I(f x) \<and> f x \<le> f(f x)"
    by (blast intro: I mono)
qed

lemma le_iff_le_annos: "C1 \<le> C2 \<longleftrightarrow>
  strip C1 = strip C2 \<and> (\<forall> i<size(annos C1). annos C1 ! i \<le> annos C2 ! i)"
by(simp add: less_eq_acom_def anno_def)

locale Measure1_fun =
fixes m :: "'av::top \<Rightarrow> nat"
fixes h :: "nat"
assumes h: "m x \<le> h"
begin

definition m_s :: "'av st \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>s") where
"m_s S X = (\<Sum> x \<in> X. m(S x))"

lemma m_s_h: "finite X \<Longrightarrow> m_s S X \<le> h * card X"
by(simp add: m_s_def) (metis mult.commute of_nat_id sum_bounded_above[OF h])

fun m_o :: "'av st option \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>o") where
"m_o (Some S) X = m_s S X" |
"m_o None X = h * card X + 1"

lemma m_o_h: "finite X \<Longrightarrow> m_o opt X \<le> (h*card X + 1)"
by(cases opt)(auto simp add: m_s_h le_SucI dest: m_s_h)

definition m_c :: "'av st option acom \<Rightarrow> nat" ("m\<^sub>c") where
"m_c C = sum_list (map (\<lambda>a. m_o a (vars C)) (annos C))"

text\<open>Upper complexity bound:\<close>
lemma m_c_h: "m_c C \<le> size(annos C) * (h * card(vars C) + 1)"
proof-
  let ?X = "vars C" let ?n = "card ?X" let ?a = "size(annos C)"
  have "m_c C = (\<Sum>i<?a. m_o (annos C ! i) ?X)"
    by(simp add: m_c_def sum_list_sum_nth atLeast0LessThan)
  also have "\<dots> \<le> (\<Sum>i<?a. h * ?n + 1)"
    apply(rule sum_mono) using m_o_h[OF finite_Cvars] by simp
  also have "\<dots> = ?a * (h * ?n + 1)" by simp
  finally show ?thesis .
qed

end

locale Measure_fun = Measure1_fun where m=m
  for m :: "'av::semilattice_sup_top \<Rightarrow> nat" +
assumes m2: "x < y \<Longrightarrow> m x > m y"
begin

text\<open>The predicates \<open>top_on_ty a X\<close> that follow describe that any abstract
state in \<open>a\<close> maps all variables in \<open>X\<close> to \<^term>\<open>\<top>\<close>.
This is an important invariant for the termination proof where we argue that only
the finitely many variables in the program change. That the others do not change
follows because they remain \<^term>\<open>\<top>\<close>.\<close>

fun top_on_st :: "'av st \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>s") where
"top_on_st S X = (\<forall>x\<in>X. S x = \<top>)"

fun top_on_opt :: "'av st option \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>o") where
"top_on_opt (Some S) X = top_on_st S X" |
"top_on_opt None X = True"

definition top_on_acom :: "'av st option acom \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>c") where
"top_on_acom C X = (\<forall>a \<in> set(annos C). top_on_opt a X)"

lemma top_on_top: "top_on_opt \<top> X"
by(auto simp: top_option_def)

lemma top_on_bot: "top_on_acom (bot c) X"
by(auto simp add: top_on_acom_def bot_def)

lemma top_on_post: "top_on_acom C X \<Longrightarrow> top_on_opt (post C) X"
by(simp add: top_on_acom_def post_in_annos)

lemma top_on_acom_simps:
  "top_on_acom (SKIP {Q}) X = top_on_opt Q X"
  "top_on_acom (x ::= e {Q}) X = top_on_opt Q X"
  "top_on_acom (C1;;C2) X = (top_on_acom C1 X \<and> top_on_acom C2 X)"
  "top_on_acom (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) X =
   (top_on_opt P1 X \<and> top_on_acom C1 X \<and> top_on_opt P2 X \<and> top_on_acom C2 X \<and> top_on_opt Q X)"
  "top_on_acom ({I} WHILE b DO {P} C {Q}) X =
   (top_on_opt I X \<and> top_on_acom C X \<and> top_on_opt P X \<and> top_on_opt Q X)"
by(auto simp add: top_on_acom_def)

lemma top_on_sup:
  "top_on_opt o1 X \<Longrightarrow> top_on_opt o2 X \<Longrightarrow> top_on_opt (o1 \<squnion> o2) X"
apply(induction o1 o2 rule: sup_option.induct)
apply(auto)
done

lemma top_on_Step: fixes C :: "'av st option acom"
assumes "!!x e S. \<lbrakk>top_on_opt S X; x \<notin> X; vars e \<subseteq> -X\<rbrakk> \<Longrightarrow> top_on_opt (f x e S) X"
        "!!b S. top_on_opt S X \<Longrightarrow> vars b \<subseteq> -X \<Longrightarrow> top_on_opt (g b S) X"
shows "\<lbrakk> vars C \<subseteq> -X; top_on_opt S X; top_on_acom C X \<rbrakk> \<Longrightarrow> top_on_acom (Step f g S C) X"
proof(induction C arbitrary: S)
qed (auto simp: top_on_acom_simps vars_acom_def top_on_post top_on_sup assms)

lemma m1: "x \<le> y \<Longrightarrow> m x \<ge> m y"
by(auto simp: le_less m2)

lemma m_s2_rep: assumes "finite(X)" and "S1 = S2 on -X" and "\<forall>x. S1 x \<le> S2 x" and "S1 \<noteq> S2"
shows "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))"
proof-
  from assms(3) have 1: "\<forall>x\<in>X. m(S1 x) \<ge> m(S2 x)" by (simp add: m1)
  from assms(2,3,4) have "\<exists>x\<in>X. S1 x < S2 x"
    by(simp add: fun_eq_iff) (metis Compl_iff le_neq_trans)
  hence 2: "\<exists>x\<in>X. m(S1 x) > m(S2 x)" by (metis m2)
  from sum_strict_mono_ex1[OF \<open>finite X\<close> 1 2]
  show "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))" .
qed

lemma m_s2: "finite(X) \<Longrightarrow> S1 = S2 on -X \<Longrightarrow> S1 < S2 \<Longrightarrow> m_s S1 X > m_s S2 X"
apply(auto simp add: less_fun_def m_s_def)
apply(simp add: m_s2_rep le_fun_def)
done

lemma m_o2: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 < o2 \<Longrightarrow> m_o o1 X > m_o o2 X"
proof(induction o1 o2 rule: less_eq_option.induct)
  case 1 thus ?case by (auto simp: m_s2 less_option_def)
next
  case 2 thus ?case by(auto simp: less_option_def le_imp_less_Suc m_s_h)
next
  case 3 thus ?case by (auto simp: less_option_def)
qed

lemma m_o1: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 \<le> o2 \<Longrightarrow> m_o o1 X \<ge> m_o o2 X"
by(auto simp: le_less m_o2)

lemma m_c2: "top_on_acom C1 (-vars C1) \<Longrightarrow> top_on_acom C2 (-vars C2) \<Longrightarrow>
  C1 < C2 \<Longrightarrow> m_c C1 > m_c C2"
proof(auto simp add: le_iff_le_annos size_annos_same[of C1 C2] vars_acom_def less_acom_def)
  let ?X = "vars(strip C2)"
  assume top: "top_on_acom C1 (- vars(strip C2))"  "top_on_acom C2 (- vars(strip C2))"
  and strip_eq: "strip C1 = strip C2"
  and 0: "\<forall>i<size(annos C2). annos C1 ! i \<le> annos C2 ! i"
  hence 1: "\<forall>i<size(annos C2). m_o (annos C1 ! i) ?X \<ge> m_o (annos C2 ! i) ?X"
    apply (auto simp: all_set_conv_all_nth vars_acom_def top_on_acom_def)
    by (metis (lifting, no_types) finite_cvars m_o1 size_annos_same2)
  fix i assume i: "i < size(annos C2)" "\<not> annos C2 ! i \<le> annos C1 ! i"
  have topo1: "top_on_opt (annos C1 ! i) (- ?X)"
    using i(1) top(1) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
  have topo2: "top_on_opt (annos C2 ! i) (- ?X)"
    using i(1) top(2) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
  from i have "m_o (annos C1 ! i) ?X > m_o (annos C2 ! i) ?X" (is "?P i")
    by (metis 0 less_option_def m_o2[OF finite_cvars topo1] topo2)
  hence 2: "\<exists>i < size(annos C2). ?P i" using \<open>i < size(annos C2)\<close> by blast
  have "(\<Sum>i<size(annos C2). m_o (annos C2 ! i) ?X)
         < (\<Sum>i<size(annos C2). m_o (annos C1 ! i) ?X)"
    apply(rule sum_strict_mono_ex1) using 1 2 by (auto)
  thus ?thesis
    by(simp add: m_c_def vars_acom_def strip_eq sum_list_sum_nth atLeast0LessThan size_annos_same[OF strip_eq])
qed

end

locale Abs_Int_fun_measure =
  Abs_Int_fun_mono where \<gamma>=\<gamma> + Measure_fun where m=m
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set" and m :: "'av \<Rightarrow> nat"
begin

lemma top_on_step': "top_on_acom C (-vars C) \<Longrightarrow> top_on_acom (step' \<top> C) (-vars C)"
unfolding step'_def
by(rule top_on_Step)
  (auto simp add: top_option_def asem_def split: option.splits)

lemma AI_Some_measure: "\<exists>C. AI c = Some C"
unfolding AI_def
apply(rule pfp_termination[where I = "\<lambda>C. top_on_acom C (- vars C)" and m="m_c"])
apply(simp_all add: m_c2 mono_step'_top bot_least top_on_bot)
using top_on_step' apply(auto simp add: vars_acom_def)
done

end

text\<open>Problem: not executable because of the comparison of abstract states,
i.e. functions, in the pre-fixpoint computation.\<close>

end


theory Ground_Closure
  imports Ground_Terms
begin

subsubsection \<open>Multihole context closure\<close>

text \<open>Computing the multihole context closure of a given relation\<close>
inductive_set gmctxt_cl :: "('f \<times> nat) set \<Rightarrow> 'f gterm rel \<Rightarrow> 'f gterm rel" for \<F> \<R> where
  base [intro]: "(s, t) \<in> \<R> \<Longrightarrow> (s, t) \<in> gmctxt_cl \<F> \<R>"
| step [intro]: "length ss = length ts \<Longrightarrow> (\<forall> i < length ts. (ss ! i, ts ! i) \<in> gmctxt_cl \<F> \<R>) \<Longrightarrow> (f, length ss) \<in> \<F> \<Longrightarrow>
    (GFun f ss, GFun f ts) \<in> gmctxt_cl \<F> \<R>"

lemma gmctxt_cl_idemp [simp]:
  "gmctxt_cl \<F> (gmctxt_cl \<F> \<R>) = gmctxt_cl \<F> \<R>"
proof -
  {fix s t assume "(s, t) \<in> gmctxt_cl \<F> (gmctxt_cl \<F> \<R>)"
    then have "(s, t) \<in> gmctxt_cl \<F> \<R>"
      by (induct) (auto intro: gmctxt_cl.step)}
  then show ?thesis by auto
qed

lemma gmctxt_cl_refl:
  "funas_gterm t \<subseteq> \<F> \<Longrightarrow> (t, t) \<in> gmctxt_cl \<F> \<R>"
  by (induct t) (auto simp: SUP_le_iff intro!: gmctxt_cl.step)

lemma gmctxt_cl_swap:
  "gmctxt_cl \<F> (prod.swap ` \<R>) = prod.swap ` gmctxt_cl \<F> \<R>" (is "?Ls = ?Rs")
proof -
  {fix s t assume "(s, t) \<in> ?Ls" then have "(s, t) \<in> ?Rs"
      by induct auto}
  moreover
  {fix s t assume "(s, t) \<in> ?Rs"
    then have "(t, s) \<in> gmctxt_cl \<F> \<R>" by auto
    then have "(s, t) \<in> ?Ls" by induct auto}
  ultimately show ?thesis by auto
qed

lemma gmctxt_cl_mono_funas:
  assumes "\<F> \<subseteq> \<G>" shows "gmctxt_cl \<F> \<R> \<subseteq> gmctxt_cl \<G> \<R>"
proof -
  {fix s t assume "(s, t) \<in> gmctxt_cl \<F> \<R>" then have "(s, t) \<in> gmctxt_cl \<G> \<R>"
      by induct (auto simp: subsetD[OF assms])}
  then show ?thesis by auto
qed

lemma gmctxt_cl_mono_rel:
  assumes "\<P> \<subseteq> \<R>" shows "gmctxt_cl \<F> \<P> \<subseteq> gmctxt_cl \<F> \<R>"
proof -
  {fix s t assume "(s, t) \<in> gmctxt_cl \<F> \<P>" then have "(s, t) \<in> gmctxt_cl \<F> \<R>" using assms
      by induct auto}
  then show ?thesis by auto
qed

definition gcomp_rel :: "('f \<times> nat) set \<Rightarrow> 'f gterm rel \<Rightarrow> 'f gterm rel \<Rightarrow> 'f gterm rel" where
  "gcomp_rel \<F> R S = (R O gmctxt_cl \<F> S) \<union> (gmctxt_cl \<F> R O S)"

definition gtrancl_rel :: "('f \<times> nat) set \<Rightarrow> 'f gterm rel \<Rightarrow> 'f gterm rel" where
  "gtrancl_rel \<F> \<R> = (gmctxt_cl \<F> \<R>)\<^sup>+ O \<R> O (gmctxt_cl \<F> \<R>)\<^sup>+"

lemma gcomp_rel:
  "gmctxt_cl \<F> (gcomp_rel \<F> \<R> \<S>) = gmctxt_cl \<F> \<R> O gmctxt_cl \<F> \<S>" (is "?Ls = ?Rs")
proof
  { fix s u assume "(s, u) \<in> gmctxt_cl \<F> (\<R> O gmctxt_cl \<F> \<S> \<union> gmctxt_cl \<F> \<R> O \<S>)"
     then have "\<exists>t. (s, t) \<in> gmctxt_cl \<F> \<R> \<and> (t, u) \<in> gmctxt_cl \<F> \<S>"
    proof (induct)
      case (step ss ts f)
      from Ex_list_of_length_P[of _ "\<lambda> u i. (ss ! i, u) \<in> gmctxt_cl \<F> \<R> \<and> (u, ts ! i) \<in> gmctxt_cl \<F> \<S>"]
      obtain us where l: "length us = length ts" and
        inv: "\<forall> i < length ts. (ss ! i, us ! i) \<in> gmctxt_cl \<F> \<R> \<and> (us ! i, ts ! i) \<in> gmctxt_cl \<F> \<S>"
        using step(2, 3) by blast
      then show ?case using step(1, 3)
        by (intro exI[of _ "GFun f us"]) auto
    qed auto}
  then show "?Ls \<subseteq> ?Rs" unfolding gcomp_rel_def
    by auto
next
  {fix s t u assume "(s, t) \<in> gmctxt_cl \<F> \<R>" "(t, u) \<in> gmctxt_cl \<F> \<S>"
    then have "(s, u) \<in> gmctxt_cl \<F> (\<R> O gmctxt_cl \<F> \<S> \<union> gmctxt_cl \<F> \<R> O \<S>)"
    proof (induct arbitrary: u rule: gmctxt_cl.induct)
      case (step ss ts f)
      then show ?case
      proof (cases "(GFun f ts, u) \<in> \<S>")
        case True
        then have "(GFun f ss, u) \<in> gmctxt_cl \<F> \<R> O \<S>" using gmctxt_cl.step[OF step(1) _ step(3)] step(2)
          by auto
        then show ?thesis by auto
      next
        case False
        then obtain us where u[simp]: "u = GFun f us" and l: "length ts = length us"
          using step(4) by (cases u) (auto elim: gmctxt_cl.cases)
        have "i < length us \<Longrightarrow>
         (ss ! i, us ! i) \<in> gmctxt_cl \<F> (\<R> O gmctxt_cl \<F> \<S> \<union> gmctxt_cl \<F> \<R> O \<S>)" for i
          using step(1, 2, 4) False by (auto elim: gmctxt_cl.cases)
        then show ?thesis using l step(1, 3)
          by auto
      qed
    qed auto}
  then show "?Rs \<subseteq> ?Ls"
    by (auto simp: gcomp_rel_def)
qed

subsubsection \<open>Signature closed property\<close>

definition all_ctxt_closed :: "('f \<times> nat) set \<Rightarrow> 'f gterm rel \<Rightarrow> bool" where
  "all_ctxt_closed F r \<longleftrightarrow> (\<forall> f ts ss. (f, length ss) \<in> F \<longrightarrow> length ss = length ts \<longrightarrow>
    (\<forall>i. i < length ts \<longrightarrow> (ss ! i, ts ! i) \<in> r) \<longrightarrow>
    (GFun f ss, GFun f ts) \<in> r)"

lemma all_ctxt_closedI:
  assumes "\<And> f ss ts. (f, length ss) \<in> \<F> \<Longrightarrow> length ss = length ts \<Longrightarrow>
     (\<forall> i < length ts. (ss ! i, ts ! i) \<in> r) \<Longrightarrow> (GFun f ss, GFun f ts) \<in> r"
  shows "all_ctxt_closed \<F> r" using assms
  unfolding all_ctxt_closed_def by auto

lemma all_ctxt_closedD:
  "all_ctxt_closed F r \<Longrightarrow> (f, length ss) \<in> F \<Longrightarrow> length ss = length ts \<Longrightarrow>
    (\<forall> i < length ts. (ss ! i, ts ! i) \<in> r) \<Longrightarrow> (GFun f ss, GFun f ts) \<in> r"
  by (auto simp: all_ctxt_closed_def)

lemma all_ctxt_closed_refl_on:
  assumes "all_ctxt_closed \<F> r" "s \<in> \<T>\<^sub>G \<F>"
  shows "(s, s) \<in> r" using assms(2)
  by (induct) (auto simp: all_ctxt_closedD[OF assms(1)])

lemma gmctxt_cl_is_all_ctxt_closed [simp]:
  "all_ctxt_closed \<F> (gmctxt_cl \<F> \<R>)"
  unfolding all_ctxt_closed_def
  by auto

lemma all_ctxt_closed_gmctxt_cl_idem [simp]:
  assumes "all_ctxt_closed \<F> \<R>"
  shows "gmctxt_cl \<F> \<R> = \<R>"
proof -
  {fix s t assume "(s, t) \<in> gmctxt_cl \<F> \<R>" then have "(s, t) \<in> \<R>"
    proof (induct)
      case (step ss ts f)
      show ?case using step(2) all_ctxt_closedD[OF assms step(3, 1)]
        by auto
    qed auto}
  then show ?thesis by auto
qed

subsubsection \<open>Transitive closure preserves @{const all_ctxt_closed}\<close>

text \<open>induction scheme for transitive closures of lists\<close>

inductive_set trancl_list for \<R> where
  base[intro, Pure.intro] : "length xs = length ys \<Longrightarrow>
      (\<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R>) \<Longrightarrow> (xs, ys) \<in> trancl_list \<R>"
| list_trancl [Pure.intro]: "(xs, ys) \<in> trancl_list \<R> \<Longrightarrow> i < length ys \<Longrightarrow> (ys ! i, z) \<in> \<R> \<Longrightarrow>
    (xs, ys[i := z]) \<in> trancl_list \<R>"

lemma trancl_list_appendI [simp, intro]:
  "(xs, ys) \<in> trancl_list \<R> \<Longrightarrow> (x, y) \<in> \<R> \<Longrightarrow> (x # xs, y # ys) \<in> trancl_list \<R>"
proof (induct rule: trancl_list.induct)
  case (base xs ys)
  then show ?case using less_Suc_eq_0_disj
    by (intro trancl_list.base) auto
next
  case (list_trancl xs ys i z)
  from list_trancl(3) have *: "y # ys[i := z] = (y # ys)[Suc i := z]" by auto
  show ?case using list_trancl unfolding *
    by (intro trancl_list.list_trancl) auto
qed

lemma trancl_list_append_tranclI [intro]:
  "(x, y) \<in> \<R>\<^sup>+ \<Longrightarrow> (xs, ys) \<in> trancl_list \<R> \<Longrightarrow> (x # xs, y # ys) \<in> trancl_list \<R>"
proof (induct rule: trancl.induct)
  case (trancl_into_trancl a b c)
  then have "(a # xs, b # ys) \<in> trancl_list \<R>" by auto
  from trancl_list.list_trancl[OF this, of 0 c]
  show ?case using trancl_into_trancl(3)
    by auto
qed auto

lemma trancl_list_conv:
  "(xs, ys) \<in> trancl_list \<R> \<longleftrightarrow> length xs = length ys \<and> (\<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R>\<^sup>+)" (is "?Ls \<longleftrightarrow> ?Rs")
proof
  assume "?Ls" then show ?Rs
  proof (induct)
    case (list_trancl xs ys i z)
    then show ?case
      by auto (metis nth_list_update trancl.trancl_into_trancl)
  qed auto
next
  assume ?Rs then show ?Ls
  proof (induct ys arbitrary: xs)
    case Nil
    then show ?case by (cases xs) auto
  next
    case (Cons y ys)
    from Cons(2) obtain x xs' where *: "xs = x # xs'" and
      inv: "(x, y) \<in> \<R>\<^sup>+"
      by (cases xs) auto
    show ?case using Cons(1)[of "tl xs"] Cons(2) unfolding *
      by (intro trancl_list_append_tranclI[OF inv]) force
  qed
qed

lemma trancl_list_induct [consumes 2, case_names base step]:
  assumes "length ss = length ts" "\<forall> i < length ts. (ss ! i, ts ! i) \<in> \<R>\<^sup>+"
    and "\<And>xs ys. length xs = length ys \<Longrightarrow> \<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R> \<Longrightarrow> P xs ys"
    and "\<And>xs ys i z. length xs = length ys \<Longrightarrow> \<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R>\<^sup>+ \<Longrightarrow> P xs ys
      \<Longrightarrow> i < length ys \<Longrightarrow> (ys ! i, z) \<in> \<R> \<Longrightarrow> P xs (ys[i := z])"
  shows "P ss ts" using assms
  by (intro trancl_list.induct[of ss ts \<R> P]) (auto simp: trancl_list_conv)

lemma trancl_list_all_step_induct [consumes 2, case_names base step]:
  assumes "length ss = length ts" "\<forall> i < length ts. (ss ! i, ts ! i) \<in> \<R>\<^sup>+"
    and base: "\<And>xs ys. length xs = length ys \<Longrightarrow> \<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R> \<Longrightarrow> P xs ys"
    and steps: "\<And>xs ys zs. length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow>
       \<forall> i < length zs. (xs ! i, ys ! i) \<in> \<R>\<^sup>+ \<Longrightarrow> \<forall> i < length zs. (ys ! i, zs ! i) \<in> \<R> \<or> ys ! i = zs ! i \<Longrightarrow>
       P xs ys \<Longrightarrow> P xs zs"
  shows "P ss ts" using assms(1, 2)
proof (induct rule: trancl_list_induct)
case (step xs ys i z)
  then show ?case
    by (intro steps[of xs ys "ys[i := z]"])
       (auto simp: nth_list_update)
qed (auto simp: base)

lemma all_ctxt_closed_trancl:
  assumes  "all_ctxt_closed \<F> \<R>" "\<R> \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
  shows "all_ctxt_closed \<F> (\<R>\<^sup>+)"
proof -
  {fix f ss ts assume sig: "(f, length ss) \<in> \<F>" and
      steps: "length ss = length ts" "\<forall>i<length ts. (ss ! i, ts ! i) \<in> \<R>\<^sup>+"
    have "(GFun f ss, GFun f ts) \<in> \<R>\<^sup>+" using steps sig
    proof (induct rule: trancl_list_induct)
      case (base ss ts)
      then show ?case using all_ctxt_closedD[OF assms(1) base(3, 1, 2)]
        by auto
    next
      case (step ss ts i t')
      from step(2) have "j < length ts \<Longrightarrow> ts ! j \<in> \<T>\<^sub>G \<F>" for j using assms(2)
        by (metis (no_types, lifting) SigmaD2 subset_iff trancl.simps)
      from this[THEN all_ctxt_closed_refl_on[OF assms(1)]]
      have "(GFun f ts, GFun f (ts[i := t'])) \<in> \<R>" using step(1, 4-)
        by (intro all_ctxt_closedD[OF assms(1)]) (auto simp: nth_list_update)
      then show ?case using step(3, 6)
        by auto
    qed}
  then show ?thesis by (intro all_ctxt_closedI)
qed

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory FixedPointTheorems
imports
  HOLCF
begin

setup \<open>
  Thy_Output.antiquotation_raw \<^binding>\<open>haskell\<close> (Scan.lift Args.name)
    (fn _ => fn s => Latex.string ("\\" ^ "<" ^ s ^ "\\>"))
\<close>

(* LaTeXsugar fights with HOLCF syntax: at least cdot *)

(* THEOREMS *)
notation (Rule output)
  Pure.imp  ("\<^latex>\<open>\\mbox{}\\inferrule{\\mbox{\<close>_\<^latex>\<open>}}\<close>\<^latex>\<open>{\\mbox{\<close>_\<^latex>\<open>}}\<close>")

syntax (Rule output)
  "_bigimpl" :: "asms \<Rightarrow> prop \<Rightarrow> prop"
  ("\<^latex>\<open>\\mbox{}\\inferrule{\<close>_\<^latex>\<open>}\<close>\<^latex>\<open>{\\mbox{\<close>_\<^latex>\<open>}}\<close>")

  "_asms" :: "prop \<Rightarrow> asms \<Rightarrow> asms"
  ("\<^latex>\<open>\\mbox{\<close>_\<^latex>\<open>}\\\\\<close>/ _")

  "_asm" :: "prop \<Rightarrow> asms" ("\<^latex>\<open>\\mbox{\<close>_\<^latex>\<open>}\<close>")

(*>*)
section\<open>Fixed-point theorems for program transformation\<close>

text\<open>

We begin by recounting some standard theorems from the early days of
denotational semantics. The origins of these results are lost to
history; the interested reader can find some of it in
\citet{Bekic:1969, Manna:1974, Greibach:1975, Stoy:1977,
DBLP:books/daglib/0002432, Harel:1980, Plotkin:1983, Winskel:1993,
DBLP:journals/toplas/Sangiorgi09}.

\<close>

subsection\<open>The rolling rule\<close>

text\<open>

The \emph{rolling rule} captures what intuitively happens when we
re-order a recursive computation consisting of two parts. This theorem
dates from the 1970s at the latest -- see \citet[p210]{Stoy:1977} and
\citet{Plotkin:1983}. The following proofs were provided by
\citet{GillHutton:2009}.

\<close>

lemma rolling_rule_ltr: "fix\<cdot>(g oo f) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
proof -
  have "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    by (rule below_refl) \<comment> \<open>reflexivity\<close>
  hence "g\<cdot>((f oo g)\<cdot>(fix\<cdot>(f oo g))) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    using fix_eq[where F="f oo g"] by simp \<comment> \<open>computation\<close>
  hence "(g oo f)\<cdot>(g\<cdot>(fix\<cdot>(f oo g))) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    by simp \<comment> \<open>re-associate @{term "(oo)"}\<close>
  thus "fix\<cdot>(g oo f) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    using fix_least_below by blast \<comment> \<open>induction\<close>
qed

lemma rolling_rule_rtl: "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> fix\<cdot>(g oo f)"
proof -
  have "fix\<cdot>(f oo g) \<sqsubseteq> f\<cdot>(fix\<cdot>(g oo f))" by (rule rolling_rule_ltr)
  hence "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> g\<cdot>(f\<cdot>(fix\<cdot>(g oo f)))"
    by (rule monofun_cfun_arg) \<comment> \<open>g is monotonic\<close>
  thus "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> fix\<cdot>(g oo f)"
    using fix_eq[where F="g oo f"] by simp \<comment> \<open>computation\<close>
qed

lemma rolling_rule: "fix\<cdot>(g oo f) = g\<cdot>(fix\<cdot>(f oo g))"
  by (rule below_antisym[OF rolling_rule_ltr rolling_rule_rtl])
(*

This property of a fixed-point operator is termed \emph{dinaturality}
by \citet{DBLP:conf/lics/SimpsonP00}.

*)

subsection\<open>Least-fixed-point fusion\<close>

text\<open>

\label{sec:lfp-fusion}

\emph{Least-fixed-point fusion} provides a kind of induction that has
proven to be very useful in calculational settings. Intuitively it
lifts the step-by-step correspondence between @{term "f"} and @{term
"h"} witnessed by the strict function @{term "g"} to the fixed points
of @{term "f"} and @{term "g"}:
\[
  \begin{diagram}
    \node{\bullet} \arrow{e,t}{h} \node{\bullet}\\
    \node{\bullet} \arrow{n,l}{g} \arrow{e,b}{f} \node{\bullet} \arrow{n,r}{g}
  \end{diagram}
  \qquad \Longrightarrow \qquad
  \begin{diagram}
    \node{\mathsf{fix}\ h}\\
    \node{\mathsf{fix}\ f} \arrow{n,r}{g}
  \end{diagram}
\]
\citet*{FokkingaMeijer:1991}, and also their later
\citet*{barbed-wire:1991}, made extensive use of this rule, as did
\citet{Tullsen:PhDThesis} in his program transformation tool PATH.
This diagram is strongly reminiscent of the simulations used to
establish refinement relations between imperative programs and their
specifications \citep*{EdR:cup98}.

The following proof is close to the third variant of
\citet[p215]{Stoy:1977}. We relate the two fixpoints using the rule
\texttt{parallel\_fix\_ind}:
\begin{center}
  @{thm[mode=Rule] parallel_fix_ind}
\end{center}
in a very straightforward way:

\<close>

lemma lfp_fusion:
  assumes "g\<cdot>\<bottom> = \<bottom>"
  assumes "g oo f = h oo g"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof(induct rule: parallel_fix_ind)
  case 2 show "g\<cdot>\<bottom> = \<bottom>" by fact
  case (3 x y)
  from \<open>g\<cdot>x = y\<close> \<open>g oo f = h oo g\<close> show "g\<cdot>(f\<cdot>x) = h\<cdot>y"
    by (simp add: cfun_eq_iff)
qed simp

text\<open>

This lemma also goes by the name of \emph{Plotkin's axiom}
\citep{PittsAM:relpod} or \emph{uniformity}
\citep{DBLP:conf/lics/SimpsonP00}.

\<close>
(*<*)

(* The rest of this theory is only of historical interest. *)

text \<open>Some may find the pointed version easier to read.\<close>

lemma lfp_fusion_pointed:
  assumes Cfg: "\<And>f. C\<cdot>(F\<cdot>f) = G\<cdot>(C\<cdot>f)"
      and strictC: "C\<cdot>\<bottom> = \<bottom>"
  shows "C\<cdot>(fix\<cdot>F) = fix\<cdot>G"
  using lfp_fusion[where f=F and g=C and h=G] assms
  by (simp add: cfcomp1)

subsubsection\<open>More about \<open>lfp-fusion\<close>\<close>

text\<open>

Alternative proofs. This is the ``intuitive'' one
\citet[p125]{Gunter:1992} and \citet[p46]{Tullsen:PhDThesis}, where we
can shuffle @{term "g"} to the end of the the iteration of @{term "f"}
using @{term "fgh"}.

\<close>

lemma lfp_fusion2_aux:
  assumes fgh: "g oo f = h oo g"
  shows "g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>) = iterate i\<cdot>h\<cdot>(g\<cdot>\<bottom>)"
proof(induct i)
  case (Suc i)
  have "g\<cdot>(iterate (Suc i)\<cdot>f\<cdot>\<bottom>) = (g oo f)\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>)" by simp
  also have "... = h\<cdot>(g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" using fgh by (simp add: cfcomp1)
  also have "... = h\<cdot>(iterate i\<cdot>h\<cdot>(g\<cdot>\<bottom>))" using Suc by simp
  also have "... = iterate (Suc i)\<cdot>h\<cdot>(g\<cdot>\<bottom>)" by simp
  finally show ?case .
qed simp

lemma lfp_fusion2:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof -
  have "g\<cdot>(fix\<cdot>f) = g\<cdot>(\<Squnion>i. iterate i\<cdot>f\<cdot>\<bottom>)" by (simp only: fix_def2)
  also have "... = (\<Squnion>i. g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" by (simp add: contlub_cfun_arg)
  also have "... = (\<Squnion>i. (iterate i\<cdot>h\<cdot>(g\<cdot>\<bottom>)))" by (simp only: lfp_fusion2_aux[OF fgh])
  also have "... = fix\<cdot>h" using strictg by (simp only: fix_def2)
  finally show ?thesis .
qed

text\<open>This is the first one by \citet[p213]{Stoy:1977}, almost
identical to the above.\<close>

lemma lfp_fusion3_aux:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>) = iterate i\<cdot>h\<cdot>\<bottom>"
proof(induct i)
  case 0 from strictg show ?case by simp
next
  case (Suc i)
  have "g\<cdot>(iterate (Suc i)\<cdot>f\<cdot>\<bottom>) = (g oo f)\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>)" by simp
  also have "... = h\<cdot>(g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" using fgh by (simp add: cfcomp1)
  also have "... = h\<cdot>(iterate i\<cdot>h\<cdot>\<bottom>)" using Suc by simp
  also have "... = iterate (Suc i)\<cdot>h\<cdot>\<bottom>" by simp
  finally show ?case .
qed

lemma lfp_fusion3:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof -
  have "g\<cdot>(fix\<cdot>f) = g\<cdot>(\<Squnion>i. iterate i\<cdot>f\<cdot>\<bottom>)" by (simp only: fix_def2)
  also have "... = (\<Squnion>i. g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" by (simp add: contlub_cfun_arg)
  also have "... = (\<Squnion>i. (iterate i\<cdot>h\<cdot>\<bottom>))" by (simp only: lfp_fusion3_aux[OF fgh strictg])
  also have "... = fix\<cdot>h" by (simp only: fix_def2)
  finally show ?thesis .
qed

text\<open>Stoy's second proof \citep[p214]{Stoy:1977} is similar to the
original proof using fixed-point induction.\<close>

lemma lfp_fusion4:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof(rule below_antisym)
  show "fix\<cdot>h \<sqsubseteq> g\<cdot>(fix\<cdot>f)"
  proof -
    have "h\<cdot>(g\<cdot>(fix\<cdot>f)) = (g oo f)\<cdot>(fix\<cdot>f)" using fgh by simp
    also have "... = g\<cdot>(fix\<cdot>f)" by (subst fix_eq, simp)
    finally show ?thesis by (rule fix_least)
  qed
  let ?P = "\<lambda>x. g\<cdot>x \<sqsubseteq> fix\<cdot>h"
  show "?P (fix\<cdot>f)"
  proof(induct rule: fix_ind[where P="?P"])
    case 2 with strictg show ?case by simp
  next
    case (3 x) hence indhyp: "g\<cdot>x \<sqsubseteq> fix\<cdot>h" .
    have "g\<cdot>(f\<cdot>x) = (h oo g)\<cdot>x" using fgh[symmetric] by simp
    with indhyp show "g\<cdot>(f\<cdot>x) \<sqsubseteq> fix\<cdot>h"
      by (subst fix_eq, simp add: monofun_cfun)
  qed simp
qed

text\<open>A wrinkly variant from \citet[p11]{barbed-wire:1991}.\<close>

lemma lfp_fusion_barbed_variant:
  assumes ff': "f\<cdot>\<bottom> = f'\<cdot>\<bottom>"
      and fgh: "f oo g = h oo f"
      and f'g'h: "f' oo g' = h oo f'"
  shows "f\<cdot>(fix\<cdot>g) = f'\<cdot>(fix\<cdot>g')"
proof(induct rule: parallel_fix_ind)
  case 2 show "f\<cdot>\<bottom> = f'\<cdot>\<bottom>" by (rule ff')
  case (3 x y)
  from \<open>f\<cdot>x = f'\<cdot>y\<close> have "h\<cdot>(f\<cdot>x) = h\<cdot>(f'\<cdot>y)" by simp
  with fgh f'g'h have "f\<cdot>(g\<cdot>x) = f'\<cdot>(g'\<cdot>y)"
    using cfcomp2[where f="f" and g="g", symmetric]
          cfcomp2[where f="f'" and g="g'", symmetric]
    by simp
  thus ?case by simp
qed simp
(*>*)

(*<*)
end
(*>*)


theory compare_test
  imports Main
begin

declare [[smt_timeout = 100000000]]
declare [[cvc4_options = "--full-saturate-quant --inst-when=full-last-call --inst-no-entail --term-db-mode=relevant --multi-trigger-linear"]]
lemma "x=x1 \<and> y=y1 \<Longrightarrow> speak(x, y) \<longleftrightarrow> speak (x1, y1)"
  by simp

lemma "p = p2 \<Longrightarrow>
((speak(p) \<longrightarrow> isReg(p, t) \<and> broadcast(t) \<and> (p \<noteq> p1 \<and> isReg(p1, t)) \<longrightarrow> ~speak(p1))
\<and> (speak(p1) \<longrightarrow> isReg(p1, t1) \<and> broadcast(t1) \<and> (p1 \<noteq> p \<and> isReg(p, t1) \<longrightarrow> ~speak(p)))) \<longleftrightarrow>
((speak(p) \<longrightarrow> isReg(p, t) \<and> broadcast(t) \<and> (p \<noteq> p1 \<and> isReg(p1, t)) \<longrightarrow> ~speak(p1))
& (speak(p1) \<longrightarrow> isReg(p1, t1) \<and> broadcast(t1) \<and> (p1 \<noteq> p2 \<and> isReg(p2, t1) \<longrightarrow> ~speak(p2))))"
  by auto

lemma "
((speak(p) \<longrightarrow> isReg(p, t) \<and> broadcast(t) \<and> (p \<noteq> p1 \<and> isReg(p1, t)) \<longrightarrow> ~speak(p1)) \<and> (speak(p1) \<longrightarrow> isReg(p1, t1) \<and> broadcast(t1) \<and> (p1 \<noteq> p \<and> isReg(p, t1) \<longrightarrow> ~speak(p)))) \<longleftrightarrow> ((speak(p) \<longrightarrow> isReg(p, t) \<and> broadcast(t) \<and> (p \<noteq> p1 \<and> isReg(p1, t)) \<longrightarrow> ~speak(p1))
& (speak(p1) \<longrightarrow> isReg(p1, t1) \<and> broadcast(t1) \<and> (p1 \<noteq> p2 \<and> isReg(p2, t1) \<longrightarrow> ~speak(p2))))
\<Longrightarrow> p = p2 \<and> t = t1"
  nitpick

lemma "speak(p1) \<longrightarrow> isReg(p1, t1) \<and> broadcast(t1) \<and> (p\<noteq>p1 \<and> isReg(p, t1)) \<longrightarrow> ~speak(p)"
  nitpick
(*2nd part same as javabip*)
(*
lemma test_1:  "
\<not>((
((((P (''5c'', ''1'') \<longrightarrow>
     (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3''))) \<or>
    (P (''5c'', ''1'') \<longrightarrow>
     (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3''))) \<or>
    (P (''5c'', ''1'') \<longrightarrow>
     (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3''))) \<or>
    (P (''5c'', ''1'') \<longrightarrow>
     (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3''))) \<or>
    (P (''5c'', ''1'') \<longrightarrow>
     (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3''))) \<or>
    (P (''5c'', ''1'') \<longrightarrow>
     (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3'')))) \<and>
   ((P (''5c'', ''2'') \<longrightarrow>
     (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3''))) \<or>
    (P (''5c'', ''2'') \<longrightarrow>
     (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3''))) \<or>
    (P (''5c'', ''2'') \<longrightarrow>
     (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3''))) \<or>
    (P (''5c'', ''2'') \<longrightarrow>
     (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3''))) \<or>
    (P (''5c'', ''2'') \<longrightarrow>
     (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3''))) \<or>
    (P (''5c'', ''2'') \<longrightarrow>
     (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'')) \<and> (P (''5d'', ''1'') \<or> P (''5d'', ''2'') \<or> P (''5d'', ''3''))))) \<and>
  ((P (''5d'', ''1'') \<longrightarrow> (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''1'') \<longrightarrow> (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''1'') \<longrightarrow> (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''1'') \<longrightarrow> (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''1'') \<longrightarrow> (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''1'') \<longrightarrow> (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2'')))) \<and>
  ((P (''5d'', ''2'') \<longrightarrow> (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''2'') \<longrightarrow> (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''2'') \<longrightarrow> (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''2'') \<longrightarrow> (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''2'') \<longrightarrow> (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''2'') \<longrightarrow> (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2'')))) \<and>
  ((P (''5d'', ''3'') \<longrightarrow> (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''3'') \<longrightarrow> (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''3'') \<longrightarrow> (Q (''1a'', ''1'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''3'') \<longrightarrow> (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''3'') \<longrightarrow> (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))) \<or>
   (P (''5d'', ''3'') \<longrightarrow> (Q (''1a'', ''2'') \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'')) \<and> (P (''5c'', ''1'') \<or> P (''5c'', ''2''))))) \<and>
 (((P (''5c'', ''1'') \<longrightarrow> \<not> P (''5c'', ''2'')) \<and> (P (''5c'', ''2'') \<longrightarrow> \<not> P (''5c'', ''1''))) \<and>
  (P (''5d'', ''1'') \<longrightarrow> \<not> P (''5d'', ''2'') \<and> \<not> P (''5d'', ''3'')) \<and>
  (P (''5d'', ''2'') \<longrightarrow> \<not> P (''5d'', ''1'') \<and> \<not> P (''5d'', ''3'')) \<and>
  (P (''5d'', ''3'') \<longrightarrow> \<not> P (''5d'', ''1'') \<and> \<not> P (''5d'', ''2''))) \<and>
 ((Q (''1a'', ''1'') \<longrightarrow> \<not> Q (''1a'', ''2'')) \<and> (Q (''1a'', ''2'') \<longrightarrow> \<not> Q (''1a'', ''1''))) \<and>
 (Q (''2'', ''1'') \<longrightarrow> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<and>
 (Q (''2'', ''2'') \<longrightarrow> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<and> (Q (''2'', ''3'') \<longrightarrow> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2''))
)
\<longleftrightarrow>
(
(((P (''5c'', ''1'') \<longrightarrow>
    (((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<or>
     ((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<or>
     ((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'')) \<or>
     ((Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<or>
     ((Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<or>
     (Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'')) \<and>
    (P (''5d'', ''1'') \<and> \<not> P (''5d'', ''2'') \<and> \<not> P (''5d'', ''3'') \<or>
     P (''5d'', ''2'') \<and> \<not> P (''5d'', ''1'') \<and> \<not> P (''5d'', ''3'') \<or> P (''5d'', ''3'') \<and> \<not> P (''5d'', ''1'') \<and> \<not> P (''5d'', ''2''))) \<and>
   (P (''5c'', ''2'') \<longrightarrow>
    (((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<or>
     ((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<or>
     ((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'')) \<or>
     ((Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<or>
     ((Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<or>
     (Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'')) \<and>
    (P (''5d'', ''1'') \<and> \<not> P (''5d'', ''2'') \<and> \<not> P (''5d'', ''3'') \<or>
     P (''5d'', ''2'') \<and> \<not> P (''5d'', ''1'') \<and> \<not> P (''5d'', ''3'') \<or> P (''5d'', ''3'') \<and> \<not> P (''5d'', ''1'') \<and> \<not> P (''5d'', ''2'')))) \<and>
  (P (''5d'', ''1'') \<longrightarrow>
   (((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<or>
    ((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<or>
    ((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'')) \<or>
    ((Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<or>
    ((Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<or>
    (Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'')) \<and>
   (P (''5c'', ''1'') \<and> \<not> P (''5c'', ''2'') \<or> P (''5c'', ''2'') \<and> \<not> P (''5c'', ''1''))) \<and>
  (P (''5d'', ''2'') \<longrightarrow>
   (((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<or>
    ((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<or>
    ((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'')) \<or>
    ((Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<or>
    ((Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<or>
    (Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'')) \<and>
   (P (''5c'', ''1'') \<and> \<not> P (''5c'', ''2'') \<or> P (''5c'', ''2'') \<and> \<not> P (''5c'', ''1''))) \<and>
  (P (''5d'', ''3'') \<longrightarrow>
   (((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<or>
    ((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<or>
    ((Q (''1a'', ''1'') \<and> \<not> Q (''1a'', ''2'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'')) \<or>
    ((Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<or>
    ((Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<or>
    (Q (''1a'', ''2'') \<and> \<not> Q (''1a'', ''1'')) \<and> Q (''1b'', ''1'') \<or> Q (''2'', ''3'') \<and> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2'')) \<and>
   (P (''5c'', ''1'') \<and> \<not> P (''5c'', ''2'') \<or> P (''5c'', ''2'') \<and> \<not> P (''5c'', ''1'')))) \<and>
 (((P (''5c'', ''1'') \<longrightarrow> \<not> P (''5c'', ''2'')) \<and> (P (''5c'', ''2'') \<longrightarrow> \<not> P (''5c'', ''1''))) \<and>
  (P (''5d'', ''1'') \<longrightarrow> \<not> P (''5d'', ''2'') \<and> \<not> P (''5d'', ''3'')) \<and>
  (P (''5d'', ''2'') \<longrightarrow> \<not> P (''5d'', ''1'') \<and> \<not> P (''5d'', ''3'')) \<and>
  (P (''5d'', ''3'') \<longrightarrow> \<not> P (''5d'', ''1'') \<and> \<not> P (''5d'', ''2''))) \<and>
 ((Q (''1a'', ''1'') \<longrightarrow> \<not> Q (''1a'', ''2'')) \<and> (Q (''1a'', ''2'') \<longrightarrow> \<not> Q (''1a'', ''1''))) \<and>
 (Q (''2'', ''1'') \<longrightarrow> \<not> Q (''2'', ''2'') \<and> \<not> Q (''2'', ''3'')) \<and>
 (Q (''2'', ''2'') \<longrightarrow> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''3'')) \<and> (Q (''2'', ''3'') \<longrightarrow> \<not> Q (''2'', ''1'') \<and> \<not> Q (''2'', ''2''))
))
"
  nitpick
  sledgehammer
  by smt
*)

lemma "(a1 \<longrightarrow> (b1 \<or> c1)) \<and> (\<not>a1 \<or> \<not>a2) \<and> (\<not>b1\<and>\<not>b2 \<or> \<not>b1\<and>\<not>b3 \<or> \<not>b3\<and>\<not>b2) \<and> (\<not>c1\<and>\<not>c2 \<or> \<not>c1\<and>\<not>c3 \<or> \<not>c3\<and>\<not>c2)
\<Longrightarrow>
(a1 \<longrightarrow> (b1\<and>\<not>b2\<and>\<not>b3 \<or> c1\<and>\<not>c2\<and>\<not>c3)) \<and> (\<not>a1 \<or> \<not>a2) \<and> (\<not>b1\<and>\<not>b2 \<or> \<not>b1\<and>\<not>b3 \<or> \<not>b3\<and>\<not>b2) \<and> (\<not>c1\<and>\<not>c2 \<or> \<not>c1\<and>\<not>c3 \<or> \<not>c3\<and>\<not>c2)
"
  by blast

lemma "
(a1 \<longrightarrow> (b1\<and>\<not>b2\<and>\<not>b3 \<or> c1\<and>\<not>c2\<and>\<not>c3)) \<and> (\<not>a1 \<or> \<not>a2) \<and> (\<not>b1\<and>\<not>b2 \<or> \<not>b1\<and>\<not>b3 \<or> \<not>b3\<and>\<not>b2) \<and> (\<not>c1\<and>\<not>c2 \<or> \<not>c1\<and>\<not>c3 \<or> \<not>c3\<and>\<not>c2)
\<Longrightarrow>
(a1 \<longrightarrow> (b1 \<or> c1)) \<and> (\<not>a1 \<or> \<not>a2) \<and> (\<not>b1\<and>\<not>b2 \<or> \<not>b1\<and>\<not>b3 \<or> \<not>b3\<and>\<not>b2) \<and> (\<not>c1\<and>\<not>c2 \<or> \<not>c1\<and>\<not>c3 \<or> \<not>c3\<and>\<not>c2)
"
  by blast

end


section\<open>Combine Match Expressions\<close>
theory MatchExpr_Fold
imports Primitive_Normalization
begin

fun andfold_MatchExp :: "'a match_expr list \<Rightarrow> 'a match_expr" where
  "andfold_MatchExp [] = MatchAny" |
  "andfold_MatchExp [e] = e" |
  "andfold_MatchExp (e#es) = MatchAnd e (andfold_MatchExp es)"

lemma andfold_MatchExp_alist_and: "alist_and' (map Pos ls) = andfold_MatchExp (map Match ls)"
  apply(induction ls)
   apply(simp)
  apply(simp)
  apply(rename_tac l ls)
  apply(case_tac "ls")
   by(simp)+

lemma andfold_MatchExp_matches:
  "matches \<gamma> (andfold_MatchExp ms) a p \<longleftrightarrow> (\<forall>m \<in> set ms. matches \<gamma> m a p)"
  apply(induction ms rule: andfold_MatchExp.induct)
    apply(simp add: bunch_of_lemmata_about_matches)+
  done

lemma andfold_MatchExp_not_discI:
  "\<forall>m \<in> set ms. \<not> has_disc disc m \<Longrightarrow> \<not> has_disc disc (andfold_MatchExp ms)"
  by(induction ms rule: andfold_MatchExp.induct) (simp)+

lemma andfold_MatchExp_not_disc_negatedI:
  "\<forall>m \<in> set ms. \<not> has_disc_negated disc neg m \<Longrightarrow> \<not> has_disc_negated disc neg (andfold_MatchExp ms)"
  by(induction ms rule: andfold_MatchExp.induct) (simp)+

lemma andfold_MatchExp_not_disc_negated_mapMatch:
  "\<not> has_disc_negated disc False (andfold_MatchExp (map (Match \<circ> C) ls))"
  apply(induction ls)
   apply(simp; fail)
  apply(simp)
   apply(rename_tac ls, case_tac ls)
  by(simp)+

lemma andfold_MatchExp_not_disc_mapMatch:
  "\<forall>a. \<not> disc (C a) \<Longrightarrow> \<not> has_disc disc (andfold_MatchExp (map (Match \<circ> C) ls))"
  apply(induction ls)
   apply(simp; fail)
  apply(simp)
   apply(rename_tac ls, case_tac ls)
  by(simp)+

lemma andfold_MatchExp_normalized_nnf: "\<forall>m \<in> set ms. normalized_nnf_match m \<Longrightarrow>
    normalized_nnf_match (andfold_MatchExp ms)"
  by(induction ms rule: andfold_MatchExp.induct)(simp)+

lemma andfold_MatchExp_normalized_n_primitive: "\<forall>m \<in> set ms. normalized_n_primitive (disc, sel) f m \<Longrightarrow>
    normalized_n_primitive (disc, sel) f (andfold_MatchExp ms)"
  by(induction ms rule: andfold_MatchExp.induct)(simp)+

lemma normalize_andfold_MatchExp_normalized_n_primitive:
  "\<forall> m \<in> set ms. \<forall> s' \<in> set (normalize_match m). normalized_n_primitive (disc, sel) f s' \<Longrightarrow>
        s \<in> set (normalize_match (andfold_MatchExp ms)) \<Longrightarrow>
          normalized_n_primitive (disc, sel) f s"
  proof(induction ms arbitrary: s rule: andfold_MatchExp.induct)
  case 1 thus ?case by simp
  next
  case 2 thus ?case by simp
  next
  case (3 v1 v2 va)
    have IH: "s' \<in> set (normalize_match (andfold_MatchExp (v2 # va))) \<Longrightarrow>
            normalized_n_primitive (disc, sel) f s'" for s'
    using 3(1)[of s'] (*without this, simp loops*)
    apply(simp)
    using 3(2) by force
    from 3(2,3) IH show ?case by(clarsimp)
  qed
end


(*
  File:     Misc_HLW.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>Miscellaneous facts\<close>
theory Misc_HLW
imports
  Complex_Main
  "HOL-Library.Multiset"
  "HOL-Library.Permutations"
  "HOL-Library.FuncSet"
  "HOL-Library.Groups_Big_Fun"
  "HOL-Library.Poly_Mapping"
  "HOL-Library.Landau_Symbols"
  "HOL-Computational_Algebra.Computational_Algebra"
begin

lemma set_mset_subset_singletonD:
  assumes "set_mset A \<subseteq> {x}"
  shows   "A = replicate_mset (size A) x"
  using assms by (induction A) auto

lemma image_mset_eq_replicate_msetD:
  assumes "image_mset f A = replicate_mset n y"
  shows   "\<forall>x\<in>#A. f x = y"
proof -
  have "f ` set_mset A = set_mset (image_mset f A)"
    by simp
  also note assms
  finally show ?thesis by (auto split: if_splits)
qed

lemma bij_betw_permutes_compose_left:
  assumes "\<pi> permutes A"
  shows   "bij_betw (\<lambda>\<sigma>. \<pi> \<circ> \<sigma>) {\<sigma>. \<sigma> permutes A} {\<sigma>. \<sigma> permutes A}"
proof (rule bij_betwI)
  show "(\<circ>) \<pi> \<in> {\<sigma>. \<sigma> permutes A} \<rightarrow> {\<sigma>. \<sigma> permutes A}"
    by (auto intro: permutes_compose assms)
  show "(\<circ>) (inv_into UNIV \<pi>) \<in> {\<sigma>. \<sigma> permutes A} \<rightarrow> {\<sigma>. \<sigma> permutes A}"
    by (auto intro: permutes_compose assms permutes_inv)
qed (use permutes_inverses[OF assms] in auto)

lemma bij_betw_compose_left_perm_Pi:
  assumes "\<pi> permutes B"
  shows   "bij_betw (\<lambda>f. (\<pi> \<circ> f)) (A \<rightarrow> B) (A \<rightarrow> B)"
proof (rule bij_betwI)
  have *: "(\<lambda>f. (\<pi> \<circ> f)) \<in> (A \<rightarrow> B) \<rightarrow> A \<rightarrow> B" if \<pi>: "\<pi> permutes B" for \<pi>
    by (auto simp: permutes_in_image[OF \<pi>])
  show "(\<lambda>f. (\<pi> \<circ> f)) \<in> (A \<rightarrow> B) \<rightarrow> A \<rightarrow> B"
    by (rule *) fact
  show "(\<lambda>f. (inv_into UNIV \<pi> \<circ> f)) \<in> (A \<rightarrow> B) \<rightarrow> A \<rightarrow> B"
    by (intro * permutes_inv) fact
qed (auto simp: permutes_inverses[OF assms] fun_eq_iff)

lemma bij_betw_compose_left_perm_PiE:
  assumes "\<pi> permutes B"
  shows   "bij_betw (\<lambda>f. restrict (\<pi> \<circ> f) A) (A \<rightarrow>\<^sub>E B) (A \<rightarrow>\<^sub>E B)"
proof (rule bij_betwI)
  have *: "(\<lambda>f. restrict (\<pi> \<circ> f) A) \<in> (A \<rightarrow>\<^sub>E B) \<rightarrow> A \<rightarrow>\<^sub>E B" if \<pi>: "\<pi> permutes B" for \<pi>
    by (auto simp: permutes_in_image[OF \<pi>])
  show "(\<lambda>f. restrict (\<pi> \<circ> f) A) \<in> (A \<rightarrow>\<^sub>E B) \<rightarrow> A \<rightarrow>\<^sub>E B"
    by (rule *) fact
  show "(\<lambda>f. restrict (inv_into UNIV \<pi> \<circ> f) A) \<in> (A \<rightarrow>\<^sub>E B) \<rightarrow> A \<rightarrow>\<^sub>E B"
    by (intro * permutes_inv) fact
qed (auto simp: permutes_inverses[OF assms] fun_eq_iff)

lemma bij_betw_image_mset_set:
  assumes "bij_betw f A B"
  shows   "image_mset f (mset_set A) = mset_set B"
  using assms by (simp add: bij_betw_def image_mset_mset_set)

lemma finite_multisets_of_size:
  assumes "finite A"
  shows   "finite {X. set_mset X \<subseteq> A \<and> size X = n}"
proof (rule finite_subset)
  show "{X. set_mset X \<subseteq> A \<and> size X = n} \<subseteq> mset ` {xs. set xs \<subseteq> A \<and> length xs = n}"
  proof
    fix X assume X: "X \<in> {X. set_mset X \<subseteq> A \<and> size X = n}"
    obtain xs where [simp]: "X = mset xs"
      by (metis ex_mset)
    thus "X \<in> mset ` {xs. set xs \<subseteq> A \<and> length xs = n}"
      using X by auto
  qed
next
  show "finite (mset ` {xs. set xs \<subseteq> A \<and> length xs = n})"
    by (intro finite_imageI finite_lists_length_eq assms)
qed

lemma sum_mset_image_mset_sum_mset_image_mset:
   "sum_mset (image_mset g (sum_mset (image_mset f A))) =
    sum_mset (image_mset (\<lambda>x. sum_mset (image_mset g (f x))) A)"
  by (induction A) auto

lemma sum_mset_image_mset_singleton: "sum_mset (image_mset (\<lambda>x. {#f x#}) A) = image_mset f A"
  by (induction A) auto

lemma sum_mset_conv_sum:
  "sum_mset (image_mset f A) = (\<Sum>x\<in>set_mset A. of_nat (count A x) * f x)"
proof (induction A rule: full_multiset_induct)
  case (less A)
  show ?case
  proof (cases "A = {#}")
    case False
    then obtain x where x: "x \<in># A"
      by auto
    define n where "n = count A x"
    define A' where "A' = filter_mset (\<lambda>y. y \<noteq> x) A"
    have A_eq: "A = replicate_mset n x + A'"
      by (intro multiset_eqI) (auto simp: A'_def n_def)
    have [simp]: "x \<notin># A'" "count A' x = 0"
      by (auto simp: A'_def)
    have "n \<noteq> 0"
      using x by (auto simp: n_def)

    have "sum_mset (image_mset f A) = of_nat n * f x + sum_mset (image_mset f A')"
      by (simp add: A_eq)
    also have "A' \<subset># A"
      unfolding A'_def using x by (simp add: filter_mset_eq_conv subset_mset_def)
    with less.IH have "sum_mset (image_mset f A') = (\<Sum>x\<in>set_mset A'. of_nat (count A' x) * f x)"
      by simp
    also have "\<dots> = (\<Sum>x\<in>set_mset A'. of_nat (count A x) * f x)"
      by (intro sum.cong) (auto simp: A_eq)
    also have "of_nat n * f x + \<dots> = (\<Sum>x\<in>insert x (set_mset A'). of_nat (count A x) * f x)"
      by (subst sum.insert) (auto simp: A_eq)
    also from \<open>n \<noteq> 0\<close> have "insert x (set_mset A') = set_mset A"
      by (auto simp: A_eq)
    finally show ?thesis .
  qed auto
qed

lemma sum_mset_conv_Sum_any:
  "sum_mset (image_mset f A) = Sum_any (\<lambda>x. of_nat (count A x) * f x)"
proof -
  have "sum_mset (image_mset f A) = (\<Sum>x\<in>set_mset A. of_nat (count A x) * f x)"
    by (rule sum_mset_conv_sum)
  also have "\<dots> = Sum_any (\<lambda>x. of_nat (count A x) * f x)"
  proof (rule Sum_any.expand_superset [symmetric])
    show "{x. of_nat (count A x) * f x \<noteq> 0} \<subseteq> set_mset A"
    proof
      fix x assume "x \<in> {x. of_nat (count A x) * f x \<noteq> 0}"
      hence "count A x \<noteq> 0"
        by (intro notI) auto
      thus "x \<in># A"
        by auto
    qed
  qed auto
  finally show ?thesis .
qed

lemma Sum_any_sum_swap:
  assumes "finite A" "\<And>y. finite {x. f x y \<noteq> 0}"
  shows   "Sum_any (\<lambda>x. sum (f x) A) = (\<Sum>y\<in>A. Sum_any (\<lambda>x. f x y))"
proof -
  have "Sum_any (\<lambda>x. sum (f x) A) = Sum_any (\<lambda>x. Sum_any (\<lambda>y. f x y when y \<in> A))"
    unfolding when_def by (subst Sum_any.conditionalize) (use assms in simp_all)
  also have "\<dots> = Sum_any (\<lambda>y. Sum_any (\<lambda>x. f x y when y \<in> A))"
    by (intro Sum_any.swap[of "(\<Union>y\<in>A. {x. f x y \<noteq> 0}) \<times> A"] finite_SigmaI finite_UN_I assms) auto
  also have "(\<lambda>y. Sum_any (\<lambda>x. f x y when y \<in> A)) = (\<lambda>y. Sum_any (\<lambda>x. f x y) when y \<in> A)"
    by (auto simp: when_def)
  also have "Sum_any \<dots> = (\<Sum>y\<in>A. Sum_any (\<lambda>x. f x y))"
    unfolding when_def by (subst Sum_any.conditionalize) (use assms in simp_all)
  finally show ?thesis .
qed

lemma (in landau_pair) big_power:
  assumes "f \<in> L F g"
  shows   "(\<lambda>x. f x ^ n) \<in> L F (\<lambda>x. g x ^ n)"
  using big_prod[of "{..<n}" "\<lambda>_. f" F "\<lambda>_. g"] assms by simp

lemma (in landau_pair) small_power:
  assumes "f \<in> l F g" "n > 0"
  shows   "(\<lambda>x. f x ^ n) \<in> l F (\<lambda>x. g x ^ n)"
  using assms(2,1)
  by (induction rule: nat_induct_non_zero) (auto intro!: small.mult)

lemma pairwise_imp_disjoint_family_on:
  assumes "pairwise R A"
  assumes "\<And>m n. m \<in> A \<Longrightarrow> n \<in> A \<Longrightarrow> R m n \<Longrightarrow> f m \<inter> f n = {}"
  shows   "disjoint_family_on f A"
  using assms
  unfolding disjoint_family_on_def pairwise_def by blast

lemma (in comm_monoid_set) If_eq:
  assumes "y \<in> A" "finite A"
  shows   "F (\<lambda>x. g x (if x = y then h1 x else h2 x)) A = f (g y (h1 y)) (F (\<lambda>x. g x (h2 x)) (A-{y}))"
proof -
  have "F (\<lambda>x. g x (if x = y then h1 x else h2 x)) A =
          f (g y (h1 y)) (F (\<lambda>x. g x (if x = y then h1 x else h2 x)) (A-{y}))"
    using assms by (subst remove[of _ y]) auto
  also have "F (\<lambda>x. g x (if x = y then h1 x else h2 x)) (A-{y}) = F (\<lambda>x. g x (h2 x)) (A-{y})"
    by (intro cong) auto
  finally show ?thesis by simp
qed

lemma prod_nonzeroI:
  fixes f :: "'a \<Rightarrow> 'b :: {semiring_no_zero_divisors, comm_semiring_1}"
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 0"
  shows "prod f A \<noteq> 0"
  using assms by (induction rule: infinite_finite_induct) auto

lemma frequently_prime_cofinite: "frequently (prime :: nat \<Rightarrow> bool) cofinite"
  unfolding INFM_nat_le by (meson bigger_prime less_imp_le)

lemma frequently_eventually_mono:
  assumes "frequently Q F" "eventually P F" "\<And>x. P x \<Longrightarrow> Q x \<Longrightarrow> R x"
  shows   "frequently R F"
proof (rule frequently_mp[OF _ assms(1)])
  show "eventually (\<lambda>x. Q x \<longrightarrow> R x) F"
    using assms(2) by eventually_elim (use assms(3) in blast)
qed

lemma bij_betw_Diff:
  assumes "bij_betw f A B" "bij_betw f A' B'" "A' \<subseteq> A" "B' \<subseteq> B"
  shows   "bij_betw f (A - A') (B - B')"
  unfolding bij_betw_def
proof
  have "inj_on f A"
    using assms(1) by (auto simp: bij_betw_def)
  thus "inj_on f (A - A')"
    by (rule inj_on_subset) auto
  have "f ` (A - A') = f ` A - f ` A'"
    by (intro inj_on_image_set_diff[OF \<open>inj_on f A\<close>]) (use \<open>A' \<subseteq> A\<close> in auto)
  also have "\<dots> = B - B'"
    using assms(1,2) by (auto simp: bij_betw_def)
  finally show "f` (A - A') = B - B'" .
qed

lemma bij_betw_singleton: "bij_betw f {x} {y} \<longleftrightarrow> f x = y"
  by (auto simp: bij_betw_def)

end