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

Auxiliary lemmas concerning cardinalities.
*)

theory Cardinal_aux imports AC_Equiv begin

lemma Diff_lepoll: "\<lbrakk>A \<lesssim> succ(m); B \<subseteq> A; B\<noteq>0\<rbrakk> \<Longrightarrow> A-B \<lesssim> m"
apply (rule not_emptyE, assumption)
apply (blast intro: lepoll_trans [OF subset_imp_lepoll Diff_sing_lepoll])
done

(* ********************************************************************** *)
(* Lemmas involving ordinals and cardinalities used in the proofs         *)
(* concerning AC16 and DC                                                 *)
(* ********************************************************************** *)

(* j=|A| *)
lemma lepoll_imp_ex_le_eqpoll:
     "\<lbrakk>A \<lesssim> i; Ord(i)\<rbrakk> \<Longrightarrow> \<exists>j. j \<le> i \<and> A \<approx> j"
by (blast intro!: lepoll_cardinal_le well_ord_Memrel
                  well_ord_cardinal_eqpoll [THEN eqpoll_sym]
          dest: lepoll_well_ord)

(* j=|A| *)
lemma lesspoll_imp_ex_lt_eqpoll:
     "\<lbrakk>A \<prec> i; Ord(i)\<rbrakk> \<Longrightarrow> \<exists>j. j<i \<and> A \<approx> j"
by (unfold lesspoll_def, blast dest!: lepoll_imp_ex_le_eqpoll elim!: leE)

lemma Un_eqpoll_Inf_Ord:
  assumes A: "A \<approx> i" and B: "B \<approx> i" and NFI: "\<not> Finite(i)" and i: "Ord(i)"
  shows "A \<union> B \<approx> i"
proof (rule eqpollI)
  have AB: "A \<approx> B" using A B by (blast intro: eqpoll_sym eqpoll_trans)
  have "2 \<lesssim> nat"
    by (rule subset_imp_lepoll) (rule OrdmemD [OF nat_2I Ord_nat])
  also have "... \<lesssim> i"
    by (simp add: nat_le_infinite_Ord le_imp_lepoll NFI i)+
  also have "... \<approx> A" by (blast intro: eqpoll_sym A)
  finally have "2 \<lesssim> A" .
  have ICI: "InfCard(|i|)"
    by (simp add: Inf_Card_is_InfCard Finite_cardinal_iff NFI i)
  have "A \<union> B \<lesssim> A + B" by (rule Un_lepoll_sum)
  also have "... \<lesssim> A \<times> B"
    by (rule lepoll_imp_sum_lepoll_prod [OF AB [THEN eqpoll_imp_lepoll] \<open>2 \<lesssim> A\<close>])
  also have "... \<approx> i \<times> i"
    by (blast intro: prod_eqpoll_cong eqpoll_imp_lepoll A B)
  also have "... \<approx> i"
    by (blast intro: well_ord_InfCard_square_eq well_ord_Memrel ICI i)
  finally show "A \<union> B \<lesssim> i" .
next
  have "i \<approx> A" by (blast intro: A eqpoll_sym)
  also have "... \<lesssim> A \<union> B" by (blast intro: subset_imp_lepoll)
  finally show "i \<lesssim> A \<union> B" .
qed

schematic_goal paired_bij: "?f \<in> bij({{y,z}. y \<in> x}, x)"
apply (rule RepFun_bijective)
apply (simp add: doubleton_eq_iff, blast)
done

lemma paired_eqpoll: "{{y,z}. y \<in> x} \<approx> x"
by (unfold eqpoll_def, fast intro!: paired_bij)

lemma ex_eqpoll_disjoint: "\<exists>B. B \<approx> A \<and> B \<inter> C = 0"
by (fast intro!: paired_eqpoll equals0I elim: mem_asym)

(*Finally we reach this result.  Surely there's a simpler proof?*)
lemma Un_lepoll_Inf_Ord:
     "\<lbrakk>A \<lesssim> i; B \<lesssim> i; \<not>Finite(i); Ord(i)\<rbrakk> \<Longrightarrow> A \<union> B \<lesssim> i"
apply (rule_tac A1 = i and C1 = i in ex_eqpoll_disjoint [THEN exE])
apply (erule conjE)
apply (drule lepoll_trans)
apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll])
apply (rule Un_lepoll_Un [THEN lepoll_trans], (assumption+))
apply (blast intro: eqpoll_refl Un_eqpoll_Inf_Ord eqpoll_imp_lepoll)
done

lemma Least_in_Ord: "\<lbrakk>P(i); i \<in> j; Ord(j)\<rbrakk> \<Longrightarrow> (\<mu> i. P(i)) \<in> j"
apply (erule Least_le [THEN leE])
apply (erule Ord_in_Ord, assumption)
apply (erule ltE)
apply (fast dest: OrdmemD)
apply (erule subst_elem, assumption)
done

lemma Diff_first_lepoll:
     "\<lbrakk>well_ord(x,r); y \<subseteq> x; y \<lesssim> succ(n); n \<in> nat\<rbrakk>
      \<Longrightarrow> y - {THE b. first(b,y,r)} \<lesssim> n"
apply (case_tac "y=0", simp add: empty_lepollI)
apply (fast intro!: Diff_sing_lepoll the_first_in)
done

lemma UN_subset_split:
     "(\<Union>x \<in> X. P(x)) \<subseteq> (\<Union>x \<in> X. P(x)-Q(x)) \<union> (\<Union>x \<in> X. Q(x))"
by blast

lemma UN_sing_lepoll: "Ord(a) \<Longrightarrow> (\<Union>x \<in> a. {P(x)}) \<lesssim> a"
  unfolding lepoll_def
apply (rule_tac x = "\<lambda>z \<in> (\<Union>x \<in> a. {P (x) }) . (\<mu> i. P (i) =z) " in exI)
apply (rule_tac d = "\<lambda>z. P (z) " in lam_injective)
apply (fast intro!: Least_in_Ord)
apply (fast intro: LeastI elim!: Ord_in_Ord)
done

