(*  Title:       Constructing Nondeterministic Finite Automata
    Authors:     Thomas Tuerk <tuerk@in.tum.de>
*)

section \<open> Constructing Nondeterministic Finite Automata \<close>

theory NFAConstruct
imports Main LTS SemiAutomaton NFA
begin

text \<open> In the following automata are constructed by
sequentially adding states together to an initially empty automaton.
An \emph{empty} automaton contains an alphabet of labels and a set of initial states.
Adding states updates the set of states, the transition relation and the set of
accepting states.

This construction is used to add only the reachable states to an automaton.
\<close>

definition NFA_initial_automaton :: "'q set \<Rightarrow> 'a set \<Rightarrow> ('q, 'a) NFA_rec" where
  "NFA_initial_automaton I A \<equiv> \<lparr> \<Q>={}, \<Sigma>=A, \<Delta> = {}, \=I, \<F> = {} \<rparr>"

definition NFA_insert_state :: "('q \<Rightarrow> bool) \<Rightarrow> ('q, 'a) LTS \<Rightarrow> 'q \<Rightarrow> ('q, 'a) NFA_rec \<Rightarrow> ('q, 'a) NFA_rec" where
"NFA_insert_state FP D q \ \<equiv>
\<lparr> \<Q>=insert q (\<Q> \), \<Sigma>=\<Sigma> \, \<Delta> = \<Delta> \ \<union> {qsq . qsq \<in> D \<and> fst qsq = q},
  \=\ \, \<F> = if (FP q) then insert q (\<F> \) else (\<F> \)\<rparr>"

definition NFA_construct_reachable where
"NFA_construct_reachable I A FP D =
 Finite_Set.fold (NFA_insert_state FP D) (NFA_initial_automaton I A)
 (accessible (LTS_forget_labels D) I)"

lemma NFA_insert_state___comp_fun_commute :
  "comp_fun_commute_on UNIV (NFA_insert_state FP D)"
apply (simp add: NFA_insert_state_def comp_fun_commute_on_def o_def)
apply (subst fun_eq_iff)
apply simp
apply (metis Un_commute Un_left_commute insert_commute)
done

lemma fold_NFA_insert_state :
"finite Q \<Longrightarrow> Finite_Set.fold (NFA_insert_state FP D) \ Q =
\<lparr> \<Q>=Q \<union> (\<Q> \), \<Sigma>=\<Sigma> \, \<Delta> = \<Delta> \ \<union> {qsq. qsq \<in> D \<and> fst qsq \<in> Q},
  \=\ \, \<F> = (\<F> \) \<union> {q. q \<in> Q \<and> FP q} \<rparr>"
apply (induct rule: finite_induct)
apply (simp)
apply (simp add: comp_fun_commute_on.fold_insert [OF NFA_insert_state___comp_fun_commute])
apply (auto simp add: NFA_insert_state_def)
done

lemma NFA_construct_reachable_simp :
 "finite (accessible (LTS_forget_labels D) I) \<Longrightarrow>
  NFA_construct_reachable I A FP D =
  \<lparr>\<Q> = accessible (LTS_forget_labels D) I, \<Sigma> = A, \<Delta> = {qsq. qsq \<in> D \<and>
      fst qsq \<in> accessible (LTS_forget_labels D) I}, \ = I,
   \<F> = {q \<in> accessible (LTS_forget_labels D) I. FP q}\<rparr>"
by (simp add: NFA_construct_reachable_def
              fold_NFA_insert_state NFA_initial_automaton_def)

text \<open> Now show that this can be used to remove unreachable states \<close>
lemma (in NFA) NFA_remove_unreachable_states_implementation :
assumes I_OK: "I = \ \"
    and A_OK: "A = \<Sigma> \"
    and FP_OK: "\<And>q. q \<in> \<Q> \ \<Longrightarrow> FP q \<longleftrightarrow> q \<in> \<F> \"
    and D_OK: "D = \<Delta> \"
shows
  "(NFA_remove_unreachable_states \) = (NFA_construct_reachable I A FP D)"
  (is "?ls = ?rs")
proof -
  let ?D = "LTS_forget_labels (\<Delta> \)"
  note access_eq = LTS_is_reachable_from_initial_alt_def
  have access_eq' : "accessible ?D (\ \) = \<Q> \ - SemiAutomaton_unreachable_states \"
                    (is "?ls' = ?rs'")
  proof (intro set_eqI iffI)
    fix q
    assume "q \<in> ?rs'"
    thus "q \<in> ?ls'"
      by (auto simp add: SemiAutomaton_unreachable_states_def access_eq LTS_is_unreachable_def)
  next
    fix q
    assume ls: "q \<in> ?ls'"
    with LTS_is_reachable_from_initial_subset have q_in_Q: "q \<in> \<Q> \" by auto
    from \_consistent have I_subset_Q: "\<And>q. q \<in> \ \ \<Longrightarrow> q \<in> \<Q> \" by auto

    from ls q_in_Q I_subset_Q show "q \<in> ?rs'"
      by (auto simp add: SemiAutomaton_unreachable_states_def access_eq LTS_is_unreachable_def Bex_def)
  qed

  have \_diff_eq: "\ \ - SemiAutomaton_unreachable_states \ = \ \"
    by (auto simp add: SemiAutomaton_unreachable_states_\)

  from \<F>_consistent FP_OK have \<F>_eq:
    "{q \<in> \<Q> \. q \<notin> SemiAutomaton_unreachable_states \ \<and> FP q} =
     \<F> \ - SemiAutomaton_unreachable_states \" by auto

  from LTS_is_reachable_from_initial_finite
  show "?ls = ?rs"
    apply (simp add: NFA_construct_reachable_simp A_OK I_OK D_OK)
    apply (simp add: NFA_remove_unreachable_states_def SemiAutomaton_to_NFA_def
                     NFA_remove_states_def access_eq' SemiAutomaton_remove_states_def)
    apply (auto simp add: \_diff_eq \<F>_eq \<Delta>_consistent)
    apply (metis SemiAutomaton_unreachable_states_extend)
  done
qed

text \<open> Now let's implement efficiently constructing NFAs. During implementation,
        the states are renamend as well. \<close>
definition NFA_construct_reachable_map_OK where
  "NFA_construct_reachable_map_OK S rm DD rm' \<longleftrightarrow>
   DD \<subseteq> dom rm' \<and>
   (\<forall>q r'. rm q = Some r' \<longrightarrow> rm' q = Some r') \<and>
   inj_on rm' (S \<inter> dom rm')"

lemma NFA_construct_reachable_map_OK_I [intro!] :
"\<lbrakk>DD \<subseteq> dom rm'; \<And>q r'. rm q = Some r' \<Longrightarrow> rm' q = Some r'; inj_on rm' (S \<inter> dom rm')\<rbrakk> \<Longrightarrow>
 NFA_construct_reachable_map_OK S rm DD rm'"
unfolding NFA_construct_reachable_map_OK_def by simp

lemma NFA_construct_reachable_map_OK_insert_DD :
  "NFA_construct_reachable_map_OK S rm (insert q DD) rm' \<longleftrightarrow>
   q \<in> dom rm' \<and> NFA_construct_reachable_map_OK S rm DD rm'"
unfolding NFA_construct_reachable_map_OK_def by simp

lemma NFA_construct_reachable_map_OK_trans :
  "\<lbrakk>NFA_construct_reachable_map_OK S rm DD rm';
    NFA_construct_reachable_map_OK S rm' DD' rm'';
    DD'' \<subseteq> DD \<union> DD'\<rbrakk> \<Longrightarrow>
   NFA_construct_reachable_map_OK S rm DD'' rm''"
unfolding NFA_construct_reachable_map_OK_def
by (simp add: subset_iff dom_def) metis

definition NFA_construct_reachable_abstract_impl_invar where
"NFA_construct_reachable_abstract_impl_invar I A FP D \<equiv> (\<lambda>((rm, \), wl).
(\<exists>s. NFA_construct_reachable_map_OK (accessible (LTS_forget_labels D) (set I)) Map.empty
       (s \<union> set I \<union> set wl \<union> {q'. \<exists>a q. q\<in>s \<and> (q,a,q')\<in> D}) rm \<and>
     (accessible (LTS_forget_labels D) (set I)  =
      accessible_restrict (LTS_forget_labels D) s (set wl)) \<and>
     (\ = NFA_rename_states
        \<lparr>\<Q> = s, \<Sigma> = A, \<Delta> = {qsq. qsq \<in> D \<and> fst qsq \<in> s}, \ = set I,
         \<F> = {q \<in> s. FP q}\<rparr> (the \<circ> rm))))"

