(*  Title:      ZF/Induct/ListN.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Lists of n elements\<close>

theory ListN imports ZF begin

text \<open>
  Inductive definition of lists of \<open>n\<close> elements; see
  @{cite "paulin-tlca"}.
\<close>

consts listn :: "i\<Rightarrow>i"
inductive
  domains "listn(A)" \<subseteq> "nat \<times> list(A)"
  intros
    NilI: "\<langle>0,Nil\<rangle> \<in> listn(A)"
    ConsI: "\<lbrakk>a \<in> A; \<langle>n,l\<rangle> \<in> listn(A)\<rbrakk> \<Longrightarrow> <succ(n), Cons(a,l)> \<in> listn(A)"
  type_intros nat_typechecks list.intros

lemma list_into_listn: "l \<in> list(A) \<Longrightarrow> <length(l),l> \<in> listn(A)"
  by (induct set: list) (simp_all add: listn.intros)

lemma listn_iff: "\<langle>n,l\<rangle> \<in> listn(A) \<longleftrightarrow> l \<in> list(A) \<and> length(l)=n"
  apply (rule iffI)
   apply (erule listn.induct)
    apply auto
  apply (blast intro: list_into_listn)
  done

lemma listn_image_eq: "listn(A)``{n} = {l \<in> list(A). length(l)=n}"
  apply (rule equality_iffI)
  apply (simp add: listn_iff separation image_singleton_iff)
  done

lemma listn_mono: "A \<subseteq> B \<Longrightarrow> listn(A) \<subseteq> listn(B)"
    unfolding listn.defs
  apply (rule lfp_mono)
    apply (rule listn.bnd_mono)+
  apply (assumption | rule univ_mono Sigma_mono list_mono basic_monos)+
  done

lemma listn_append:
    "\<lbrakk>\<langle>n,l\<rangle> \<in> listn(A); <n',l'> \<in> listn(A)\<rbrakk> \<Longrightarrow> <n#+n', l@l'> \<in> listn(A)"
  apply (erule listn.induct)
   apply (frule listn.dom_subset [THEN subsetD])
   apply (simp_all add: listn.intros)
  done

inductive_cases
      Nil_listn_case: "\<langle>i,Nil\<rangle> \<in> listn(A)"
  and Cons_listn_case: "<i,Cons(x,l)> \<in> listn(A)"

inductive_cases
      zero_listn_case: "\<langle>0,l\<rangle> \<in> listn(A)"
  and succ_listn_case: "<succ(i),l> \<in> listn(A)"

end


(*
  File:     Nearest_Neighbors.thy
  Author:   Martin Rau, TU München
*)

section \<open>Nearest Neighbor Search on the \<open>k\<close>-d Tree\<close>

theory Nearest_Neighbors
  imports
  KD_Tree
  "Eval_Base.Eval_Base"
begin

text \<open>
  Verifying nearest neighbor search on the k-d tree. Given a \<open>k\<close>-d tree and a point \<open>p\<close>,
  which might not be in the tree, find the points \<open>ps\<close> that are closest to \<open>p\<close> using the
  Euclidean metric.
\<close>

subsection \<open>Auxiliary Lemmas about \<open>sorted_wrt\<close>\<close>

lemma
  assumes "sorted_wrt f xs"
  shows sorted_wrt_take: "sorted_wrt f (take n xs)"
  and sorted_wrt_drop: "sorted_wrt f (drop n xs)"
proof -
  have "sorted_wrt f (take n xs @ drop n xs)"
    using assms by simp
  thus "sorted_wrt f (take n xs)" "sorted_wrt f (drop n xs)"
    using sorted_wrt_append by blast+
qed

definition sorted_wrt_dist :: "('k::finite) point \<Rightarrow> 'k point list \<Rightarrow> bool" where
  "sorted_wrt_dist p \<equiv> sorted_wrt (\<lambda>p\<^sub>0 p\<^sub>1. dist p\<^sub>0 p \<le> dist p\<^sub>1 p)"

lemma sorted_wrt_dist_insort_key:
  "sorted_wrt_dist p ps \<Longrightarrow> sorted_wrt_dist p (insort_key (\<lambda>q. dist q p) q ps)"
  apply2 (induction ps) by (auto simp: sorted_wrt_dist_def set_insort_key)

lemma sorted_wrt_dist_take_drop:
  assumes "sorted_wrt_dist p ps"
  shows "\<forall>p\<^sub>0 \<in> set (take n ps). \<forall>p\<^sub>1 \<in> set (drop n ps). dist p\<^sub>0 p \<le> dist p\<^sub>1 p"
  using assms sorted_wrt_append[of _ "take n ps" "drop n ps"] by (simp add: sorted_wrt_dist_def)

lemma sorted_wrt_dist_last_take_mono:
  assumes "sorted_wrt_dist p ps" "n \<le> length ps" "0 < n"
  shows "dist (last (take n ps)) p \<le> dist (last ps) p"
  using assms unfolding sorted_wrt_dist_def apply2 (induction ps arbitrary: n) by (auto simp add: take_Cons')

lemma sorted_wrt_dist_last_insort_key_eq:
  assumes "sorted_wrt_dist p ps" "insort_key (\<lambda>q. dist q p) q ps \<noteq> ps @ [q]"
  shows "last (insort_key (\<lambda>q. dist q p) q ps) = last ps"
  using assms unfolding sorted_wrt_dist_def apply2 (induction ps) by (auto)

lemma sorted_wrt_dist_last:
  assumes "sorted_wrt_dist p ps"
  shows "\<forall>q \<in> set ps. dist q p \<le> dist (last ps) p"
proof (cases "ps = []")
  case True
  thus ?thesis by simp
next
  case False
  then obtain ps' p' where [simp]:"ps = ps' @ [p']"
    using rev_exhaust by blast
  hence "sorted_wrt_dist p (ps' @ [p'])"
    using assms by blast
  thus ?thesis
    unfolding sorted_wrt_dist_def using sorted_wrt_append[of _ ps' "[p']"] by simp
qed

subsection \<open>Neighbors Sorted wrt. Distance\<close>

definition upd_nbors :: "nat \<Rightarrow> ('k::finite) point \<Rightarrow> 'k point \<Rightarrow> 'k point list \<Rightarrow> 'k point list" where
  "upd_nbors n p q ps = take n (insort_key (\<lambda>q. dist q p) q ps)"

lemma sorted_wrt_dist_nbors:
  assumes "sorted_wrt_dist p ps"
  shows "sorted_wrt_dist p (upd_nbors n p q ps)"
proof -
  have "sorted_wrt_dist p (insort_key (\<lambda>q. dist q p) q ps)"
    using assms sorted_wrt_dist_insort_key by blast
  thus ?thesis
    by (simp add: sorted_wrt_dist_def sorted_wrt_take upd_nbors_def)
qed

lemma sorted_wrt_dist_nbors_diff:
  assumes "sorted_wrt_dist p ps"
  shows "\<forall>r \<in> set ps \<union> {q} - set (upd_nbors n p q ps). \<forall>s \<in> set (upd_nbors n p q ps). dist s p \<le> dist r p"
proof -
  let ?ps' = "insort_key (\<lambda>q. dist q p) q ps"
  have "set ps \<union> { q } = set ?ps'"
    by (simp add: set_insort_key)
  moreover have "set ?ps' = set (take n ?ps') \<union> set (drop n ?ps')"
    using append_take_drop_id set_append by metis
  ultimately have "set ps \<union> { q } - set (take n ?ps') \<subseteq> set (drop n ?ps')"
    by blast
  moreover have "sorted_wrt_dist p ?ps'"
    using assms sorted_wrt_dist_insort_key by blast
  ultimately show ?thesis
    unfolding upd_nbors_def using sorted_wrt_dist_take_drop by blast
qed

lemma sorted_wrt_dist_last_upd_nbors_mono:
  assumes "sorted_wrt_dist p ps" "n \<le> length ps" "0 < n"
  shows "dist (last (upd_nbors n p q ps)) p \<le> dist (last ps) p"
proof (cases "insort_key (\<lambda>q. dist q p) q ps = ps @ [q]")
  case True
  thus ?thesis
    unfolding upd_nbors_def using assms sorted_wrt_dist_last_take_mono by auto
next
  case False
  hence "last (insort_key (\<lambda>q. dist q p) q ps) = last ps"
    using sorted_wrt_dist_last_insort_key_eq assms by blast
  moreover have "dist (last (upd_nbors  n p q ps)) p \<le> dist (last (insort_key (\<lambda>q. dist q p) q ps)) p"
    unfolding upd_nbors_def using assms sorted_wrt_dist_last_take_mono[of p "insort_key (\<lambda>q. dist q p) q ps"]
    by (simp add: sorted_wrt_dist_insort_key)
  ultimately show ?thesis
    by simp
qed

subsection \<open>The Recursive Nearest Neighbor Algorithm\<close>

fun nearest_nbors :: "nat \<Rightarrow> ('k::finite) point list \<Rightarrow> 'k point \<Rightarrow> 'k kdt \<Rightarrow> 'k point list" where
  "nearest_nbors n ps p (Leaf q) = upd_nbors n p q ps"
| "nearest_nbors n ps p (Node k v l r) = (
    if p$k \<le> v then
      let candidates = nearest_nbors n ps p l in
      if length candidates = n \<and> dist p (last candidates) \<le> dist v (p$k) then
        candidates
      else
        nearest_nbors n candidates p r
    else
      let candidates = nearest_nbors n ps p r in
      if length candidates = n \<and> dist p (last candidates) \<le> dist v (p$k) then
        candidates
      else
        nearest_nbors n candidates p l
  )"

subsection \<open>Auxiliary Lemmas\<close>

lemma cutoff_r:
  assumes "invar (Node k v l r)"
  assumes "p$k \<le> v" "dist p c \<le> dist (p$k) v"
  shows "\<forall>q \<in> set_kdt r. dist p c \<le> dist p q"
proof standard
  fix q
  assume *: "q \<in> set_kdt r"
  have "dist p c \<le> dist (p$k) v"
    using assms(3) by blast
  also have "... \<le> dist (p$k) v + dist v (q$k)"
    by simp
  also have "... = dist (p$k) (q$k)"
    using * assms(1,2) dist_real_def by auto
  also have "... \<le> dist p q"
    using dist_vec_nth_le by blast
  finally show "dist p c \<le> dist p q" .
qed

lemma cutoff_l:
  assumes "invar (Node k v l r)"
  assumes "v \<le> p$k" "dist p c \<le> dist v (p$k)"
  shows "\<forall>q \<in> set_kdt l. dist p c \<le> dist p q"
proof standard
  fix q
  assume *: "q \<in> set_kdt l"
  have "dist p c \<le> dist v (p$k)"
    using assms(3) by blast
  also have "... \<le> dist v (p$k) + dist (q$k) v"
    by simp
  also have "... = dist (p$k) (q$k)"
    using * assms(1,2) dist_real_def by auto
  also have "... \<le> dist p q"
    using dist_vec_nth_le by blast
  finally show "dist p c \<le> dist p q" .
qed

subsection \<open>The Main Theorems\<close>

lemma set_nns:
  "set (nearest_nbors n ps p kdt) \<subseteq> set_kdt kdt \<union> set ps"
  apply2 (induction kdt arbitrary: ps)
  apply (auto simp: Let_def upd_nbors_def set_insort_key)
  using in_set_takeD set_insort_key by fastforce

lemma length_nns:
  "length (nearest_nbors n ps p kdt) = min n (size_kdt kdt + length ps)"
  apply2 (induction kdt arbitrary: ps) by (auto simp: Let_def upd_nbors_def)

lemma length_nns_gt_0:
  "0 < n \<Longrightarrow> 0 < length (nearest_nbors n ps p kdt)"
  apply2 (induction kdt arbitrary: ps) by (auto simp: Let_def upd_nbors_def)

lemma length_nns_n:
  assumes "(set_kdt kdt \<union> set ps) - set (nearest_nbors n ps p kdt) \<noteq> {}"
  shows "length (nearest_nbors n ps p kdt) = n"
  using assms
proof2 (induction kdt arbitrary: ps)
  case (Node k v l r)
  let ?nnsl = "nearest_nbors n ps p l"
  let ?nnsr = "nearest_nbors n ps p r"
  consider (A) "p$k \<le> v \<and> length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k)"
         | (B) "p$k \<le> v \<and> \<not>(length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k))"
         | (C) "v < p$k \<and> length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k)"
         | (D) "v < p$k \<and> \<not>(length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k))"
    by argo
  thus ?case
  proof cases
    case B
    let ?nns = "nearest_nbors n ?nnsl p r"
    have "length ?nnsl \<noteq> n \<longrightarrow> (set_kdt l \<union> set ps - set (nearest_nbors n ps p l) = {})"
      using Node.IH(1) by blast
    hence "length ?nnsl \<noteq> n \<longrightarrow> (set_kdt r \<union> set ?nnsl - set ?nns \<noteq> {})"
      using B Node.prems by auto
    moreover have "length ?nnsl = n \<longrightarrow> ?thesis"
      using B by (auto simp: length_nns)
    ultimately show ?thesis
      using B Node.IH(2) by force
  next
    case D
    let ?nns = "nearest_nbors n ?nnsr p l"
    have "length ?nnsr \<noteq> n \<longrightarrow> (set_kdt r \<union> set ps - set (nearest_nbors n ps p r) = {})"
      using Node.IH(2) by blast
    hence "length ?nnsr \<noteq> n \<longrightarrow> (set_kdt l \<union> set ?nnsr - set ?nns \<noteq> {})"
      using D Node.prems by auto
    moreover have "length ?nnsr = n \<longrightarrow> ?thesis"
      using D by (auto simp: length_nns)
    ultimately show ?thesis
      using D Node.IH(1) by force
  qed auto
qed (auto simp: upd_nbors_def min_def set_insort_key)

lemma sorted_nns:
  "sorted_wrt_dist p ps \<Longrightarrow> sorted_wrt_dist p (nearest_nbors n ps p kdt)"
  using sorted_wrt_dist_nbors apply2 (induction kdt arbitrary: ps) by (auto simp: Let_def)

lemma distinct_nns:
  assumes "invar kdt" "distinct ps" "set ps \<inter> set_kdt kdt = {}"
  shows "distinct (nearest_nbors n ps p kdt)"
  using assms
proof2 (induction kdt arbitrary: ps)
  case (Node k v l r)
  let ?nnsl = "nearest_nbors n ps p l"
  let ?nnsr = "nearest_nbors n ps p r"
  have "set ps \<inter> set_kdt l = {}" "set ps \<inter> set_kdt r = {}"
    using Node.prems(3) by auto
  hence DCLR: "distinct ?nnsl" "distinct ?nnsr"
    using Node invar_l invar_r by blast+
  have "set ?nnsl \<inter> set_kdt r = {}" "set ?nnsr \<inter> set_kdt l = {}"
    using Node.prems(1,3) set_nns by fastforce+
  hence "distinct (nearest_nbors n ?nnsl p r)" "distinct (nearest_nbors n ?nnsr p l)"
    using Node.IH(1,2) Node.prems(1,2) DCLR invar_l invar_r by blast+
  thus ?case
    using DCLR by (auto simp add: Let_def)
qed (auto simp: upd_nbors_def distinct_insort)

theorem dist_nns:
  assumes "invar kdt" "sorted_wrt_dist p ps" "set ps \<inter> set_kdt kdt = {}" "distinct ps" "0 < n"
  shows "\<forall>q \<in> set_kdt kdt \<union> set ps - set (nearest_nbors n ps p kdt). dist (last (nearest_nbors n ps p kdt)) p \<le> dist q p"
  using assms
proof2 (induction kdt arbitrary: ps)
  case (Node k v l r)

  let ?nnsl = "nearest_nbors n ps p l"
  let ?nnsr = "nearest_nbors n ps p r"

  have IHL: "\<forall>q \<in> set_kdt l \<union> set ps - set ?nnsl. dist (last ?nnsl) p \<le> dist q p"
    using Node.IH(1) Node.prems invar_l invar_set by auto
  have IHR: "\<forall>q \<in> set_kdt r \<union> set ps - set ?nnsr. dist (last ?nnsr) p \<le> dist q p"
    using Node.IH(2) Node.prems invar_r invar_set by auto

  have SORTED_L: "sorted_wrt_dist p ?nnsl"
    using sorted_nns Node.prems(2) by blast
  have SORTED_R: "sorted_wrt_dist p ?nnsr"
    using sorted_nns Node.prems(2) by blast

  have DISTINCT_L: "distinct ?nnsl"
    using Node.prems distinct_nns invar_set invar_l by fastforce
  have DISTINCT_R: "distinct ?nnsr"
    using Node.prems distinct_nns invar_set invar_r
    by (metis inf_bot_right inf_sup_absorb inf_sup_aci(3) sup.commute)

  consider (A) "p$k \<le> v \<and> length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k)"
         | (B) "p$k \<le> v \<and> \<not>(length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k))"
         | (C) "v < p$k \<and> length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k)"
         | (D) "v < p$k \<and> \<not>(length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k))"
    by argo
  thus ?case
  proof cases
    case A
    hence "\<forall>q \<in> set_kdt r. dist (last ?nnsl) p \<le> dist q p"
      using Node.prems(1,2) cutoff_r by (metis dist_commute)
    thus ?thesis
      using IHL A by auto
  next
    case B

    let ?nns = "nearest_nbors n ?nnsl p r"

    have "set ?nnsl \<subseteq> set_kdt l \<union> set ps" "set ps \<inter> set_kdt r = {}"
      using set_nns Node.prems(1,3) by (simp add: set_nns disjoint_iff_not_equal)+
    hence "set ?nnsl \<inter> set_kdt r = {}"
      using Node.prems(1) by fastforce
    hence IHLR: "\<forall>q \<in> set_kdt r \<union> set ?nnsl - set ?nns. dist (last ?nns) p \<le> dist q p"
      using Node.IH(2)[OF _ SORTED_L _ DISTINCT_L Node.prems(5)] Node.prems(1) invar_r by blast

    have "\<forall>q \<in> set ps - set ?nnsl. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set ps - set ?nnsl"

      hence "length ?nnsl = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsl) p"
        using last_nns_mono SORTED_L invar_r Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsl) p \<le> dist q p"
        using IHL * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence R: "\<forall>q \<in> set_kdt r \<union> set ps - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHLR by auto

    have "\<forall>q \<in> set_kdt l - set ?nnsl. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set_kdt l - set ?nnsl"

      hence "length ?nnsl = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsl) p"
        using last_nns_mono SORTED_L invar_r Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsl) p \<le> dist q p"
        using IHL * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence L: "\<forall>q \<in> set_kdt l - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHLR by blast

    show ?thesis
      using B R L by auto
  next
    case C
    hence "\<forall>q \<in> set_kdt l. dist (last ?nnsr) p \<le> dist q p"
      using Node.prems(1,2) cutoff_l by (metis dist_commute less_imp_le)
    thus ?thesis
      using IHR C by auto
  next
    case D

    let ?nns = "nearest_nbors n ?nnsr p l"

    have "set ?nnsr \<subseteq> set_kdt r \<union> set ps" "set ps \<inter> set_kdt l = {}"
      using set_nns Node.prems(1,3) by (simp add: set_nns disjoint_iff_not_equal)+
    hence "set ?nnsr \<inter> set_kdt l = {}"
      using Node.prems(1) by fastforce
    hence IHRL: "\<forall>q \<in> set_kdt l \<union> set ?nnsr - set ?nns. dist (last ?nns) p \<le> dist q p"
      using Node.IH(1)[OF _ SORTED_R _ DISTINCT_R Node.prems(5)] Node.prems(1) invar_l by blast

    have "\<forall>q \<in> set ps - set ?nnsr. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set ps - set ?nnsr"

      hence "length ?nnsr = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsr) p"
        using last_nns_mono SORTED_R invar_l Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsr) p \<le> dist q p"
        using IHR * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence R: "\<forall>q \<in> set_kdt l \<union> set ps - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHRL by auto

    have "\<forall>q \<in> set_kdt r - set ?nnsr. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set_kdt r - set ?nnsr"

      hence "length ?nnsr = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsr) p"
        using last_nns_mono SORTED_R invar_l Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsr) p \<le> dist q p"
        using IHR * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence L: "\<forall>q \<in> set_kdt r - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHRL by blast

    show ?thesis
      using D R L by auto
  qed
