theory "FMap-HOLCF"
  imports FMap "HOLCF-Join" "HOLCF-Set"
begin

default_sort type

subsubsection {* A partial order on finite maps *}

instantiation fmap :: (type, po) po
begin
  definition "(a::'a f\<rightharpoonup> 'b) \<sqsubseteq> b \<equiv> (fdom a = fdom b) \<and> (\<forall>x \<in> fdom a. a f! x \<sqsubseteq> b f! x)"

instance
proof default
  fix x :: "'a f\<rightharpoonup> 'b"
  show "x \<sqsubseteq> x" by (auto simp add:below_fmap_def)
next
  fix x y z :: "'a f\<rightharpoonup> 'b"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z"
  thus "x \<sqsubseteq> z"
  apply (auto simp add: below_fmap_def)
  by (metis rev_below_trans)
next
  fix x y :: "'a f\<rightharpoonup> 'b"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x"
  thus "x = y"
  by (metis "FMap-HOLCF.below_fmap_def" fmap_eqI po_eq_conv)
qed
end

lemma fmap_belowI:
  assumes "fdom a = fdom b"
    and "\<And> x. \<lbrakk>
      x \<in> fdom a;
      x \<in> fdom b
      \<rbrakk>  \<Longrightarrow> a f! x \<sqsubseteq> b f! x"
  shows "a \<sqsubseteq> b"
  using assms
  by (metis below_fmap_def)

lemma fmap_belowE:
  assumes "m1 \<sqsubseteq> m2"
  shows "m1 f! x \<sqsubseteq> m2 f! x"
  apply (cases "x \<in> fdom m1")
  using assms
  apply (metis below_fmap_def)
  using assms unfolding below_fmap_def
  apply (transfer, auto)
  done

subsubsection {* The order is chain-complete *}

definition fmap_lub_raw where
  "fmap_lub_raw S = (\<lambda> x.
      if (x \<in> dom (S 0))
      then Some (\<Squnion>i::nat. the (S i x))
      else None)"

lemma fmap_lub_raw_dom[simp]: "dom (fmap_lub_raw S) = dom (S 0)"
  by (auto simp add: fmap_lub_raw_def dom_def)

lift_definition fmap_lub :: "(nat \<Rightarrow> ('key f\<rightharpoonup> 'value::po)) \<Rightarrow> 'key f\<rightharpoonup> 'value" is "fmap_lub_raw"
by auto

lemma fmap_below_dom:
  "a \<sqsubseteq> b \<Longrightarrow> fdom a = fdom b"
  unfolding below_fmap_def by simp

lemma is_lub_fmap:
  assumes "chain (S::nat => 'a f\<rightharpoonup> 'b::cpo)"
  shows "range S <<| fmap_lub S"
proof(rule is_lubI)

  def d \<equiv> "fdom (S 0)"
  have [simp]:"\<And>i . fdom (S i) = d"
    using chain_mono[OF `chain S`, of 0]
    unfolding d_def
    by (metis fmap_below_dom le0)
  hence [simp]: "fdom (fmap_lub S) = d"
    unfolding fmap_lub.rep_eq fdom.rep_eq fmap_lub_raw_def  dom_def
    by auto

{
  show "range S <| fmap_lub S"
  proof(rule is_ubI)
  case (goal1 m)
    then obtain i where "m = S i" by auto
    hence "S 0 \<sqsubseteq> m" using chain_mono[OF `chain S`] by auto

    have [simp]: "fdom m = d" using `m = S i` by simp

    show "m \<sqsubseteq> fmap_lub S"
    proof(rule fmap_belowI)
      fix x
      assume "x \<in> fdom m"
      hence c2: "chain (\<lambda> i. the (Rep_fmap (S i) x))" using `chain S`
        unfolding chain_def below_fmap_def lookup.rep_eq
        by auto

      have "m f! x = the (Rep_fmap (S i) x)"  using `m = _` by (auto simp add: lookup.rep_eq)
      hence ylt: "m f! x \<sqsubseteq> (\<Squnion>i::nat. the (Rep_fmap (S i) x))"
          using is_ub_thelub[OF c2] by (auto simp add: lookup.rep_eq)
      also
      have "x \<in> fdom (S 0) " using `x \<in> fdom m` by simp
      hence "(\<Squnion>i::nat. the (Rep_fmap (S i) x)) = (fmap_lub S) f! x"
        by (auto simp add: fmap_lub.rep_eq lookup.rep_eq fmap_lub_raw_def fdom.rep_eq)
      finally
      show "m f! x \<sqsubseteq> (fmap_lub S) f! x".
    qed simp
  qed
next
  fix u
  assume "range S <| u"

  hence [simp]: "fdom u = d"
    by (metis ub_rangeD  `\<And>i. fdom (S i) = d` fmap_below_dom)

  show "fmap_lub S \<sqsubseteq> u "
  proof(rule fmap_belowI)
    fix x

    assume  "x \<in> fdom (fmap_lub S)"
    hence c2: "chain (\<lambda> i. the (Rep_fmap (S i) x))" (is "chain ?S2") using `chain S`
      unfolding chain_def below_fmap_def lookup.rep_eq
      by auto

    have "x \<in> fdom (S 0) " using `x \<in> fdom (fmap_lub S)` by simp
    hence "lookup (fmap_lub S) x = Some (lub (range ?S2))"
      by (auto simp add: fmap_lub.rep_eq lookup.rep_eq fmap_lub_raw_def fdom.rep_eq)

    hence lub_at_x: "range ?S2 <<| (fmap_lub S f! x)"
      by (metis c2 option.sel thelubE)

    assume "x \<in> fdom u"
    have "range ?S2 <| (u f! x)"
      using ub_rangeD[OF `range S <| u`] `x \<in> fdom u`
      by (auto intro: ub_rangeI simp add:  below_fmap_def lookup.rep_eq)

    thus "(fmap_lub S) f! x \<sqsubseteq> u f! x"
      by (rule is_lubD2[OF lub_at_x])
  qed simp
}
qed

instance fmap :: (type, cpo) cpo
apply default
proof
  fix S :: "nat \<Rightarrow> 'a f\<rightharpoonup> 'b"
  assume "chain S"
  thus "range S <<| fmap_lub S"
    by (rule is_lub_fmap)
qed

lemma unfold_lub_fmap:  "chain (Y::nat => 'a f\<rightharpoonup> 'b::cpo) \<Longrightarrow> lub (range Y) = fmap_lub Y"
  by (rule lub_eqI, rule is_lub_fmap)

subsubsection {* Continuity and finite maps *}

lemma chain_fdom:
  assumes "chain (Y :: nat \<Rightarrow> 'a\<Colon>type f\<rightharpoonup> 'b\<Colon>cpo) "
  shows "fdom (Y i) = fdom (Y 0)" and "fdom (\<Squnion> i. Y i) = fdom (Y 0)"
proof-
    have "Y 0 \<sqsubseteq> Y i" apply (rule chain_mono[OF `chain Y`]) by simp
    thus "fdom (Y i) = fdom (Y 0)" by-(drule fmap_below_dom, rule sym)
    moreover
    have "Y 0 \<sqsubseteq> (\<Squnion>i . Y i)"  by (rule is_ub_thelub[OF `chain Y`])
    thus "fdom (\<Squnion> i. Y i) = fdom (Y 0)" by-(drule fmap_below_dom, rule sym)
qed

lemma lookup_chain:
  assumes "chain (Y :: nat \<Rightarrow> 'a f\<rightharpoonup> 'b::cpo)"
  shows "chain (\<lambda> i . (Y i) f! x)"
proof(rule chainI)
  fix i
  have "fdom (Y i) = fdom (Y 0)" and
       "fdom (Y (Suc i)) = fdom (Y 0)" and
       "fdom (Y j) = fdom (Y 0)"
       by (intro chain_fdom[OF `chain Y`])+
  have "Y i \<sqsubseteq> Y (Suc i)" using `chain _` by (rule chainE)
    hence "fdom (Y (Suc i)) = fdom (Y i)" unfolding below_fmap_def by simp
  show "(Y i) f! x \<sqsubseteq> Y (Suc i) f! x"
    proof(cases "x \<in> fdom (Y i)")
    case True thus ?thesis using `_ \<sqsubseteq> _`  by (simp add: below_fmap_def)
    next
    case False
      hence "(Y i) f! x = the None"
        by (transfer, auto simp add: dom_def)
      moreover
      have "x \<notin> fdom (Y (Suc i))"
        using False `fdom (Y (Suc i)) = fdom (Y i)` by simp
      hence "Y (Suc i) f! x = the None"
        by (transfer, auto simp add: dom_def)
      ultimately show ?thesis by simp
    qed
qed

lemma lookup_cont:
  assumes "chain (Y :: nat \<Rightarrow> 'a f\<rightharpoonup> 'b::cpo)"
  shows "(\<Squnion> i. Y i) f! x = (\<Squnion> i. (Y i) f! x)"
proof(cases "x \<in> fdom (Y 0)")
case True thus ?thesis
  unfolding unfold_lub_fmap[OF `chain Y`]
  apply transfer
  apply (auto simp add: fmap_lub_raw_def)
  done
next
case False
  have "\<And> i. lookup (Y i) x = None"
    by (metis False assms chain_fdom(1) domIff fdom.rep_eq lookup.rep_eq)
  thus ?thesis
    unfolding unfold_lub_fmap[OF `chain Y`]
    by (transfer, auto simp add: fmap_lub_raw_def)
qed

lemma cont2cont_lookup[simp,cont2cont]:
  fixes f :: "'a::cpo \<Rightarrow> 'b::type f\<rightharpoonup> 'c::cpo"
  assumes "cont f"
  shows "cont (\<lambda>p. (f p) f! x)"
proof (rule cont_compose[OF _ `cont f`], rule contI)
  fix Y :: "nat \<Rightarrow> 'b::type f\<rightharpoonup> 'c::cpo"
  assume "chain Y"
  show "range (\<lambda>i. (Y i) f! x) <<| ((\<Squnion> i. Y i) f! x)"
    by (subst lookup_cont[OF `chain Y`], rule cpo_lubI[OF lookup_chain[OF `chain Y`]])
qed

lemma fmap_contI:
  assumes "\<And> x y . x \<sqsubseteq> y \<Longrightarrow> fdom (f x) = fdom (f y)"
  and "\<And>x y z. x \<sqsubseteq> y \<Longrightarrow> z \<in> fdom (f x) \<Longrightarrow> z \<in> fdom (f y) \<Longrightarrow> (f x) f! z \<sqsubseteq> (f y) f! z" (is "PROP ?a2")
  and "\<And> Y x. chain Y \<Longrightarrow> chain (\<lambda>i. f (Y i)) \<Longrightarrow>
       x \<in> fdom (f (\<Squnion> i. Y i)) \<Longrightarrow> x \<in> fdom (\<Squnion> i. f (Y i)) \<Longrightarrow>
       f (\<Squnion> i. Y i) f! x \<sqsubseteq> (\<Squnion> i. f (Y i)) f! x" (is "PROP ?a3")
  shows "cont (f :: 'c::cpo \<Rightarrow> 'a f\<rightharpoonup> 'b::cpo)"
proof(intro contI2 monofunI fmap_belowI)
  fix x y :: 'c
  assume "x \<sqsubseteq> y"
  thus "fdom (f x) = fdom (f y)" using assms(1) by auto
next
  next
  fix Y
  assume c1: "chain (Y :: nat \<Rightarrow> 'c)"
  assume c2: "chain (\<lambda>i. f (Y i))"
  have "Y 0 \<sqsubseteq> Lub Y" by (metis is_ub_thelub[OF c1])
  hence "fdom (f (Y 0)) = fdom (f (Lub Y))" using assms(1) by auto
  thus "fdom (f (\<Squnion> i. Y i)) = fdom (\<Squnion> i. f (Y i))"
    by (simp add: chain_fdom(2)[OF c2])
qed fact+

lemma fmap_upd_mono:
  "\<rho>1 \<sqsubseteq> \<rho>2 \<Longrightarrow> v1 \<sqsubseteq> v2 \<Longrightarrow> \<rho>1(x f\<mapsto> v1) \<sqsubseteq> \<rho>2(x f\<mapsto> v2)"
  apply (rule fmap_belowI)
  apply (auto dest:fmap_below_dom)[1]
  apply (case_tac "xa = x")
  apply simp
  apply (auto elim:fmap_belowE)
  done

lemma fmap_upd_cont[simp,cont2cont]:
  assumes "cont f" and "cont h"
  shows "cont (\<lambda> x. fmap_upd (f x) v (h x) :: 'a f\<rightharpoonup> 'b::cpo)"
proof (intro contI2  monofunI fmap_belowI)
  fix x1 x2 :: 'c
  assume "x1 \<sqsubseteq> x2"
  hence "f x1 \<sqsubseteq> f x2" by -(erule cont2monofunE[OF `cont f`])
  thus "fdom (f x1(v f\<mapsto> h x1)) = fdom (f x2(v f\<mapsto> h x2))"
    by (simp add: fmap_below_dom)

  fix v'
  assume "v' \<in> fdom (f x1(v f\<mapsto> h x1))"  and "v' \<in> fdom (f x2(v f\<mapsto> h x2))"
  thus "f x1(v f\<mapsto> h x1) f! v' \<sqsubseteq> f x2(v f\<mapsto> h x2) f! v'"
  proof(cases "v = v'")
    case True
    thus ?thesis
      using cont2monofunE[OF `cont h` `x1 \<sqsubseteq> x2`]
      by (transfer, auto)
  next
    case False
    moreover
    with ` v' \<in> fdom (f x1(v f\<mapsto> h x1))` `v' \<in> fdom (f x2(v f\<mapsto> h x2))`
    have "v' \<in> fdom (f x1)" and "v' \<in> fdom (f x2)" by auto
    moreover
    have "f x1 f! v' \<sqsubseteq> f x2 f! v'"
      by (rule fmap_belowE[OF cont2monofunE[OF `cont f` `x1 \<sqsubseteq> x2`]])
    ultimately
    show  ?thesis  by (transfer, simp)
  qed

next
  fix Y
  assume c1: "chain (Y :: nat \<Rightarrow> 'c)"
  assume c2: "chain (\<lambda>i. f (Y i)(v f\<mapsto> h (Y i)))"
  have "Y 0 \<sqsubseteq> Lub Y" by (metis is_ub_thelub[OF c1])
  hence "f (Y 0) \<sqsubseteq> f (Lub Y)" by (rule cont2monofunE[OF `cont f`])
  hence "fdom (f (Y 0)) = fdom (f (Lub Y))" by (rule fmap_below_dom)

  thus "fdom (f (\<Squnion> i. Y i)(v f\<mapsto> h (\<Squnion> i. Y i))) = fdom (\<Squnion> i. f (Y i)(v f\<mapsto> h (Y i)))"
    by (simp add: chain_fdom(2)[OF c2])

  fix v'
  show "f (\<Squnion> i. Y i)(v f\<mapsto> h (\<Squnion> i. Y i)) f! v' \<sqsubseteq> (\<Squnion> i. f (Y i)(v f\<mapsto> h (Y i))) f! v'"
  proof(cases "v = v'")
    case True
    thus ?thesis
      using lookup_cont[OF c2]  cont2contlubE[OF `cont h` c1]
      by simp
  next
    case False
    thus ?thesis
      using lookup_cont[OF c2] cont2contlubE[OF `cont f` c1]
            lookup_cont[OF ch2ch_cont[OF `cont f` `chain Y`]]
      by simp
  qed