definition NFA_construct_reachable_abstract_impl_weak_invar where
"NFA_construct_reachable_abstract_impl_weak_invar I A FP D \<equiv> (\<lambda>(rm, \).
(\<exists>s. NFA_construct_reachable_map_OK (accessible (LTS_forget_labels D) (set I)) Map.empty
       (s \<union> set I \<union> {q'. \<exists>a q. q\<in>s \<and> (q,a,q')\<in> D}) rm \<and>
     s \<subseteq> accessible (LTS_forget_labels D) (set I) \<and>
     (\ = NFA_rename_states
        \<lparr>\<Q> = s, \<Sigma> = A, \<Delta> = {qsq. qsq \<in> D \<and> fst qsq \<in> s}, \ = set I,
         \<F> = {q \<in> s. FP q}\<rparr> (the \<circ> rm))))"

lemma NFA_construct_reachable_abstract_impl_invar_weaken :
assumes invar: "NFA_construct_reachable_abstract_impl_invar I A FP D ((rm, \), wl)"
shows "NFA_construct_reachable_abstract_impl_weak_invar I A FP D (rm, \)"
using assms
unfolding NFA_construct_reachable_abstract_impl_weak_invar_def
          NFA_construct_reachable_abstract_impl_invar_def
          accessible_restrict_def NFA_construct_reachable_map_OK_def
apply clarify
apply (rule_tac x=s in exI)
apply auto
done

