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

section {* Map functions for various types *}

theory Map_Functions
imports Deflation
begin

subsection {* Map operator for continuous function space *}

default_sort cpo

definition
  cfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'd)"
where
  "cfun_map = (\<Lambda> a b f x. b\<cdot>(f\<cdot>(a\<cdot>x)))"

lemma cfun_map_beta [simp]: "cfun_map\<cdot>a\<cdot>b\<cdot>f\<cdot>x = b\<cdot>(f\<cdot>(a\<cdot>x))"
unfolding cfun_map_def by simp

lemma cfun_map_ID: "cfun_map\<cdot>ID\<cdot>ID = ID"
unfolding cfun_eq_iff by simp

lemma cfun_map_map:
  "cfun_map\<cdot>f1\<cdot>g1\<cdot>(cfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
    cfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
by (rule cfun_eqI) simp

lemma ep_pair_cfun_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (cfun_map\<cdot>p1\<cdot>e2) (cfun_map\<cdot>e1\<cdot>p2)"
proof
  interpret e1p1: ep_pair e1 p1 by fact
  interpret e2p2: ep_pair e2 p2 by fact
  fix f show "cfun_map\<cdot>e1\<cdot>p2\<cdot>(cfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
    by (simp add: cfun_eq_iff)
  fix g show "cfun_map\<cdot>p1\<cdot>e2\<cdot>(cfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
    apply (rule cfun_belowI, simp)
    apply (rule below_trans [OF e2p2.e_p_below])
    apply (rule monofun_cfun_arg)
    apply (rule e1p1.e_p_below)
    done
qed