qed

lemma fdom_adm[intro]: "adm (\<lambda> a. P (fdom a))"
  by (rule admI, metis chain_fdom(2))

lemma fdom_adm_eq[simp]:
   "adm (\<lambda>\<rho>. fdom \<rho> = z)"
   by (rule fdom_adm)

lemma  fmap_add_belowI:
  assumes "fdom x \<union> fdom y = fdom z"
  and "\<And> a. a \<in> fdom y \<Longrightarrow> y f! a \<sqsubseteq> z f! a"
  and "\<And> a. a \<in> fdom x \<Longrightarrow> a \<notin> fdom y \<Longrightarrow> x f! a \<sqsubseteq> z f! a"
  shows  "x f++ y \<sqsubseteq> z"
  using assms
  apply -
  apply (rule fmap_belowI)
  apply auto[1]
  by (metis fdomIff lookup_fmap_add1 lookup_fmap_add2)

lemma fmap_add_cont1: "cont (\<lambda> x. x f++ m::('a::type f\<rightharpoonup> 'b::cpo))"
proof(rule fmap_contI)
  fix x y :: "'a f\<rightharpoonup> 'b"
  assume "x \<sqsubseteq> y"
  hence "fdom x = fdom y" by (rule fmap_below_dom)
  thus "fdom (x f++ m) = fdom (y f++ m)"  by simp
next
  fix x y :: "'a f\<rightharpoonup> 'b"
  assume "x \<sqsubseteq> y"
  fix z :: 'a
  show "(x f++ m) f! z \<sqsubseteq> (y f++ m) f! z"
    using `x \<sqsubseteq> y`
    by(cases "z \<in> fdom m", auto elim: fmap_belowE)
next
  fix Y :: "nat \<Rightarrow> 'a f\<rightharpoonup> 'b"
  assume c1: "chain Y" and c2: "chain (\<lambda>i. Y i f++ m)"
  fix x :: 'a
  show "(\<Squnion> i. Y i) f++ m f! x \<sqsubseteq> (\<Squnion> i. Y i f++ m) f! x"
    by (cases "x \<in> fdom m", auto simp add: lookup_cont[OF c2] lookup_cont[OF c1])
qed

lemma fmap_add_cont2: "cont (\<lambda> x. m f++ x::('a::type f\<rightharpoonup> 'b::cpo))"
proof(rule fmap_contI)
  fix x y :: "'a f\<rightharpoonup> 'b"
  assume "x \<sqsubseteq> y"
  hence "fdom x = fdom y" by (rule fmap_below_dom)
  thus "fdom (m f++ x) = fdom (m f++ y)" by simp
next
  fix x y :: "'a f\<rightharpoonup> 'b"
  assume "x \<sqsubseteq> y"
  hence "fdom x = fdom y" by (rule fmap_below_dom)
  fix z :: 'a
  show "m f++ x f! z \<sqsubseteq> m f++ y f! z"
    using `x \<sqsubseteq> y` `fdom x = fdom y`
    by(cases "z \<in> fdom x", auto elim: fmap_belowE)
next
  fix Y :: "nat \<Rightarrow> 'a f\<rightharpoonup> 'b"
  assume c1: "chain Y" and c2: "chain (\<lambda>i. m f++ Y i)"
    hence [simp]:"\<And> i. fdom (Y i) =  fdom (\<Squnion> i . Y i)"
      by (metis chain_fdom(1) chain_fdom(2))
  fix x :: 'a
  show "m f++ (\<Squnion> i. Y i) f! x \<sqsubseteq> (\<Squnion> i. m f++ Y i) f! x"
    by (cases "x \<in> fdom (\<Squnion> i . Y i)", auto simp add: lookup_cont[OF c2] lookup_cont[OF c1])
qed

lemma fmap_add_cont2cont[simp, cont2cont]:
  assumes "cont f"
  assumes "cont g"
  shows "cont (\<lambda> x. f x f++ (g x :: 'a f\<rightharpoonup> 'b::cpo))"
by (rule cont_apply[OF assms(1) fmap_add_cont1 cont_compose[OF fmap_add_cont2 assms(2)]])

lemma fmap_add_mono:
  assumes "x1 \<sqsubseteq> (x2 :: ('a::type f\<rightharpoonup> 'b::cpo))"
  assumes "y1 \<sqsubseteq> y2"
  shows "x1 f++ y1 \<sqsubseteq> x2 f++ y2"
by (rule below_trans[OF cont2monofunE[OF fmap_add_cont1 assms(1)] cont2monofunE[OF fmap_add_cont2 assms(2)]])

lemma fmap_upd_belowI:
  assumes "fdom \<rho>' = insert x (fdom \<rho>)"
  assumes "\<And> z . z \<in> fdom \<rho> \<Longrightarrow> z \<noteq> x \<Longrightarrow> \<rho> f! z \<sqsubseteq> \<rho>' f! z"
  assumes "y \<sqsubseteq> \<rho>' f! x"
  shows  "\<rho>(x f\<mapsto> y) \<sqsubseteq> \<rho>'"
  apply (rule fmap_belowI)
  using assms apply simp
  using assms
  apply (case_tac "xa = x")
  apply auto
  done

lemma fmap_upd_belowI2:
  assumes "fdom \<rho> = insert x (fdom \<rho>')"
  assumes "\<And> z . z \<in> fdom \<rho> \<Longrightarrow> z \<noteq> x \<Longrightarrow> \<rho> f! z \<sqsubseteq> \<rho>' f! z"
  assumes "\<rho> f! x \<sqsubseteq> y"
  shows  "\<rho> \<sqsubseteq> \<rho>'(x f\<mapsto> y)"
  apply (rule fmap_belowI)
  using assms apply simp
  using assms
  apply (case_tac "xa = x")
  apply auto
  done

lemma fmap_restr_belowI:
  assumes  "\<And> x. x \<in> S \<Longrightarrow> (fmap_restr S m1) f! x \<sqsubseteq> (fmap_restr S m2) f! x"
  and "fdom m1 = fdom m2"
  shows "fmap_restr S m1 \<sqsubseteq> fmap_restr S m2"
proof (cases "finite S")
case True thus ?thesis
  apply -
  apply (rule fmap_belowI)
  apply (simp add: `fdom m1 = fdom m2`)
  by (metis Int_iff assms(1) fdom_fmap_restr)
next
case False thus ?thesis unfolding fmap_restr_def by simp
qed

lemma fmap_restr_monofun:  "monofun (fmap_restr S)"
proof (cases "finite S")
  case True thus ?thesis
    apply -
    apply (rule monofunI)
    apply (rule fmap_restr_belowI)
    apply (subst lookup_fmap_restr[OF True], assumption)+
    apply (metis fmap_belowE)
    by (metis fmap_below_dom)
next
case False thus ?thesis  by -(rule monofunI, simp add: fmap_restr_def)
qed

lemma fmap_restr_cont:  "cont (fmap_restr S)"
proof(cases "finite S")
case True thus ?thesis apply -
  apply (rule contI2[OF fmap_restr_monofun])
  apply (rule fmap_belowI)
  apply (simp add: chain_fdom(2))[1]
  apply auto
  apply (subst lookup_cont, assumption)+
  apply (rule lub_mono[OF lookup_chain lookup_chain], assumption+)
  apply (subst lookup_fmap_restr[OF True], assumption)
  apply (rule below_refl)
  done
next
case False thus ?thesis by -(rule contI2[OF fmap_restr_monofun], simp add: fmap_restr_def)
qed

lemma fmap_restr_fdom_cont'[simp, cont2cont]:
  assumes "cont f"
  assumes "cont g"
  shows "cont (\<lambda> x. fmap_restr (S (fdom (f x))) (g x))"
proof (rule contI)
  case (goal1 Y)
  have [simp]:"\<And> i. fdom (f (Y i)) = fdom (f (\<Squnion>i. Y i))"
    apply (subst cont2contlubE[OF `cont f` `chain Y`])
    using ch2ch_cont[OF `cont f` `chain Y`]
    by (metis chain_fdom)
  show "?case"
    apply simp
    apply (subst cont2contlubE[OF cont_compose[OF fmap_restr_cont `cont g`] `chain Y`])
    by (metis assms(2) ch2ch_cont cpo_lubI fmap_restr_cont goal1)
qed

lemmas fmap_restr_cont2cont[simp,cont2cont] = cont_compose[OF fmap_restr_cont]

lemma adm_less_fmap [simp]:
  "[|cont (\<lambda>x. u x); cont (\<lambda>x. v x)|] ==> adm (\<lambda>x. u x \<le> ((v x)::'a::type f\<rightharpoonup> 'b::pcpo))"
  apply (subst fmap_less_restrict)
  apply (intro adm_lemmas, assumption+)
  apply (rule contI)
  apply (subst chain_fdom(1)[OF ch2ch_cont[of u]], assumption+)
  apply (subst cont2contlubE[of u], assumption+)
  apply (subst chain_fdom(2)[OF ch2ch_cont[of u]], assumption+)
  apply (rule contE)
  apply auto
  done

subsubsection {* Expanding the domain of finite maps *}

lift_definition fmap_expand :: "'a f\<rightharpoonup> 'b::pcpo \<Rightarrow> 'a set  \<Rightarrow> 'a f\<rightharpoonup> 'b" ("_\<^bsub>[_]\<^esub>" [90, 60] 90)
  is "\<lambda> m1 S. (if finite S then (\<lambda> x. if x \<in> S then Some (case m1 x of (Some x) => x | None => \<bottom>) else None) else empty)"
  apply (case_tac "finite set")
  apply (rule_tac B = "dom fun \<union> set" in   finite_subset)
  apply auto
  done

lemma fmap_expand_nonfinite:
  "\<not> finite S \<Longrightarrow> m\<^bsub>[S]\<^esub> = f\<emptyset>"
  by (transfer, simp)

lemma fmap_restr_fmap_expand:
  "finite d2 \<Longrightarrow> fmap_restr d1 (m\<^bsub>[d2]\<^esub>) = fmap_restr d1 (m\<^bsub>[d1 \<inter> d2]\<^esub>)"
  apply(cases "finite d1")
  apply transfer
  apply (auto simp add: restrict_map_def)
  unfolding fmap_restr_def
  by auto

lemma fmap_restr_fmap_expand2:
  "finite d2 \<Longrightarrow> d1 \<subseteq> d2 \<Longrightarrow> fmap_restr d1 (m\<^bsub>[d2]\<^esub>) = m\<^bsub>[d1]\<^esub>"
  apply(cases "finite d1")
  apply transfer
  apply (auto simp add: restrict_map_def split:option.split)
  apply (metis set_mp)
  by (metis rev_finite_subset)

lemma fdom_fmap_expand[simp]:
  "finite S \<Longrightarrow> fdom (m\<^bsub>[S]\<^esub>) = S"
  by (transfer, auto split:if_splits)

lemma fmap_expand_noop[simp]:
  "S = fdom \<rho> \<Longrightarrow> \<rho>\<^bsub>[S]\<^esub> = \<rho>"
  by (transfer, auto split: option.split)

lemma fmap_expand_idem:
  "finite S2 \<Longrightarrow> fdom \<rho> \<subseteq> S1 \<Longrightarrow> S1 \<subseteq> S2 \<Longrightarrow> (\<rho>\<^bsub>[S1]\<^esub>)\<^bsub>[S2]\<^esub> = \<rho>\<^bsub>[S2]\<^esub>"
  apply (transfer)
  apply (auto split:option.split simp add: split_if_eq1 split_if_eq2)
  apply (rule ext)
  apply (auto split:option.split simp add: split_if_eq1 split_if_eq2)
  by (metis finite_subset)

lemma lookup_fmap_expand1[simp]:
  "finite S \<Longrightarrow> x \<in> S \<Longrightarrow> x \<in> fdom m \<Longrightarrow> lookup (m\<^bsub>[S]\<^esub>) x = lookup m x"
  by (transfer, auto)

lemma lookup_fmap_expand2[simp]:
  "finite S \<Longrightarrow> x \<in> S \<Longrightarrow> x \<notin> fdom m \<Longrightarrow> lookup (m\<^bsub>[S]\<^esub>) x = Some \<bottom>"
  by (transfer, auto split:option.split)

lemma lookup_fmap_expand3[simp]:
  "finite S \<Longrightarrow> x \<notin> S \<Longrightarrow> lookup (m\<^bsub>[S]\<^esub>) x = None"
  by (transfer, auto split:option.split)

lemma fmap_expand_fdom[simp]: "\<rho>\<^bsub>[fdom \<rho>]\<^esub> = \<rho>"
  by (transfer, auto split:option.split)

lemma fmap_expand_belowI:
  assumes "fdom \<rho>' = S"
  assumes "\<And> x. x \<in> fdom \<rho> \<Longrightarrow> x \<in> S \<Longrightarrow> \<rho> f! x \<sqsubseteq> \<rho>' f! x"
  shows "\<rho>\<^bsub>[S]\<^esub> \<sqsubseteq> \<rho>'"
  apply (rule fmap_belowI)
  apply (metis assms(1) fdom_fmap_expand finite_fdom)
  apply (case_tac "x \<in> fdom \<rho>")
  apply (metis assms(1) assms(2) finite_fdom lookup_fmap_expand1)
  apply (metis assms(1) finite_fdom lookup_fmap_expand2 minimal option.sel)
  done

lemma fmap_expand_fmap_restr_below:
  assumes [simp]:"fdom x = S2"
  shows "(fmap_restr S1 x)\<^bsub>[S2]\<^esub> \<sqsubseteq> x"
  apply (rule fmap_expand_belowI[OF assms(1)])
  by (metis Int_iff below.r_refl empty_iff fdom_fmap_restr fempty_fdom fmap_restr_not_finite lookup_fmap_restr)

lemma fmap_expand_monofun:
  "monofun (\<lambda> m. m\<^bsub>[S]\<^esub>)"
proof(cases "finite S")
case True
  show ?thesis
  proof (rule monofunI, rule fmap_belowI)
  case goal1 thus *: ?case using True by (simp add: fmap_below_dom)
  case (goal2 m1 m2 x) thus ?case
    using goal2 True
    apply (cases "x \<in> S")
    apply (cases "x \<in> fdom m1")
    apply (subgoal_tac "x \<in> fdom m2")
    apply (auto dest:fmap_belowE simp add: fmap_below_dom)
    done
  qed
next
case False
  show ?thesis by (rule monofunI, simp add: fmap_expand_nonfinite[OF False])
qed

lemma fmap_expand_cont:
  "cont (\<lambda> m. m\<^bsub>[S]\<^esub>)"