lemma UN_fun_lepoll_lemma [rule_format]:
     "\<lbrakk>well_ord(T, R); \<not>Finite(a); Ord(a); n \<in> nat\<rbrakk>
      \<Longrightarrow> \<forall>f. (\<forall>b \<in> a. f`b \<lesssim> n \<and> f`b \<subseteq> T) \<longrightarrow> (\<Union>b \<in> a. f`b) \<lesssim> a"
apply (induct_tac "n")
apply (rule allI)
apply (rule impI)
apply (rule_tac b = "\<Union>b \<in> a. f`b" in subst)
apply (rule_tac [2] empty_lepollI)
apply (rule equals0I [symmetric], clarify)
apply (fast dest: lepoll_0_is_0 [THEN subst])
apply (rule allI)
apply (rule impI)
apply (erule_tac x = "\<lambda>x \<in> a. f`x - {THE b. first (b,f`x,R) }" in allE)
apply (erule impE, simp)
apply (fast intro!: Diff_first_lepoll, simp)
apply (rule UN_subset_split [THEN subset_imp_lepoll, THEN lepoll_trans])
apply (fast intro: Un_lepoll_Inf_Ord UN_sing_lepoll)
done

lemma UN_fun_lepoll:
     "\<lbrakk>\<forall>b \<in> a. f`b \<lesssim> n \<and> f`b \<subseteq> T; well_ord(T, R);
         \<not>Finite(a); Ord(a); n \<in> nat\<rbrakk> \<Longrightarrow> (\<Union>b \<in> a. f`b) \<lesssim> a"
by (blast intro: UN_fun_lepoll_lemma)

lemma UN_lepoll:
     "\<lbrakk>\<forall>b \<in> a. F(b) \<lesssim> n \<and> F(b) \<subseteq> T; well_ord(T, R);
         \<not>Finite(a); Ord(a); n \<in> nat\<rbrakk>
      \<Longrightarrow> (\<Union>b \<in> a. F(b)) \<lesssim> a"
apply (rule rev_mp)
apply (rule_tac f="\<lambda>b \<in> a. F (b)" in UN_fun_lepoll)
apply auto
done

lemma UN_eq_UN_Diffs:
     "Ord(a) \<Longrightarrow> (\<Union>b \<in> a. F(b)) = (\<Union>b \<in> a. F(b) - (\<Union>c \<in> b. F(c)))"
apply (rule equalityI)
 prefer 2 apply fast
apply (rule subsetI)
apply (erule UN_E)
apply (rule UN_I)
 apply (rule_tac P = "\<lambda>z. x \<in> F (z) " in Least_in_Ord, (assumption+))
apply (rule DiffI, best intro: Ord_in_Ord LeastI, clarify)
apply (erule_tac P = "\<lambda>z. x \<in> F (z) " and i = c in less_LeastE)
apply (blast intro: Ord_Least ltI)
done

lemma lepoll_imp_eqpoll_subset:
     "a \<lesssim> X \<Longrightarrow> \<exists>Y. Y \<subseteq> X \<and> a \<approx> Y"
apply (unfold lepoll_def eqpoll_def, clarify)
apply (blast intro: restrict_bij
             dest: inj_is_fun [THEN fun_is_rel, THEN image_subset])
done

(* ********************************************************************** *)
(* Diff_lesspoll_eqpoll_Card                                              *)
(* ********************************************************************** *)

lemma Diff_lesspoll_eqpoll_Card_lemma:
     "\<lbrakk>A\<approx>a; \<not>Finite(a); Card(a); B \<prec> a; A-B \<prec> a\<rbrakk> \<Longrightarrow> P"
apply (elim lesspoll_imp_ex_lt_eqpoll [THEN exE] Card_is_Ord conjE)
apply (frule_tac j=xa in Un_upper1_le [OF lt_Ord lt_Ord], assumption)
apply (frule_tac j=xa in Un_upper2_le [OF lt_Ord lt_Ord], assumption)
apply (drule Un_least_lt, assumption)
apply (drule eqpoll_imp_lepoll [THEN lepoll_trans],
       rule le_imp_lepoll, assumption)+
apply (case_tac "Finite(x \<union> xa)")
txt\<open>finite case\<close>
 apply (drule Finite_Un [OF lepoll_Finite lepoll_Finite], assumption+)
 apply (drule subset_Un_Diff [THEN subset_imp_lepoll, THEN lepoll_Finite])
 apply (fast dest: eqpoll_sym [THEN eqpoll_imp_lepoll, THEN lepoll_Finite])
txt\<open>infinite case\<close>
apply (drule Un_lepoll_Inf_Ord, (assumption+))
apply (blast intro: le_Ord2)
apply (drule lesspoll_trans1
             [OF subset_Un_Diff [THEN subset_imp_lepoll, THEN lepoll_trans]
                 lt_Card_imp_lesspoll], assumption+)
apply (simp add: lesspoll_def)
done

lemma Diff_lesspoll_eqpoll_Card:
     "\<lbrakk>A \<approx> a; \<not>Finite(a); Card(a); B \<prec> a\<rbrakk> \<Longrightarrow> A - B \<approx> a"
apply (rule ccontr)
apply (rule Diff_lesspoll_eqpoll_Card_lemma, (assumption+))
apply (blast intro: lesspoll_def [THEN def_imp_iff, THEN iffD2]
                    subset_imp_lepoll eqpoll_imp_lepoll lepoll_trans)
done

end


(* Title:      Containers/Examples/Containers_DFS_Ex.thy
   Author:     Andreas Lochbihler, ETH Zurich *)

section \<open>Formalisation of depth-first search using Containers\<close>

theory Containers_DFS_Ex imports
  "../Containers"
  "HOL-Library.Transitive_Closure_Table"
begin

subsection \<open>Auxiliary stuff\<close>

definition restrict :: "('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set" (infixl "\<upharpoonleft>" 60)
where "R \<upharpoonleft> A = {(a, b) \<in> R. b \<in> A}"

lemma restrict_UNIV [simp]: "R \<upharpoonleft> UNIV = R"
by auto

lemma restrict_restrict [simp]: "R \<upharpoonleft> A \<upharpoonleft> B = R \<upharpoonleft> (A \<inter> B)"
by auto

lemma rtrancl_restrict_reachable:
  assumes x: "(x, y) \<in> R\<^sup>*"
  and z: "(z, y) \<notin> R\<^sup>*"
  shows "(x, y) \<in> (R \<upharpoonleft> - R\<^sup>* `` {z})\<^sup>*"
using x
proof(induction rule: converse_rtrancl_induct)
  case (step x x')
  from \<open>(x, x') \<in> R\<close> z \<open>(x', y) \<in> R\<^sup>*\<close>
  have "(x, x') \<in> R \<upharpoonleft> - R\<^sup>* `` {z}" by(auto intro: rtrancl_trans converse_rtrancl_into_rtrancl)
  thus ?case using step.IH by(rule converse_rtrancl_into_rtrancl)
qed simp

lemma rtrancl_restrict_start:
  assumes "(x, y) \<in> R\<^sup>*"
  shows "(x, y) \<in> (R \<upharpoonleft> - {x})\<^sup>*"
proof -
  let ?R = "\<lambda>x y. (x, y) \<in> R"
  define z where "z \<equiv> x"
  with assms obtain xs where "rtrancl_path ?R x xs y" "z \<notin> set xs"
    by(auto simp add: rtrancl_def rtranclp_eq_rtrancl_path elim: rtrancl_path_distinct)
  thus "(x, y) \<in> (R \<upharpoonleft> - {z})\<^sup>*"
    by induction(auto intro: converse_rtrancl_into_rtrancl)
qed

lemma (in comp_fun_commute) fold_set_union_disj: (* Move to distribution *)
  assumes "finite A" "finite B" "A \<inter> B = {}"
  shows "Finite_Set.fold f z (A \<union> B) = Finite_Set.fold f (Finite_Set.fold f z A) B"
using assms(2,1,3) by induction simp_all

lemma Image_insert [simp]:
  fixes A :: "'a set"
  assumes "NO_MATCH ({} :: 'a set) A"
  shows "R `` insert x A = R `` {x} \<union> (R `` A)"
by(auto)

subsection \<open>Declarative definition\<close>

datatype 'a dfs_result = is_Reachable: Reachable | Visited "'a set"

context fixes E :: "('a \<times> 'a) set" begin

definition reachable :: "'a => 'a => bool"
where "reachable src tgt \<longleftrightarrow> (src, tgt) \<in> E\<^sup>*"

text \<open>
  We avoid the non-determinism of visited nodes in depth-first search by only returning
  the set of visited nodes when the search fails, because in that case it contains all reachable
  nodes and therefore is deterministic again.
\<close>

definition dfs :: "'a \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> 'a dfs_result"
where
  "dfs src tgt visited =
  (if tgt \<in> (E \<upharpoonleft> - visited)\<^sup>* `` {src} then Reachable else Visited (visited \<union> (E \<upharpoonleft> - visited)\<^sup>* `` {src}))"

subsection \<open>Derivation of the recursion equation\<close>

context
  fixes tgt :: 'a and loop
  defines "loop \<equiv> \<lambda>x r. case r of Reachable \<Rightarrow> Reachable | Visited \<V> \<Rightarrow>
    if x \<in> \<V> then Visited \<V> else dfs x tgt \<V>"
begin

private lemma loop_simps:
  "loop x Reachable = Reachable"
  "loop x (Visited \<V>) = (if x \<in> \<V> then Visited \<V> else dfs x tgt \<V>)"
by(simp_all add: loop_def)

context notes [simp] = loop_simps begin

lemma comp_fun_commute_dfs_body: "comp_fun_commute loop"
by(unfold_locales)(auto simp add: loop_def dfs_def fun_eq_iff intro: rtrancl_mono[THEN subsetD, rotated] rtrancl_trans dest: rtrancl_restrict_reachable split: dfs_result.split)

interpretation f: comp_fun_commute loop
by(rule comp_fun_commute_dfs_body)

lemma fold_dfs_Reachable [simp]:
  "Finite_Set.fold loop Reachable A = Reachable"
proof(cases "finite A")
  case True thus ?thesis by(induction) auto
qed simp

lemma dfs_blocked:
  assumes "finite A"
  and "E `` A \<subseteq> visited" "tgt \<notin> A"
  shows "Finite_Set.fold loop (Visited visited) A = Visited (A \<union> visited)"
using assms by induction(auto elim: converse_rtranclE simp add: dfs_def)

lemma dfs_visited:
  assumes "finite A"
  and "A \<subseteq> visited"
  shows "Finite_Set.fold loop (Visited visited) A = Visited visited"
using assms by induction(auto)

lemma dfs_rec:
  "dfs src tgt visited =
  (if src = tgt then Reachable
   else let succs = E `` {src} in if finite succs then Finite_Set.fold loop (Visited (insert src visited)) succs
   else Code.abort (STR ''infinite successor relation'') (\<lambda>_. dfs src tgt visited))"
proof(cases "src \<noteq> tgt \<and> finite (E `` {src})")
  case False
  thus ?thesis by(auto simp add: dfs_def)
next
  case True
  hence [simp]: "src \<noteq> tgt" "tgt \<noteq> src"
    and fin: "finite (E `` {src})" by auto

  show ?thesis
  proof(cases "(src, tgt) \<in> (E \<upharpoonleft> - visited)\<^sup>*")
    case True
    let ?g = "\<lambda>x y. (x, y) \<in> E \<upharpoonleft> - visited"
    have "Finite_Set.fold loop (Visited (insert src visited)) (E `` {src}) =
      Finite_Set.fold loop (Finite_Set.fold loop (Visited (insert src visited)) (E `` {src} - insert src visited)) (E `` {src} \<inter> insert src visited)"
      using fin by(subst f.fold_set_union_disj[symmetric])(auto intro: arg_cong2[where f="Finite_Set.fold loop"])
    also from True obtain xs where "rtrancl_path ?g src xs tgt" "distinct (src # xs)"
      by(auto simp add: rtrancl_def rtranclp_eq_rtrancl_path elim: rtrancl_path_distinct)
    hence "Finite_Set.fold loop (Visited (insert src visited)) (E `` {src} - insert src visited) = Reachable"
      using \<open>src \<noteq> tgt\<close> fin
    proof(induction src xs z\<equiv>tgt)
      case (step x y xs)
      let ?succs = "E `` {x} - visited - {y,x}"

      have "Finite_Set.fold loop (Visited (insert x visited)) (insert y ?succs) =
            Finite_Set.fold loop (loop y (Visited (insert x visited))) ?succs"
        by(rule f.fold_insert2)(simp_all add: \<open>finite (E `` {x})\<close>)
      also
      from \<open>distinct (x # y # xs)\<close> have "x \<notin> set (y # xs)" by simp
      with \<open>rtrancl_path ?g y xs tgt\<close>
      have "(y, tgt) \<in> (E \<upharpoonleft> - insert x visited)\<^sup>*"
        by induction(auto intro: converse_rtrancl_into_rtrancl)
      with \<open>(x, y) \<in> E \<upharpoonleft> - visited\<close> have "loop y (Visited (insert x visited)) = Reachable"
        using \<open>x \<notin> set (y # xs)\<close> by(auto simp add: dfs_def)
      also from \<open>(x, y) \<in> E \<upharpoonleft> - visited\<close>
      have "insert y ?succs = E `` {x} - insert x visited"
        using \<open>distinct (x # y # xs)\<close> by auto
      finally show ?case by simp
    qed simp
    finally show ?thesis using True by(simp add: dfs_def Let_def)
  next
    case False
    have "Finite_Set.fold loop (Visited (insert src visited)) (E `` {src}) =
      Finite_Set.fold loop (Finite_Set.fold loop (Visited (insert src visited)) (E `` {src} - insert src visited)) (E `` {src} \<inter> insert src visited)"
      using fin by(subst f.fold_set_union_disj[symmetric])(auto intro: arg_cong2[where f="Finite_Set.fold loop"])
    also from fin have "finite (E `` {src} - visited)" by simp
    then have "Finite_Set.fold loop (Visited (insert src visited)) (E `` {src} - insert src visited) = Visited (visited \<union> (E \<upharpoonleft> - visited)\<^sup>* `` {src})"
      using False
    proof(induct A\<equiv>"E `` {src} - visited" arbitrary: visited rule: finite_psubset_induct)
      case psubset
      note fin = \<open>finite (E `` {src})\<close>
      note src_tgt = \<open>(src, tgt) \<notin> (E \<upharpoonleft> - visited)\<^sup>*\<close>
      show ?case
      proof (cases "E `` {src} - insert src visited = {}")
        case True
        { let ?g = "\<lambda>x y. (x, y) \<in> E \<upharpoonleft> - visited"
          fix x
          assume "(src, x) \<in> (E \<upharpoonleft> - visited)\<^sup>*"
          then obtain xs where "rtrancl_path ?g src xs x" "distinct (src # xs)"
            by(auto simp add: rtrancl_def rtranclp_eq_rtrancl_path elim: rtrancl_path_distinct)
          hence "src = x" using True by induction auto }
        then show ?thesis unfolding True using True
          by(auto elim: converse_rtranclE)
      next
        case False
        then obtain y where y: "y \<in> E `` {src}" "y \<notin> visited" "y \<noteq> src" by auto
        let ?succs = "E `` {src} - insert src visited - {y}"
        let ?visited = "insert src visited"
        let ?visited' = "?visited \<union> (E \<upharpoonleft> - insert src visited)\<^sup>* `` {y}"
        have "Finite_Set.fold loop (Visited ?visited) (insert y ?succs) =
              Finite_Set.fold loop (loop y (Visited ?visited)) ?succs"
          by(rule f.fold_insert2)(simp_all add: fin)
        also have y_tgt: "(y, tgt) \<notin> (E \<upharpoonleft> - ?visited)\<^sup>*" using y src_tgt
          by(auto intro: converse_rtrancl_into_rtrancl rtrancl_mono[THEN subsetD, rotated])
        hence "loop y (Visited (insert src visited)) = Visited ?visited'"
          using y by(auto simp add: dfs_def)
        also define A where "A \<equiv> ?succs \<inter> (E \<upharpoonleft> - insert src visited)\<^sup>* `` {y}"
        have "?succs = A \<union> (E `` {src} - insert src ?visited')" unfolding A_def using y by auto
        hence "Finite_Set.fold loop (Visited ?visited') ?succs =
               Finite_Set.fold loop (Visited ?visited') \<dots>" by simp
        also have "\<dots> = Finite_Set.fold loop (Finite_Set.fold loop (Visited ?visited') A) (E `` {src} - insert src ?visited')"
          by(rule f.fold_set_union_disj)(auto simp add: A_def intro: finite_subset[OF _ fin])
        also {
          from fin have "finite A" unfolding A_def
            by(rule finite_subset[rotated]) auto
          moreover have "E `` A \<subseteq> ?visited'" using y unfolding A_def
            by(auto intro: rtrancl_into_rtrancl)
          moreover have "tgt \<notin> A" unfolding A_def using y_tgt by auto
          ultimately have "Finite_Set.fold loop (Visited ?visited') A = (Visited (A \<union> ?visited'))"
            by(rule dfs_blocked) }
        also have "A \<union> ?visited' = insert src ?visited'" unfolding A_def by auto
        also {
          have "E `` {src} - ?visited' \<subset> E `` {src} - visited" using y by fastforce
          moreover have "(src, tgt) \<notin> (E \<upharpoonleft> - ?visited')\<^sup>*" using \<open>(src, tgt) \<notin> (E \<upharpoonleft> - visited)\<^sup>*\<close>
            by(auto intro: rtrancl_mono[THEN subsetD, rotated])
          ultimately
          have "Finite_Set.fold loop (Visited (insert src ?visited')) (E `` {src} - insert src ?visited') =
                Visited (?visited' \<union> (E \<upharpoonleft> - ?visited')\<^sup>* `` {src})"
            by(rule psubset.hyps) }
        also {
          fix x
          assume src_x: "(src, x) \<in> (E \<upharpoonleft> - visited)\<^sup>*"
            and y_x: "(y, x) \<notin> (E \<upharpoonleft> - insert src visited)\<^sup>*"
          from src_x have "(src, x) \<in> (E \<upharpoonleft> - ?visited)\<^sup>*"
            by (metis rtrancl_restrict_start Compl_insert Containers_DFS_Ex.restrict_restrict Diff_Compl double_complement)
          from rtrancl_restrict_reachable[OF this y_x]
          have "(src, x) \<in> (E \<upharpoonleft> - ?visited')\<^sup>*" by simp (metis Un_insert_left compl_sup) }
        then have "?visited' \<union> (E \<upharpoonleft> - ?visited')\<^sup>* `` {src} = visited \<union> (E \<upharpoonleft> - visited)\<^sup>* `` {src}"
          using y by(auto intro: converse_rtrancl_into_rtrancl rtrancl_mono[THEN subsetD, rotated])
        also have "insert y ?succs = E `` {src} - insert src visited" using y by auto
        finally show ?thesis .
      qed
    qed
    finally
    show ?thesis using False fin
      by(simp add: dfs_def Let_def)(subst dfs_visited; auto)
  qed
qed

end

end

lift_definition dfs_body :: "'a \<Rightarrow> ('a, 'a dfs_result) comp_fun_commute"
is "\<lambda>tgt x r. case r of Reachable \<Rightarrow> Reachable | Visited \<V> \<Rightarrow> if x \<in> \<V> then Visited \<V> else dfs x tgt \<V>"
 by(rule comp_fun_commute_dfs_body)

lemma dfs_code [code]:
  "dfs src tgt visited =
  (if src = tgt then Reachable
   else let S = E `` {src} in
   if finite S then set_fold_cfc (dfs_body tgt) (Visited (insert src visited)) S
   else Code.abort (STR ''infinite successor relation'') (\<lambda>_. dfs src tgt visited))"
by transfer(subst dfs_rec, simp add: Let_def)

lemma reachable_dfs [code]:
  "reachable src tgt = is_Reachable (dfs src tgt {})"
by(simp add: dfs_def reachable_def)

end

subsection \<open>Refinement to executable code\<close>

typedef 'a graph = "UNIV :: ('a \<times> 'a) set set" morphisms edges Graph ..
setup_lifting type_definition_graph

text \<open>Implement graphs with successor function\<close>

definition graph_of_succs :: "('a \<Rightarrow> 'a set) \<Rightarrow> ('a \<times> 'a) set"
where "graph_of_succs succs = {(v, w). w \<in> succs v}"
declare graph_of_succs_def[containers_post, symmetric, containers_pre]

lift_definition Succ :: "('a \<Rightarrow> 'a set) \<Rightarrow> 'a graph" is "graph_of_succs" .
code_datatype Succ

text \<open>Identify operations on graph\<close>

definition successors :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a set" where "successors E x = E `` {x}"
declare successors_def[containers_post, symmetric, containers_pre]

lift_definition succs :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a set" is successors .
lemma succs_code [code]: "succs (Succ s) = s" by transfer(simp add: successors_def fun_eq_iff graph_of_succs_def)

text \<open>Transfer algorithms to abstract graph type\<close>

lift_definition reachable_impl :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" is reachable .
lift_definition dfs_impl :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> 'a dfs_result" is dfs .
lift_definition dfs_body_impl :: "'a graph \<Rightarrow> 'a \<Rightarrow> ('a, 'a dfs_result) comp_fun_commute" is dfs_body .

lemmas [containers_identify, code] = reachable_dfs dfs_code dfs_body.rep_eq

subsection \<open>Tests\<close>

definition test_graph :: "nat graph"
where "test_graph = Succ ((\<lambda>_. {})(0 := {1,3}, 1 := {2,4}, 2 := {1}, 3 := {1, 5}, 4 := {5}))"

definition test_dfs where "test_dfs = map (reachable_impl test_graph 0) [0..<7]"

ML_val \<open>
  val [true, true, true, true, true, true, false] = @{code test_dfs};
\<close>

end


theory PosixSpec
  imports RegLangs
begin

section \<open>"Plain" Values\<close>

datatype val =
  Void
| Char char
| Seq val val
| Right val
| Left val
| Stars "val list"

section \<open>The string behind a value\<close>

fun
  flat :: "val \<Rightarrow> string"
where
  "flat (Void) = []"
| "flat (Char c) = [c]"
| "flat (Left v) = flat v"
| "flat (Right v) = flat v"
| "flat (Seq v1 v2) = (flat v1) @ (flat v2)"
| "flat (Stars []) = []"
| "flat (Stars (v#vs)) = (flat v) @ (flat (Stars vs))"

abbreviation
  "flats vs \<equiv> concat (map flat vs)"

lemma flat_Stars [simp]:
 "flat (Stars vs) = flats vs"
by (induct vs) (auto)

section \<open>Lexical Values\<close>

inductive
  Prf :: "val \<Rightarrow> rexp \<Rightarrow> bool" ("\<Turnstile> _ : _" [100, 100] 100)
where
 "\<lbrakk>\<Turnstile> v1 : r1; \<Turnstile> v2 : r2\<rbrakk> \<Longrightarrow> \<Turnstile>  Seq v1 v2 : SEQ r1 r2"
| "\<Turnstile> v1 : r1 \<Longrightarrow> \<Turnstile> Left v1 : ALT r1 r2"
| "\<Turnstile> v2 : r2 \<Longrightarrow> \<Turnstile> Right v2 : ALT r1 r2"
| "\<Turnstile> Void : ONE"
| "\<Turnstile> Char c : CH c"
| "\<forall>v \<in> set vs. \<Turnstile> v : r \<and> flat v \<noteq> [] \<Longrightarrow> \<Turnstile> Stars vs : STAR r"
| "\<lbrakk>\<forall>v \<in> set vs1. \<Turnstile> v : r \<and> flat v \<noteq> [];
    \<forall>v \<in> set vs2. \<Turnstile> v : r \<and> flat v = [];
    length (vs1 @ vs2) = n\<rbrakk> \<Longrightarrow> \<Turnstile> Stars (vs1 @ vs2) : NTIMES r n"

inductive_cases Prf_elims:
  "\<Turnstile> v : ZERO"
  "\<Turnstile> v : SEQ r1 r2"
  "\<Turnstile> v : ALT r1 r2"
  "\<Turnstile> v : ONE"
  "\<Turnstile> v : CH c"
  "\<Turnstile> vs : STAR r"
  "\<Turnstile> vs : NTIMES r n"

lemma Prf_Stars_appendE:
  assumes "\<Turnstile> Stars (vs1 @ vs2) : STAR r"
  shows "\<Turnstile> Stars vs1 : STAR r \<and> \<Turnstile> Stars vs2 : STAR r"
using assms
by (auto intro: Prf.intros elim!: Prf_elims)

lemma Pow_cstring:
  fixes A::"string set"
  assumes "s \<in> A ^^ n"
  shows "\<exists>ss1 ss2. concat (ss1 @ ss2) = s \<and> length (ss1 @ ss2) = n \<and>
         (\<forall>s \<in> set ss1. s \<in> A \<and> s \<noteq> []) \<and> (\<forall>s \<in> set ss2. s \<in> A \<and> s = [])"
using assms
apply(induct n arbitrary: s)
  apply(auto)[1]
  apply(auto simp add: Sequ_def)
  apply(drule_tac x="s2" in meta_spec)
  apply(simp)
apply(erule exE)+
  apply(clarify)
apply(case_tac "s1 = []")
apply(simp)
apply(rule_tac x="ss1" in exI)
apply(rule_tac x="s1 # ss2" in exI)
apply(simp)
apply(rule_tac x="s1 # ss1" in exI)
apply(rule_tac x="ss2" in exI)
  apply(simp)
  done

lemma flats_Prf_value:
  assumes "\<forall>s\<in>set ss. \<exists>v. s = flat v \<and> \<Turnstile> v : r"
  shows "\<exists>vs. flats vs = concat ss \<and> (\<forall>v\<in>set vs. \<Turnstile> v : r \<and> flat v \<noteq> [])"
using assms
apply(induct ss)
apply(auto)
apply(rule_tac x="[]" in exI)
apply(simp)
apply(case_tac "flat v = []")
apply(rule_tac x="vs" in exI)
apply(simp)
apply(rule_tac x="v#vs" in exI)
apply(simp)
  done

lemma Aux:
  assumes "\<forall>s\<in>set ss. s = []"
  shows "concat ss = []"
using assms
by (induct ss) (auto)

lemma flats_cval:
  assumes "\<forall>s\<in>set ss. \<exists>v. s = flat v \<and> \<Turnstile> v : r"
  shows "\<exists>vs1 vs2. flats (vs1 @ vs2) = concat ss \<and> length (vs1 @ vs2) = length ss \<and>
          (\<forall>v\<in>set vs1. \<Turnstile> v : r \<and> flat v \<noteq> []) \<and>
          (\<forall>v\<in>set vs2. \<Turnstile> v : r \<and> flat v = [])"
using assms
apply(induct ss rule: rev_induct)
apply(rule_tac x="[]" in exI)+
apply(simp)
apply(simp)
apply(clarify)
apply(case_tac "flat v = []")
apply(rule_tac x="vs1" in exI)
apply(rule_tac x="v#vs2" in exI)
apply(simp)
apply(rule_tac x="vs1 @ [v]" in exI)
apply(rule_tac x="vs2" in exI)
apply(simp)
by (simp add: Aux)

lemma pow_Prf:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> flat v \<in> A"
  shows "flats vs \<in> A ^^ (length vs)"
  using assms
  by (induct vs) (auto)

lemma L_flat_Prf1:
  assumes "\<Turnstile> v : r"
  shows "flat v \<in> L r"
  using assms
  apply (induct v r rule: Prf.induct)
  apply(auto simp add: Sequ_def Star_concat lang_pow_add)
  by (metis pow_Prf)

lemma L_flat_Prf2:
  assumes "s \<in> L r"
  shows "\<exists>v. \<Turnstile> v : r \<and> flat v = s"
using assms
proof(induct r arbitrary: s)
  case (STAR r s)
  have IH: "\<And>s. s \<in> L r \<Longrightarrow> \<exists>v. \<Turnstile> v : r \<and> flat v = s" by fact
  have "s \<in> L (STAR r)" by fact
  then obtain ss where "concat ss = s" "\<forall>s \<in> set ss. s \<in> L r \<and> s \<noteq> []"
  using Star_split by auto
  then obtain vs where "flats vs = s" "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> flat v \<noteq> []"
  using IH flats_Prf_value by metis
  then show "\<exists>v. \<Turnstile> v : STAR r \<and> flat v = s"
  using Prf.intros(6) flat_Stars by blast
next
  case (SEQ r1 r2 s)
  then show "\<exists>v. \<Turnstile> v : SEQ r1 r2 \<and> flat v = s"
  unfolding Sequ_def L.simps by (fastforce intro: Prf.intros)
next
  case (ALT r1 r2 s)
  then show "\<exists>v. \<Turnstile> v : ALT r1 r2 \<and> flat v = s"
    unfolding L.simps by (fastforce intro: Prf.intros)
next
  case (NTIMES r n)
  have IH: "\<And>s. s \<in> L r \<Longrightarrow> \<exists>v. \<Turnstile> v : r \<and> flat v = s" by fact
  have "s \<in> L (NTIMES r n)" by fact
  then obtain ss1 ss2 where "concat (ss1 @ ss2) = s" "length (ss1 @ ss2) = n"
    "\<forall>s \<in> set ss1. s \<in> L r \<and> s \<noteq> []" "\<forall>s \<in> set ss2. s \<in> L r \<and> s = []"
  using Pow_cstring by force
  then obtain vs1 vs2 where "flats (vs1 @ vs2) = s" "length (vs1 @ vs2) = n"
      "\<forall>v\<in>set vs1. \<Turnstile> v : r \<and> flat v \<noteq> []" "\<forall>v\<in>set vs2. \<Turnstile> v : r \<and> flat v = []"
    using IH flats_cval
  apply -
  apply(drule_tac x="ss1 @ ss2" in meta_spec)
  apply(drule_tac x="r" in meta_spec)
  apply(drule meta_mp)
  apply(simp)
  apply (metis Un_iff)
  apply(clarify)
  apply(drule_tac x="vs1" in meta_spec)
  apply(drule_tac x="vs2" in meta_spec)
  apply(simp)
  done
  then show "\<exists>v. \<Turnstile> v : NTIMES r n \<and> flat v = s"
  using Prf.intros(7) flat_Stars by blast
qed (auto intro: Prf.intros)

lemma L_flat_Prf:
  shows "L(r) = {flat v | v. \<Turnstile> v : r}"
using L_flat_Prf1 L_flat_Prf2 by blast

section \<open>Sets of Lexical Values\<close>

text \<open>
  Shows that lexical values are finite for a given regex and string.
\<close>

definition
  LV :: "rexp \<Rightarrow> string \<Rightarrow> val set"
where  "LV r s \<equiv> {v. \<Turnstile> v : r \<and> flat v = s}"

lemma LV_simps:
  shows "LV ZERO s = {}"
  and   "LV ONE s = (if s = [] then {Void} else {})"
  and   "LV (CH c) s = (if s = [c] then {Char c} else {})"
  and   "LV (ALT r1 r2) s = Left ` LV r1 s \<union> Right ` LV r2 s"
  and   "LV (NTIMES r 0) s = (if s = [] then {Stars []} else {})"
unfolding LV_def
  apply (auto intro: Prf.intros elim: Prf.cases)
  by (metis Prf.intros(7) append.right_neutral empty_iff list.set(1) list.size(3))

abbreviation
  "Prefixes s \<equiv> {s'. prefix s' s}"

abbreviation
  "Suffixes s \<equiv> {s'. suffix s' s}"

abbreviation
  "SSuffixes s \<equiv> {s'. strict_suffix s' s}"

lemma Suffixes_cons [simp]:
  shows "Suffixes (c # s) = Suffixes s \<union> {c # s}"
by (auto simp add: suffix_def Cons_eq_append_conv)

lemma finite_Suffixes:
  shows "finite (Suffixes s)"
by (induct s) (simp_all)

lemma finite_SSuffixes:
  shows "finite (SSuffixes s)"
proof -
  have "SSuffixes s \<subseteq> Suffixes s"
   unfolding strict_suffix_def suffix_def by auto
  then show "finite (SSuffixes s)"
   using finite_Suffixes finite_subset by blast
qed

lemma finite_Prefixes:
  shows "finite (Prefixes s)"
proof -
  have "finite (Suffixes (rev s))"
    by (rule finite_Suffixes)
  then have "finite (rev ` Suffixes (rev s))" by simp
  moreover
  have "rev ` (Suffixes (rev s)) = Prefixes s"
  unfolding suffix_def prefix_def image_def
   by (auto)(metis rev_append rev_rev_ident)+
  ultimately show "finite (Prefixes s)" by simp
qed

definition
  "Stars_Append Vs1 Vs2 \<equiv> {Stars (vs1 @ vs2) | vs1 vs2. Stars vs1 \<in> Vs1 \<and> Stars vs2 \<in> Vs2}"

lemma finite_Stars_Append:
  assumes "finite Vs1" "finite Vs2"
  shows "finite (Stars_Append Vs1 Vs2)"
  using assms
proof -
  define UVs1 where "UVs1 \<equiv> Stars -` Vs1"
  define UVs2 where "UVs2 \<equiv> Stars -` Vs2"
  from assms have "finite UVs1" "finite UVs2"
    unfolding UVs1_def UVs2_def
    by(simp_all add: finite_vimageI inj_on_def)
  then have "finite ((\<lambda>(vs1, vs2). Stars (vs1 @ vs2)) ` (UVs1 \<times> UVs2))"
    by simp
  moreover
    have "Stars_Append Vs1 Vs2 = (\<lambda>(vs1, vs2). Stars (vs1 @ vs2)) ` (UVs1 \<times> UVs2)"
    unfolding Stars_Append_def UVs1_def UVs2_def by auto
  ultimately show "finite (Stars_Append Vs1 Vs2)"
    by simp
qed

lemma LV_NTIMES_subset:
  "LV (NTIMES r n) s \<subseteq> Stars_Append (LV (STAR r) s) (\<Union>i\<le>n. LV (NTIMES r i) [])"
apply(auto simp add: LV_def)
apply(auto elim!: Prf_elims)
  apply(auto simp add: Stars_Append_def)
  apply(rule_tac x="vs1" in exI)
  apply(rule_tac x="vs2" in exI)
  apply(auto)
    using Prf.intros(6) apply(auto)
      apply(rule_tac x="length vs2" in bexI)
    thm Prf.intros
      apply(subst append.simps(1)[symmetric])
    apply(rule Prf.intros)
      apply(auto)[1]
      apply(auto)[1]
     apply(simp)
    apply(simp)
    done

lemma LV_NTIMES_Suc_empty:
  shows "LV (NTIMES r (Suc n)) [] =
     (\<lambda>(v, vs). Stars (v#vs)) ` (LV r [] \<times> (Stars -` (LV (NTIMES r n) [])))"
unfolding LV_def
apply(auto elim!: Prf_elims simp add: image_def)
apply(case_tac vs1)
apply(auto)
apply(case_tac vs2)
apply(auto)
apply(subst append.simps(1)[symmetric])
apply(rule Prf.intros)
apply(auto)
apply(subst append.simps(1)[symmetric])
apply(rule Prf.intros)
apply(auto)
  done

lemma LV_STAR_finite:
  assumes "\<forall>s. finite (LV r s)"
  shows "finite (LV (STAR r) s)"
proof(induct s rule: length_induct)
  fix s::"char list"
  assume "\<forall>s'. length s' < length s \<longrightarrow> finite (LV (STAR r) s')"
  then have IH: "\<forall>s' \<in> SSuffixes s. finite (LV (STAR r) s')"
    by (force simp add: strict_suffix_def suffix_def)
  define f where "f \<equiv> \<lambda>(v, vs). Stars (v # vs)"
  define S1 where "S1 \<equiv> \<Union>s' \<in> Prefixes s. LV r s'"
  define S2 where "S2 \<equiv> \<Union>s2 \<in> SSuffixes s. Stars -` (LV (STAR r) s2)"
  have "finite S1" using assms
    unfolding S1_def by (simp_all add: finite_Prefixes)
  moreover
  with IH have "finite S2" unfolding S2_def
    by (auto simp add: finite_SSuffixes inj_on_def finite_vimageI)
  ultimately
  have "finite ({Stars []} \<union> f ` (S1 \<times> S2))" by simp
  moreover
  have "LV (STAR r) s \<subseteq> {Stars []} \<union> f ` (S1 \<times> S2)"
  unfolding S1_def S2_def f_def
  unfolding LV_def image_def prefix_def strict_suffix_def
  apply(auto)
  apply(case_tac x)
  apply(auto elim: Prf_elims)
  apply(erule Prf_elims)
  apply(auto)
  apply(case_tac vs)
  apply(auto intro: Prf.intros)
  apply(rule exI)
  apply(rule conjI)
  apply(rule_tac x="flat a" in exI)
  apply(rule conjI)
  apply(rule_tac x="flats list" in exI)
  apply(simp)
   apply(blast)
  apply(simp add: suffix_def)
  using Prf.intros(6) by blast
  ultimately
  show "finite (LV (STAR r) s)" by (simp add: finite_subset)
qed

lemma finite_NTimes_empty:
  assumes "\<And>s. finite (LV r s)"
  shows "finite (LV (NTIMES r n) [])"
  using assms
  apply(induct n)
   apply(auto simp add: LV_simps)
  apply(subst LV_NTIMES_Suc_empty)
  apply(rule finite_imageI)
  apply(rule finite_cartesian_product)
  using assms apply simp
  apply(rule finite_vimageI)
  apply(simp)
  apply(simp add: inj_on_def)
  done

lemma LV_finite:
  shows "finite (LV r s)"
proof(induct r arbitrary: s)
  case (ZERO s)
  show "finite (LV ZERO s)" by (simp add: LV_simps)
next
  case (ONE s)
  show "finite (LV ONE s)" by (simp add: LV_simps)
next
  case (CH c s)
  show "finite (LV (CH c) s)" by (simp add: LV_simps)
next
  case (ALT r1 r2 s)
  then show "finite (LV (ALT r1 r2) s)" by (simp add: LV_simps)
next
  case (SEQ r1 r2 s)
  define f where "f \<equiv> \<lambda>(v1, v2). Seq v1 v2"
  define S1 where "S1 \<equiv> \<Union>s' \<in> Prefixes s. LV r1 s'"
  define S2 where "S2 \<equiv> \<Union>s' \<in> Suffixes s. LV r2 s'"
  have IHs: "\<And>s. finite (LV r1 s)" "\<And>s. finite (LV r2 s)" by fact+
  then have "finite S1" "finite S2" unfolding S1_def S2_def
    by (simp_all add: finite_Prefixes finite_Suffixes)
  moreover
  have "LV (SEQ r1 r2) s \<subseteq> f ` (S1 \<times> S2)"
    unfolding f_def S1_def S2_def
    unfolding LV_def image_def prefix_def suffix_def
    apply (auto elim!: Prf_elims)
    by (metis (mono_tags, lifting) mem_Collect_eq)
  ultimately
  show "finite (LV (SEQ r1 r2) s)"
    by (simp add: finite_subset)
next
  case (STAR r s)
  then show "finite (LV (STAR r) s)" by (simp add: LV_STAR_finite)
next
  case (NTIMES r n s)
  have "\<And>s. finite (LV r s)" by fact
  then have "finite (Stars_Append (LV (STAR r) s) (\<Union>i\<le>n. LV (NTIMES r i) []))"
    apply(rule_tac finite_Stars_Append)
     apply (simp add: LV_STAR_finite)
    using finite_NTimes_empty by blast
  then show "finite (LV (NTIMES r n) s)"
    by (metis LV_NTIMES_subset finite_subset)
qed

section \<open>Our inductive POSIX Definition\<close>

inductive
  Posix :: "string \<Rightarrow> rexp \<Rightarrow> val \<Rightarrow> bool" ("_ \<in> _ \<rightarrow> _" [100, 100, 100] 100)
where
  Posix_ONE: "[] \<in> ONE \<rightarrow> Void"
| Posix_CH: "[c] \<in> (CH c) \<rightarrow> (Char c)"
| Posix_ALT1: "s \<in> r1 \<rightarrow> v \<Longrightarrow> s \<in> (ALT r1 r2) \<rightarrow> (Left v)"
| Posix_ALT2: "\<lbrakk>s \<in> r2 \<rightarrow> v; s \<notin> L(r1)\<rbrakk> \<Longrightarrow> s \<in> (ALT r1 r2) \<rightarrow> (Right v)"
| Posix_SEQ: "\<lbrakk>s1 \<in> r1 \<rightarrow> v1; s2 \<in> r2 \<rightarrow> v2;
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> L r1 \<and> s\<^sub>4 \<in> L r2)\<rbrakk> \<Longrightarrow>
    (s1 @ s2) \<in> (SEQ r1 r2) \<rightarrow> (Seq v1 v2)"
| Posix_STAR1: "\<lbrakk>s1 \<in> r \<rightarrow> v; s2 \<in> STAR r \<rightarrow> Stars vs; flat v \<noteq> [];
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> L r \<and> s\<^sub>4 \<in> L (STAR r))\<rbrakk>
    \<Longrightarrow> (s1 @ s2) \<in> STAR r \<rightarrow> Stars (v # vs)"
| Posix_STAR2: "[] \<in> STAR r \<rightarrow> Stars []"
| Posix_NTIMES1: "\<lbrakk>s1 \<in> r \<rightarrow> v; s2 \<in> NTIMES r (n - 1) \<rightarrow> Stars vs; flat v \<noteq> []; 0 < n;
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> L r \<and> s\<^sub>4 \<in> L (NTIMES r (n - 1)))\<rbrakk>
    \<Longrightarrow> (s1 @ s2) \<in> NTIMES r n \<rightarrow> Stars (v # vs)"
| Posix_NTIMES2: "\<lbrakk>\<forall>v \<in> set vs. [] \<in> r \<rightarrow> v; length vs = n\<rbrakk>
    \<Longrightarrow> [] \<in> NTIMES r n \<rightarrow> Stars vs"

inductive_cases Posix_elims:
  "s \<in> ZERO \<rightarrow> v"
  "s \<in> ONE \<rightarrow> v"
  "s \<in> CH c \<rightarrow> v"
  "s \<in> ALT r1 r2 \<rightarrow> v"
  "s \<in> SEQ r1 r2 \<rightarrow> v"
  "s \<in> STAR r \<rightarrow> v"
  "s \<in> NTIMES r n \<rightarrow> v"

lemma Posix1:
  assumes "s \<in> r \<rightarrow> v"
  shows "s \<in> L r" "flat v = s"
using assms
  apply(induct s r v rule: Posix.induct)
  apply(auto simp add: pow_empty_iff)
  apply (metis Suc_pred concI lang_pow.simps(2))
  by (meson ex_in_conv set_empty)

lemma Posix1a:
  assumes "s \<in> r \<rightarrow> v"
  shows "\<Turnstile> v : r"
using assms
  apply(induct s r v rule: Posix.induct)
  apply(auto intro: Prf.intros)
  apply (metis Prf.intros(6) Prf_elims(6) set_ConsD val.inject(5))
  prefer 2
  apply (metis Posix1(2) Prf.intros(7) append_Nil empty_iff list.set(1))
  apply(erule Prf_elims)
  apply(auto)
  apply(subst append.simps(2)[symmetric])
  apply(rule Prf.intros)
  apply(auto)
  done

text \<open>
  For a give value and string, our Posix definition
  determines a unique value.
\<close>

lemma List_eq_zipI:
  assumes "list_all2 (\<lambda>v1 v2. v1 = v2) vs1 vs2"
  and "length vs1 = length vs2"
  shows "vs1 = vs2"
 using assms
  apply(induct vs1 vs2 rule: list_all2_induct)
  apply(auto)
  done

lemma Posix_determ:
  assumes "s \<in> r \<rightarrow> v1" "s \<in> r \<rightarrow> v2"
  shows "v1 = v2"
using assms
proof (induct s r v1 arbitrary: v2 rule: Posix.induct)
  case (Posix_ONE v2)
  have "[] \<in> ONE \<rightarrow> v2" by fact
  then show "Void = v2" by cases auto
next
  case (Posix_CH c v2)
  have "[c] \<in> CH c \<rightarrow> v2" by fact
  then show "Char c = v2" by cases auto
next
  case (Posix_ALT1 s r1 v r2 v2)
  have "s \<in> ALT r1 r2 \<rightarrow> v2" by fact
  moreover
  have "s \<in> r1 \<rightarrow> v" by fact
  then have "s \<in> L r1" by (simp add: Posix1)
  ultimately obtain v' where eq: "v2 = Left v'" "s \<in> r1 \<rightarrow> v'" by cases auto
  moreover
  have IH: "\<And>v2. s \<in> r1 \<rightarrow> v2 \<Longrightarrow> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Left v = v2" using eq by simp
next
  case (Posix_ALT2 s r2 v r1 v2)
  have "s \<in> ALT r1 r2 \<rightarrow> v2" by fact
  moreover
  have "s \<notin> L r1" by fact
  ultimately obtain v' where eq: "v2 = Right v'" "s \<in> r2 \<rightarrow> v'"
    by cases (auto simp add: Posix1)
  moreover
  have IH: "\<And>v2. s \<in> r2 \<rightarrow> v2 \<Longrightarrow> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Right v = v2" using eq by simp
next
  case (Posix_SEQ s1 r1 v1 s2 r2 v2 v')
  have "(s1 @ s2) \<in> SEQ r1 r2 \<rightarrow> v'"
       "s1 \<in> r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)" by fact+
  then obtain v1' v2' where "v' = Seq v1' v2'" "s1 \<in> r1 \<rightarrow> v1'" "s2 \<in> r2 \<rightarrow> v2'"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) by fastforce+
  moreover
  have IHs: "\<And>v1'. s1 \<in> r1 \<rightarrow> v1' \<Longrightarrow> v1 = v1'"
            "\<And>v2'. s2 \<in> r2 \<rightarrow> v2' \<Longrightarrow> v2 = v2'" by fact+
  ultimately show "Seq v1 v2 = v'" by simp
next
  case (Posix_STAR1 s1 r v s2 vs v2)
  have "(s1 @ s2) \<in> STAR r \<rightarrow> v2"
       "s1 \<in> r \<rightarrow> v" "s2 \<in> STAR r \<rightarrow> Stars vs" "flat v \<noteq> []"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (STAR r))" by fact+
  then obtain v' vs' where "v2 = Stars (v' # vs')" "s1 \<in> r \<rightarrow> v'" "s2 \<in> (STAR r) \<rightarrow> (Stars vs')"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) apply fastforce
  apply (metis Posix1(1) Posix_STAR1.hyps(6) append_Nil append_Nil2)
  using Posix1(2) by blast
  moreover
  have IHs: "\<And>v2. s1 \<in> r \<rightarrow> v2 \<Longrightarrow> v = v2"
            "\<And>v2. s2 \<in> STAR r \<rightarrow> v2 \<Longrightarrow> Stars vs = v2" by fact+
  ultimately show "Stars (v # vs) = v2" by auto
