(*  Title:      NatInt.thy
    Author:     Sven Linker, University of Liverpool

Intervals based on natural numbers. Defines a
bottom element (empty set), infimum (set intersection),
partial order (subset relation), cardinality (set cardinality).

The union of intervals i and j can only be created, if they are consecutive, i.e.,
max i +1 = min j (or vice versa). To express consecutiveness, we employ the
predicate consec.

Also contains a "chopping" predicate N_Chop(i,j,k): i can be divided into
consecutive intervals j and k.
*)

section \<open>Discrete Intervals based on Natural Numbers\<close>

text\<open>We define a type of intervals based on the natural numbers. To that
end, we employ standard operators of Isabelle, but in addition prove some
structural properties of the intervals. In particular, we show that this type
constitutes a meet-semilattice with a bottom element and equality.

Furthermore, we show that this semilattice allows for a constrained join, i.e.,
the union of two intervals is defined, if either one of them is empty, or they are
consecutive. Finally, we define the notion of \emph{chopping} an interval into
two consecutive subintervals.\<close>

theory NatInt
  imports Main
begin

text \<open>A discrete interval is a set of consecutive natural numbers, or the empty
set.\<close>

typedef nat_int = "{S . (\<exists> (m::nat) n . {m..n }=S) }"
  by auto
setup_lifting type_definition_nat_int

subsection \<open>Basic properties of discrete intervals.\<close>

locale nat_int
interpretation nat_int_class?: nat_int .

context nat_int
begin

lemma un_consec_seq: "(m::nat)\<le> n \<and> n+1 \<le> l \<longrightarrow> {m..n} \<union> {n+1..l} = {m..l}"
  by auto

lemma int_conseq_seq: " {(m::nat)..n} \<inter> {n+1..l} = {}"
  by auto

lemma empty_type: "{} \<in> { S . \<exists> (m:: nat) n . {m..n}=S}"
  by auto

lemma inter_result: "\<forall>x \<in> {S . (\<exists> (m::nat) n .  {m..n }=S) }.
         \<forall>y \<in> {S . (\<exists> (m::nat) n . {m..n }=S) }.
           x \<inter> y \<in>{S . (\<exists> (m::nat) n .  {m..n }=S)}"
  using Int_atLeastAtMost by blast

lemma union_result: "\<forall>x \<in> {S . (\<exists> (m::nat) n .  {m..n }=S) }.
         \<forall>y \<in> {S . (\<exists> (m::nat) n .  {m..n }=S)  }.
           x \<noteq> {} \<and> y \<noteq> {} \<and> Max x +1 = Min y
            \<longrightarrow> x \<union> y \<in>{S . (\<exists> (m::nat) n . {m..n }=S)  }"
proof (rule ballI)+
  fix x y
  assume "x\<in> {S . (\<exists> (m::nat) n .  {m..n }=S) }"
    and "y\<in> {S . (\<exists> (m::nat) n .  {m..n }=S) }"
  then have x_def:"(\<exists>m n.  {m..n} = x) "
    and y_def:"(\<exists>m n.  {m..n} = y) " by blast+
  show   " x \<noteq> {} \<and> y \<noteq> {} \<and>   Max x+1 = Min y
            \<longrightarrow> x \<union>  y \<in> {S. (\<exists>m n.  {m..n} = S) }"
  proof
    assume pre:"x \<noteq> {} \<and> y \<noteq> {} \<and> Max x + 1 = Min y"
    then have x_int:"\<exists>m n. m \<le> n \<and> {m..n} = x"
          and y_int:"(\<exists>m n. m \<le> n \<and> {m..n} = y)"
      using  x_def y_def by force+
    {
      fix ya yb xa xb
      assume y_prop:"ya \<le> yb \<and> {ya..yb} = y"
      assume x_prop:"xa \<le> xb \<and> {xa..xb} = x"
      from  x_prop have upper_x:"Max x = xb"
        by (metis Sup_nat_def cSup_atLeastAtMost)
      from y_prop have lower_y:"Min y = ya"
        by (metis Inf_fin.coboundedI Inf_fin_Min Min_in add.right_neutral finite_atLeastAtMost
            le_add1 ord_class.atLeastAtMost_iff order_class.antisym pre)
      from upper_x and lower_y and pre have upper_eq_lower: "xb+1 = ya"
        by blast
      hence "y= {xb+1 .. yb}" using y_prop by blast
      hence "x \<union> y = {xa..yb}"
        using un_consec_seq upper_eq_lower x_prop y_prop by blast
      then have " x \<union> y \<in> {S.(\<exists>m n.  {m..n} = S) }"
        by auto
    }
    then show "x \<union> y \<in> {S.(\<exists>m n.  {m..n} = S)}"
      using x_int y_int by blast
  qed
qed

lemma union_empty_result1: "\<forall>i \<in> {S . (\<exists> (m::nat) n .  {m..n }=S) }.
                                  i \<union> {} \<in> {S . (\<exists> (m::nat) n .  {m..n }=S) }"
  by blast

lemma union_empty_result2: "\<forall>i \<in> {S . (\<exists> (m::nat) n . {m..n }=S)  }.
                                  {} \<union> i \<in> {S . (\<exists> (m::nat) n . {m..n }=S)  }"
  by blast

lemma finite:" \<forall>i \<in> {S . (\<exists> (m::nat) n .  {m..n }=S) } . (finite i)"
  by blast

lemma not_empty_means_seq:"\<forall>i \<in> {S . (\<exists> (m::nat) n .  {m..n }=S) } . i \<noteq> {}
                            \<longrightarrow> ( \<exists>m n . m \<le> n \<and> {m..n} = i)"
  using atLeastatMost_empty_iff
  by force
end

text \<open>The empty set is the bottom element of the type. The infimum/meet of
the semilattice is set intersection. The order is given by the subset relation.
\<close>

instantiation nat_int :: bot
begin
lift_definition bot_nat_int :: "nat_int" is Set.empty by force
instance by standard
end

instantiation nat_int ::  inf
begin
lift_definition inf_nat_int  ::"nat_int \<Rightarrow> nat_int \<Rightarrow> nat_int" is Set.inter  by force
instance
proof qed
end

instantiation nat_int :: "order_bot"
begin
lift_definition less_eq_nat_int :: "nat_int \<Rightarrow> nat_int \<Rightarrow> bool" is Set.subset_eq .
lift_definition less_nat_int :: "nat_int \<Rightarrow> nat_int \<Rightarrow> bool" is Set.subset .
instance
proof
  fix i j k ::nat_int
  show "(i < j) = (i \<le> j \<and> \<not> j \<le> i)"
    by (simp add: less_eq_nat_int.rep_eq less_le_not_le less_nat_int.rep_eq)
  show "i \<le> i" by (simp add:less_eq_nat_int.rep_eq)
  show " i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> i \<le> k" by (simp add:less_eq_nat_int.rep_eq)
  show "i \<le> j \<Longrightarrow> j \<le> i \<Longrightarrow> i = j"
    by (simp add: Rep_nat_int_inject less_eq_nat_int.rep_eq )
  show "bot \<le> i" using  less_eq_nat_int.rep_eq
    using bot_nat_int.rep_eq by blast
qed
end

instantiation nat_int ::  "semilattice_inf"
begin
instance
proof
  fix i j k :: nat_int
  show "i \<le> j \<Longrightarrow> i \<le> k \<Longrightarrow> i \<le> inf j k"
    by (simp add: inf_nat_int.rep_eq less_eq_nat_int.rep_eq)
  show " inf i   j \<le> i"
    by (simp add: inf_nat_int.rep_eq less_eq_nat_int.rep_eq)
  show "inf i  j \<le> j"
    by (simp add: inf_nat_int.rep_eq less_eq_nat_int.rep_eq)
qed
end

instantiation nat_int:: "equal"
begin
definition equal_nat_int :: "nat_int \<Rightarrow> nat_int \<Rightarrow> bool"
  where "equal_nat_int i  j \<equiv> i \<le> j \<and> j \<le> i"
instance
proof
  fix i j :: nat_int
  show " equal_class.equal i j = (i = j)" using equal_nat_int_def  by auto
qed
end

context nat_int
begin
abbreviation subseteq :: "nat_int \<Rightarrow> nat_int\<Rightarrow> bool" (infix "\<sqsubseteq>" 30)
  where  "i \<sqsubseteq> j == i \<le> j "
abbreviation empty :: "nat_int" ("\<emptyset>")
  where "\<emptyset> \<equiv> bot"

notation inf (infix "\<sqinter>" 70)

text \<open>The union of two intervals is only defined, if it is also
a discrete interval.\<close>
definition union :: "nat_int \<Rightarrow> nat_int \<Rightarrow> nat_int" (infix "\<squnion>" 65)
  where "i \<squnion> j = Abs_nat_int (Rep_nat_int i \<union> Rep_nat_int j)"

text \<open>Non-empty intervals contain a minimal and maximal element.
Two non-empty intervals \(i\) and \(j\) are
consecutive, if the minimum of \(j\) is the successor of the
maximum of \(i\).
Furthermore, the interval \(i\) can be chopped into the intervals \(j\)
and \(k\), if the union of \(j\) and \(k\) equals \(i\), and if \(j\)
and \(k\) are not-empty, they must be consecutive. Finally, we define
the cardinality of discrete intervals by lifting the cardinality of
sets.
\<close>
definition maximum :: "nat_int \<Rightarrow> nat"
  where maximum_def: "i \<noteq> \<emptyset> \<Longrightarrow> maximum (i) =   Max (Rep_nat_int i)"

definition minimum :: "nat_int \<Rightarrow> nat"
  where minimum_def: "i \<noteq> \<emptyset> \<Longrightarrow> minimum(i) = Min (Rep_nat_int i)"

definition consec:: "nat_int\<Rightarrow>nat_int \<Rightarrow> bool"
  where "consec i j \<equiv> (i\<noteq>\<emptyset> \<and> j \<noteq> \<emptyset> \<and> (maximum(i)+1 = minimum j))"

definition N_Chop :: "nat_int \<Rightarrow> nat_int \<Rightarrow> nat_int \<Rightarrow> bool" ("N'_Chop'(_,_,_')" 51)
  where nchop_def :
    "N_Chop(i,j,k) \<equiv> (i =  j \<squnion> k   \<and> (j = \<emptyset> \<or>  k = \<emptyset> \<or> consec j k))"

lift_definition card' ::"nat_int \<Rightarrow> nat"  ( "|_|" 70) is card .

text\<open>For convenience, we also lift the membership relation and its negation
to discrete intervals.\<close>

lift_definition el::"nat \<Rightarrow> nat_int \<Rightarrow> bool" (infix "\<^bold>\<in>" 50) is "Set.member" .

lift_definition not_in ::"nat \<Rightarrow> nat_int \<Rightarrow> bool" (infix "\<^bold>\<notin>" 40)  is Set.not_member .
end

lemmas[simp] = nat_int.el.rep_eq nat_int.not_in.rep_eq nat_int.card'.rep_eq

context nat_int
begin

lemma in_not_in_iff1 :"n \<^bold>\<in> i \<longleftrightarrow> \<not> n\<^bold>\<notin> i" by simp
lemma in_not_in_iff2: "n\<^bold>\<notin> i \<longleftrightarrow> \<not> n \<^bold>\<in> i" by simp

lemma rep_non_empty_means_seq:"i \<noteq>\<emptyset>
                                \<longrightarrow> (\<exists>m n. m \<le> n \<and> ({m..n} =( Rep_nat_int i)))"
  by (metis Rep_nat_int Rep_nat_int_inject bot_nat_int.rep_eq nat_int.not_empty_means_seq)

lemma non_empty_max: "i \<noteq> \<emptyset> \<longrightarrow> (\<exists>m . maximum(i) = m)"
  by auto

lemma non_empty_min: "i \<noteq> \<emptyset> \<longrightarrow> (\<exists>m . minimum(i) = m)"
  by auto

lemma minimum_in: "i \<noteq> \<emptyset> \<longrightarrow> minimum i \<^bold>\<in> i"
  by (metis Min_in atLeastatMost_empty_iff2 finite_atLeastAtMost minimum_def
      el.rep_eq rep_non_empty_means_seq)

lemma maximum_in: "i \<noteq> \<emptyset> \<longrightarrow> maximum i \<^bold>\<in> i"
  by (metis Max_in atLeastatMost_empty_iff2 finite_atLeastAtMost maximum_def
      el.rep_eq rep_non_empty_means_seq)

lemma non_empty_elem_in:"i \<noteq> \<emptyset> \<longleftrightarrow> (\<exists>n. n \<^bold>\<in> i)"
proof
  assume assm:"i \<noteq> \<emptyset>"
  show "\<exists>n . n \<^bold>\<in> i"
    by (metis assm Rep_nat_int_inverse all_not_in_conv el.rep_eq bot_nat_int_def)
next
  assume assm:"\<exists>n. n \<^bold>\<in> i"
  show "i \<noteq> \<emptyset>"
    using Abs_nat_int_inverse assm el.rep_eq bot_nat_int_def by fastforce
qed

lemma leq_nat_non_empty:"(m::nat) \<le> n \<longrightarrow> Abs_nat_int{m..n} \<noteq> \<emptyset>"
proof
  assume assm:"m \<le>n"
  then have non_empty:"{m..n} \<noteq> {} "
    using atLeastatMost_empty_iff by blast
  with assm have "{m..n} \<in> {S . (\<exists> (m::nat) n .  {m..n }=S)  }" by blast
  then show "Abs_nat_int {m..n} \<noteq> \<emptyset>"
    using Abs_nat_int_inject empty_type non_empty bot_nat_int_def
    by (simp add: bot_nat_int.abs_eq)
qed

subsection \<open>Algebraic properties of intersection and union.\<close>

lemma inter_empty1:"(i::nat_int) \<sqinter> \<emptyset> = \<emptyset>"
  using Rep_nat_int_inject inf_nat_int.rep_eq bot_nat_int.abs_eq bot_nat_int.rep_eq
  by fastforce