proof(cases "finite S")
case True[simp]
  show ?thesis
  proof (rule fmap_contI)
  case goal1 thus ?case by (simp add: fmap_below_dom)
  case goal2 thus ?case by (metis True below_fmap_def fdom_fmap_expand lookup_fmap_expand1 lookup_fmap_expand2 minimal option.sel)
  next
  case (goal3 Y x)[simp]
    hence [simp]:"x \<in> S" by simp
    show ?case
      apply (cases "x \<in> fdom (\<Squnion> i. Y i)")
      apply (subgoal_tac "\<And> i. x \<in> fdom (Y i)")
      apply (simp add: lookup_cont)
      apply (metis chain_fdom(1) chain_fdom(2) goal3(1))
      apply (simp)
      done
  qed
next
case False
  show ?thesis by (rule contI2[OF fmap_expand_monofun] , simp add: fmap_expand_nonfinite[OF False])
qed

lemma fmap_upd_expand:
  "finite S \<Longrightarrow>
   x \<in> S \<Longrightarrow>
   \<rho>(x f\<mapsto> y)\<^bsub>[S]\<^esub> = (\<rho>\<^bsub>[S - {x}]\<^esub>)(x f\<mapsto> y)"
   apply (rule fmap_eqI, auto)
   apply (case_tac "xa \<in> fdom (\<rho>(x f\<mapsto> y))", auto)
   apply (case_tac "xa = x", auto)
   done

lemma less_fmap_expand:
  "finite S \<Longrightarrow> fdom \<rho> \<subseteq> S \<Longrightarrow> \<rho> \<le> \<rho>\<^bsub>[S]\<^esub>"
  unfolding less_eq_fmap_def
  by (transfer, auto)

subsubsection {* Bottoms *}

lemma fmap_bottom_below[simp]:
  "S = fdom \<rho> \<Longrightarrow> f\<emptyset>\<^bsub>[S]\<^esub> \<sqsubseteq> \<rho>"
 by(rule fmap_belowI, auto)

lemma fmap_bottom_below_iff[iff]:
  "finite S \<Longrightarrow> f\<emptyset>\<^bsub>[S]\<^esub> \<sqsubseteq> \<rho> \<longleftrightarrow> S = fdom \<rho>"
  by (metis fdom_fmap_expand fmap_below_dom fmap_bottom_below)

lemma fmap_bottom_inj[iff]: "finite x \<Longrightarrow> finite y \<Longrightarrow> f\<emptyset>\<^bsub>[x]\<^esub> = f\<emptyset>\<^bsub>[y]\<^esub> \<longleftrightarrow> x = y"
  by (metis below.r_refl fmap_bottom_below_iff)

lemma fmap_expand_fmap_bottom[simp]: "f\<emptyset>\<^bsub>[S']\<^esub>\<^bsub>[S]\<^esub> = f\<emptyset>\<^bsub>[S]\<^esub>"
  by (transfer, auto)

lemma fmap_restr_fmap_bottom[simp]:
  "finite S \<Longrightarrow> finite S2 \<Longrightarrow> fmap_restr S (f\<emptyset>\<^bsub>[S2]\<^esub>) = f\<emptyset>\<^bsub>[S \<inter> S2]\<^esub>"
  by auto

lemma fmap_bottom_insert:
  "finite S \<Longrightarrow>
  f\<emptyset>\<^bsub>[insert x S]\<^esub> = (f\<emptyset>\<^bsub>[S]\<^esub>)(x f\<mapsto> \<bottom>)"
  apply (rule fmap_eqI)
  apply auto[1]
  apply (case_tac "xa = x", auto)
  done

lemma fmap_bottom_less[simp]:
  "finite S2 \<Longrightarrow> S1 \<subseteq> S2 \<Longrightarrow> f\<emptyset>\<^bsub>[S1]\<^esub> \<le> f\<emptyset>\<^bsub>[S2]\<^esub>"
  apply (subgoal_tac "finite S1")
  apply (rule fmap_less_eqI)
  apply simp
  apply simp
  by (rule rev_finite_subset)

subsubsection {* A setup for defining a fixed point of finite maps iteratively *}

lemma fdom_fix_on:
  assumes "fix_on_cond S b F"
  shows  "fdom (fix_on' b F) = fdom b"
proof-
  have "fix_on' b F \<in> S"
    by (rule fix_on_there[OF assms])
  hence "b \<sqsubseteq> fix_on' b F"
    by (metis assms bottom_of_subpcpo_bot_minimal fix_on_cond.simps subpcpo_is_subpcpo_bot)
  thus ?thesis
    by (metis fmap_below_dom)
qed

locale iterative =
  fixes \<rho> :: "'a::type f\<rightharpoonup> 'b::pcpo"
   and e1 :: "'a f\<rightharpoonup> 'b \<Rightarrow> 'a f\<rightharpoonup> 'b"
   and e2 :: "'a f\<rightharpoonup> 'b \<Rightarrow> 'b"
   and S :: "'a set" and x :: 'a
   and D
  defines "D \<equiv> insert x (fdom \<rho> \<union> S)"
  assumes cont_e1 [simp]:"cont e1"
  assumes cont_e2 [simp]:"cont e2"
  assumes dom[simp]: "\<And> \<rho>. fdom (e1 \<rho>) = S"
  assumes ne:"x \<notin> S"

sublocale iterative < subpcpo "{x. f\<emptyset>\<^bsub>[D]\<^esub> \<sqsubseteq> x}" by (rule subpcpo_cone_above)