fun NFA_construct_reachable_abstract_impl_foreach_invar where
  "NFA_construct_reachable_abstract_impl_foreach_invar S DD rm D0 q it (rm', D', N) =
   (let D'' = (DD q) - it; qS = snd ` D'' in
    (NFA_construct_reachable_map_OK S rm qS rm' \<and>
     set N = qS \<and> q \<in> S \<and>
     D' = D0 \<union> {(the (rm' q), a, the (rm' q')) | a as q'. (as, q') \<in> D'' \<and> a \<in> as}))"
declare NFA_construct_reachable_abstract_impl_foreach_invar.simps [simp del]

definition NFA_construct_reachable_abstract_impl_step where
"NFA_construct_reachable_abstract_impl_step S DD rm D0 q =
  FOREACHi
    (NFA_construct_reachable_abstract_impl_foreach_invar S DD rm D0 q)
    (DD q)
    (\<lambda>(as, q') (rm, D', N). do {
       ASSERT (q' \<in> S);
       (rm', r') \<leftarrow> SPEC (\<lambda>(rm', r'). NFA_construct_reachable_map_OK S rm {q'} rm' \<and> rm' q' = Some r');
       RETURN (rm', {(the (rm q), a, r') | a. a \<in> as} \<union> D', q' # N)
     }) (rm, D0, [])"

lemma NFA_construct_reachable_abstract_impl_step_correct :
assumes fin: "finite (DD q)"
    and DD_OK: "\<And>q as q'. q \<in> S \<Longrightarrow> (as, q') \<in> DD q \<Longrightarrow> q' \<in> S"
    and inj_rm: "inj_on rm (S \<inter> dom rm)"
    and q_in_dom: "q \<in> S \<inter> dom rm"
shows "NFA_construct_reachable_abstract_impl_step S DD rm D0 q \<le>
      SPEC (NFA_construct_reachable_abstract_impl_foreach_invar S DD rm D0 q {})"
unfolding NFA_construct_reachable_abstract_impl_step_def
apply (intro refine_vcg)
apply (fact fin)
apply (insert q_in_dom)[]
apply (simp add: NFA_construct_reachable_abstract_impl_foreach_invar.simps
                 NFA_construct_reachable_map_OK_def inj_rm)
apply (insert q_in_dom)[] apply (simp, metis DD_OK subset_iff)
apply (clarify, simp)
apply (rename_tac it as q' rm' D' N rm'' r)
defer
apply simp
proof -
  fix it as q' rm' D' N rm'' r'
  assume in_it: "(as, q') \<in> it"
     and it_subset: "it \<subseteq> DD q"
     and invar: "NFA_construct_reachable_abstract_impl_foreach_invar S DD rm D0 q it (rm', D', N)"
     and map_OK: "NFA_construct_reachable_map_OK S rm' {q'} rm''"
     and rm''_q': "rm'' q' = Some r'"
  from q_in_dom obtain r where rm_q: "rm q = Some r" by auto

  define D'' where "D'' \<equiv> DD q - it"
  have D''_intro : "(DD q - (it - {(as, q')})) = insert (as, q') D''"
    using in_it it_subset D''_def by auto

  from invar have
    rm'_OK: "NFA_construct_reachable_map_OK S rm (snd ` D'') rm'" and
    set_N_eq: "set N = snd ` D''"  and
    D'_eq: "D' = D0 \<union> {(the (rm' q), a, the (rm' q')) |a as q'. (as, q') \<in> D'' \<and> a \<in> as}"
    unfolding NFA_construct_reachable_abstract_impl_foreach_invar.simps
    by (simp_all add: Let_def D''_def)

  have prop1: "NFA_construct_reachable_map_OK S rm (insert q' (snd ` D'')) rm''"
    using map_OK rm'_OK
    unfolding NFA_construct_reachable_map_OK_def
    by auto

  have prop2: "{(the (rm' q), a, r') |a. a \<in> as} \<union> D' =
    D0 \<union> {(the (rm'' q), aa, the (rm'' q'a)) |aa as' q'a. aa \<in> as' \<and>
       (as' = as \<and> q'a = q' \<or> (as', q'a) \<in> D'')}"
    (is "?ls = D0 \<union> ?rs")
  proof -
    from rm'_OK rm_q have rm'_q: "rm' q = Some r"
      unfolding NFA_construct_reachable_map_OK_def by simp
    with map_OK have rm''_q: "rm'' q = Some r"
      unfolding NFA_construct_reachable_map_OK_def by simp

    have step1: "?rs = {(the (rm'' q), a, the (rm'' q')) | a. a \<in> as} \<union>
      {(the (rm'' q), a, the (rm'' q')) |a as q'. (as, q') \<in> D'' \<and> a \<in> as}"
      (is "_ = _ \<union> ?rs'")
      by auto

    from rm'_OK map_OK have rm''_eq: "\<And>a q'. (a, q') \<in> D'' \<Longrightarrow> rm'' q' = rm' q'"
      unfolding NFA_construct_reachable_map_OK_def dom_def subset_iff
      by auto

    from rm''_eq have D'_eq': "D' = D0 \<union> ?rs'" unfolding D'_eq rm'_q rm''_q
      by auto  metis+

    show ?thesis unfolding D'_eq' step1 by (auto simp add: rm'_q rm''_q rm''_q')
  qed

  show "NFA_construct_reachable_abstract_impl_foreach_invar
        S DD rm D0 q (it - {(as, q')})
        (rm'', {(the (rm' q), a, r') |a. a \<in> as} \<union> D', q' # N) "
    unfolding NFA_construct_reachable_abstract_impl_foreach_invar.simps D''_intro using q_in_dom
    by (auto simp add: Let_def set_N_eq prop1 prop2)
qed

definition NFA_construct_reachable_abstract_impl where
  "NFA_construct_reachable_abstract_impl I A FP D DD =
   do {
     (rm, I') \<leftarrow> SPEC (\<lambda>(rm, I').
        NFA_construct_reachable_map_OK (accessible (LTS_forget_labels D) (set I)) Map.empty (set I) rm \<and>
        I' = (the \<circ> rm) ` (set I));
     ((rm, \), _) \<leftarrow> WORKLISTIT (NFA_construct_reachable_abstract_impl_invar I A FP D)
      (\<lambda>_. True)
      (\<lambda>(rm, \) q. do {
         ASSERT (q \<in> dom rm \<and> q \<in> accessible (LTS_forget_labels D) (set I) \<and>
                 NFA_construct_reachable_abstract_impl_weak_invar I A FP D (rm, \));
         if (the (rm q) \<in> \<Q> \) then
           (RETURN ((rm, \), []))
         else
           do {
             (rm', D', N) \<leftarrow> SPEC (NFA_construct_reachable_abstract_impl_foreach_invar
                 (accessible (LTS_forget_labels D) (set I)) DD rm (\<Delta> \) q {});
             RETURN ((rm', \<lparr> \<Q>=insert (the (rm q)) (\<Q> \), \<Sigma>=\<Sigma> \, \<Delta> = D',
                           \=\ \, \<F> = if (FP q) then (insert (the (rm q)) (\<F> \)) else (\<F> \)\<rparr>), N)
           }
        }) ((rm, \<lparr> \<Q>={}, \<Sigma>=A, \<Delta> = {}, \=I', \<F>={} \<rparr>), I);
     RETURN \
   }"

lemma NFA_construct_reachable_abstract_impl_correct :
fixes D :: "('q \<times> 'a \<times> 'q) set" and I
  and DD :: "'q \<Rightarrow> ('a set \<times> 'q) set"
defines "S \<equiv> (accessible (LTS_forget_labels D) (set I))"
assumes fin_S: "finite S"
    and DD_OK: "\<And>q a q'. q \<in> S \<Longrightarrow> (q, a, q') \<in> D \<longleftrightarrow> (\<exists>as. a \<in> as \<and> (as, q') \<in> DD q)"
               "\<And>q as q'. q \<in> S \<Longrightarrow> (as, q') \<in> DD q \<Longrightarrow> as \<noteq> {}"
shows "NFA_construct_reachable_abstract_impl I A FP D DD \<le>
       SPEC (\<lambda>\. NFA_isomorphic (NFA_construct_reachable (set I) A FP D) (\::('q2, 'a) NFA_rec))"
unfolding NFA_construct_reachable_abstract_impl_def S_def[symmetric]
apply (intro refine_vcg WORKLISTIT_rule)
apply (simp_all split: prod.splits split del: if_splits)

  apply (clarify, simp)
  apply (rename_tac rm)
defer
  apply (clarify, simp)
  apply (rename_tac rm)
  apply (subgoal_tac "wf (inv_image (measure (\<lambda>\. card S - card (\<Q> \))) snd)")
  apply assumption
defer
   apply (clarify)
   apply (intro refine_vcg)
   apply simp
   apply (rename_tac rm' wl q rm \)
   apply (intro conjI)
defer
defer
defer
   apply (clarify, simp)
   apply (rename_tac rm' wl q rm \ r)
defer
   apply clarify
   apply (simp split del: if_splits)
   apply (rename_tac rm'' wl q rm \ rm' D' N r)
   apply (intro conjI)
defer
defer
   apply (clarify, simp)
   apply (rename_tac rm' rm \)
defer
proof -
  fix rm :: "'q \<Rightarrow> 'q2 option"
  assume rm_OK: "NFA_construct_reachable_map_OK S Map.empty (set I) rm"

  thus "NFA_construct_reachable_abstract_impl_invar I A FP D
          ((rm, \<lparr>\<Q> = {}, \<Sigma> = A, \<Delta> = {}, \ = (\<lambda>x. the (rm x)) ` set I, \<F> = {}\<rparr>), I)"
    unfolding NFA_construct_reachable_abstract_impl_invar_def
    apply (simp)
    apply (rule exI [where x = "{}"])
    apply (simp add: accessible_restrict_def NFA_rename_states_full_def S_def)
  done
next
  show "wf (inv_image (measure (\<lambda>\. card S - card (\<Q> \))) snd)"
    by (intro wf_inv_image wf_measure)
next
  fix rm :: "'q \<Rightarrow> 'q2 option" and \

  note reach_simp = NFA_construct_reachable_simp [OF fin_S[unfolded S_def]]
  assume "NFA_construct_reachable_abstract_impl_invar I A FP D ((rm, \), [])"
  thus "NFA_isomorphic (NFA_construct_reachable (set I) A FP D) \"
    unfolding NFA_construct_reachable_abstract_impl_invar_def
    apply (simp add: reach_simp S_def[symmetric])
    apply (rule NFA_isomorphic___NFA_rename_states)
    apply (simp add: inj_on_def NFA_construct_reachable_map_OK_def dom_def subset_iff Ball_def)
    apply (metis option.sel)
  done
next
  fix rm :: "'q \<Rightarrow> 'q2 option"
  fix \ q wl
  assume invar: "NFA_construct_reachable_abstract_impl_invar I A FP D ((rm, \), q # wl)"

  from invar obtain s where
    S_eq: "S = accessible_restrict (LTS_forget_labels D) s (insert q (set wl))" and
    rm_OK: "NFA_construct_reachable_map_OK S Map.empty (insert q (s \<union> set I \<union>
            set wl \<union> {q'. \<exists>a q. q \<in> s \<and> (q, a, q') \<in> D})) rm" and
    \_eq: "\ = NFA_rename_states
           \<lparr>\<Q> = s, \<Sigma> = A, \<Delta> = {qsq \<in> D. fst qsq \<in> s}, \ = set I, \<F> = {q \<in> s. FP q}\<rparr>
           (the \<circ> rm)"
    unfolding NFA_construct_reachable_abstract_impl_invar_def S_def[symmetric]
  by auto

  from rm_OK show "q \<in> dom rm"
    unfolding NFA_construct_reachable_map_OK_def by simp

  from S_eq show "q \<in> S"
    using accessible_restrict_subset_ws[of "insert q (set wl)" "LTS_forget_labels D" s]
    by simp

  from NFA_construct_reachable_abstract_impl_invar_weaken[OF invar]
  show "NFA_construct_reachable_abstract_impl_weak_invar I A FP D (rm, \)" by simp
next
  fix rm :: "'q \<Rightarrow> 'q2 option" and \ q wl r

  assume invar: "NFA_construct_reachable_abstract_impl_invar I A FP D ((rm, \), q # wl)" and
         rm_q_eq: "rm q = Some r" and
         rm_q: "r \<in> \<Q> \" and
         q_in_S: "q \<in> S"

  show "NFA_construct_reachable_abstract_impl_invar I A FP D ((rm, \), wl)"
  proof -
    from invar obtain s where
      rm_OK: "NFA_construct_reachable_map_OK S Map.empty (insert q (s \<union> set I \<union>
              set wl \<union> {q'. \<exists>a q. q \<in> s \<and> (q, a, q') \<in> D})) rm" and
      S_eq: "S = accessible_restrict (LTS_forget_labels D) s (insert q (set wl))" and
      \_eq: "\ = NFA_rename_states
        \<lparr>\<Q> = s, \<Sigma> = A, \<Delta> = {qsq. qsq \<in> D \<and> fst qsq \<in> s}, \ = set I,
         \<F> = {q \<in> s. FP q}\<rparr> (the \<circ> rm)"
      unfolding NFA_construct_reachable_abstract_impl_invar_def S_def[symmetric] by auto
    from S_eq have s_subset: "s \<subseteq> S" unfolding accessible_restrict_def by simp

    from rm_q \_eq have "r \<in> (the \<circ> rm) ` s" by simp
    with rm_OK rm_q_eq q_in_S s_subset have "q \<in> s"
      unfolding NFA_construct_reachable_map_OK_def
      apply (simp add: image_iff Bex_def dom_def subset_iff inj_on_def Ball_def)
      apply (metis option.sel)
    done

    from `q \<in> s` have "insert q (s \<union> set I \<union> set wl \<union> {q'. \<exists>a q. q \<in> s \<and> (q, a, q') \<in> D}) =
                       s \<union>  set I \<union> set wl \<union> {q'. \<exists>a q. q \<in> s \<and> (q, a, q') \<in> D}" by auto
    with `q \<in> s` rm_OK s_subset show ?thesis
      unfolding NFA_construct_reachable_abstract_impl_invar_def S_def[symmetric]
      apply simp
      apply (rule exI[where x = s])
      apply (simp add: \_eq S_eq accessible_restrict_insert_in)
    done
  qed
next
  fix rm :: "'q \<Rightarrow> 'q2 option"
  fix \ q wl rm' D' N r
  assume invar: "NFA_construct_reachable_abstract_impl_invar I A FP D ((rm, \), q # wl)"
     and rm_q_eq: "rm q = Some r"
     and nin_Q: "r \<notin> \<Q> \"
     and q_in_S: "q \<in> S"
  assume foreach_invar: "NFA_construct_reachable_abstract_impl_foreach_invar S DD rm (\<Delta> \) q {} (rm', D', N)"
  from rm_q_eq have r_eq: "r = the (rm q)" by simp

  from invar obtain s where
     S_eq: "S = accessible_restrict (LTS_forget_labels D) s (insert q (set wl))" and
     rm_OK: "NFA_construct_reachable_map_OK S Map.empty
          (insert q (s \<union> set I \<union> set wl \<union> {q'. \<exists>a q. q \<in> s \<and> (q, a, q') \<in> D})) rm" and
     \_eq: "\ = NFA_rename_states
        \<lparr>\<Q> = s, \<Sigma> = A, \<Delta> = {qsq. qsq \<in> D \<and> fst qsq \<in> s}, \ = set I,
         \<F> = {q \<in> s. FP q}\<rparr> (the \<circ> rm)"
     unfolding NFA_construct_reachable_abstract_impl_invar_def S_def[symmetric] by auto

   define D'' where "D'' \<equiv> {(a, q'). (q, a, q') \<in> D}"

  from DD_OK[OF q_in_S]
  have snd_D''_eq: "snd ` D'' = snd ` (DD q)"
    unfolding D''_def by (auto simp add: image_iff Bex_def) (metis ex_in_conv)

  from foreach_invar have
    rm'_OK: "NFA_construct_reachable_map_OK S rm (snd ` D'') rm'" and
    set_N_eq: "set N = snd ` D''"  and
    D'_eq: "D' = \<Delta> \ \<union> {(the (rm' q), a, the (rm' q')) |a q'. (a, q') \<in> D''}"
    unfolding NFA_construct_reachable_abstract_impl_foreach_invar.simps snd_D''_eq
    by (auto simp add: Let_def D''_def DD_OK)

  define DDD where "DDD \<equiv> insert q (s \<union> set I \<union> set wl \<union> {q'. \<exists>a q. q \<in> s \<and> (q, a, q') \<in> D})"
  have DDD_intro: "(insert q
       (s \<union> set I \<union> (set N \<union> set wl) \<union> {q'. \<exists>a qa. (qa = q \<or> qa \<in> s) \<and> (qa, a, q') \<in> D})) = DDD \<union> snd ` D''"
    unfolding DDD_def by (auto simp add: image_iff set_N_eq D''_def)

  from nin_Q \_eq have q_nin_s: "q \<notin> s" by (auto simp add: image_iff r_eq)

  have "(set wl \<union> {y. (q, y) \<in> LTS_forget_labels D}) = set N \<union> set wl"
    unfolding set_N_eq D''_def LTS_forget_labels_def by (auto simp add: image_iff)
  hence prop1: "S = accessible_restrict (LTS_forget_labels D) (insert q s) (set N \<union> set wl)"
     by (simp add: S_eq accessible_restrict_insert_nin q_nin_s)

  have prop2: "NFA_construct_reachable_map_OK S Map.empty
     (insert q  (s \<union> set I \<union> (set N \<union> set wl) \<union> {q'. \<exists>a qa. (qa = q \<or> qa \<in> s) \<and> (qa, a, q') \<in> D})) rm'"
    unfolding DDD_intro NFA_construct_reachable_map_OK_def
  proof (intro conjI allI impI Un_least)
    from rm'_OK show "snd ` D'' \<subseteq> dom rm'" "inj_on rm' (S \<inter> dom rm')"
      unfolding NFA_construct_reachable_map_OK_def by simp_all
  next
    from rm_OK have "DDD \<subseteq> dom rm"
      unfolding NFA_construct_reachable_map_OK_def DDD_def[symmetric] by simp
    moreover from rm'_OK have "dom rm \<subseteq> dom rm'"
      unfolding NFA_construct_reachable_map_OK_def dom_def by auto
    finally show "DDD \<subseteq> dom rm'" .
  qed simp

  from rm'_OK have "\<And>q. q \<in> dom rm \<Longrightarrow> rm' q = rm q"
    unfolding NFA_construct_reachable_map_OK_def
    by (simp add: dom_def) metis
  with rm_OK have rm'_eq: "\<And>q'. q' \<in> DDD \<Longrightarrow> rm' q' = rm q'"
    unfolding NFA_construct_reachable_map_OK_def DDD_def[symmetric]
    by (simp add: subset_iff)

  have prop3: "
    \<lparr>\<Q> = insert r (\<Q> \), \<Sigma> = \<Sigma> \, \<Delta> = D', \ = \ \,
       \<F> = if FP q then insert (the (rm q)) (\<F> \) else \<F> \\<rparr> =
    NFA_rename_states
     \<lparr>\<Q> = insert q s, \<Sigma> = A, \<Delta> = {qsq \<in> D. fst qsq = q \<or> fst qsq \<in> s}, \ = set I,
        \<F> = {qa. (qa = q \<or> qa \<in> s) \<and> FP qa}\<rparr>
     (the \<circ> rm')"
  proof -
    from DDD_def have "set I \<subseteq> DDD" unfolding DDD_def by auto
    with rm'_eq have rm'_eq_I: "(the \<circ> rm) ` set I = (the \<circ> rm') ` set I"
      apply (rule_tac set_eqI)
      apply (auto simp add: image_iff Bex_def subset_iff)
    done

    have "insert q s \<subseteq> DDD" unfolding DDD_def by auto
    with rm'_eq have rm'_eq_Q: "insert r ((the \<circ> rm) ` s) = insert (the (rm' q)) ((the \<circ> rm') ` s)"
      apply (rule_tac set_eqI)
      apply (auto simp add: image_iff Bex_def subset_iff r_eq)
    done

    have D'_eq' : "D' = {(the (rm' s1), a, the (rm' s2)) |s1 a s2. (s1, a, s2) \<in> D \<and> (s1 = q \<or> s1 \<in> s)}"
       (is "_ = ?ls")
    proof -
      have "?ls = {(the (rm' s1), a, the (rm' s2)) |s1 a s2. (s1, a, s2) \<in> D \<and> s1 \<in> s} \<union>
                  {(the (rm' q), a, the (rm' q')) |a q'. (a, q') \<in> D''}"
           (is "_ = ?ls' \<union> _")
        unfolding D''_def by auto
      moreover
        from rm'_eq have "?ls' = \<Delta> \" unfolding \_eq DDD_def
          by (auto simp add: NFA_rename_states_def) metis+
      finally show ?thesis by (simp add: D'_eq)
    qed

    from rm'_eq have rm'_eq_F:
      "(if FP q then insert (the (rm q)) (\<F> \) else \<F> \) =
        (the \<circ> rm') ` {qa. (qa = q \<or> qa \<in> s) \<and> FP qa}"
      apply (rule_tac set_eqI)
      apply (simp add: image_iff \_eq DDD_def)
      apply (metis)
    done

  show ?thesis
    using rm'_eq_I rm'_eq_Q by (simp add: NFA_rename_states_full_def \_eq rm'_eq_F D'_eq')
  qed

  from S_eq have s_subset: "s \<subseteq> S" unfolding accessible_restrict_def by simp
  show "NFA_construct_reachable_abstract_impl_invar I A FP D
        ((rm',\<lparr>\<Q> = insert r (\<Q> \), \<Sigma> = \<Sigma> \, \<Delta> = D', \ = \ \,
             \<F> = if FP q then insert (the (rm q)) (\<F> \) else \<F> \\<rparr>), N @ wl)"
    unfolding NFA_construct_reachable_abstract_impl_invar_def S_def[symmetric]
    apply (simp split del: if_splits)
    apply (rule exI [where x = "insert q s"])
    apply (simp split del: if_splits add: q_in_S s_subset)
    apply (simp add: prop3 prop2)
    apply (simp add: prop1)
  done

  from S_eq have s_subset: "s \<subseteq> S" unfolding accessible_restrict_def by simp
  with fin_S have fin_s: "finite s" by (metis finite_subset)

  from \_eq fin_s nin_Q have fin_Q: "finite (\<Q> \)" and card_Q_le': "card (\<Q> \) \<le> card s"
    unfolding NFA_rename_states_def by (simp_all add: card_image_le image_iff r_eq)

  from S_eq s_subset accessible_restrict_subset_ws[of "(insert q (set wl))" "LTS_forget_labels D" s]
  have "insert q s \<subseteq> S" unfolding accessible_restrict_def by simp
  hence "card (insert q s) \<le> card S" by (rule card_mono[OF fin_S])
  hence "card s < card S" by (simp add: q_nin_s fin_s)
  with card_Q_le' have card_Q_le: "card (\<Q> \) < card S" by simp

  hence "card S - card (insert r (\<Q> \)) < card S - card (\<Q> \)"  by (simp add: nin_Q fin_Q)
  thus "card S - card (insert r (\<Q> \)) < card S - card (\<Q> \) \<or>
       rm' = rm \<and> \<lparr>\<Q> = insert r (\<Q> \), \<Sigma> = \<Sigma> \, \<Delta> = D', \ = \ \,
          \<F> = if FP q then insert (the (rm q)) (\<F> \) else \<F> \\<rparr> = \ \<and> N = []" by simp
qed

definition NFA_construct_reachable_abstract2_impl where
  "NFA_construct_reachable_abstract2_impl I A FP D DD =
   do {
     (rm, I') \<leftarrow> SPEC (\<lambda>(rm, I').
        NFA_construct_reachable_map_OK (accessible (LTS_forget_labels D) (set I)) Map.empty (set I) rm \<and>
        I' = (the \<circ> rm) ` (set I));
     ((rm, \), _) \<leftarrow> WORKLISTIT (NFA_construct_reachable_abstract_impl_invar I A FP D)
      (\<lambda>_. True)
      (\<lambda>(rm, \) q. do {
         ASSERT (q \<in> dom rm \<and> q \<in> accessible (LTS_forget_labels D) (set I) \<and>
                 NFA_construct_reachable_abstract_impl_weak_invar I A FP D (rm, \));
         if (the (rm q) \<in> \<Q> \) then
           (RETURN ((rm, \), []))
         else
           do {
             (rm', D', N) \<leftarrow> NFA_construct_reachable_abstract_impl_step
                 (accessible (LTS_forget_labels D) (set I)) DD rm (\<Delta> \) q;
             RETURN ((rm', \<lparr> \<Q>=insert (the (rm q)) (\<Q> \), \<Sigma>=\<Sigma> \, \<Delta> = D',
                           \=\ \, \<F> = if (FP q) then (insert (the (rm q)) (\<F> \)) else (\<F> \)\<rparr>), N)
           }
        }) ((rm, \<lparr> \<Q>={}, \<Sigma>=A, \<Delta> = {}, \=I', \<F>={} \<rparr>), I);
     RETURN \
   }"

lemma NFA_construct_reachable_abstract2_impl_correct :
fixes D :: "('q \<times> 'a \<times> 'q) set" and I
defines "S \<equiv> accessible (LTS_forget_labels D) (set I)"
assumes fin_S: "finite S"
    and fin_DD: "\<And>q. q \<in> S \<Longrightarrow> finite (DD q)"
    and DD_OK: "\<And>q as q'. q \<in> S \<Longrightarrow> (as, q') \<in> DD q \<Longrightarrow> q' \<in> S"
shows "NFA_construct_reachable_abstract2_impl I A FP D DD \<le> \<Down>Id ((NFA_construct_reachable_abstract_impl I A FP D DD)::('q2, 'a) NFA_rec nres)"
unfolding NFA_construct_reachable_abstract2_impl_def NFA_construct_reachable_abstract_impl_def S_def[symmetric]
apply refine_rcg
apply (simp)
apply (rule single_valued_Id)
apply (rule single_valued_Id)
apply (simp)
apply (simp_all add: list_all2_eq[symmetric] refine_hsimp)

apply (clarify, simp)
apply (rename_tac q rm \ r)
apply (rule NFA_construct_reachable_abstract_impl_step_correct)
proof -
  fix q
  assume "q \<in> S"
  thus "finite (DD q)" by (rule fin_DD)
next
  fix rm :: "'q \<Rightarrow> 'q2 option" and
      \ :: "('q2, 'a) NFA_rec"

  assume "NFA_construct_reachable_abstract_impl_weak_invar I A FP D (rm, \)"
  thus "inj_on rm (S \<inter> dom rm)"
     unfolding NFA_construct_reachable_abstract_impl_weak_invar_def
               NFA_construct_reachable_map_OK_def S_def[symmetric] by auto
next
  fix q as q'
  assume "q \<in> S" "(as, q') \<in> DD q"
  with DD_OK show "q' \<in> S" by blast
next
  fix rm :: "'q \<Rightarrow> 'q2 option" and q r
  assume "rm q = Some r" "q \<in> S"
  thus "q \<in> S \<inter> dom rm" by blast
qed

lemma NFA_construct_reachable_abstract2_impl_correct_full :
fixes D :: "('q \<times> 'a \<times> 'q) set" and I
  and DD :: "'q \<Rightarrow> ('a set \<times> 'q) set"
defines "S \<equiv> (accessible (LTS_forget_labels D) (set I))"
assumes fin_S: "finite S"
    and DD_OK: "\<And>q a q'. q \<in> S \<Longrightarrow> (q, a, q') \<in> D \<longleftrightarrow> (\<exists>as. a \<in> as \<and> (as, q') \<in> DD q)"
               "\<And>q as q'. q \<in> S \<Longrightarrow> (as, q') \<in> DD q \<Longrightarrow> as \<noteq> {}"
    and fin_DD: "\<And>q. q \<in> S \<Longrightarrow> finite (DD q)"
shows "NFA_construct_reachable_abstract2_impl I A FP D DD \<le>
       SPEC (\<lambda>\. NFA_isomorphic (NFA_construct_reachable (set I) A FP D) (\::('q2, 'a) NFA_rec))"
proof -
  from assms
  have step1 : "NFA_construct_reachable_abstract_impl I A FP D DD \<le> SPEC
     (NFA_isomorphic (NFA_construct_reachable (set I) A FP D))"
    apply (rule_tac NFA_construct_reachable_abstract_impl_correct)
    apply (simp_all add: S_def)
  done

  have step2: "NFA_construct_reachable_abstract2_impl I A FP D DD \<le> \<Down> Id
     (NFA_construct_reachable_abstract_impl I A FP D DD)"
  proof -
    { fix q as q'
      assume q_in_S: "q \<in> S" and in_DD_q: "(as, q') \<in> DD q"

      from in_DD_q DD_OK[OF q_in_S] have qq'_in_D: "(q, q') \<in> (LTS_forget_labels D)"
        unfolding LTS_forget_labels_def
        by simp (metis all_not_in_conv)

      from q_in_S qq'_in_D
      have "q' \<in> S" unfolding S_def accessible_def
      by (metis rtrancl_image_advance)
    } note pre = this

    from NFA_construct_reachable_abstract2_impl_correct[of D I DD, folded S_def, OF fin_S]
         fin_DD pre
    show ?thesis by auto
  qed

  from conc_trans_additional(5)[OF step2 step1] show ?thesis .
qed

end


(*  Title:      HOL/ATP.thy
    Author:     Fabian Immler, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
*)

section {* Automatic Theorem Provers (ATPs) *}

theory ATP
imports Meson
begin

subsection {* ATP problems and proofs *}

ML_file "Tools/ATP/atp_util.ML"
ML_file "Tools/ATP/atp_problem.ML"
ML_file "Tools/ATP/atp_proof.ML"
ML_file "Tools/ATP/atp_proof_redirect.ML"
ML_file "Tools/ATP/atp_satallax.ML"

subsection {* Higher-order reasoning helpers *}

definition fFalse :: bool where
"fFalse \<longleftrightarrow> False"

definition fTrue :: bool where
"fTrue \<longleftrightarrow> True"

definition fNot :: "bool \<Rightarrow> bool" where
"fNot P \<longleftrightarrow> \<not> P"

definition fComp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
"fComp P = (\<lambda>x. \<not> P x)"

definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fconj P Q \<longleftrightarrow> P \<and> Q"

definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fdisj P Q \<longleftrightarrow> P \<or> Q"

definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fimplies P Q \<longleftrightarrow> (P \<longrightarrow> Q)"

definition fAll :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
"fAll P \<longleftrightarrow> All P"

definition fEx :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
"fEx P \<longleftrightarrow> Ex P"

definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
"fequal x y \<longleftrightarrow> (x = y)"

lemma fTrue_ne_fFalse: "fFalse \<noteq> fTrue"
unfolding fFalse_def fTrue_def by simp

lemma fNot_table:
"fNot fFalse = fTrue"
"fNot fTrue = fFalse"
unfolding fFalse_def fTrue_def fNot_def by auto

lemma fconj_table:
"fconj fFalse P = fFalse"
"fconj P fFalse = fFalse"
"fconj fTrue fTrue = fTrue"
unfolding fFalse_def fTrue_def fconj_def by auto

lemma fdisj_table:
"fdisj fTrue P = fTrue"
"fdisj P fTrue = fTrue"
"fdisj fFalse fFalse = fFalse"
unfolding fFalse_def fTrue_def fdisj_def by auto

lemma fimplies_table:
"fimplies P fTrue = fTrue"
"fimplies fFalse P = fTrue"
"fimplies fTrue fFalse = fFalse"
unfolding fFalse_def fTrue_def fimplies_def by auto

lemma fAll_table:
"Ex (fComp P) \<or> fAll P = fTrue"
"All P \<or> fAll P = fFalse"
unfolding fFalse_def fTrue_def fComp_def fAll_def by auto

lemma fEx_table:
"All (fComp P) \<or> fEx P = fTrue"
"Ex P \<or> fEx P = fFalse"
unfolding fFalse_def fTrue_def fComp_def fEx_def by auto

lemma fequal_table:
"fequal x x = fTrue"
"x = y \<or> fequal x y = fFalse"
unfolding fFalse_def fTrue_def fequal_def by auto

lemma fNot_law:
"fNot P \<noteq> P"
unfolding fNot_def by auto

lemma fComp_law:
"fComp P x \<longleftrightarrow> \<not> P x"
unfolding fComp_def ..

lemma fconj_laws:
"fconj P P \<longleftrightarrow> P"
"fconj P Q \<longleftrightarrow> fconj Q P"
"fNot (fconj P Q) \<longleftrightarrow> fdisj (fNot P) (fNot Q)"
unfolding fNot_def fconj_def fdisj_def by auto

lemma fdisj_laws:
"fdisj P P \<longleftrightarrow> P"
"fdisj P Q \<longleftrightarrow> fdisj Q P"
"fNot (fdisj P Q) \<longleftrightarrow> fconj (fNot P) (fNot Q)"
unfolding fNot_def fconj_def fdisj_def by auto

lemma fimplies_laws:
"fimplies P Q \<longleftrightarrow> fdisj (\<not> P) Q"
"fNot (fimplies P Q) \<longleftrightarrow> fconj P (fNot Q)"
unfolding fNot_def fconj_def fdisj_def fimplies_def by auto

lemma fAll_law:
"fNot (fAll R) \<longleftrightarrow> fEx (fComp R)"
unfolding fNot_def fComp_def fAll_def fEx_def by auto

lemma fEx_law:
"fNot (fEx R) \<longleftrightarrow> fAll (fComp R)"
unfolding fNot_def fComp_def fAll_def fEx_def by auto

lemma fequal_laws:
"fequal x y = fequal y x"
"fequal x y = fFalse \<or> fequal y z = fFalse \<or> fequal x z = fTrue"
"fequal x y = fFalse \<or> fequal (f x) (f y) = fTrue"
unfolding fFalse_def fTrue_def fequal_def by auto

subsection {* Waldmeister helpers *}

(* Has all needed simplification lemmas for logic. *)
lemma boolean_equality: "(P \<longleftrightarrow> P) = True"
  by simp

lemma boolean_comm: "(P \<longleftrightarrow> Q) = (Q \<longleftrightarrow> P)"
  by auto

lemmas waldmeister_fol = boolean_equality boolean_comm
  simp_thms(1-5,7-8,11-25,27-33) disj_comms disj_assoc conj_comms conj_assoc

subsection {* Basic connection between ATPs and HOL *}

ML_file "Tools/lambda_lifting.ML"
ML_file "Tools/monomorph.ML"
ML_file "Tools/ATP/atp_problem_generate.ML"
ML_file "Tools/ATP/atp_proof_reconstruct.ML"
ML_file "Tools/ATP/atp_systems.ML"
ML_file "Tools/ATP/atp_waldmeister.ML"

hide_fact (open) waldmeister_fol boolean_equality boolean_comm

end


section \<open>Breadth First Search\<close>
theory Breadth_First_Search
imports "../Refine_Monadic"
begin

text \<open>
  This is a slightly modified version of Task~5 of our submission to
  the VSTTE 2011 verification competition
  (@{url "https://sites.google.com/site/vstte2012/compet"}). The task was to
  formalize a breadth-first-search algorithm.
\<close>

text \<open>
  With Isabelle's locale-construct, we put ourselves into a context where
  the \<open>succ\<close>-function is fixed.
  We assume finitely branching graphs here, as our
  foreach-construct is only defined for finite sets.
\<close>
locale Graph =
  fixes succ :: "'vertex \<Rightarrow> 'vertex set"
  assumes [simp, intro!]: "finite (succ v)"
begin

  subsection \<open>Distances in a Graph\<close>
  text \<open>
    We start over by defining the basic notions of paths and shortest paths.
\<close>

  text \<open>A path is expressed by the \<open>dist\<close>-predicate. Intuitively,
    \<open>dist v d v'\<close> means that there is a path of length \<open>d\<close>
    between \<open>v\<close> and \<open>v'\<close>.

    The definition of the \<open>dist\<close>-predicate is done inductively, i.e.,
    as the least solution of the following constraints:
\<close>
  inductive dist :: "'vertex \<Rightarrow> nat \<Rightarrow> 'vertex \<Rightarrow> bool" where
    dist_z: "dist v 0 v" |
    dist_suc: "\<lbrakk>dist v d vh; v' \<in> succ vh \<rbrakk> \<Longrightarrow> dist v (Suc d) v'"

  text \<open>
    Next, we define a predicate that expresses that the shortest path between
    \<open>v\<close> and \<open>v'\<close> has length \<open>d\<close>.
    This is the case if there is a path of length \<open>d\<close>, but there
    is no shorter path.
\<close>
  definition "min_dist v v' = (LEAST d. dist v d v')"
  definition "conn v v' = (\<exists>d. dist v d v')"

  subsubsection \<open>Properties\<close>
  text \<open>
    In this subsection, we prove some properties of paths.
\<close>

  lemma
    shows connI[intro]: "dist v d v' \<Longrightarrow> conn v v'"
      and connI_id[intro]: "conn v v"
      and connI_succ[intro]: "conn v v' \<Longrightarrow> v'' \<in> succ v' \<Longrightarrow> conn v v''"
    by (auto simp: conn_def intro: dist_suc dist_z)

  lemma min_distI2:
    "\<lbrakk> conn v v' ; \<And>d. \<lbrakk> dist v d v'; \<And>d'. dist v d' v' \<Longrightarrow> d \<le> d' \<rbrakk> \<Longrightarrow> Q d \<rbrakk>
      \<Longrightarrow> Q (min_dist v v')"
    unfolding min_dist_def
    by (rule LeastI2_wellorder[where Q=Q and a="SOME d. dist v d v'"])
       (auto simp: conn_def intro: someI)

  lemma min_distI_eq:
    "\<lbrakk> dist v d v'; \<And>d'. dist v d' v' \<Longrightarrow> d \<le> d' \<rbrakk> \<Longrightarrow> min_dist v v' = d"
    by (force intro: min_distI2 simp: conn_def)

  text \<open>Two nodes are connected by a path of length \<open>0\<close>,
    iff they are equal.\<close>
  lemma dist_z_iff[simp]: "dist v 0 v' \<longleftrightarrow> v'=v"
    by (auto elim: dist.cases intro: dist.intros)

  text \<open>The same holds for \<open>min_dist\<close>, i.e.,
    the shortest path between two nodes has length \<open>0\<close>,
    iff these nodes are equal.\<close>
  lemma min_dist_z[simp]: "min_dist v v = 0"
    by (rule min_distI2) (auto intro: dist_z)

  text \<open>We also provide introduction and destruction rules for the
    pattern \<open>min_dist v v' = Suc d\<close>.
\<close>

  lemma min_dist_succ:
    "\<lbrakk> conn v v'; v'' \<in> succ v' \<rbrakk> \<Longrightarrow> min_dist v v'' \<le> Suc (min_dist v v') "
    by (rule min_distI2[where v'=v'])
       (auto elim: dist.cases intro!: min_dist_minD dist_suc)

  lemma min_dist_suc:
    assumes c: "conn v v'" "min_dist v v' = Suc d"
    shows "\<exists>v''. conn v v'' \<and> v' \<in> succ v'' \<and> min_dist v v'' = d"
  proof -
    from min_dist_is_dist[OF c(1)]
    have "min_dist v v' = Suc d \<longrightarrow> ?thesis"
    proof cases
      case (dist_suc d' v'') then show ?thesis
        using min_dist_succ[of v v'' v'] min_dist_minD[of v d v'']
        by (auto simp: connI)
    qed simp
    with c show ?thesis by simp
  qed

  text \<open>
    If there is a node with a shortest path of length \<open>d\<close>,
    then, for any \<open>d'<d\<close>, there is also a node with a shortest path
    of length \<open>d'\<close>.
\<close>
  lemma min_dist_less:
    assumes "conn src v" "min_dist src v = d" and "d' < d"
    shows "\<exists>v'. conn src v' \<and> min_dist src v' = d'"
    using assms
  proof (induct d arbitrary: v)
    case (Suc d) with min_dist_suc[of src v] show ?case
      by (cases "d' = d") auto
  qed auto

  text \<open>
    Lemma \<open>min_dist_less\<close> can be weakened to \<open>d'\<le>d\<close>.
\<close>

  corollary min_dist_le:
    assumes c: "conn src v" and d': "d' \<le> min_dist src v"
    shows "\<exists>v'. conn src v' \<and> min_dist src v' = d'"
    using min_dist_less[OF c, of "min_dist src v" d'] d' c
    by (auto simp: le_less)

  subsection \<open>Invariants\<close>
  text \<open>
    In our framework, it is convenient to annotate the invariants and
    auxiliary assertions into the program. Thus, we have to define the
    invariants first.
\<close>

  text \<open>
    The invariant for the outer loop is split into two parts:
    The first part already holds before
    the \<open>if C={}\<close> check, the second part only holds again
    at the end of the loop body.
\<close>

  text \<open>
    The first part of the invariant, \<open>bfs_invar'\<close>,
    intuitively states the following:
    If the loop is not {\em break}ed, then we have:
    \begin{itemize}
      \item The next-node set \<open>N\<close> is a subset of \<open>V\<close>, and
        the destination node is not contained into \<open>V-(C\<union>N)\<close>,
      \item all nodes in the current-node set \<open>C\<close> have a shortest
        path of length \<open>d\<close>,
      \item all nodes in the next-node set \<open>N\<close> have a shortest path
        of length \<open>d+1\<close>,
      \item all nodes in the visited set \<open>V\<close> have a shortest path
        of length at most \<open>d+1\<close>,
      \item all nodes with a path shorter than \<open>d\<close> are already in
        \<open>V\<close>, and
      \item all nodes with a shortest path of length \<open>d+1\<close> are either
        in the next-node set \<open>N\<close>, or they are undiscovered successors
        of a node in the current-node set.
    \end{itemize}

    If the loop has been {\em break}ed, \<open>d\<close> is the distance of the
    shortest path between \<open>src\<close> and \<open>dst\<close>.
\<close>

  definition "bfs_invar' src dst \<sigma> \<equiv> let (f,V,C,N,d)=\<sigma> in
    (\<not>f \<longrightarrow> (
      N \<subseteq> V \<and> dst \<notin> V - (C \<union> N) \<and>
      (\<forall>v\<in>C. conn src v \<and> min_dist src v = d) \<and>
      (\<forall>v\<in>N. conn src v \<and> min_dist src v = Suc d) \<and>
      (\<forall>v\<in>V. conn src v \<and> min_dist src v \<le> Suc d) \<and>
      (\<forall>v. conn src v \<and> min_dist src v \<le> d \<longrightarrow> v \<in> V) \<and>
      (\<forall>v. conn src v \<and> min_dist src v = Suc d \<longrightarrow> v \<in> N \<union> ((\<Union>(succ`C)) - V))
    )) \<and> (
    f \<longrightarrow> conn src dst \<and> min_dist src dst = d
    )"

  text \<open>
    The second part of the invariant, \<open>empty_assm\<close>, just states
    that \<open>C\<close> can only be empty if \<open>N\<close> is also empty.
\<close>
  definition "empty_assm \<sigma> \<equiv> let (f,V,C,N,d)=\<sigma> in
    C={} \<longrightarrow> N={}"

  text \<open>
    Finally, we define the invariant of the outer loop, \<open>bfs_invar\<close>,
    as the conjunction of both parts:
\<close>
  definition "bfs_invar src dst \<sigma> \<equiv> bfs_invar' src dst \<sigma> \<and>
    empty_assm \<sigma>"

  text \<open>
    The invariant of the inner foreach-loop states that
    the successors that have already been processed (\<open>succ v - it\<close>),
    have been added to \<open>V\<close> and have also been added to
    \<open>N'\<close> if they are not in \<open>V\<close>.
\<close>
  definition "FE_invar V N v it \<sigma> \<equiv> let (V',N')=\<sigma> in
    V'=V \<union> (succ v - it) \<and>
    N'=N \<union> ((succ v - it) - V)"

  subsection \<open>Algorithm\<close>
  text \<open>
    The following algorithm is a straightforward transcription of the
    algorithm given in the assignment to the monadic style featured by our
    framework.
    We briefly explain the (mainly syntactic) differences:
    \begin{itemize}
      \item The initialization of the variables occur after the loop in
          our formulation. This is just a syntactic difference, as our loop
          construct has the form \<open>WHILEI I c f \<sigma>\<^sub>0\<close>, where \<open>\<sigma>\<^sub>0\<close>
          is the initial state, and \<open>I\<close> is the loop invariant;
      \item We translated the textual specification
        {\em remove one vertex \<open>v\<close> from \<open>C\<close>} as accurately as
        possible: The statement \<open>v \<leftarrow> SPEC (\<lambda>v. v\<in>C)\<close>
        nondeterministically assigns a node from \<open>C\<close> to \<open>v\<close>,
        that is then removed in the next statement;
      \item In our monad, we have no notion of loop-breaking (yet). Hence we
        added an additional boolean variable \<open>f\<close> that indicates that
        the loop shall terminate. The \<open>RETURN\<close>-statements used in our
        program are the return-operator of the monad, and must not be mixed up
        with the return-statement given in the original program, that is
        modeled by breaking the loop. The if-statement after the loop takes
        care to return the right value;
      \item We added an else-branch to the if-statement that checks
        whether we reached the destination node;
      \item We added an assertion of the first part of the invariant to the
        program text, moreover, we annotated invariants at the loops.
        We also added an assertion \<open>w\<notin>N\<close> into the inner loop. This
        is merely an optimization, that will allow us to implement the
        insert operation more efficiently;
      \item Each conditional branch in the loop body ends with a
        \<open>RETURN\<close>-statement. This is required by the monadic style;
      \item Failure is modeled by an option-datatype. The result
        \<open>Some d\<close> means that the integer \<open>d\<close> is returned,
        the result \<open>None\<close> means that a failure is returned.
    \end{itemize}
\<close>

  text_raw \<open>\clearpage\<close>

  definition bfs :: "'vertex \<Rightarrow> 'vertex \<Rightarrow>
    (nat option nres)"
    where "bfs src dst \<equiv> do {
    (f,_,_,_,d) \<leftarrow> WHILEI (bfs_invar src dst) (\<lambda>(f,V,C,N,d). f=False \<and> C\<noteq>{})
      (\<lambda>(f,V,C,N,d). do {
        v \<leftarrow> SPEC (\<lambda>v. v\<in>C); let C = C-{v};
        if v=dst then RETURN (True,{},{},{},d)
        else do {
          (V,N) \<leftarrow> FOREACHi (FE_invar V N v) (succ v) (\<lambda>w (V,N).
            if (w\<notin>V) then do {
              ASSERT (w\<notin>N);
              RETURN (insert w V, insert w N)
            } else RETURN (V,N)
          ) (V,N);
          ASSERT (bfs_invar' src dst (f,V,C,N,d));
          if (C={}) then do {
            let C=N;
            let N={};
            let d=d+1;
            RETURN (f,V,C,N,d)
          } else RETURN (f,V,C,N,d)
        }
      })
      (False,{src},{src},{},0::nat);
    if f then RETURN (Some d) else RETURN None
    }"

  subsection "Verification Tasks"
  text \<open>
    In order to make the proof more readable, we have extracted the
    difficult verification conditions and proved them in separate lemmas.
    The other verification conditions are proved automatically by Isabelle/HOL
    during the proof of the main theorem.

    Due to the timing constraints of the competition, the verification
    conditions are mostly proved in Isabelle's apply-style, that is faster
    to write for the experienced user, but harder to read by a human.

    Exemplarily, we formulated the last proof in the proof language
    {\em Isar}, that allows one to write human-readable proofs and verify
    them with Isabelle/HOL.
\<close>

  text \<open>
    The first part of the invariant is preserved if we take a node from
    \<open>C\<close>, and add its successors that are not in \<open>V\<close> to
    \<open>N\<close>.
    This is the verification condition for the assertion after the
    foreach-loop.
\<close>
  lemma invar_succ_step:
    assumes "bfs_invar' src dst (False, V, C, N, d)"
    assumes "v\<in>C"
    assumes "v\<noteq>dst"
    shows "bfs_invar' src dst
            (False, V \<union> succ v, C - {v}, N \<union> (succ v - V), d)"
    using assms
  proof (simp (no_asm_use) add: bfs_invar'_def, intro conjI, goal_cases)
    case 6 then show ?case
      by (metis Un_iff Diff_iff connI_succ le_SucE min_dist_succ)
  next
    case 7 then show ?case
      by (metis Un_iff connI_succ min_dist_succ)
  qed blast+

  text \<open>
    The first part of the invariant is preserved if the
    \<open>if C={}\<close>-statement is executed.
    This is the verification condition for the
    loop-invariant. Note that preservation of the second part of the
    invariant is proven easily inside the main proof.
\<close>
  lemma invar_empty_step:
    assumes "bfs_invar' src dst (False, V, {}, N, d)"
    shows "bfs_invar' src dst (False, V, N, {}, Suc d)"
    using assms
  proof (simp (no_asm_use) add: bfs_invar'_def, intro conjI impI allI, goal_cases)
    case 3 then show ?case
      by (metis le_SucI)
  next
    case 4 then show ?case
      by (metis le_SucE subsetD)
  next
    case (5 v) then show ?case
      using min_dist_suc[of src v "Suc d"] by metis
  next
    case 6 then show ?case
      by (metis Suc_n_not_le_n)
  qed blast+

  text \<open>The invariant holds initially.\<close>
  lemma invar_init: "bfs_invar src dst (False, {src}, {src}, {}, 0)"
    by (auto simp: bfs_invar_def bfs_invar'_def empty_assm_def)
       (metis min_dist_suc min_dist_z_iff)

  text \<open>The invariant is preserved if we break the loop.\<close>
  lemma invar_break:
    assumes "bfs_invar src dst (False, V, C, N, d)"
    assumes "dst\<in>C"
    shows "bfs_invar src dst (True, {}, {}, {}, d)"
    using assms unfolding bfs_invar_def bfs_invar'_def empty_assm_def
    by auto

  text \<open>If we have {\em break}ed the loop, the invariant implies
    that we, indeed, returned the shortest path.\<close>
  lemma invar_final_succeed:
    assumes "bfs_invar' src dst (True, V, C, N, d)"
    shows "min_dist src dst = d"
    using assms unfolding bfs_invar'_def
    by auto

  text \<open>If the loop terminated normally, there is no path between
    \<open>src\<close> and \<open>dst\<close>.

    The lemma is formulated as deriving a contradiction from the fact
    that there is a path and the loop terminated normally.

    Note the proof language {\em Isar} that was used here.
    It allows one to write human-readable proofs in a theorem prover.
\<close>
  lemma invar_final_fail:
    assumes C: "conn src dst" \<comment> \<open>There is a path between
      @{text "src"} and @{text "dst"}.\<close>
    assumes INV: "bfs_invar' src dst (False, V, {}, {}, d)"
    shows False
  proof -
    txt \<open>We make a case-distinction whether \<open>d'\<le>d\<close>:\<close>
    have "min_dist src dst \<le> d \<or> d + 1 \<le> min_dist src dst" by auto
    moreover {
      txt \<open>Due to the invariant, any node with a path of
        length at most \<open>d\<close> is contained in \<open>V\<close>
\<close>
      from INV have "\<forall>v. conn src v \<and> min_dist src v \<le> d \<longrightarrow> v\<in>V"
        unfolding bfs_invar'_def by auto
      moreover
      txt \<open>This applies in the first case, hence we obtain that
        \<open>dst\<in>V\<close>\<close>
      assume A: "min_dist src dst \<le> d"
      moreover from C have "dist src (min_dist src dst) dst"
        by (blast intro: min_dist_is_dist)
      ultimately have "dst\<in>V" by blast
      txt \<open>However, as \<open>C\<close> and \<open>N\<close> are empty, the invariant
        also implies that \<open>dst\<close> is not in \<open>V\<close>:\<close>
      moreover from INV have "dst\<notin>V" unfolding bfs_invar'_def by auto
      txt \<open>This yields a contradiction:\<close>
      ultimately have False by blast
    } moreover {
      txt \<open>In the case \<open>d+1 \<le> d'\<close>, we also obtain a node
        that has a shortest path of length \<open>d+1\<close>:\<close>
      assume "d+1 \<le> min_dist src dst"
      with min_dist_le[OF C] obtain v' where
        "conn src v'" "min_dist src v' = d + 1"
        by auto
      txt \<open>However, the invariant states that such nodes are either in
        \<open>N\<close> or are successors of \<open>C\<close>. As \<open>N\<close>
        and \<open>C\<close> are both empty, we again get a contradiction.\<close>
      with INV have False unfolding bfs_invar'_def by auto
    } ultimately show ?thesis by blast
  qed

  text \<open>
    Finally, we prove our algorithm correct:
    The following theorem solves both verification tasks.

    Note that a proposition of the form \<open>S \<sqsubseteq> SPEC \<Phi>\<close> states partial
    correctness in our framework, i.e., \<open>S\<close> refines the
    specification \<open>\<Phi>\<close>.

    The actual specification that we prove here
    precisely reflects the two verification tasks: {\em If the algorithm fails,
    there is no path between \<open>src\<close> and \<open>dst\<close>, otherwise
    it returns the length of the shortest path.}

    The proof of this theorem first applies the verification condition
    generator (\<open>apply (intro refine_vcg)\<close>), and then uses the
    lemmas proved beforehand to discharge the verification conditions.
    During the \<open>auto\<close>-methods, some trivial verification conditions,
    e.g., those concerning the invariant of the inner loop, are discharged
    automatically.
    During the proof, we gradually unfold the definition of the loop
    invariant.
\<close>
  definition "bfs_spec src dst \<equiv> SPEC (
    \<lambda>r. case r of None \<Rightarrow> \<not> conn src dst
              | Some d \<Rightarrow> conn src dst \<and> min_dist src dst = d)"
  theorem bfs_correct: "bfs src dst \<le> bfs_spec src dst"
    unfolding bfs_def bfs_spec_def
    apply (intro refine_vcg)

    unfolding FE_invar_def
    apply (auto simp:
      intro: invar_init invar_break )

    unfolding bfs_invar_def
    apply (auto simp:
      intro: invar_succ_step invar_empty_step invar_final_succeed)

    unfolding empty_assm_def
    apply (auto intro: invar_final_fail)

    unfolding bfs_invar'_def
    apply auto
    done

end

end


(*  Title:      FOL/ex/Prolog.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section {* First-Order Logic: PROLOG examples *}

theory Prolog
imports FOL
begin

typedecl 'a list
instance list :: ("term") "term" ..

axiomatization
  Nil     :: "'a list" and
  Cons    :: "['a, 'a list]=> 'a list"    (infixr ":" 60) and
  app     :: "['a list, 'a list, 'a list] => o" and
  rev     :: "['a list, 'a list] => o"
where
  appNil:  "app(Nil,ys,ys)" and
  appCons: "app(xs,ys,zs) ==> app(x:xs, ys, x:zs)" and
  revNil:  "rev(Nil,Nil)" and
  revCons: "[| rev(xs,ys);  app(ys, x:Nil, zs) |] ==> rev(x:xs, zs)"

schematic_lemma "app(a:b:c:Nil, d:e:Nil, ?x)"
apply (rule appNil appCons)
apply (rule appNil appCons)
apply (rule appNil appCons)
apply (rule appNil appCons)
done

schematic_lemma "app(?x, c:d:Nil, a:b:c:d:Nil)"
apply (rule appNil appCons)+
done

schematic_lemma "app(?x, ?y, a:b:c:d:Nil)"
apply (rule appNil appCons)+
back
back
back
back
done

(*app([x1,...,xn], y, ?z) requires (n+1) inferences*)
(*rev([x1,...,xn], ?y) requires (n+1)(n+2)/2 inferences*)

lemmas rules = appNil appCons revNil revCons

schematic_lemma "rev(a:b:c:d:Nil, ?x)"
apply (rule rules)+
done

schematic_lemma "rev(a:b:c:d:e:f:g:h:i:j:k:l:m:n:Nil, ?w)"
apply (rule rules)+
done

schematic_lemma "rev(?x, a:b:c:Nil)"
apply (rule rules)+  -- {* does not solve it directly! *}
back
back
done

(*backtracking version*)
ML {*
val prolog_tac = DEPTH_FIRST (has_fewer_prems 1) (resolve_tac (@{thms rules}) 1)
*}

schematic_lemma "rev(?x, a:b:c:Nil)"
apply (tactic prolog_tac)
done

schematic_lemma "rev(a:?x:c:?y:Nil, d:?z:b:?u)"
apply (tactic prolog_tac)
done

(*rev([a..p], ?w) requires 153 inferences *)
schematic_lemma "rev(a:b:c:d:e:f:g:h:i:j:k:l:m:n:o:p:Nil, ?w)"
apply (tactic {* DEPTH_SOLVE (resolve_tac ([@{thm refl}, @{thm conjI}] @ @{thms rules}) 1) *})
done

(*?x has 16, ?y has 32;  rev(?y,?w) requires 561 (rather large) inferences
  total inferences = 2 + 1 + 17 + 561 = 581*)
schematic_lemma "a:b:c:d:e:f:g:h:i:j:k:l:m:n:o:p:Nil = ?x & app(?x,?x,?y) & rev(?y,?w)"
apply (tactic {* DEPTH_SOLVE (resolve_tac ([@{thm refl}, @{thm conjI}] @ @{thms rules}) 1) *})
done

end