lemma deflation_cfun_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (cfun_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix f
  show "cfun_map\<cdot>d1\<cdot>d2\<cdot>(cfun_map\<cdot>d1\<cdot>d2\<cdot>f) = cfun_map\<cdot>d1\<cdot>d2\<cdot>f"
    by (simp add: cfun_eq_iff d1.idem d2.idem)
  show "cfun_map\<cdot>d1\<cdot>d2\<cdot>f \<sqsubseteq> f"
    apply (rule cfun_belowI, simp)
    apply (rule below_trans [OF d2.below])
    apply (rule monofun_cfun_arg)
    apply (rule d1.below)
    done
qed

lemma finite_range_cfun_map:
  assumes a: "finite (range (\<lambda>x. a\<cdot>x))"
  assumes b: "finite (range (\<lambda>y. b\<cdot>y))"
  shows "finite (range (\<lambda>f. cfun_map\<cdot>a\<cdot>b\<cdot>f))"  (is "finite (range ?h)")
proof (rule finite_imageD)
  let ?f = "\<lambda>g. range (\<lambda>x. (a\<cdot>x, g\<cdot>x))"
  show "finite (?f ` range ?h)"
  proof (rule finite_subset)
    let ?B = "Pow (range (\<lambda>x. a\<cdot>x) \<times> range (\<lambda>y. b\<cdot>y))"
    show "?f ` range ?h \<subseteq> ?B"
      by clarsimp
    show "finite ?B"
      by (simp add: a b)
  qed
  show "inj_on ?f (range ?h)"
  proof (rule inj_onI, rule cfun_eqI, clarsimp)
    fix x f g
    assume "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) = range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
    hence "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) \<subseteq> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
      by (rule equalityD1)
    hence "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) \<in> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
      by (simp add: subset_eq)
    then obtain y where "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) = (a\<cdot>y, b\<cdot>(g\<cdot>(a\<cdot>y)))"
      by (rule rangeE)
    thus "b\<cdot>(f\<cdot>(a\<cdot>x)) = b\<cdot>(g\<cdot>(a\<cdot>x))"
      by clarsimp
  qed
qed

lemma finite_deflation_cfun_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  have "deflation d1" and "deflation d2" by fact+
  thus "deflation (cfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_cfun_map)
  have "finite (range (\<lambda>f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f))"
    using d1.finite_range d2.finite_range
    by (rule finite_range_cfun_map)
  thus "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
    by (rule finite_range_imp_finite_fixes)
qed

text {* Finite deflations are compact elements of the function space *}

lemma finite_deflation_imp_compact: "finite_deflation d \<Longrightarrow> compact d"
apply (frule finite_deflation_imp_deflation)
apply (subgoal_tac "compact (cfun_map\<cdot>d\<cdot>d\<cdot>d)")
apply (simp add: cfun_map_def deflation.idem eta_cfun)
apply (rule finite_deflation.compact)
apply (simp only: finite_deflation_cfun_map)
done

subsection {* Map operator for product type *}

definition
  prod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<times> 'c \<rightarrow> 'b \<times> 'd"
where
  "prod_map = (\<Lambda> f g p. (f\<cdot>(fst p), g\<cdot>(snd p)))"

lemma prod_map_Pair [simp]: "prod_map\<cdot>f\<cdot>g\<cdot>(x, y) = (f\<cdot>x, g\<cdot>y)"
unfolding prod_map_def by simp

lemma prod_map_ID: "prod_map\<cdot>ID\<cdot>ID = ID"
unfolding cfun_eq_iff by auto

lemma prod_map_map:
  "prod_map\<cdot>f1\<cdot>g1\<cdot>(prod_map\<cdot>f2\<cdot>g2\<cdot>p) =
    prod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
by (induct p) simp

lemma ep_pair_prod_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (prod_map\<cdot>e1\<cdot>e2) (prod_map\<cdot>p1\<cdot>p2)"
proof
  interpret e1p1: ep_pair e1 p1 by fact
  interpret e2p2: ep_pair e2 p2 by fact
  fix x show "prod_map\<cdot>p1\<cdot>p2\<cdot>(prod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
    by (induct x) simp
  fix y show "prod_map\<cdot>e1\<cdot>e2\<cdot>(prod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
    by (induct y) (simp add: e1p1.e_p_below e2p2.e_p_below)
qed

lemma deflation_prod_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (prod_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix x
  show "prod_map\<cdot>d1\<cdot>d2\<cdot>(prod_map\<cdot>d1\<cdot>d2\<cdot>x) = prod_map\<cdot>d1\<cdot>d2\<cdot>x"
    by (induct x) (simp add: d1.idem d2.idem)
  show "prod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
    by (induct x) (simp add: d1.below d2.below)
qed

lemma finite_deflation_prod_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (prod_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  have "deflation d1" and "deflation d2" by fact+
  thus "deflation (prod_map\<cdot>d1\<cdot>d2)" by (rule deflation_prod_map)
  have "{p. prod_map\<cdot>d1\<cdot>d2\<cdot>p = p} \<subseteq> {x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}"
    by clarsimp
  thus "finite {p. prod_map\<cdot>d1\<cdot>d2\<cdot>p = p}"
    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
qed

subsection {* Map function for lifted cpo *}

definition
  u_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a u \<rightarrow> 'b u"
where
  "u_map = (\<Lambda> f. fup\<cdot>(up oo f))"

lemma u_map_strict [simp]: "u_map\<cdot>f\<cdot>\<bottom> = \<bottom>"
unfolding u_map_def by simp

lemma u_map_up [simp]: "u_map\<cdot>f\<cdot>(up\<cdot>x) = up\<cdot>(f\<cdot>x)"
unfolding u_map_def by simp

lemma u_map_ID: "u_map\<cdot>ID = ID"
unfolding u_map_def by (simp add: cfun_eq_iff eta_cfun)

lemma u_map_map: "u_map\<cdot>f\<cdot>(u_map\<cdot>g\<cdot>p) = u_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>p"
by (induct p) simp_all

lemma u_map_oo: "u_map\<cdot>(f oo g) = u_map\<cdot>f oo u_map\<cdot>g"
by (simp add: cfcomp1 u_map_map eta_cfun)

lemma ep_pair_u_map: "ep_pair e p \<Longrightarrow> ep_pair (u_map\<cdot>e) (u_map\<cdot>p)"
apply default
apply (case_tac x, simp, simp add: ep_pair.e_inverse)
apply (case_tac y, simp, simp add: ep_pair.e_p_below)
done

lemma deflation_u_map: "deflation d \<Longrightarrow> deflation (u_map\<cdot>d)"
apply default
apply (case_tac x, simp, simp add: deflation.idem)
apply (case_tac x, simp, simp add: deflation.below)
done

lemma finite_deflation_u_map:
  assumes "finite_deflation d" shows "finite_deflation (u_map\<cdot>d)"
proof (rule finite_deflation_intro)
  interpret d: finite_deflation d by fact
  have "deflation d" by fact
  thus "deflation (u_map\<cdot>d)" by (rule deflation_u_map)
  have "{x. u_map\<cdot>d\<cdot>x = x} \<subseteq> insert \<bottom> ((\<lambda>x. up\<cdot>x) ` {x. d\<cdot>x = x})"
    by (rule subsetI, case_tac x, simp_all)
  thus "finite {x. u_map\<cdot>d\<cdot>x = x}"
    by (rule finite_subset, simp add: d.finite_fixes)
qed

subsection {* Map function for strict products *}

default_sort pcpo

definition
  sprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<otimes> 'c \<rightarrow> 'b \<otimes> 'd"
where
  "sprod_map = (\<Lambda> f g. ssplit\<cdot>(\<Lambda> x y. (:f\<cdot>x, g\<cdot>y:)))"

lemma sprod_map_strict [simp]: "sprod_map\<cdot>a\<cdot>b\<cdot>\<bottom> = \<bottom>"
unfolding sprod_map_def by simp

lemma sprod_map_spair [simp]:
  "x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
by (simp add: sprod_map_def)

lemma sprod_map_spair':
  "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
by (cases "x = \<bottom> \<or> y = \<bottom>") auto

lemma sprod_map_ID: "sprod_map\<cdot>ID\<cdot>ID = ID"
unfolding sprod_map_def by (simp add: cfun_eq_iff eta_cfun)

lemma sprod_map_map:
  "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
    sprod_map\<cdot>f1\<cdot>g1\<cdot>(sprod_map\<cdot>f2\<cdot>g2\<cdot>p) =
     sprod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
apply (induct p, simp)
apply (case_tac "f2\<cdot>x = \<bottom>", simp)
apply (case_tac "g2\<cdot>y = \<bottom>", simp)
apply simp
done

lemma ep_pair_sprod_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (sprod_map\<cdot>e1\<cdot>e2) (sprod_map\<cdot>p1\<cdot>p2)"
proof
  interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
  interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
  fix x show "sprod_map\<cdot>p1\<cdot>p2\<cdot>(sprod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
    by (induct x) simp_all
  fix y show "sprod_map\<cdot>e1\<cdot>e2\<cdot>(sprod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
    apply (induct y, simp)
    apply (case_tac "p1\<cdot>x = \<bottom>", simp, case_tac "p2\<cdot>y = \<bottom>", simp)
    apply (simp add: monofun_cfun e1p1.e_p_below e2p2.e_p_below)
    done
qed

lemma deflation_sprod_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (sprod_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix x
  show "sprod_map\<cdot>d1\<cdot>d2\<cdot>(sprod_map\<cdot>d1\<cdot>d2\<cdot>x) = sprod_map\<cdot>d1\<cdot>d2\<cdot>x"
    apply (induct x, simp)
    apply (case_tac "d1\<cdot>x = \<bottom>", simp, case_tac "d2\<cdot>y = \<bottom>", simp)
    apply (simp add: d1.idem d2.idem)
    done
  show "sprod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
    apply (induct x, simp)
    apply (simp add: monofun_cfun d1.below d2.below)
    done
qed

lemma finite_deflation_sprod_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (sprod_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  have "deflation d1" and "deflation d2" by fact+
  thus "deflation (sprod_map\<cdot>d1\<cdot>d2)" by (rule deflation_sprod_map)
  have "{x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq> insert \<bottom>
        ((\<lambda>(x, y). (:x, y:)) ` ({x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}))"
    by (rule subsetI, case_tac x, auto simp add: spair_eq_iff)
  thus "finite {x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
qed

subsection {* Map function for strict sums *}

definition
  ssum_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<oplus> 'c \<rightarrow> 'b \<oplus> 'd"
where
  "ssum_map = (\<Lambda> f g. sscase\<cdot>(sinl oo f)\<cdot>(sinr oo g))"

lemma ssum_map_strict [simp]: "ssum_map\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
unfolding ssum_map_def by simp

lemma ssum_map_sinl [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
unfolding ssum_map_def by simp

lemma ssum_map_sinr [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
unfolding ssum_map_def by simp

lemma ssum_map_sinl': "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
by (cases "x = \<bottom>") simp_all

lemma ssum_map_sinr': "g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
by (cases "x = \<bottom>") simp_all

lemma ssum_map_ID: "ssum_map\<cdot>ID\<cdot>ID = ID"
unfolding ssum_map_def by (simp add: cfun_eq_iff eta_cfun)

lemma ssum_map_map:
  "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
    ssum_map\<cdot>f1\<cdot>g1\<cdot>(ssum_map\<cdot>f2\<cdot>g2\<cdot>p) =
     ssum_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
apply (induct p, simp)
apply (case_tac "f2\<cdot>x = \<bottom>", simp, simp)
apply (case_tac "g2\<cdot>y = \<bottom>", simp, simp)
done

lemma ep_pair_ssum_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (ssum_map\<cdot>e1\<cdot>e2) (ssum_map\<cdot>p1\<cdot>p2)"
proof
  interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
  interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
  fix x show "ssum_map\<cdot>p1\<cdot>p2\<cdot>(ssum_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
    by (induct x) simp_all
  fix y show "ssum_map\<cdot>e1\<cdot>e2\<cdot>(ssum_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
    apply (induct y, simp)
    apply (case_tac "p1\<cdot>x = \<bottom>", simp, simp add: e1p1.e_p_below)
    apply (case_tac "p2\<cdot>y = \<bottom>", simp, simp add: e2p2.e_p_below)
    done
qed

lemma deflation_ssum_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (ssum_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix x
  show "ssum_map\<cdot>d1\<cdot>d2\<cdot>(ssum_map\<cdot>d1\<cdot>d2\<cdot>x) = ssum_map\<cdot>d1\<cdot>d2\<cdot>x"
    apply (induct x, simp)
    apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.idem)
    apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.idem)
    done
  show "ssum_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
    apply (induct x, simp)
    apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.below)
    apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.below)
    done
qed

lemma finite_deflation_ssum_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (ssum_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  have "deflation d1" and "deflation d2" by fact+
  thus "deflation (ssum_map\<cdot>d1\<cdot>d2)" by (rule deflation_ssum_map)
  have "{x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq>
        (\<lambda>x. sinl\<cdot>x) ` {x. d1\<cdot>x = x} \<union>
        (\<lambda>x. sinr\<cdot>x) ` {x. d2\<cdot>x = x} \<union> {\<bottom>}"
    by (rule subsetI, case_tac x, simp_all)
  thus "finite {x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
qed

subsection {* Map operator for strict function space *}

definition
  sfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow>! 'c) \<rightarrow> ('b \<rightarrow>! 'd)"
where
  "sfun_map = (\<Lambda> a b. sfun_abs oo cfun_map\<cdot>a\<cdot>b oo sfun_rep)"

lemma sfun_map_ID: "sfun_map\<cdot>ID\<cdot>ID = ID"
  unfolding sfun_map_def
  by (simp add: cfun_map_ID cfun_eq_iff)

lemma sfun_map_map:
  assumes "f2\<cdot>\<bottom> = \<bottom>" and "g2\<cdot>\<bottom> = \<bottom>" shows
  "sfun_map\<cdot>f1\<cdot>g1\<cdot>(sfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
    sfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
unfolding sfun_map_def
by (simp add: cfun_eq_iff strictify_cancel assms cfun_map_map)

lemma ep_pair_sfun_map:
  assumes 1: "ep_pair e1 p1"
  assumes 2: "ep_pair e2 p2"
  shows "ep_pair (sfun_map\<cdot>p1\<cdot>e2) (sfun_map\<cdot>e1\<cdot>p2)"
proof
  interpret e1p1: pcpo_ep_pair e1 p1
    unfolding pcpo_ep_pair_def by fact
  interpret e2p2: pcpo_ep_pair e2 p2
    unfolding pcpo_ep_pair_def by fact
  fix f show "sfun_map\<cdot>e1\<cdot>p2\<cdot>(sfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
    unfolding sfun_map_def
    apply (simp add: sfun_eq_iff strictify_cancel)
    apply (rule ep_pair.e_inverse)
    apply (rule ep_pair_cfun_map [OF 1 2])
    done
  fix g show "sfun_map\<cdot>p1\<cdot>e2\<cdot>(sfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
    unfolding sfun_map_def
    apply (simp add: sfun_below_iff strictify_cancel)
    apply (rule ep_pair.e_p_below)
    apply (rule ep_pair_cfun_map [OF 1 2])
    done
qed

lemma deflation_sfun_map:
  assumes 1: "deflation d1"
  assumes 2: "deflation d2"
  shows "deflation (sfun_map\<cdot>d1\<cdot>d2)"
apply (simp add: sfun_map_def)
apply (rule deflation.intro)
apply simp
apply (subst strictify_cancel)
apply (simp add: cfun_map_def deflation_strict 1 2)
apply (simp add: cfun_map_def deflation.idem 1 2)
apply (simp add: sfun_below_iff)
apply (subst strictify_cancel)
apply (simp add: cfun_map_def deflation_strict 1 2)
apply (rule deflation.below)
apply (rule deflation_cfun_map [OF 1 2])
done

lemma finite_deflation_sfun_map:
  assumes 1: "finite_deflation d1"
  assumes 2: "finite_deflation d2"
  shows "finite_deflation (sfun_map\<cdot>d1\<cdot>d2)"
proof (intro finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  have "deflation d1" and "deflation d2" by fact+
  thus "deflation (sfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_sfun_map)
  from 1 2 have "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
    by (rule finite_deflation_cfun_map)
  then have "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
    by (rule finite_deflation.finite_fixes)
  moreover have "inj (\<lambda>f. sfun_rep\<cdot>f)"
    by (rule inj_onI, simp add: sfun_eq_iff)
  ultimately have "finite ((\<lambda>f. sfun_rep\<cdot>f) -` {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f})"
    by (rule finite_vimageI)
  then show "finite {f. sfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
    unfolding sfun_map_def sfun_eq_iff
    by (simp add: strictify_cancel
         deflation_strict `deflation d1` `deflation d2`)
qed

end


(*<*)
theory paper
  imports
  (*"Regular-Sets.Equivalence_Checking2"*)
  "Regular-Sets.Regexp_Method"
  "HOL-Library.Char_ord"
  "HOL-Eisbach.Eisbach"
begin

alias nTimes = NDerivative.nTimes
alias nPlus = NDerivative.nPlus
alias norm = NDerivative.norm
alias add_atoms = Equivalence_Checking.add_atoms
alias closure = Equivalence_Checking.closure
alias nullable = Regular_Exp.nullable

declare[[names_short]]
(*>*)

section\<open>Introduction\<close>
text\<open>Two regular expressions (RE for short) are \<^emph>\<open>equivalent\<close>, if and only if they represent the
 same formal language, i.e.

  @{prop "lang r1 = lang r2"}

A well-known result from theoretical CS is that the problem of RE equivalence is decidable, meaning
that solving goals of the above form can be reduced to a mere computation. Thus, structured proofs
 often do not add understanding; they should be replaced by a simple proof method invocation,
 increasing readability and maintainability.

To prove decidability, most textbooks give this algorithm: Convert both REs into automata,
 determinize and minimize the result and check for equality (disregarding state identifiers).
 However, while correctness of this approach is obvious for CS graduates, verifying it is tedious,
 mostly because the formalization of all the needed automata theory requires a lot of work. Nipkow
 and Krauss @{cite "Krauss-Nipkow-JAR"} follow an alternative approach first described by Brzozowski
 @{cite Brzozowski}. The development results in a ready-to-use proof method @{cite
 "Regular-Sets-AFP"} in Isabelle/HOL, replacing the need for manual derivation of RE equivalences.

  This paper explains this approach, and how it is implemented as of AFP2017 (@{url
 "https://www.isa-afp.org"}). It hopes to give insight why such a succinct development (compared to
 other verified RE equivalent checkers) is elegant and desirable for interactive proving.
\<close>

section\<open>About the reference article\<close>

text\<open>The purpose of the article @{cite "Krauss-Nipkow-JAR"} is to provide a new proof method for
  Isabelle/HOL. Users should not have to prove equivalence relations of REs
  themselves, but use a simple automatic command, saving time and work load. Ideally, this command should
 verify every correct equivalence, i.e. be complete. However, as the authors write, completeness
 "merely lets you sleep better". They still argue why completeness holds (following a proof by
 Brzozowski @{cite "Brzozowski"}), but do not verify it. The reason is that proof methods are
 typically used interactively, and for small goals, meaning that a user can just \<^emph>\<open>try\<close> whether it solves the
 goal.
\<close>
paragraph\<open>What \<^emph>\<open>is\<close> in the article\<close>\<comment>\<open>\<close>
text\<open>Nipkow and Krauss document an elegant development of\<close>
text\<open>
\<^item> a proof method for RE equivalences, i.e. goals of the form
  \<open>lang r1 = lang r2\<close>; ...
\<^item> ...using the rule @{prop \<open>lang r1 \<subseteq> lang r2 \<longleftrightarrow> lang (Plus r1 r2) = lang r2\<close>}, also
  for \<open>lang r1 \<subseteq> lang r2\<close> (or \<open>lang r1 \<supseteq> lang r2\<close>)
\<close>
paragraph\<open>What \<^emph>\<open>is not\<close> in the article\<close>\<comment>\<open>\<close>
text\<open>The article stresses that it does \<^emph>\<open>not\<close> provide:\<close>
text\<open>
\<^item> verified termination proofs for any of the above
\<^item> a proof method for RE \<^emph>\<open>in\<close>equalities, i.e. goals of the form \<open>lang r1 \<noteq> lang r2\<close>
\<close>

section\<open>Languages and REs\<close>

subsection\<open>Notation\<close>

text\<open>
In Isabelle, list syntax is used for word operations:
\<close>
type_synonym 'a lang = "'a list set"  \<comment>\<open>Languages are sets of lists.\<close>
text\<open>@{term_type lang} is defined as usual.

For REs, we have the identifiers

@{const Zero} for the RE with @{thm Regular_Exp.lang.simps(1)} and

@{const One} for the RE with @{thm Regular_Exp.lang.simps(2)}

Special syntax is completely avoided; all connectives are represented
 with standard constructors:
  \<^descr>@{term_type Atom}
  \<^descr>@{term_type Plus}
  \<^descr>@{term_type Times}
  \<^descr>@{term_type Star}
\<close>

subsection\<open>Derivatives\<close>
text\<open>Remember the standard definition of a \<^emph>\<open>language derivative\<close> with respect to an atom \<open>x\<close>:

@{thm Deriv_def[no_vars]}

As the derivative of a regular language is regular again, we know that a RE
 describing it exists.

In his 1964 article \<^emph>\<open>Derivatives of Regular Expressions\<close> @{cite "Brzozowski"}, Brzozowski gives
 rules to construct it from a RE describing the original language:
\<close>
fun deriv :: "'a \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "deriv _ Zero = Zero"
| "deriv _ One = Zero"
| "deriv a (Atom b) = (if a = b then One else Zero)"
| "deriv a (Plus r s) = Plus (deriv a r) (deriv a s)"
| "deriv a (Times r s) =
    (let r's = Times (deriv a r) s
     in if nullable r then Plus r's (deriv a s) else r's)"
| "deriv a (Star r) = Times (deriv a r) (Star r)"

text\<open>...where @{const nullable}, defined as \<open>nullable r \<longleftrightarrow> [] \<in> lang r\<close>, is a simple syntactic check
  (omitted here).\<close>

lemma lang_deriv: "lang (deriv a r) = Deriv a (lang r)"
by (induction r) (auto simp: Let_def nullable_iff)

section\<open>Bisimulations\<close>

subsection\<open>Language Coinduction\<close>
text\<open>Consider the following lemma, which is proven by word induction (i.e. list induction):
\<close>
lemma language_coinduct:
assumes "\<And>K L. R K L \<Longrightarrow> ([] \<in> K \<longleftrightarrow> [] \<in> L)"
assumes "\<And>K L x. R K L \<Longrightarrow> R (Deriv x K) (Deriv x L)"
assumes "R K\<^sub>0 L\<^sub>0"
shows "K\<^sub>0 = L\<^sub>0"
proof (rule set_eqI)
  fix w
  show "w \<in> K\<^sub>0 \<longleftrightarrow> w \<in> L\<^sub>0" using assms
    apply (induction w arbitrary: K\<^sub>0 L\<^sub>0)
     apply (auto simp: Deriv_def)
     apply blast+
    done
qed
text\<open>Thus, we can obtain an equivalence proof by establishing such a relation \<open>R\<close> (called
 \<^emph>\<open>bisimulation\<close>).
\<close>
subsection\<open>Computable variant\<close>
text\<open>The following is the same for @{typ "'a rexp"} instead of languages themselves. Note that we
 also switch to set-bounded quantification (property 1 below), to make this computable for finite
 \<open>as\<close>. We can later set \<open>as = atoms r1 \<union> atoms r2\<close>: Words with symbols outside of this set can not
 be derived from either \<open>r1\<close> or \<open>r2\<close>, so equivalence within this sub-alphabet implies overall
 equivalence.
\<close>
definition is_bisimulation ::  "'a::order list \<Rightarrow> ('a rexp \<times> 'a rexp) set \<Rightarrow> bool"
where
  "is_bisimulation as R \<longleftrightarrow>
    (\<forall>(r,s)\<in> R.
(*1*) atoms r \<union> atoms s \<subseteq> set as \<and>
(*2*) (nullable r \<longleftrightarrow> nullable s) \<and>
(*3*) (\<forall>a\<in>set as. (nderiv a r, nderiv a s) \<in> R))"
text\<open>@{const nderiv} is a simplifying variant of @{const deriv}, which also fulfills \<open>lang (nderiv a
  r) = Deriv a (lang r)\<close>, details in section 5.3.\<close>
lemma bisim_lang_eq:
assumes "is_bisimulation as ps"
assumes "(r, s) \<in> ps"
shows "lang r = lang s"
proof -
  \<comment>\<open>This can easily be reduced to the above result.\<close>
(*<*)
  define ps' where "ps' = insert (Zero, Zero) ps"
  from \<open>is_bisimulation as ps\<close> have bisim': "is_bisimulation as ps'"
    by (auto simp: ps'_def is_bisimulation_def)
  let ?R = "\<lambda>K L. (\<exists>(r,s)\<in>ps'. K = lang r \<and> L = lang s)"
  show ?thesis
  proof (rule language_coinduct[where R="?R"])
    from \<open>(r, s) \<in> ps\<close>
    have "(r, s) \<in> ps'" by (auto simp: ps'_def)
    thus "?R (lang r) (lang s)" by auto
  next
    fix K L assume "?R K L"
    then obtain r s where rs: "(r, s) \<in> ps'"
      and KL: "K = lang r" "L = lang s" by auto
    with bisim' have "nullable r \<longleftrightarrow> nullable s"
      by (auto simp: is_bisimulation_def)
    thus "[] \<in> K \<longleftrightarrow> [] \<in> L" by (auto simp: nullable_iff KL)
    fix a
    show "?R (Deriv a K) (Deriv a L)"
    proof cases
      assume "a \<in> set as"
      with rs bisim'
      have "(nderiv a r, nderiv a s) \<in> ps'"
        by (auto simp: is_bisimulation_def)
      thus ?thesis by (force simp: KL lang_nderiv)
    next
      assume "a \<notin> set as"
      with bisim' rs
      have "a \<notin> atoms r" "a \<notin> atoms s" by (auto simp: is_bisimulation_def)
      then have "nderiv a r = Zero" "nderiv a s = Zero"
        by (auto intro: deriv_no_occurrence)
      then have "Deriv a K = lang Zero"
        "Deriv a L = lang Zero"
        unfolding KL lang_nderiv[symmetric] by auto
      thus ?thesis by (auto simp: ps'_def)
    qed
  qed
qed
(*>*)

text\<open>At this point, we already have a certificate checker: Given \<open>as\<close> and \<open>ps\<close>, it iterates over
 all RE-pairs in \<open>ps\<close> and test whether they satisfy property 1,2 and 3 (3 needs another iteration
 over \<open>as\<close>).
Isabelle's proof method @{method eval} performs this without further setup:\<close>

abbreviation "a \<equiv> Atom CHR ''a''"

lemma "is_bisimulation [CHR ''a''] {
        (Zero, Zero),
        (One, One),
        (a, a),
        (Times a a, Times a a),
        (Times a (Times a a), Times (Times a a) a)
        }"
  by eval

text\<open>Afterwards, if \<open>(r,s)\<in>ps\<close>, the desired RE equivalence is shown via rule @{thm[source]bisim_lang_eq}.\<close>

text\<open>
Such a certificate \<open>(as, ps)\<close> could be obtained from untrusted computations, and checked by
 @{method eval}.
However, it turns out that constructing the (already verified) bisimulation is just as
 simple, removing the need to check it separately.\<close>

section\<open>Algorithm\<close>

text\<open>
We present a simple work set algorithm: A state of the algorithm is a pair \<open>(ws, ps)\<close>, where
  \<open>ws\<close> is the work set and \<open>ps\<close> the relation we construct. An iteration

  \<^item>moves one pair from \<open>ws\<close> to \<open>ps\<close>, checking that it satisfies property 2 of @{const
 is_bisimulation} as defined in section 4.2.
  \<^item>identifies RE pairs missing for property 3 and adds them to \<open>ws\<close>. Since @{const nderiv} does
 not increase the set of atoms, these pairs satisfy property 1.

Initially, we put \<open>(r,s)\<close> in the work set, to ensure that it will be in the constructed relation.

We can then prove that the
 work set becoming empty already guarantees the premises of @{thm[source] bisim_lang_eq}.
\<close>

subsection\<open>Usage of @{const while_option}\<close>
text\<open>In order to define the computation without having to prove termination, we use the @{const
 while_option}-function from Isabelle's standard library. @{const while_option} always
 has a value associated with it: If no number of iterations falsifies the while-condition, this is
 @{const None}. However, executed code only uses the unfolding equation @{thm
 while_option_unfold[no_vars]}, meaning it works just like expected when evaluated.
\<close>

subsection\<open>While-body\<close>

text\<open>\<open>succs\<close> computes the list of derivated RE pairs for all atoms:\<close>

fun succs where "succs as (r, s) = map (\<lambda>a. (nderiv a r, nderiv a s)) as"

text\<open>In each step, a pair is taken from the work set, added to the relation, and its derivatives are
 in turn added to the work set if they are not yet accounted for:
\<close>

fun step where "step as (ws, ps) =
  (let ps' = hd ws # ps;
    new = [p\<leftarrow>succs as (hd ws) . p \<notin> set ps' \<union> set ws]
  in (new @ tl ws, ps'))"

subsection\<open>While-condition\<close>

fun test where "test (ws,_) \<longleftrightarrow> (case ws of
  [] \<Rightarrow> False |
  (p,q)#vs \<Rightarrow> nullable p \<longleftrightarrow> nullable q
)"
text\<open>The loop terminates
  \<^item> if the worklist is empty (a suitable \<^emph>\<open>bisimulation\<close> was found) or
  \<^item> if two derivs do not agree on nullability (a counterexample was found)\<close>

text\<open>@{theory_text \<open>definition "closure as = while_option test (step as)"\<close>}\<close>

text\<open>The following is the same as @{const is_bisimulation}, but with the work list elements not yet
 processed:\<close>

definition pre_bisim :: "'a::order list \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp \<Rightarrow> ('a rexp \<times> 'a rexp) list \<times> ('a rexp \<times> 'a rexp) list \<Rightarrow> bool"
where
"pre_bisim as r s = (\<lambda>(ws, ps).
 (r,s) \<in> set ws \<union> set ps \<and>
 (\<forall>(r,s)\<in> set ws \<union> set ps. atoms r \<union> atoms s \<subseteq> set as) \<and>
 (\<forall>(r,s)\<in> set ps. (nullable r \<longleftrightarrow> nullable s) \<and>
   (\<forall>a\<in>set as. (nderiv a r, nderiv a s) \<in> set ps)))"

text\<open>@{const pre_bisim} is a suitable invariant:
  \<^item> It holds initially, when \<open>ws = [(r,s)]\<close> and \<open>ps = {}\<close>.
  \<^item> If the state satisfies @{const test} and @{const pre_bisim} holds, it also holds after a @{const
 step}.
  \<^item> The negated @{const test} together with the premise that the result matches the pattern
 \<open>Some([], _)\<close> (i.e. terminated with an empty work set) implies @{const is_bisimulation}, yielding
 the desired equivalence via rule @{thm[source] bisim_lang_eq}.

This proof is available as @{thm[source] closure_sound} in a formal form.
\<close>

subsection\<open>Remarks\<close>
text\<open>
Note that this is the computation of a transitive closure, i.e. the smallest set \<open>R \<supseteq> {(r,s)}\<close>
 s.t. \<open>\<And>r1 r2. (r1,r2) \<in> R \<Longrightarrow> (nderiv r1, nderiv r2) \<in> R\<close>.
 Thus, it can be expressed using the library's @{const rtrancl_while} specialization of @{const
 while_option}, which is how it is done as of AFP 2017 @{cite "Regular-Sets-AFP"}.

Also note that there are more efficient ways to compute the transitive closure @{cite
 "Transitive-Closure-AFP"} @{cite "Roy_Floyd_Warshall-AFP"}, but for the small goals that arise in
 interactive proofs, this is not needed.
\<close>

subsection\<open>Termination via ACI-normalization\<close>

text\<open>REs \<open>r1\<close> and \<open>r2\<close> are \<^emph>\<open>ACI-equivalent\<close> @{cite "Krauss-Nipkow-JAR"} /
 \<^emph>\<open>similar\<close> @{cite Brzozowski}, if one can be transformed into the other using only the following
  rules:\<close>
lemma
  "lang (Times (Times a b) c) = lang (Times a (Times b c))" --\<open>\<^bold>\<open>A\<close>ssociativity\<close>
  "lang (Plus a b) = lang (Plus b a)"                       --\<open>\<^bold>\<open>C\<close>ommutativity\<close>
  "lang (Plus a a) = lang a"                                --\<open>\<^bold>\<open>I\<close>dempotence\<close>
  by (auto simp: conc_assoc)

text\<open>In the following, we will call a RE \<^emph>\<open>normalized\<close> if
  \<^item> nested concatenations are parenthesized to the right
  \<^item> nested choices are also parenthesized to the right and also sorted:
    Atoms first, then @{const Star}-terms, then concatenations
    (This order is arbitrary, but fixed)
  \<^item> within nested choices, every subterm occurs at most once.

The goal is that @{const nderiv} maintains this property, meaning that ACI-equivalent terms can be
identified.
\<close>
text
\<open>The first step of the equivalence checker must bring the input expressions into a normal form,
 such that ACI-equivalent terms map to the same normal form. It also performs other minor
 simplifications. The authors indicate the rough procedure for such a transformation, but omit
 implementation details. These are not relevant anyways: As long as @{thm lang_norm[no_vars]} is
 fulfilled (a simple structural induction proves it), errors at this step would not
  lead to wrong results, but instead impede completeness of the method.

  However, verifying completeness is not necessary for an Isabelle proof method: In the case that
 the method were to loop infinitely, a user could always just try a different proof method or provide a
 structured proof in Isar.
\<close>

text\<open>
@{const norm} operates bottom up, deferring Plus-terms and Times-terms to auxiliary functions
  which associate their subterms in a fixed manner.

The rules are obviously designed to fulfill @{thm lang_nderiv[no_vars]} just like @{const deriv} does,
 which is shown by structural induction. This part is needed in the soundness proof.

 @{const nderiv} operating on normalized terms outputs normalized terms again. This fact is
 not needed for partial correctness, and therefore not verified.

It is, however, crucial for the termination argument:
In the while-step, the filter \<open>p \<notin> set ps' \<union> set ws\<close> must throw out at least ACI-equivalent terms
 (\<open>p\<close> is normalized at that point).
 Brzozowski showed @{cite "Brzozowski"} that this is enough for the work set to become empty
 eventually.
\<close>

section\<open>A proof method for standard-@{type rexp}s\<close>
text\<open>The authors choose to provide the equivalence checker only specialized to @{typ "nat rexp"},
 however, it also works for an arbitrary \<open>'a::order rexp\<close>:
\<close>

subsection\<open>@{const Equivalence_Checking.check_eqv} for arbitrary (but ordered) atoms\<close>
text\<open>We reproduce the definition from @{theory Equivalence_Checking}, with additional
  explanations and @{typ nat} replaced by \<open>'a::order\<close>.
\<close>
definition check_eqv :: "'a :: order rexp \<Rightarrow> 'a rexp \<Rightarrow> bool" where
"check_eqv r s =(
  let
    r= norm r; (*normalize r*)
    s= norm s; (*normalize s*)
    as= add_atoms r (add_atoms s []) (*identify the atoms to check derivations of*)
  in case closure as (r, s) of
    Some([],_) \<Rightarrow> True (* bisimulation was constructed *)
  | _ \<Rightarrow> False (* while condition failed due to a counterexample *)
)"

subsection\<open>The proof method\<close>

text\<open>We use the @{command method} command from @{doc eisbach} @{cite "Matichuk:2016:EPM:2904234.2904264"},
 an Isabelle tool for proof method definitions, to provide a simple invocation
 possibility for the presented algorithm.
\<close>

text\<open>First, we want to refine subset-goals to an equivalence check, to make the method more
  versatile:\<close>
lemma subset_eq_to_eq: "lang r \<subseteq> lang s \<longleftrightarrow> lang (Plus r s) = lang s"
  by auto

text\<open>We can then define the method using the usual Isabelle proof method combinators:\<close>
method rexp = (unfold subset_eq_to_eq)?, (rule soundness, eval)+
text\<open>An informal description: If necessary, unfold @{thm[source]
 subset_eq_to_eq} to obtain an equality goal, then apply the soundness rule (backwards refinement),
 then iterate the closure-check loop (by @{method eval}) until it has the form \<open>Some([],_)\<close>,
 which solves the goal. Repeat this if more subgoals are present.
\<close>

paragraph\<open>Examples\<close>\<comment>\<open>\<close>
abbreviation "ab \<equiv> Times (Atom (CHR ''a'')) (Atom (CHR ''b''))"
abbreviation "a_p_b \<equiv> Plus (Atom (CHR ''a'')) (Atom (CHR ''b''))"
abbreviation "b_p_a \<equiv> Plus (Atom (CHR ''b'')) (Atom (CHR ''a''))"

lemma
  "lang (Times (Star (Plus One ab)) a_p_b) = lang (Times (Star ab) b_p_a)"
  "lang (Times (Star ab) b_p_a) \<supseteq> lang (Times (Star (Plus ab One)) a_p_b)"
  "lang (Times (Star (Plus ab One)) ab) \<subseteq> lang (Star (Plus One ab))"
  by rexp \<comment>\<open>These are solved very fast\<close>

lemma "lang (Star (Atom (CHR ''a''))) \<noteq> lang (Star (Atom (CHR ''b'')))"
  oops \<comment>\<open>correct, but not part of the method\<close>

section\<open>Termination conditions\<close>

(*replace by comments about Not and Inter (extended REs)?*)

text\<open>Note that Brzozoswki's proof of termination requires the property that ACI-equivalent REs can
 be identified, i.e. mapped to one representative. Nipkow and Krauss argue why their @{const
 nderiv}-function maintains such an ACI-normal form, but they need the assumption that the atoms of
 the REs conform to some total order.

This is presently not reflected by the code @{cite "Regular-Sets-AFP"}: @{const closure} has the
 type

\<open>'a::order list \<Rightarrow> ... \<Rightarrow> ...\<close>

The reason is convenience for the user: When only requiring @{class order}, there is no need to
 provide an instance proof for @{class linorder} before being able to use the proof method: For
 its partial correctness, the total order is not needed.
\<close>
(*<*)
paragraph \<open>Small example for a non-total order\<close>

text\<open>Via \<^bold>\<open>associativity\<close> and \<^bold>\<open>commutativity\<close>, only finitely many equivalent REs can arise (proof:
 both rules do not increase the term size). Thus, the counterexample needs to be crafted so that norm
 fails to recognize \<^bold>\<open>idempotence\<close>, producing bigger and bigger REs. The only @{const norm}-step which
 increases the RE is @{term "nderiv c (Times r s)"}, so target that.
\<close>

datatype part_ord = A | B | C

text\<open>For finite types, one could always find a total order, but let's assume we do not.\<close>

instantiation part_ord :: order
begin

definition "a \<le> b \<longleftrightarrow> a = b" for a b :: part_ord
definition "a < b \<longleftrightarrow> False" for a b :: part_ord

instance
  by standard (simp_all add: less_eq_part_ord_def less_part_ord_def)
end
lemma size_nPlus: "size (nPlus R1 R2) \<le> size R1 + size R2 + 1"
  apply (induction rule: nPlus.induct)
                      apply auto
  done

lemma size_nTimes: "size (nTimes R1 R2) \<le> size R1 + size R2 + 1"
  apply (induction rule: nTimes.induct)
                      apply auto
  done

lemma size_norm: "size (norm R) \<le> size R"
proof (induction R, simp_all)
  fix R1 :: "'a rexp" and R2 :: "'a rexp"
  assume "size (norm R1) \<le> size R1" "size (norm R2) \<le> size R2"
  then have "1 + (size (norm R1) + size (norm R2)) \<le> Suc (size R1 + size R2)"
    using add_le_mono by presburger
  then show
    "size (nPlus (norm R1) (norm R2)) \<le> Suc (size R1 + size R2)"
    "size (nTimes (norm R1) (norm R2)) \<le> Suc (size R1 + size R2)"
    using size_nPlus size_nTimes by (metis (no_types)
        Orderings.order_class.dual_order.trans semiring_normalization_rules(24))+
qed

lemma "finite b1 \<Longrightarrow> finite {R . atoms R \<subseteq> b1 \<and> size R \<le> b2}"
  oops

lemma "finite {(norm ^^ k) R | k . True}"
proof -
  have "atoms ((norm ^^ k) R) \<subseteq> atoms R" for k
    apply (induction k)
     apply simp
    using atoms_norm by auto
  moreover have "size ((norm ^^ k) R) \<le> size R" for k
    apply (induction k)
    apply auto
    using le_trans size_norm by blast
  ultimately
  show ?thesis oops

value "let
    nr = norm (Times a (Times a a));
    ns = norm (Times (Times a a) a);
    as = add_atoms nr (add_atoms ns [])
  in closure as (nr, ns)"
(*>*)
(*
text\<open>We illustate the nontermination using the Isar proof language:\<close>
notepad
begin
  have \<open>nderiv s = \<close> by simp
  have \<open>... = \<close> by simp
  have \<open>... = \<close> by simp
  have \<open>... = \<close> by simp
end
*)

section\<open>Conclusion\<close>

subsection\<open>Achievements\<close>
text\<open>As mentioned above, the method simplifies interactive proof development in Isabelle/HOL.
However, it also is an advancement of theoretical CS, as Brzozowski's simple algorithm was seldom
 considered before. Due to Nipkow's and Krauss' development, it might get more attention.
\<close>

text\<open>Simplicity is desirable for an Isabelle proof method: Not only is a small, elegant
 verification faster to
 re-run itself (AFP is run several times a day to test conformance to the Isabelle development
 version), the algorithm itself is also small, and has little dependencies.
Thus, we do not a expect a large build time increase when using the new proof method in
 other Isabelle projects.
\<close>

subsection\<open>Proof pearls\<close>
text\<open>Not so often, experts publish articles so polished and clear, that they are called \<^emph>\<open>Proof
 pearl\<close>.
The proof should be purposeful, and unexpected in its elegance and shortness. The authors compare
 their technique to the work of
 Braibant and
 Pous @{cite Braibant2010}, whose verified equivalence checker is more efficient, but very complex in
 the derivation.
 The paper's strength is that it mostly ignores standard textbook methods and finds inspiration
 instead in Brzozowski's paper @{cite "Brzozowski"}, which fits perfectly into the world of
 interactive theorem proving due to its simplicity.
\<close>

subsection\<open>Historical Remarks\<close>

text\<open>
Brzozoswki's RE derivatives are seldom-mentioned, which is surprising, considering they are such a
 natural counterpart to the (more often used) language derivatives.
  A quick search suggests that it took until 1998 until the simple algorithm above was formulated
 without automata theory.

Nipkow and Krauss mention as inspiration the \<^emph>\<open>Interactive Theorem Proving\<close> conference 2010,
 when Braibant and
 Pous @{cite "Braibant2010"} presented their tactic for the theorem prover coq. While their acquired
 algorithm is quite efficient and can handle arbitrary Kleene algebras, they need long and complex
 proofs for the verification (about 19000 lines compared to about 950 in the AFP entry's relevant
 theories).
\<close>

(*<*)
end
(*>*)


header {* Proving Relation (In)equalities via Regular Expressions *}

theory Regexp_Method
imports Equivalence_Checking Relation_Interpretation
begin

primrec rel_of_regexp :: "('a * 'a) set list \<Rightarrow> nat rexp \<Rightarrow> ('a * 'a) set" where
"rel_of_regexp vs Zero  = {}" |
"rel_of_regexp vs One  = Id" |
"rel_of_regexp vs (Atom i)  = vs ! i" |
"rel_of_regexp vs (Plus r s)  = rel_of_regexp vs r  \<union> rel_of_regexp vs s " |
"rel_of_regexp vs (Times r s)  = rel_of_regexp vs r O rel_of_regexp vs s" |
"rel_of_regexp vs (Star r)  = (rel_of_regexp vs r)^*"

lemma rel_of_regexp_rel: "rel_of_regexp vs r = rel (\<lambda>i. vs ! i) r"
by (induct r) auto

primrec rel_eq where
"rel_eq (r, s) vs = (rel_of_regexp vs r = rel_of_regexp vs s)"

lemma rel_eqI: "check_eqv r s \<Longrightarrow> rel_eq (r, s) vs"
unfolding rel_eq.simps rel_of_regexp_rel
by (rule Relation_Interpretation.soundness)
 (rule Equivalence_Checking.soundness)

lemmas regexp_reify = rel_of_regexp.simps rel_eq.simps
lemmas regexp_unfold = trancl_unfold_left subset_Un_eq

method_setup regexp = {*
  let
    val regexp_conv = Code_Runtime.static_holds_conv { ctxt = @{context},
      consts = [@{const_name "Nat.zero_nat_inst.zero_nat"}, @{const_name Suc},
       @{const_name Zero}, @{const_name One}, @{const_name Atom},
       @{const_name Plus}, @{const_name Times}, @{const_name Star},
       @{const_name check_eqv}, @{const_name Trueprop}] }
  in Scan.succeed (fn ctxt =>
      SIMPLE_METHOD' (
        (TRY o etac @{thm rev_subsetD})
        THEN' (Subgoal.FOCUS_PARAMS (fn {context = ctxt', ...} =>
          TRY (Local_Defs.unfold_tac ctxt' @{thms regexp_unfold})
          THEN Reification.tac ctxt' @{thms regexp_reify} NONE 1
          THEN rtac @{thm rel_eqI} 1
          THEN CONVERSION (regexp_conv ctxt') 1
          THEN rtac TrueI 1) ctxt)))
  end
*} "decide relation equalities via regular expressions"

hide_const (open) le_rexp nPlus nTimes norm nullable bisimilar is_bisimulation closure
  pre_bisim add_atoms check_eqv rel word_rel rel_eq

text {* Example: *}

lemma "(r \<union> s^+)^* = (r \<union> s)^*"
  by regexp

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

header "A Shallow Embedding of pGCL in HOL"

theory Embedding imports Misc Induction begin

subsection {* Core Primitives and Syntax *}

text_raw {* \label{s:syntax} *}

text {* A pGCL program is embedded directly as its strict or liberal transformer.  This is
achieved with an additional parameter, specifying which semantics should be obeyed. *}

type_synonym 's prog = "bool \<Rightarrow> ('s \<Rightarrow> real) \<Rightarrow> ('s \<Rightarrow> real)"

text {* @{term Abort} either always fails, @{term "\<lambda>P s. 0"}, or always succeeds,
@{term "\<lambda>P s. 1"}. *}
definition Abort :: "'s prog"
where     "Abort \<equiv> \<lambda>ab P s. if ab then 0 else 1"

text {* @{term Skip} does nothing at all. *}
definition Skip :: "'s prog"
where     "Skip \<equiv> \<lambda>ab P. P"

text {* @{term Apply} lifts a state transformer into the space of programs. *}
definition Apply :: "('s \<Rightarrow> 's) \<Rightarrow> 's prog"
where     "Apply f \<equiv> \<lambda>ab P s. P (f s)"

text {* @{term Seq} is sequential composition. *}
definition Seq :: "'s prog \<Rightarrow> 's prog \<Rightarrow> 's prog"
                 (infixl ";;" 59)
where     "Seq a b \<equiv> (\<lambda>ab. a ab o b ab)"

text {* @{term PC} is \emph{probabilistic} choice between programs. *}
definition PC :: "'s prog \<Rightarrow> ('s \<Rightarrow> real) \<Rightarrow> 's prog \<Rightarrow> 's prog"
                 ("_ \<^bsub>_\<^esub>\<oplus> _" [58,57,57] 57)
where     "PC a P b \<equiv> \<lambda>ab Q s. P s * a ab Q s + (1 - P s) * b ab Q s"

text {* @{term DC} is \emph{demonic} choice between programs. *}
definition DC :: "'s prog \<Rightarrow> 's prog \<Rightarrow> 's prog" ("_ \<Sqinter> _" [58,57] 57)
where     "DC a b \<equiv> \<lambda>ab Q s. min (a ab Q s) (b ab Q s)"

text {* @{term AC} is \emph{angelic} choice between programs. *}
definition AC :: "'s prog \<Rightarrow> 's prog \<Rightarrow> 's prog" ("_ \<Squnion> _" [58,57] 57)
where     "AC a b \<equiv> \<lambda>ab Q s. max (a ab Q s) (b ab Q s)"

text {* @{term Embed} allows any expectation transformer to be treated
  syntactically as a program, by ignoring the failure flag. *}
definition Embed :: "'s trans \<Rightarrow> 's prog"
where     "Embed t = (\<lambda>ab. t)"

text {* @{term Mu} is the recursive primitive, and is either then
  least or greatest fixed point. *}
definition Mu :: "('s prog \<Rightarrow> 's prog) \<Rightarrow> 's prog" (binder "\<mu>" 50)
where     "Mu(T) \<equiv> (\<lambda>ab. if ab then lfp_trans (\<lambda>t. T (Embed t) ab)
                               else gfp_trans (\<lambda>t. T (Embed t) ab))"

text {* @{term repeat} expresses finite repetition *}
primrec
  repeat :: "nat \<Rightarrow> 'a prog \<Rightarrow> 'a prog"
where
  "repeat 0 p = Skip" |
  "repeat (Suc n) p = p ;; repeat n p"

text {* @{term SetDC} is demonic choice between a set of alternatives,
  which may depend on the state. *}
definition SetDC :: "('a \<Rightarrow> 's prog) \<Rightarrow> ('s \<Rightarrow> 'a set) \<Rightarrow> 's prog"
  where "SetDC f S \<equiv> \<lambda>ab P s. Inf ((\<lambda>a. f a ab P s) ` S s)"

syntax "_SetDC" :: "pttrn => ('s => 'a set) => 's prog => 's prog"
                   ("\<Sqinter>_\<in>_./ _" 100)
translations "\<Sqinter>x\<in>S. p" == "CONST SetDC (%x. p) S"

text {* The above syntax allows us to write @{term "\<Sqinter>x\<in>S. Apply f"} *}

text {* @{term SetPC} is \emph{probabilistic} choice from a set.  Note that this is only
meaningful for distributions of finite support. *}
definition
  SetPC :: "('a \<Rightarrow> 's prog) \<Rightarrow> ('s \<Rightarrow> 'a \<Rightarrow> real) \<Rightarrow> 's prog"
where
  "SetPC f p \<equiv> \<lambda>ab P s. \<Sum>a\<in>supp (p s). p s a * f a ab P s"

text {* @{term Bind} allows us to name an expression in the current state, and re-use it later. *}
definition
  Bind :: "('s \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 's prog) \<Rightarrow> 's prog"
where
  "Bind g f ab \<equiv> \<lambda>P s. let a = g s in f a ab P s"

text {* This gives us something like let syntax *}
syntax "_Bind" :: "pttrn => ('s => 'a) => 's prog => 's prog"
       ("_ is _ in _" [55,55,55]55)
translations "x is f in a" => "CONST Bind f (%x. a)"

definition flip :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'c"
where [simp]: "flip f = (\<lambda>b a. f a b)"

text {* The following pair of translations introduce let-style syntax
  for @{term SetPC} and @{term SetDC}, respectively. *}
syntax "_PBind" :: "pttrn => ('s => real) => 's prog => 's prog"
                   ("bind _ at _ in _" [55,55,55]55)
translations "bind x at p in a" => "CONST SetPC (%x. a) (CONST flip (%x. p))"

syntax "_DBind" :: "pttrn => ('s => 'a set) \<Rightarrow> 's prog => 's prog"
                   ("bind _ from _ in _" [55,55,55]55)
translations "bind x from S in a" => "CONST SetDC (%x. a) S"

text {* The following syntax translations are for convenience when
  using a record as the state type. *}
syntax
  "_assign" :: "ident => 'a => 's prog" ("_ := _" [1000,900]900)
ML {*
  fun assign_tr _ [Const (name,_), arg] =
      Const ("Embedding.Apply", dummyT) $
      Abs ("s", dummyT,
           Syntax.const (suffix Record.updateN name) $
           Abs (Name.uu_, dummyT, arg $ Bound 1) $ Bound 0)
    | assign_tr _ ts = raise TERM ("assign_tr", ts)
*}
parse_translation {* [(@{syntax_const "_assign"}, assign_tr)] *}

syntax
  "_SetPC" :: "ident => ('s => 'a => real) => 's prog"
              ("choose _ at _" [66,66]66)
ML {*
  fun set_pc_tr _ [Const (f,_), P] =
      Const ("SetPC", dummyT) $
      Abs ("v", dummyT,
           (Const ("Embedding.Apply", dummyT) $
            Abs ("s", dummyT,
                 Syntax.const (suffix Record.updateN f) $
                 Abs (Name.uu_, dummyT, Bound 2) $ Bound 0))) $
      P
    | set_pc_tr _ ts = raise TERM ("set_pc_tr", ts)
*}
parse_translation {* [(@{syntax_const "_SetPC"}, set_pc_tr)] *}

syntax
  "_set_dc" :: "ident => ('s => 'a set) => 's prog" ("_ :\<in> _" [66,66]66)
ML {*
  fun set_dc_tr _ [Const (f,_), S] =
      Const ("SetDC", dummyT) $
      Abs ("v", dummyT,
           (Const ("Embedding.Apply", dummyT) $
            Abs ("s", dummyT,
                 Syntax.const (suffix Record.updateN f) $
                 Abs (Name.uu_, dummyT, Bound 2) $ Bound 0))) $
      S
    | set_dc_tr _ ts = raise TERM ("set_dc_tr", ts)
*}
parse_translation {* [(@{syntax_const "_set_dc"}, set_dc_tr)] *}

text {* These definitions instantiate the embedding as either
        weakest precondition (True) or weakest liberal precondition
        (False). *}

syntax
  "_set_dc_UNIV" :: "ident => 's prog" ("any _" [66]66)

translations
  "_set_dc_UNIV x" => "_set_dc x (%_. CONST UNIV)"

definition
  wp :: "'s prog \<Rightarrow> 's trans"
where
  "wp pr \<equiv> pr True"

definition
  wlp :: "'s prog \<Rightarrow> 's trans"
where
  "wlp pr \<equiv> pr False"

text {* If-Then-Else as a degenerate probabilistic choice. *}
abbreviation(input)
  if_then_else :: "['s \<Rightarrow> bool, 's prog, 's prog] \<Rightarrow> 's prog"
      ("If _ Then _ Else _" 58)
where
  "If P Then a Else b == a \<^bsub>\<guillemotleft>P\<guillemotright>\<^esub>\<oplus> b"

text {* Syntax for loops *}
abbreviation
  do_while :: "['s \<Rightarrow> bool, 's prog] \<Rightarrow> 's prog"
              ("do _ \<longrightarrow>// (4 _) //od")
where
  "do_while P a \<equiv> \<mu> x. If P Then a ;; x Else Skip"

subsection {* Unfolding rules for non-recursive primitives *}

lemma eval_wp_Abort:
  "wp Abort P = (\<lambda>s. 0)"
  unfolding wp_def Abort_def by(simp)

lemma eval_wlp_Abort:
  "wlp Abort P = (\<lambda>s. 1)"
  unfolding wlp_def Abort_def by(simp)

lemma eval_wp_Skip:
  "wp Skip P = P"
  unfolding wp_def Skip_def by(simp)

lemma eval_wlp_Skip:
  "wlp Skip P = P"
  unfolding wlp_def Skip_def by(simp)

lemma eval_wp_Apply:
  "wp (Apply f) P = P o f"
  unfolding wp_def Apply_def by(simp add:o_def)

lemma eval_wlp_Apply:
  "wlp (Apply f) P = P o f"
  unfolding wlp_def Apply_def by(simp add:o_def)

lemma eval_wp_Seq:
  "wp (a ;; b) P = (wp a o wp b) P"
  unfolding wp_def Seq_def by(simp)

lemma eval_wlp_Seq:
  "wlp (a ;; b) P = (wlp a o wlp b) P"
  unfolding wlp_def Seq_def by(simp)

lemma eval_wp_PC:
  "wp (a \<^bsub>Q\<^esub>\<oplus> b) P = (\<lambda>s. Q s * wp a P s + (1 - Q s) * wp b P s)"
  unfolding wp_def PC_def by(simp)

lemma eval_wlp_PC:
  "wlp (a \<^bsub>Q\<^esub>\<oplus> b) P = (\<lambda>s. Q s * wlp a P s + (1 - Q s) * wlp b P s)"
  unfolding wlp_def PC_def by(simp)

lemma eval_wp_DC:
  "wp (a \<Sqinter> b) P = (\<lambda>s. min (wp a P s) (wp b P s))"
  unfolding wp_def DC_def by(simp)

lemma eval_wlp_DC:
  "wlp (a \<Sqinter> b) P = (\<lambda>s. min (wlp a P s) (wlp b P s))"
  unfolding wlp_def DC_def by(simp)

lemma eval_wp_AC:
  "wp (a \<Squnion> b) P = (\<lambda>s. max (wp a P s) (wp b P s))"
  unfolding wp_def AC_def by(simp)

lemma eval_wlp_AC:
  "wlp (a \<Squnion> b) P = (\<lambda>s. max (wlp a P s) (wlp b P s))"
  unfolding wlp_def AC_def by(simp)

lemma eval_wp_Embed:
  "wp (Embed t) = t"
  unfolding wp_def Embed_def by(simp)

lemma eval_wlp_Embed:
  "wlp (Embed t) = t"
  unfolding wlp_def Embed_def by(simp)

lemma eval_wp_SetDC:
  "wp (SetDC p S) R s = Inf ((\<lambda>a. wp (p a) R s) ` S s)"
  unfolding wp_def SetDC_def by(simp)

lemma eval_wlp_SetDC:
  "wlp (SetDC p S) R s = Inf ((\<lambda>a. wlp (p a) R s) ` S s)"
  unfolding wlp_def SetDC_def by(simp)

lemma eval_wp_SetPC:
  "wp (SetPC f p) P = (\<lambda>s. \<Sum>a\<in>supp (p s). p s a * wp (f a) P s)"
  unfolding wp_def SetPC_def by(simp)

lemma eval_wlp_SetPC:
  "wlp (SetPC f p) P = (\<lambda>s. \<Sum>a\<in>supp (p s). p s a * wlp (f a) P s)"
  unfolding wlp_def SetPC_def by(simp)

lemma eval_wp_Mu:
  "wp (\<mu> t. T t) = lfp_trans (\<lambda>t. wp (T (Embed t)))"
  unfolding wp_def Mu_def by(simp)

lemma eval_wlp_Mu:
  "wlp (\<mu> t. T t) = gfp_trans (\<lambda>t. wlp (T (Embed t)))"
  unfolding wlp_def Mu_def by(simp)

lemma eval_wp_Bind:
  "wp (Bind g f) = (\<lambda>P s. wp (f (g s)) P s)"
  unfolding Bind_def wp_def Let_def by(simp)

lemma eval_wlp_Bind:
  "wlp (Bind g f) = (\<lambda>P s. wlp (f (g s)) P s)"
  unfolding Bind_def wlp_def Let_def by(simp)

text {* Use simp add:wp\_eval to fully unfold a program fragment *}
lemmas wp_eval = eval_wp_Abort eval_wlp_Abort eval_wp_Skip eval_wlp_Skip
                 eval_wp_Apply eval_wlp_Apply eval_wp_Seq eval_wlp_Seq
                 eval_wp_PC eval_wlp_PC eval_wp_DC eval_wlp_DC
                 eval_wp_AC eval_wlp_AC
                 eval_wp_Embed eval_wlp_Embed eval_wp_SetDC eval_wlp_SetDC
                 eval_wp_SetPC eval_wlp_SetPC eval_wp_Mu eval_wlp_Mu
                 eval_wp_Bind eval_wlp_Bind

lemma Skip_Seq:
  "Skip ;; A = A"
  unfolding Skip_def Seq_def o_def by(rule refl)

lemma Seq_Skip:
  "A ;; Skip = A"
  unfolding Skip_def Seq_def o_def by(rule refl)

text {* Use these as simp rules to clear out Skips *}
lemmas skip_simps = Skip_Seq Seq_Skip

end


theory ModelBase
  imports Tagging "../Functions/Functions"
  (* keywords "model_interpretation" "model_closed" "model_closed'" "base_model" "build_model" :: thy_goal  *)
begin

class ModelBase = Tagging + Function +
  fixes
    Variants :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" and
    \<alpha> :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> and
    Excluded :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes
    variants_typ1 : "Variants : (\<Pi> i : Tag. nonLimit \<rightarrow> Set \<rightarrow> SetOf (\<alpha> i))" and
    variants_typ2 : "Variants : (\<Pi> i : Tag. Limit \<rightarrow> Function \<rightarrow> SetOf (\<alpha> i))"
    (* smem_fmem_subtyp : "SetMem << FunMem" *)

context ModelBase begin

subsection \<open>Soft-typing rules for Variants\<close>

(* lemmas smem_fmem = subtypE[OF smem_fmem_subtyp] *)
(* lemmas ord_fmem = smem_fmem[OF ord_setmem] *)
lemmas tag_pmem = ord_pmem[OF tagD(1)]

lemma variants_setofseq1 :
  assumes j:"j : nonLimit" and x:"x : Set"
  shows "(\<lambda>i. Variants i j x) : (\<Pi> i : Tag. SetOf (\<alpha> i))"
  by (rule depfunI,
      use funE[OF funE[OF depfunE[OF variants_typ1]]] j x in auto)

lemma variants_setof :
  assumes i:"i : Tag" and j:"j : nonLimit" and x : "x : Set"
    shows "Variants i j x : SetOf (\<alpha> i)"
  by (rule depfunE[OF variants_setofseq1[OF j x] i])

lemmas variants_set = setof_set[OF variants_setof]

lemma variants_setseq1 :
  assumes j:"j : nonLimit" and x:"x : Set"
  shows "(\<lambda>i. Variants i j x) : (\<Pi> i : Tag. Set)"
  by (rule depfunI, rule variants_set[OF _ j x])

lemma variants_setofseq2 :
  assumes j:"j : Limit" and f:"f : Function"
  shows "(\<lambda>i. Variants i j f) : (\<Pi> i : Tag. SetOf (\<alpha> i))"
  by (rule depfunI,
      use funE[OF funE[OF depfunE[OF variants_typ2]]] j f in auto)

lemma variants_setof2 :
  assumes i:"i : Tag" and j:"j : Limit" and f:"f : Function"
    shows "Variants i j f : SetOf (\<alpha> i)"
  by (rule depfunE[OF variants_setofseq2[OF j f] i])

lemmas variants_set2 = setof_set[OF variants_setof2]

lemma variants_setseq2 :
  assumes j:"j : Limit" and x:"x : Function"
  shows "(\<lambda>i. Variants i j x) : (\<Pi> i : Tag. Set)"
  by (rule depfunI, rule variants_set2[OF _ j x])

subsection \<open>Operator for removing Excluded stuff from a set/type\<close>

definition RemoveExcluded :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix \<open>\<ominus>\<close> 60)
  where "RemoveExcluded x i \<equiv> { b \<in> x | \<not> Excluded i b }"

definition RemoveExcludedTyp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> bool)" (infix \<open>\<oslash>\<close> 50)
  where "P \<oslash> i \<equiv> P \<sslash> (Excluded i)"

lemma extypD1 :
  assumes "x : P \<oslash> i"
  shows "x : P"
  using assms unfolding RemoveExcludedTyp_def diff_typ_iff by auto

lemma exset_set :
  assumes "x : Set"
  shows "x \<ominus> i : Set"
  unfolding RemoveExcluded_def
  by (rule collect_set[OF assms])

lemma exset_iff :
  assumes "x : Set"
  shows "b \<in> x \<ominus> i \<longleftrightarrow> b \<in> x \<and> \<not> Excluded i b"
  unfolding RemoveExcluded_def
  using collect_iff[OF assms] by auto

lemma exsetI :
  assumes x:"x : Set"
      and b:"b \<in> x" "\<not> Excluded i b"
    shows "b \<in> x \<ominus> i"
  unfolding RemoveExcluded_def
  using collectI[OF x] b by auto

lemma exsetD1 :
  assumes x:"x : Set" and b:"b \<in> x \<ominus> i"
  shows "b \<in> x"
  using exset_iff x b by auto

lemma exsetD2 :
  assumes x:"x : Set" and b:"b \<in> x \<ominus> i"
  shows "\<not> Excluded i b"
  using exset_iff x b by auto

lemma exsetD_conj :
  assumes x:"x : Set" and b:"b \<in> x \<ominus> i"
  shows "b \<in> x \<and> \<not> Excluded i b"
  using exset_iff x b by auto

lemma exsetE :
  assumes x:"x : Set" and b:"b \<in> x \<ominus> i"
  obtains "b \<in> x" "\<not> Excluded i b"
  using exset_iff x b by auto

lemma ex_subset1 :
  assumes x:"x : Set" and y:"y : Set"
      and sub:"x \<subseteq> y"
    shows "a \<subseteq> x \<ominus> i \<Longrightarrow> a \<subseteq> y \<ominus> i"
  using subset_iff exset_iff x y sub
  by auto

lemma ex_subset2 :
  assumes x:"x : Set" and y:"y : Set"
    shows "x \<subseteq> y \<ominus> i \<Longrightarrow> x \<subseteq> y"
  using subset_iff exset_iff x y
  by auto

lemma ex_subset3 :
  assumes x:"x : Set" and y:"y : Set"
      and sub:"x \<subseteq> y"
    shows "x \<ominus> i \<subseteq> y \<ominus> i"
  using subset_iff exset_iff x y sub
  by auto

section \<open>Tier -- model building operator\<close>

abbreviation Tier_zero :: 'a
  where "Tier_zero \<equiv> \<Uplus> (\<lambda>i. Variants i 0 \<emptyset>)"

abbreviation Tier_succ :: "['a, 'a] \<Rightarrow> 'a"
  where "Tier_succ j x \<equiv> x \<union> \<Uplus> (\<lambda>i. Variants i j (x \<ominus> i))"

abbreviation Tier_lim :: "['a, 'a \<Rightarrow> 'a] \<Rightarrow> 'a"
  where "Tier_lim \<mu> f \<equiv> (\<Union> {f j | j < \<mu>})
                      \<union> \<Uplus> (\<lambda>i. Variants i \<mu> (\<lambda>j<\<mu>. f j \<ominus> i))"

definition Tier :: "'a \<Rightarrow> 'a" where
 "Tier \<equiv> OrdRec Tier_lim Tier_succ Tier_zero"

lemma tier_cases :
  shows "Tier 0 = Tier_zero"
    and "j : Ord \<Longrightarrow> Tier (succ j) = Tier_succ (succ j) (Tier j)"
    and "\<mu> : Limit \<Longrightarrow> Tier \<mu> = Tier_lim \<mu> (\<lambda>j. if j : Ord \<and> j < \<mu> then Tier j else OrdRec_default)"
  unfolding Tier_def
  by (simp add: ordrec_0, use ordrec_succ ordrec_lim in auto)

subsection \<open>All Tiers are sets\<close>

lemma tier_zero_set :
  "Tier 0 : Set"
  unfolding tier_cases(1)
  by (rule disj_set[OF variants_setseq1[OF zero_nonlimit emp_set]])

lemma variants_succ_setseq :
  assumes j:"j : Ord" and x:"x : Set"
    shows "(\<lambda>i. Variants i (succ j) (x \<ominus> i)) : (\<Pi> i : Tag. Set)"
proof (rule depfunI)
  fix i assume "i : Tag"
  thus "Variants i (succ j) (x \<ominus> i) : Set"
  by (rule depfunE[OF variants_setseq1[OF succ_nonlimit[OF j] exset_set[OF x, of]], of i i])
qed

lemma tier_succ_set_ih :
  assumes j:"j : Ord"
      and tj : "Tier j : Set"
  shows "Tier (succ j) : Set"
  unfolding tier_cases(2)[OF j]
  by (rule un_set[OF tj disj_set[OF variants_succ_setseq[OF j tj]]])

(* lemma limit_fmem :
  assumes \<mu>:"\<mu> : Limit"
  shows "predSet \<mu> : SetOf FunMem"
  using setofI[OF predset_set] ord_fmem[OF predset_mem_ord] limit_ord[OF \<mu>] by auto
 *)
(* lemma tier_fmem' :
  assumes \<mu>:"\<mu> : Limit"
      and t\<mu> : "\<And>j. j : Ord \<Longrightarrow> j < \<mu> \<Longrightarrow> Tier j : Set"
    shows "Tier : predSet \<mu> \<leadsto> FunMem"
proof (rule mem_funI)
  fix j assume "j \<in> predSet \<mu>"
  hence "j : Ord" "j < \<mu>"
    using predsetD[OF limit_ord[OF \<mu>]] by auto
  thus "Tier j : FunMem" using smem_fmem[OF set_setmem[OF t\<mu>]] by auto
qed
 *)
lemma tier_lim_set :
  assumes \<mu>:"\<mu> : Limit"
      and t\<mu> : "\<And>j. j : Ord \<Longrightarrow> j < \<mu> \<Longrightarrow> Tier j : Set"
    shows "Tier : MemOf (predSet \<mu>) \<rightarrow> Set"
 by (rule funI, drule memofD, drule predsetD[OF limit_ord[OF \<mu>]],
     use t\<mu> in auto)

lemma tier_replfun' :
  assumes \<mu> : "\<mu> : Limit"
      and t\<mu> : "\<And>j. j : Ord \<Longrightarrow> j < \<mu> \<Longrightarrow> Tier j : Set"
    shows "Tier : (predSet \<mu>) \<leadsto> Set"
  by (rule mem_funI, use predsetD[OF limit_ord[OF \<mu>]] t\<mu> in auto)

(* lemma lam_tier_replfun' :
  assumes \<mu> : "\<mu> : Limit"
      and t\<mu> : "\<And>j. j : Ord \<Longrightarrow> j < \<mu> \<Longrightarrow> Tier j : Set"
  defines "t \<equiv> (\<lambda>j<\<mu>. Tier j)"
    shows "(\<lambda>j. t ` j) : ReplFun (predSet \<mu>) Ord Set"
 unfolding ReplFun_def
proof (rule intI[OF setfunI funI])
  fix j assume "j \<in> predSet \<mu>"
  hence "j : Ord" "j < \<mu>" "t ` j = Tier j"
    unfolding t_def
    using predsetD[OF limit_ord[OF \<mu>]]
          lam_app[OF limit_fmem[OF \<mu>] tier_fmem'[OF \<mu> t\<mu>]] by auto
  thus "t ` j : SetMem" using set_setmem t\<mu> by auto
next
  fix j assume j:"j : (Ord \<bar> MemOf (predSet \<mu>))"
  hence "j : Ord" "j < \<mu>" "t ` j = Tier j"
  unfolding t_def
  using intE[OF j] memofD predsetD[OF limit_ord[OF \<mu>]]
        lam_app[OF limit_fmem[OF \<mu>] tier_fmem'[OF \<mu> t\<mu>]]
    by auto
  thus "t ` j : Set" using t\<mu> by auto
qed       *)

lemma variants_limit_setseq' :
  assumes \<mu> : "\<mu> : Limit"
  defines "t \<equiv> (\<lambda>j. if j : Ord \<and> j < \<mu> then Tier j else OrdRec_default)"
  shows "(\<lambda>i. Variants i \<mu> (\<lambda>j<\<mu>. t j \<ominus> i)) : (\<Pi> i : Tag. Set)"
proof (rule depfunI)
  fix i assume i:"i : Tag"
  have "(\<lambda>j<\<mu>. t j \<ominus> i) : Function"
    by (rule lam_fun[OF predset_set[OF limit_ord[OF \<mu>]]])
  thus "Variants i \<mu> (\<lambda>j<\<mu>. t j \<ominus> i) : Set"
    by (rule depfunE[OF variants_setseq2[OF \<mu> _] i])
qed

lemma tier_lim_set_ih :
  assumes \<mu>:"\<mu> : Limit"
      and t\<mu> : "\<And>j. j : Ord \<Longrightarrow> j < \<mu> \<Longrightarrow> Tier j : Set"
    shows "Tier \<mu> : Set"
  unfolding tier_cases(3)[OF \<mu>]
proof (rule un_set[OF union_set])
  let ?L = "\<lambda>j. if j : Ord \<and> j < \<mu> then Tier j else OrdRec_default"
  show "{ ?L j | j<\<mu> } : SetOf Set"
  by (rule repfun_ord_setof[OF limit_ord[OF \<mu>] mem_funI],
      drule predsetD[OF limit_ord[OF \<mu>]], use t\<mu> in auto)
  show "\<Uplus> (\<lambda>i. Variants i \<mu> (\<lambda>j<\<mu>. ?L j \<ominus> i)) : Set"
  by (rule disj_set[OF variants_limit_setseq'[OF \<mu>]])
qed

theorem tier_set :
  "j : Ord \<Longrightarrow> Tier j : Set"
  by (erule trans_induct3,
      use tier_zero_set tier_succ_set_ih tier_lim_set_ih in auto)

lemma tier_ex_set :
  "j : Ord \<Longrightarrow> Tier j \<ominus> i : Set"
  by (rule exset_set[OF tier_set])

(* lemma tier_fmem :
  assumes \<mu>:"\<mu> : Limit"
    shows "Tier : (predSet \<mu>) \<leadsto> FunMem"
  using tier_fmem'[OF \<mu> tier_set] by auto
 *)
lemma tier_replfun :
  assumes \<mu> : "\<mu> : Limit"
  shows "Tier : (predSet \<mu>) \<leadsto> Set"
  using tier_replfun'[OF \<mu> tier_set] by auto

lemmas lim_predset_set = predset_set[OF limit_ord]

lemma tier_restrict_replfun :
  assumes \<mu> : "\<mu> : Limit"
  shows "(\<lambda>j. if j : Ord \<and> j < \<mu> then Tier j else OrdRec_default) : (predSet \<mu>) \<leadsto> Set"
  by (rule mem_funI, frule predsetD[OF limit_ord[OF \<mu>]],
      use mem_funE[OF tier_replfun[OF \<mu>]] in auto)

lemma lam_tier_restrict_eq :
  assumes \<mu> : "\<mu> : Limit"
  shows "(\<lambda>j<\<mu>. (\<lambda>j. if j : Ord \<and> j < \<mu> then Tier j else OrdRec_default) j \<ominus> i) = (\<lambda>j<\<mu>. Tier j \<ominus> i)"
  by (rule lam_cong[OF lim_predset_set[OF \<mu>]],
      drule predsetD[OF limit_ord[OF \<mu>]], auto)

(* lemma lam_tier_replfun :
  assumes \<mu> : "\<mu> : Limit"
  defines "t \<equiv> (\<lambda>j<\<mu>. Tier j)"
  shows "(\<lambda>j. t ` j) : ReplFun (predSet \<mu>) Ord Set"
  unfolding t_def
  using lam_tier_replfun'[OF \<mu> tier_set] by auto *)

lemma lam_limit_fun :
  assumes "u : Limit"
  shows "(\<lambda>i<u. F i) : Function"
    using lam_fun[OF predset_set[OF limit_ord[OF assms]]] .
(*
lemma lam_tier_app :
  assumes \<mu>:"\<mu> : Limit"
      and j:"j : Ord" "j < \<mu>"
    shows "(\<lambda>j<\<mu>. Tier j) ` j = Tier j"
  using lam_app[OF predset_set[OF limit_ord[OF \<mu>]] tier_fmem[OF \<mu>]]
        predsetI[OF \<open>j : Ord\<close> limit_ord[OF \<mu>] \<open>j < \<mu>\<close>]
        ord_fmem[OF j(1)] by auto *)

(* lemma lam_tier_ex_eq :
  assumes \<mu>:"\<mu> : Limit"
  shows "(\<lambda>j<\<mu>. (\<lambda>j<\<mu>. Tier j) ` j \<ominus> i) = (\<lambda>j<\<mu>. Tier j \<ominus> i)"
proof (rule lam_cong[OF limit_fmem[OF \<mu>]], rule funI, drule memofD, drule predsetD[OF limit_ord[OF \<mu>]])
  fix j assume "j : Ord \<and> j < \<mu>"
  thus "(\<lambda>j<\<mu>. Tier j) ` j \<ominus> i : FunMem"
    using smem_fmem[OF set_setmem[OF exset_set[OF tier_set]]]
          lam_tier_app[OF \<mu>] by auto
next
  show "(\<lambda>b. Tier b \<ominus> i) : MemOf (predSet \<mu>) \<rightarrow> FunMem"
    by (rule funI, drule memofD, drule predsetD[OF limit_ord[OF \<mu>]],
       rule smem_fmem[OF set_setmem[OF exset_set[OF tier_set]]], auto)
next
  fix j assume "j \<in> predSet \<mu>"
  hence "j : Ord" "j < \<mu>" using predsetD[OF limit_ord[OF \<mu>]] by auto
  thus "(\<lambda>j<\<mu>. Tier j) ` j \<ominus> i = Tier j \<ominus> i" using lam_tier_app[OF \<mu>] by auto
qed *)

lemma lam_tier_fun :
  assumes \<mu>:"\<mu> : Limit"
    shows "(\<lambda>j<\<mu>. Tier j) : Function"
 using lam_fun[OF lim_predset_set[OF \<mu>]] .

lemma lam_tier_ex_fun :
  assumes \<mu>:"\<mu> : Limit"
    shows "(\<lambda>j<\<mu>. Tier j \<ominus> i) : Function"
  using lam_limit_fun[OF \<mu>] .

lemma ord_ex_iff :
  assumes i:"i : Ord"
  shows "(\<exists>j\<in>predSet i. P j) \<longleftrightarrow> (\<exists>j<i. P j)"
  unfolding bex_def rex_def tex_def
  using predsetI predsetD i
  by metis

lemma variants_limit_setseq :
  assumes \<mu> : "\<mu> : Limit"
  defines "t \<equiv> (\<lambda>j. if j : Ord \<and> j < \<mu> then Tier j else OrdRec_default)"
  shows "(\<lambda>i. Variants i \<mu> (\<lambda>j<\<mu>. t j \<ominus> i)) : (\<Pi> i : Tag. Set)"
  unfolding t_def
  using variants_limit_setseq'[OF \<mu> ] .

subsection \<open>Rules for Tiers\<close>

subsubsection \<open>Tier 0\<close>

lemma variants0_pair :
  assumes i : "i : Tag" and b' : "b' \<in> Variants i 0 \<emptyset>"
    shows "<i,b'> : Pair"
  using pair_pair[OF tag_pmem[OF i] smem_pmem[OF setmemI]]
        variants_set[OF i zero_nonlimit emp_set] b'
  by auto

lemma tier0_iff :
  "b \<in> Tier 0 \<longleftrightarrow> (\<exists> i : Tag. \<exists>b' \<in> Variants i 0 \<emptyset>. b : Pair \<and> b = <i,b'>)"
  unfolding tier_cases(1)
  by (rule disj_iff[OF variants_setseq1[OF zero_nonlimit emp_set]])

lemma tier0I :
  assumes i:"i : Tag" and b':"b' \<in> Variants i 0 \<emptyset>"
    shows "<i,b'> \<in> Tier 0"
proof -
  have "<i,b'> : Pair"
    using pair_pair[OF tag_pmem[OF i(1)] smem_pmem[OF setmemI]]
          variants_set[OF i zero_nonlimit emp_set] b' by metis
  thus "<i,b'> \<in> Tier 0" unfolding tier0_iff using i b' by auto
qed

lemma tier0E :
  assumes b:"b \<in> Tier 0"
  obtains i b' where "i : Tag" "b' \<in> Variants i 0 \<emptyset>" "b : Pair" "b = <i,b'>"
  using b unfolding tier0_iff by auto

lemma tier0D :
  assumes b:"<i,b'> \<in> Tier 0"
  shows "i : Tag" "b' \<in> Variants i 0 \<emptyset>" "<i,b'> : Pair"
proof -
  from tier0E[OF b] obtain j c'
    where "j : Tag" "c' \<in> Variants j 0 \<emptyset>" "<j,c'> : Pair" "<i,b'> = <j,c'>"
    by metis
  moreover hence "i = j" "b' = c'" using pair_inject by auto
  ultimately show "i : Tag" "b' \<in> Variants i 0 \<emptyset>" "<i,b'> : Pair" by auto
qed

subsubsection \<open>Tier 'succ'\<close>

lemma variants_succ_pair :
  assumes i : "i : Tag" and j : "j : Ord"
      and b' : "b' \<in> Variants i (succ j) (Tier j \<ominus> i)"
    shows "<i,b'> : Pair"
  using pair_pair[OF tag_pmem[OF i(1)] smem_pmem[OF setmemI]]
        variants_set[OF i succ_nonlimit[OF j] tier_ex_set[OF j]] b'
  by auto

lemma tier_succ_iff :
  assumes j:"j: Ord"
  shows "b \<in> Tier (succ j) \<longleftrightarrow> b \<in> Tier j \<or>
          (\<exists>i : Tag. \<exists>b'\<in> Variants i (succ j) (Tier j \<ominus> i). b : Pair \<and> b = <i,b'>)"
  unfolding tier_cases(2)[OF assms]
            un_iff[OF tier_set[OF j] disj_set[OF variants_succ_setseq[OF j tier_set[OF j]]]]
            disj_iff[OF  variants_succ_setseq[OF j tier_set[OF j]]]
  by rule

lemma tier_succI1 :
  assumes j : "j  : Ord"
      and b : "b \<in> Tier j"
    shows "b \<in> Tier (succ j)"
  using tier_succ_iff[OF j] b by auto

lemma tier_succI2 :
  assumes i : "i : Tag" and j : "j : Ord"
    and b' : "b' \<in> Variants i (succ j) (Tier j \<ominus> i)"
  shows "<i,b'> \<in> Tier (succ j)"
  using tier_succ_iff[OF j] i b'
        variants_succ_pair[OF i j b']
  by auto

lemma tier_succE :
  assumes
    j : "j : Ord" and b : "b \<in> Tier (succ j)"
  obtains (pred) "b \<in> Tier j"
        | (fresh) i b' where "i : Tag" "b : Pair" "b = <i,b'>"
                       "b' \<in> Variants i (succ j) (Tier j \<ominus> i)"
  using b unfolding tier_succ_iff[OF j]
  by blast

lemma tier_succE_pair :
  assumes
     j : "j : Ord" and b : "<i,b'> \<in> Tier (succ j)"
   obtains
     (pred)  "<i,b'> \<in> Tier j"
   | (fresh) "b' \<in> Variants i (succ j) (Tier j \<ominus> i)"
  by (erule tier_succE[OF j b], metis pair_inject)

lemma tier_subset_succ :
  assumes j:"j : Ord"
  shows "Tier j \<subseteq> Tier (succ j)"
  using tier_succI1[OF j] by auto

lemma tier_ex_subset_succ :
  assumes j:"j : Ord"
  shows "Tier j \<ominus> i \<subseteq> Tier (succ j) \<ominus> i"
  using ex_subset1[OF tier_set[OF j] tier_set[OF succ_ord[OF j]] tier_subset_succ[OF j] subset_refl]
  by auto

subsubsection \<open>Tier 'limit'\<close>

lemma variants_limit_pair :
  assumes i : "i : Tag" and \<mu> : "\<mu> : Limit"
      and b' : "b' \<in> Variants i \<mu> (\<lambda>j<\<mu>. Tier j \<ominus> i)"
    shows "<i,b'> : Pair"
  using pair_pair[OF tag_pmem[OF i(1)] smem_pmem[OF setmemI]]
        variants_set2[OF i \<mu> lam_tier_ex_fun[OF \<mu>]] b'
  by auto

lemma tier_lim_iff :
  assumes \<mu>:"\<mu> : Limit"
  shows "b \<in> Tier \<mu> \<longleftrightarrow> (\<exists>j<\<mu>. b \<in> Tier j)
          \<or> (\<exists> i : Tag. \<exists>b'\<in> Variants i \<mu> (\<lambda>j<\<mu>. Tier j \<ominus> i). b : Pair \<and> b = <i,b'>)"
  unfolding tier_cases(3)[OF \<mu>]
            un_iff[OF repfun_union_ord_set[OF limit_ord[OF \<mu>] tier_restrict_replfun[OF \<mu>]]
                      disj_set[OF variants_limit_setseq[OF \<mu>]]]
 unfolding disj_iff[OF variants_limit_setseq[OF \<mu>]]
           repfun_union[OF predset_set[OF limit_ord[OF \<mu>]] tier_restrict_replfun[OF \<mu>]]
 unfolding lam_tier_restrict_eq[OF \<mu>] tex_def
           ord_ex_iff[OF limit_ord[OF \<mu>]] by auto

lemma tier_limI1 :
  assumes \<mu> : "\<mu> : Limit" and j : "j : Ord" "j < \<mu>"
      and b : "b \<in> Tier j"
    shows "b \<in> Tier \<mu>"
  unfolding tier_lim_iff[OF \<mu>]
  using b j by auto

lemma tier_limI2 :
  assumes i : "i : Tag" and \<mu> : "\<mu> : Limit"
      and b : "b' \<in> Variants i \<mu> (\<lambda>j<\<mu>. Tier j \<ominus> i)"
    shows "<i,b'> \<in> Tier \<mu>"
  unfolding tier_lim_iff[OF \<mu>]
  using b i variants_limit_pair[OF i \<mu>] by auto

lemma tier_limE :
  assumes
    \<mu> : "\<mu> : Limit" and
    b : "b \<in> Tier \<mu>"
  obtains (pred)  j where "j : Ord" "j < \<mu>" "b \<in> Tier j"
        | (fresh) i b' where "i : Tag" "b : Pair" "b = <i,b'>"
                       "b' \<in> Variants i \<mu> (\<lambda>j<\<mu>. Tier j \<ominus> i)"
  using b unfolding tier_lim_iff[OF \<mu>]
  by blast

lemma tier_limE_pair :
  assumes
    \<mu> : "\<mu> : Limit" and
    b : "<i,b'> \<in> Tier \<mu>"
  obtains (pred)  j where "j : Ord" "j < \<mu>" "<i,b'> \<in> Tier j"
        | (fresh) "b' \<in> Variants i \<mu> (\<lambda>j<\<mu>. Tier j \<ominus> i)"
  by (erule tier_limE[OF \<mu> b], metis pair_inject)

lemma tier_limit_union :
  assumes \<mu>:"\<mu> : Limit"
  shows "(\<Union> j<\<mu>. Tier j) \<subseteq> Tier \<mu>"
proof
  fix a assume "a \<in> (\<Union> j<\<mu>. Tier j)"
  then obtain j where "j : Ord" "j < \<mu>" "a \<in> Tier j"
    using repfun_union[OF lim_predset_set[OF \<mu>] tier_replfun[OF \<mu>]]
          predsetD[OF limit_ord[OF \<mu>]] by auto
  thus "a \<in> Tier \<mu>"
    unfolding tier_lim_iff[OF \<mu>]
    by auto
qed

lemma tier_limit_subset :
  assumes \<mu> : "\<mu> : Limit"
      and j : "j : Ord" "j < \<mu>"
    shows "Tier j \<subseteq> Tier \<mu>"
    using repfun_union_subset[OF lim_predset_set[OF \<mu>]
                                 tier_set[OF j(1)] tier_replfun[OF \<mu>]
                                 predsetI[OF j(1) limit_ord[OF \<mu>] j(2)] subset_refl]
           subset_trans[OF _ tier_limit_union[OF \<mu>]]
    by auto

lemma tier_limit_ex_subset :
  assumes \<mu> : "\<mu> : Limit"
      and j : "j : Ord" "j < \<mu>"
    shows "Tier j \<ominus> i \<subseteq> Tier \<mu> \<ominus> i"
  using ex_subset1[OF tier_set[OF j(1)] tier_set[OF limit_ord[OF \<mu>]]
                      tier_limit_subset[OF assms] subset_refl]
  by auto

subsection \<open>Tier is a cumulative hierarchy\<close>
(*
lemma tier_ord :
  assumes j : "j : Ord"
      and b : "b \<in> Tier j"
  obtains i b' where "i : Tag" "b : Pair" "b = <i,b'>"
*)

lemma tier_increasing :
  assumes i:"i : Ord" and j:"j : Ord"
  shows "i < j \<Longrightarrow> Tier i \<subseteq> Tier j"
proof (induct rule: trans_induct3[OF j])
  case 1
  then show ?case
  using zero_lt[OF i] by auto
next
  case IH:(2 j)
  show ?case
  proof (rule leqE[OF i \<open>j : Ord\<close> \<open>i \<le> j\<close>])
    assume "i < j"
    hence "Tier i \<subseteq> Tier j" by (rule IH(2))
    thus "Tier i \<subseteq> Tier (succ j)"
      by (rule subset_trans[OF _ tier_subset_succ[OF \<open>j : Ord\<close>]])
  next
    assume "i = j"
    thus "Tier i \<subseteq> Tier (succ j)"
      using tier_subset_succ[OF i] by auto
  qed
next
  case IH:(3 \<mu>)
  show ?case using tier_limit_subset[OF IH(1) i IH(3)] by simp
qed

lemma tier_increasing_leq :
  assumes i:"i : Ord" and j:"j : Ord"
  shows "i \<le> j \<Longrightarrow> Tier i \<subseteq> Tier j"
  unfolding leq_iff[OF i j]
  using tier_increasing[OF i j] by auto

lemma greatest_tier :
  assumes i : "i : Ord" and j : "j : Ord"
      and b : "b \<in> Tier i" and c : "c \<in> Tier j"
  obtains k where "k : Ord" "b \<in> Tier k" "c \<in> Tier k"
proof (rule linear[OF i j])
  assume "i < j"
  hence "j : Ord" "b \<in> Tier j" "c \<in> Tier j"
    using tier_increasing[OF i j] b c j by auto
  thus ?thesis ..
next
  assume "i = j"
  hence "j : Ord" "b \<in> Tier j" "c \<in> Tier j"
    using j b c by auto
  thus ?thesis ..
next
  assume "j < i"
  hence "i : Ord" "b \<in> Tier i" "c \<in> Tier i"
    using tier_increasing[OF j i] b c i by auto
  thus ?thesis ..
qed

lemma greatest_tier_subset :
  assumes i : "i : Ord" and j : "j : Ord"
      and xy : "x \<subseteq> Tier i" "y \<subseteq> Tier j"
   obtains k where "k : Ord" "x \<subseteq> Tier k" "y \<subseteq> Tier k"
   using linear_leq[OF i j]
    tier_increasing_leq[OF i j] tier_increasing_leq[OF j i]
    xy i j subset_trans by meson

lemma tier_typ_setof_depsum :
  "Tier : Ord \<rightarrow> SetOf (\<Sigma> i : Tag. \<alpha> i)"
proof (rule funI, rule setofI[OF tier_set], auto)
  fix j b assume "j : Ord" thus "b \<in> Tier j \<Longrightarrow> b : (\<Sigma> i : Tag. \<alpha> i)"
  proof (induct j rule: trans_induct3)
    case zero show ?case
    proof (rule tier0E[OF zero], auto, rule depsumI, auto)
      fix i b'
      assume "i : Tag" and "b' \<in> Variants i 0 \<emptyset>"
      thus "b' : \<alpha> i" by (rule setof_mem[OF variants_setof[OF _ zero_nonlimit emp_set]])
    qed
  next
    case (succ j)
    show ?case
    proof (rule tier_succE[OF succ(1,3) succ(2)], auto,
           rule depsumI, auto)
      fix i b'
      assume "i : Tag" and "b' \<in> Variants i (succ j) (Tier j \<ominus> i)"
      thus "b' : \<alpha> i"
        using setof_mem[OF variants_setof[OF _ succ_nonlimit tier_ex_set]] \<open>j : Ord\<close> by auto
    qed
  next
    case (lim \<mu>)
    show ?case
    proof (rule tier_limE[OF \<open>\<mu> : Limit\<close> \<open>b \<in> Tier \<mu>\<close>], use lim(2) in auto,
           rule depsumI, auto)
      fix i b'
      assume "i : Tag" "b' \<in> Variants i \<mu> (\<lambda>j<\<mu>. Tier j \<ominus> i)"
      thus "b' : \<alpha> i"
        using setof_mem[OF variants_setof2[OF _ lim(1) lam_tier_ex_fun[OF lim(1)]]] by auto
    qed
  qed
qed

lemmas tier_setof_depsum = funE[OF tier_typ_setof_depsum]
lemmas tier_setof_pair = subtypE[OF setof_subtyp[OF depsum_pair_subtyp] tier_setof_depsum]
lemmas tier_mem_depsum = setof_mem[OF tier_setof_depsum]
lemmas tier_mem_pair = setof_mem[OF tier_setof_pair]

subsection \<open>Part of Tier\<close>

lemma tier0_partI :
  assumes i : "i : Tag"
      and b : "b = <i,b'>"
      and b': "b' \<in> Variants i 0 \<emptyset>"
  shows "b :\<^enum> i" "b \<in> Tier 0"
  using partI[OF b] tier0I[OF i b'] variants0_pair[OF i b'] b
  by auto

lemma tier0_partE :
  assumes b:"b \<in> Tier 0" "b :\<^enum> i"
  obtains b' where "i : Tag"
    "b : Pair" "b = <i,b'>" "b' \<in> Variants i 0 \<emptyset>"
  by (rule partE[OF b(2)], metis tier0D(1-3) b(1))

lemma tier0_partD :
  assumes ib:"<i,b'> \<in> Tier 0"
  shows "<i,b'> :\<^enum> i"
  using partI[OF _ tier0D(3)[OF ib]]
  by auto

lemma tier_succ_partI1 :
  assumes i : "i : Tag" and j : "j : Ord"
      and b : "<i,b'> \<in> Tier j"
    shows "<i,b'> :\<^enum> i" "<i,b'> \<in> Tier (succ j)"
  using partI tier_succI1[OF j] b tier_mem_pair[OF j b]
  by auto

lemma tier_succ_partI2 :
  assumes i : "i : Tag" and j : "j : Ord"
      and b': "b' \<in> Variants i (succ j) (Tier j \<ominus> i)"
      and b : "b = <i,b'>"
    shows "b :\<^enum> i" "b \<in> Tier (succ j)"
  using partI[OF b] tier_succI2[OF i j b'] variants_succ_pair[OF i j b'] b
  by auto

lemma tier_succ_partE :
  assumes j : "j : Ord"
      and b : "b \<in> Tier (succ j)" "b :\<^enum> i"
  obtains
      (pred)  b' where "i : Tag" "b : Pair" "b = <i,b'>" "b \<in> Tier j"
    | (fresh) b' where "i : Tag"
      "b : Pair" "b = <i,b'>" "b' \<in> Variants i (succ j) (Tier j \<ominus> i)"
proof (rule partE[OF b(2)])
  fix b' assume B: "b : Pair" "b = <i,b'>"
  thus ?thesis
  proof (cases rule: tier_succE[OF j b(1)])
    case pred : 1
    hence "i : Tag" "b : Pair" "b = <i,b'>" "b \<in> Tier j"
      using depsumD_pair(2)[of i b', OF tier_mem_depsum[OF j]] B
      by auto
     thus ?thesis ..
  next
    case fresh:(2 i' c')
    have "i' = i" "c' = b'"
      using pair_inject B fresh(3) by auto
      hence "i : Tag" "b : Pair" "b = <i,b'>"
        "b' \<in> Variants i (succ j) (Tier j \<ominus> i)"
     using fresh B by auto
     thus ?thesis ..
   qed
qed

end
end


theory DNEList imports
  "$AFP/Applicative_Lifting/Applicative_List"
  "~~/src/HOL/Library/Dlist"
begin

lemma bind_eq_Nil_iff [simp]: "List.bind xs f = [] \<longleftrightarrow> (\<forall>x\<in>set xs. f x = [])"
by(simp add: List.bind_def)

lemma zip_eq_Nil_iff [simp]: "zip xs ys = [] \<longleftrightarrow> xs = [] \<or> ys = []"
by(cases xs ys rule: list.exhaust[case_product list.exhaust]) simp_all

lemma fst_swap [simp]: "fst (prod.swap x) = snd x"
by(cases x) simp

lemma snd_swap [simp]: "snd (prod.swap x) = fst x"
by(cases x) simp

lemma remdups_append1: "remdups (remdups xs @ ys) = remdups (xs @ ys)"
by(induction xs) simp_all

lemma remdups_append2: "remdups (xs @ remdups ys) = remdups (xs @ ys)"
by(induction xs) simp_all

lemma remdups_append1_drop: "set xs \<subseteq> set ys \<Longrightarrow> remdups (xs @ ys) = remdups ys"
by(induction xs) auto

lemma remdups_concat_map: "remdups (concat (map remdups xss)) = remdups (concat xss)"
by(induction xss)(simp_all add: remdups_append1, metis remdups_append2)

lemma remdups_concat_remdups: "remdups (concat (remdups xss)) = remdups (concat xss)"
apply(induction xss)
apply(auto simp add: remdups_append1_drop)
 apply(subst remdups_append1_drop; auto)
apply(metis remdups_append2)
done

lemma remdups_replicate: "remdups (replicate n x) = (if n = 0 then [] else [x])"
by(induction n) simp_all

typedef 'a dnelist = "{xs::'a list. distinct xs \<and> xs \<noteq> []}"
  morphisms list_of_dnelist Abs_dnelist
proof
  show "[x] \<in> ?dnelist" for x by simp
qed

setup_lifting type_definition_dnelist

lemma dnelist_subtype_dlist:
  "type_definition (\<lambda>x. Dlist (list_of_dnelist x)) (\<lambda>x. Abs_dnelist (list_of_dlist x)) {xs. xs \<noteq> Dlist.empty}"
apply unfold_locales
subgoal by(transfer; auto simp add: dlist_eq_iff)
subgoal by(simp add: distinct_remdups_id dnelist.list_of_dnelist[simplified] list_of_dnelist_inverse)
subgoal by(simp add: dlist_eq_iff Abs_dnelist_inverse)
done

lift_bnf 'a dnelist via dnelist_subtype_dlist for map: map by(simp_all add: dlist_eq_iff)
hide_const (open) map

context begin
qualified lemma map_def: "DNEList.map = map_fun id (map_fun list_of_dnelist Abs_dnelist) (\<lambda>f xs. remdups (list.map f xs))"
unfolding map_def by(simp add: fun_eq_iff distinct_remdups_id list_of_dnelist[simplified])

qualified lemma map_transfer [transfer_rule]:
  "rel_fun op = (rel_fun (pcr_dnelist op =) (pcr_dnelist op =)) (\<lambda>f xs. remdups (map f xs)) DNEList.map"
by(simp add: map_def rel_fun_def dnelist.pcr_cr_eq cr_dnelist_def list_of_dnelist[simplified] Abs_dnelist_inverse)

qualified lift_definition single :: "'a \<Rightarrow> 'a dnelist" is "\<lambda>x. [x]" by simp
qualified lift_definition insert :: "'a \<Rightarrow> 'a dnelist \<Rightarrow> 'a dnelist" is "\<lambda>x xs. if x \<in> set xs then xs else x # xs" by auto
qualified lift_definition append :: "'a dnelist \<Rightarrow> 'a dnelist \<Rightarrow> 'a dnelist" is "\<lambda>xs ys. remdups (xs @ ys)" by auto
qualified lift_definition bind :: "'a dnelist \<Rightarrow> ('a \<Rightarrow> 'b dnelist) \<Rightarrow> 'b dnelist" is "\<lambda>xs f. remdups (List.bind xs f)" by auto

abbreviation (input) pure_dnelist :: "'a \<Rightarrow> 'a dnelist"
where "pure_dnelist \<equiv> single"

end

lift_definition ap_dnelist :: "('a \<Rightarrow> 'b) dnelist \<Rightarrow> 'a dnelist \<Rightarrow> 'b dnelist"
is "\<lambda>f x. remdups (ap_list f x)"
by(auto simp add: ap_list_def)

adhoc_overloading Applicative.ap ap_dnelist

lemma ap_pure_list [simp]: "ap_list [f] xs = map f xs"
by(simp add: ap_list_def List.bind_def)

context begin interpretation applicative_syntax .

lemma ap_pure_dlist: "pure_dnelist f \<diamondop> x = DNEList.map f x"
by transfer simp

applicative dnelist (K)
for pure: pure_dnelist
    ap: ap_dnelist
proof -
  show "pure_dnelist (\<lambda>x. x) \<diamondop> x = x" for x :: "'a dnelist"
    by transfer simp
  show "pure_dnelist (\<lambda>g f x. g (f x)) \<diamondop> g \<diamondop> f \<diamondop> x = g \<diamondop> (f \<diamondop> x)"
    for g :: "('c \<Rightarrow> 'b) dnelist" and f :: "('a \<Rightarrow> 'c) dnelist" and x
    apply transfer
    apply(simp add: ap_list_def List.bind_def)
    apply(subst (2) remdups_concat_remdups[symmetric])
    apply(subst remdups_map_remdups)
    apply simp
    apply(subst remdups_concat_remdups)
    apply(subst (1) remdups_concat_remdups[symmetric])
    apply(subst remdups_map_remdups)
    apply(subst remdups_concat_remdups)
    apply(subst (2) remdups_concat_map[symmetric])
    apply(simp add: o_def)
    apply(subst remdups_map_remdups)
    apply(subst (5) list.map_comp[symmetric, unfolded o_def]) back back back back
    apply(subst remdups_concat_map)
    subgoal for g f x using list.afun_comp[of g f x]
      by(simp add: ap_list_def List.bind_def o_def)
    done
  show "pure_dnelist f \<diamondop> pure_dnelist x = pure_dnelist (f x)" for f :: "'a \<Rightarrow> 'b" and x
    by transfer simp
  show "f \<diamondop> pure_dnelist x = pure_dnelist (\<lambda>f. f x) \<diamondop> f" for f :: "('a \<Rightarrow> 'b) dnelist" and x
    by transfer(simp add: list.afun_ichng)
  show "pure_dnelist (\<lambda>x y. x) \<diamondop> x \<diamondop> y = x"
    for x :: "'b dnelist" and y :: "'a dnelist"
    apply transfer
    apply(simp add: ap_list_def List.bind_def)
    apply(subst (2) distinct_remdups_id)
    apply(simp add: distinct_map)
    apply(rule inj_onI)
    apply(simp add: fun_eq_iff)
    apply(simp add: o_def map_replicate_const)
    apply(subst remdups_concat_map[symmetric])
    apply(simp add: o_def remdups_replicate)
    done
qed

text \<open>@{typ "_ dnelist"} does not have combinator C, so it cannot have W either.\<close>

context begin
private lift_definition x :: "int dnelist" is "[2,3]" by simp
private lift_definition y :: "int dnelist" is "[5,7]" by simp
private lemma "pure_dnelist (\<lambda>f x y. f y x) \<diamondop> pure_dnelist (op *) \<diamondop> x \<diamondop> y \<noteq> pure_dnelist (op *) \<diamondop> y \<diamondop> x"
  by transfer(simp add: ap_list_def fun_eq_iff)
end

end

end