context iterative
begin

  abbreviation "cpo == {x. f\<emptyset>\<^bsub>[D]\<^esub> \<sqsubseteq> x}"
  abbreviation "b == f\<emptyset>\<^bsub>[D]\<^esub>"

  abbreviation "L == (\<lambda> \<rho>'. (\<rho> f++ e1 \<rho>')(x f\<mapsto> e2 \<rho>'))"
  abbreviation "H == (\<lambda> \<rho>' \<rho>''. \<rho>' f++ e1 \<rho>'')"
  abbreviation "R == (\<lambda> \<rho>'. (\<rho> f++ fmap_restr S (fix_on' b (H \<rho>')))(x f\<mapsto> e2 \<rho>'))"
  abbreviation "R' == (\<lambda> \<rho>'. (\<rho> f++ fmap_restr S (fix_on' b (H \<rho>')))(x f\<mapsto> e2 (fix_on' b (H \<rho>'))))"

  lemma condL: "fix_on_cond cpo b L"
    apply (rule fix_on_condI)
    apply (rule subpcpo_cone_above)
    apply (rule bottom_of_cone_above)
    apply (rule closed_onI)
      apply (simp add: D_def)
    apply (rule cont_is_cont_on)
      apply simp
    done
  lemmas [simp] = fdom_fix_on[OF condL]

  lemma condH: "\<And> \<rho>'. \<rho>' \<in> cpo \<Longrightarrow> fix_on_cond cpo b (H \<rho>')"
    apply (rule fix_on_condI)
    apply (rule subpcpo_cone_above)
    apply (rule bottom_of_cone_above)
    apply (rule closed_onI)
      apply (auto simp add: D_def)[1]
    apply (rule cont_is_cont_on)
      apply simp
    done
  lemmas [simp] = fdom_fix_on[OF condH]

  lemma condR: "fix_on_cond cpo b R"
    apply (rule fix_on_condI)
    apply (rule subpcpo_cone_above)
    apply (rule bottom_of_cone_above)
    apply (rule closed_onI)
      using fdom_fix_on[OF condH]  apply (auto simp add: D_def)[1]
    apply (rule cont_comp_cont_on2[OF cont2cont_lambda[OF fmap_upd_cont[OF cont_id cont_const]]
                fmap_upd_cont[OF cont_const cont_id]
                _
                cont_is_cont_on[OF cont_e2]])
    apply (rule cont_comp_cont_on2[OF cont2cont_lambda[OF fmap_add_cont1]
                fmap_add_cont2
                cont_is_cont_on[OF cont_const]
                ])
    apply (rule cont_comp_cont_on[OF fmap_restr_cont])
    apply (rule cont_onI2)
      apply (rule monofun_onI)
      apply (erule (1) fix_on_mono[OF condH condH])
      apply (erule cont2monofunE[OF fmap_add_cont1])

    apply (rule eq_imp_below)
    apply (rule fix_on_cont[OF chain_on_is_chain condH[OF chain_on_is_on]])
      apply assumption
      apply assumption
    apply (rule cont2cont_lambda[OF fmap_add_cont1])
    done
  lemmas [simp] = fdom_fix_on[OF condR]

  lemma cont_on_fix_H: "cont_on (\<lambda> \<rho>'. fix_on' b (H \<rho>'))"
    apply (rule cont_onI2)
      apply (rule monofun_onI)
      apply (erule (1) fix_on_mono[OF condH condH])
      apply (erule cont2monofunE[OF fmap_add_cont1])

    apply (rule eq_imp_below)
    apply (rule fix_on_cont[OF chain_on_is_chain condH[OF chain_on_is_on]])
      apply assumption
      apply assumption
    apply (rule cont2cont_lambda[OF fmap_add_cont1])
    done

  lemma condR': "fix_on_cond cpo b R'"
    apply (rule fix_on_condI)
    apply (rule subpcpo_cone_above)
    apply (rule bottom_of_cone_above)
    apply (rule closed_onI)
      using fdom_fix_on[OF condH]  apply (auto simp add: D_def)[1]
    apply (rule cont_comp_cont_on2[OF cont2cont_lambda[OF fmap_upd_cont[OF cont_id cont_const]]
                fmap_upd_cont[OF cont_const cont_id]
                _
                cont_comp_cont_on[OF cont_e2 cont_on_fix_H]])
    apply (rule cont_comp_cont_on2[OF cont2cont_lambda[OF fmap_add_cont1]
                fmap_add_cont2
                cont_is_cont_on[OF cont_const]
                ])
    apply (rule cont_comp_cont_on[OF fmap_restr_cont cont_on_fix_H])
    done
  lemmas [simp] = fdom_fix_on[OF condR']

  lemmas fix_eq_R = fix_on_eq[OF condR]
  lemmas fix_eq_R' = fix_on_eq[OF condR']
  lemmas fix_eq_L = fix_on_eq[OF condL]
  lemmas fix_eq_HL = fix_on_eq[OF condH[OF fix_on_there[OF condL]]]
  lemmas fix_eq_HR = fix_on_eq[OF condH[OF fix_on_there[OF condR]]]
  lemmas fix_eq_HR' = fix_on_eq[OF condH[OF fix_on_there[OF condR']]]

  lemma [simp]: "D \<inter> S = S"
      by (auto simp add: D_def)

  lemma HR_not_S[simp]: "\<And> x. x \<notin> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b R))) x = lookup (fix_on' b R) x"
      apply (subst fix_eq_HR) by simp

  lemma HR_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b R))) y = lookup (e1 (fix_on' b (H (fix_on' b R)))) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst fix_eq_HR)
    apply simp
    using ne by metis

  lemma L_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b L) y = lookup (e1 (fix_on' b L)) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst (1) fix_eq_L)
    apply simp
    using ne by metis

  lemma L_x2[simp]: "(fix_on' b L) f! x = e2 (fix_on' b L)"
    by (subst (1) fix_eq_L, simp)

  lemma L_not_S_x2[simp]: "\<And> y. y \<notin> S \<Longrightarrow> y \<noteq> x \<Longrightarrow> lookup (fix_on' b L) y = lookup \<rho> y"
    by (subst (1) fix_eq_L, simp)

  lemma R_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b R) y = lookup (e1 (fix_on' b (H (fix_on' b R)))) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst fix_eq_R)
    apply simp
    using ne by metis

  lemma R_x2[simp]: "(fix_on' b R) f! x = e2 (fix_on' b R)"
    by (subst fix_eq_R, simp)

  lemma R_not_S[simp]: "\<And> y. y \<notin> S \<Longrightarrow> y \<noteq> x \<Longrightarrow> lookup (fix_on' b R) y = lookup \<rho> y"
    by (subst fix_eq_R, simp)

  lemma HR_is_R[simp]: "fix_on' b (H (fix_on' b R)) = fix_on' b R"
    apply (rule fmap_eqI)
    apply simp
    apply (case_tac "xa \<in> S")
    apply simp_all
    done

  lemma HL_not_S[simp]: "\<And> x. x \<notin> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b L))) x = lookup (fix_on' b L) x"
    apply (subst fix_eq_HL) by simp

  lemma HR'_not_S[simp]: "\<And> x. x \<notin> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b R'))) x = lookup (fix_on' b R') x"
    apply (subst fix_eq_HR') by simp

  lemma HR'_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b R'))) y = lookup (e1 (fix_on' b (H (fix_on' b R')))) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst fix_eq_HR')
    apply simp
    using ne by metis

  lemma HL_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b L))) y = lookup (e1 (fix_on' b (H (fix_on' b L)))) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst fix_eq_HL)
    apply simp
    using ne by metis

  lemma R'_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b R') y = lookup (e1 (fix_on' b (H (fix_on' b R')))) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst fix_eq_R')
    apply simp
    using ne by metis

  lemma R'_x2[simp]: "(fix_on' b R') f! x = e2 (fix_on' b (H (fix_on' b R')))"
    by (subst fix_eq_R', simp)

  lemma R'_not_S[simp]: "\<And> y. y \<notin> S \<Longrightarrow> y \<noteq> x \<Longrightarrow> lookup (fix_on' b R') y = lookup \<rho> y"
    by (subst fix_eq_R', simp)

  lemma HR'_is_R'[simp]: "fix_on' b (H (fix_on' b R')) = fix_on' b R'"
    apply (rule fmap_eqI)
    apply simp
    apply (case_tac "xa \<in> S")
    apply simp_all
    done

  lemma H_noop:
    fixes \<rho>' \<rho>''
    assumes there: "(\<rho>' :: 'a f\<rightharpoonup> 'b) \<in> cpo"
    assumes "\<And> x. x \<in> S \<Longrightarrow> (e1 \<rho>'') f! x \<sqsubseteq> \<rho>' f! x"
    shows "H \<rho>' \<rho>'' \<sqsubseteq> \<rho>'"
      using assms
      apply -
      apply (rule fmap_belowI)
      using there apply (auto simp add: D_def)[1]
      apply (case_tac "x \<in> fdom (e1 \<rho>')")
      apply simp
      apply simp
      done

  lemma HL_is_L[simp]: "fix_on' b (H (fix_on' b L)) = fix_on' b L"
  proof (rule below_antisym)
    show "fix_on' b (H (fix_on' b L)) \<sqsubseteq> fix_on' b L"
      apply (rule fix_on_least_below[OF condH[OF fix_on_there[OF condL]] fix_on_there[OF condL]])
      apply (rule H_noop[OF fix_on_there[OF condL]])
      apply simp
    done

    show "fix_on' b L \<sqsubseteq> fix_on' b (H (fix_on' b L))"
    apply (rule fix_on_least_below[OF condL fix_on_there[OF condH[OF fix_on_there[OF condL]]]])
    apply (rule fmap_upd_belowI)
    apply simp apply (auto simp add: D_def)[1]
    apply (case_tac "z \<in> S")
    apply simp
    apply simp
    apply (simp add: ne)
    apply (rule cont2monofunE[OF cont_e2])
    apply fact
    done
  qed

  lemma HLL_below_L: "H (fix_on' b L) (fix_on' b L) \<sqsubseteq> (fix_on' b L)"
    by (rule H_noop, simp_all)

  lemma iterative_fmap_add:
    shows "fix_on' b L = fix_on' b R"
  proof(rule below_antisym)
    show "fix_on' b R \<sqsubseteq> fix_on' b L"
    proof (rule fix_on_least_below[OF condR])
      show "fix_on' b L \<in> cpo"
        by simp
      show "R (fix_on' b L) \<sqsubseteq> fix_on' b L"
      proof(rule fmap_upd_belowI)
        case goal1 show ?case by (simp, auto simp add: D_def)
        show "e2 (fix_on' b L) \<sqsubseteq> (fix_on' b L) f! x"
          by simp
        case (goal2 y)
          hence [simp]:"y \<noteq> x" by metis
        show "\<rho> f++ fmap_restr S (fix_on' b (H (fix_on' b L))) f! y \<sqsubseteq> (fix_on' b L) f! y"
        proof(cases "y \<in> S")
        case True[simp]
          from HLL_below_L
          have "(fix_on' b (H (fix_on' b L))) \<sqsubseteq> (fix_on' b L)"
            by (rule fix_on_least_below[OF condH[OF fix_on_there[OF condL]] fix_on_there[OF condL]])
          hence "fix_on' b (H (fix_on' b L)) f! y \<sqsubseteq> fix_on' b L f! y"
            by (rule fmap_belowE)
          thus ?thesis
            by (subst lookup_fmap_add1, simp_all)
        next
        case False
          thus ?thesis by simp
        qed
      qed
    qed

    show "fix_on' b L \<sqsubseteq> fix_on' b R"
    proof (rule fix_on_least_below[OF condL])
      show "fix_on' b R \<in> cpo"
        by simp
      show "L (fix_on' b R) \<sqsubseteq> fix_on' b R"
        apply (rule  fmap_upd_belowI)
        apply simp apply (auto simp add: D_def)[1]
        apply (case_tac "z \<notin> S")
        apply simp_all
      done
    qed
  qed

  lemma iterative_fmap_add':
    shows "fix_on' b L = fix_on' b R'"
  proof(rule below_antisym)
    show "fix_on' b R' \<sqsubseteq> fix_on' b L"
    proof (rule fix_on_least_below[OF condR'])
      show "fix_on' b L \<in> cpo"
        by simp
      show "R' (fix_on' b L) \<sqsubseteq> fix_on' b L"
      proof(rule fmap_upd_belowI)
        case goal1 show ?case by (simp, auto simp add: D_def)
        show "e2 (fix_on' b (H (fix_on' b L))) \<sqsubseteq> (fix_on' b L) f! x"
          by simp
        case (goal2 y)
          hence [simp]:"y \<noteq> x" by metis
        show "\<rho> f++ fmap_restr S (fix_on' b (H (fix_on' b L))) f! y \<sqsubseteq> fix_on' b L f! y"
        proof(cases "y \<in> S")
        case True[simp]
          from HLL_below_L
          have "(fix_on' b (H (fix_on' b L))) \<sqsubseteq> (fix_on' b L)"
            by (rule fix_on_least_below[OF condH[OF fix_on_there[OF condL]] fix_on_there[OF condL]])
          hence "fix_on' b (H (fix_on' b L)) f! y \<sqsubseteq> fix_on' b L f! y"
            by (rule fmap_belowE)
          thus ?thesis
            by (subst lookup_fmap_add1, simp_all)
        next
        case False
          thus ?thesis by simp
        qed
      qed
    qed

    show "fix_on' b L \<sqsubseteq> fix_on' b R'"
    proof (rule fix_on_least_below[OF condL])
      show "fix_on' b R' \<in> cpo"
        by simp
      show "L (fix_on' b R') \<sqsubseteq> fix_on' b R'"
        apply (rule  fmap_upd_belowI)
        apply simp apply (auto simp add: D_def)[1]
        apply (case_tac "z \<notin> S")
        apply simp_all
      done
    qed
  qed
end

subsubsection {* Finite maps have greatest lowest bounds *}

instance fmap :: (type, Nonempty_Meet_cpo) Bounded_Nonempty_Meet_cpo
apply default
proof-
  fix S :: "('a f\<rightharpoonup> 'b) set"
  assume "S \<noteq> {}" and "\<exists>z. S >| z"
  then obtain b where "\<And> m. m\<in>S \<Longrightarrow> b \<sqsubseteq> m" by (metis is_lbD)
  hence [simp]:"\<And> m. m \<in> S \<Longrightarrow> fdom m = fdom b" by (metis fmap_below_dom)

  obtain f where f: "\<And> x. x \<in> fdom b \<Longrightarrow> (\<lambda>m . m f! x) ` S >>| f x "
  proof-
    {
    fix x
    assume "x \<in> fdom b"
    have "(\<lambda>m . m f! x) ` S \<noteq> {}" using `S \<noteq> {}` by auto
    then obtain l where  "(\<lambda>m . m f! x) ` S >>| l" by (metis nonempty_meet_exists)
    hence "(\<lambda>m . m f! x) ` S >>| (SOME l. (\<lambda>m . m f! x) ` S >>| l)"
      by (rule someI)
    }
    thus ?thesis by (rule that)
  qed

  let ?zm = "\<lambda> x. if x \<in> fdom b then Some (f x) else None"
  have "dom ?zm = fdom b" by (auto simp add: dom_def)

  obtain z where [simp]: "fdom z = fdom b" and z: "\<And> x m . x \<in> fdom b \<Longrightarrow> (\<lambda>m . m f! x) ` S >>| (z f! x)"
  proof-
    show ?thesis
      apply (rule that[of "Abs_fmap ?zm"])
      apply (subst fdom.rep_eq)
      apply (subst  Abs_fmap_inverse)
      prefer 3
      apply (subst (2) lookup.rep_eq)
      apply (subst  Abs_fmap_inverse)
      apply (auto simp add: dom_def)
      apply (erule f)
      done
  qed

  have "S >>| z"
    apply (rule is_glbI)
    apply (rule is_lbI)
    apply (rule fmap_belowI)
    apply simp
    apply (rule is_lbD)
    apply (rule is_glbD1)
    apply (rule z, simp)
    apply auto
    apply (rule fmap_belowI)
    apply (metis `S \<noteq> {}` `\<And>m. m \<in> S \<Longrightarrow> fdom m = fdom b` `fdom z = fdom b` all_not_in_conv fmap_below_dom is_lbD)
    apply (rule is_glbD2)
    apply (rule z, simp)
    apply (rule is_lbI)
    apply (erule imageE)
    apply (erule ssubst)
    apply (rule fmap_belowE)
    apply (erule (1) is_lbD)
    done
  thus "\<exists> z. S >>| z" by auto
qed

subsubsection {* Finite maps can be partitioned in pcpo's *}

instantiation fmap :: (type, pcpo) subpcpo_partition
begin
  definition "to_bot x = f\<emptyset>\<^bsub>[fdom x]\<^esub>"
  lemma [simp]:"fdom (to_bot x) = fdom x"
    unfolding to_bot_fmap_def by auto

  lemma to_bot_vimage_cone:"to_bot -` {to_bot x} = {z. f\<emptyset>\<^bsub>[fdom x]\<^esub> \<sqsubseteq> z}"
    by (auto simp add:to_bot_fmap_def)

  instance
  apply default
  apply (subst to_bot_vimage_cone)
  apply (rule subpcpo_cone_above)
  apply (simp add: to_bot_fmap_def fmap_below_dom)
  apply (simp add: to_bot_fmap_def)
  done
end

subsubsection {* Binary joins of finite maps *}

lemma fdom_join[simp]:
  "compatible m1 m2 \<Longrightarrow> fdom (m1 \<squnion> m2) = fdom m1"
  by (metis join_above1 fmap_below_dom)

lemma fdom_compatible:
  "compatible m1 m2 \<Longrightarrow> fdom m1 = fdom m2"
by (metis join_above1 join_above2 fmap_below_dom)

lemma the_lookup_compatible_and_join:
  assumes "compatible m1 m2"
  assumes [simp]: "x \<in> fdom m1"
  shows "compatible (m1 f! x) (m2 f! x) \<and> (m1 f! x) \<squnion> (m2 f! x) = (m1 \<squnion> m2) f! x"
proof (rule is_join_and_compatible)
  show "m1 f! x \<sqsubseteq> (m1 \<squnion> m2) f! x"
    by (rule fmap_belowE[OF join_above1[OF `compatible m1 m2`]])
  show "m2 f! x \<sqsubseteq> (m1 \<squnion> m2) f! x"
    by (rule fmap_belowE[OF join_above2[OF `compatible m1 m2`]])
  fix a
  assume "m1 f! x \<sqsubseteq> a"
  assume "m2 f! x \<sqsubseteq> a"

  note fdom_compatible[OF `compatible m1 m2`, symmetric, simp]
  note fdom_join[OF `compatible m1 m2`, simp]

  have "m1 \<sqsubseteq> (m1 \<squnion> m2)(x f\<mapsto> a)"
    apply (rule fmap_upd_belowI2)
    apply auto[1]
    apply (rule fmap_belowE[OF join_above1[OF `compatible m1 m2`]])
    apply (rule `m1 f! x \<sqsubseteq> a`)
    done
  moreover
  have "m2 \<sqsubseteq> (m1 \<squnion> m2)(x f\<mapsto> a)"
    apply (rule fmap_upd_belowI2)
    apply auto[1]
    apply (rule fmap_belowE[OF join_above2[OF `compatible m1 m2`]])
    apply (rule `m2 f! x \<sqsubseteq> a`)
    done
  ultimately
  have "(m1 \<squnion> m2) \<sqsubseteq> (m1 \<squnion> m2)(x f\<mapsto> a)"
    by (rule join_below[OF `compatible m1 m2`])
  thus " m1 \<squnion> m2 f! x \<sqsubseteq> a"
    by (metis (full_types) fmap_belowE option.sel the_lookup_fmap_upd)
qed

lemma the_lookup_join[simp]:
  assumes "compatible m1 m2"
  shows "(m1 \<squnion> m2) f! x = (m1 f! x) \<squnion> (m2 f! x)"
  apply (cases "x \<in> fdom m1")
  apply (metis assms the_lookup_compatible_and_join)
  apply (metis assms fdomIff fdom_compatible fdom_join join_self)
  done

lemma the_lookup_compatible:
  assumes "compatible m1 m2"
  shows "compatible (m1 f! x) (m2 f! x)"
  apply (cases "x \<in> fdom m1")
  apply (metis assms the_lookup_compatible_and_join)
  apply (metis assms compatible_refl fdomIff fdom_compatible)
  done

lift_definition fmap_join :: "'a f\<rightharpoonup> 'b::cpo \<Rightarrow> 'a f\<rightharpoonup> 'b  \<Rightarrow> 'a f\<rightharpoonup> 'b"
is "\<lambda>m1 m2 x. (if x \<in> fdom m1 then Some ((m1 f! x) \<squnion> (m2 f! x)) else None)"
  by (auto simp add: dom_def)

lemma fdom_fmap_join'[simp]: "fdom (fmap_join m1 m2) = fdom m1"
  apply (subst fdom.rep_eq)
  apply (subst fmap_join.rep_eq)
  apply (auto, metis not_Some_eq)
  done

lemma the_lookup_fmap_join'[simp]: "x \<in> fdom m1 \<Longrightarrow> (fmap_join m1 m2) f! x = (m1 f! x) \<squnion> (m2 f! x)"
  apply (subst lookup.rep_eq)
  apply (subst fmap_join.rep_eq)
  apply simp
  done

lemma compatible_fmapI:
  assumes "\<And> x. \<lbrakk> x \<in> fdom m1 ; x \<in> fdom m2 \<rbrakk> \<Longrightarrow> compatible (m1 f! x) (m2 f! x)"
  assumes "fdom m1 = fdom m2"
  shows "compatible m1 m2"
proof (rule compatibleI)
  show "m1 \<sqsubseteq> fmap_join m1 m2"
    apply (rule fmap_belowI)
    apply simp
    apply simp
    by (metis "HOLCF-Join.join_above1" assms(1) assms(2))
  show "m2 \<sqsubseteq> fmap_join m1 m2"
    apply (rule fmap_belowI)
    apply (simp add: assms(2))
    apply (simp add: assms(2))
    by (metis "HOLCF-Join.join_above2" assms(1) assms(2))
  fix a
  assume "m1 \<sqsubseteq> a"
  assume "m2 \<sqsubseteq> a"
  show "fmap_join m1 m2 \<sqsubseteq> a"
    apply (rule fmap_belowI)
    apply (metis fdom_fmap_join' fmap_below_dom[OF `m1 \<sqsubseteq> a`])
    apply (metis fmap_belowE[OF `m1 \<sqsubseteq> a`] fmap_belowE[OF `m2 \<sqsubseteq> a`] assms(1) assms(2) fdom_fmap_join' join_below the_lookup_fmap_join')
    done
qed

lemma fmap_restr_join:
  assumes [simp]: "finite S"
  assumes [simp]:"compatible m1 m2"
  shows "fmap_restr S (m1 \<squnion> m2) = fmap_restr S m1 \<squnion> fmap_restr S m2"
proof-
  have [simp]: "compatible (fmap_restr S m1) (fmap_restr S m2)"
    by (auto intro!: compatible_fmapI simp add: the_lookup_compatible fdom_compatible[OF assms(2)])
  show ?thesis
    by (rule fmap_eqI, auto)
qed

lemma fmap_upd_join:
  assumes "S = insert x (fdom \<rho>1)"
  and "x \<notin> fdom \<rho>1"
  and "x \<notin> fdom \<rho>2"
  and compat1: "compatible (\<rho>1(x f\<mapsto> y)) (\<rho>2\<^bsub>[S]\<^esub>)"
  shows "(\<rho>1(x f\<mapsto> y)) \<squnion> (\<rho>2\<^bsub>[S]\<^esub>) = (\<rho>1 \<squnion> (\<rho>2\<^bsub>[S - {x}]\<^esub>))(x f\<mapsto> y)" (is "?L = ?R")
proof(rule fmap_eqI)
  have "finite S" using assms(1) by auto

  have *: "\<And> xa . xa \<in> S \<Longrightarrow> xa \<noteq> x \<Longrightarrow> \<rho>2\<^bsub>[S - {x}]\<^esub> f! xa = \<rho>2\<^bsub>[S]\<^esub> f! xa"
    using `finite S` by (case_tac "xa \<in> fdom \<rho>2", auto)

  have compat2: "compatible \<rho>1 (\<rho>2\<^bsub>[S - {x}]\<^esub>)"
    apply (rule compatible_fmapI)
    using compat1
    apply -
    apply (drule_tac x = xa in the_lookup_compatible)
    apply (subst *)
    using assms(1) apply simp
    apply (metis assms(2))

    apply (subst (asm) the_lookup_fmap_upd_other)
    apply (metis `x \<notin> fdom \<rho>1`)
    apply assumption
    using assms(2) assms(1)
    by auto

  show "fdom ?L = fdom ?R"
    using compat1 compat2 by auto
  fix y
  assume "y \<in> fdom ?L"
  hence "y \<in> S" by (metis assms(1) compat1 fdom_join fmap_upd_fdom)
  show "?L f! y = ?R f! y"
  proof(cases "y = x")
    case True
    thus ?thesis
      apply (subst the_lookup_join[OF compat1])
      apply (subst lookup_fmap_expand2[OF `finite S` `y\<in> S`])
      using `x \<notin> fdom \<rho>2` compat2  `y\<in> S`
      by auto
  next
    case False
    thus ?thesis
      apply simp
      apply (subst the_lookup_join[OF compat1], auto)
      apply (subst the_lookup_join[OF compat2])
      apply (case_tac "y \<in> fdom \<rho>2")
      using `finite S`  `y \<in> S`
      by auto
  qed
qed

end


(*
  File: Interval_Tree.thy
  Author: Bohua Zhan
*)

section \<open>Interval tree\<close>

theory Interval_Tree
  imports Lists_Ex Interval
begin

text \<open>
  Functional version of interval tree. This is an augmented data
  structure on top of regular binary search trees (see BST.thy).
  See \cite[Section 14.3]{cormen2009introduction} for a reference.
\<close>

subsection \<open>Definition of an interval tree\<close>

datatype interval_tree =
   Tip
 | Node (lsub: interval_tree) (val: "nat idx_interval") (tmax: nat) (rsub: interval_tree)
where
  "tmax Tip = 0"

setup \<open>add_resolve_prfstep @{thm interval_tree.distinct(1)}\<close>
setup \<open>fold add_rewrite_rule @{thms interval_tree.sel}\<close>
setup \<open>add_forward_prfstep @{thm interval_tree.collapse}\<close>
setup \<open>add_var_induct_rule @{thm interval_tree.induct}\<close>

subsection \<open>Inorder traversal, and set of elements of a tree\<close>

fun in_traverse :: "interval_tree \<Rightarrow> nat idx_interval list" where
  "in_traverse Tip = []"
| "in_traverse (Node l it m r) = in_traverse l @ it # in_traverse r"
setup \<open>fold add_rewrite_rule @{thms in_traverse.simps}\<close>

fun tree_set :: "interval_tree \<Rightarrow> nat idx_interval set" where
  "tree_set Tip = {}"
| "tree_set (Node l it m r) = {it} \<union> tree_set l \<union> tree_set r"
setup \<open>fold add_rewrite_rule @{thms tree_set.simps}\<close>

fun tree_sorted :: "interval_tree \<Rightarrow> bool" where
  "tree_sorted Tip = True"
| "tree_sorted (Node l it m r) = ((\<forall>x\<in>tree_set l. x < it) \<and> (\<forall>x\<in>tree_set r. it < x)
                                   \<and> tree_sorted l \<and> tree_sorted r)"
setup \<open>fold add_rewrite_rule @{thms tree_sorted.simps}\<close>

lemma tree_sorted_lr [forward]:
  "tree_sorted (Node l it m r) \<Longrightarrow> tree_sorted l \<and> tree_sorted r" by auto2

lemma tree_sortedD1 [forward]:
  "tree_sorted (Node l it m r) \<Longrightarrow> x \<in> tree_set l \<Longrightarrow> x < it" by auto2

lemma tree_sortedD2 [forward]:
  "tree_sorted (Node l it m r) \<Longrightarrow> x \<in> tree_set r \<Longrightarrow> x > it" by auto2

lemma inorder_preserve_set [rewrite]:
  "tree_set t = set (in_traverse t)"
@proof @induct t @qed

lemma inorder_sorted [rewrite]:
  "tree_sorted t \<longleftrightarrow> strict_sorted (in_traverse t)"
@proof @induct t @qed

text \<open>Use definition in terms of in\_traverse from now on.\<close>
setup \<open>fold del_prfstep_thm (@{thms tree_set.simps} @ @{thms tree_sorted.simps})\<close>

subsection \<open>Invariant on the maximum\<close>

definition max3 :: "nat idx_interval \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where [rewrite]:
  "max3 it b c = max (high (int it)) (max b c)"

fun tree_max_inv :: "interval_tree \<Rightarrow> bool" where
  "tree_max_inv Tip = True"
| "tree_max_inv (Node l it m r) \<longleftrightarrow> (tree_max_inv l \<and> tree_max_inv r \<and> m = max3 it (tmax l) (tmax r))"
setup \<open>fold add_rewrite_rule @{thms tree_max_inv.simps}\<close>

lemma tree_max_is_max [resolve]:
  "tree_max_inv t \<Longrightarrow> it \<in> tree_set t \<Longrightarrow> high (int it) \<le> tmax t"
@proof @induct t @qed

lemma tmax_exists [backward]:
  "tree_max_inv t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> \<exists>p\<in>tree_set t. high (int p) = tmax t"
@proof @induct t @with
  @subgoal "t = Node l it m r"
    @case "l = Tip" @with @case "r = Tip" @end
    @case "r = Tip"
  @endgoal @end
@qed

text \<open>For insertion\<close>
lemma max3_insert [rewrite]: "max3 it 0 0 = high (int it)" by auto2

setup \<open>del_prfstep_thm @{thm max3_def}\<close>

subsection \<open>Condition on the values\<close>

definition tree_interval_inv :: "interval_tree \<Rightarrow> bool" where [rewrite]:
  "tree_interval_inv t \<longleftrightarrow> (\<forall>p\<in>tree_set t. is_interval (int p))"

definition is_interval_tree :: "interval_tree \<Rightarrow> bool" where [rewrite]:
  "is_interval_tree t \<longleftrightarrow> (tree_sorted t \<and> tree_max_inv t \<and> tree_interval_inv t)"

lemma is_interval_tree_lr [forward]:
  "is_interval_tree (Node l x m r) \<Longrightarrow> is_interval_tree l \<and> is_interval_tree r" by auto2

subsection \<open>Insertion on trees\<close>

fun insert :: "nat idx_interval \<Rightarrow> interval_tree \<Rightarrow> interval_tree" where
  "insert x Tip = Node Tip x (high (int x)) Tip"
| "insert x (Node l y m r) =
    (if x = y then Node l y m r
     else if x < y then
       let l' = insert x l in
           Node l' y (max3 y (tmax l') (tmax r)) r
     else
       let r' = insert x r in
           Node l y (max3 y (tmax l) (tmax r')) r')"
setup \<open>fold add_rewrite_rule @{thms insert.simps}\<close>

lemma tree_insert_in_traverse [rewrite]:
  "tree_sorted t \<Longrightarrow> in_traverse (insert x t) = ordered_insert x (in_traverse t)"
@proof @induct t @qed

lemma tree_insert_max_inv [forward]:
  "tree_max_inv t \<Longrightarrow> tree_max_inv (insert x t)"
@proof @induct t @qed

text \<open>Correctness of insertion.\<close>

theorem tree_insert_on_set [rewrite]:
  "tree_sorted t \<Longrightarrow> tree_set (insert it t) = {it} \<union> tree_set t" by auto2

subsection \<open>Deletion on trees\<close>

fun del_min :: "interval_tree \<Rightarrow> nat idx_interval \<times> interval_tree" where
  "del_min Tip = undefined"
| "del_min (Node lt v m rt) =
   (if lt = Tip then (v, rt) else
    let lt' = snd (del_min lt) in
    (fst (del_min lt), Node lt' v (max3 v (tmax lt') (tmax rt)) rt))"
setup \<open>add_rewrite_rule @{thm del_min.simps(2)}\<close>
setup \<open>register_wellform_data ("del_min t", ["t \<noteq> Tip"])\<close>

lemma delete_min_del_hd:
  "t \<noteq> Tip \<Longrightarrow> fst (del_min t) # in_traverse (snd (del_min t)) = in_traverse t"
@proof @induct t @qed
setup \<open>add_forward_prfstep_cond @{thm delete_min_del_hd} [with_term "in_traverse (snd (del_min ?t))"]\<close>

lemma delete_min_max_inv [forward_arg]:
  "tree_max_inv t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> tree_max_inv (snd (del_min t))"
@proof @induct t @qed

lemma delete_min_on_set:
  "t \<noteq> Tip \<Longrightarrow> {fst (del_min t)} \<union> tree_set (snd (del_min t)) = tree_set t" by auto2
setup \<open>add_forward_prfstep_cond @{thm delete_min_on_set} [with_term "tree_set (snd (del_min ?t))"]\<close>

lemma delete_min_interval_inv [forward_arg]:
  "tree_interval_inv t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> tree_interval_inv (snd (del_min t))" by auto2

lemma delete_min_all_inv [forward_arg]:
  "is_interval_tree t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> is_interval_tree (snd (del_min t))" by auto2

fun delete_elt_tree :: "interval_tree \<Rightarrow> interval_tree" where
  "delete_elt_tree Tip = undefined"
| "delete_elt_tree (Node lt x m rt) =
    (if lt = Tip then rt else if rt = Tip then lt else
     let x' = fst (del_min rt);
         rt' = snd (del_min rt);
         m' = max3 x' (tmax lt) (tmax rt') in
       Node lt (fst (del_min rt)) m' rt')"
setup \<open>add_rewrite_rule @{thm delete_elt_tree.simps(2)}\<close>

lemma delete_elt_in_traverse [rewrite]:
  "in_traverse (delete_elt_tree (Node lt x m rt)) = in_traverse lt @ in_traverse rt" by auto2

lemma delete_elt_max_inv [forward_arg]:
  "tree_max_inv t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> tree_max_inv (delete_elt_tree t)" by auto2

lemma delete_elt_on_set [rewrite]:
  "t \<noteq> Tip \<Longrightarrow> tree_set (delete_elt_tree (Node lt x m rt)) = tree_set lt \<union> tree_set rt" by auto2

lemma delete_elt_interval_inv [forward_arg]:
  "tree_interval_inv t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> tree_interval_inv (delete_elt_tree t)" by auto2

lemma delete_elt_all_inv [forward_arg]:
  "is_interval_tree t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> is_interval_tree (delete_elt_tree t)" by auto2

fun delete :: "nat idx_interval \<Rightarrow> interval_tree \<Rightarrow> interval_tree" where
  "delete x Tip = Tip"
| "delete x (Node l y m r) =
    (if x = y then delete_elt_tree (Node l y m r)
     else if x < y then
       let l' = delete x l;
           m' = max3 y (tmax l') (tmax r) in Node l' y m' r
     else
       let r' = delete x r;
           m' = max3 y (tmax l) (tmax r') in Node l y m' r')"
setup \<open>fold add_rewrite_rule @{thms delete.simps}\<close>

lemma tree_delete_in_traverse [rewrite]:
  "tree_sorted t \<Longrightarrow> in_traverse (delete x t) = remove_elt_list x (in_traverse t)"
@proof @induct t @qed

lemma tree_delete_max_inv [forward]:
  "tree_max_inv t \<Longrightarrow> tree_max_inv (delete x t)"
@proof @induct t @qed

text \<open>Correctness of deletion.\<close>
theorem tree_delete_all_inv [forward]:
  "is_interval_tree t \<Longrightarrow> is_interval_tree (delete x t)"
@proof @have "tree_set (delete x t) \<subseteq> tree_set t" @qed

theorem tree_delete_on_set [rewrite]:
  "tree_sorted t \<Longrightarrow> tree_set (delete x t) = tree_set t - {x}" by auto2

subsection \<open>Search on interval trees\<close>

fun search :: "interval_tree \<Rightarrow> nat interval \<Rightarrow> bool" where
  "search Tip x = False"
| "search (Node l y m r) x =
   (if is_overlap (int y) x then True
    else if l \<noteq> Tip \<and> tmax l \<ge> low x then search l x
    else search r x)"
setup \<open>fold add_rewrite_rule @{thms search.simps}\<close>

text \<open>Correctness of search\<close>
theorem search_correct [rewrite]:
  "is_interval_tree t \<Longrightarrow> is_interval x \<Longrightarrow> search t x \<longleftrightarrow> has_overlap (tree_set t) x"
@proof
  @induct t @with
    @subgoal "t = Node l y m r"
      @let "t = Node l y m r"
      @case "is_overlap (int y) x"
      @case "l \<noteq> Tip \<and> tmax l \<ge> low x" @with
        @obtain "p\<in>tree_set l" where "high (int p) = tmax l"
        @case "is_overlap (int p) x"
      @end
      @case "l = Tip"
    @endgoal
  @end
@qed

end


(* Author: Tobias Nipkow, TU Muenchen *)

section {* Sum and product over lists *}

theory Groups_List
imports List
begin

no_notation times (infixl "*" 70)
no_notation Groups.one ("1")

locale monoid_list = monoid
begin

definition F :: "'a list \<Rightarrow> 'a"
where
  eq_foldr [code]: "F xs = foldr f xs 1"

lemma Nil [simp]:
  "F [] = 1"
  by (simp add: eq_foldr)

lemma Cons [simp]:
  "F (x # xs) = x * F xs"
  by (simp add: eq_foldr)

lemma append [simp]:
  "F (xs @ ys) = F xs * F ys"
  by (induct xs) (simp_all add: assoc)

end

locale comm_monoid_list = comm_monoid + monoid_list
begin

lemma rev [simp]:
  "F (rev xs) = F xs"
  by (simp add: eq_foldr foldr_fold  fold_rev fun_eq_iff assoc left_commute)

end

locale comm_monoid_list_set = list: comm_monoid_list + set: comm_monoid_set
begin

lemma distinct_set_conv_list:
  "distinct xs \<Longrightarrow> set.F g (set xs) = list.F (map g xs)"
  by (induct xs) simp_all

lemma set_conv_list [code]:
  "set.F g (set xs) = list.F (map g (remdups xs))"
  by (simp add: distinct_set_conv_list [symmetric])

end

notation times (infixl "*" 70)
notation Groups.one ("1")

subsection {* List summation *}

context monoid_add
begin

definition listsum :: "'a list \<Rightarrow> 'a"
where
  "listsum  = monoid_list.F plus 0"

sublocale listsum!: monoid_list plus 0
where
 "monoid_list.F plus 0 = listsum"
proof -
  show "monoid_list plus 0" ..
  then interpret listsum!: monoid_list plus 0 .
  from listsum_def show "monoid_list.F plus 0 = listsum" by rule
qed

end

context comm_monoid_add
begin

sublocale listsum!: comm_monoid_list plus 0
where
  "monoid_list.F plus 0 = listsum"
proof -
  show "comm_monoid_list plus 0" ..
  then interpret listsum!: comm_monoid_list plus 0 .
  from listsum_def show "monoid_list.F plus 0 = listsum" by rule
qed

sublocale setsum!: comm_monoid_list_set plus 0
where
  "monoid_list.F plus 0 = listsum"
  and "comm_monoid_set.F plus 0 = setsum"
proof -
  show "comm_monoid_list_set plus 0" ..
  then interpret setsum!: comm_monoid_list_set plus 0 .
  from listsum_def show "monoid_list.F plus 0 = listsum" by rule
  from setsum_def show "comm_monoid_set.F plus 0 = setsum" by rule
qed

end

text {* Some syntactic sugar for summing a function over a list: *}

syntax
  "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3SUM _<-_. _)" [0, 51, 10] 10)
syntax (xsymbols)
  "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)
syntax (HTML output)
  "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)

translations -- {* Beware of argument permutation! *}
  "SUM x<-xs. b" == "CONST listsum (CONST map (%x. b) xs)"
  "\<Sum>x\<leftarrow>xs. b" == "CONST listsum (CONST map (%x. b) xs)"

text {* TODO duplicates *}
lemmas listsum_simps = listsum.Nil listsum.Cons
lemmas listsum_append = listsum.append
lemmas listsum_rev = listsum.rev

lemma (in monoid_add) fold_plus_listsum_rev:
  "fold plus xs = plus (listsum (rev xs))"
proof
  fix x
  have "fold plus xs x = listsum (rev xs @ [x])"
    by (simp add: foldr_conv_fold listsum.eq_foldr)
  also have "\<dots> = listsum (rev xs) + x"
    by simp
  finally show "fold plus xs x = listsum (rev xs) + x"
    .
qed

lemma (in comm_monoid_add) listsum_map_remove1:
  "x \<in> set xs \<Longrightarrow> listsum (map f xs) = f x + listsum (map f (remove1 x xs))"
  by (induct xs) (auto simp add: ac_simps)

lemma (in monoid_add) size_list_conv_listsum:
  "size_list f xs = listsum (map f xs) + size xs"
  by (induct xs) auto

lemma (in monoid_add) length_concat:
  "length (concat xss) = listsum (map length xss)"
  by (induct xss) simp_all

lemma (in monoid_add) length_product_lists:
  "length (product_lists xss) = foldr op * (map length xss) 1"
proof (induct xss)
  case (Cons xs xss) then show ?case by (induct xs) (auto simp: length_concat o_def)
qed simp

lemma (in monoid_add) listsum_map_filter:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> f x = 0"
  shows "listsum (map f (filter P xs)) = listsum (map f xs)"
  using assms by (induct xs) auto

lemma (in comm_monoid_add) distinct_listsum_conv_Setsum:
  "distinct xs \<Longrightarrow> listsum xs = Setsum (set xs)"
  by (induct xs) simp_all

lemma listsum_upt[simp]:
  "m \<le> n \<Longrightarrow> listsum [m..<n] = \<Sum> {m..<n}"
by(simp add: distinct_listsum_conv_Setsum)

lemma listsum_eq_0_nat_iff_nat [simp]:
  "listsum ns = (0::nat) \<longleftrightarrow> (\<forall>n \<in> set ns. n = 0)"
  by (induct ns) simp_all

lemma member_le_listsum_nat:
  "(n :: nat) \<in> set ns \<Longrightarrow> n \<le> listsum ns"
  by (induct ns) auto

lemma elem_le_listsum_nat:
  "k < size ns \<Longrightarrow> ns ! k \<le> listsum (ns::nat list)"
  by (rule member_le_listsum_nat) simp

lemma listsum_update_nat:
  "k < size ns \<Longrightarrow> listsum (ns[k := (n::nat)]) = listsum ns + n - ns ! k"
apply(induct ns arbitrary:k)
 apply (auto split:nat.split)
apply(drule elem_le_listsum_nat)
apply arith
done

lemma (in monoid_add) listsum_triv:
  "(\<Sum>x\<leftarrow>xs. r) = of_nat (length xs) * r"
  by (induct xs) (simp_all add: distrib_right)

lemma (in monoid_add) listsum_0 [simp]:
  "(\<Sum>x\<leftarrow>xs. 0) = 0"
  by (induct xs) (simp_all add: distrib_right)

text{* For non-Abelian groups @{text xs} needs to be reversed on one side: *}
lemma (in ab_group_add) uminus_listsum_map:
  "- listsum (map f xs) = listsum (map (uminus \<circ> f) xs)"
  by (induct xs) simp_all

lemma (in comm_monoid_add) listsum_addf:
  "(\<Sum>x\<leftarrow>xs. f x + g x) = listsum (map f xs) + listsum (map g xs)"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in ab_group_add) listsum_subtractf:
  "(\<Sum>x\<leftarrow>xs. f x - g x) = listsum (map f xs) - listsum (map g xs)"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in semiring_0) listsum_const_mult:
  "(\<Sum>x\<leftarrow>xs. c * f x) = c * (\<Sum>x\<leftarrow>xs. f x)"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in semiring_0) listsum_mult_const:
  "(\<Sum>x\<leftarrow>xs. f x * c) = (\<Sum>x\<leftarrow>xs. f x) * c"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in ordered_ab_group_add_abs) listsum_abs:
  "\<bar>listsum xs\<bar> \<le> listsum (map abs xs)"
  by (induct xs) (simp_all add: order_trans [OF abs_triangle_ineq])