next
  case (Posix_STAR2 r v2)
  have "[] \<in> STAR r \<rightarrow> v2" by fact
  then show "Stars [] = v2" by cases (auto simp add: Posix1)
next
  case (Posix_NTIMES2 vs r n v2)
  then show "Stars vs = v2"
    apply(erule_tac Posix_elims)
    apply(auto)
    apply (simp add: Posix1(2))
    apply(rule List_eq_zipI)
     apply(auto simp add: list_all2_iff)
    by (meson in_set_zipE)
next
  case (Posix_NTIMES1 s1 r v s2 n vs)
  have "(s1 @ s2) \<in> NTIMES r n \<rightarrow> v2"
       "s1 \<in> r \<rightarrow> v" "s2 \<in> NTIMES r (n - 1) \<rightarrow> Stars vs" "flat v \<noteq> []"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (NTIMES r (n - 1 )))" by fact+
  then obtain v' vs' where "v2 = Stars (v' # vs')" "s1 \<in> r \<rightarrow> v'" "s2 \<in> (NTIMES r (n - 1)) \<rightarrow> (Stars vs')"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
    using Posix1(1) apply fastforce
    apply (metis One_nat_def Posix1(1) Posix_NTIMES1.hyps(7) append.right_neutral append_self_conv2)
  using Posix1(2) by blast
  moreover
  have IHs: "\<And>v2. s1 \<in> r \<rightarrow> v2 \<Longrightarrow> v = v2"
            "\<And>v2. s2 \<in> NTIMES r (n - 1) \<rightarrow> v2 \<Longrightarrow> Stars vs = v2" by fact+
  ultimately show "Stars (v # vs) = v2" by auto