qed (auto simp: sorted_wrt_dist_nbors_diff upd_nbors_def)

subsection \<open>Nearest Neighbors Definition and Theorems\<close>

definition nearest_neighbors :: "nat \<Rightarrow> ('k::finite) point \<Rightarrow> 'k kdt \<Rightarrow> 'k point list" where
  "nearest_neighbors n p kdt = nearest_nbors n [] p kdt"

theorem length_nearest_neighbors:
  "length (nearest_neighbors n p kdt) = min n (size_kdt kdt)"
  by (simp add: length_nns nearest_neighbors_def)

theorem sorted_wrt_dist_nearest_neighbors:
  "sorted_wrt_dist p (nearest_neighbors n p kdt)"
  using sorted_nns unfolding nearest_neighbors_def sorted_wrt_dist_def by force

theorem distinct_nearest_neighbors:
  assumes "invar kdt"
  shows "distinct (nearest_neighbors n p kdt)"
  using assms by (simp add: distinct_nns nearest_neighbors_def)

theorem dist_nearest_neighbors:
  assumes "invar kdt" "nns = nearest_neighbors n p kdt"
  shows "\<forall>q \<in> (set_kdt kdt - set nns). \<forall>r \<in> set nns. dist r p \<le> dist q p"
proof (cases "0 < n")
  case True
  have "\<forall>q \<in> set_kdt kdt - set nns. dist (last nns) p \<le> dist q p"
    using nearest_neighbors_def dist_nns[OF assms(1), of p "[]", OF _ _ _ True] assms(2)
    by (simp add: nearest_neighbors_def sorted_wrt_dist_def)
  hence "\<forall>q \<in> set_kdt kdt - set nns. \<forall>n \<in> set nns. dist n p \<le> dist q p"
    using assms(2) sorted_wrt_dist_nearest_neighbors[of p n kdt] sorted_wrt_dist_last[of p nns] by force
  thus ?thesis
    using nearest_neighbors_def by blast
next
  case False
  hence "length nns = 0"
    using assms(2) unfolding nearest_neighbors_def by (auto simp: length_nns)
  thus ?thesis
    by simp
qed

end


\<^marker>\<open>create Bernhard Pöttinger\<close>

chapter \<open>Approximations\<close>
theory Effectively_Acyclic_Approximations
imports Effectively_Acyclic
begin

paragraph \<open>Summary\<close>
text \<open>This theory complements theory Approximations with some approximations/results on capacities
that depend on effective acyclicity and can not be put into Approximations due to this dependency.\<close>

text \<open>@{term cap_eff_acyclic}: the capacity from x to x equals the identity function as all paths of
length >= 1 that reach from x to x are cycles, i.e. have flow 0.\<close>