lemma listsum_mono:
  fixes f g :: "'a \<Rightarrow> 'b::{monoid_add, ordered_ab_semigroup_add}"
  shows "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> (\<Sum>x\<leftarrow>xs. f x) \<le> (\<Sum>x\<leftarrow>xs. g x)"
  by (induct xs) (simp, simp add: add_mono)

lemma (in monoid_add) listsum_distinct_conv_setsum_set:
  "distinct xs \<Longrightarrow> listsum (map f xs) = setsum f (set xs)"
  by (induct xs) simp_all

lemma (in monoid_add) interv_listsum_conv_setsum_set_nat:
  "listsum (map f [m..<n]) = setsum f (set [m..<n])"
  by (simp add: listsum_distinct_conv_setsum_set)

lemma (in monoid_add) interv_listsum_conv_setsum_set_int:
  "listsum (map f [k..l]) = setsum f (set [k..l])"
  by (simp add: listsum_distinct_conv_setsum_set)

text {* General equivalence between @{const listsum} and @{const setsum} *}
lemma (in monoid_add) listsum_setsum_nth:
  "listsum xs = (\<Sum> i = 0 ..< length xs. xs ! i)"
  using interv_listsum_conv_setsum_set_nat [of "op ! xs" 0 "length xs"] by (simp add: map_nth)