lemma inter_empty2:"\<emptyset> \<sqinter> (i::nat_int) = \<emptyset>"
  by (metis inf_commute nat_int.inter_empty1)

lemma un_empty_absorb1:"i \<squnion> \<emptyset> = i"
  using  Abs_nat_int_inverse Rep_nat_int_inverse union_def empty_type bot_nat_int.rep_eq
  by auto

lemma un_empty_absorb2:"\<emptyset> \<squnion> i = i"
  using  Abs_nat_int_inverse Rep_nat_int_inverse union_def empty_type bot_nat_int.rep_eq
  by auto

text \<open>Most properties of the union of two intervals depends on them being consectuive,
to ensure that their union exists.\<close>

lemma consec_un:"consec i j \<and> n \<notin> Rep_nat_int(i) \<union> Rep_nat_int j
                  \<longrightarrow> n \<^bold>\<notin>  (i \<squnion> j)"
proof
  assume assm:"consec i j \<and> n \<notin>  Rep_nat_int i \<union> Rep_nat_int j"
  thus "n \<^bold>\<notin> (i \<squnion> j)"
  proof -
    have f1: "Abs_nat_int (Rep_nat_int (i \<squnion> j))
              = Abs_nat_int (Rep_nat_int i \<union> Rep_nat_int j)"
      using Rep_nat_int_inverse union_def by presburger
    have "i \<noteq> \<emptyset> \<and> j \<noteq> \<emptyset> \<and> maximum i + 1 = minimum j"
      using assm consec_def by auto
    then have "\<exists>n na. {n..na} = Rep_nat_int i \<union> Rep_nat_int j"
      by (metis (no_types) leq_max_sup leq_min_inf maximum_def minimum_def
          rep_non_empty_means_seq un_consec_seq)
    then show ?thesis
      using f1 Abs_nat_int_inject Rep_nat_int not_in.rep_eq assm by auto
  qed
qed

lemma consec_in_exclusive1:"consec i j \<and> n \<^bold>\<in> i \<longrightarrow> n \<^bold>\<notin> j"
  using nat_int.consec_lesser nat_int.in_not_in_iff2 by blast

lemma consec_in_exclusive2:"consec i j \<and> n \<^bold>\<in> j \<longrightarrow> n \<^bold>\<notin> i"
  using consec_in_exclusive1 el.rep_eq not_in.rep_eq by blast