qed

text \<open>
  Our POSIX values are lexical values.
\<close>

lemma Posix_LV:
  assumes "s \<in> r \<rightarrow> v"
  shows "v \<in> LV r s"
  using assms unfolding LV_def
  apply(induct rule: Posix.induct)
   apply(auto simp add: intro!: Prf.intros elim!: Prf_elims Posix1a)
   apply (smt (verit, best) One_nat_def Posix1a Posix_NTIMES1 L.simps(7))
  using Posix1a Posix_NTIMES2 by blast

end


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

theory
  Z_Exp

imports
  Z_Rel_Chap

begin

section {* Preliminaries *}

text {*

In this section we introduce a number of rules quoted by Spivey~\cite{Spivey:ZRef}
about the basic term constructors of the Z language.

Rules about equality~\cite[p. 68]{Spivey:ZRef}.

*}

lemma Z_sym:
  "x = y \<Rightarrow> y = x"
  by (auto)

lemma Z_trans:
  "x = y \<and> y = z \<Rightarrow> x = z"
  by (auto)

lemma Z_set_eq_def:
  "S = T \<Leftrightarrow> (\<forall> x \<bullet> x \<in> S \<Leftrightarrow> x \<in> T)"
  by (auto)

lemma Z_member_congruence:
  "x = y \<Leftrightarrow> (\<forall> S \<bullet> x \<in> S \<Leftrightarrow> y \<in> S)"
  apply (msafe(inference))