lemma cap_eff_acyclic:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "eff_acyclic' h" "h \<noteq> bot" "x \<in> dom_fg h" "End_closed E" "\<forall>x y. edge_fg h x y \<in> E"
    "a \<le> flow_fg h x" "id \<in> E"
  shows "cap' k (dom_fg h) (edge_fg h) x x a = a"
  using assms
  apply (subst cap'_unrolled_closed[where E=E], simp_all)
  apply (subst plus_fun_apply_iterated[OF l_lists'_finite[OF dom_fg_finite]])
  apply (rule sum.neutral, safe)
  apply (subst chain2_chain)
  subgoal premises prems for xs
  proof -
    have K: "x # xs \<in> k_lists (dom_fg h) (length (x # xs))"
      using prems unfolding k_lists_def l_lists'_def by auto
    then have L: "chain (edge_fg h) (x # xs) x (flow_fg h (hd (x # xs))) = 0"
      using prems unfolding eff_acyclic'_def eff_acyclic_def by force

    have "chain (edge_fg h) (x # xs) x a \<le> chain (edge_fg h) (x # xs) x (flow_fg h x)"
      apply (rule pos_endo_mono'_closed[where f="chain (edge_fg h) (x # xs) x" and E=E])
      using prems apply simp_all
      by (rule endo_chain_closed, simp_all)
    with L show ?thesis by simp
  qed
  done

text \<open>@{term cap_cap_le_cap}: some kind of triangle inequality for capacities,
i.e. the capacity from x to z is >= than the capacity from x to y to z for y != z\<close>

lemma cap_cap_le_cap:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "End_closed E" "\<forall>x y. edge_fg h x y \<in> E" "x \<in> dom_fg h" "y \<in> dom_fg h" "z \<in> dom_fg h"
    and "h \<noteq> bot" "id \<in> E" "0 \<in> E"
    and dist: "y \<noteq> z"
    and flow: "a \<le> inf_fg h x"
    and ea: "eff_acyclic' h"
  shows "cap' k (dom_fg h) (edge_fg h) y z (cap' l (dom_fg h) (edge_fg h) x y a)
       \<le> cap' (k + l) (dom_fg h) (edge_fg h) x z a"
  using assms
proof (induction k arbitrary: y z)
  case 0
  then show ?case by simp
next
  case (Suc k)

  let ?e = "edge_fg h" let ?N = "dom_fg h"

  have "(\<Sum>n''\<in>?N. ?e n'' z \<circ> cap' k ?N ?e y n'') (cap' l ?N ?e x y a) =
        (\<Sum>n''\<in>?N. (?e n'' z o cap' k ?N ?e y n'') (cap' l ?N ?e x y a))"
    by (rule plus_fun_apply_iterated[OF dom_fg_finite])
  also have "... \<le> (\<Sum>n''\<in>?N. ?e n'' z (cap' (k + l) ?N ?e x n'' a))"
    apply (simp, rule sum_mono)
    subgoal for n''
      apply (rule pos_endo_mono'_closed[where f="?e n'' z" and E=E])
      apply (cases "y \<noteq> n''")
        apply (rule Suc.IH[of y n''])
      using Suc apply simp_all
      apply (subst cap_eff_acyclic, simp_all)
        apply (rule order_trans[OF pos_endo_mono'_closed[OF flow, where E=E]])
          apply (rule endo_cap'[where E=E], simp_all add: zero_fun_def id_def)
       apply (cases l)
        apply (clarsimp simp: \<delta>_def)
      apply (rule inf_fg_le_flow_fg, simp, simp)
      apply (rule cap'_inf_fg_le_flow_fg, simp_all add: id_def)
      by (rule cap'_superset_iterations[OF dom_fg_finite], simp_all)
    done
  finally have A: "(\<Sum>n''\<in>?N. ?e n'' z \<circ> cap' k ?N ?e y n'') (cap' l ?N ?e x y a)
                 \<le> (\<Sum>n''\<in>?N. ?e n'' z (cap' (k + l) ?N ?e x n'' a))" .

  show ?case
    using Suc apply (auto simp: \<delta>_def)
    using A apply (subst (2) plus_fun_apply_iterated[OF dom_fg_finite],
                   simp add: comp_def add_increasing)
    using A by (subst (2) plus_fun_apply_iterated[OF dom_fg_finite], simp add: comp_def)
qed

text \<open>@{term unroll_flow_eq_eff_acyclic}: like @{thm unroll_flow_eq} but in an effectively acyclic context
we can eliminiate its second big-sum if we unroll the flow equation far enough to obtain cycles
in the second big-sum.\<close>

lemma unroll_flow_eq_eff_acyclic:
  fixes e :: "'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b :: pos_cancel_comm_monoid_add"
  assumes "eff_acyclic N e f" "flow_eq2' N e f i" "\<forall>x y. e x y \<in> E" "End_closed E" "finite N"
    "k \<ge> card N" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "\<forall>x \<in> N. f x = i x + (\<Sum>xs \<in> l_lists N k. chain e xs x (i (hd xs)))"
proof (cases "card N")
  case 0
  then have "N = {}" using assms card_0_eq by blast
  then show ?thesis by blast
next
  case (Suc nat)
  then have "k \<ge> 1" using assms by simp
  show ?thesis
  proof
    fix x
    assume A: "x \<in> N"

    have zt: "(\<Sum>ns\<in>k_lists N k. chain e ns x (f (hd ns))) = 0"
    proof (rule sum.neutral, safe)
      fix ns
      assume A: "ns \<in> k_lists N k"
      then obtain z xs ys zs where *: "ns @ [x] = xs @ z # ys @ z # zs"
        using pigeonhole_split_list[of N "ns @ [x]"] k_lists_finite[of N k] assms \<open>x \<in> N\<close>
        unfolding k_lists_def by auto
      then have **: "ns = butlast (xs @ z # ys @ z # zs)"
        by (metis butlast_snoc)
      have "set ns \<subseteq> N"
        using A unfolding k_lists_def by simp
      then have ***: "z \<in> N" "set (ns @ [x]) \<subseteq> N"
        using * A \<open>x \<in> N\<close> apply (simp_all add: "**" butlast_append)
        by (metis UnE list.set(1) list.set(2) set_append set_subset_Cons singletonD subset_code(1))
      have "set (ns @ [x]) \<subseteq> N"
        using A \<open>x \<in> N\<close> unfolding k_lists_def by simp
      then have "z # ys \<in> k_lists N (length ys + 1)"
        using A \<open>x \<in> N\<close> * unfolding k_lists_def by auto
      then have C: "chain e (z # ys) z (f z) = 0"
        using assms unfolding eff_acyclic_def by fastforce
      have B: "chain e xs z (f (hd (ns @ [x]))) \<le> f z"
      proof (cases xs)
        case Nil
        then show ?thesis using * by simp
      next
        case (Cons a xs')
        have "chain e xs z (f (hd (xs @ [x])))
           \<le> (\<Sum>ns\<in>k_lists N (length xs). chain e ns z (f (hd (ns @ [x]))))"
          apply (rule sum_insert_pos_monoid[where f="\<lambda>xs. chain e xs z (f (hd (xs @ [x])))"])
          using k_lists_finite[OF \<open>finite N\<close>] apply simp
          using Cons * *** unfolding k_lists_def by simp
        also have "... \<le> i z + (\<Sum>ns\<in>l_lists N (length xs). chain e ns z (i (hd ns))) +
                               (\<Sum>ns\<in>k_lists N (length xs). chain e ns z (f (hd (ns @ [x]))))"
          by (simp add: add_increasing)
        also have "... = i z + (\<Sum>ns\<in>l_lists N (length xs). chain e ns z (i (hd ns))) +
                              (\<Sum>ns\<in>k_lists N (length xs). chain e ns z (f (hd ns)))"
          apply (simp, rule sum.cong, simp)
          unfolding k_lists_def using Cons
          by (metis (mono_tags, lifting) append_Cons hd_append2
              length_0_conv list.sel(1) mem_Collect_eq)
        also have "... = f z"
          apply (rule unroll_flow_eq[of "length xs" N e f i E z, symmetric])
          using assms Cons *** by simp_all
        finally show ?thesis
          using * Cons by simp
      qed
      have "chain e (z # ys) z (chain e xs z (f (hd (ns @ [x])))) \<le> chain e (z # ys) z (f z)"
        apply (rule pos_endo_mono'_closed[OF B])
        using endo_chain_closed assms by simp_all
      also have "... = 0"
        using C by simp
      finally have "chain e (z # ys) z (chain e xs z (f (hd (ns @ [x])))) = 0"
        by simp
      then have Z: "chain e (xs @ z # ys) z (f (hd ns)) = 0"
        apply (subst chain_append, simp_all)
        using A \<open>1 \<le> k\<close> k_lists_nonempty(2) by fastforce
      have X: "(xs @ z # ys) @ butlast (z # zs) = ns"
        using **  by (simp add: butlast_append)
      have "chain e ((xs @ z # ys) @ butlast (z # zs)) (last (ns @ [x])) =
        chain e (butlast (z # zs)) (last (ns @ [x])) o chain e (xs @ z # ys) (hd (butlast (z # zs) @ [last (ns @ [x])]))"
        using chain_append_nonempty[of e "xs @ z # ys" "butlast (z # zs)" "last (ns @ [x])"]
        apply simp unfolding comp_def by (auto split: if_splits)
      then have "chain e ns (last (ns @ [x])) =
        chain e (butlast (z # zs)) (last (ns @ [x])) o chain e (xs @ z # ys) (hd (butlast (z # zs) @ [last (ns @ [x])]))"
        using X by auto
      then show "chain e ns x (f (hd ns)) = 0"
        using endo_f_0_0_closed[of "chain e (butlast (z # zs)) x" E] Z
          assms endo_chain_closed[of e E "butlast (z # zs)" x]
        by (metis (no_types, lifting) "*" append_butlast_last_id append_is_Nil_conv
            comp_apply last_ConsR last_appendR last_snoc list.discI list.sel(1))
    qed

    have "f x = i x + (\<Sum>ns\<in>l_lists N k. chain e ns x (i (hd ns))) +
                      (\<Sum>ns\<in>k_lists N k. chain e ns x (f (hd ns)))"
      apply (rule unroll_flow_eq[of k N e f i E x], simp_all add: assms A) using \<open>k \<ge> 1\<close> by simp
    then show "f x = i x + (\<Sum>xs\<in>l_lists N k. chain e xs x (i (hd xs)))"
      using zt by simp
  qed
qed

text \<open>@{term unroll_flow_eq_eff_acyclic'}: wrapper lemma for @{thm unroll_flow_eq_eff_acyclic} that integrates
"i x" in the big-sum by using @{term l_lists'} instead of @{term l_lists}.\<close>

lemma unroll_flow_eq_eff_acyclic':
  fixes e :: "'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b :: pos_cancel_comm_monoid_add"
  assumes "eff_acyclic N e f" "flow_eq2' N e f i" "\<forall>x y. e x y \<in> E" "End_closed E" "finite N"
    "k \<ge> card N" "k \<ge> 1" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "\<forall>x \<in> N. f x = (\<Sum>xs \<in> l_lists' N k. chain e xs x (i (hd (xs @ [x]))))"
proof -
  have S: "\<forall>x \<in> N. f x = i x + (\<Sum>xs \<in> l_lists N k. chain e xs x (i (hd xs)))"
    using assms unroll_flow_eq_eff_acyclic by blast
  have T: "\<forall>x \<in> N. i x = chain e [] x (i (hd ([] @ [x])))"
    by simp
  show ?thesis
  proof
    fix x assume A: "x \<in> N"
    have "f x = i x + (\<Sum>xs \<in> l_lists N k. chain e xs x (i (hd xs)))" using S A by simp
    also have "... = i x + (\<Sum>xs \<in> l_lists N k. chain e xs x (i (hd (xs @ [x]))))"
      apply (simp, rule sum.cong, simp)
      unfolding l_lists_def using Suc_le_lessD by fastforce
    also have"... =
      chain e [] x (i (hd ([] @ [x]))) + (\<Sum>xs \<in> l_lists N k. chain e xs x (i (hd (xs @ [x]))))"
      using S by simp
    also have "... = (\<Sum>xs \<in>insert [] (l_lists N k). chain e xs x (i (hd (xs @ [x]))))"
      apply (rule sum.insert[symmetric, where g="\<lambda>xs. chain e xs x (i (hd (xs @ [x])))"])
       apply (rule l_lists_finite[OF \<open>finite N\<close>])
      unfolding l_lists_def by simp
    also have "... = (\<Sum>xs \<in>(l_lists' N k). chain e xs x (i (hd (xs @ [x]))))"
      apply (rule sum.cong)
      using l_lists_eq_l_lists'[of k N]  assms by auto
    finally show " f x = (\<Sum>xs\<in>l_lists' N k. chain e xs x (i (hd (xs @ [x]))))" .
  qed
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_56
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

theorem property0 :
  "((drop n (drop m xs)) = (drop (t2 n m) xs))"
  oops

end


theory Dioid
  imports Lattice
begin

(* +------------------------------------------------------------------------+ *)
section {* Dioids *}
(* +------------------------------------------------------------------------+ *)

record 'a dioid = "'a partial_object" +
  plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "+\<index>" 70)
  mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<cdot>\<index>" 80)
  one :: "'a" ("1\<index>")
  zero :: "'a" ("0\<index>")

locale dioid = fixes A (structure)
  assumes add_closed: "\<lbrakk>(x::'a) \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x + y \<in> carrier A"
  and mult_closed: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x\<cdot>y \<in> carrier A"
  and one_closed: "(1::'a) \<in> carrier A"
  and zero_closed: "(0::'a) \<in> carrier A"
  and mult_assoc: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> (x\<cdot>y)\<cdot>z = x\<cdot>(y\<cdot>z)"
  and add_assoc: "\<lbrakk>(x::'a) \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> (x + y) + z = x + (y + z)"
  and add_comm: "\<lbrakk>(x::'a) \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x + y = y + x"
  and add_idem: "(x::'a) \<in> carrier A \<Longrightarrow> x + x = x"
  and distl: "\<lbrakk>(x::'a) \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> x\<cdot>(y + z) = x\<cdot>y + x\<cdot>z"
  and distr: "\<lbrakk>(x::'a) \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> (x + y)\<cdot>z = x\<cdot>z + y\<cdot>z"
  and mult_onel: "(x::'a) \<in> carrier A \<Longrightarrow> 1\<cdot>x = x"
  and mult_oner: "(x::'a) \<in> carrier A \<Longrightarrow> x\<cdot>1 = x"
  and add_zerol: "(x::'a) \<in> carrier A \<Longrightarrow> 0 + x = x"
  and mult_zerol: "(x::'a) \<in> carrier A \<Longrightarrow> 0\<cdot>x = 0"
  and mult_zeror: "(x::'a) \<in> carrier A \<Longrightarrow> x\<cdot>0 = 0"

begin

  definition nat_order :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubseteq>" 50) where
    "x \<sqsubseteq> y \<equiv> x + y = y"

  abbreviation natural :: "'a ord" where
    "natural \<equiv> \<lparr>carrier = carrier A, le = nat_order\<rparr>"

  lemma natural: "order natural"
    by (default, auto simp add: nat_order_def, (metis add_idem add_assoc add_comm)+)

end

sublocale dioid \<subseteq> order "\<lparr>carrier = carrier A, le = nat_order\<rparr>" using natural .

sublocale dioid \<subseteq> join_semilattice "\<lparr>carrier = carrier A, le = nat_order\<rparr>"
  apply (default, auto simp add: order.is_lub_simp[OF natural])
  by (smt add_assoc add_closed add_comm add_idem nat_order_def)

context dioid
begin

  lemma add_zeror: "x \<in> carrier A \<Longrightarrow> x + 0 = x"
    by (metis add_comm add_zerol zero_closed)

  lemma add_lub: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z \<and> y \<sqsubseteq> z  \<longleftrightarrow> x + y \<sqsubseteq> z"
    by (metis add_assoc add_closed add_comm add_idem nat_order_def)

  lemma add_iso: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<longrightarrow> z + x \<sqsubseteq> z + y"
    by (metis add_assoc add_closed add_comm add_idem nat_order_def)

  lemma mult_isol: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<longrightarrow> z\<cdot>x \<sqsubseteq> z\<cdot>y"
    by (metis distl nat_order_def)

  lemma mult_isor: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<longrightarrow> x\<cdot>z \<sqsubseteq> y\<cdot>z"
    by (metis distr nat_order_def)

  lemma mult_double_iso: "\<lbrakk>w \<in> carrier A; x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> w \<sqsubseteq> x \<and> y \<sqsubseteq> z \<longrightarrow> w\<cdot>y \<sqsubseteq> x\<cdot>z"
    by (smt add_assoc distl distr add_idem nat_order_def mult_closed)

  lemma subdistl: "\<lbrakk>x \<in>  carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> z\<cdot>x \<sqsubseteq> z\<cdot>(x + y)"
    by (metis add_assoc add_closed add_idem nat_order_def mult_double_iso)

  lemma zero_min: "x \<in> carrier A \<Longrightarrow> 0 \<sqsubseteq> x"
    by (metis (lifting) add_zerol nat_order_def)

  lemma no_trivial_inverse: "\<forall>x\<in>carrier A.(x \<noteq> 0 \<longrightarrow> \<not>(\<exists>y\<in>carrier A.(x+y = 0)))"
    by (metis add_lub add_zeror nat_order_def zero_min)

  lemmas nat_antisym = order_antisym[simplified]
    and nat_refl = order_refl[simplified]
    and nat_trans = order_trans[simplified]

end

(* +------------------------------------------------------------------------+ *)
subsection {* Free Dioid *}
(* +------------------------------------------------------------------------+ *)

datatype 'a dioid_term = DioidAtom 'a
                       | DioidPlus "'a dioid_term" "'a dioid_term"
                       | DioidMult "'a dioid_term" "'a dioid_term"
                       | DioidOne
                       | DioidZero

primrec (in dioid) term_unfold :: "'a dioid_term \<Rightarrow> 'a" where
  "term_unfold (DioidAtom x) = x"
| "term_unfold (DioidPlus x y) = (term_unfold x) + (term_unfold y)"
| "term_unfold (DioidMult x y) = (term_unfold x) \<cdot> (term_unfold y)"
| "term_unfold DioidOne = 1"
| "term_unfold DioidZero = 0"

lemma (in dioid) term_fold_atom: "x \<in> carrier A \<Longrightarrow> x = term_unfold (DioidAtom x)"
  by (rule term_unfold.simps(1)[symmetric])

primrec (in dioid) term_atoms :: "'a dioid_term \<Rightarrow> 'a set" where
  "term_atoms (DioidAtom x) = {x}"
| "term_atoms (DioidPlus x y) = (term_atoms x) \<union> (term_atoms y)"
| "term_atoms (DioidMult x y) = (term_atoms x) \<union> (term_atoms y)"
| "term_atoms DioidOne = {}"
| "term_atoms DioidZero = {}"

lemma (in dioid) term_closure: "term_atoms x \<subseteq> carrier A \<Longrightarrow> term_unfold x \<in> carrier A"
  by (induct x, simp_all add: add_closed mult_closed one_closed zero_closed)

primrec dioid_term_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a dioid_term \<Rightarrow> 'b dioid_term" where
  "dioid_term_map f (DioidAtom x) = DioidAtom (f x)"
| "dioid_term_map f (DioidPlus x y) = DioidPlus (dioid_term_map f x) (dioid_term_map f y)"
| "dioid_term_map f (DioidMult x y) = DioidMult (dioid_term_map f x) (dioid_term_map f y)"
| "dioid_term_map f DioidOne = DioidOne"
| "dioid_term_map f DioidZero = DioidZero"

inductive dioid_con :: "'a dioid_term \<Rightarrow> 'a dioid_term \<Rightarrow> bool" where
  refl [intro]: "dioid_con x x"
| sym [sym]: "dioid_con x y \<Longrightarrow> dioid_con y x"
| trans [trans]: "dioid_con x y \<Longrightarrow> dioid_con y z \<Longrightarrow> dioid_con x z"
| add_lift: "dioid_con x1 x2 \<Longrightarrow> dioid_con y1 y2 \<Longrightarrow> dioid_con (DioidPlus x1 y1) (DioidPlus x2 y2)"
| mult_lift: "dioid_con x1 x2 \<Longrightarrow> dioid_con y1 y2 \<Longrightarrow> dioid_con (DioidMult x1 y1) (DioidMult x2 y2)"
| mult_assoc: "dioid_con (DioidMult (DioidMult x y) z) (DioidMult x (DioidMult y z))"
| add_assoc: "dioid_con (DioidPlus (DioidPlus x y) z) (DioidPlus x (DioidPlus y z))"
| add_comm: "dioid_con (DioidPlus x y) (DioidPlus y x)"
| add_idem: "dioid_con (DioidPlus x x) x"
| distl: "dioid_con (DioidMult x (DioidPlus y z)) (DioidPlus (DioidMult x y) (DioidMult x z))"
| distr: "dioid_con (DioidMult (DioidPlus x y) z) (DioidPlus (DioidMult x z) (DioidMult y z))"
| mult_onel: "dioid_con (DioidMult DioidOne x) x"
| mult_oner: "dioid_con (DioidMult x DioidOne) x"
| add_zerol: "dioid_con (DioidPlus DioidZero x) x"
| mult_zerol: "dioid_con (DioidMult DioidZero x) DioidZero"
| mult_zeror: "dioid_con (DioidMult x DioidZero) DioidZero"

quotient_type 'a dioid_expr = "'a dioid_term" / dioid_con
  by (metis (lifting) dioid_con.refl dioid_con.sym dioid_con.trans equivpI reflpI sympI transpI)

lift_definition term_mult :: "'a dioid_expr \<Rightarrow> 'a dioid_expr \<Rightarrow> 'a dioid_expr" is DioidMult
  by (rule mult_lift, assumption+)

lift_definition term_plus :: "'a dioid_expr \<Rightarrow> 'a dioid_expr \<Rightarrow> 'a dioid_expr" is DioidPlus
  by (rule add_lift, assumption+)

lift_definition term_one :: "'a dioid_expr" is DioidOne
  by (rule dioid_con.refl)

lift_definition term_zero :: "'a dioid_expr" is DioidZero
  by (rule dioid_con.refl)

definition free_dioid :: "'a dioid_expr dioid" where
  "free_dioid = \<lparr>carrier = UNIV, plus = term_plus, mult = term_mult, one = term_one, zero = term_zero\<rparr>"

lemma "dioid free_dioid"
proof (unfold_locales, simp_all add: free_dioid_def)
  fix x y z
  show "term_mult (term_mult x y) z = term_mult x (term_mult y z)"
    by (transfer, rule dioid_con.mult_assoc)
  show "term_plus (term_plus x y) z = term_plus x (term_plus y z)"
    by (transfer, rule dioid_con.add_assoc)
  show "term_plus x y = term_plus y x"
    by (transfer, rule dioid_con.add_comm)
  show "term_plus x x = x"
    by (transfer, rule dioid_con.add_idem)
  show "term_mult x (term_plus y z) = term_plus (term_mult x y) (term_mult x z)"
    by (transfer, rule dioid_con.distl)
  show "term_mult (term_plus x y) z = term_plus (term_mult x z) (term_mult y z)"
    by (transfer, rule dioid_con.distr)
  show "term_mult term_one x = x"
    by (transfer, rule dioid_con.mult_onel)
  show "term_mult x term_one = x"
    by (transfer, rule dioid_con.mult_oner)
  show "term_plus term_zero x = x"
    by (transfer, rule dioid_con.add_zerol)
  show "term_mult term_zero x = term_zero"
    by (transfer, rule dioid_con.mult_zerol)
  show "term_mult x term_zero = term_zero"
    by (transfer, rule dioid_con.mult_zeror)
qed

ML {*

fun term_fold_tac fold_atom folds closure leaves =
  Subgoal.FOCUS (fn {context, prems, ...} =>
  let
    val witnesses = Locale.get_witnesses context
    val subst_thm = hd (witnesses RL [fold_atom])
    val subst_thms = prems RL [subst_thm]
    val folds = witnesses RL folds
    val to_leaves_thm = hd (witnesses RL [closure])
  in
    DETERM
      (Method.insert_tac subst_thms 1
      THEN REPEAT (etac @{thm ssubst} 1)
      THEN asm_full_simp_tac (HOL_basic_ss addsimps folds) 1)
    THEN (if leaves then rtac to_leaves_thm 1 else all_tac)
  end)

val dioid_term_fold_tac =
  term_fold_tac @{thm dioid.term_fold_atom} @{thms dioid.term_unfold.simps[symmetric]} @{thm dioid.term_closure}

*}

method_setup dioid_closure = {*
Scan.succeed (fn ctxt =>
  let
    val witnesses = Locale.get_witnesses ctxt
    val unfolds = witnesses RL @{thms dioid.term_atoms.simps}
  in
    METHOD (fn _ =>
      dioid_term_fold_tac true ctxt 1
      THEN asm_full_simp_tac (@{simpset} addsimps unfolds) 1)
  end)
*}

lemma (in dioid) "\<lbrakk>y\<cdot>y \<in> carrier A; x \<in> carrier A\<rbrakk> \<Longrightarrow> x + x + y\<cdot>y \<in> carrier A"
  by dioid_closure

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

fun pairs :: "'t list => (('t, 't) pair) list" where
"pairs (nil2) = nil2"
| "pairs (cons2 y (nil2)) = nil2"
| "pairs (cons2 y (cons2 y2 xs)) = cons2 (pair2 y y2) (pairs xs)"

fun map :: "('a => 'b) => 'a list => 'b list" where
"map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (nil2) = nil2"
| "evens (cons2 y xs) = cons2 y (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 y xs) = evens xs"
by pat_completeness auto

theorem property0 :
  "((map
       (% (x :: ('a, 'a) pair) => (case x of pair2 y z => z))
       (pairs xs)) =
      (odds xs))"
  oops

end


(*  Title:      HOL/HOLCF/ConvexPD.thy
    Author:     Brian Huffman
*)

section \<open>Convex powerdomain\<close>

theory ConvexPD
imports UpperPD LowerPD
begin

subsection \<open>Basis preorder\<close>

definition
  convex_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<natural>" 50) where
  "convex_le = (\<lambda>u v. u \<le>\<sharp> v \<and> u \<le>\<flat> v)"

lemma convex_le_refl [simp]: "t \<le>\<natural> t"
unfolding convex_le_def by (fast intro: upper_le_refl lower_le_refl)

lemma convex_le_trans: "\<lbrakk>t \<le>\<natural> u; u \<le>\<natural> v\<rbrakk> \<Longrightarrow> t \<le>\<natural> v"
unfolding convex_le_def by (fast intro: upper_le_trans lower_le_trans)

interpretation convex_le: preorder convex_le
by (rule preorder.intro, rule convex_le_refl, rule convex_le_trans)

lemma upper_le_minimal [simp]: "PDUnit compact_bot \<le>\<natural> t"
unfolding convex_le_def Rep_PDUnit by simp

lemma PDUnit_convex_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<natural> PDUnit y"
unfolding convex_le_def by (fast intro: PDUnit_upper_mono PDUnit_lower_mono)

lemma PDPlus_convex_mono: "\<lbrakk>s \<le>\<natural> t; u \<le>\<natural> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<natural> PDPlus t v"
unfolding convex_le_def by (fast intro: PDPlus_upper_mono PDPlus_lower_mono)

lemma convex_le_PDUnit_PDUnit_iff [simp]:
  "(PDUnit a \<le>\<natural> PDUnit b) = (a \<sqsubseteq> b)"
unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit by fast

lemma convex_le_PDUnit_lemma1:
  "(PDUnit a \<le>\<natural> t) = (\<forall>b\<in>Rep_pd_basis t. a \<sqsubseteq> b)"
unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit
using Rep_pd_basis_nonempty [of t, folded ex_in_conv] by fast

lemma convex_le_PDUnit_PDPlus_iff [simp]:
  "(PDUnit a \<le>\<natural> PDPlus t u) = (PDUnit a \<le>\<natural> t \<and> PDUnit a \<le>\<natural> u)"
unfolding convex_le_PDUnit_lemma1 Rep_PDPlus by fast

lemma convex_le_PDUnit_lemma2:
  "(t \<le>\<natural> PDUnit b) = (\<forall>a\<in>Rep_pd_basis t. a \<sqsubseteq> b)"
unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit
using Rep_pd_basis_nonempty [of t, folded ex_in_conv] by fast

lemma convex_le_PDPlus_PDUnit_iff [simp]:
  "(PDPlus t u \<le>\<natural> PDUnit a) = (t \<le>\<natural> PDUnit a \<and> u \<le>\<natural> PDUnit a)"
unfolding convex_le_PDUnit_lemma2 Rep_PDPlus by fast

lemma convex_le_PDPlus_lemma:
  assumes z: "PDPlus t u \<le>\<natural> z"
  shows "\<exists>v w. z = PDPlus v w \<and> t \<le>\<natural> v \<and> u \<le>\<natural> w"
proof (intro exI conjI)
  let ?A = "{b\<in>Rep_pd_basis z. \<exists>a\<in>Rep_pd_basis t. a \<sqsubseteq> b}"
  let ?B = "{b\<in>Rep_pd_basis z. \<exists>a\<in>Rep_pd_basis u. a \<sqsubseteq> b}"
  let ?v = "Abs_pd_basis ?A"
  let ?w = "Abs_pd_basis ?B"
  have Rep_v: "Rep_pd_basis ?v = ?A"
    apply (rule Abs_pd_basis_inverse)
    apply (rule Rep_pd_basis_nonempty [of t, folded ex_in_conv, THEN exE])
    apply (cut_tac z, simp only: convex_le_def lower_le_def, clarify)
    apply (drule_tac x=x in bspec, simp add: Rep_PDPlus, erule bexE)
    apply (simp add: pd_basis_def)
    apply fast
    done
  have Rep_w: "Rep_pd_basis ?w = ?B"
    apply (rule Abs_pd_basis_inverse)
    apply (rule Rep_pd_basis_nonempty [of u, folded ex_in_conv, THEN exE])
    apply (cut_tac z, simp only: convex_le_def lower_le_def, clarify)
    apply (drule_tac x=x in bspec, simp add: Rep_PDPlus, erule bexE)
    apply (simp add: pd_basis_def)
    apply fast
    done
  show "z = PDPlus ?v ?w"
    apply (insert z)
    apply (simp add: convex_le_def, erule conjE)
    apply (simp add: Rep_pd_basis_inject [symmetric] Rep_PDPlus)
    apply (simp add: Rep_v Rep_w)
    apply (rule equalityI)
     apply (rule subsetI)
     apply (simp only: upper_le_def)
     apply (drule (1) bspec, erule bexE)
     apply (simp add: Rep_PDPlus)
     apply fast
    apply fast
    done
  show "t \<le>\<natural> ?v" "u \<le>\<natural> ?w"
   apply (insert z)
   apply (simp_all add: convex_le_def upper_le_def lower_le_def Rep_PDPlus Rep_v Rep_w)
   apply fast+
   done
qed

lemma convex_le_induct [induct set: convex_le]:
  assumes le: "t \<le>\<natural> u"
  assumes 2: "\<And>t u v. \<lbrakk>P t u; P u v\<rbrakk> \<Longrightarrow> P t v"
  assumes 3: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
  assumes 4: "\<And>t u v w. \<lbrakk>P t v; P u w\<rbrakk> \<Longrightarrow> P (PDPlus t u) (PDPlus v w)"
  shows "P t u"
using le apply (induct t arbitrary: u rule: pd_basis_induct)
apply (erule rev_mp)
apply (induct_tac u rule: pd_basis_induct1)
apply (simp add: 3)
apply (simp, clarify, rename_tac a b t)
apply (subgoal_tac "P (PDPlus (PDUnit a) (PDUnit a)) (PDPlus (PDUnit b) t)")
apply (simp add: PDPlus_absorb)
apply (erule (1) 4 [OF 3])
apply (drule convex_le_PDPlus_lemma, clarify)
apply (simp add: 4)
done

subsection \<open>Type definition\<close>

typedef 'a convex_pd  ("('(_')\<natural>)") =
  "{S::'a pd_basis set. convex_le.ideal S}"
by (rule convex_le.ex_ideal)

instantiation convex_pd :: (bifinite) below
begin

definition
  "x \<sqsubseteq> y \<longleftrightarrow> Rep_convex_pd x \<subseteq> Rep_convex_pd y"

instance ..
end

instance convex_pd :: (bifinite) po
using type_definition_convex_pd below_convex_pd_def
by (rule convex_le.typedef_ideal_po)

instance convex_pd :: (bifinite) cpo
using type_definition_convex_pd below_convex_pd_def
by (rule convex_le.typedef_ideal_cpo)

definition
  convex_principal :: "'a pd_basis \<Rightarrow> 'a convex_pd" where
  "convex_principal t = Abs_convex_pd {u. u \<le>\<natural> t}"

interpretation convex_pd:
  ideal_completion convex_le convex_principal Rep_convex_pd
using type_definition_convex_pd below_convex_pd_def
using convex_principal_def pd_basis_countable
by (rule convex_le.typedef_ideal_completion)

text \<open>Convex powerdomain is pointed\<close>

lemma convex_pd_minimal: "convex_principal (PDUnit compact_bot) \<sqsubseteq> ys"
by (induct ys rule: convex_pd.principal_induct, simp, simp)

instance convex_pd :: (bifinite) pcpo
by intro_classes (fast intro: convex_pd_minimal)

lemma inst_convex_pd_pcpo: "\<bottom> = convex_principal (PDUnit compact_bot)"
by (rule convex_pd_minimal [THEN bottomI, symmetric])

subsection \<open>Monadic unit and plus\<close>

definition
  convex_unit :: "'a \<rightarrow> 'a convex_pd" where
  "convex_unit = compact_basis.extension (\<lambda>a. convex_principal (PDUnit a))"

definition
  convex_plus :: "'a convex_pd \<rightarrow> 'a convex_pd \<rightarrow> 'a convex_pd" where
  "convex_plus = convex_pd.extension (\<lambda>t. convex_pd.extension (\<lambda>u.
      convex_principal (PDPlus t u)))"

abbreviation
  convex_add :: "'a convex_pd \<Rightarrow> 'a convex_pd \<Rightarrow> 'a convex_pd"
    (infixl "\<union>\<natural>" 65) where
  "xs \<union>\<natural> ys == convex_plus\<cdot>xs\<cdot>ys"

syntax
  "_convex_pd" :: "args \<Rightarrow> logic" ("{_}\<natural>")

translations
  "{x,xs}\<natural>" == "{x}\<natural> \<union>\<natural> {xs}\<natural>"
  "{x}\<natural>" == "CONST convex_unit\<cdot>x"

lemma convex_unit_Rep_compact_basis [simp]:
  "{Rep_compact_basis a}\<natural> = convex_principal (PDUnit a)"
unfolding convex_unit_def
by (simp add: compact_basis.extension_principal PDUnit_convex_mono)

lemma convex_plus_principal [simp]:
  "convex_principal t \<union>\<natural> convex_principal u = convex_principal (PDPlus t u)"
unfolding convex_plus_def
by (simp add: convex_pd.extension_principal
    convex_pd.extension_mono PDPlus_convex_mono)

interpretation convex_add: semilattice convex_add proof
  fix xs ys zs :: "'a convex_pd"
  show "(xs \<union>\<natural> ys) \<union>\<natural> zs = xs \<union>\<natural> (ys \<union>\<natural> zs)"
    apply (induct xs rule: convex_pd.principal_induct, simp)
    apply (induct ys rule: convex_pd.principal_induct, simp)
    apply (induct zs rule: convex_pd.principal_induct, simp)
    apply (simp add: PDPlus_assoc)
    done
  show "xs \<union>\<natural> ys = ys \<union>\<natural> xs"
    apply (induct xs rule: convex_pd.principal_induct, simp)
    apply (induct ys rule: convex_pd.principal_induct, simp)
    apply (simp add: PDPlus_commute)
    done
  show "xs \<union>\<natural> xs = xs"
    apply (induct xs rule: convex_pd.principal_induct, simp)
    apply (simp add: PDPlus_absorb)
    done
qed

lemmas convex_plus_assoc = convex_add.assoc
lemmas convex_plus_commute = convex_add.commute
lemmas convex_plus_absorb = convex_add.idem
lemmas convex_plus_left_commute = convex_add.left_commute
lemmas convex_plus_left_absorb = convex_add.left_idem

text \<open>Useful for \<open>simp add: convex_plus_ac\<close>\<close>
lemmas convex_plus_ac =
  convex_plus_assoc convex_plus_commute convex_plus_left_commute

text \<open>Useful for \<open>simp only: convex_plus_aci\<close>\<close>
lemmas convex_plus_aci =
  convex_plus_ac convex_plus_absorb convex_plus_left_absorb

lemma convex_unit_below_plus_iff [simp]:
  "{x}\<natural> \<sqsubseteq> ys \<union>\<natural> zs \<longleftrightarrow> {x}\<natural> \<sqsubseteq> ys \<and> {x}\<natural> \<sqsubseteq> zs"
apply (induct x rule: compact_basis.principal_induct, simp)
apply (induct ys rule: convex_pd.principal_induct, simp)
apply (induct zs rule: convex_pd.principal_induct, simp)
apply simp
done

lemma convex_plus_below_unit_iff [simp]:
  "xs \<union>\<natural> ys \<sqsubseteq> {z}\<natural> \<longleftrightarrow> xs \<sqsubseteq> {z}\<natural> \<and> ys \<sqsubseteq> {z}\<natural>"
apply (induct xs rule: convex_pd.principal_induct, simp)
apply (induct ys rule: convex_pd.principal_induct, simp)
apply (induct z rule: compact_basis.principal_induct, simp)
apply simp
done

lemma convex_unit_below_iff [simp]: "{x}\<natural> \<sqsubseteq> {y}\<natural> \<longleftrightarrow> x \<sqsubseteq> y"
apply (induct x rule: compact_basis.principal_induct, simp)
apply (induct y rule: compact_basis.principal_induct, simp)
apply simp
done

lemma convex_unit_eq_iff [simp]: "{x}\<natural> = {y}\<natural> \<longleftrightarrow> x = y"
unfolding po_eq_conv by simp

lemma convex_unit_strict [simp]: "{\<bottom>}\<natural> = \<bottom>"
using convex_unit_Rep_compact_basis [of compact_bot]
by (simp add: inst_convex_pd_pcpo)

lemma convex_unit_bottom_iff [simp]: "{x}\<natural> = \<bottom> \<longleftrightarrow> x = \<bottom>"
unfolding convex_unit_strict [symmetric] by (rule convex_unit_eq_iff)

lemma compact_convex_unit: "compact x \<Longrightarrow> compact {x}\<natural>"
by (auto dest!: compact_basis.compact_imp_principal)

lemma compact_convex_unit_iff [simp]: "compact {x}\<natural> \<longleftrightarrow> compact x"
apply (safe elim!: compact_convex_unit)
apply (simp only: compact_def convex_unit_below_iff [symmetric])
apply (erule adm_subst [OF cont_Rep_cfun2])
done

lemma compact_convex_plus [simp]:
  "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs \<union>\<natural> ys)"
by (auto dest!: convex_pd.compact_imp_principal)

subsection \<open>Induction rules\<close>

lemma convex_pd_induct1:
  assumes P: "adm P"
  assumes unit: "\<And>x. P {x}\<natural>"
  assumes insert: "\<And>x ys. \<lbrakk>P {x}\<natural>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<natural> \<union>\<natural> ys)"
  shows "P (xs::'a convex_pd)"
apply (induct xs rule: convex_pd.principal_induct, rule P)
apply (induct_tac a rule: pd_basis_induct1)
apply (simp only: convex_unit_Rep_compact_basis [symmetric])
apply (rule unit)
apply (simp only: convex_unit_Rep_compact_basis [symmetric]
                  convex_plus_principal [symmetric])
apply (erule insert [OF unit])
done

lemma convex_pd_induct
  [case_names adm convex_unit convex_plus, induct type: convex_pd]:
  assumes P: "adm P"
  assumes unit: "\<And>x. P {x}\<natural>"
  assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs \<union>\<natural> ys)"
  shows "P (xs::'a convex_pd)"
apply (induct xs rule: convex_pd.principal_induct, rule P)
apply (induct_tac a rule: pd_basis_induct)
apply (simp only: convex_unit_Rep_compact_basis [symmetric] unit)
apply (simp only: convex_plus_principal [symmetric] plus)
done

subsection \<open>Monadic bind\<close>

definition
  convex_bind_basis ::
  "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b convex_pd) \<rightarrow> 'b convex_pd" where
  "convex_bind_basis = fold_pd
    (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
    (\<lambda>x y. \<Lambda> f. x\<cdot>f \<union>\<natural> y\<cdot>f)"

lemma ACI_convex_bind:
  "semilattice (\<lambda>x y. \<Lambda> f. x\<cdot>f \<union>\<natural> y\<cdot>f)"
apply unfold_locales
apply (simp add: convex_plus_assoc)
apply (simp add: convex_plus_commute)
apply (simp add: eta_cfun)
done

lemma convex_bind_basis_simps [simp]:
  "convex_bind_basis (PDUnit a) =
    (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
  "convex_bind_basis (PDPlus t u) =
    (\<Lambda> f. convex_bind_basis t\<cdot>f \<union>\<natural> convex_bind_basis u\<cdot>f)"
unfolding convex_bind_basis_def
apply -
apply (rule fold_pd_PDUnit [OF ACI_convex_bind])
apply (rule fold_pd_PDPlus [OF ACI_convex_bind])
done

lemma convex_bind_basis_mono:
  "t \<le>\<natural> u \<Longrightarrow> convex_bind_basis t \<sqsubseteq> convex_bind_basis u"
apply (erule convex_le_induct)
apply (erule (1) below_trans)
apply (simp add: monofun_LAM monofun_cfun)
apply (simp add: monofun_LAM monofun_cfun)
done

definition
  convex_bind :: "'a convex_pd \<rightarrow> ('a \<rightarrow> 'b convex_pd) \<rightarrow> 'b convex_pd" where
  "convex_bind = convex_pd.extension convex_bind_basis"

syntax
  "_convex_bind" :: "[logic, logic, logic] \<Rightarrow> logic"
    ("(3\<Union>\<natural>_\<in>_./ _)" [0, 0, 10] 10)

translations
  "\<Union>\<natural>x\<in>xs. e" == "CONST convex_bind\<cdot>xs\<cdot>(\<Lambda> x. e)"

lemma convex_bind_principal [simp]:
  "convex_bind\<cdot>(convex_principal t) = convex_bind_basis t"
unfolding convex_bind_def
apply (rule convex_pd.extension_principal)
apply (erule convex_bind_basis_mono)
done

lemma convex_bind_unit [simp]:
  "convex_bind\<cdot>{x}\<natural>\<cdot>f = f\<cdot>x"
by (induct x rule: compact_basis.principal_induct, simp, simp)

lemma convex_bind_plus [simp]:
  "convex_bind\<cdot>(xs \<union>\<natural> ys)\<cdot>f = convex_bind\<cdot>xs\<cdot>f \<union>\<natural> convex_bind\<cdot>ys\<cdot>f"
by (induct xs rule: convex_pd.principal_induct, simp,
    induct ys rule: convex_pd.principal_induct, simp, simp)

lemma convex_bind_strict [simp]: "convex_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
unfolding convex_unit_strict [symmetric] by (rule convex_bind_unit)

lemma convex_bind_bind:
  "convex_bind\<cdot>(convex_bind\<cdot>xs\<cdot>f)\<cdot>g =
    convex_bind\<cdot>xs\<cdot>(\<Lambda> x. convex_bind\<cdot>(f\<cdot>x)\<cdot>g)"
by (induct xs, simp_all)

subsection \<open>Map\<close>

definition
  convex_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a convex_pd \<rightarrow> 'b convex_pd" where
  "convex_map = (\<Lambda> f xs. convex_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<natural>))"

lemma convex_map_unit [simp]:
  "convex_map\<cdot>f\<cdot>{x}\<natural> = {f\<cdot>x}\<natural>"
unfolding convex_map_def by simp

lemma convex_map_plus [simp]:
  "convex_map\<cdot>f\<cdot>(xs \<union>\<natural> ys) = convex_map\<cdot>f\<cdot>xs \<union>\<natural> convex_map\<cdot>f\<cdot>ys"
unfolding convex_map_def by simp

lemma convex_map_bottom [simp]: "convex_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<natural>"
unfolding convex_map_def by simp

lemma convex_map_ident: "convex_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
by (induct xs rule: convex_pd_induct, simp_all)

lemma convex_map_ID: "convex_map\<cdot>ID = ID"
by (simp add: cfun_eq_iff ID_def convex_map_ident)

lemma convex_map_map:
  "convex_map\<cdot>f\<cdot>(convex_map\<cdot>g\<cdot>xs) = convex_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
by (induct xs rule: convex_pd_induct, simp_all)

lemma convex_bind_map:
  "convex_bind\<cdot>(convex_map\<cdot>f\<cdot>xs)\<cdot>g = convex_bind\<cdot>xs\<cdot>(\<Lambda> x. g\<cdot>(f\<cdot>x))"
by (simp add: convex_map_def convex_bind_bind)

lemma convex_map_bind:
  "convex_map\<cdot>f\<cdot>(convex_bind\<cdot>xs\<cdot>g) = convex_bind\<cdot>xs\<cdot>(\<Lambda> x. convex_map\<cdot>f\<cdot>(g\<cdot>x))"
by (simp add: convex_map_def convex_bind_bind)

lemma ep_pair_convex_map: "ep_pair e p \<Longrightarrow> ep_pair (convex_map\<cdot>e) (convex_map\<cdot>p)"
apply standard
apply (induct_tac x rule: convex_pd_induct, simp_all add: ep_pair.e_inverse)
apply (induct_tac y rule: convex_pd_induct)
apply (simp_all add: ep_pair.e_p_below monofun_cfun)
done

lemma deflation_convex_map: "deflation d \<Longrightarrow> deflation (convex_map\<cdot>d)"
apply standard
apply (induct_tac x rule: convex_pd_induct, simp_all add: deflation.idem)
apply (induct_tac x rule: convex_pd_induct)
apply (simp_all add: deflation.below monofun_cfun)
done

(* FIXME: long proof! *)
lemma finite_deflation_convex_map:
  assumes "finite_deflation d" shows "finite_deflation (convex_map\<cdot>d)"
proof (rule finite_deflation_intro)
  interpret d: finite_deflation d by fact
  from d.deflation_axioms show "deflation (convex_map\<cdot>d)"
    by (rule deflation_convex_map)
  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
  hence *: "finite (convex_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
  hence "finite (range (\<lambda>xs. convex_map\<cdot>d\<cdot>xs))"
    apply (rule rev_finite_subset)
    apply clarsimp
    apply (induct_tac xs rule: convex_pd.principal_induct)
    apply (simp add: adm_mem_finite *)
    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
    apply (simp only: convex_unit_Rep_compact_basis [symmetric] convex_map_unit)
    apply simp
    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
    apply clarsimp
    apply (rule imageI)
    apply (rule vimageI2)
    apply (simp add: Rep_PDUnit)
    apply (rule range_eqI)
    apply (erule sym)
    apply (rule exI)
    apply (rule Abs_compact_basis_inverse [symmetric])
    apply (simp add: d.compact)
    apply (simp only: convex_plus_principal [symmetric] convex_map_plus)
    apply clarsimp
    apply (rule imageI)
    apply (rule vimageI2)
    apply (simp add: Rep_PDPlus)
    done
  thus "finite {xs. convex_map\<cdot>d\<cdot>xs = xs}"
    by (rule finite_range_imp_finite_fixes)
qed

subsection \<open>Convex powerdomain is bifinite\<close>

lemma approx_chain_convex_map:
  assumes "approx_chain a"
  shows "approx_chain (\<lambda>i. convex_map\<cdot>(a i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP convex_map_ID finite_deflation_convex_map)

instance convex_pd :: (bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> 'a convex_pd \<rightarrow> 'a convex_pd). approx_chain a"
    using bifinite [where 'a='a]
    by (fast intro!: approx_chain_convex_map)
qed

subsection \<open>Join\<close>

definition
  convex_join :: "'a convex_pd convex_pd \<rightarrow> 'a convex_pd" where
  "convex_join = (\<Lambda> xss. convex_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"

lemma convex_join_unit [simp]:
  "convex_join\<cdot>{xs}\<natural> = xs"
unfolding convex_join_def by simp

lemma convex_join_plus [simp]:
  "convex_join\<cdot>(xss \<union>\<natural> yss) = convex_join\<cdot>xss \<union>\<natural> convex_join\<cdot>yss"
unfolding convex_join_def by simp

lemma convex_join_bottom [simp]: "convex_join\<cdot>\<bottom> = \<bottom>"
unfolding convex_join_def by simp

lemma convex_join_map_unit:
  "convex_join\<cdot>(convex_map\<cdot>convex_unit\<cdot>xs) = xs"
by (induct xs rule: convex_pd_induct, simp_all)

lemma convex_join_map_join:
  "convex_join\<cdot>(convex_map\<cdot>convex_join\<cdot>xsss) = convex_join\<cdot>(convex_join\<cdot>xsss)"
by (induct xsss rule: convex_pd_induct, simp_all)

lemma convex_join_map_map:
  "convex_join\<cdot>(convex_map\<cdot>(convex_map\<cdot>f)\<cdot>xss) =
   convex_map\<cdot>f\<cdot>(convex_join\<cdot>xss)"
by (induct xss rule: convex_pd_induct, simp_all)

subsection \<open>Conversions to other powerdomains\<close>

text \<open>Convex to upper\<close>

lemma convex_le_imp_upper_le: "t \<le>\<natural> u \<Longrightarrow> t \<le>\<sharp> u"
unfolding convex_le_def by simp

definition
  convex_to_upper :: "'a convex_pd \<rightarrow> 'a upper_pd" where
  "convex_to_upper = convex_pd.extension upper_principal"

lemma convex_to_upper_principal [simp]:
  "convex_to_upper\<cdot>(convex_principal t) = upper_principal t"
unfolding convex_to_upper_def
apply (rule convex_pd.extension_principal)
apply (rule upper_pd.principal_mono)
apply (erule convex_le_imp_upper_le)
done

lemma convex_to_upper_unit [simp]:
  "convex_to_upper\<cdot>{x}\<natural> = {x}\<sharp>"
by (induct x rule: compact_basis.principal_induct, simp, simp)

lemma convex_to_upper_plus [simp]:
  "convex_to_upper\<cdot>(xs \<union>\<natural> ys) = convex_to_upper\<cdot>xs \<union>\<sharp> convex_to_upper\<cdot>ys"
by (induct xs rule: convex_pd.principal_induct, simp,
    induct ys rule: convex_pd.principal_induct, simp, simp)

lemma convex_to_upper_bind [simp]:
  "convex_to_upper\<cdot>(convex_bind\<cdot>xs\<cdot>f) =
    upper_bind\<cdot>(convex_to_upper\<cdot>xs)\<cdot>(convex_to_upper oo f)"
by (induct xs rule: convex_pd_induct, simp, simp, simp)

lemma convex_to_upper_map [simp]:
  "convex_to_upper\<cdot>(convex_map\<cdot>f\<cdot>xs) = upper_map\<cdot>f\<cdot>(convex_to_upper\<cdot>xs)"
by (simp add: convex_map_def upper_map_def cfcomp_LAM)

lemma convex_to_upper_join [simp]:
  "convex_to_upper\<cdot>(convex_join\<cdot>xss) =
    upper_bind\<cdot>(convex_to_upper\<cdot>xss)\<cdot>convex_to_upper"
by (simp add: convex_join_def upper_join_def cfcomp_LAM eta_cfun)

text \<open>Convex to lower\<close>

lemma convex_le_imp_lower_le: "t \<le>\<natural> u \<Longrightarrow> t \<le>\<flat> u"
unfolding convex_le_def by simp

definition
  convex_to_lower :: "'a convex_pd \<rightarrow> 'a lower_pd" where
  "convex_to_lower = convex_pd.extension lower_principal"

lemma convex_to_lower_principal [simp]:
  "convex_to_lower\<cdot>(convex_principal t) = lower_principal t"
unfolding convex_to_lower_def
apply (rule convex_pd.extension_principal)
apply (rule lower_pd.principal_mono)
apply (erule convex_le_imp_lower_le)
done

lemma convex_to_lower_unit [simp]:
  "convex_to_lower\<cdot>{x}\<natural> = {x}\<flat>"
by (induct x rule: compact_basis.principal_induct, simp, simp)

lemma convex_to_lower_plus [simp]:
  "convex_to_lower\<cdot>(xs \<union>\<natural> ys) = convex_to_lower\<cdot>xs \<union>\<flat> convex_to_lower\<cdot>ys"
by (induct xs rule: convex_pd.principal_induct, simp,
    induct ys rule: convex_pd.principal_induct, simp, simp)

lemma convex_to_lower_bind [simp]:
  "convex_to_lower\<cdot>(convex_bind\<cdot>xs\<cdot>f) =
    lower_bind\<cdot>(convex_to_lower\<cdot>xs)\<cdot>(convex_to_lower oo f)"
by (induct xs rule: convex_pd_induct, simp, simp, simp)

lemma convex_to_lower_map [simp]:
  "convex_to_lower\<cdot>(convex_map\<cdot>f\<cdot>xs) = lower_map\<cdot>f\<cdot>(convex_to_lower\<cdot>xs)"
by (simp add: convex_map_def lower_map_def cfcomp_LAM)

lemma convex_to_lower_join [simp]:
  "convex_to_lower\<cdot>(convex_join\<cdot>xss) =
    lower_bind\<cdot>(convex_to_lower\<cdot>xss)\<cdot>convex_to_lower"
by (simp add: convex_join_def lower_join_def cfcomp_LAM eta_cfun)

text \<open>Ordering property\<close>

lemma convex_pd_below_iff:
  "(xs \<sqsubseteq> ys) =
    (convex_to_upper\<cdot>xs \<sqsubseteq> convex_to_upper\<cdot>ys \<and>
     convex_to_lower\<cdot>xs \<sqsubseteq> convex_to_lower\<cdot>ys)"
apply (induct xs rule: convex_pd.principal_induct, simp)
apply (induct ys rule: convex_pd.principal_induct, simp)
apply (simp add: convex_le_def)
done

lemmas convex_plus_below_plus_iff =
  convex_pd_below_iff [where xs="xs \<union>\<natural> ys" and ys="zs \<union>\<natural> ws"]
  for xs ys zs ws

lemmas convex_pd_below_simps =
  convex_unit_below_plus_iff
  convex_plus_below_unit_iff
  convex_plus_below_plus_iff
  convex_unit_below_iff
  convex_to_upper_unit
  convex_to_upper_plus
  convex_to_lower_unit
  convex_to_lower_plus
  upper_pd_below_simps
  lower_pd_below_simps

end


section {*fixed\_point\_iterator*}
theory
  fixed_point_iterator

imports
  PRJ_05__ENTRY

begin

definition UNIVmap :: "'a \<Rightarrow> bool" where
  "UNIVmap \<equiv> \<lambda>x. True"

definition predicate_AND :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" where
  "predicate_AND F1 F2 = (\<lambda>x. F1 x \<and> F2 x)"

definition predicate_OR :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" where
  "predicate_OR F1 F2 = (\<lambda>x. F1 x \<or> F2 x)"

declare UNIVmap_def [simp add]
declare predicate_AND_def [simp add]
declare predicate_OR_def [simp add]

lemma GFP_SOUND_le_trans: "
  p\<le>(q::'a::order)
  \<Longrightarrow> q\<le>r
  \<Longrightarrow> p\<le>r"
  apply(rule order_trans_rules)
    apply(force)
   apply(force)
  apply(rename_tac x y)(*strict*)
  apply(force)
  done

definition Fixed_Point_Iterator :: "
  ('a::order \<Rightarrow> 'a)
  \<Rightarrow> 'a set
  \<Rightarrow> 'a set
  \<Rightarrow> 'a set
  \<Rightarrow> bool"
  where
    "Fixed_Point_Iterator F Qinp Qterm Qout \<equiv>
  \<forall>X \<in> Qinp. \<forall>Y \<in> Qinp.
     F X \<le> X
  \<and> (X \<le> Y \<longrightarrow> F X \<le> F Y)
  \<and> F X \<in> Qout
  \<and> (X \<in> Qterm \<longleftrightarrow> F X = X)"

definition Characteristic_Fixed_Point_Iterator :: "
  ('a::order \<Rightarrow> 'a)
  \<Rightarrow> ('a \<Rightarrow> bool)
  \<Rightarrow> ('a \<Rightarrow> bool)
  \<Rightarrow> ('a \<Rightarrow> bool)
  \<Rightarrow> bool"
  where
    "Characteristic_Fixed_Point_Iterator F Qinp Qterm Qout \<equiv>
  (\<forall>X \<in> Collect Qinp. F X \<le> X)
  \<and> (\<forall>X \<in> Collect Qinp. Qterm X \<longleftrightarrow> F X = X)
  \<and> (\<forall>X \<in> Collect Qinp. Qout (F X))
  \<and> (\<forall>X \<in> Collect Qinp. \<forall>Y \<in> Collect Qinp. X \<le> Y \<longrightarrow> F X \<le> F Y)"

corollary Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator1: "
  Fixed_Point_Iterator F (Collect Qinp) (Collect Qterm) (Collect Qout)
  = Characteristic_Fixed_Point_Iterator F Qinp Qterm Qout"
  apply(simp add: Characteristic_Fixed_Point_Iterator_def Fixed_Point_Iterator_def)
  apply(rule antisym)
   apply(force)
  apply(force)
  done

corollary Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator2: "
  Characteristic_Fixed_Point_Iterator F (\<lambda>x. x\<in> Qinp) (\<lambda>x. x\<in> Qterm) (\<lambda>x. x\<in> Qout)
  = Fixed_Point_Iterator F Qinp Qterm Qout"
  apply(simp add: Characteristic_Fixed_Point_Iterator_def Fixed_Point_Iterator_def)
  apply(rule antisym)
   apply(force)
  apply(force)
  done

lemma Characteristic_Fixed_Point_Iterator_does_not_skip_Fixed_Points: "
  Characteristic_Fixed_Point_Iterator F Qinp Qterm Qout
  \<Longrightarrow>
  (\<forall>X \<in> Collect Qinp. \<forall>Y \<in> Collect Qinp. F X < X \<longrightarrow> Y < X \<longrightarrow> F Y = Y \<longrightarrow> Y \<le> F X)"
  apply(simp add: Characteristic_Fixed_Point_Iterator_def)
  apply(force)
  done

theorem Fixed_Point_Iterator_does_not_skip_Fixed_Points: "
  Fixed_Point_Iterator F Qinp Qterm Qout
  \<Longrightarrow> X \<in> Qinp
  \<Longrightarrow> Y \<in> Qinp
  \<Longrightarrow> F X < X
  \<Longrightarrow> Y < X
  \<Longrightarrow> F Y = Y
  \<Longrightarrow> Y \<le> F X"
  apply(simp add: Fixed_Point_Iterator_def)
  apply(force)
  done

definition Characteristic_Fixed_Point_IteratorDec :: "('a::complete_lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "Characteristic_Fixed_Point_IteratorDec F Qinp Qterm Qout \<equiv> (
  (\<forall>X. F X \<le> X)
  \<and> (\<forall>X\<in> Collect Qinp. Qterm X \<longleftrightarrow> (F X = X))
  \<and> (\<forall>X\<in> Collect Qinp. Qout (F X))
  \<and> (\<forall>X. \<forall>Y. X \<le> Y \<longrightarrow> F X \<le> F Y))"

lemma Characteristic_Fixed_Point_Iterator_to_Characteristic_Fixed_Point_IteratorDec: "
  Characteristic_Fixed_Point_Iterator F Qinp Qterm Qout
  \<Longrightarrow> (\<And>C. \<not>Qinp C \<Longrightarrow> F C \<le> C)
  \<Longrightarrow> (\<forall>X. \<forall>Y. X \<le> Y \<longrightarrow> F X \<le> F Y)
  \<Longrightarrow> Characteristic_Fixed_Point_IteratorDec F Qinp Qterm Qout"
  apply(simp add: Characteristic_Fixed_Point_IteratorDec_def Characteristic_Fixed_Point_Iterator_def)
  apply(clarsimp)
  apply(rename_tac X)(*strict*)
  apply(erule_tac
      x="X"
      in allE)+
  apply(clarsimp)
  done

lemma Characteristic_Fixed_Point_IteratorDec_to_Characteristic_Fixed_Point_Iterator: "
  Characteristic_Fixed_Point_IteratorDec F Qinp Qterm Qout
  \<Longrightarrow> Characteristic_Fixed_Point_Iterator F Qinp Qterm Qout"
  apply(simp add: Characteristic_Fixed_Point_IteratorDec_def Characteristic_Fixed_Point_Iterator_def)
  done

lemma Characteristic_Fixed_Point_Iterator_weakening: "
  Characteristic_Fixed_Point_Iterator F Qinp Qterm Qout
  \<Longrightarrow> Characteristic_Fixed_Point_Iterator F Qinp Qterm UNIVmap"
  apply(simp add: Characteristic_Fixed_Point_Iterator_def)
  done

lemma Characteristic_Fixed_Point_IteratorDec_does_not_skip_Fixed_Points: "
  Characteristic_Fixed_Point_IteratorDec F Qinp Qterm Qout
  \<Longrightarrow>
  (\<forall>X \<in> Collect Qinp. \<forall>Y \<in> Collect Qinp. F X < X \<longrightarrow> Y < X \<longrightarrow> F Y = Y \<longrightarrow> Y \<le> F X)"
  apply (metis Characteristic_Fixed_Point_IteratorDec_to_Characteristic_Fixed_Point_Iterator Characteristic_Fixed_Point_Iterator_does_not_skip_Fixed_Points)
  done

lemma Characteristic_Composition_of_Fixed_Point_Iterators: "
  Characteristic_Fixed_Point_Iterator F1 Qinp Qterm1 Qinter1
  \<Longrightarrow> Characteristic_Fixed_Point_Iterator F2 Qinter2 Qterm2 Qout2
  \<Longrightarrow> (\<And>Q. Qinter1 Q \<longrightarrow> Qinter2 Q )
  \<Longrightarrow> Characteristic_Fixed_Point_Iterator (F2 \<circ> F1) Qinp (predicate_AND Qterm1 Qterm2) Qout2"
  apply(simp (no_asm) add: Characteristic_Fixed_Point_Iterator_def)
  apply(rule context_conjI)
   apply(subgoal_tac "\<forall>X::'a. Qinter1 X \<longrightarrow> F2 X \<le> X")
    prefer 2
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(clarsimp)
   apply(rename_tac X)(*strict*)
   apply(rule_tac
      q="F1 X"
      in GFP_SOUND_le_trans)
    apply(rename_tac X)(*strict*)
    apply(erule_tac
      x="F1 X"
      in allE)
    apply(clarsimp)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(rename_tac X)(*strict*)
   apply(simp add: Characteristic_Fixed_Point_Iterator_def)
  apply(rule context_conjI)
   apply(clarsimp)
   apply(rename_tac X)(*strict*)
   apply(erule_tac
      x="X"
      in allE)
   apply(clarsimp)
   apply(rule order_antisym)
    apply(rename_tac X)(*strict*)
    apply(clarsimp)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
    apply(force)
   apply(rename_tac X)(*strict*)
   apply(clarsimp)
   apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(force)
  apply(rule context_conjI)
   apply(simp add: Characteristic_Fixed_Point_Iterator_def)
  apply(clarsimp)
  apply(rename_tac X Y)(*strict*)
  apply(simp add: Characteristic_Fixed_Point_Iterator_def)
  done

theorem Composition_of_Fixed_Point_Iterators: "
  Fixed_Point_Iterator F1 Qinp Qterm1 Qinter1
  \<Longrightarrow> Fixed_Point_Iterator F2 Qinter2 Qterm2 Qout2
  \<Longrightarrow> Qinter1 \<subseteq> Qinter2
  \<Longrightarrow> Fixed_Point_Iterator (F2 \<circ> F1) Qinp (Qterm1 \<inter> Qterm2) Qout2"
  apply(rule_tac
      t="Fixed_Point_Iterator (F2 \<circ> F1) Qinp (Qterm1 \<inter> Qterm2) Qout2"
      in subst)
   apply(rule Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator2)
  apply(rule_tac
      P="\<lambda>X. X"
      and s="Characteristic_Fixed_Point_Iterator (F2 \<circ> F1) Qinp (predicate_AND Qterm1 Qterm2) Qout2" for Qinp Qterm1 Qterm2 Qout2
      in ssubst)
   apply(force)
  apply(rule_tac
      ?Qinter1.0="\<lambda>x. x \<in> Qinter1"
      and ?Qinter2.0="\<lambda>x. x \<in> Qinter2"
      in Characteristic_Composition_of_Fixed_Point_Iterators)
    apply(rule_tac
      P="\<lambda>X. X"
      in subst)
     apply(rule Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator1)
    apply(rule_tac
      t="{x. x \<in> Qinp}"
      and s="Qinp"
      in ssubst)
     apply(blast)
    apply(rule_tac
      t="{x. x \<in> Qterm1}"
      and s="Qterm1"
      in ssubst)
     apply(blast)
    apply(rule_tac
      t="{x. x \<in> Qinter1}"
      and s="Qinter1"
      in ssubst)
     apply(blast)
    apply(blast)
   apply(rule_tac
      P="\<lambda>X. X"
      in subst)
    apply(rule Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator1)
   apply(rule_tac
      t="{x. x \<in> Qout2}"
      and s="Qout2"
      in ssubst)
    apply(blast)
   apply(rule_tac
      t="{x. x \<in> Qterm2}"
      and s="Qterm2"
      in ssubst)
    apply(blast)
   apply(rule_tac
      t="{x. x \<in> Qinter2}"
      and s="Qinter2"
      in ssubst)
    apply(blast)
   apply(blast)
  apply(rename_tac Q)(*strict*)
  apply(force)
  done

definition ifcomp :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "ifcomp F2 F1 \<equiv> \<lambda>C. if F1 C = C then C else (F2 \<circ> F1)C"

lemma Characteristic_Conditional_Composition_of_Fixed_Point_Iterators: "
  Characteristic_Fixed_Point_Iterator F1 Qinp Qterm1 Qinter1
  \<Longrightarrow> Characteristic_Fixed_Point_Iterator F2 Qinter2 Qterm2 Qout
  \<Longrightarrow> (\<And>Q. Qinter1 Q \<longrightarrow> Qinter2 Q )
  \<Longrightarrow> (\<And>Q. Qinp Q \<and> Qterm1 Q \<longrightarrow> Qterm2 Q)
  \<Longrightarrow> Characteristic_Fixed_Point_Iterator (ifcomp F2 F1) Qinp (\<lambda>C. if F1 C=C then
Qterm1 C\<and>Qinp C else Qterm1 C\<and>Qterm2 C) (predicate_OR (predicate_AND (predicate_AND Qinp Qinter1) Qterm1) Qout)"
  apply(simp (no_asm) add: Characteristic_Fixed_Point_Iterator_def)
  apply(rule context_conjI)
   apply(subgoal_tac "\<forall>X::'a. Qinter1 X \<longrightarrow> F2 X \<le> X")
    prefer 2
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(clarsimp)
   apply(rename_tac X)(*strict*)
   apply(rule_tac
      q="F1 X"
      in GFP_SOUND_le_trans)
    apply(rename_tac X)(*strict*)
    apply(erule_tac
      x="F1 X"
      in allE)
    apply(simp add: ifcomp_def)
    apply(clarsimp)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(rename_tac X)(*strict*)
   apply(simp add: Characteristic_Fixed_Point_Iterator_def)
  apply(rule context_conjI)
   apply(clarsimp)
   apply(rename_tac X)(*strict*)
   apply(case_tac "F1 X = X")
    apply(rename_tac X)(*strict*)
    apply(simp add: ifcomp_def)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(rename_tac X)(*strict*)
   apply(erule_tac
      x="X"
      in allE)
   apply(clarsimp)
   apply(rule order_antisym)
    apply(rename_tac X)(*strict*)
    apply(clarsimp)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(rename_tac X)(*strict*)
   apply(clarsimp)
   apply(simp add: ifcomp_def)
   apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(force)
  apply(rule context_conjI)
   apply(clarsimp)
   apply(rename_tac X)(*strict*)
   apply(case_tac "F1 X = X")
    apply(rename_tac X)(*strict*)
    apply(simp add: ifcomp_def)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
    apply(force)
   apply(rename_tac X)(*strict*)
   apply(simp add: ifcomp_def)
   apply(simp add: Characteristic_Fixed_Point_Iterator_def)
  apply(clarsimp)
  apply(rename_tac X Y)(*strict*)
  apply(case_tac "F1 X = X")
   apply(rename_tac X Y)(*strict*)
   apply(simp add: ifcomp_def)
   apply(clarsimp)
   apply(subgoal_tac "\<forall>X. Qinter2 X \<longrightarrow> (\<forall>Y. Qinter2 Y \<longrightarrow> X \<le> Y \<longrightarrow> F2 X \<le> F2 Y)")
    apply(rename_tac X Y)(*strict*)
    prefer 2
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(rename_tac X Y)(*strict*)
   apply(erule_tac
      x="F1 X"
      and P="\<lambda>x. Qinter2 x \<longrightarrow> (\<forall>Y. Qinter2 Y \<longrightarrow> x \<le> Y \<longrightarrow> F2 x \<le> F2 Y)"
      in allE)
   apply(erule impE)
    apply(rename_tac X Y)(*strict*)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
    apply(force)
   apply(rename_tac X Y)(*strict*)
   apply(erule_tac
      x="F1 Y"
      and P="\<lambda>x. Qinter2 x \<longrightarrow> F1 X \<le> x \<longrightarrow> F2 (F1 X) \<le> F2 x"
      in allE)
   apply(erule impE)
    apply(rename_tac X Y)(*strict*)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(rename_tac X Y)(*strict*)
   apply(erule impE)
    apply(rename_tac X Y)(*strict*)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
    apply(force)
   apply(rename_tac X Y)(*strict*)
   apply(subgoal_tac "(\<forall>X. Qinter2 X \<longrightarrow> Qterm2 X = (F2 X = X))")
    apply(rename_tac X Y)(*strict*)
    prefer 2
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(rename_tac X Y)(*strict*)
   apply(erule_tac
      x="F1 X"
      and P="\<lambda>x. Qinter2 x \<longrightarrow> Qterm2 x = (F2 x = x)"
      in allE)
   apply(erule impE)
    apply(rename_tac X Y)(*strict*)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
    apply(force)
   apply(rename_tac X Y)(*strict*)
   apply(subgoal_tac "Qterm2 (F1 X)")
    apply(rename_tac X Y)(*strict*)
    apply(clarsimp)
   apply(rename_tac X Y)(*strict*)
   apply(force)
  apply(rename_tac X Y)(*strict*)
  apply(simp add: ifcomp_def)
  apply(case_tac "F1 Y=Y")
   apply(rename_tac X Y)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      q="F1 X"
      in GFP_SOUND_le_trans)
    apply(rename_tac X Y)(*strict*)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(rename_tac X Y)(*strict*)
   apply(rule_tac
      q="X"
      in GFP_SOUND_le_trans)
    apply(rename_tac X Y)(*strict*)
    apply(simp add: Characteristic_Fixed_Point_Iterator_def)
   apply(rename_tac X Y)(*strict*)
   apply(force)
  apply(rename_tac X Y)(*strict*)
  apply(clarsimp)
  apply(simp add: Characteristic_Fixed_Point_Iterator_def)
  done

lemma Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator1_proof: "
  P (Fixed_Point_Iterator F (Collect Q1) (Collect Q2) (Collect Q3))
  \<Longrightarrow> P (Characteristic_Fixed_Point_Iterator F Q1 Q2 Q3)"
  apply(simp add: Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator1)
  done

lemma Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator2_proof: "
  P (Characteristic_Fixed_Point_Iterator F (\<lambda>x. x\<in> Qinp) (\<lambda>x. x\<in> Qterm) (\<lambda>x. x\<in> Qout))
  \<Longrightarrow> P (Fixed_Point_Iterator F Qinp Qterm Qout)"
  apply(simp add: Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator2)
  done

theorem Conditional_Composition_of_Fixed_Point_Iterators: "
  Fixed_Point_Iterator F1 Qinp Qterm1 Qinter1
  \<Longrightarrow> Fixed_Point_Iterator F2 Qinter2 Qterm2 Qout
  \<Longrightarrow> Qinter1 \<subseteq> Qinter2
  \<Longrightarrow> Qinp \<inter> Qterm1 \<subseteq> Qterm2
  \<Longrightarrow> Fixed_Point_Iterator
  (ifcomp F2 F1)
  Qinp
  {C. if F1 C=C then C \<in> Qterm1 \<inter> Qinp else C \<in> Qterm1 \<inter> Qterm2}
  ((Qinp \<inter> Qinter1 \<inter> Qterm1) \<union> Qout)"
  apply(rule_tac
      P="\<lambda>X. X"
      in Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator2_proof)
  apply(rule_tac
      P="\<lambda>X. X"
      and s="Characteristic_Fixed_Point_Iterator (ifcomp F2 F1) (\<lambda>x. x \<in> Qinp) (\<lambda>C. if F1 C=C then (\<lambda>x. x \<in> Qterm1) C\<and>(\<lambda>x. x \<in> Qinp) C else (\<lambda>x. x \<in> Qterm1) C\<and>(\<lambda>x. x \<in> Qterm2) C) (predicate_OR (predicate_AND (predicate_AND (\<lambda>x. x \<in> Qinp) (\<lambda>x. x \<in> Qinter1))(\<lambda>x. x \<in> Qterm1)) (\<lambda>x. x \<in> Qout))"
      in subst)
   apply(force)
  apply(rule_tac
      ?Qinter1.0="\<lambda>x. x \<in> Qinter1"
      and ?Qinter2.0="\<lambda>x. x \<in> Qinter2"
      in Characteristic_Conditional_Composition_of_Fixed_Point_Iterators)
     apply(rule_tac
      P="\<lambda>X. X"
      in Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator1_proof)
     apply(force)
    apply(rule_tac
      P="\<lambda>X. X"
      in Characteristic_Fixed_Point_Iterator_equals_Fixed_Point_Iterator1_proof)
    apply(force)
   apply(rename_tac Q)(*strict*)
   apply(force)
  apply(rename_tac Q)(*strict*)
  apply(force)
  done

definition Characteristic_Fixed_Point_IteratorX :: "('a::complete_lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "Characteristic_Fixed_Point_IteratorX F Qterm \<equiv> (
  (\<forall>X. F X \<le> X)
  \<and> (\<forall>X. Qterm X \<longleftrightarrow> (F X = X))
  \<and> (\<forall>X Y. X \<le> Y \<longrightarrow> F X \<le> F Y))"

lemma Characteristic_Fixed_Point_IteratorX_vs_Characteristic_Fixed_Point_Iterator: "
  Characteristic_Fixed_Point_IteratorX F Qterm= Characteristic_Fixed_Point_Iterator F UNIVmap Qterm UNIVmap"
  apply(rule order_antisym)
   apply(simp add: Characteristic_Fixed_Point_IteratorX_def Characteristic_Fixed_Point_Iterator_def)
  apply(simp add: Characteristic_Fixed_Point_IteratorX_def Characteristic_Fixed_Point_Iterator_def)
  done

lemma Characteristic_Fixed_Point_IteratorX_does_not_skip_Fixed_Points: "
  Characteristic_Fixed_Point_IteratorX F Qterm
  \<Longrightarrow> (\<forall>X Y. F X < X \<longrightarrow> Y < X \<longrightarrow> F Y = Y \<longrightarrow> Y \<le> F X)"
  apply (metis Characteristic_Fixed_Point_IteratorX_def le_less)
  done

lemma Supremum_to_gfp: "
  Characteristic_Fixed_Point_IteratorX F Qterm
  \<Longrightarrow> Sup{X. Qterm X} = gfp F"
  apply(unfold Characteristic_Fixed_Point_IteratorX_def)
  apply(rule_tac
      t="gfp F"
      and s="Sup{u. u \<le> F u}"
      in ssubst)
   apply(simp only: gfp_def)
  apply(rule_tac
      t="{X. Qterm X}"
      and s="{u. u \<le> F u}"
      in ssubst)
   prefer 2
   apply(force)
  apply(rule order_antisym)
   apply(clarsimp)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(erule_tac
      x="x"
      in allE)+
  apply(force)
  done

lemma gfp_invariant: "
  Characteristic_Fixed_Point_IteratorX F Q
  \<Longrightarrow> gfp (\<lambda>X. F (inf X (F Y))) = gfp (\<lambda>X. F (inf X Y))"
  apply(rule order_antisym)
   apply(simp add: gfp_def)
   apply(rule Sup_least)
   apply(rename_tac x)(*strict*)
   apply(clarsimp)
   apply(rule Sup_upper)
   apply(clarsimp)
   apply(rule_tac
      q="F (inf x (F Y))"
      in GFP_SOUND_le_trans)
    apply(rename_tac x)(*strict*)
    apply(force)
   apply(rename_tac x)(*strict*)
   apply(subgoal_tac "inf x (F Y) \<le> inf x Y")
    apply(rename_tac x)(*strict*)
    apply(simp add: Characteristic_Fixed_Point_IteratorX_def)
   apply(rename_tac x)(*strict*)
   apply(subgoal_tac "F Y \<le> Y")
    apply(rename_tac x)(*strict*)
    apply (rule inf_mono order_refl)
     apply(rename_tac x)(*strict*)
     apply(force)
    apply(rename_tac x)(*strict*)
    apply(force)
   apply(rename_tac x)(*strict*)
   apply(simp add: Characteristic_Fixed_Point_IteratorX_def)
  apply(simp add: gfp_def)
  apply(rule Sup_least)
  apply(rename_tac x)(*strict*)
  apply(rule Sup_upper)
  apply(clarsimp)
  apply(subgoal_tac "F (inf x Y) \<le> F x")
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(simp add: Characteristic_Fixed_Point_IteratorX_def)
  apply(rename_tac x)(*strict*)
  apply(subgoal_tac "F (inf x Y) \<le> F Y")
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(simp add: Characteristic_Fixed_Point_IteratorX_def)
  apply(rename_tac x)(*strict*)
  apply(subgoal_tac "F x \<le> x")
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(simp add: Characteristic_Fixed_Point_IteratorX_def)
  apply(rename_tac x)(*strict*)
  apply(subgoal_tac "x= F (inf x Y)")
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      q="F (inf x Y)"
      in GFP_SOUND_le_trans)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(subgoal_tac "inf x Y \<le> inf x (F Y)")
   apply(rename_tac x)(*strict*)
   apply(unfold Characteristic_Fixed_Point_IteratorX_def)
   apply(erule conjE)+
   apply(erule_tac
      x="inf x Y"
      and P="\<lambda>X. \<forall>Ya\<ge>X. F X \<le> F Ya"
      in allE)
   apply(erule_tac
      x="inf x (F Y)"
      and P="\<lambda>X. inf x Y \<le> X \<longrightarrow> F (inf x Y) \<le> F X"
      in allE)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(fold Characteristic_Fixed_Point_IteratorX_def)
  apply(subgoal_tac "x\<le>Y")
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(simp add: Characteristic_Fixed_Point_IteratorX_def)
   apply(clarsimp)
   apply(rule_tac
      q="F Y"
      in GFP_SOUND_le_trans)
    apply(rename_tac x)(*strict*)
    apply(force)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(clarsimp)
  apply(subgoal_tac "inf x Y = x")
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(rule_tac
      t="inf x Y = x"
      and s="x\<le>Y"
      in subst)
    apply(rename_tac x)(*strict*)
    apply (rule le_iff_inf)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(force)
  done

lemma computation_via_Compute_Fixed_Point_Finite_hlp1: "
  Characteristic_Fixed_Point_IteratorX F Q
  \<Longrightarrow> F A \<noteq> A
  \<Longrightarrow> F (F A) \<noteq> F A
  \<Longrightarrow> gfp F < A
  \<Longrightarrow> gfp F < F A"
  apply(subgoal_tac "(\<forall>X Y. F X < X \<longrightarrow> Y < X \<longrightarrow> F Y = Y \<longrightarrow> Y \<le> F X)")
   prefer 2
   apply(rule Characteristic_Fixed_Point_IteratorX_does_not_skip_Fixed_Points)
   apply(force)
  apply(erule_tac
      x="A"
      in allE)
  apply(subgoal_tac "F A \<le> A")
   apply(clarsimp)
   apply(erule impE)
    apply(force)
   apply(erule_tac
      x="gfp F"
      in allE)
   apply(erule impE)
    apply(force)
   apply(subgoal_tac "mono F")
    prefer 2
    apply(simp add: Characteristic_Fixed_Point_IteratorX_def mono_def)
   apply(erule impE)
    apply (metis gfp_unfold)
   apply(case_tac "gfp F = F A")
    apply (metis gfp_unfold)
   apply(force)
  apply(simp add: Characteristic_Fixed_Point_IteratorX_def)
  done

lemma computation_via_Compute_Fixed_Point_Finite_hlp2: "
  Characteristic_Fixed_Point_IteratorX F Q
  \<Longrightarrow> F A \<noteq> A
  \<Longrightarrow> F (F A) = F A
  \<Longrightarrow> gfp F < A
  \<Longrightarrow> F A = gfp F"
  apply(subgoal_tac "mono F")
   prefer 2
   apply(simp add: Characteristic_Fixed_Point_IteratorX_def mono_def)
  apply(rule order_antisym)
   apply (metis gfp_upperbound order_eq_refl)
  apply(subgoal_tac "(\<forall>X Y. F X < X \<longrightarrow> Y < X \<longrightarrow> F Y = Y \<longrightarrow> Y \<le> F X)")
   prefer 2
   apply(rule Characteristic_Fixed_Point_IteratorX_does_not_skip_Fixed_Points)
   apply(force)
  apply(erule_tac
      x="A"
      in allE)
  apply(subgoal_tac "F A \<le> A")
   apply(clarsimp)
   apply(erule impE)
    apply(force)
   apply(erule_tac
      x="gfp F"
      in allE)
   apply(erule impE)
    apply(force)
   apply(erule impE)
    apply (metis gfp_unfold)
   apply(case_tac "gfp F = F A")
    apply (metis)
   apply(force)
  apply(simp add: Characteristic_Fixed_Point_IteratorX_def)
  done

end


(*  Title:      ZF/AC/Hartog.thy
    Author:     Krzysztof Grabczewski

Hartog's function.
*)

theory Hartog
imports AC_Equiv
begin

definition
  Hartog :: "i \<Rightarrow> i"  where
   "Hartog(X) \<equiv> \<mu> i. \<not> i \<lesssim> X"

lemma Ords_in_set: "\<forall>a. Ord(a) \<longrightarrow> a \<in> X \<Longrightarrow> P"
apply (rule_tac X = "{y \<in> X. Ord (y) }" in ON_class [elim_format])
apply fast
done

lemma Ord_lepoll_imp_ex_well_ord:
     "\<lbrakk>Ord(a); a \<lesssim> X\<rbrakk>
      \<Longrightarrow> \<exists>Y. Y \<subseteq> X \<and> (\<exists>R. well_ord(Y,R) \<and> ordertype(Y,R)=a)"
  unfolding lepoll_def
apply (erule exE)
apply (intro exI conjI)
  apply (erule inj_is_fun [THEN fun_is_rel, THEN image_subset])
 apply (rule well_ord_rvimage [OF bij_is_inj well_ord_Memrel])
  apply (erule restrict_bij [THEN bij_converse_bij])
apply (rule subset_refl, assumption)
apply (rule trans)
apply (rule bij_ordertype_vimage)
apply (erule restrict_bij [THEN bij_converse_bij])
apply (rule subset_refl)
apply (erule well_ord_Memrel)
apply (erule ordertype_Memrel)
done

lemma Ord_lepoll_imp_eq_ordertype:
     "\<lbrakk>Ord(a); a \<lesssim> X\<rbrakk> \<Longrightarrow> \<exists>Y. Y \<subseteq> X \<and> (\<exists>R. R \<subseteq> X*X \<and> ordertype(Y,R)=a)"
apply (drule Ord_lepoll_imp_ex_well_ord, assumption, clarify)
apply (intro exI conjI)
apply (erule_tac [3] ordertype_Int, auto)
done

lemma Ords_lepoll_set_lemma:
     "(\<forall>a. Ord(a) \<longrightarrow> a \<lesssim> X) \<Longrightarrow>
       \<forall>a. Ord(a) \<longrightarrow>
        a \<in> {b. Z \<in> Pow(X)*Pow(X*X), \<exists>Y R. Z=\<langle>Y,R\<rangle> \<and> ordertype(Y,R)=b}"
apply (intro allI impI)
apply (elim allE impE, assumption)
apply (blast dest!: Ord_lepoll_imp_eq_ordertype intro: sym)
done

lemma Ords_lepoll_set: "\<forall>a. Ord(a) \<longrightarrow> a \<lesssim> X \<Longrightarrow> P"
by (erule Ords_lepoll_set_lemma [THEN Ords_in_set])

lemma ex_Ord_not_lepoll: "\<exists>a. Ord(a) \<and> \<not>a \<lesssim> X"
apply (rule ccontr)
apply (best intro: Ords_lepoll_set)
done

lemma not_Hartog_lepoll_self: "\<not> Hartog(A) \<lesssim> A"
  unfolding Hartog_def
apply (rule ex_Ord_not_lepoll [THEN exE])
apply (rule LeastI, auto)
done

lemmas Hartog_lepoll_selfE = not_Hartog_lepoll_self [THEN notE]

lemma Ord_Hartog: "Ord(Hartog(A))"
by (unfold Hartog_def, rule Ord_Least)

lemma less_HartogE1: "\<lbrakk>i < Hartog(A); \<not> i \<lesssim> A\<rbrakk> \<Longrightarrow> P"
by (unfold Hartog_def, fast elim: less_LeastE)

lemma less_HartogE: "\<lbrakk>i < Hartog(A); i \<approx> Hartog(A)\<rbrakk> \<Longrightarrow> P"
by (blast intro: less_HartogE1 eqpoll_sym eqpoll_imp_lepoll
                 lepoll_trans [THEN Hartog_lepoll_selfE])

lemma Card_Hartog: "Card(Hartog(A))"
by (fast intro!: CardI Ord_Hartog elim: less_HartogE)

end