subsection {* Further facts about @{const List.n_lists} *}

lemma length_n_lists: "length (List.n_lists n xs) = length xs ^ n"
  by (induct n) (auto simp add: comp_def length_concat listsum_triv)

lemma distinct_n_lists:
  assumes "distinct xs"
  shows "distinct (List.n_lists n xs)"
proof (rule card_distinct)
  from assms have card_length: "card (set xs) = length xs" by (rule distinct_card)
  have "card (set (List.n_lists n xs)) = card (set xs) ^ n"
  proof (induct n)
    case 0 then show ?case by simp
  next
    case (Suc n)
    moreover have "card (\<Union>ys\<in>set (List.n_lists n xs). (\<lambda>y. y # ys) ` set xs)
      = (\<Sum>ys\<in>set (List.n_lists n xs). card ((\<lambda>y. y # ys) ` set xs))"
      by (rule card_UN_disjoint) auto
    moreover have "\<And>ys. card ((\<lambda>y. y # ys) ` set xs) = card (set xs)"
      by (rule card_image) (simp add: inj_on_def)
    ultimately show ?case by auto
  qed
  also have "\<dots> = length xs ^ n" by (simp add: card_length)
  finally show "card (set (List.n_lists n xs)) = length (List.n_lists n xs)"
    by (simp add: length_n_lists)
qed

subsection {* Tools setup *}

lemmas setsum_code = setsum.set_conv_list

lemma setsum_set_upto_conv_listsum_int [code_unfold]:
  "setsum f (set [i..j::int]) = listsum (map f [i..j])"
  by (simp add: interv_listsum_conv_setsum_set_int)

lemma setsum_set_upt_conv_listsum_nat [code_unfold]:
  "setsum f (set [m..<n]) = listsum (map f [m..<n])"
  by (simp add: interv_listsum_conv_setsum_set_nat)

context
begin

interpretation lifting_syntax .

lemma listsum_transfer[transfer_rule]:
  assumes [transfer_rule]: "A 0 0"
  assumes [transfer_rule]: "(A ===> A ===> A) op + op +"
  shows "(list_all2 A ===> A) listsum listsum"
  unfolding listsum.eq_foldr [abs_def]
  by transfer_prover

end

subsection {* List product *}

context monoid_mult
begin

definition listprod :: "'a list \<Rightarrow> 'a"
where
  "listprod  = monoid_list.F times 1"

sublocale listprod!: monoid_list times 1
where
  "monoid_list.F times 1 = listprod"
proof -
  show "monoid_list times 1" ..
  then interpret listprod!: monoid_list times 1 .
  from listprod_def show "monoid_list.F times 1 = listprod" by rule
qed

end

context comm_monoid_mult
begin

sublocale listprod!: comm_monoid_list times 1
where
  "monoid_list.F times 1 = listprod"
proof -
  show "comm_monoid_list times 1" ..
  then interpret listprod!: comm_monoid_list times 1 .
  from listprod_def show "monoid_list.F times 1 = listprod" by rule
qed

sublocale setprod!: comm_monoid_list_set times 1
where
  "monoid_list.F times 1 = listprod"
  and "comm_monoid_set.F times 1 = setprod"
proof -
  show "comm_monoid_list_set times 1" ..
  then interpret setprod!: comm_monoid_list_set times 1 .
  from listprod_def show "monoid_list.F times 1 = listprod" by rule
  from setprod_def show "comm_monoid_set.F times 1 = setprod" by rule
qed

end

text {* Some syntactic sugar: *}

syntax
  "_listprod" :: "pttrn => 'a list => 'b => 'b"    ("(3PROD _<-_. _)" [0, 51, 10] 10)
syntax (xsymbols)
  "_listprod" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Prod>_\<leftarrow>_. _)" [0, 51, 10] 10)
syntax (HTML output)
  "_listprod" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Prod>_\<leftarrow>_. _)" [0, 51, 10] 10)

translations -- {* Beware of argument permutation! *}
  "PROD x<-xs. b" == "CONST listprod (CONST map (%x. b) xs)"
  "\<Prod>x\<leftarrow>xs. b" == "CONST listprod (CONST map (%x. b) xs)"

end


section \<open>Cardinalities of Interpolation Polynomials\<close>

text \<open>This section establishes the cardinalities of the set of polynomials with a degree bound
interpolating a given set of points.\<close>

theory Interpolation_Polynomial_Cardinalities
  imports Bounded_Degree_Polynomials Lagrange_Interpolation
begin

lemma (in ring) poly_add_coeff:
  assumes "x \<in> carrier (poly_ring R)"
  assumes "y \<in> carrier (poly_ring R)"
  shows "coeff (x \<oplus>\<^bsub>poly_ring R\<^esub> y) k = coeff x k \<oplus> coeff y k"
  by (metis assms univ_poly_carrier polynomial_incl univ_poly_add poly_add_coeff)

lemma (in domain) poly_neg_coeff:
  assumes "x \<in> carrier (poly_ring R)"
  shows "coeff (\<ominus>\<^bsub>poly_ring R\<^esub> x) k = \<ominus>coeff x k"
proof -
  interpret x:cring "poly_ring R"
    using assms cring_def carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto

  have a:"\<zero>\<^bsub>poly_ring R\<^esub> = x \<ominus>\<^bsub>poly_ring R\<^esub> x"
    by (metis x.r_right_minus_eq assms(1))

  have "\<zero> = coeff (\<zero>\<^bsub>poly_ring R\<^esub>) k" by (simp add:univ_poly_zero)
  also have "... = coeff x k \<oplus> coeff (\<ominus>\<^bsub>poly_ring R\<^esub> x) k" using a assms
    by (simp add:a_minus_def poly_add_coeff)
  finally have "\<zero> = coeff x k \<oplus> coeff (\<ominus>\<^bsub>poly_ring R\<^esub> x) k" by simp
  thus ?thesis
    by (metis local.minus_minus x.a_inv_closed sum_zero_eq_neg coeff_in_carrier assms)
qed

lemma (in domain) poly_substract_coeff:
  assumes "x \<in> carrier (poly_ring R)"
  assumes "y \<in> carrier (poly_ring R)"
  shows "coeff (x \<ominus>\<^bsub>poly_ring R\<^esub> y) k = coeff x k \<ominus> coeff y k"
proof -
  interpret x:cring "poly_ring R"
    using assms cring_def carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
  show ?thesis
    using assms by (simp add:a_minus_def poly_add_coeff poly_neg_coeff)
qed

text \<open>A polynomial with more zeros than its degree is the zero polynomial.\<close>

lemma (in field) max_roots:
  assumes "p \<in> carrier (poly_ring R)"
  assumes "K \<subseteq> carrier R"
  assumes "finite K"
  assumes "degree p < card K"
  assumes "\<And>x. x \<in> K \<Longrightarrow> eval p x = \<zero>"
  shows "p = \<zero>\<^bsub>poly_ring R\<^esub>"
proof (rule ccontr)
  assume "p \<noteq> \<zero>\<^bsub>poly_ring R\<^esub>"
  hence a:"p \<noteq> []" by (simp add: univ_poly_zero)
  have "\<And>x. count (mset_set K) x \<le> count (roots p) x"
  proof -
    fix x
    show "count (mset_set K) x \<le> count (roots p) x"
    proof (cases "x \<in> K")
      case True
      hence "is_root p x"
        by (meson a assms(2,5) is_ring is_root_def subsetD)
      hence "x \<in> set_mset (roots p)"
        using assms(1) roots_mem_iff_is_root field_def by force
      hence "1 \<le> count (roots p) x" by simp
      moreover have "count (mset_set K) x = 1" using True assms(3) by simp
      ultimately show ?thesis by presburger
    next
      case False
      hence "count (mset_set K) x = 0" by simp
      then show ?thesis by presburger
    qed
  qed
  hence "mset_set K \<subseteq># roots p"
    by (simp add: subseteq_mset_def)
  hence "card K \<le> size (roots p)"
    by (metis size_mset_mono size_mset_set)
  moreover have "size (roots p) \<le> degree p"
    using a size_roots_le_degree assms by auto
  ultimately show "False" using assms(4)
    by (meson leD less_le_trans)
qed

definition (in ring) split_poly
  where "split_poly K p = (restrict (eval p) K, \<lambda>k. coeff p (k+card K))"

text \<open>To establish the count of the number of polynomials of degree less than
$n$ interpolating a function $f$ on $K$ where $\lvert K \rvert \leq n$, the function
@{term "split_poly K"} establishes a bijection between the polynomials of degree less than
$n$ and the values of the polynomials on $K$ in combination with the coefficients of order
$\lvert K \rvert$ and greater.

For the injectivity: Note that the difference of two polynomials whose coefficients of order
$\lvert K \rvert$ and larger agree must have a degree less than $\lvert K \rvert$ and because
their values agree on $k$ points, it must have $\lvert K \rvert$ zeros and hence is the zero
polynomial.

For the surjectivty: Let $p$ be a polynomial whose coefficients larger than $\lvert K \rvert$ are
chosen, and all other coefficients be $0$. Now it is possible to find a polynomial $q$ interpolating
$f - p$ on $K$ using Lagrange interpolation. Then $p + q$ will interpolate $f$ on $K$ and because
the degree of $q$ is less than $\lvert K \rvert$ its coefficients of order $\lvert K \rvert$ will
be the same as those of $p$.

A tempting question is whether it would be easier to instead establish a bijection between the
polynomials of degree less than $n$ and its values on $K \cup K'$ where $K'$ are arbitrarily chosen
$n-\lvert K \rvert$ points in the field. This approach is indeed easier, however, it fails for
the case where the size of the field is less than $n$.\<close>

lemma (in field) split_poly_inj:
  assumes "finite K"
  assumes "K \<subseteq> carrier R"
  shows "inj_on (split_poly K) (carrier (poly_ring R))"
proof
  fix x
  fix y
  assume a1:"x \<in> carrier (poly_ring R)"
  assume a2:"y \<in> carrier (poly_ring R)"
  assume a3:"split_poly K x = split_poly K y"

  interpret x:cring "poly_ring R"
    using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto

  have x_y_carrier: "x \<ominus>\<^bsub>poly_ring R\<^esub> y \<in> carrier (poly_ring R)" using a1 a2 by simp
  have "\<And>k. coeff x (k+card K) = coeff y (k+card K)"
    using a3 by (simp add:split_poly_def, meson)
  hence "\<And>k. coeff (x \<ominus>\<^bsub>poly_ring R\<^esub> y) (k+card K) = \<zero>"
    using coeff_in_carrier a1 a2 by (simp add:poly_substract_coeff)
  hence "degree (x \<ominus>\<^bsub>poly_ring R\<^esub> y) < card K \<or> (x \<ominus>\<^bsub>poly_ring R\<^esub> y) = \<zero>\<^bsub>poly_ring R\<^esub>"
    by (metis poly_degree_bound_from_coeff add.commute le_iff_add x_y_carrier)
  moreover have "\<And>k. k \<in> K \<Longrightarrow> eval x k = eval y k"
    using a3 by (simp add:split_poly_def restrict_def, meson)
  hence "\<And>k. k \<in> K \<Longrightarrow> eval x k \<ominus> eval y k = \<zero>"
    by (metis eval_in_carrier univ_poly_carrier polynomial_incl a1 assms(2) in_mono r_right_minus_eq)
  hence "\<And>k. k \<in> K \<Longrightarrow> eval (x \<ominus>\<^bsub>poly_ring R\<^esub> y) k = \<zero>"
    using a1 a2 subsetD[OF assms(2)] carrier_is_subring
    by (simp add: ring_hom_cring.hom_sub[OF eval_cring_hom])
  ultimately have "x \<ominus>\<^bsub>poly_ring R\<^esub> y = \<zero>\<^bsub>poly_ring R\<^esub>"
    using max_roots x_y_carrier assms by blast
  then show "x = y"
    using x.r_right_minus_eq[OF a1 a2] by simp
qed

lemma (in field) split_poly_image:
  assumes "finite K"
  assumes "K \<subseteq> carrier R"
  shows "split_poly K ` carrier (poly_ring R) \<supseteq>
        (K \<rightarrow>\<^sub>E carrier R) \<times> {f. range f \<subseteq> carrier R \<and> (\<exists>n. \<forall>k \<ge> n. f k = \<zero>\<^bsub>R\<^esub>)}"
proof (rule subsetI)
  fix x
  assume a:"x \<in> (K \<rightarrow>\<^sub>E carrier R) \<times> {f. range f \<subseteq> carrier R \<and> (\<exists>(n::nat). \<forall>k \<ge> n. f k = \<zero>)}"
  have a1: "fst x \<in> (K \<rightarrow>\<^sub>E carrier R)"
    using a by (simp add:mem_Times_iff)
  obtain n where a2: "snd x \<in> {f. range f \<subseteq> carrier R \<and> (\<forall>k \<ge> n. f k = \<zero>)}"
    using a mem_Times_iff by force
  have a3: "\<And>y. snd x y \<in> carrier R" using a2 by blast

  define w where "w = build_poly (\<lambda>i. if i \<ge> card K then (snd x (i - card K)) else \<zero>) (card K + n)"

  have w_carr: "w \<in> carrier (poly_ring R)"
    unfolding w_def by (rule build_poly_poly, simp add:a3)

  have w_eval_range: "\<And>x. x \<in> carrier R \<Longrightarrow> local.eval w x \<in> carrier R"
  proof -
    fix x
    assume w_eval_range_1:"x \<in> carrier R"
    interpret x:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p x)"
      using eval_cring_hom[OF carrier_is_subring] assms w_eval_range_1 by blast
    show "eval w x \<in> carrier R"
      by (rule x.hom_closed[OF w_carr])
  qed

  interpret r:cring "poly_ring R"
    using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto

  define y where "y = interpolate K (\<lambda>k. fst x k \<ominus> eval w k)"
  define r where "r = y \<oplus>\<^bsub>poly_ring R\<^esub> w"

  have x_minus_w_in_carrier: "\<And>z. z \<in> K \<Longrightarrow> fst x z \<ominus> eval w z \<in> carrier R"
    using a1 PiE_def Pi_def minus_closed subsetD[OF assms(2)] w_eval_range by auto

  have y_poly: "y \<in> carrier (poly_ring R)" unfolding y_def
    using x_minus_w_in_carrier interpolate_poly[OF assms(1) assms(2)] image_subsetI by force

  have y_degree: "degree y \<le> card K - 1"
    unfolding y_def
    using x_minus_w_in_carrier interpolate_degree[OF assms(1) assms(2)] image_subsetI by force

  have y_len: "length y \<le> card K"
  proof (cases "K={}")
    case True
    then show ?thesis
      by (simp add:y_def interpolate_def univ_poly_zero)
  next
    case False
    then show ?thesis
      by (metis y_degree Suc_le_D assms(1) card_gt_0_iff diff_Suc_1 not_less_eq_eq order.strict_iff_not)
  qed

  have r_poly: "r \<in> carrier (poly_ring R)"
    using r_def y_poly w_carr by simp

  have coeff_r: "\<And>k. coeff r (k + card K) = snd x k"
  proof -
    fix k :: nat
    have y_len': "length y \<le> k + card K" using y_len trans_le_add2 by blast
    have "coeff r (k + card K) = coeff y (k + card K) \<oplus> coeff w (k+card K)"
      by (simp add:r_def  poly_add_coeff[OF y_poly w_carr])
    also have "... = \<zero> \<oplus> coeff w (k+card K)"
      using coeff_length[OF y_len'] by simp
    also have "... = coeff w (k+card K)"
      using coeff_in_carrier[OF w_carr] by simp
    also have "... = snd x k"
      using a2 by (simp add:w_def build_poly_coeff not_less)
    finally show "coeff r (k + card K) = snd x k" by simp
  qed

  have eval_r: "\<And>k. k \<in> K \<Longrightarrow> eval r k = fst x k"
  proof -
    fix k
    assume b:"k \<in> K"
    interpret s:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p k)"
      using eval_cring_hom[OF carrier_is_subring] assms b by blast

    have k_carr: "k \<in> carrier R" using assms(2) b by blast
    have fst_x_k_carr: "\<And>k. k \<in> K \<Longrightarrow> fst x k \<in> carrier R"
      using  a1 PiE_def Pi_def by blast
    have "eval r k = eval y k \<oplus> eval w k"
      using y_poly w_carr by (simp add:r_def)
    also have "... = fst x k \<ominus> local.eval w k \<oplus> local.eval w k"
      using assms b x_minus_w_in_carrier
      by (simp add:y_def interpolate_eval[OF _ _ image_subsetI])
    also have "... = fst x k \<oplus> (\<ominus> local.eval w k \<oplus> local.eval w k)"
      using fst_x_k_carr[OF b] w_eval_range[OF k_carr]
      by (simp add:a_minus_def a_assoc)
    also have "... = fst x k"
      using fst_x_k_carr[OF b] w_eval_range[OF k_carr]
      by (simp add:a_comm r_neg)
    finally show "eval r k = fst x k" by simp
  qed

  have "r \<in> (carrier (poly_ring R))"
    by (metis r_poly)
  moreover have "\<And>y. (if y \<in> K then eval r y else undefined) = fst x y"
    using a1 eval_r PiE_E by auto
  hence "split_poly K r = x"
    by (simp add:split_poly_def prod_eq_iff coeff_r restrict_def)
  ultimately show "x \<in> split_poly K ` (carrier (poly_ring R))"
    by blast