(* J: note improves!
  apply (msafe_no_assms(inference))
  apply (simp_all)
*)
proof -
  assume b1 [rule_format]:
    "(\<forall> S \<bullet> x \<in> S \<Leftrightarrow> y \<in> S)"
  from b1 [of "{x}"] show
    "x = y"
    by (auto)
qed

text {*

The negations of equality and set
membership~\cite[p 89]{Spivey:ZRef}\cite[p 95]{ZStand02}
are already defined as syntactic operators in HOL.
We simply make use of these existing, type-generic operators.

*}

lemma Z_neq_def:
  "x \<noteq> y \<defs> \<not>\<^zid>{:(x = y):}"
  by (auto)

lemma Z_nin_def:
  "x \<notin> S \<defs> \<not>\<^zid>{:(x \<in> S):}"
  by (auto)

lemma Z_neq_commute:
  "x \<noteq> y \<Rightarrow> y \<noteq> x"
  by (auto)

text {*

Rules about the boolean constants.

*}

lemma Z_FalseE:
  "\<False> \<Rightarrow> P"
  by (auto)

lemma Z_TrueI:
  "P \<Rightarrow> \<True>"
  by (auto)

lemma Z_bool_cases:
  "(P = \<True> \<Rightarrow> R) \<and> (P = \<False> \<Rightarrow> R) \<Rightarrow> R"
  by (auto)