lemma consec_un_max:"consec i j \<longrightarrow> maximum j = maximum (i \<squnion> j)"
proof
  assume assm:"consec i j"
  then have "(\<forall>n m. (n \<^bold>\<in> i \<and> m \<^bold>\<in> j \<longrightarrow> n < m))"
    using nat_int.consec_lesser by blast
  then have "\<forall>n . (n \<^bold>\<in> i \<longrightarrow> n < maximum j)"
    using assm local.consec_def nat_int.maximum_in by auto
  then have "\<forall>n. (n \<^bold>\<in> i \<squnion> j \<longrightarrow> n \<le> maximum j)"
    by (metis (no_types, lifting) Rep_nat_int Rep_nat_int_inverse Un_iff assm atLeastAtMost_iff
        bot_nat_int.rep_eq less_imp_le_nat local.consec_def local.not_empty_means_seq
        nat_int.consec_un nat_int.el.rep_eq nat_int.in_not_in_iff1 nat_int.leq_max_sup')
  then show "maximum j = maximum (i \<squnion> j)"
    by (metis Rep_nat_int_inverse assm atLeastAtMost_iff bot.extremum_uniqueI
        le_antisym local.consec_def nat_int.consec_un_element2 nat_int.el.rep_eq
        nat_int.leq_max_sup' nat_int.maximum_in nat_int.un_subset2 rep_non_empty_means_seq)
qed

lemma consec_un_min:"consec i j \<longrightarrow> minimum i = minimum (i \<squnion> j)"
proof
  assume assm:"consec i j"
  then have "(\<forall>n m. (n \<^bold>\<in> i \<and> m \<^bold>\<in> j \<longrightarrow> n < m))"
    using nat_int.consec_lesser by blast
  then have "\<forall>n . (n \<^bold>\<in> j \<longrightarrow> n > minimum i)"
    using assm local.consec_def nat_int.minimum_in by auto
  then have 1:"\<forall>n. (n \<^bold>\<in> i \<squnion> j \<longrightarrow> n \<ge> minimum i)"
    using Rep_nat_int Rep_nat_int_inverse Un_iff assm atLeastAtMost_iff bot_nat_int.rep_eq
      less_imp_le_nat local.consec_def local.not_empty_means_seq nat_int.consec_un
      nat_int.el.rep_eq nat_int.in_not_in_iff1
    by (metis (no_types, lifting) leq_min_inf local.minimum_def)
  from assm have "i \<squnion> j \<noteq> \<emptyset>"
    by (metis bot.extremum_uniqueI nat_int.consec_def nat_int.un_subset2)
  then show "minimum i = minimum (i \<squnion> j)"
    by (metis "1" antisym assm atLeastAtMost_iff leq_min_inf nat_int.consec_def
        nat_int.consec_un_element1 nat_int.el.rep_eq nat_int.minimum_def nat_int.minimum_in
        rep_non_empty_means_seq)
qed

lemma consec_un_defined:
  "consec i j \<longrightarrow> (Rep_nat_int (i \<squnion> j) \<in> {S . (\<exists> (m::nat) n . {m..n }=S) })"
  using Rep_nat_int by auto

lemma consec_un_min_max:
  "consec i j \<longrightarrow> Rep_nat_int(i \<squnion> j) = {minimum i .. maximum j}"
proof
  assume assm:"consec i j"
  then have 1:"minimum j = maximum i +1"
    by (simp add: nat_int.consec_def)
  have i:"Rep_nat_int i = {minimum i..maximum i}"
    by (metis Rep_nat_int_inverse assm nat_int.consec_def nat_int.leq_max_sup' nat_int.leq_min_inf'
        rep_non_empty_means_seq)
  have j:"Rep_nat_int j = {minimum j..maximum j}"
    by (metis Rep_nat_int_inverse assm nat_int.consec_def nat_int.leq_max_sup' nat_int.leq_min_inf'
        rep_non_empty_means_seq)
  show "Rep_nat_int(i \<squnion> j) = {minimum i .. maximum j}"
    by (metis Rep_nat_int_inverse antisym assm bot.extremum i nat_int.consec_un_max
        nat_int.consec_un_min nat_int.leq_max_sup' nat_int.leq_min_inf' nat_int.un_subset1
        rep_non_empty_means_seq)
qed

lemma consec_un_equality:
  "(consec i j \<and> k \<noteq> \<emptyset>)
    \<longrightarrow>( minimum (i \<squnion> j) = minimum (k) \<and> maximum (i \<squnion> j) = maximum (k))
      \<longrightarrow> i \<squnion> j = k"
proof (rule impI)+
  assume cons:"consec i j \<and> k \<noteq> \<emptyset>"
  assume endpoints:" minimum(i \<squnion> j) = minimum(k) \<and> maximum(i \<squnion> j) = maximum(k)"
  have "Rep_nat_int( i \<squnion> j) = {minimum(i \<squnion> j)..maximum(i \<squnion> j)}"
    by (metis cons leq_max_sup leq_min_inf local.consec_def nat_int.consec_un_element2
        nat_int.maximum_def nat_int.minimum_def nat_int.non_empty_elem_in rep_non_empty_means_seq)
  then have 1:"Rep_nat_int( i \<squnion> j) = {minimum(k) .. maximum(k)}"
    using endpoints by simp
  have "Rep_nat_int( k) = {minimum(k) .. maximum(k)}"
    by (metis cons leq_max_sup leq_min_inf nat_int.maximum_def nat_int.minimum_def
        rep_non_empty_means_seq)
  then  show " i \<squnion> j = k" using 1
    by (metis Rep_nat_int_inverse)
qed

lemma consec_trans_lesser:
  "consec i j \<and> consec j k \<longrightarrow> (\<forall>n m. (n \<^bold>\<in> i \<and> m \<^bold>\<in> k \<longrightarrow> n < m))"
proof (rule allI|rule impI)+
  assume cons:" consec i j \<and> consec j k"
  fix n and m
  assume assump:"n \<^bold>\<in> i \<and> m \<^bold>\<in> k "
  have "\<forall>k . k \<^bold>\<in> j \<longrightarrow> k < m" using consec_lesser assump cons by blast
  hence m_greater:"maximum j < m" using cons maximum_in consec_def by blast
  then show "n < m"
    by (metis assump cons consec_def dual_order.strict_trans nat_int.consec_lesser
        nat_int.maximum_in)
qed

lemma consec_inter_empty:"consec i j \<Longrightarrow> i \<sqinter> j = \<emptyset>"
proof -
  assume "consec i j"
  then have "i \<noteq> bot \<and> j \<noteq> bot \<and> maximum i + 1 = minimum j"
    using consec_def by force
  then show ?thesis
    by (metis (no_types) Rep_nat_int_inverse bot_nat_int_def inf_nat_int.rep_eq int_conseq_seq
        nat_int.leq_max_sup nat_int.leq_min_inf nat_int.maximum_def nat_int.minimum_def
        nat_int.rep_non_empty_means_seq)
qed

lemma consec_intermediate1:"consec j k \<and> consec i (j \<squnion> k) \<longrightarrow> consec i j "
proof
  assume assm:"consec j k \<and> consec i (j \<squnion> k)"
  hence min_max_yz:"maximum j +1=minimum k" using consec_def by blast
  hence min_max_xyz:"maximum i +1 = minimum (j \<squnion> k)"
      using consec_def assm by blast
  have min_y_yz:"minimum j = minimum (j \<squnion> k)"
    by (simp add: assm nat_int.consec_un_min)
  hence min_max_xy:"maximum i+1 = minimum j"
    using min_max_xyz by simp
  thus consec_x_y:"consec i j" using assm consec_def by auto
qed

lemma consec_intermediate2:"consec i j \<and> consec (i \<squnion> j) k \<longrightarrow> consec j k "
proof
  assume assm:"consec i j \<and> consec (i \<squnion> j) k"
  hence min_max_yz:"maximum i +1=minimum j" using consec_def by blast
  hence min_max_xyz:"maximum (i \<squnion> j) +1 = minimum ( k)"
      using consec_def assm by blast
  have min_y_yz:"maximum j = maximum (i \<squnion> j)"
    using assm nat_int.consec_un_max by blast
  then have min_max_xy:"maximum j+1 = minimum k"
    using min_max_xyz by simp
  thus consec_x_y:"consec j k" using assm consec_def by auto
qed

lemma un_assoc: "consec i j \<and> consec j k \<longrightarrow> (i \<squnion> j) \<squnion> k = i \<squnion> (j \<squnion> k)"
proof
  assume assm:"consec i j \<and> consec j k"
  from assm have 3:"maximum (i \<squnion> j) = maximum j"
    using nat_int.consec_un_max by auto
  from assm have 4:"minimum (j \<squnion> k) = minimum (j)"
    using nat_int.consec_un_min by auto
  have "i \<squnion> j  = Abs_nat_int{minimum i .. maximum j}"
    by (metis Rep_nat_int_inverse assm nat_int.consec_un_min_max)
  then have 5:"(i \<squnion> j) \<squnion> k = Abs_nat_int{minimum i .. maximum k}"
    by (metis (no_types, hide_lams) "3" Rep_nat_int_inverse antisym assm bot.extremum
        nat_int.consec_def nat_int.consec_un_min nat_int.consec_un_min_max nat_int.un_subset1)
  have "j \<squnion> k = Abs_nat_int{minimum j .. maximum k}"
    by (metis Rep_nat_int_inverse assm nat_int.consec_un_min_max)
  then have 6:"i \<squnion> (j \<squnion> k) = Abs_nat_int{minimum i .. maximum k}"
    by (metis (no_types, hide_lams) "4" Rep_nat_int_inverse antisym assm bot.extremum
        nat_int.consec_def nat_int.consec_un_max nat_int.consec_un_min_max nat_int.un_subset2)
  from 5 and 6 show " (i \<squnion> j) \<squnion> k = i \<squnion> (j \<squnion> k)" by simp
qed

lemma consec_assoc1:"consec j k \<and> consec i (j \<squnion> k) \<longrightarrow> consec (i \<squnion> j) k "
proof
  assume assm:"consec j k \<and> consec i (j \<squnion> k)"
  hence min_max_yz:"maximum j +1=minimum k" using consec_def by blast
  hence min_max_xyz:"maximum i +1 = minimum (j \<squnion> k)"
      using consec_def assm by blast
  have min_y_yz:"minimum j = minimum (j \<squnion> k)"
    by (simp add: assm nat_int.consec_un_min)
  hence min_max_xy:"maximum i+1 = minimum j" using min_max_xyz by simp
  hence consec_x_y:"consec i j" using assm _consec_def by auto
  hence max_y_xy:"maximum j = maximum (i \<squnion> j)" using consec_lesser assm
    by (simp add: nat_int.consec_un_max)
  have none_empty:"i \<noteq> \<emptyset> \<and> j \<noteq> \<emptyset> \<and> k \<noteq> \<emptyset>" using assm by (simp add: consec_def)
  hence un_non_empty:"i\<squnion>j \<noteq> \<emptyset>"
    using bot.extremum_uniqueI consec_x_y nat_int.un_subset2 by force
  have max:"maximum (i\<squnion>j) +1 = minimum k"
    using min_max_yz max_y_xy by auto
  thus "consec (i \<squnion> j) k"  using max un_non_empty none_empty consec_def by blast
qed

lemma consec_assoc2:"consec i j \<and> consec (i\<squnion> j) k \<longrightarrow> consec i  (j\<squnion> k) "
proof
  assume assm:"consec i j \<and> consec (i\<squnion> j) k"
  hence consec_y_z:"consec j k" using assm consec_def consec_intermediate2
    by blast
  hence max_y_xy:"maximum j = maximum (i \<squnion> j)"
    by (simp add: assm nat_int.consec_un_max)
  have min_y_yz:"minimum j = minimum (j \<squnion> k)"
    by (simp add: consec_y_z nat_int.consec_un_min)
  have none_empty:"i \<noteq> \<emptyset> \<and> j \<noteq> \<emptyset> \<and> k \<noteq> \<emptyset>" using assm by (simp add: consec_def)
  then have un_non_empty:"j\<squnion>k \<noteq> \<emptyset>"
    by (metis  bot_nat_int.rep_eq Rep_nat_int_inject consec_y_z  less_eq_nat_int.rep_eq
        un_subset1 subset_empty)
  have max:"maximum (i) +1 = minimum (j\<squnion> k)"
    using assm min_y_yz consec_def by auto
  thus "consec i ( j \<squnion> k)"  using max un_non_empty none_empty consec_def by blast
qed

lemma consec_assoc_mult:
  "(i2=\<emptyset>\<or> consec i1 i2 ) \<and> (i3 =\<emptyset> \<or> consec i3 i4) \<and> (consec (i1 \<squnion> i2) (i3 \<squnion> i4))
      \<longrightarrow> (i1 \<squnion> i2) \<squnion> (i3 \<squnion> i4) = (i1 \<squnion> (i2 \<squnion> i3)) \<squnion> i4"
proof
  assume assm:"(i2=\<emptyset>\<or> consec i1 i2 ) \<and> (i3 =\<emptyset> \<or> consec i3 i4)
                \<and> (consec (i1 \<squnion> i2) (i3 \<squnion> i4))"
  hence "(i2=\<emptyset>\<or> consec i1 i2 )" by simp
  thus " (i1 \<squnion> i2) \<squnion> (i3 \<squnion> i4) = (i1 \<squnion> (i2 \<squnion> i3)) \<squnion> i4"
  proof
    assume empty2:"i2 = \<emptyset>"
    hence only_l1:"(i1 \<squnion> i2) = i1" using un_empty_absorb1 by simp
    from assm have "(i3 =\<emptyset> \<or> consec i3 i4)" by simp
    thus " (i1 \<squnion> i2) \<squnion> (i3 \<squnion> i4) = (i1 \<squnion> (i2 \<squnion> i3)) \<squnion> i4"
      by (metis Rep_nat_int_inverse assm bot_nat_int.rep_eq empty2 local.union_def
          nat_int.consec_intermediate1 nat_int.un_assoc only_l1 sup_bot.left_neutral)
  next
    assume consec12:" consec i1 i2"
    from assm have "(i3 =\<emptyset> \<or> consec i3 i4)" by simp
    thus " (i1 \<squnion> i2) \<squnion> (i3 \<squnion> i4) = (i1 \<squnion> (i2 \<squnion> i3)) \<squnion> i4"
    proof
      assume empty3:"i3 = \<emptyset>"
      hence only_l4:"(i3 \<squnion> i4) = i4 " using un_empty_absorb2 by simp
      have "(i1 \<squnion> (i2 \<squnion> i3)) = i1 \<squnion> i2" using empty3 by (simp add: un_empty_absorb1)
      thus ?thesis by (simp add: only_l4)
    next
      assume  consec34:" consec i3 i4"
      have consec12_3:"consec (i1 \<squnion> i2) i3"
        using assm consec34 consec_intermediate1 by blast
      show ?thesis
        by (metis consec12 consec12_3 consec34 consec_intermediate2 un_assoc)
    qed
  qed
qed

lemma card_subset_le: "i \<sqsubseteq> i' \<longrightarrow> |i| \<le> |i'|"
  by (metis bot_nat_int.rep_eq card_mono finite.intros(1) finite_atLeastAtMost
      less_eq_nat_int.rep_eq local.card'.rep_eq rep_non_empty_means_seq)

lemma card_subset_less:"(i::nat_int) < i' \<longrightarrow> |i|<|i'|"
  by (metis bot_nat_int.rep_eq finite.intros(1) finite_atLeastAtMost less_nat_int.rep_eq
      local.card'.rep_eq psubset_card_mono rep_non_empty_means_seq)

lemma card_empty_zero:"|\<emptyset>| = 0"
  using Abs_nat_int_inverse empty_type card'.rep_eq bot_nat_int.rep_eq by auto

lemma card_non_empty_geq_one:"i \<noteq> \<emptyset> \<longleftrightarrow> |i| \<ge> 1"
proof
  assume "i \<noteq> \<emptyset>"
  hence "Rep_nat_int i \<noteq> {}" by (metis Rep_nat_int_inverse bot_nat_int.rep_eq)
  hence "card (Rep_nat_int i) > 0"
    by (metis \<open>i \<noteq> \<emptyset>\<close> card_0_eq finite_atLeastAtMost gr0I rep_non_empty_means_seq)
  thus "|i| \<ge> 1" by (simp add: card'_def)
next
  assume "|i| \<ge> 1" thus "i \<noteq>\<emptyset>"
    using card_empty_zero by auto
qed

lemma card_min_max:"i \<noteq> \<emptyset> \<longrightarrow> |i| = (maximum i - minimum i) + 1"
proof
  assume assm:"i \<noteq> \<emptyset>"
  then have "Rep_nat_int i = {minimum i .. maximum i}"
    by (metis leq_max_sup leq_min_inf nat_int.maximum_def nat_int.minimum_def
        rep_non_empty_means_seq)
  then have "card (Rep_nat_int i) = maximum i - minimum i + 1"
    using Rep_nat_int_inject assm bot_nat_int.rep_eq by fastforce
  then show " |i| = (maximum i - minimum i) + 1"  by simp
qed

lemma card_un_add: " consec i j \<longrightarrow> |i \<squnion> j| = |i| + |j|"
proof
  assume assm:"consec i j"
  then have 0:"i \<sqinter> j = \<emptyset>"
    using nat_int.consec_inter_empty by auto
  then have "(Rep_nat_int i) \<inter> (Rep_nat_int j) = {}"
    by (metis bot_nat_int.rep_eq inf_nat_int.rep_eq)
  then have 1:
    "card((Rep_nat_int i)\<union>(Rep_nat_int j))=card(Rep_nat_int i)+card(Rep_nat_int j)"
    by (metis Int_iff add.commute add.left_neutral assm card.infinite card_Un_disjoint
        emptyE le_add1 le_antisym local.consec_def nat_int.card'.rep_eq
        nat_int.card_min_max nat_int.el.rep_eq nat_int.maximum_in nat_int.minimum_in)
  then show "|i \<squnion> j| = |i| + |j|"
  proof -
    have f1: "i \<noteq> \<emptyset> \<and> j \<noteq> \<emptyset> \<and> maximum i + 1 = minimum j"
      using assm nat_int.consec_def by blast
    then have f2: "Rep_nat_int i \<noteq> {}"
      using Rep_nat_int_inject bot_nat_int.rep_eq by auto
    have "Rep_nat_int j \<noteq> {}"
      using f1 Rep_nat_int_inject bot_nat_int.rep_eq by auto
    then show ?thesis
      using f2 f1 Abs_nat_int_inverse Rep_nat_int 1 local.union_result
        nat_int.union_def nat_int_class.maximum_def nat_int_class.minimum_def
        by force
  qed
qed

lemma singleton:"|i| = 1 \<longrightarrow> (\<exists>n. Rep_nat_int i = {n})"
  using card_1_singletonE card'.rep_eq by fastforce

lemma singleton2:" (\<exists>n. Rep_nat_int i = {n}) \<longrightarrow> |i| = 1"
  using card_1_singletonE card'.rep_eq by fastforce

lemma chop_empty_right: "\<forall>i. N_Chop(i,i,\<emptyset>)"
  using bot_nat_int.abs_eq nat_int.inter_empty1 nat_int.nchop_def nat_int.un_empty_absorb1
  by auto


(* D. Fuenmayor and A. Steen, August 2021 *)
(* This file contains miscellaneous basic definition used throughout the work. *)
theory misc
  imports Main
begin

(* Technical detail: default settings to use for model finder Nitpick (inherited by all downstream theories) *)
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=2, atoms= a b c d]

declare [[syntax_ambiguity_warning = false]]

(************** Basic set- and order-theoretical notions ******************)

(* hide set notation for Isabelle's built-in sets: The aim is to provide an
   embedding that is as shallow as possible (i.e., it uses no representation
   techniques that are specific to Isabelle/HOL. Still, we want to
   use nice notation; this is why Isabelle/HOL predefined interpretations for
   subset, union, etc. symbols are hidden. *)
no_notation
  subset  ("'(\<subset>')") and
  subset  ("(_/ \<subset> _)" [51, 51] 50) and
  subset_eq  ("'(\<subseteq>')") and
  subset_eq  ("(_/ \<subseteq> _)" [51, 51] 50) and
  union (infixl "\<union>" 65) and
  inter (infixl "\<inter>" 70)

(* Sets and relations are vanilla type-polymorphic predicates.
   'a is a type variable representing an arbitrary type.
   Both notions are repreesnted by their respective characteristic
   functions. *)
(*sets as functions into a 2-element codomain *)
type_synonym 'a Set = \<open>'a \<Rightarrow> bool\<close>
(*relations as curried 2-ary functions into a 2-element codomain *)
type_synonym 'a Rel = \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close>

(* Introduce useful set operations and shorthand.
   They only make use of plain higher-order terms.
   Some of the symbols are, for presentation purposes, defined
   as infix symbols (using Isabelle/HOLs representation syntax);
   this is just syntactical sugar. *)
abbreviation union::\<open>'a Set \<Rightarrow> 'a Set \<Rightarrow> 'a Set\<close> (infixl "\<union>" 53) where \<open>A \<union> B \<equiv> \<lambda>x. (A x \<or> B x)\<close>
abbreviation inter::\<open>'a Set \<Rightarrow> 'a Set \<Rightarrow> 'a Set\<close> (infixl "\<inter>" 54) where \<open>A \<inter> B \<equiv> \<lambda>x. (A x \<and> B x)\<close>
abbreviation compl::\<open>'a Set \<Rightarrow> 'a Set\<close> ("\<midarrow>_") where \<open>\<midarrow>A \<equiv> \<lambda>x. \<not>A x\<close>
abbreviation inclusion::\<open>'a Set \<Rightarrow> 'a Set \<Rightarrow> bool\<close> (infix "\<subseteq>" 52) where \<open>A \<subseteq> B \<equiv> \<forall>x. (A x \<longrightarrow> B x)\<close>
abbreviation inclusion_rel::\<open>'a Set \<Rightarrow> 'a Set \<Rightarrow> 'a Set \<Rightarrow> bool\<close> ("_\<subseteq>\<^sup>__") where \<open>A \<subseteq>\<^sup>U B \<equiv> \<forall>x. U x \<longrightarrow> (A x \<longrightarrow> B x)\<close>
abbreviation equ::\<open>'a Set \<Rightarrow> 'a Set \<Rightarrow> bool\<close> (infix "\<approx>" 55) where \<open>A \<approx> B \<equiv> \<forall>x. (A x \<longleftrightarrow> B x)\<close>
abbreviation equ_rel::\<open>'a Set \<Rightarrow> 'a Set \<Rightarrow> 'a Set \<Rightarrow> bool\<close> ("_\<approx>\<^sup>__") where \<open>A \<approx>\<^sup>U B \<equiv> \<forall>x. U x \<longrightarrow> (A x \<longleftrightarrow> B x)\<close>
abbreviation proper_inclusion::\<open>'a Set \<Rightarrow> 'a Set \<Rightarrow>bool\<close> (infix "\<subset>" 52) where \<open>A \<subset> B \<equiv> (A \<subseteq> B) \<and> \<not>(A\<approx>B)\<close>
abbreviation proper_inclusion_rel::\<open>'a Set \<Rightarrow> 'a Set \<Rightarrow> 'a Set \<Rightarrow>bool\<close> ("_\<subset>\<^sup>__") where \<open>A \<subset>\<^sup>U B \<equiv> (A \<subseteq>\<^sup>U B) \<and> \<not>(A \<approx>\<^sup>U B)\<close>
abbreviation set_cnstr0::\<open>'a Set\<close> ("\<lbrace>-\<rbrace>") where \<open>\<lbrace>-\<rbrace> \<equiv> \<lambda>x. False\<close>
abbreviation set_cnstr1::\<open>'a\<Rightarrow>'a Set\<close> ("\<lbrace>_\<rbrace>") where \<open>\<lbrace>a\<rbrace> \<equiv> \<lambda>x. x = a\<close>
abbreviation set_cnstr2::\<open>'a\<Rightarrow>'a\<Rightarrow>'a Set\<close> ("\<lbrace>_,_\<rbrace>") where \<open>\<lbrace>a,b\<rbrace> \<equiv> \<lambda>x. x = a \<or> x = b\<close>
abbreviation set_cnstr3::\<open>'a\<Rightarrow>'a\<Rightarrow>'a\<Rightarrow>'a Set\<close> ("\<lbrace>_,_,_\<rbrace>") where \<open>\<lbrace>a,b,c\<rbrace> \<equiv> \<lambda>x. x = a \<or> x = b \<or> x = c\<close>

(*TODO: is it possible to also add binder notation to the ones below?*)
(*Restricted quantifiers that take a 'domain' as additional parameter (interpreted as the predicate 'exists')*)
abbreviation mforall_rel::"('a\<Rightarrow>bool)\<Rightarrow>('a\<Rightarrow>bool)\<Rightarrow>bool" ("\<forall>\<^sup>_ _") where \<open>\<forall>\<^sup>U P \<equiv> \<forall>x. U x \<longrightarrow> (P x)\<close>
abbreviation mexists_rel::"('a\<Rightarrow>bool)\<Rightarrow>('a\<Rightarrow>bool)\<Rightarrow>bool" ("\<exists>\<^sup>_ _") where \<open>\<exists>\<^sup>U P \<equiv> \<exists>x. U x  \<and>  (P x)\<close>
lemma relQuantifierDual: \<open>\<forall>\<^sup>A P \<longleftrightarrow> \<not>(\<exists>\<^sup>A (\<lambda>x. \<not>(P x)))\<close> by simp

(* abbreviation mforall_relB (binder "\<forall>\<^sup>_" [55]56) where "\<forall>\<^sup>U x. P x \<equiv> \<forall>\<^sup>U P" *)
(* abbreviation mexists_relB (binder "\<exists>\<^sup>_" [55]56) where "\<exists>\<^sup>U x. P x \<equiv> \<exists>\<^sup>U P" *)

lemma \<open>A \<subset>\<^sup>U B \<longrightarrow> A \<subset> B\<close> nitpick oops
lemma \<open>A \<subset> B \<longrightarrow> A \<subset>\<^sup>U B\<close> nitpick oops
lemma \<open>A \<subseteq>\<^sup>U B \<longrightarrow> A \<subseteq> B\<close> nitpick oops
lemma subs_rel: \<open>A \<subseteq> B \<Longrightarrow> A \<subseteq>\<^sup>U B\<close> by simp

(* and some generic notions for representing minimal and maximal (resp.least and greatest) sets wrt. set inclusion: *)
definition  \<open>minimal Prop Obj E \<equiv> Prop Obj \<and> (\<forall>X. Prop X \<and>  E(X)  \<subseteq> E(Obj) \<longrightarrow> E(X) \<approx> E(Obj))\<close>
definition  \<open>maximal Prop Obj E \<equiv> Prop Obj \<and> (\<forall>X. Prop X \<and> E(Obj) \<subseteq>  E(X)  \<longrightarrow> E(X) \<approx> E(Obj))\<close>
definition    \<open>least Prop Obj E \<equiv> Prop Obj \<and> (\<forall>X. Prop X \<longrightarrow> E(Obj) \<subseteq> E(X))\<close>
definition \<open>greatest Prop Obj E \<equiv> Prop Obj \<and> (\<forall>X. Prop X \<longrightarrow>  E(X)  \<subseteq> E(Obj))\<close>

definition minimal_rel ("minimal\<^sup>_ _ _ _")
  where \<open>minimal\<^sup>U Prop Obj E \<equiv> Prop Obj \<and> (\<forall>X. Prop X \<and> (E X) \<subseteq>\<^sup>U (E Obj) \<longrightarrow> (E X) \<approx>\<^sup>U (E Obj))\<close>
definition maximal_rel ("maximal\<^sup>_ _ _ _")
  where \<open>maximal\<^sup>U Prop Obj E \<equiv> Prop Obj \<and> (\<forall>X. Prop X \<and> (E Obj) \<subseteq>\<^sup>U (E X) \<longrightarrow> (E X) \<approx>\<^sup>U (E Obj))\<close>
definition least_rel ("least\<^sup>_ _ _ _")
  where \<open>least\<^sup>U Prop Obj E \<equiv> Prop Obj \<and> (\<forall>X. Prop X \<longrightarrow> (E Obj) \<subseteq>\<^sup>U (E X))\<close>
definition greatest_rel ("greatest\<^sup>_ _ _ _")
  where \<open>greatest\<^sup>U Prop Obj E \<equiv> Prop Obj \<and> (\<forall>X. Prop X \<longrightarrow> (E X) \<subseteq>\<^sup>U (E Obj))\<close>

(* Verified: Least (resp. greatest) sets are minimal (resp. maximal) but not the other way round. *)
lemma leastMin: \<open>least Prop Obj E \<longrightarrow>  minimal Prop Obj E\<close> unfolding least_def minimal_def by blast
lemma leastMin_rel: \<open>least\<^sup>U Prop Obj E \<longrightarrow>  minimal\<^sup>U Prop Obj E\<close> unfolding least_rel_def minimal_rel_def by blast
lemma greatestMax: \<open>greatest Prop Obj E \<longrightarrow>  maximal Prop Obj E\<close> unfolding greatest_def maximal_def by blast
lemma greatestMax_rel: \<open>greatest\<^sup>U Prop Obj E \<longrightarrow>  maximal\<^sup>U Prop Obj E\<close> unfolding greatest_rel_def maximal_rel_def by blast
lemma  \<open>minimal Prop Obj E \<longrightarrow>  least Prop Obj E\<close> nitpick oops (* countermodel found *)
lemma  \<open>minimal\<^sup>U Prop Obj E \<longrightarrow> least\<^sup>U Prop Obj E\<close> nitpick oops (* countermodel found *)
lemma  \<open>maximal Prop Obj E \<longrightarrow> greatest Prop Obj E\<close> nitpick oops (* countermodel found *)
lemma  \<open>maximal\<^sup>U Prop Obj E \<longrightarrow> greatest\<^sup>U Prop Obj E\<close> nitpick oops (* countermodel found *)

lemma \<open>minimal Prop Obj E \<longrightarrow> minimal\<^sup>U Prop Obj E\<close> nitpick oops
lemma \<open>minimal\<^sup>U Prop Obj E \<longrightarrow> minimal Prop Obj E\<close> nitpick oops
lemma \<open>maximal Prop Obj E \<longrightarrow> maximal\<^sup>U Prop Obj E\<close> nitpick oops
lemma \<open>maximal\<^sup>U Prop Obj E \<longrightarrow> maximal Prop Obj E\<close> nitpick oops
lemma least_rel_impl:    \<open>least Prop Obj E \<longrightarrow> least\<^sup>U Prop Obj E\<close> by (simp add: least_def least_rel_def)
lemma greatest_rel_impl: \<open>greatest Prop Obj E \<longrightarrow> greatest\<^sup>U Prop Obj E\<close> by (simp add: greatest_def greatest_rel_def)

(* Verified: Least and greatest elements are unique (wrt. their extensions by E). *)
lemma leastUnique:      \<open>least Prop A E \<and> least Prop B E \<longrightarrow> E(A) \<approx> E(B)\<close> by (metis least_def)
lemma leastUnique_rel: \<open>least\<^sup>U Prop A E \<and> least\<^sup>U Prop B E \<longrightarrow> E(A) \<approx>\<^sup>U E(B)\<close> by (metis least_rel_def)
lemma greatestUnique:      \<open>greatest Prop A E \<and> greatest Prop B E \<longrightarrow> E(A) \<approx> E(B)\<close> by (metis greatest_def)
lemma greatestUnique_rel: \<open>greatest\<^sup>U Prop A E \<and> greatest\<^sup>U Prop B E \<longrightarrow> E(A) \<approx>\<^sup>U E(B)\<close> by (metis greatest_rel_def)

(* Verified: If there exists a least/greatest element then minimal/maximal collapse to least/greatest. *)
lemma minLeastCollapse:      \<open>\<exists>A. least Prop A E \<Longrightarrow> \<forall>B. minimal Prop B E \<longrightarrow>  least Prop B E\<close>
  by (smt (verit, best) least_def minimal_def)
lemma minLeastCollapse_rel: \<open>\<exists>A. least\<^sup>U Prop A E \<Longrightarrow> \<forall>B. minimal\<^sup>U Prop B E \<longrightarrow>  least\<^sup>U Prop B E\<close>
  by (smt (verit, best) least_rel_def minimal_rel_def)
lemma maxGreatestCollapse:      \<open>\<exists>A. greatest Prop A E \<Longrightarrow> \<forall>B. maximal Prop B E \<longrightarrow>  greatest Prop B E\<close>
  by (smt (verit, best) greatest_def maximal_def)
lemma maxGreatestCollapse_rel: \<open>\<exists>A. greatest\<^sup>U Prop A E \<Longrightarrow> \<forall>B. maximal\<^sup>U Prop B E \<longrightarrow>  greatest\<^sup>U Prop B E\<close>
  by (smt (verit, best) greatest_rel_def maximal_rel_def)

(* In what follows we verify some useful results concerning the existence of least/greatest fixed points of monotone functions. *)
(* We start by defining infinite meet (infimum) and infinite join (supremum) operations,*)
definition infimum::  \<open>'a Set Set \<Rightarrow> 'a Set\<close> ("\<^bold>\<And>_") where \<open>\<^bold>\<And>S \<equiv> \<lambda>w. \<forall>X. S X \<longrightarrow> X w\<close>
definition supremum:: \<open>'a Set Set \<Rightarrow> 'a Set\<close> ("\<^bold>\<Or>_") where \<open>\<^bold>\<Or>S \<equiv> \<lambda>w. \<exists>X. S X  \<and>  X w\<close>

definition upper_bound ("UB") where \<open>UB S \<equiv> \<lambda>A. \<forall>X. S X \<longrightarrow> X \<subseteq> A\<close>
definition upper_bound_rel ("UB\<^sup>_") where \<open>UB\<^sup>U S \<equiv> \<lambda>A. \<forall>X. S X \<longrightarrow> (X \<subseteq>\<^sup>U A)\<close>
lemma ub_rel_impl: \<open>UB S x \<Longrightarrow> UB\<^sup>U S x\<close> by (simp add: upper_bound_def upper_bound_rel_def)

definition lower_bound ("LB") where \<open>LB S \<equiv> \<lambda>A. \<forall>X. S X \<longrightarrow> A \<subseteq> X\<close>
definition lower_bound_rel ("LB\<^sup>_") where \<open>LB\<^sup>U S \<equiv> \<lambda>A. \<forall>X. S X \<longrightarrow> (A \<subseteq>\<^sup>U X)\<close>
abbreviation \<open>is_supremum S U \<equiv> least (UB S) U id\<close>
abbreviation \<open>is_infimum  S L \<equiv> greatest (LB S) L id\<close>

(* ... and show that the corresponding lattice is complete: *)
lemma sup_char: \<open>is_supremum S \<^bold>\<Or>S\<close> unfolding supremum_def least_def upper_bound_def by auto
lemma inf_char: \<open>is_infimum S \<^bold>\<And>S\<close> unfolding infimum_def greatest_def lower_bound_def by auto

lemma sup_char_rel: \<open>is_supremum (S \<inter> U) (\<^bold>\<Or>S \<inter> U) \<close> by (simp add: sup_char)
lemma inf_char_rel: \<open>is_infimum (S \<inter> U) (\<^bold>\<And>S \<inter> U) \<close> by (simp add: inf_char)

(* Definition of a monotone function.*)
definition \<open>MONO F \<equiv> \<forall>A B. A \<subseteq> B \<longrightarrow> F A \<subseteq> F B\<close>
definition MONO_rel ("MONO\<^sup>_") where \<open>MONO\<^sup>U F \<equiv> \<forall>A B. (A \<subseteq>\<^sup>U B \<longrightarrow> F A \<subseteq>\<^sup>U F B)\<close>

(* We speak of argument-sets being fixed points of functions (mapping argument-sets to argument-sets).
For a given function we define in the usual way a fixed-point predicate for argument-sets.*)
definition fixpoint :: \<open>('a Set \<Rightarrow> 'a Set) \<Rightarrow> 'a Set \<Rightarrow> bool\<close>
  where \<open>fixpoint \<phi> \<equiv> \<lambda>S. \<phi>(S) \<approx>  S\<close>
definition fixpoint_rel:: \<open>'a Set \<Rightarrow> ('a Set \<Rightarrow> 'a Set) \<Rightarrow> 'a Set \<Rightarrow> bool\<close> ("fixpoint\<^sup>_")
  where \<open>fixpoint\<^sup>U \<phi> \<equiv> \<lambda>S. \<phi>(S) \<approx>\<^sup>U S\<close>

lemma fp_prop1: \<open>fixpoint \<phi> S \<Longrightarrow> fixpoint\<^sup>U \<phi> S\<close> by (simp add: fixpoint_rel_def fixpoint_def)
lemma fp_prop2: \<open>\<forall>U. least\<^sup>U (\<lambda>S. fixpoint\<^sup>U F S) S id \<Longrightarrow> least (fixpoint F) S id\<close> unfolding fixpoint_rel_def fixpoint_def least_def least_rel_def by metis

(* Verified: Least/Greatest fixedpoint is indeed a fixedpoint and is least/greatest. *)
lemma    \<open>(least (fixpoint F) S id) = (fixpoint F S \<and> (\<forall>X. fixpoint F X \<longrightarrow> S \<subseteq> X))\<close> by (simp add: least_def)
lemma \<open>(greatest (fixpoint F) S id) = (fixpoint F S \<and> (\<forall>X. fixpoint F X \<longrightarrow> X \<subseteq> S))\<close> by (simp add: greatest_def)

(* A weak formulation of the Knaster-Tarski Theorem:
 Any monotone function on a powerset lattice has a least/greatest fixed-point.*)
lemma wKTl': \<open>MONO F \<Longrightarrow> let S = \<^bold>\<And>(\<lambda>X. F X \<subseteq> X) in (least (fixpoint F) S id)\<close>
  unfolding least_def fixpoint_def MONO_def by (smt (z3) eq_id_iff infimum_def)
lemma wKTg': \<open>MONO F \<Longrightarrow> let S = \<^bold>\<Or>(\<lambda>X. X \<subseteq> F X) in (greatest (fixpoint F) S id)\<close>
  unfolding greatest_def fixpoint_def MONO_def by (smt (z3) eq_id_iff supremum_def)
lemma wKTl:  \<open>MONO F \<Longrightarrow> \<exists>S. least (fixpoint F) S id\<close> using wKTl' by auto
lemma wKTg:  \<open>MONO F \<Longrightarrow> \<exists>S. greatest (fixpoint F) S id\<close> using wKTg' by auto

lemma wKTl_rel': \<open>MONO\<^sup>U F \<Longrightarrow> let S = \<^bold>\<And>(\<lambda>X. F X \<subseteq>\<^sup>U X) in (least (fixpoint\<^sup>U F) S id)\<close>
  unfolding MONO_rel_def fixpoint_rel_def least_def by (smt (z3) eq_id_iff infimum_def)
lemma wKTg_rel': \<open>MONO\<^sup>U F \<Longrightarrow> let S = \<^bold>\<Or>(\<lambda>X. X \<subseteq>\<^sup>U F X) in (greatest (fixpoint\<^sup>U F) S id)\<close>
  unfolding MONO_rel_def fixpoint_rel_def greatest_def by (smt (z3) eq_id_iff supremum_def)

lemma wKTl_rel: \<open>MONO\<^sup>U F \<Longrightarrow> \<exists>S. least (fixpoint\<^sup>U F) S id\<close> using wKTl_rel' by auto
lemma wKTl_relw: \<open>MONO\<^sup>U F \<Longrightarrow> \<exists>S. least\<^sup>U (fixpoint\<^sup>U F) S id\<close> using wKTl_rel by (metis least_rel_impl)
lemma wKTg_rel: \<open>MONO\<^sup>U F \<Longrightarrow> \<exists>S. greatest (fixpoint\<^sup>U F) S id\<close> using wKTg_rel' by auto
lemma wKTg_relw: \<open>MONO\<^sup>U F \<Longrightarrow> \<exists>S. greatest\<^sup>U (fixpoint\<^sup>U F) S id\<close> using wKTg_rel by (metis greatest_rel_impl)

(* Directed sets are sets for which each pair of elements have an upper bound in the set*)
definition directed :: "'a Set Set \<Rightarrow> bool"
  where "directed S \<equiv> \<forall>A B. S A \<and> S B \<longrightarrow> (\<exists>C. S C \<and> A \<subseteq> C \<and> B \<subseteq> C)"
definition directed_rel :: "'a Set \<Rightarrow> 'a Set Set \<Rightarrow> bool" ("directed\<^sup>_")
  where "directed\<^sup>U S \<equiv> \<forall>A B. S A \<and> S B \<longrightarrow> (\<exists>C. S C \<and> A \<subseteq>\<^sup>U C \<and> B \<subseteq>\<^sup>U C)"

(* Every maximal element of a directed set is a greatest element*)
lemma directedMaxGreatest: "directed A \<Longrightarrow> \<forall>B. maximal A B id \<longrightarrow>  greatest A B id"
  by (smt (verit, del_insts) directed_def greatest_def id_apply maximal_def)

(* A particular sort of directed set is a chain: *)
definition chain :: "'a Set Set \<Rightarrow> bool"
  where "chain C \<equiv> \<forall>A. \<forall>B. C A \<longrightarrow> C B \<longrightarrow> (A \<subseteq> B \<or> B \<subseteq> A)"
definition chain_rel :: "'a Set \<Rightarrow> 'a Set Set \<Rightarrow> bool" ("chain\<^sup>_")
  where "chain\<^sup>U C \<equiv> \<forall>A. \<forall>B. C A \<longrightarrow> C B \<longrightarrow> (A \<subseteq>\<^sup>U B \<or> B \<subseteq>\<^sup>U A)"
lemma chain_rel_impl: \<open>chain C \<Longrightarrow> chain\<^sup>U C\<close> by (metis (full_types) chain_rel_def misc.chain_def)

lemma chainDirected: "chain S \<longrightarrow> directed S" by (smt (verit, ccfv_SIG) directed_def chain_def)
lemma chainDirected_rel: "chain\<^sup>U S \<longrightarrow> directed\<^sup>U S" by (smt (verit, best) chain_rel_def directed_rel_def)
lemma "directed S \<longrightarrow> chain S"  oops (* counterexample found, as expected*)
lemma "directed\<^sup>U S \<longrightarrow> chain\<^sup>U S"  oops (* counterexample found, as expected*)

(* A is called directed-complete (aka. dcpo) if every subset that is directed has a supremum in A*)
definition omegacomplete ("\<omega>-cpo _")    where "\<omega>-cpo A \<equiv> \<forall>C. C \<subseteq> A \<and>  chain C  \<longrightarrow>  A(\<^bold>\<Or>C)"
definition omegacomplete_rel ("\<omega>-cpo\<^sup>_ _")    where "\<omega>-cpo\<^sup>U A \<equiv> \<forall>C. C \<subseteq> A \<and>  chain\<^sup>U C  \<longrightarrow>  A(\<^bold>\<Or>C \<inter> U)"
(* A is called \<omega>-complete (aka. \<omega>-cpo) if every subset that is a chain has a supremum in A*)
definition directedcomplete ("dcpo _") where "dcpo A \<equiv> \<forall>D. D \<subseteq> A \<and> directed D \<longrightarrow> A(\<^bold>\<Or>D)"
definition directedcomplete_rel ("dcpo\<^sup>_ _") where "dcpo\<^sup>U A \<equiv> \<forall>D. D \<subseteq> A \<and> directed\<^sup>U D \<longrightarrow> A(\<^bold>\<Or>D \<inter> U)"

(* Clearly, dcpos are also \<omega>-cpos (but not viceversa)*)
lemma dcpo_\<omega>: "dcpo A \<longrightarrow> \<omega>-cpo A" by (simp add: chainDirected directedcomplete_def omegacomplete_def)
lemma dcpo_\<omega>_rel: "dcpo\<^sup>U A \<longrightarrow> \<omega>-cpo\<^sup>U A" by (simp add: chainDirected_rel directedcomplete_rel_def omegacomplete_rel_def)
lemma "\<omega>-cpo A \<longrightarrow> dcpo A" (*nitpick*) oops (* counterexamples are infinite*)
lemma "\<omega>-cpo\<^sup>U A \<longrightarrow> dcpo\<^sup>U A" (*nitpick*) oops (* counterexamples are infinite*)

definition allChainsHaveUB
  where "allChainsHaveUB A \<equiv> \<forall>C. C \<subseteq> A \<longrightarrow> chain C \<longrightarrow> (\<exists>X. A X \<and> UB C X)"
definition allChainsHaveUB_rel ("allChainsHaveUB\<^sup>_")
  where "allChainsHaveUB\<^sup>U A \<equiv> \<forall>C. C \<subseteq> A \<and> chain\<^sup>U C \<longrightarrow> (\<exists>X. A X \<and> UB\<^sup>U C X)"

lemma omegaCompleteUB: "\<omega>-cpo A \<Longrightarrow> allChainsHaveUB A" by (smt (verit, best) chains_def allChainsHaveUB_def least_def omegacomplete_def sup_char)
lemma omegaCompleteUB_rel: "\<omega>-cpo\<^sup>U A \<Longrightarrow> allChainsHaveUB\<^sup>U A" by (smt (verit, best) allChainsHaveUB_rel_def omegacomplete_rel_def supremum_def upper_bound_rel_def)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Inverse\<close>
theory Functions_Inverse
  imports
    Functions_Injective
begin

consts inverse_on :: "'a \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> ('c \<Rightarrow> 'b) \<Rightarrow> bool"

overloading
  inverse_on_pred \<equiv> "inverse_on :: ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool"
begin
  definition "inverse_on_pred P f g \<equiv> \<forall>x. P x \<longrightarrow> g (f x) = x"
end

lemma inverse_onI [intro]:
  assumes "\<And>x. P x \<Longrightarrow> g (f x) = x"
  shows "inverse_on P f g"
  unfolding inverse_on_pred_def using assms by blast

lemma inverse_onD:
  assumes "inverse_on P f g"
  and "P x"
  shows "g (f x) = x"
  using assms unfolding inverse_on_pred_def by blast

lemma injective_on_if_inverse_on:
  assumes inv: "inverse_on (P :: 'a \<Rightarrow> bool) (f :: 'a \<Rightarrow> _) g"
  shows "injective_on P f"
proof (rule injective_onI)
  fix x x'
  assume Px: "P x" and Px': "P x'" and f_x_eq_f_x': "f x = f x'"
  from inv have "x = g (f x)" using Px by (intro inverse_onD[symmetric])
  also have "... = g (f x')" by (simp only: f_x_eq_f_x')
  also have "... = x'" using inv Px' by (intro inverse_onD)
  finally show "x = x'" .
qed

definition "inverse (f :: 'a \<Rightarrow> _) \<equiv> inverse_on (\<top> :: 'a \<Rightarrow> bool) f"

lemma inverse_eq_inverse_on:
  "inverse (f :: 'a \<Rightarrow> _) = inverse_on (\<top> :: 'a \<Rightarrow> bool) f"
  unfolding inverse_def ..

lemma inverseI [intro]:
  assumes "\<And>x. g (f x) = x"
  shows "inverse f g"
  unfolding inverse_eq_inverse_on using assms by (intro inverse_onI)

lemma inverseD:
  assumes "inverse f g"
  shows "g (f x) = x"
  using assms unfolding inverse_eq_inverse_on by (auto dest: inverse_onD)

lemma inverse_on_if_inverse:
  fixes P :: "'a \<Rightarrow> bool" and f :: "'a \<Rightarrow> 'b"
  assumes "inverse f g"
  shows "inverse_on P f g"
  using assms by (intro inverse_onI) (blast dest: inverseD)

end


theory ConcreteSemantics7_2_SmallStep
  imports Main "~~/src/HOL/IMP/Com" "~~/src/HOL/IMP/Star" "~~/src/HOL/IMP/Big_Step"
begin

section "7 IMP: A Simple Imperative Language"

subsection "7.3 Small-Step Semantics"

(* a different way of defining the semantics of IMP.
let us talk explicitly about intermediate states of execution and about termination
*)

text \<open>
the purpose of a small-step semantics:
  allow us to explicitly observe intermediate execution states.

The main idea for representing a partial execution is
to introduce the concept of how far execution has progressed in the program.
  "com * state \<Rightarrow> com * state \<Rightarrow> bool"
  2nd "com * state" component of the judgement is
  use the command SKIP to indicate that execution has terminated
\<close>

inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq2:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"
text \<open> for the WHILE loop: we define its semantics by merely unrolling the loop once.
Note that we could have used the unrolling definition of WHILE in the big-step semantics as well.(cf: section 7.2.4)
\<close>

code_pred small_step .
declare small_step.intros [intro]
thm small_step.induct
lemmas small_step_induct = small_step.induct[split_format(complete)]
thm small_step_induct

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

values "{(c', map t [''x'', ''y'', ''z'']) | c' t. (''x'' ::= V ''z'';; ''y'' ::= V ''x'',<''x'' := 3, ''y'' := 7, ''z'' := 5>) \<rightarrow>* (c', t)}"
(*
"{(''x'' ::= V ''z'';; ''y'' ::= V ''x'', [3, 7, 5]),
  (SKIP;; ''y'' ::= V ''x'', [5, 7, 5]), (''y'' ::= V ''x'', [5, 7, 5]),
  (SKIP, [5, 5, 5])}"
  :: "(com \<times> int list) set"
*)

(* こいつらがないとdeterministicの証明ができない *)
inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm SkipE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"

lemma deterministic:
  "cs \<rightarrow> cs' \<Longrightarrow> cs \<rightarrow> cs'' \<Longrightarrow> cs'' = cs'"
apply(induction arbitrary: cs'' rule:small_step.induct)
apply blast+
done

(* lemma deterministic':
  "\<lbrakk> cs \<rightarrow> cs' ; cs \<rightarrow> cs'' \<rbrakk> \<Longrightarrow> cs'' = cs'"
apply(induction arbitrary: cs'' rule:small_step.induct)
apply blast+
done *)

subsubsection "7.3.1 Equivalence with Big-Step Semantics"

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
proof (induction rule: star_induct)
  case (refl x)
  then show ?case by simp
next
  case (step x y z)
  then show ?case by (metis Seq2 star.step)
qed

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
by (meson Seq1 star.step star_seq2 star_trans)

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof(induction rule: big_step.induct)
  case (Skip s)
  then show ?case by blast
next
  case (Assign x a s)
  then show ?case by blast
next
  case (Seq c1 s1 s2 c2 s3)
  assume "(c1,s1) \<rightarrow>* (SKIP,s2)" and "(c2,s2) \<rightarrow>* (SKIP,s3)"
  (* here is gap *)
  then show ?case using seq_comp by blast
next
  case (IfTrue b s c1 t c2)
  assume "bval b s" and "(c1, s) \<rightarrow>* (SKIP, t)"
  hence "(IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)"  by (simp add: small_step.IfTrue)
  then show ?case by (meson IfTrue.IH star.step)
next
  case (IfFalse b s c2 t c1)
  assume "\<not> bval b s" and "(c2, s) \<rightarrow>* (SKIP, t)"
  hence "(IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" by (simp add: small_step.IfFalse)
  then show ?case by (meson IfFalse.IH star.step)
next
(* WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" *)
  case (WhileFalse b s c)
  assume "\<not>bval b s"
  have "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"  by (simp add: While)
  moreover have "(IF b THEN c;; WHILE b DO c ELSE SKIP,s) \<rightarrow>* (SKIP, s)"  by (simp add: WhileFalse.hyps small_step.IfFalse)
  ultimately show ?case  by (meson star.step)
  (* then ... by (meson calculation star.step) *)
next
(* WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"  *)
  case (WhileTrue b s1 c s2 s3)
  assume b: "bval b s1" and c: "(c,s1) \<Rightarrow> s2" and w: "(WHILE b DO c, s2) \<Rightarrow> s3"
  have "(WHILE b DO c, s1) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, s1)" by blast
  moreover have "(IF b THEN c;; WHILE b DO c ELSE SKIP, s1) \<rightarrow>* (c;;WHILE b DO c, s1)"  by (simp add: b small_step.IfTrue)
  moreover have  "(c;; WHILE b DO c,s1) \<rightarrow>* (SKIP, s3)" using WhileTrue.IH(1) WhileTrue.IH(2) seq_comp by auto
  ultimately show ?case  by (meson star.step star_trans)
qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
  apply(induction arbitrary: t rule: small_step.induct)
  apply(auto)
  done

lemma small_to_big:
  "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
  apply(induction cs "(SKIP, t)" rule: star.induct)
  apply(auto)
  by (simp add: small1_big_continue)

(* this alternative form describes the same behaviours as the big-step semantics. *)
theorem big_iff_small:
  "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
  using big_to_small small_to_big by blast

subsubsection "7.3.2 Final Configurations, Infinite Reductions, and Termination"

definition final :: "com \<times> state \<Rightarrow> bool" where
"final cs \<longleftrightarrow> \<not>(\<exists> cs'. cs \<rightarrow> cs')"

lemma final_then_skip: "final (c,s) \<Longrightarrow> (c = SKIP)"
(* final_def はinductionの先におかないと *)
apply(simp add: final_def)
apply(induction c)
apply blast+
done

lemma skip_is_final: "(c = SKIP) \<Longrightarrow> final (c,s)"
 using final_def by auto

lemma finality_equivalent_skip: "final (c,s) = (c = SKIP)"
using final_then_skip skip_is_final by blast

text \<open>
This lemma says that in IMP the absence of a big-step result is equivalent to non-termination.

In the bigstep semantics this is often indistinguishable from non-termination.
In the small-step semantics the concept of final configurations neatly distinguishes the two causes.
\<close>
lemma "(\<exists> t. cs \<Rightarrow> t ) \<longleftrightarrow> (\<exists> cs'. cs \<rightarrow>* cs' \<and> final cs')"
apply(simp add: finality_equivalent_skip)
using big_to_small small_to_big by blast

end


theory Ord_locale
  imports GZF_locale HOL.Orderings begin

(*It would be nice to use the \<open>class.wellorder\<close> locale, but unfortunately
  this assumes that the entire type is well-ordered by leq and lt,
  but we just want this to be true for the ordinal portion.
  We could assume an 'Ordinal' subtype and assume an instantiation of the wellorder class on there,
  then I imagine that the types-to-sets stuff could port all of the theorems we would import from type class
  to the portion of 'd such that Ord x holds.
  But this is too much work just to avoid assuming the axioms manually.  *)

locale Ord = GZF Mem Emp Set Union Subset Pow Succ Inf Repl
    for Mem :: "'d \<Rightarrow> 'd \<Rightarrow> bool" (infixl \<open>\<in>\<close> 50)
    and Emp :: "'d" (\<open>\<emptyset>\<close>) and Set :: "'d \<Rightarrow> bool"
    and Union :: "'d \<Rightarrow> 'd" (\<open>\<Union>_\<close> [90] 90)
    and Subset:: "['d,'d] \<Rightarrow> bool" (infixl \<open>\<subseteq>\<close> 50)
    and Pow ::  "'d \<Rightarrow> 'd" (\<open>\<P>\<close> 90)
    and Succ :: "'d \<Rightarrow> 'd"
    and Inf :: "'d"  \<comment> \<open>witness of Infinity\<close>
    and Repl :: "[['d,'d] \<Rightarrow> bool] \<Rightarrow> 'd \<Rightarrow>'d" (\<open>\<R>\<close> 90)  +
  fixes
    Ord :: "'d \<Rightarrow> bool" and
    lt :: "'d \<Rightarrow> 'd \<Rightarrow> bool" (infixl \<open><\<close> 50) and
    zero :: "'d" (\<open>0\<close>) and
    succ :: "'d \<Rightarrow> 'd" and
    Limit :: "'d \<Rightarrow> bool" and
    predSet :: "'d \<Rightarrow> 'd" and
    OrdRec :: "('d \<Rightarrow> 'd \<Rightarrow> 'd) \<Rightarrow> ('d \<Rightarrow> 'd \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd" and
    omega :: "'d" (\<open>\<omega>\<close>)
  assumes
    (*Axioms for the Ord predicate*)
    zero_ord [simp]: "Ord 0" and
    \<omega>_ord [simp]: "Ord \<omega>" and
    lt_ord_ax : "\<forall>\<alpha> \<beta>. \<alpha> < \<beta> \<longrightarrow> Ord \<alpha> \<and> Ord \<beta>" and
    ord_succ_iff_ax : "\<forall>\<beta>. Ord (succ \<beta>) \<longleftrightarrow> Ord \<beta>" and
    (*Definition of 0, succ, leq and Limit*)
    zero_def : "\<forall>\<alpha>. \<not> (\<alpha> < 0)" and
    succ_def : "(\<forall>\<alpha> \<beta>. \<alpha> < (succ \<beta>) \<longleftrightarrow> \<alpha> < \<beta> | \<alpha> = \<beta> \<and> Ord \<beta>)" and
    limit_def : "\<forall>\<mu>. Limit \<mu> \<longleftrightarrow> (Ord \<mu> \<and> 0 < \<mu> \<and> (\<forall>\<beta>. \<beta> < \<mu> \<longrightarrow> succ \<beta> < \<mu>))" and
    \<omega>_def : "Limit \<omega> \<and> (\<forall>\<mu>. Limit \<mu> \<longrightarrow> \<omega> < \<mu>)" and
    (*Characterisation of < as a wellorder*)
    lt_trans : "\<forall>i j k. i < j \<longrightarrow> j < k \<longrightarrow> i < k" and
    lt_notsym : "\<forall>i j. i < j \<longrightarrow> \<not> j < i" and
    lt_linear : "\<forall>i j. Ord i \<and> Ord j \<longrightarrow> i < j | i = j | j < i" and
    lt_induct : "\<forall>a. Ord a \<longrightarrow> (\<forall>x. Ord x \<longrightarrow> (\<forall>y. y < x \<longrightarrow> P y) \<longrightarrow> P x) \<longrightarrow> P a" and

    predset_def : "\<forall>\<beta>. Ord \<beta> \<longrightarrow> Set (predSet \<beta>) \<and> (\<forall>\<alpha>. \<alpha> \<in> predSet \<beta> \<longleftrightarrow> \<alpha> < \<beta>)" and
    ordrec_0 : "\<forall>G F A. OrdRec G F A 0 = A" and
    ordrec_succ : "\<forall>G F A b.
      OrdRec G F A (succ b) = F (succ b) (OrdRec G F A b)" and
    ordrec_lim :  "\<forall>G F A z. Limit z \<longrightarrow>
      OrdRec G F A z = G z (Lambda (predSet z) (\<lambda>\<beta>. OrdRec G F A \<beta>))"

context Ord begin

lemma lt_ord : "\<alpha> < \<beta> \<Longrightarrow> Ord \<alpha> \<and> Ord \<beta>" using lt_ord_ax by auto
lemma lt_ord1: "j<i ==> Ord(j)"
  using lt_ord by simp

lemma lt_ord2: "j<i ==> Ord(i)"
  using lt_ord by simp

lemma ord_succ_iff [iff] : "Ord (succ \<beta>) \<longleftrightarrow> Ord \<beta>" using ord_succ_iff_ax by auto
lemma limit_iff : "Limit \<mu> \<longleftrightarrow> Ord \<mu> \<and> 0 < \<mu> \<and> (\<forall>\<beta>. \<beta> < \<mu> \<longrightarrow> succ \<beta> < \<mu>)" using limit_def by auto
lemma succ_ord [intro]:
  assumes "Ord x" shows "Ord (succ x)"
  using assms by (auto)

lemma succ_ordD : "Ord (succ i) \<Longrightarrow> Ord i"
  using ord_succ_iff by simp

lemma predset_set : "Ord \<beta> \<Longrightarrow> Set (predSet \<beta>)"
  using predset_def by auto

lemma predset_iff : assumes "Ord \<beta>"
  shows "\<alpha> \<in> predSet \<beta> \<longleftrightarrow> \<alpha> < \<beta>"
  using predset_def assms by auto

lemma predsetI :
  shows "\<alpha> < \<beta> \<Longrightarrow> \<alpha> \<in> predSet \<beta>"
  using predset_iff lt_ord by auto

lemma predsetE : assumes "Ord \<beta>"
  shows "\<alpha> \<in> predSet \<beta> \<Longrightarrow> \<alpha> < \<beta>"
  using predset_iff[OF assms] by simp

lemma predset_mem_ord : assumes "Ord \<beta>"
  shows "\<alpha> \<in> predSet \<beta> \<Longrightarrow> Ord \<alpha>"
  using predset_iff[OF \<open>Ord \<beta>\<close>] lt_ord1 by auto

lemma succ_lt : "Ord \<beta> \<Longrightarrow> \<beta> < succ \<beta>" using succ_def by auto

lemma zero_lt : "\<not> (\<alpha> < 0)" by (simp add: zero_def)

definition one :: "'d" (\<open>1\<close>) where
  "1 \<equiv> succ 0"

definition three :: "'d" (\<open>3\<close>) where
  "3 \<equiv> succ (succ 1)"

lemma Ord_1 [simp]: "Ord 1"
  unfolding one_def using succ_ord by simp

lemma Ord_3 [simp]: "Ord 3"
  unfolding three_def using succ_ord by simp

lemma trans_induct [consumes 1, case_names step] :
 "Ord i \<Longrightarrow> (\<And>x. Ord x \<Longrightarrow> (\<And>y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x) \<Longrightarrow> P i"
  using lt_induct by auto

lemmas le_Ord2 = lt_ord2 [THEN succ_ordD]
(* i<0 ==> R *)
lemmas lt0E = zero_lt [THEN notE, elim!]

lemma lt_trans_pure [trans]: "\<lbrakk> i < j ; j < k \<rbrakk> \<Longrightarrow> i < k" using lt_trans by blast

lemma lt_asym : "\<lbrakk> i<j; \<not> P \<Longrightarrow> j<i \<rbrakk> \<Longrightarrow> P" using lt_notsym by auto

lemma lt_irrefl [elim!]: "i<i \<Longrightarrow> P"
  by (blast intro: lt_asym)

lemma lt_not_refl: "\<not> i<i"
  using lt_irrefl by auto

abbreviation leq (infixl \<open>\<le>\<close> 50) where "x \<le> y \<equiv> x < succ y"

lemma le_iff: "i \<le> j <-> i<j | (i=j & Ord(j))" using succ_def by auto

lemma leI: "i<j ==> i \<le> j"
  by (simp add: le_iff)

lemma le_eqI: "[| i=j;  Ord(j) |] ==> i \<le> j"
by (simp add: le_iff)

lemmas le_refl = refl [THEN le_eqI]

lemma le_refl_iff [iff]: "i \<le> i <-> Ord(i)"
by (simp (no_asm_simp) add: lt_not_refl le_iff)

lemma leCI: "(~ (i=j & Ord(j)) ==> i<j) ==> i \<le> j"
by (simp add: le_iff, blast)

lemma leE:
    "[| i \<le> j;  i<j ==> P;  [| i=j;  Ord(j) |] ==> P |] ==> P"
by (simp add: le_iff, blast)

lemma le_anti_sym: "[| i \<le> j;  j \<le> i |] ==> i=j"
apply (simp add: le_iff)
apply (blast elim: lt_asym)
done

lemma le0_iff [simp]: "i \<le> 0 \<longleftrightarrow> i=0"
 using zero_ord by (blast elim!: leE)

lemmas le0D = le0_iff [THEN iffD1, dest!]

lemma Ord_linear_lt:
  assumes "Ord i" "Ord j"
  obtains (lt) "i < j" | (eq) "i=j" | (gt) "j < i"
  using assms lt_linear by auto

lemma Ord_linear2:
 assumes o: "Ord(i)" "Ord(j)"
 obtains (lt) "i<j" | (ge) "j \<le> i"
apply (rule_tac i = i and j = j in Ord_linear_lt)
apply (blast intro: leI le_eqI sym o) +
done

lemma Ord_linear_le:
 assumes o: "Ord(i)" "Ord(j)"
 obtains (le) "i \<le> j" | (ge) "j \<le> i"
apply (rule_tac i = i and j = j in Ord_linear_lt)
apply (blast intro: leI le_eqI o) +
  done

lemma le_imp_not_lt: "j \<le> i ==> ~ i<j"
by (blast elim!: leE elim: lt_asym)

lemma not_lt_imp_le: "[| ~ i<j;  Ord(i);  Ord(j) |] ==> j \<le> i"
by (rule_tac i = i and j = j in Ord_linear2, auto)

lemma not_lt_iff_le: "[| Ord(i);  Ord(j) |] ==> ~ i<j <-> j \<le> i"
by (blast dest: le_imp_not_lt not_lt_imp_le)

lemma not_le_iff_lt: "[| Ord(i);  Ord(j) |] ==> ~ i \<le> j <-> j<i"
  by (use not_lt_iff_le in auto)
    (*Proof edited. WAS: (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym]) *)

lemma Ord_0_le: "Ord(i) ==> 0 \<le> i"
  by (erule not_lt_iff_le [THEN iffD1], auto)

lemma Ord_0_lt: "[| Ord(i);  i\<noteq>0 |] ==> 0<i"
apply (erule not_le_iff_lt [THEN iffD1])
apply (rule zero_ord, blast)
done

lemma Ord_0_lt_iff: "Ord(i) ==> i\<noteq>0 <-> 0<i"
by (blast intro: Ord_0_lt)

lemma all_lt_imp_le: "[| Ord(i);  Ord(j);  !!x. x<j ==> x<i |] ==> j \<le> i"
  by (blast intro: not_lt_imp_le dest: lt_irrefl)

lemma lt_trans1: "[| i \<le> j;  j<k |] ==> i<k"
by (blast elim!: leE intro: lt_trans_pure)

lemma lt_trans2: "[| i<j;  j \<le> k |] ==> i<k"
by (blast elim!: leE intro: lt_trans_pure)

lemma le_trans: "[| i \<le> j;  j \<le> k |] ==> i \<le> k"
by (blast intro: lt_trans1)

lemma succ_leI: "i<j ==> succ(i) \<le> j"
proof (rule not_lt_iff_le [THEN iffD1])
  assume "i < j"
  thus "Ord j" using lt_ord2 by auto
  from \<open>i < j\<close> have "Ord i" using lt_ord by simp
  thus "Ord (succ i)" using succ_ord by auto
  from \<open>i < j\<close> show "\<not> j \<le> i" by (blast elim: leE lt_asym)
qed

lemma succ_leE: "succ(i) \<le> j ==> i<j"
proof (rule not_le_iff_lt [THEN iffD1])
  assume "succ i \<le> j"
  thus "Ord j" using lt_ord2 by auto
  from \<open>succ i \<le> j\<close> show "Ord i" using lt_ord succ_ordD by auto
  from \<open>succ i \<le> j\<close> show "\<not> j \<le> i" by (blast elim: leE lt_asym)
qed
(*WAS:
apply (rule not_le_iff_lt [THEN iffD1])
apply (blast elim: ltE leE lt_asym)+
done *)

lemma succ_le_iff [iff]: "succ(i) \<le> j <-> i<j"
by (blast intro: succ_leI succ_leE)

lemma succ_le_imp_le: "succ(i) \<le> succ(j) ==> i \<le> j"
  by (blast)

lemma lt_imp_0_lt: "j<i ==> 0<i"
by (blast intro: lt_trans1 Ord_0_le [OF lt_ord1])

lemma le_succ_iff: "i \<le> succ(j) <-> i \<le> j | i=succ(j) & Ord(i)"
apply (simp (no_asm) add: le_iff)
apply blast
done

lemma limit_ord: "Limit(i) ==> Ord(i)"
  unfolding limit_iff by auto
(*WAS:
apply (unfold Limit_def)
apply (erule conjunct1)
done *)

lemma Limit_has_0: "Limit(i) ==> 0 < i"
  unfolding limit_iff by auto
(*WAS:
apply (unfold Limit_def)
apply (erule conjunct2 [THEN conjunct1])
done *)

lemma Limit_nonzero: "Limit(i) ==> i \<noteq> 0"
by (drule Limit_has_0, blast)

lemma Limit_has_succ: "[| Limit(i);  j<i |] ==> succ(j) < i"
by (unfold limit_iff, blast)

lemma Limit_succ_lt_iff [simp]: assumes "Limit(i)"
  shows  "succ(j) < i <-> (j<i)"
proof
  assume "succ j < i"
  moreover hence "j < succ j" using lt_ord succ_lt by auto
  ultimately show "j < i" using lt_trans_pure by auto
next
  assume "j < i" thus "succ j < i" using Limit_has_succ[OF assms] by simp
qed
(*WAS:
apply (safe intro!: Limit_has_succ)
apply (frule lt_ord)
apply (blast intro: lt_trans)
done*)

lemma zero_not_Limit [iff]: "~ Limit(0)"
  using limit_iff by auto
(*WAS: by (simp add: Limit_def)*)

lemma Limit_has_1: "Limit(i) ==> 1 < i"
 unfolding one_def by (blast intro: Limit_has_0 Limit_has_succ)
(*WAS: by (blast intro: Limit_has_0 Limit_has_succ) *)

lemma increasing_LimitI: "[| 0<l; \<forall>x. x < l \<longrightarrow> (\<exists>y. y < l \<and> x < y) |] ==> Limit(l)"
(*WAS: "[| 0<l; \<forall>x\<in>l. \<exists>y\<in>l. x<y |] ==> Limit(l)"*)
  by (unfold limit_iff, simp add: lt_ord2, clarify, blast intro: lt_trans1 lt_ord2)
(*WAS: apply (unfold Limit_def, simp add: lt_ord2, clarify)
apply (drule_tac i=y in ltD)
apply (blast intro: lt_trans1 [OF _ ltI] lt_ord2)
done*)

lemma non_succ_LimitI:
  assumes i: "0<i" and nsucc: "\<And>y. succ(y) \<noteq> i"
  shows "Limit(i)"
proof -
  have Oi: "Ord(i)" using i by (simp add: lt_ord2)
  { fix y
    assume yi: "y<i"
    hence Osy: "Ord(succ(y))" by (simp add: lt_ord succ_ord)
    have "~ i \<le> y" using yi by (blast dest: le_imp_not_lt)
    hence "succ(y) < i" using nsucc [of y]
      by (blast intro: Ord_linear_lt [OF Osy Oi]) }
  thus ?thesis using i Oi by (auto simp add: limit_iff)
qed

lemma succ_LimitE [elim!]: "Limit(succ(i)) ==> P"
apply (rule lt_irrefl)
apply (rule Limit_has_succ, assumption)
apply (erule limit_ord [THEN succ_ordD, THEN le_refl])
done

lemma not_succ_Limit [simp]: "~ Limit(succ(i))"
by blast

lemma Limit_le_succD: "[| Limit(i);  i \<le> succ(j) |] ==> i \<le> j"
  by (blast elim!: leE)

lemma ord_cases_disj: "Ord(i) ==> i=0 | (\<exists>j. Ord(j) & i=succ(j)) | Limit(i)"
by (blast intro!: non_succ_LimitI Ord_0_lt)

lemma ord_cases:
 assumes i: "Ord(i)"
 obtains ("0") "i=0" | (succ) j where "Ord(j)" "i=succ(j)" | (limit) "Limit(i)"
by (insert ord_cases_disj [OF i], auto)

lemma trans_induct3_raw:
     "[| Ord(i);
         P(0);
         !!x. [| Ord(x);  P(x) |] ==> P(succ(x));
         !!x. [| Limit(x);  \<forall>y. y < x \<longrightarrow> P(y) |] ==> P(x)
      |] ==> P(i)"
apply (erule trans_induct)
apply (erule ord_cases, blast+)
done

lemma trans_induct3 [case_names 0 succ limit, consumes 1]:
  assumes "Ord(i)" "P(0)"
    "(\<And>x. Ord(x) \<Longrightarrow> P(x) \<Longrightarrow> P(succ(x)))"
    "(\<And>x. Limit(x) \<Longrightarrow> (\<And>y. y < x \<Longrightarrow> P(y)) \<Longrightarrow> P(x))"
    shows "P(i)"
  using trans_induct3_raw [of i P, OF assms] by simp

lemma \<omega>_lim : "Limit \<omega>" using \<omega>_def by simp
lemma \<omega>_0 : "0 < \<omega>" using \<omega>_lim limit_def by auto
lemma \<omega>_succ : "\<beta> < \<omega> \<Longrightarrow> succ \<beta> < \<omega>" using \<omega>_lim limit_def by auto

(*Needs to come before the locale specification of Ops *)
abbreviation setseq where "setseq X \<equiv> rall (\<lambda>\<beta>. \<beta> < \<omega>) (\<lambda>\<beta>. Set (X \<beta>))"

end
end


(*<*)
theory Regex
  imports
    "MFOTL_Monitor.Trace"
    "HOL-Library.Lattice_Syntax"
    "HOL-Library.Extended_Nat"
begin
(*>*)

section \<open>Regular expressions\<close>

context begin

qualified datatype (atms: 'a) regex = Skip nat | Test 'a
  | Plus "'a regex" "'a regex" | Times "'a regex" "'a regex"  | Star "'a regex"

lemma finite_atms[simp]: "finite (atms r)"
  by (induct r) auto

definition "Wild = Skip 1"

lemma size_regex_estimation[termination_simp]: "x \<in> atms r \<Longrightarrow> y < f x \<Longrightarrow> y < size_regex f r"
  by (induct r) auto

lemma size_regex_estimation'[termination_simp]: "x \<in> atms r \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> size_regex f r"
  by (induct r) auto

qualified definition "TimesL r S = Times r ` S"
qualified definition "TimesR R s = (\<lambda>r. Times r s) ` R"

qualified primrec fv_regex where
  "fv_regex fv (Skip n) = {}"
| "fv_regex fv (Test \<phi>) = fv \<phi>"
| "fv_regex fv (Plus r s) = fv_regex fv r \<union> fv_regex fv s"
| "fv_regex fv (Times r s) = fv_regex fv r \<union> fv_regex fv s"
| "fv_regex fv (Star r) = fv_regex fv r"

lemma fv_regex_cong[fundef_cong]:
  "r = r' \<Longrightarrow> (\<And>z. z \<in> atms r \<Longrightarrow> fv z = fv' z) \<Longrightarrow> fv_regex fv r = fv_regex fv' r'"
  by (induct r arbitrary: r') auto

lemma finite_fv_regex[simp]: "(\<And>z. z \<in> atms r \<Longrightarrow> finite (fv z)) \<Longrightarrow> finite (fv_regex fv r)"
  by (induct r) auto

lemma fv_regex_commute:
  "(\<And>z. z \<in> atms r \<Longrightarrow> x \<in> fv z \<longleftrightarrow> g x \<in> fv' z) \<Longrightarrow> x \<in> fv_regex fv r \<longleftrightarrow> g x \<in> fv_regex fv' r"
  by (induct r) auto

lemma fv_regex_alt: "fv_regex fv r = (\<Union>z \<in> atms r. fv z)"
  by (induct r) auto

qualified definition nfv_regex where
  "nfv_regex fv r = Max (insert 0 (Suc ` fv_regex fv r))"

lemma insert_Un: "insert x (A \<union> B) = insert x A \<union> insert x B"
  by auto

lemma nfv_regex_simps[simp]:
  assumes [simp]: "(\<And>z. z \<in> atms r \<Longrightarrow> finite (fv z))" "(\<And>z. z \<in> atms s \<Longrightarrow> finite (fv z))"
  shows
  "nfv_regex fv (Skip n) = 0"
  "nfv_regex fv (Test \<phi>) = Max (insert 0 (Suc ` fv \<phi>))"
  "nfv_regex fv (Plus r s) = max (nfv_regex fv r) (nfv_regex fv s)"
  "nfv_regex fv (Times r s) = max (nfv_regex fv r) (nfv_regex fv s)"
  "nfv_regex fv (Star r) = nfv_regex fv r"
  unfolding nfv_regex_def
  by (auto simp add: image_Un Max_Un insert_Un simp del: Un_insert_right Un_insert_left)

abbreviation "min_regex_default f r j \<equiv> (if atms r = {} then j else Min ((\<lambda>z. f z j) ` atms r))"

qualified primrec match :: "(nat \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a regex \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "match test (Skip n) = (\<lambda>i j. j = i + n)"
| "match test (Test \<phi>) = (\<lambda>i j. i = j \<and> test i \<phi>)"
| "match test (Plus r s) = match test r \<squnion> match test s"
| "match test (Times r s) = match test r OO match test s"
| "match test (Star r) = (match test r)\<^sup>*\<^sup>*"

lemma match_cong[fundef_cong]:
  "r = r' \<Longrightarrow> (\<And>i z. z \<in> atms r \<Longrightarrow> t i z = t' i z) \<Longrightarrow> match t r = match t' r'"
  by (induct r arbitrary: r') auto

qualified primrec eps where
  "eps test i (Skip n) = (n = 0)"
| "eps test i (Test \<phi>) = test i \<phi>"
| "eps test i (Plus r s) = (eps test i r \<or> eps test i s)"
| "eps test i (Times r s) = (eps test i r \<and> eps test i s)"
| "eps test i (Star r) = True"

qualified primrec lpd where
  "lpd test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {Skip m})"
| "lpd test i (Test \<phi>) = {}"
| "lpd test i (Plus r s) = (lpd test i r \<union> lpd test i s)"
| "lpd test i (Times r s) = TimesR (lpd test i r) s \<union> (if eps test i r then lpd test i s else {})"
| "lpd test i (Star r) = TimesR (lpd test i r) (Star r)"

qualified primrec lpd\<kappa> where
  "lpd\<kappa> \<kappa> test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {\<kappa> (Skip m)})"
| "lpd\<kappa> \<kappa> test i (Test \<phi>) = {}"
| "lpd\<kappa> \<kappa> test i (Plus r s) = lpd\<kappa> \<kappa> test i r \<union> lpd\<kappa> \<kappa> test i s"
| "lpd\<kappa> \<kappa> test i (Times r s) = lpd\<kappa> (\<lambda>t. \<kappa> (Times t s)) test i r \<union> (if eps test i r then lpd\<kappa> \<kappa> test i s else {})"
| "lpd\<kappa> \<kappa> test i (Star r) = lpd\<kappa> (\<lambda>t. \<kappa> (Times t (Star r))) test i r"

qualified primrec rpd where
  "rpd test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {Skip m})"
| "rpd test i (Test \<phi>) = {}"
| "rpd test i (Plus r s) = (rpd test i r \<union> rpd test i s)"
| "rpd test i (Times r s) = TimesL r (rpd test i s) \<union> (if eps test i s then rpd test i r else {})"
| "rpd test i (Star r) = TimesL (Star r) (rpd test i r)"

qualified primrec rpd\<kappa> where
  "rpd\<kappa> \<kappa> test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {\<kappa> (Skip m)})"
| "rpd\<kappa> \<kappa> test i (Test \<phi>) = {}"
| "rpd\<kappa> \<kappa> test i (Plus r s) = rpd\<kappa> \<kappa> test i r \<union> rpd\<kappa> \<kappa> test i s"
| "rpd\<kappa> \<kappa> test i (Times r s) = rpd\<kappa> (\<lambda>t. \<kappa> (Times r t)) test i s \<union> (if eps test i s then rpd\<kappa> \<kappa> test i r else {})"
| "rpd\<kappa> \<kappa> test i (Star r) = rpd\<kappa> (\<lambda>t. \<kappa> (Times (Star r) t)) test i r"

lemma lpd\<kappa>_lpd: "lpd\<kappa> \<kappa> test i r = \<kappa> ` lpd test i r"
  by (induct r arbitrary: \<kappa>) (auto simp: TimesR_def split: nat.splits)

lemma rpd\<kappa>_rpd: "rpd\<kappa> \<kappa> test i r = \<kappa> ` rpd test i r"
  by (induct r arbitrary: \<kappa>) (auto simp: TimesL_def split: nat.splits)

lemma match_le: "match test r i j \<Longrightarrow> i \<le> j"
proof (induction r arbitrary: i j)
  case (Times r s)
  then show ?case using order.trans by fastforce
next
  case (Star r)
  from Star.prems show ?case
    unfolding match.simps by (induct i j rule: rtranclp.induct) (force dest: Star.IH)+
qed auto

lemma match_rtranclp_le: "(match test r)\<^sup>*\<^sup>* i j \<Longrightarrow> i \<le> j"
  by (metis match.simps(5) match_le)

lemma eps_match: "eps test i r \<longleftrightarrow> match test r i i"
  by (induction r) (auto dest: antisym[OF match_le match_le])

lemma lpd_match: "i < j \<Longrightarrow> match test r i j \<longleftrightarrow> (\<Squnion>s \<in> lpd test i r. match test s) (i + 1) j"
proof (induction r arbitrary: i j)
  case (Times r s)
  have "match test (Times r s) i j \<longleftrightarrow> (\<exists>k. match test r i k \<and> match test s k j)"
    by auto
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> match test s i j \<or>
    (\<exists>k>i. match test r i k \<and> match test s k j)"
    using match_le[of test r i] nat_less_le by auto
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> (\<Squnion>t \<in> lpd test i s. match test t) (i + 1) j \<or>
    (\<exists>k>i. (\<Squnion>t \<in> lpd test i r. match test t) (i + 1) k \<and> match test s k j)"
    using Times.IH(1) Times.IH(2)[OF Times.prems] by metis
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> (\<Squnion>t \<in> lpd test i s. match test t) (i + 1) j \<or>
    (\<exists>k. (\<Squnion>t \<in> lpd test i r. match test t) (i + 1) k \<and> match test s k j)"
    using Times.prems by (intro disj_cong[OF refl] iff_exI) (auto dest: match_le)
  also have "\<dots> \<longleftrightarrow> (\<Squnion> (match test ` lpd test i (Times r s))) (i + 1) j"
    by (force simp: TimesL_def TimesR_def eps_match)
  finally show ?case .
next
  case (Star r)
  have "\<exists>s\<in>lpd test i r. (match test s OO (match test r)\<^sup>*\<^sup>*) (i + 1) j" if "(match test r)\<^sup>*\<^sup>* i j"
    using that Star.prems match_le[of test _ "i + 1"]
  proof (induct rule: converse_rtranclp_induct)
    case (step i k)
    then show ?case
      by (cases "i < k") (auto simp: not_less Star.IH dest: match_le)
  qed simp
  with Star.prems show ?case using match_le[of test _  "i + 1"]
    by (auto simp: TimesL_def TimesR_def Suc_le_eq Star.IH[of i]
      elim!: converse_rtranclp_into_rtranclp[rotated])
qed (auto split: nat.splits)

lemma rpd_match: "i < j \<Longrightarrow> match test r i j \<longleftrightarrow> (\<Squnion>s \<in> rpd test j r. match test s) i (j - 1)"
proof (induction r arbitrary: i j)
  case (Times r s)
  have "match test (Times r s) i j \<longleftrightarrow> (\<exists>k. match test r i k \<and> match test s k j)"
    by auto
  also have "\<dots> \<longleftrightarrow> match test r i j \<and> match test s j j \<or>
    (\<exists>k<j. match test r i k \<and> match test s k j)"
    using match_le[of test s _ j] nat_less_le by auto
  also have "\<dots> \<longleftrightarrow> (\<Squnion>t \<in> rpd test j r. match test t) i (j - 1) \<and> match test s j j  \<or>
    (\<exists>k<j. match test r i k \<and> (\<Squnion>t \<in> rpd test j s. match test t) k (j - 1))"
    using Times.IH(1)[OF Times.prems] Times.IH(2) by metis
  also have "\<dots> \<longleftrightarrow> (\<Squnion>t \<in> rpd test j r. match test t) i (j - 1) \<and> match test s j j  \<or>
    (\<exists>k. match test r i k \<and> (\<Squnion>t \<in> rpd test j s. match test t) k (j - 1))"
    using Times.prems by (intro disj_cong[OF refl] iff_exI) (auto dest: match_le)
  also have "\<dots> \<longleftrightarrow> (\<Squnion> (match test ` rpd test j (Times r s))) i (j - 1)"
    by (force simp: TimesL_def TimesR_def eps_match)
  finally show ?case .
next
  case (Star r)
  have "\<exists>s\<in>rpd test j r. ((match test r)\<^sup>*\<^sup>* OO match test s) i (j - 1)" if "(match test r)\<^sup>*\<^sup>* i j"
    using that Star.prems match_le[of test _ _ "j - 1"]
  proof (induct rule: rtranclp_induct)
    case (step k j)
    then show ?case
      by (cases "k < j") (auto simp: not_less Star.IH dest: match_le)
  qed simp
  with Star.prems show ?case
    by (auto 0 3 simp: TimesL_def TimesR_def intro: Star.IH[of _ j, THEN iffD2]
      elim!: rtranclp.rtrancl_into_rtrancl dest: match_le[of test _ _ "j - 1", unfolded One_nat_def])
qed (auto split: nat.splits)

lemma lpd_fv_regex: "s \<in> lpd test i r \<Longrightarrow> fv_regex fv s \<subseteq> fv_regex fv r"
  by (induct r arbitrary: s) (auto simp: TimesR_def TimesL_def split: if_splits nat.splits)+

lemma rpd_fv_regex: "s \<in> rpd test i r \<Longrightarrow> fv_regex fv s \<subseteq> fv_regex fv r"
  by (induct r arbitrary: s) (auto simp: TimesR_def TimesL_def split: if_splits nat.splits)+

lemma match_fv_cong:
  "(\<And>i x. x \<in> atms r \<Longrightarrow> test i x = test' i x) \<Longrightarrow> match test r = match test' r"
  by (induct r) auto

lemma eps_fv_cong:
  "(\<And>i x. x \<in> atms r \<Longrightarrow> test i x = test' i x) \<Longrightarrow> eps test i r = eps test' i r"
  by (induct r) auto

datatype modality = Past | Futu
datatype safety = Strict | Lax

context
  fixes fv :: "'a \<Rightarrow> 'b set"
  and safe :: "safety \<Rightarrow> 'a \<Rightarrow> bool"
begin

qualified fun safe_regex :: "modality \<Rightarrow> safety \<Rightarrow> 'a regex \<Rightarrow> bool" where
  "safe_regex m _ (Skip n) = True"
| "safe_regex m g (Test \<phi>) = safe g \<phi>"
| "safe_regex m g (Plus r s) = ((g = Lax \<or> fv_regex fv r = fv_regex fv s) \<and> safe_regex m g r \<and> safe_regex m g s)"
| "safe_regex Futu g (Times r s) =
    ((g = Lax \<or> fv_regex fv r \<subseteq> fv_regex fv s) \<and> safe_regex Futu g s \<and> safe_regex Futu Lax r)"
| "safe_regex Past g (Times r s) =
    ((g = Lax \<or> fv_regex fv s \<subseteq> fv_regex fv r) \<and> safe_regex Past g r \<and> safe_regex Past Lax s)"
| "safe_regex m g (Star r) = ((g = Lax \<or> fv_regex fv r = {}) \<and> safe_regex m g r)"

lemmas safe_regex_induct = safe_regex.induct[case_names Skip Test Plus TimesF TimesP Star]

lemma safe_cosafe:
  "(\<And>x. x \<in> atms r \<Longrightarrow> safe Strict x \<Longrightarrow> safe Lax x) \<Longrightarrow> safe_regex m Strict r \<Longrightarrow> safe_regex m Lax r"
  by (induct r; cases m) auto

lemma safe_lpd_fv_regex_le: "safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> fv_regex fv r \<subseteq> fv_regex fv s"
  by (induct r) (auto simp: TimesR_def split: if_splits)

lemma safe_lpd_fv_regex: "safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> fv_regex fv s = fv_regex fv r"
  by (simp add: eq_iff lpd_fv_regex safe_lpd_fv_regex_le)

lemma cosafe_lpd: "safe_regex Futu Lax r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> safe_regex Futu Lax s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4) show ?case
    by (auto elim: Plus(1,2))
next
  case (Times r1 r2)
  from Times(3,4) show ?case
    by (auto simp: TimesR_def elim: Times(1,2) split: if_splits)
qed (auto simp: TimesR_def split: nat.splits)

lemma safe_lpd: "(\<forall>x \<in> atms r. safe Strict x \<longrightarrow> safe Lax x) \<Longrightarrow>
  safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> safe_regex Futu Strict s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4,5) show ?case
    by (auto elim: Plus(1,2) simp: ball_Un)
next
  case (Times r1 r2)
  from Times(3,4,5) show ?case
    by (force simp: TimesR_def ball_Un elim: Times(1,2) cosafe_lpd dest: lpd_fv_regex split: if_splits)
next
  case (Star r)
  from Star(2,3,4) show ?case
    by (force simp: TimesR_def elim: Star(1) cosafe_lpd
      dest: safe_cosafe[rotated] lpd_fv_regex[where fv=fv] split: if_splits)
qed (auto split: nat.splits)

lemma safe_rpd_fv_regex_le: "safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> fv_regex fv r \<subseteq> fv_regex fv s"
  by (induct r) (auto simp: TimesL_def split: if_splits)

lemma safe_rpd_fv_regex: "safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> fv_regex fv s = fv_regex fv r"
  by (simp add: eq_iff rpd_fv_regex safe_rpd_fv_regex_le)

lemma cosafe_rpd: "safe_regex Past Lax r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> safe_regex Past Lax s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4) show ?case
    by (auto elim: Plus(1,2))
next
  case (Times r1 r2)
  from Times(3,4) show ?case
    by (auto simp: TimesL_def elim: Times(1,2) split: if_splits)
qed (auto simp: TimesL_def split: nat.splits)

lemma safe_rpd: "(\<forall>x \<in> atms r. safe Strict x \<longrightarrow> safe Lax x) \<Longrightarrow>
  safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> safe_regex Past Strict s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4,5) show ?case
    by (auto elim: Plus(1,2) simp: ball_Un)
next
  case (Times r1 r2)
  from Times(3,4,5) show ?case
    by (force simp: TimesL_def ball_Un elim: Times(1,2) cosafe_rpd dest: rpd_fv_regex split: if_splits)
next
  case (Star r)
  from Star(2,3,4) show ?case
    by (force simp: TimesL_def elim: Star(1) cosafe_rpd
      dest: safe_cosafe[rotated] rpd_fv_regex[where fv=fv] split: if_splits)
qed (auto split: nat.splits)

lemma safe_regex_safe: "(\<And>g r. safe g r \<Longrightarrow> safe Lax r) \<Longrightarrow>
  safe_regex m g r \<Longrightarrow> x \<in> atms r \<Longrightarrow> safe Lax x"
  by (induct m g r rule: safe_regex.induct) auto

lemma safe_regex_map_regex:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x \<Longrightarrow>  safe g (f x)) \<Longrightarrow> (\<And>x. x \<in> atms r \<Longrightarrow> fv (f x) = fv x) \<Longrightarrow>
   safe_regex m g r \<Longrightarrow> safe_regex m g (map_regex f r)"
  by (induct m g r rule: safe_regex.induct) (auto simp: fv_regex_alt regex.set_map)

end

lemma safe_regex_cong[fundef_cong]:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x = safe' g x) \<Longrightarrow>
  Regex.safe_regex fv safe m g r = Regex.safe_regex fv safe' m g r"
  by (induct m g r rule: safe_regex.induct) auto

lemma safe_regex_mono:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x \<Longrightarrow> safe' g x) \<Longrightarrow>
  Regex.safe_regex fv safe m g r \<Longrightarrow> Regex.safe_regex fv safe' m g r"
  by (induct m g r rule: safe_regex.induct) auto

lemma match_map_regex: "match t (map_regex f r) = match (\<lambda>k z. t k (f z)) r"
  by (induct r) auto

lemma match_cong_strong:
  "(\<And>k z. k \<in> {i ..< j + 1} \<Longrightarrow> z \<in> atms r \<Longrightarrow> t k z = t' k z) \<Longrightarrow> match t r i j = match t' r i j"
proof (induction r arbitrary: i j)
  case (Times r s)
  from Times.prems show ?case
    by (auto 0 4 simp: relcompp_apply intro: le_less_trans match_le less_Suc_eq_le
      dest: Times.IH[THEN iffD1, rotated -1] Times.IH[THEN iffD2, rotated -1] match_le)
next
  case (Star r)
  show ?case unfolding match.simps
  proof (rule iffI)
    assume *: "(match t r)\<^sup>*\<^sup>* i j"
    then have "i \<le> j" unfolding match.simps(5)[symmetric]
      by (rule match_le)
    with * show "(match t' r)\<^sup>*\<^sup>* i j" using Star.prems
    proof (induction i j rule: rtranclp.induct)
      case (rtrancl_into_rtrancl a b c)
      from rtrancl_into_rtrancl(1,2,4,5) show ?case
        by (intro rtranclp.rtrancl_into_rtrancl[OF rtrancl_into_rtrancl.IH])
          (auto dest!: Star.IH[THEN iffD1, rotated -1]
            dest: match_le match_rtranclp_le simp: less_Suc_eq_le)
    qed simp
  next
    assume *: "(match t' r)\<^sup>*\<^sup>* i j"
    then have "i \<le> j" unfolding match.simps(5)[symmetric]
      by (rule match_le)
    with * show "(match t r)\<^sup>*\<^sup>* i j" using Star.prems
    proof (induction i j rule: rtranclp.induct)
      case (rtrancl_into_rtrancl a b c)
      from rtrancl_into_rtrancl(1,2,4,5) show ?case
        by (intro rtranclp.rtrancl_into_rtrancl[OF rtrancl_into_rtrancl.IH])
          (auto dest!: Star.IH[THEN iffD2, rotated -1]
            dest: match_le match_rtranclp_le simp: less_Suc_eq_le)
    qed simp
  qed
qed auto

end

(*<*)
end
(*>*)