qed

text \<open>This is like @{thm [source] card_vimage_inj} but supports @{term "inj_on"} instead.\<close>
lemma card_vimage_inj_on:
  assumes "inj_on f B"
  assumes "A \<subseteq> f ` B"
  shows "card (f -` A \<inter> B) = card A"
proof -
  have "A = f ` (f -` A \<inter> B)" using assms(2) by auto
  thus ?thesis using assms card_image
    by (metis inf_le2 inj_on_subset)
qed

lemma inv_subsetI:
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<in> B \<Longrightarrow> x \<in> C"
  shows "f -` B \<inter> A \<subseteq> C"
  using assms by force

text \<open>The following establishes the main result of this section: There are $\lvert F \rvert^{n-k}$
polynomials of degree less than $n$ interpolating $k \leq n$ points.\<close>

lemma restrict_eq_imp:
  assumes "restrict f A = restrict g A"
  assumes "x \<in> A"
  shows "f x = g x"
  by (metis restrict_def assms)

theorem (in field) interpolating_polynomials_card:
  assumes "finite K"
  assumes "K \<subseteq> carrier R"
  assumes "f ` K \<subseteq> carrier R"
  shows "card {\<omega> \<in> bounded_degree_polynomials R (card K + n). (\<forall>k \<in> K. eval \<omega> k = f k)} = card (carrier R)^n"
    (is "card ?A = ?B")
proof -
  define z where "z = restrict f K"
  define M where "M = {f. range f \<subseteq> carrier R \<and> (\<forall>k \<ge> n. f k = \<zero>)}"

  hence inj_on_bounded: "inj_on (split_poly K) (carrier (poly_ring R))"
    using split_poly_inj[OF assms(1) assms(2)] by blast

  have "?A \<subseteq> split_poly K -` ({z} \<times> M)"
    unfolding split_poly_def z_def M_def bounded_degree_polynomials_length
    by (rule subsetI, auto intro!:coeff_in_carrier coeff_length)
  moreover have "?A \<subseteq> carrier (poly_ring R)"
    unfolding bounded_degree_polynomials_length by blast
  ultimately have a:"?A \<subseteq> split_poly K -` ({z} \<times> M) \<inter> carrier (poly_ring R)"
    by blast

  have "\<And>x k . (\<lambda>k. coeff x (k + card K)) \<in> M \<Longrightarrow> k \<ge> n + card K \<Longrightarrow> coeff x k = \<zero>"
    by (simp add:M_def, metis Nat.le_diff_conv2 Nat.le_imp_diff_is_add add_leD2)
  hence "split_poly K -` ({z} \<times> M) \<inter> carrier (poly_ring R) \<subseteq> bounded_degree_polynomials R (card K + n)"
    unfolding split_poly_def z_def using poly_degree_bound_from_coeff_1 inv_subsetI by force
  moreover have "\<And>\<omega> k. \<omega> \<in> split_poly K -` ({z} \<times> M) \<inter> carrier (poly_ring R) \<Longrightarrow> k \<in> K \<Longrightarrow> eval \<omega> k = f k"
    unfolding split_poly_def z_def using restrict_eq_imp by fastforce
  ultimately have b:"split_poly K -` ({z} \<times> M) \<inter> carrier (poly_ring R) \<subseteq> ?A"
    by blast

  have "z \<in> K \<rightarrow>\<^sub>E carrier R"
    unfolding z_def using assms(3) by auto
  moreover have "M \<subseteq> {f. range f \<subseteq> carrier R \<and> (\<exists>n. (\<forall>k \<ge> n. f k = \<zero>))}"
    unfolding M_def by blast
  ultimately have c:"{z} \<times> M \<subseteq> split_poly K ` carrier (poly_ring R)"
    using split_poly_image[OF assms(1) assms(2)] by fast

  have "card ?A = card (split_poly K -` ({z} \<times> M) \<inter> carrier (poly_ring R))"
    using order_antisym[OF a b] by simp
  also have "... = card ({z} \<times> M)"
    using card_vimage_inj_on[OF inj_on_bounded] c by blast
  also have "... = card (carrier R)^n"
    by (simp add:card_cartesian_product M_def card_mostly_constant_maps)
  finally show ?thesis by simp
qed

text \<open>A corollary is the classic result~\<^cite>\<open>\<open>Theorem 7.15\<close> in "shoup2009computational"\<close> that there is
exactly one polynomial of degree less than $n$ interpolating $n$ points:\<close>

corollary (in field) interpolating_polynomial_one:
  assumes "finite K"
  assumes "K \<subseteq> carrier R"
  assumes "f ` K \<subseteq> carrier R"
  shows "card {\<omega> \<in> bounded_degree_polynomials R (card K). (\<forall>k \<in> K. eval \<omega> k = f k)} = 1"
  using interpolating_polynomials_card[OF assms(1) assms(2) assms(3), where n="0"]
  by simp

text \<open>In the case of fields with infinite carriers, it is possible to conclude that there are
infinitely many polynomials of degree less than $n$ interpolating $k < n$ points.\<close>

corollary (in field) interpolating_polynomial_inf:
  assumes "infinite (carrier R)"
  assumes "finite K" "K \<subseteq> carrier R" "f ` K \<subseteq> carrier R"
  assumes "n > 0"
  shows "infinite {\<omega> \<in> bounded_degree_polynomials R (card K + n). (\<forall>k \<in> K. eval \<omega> k = f k)}"
    (is "infinite ?A")
proof -
  have "{} \<subset> {\<omega> \<in> bounded_degree_polynomials R (card K). (\<forall>k \<in> K. eval \<omega> k = f k)}"
    using interpolating_polynomial_one[OF assms(2) assms(3) assms(4)] by fastforce
  also have "... \<subseteq> ?A"
    unfolding bounded_degree_polynomials_def by auto
  finally have a:"?A \<noteq> {}" by auto

  have "card ?A = card (carrier R)^n"
    using interpolating_polynomials_card[OF assms(2) assms(3) assms(4), where n="n"] by simp
  also have "... = 0"
    using assms(1) assms(5) by simp
  finally have b:"card ?A = 0" by simp

  show ?thesis using a b card_0_eq by blast
qed

text \<open>The following is an additional independent result: The evaluation homomorphism is injective
for degree one polynomials.\<close>

lemma  (in field) eval_inj_if_degree_1:
  assumes "p \<in> carrier (poly_ring R)" "degree p = 1"
  shows "inj_on (eval p) (carrier R)"
proof -
  obtain u v where p_def: "p = [u,v]" using assms
    by (cases p, cases "(tl p)", auto)

  have "u \<in> carrier R - {\<zero>}" using p_def assms by blast
  moreover have "v \<in> carrier R" using p_def assms by blast
  ultimately show ?thesis by (simp add:p_def field_Units inj_on_def)
qed

end


(* Author: Tobias Nipkow *)

section \<open>Alternative Deletion in Red-Black Trees\<close>

theory RBT_Set2
imports RBT_Set
begin