text {*

Rules about the boolean connectives~\cite[p. 69]{Spivey:ZRef}.

*}

lemma Z_notI: "(P \<Rightarrow> \<False>) \<Rightarrow> \<not> P"
  by (auto)

lemma Z_conjI: "P \<Rightarrow> (Q \<Rightarrow> P \<and> Q)"
  by (auto)

lemma Z_disjI: "(P \<Rightarrow> P \<or> Q) \<and> (Q \<Rightarrow> P \<or> Q)"
  by (auto)

lemma Z_iffI: "(P \<Rightarrow> Q) \<and> (Q \<Rightarrow> P) \<Rightarrow> (P \<Leftrightarrow> Q)"
  by (msafe(inference))

lemma Z_ex1_def:
  "(\<exists>\<subone> x \<bullet> P x) \<Leftrightarrow> (\<exists> x \<bullet> P x \<and> (\<forall> y \<bullet> P y \<Rightarrow> y = x))"
  by (auto)

text {*

Rules about sets and products.

*}

lemma Z_prod_def:
  "X \<times> Y = { x y | x \<in> X \<and> y \<in> Y \<bullet> (x, y) }"
  by (auto)

lemma Z_coll_mem:
  "y \<in> { x | Q x \<bullet> t x } \<Leftrightarrow> (\<exists> x | Q x \<bullet> y = t x)"
  by (auto)

lemma Z_collect_the_equality:
  "P a \<Rightarrow> (\<forall> x \<bullet> P x \<Rightarrow> x = a) \<Rightarrow> (\<mu> x | P x) = a"
  apply (msafe(inference))
  apply (rule the_equality)
  apply (fast+)
  done

text {*

Rules about alternation.

*}

lemma Z_true_if:
  "P \<Rightarrow> \<if> P \<then> E_d_1 \<else> E_d_2 \<fi> = E_d_1"
  by (auto)

lemma Z_false_if:
  "\<not> P \<Rightarrow> \<if> P \<then> E_d_1 \<else> E_d_2 \<fi> = E_d_2"
  by (auto)

lemma Z_idem_if:
  "\<if> P \<then> E \<else> E \<fi> = E"
  by (auto)

text {*

The first and second operators~\cite[p 93]{Spivey:ZRef}\cite[p 98]{ZStand02}
are defined in HOL. These are not strictly
compatible with those defined in the Z Standard, since the Z operators
act on bindings rather than tuples, which are subsumed by the binding
structure in Z. Nevertheless we find it convenient to make use of the HOL
operators. As noted elsewhere,
bindings are a difficult structure to model in HOL.

*}

lemma Z_fst_snd_def:
  "\<forall> x y \<bullet>
    \<fst> (x, y) = x \<and>
    \<snd> (x, y) = y"
  by (auto)

lemma Z_fst_def:
  "\<fst> (x, y) \<defs> x"
  by (simp add: fst_conv)

lemma Z_snd_def:
  "\<snd> (x, y) \<defs> y"
  by (simp add: snd_conv)

lemma Z_tuple_cong:
  "(\<fst> p, \<snd> p) = p"
  by (auto)

end