text \<open>This is a conceptually simpler version of deletion. Instead of the tricky \<open>join\<close>
function this version follows the standard approach of replacing the deleted element
(in function \<open>del\<close>) by the minimal element in its right subtree.\<close>

fun split_min :: "'a rbt \<Rightarrow> 'a \<times> 'a rbt" where
"split_min (Node l (a, _) r) =
  (if l = Leaf then (a,r)
   else let (x,l') = split_min l
        in (x, if color l = Black then baldL l' a r else R l' a r))"

fun del :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"del x Leaf = Leaf" |
"del x (Node l (a, _) r) =
  (case cmp x a of
     LT \<Rightarrow> let l' = del x l in if l \<noteq> Leaf \<and> color l = Black
           then baldL l' a r else R l' a r |
     GT \<Rightarrow> let r' = del x r in if r \<noteq> Leaf \<and> color r = Black
           then baldR l a r' else R l a r' |
     EQ \<Rightarrow> if r = Leaf then l else let (a',r') = split_min r in
           if color r = Black then baldR l a' r' else R l a' r')"

text \<open>The first two \<open>let\<close>s speed up the automatic proof of \<open>inv_del\<close> below.\<close>

definition delete :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"delete x t = paint Black (del x t)"

subsection "Functional Correctness Proofs"

declare Let_def[simp]

lemma split_minD:
  "split_min t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> x # inorder t' = inorder t"
by(induction t arbitrary: t' rule: split_min.induct)
  (auto simp: inorder_baldL sorted_lems split: prod.splits if_splits)

lemma inorder_del:
 "sorted(inorder t) \<Longrightarrow>  inorder(del x t) = del_list x (inorder t)"
by(induction x t rule: del.induct)
  (auto simp: del_list_simps inorder_baldL inorder_baldR split_minD split: prod.splits)

lemma inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by (auto simp: delete_def inorder_del inorder_paint)

subsection \<open>Structural invariants\<close>

lemma neq_Red[simp]: "(c \<noteq> Red) = (c = Black)"
by (cases c) auto

subsubsection \<open>Deletion\<close>

lemma inv_split_min: "\<lbrakk> split_min t = (x,t'); t \<noteq> Leaf; invh t; invc t \<rbrakk> \<Longrightarrow>
   invh t' \<and>
   (color t = Red \<longrightarrow> bheight t' = bheight t \<and> invc t') \<and>
   (color t = Black \<longrightarrow> bheight t' = bheight t - 1 \<and> invc2 t')"
apply(induction t arbitrary: x t' rule: split_min.induct)
apply(auto simp: inv_baldR inv_baldL invc2I dest!: neq_LeafD
           split: if_splits prod.splits)
done

text \<open>An automatic proof. It is quite brittle, e.g. inlining the \<open>let\<close>s in @{const del} breaks it.\<close>
lemma inv_del: "\<lbrakk> invh t; invc t \<rbrakk> \<Longrightarrow>
   invh (del x t) \<and>
   (color t = Red \<longrightarrow> bheight (del x t) = bheight t \<and> invc (del x t)) \<and>
   (color t = Black \<longrightarrow> bheight (del x t) = bheight t - 1 \<and> invc2 (del x t))"
apply(induction x t rule: del.induct)
apply(auto simp: inv_baldR inv_baldL invc2I dest!: inv_split_min dest: neq_LeafD
           split!: prod.splits if_splits)
done

text\<open>A structured proof where one can see what is used in each case.\<close>
lemma inv_del2: "\<lbrakk> invh t; invc t \<rbrakk> \<Longrightarrow>
   invh (del x t) \<and>
   (color t = Red \<longrightarrow> bheight (del x t) = bheight t \<and> invc (del x t)) \<and>
   (color t = Black \<longrightarrow> bheight (del x t) = bheight t - 1 \<and> invc2 (del x t))"
proof(induction x t rule: del.induct)
  case (1 x)
  then show ?case by simp
next
  case (2 x l a c r)
  note if_split[split del]
  show ?case
  proof cases
    assume "x < a"
    show ?thesis
    proof cases (* For readability; is automated more (below) *)
      assume "l = Leaf" thus ?thesis using \<open>x < a\<close> "2.prems" by(auto)
    next
      assume l: "l \<noteq> Leaf"
      show ?thesis
      proof (cases "color l")
        assume *: "color l = Black"
        hence "bheight l > 0" using l neq_LeafD[of l] by auto
        thus ?thesis using \<open>x < a\<close> "2.IH"(1) "2.prems" inv_baldL[of "del x l"] * l by(auto)
      next
        assume "color l = Red"
        thus ?thesis using \<open>x < a\<close> "2.prems" "2.IH"(1) by(auto)
      qed
    qed
  next (* more automation: *)
    assume "\<not> x < a"
    show ?thesis
    proof cases
      assume "x > a"
      show ?thesis using \<open>a < x\<close> "2.IH"(2) "2.prems" neq_LeafD[of r] inv_baldR[of _ "del x r"]
          by(auto split: if_split)

    next
      assume "\<not> x > a"
      show ?thesis using "2.prems" \<open>\<not> x < a\<close> \<open>\<not> x > a\<close>
          by(auto simp: inv_baldR invc2I dest!: inv_split_min dest: neq_LeafD split: prod.split if_split)
    qed
  qed
qed

theorem rbt_delete: "rbt t \<Longrightarrow> rbt (delete x t)"
by (metis delete_def rbt_def color_paint_Black inv_del invh_paint)

text \<open>Overall correctness:\<close>

interpretation S: Set_by_Ordered
where empty = empty and isin = isin and insert = insert and delete = delete
and inorder = inorder and inv = rbt
proof (standard, goal_cases)
  case 1 show ?case by (simp add: empty_def)
next
  case 2 thus ?case by(simp add: isin_set_inorder)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 5 thus ?case by (simp add: rbt_def empty_def)
next
  case 6 thus ?case by (simp add: rbt_insert)
next
  case 7 thus ?case by (simp add: rbt_delete)
qed

end


(*  Title:      HOL/ex/SOS.thy
    Author:     Amine Chaieb, University of Cambridge
    Author:     Philipp Meyer, TU Muenchen

Examples for Sum_of_Squares.
*)

theory SOS
imports "~~/src/HOL/Library/Sum_of_Squares"
begin

lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x \<Longrightarrow> a < 0"
  by sos

lemma "a1 \<ge> 0 \<and> a2 \<ge> 0 \<and> (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) \<and> (a1 * b1 + a2 * b2 = 0) \<longrightarrow>
    a1 * a2 - b1 * b2 \<ge> (0::real)"
  by sos

lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x \<longrightarrow> a < 0"
  by sos

lemma "(0::real) \<le> x \<and> x \<le> 1 \<and> 0 \<le> y \<and> y \<le> 1 \<longrightarrow>
    x\<^sup>2 + y\<^sup>2 < 1 \<or> (x - 1)\<^sup>2 + y\<^sup>2 < 1 \<or> x\<^sup>2 + (y - 1)\<^sup>2 < 1 \<or> (x - 1)\<^sup>2 + (y - 1)\<^sup>2 < 1"
  by sos

lemma "(0::real) \<le> x \<and> 0 \<le> y \<and> 0 \<le> z \<and> x + y + z \<le> 3 \<longrightarrow> x * y + x * z + y * z \<ge> 3 * x * y * z"
  by sos

lemma "(x::real)\<^sup>2 + y\<^sup>2 + z\<^sup>2 = 1 \<longrightarrow> (x + y + z)\<^sup>2 \<le> 3"
  by sos

lemma "w\<^sup>2 + x\<^sup>2 + y\<^sup>2 + z\<^sup>2 = 1 \<longrightarrow> (w + x + y + z)\<^sup>2 \<le> (4::real)"
  by sos

lemma "(x::real) \<ge> 1 \<and> y \<ge> 1 \<longrightarrow> x * y \<ge> x + y - 1"
  by sos

lemma "(x::real) > 1 \<and> y > 1 \<longrightarrow> x * y > x + y - 1"
  by sos

lemma "\<bar>x\<bar> \<le> 1 \<longrightarrow> \<bar>64 * x^7 - 112 * x^5 + 56 * x^3 - 7 * x\<bar> \<le> (1::real)"
  by sos

text \<open>One component of denominator in dodecahedral example.\<close>

lemma "2 \<le> x \<and> x \<le> 125841 / 50000 \<and> 2 \<le> y \<and> y \<le> 125841 / 50000 \<and> 2 \<le> z \<and> z \<le> 125841 / 50000 \<longrightarrow>
    2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) \<ge> (0::real)"
  by sos

text \<open>Over a larger but simpler interval.\<close>

lemma "(2::real) \<le> x \<and> x \<le> 4 \<and> 2 \<le> y \<and> y \<le> 4 \<and> 2 \<le> z \<and> z \<le> 4 \<longrightarrow>
    0 \<le> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)"
  by sos

text \<open>We can do 12. I think 12 is a sharp bound; see PP's certificate.\<close>

lemma "2 \<le> (x::real) \<and> x \<le> 4 \<and> 2 \<le> y \<and> y \<le> 4 \<and> 2 \<le> z \<and> z \<le> 4 \<longrightarrow>
    12 \<le> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)"
  by sos

text \<open>Inequality from sci.math (see "Leon-Sotelo, por favor").\<close>

lemma "0 \<le> (x::real) \<and> 0 \<le> y \<and> x * y = 1 \<longrightarrow> x + y \<le> x\<^sup>2 + y\<^sup>2"
  by sos

lemma "0 \<le> (x::real) \<and> 0 \<le> y \<and> x * y = 1 \<longrightarrow> x * y * (x + y) \<le> x\<^sup>2 + y\<^sup>2"
  by sos

lemma "0 \<le> (x::real) \<and> 0 \<le> y \<longrightarrow> x * y * (x + y)\<^sup>2 \<le> (x\<^sup>2 + y\<^sup>2)\<^sup>2"
  by sos

lemma "(0::real) \<le> a \<and> 0 \<le> b \<and> 0 \<le> c \<and> c * (2 * a + b)^3 / 27 \<le> x \<longrightarrow> c * a\<^sup>2 * b \<le> x"
  by sos

lemma "(0::real) < x \<longrightarrow> 0 < 1 + x + x\<^sup>2"
  by sos

lemma "(0::real) \<le> x \<longrightarrow> 0 < 1 + x + x\<^sup>2"
  by sos

lemma "(0::real) < 1 + x\<^sup>2"
  by sos

lemma "(0::real) \<le> 1 + 2 * x + x\<^sup>2"
  by sos

lemma "(0::real) < 1 + \<bar>x\<bar>"
  by sos

lemma "(0::real) < 1 + (1 + x)\<^sup>2 * \<bar>x\<bar>"
  by sos

lemma "\<bar>(1::real) + x\<^sup>2\<bar> = (1::real) + x\<^sup>2"
  by sos

lemma "(3::real) * x + 7 * a < 4 \<and> 3 < 2 * x \<longrightarrow> a < 0"
  by sos

lemma "(0::real) < x \<longrightarrow> 1 < y \<longrightarrow> y * x \<le> z \<longrightarrow> x < z"
  by sos

lemma "(1::real) < x \<longrightarrow> x\<^sup>2 < y \<longrightarrow> 1 < y"
  by sos

lemma "(b::real)\<^sup>2 < 4 * a * c \<longrightarrow> a * x\<^sup>2 + b * x + c \<noteq> 0"
  by sos

lemma "(b::real)\<^sup>2 < 4 * a * c \<longrightarrow> a * x\<^sup>2 + b * x + c \<noteq> 0"
  by sos

lemma "(a::real) * x\<^sup>2 + b * x + c = 0 \<longrightarrow> b\<^sup>2 \<ge> 4 * a * c"
  by sos

lemma "(0::real) \<le> b \<and> 0 \<le> c \<and> 0 \<le> x \<and> 0 \<le> y \<and> x\<^sup>2 = c \<and> y\<^sup>2 = a\<^sup>2 * c + b \<longrightarrow> a * c \<le> y * x"
  by sos

lemma "\<bar>x - z\<bar> \<le> e \<and> \<bar>y - z\<bar> \<le> e \<and> 0 \<le> u \<and> 0 \<le> v \<and> u + v = 1 --> \<bar>(u * x + v * y) - z\<bar> \<le> (e::real)"
  by sos

lemma "(x::real) - y - 2 * x^4 = 0 \<and> 0 \<le> x \<and> x \<le> 2 \<and> 0 \<le> y \<and> y \<le> 3 \<longrightarrow> y\<^sup>2 - 7 * y - 12 * x + 17 \<ge> 0"
  oops (*Too hard?*)

lemma "(0::real) \<le> x \<longrightarrow> (1 + x + x\<^sup>2) / (1 + x\<^sup>2) \<le> 1 + x"
  by sos

lemma "(0::real) \<le> x \<longrightarrow> 1 - x \<le> 1 / (1 + x + x\<^sup>2)"
  by sos

lemma "(x::real) \<le> 1 / 2 \<longrightarrow> - x - 2 * x\<^sup>2 \<le> - x / (1 - x)"
  by sos

lemma "4 * r\<^sup>2 = p\<^sup>2 - 4 * q \<and> r \<ge> (0::real) \<and> x\<^sup>2 + p * x + q = 0 \<longrightarrow>
    2 * (x::real) = - p + 2 * r \<or> 2 * x = - p - 2 * r"
  by sos

end


theory Ex027
  imports Main
begin

(*law of excluded middle*)
lemma "P \<or> \<not>P"
proof -
  {
    assume a:"\<not>(P \<or> \<not>P)"
    {
      assume b:P
      hence "P \<or> \<not>P" by (rule disjI1)
      with a have False by contradiction
    }
    hence "\<not>P" by (rule notI)
    hence "P \<or> \<not>P" by (rule disjI2)
    with a have False by contradiction
  }
  hence "\<not>\<not>(P \<or> \<not>P)" by (rule notI)
  thus ?thesis by (rule notnotD)
qed


theory IndProp
  imports Logic
begin

section {* IndProp *}

subsection {* Inductively defined propositions *}

inductive ev :: "nat \<Rightarrow> HOL.bool" where
  ev_0: "ev 0"
| ev_SS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

theorem ev_4: "ev (Suc (Suc (Suc (Suc 0))))"
  apply (rule ev_SS)
  apply (rule ev_SS)
  apply (rule ev_0)
  done

theorem ev_double: "\<forall> n. ev (double n)"
  oops

subsection {* Using Evidence in Proofs *}

subsubsection {* Inversion on Evidence *}

theorem ev_minus2: "ev n \<Longrightarrow> ev (pred (pred n))"
  apply (induction rule: ev.induct)
   apply (simp_all add: ev_0)
  done

(*
inductive_set even :: "nat set" where
  zero[intro!]: "0 \<in> even"
| step[intro!]: "n \<in> even \<Longrightarrow> Suc (Suc n) \<in> even"

inductive_cases Suc_Suc_cases [elim!]: "Suc (Suc n) \<in> even"
*)

(* theorem ev_minus2: "\<forall> n. n \<in> even \<longrightarrow> (pred (pred n)) \<in> even" *)

end