section \<open>Finding a Path between Nodes\<close>
theory DFS_Find_Path
imports
  DFS_Framework.DFS_Framework
  CAVA_Automata.Digraph_Impl
begin
text \<open>
  We instantiate the DFS framework to find a path to some reachable node
  that satisfies a given predicate. We present four variants of the algorithm:
  Finding any path, and finding path of at least length one, combined with
  searching the whole graph, and searching the graph restricted to a given set
  of nodes. The restricted variants are efficiently implemented by
  pre-initializing the visited set (cf. @{theory DFS_Framework.Restr_Impl}).

  The restricted variants can be used for incremental search, ignoring already
  searched nodes in further searches. This is required, e.g., for the inner
  search of nested DFS (Buchi automaton emptiness check).
\<close>

subsection \<open>Including empty Path\<close>
record 'v fp0_state = "'v state" +
  ppath :: "('v list \<times> 'v) option"

type_synonym 'v fp0_param = "('v, ('v,unit) fp0_state_ext) parameterization"

abbreviation "no_path \<equiv> \<lparr> ppath = None \<rparr>"
abbreviation "a_path p v \<equiv> \<lparr> ppath = Some (p,v) \<rparr>"

definition fp0_params :: "('v \<Rightarrow> bool) \<Rightarrow> 'v fp0_param"
  where "fp0_params P \<equiv> \<lparr>
  on_init = RETURN no_path,
  on_new_root = \<lambda>v0 s. if P v0 then RETURN (a_path [] v0) else RETURN no_path,
  on_discover = \<lambda>u v s. if P v
                   then \<comment> \<open>\<open>v\<close> is already on the stack, so we need to pop it again\<close>
                      RETURN (a_path (rev (tl (stack s))) v)
                   else RETURN no_path,
  on_finish = \<lambda>u s. RETURN (state.more s),
  on_back_edge = \<lambda>u v s. RETURN (state.more s),
  on_cross_edge = \<lambda>u v s. RETURN (state.more s),
  is_break = \<lambda>s. ppath s \<noteq> None \<rparr>"

lemmas fp0_params_simps[simp]
  = gen_parameterization.simps[mk_record_simp, OF fp0_params_def]

interpretation fp0: param_DFS_defs where param = "fp0_params P"
  for G P .

locale fp0 = param_DFS G "fp0_params P"
  for G and P :: "'v \<Rightarrow> bool" +
  fixes T
  assumes \<open>G = G\<close> \<open>T = T\<close>
begin

  lemma [simp]:
    "ppath (empty_state \<lparr>ppath = e\<rparr>) = e"
    by (simp add: empty_state_def)

  lemma [simp]:
    "ppath (s\<lparr>state.more := state.more s'\<rparr>) = ppath s'"
    by (cases s, cases s') auto

  sublocale DFS where param = "fp0_params P"
    by unfold_locales simp_all

end

lemma fp0I: assumes "fb_graph G" "T = T" shows "fp0 G T"
proof - interpret fb_graph G by fact show ?thesis by unfold_locales auto qed

locale fp0_invar = fp0 +
  DFS_invar where param = "fp0_params P"

lemma fp0_invar_eq[simp]:
  "DFS_invar G (fp0_params P) s \<longleftrightarrow> fp0_invar G P T s"
proof (intro ext iffI)
  fix s
  assume "DFS_invar G (fp0_params P) s"
  interpret DFS_invar G "fp0_params P" s by fact
  show "fp0_invar G P T s" by unfold_locales auto
next
  fix s
  assume "fp0_invar G P T s"
  interpret fp0_invar G P T s by fact
  show "DFS_invar G (fp0_params P) s" by unfold_locales
qed

context fp0 begin

  lemma i_no_path_no_P_discovered:
    "is_invar (\<lambda>s. ppath s = None \<longrightarrow> dom (discovered s) \<inter> Collect P = {})"
  by (rule establish_invarI) simp_all

  lemma i_path_to_P:
    "is_invar (\<lambda>s. ppath s = Some (vs,v) \<longrightarrow> P v)"
  by (rule establish_invarI) auto

  lemma i_path_invar:
    "is_invar (\<lambda>s. ppath s = Some (vs,v) \<longrightarrow>
                   (vs \<noteq> [] \<longrightarrow> hd vs \<in> V0 \<and> path E (hd vs) vs v)
                 \<and> (vs = [] \<longrightarrow> v \<in> V0 \<and> path E v vs v)
                 \<and> (distinct (vs@[v]))
                 )"
  proof (induct rule: establish_invarI)
    case (discover s s' u v) then interpret fp0_invar where s=s
      by (meson fp0_invar_eq)

    from discover have ne: "stack s \<noteq> []" by simp
    from discover have vnis: "v\<notin>set (stack s)" using stack_discovered by auto

    from pendingD discover have "v \<in> succ (hd (stack s))" by simp
    with hd_succ_stack_is_path[OF ne] have "\<exists>v0\<in>V0. path E v0 (rev (stack s)) v" .
    moreover from last_stack_in_V0 ne have "last (stack s) \<in> V0" by simp
    ultimately have "path E (hd (rev (stack s)))  (rev (stack s)) v" "hd (rev (stack s)) \<in> V0"
      using hd_rev[OF ne] path_hd[where p="rev (stack s)"] ne
      by auto
    with ne discover vnis show ?case by (auto simp: stack_distinct)
  qed auto
end

context fp0_invar
begin
  lemmas no_path_no_P_discovered
    = i_no_path_no_P_discovered[THEN make_invar_thm, rule_format]

  lemmas path_to_P
    = i_path_to_P[THEN make_invar_thm, rule_format]

  lemmas path_invar
    = i_path_invar[THEN make_invar_thm, rule_format]

  lemma path_invar_nonempty:
    assumes "ppath s = Some (vs,v)"
    and "vs \<noteq> []"
    shows "hd vs \<in> V0" "path E (hd vs) vs v"
    using assms path_invar
    by auto

  lemma path_invar_empty:
    assumes "ppath s = Some (vs,v)"
    and "vs = []"
    shows "v \<in> V0" "path E v vs v"
    using assms path_invar
    by auto

  lemma fp0_correct:
    assumes "\<not>cond s"
    shows "case ppath s of
      None \<Rightarrow> \<not>(\<exists>v0\<in>V0. \<exists>v. (v0,v) \<in> E\<^sup>* \<and> P v)
    | Some (p,v) \<Rightarrow> (\<exists>v0\<in>V0. path E v0 p v \<and> P v \<and> distinct (p@[v]))"
  proof (cases "ppath s")
    case None with assms nc_discovered_eq_reachable no_path_no_P_discovered have
      "reachable \<inter> Collect P = {}" by auto
    thus ?thesis by (auto simp add: None)
  next
    case (Some vvs) then obtain v vs where [simp]: "vvs = (vs,v)"
      by (cases vvs) auto

    from Some path_invar[of vs v] path_to_P[of _ v] show ?thesis
      by auto
  qed

end

context fp0 begin
  lemma fp0_correct: "it_dfs \<le> SPEC (\<lambda>s. case ppath s of
      None \<Rightarrow> \<not>(\<exists>v0\<in>V0. \<exists>v. (v0,v) \<in> E\<^sup>* \<and> P v)
    | Some (p,v) \<Rightarrow> (\<exists>v0\<in>V0. path E v0 p v \<and> P v \<and> distinct (p@[v])))"
    apply (rule weaken_SPEC[OF it_dfs_correct])
    apply clarsimp
    using fp0_invar.fp0_correct fp0_invar_eq by fastforce
end

subsubsection \<open>Basic Interface\<close>
text \<open>Use this interface, rather than the internal stuff above! \<close>
(* Making it a well-defined interface. This interface should be used, not
  the internal stuff. If more information about the result is needed, this
  interface should be extended! *)

type_synonym 'v fp_result = "('v list \<times> 'v) option"
definition "find_path0_pred G P \<equiv> \<lambda>r. case r of
    None \<Rightarrow> (g_E G)\<^sup>* `` g_V0 G \<inter> Collect P = {}
  | Some (vs,v) \<Rightarrow> P v \<and> distinct (vs@[v]) \<and> (\<exists> v0 \<in> g_V0 G. path (g_E G) v0 vs v)"

definition find_path0_spec
  :: "('v, _) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> _ \<Rightarrow> 'v fp_result nres"
  \<comment> \<open>Searches a path from the root nodes to some target node that satisfies a
      given predicate. If such a path is found, the path and the target node
      are returned\<close>
where
  "find_path0_spec G P T \<equiv> do {
    ASSERT (fb_graph G);
    SPEC (find_path0_pred G P)
  }"

definition find_path0
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'v fp_result nres"
  where "find_path0 G P T \<equiv> do {
  ASSERT (fp0 G T);
  s \<leftarrow> fp0.it_dfs TYPE('more) G P;
  RETURN (ppath s)
}"

lemma find_path0_correct:
  shows "find_path0 G P T \<le> find_path0_spec G P T"
  unfolding find_path0_def find_path0_spec_def find_path0_pred_def
  apply (refine_vcg le_ASSERTI order_trans[OF fp0.fp0_correct])
  apply (erule fp0I)
  apply (auto split: option.split)
  done

lemmas find_path0_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path0_spec_def]
  ASSERT_leof_defI[OF find_path0_spec_def]

subsection \<open>Restricting the Graph\<close>
text \<open> Extended interface, propagating set of already searched nodes (restriction) \<close>
(* Invariant for restriction: The restriction is closed under E
  and contains no P-nodes *)
definition restr_invar
  \<comment> \<open>Invariant for a node restriction, i.e., a transition closed set of nodes
    known to not contain a target node that satisfies a predicate.\<close>
  where
  "restr_invar E R P \<equiv> E `` R \<subseteq> R \<and> R \<inter> Collect P = {}"

lemma restr_invar_triv[simp, intro!]: "restr_invar E {} P"
  unfolding restr_invar_def by simp

lemma restr_invar_imp_not_reachable: "restr_invar E R P \<Longrightarrow> E\<^sup>*``R \<inter> Collect P = {}"
  unfolding restr_invar_def by (simp add: Image_closed_trancl)

type_synonym 'v fpr_result = "'v set + ('v list \<times> 'v)"
definition "find_path0_restr_pred G P R \<equiv> \<lambda>r.
    case r of
      Inl R' \<Rightarrow> R' = R \<union> (g_E G)\<^sup>* `` g_V0 G \<and> restr_invar (g_E G) R' P
    | Inr (vs,v) \<Rightarrow> P v \<and> (\<exists> v0 \<in> g_V0 G - R. path (rel_restrict (g_E G) R) v0 vs v)"

definition find_path0_restr_spec
  \<comment> \<open>Find a path to a target node that satisfies a predicate, not considering
      nodes from the given node restriction. If no path is found, an extended
      restriction is returned, that contains the start nodes\<close>
  where "find_path0_restr_spec G P R \<equiv> do {
    ASSERT (fb_graph G \<and> restr_invar (g_E G) R P);
    SPEC (find_path0_restr_pred G P R)}"

lemmas find_path0_restr_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path0_restr_spec_def]
  ASSERT_leof_defI[OF find_path0_restr_spec_def]

definition find_path0_restr
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v set \<Rightarrow> 'v fpr_result nres"
  where "find_path0_restr G P R \<equiv> do {
  ASSERT (fb_graph G);
  ASSERT (fp0 (graph_restrict G R));
  s \<leftarrow> fp0.it_dfs TYPE('more) (graph_restrict G R) P;
  case ppath s of
    None \<Rightarrow> do {
      ASSERT (dom (discovered s) = dom (finished s));
      RETURN (Inl (R \<union> dom (finished s)))
    }
  | Some (vs,v) \<Rightarrow> RETURN (Inr (vs,v))
}"

lemma find_path0_restr_correct:
  shows "find_path0_restr G P R \<le> find_path0_restr_spec G P R"
proof (rule le_ASSERT_defI1[OF find_path0_restr_spec_def], clarify)
  assume "fb_graph G"
  interpret a: fb_graph G by fact
  interpret fb_graph "graph_restrict G R" by (rule a.fb_graph_restrict)

  assume I: "restr_invar (g_E G) R P"

  define reachable where "reachable = graph_defs.reachable (graph_restrict G R)"

  interpret fp0 "graph_restrict G R" by unfold_locales simp

  show ?thesis unfolding find_path0_restr_def find_path0_restr_spec_def
    apply (refine_rcg refine_vcg le_ASSERTI order_trans[OF it_dfs_correct])
    apply unfold_locales
    apply (clarsimp_all)
  proof -
    fix s
    assume "fp0_invar (graph_restrict G R) P s"
      and NC[simp]: "\<not>fp0.cond TYPE('b) (graph_restrict G R) P s"
    then interpret fp0_invar "graph_restrict G R" P s by simp

    {
      assume [simp]: "ppath s = None"

      from nc_discovered_eq_finished
      show "dom (discovered s) = dom (finished s)" by simp

      from nc_finished_eq_reachable
      have DFR[simp]: "dom (finished s) = reachable"
        by (simp add: reachable_def)

      from I have "g_E G `` R \<subseteq> R" unfolding restr_invar_def by auto

      have "reachable \<subseteq> (g_E G)\<^sup>* `` g_V0 G"
        unfolding reachable_def
        by (rule Image_mono, rule rtrancl_mono) (auto simp: rel_restrict_def)

      hence "R \<union> dom (finished s) = R \<union> (g_E G)\<^sup>* `` g_V0 G"
        apply -
        apply (rule equalityI)
        apply auto []
        unfolding DFR reachable_def
        apply (auto elim: E_closed_restr_reach_cases[OF _ \<open>g_E G `` R \<subseteq> R\<close>]) []
        done
      moreover from nc_fin_closed I
      have "g_E G `` (R \<union> dom (finished s)) \<subseteq> R \<union> dom (finished s)"
        unfolding restr_invar_def by (simp add: rel_restrict_def) blast
      moreover from no_path_no_P_discovered nc_discovered_eq_finished I
      have "(R \<union> dom (finished s)) \<inter> Collect P = {}"
        unfolding restr_invar_def by auto
      ultimately
      show "find_path0_restr_pred G P R (Inl (R \<union> dom (finished s)))"
        unfolding restr_invar_def find_path0_restr_pred_def by auto
    }

    {
      fix v vs
      assume [simp]: "ppath s = Some (vs,v)"
      from fp0_correct
      show "find_path0_restr_pred G P R (Inr (vs, v))"
        unfolding find_path0_restr_pred_def by auto
    }
  qed
qed

subsection \<open>Path of Minimal Length One, with Restriction\<close>
definition "find_path1_restr_pred G P R \<equiv> \<lambda>r.
      case r of
        Inl R' \<Rightarrow> R' = R \<union> (g_E G)\<^sup>+ `` g_V0 G \<and> restr_invar (g_E G) R' P
      | Inr (vs,v) \<Rightarrow> P v \<and> vs \<noteq> [] \<and> (\<exists> v0 \<in> g_V0 G. path (g_E G \<inter> UNIV \<times> -R) v0 vs v)"

definition find_path1_restr_spec
  \<comment> \<open>Find a path of length at least one to a target node that satisfies P.
    Takes an initial node restriction, and returns an extended node restriction.\<close>
  where "find_path1_restr_spec G P R \<equiv> do {
    ASSERT (fb_graph G \<and> restr_invar (g_E G) R P);
    SPEC (find_path1_restr_pred G P R)}"

lemmas find_path1_restr_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path1_restr_spec_def]
  ASSERT_leof_defI[OF find_path1_restr_spec_def]

definition find_path1_restr
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v set \<Rightarrow> 'v fpr_result nres"
  where "find_path1_restr G P R \<equiv>
  FOREACHc (g_V0 G) is_Inl (\<lambda>v0 s. do {
    ASSERT (is_Inl s); \<comment> \<open>TODO: Add FOREACH-condition as precondition in autoref!\<close>
    let R = projl s;
    f0 \<leftarrow> find_path0_restr_spec (G \<lparr> g_V0 := g_E G `` {v0} \<rparr>) P R;
    case f0 of
      Inl _ \<Rightarrow> RETURN f0
    | Inr (vs,v) \<Rightarrow> RETURN (Inr (v0#vs,v))
  }) (Inl R)"

definition "find_path1_tailrec_invar G P R0 it s \<equiv>
  case s of
    Inl R \<Rightarrow> R = R0 \<union> (g_E G)\<^sup>+ `` (g_V0 G - it) \<and> restr_invar (g_E G) R P
  | Inr (vs, v) \<Rightarrow> P v \<and> vs \<noteq> [] \<and> (\<exists> v0 \<in> g_V0 G - it. path (g_E G \<inter> UNIV \<times> -R0) v0 vs v)"

lemma find_path1_restr_correct:
  shows "find_path1_restr G P R \<le> find_path1_restr_spec G P R"
proof (rule le_ASSERT_defI1[OF find_path1_restr_spec_def], clarify)
  assume "fb_graph G"
  interpret a: fb_graph G by fact
  interpret fb0: fb_graph "G \<lparr> g_E := g_E G \<inter> UNIV \<times> -R \<rparr>"
    by (rule a.fb_graph_subset, auto)

  assume I: "restr_invar (g_E G) R P"

  have aux2: "\<And>v0. v0 \<in> g_V0 G \<Longrightarrow> fb_graph (G \<lparr> g_V0 := g_E G `` {v0} \<rparr>)"
    by (rule a.fb_graph_subset, auto)

  {
    fix v0 it s
    assume IT: "it \<subseteq> g_V0 G" "v0 \<in> it"
    and "is_Inl s"
    and FPI: "find_path1_tailrec_invar G P R it s"
    and RI: "restr_invar (g_E G) (projl s \<union> (g_E G)\<^sup>+ `` {v0}) P"

    then obtain R' where [simp]: "s = Inl R'" by (cases s) auto

    from FPI have [simp]: "R' = R \<union> (g_E G)\<^sup>+ `` (g_V0 G - it)"
      unfolding find_path1_tailrec_invar_def by simp

    have "find_path1_tailrec_invar G P R (it - {v0})
            (Inl (projl s \<union> (g_E G)\<^sup>+ `` {v0}))"
      using RI
      by (auto simp: find_path1_tailrec_invar_def it_step_insert_iff[OF IT])
  } note aux4 = this

  {
    fix v0 u it s v p
    assume IT: "it \<subseteq> g_V0 G" "v0 \<in> it"
    and "is_Inl s"
    and FPI: "find_path1_tailrec_invar G P R it s"
    and PV: "P v"
    and PATH: "path (rel_restrict (g_E G) (projl s)) u p v" "(v0,u)\<in>(g_E G)"
    and PR: "u \<notin> projl s"

    then obtain R' where [simp]: "s = Inl R'" by (cases s) auto

    from FPI have [simp]: "R' = R \<union> (g_E G)\<^sup>+ `` (g_V0 G - it)"
      unfolding find_path1_tailrec_invar_def by simp

    have "find_path1_tailrec_invar G P R (it - {v0}) (Inr (v0 # p, v))"
      apply (simp add: find_path1_tailrec_invar_def PV)
      apply (rule bexI[where x=v0])
        using PR PATH(2) path_mono[OF rel_restrict_mono2[of R] PATH(1)]
        apply (auto simp: path1_restr_conv) []

        using IT apply blast
      done
  } note aux5 = this

  show ?thesis
    unfolding find_path1_restr_def find_path1_restr_spec_def find_path1_restr_pred_def
    apply (refine_rcg le_ASSERTI
      refine_vcg FOREACHc_rule[where I="find_path1_tailrec_invar G P R"]
      (*order_trans[OF find_path0_restr_correct]*)
      )
    apply simp
    using I apply (auto simp add: find_path1_tailrec_invar_def restr_invar_def) []

    apply (blast intro: aux2)
    apply (auto simp add: find_path1_tailrec_invar_def split: sum.splits) []
    apply (auto
      simp: find_path0_restr_pred_def aux4 aux5
      simp: trancl_Image_unfold_left[symmetric]
      split: sum.splits) []

    apply (auto simp add: find_path1_tailrec_invar_def split: sum.splits) [2]
    done
qed

definition "find_path1_pred G P \<equiv> \<lambda>r.
      case r of
        None \<Rightarrow> (g_E G)\<^sup>+ `` g_V0 G \<inter> Collect P = {}
      | Some (vs, v) \<Rightarrow> P v \<and> vs \<noteq> [] \<and> (\<exists> v0 \<in> g_V0 G. path (g_E G) v0 vs v)"
definition find_path1_spec
  \<comment> \<open>Find a path of length at least one to a target node that satisfies
      a given predicate.\<close>
  where "find_path1_spec G P \<equiv> do {
    ASSERT (fb_graph G);
    SPEC (find_path1_pred G P)}"

lemmas find_path1_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path1_spec_def]
  ASSERT_leof_defI[OF find_path1_spec_def]

subsection \<open>Path of Minimal Length One, without Restriction\<close>
definition find_path1
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v fp_result nres"
  where "find_path1 G P \<equiv> do {
  r \<leftarrow> find_path1_restr_spec G P {};
  case r of
    Inl _ \<Rightarrow> RETURN None
  | Inr vsv \<Rightarrow> RETURN (Some vsv)
}"

lemma find_path1_correct:
  shows "find_path1 G P \<le> find_path1_spec G P"
  unfolding find_path1_def find_path1_spec_def find_path1_pred_def
  apply (refine_rcg refine_vcg le_ASSERTI order_trans[OF find_path1_restr_correct])
  apply simp
  apply (fastforce
    simp: find_path1_restr_spec_def find_path1_restr_pred_def
    split: sum.splits
    dest!: restr_invar_imp_not_reachable tranclD)
  done

subsection \<open>Implementation\<close>

(* Implementation with stack *)
record 'v fp0_state_impl = "'v simple_state" +
  ppath :: "('v list \<times> 'v) option"

definition "fp0_erel \<equiv> {
  (\<lparr> fp0_state_impl.ppath = p \<rparr>, \<lparr> fp0_state.ppath = p\<rparr>) | p. True }"

abbreviation "fp0_rel R \<equiv> \<langle>fp0_erel\<rangle>restr_simple_state_rel R"

abbreviation "no_path_impl \<equiv> \<lparr> fp0_state_impl.ppath = None \<rparr>"
abbreviation "a_path_impl p v \<equiv> \<lparr> fp0_state_impl.ppath = Some (p,v) \<rparr>"

lemma fp0_rel_ppath_cong[simp]:
  "(s,s')\<in>fp0_rel R \<Longrightarrow> fp0_state_impl.ppath s = fp0_state.ppath s'"
  unfolding restr_simple_state_rel_def fp0_erel_def
  by (cases s, cases s', auto)

lemma fp0_ss_rel_ppath_cong[simp]:
  "(s,s')\<in>\<langle>fp0_erel\<rangle>simple_state_rel \<Longrightarrow> fp0_state_impl.ppath s = fp0_state.ppath s'"
  unfolding simple_state_rel_def fp0_erel_def
  by (cases s, cases s', auto)

lemma fp0i_cong[cong]: "simple_state.more s = simple_state.more s'
  \<Longrightarrow> fp0_state_impl.ppath s = fp0_state_impl.ppath s'"
  by (cases s, cases s', auto)

lemma fp0_erelI: "p=p'
  \<Longrightarrow> (\<lparr> fp0_state_impl.ppath = p \<rparr>, \<lparr> fp0_state.ppath = p'\<rparr>)\<in>fp0_erel"
  unfolding fp0_erel_def by auto

definition fp0_params_impl
  :: "_ \<Rightarrow> ('v,'v fp0_state_impl,('v,unit)fp0_state_impl_ext) gen_parameterization"
where "fp0_params_impl P \<equiv> \<lparr>
  on_init = RETURN no_path_impl,
  on_new_root = \<lambda>v0 s.
    if P v0 then RETURN (a_path_impl [] v0) else RETURN no_path_impl,
  on_discover = \<lambda>u v s.
    if P v then RETURN (a_path_impl (map fst (rev (tl (CAST (ss_stack s))))) v)
    else RETURN no_path_impl,
  on_finish = \<lambda>u s. RETURN (simple_state.more s),
  on_back_edge = \<lambda>u v s. RETURN (simple_state.more s),
  on_cross_edge = \<lambda>u v s. RETURN (simple_state.more s),
  is_break = \<lambda>s. ppath s \<noteq> None \<rparr>"

lemmas fp0_params_impl_simp[simp, DFS_code_unfold]
  = gen_parameterization.simps[mk_record_simp, OF fp0_params_impl_def]

interpretation fp0_impl:
  restricted_impl_defs "fp0_params_impl P" "fp0_params P" G R
  for G P R .

locale fp0_restr = fb_graph
begin
  sublocale fp0?: fp0 "graph_restrict G R"
    apply (rule fp0I)
    apply (rule fb_graph_restrict)
    done

  sublocale impl: restricted_impl G "fp0_params P" "fp0_params_impl P"
    fp0_erel R
    apply unfold_locales
      apply parametricity

      apply (simp add: fp0_erel_def)
      apply (auto) [1]

      apply (auto
        simp: rev_map[symmetric] map_tl comp_def
        simp: fp0_erel_def simple_state_rel_def) [7]

      apply (auto simp: restr_rel_def) [3]
      apply (clarsimp simp: restr_rel_def)
      apply (rule IdD) apply (subst list_rel_id_simp[symmetric])
      apply parametricity
    done
end

definition "find_path0_restr_impl G P R \<equiv> do {
  ASSERT (fb_graph G);
  ASSERT (fp0 (graph_restrict G R));
  s \<leftarrow> fp0_impl.tailrec_impl TYPE('a) G R P;
  case ppath s of
    None \<Rightarrow> RETURN (Inl (visited s))
  | Some (vs,v) \<Rightarrow> RETURN (Inr (vs,v))
}"

lemma find_path0_restr_impl[refine]:
  shows "find_path0_restr_impl G P R
     \<le> \<Down>(\<langle>Id,Id\<times>\<^sub>rId\<rangle>sum_rel)
   (find_path0_restr G P R)"
proof (rule refine_ASSERT_defI2[OF find_path0_restr_def])
  assume "fb_graph G"
  then interpret fb_graph G .
  interpret fp0_restr G by unfold_locales

  show ?thesis
   unfolding find_path0_restr_impl_def find_path0_restr_def
   apply (refine_rcg impl.tailrec_refine)
   apply refine_dref_type
   apply (auto simp: restr_simple_state_rel_def)
   done
qed

definition "find_path0_impl G P \<equiv> do {
  ASSERT (fp0 G);
  s \<leftarrow> fp0_impl.tailrec_impl TYPE('a) G {} P;
  RETURN (ppath s)
}"

lemma find_path0_impl[refine]: "find_path0_impl G P
  \<le> \<Down> (\<langle>Id\<times>\<^sub>rId\<rangle>option_rel) (find_path0 G P)"
proof (rule refine_ASSERT_defI1[OF find_path0_def])
  assume "fp0 G"
  then interpret fp0 G .
  interpret r: fp0_restr G by unfold_locales

  show ?thesis
   unfolding find_path0_impl_def find_path0_def
   apply (refine_rcg r.impl.tailrec_refine[where R="{}", simplified])
   apply (auto)
   done
qed

subsection \<open>Synthesis of Executable Code\<close>
(* Autoref *)

record ('v,'si,'nsi)fp0_state_impl' = "('si,'nsi)simple_state_nos_impl" +
  ppath_impl :: "('v list \<times> 'v) option"

definition [to_relAPP]: "fp0_state_erel erel \<equiv> {
  (\<lparr>ppath_impl = pi, \<dots> =  mi\<rparr>,\<lparr>ppath = p, \<dots> = m\<rparr>) | pi mi p m.
    (pi,p)\<in>\<langle>\<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>option_rel \<and> (mi,m)\<in>erel}"

consts
  i_fp0_state_ext :: "interface \<Rightarrow> interface"

lemmas [autoref_rel_intf] = REL_INTFI[of fp0_state_erel i_fp0_state_ext]

term fp0_state_impl_ext
lemma [autoref_rules]:
  fixes ns_rel vis_rel erel
  defines "R \<equiv> \<langle>ns_rel,vis_rel,\<langle>erel\<rangle>fp0_state_erel\<rangle>ssnos_impl_rel"
  shows
    "(fp0_state_impl'_ext, fp0_state_impl_ext)
      \<in> \<langle>\<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>option_rel \<rightarrow> erel \<rightarrow> \<langle>erel\<rangle>fp0_state_erel"
    "(ppath_impl, fp0_state_impl.ppath) \<in> R \<rightarrow> \<langle>\<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>option_rel"
  unfolding fp0_state_erel_def ssnos_impl_rel_def R_def
  by auto

schematic_goal find_path0_code:
  fixes G :: "('v :: hashable, _) graph_rec_scheme"
  assumes [autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
    "(Pi, P) \<in> Id \<rightarrow> bool_rel"
  notes [autoref_tyrel] = TYRELI[where R="\<langle>Id::('v\<times>'v) set\<rangle>dflt_ahs_rel"]
  shows "(nres_of (?c::?'c dres), find_path0_impl G P) \<in> ?R"
  unfolding find_path0_impl_def[abs_def] DFS_code_unfold ssnos_unfolds
  unfolding if_cancel not_not comp_def nres_monad_laws
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done

concrete_definition find_path0_code uses find_path0_code
export_code find_path0_code checking SML

lemma find_path0_autoref_aux:
  assumes Vid: "Rv = (Id :: 'a :: hashable rel)"
  shows "(\<lambda>G P. nres_of (find_path0_code G P), find_path0_spec)
    \<in> \<langle>Rm, Rv\<rangle>g_impl_rel_ext \<rightarrow> (Rv \<rightarrow> bool_rel)
      \<rightarrow> \<langle>\<langle>\<langle>Rv\<rangle>list_rel \<times>\<^sub>r Rv\<rangle>option_rel\<rangle>nres_rel"
  apply (intro fun_relI nres_relI)
  unfolding Vid
  apply (rule
    order_trans[OF find_path0_code.refine[param_fo, THEN nres_relD]],
    assumption+
    )
  using find_path0_impl find_path0_correct
  apply (simp add: pw_le_iff refine_pw_simps)
  apply blast
  done
lemmas find_path0_autoref[autoref_rules] = find_path0_autoref_aux[OF PREFER_id_D]

schematic_goal find_path0_restr_code:
  fixes vis_rel :: "('v\<times>'v) set \<Rightarrow> ('visi\<times>'v set) set"
  notes [autoref_rel_intf] = REL_INTFI[of vis_rel "i_set" for I]
  assumes [autoref_rules]: "(op_vis_insert, insert)\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> \<langle>Id\<rangle>vis_rel"
  assumes [autoref_rules]: "(op_vis_memb, (\<in>))\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes [autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
    "(Pi,P)\<in>Id \<rightarrow> bool_rel"
    "(Ri,R)\<in>\<langle>Id\<rangle>vis_rel"
  shows "(nres_of (?c::?'c dres),
    find_path0_restr_impl
      G
      P
      (R:::\<^sub>r\<langle>Id\<rangle>vis_rel)) \<in> ?R"
  unfolding find_path0_restr_impl_def[abs_def] DFS_code_unfold ssnos_unfolds
  unfolding if_cancel not_not comp_def nres_monad_laws
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done

concrete_definition find_path0_restr_code uses find_path0_restr_code
export_code find_path0_restr_code checking SML

lemma find_path0_restr_autoref_aux:
  assumes 1: "(op_vis_insert, insert)\<in>Rv \<rightarrow> \<langle>Rv\<rangle>vis_rel \<rightarrow> \<langle>Rv\<rangle>vis_rel"
  assumes 2: "(op_vis_memb, (\<in>))\<in>Rv \<rightarrow> \<langle>Rv\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes Vid: "Rv = Id"
  shows "(\<lambda> G P R. nres_of (find_path0_restr_code op_vis_insert op_vis_memb G P R),
    find_path0_restr_spec)
    \<in> \<langle>Rm, Rv\<rangle>g_impl_rel_ext \<rightarrow> (Rv \<rightarrow> bool_rel) \<rightarrow> \<langle>Rv\<rangle>vis_rel \<rightarrow>
    \<langle>\<langle>\<langle>Rv\<rangle>vis_rel, \<langle>Rv\<rangle>list_rel \<times>\<^sub>r Rv\<rangle>sum_rel\<rangle>nres_rel"
  apply (intro fun_relI nres_relI)
  unfolding Vid
  apply (rule
    order_trans[OF find_path0_restr_code.refine[OF 1[unfolded Vid] 2[unfolded Vid], param_fo, THEN nres_relD]]
    )
  apply assumption+
  using find_path0_restr_impl find_path0_restr_correct
  apply (simp add: pw_le_iff refine_pw_simps)
  apply blast
  done
lemmas find_path0_restr_autoref[autoref_rules] = find_path0_restr_autoref_aux[OF GEN_OP_D GEN_OP_D PREFER_id_D]

schematic_goal find_path1_restr_code:
  fixes vis_rel :: "('v\<times>'v) set \<Rightarrow> ('visi\<times>'v set) set"
  notes [autoref_rel_intf] = REL_INTFI[of vis_rel "i_set" for I]
  assumes [autoref_rules]: "(op_vis_insert, insert)\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> \<langle>Id\<rangle>vis_rel"
  assumes [autoref_rules]: "(op_vis_memb, (\<in>))\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes [autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
    "(Pi,P)\<in>Id \<rightarrow> bool_rel"
    "(Ri,R)\<in>\<langle>Id\<rangle>vis_rel"
  shows "(nres_of ?c,find_path1_restr G P R)
  \<in> \<langle>\<langle>\<langle>Id\<rangle>vis_rel, \<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>sum_rel\<rangle>nres_rel"
  unfolding find_path1_restr_def[abs_def]
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done

concrete_definition find_path1_restr_code uses find_path1_restr_code
export_code find_path1_restr_code checking SML

lemma find_path1_restr_autoref_aux:
  assumes G: "(op_vis_insert, insert)\<in>V \<rightarrow> \<langle>V\<rangle>vis_rel \<rightarrow> \<langle>V\<rangle>vis_rel"
             "(op_vis_memb, (\<in>))\<in>V \<rightarrow> \<langle>V\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes Vid[simp]: "V=Id"
  shows "(\<lambda> G P R. nres_of (find_path1_restr_code op_vis_insert op_vis_memb G P R),find_path1_restr_spec)
  \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext \<rightarrow> (V \<rightarrow> bool_rel) \<rightarrow> \<langle>V\<rangle>vis_rel \<rightarrow>
    \<langle>\<langle>\<langle>V\<rangle>vis_rel, \<langle>V\<rangle>list_rel \<times>\<^sub>r V\<rangle>sum_rel\<rangle>nres_rel"

proof -
  note find_path1_restr_code.refine[OF G[simplified], param_fo, THEN nres_relD]
  also note find_path1_restr_correct
  finally show ?thesis by (force intro!: nres_relI)
qed

lemmas find_path1_restr_autoref[autoref_rules] = find_path1_restr_autoref_aux[OF GEN_OP_D GEN_OP_D PREFER_id_D]

schematic_goal find_path1_code:
  assumes Vid: "V = (Id :: 'a :: hashable rel)"
  assumes [unfolded Vid,autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext"
    "(Pi,P)\<in>V \<rightarrow> bool_rel"
  notes [autoref_tyrel] = TYRELI[where R="\<langle>(Id::('a\<times>'a::hashable)set)\<rangle>dflt_ahs_rel"]
  shows "(nres_of ?c,find_path1 G P)
  \<in> \<langle>\<langle>\<langle>V\<rangle>list_rel \<times>\<^sub>r V\<rangle>option_rel\<rangle>nres_rel"
  unfolding find_path1_def[abs_def] Vid
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done
concrete_definition find_path1_code uses find_path1_code

export_code find_path1_code checking SML

lemma find_path1_code_autoref_aux:
  assumes Vid: "V = (Id :: 'a :: hashable rel)"
  shows "(\<lambda> G P. nres_of (find_path1_code G P), find_path1_spec)
    \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext \<rightarrow> (V \<rightarrow> bool_rel) \<rightarrow> \<langle>\<langle>\<langle>V\<rangle>list_rel \<times>\<^sub>r V\<rangle>option_rel\<rangle>nres_rel"
proof -
  note find_path1_code.refine[OF Vid, param_fo, THEN nres_relD, simplified]
  also note find_path1_correct
  finally show ?thesis by (force intro!: nres_relI)
qed

lemmas find_path1_autoref[autoref_rules] = find_path1_code_autoref_aux[OF PREFER_id_D]

subsection \<open>Conclusion\<close>
text \<open>
  We have synthesized an efficient implementation for an algorithm to find a path
  to a reachable node that satisfies a predicate. The algorithm comes in four variants,
  with and without empty path, and with and without node restriction.

  We have set up the Autoref tool, to insert this algorithms for the following
  specifications:
  \<^item> @{term "find_path0_spec G P"} --- find path to node that satisfies @{term P}.
  \<^item> @{term "find_path1_spec G P"} --- find non-empty path to node that satisfies @{term P}.
  \<^item> @{term "find_path0_restr_spec G P R"} --- find path, with nodes from @{term R} already searched.
  \<^item> @{term "find_path1_restr_spec"} --- find non-empty path, with nodes from @{term R} already searched.

\<close>
thm find_path0_autoref
thm find_path1_autoref
thm find_path0_restr_autoref
thm find_path1_restr_autoref

end


(*:maxLineLen=78:*)

subsection \<open> Intuitionistic Logic \<close>

theory Intuitionistic_Logic
  imports implication_logic
begin

text \<open> This theory presents extends \<^emph>\<open>implicational intuitionistic logic\<close>
 to full \<^emph>\<open>intuitionistic logic\<close>.  Intuitionistic logic include binary logical
 connectives for \<^emph>\<open>conjunction\<close> and \<^emph>\<open>disjunction\<close> as well as \<^emph>\<open>negation\<close>,
 \<^emph>\<open>falsum\<close> and \<^emph>\<open>verum\<close>. \<close>

subsection \<open> Axiomatization \<close>

class Intuitionistic_Logic = implication_logic +
  fixes falsum :: "'a" ("\<bottom>")
  fixes verum :: "'a" ("\<top>")
  fixes negation :: "'a \<Rightarrow> 'a" ("\<sim>")
  fixes conjunction :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<sqinter>" 67)
  fixes disjunction :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<squnion>" 68)
  fixes biconditional :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<leftrightarrow>" 75)
  assumes Conjunction_Introduction: "\<turnstile> \<phi> \<rightarrow> \<psi> \<rightarrow> (\<phi> \<sqinter> \<psi>)"
  assumes Conjunction_Left_Elimination: "\<turnstile> (\<phi> \<sqinter> \<psi>) \<rightarrow> \<phi>"
  assumes Conjunction_Right_Elimination: "\<turnstile> (\<phi> \<sqinter> \<psi>) \<rightarrow> \<psi>"
  assumes Biconditional_Introduction: "\<turnstile> (\<phi> \<rightarrow> \<psi>) \<rightarrow> (\<psi> \<rightarrow> \<phi>) \<rightarrow> (\<phi> \<leftrightarrow> \<psi>)"
  assumes Biconditional_Left_Elimination: "\<turnstile> (\<phi> \<leftrightarrow> \<psi>) \<rightarrow> \<phi> \<rightarrow> \<psi>"
  assumes Biconditional_Right_Elimination: "\<turnstile> (\<phi> \<leftrightarrow> \<psi>) \<rightarrow> \<psi> \<rightarrow> \<phi>"
  assumes disjunction_elimination: "\<turnstile> (\<phi> \<rightarrow> \<chi>) \<rightarrow> (\<psi> \<rightarrow> \<chi>) \<rightarrow> (\<phi> \<squnion> \<psi>) \<rightarrow> \<chi>"
  assumes Disjunction_Left_Introduction: "\<turnstile> \<phi> \<rightarrow> (\<phi> \<squnion> \<psi>)"
  assumes Disjunction_Right_Introduction: "\<turnstile> \<psi> \<rightarrow> (\<phi> \<squnion> \<psi>)"
  assumes Negation_Introduction: "\<turnstile> (\<phi> \<rightarrow> \<bottom>) \<rightarrow> (\<sim> \<phi>)"
  assumes Negation_Elimination: "\<turnstile> \<sim> \<phi> \<rightarrow> \<phi> \<rightarrow> \<bottom>"
  assumes Verum_Rule: "\<turnstile> \<phi> \<rightarrow> \<top>"
  assumes ex_falso_quodlibet: "\<turnstile> \<bottom> \<rightarrow> \<phi>"

subsection \<open> Maximally Consistent Sets \<close>

theorem (in Intuitionistic_Logic) formula_maximally_consistent_set_def_conjunction:
  assumes "\<phi>-MCS \<Omega>"
  shows "(\<psi> \<sqinter> \<chi>) \<in> \<Omega> \<equiv> \<psi> \<in> \<Omega> \<and> \<chi> \<in> \<Omega>"
proof -
  {
    assume "(\<psi> \<sqinter> \<chi>) \<in> \<Omega>"
    hence "\<psi> \<in> \<Omega>" "\<chi> \<in> \<Omega>"
      using
        assms
        formula_maximally_consistent_set_def_reflection
        Conjunction_Right_Elimination
        Conjunction_Left_Elimination
        set_deduction_modus_ponens
        set_deduction_weaken
      by metis+
  }
  moreover
  {
    assume "\<psi> \<in> \<Omega> \<and> \<chi> \<in> \<Omega>"
    hence "(\<psi> \<sqinter> \<chi>) \<in> \<Omega>"
      using
        assms
        Set.set_insert
        insert_iff
        Conjunction_Introduction [where \<phi>="\<psi>" and \<psi>="\<chi>"]
        formula_maximally_consistent_set_def_reflection [where \<Gamma>="\<Omega>" and \<phi>="\<phi>"]
        modus_ponens
        implication_absorption
        set_deduction_theorem
        set_deduction_weaken
      by metis
  }
  ultimately show "(\<psi> \<sqinter> \<chi>) \<in> \<Omega> \<equiv> \<psi> \<in> \<Omega> \<and> \<chi> \<in> \<Omega>"
    by linarith
qed

lemma (in Intuitionistic_Logic) formula_maximally_consistent_set_def_disjunction:
  assumes "\<phi>-MCS \<Omega>"
  shows "(\<psi> \<squnion> \<chi>) \<in> \<Omega> \<equiv> \<psi> \<in> \<Omega> \<or> \<chi> \<in> \<Omega>"
proof -
  {
    assume "(\<psi> \<squnion> \<chi>) \<in> \<Omega>"
    {
      assume "\<psi> \<notin> \<Omega>" "\<chi> \<notin> \<Omega>"
      hence "\<Omega> \<tturnstile> \<psi> \<rightarrow> \<phi>" "\<Omega> \<tturnstile> \<chi> \<rightarrow> \<phi>"
        using assms formula_maximally_consistent_set_def_def set_deduction_reflection
        by blast+
      hence "\<Omega> \<tturnstile> \<phi>"
        using
          \<open>(\<psi> \<squnion> \<chi>) \<in> \<Omega>\<close>
          set_deduction_weaken [where \<Gamma>="\<Omega>"]
          set_deduction_modus_ponens [where \<Gamma>="\<Omega>"]
          set_deduction_reflection [where \<Gamma>="\<Omega>" and \<phi>="\<psi> \<squnion> \<chi>"]
          disjunction_elimination [where \<phi>="\<psi>" and \<psi>="\<chi>" and \<chi>="\<phi>"]
        by blast
      hence "False" using assms by simp
    }
    hence "\<psi> \<in> \<Omega> \<or> \<chi> \<in> \<Omega>" by blast
  }
  moreover
  {
    assume "\<psi> \<in> \<Omega> \<or> \<chi> \<in> \<Omega>"
    hence "(\<psi> \<squnion> \<chi>) \<in> \<Omega>"
      using
        assms
        formula_maximally_consistent_set_def_reflection
        Disjunction_Left_Introduction
        Disjunction_Right_Introduction
        set_deduction_modus_ponens
        set_deduction_weaken
      by blast
  }
  ultimately show "(\<psi> \<squnion> \<chi>) \<in> \<Omega> \<equiv> \<psi> \<in> \<Omega> \<or> \<chi> \<in> \<Omega>"
    by linarith
qed

lemma (in Intuitionistic_Logic) formula_maximally_consistent_set_def_verum:
  assumes "\<phi>-MCS \<Omega>"
  shows "\<top> \<in> \<Omega>"
  using
    assms
    formula_maximally_consistent_set_def_reflection
    modus_ponens
    Verum_Rule
    set_deduction_weaken
  by blast

lemma (in Intuitionistic_Logic) formula_maximally_consistent_set_def_falsum:
  assumes "\<phi>-MCS \<Omega>"
  shows "\<bottom> \<notin> \<Omega>"
  by (metis
        assms
        insert_Diff
        ex_falso_quodlibet
        formula_consistent_def
        formula_maximally_consistent_set_def_def
        set_deduction_theorem
        set_deduction_weaken)

lemma (in Intuitionistic_Logic) formula_maximally_consistent_set_def_negation:
  assumes "\<phi>-MCS \<Omega>"
  shows "\<psi> \<rightarrow> \<bottom> \<in> \<Omega> = (\<sim> \<psi> \<in> \<Omega>)"
  by (metis
        assms
        formula_maximally_consistent_set_def_reflection
        Negation_Elimination
        Negation_Introduction
        set_deduction_modus_ponens
        set_deduction_weaken)

theorem (in Intuitionistic_Logic) formula_maximally_consistent_set_def_biconditional_elimination:
  assumes "\<phi>-MCS \<Omega>"
  shows "(\<psi> \<leftrightarrow> \<chi>) \<in> \<Omega> \<Longrightarrow> \<psi> \<in> \<Omega> \<longleftrightarrow> \<chi> \<in> \<Omega>"
  by (meson
        assms
        formula_maximally_consistent_set_def_implication_elimination
        formula_maximally_consistent_set_def_reflection
        Biconditional_Left_Elimination
        Biconditional_Right_Elimination
        set_deduction_weaken)

end


section \<open>Relpow Implementation\<close>

theory Relpow_Meta_Impl
  imports "Transitive-Closure.Transitive_Closure_Impl"
begin

fun
  relpow_meta_impl :: "(('a * 'b) list \<Rightarrow> ('a * 'b) list ) \<Rightarrow>
(('a * 'b) list \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a * 'b) list \<Rightarrow> 'c \<Rightarrow> nat \<Rightarrow> 'c"
where
  "relpow_meta_impl succ un memb new have 0 = un new have" |
  "relpow_meta_impl succ un memb new have (Suc m) =
    (if new = [] then have
    else
      let
        maybe = succ new;
        have' = un new have;
        new' = filter (\<lambda>x. \<not> memb (fst x) have') maybe
      in relpow_meta_impl succ un memb new' have' m)"

abbreviation "keys \<equiv> map fst"

definition "valid_metas_set valid_meta as \<equiv> (\<forall>(k, v) \<in> as. valid_meta k v)"

locale relpow_data_structure =
  fixes un :: "('a * 'b) list \<Rightarrow> 'c \<Rightarrow> 'c"
    and set_of :: "'c \<Rightarrow> ('a * 'b) set"
    and memb :: "'a \<Rightarrow> 'c \<Rightarrow> bool"
    and empty :: 'c
    and valid_meta :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  assumes un: "fst ` set_of (un as m) = fst ` (set as \<union> set_of m)"
    and memb: "memb a m \<longleftrightarrow> (a \<in> fst ` (set_of m))"
    and empty: "set_of empty = {}"
    and un_valid_metas: "valid_metas_set valid_meta (set as) \<Longrightarrow> valid_metas_set valid_meta (set_of m)
          \<Longrightarrow> valid_metas_set valid_meta (set_of (un as m))"
begin

abbreviation "valid_metas \<equiv> valid_metas_set valid_meta"

abbreviation "keys_of m \<equiv> fst ` set_of m"

lemma valid_metas_empty: "valid_metas (set_of empty)"
  using valid_metas_set_def empty by auto

end

locale relpow_meta_succ =
  relpow_data_structure un set_of memb empty valid_meta
  for un :: "('a * 'b) list \<Rightarrow> 'c \<Rightarrow> 'c" and set_of memb empty valid_meta +
  fixes succ :: "('a * 'b) list \<Rightarrow> ('a * 'b) list"
    and succ_rel :: "('a * 'a) set"
  assumes succ_rel: "fst ` (set (succ as)) = {b. \<exists>a \<in> fst ` (set as). (a, b) \<in> succ_rel}"
    and succ_valid_metas: "valid_metas_set valid_meta (set as) \<Longrightarrow> valid_metas_set valid_meta (set (succ as))"
begin

abbreviation "add_undef_meta \<equiv> map (\<lambda>a. (a,undefined))"

definition "succ' as \<equiv> keys (succ (add_undef_meta as))"

definition "un' as \<equiv> un (add_undef_meta as)"

sublocale relpow': set_access_succ keys_of memb empty un' succ' succ_rel
  by (unfold_locales,
      auto simp: un memb empty succ_rel succ'_def un'_def,
      force)

definition "eq_new new new' \<equiv> set (keys new) = set new'"

lemma succ_eq: "eq_new new new' \<Longrightarrow> eq_new (succ new) (succ' new')"
  using succ_rel by (auto simp add: eq_new_def succ'_def) fastforce

lemma un_eq: "eq_new as as' \<Longrightarrow> keys_of bs = keys_of bs'
  \<Longrightarrow> keys_of (un as bs) = keys_of (un' as' bs')"
  using relpow'.un by (auto simp add: eq_new_def un'_def un)

lemma relpow_relpow'_aux: "eq_new new new' \<Longrightarrow> keys_of have = keys_of have'
  \<Longrightarrow> keys_of (relpow_meta_impl succ un memb new have n)
    = keys_of (relpow_impl succ' un' memb new' have' n)"
proof (induction n arbitrary: "have" have' new new')
  case 0
  then show ?case by (simp add: un_eq)
next
  case (Suc n)
  then show ?case
  proof (cases "new = []")
    case True
    then have "new' = []" using Suc.prems(1) by (auto simp: eq_new_def)
    then show ?thesis using True Suc.prems(2) by simp
  next
    case False
    then have new': "new' \<noteq> []" using Suc.prems(1) by (auto simp: eq_new_def)
    let ?maybe1 = "succ new"
    let ?maybe2 = "succ' new'"
    have maybe_eq: "eq_new ?maybe1 ?maybe2" using Suc.prems(1) by (simp add: succ_eq)
    let ?have1 = "un new have"
    let ?have2 = "un' new' have'"
    have have'_eq: "keys_of ?have1 = keys_of ?have2" using Suc.prems by (auto simp: un_eq)
    let ?new1 = "filter (\<lambda>x. \<not> memb (fst x) ?have1) ?maybe1"
    let ?new2 = "filter (\<lambda>x. \<not> memb x ?have2) ?maybe2"
    have new'_eq: "eq_new ?new1 ?new2" using maybe_eq have'_eq eq_new_def relpow'.memb by (auto simp: eq_new_def)
    show ?thesis using Suc.IH[OF new'_eq have'_eq] False new' by (simp add: Let_def)
  qed
qed

lemma relpow_relpow': "keys_of (relpow_meta_impl succ un memb new have n)
    = keys_of (relpow_impl succ' un' memb (keys new) have n)"
  by (simp add: eq_new_def relpow_relpow'_aux)

theorem trancl_meta_impl: "keys_of (relpow_meta_impl succ un memb new empty n)
      = {b | a b m. a \<in> fst ` set new \<and> m \<le> n \<and> (a, b) \<in> succ_rel ^^ m}"
  by (simp add: relpow_relpow' relpow'.relpow_impl)

lemma relpow_valid_metas_gen: "valid_metas (set_of have) \<Longrightarrow> valid_metas (set new)
  \<Longrightarrow> valid_metas (set_of (relpow_meta_impl succ un memb new have n))"
proof (induction n arbitrary: new "have")
  case 0
  then show ?case by (simp add: un_valid_metas)
next
  case (Suc n)
  let ?have' = "un new have"
  have valid_have': "valid_metas (set_of ?have')" by (simp add: un_valid_metas Suc.prems)
  let ?new' = "filter (\<lambda>x. \<not> memb (fst x) ?have') (succ new)"
  have "valid_metas (set (succ new))" using succ_valid_metas Suc.prems by auto
  hence valid_new': "valid_metas (set ?new')" using filter_is_subset by (auto simp: valid_metas_set_def)
  then show ?case using Suc.IH Suc valid_have' valid_new' by (simp add: Let_def)
qed

theorem relpow_valid_metas: "valid_metas (set new) \<Longrightarrow> valid_metas (set_of (relpow_meta_impl succ un memb new empty n))"
  using relpow_valid_metas_gen valid_metas_empty by blast

end

end


(*  Title:      HOL/Eisbach/Examples_FOL.thy
    Author:     Daniel Matichuk, NICTA/UNSW
*)

section \<open>Basic Eisbach examples (in FOL)\<close>

theory Examples_FOL
imports FOL Eisbach_Old_Appl_Syntax
begin

subsection \<open>Basic methods\<close>

method my_intros = (rule conjI | rule impI)

lemma "P \<and> Q \<longrightarrow> Z \<and> X"
  apply my_intros+
  oops

method my_intros' uses intros = (rule conjI | rule impI | rule intros)

lemma "P \<and> Q \<longrightarrow> Z \<or> X"
  apply (my_intros' intros: disjI1)+
  oops

method my_spec for x :: 'a = (drule spec[where x="x"])

lemma "\<forall>x. P(x) \<Longrightarrow> P(x)"
  apply (my_spec x)
  apply assumption
  done

subsection \<open>Demo\<close>

named_theorems intros and elims and subst

method prop_solver declares intros elims subst =
  (assumption |
    rule intros | erule elims |
    subst subst | subst (asm) subst |
    (erule notE; solves prop_solver))+

lemmas [intros] =
  conjI
  impI
  disjCI
  iffI
  notI
lemmas [elims] =
  impCE
  conjE
  disjE

lemma "((A \<or> B) \<and> (A \<longrightarrow> C) \<and> (B \<longrightarrow> C)) \<longrightarrow> C"
  apply prop_solver
  done

method guess_all =
  (match premises in U[thin]:"\<forall>x. P (x :: 'a)" for P \<Rightarrow>
    \<open>match premises in "?H (y :: 'a)" for y \<Rightarrow>
       \<open>rule allE[where P = P and x = y, OF U]\<close>
   | match conclusion in "?H (y :: 'a)" for y \<Rightarrow>
       \<open>rule allE[where P = P and x = y, OF U]\<close>\<close>)

lemma "(\<forall>x. P(x) \<longrightarrow> Q(x)) \<Longrightarrow> P(y) \<Longrightarrow> Q(y)"
  apply guess_all
  apply prop_solver
  done

lemma "(\<forall>x. P(x) \<longrightarrow> Q(x)) \<Longrightarrow>  P(z) \<Longrightarrow> P(y) \<Longrightarrow> Q(y)"
  apply (solves \<open>guess_all, prop_solver\<close>)  \<comment> \<open>Try it without solve\<close>
  done

method guess_ex =
  (match conclusion in
    "\<exists>x. P (x :: 'a)" for P \<Rightarrow>
      \<open>match premises in "?H (x :: 'a)" for x \<Rightarrow>
              \<open>rule exI[where x=x]\<close>\<close>)

lemma "P(x) \<Longrightarrow> \<exists>x. P(x)"
  apply guess_ex
  apply prop_solver
  done

method fol_solver =
  ((guess_ex | guess_all | prop_solver); solves fol_solver)

declare
  allI [intros]
  exE [elims]
  ex_simps [subst]
  all_simps [subst]

lemma "(\<forall>x. P(x)) \<and> (\<forall>x. Q(x)) \<Longrightarrow> (\<forall>x. P(x) \<and> Q(x))"
  and  "\<exists>x. P(x) \<longrightarrow> (\<forall>x. P(x))"
  and "(\<exists>x. \<forall>y. R(x, y)) \<longrightarrow> (\<forall>y. \<exists>x. R(x, y))"
  by fol_solver+

end


(*  Title:      HOL/HOLCF/Library/Stream.thy
    Author:     Franz Regensburger, David von Oheimb, Borislav Gajanovic
*)

section \<open>General Stream domain\<close>

theory Stream
imports HOLCF "HOL-Library.Extended_Nat"
begin

default_sort pcpo

domain (unsafe) 'a stream = scons (ft::'a) (lazy rt::"'a stream") (infixr "&&" 65)

definition
  smap :: "('a \<rightarrow> 'b) \<rightarrow> 'a stream \<rightarrow> 'b stream" where
  "smap = fix\<cdot>(\<Lambda> h f s. case s of x && xs \<Rightarrow> f\<cdot>x && h\<cdot>f\<cdot>xs)"

definition
  sfilter :: "('a \<rightarrow> tr) \<rightarrow> 'a stream \<rightarrow> 'a stream" where
  "sfilter = fix\<cdot>(\<Lambda> h p s. case s of x && xs \<Rightarrow>
                                     If p\<cdot>x then x && h\<cdot>p\<cdot>xs else h\<cdot>p\<cdot>xs)"

definition
  slen :: "'a stream \<Rightarrow> enat"  ("#_" [1000] 1000) where
  "#s = (if stream_finite s then enat (LEAST n. stream_take n\<cdot>s = s) else \<infinity>)"

(* concatenation *)

definition
  i_rt :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where (* chops the first i elements *)
  "i_rt = (\<lambda>i s. iterate i\<cdot>rt\<cdot>s)"

definition
  i_th :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a" where (* the i-th element *)
  "i_th = (\<lambda>i s. ft\<cdot>(i_rt i s))"

definition
  sconc :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream"  (infixr "ooo" 65) where
  "s1 ooo s2 = (case #s1 of
                  enat n \<Rightarrow> (SOME s. (stream_take n\<cdot>s = s1) \<and> (i_rt n s = s2))
               | \<infinity>     \<Rightarrow> s1)"

primrec constr_sconc' :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
where
  constr_sconc'_0:   "constr_sconc' 0 s1 s2 = s2"
| constr_sconc'_Suc: "constr_sconc' (Suc n) s1 s2 = ft\<cdot>s1 && constr_sconc' n (rt\<cdot>s1) s2"

definition
  constr_sconc  :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where (* constructive *)
  "constr_sconc s1 s2 = (case #s1 of
                          enat n \<Rightarrow> constr_sconc' n s1 s2
                        | \<infinity>    \<Rightarrow> s1)"

(* ----------------------------------------------------------------------- *)
(* theorems about scons                                                    *)
(* ----------------------------------------------------------------------- *)

section "scons"

lemma scons_eq_UU: "(a && s = UU) = (a = UU)"
by simp

lemma scons_not_empty: "\<lbrakk>a && x = UU; a \<noteq> UU\<rbrakk> \<Longrightarrow> R"
by simp

lemma stream_exhaust_eq: "x \<noteq> UU \<longleftrightarrow> (\<exists>a y. a \<noteq> UU \<and> x = a && y)"
by (cases x, auto)

lemma stream_neq_UU: "x \<noteq> UU \<Longrightarrow> \<exists>a a_s. x = a && a_s \<and> a \<noteq> UU"
by (simp add: stream_exhaust_eq,auto)

lemma stream_prefix:
  "\<lbrakk>a && s \<sqsubseteq> t; a \<noteq> UU\<rbrakk> \<Longrightarrow> \<exists>b tt. t = b && tt \<and> b \<noteq> UU \<and> s \<sqsubseteq> tt"
by (cases t, auto)

lemma stream_prefix':
  "b \<noteq> UU \<Longrightarrow> x \<sqsubseteq> b && z =
   (x = UU \<or> (\<exists>a y. x = a && y \<and> a \<noteq> UU \<and> a \<sqsubseteq> b \<and> y \<sqsubseteq> z))"
by (cases x, auto)

(*
lemma stream_prefix1: "\<lbrakk>x \<sqsubseteq> y; xs \<sqsubseteq> ys\<rbrakk> \<Longrightarrow> x && xs \<sqsubseteq> y && ys"
by (insert stream_prefix' [of y "x && xs" ys],force)
*)

lemma stream_flat_prefix:
  "\<lbrakk>x && xs \<sqsubseteq> y && ys; (x::'a::flat) \<noteq> UU\<rbrakk> \<Longrightarrow> x = y \<and> xs \<sqsubseteq> ys"
apply (case_tac "y = UU",auto)
apply (drule ax_flat,simp)
done

(* ----------------------------------------------------------------------- *)
(* theorems about stream_case                                              *)
(* ----------------------------------------------------------------------- *)

section "stream_case"

lemma stream_case_strictf: "stream_case\<cdot>UU\<cdot>s = UU"
by (cases s, auto)

(* ----------------------------------------------------------------------- *)
(* theorems about ft and rt                                                *)
(* ----------------------------------------------------------------------- *)

section "ft and rt"

lemma ft_defin: "s \<noteq> UU \<Longrightarrow> ft\<cdot>s \<noteq> UU"
by simp

lemma rt_strict_rev: "rt\<cdot>s \<noteq> UU \<Longrightarrow> s \<noteq> UU"
by auto

lemma surjectiv_scons: "(ft\<cdot>s) && (rt\<cdot>s) = s"
by (cases s, auto)

lemma monofun_rt_mult: "x \<sqsubseteq> s \<Longrightarrow> iterate i\<cdot>rt\<cdot>x \<sqsubseteq> iterate i\<cdot>rt\<cdot>s"
by (rule monofun_cfun_arg)

(* ----------------------------------------------------------------------- *)
(* theorems about stream_take                                              *)
(* ----------------------------------------------------------------------- *)

section "stream_take"

lemma stream_reach2: "(LUB i. stream_take i\<cdot>s) = s"
by (rule stream.reach)

lemma chain_stream_take: "chain (\<lambda>i. stream_take i\<cdot>s)"
by simp

lemma stream_take_prefix [simp]: "stream_take n\<cdot>s \<sqsubseteq> s"
apply (insert stream_reach2 [of s])
apply (erule subst) back
apply (rule is_ub_thelub)
apply (simp only: chain_stream_take)
done

lemma stream_take_more [rule_format]:
  "\<forall>x. stream_take n\<cdot>x = x \<longrightarrow> stream_take (Suc n)\<cdot>x = x"
apply (induct_tac n,auto)
apply (case_tac "x=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1],auto)
done

lemma stream_take_lemma3 [rule_format]:
  "\<forall>x xs. x \<noteq> UU \<longrightarrow> stream_take n\<cdot>(x && xs) = x && xs \<longrightarrow> stream_take n\<cdot>xs = xs"
apply (induct_tac n,clarsimp)
(*apply (drule sym, erule scons_not_empty, simp)*)
apply (clarify, rule stream_take_more)
apply (erule_tac x="x" in allE)
apply (erule_tac x="xs" in allE,simp)
done

lemma stream_take_lemma4:
  "\<forall>x xs. stream_take n\<cdot>xs = xs \<longrightarrow> stream_take (Suc n)\<cdot>(x && xs) = x && xs"
by auto

lemma stream_take_idempotent [rule_format, simp]:
  "\<forall>s. stream_take n\<cdot>(stream_take n\<cdot>s) = stream_take n\<cdot>s"
apply (induct_tac n, auto)
apply (case_tac "s=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
done

lemma stream_take_take_Suc [rule_format, simp]:
  "\<forall>s. stream_take n\<cdot>(stream_take (Suc n)\<cdot>s) = stream_take n\<cdot>s"
apply (induct_tac n, auto)
apply (case_tac "s=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
done

lemma mono_stream_take_pred:
  "stream_take (Suc n)\<cdot>s1 \<sqsubseteq> stream_take (Suc n)\<cdot>s2 \<Longrightarrow>
                       stream_take n\<cdot>s1 \<sqsubseteq> stream_take n\<cdot>s2"
by (insert monofun_cfun_arg [of "stream_take (Suc n)\<cdot>s1"
  "stream_take (Suc n)\<cdot>s2" "stream_take n"], auto)
(*
lemma mono_stream_take_pred:
  "stream_take (Suc n)\<cdot>s1 \<sqsubseteq> stream_take (Suc n)\<cdot>s2 \<Longrightarrow>
                       stream_take n\<cdot>s1 \<sqsubseteq> stream_take n\<cdot>s2"
by (drule mono_stream_take [of _ _ n],simp)
*)

lemma stream_take_lemma10 [rule_format]:
  "\<forall>k\<le>n. stream_take n\<cdot>s1 \<sqsubseteq> stream_take n\<cdot>s2 \<longrightarrow> stream_take k\<cdot>s1 \<sqsubseteq> stream_take k\<cdot>s2"
apply (induct_tac n,simp,clarsimp)
apply (case_tac "k=Suc n",blast)
apply (erule_tac x="k" in allE)
apply (drule mono_stream_take_pred,simp)
done

lemma stream_take_le_mono : "k \<le> n \<Longrightarrow> stream_take k\<cdot>s1 \<sqsubseteq> stream_take n\<cdot>s1"
apply (insert chain_stream_take [of s1])
apply (drule chain_mono,auto)
done

lemma mono_stream_take: "s1 \<sqsubseteq> s2 \<Longrightarrow> stream_take n\<cdot>s1 \<sqsubseteq> stream_take n\<cdot>s2"
by (simp add: monofun_cfun_arg)

(*
lemma stream_take_prefix [simp]: "stream_take n\<cdot>s \<sqsubseteq> s"
apply (subgoal_tac "s=(LUB n. stream_take n\<cdot>s)")
 apply (erule ssubst, rule is_ub_thelub)
 apply (simp only: chain_stream_take)
by (simp only: stream_reach2)
*)

lemma stream_take_take_less:"stream_take k\<cdot>(stream_take n\<cdot>s) \<sqsubseteq> stream_take k\<cdot>s"
by (rule monofun_cfun_arg,auto)

(* ------------------------------------------------------------------------- *)
(* special induction rules                                                   *)
(* ------------------------------------------------------------------------- *)

section "induction"

lemma stream_finite_ind:
  "\<lbrakk>stream_finite x; P UU; \<And>a s. \<lbrakk>a \<noteq> UU; P s\<rbrakk> \<Longrightarrow> P (a && s)\<rbrakk> \<Longrightarrow> P x"
apply (simp add: stream.finite_def,auto)
apply (erule subst)
apply (drule stream.finite_induct [of P _ x], auto)
done

lemma stream_finite_ind2:
  "\<lbrakk>P UU; \<And>x. x \<noteq> UU \<Longrightarrow> P (x && UU); \<And>y z s. \<lbrakk>y \<noteq> UU; z \<noteq> UU; P s\<rbrakk> \<Longrightarrow> P (y && z && s)\<rbrakk> \<Longrightarrow>
                                 \<forall>s. P (stream_take n\<cdot>s)"
apply (rule nat_less_induct [of _ n],auto)
apply (case_tac n, auto)
apply (case_tac nat, auto)
apply (case_tac "s=UU",clarsimp)
apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
apply (case_tac "s=UU",clarsimp)
apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
apply (case_tac "y=UU",clarsimp)
apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
done

lemma stream_ind2:
"\<lbrakk> adm P; P UU; \<And>a. a \<noteq> UU \<Longrightarrow> P (a && UU); \<And>a b s. \<lbrakk>a \<noteq> UU; b \<noteq> UU; P s\<rbrakk> \<Longrightarrow> P (a && b && s)\<rbrakk> \<Longrightarrow> P x"
apply (insert stream.reach [of x],erule subst)
apply (erule admD, rule chain_stream_take)
apply (insert stream_finite_ind2 [of P])
by simp

(* ----------------------------------------------------------------------- *)
(* simplify use of coinduction                                             *)
(* ----------------------------------------------------------------------- *)

section "coinduction"

lemma stream_coind_lemma2: "\<forall>s1 s2. R s1 s2 \<longrightarrow> ft\<cdot>s1 = ft\<cdot>s2 \<and> R (rt\<cdot>s1) (rt\<cdot>s2) \<Longrightarrow> stream_bisim R"
 apply (simp add: stream.bisim_def,clarsimp)
 apply (drule spec, drule spec, drule (1) mp)
 apply (case_tac "x", simp)
 apply (case_tac "y", simp)
 apply auto
 done

(* ----------------------------------------------------------------------- *)
(* theorems about stream_finite                                            *)
(* ----------------------------------------------------------------------- *)

section "stream_finite"

lemma stream_finite_UU [simp]: "stream_finite UU"
by (simp add: stream.finite_def)

lemma stream_finite_UU_rev: "\<not> stream_finite s \<Longrightarrow> s \<noteq> UU"
by (auto simp add: stream.finite_def)

lemma stream_finite_lemma1: "stream_finite xs \<Longrightarrow> stream_finite (x && xs)"
apply (simp add: stream.finite_def,auto)
apply (rule_tac x="Suc n" in exI)
apply (simp add: stream_take_lemma4)
done

lemma stream_finite_lemma2: "\<lbrakk>x \<noteq> UU; stream_finite (x && xs)\<rbrakk> \<Longrightarrow> stream_finite xs"
apply (simp add: stream.finite_def, auto)
apply (rule_tac x="n" in exI)
apply (erule stream_take_lemma3,simp)
done

lemma stream_finite_rt_eq: "stream_finite (rt\<cdot>s) = stream_finite s"
apply (cases s, auto)
apply (rule stream_finite_lemma1, simp)
apply (rule stream_finite_lemma2,simp)
apply assumption
done

lemma stream_finite_less: "stream_finite s \<Longrightarrow> \<forall>t. t \<sqsubseteq> s \<longrightarrow> stream_finite t"
apply (erule stream_finite_ind [of s], auto)
apply (case_tac "t=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1],auto)
apply (erule_tac x="y" in allE, simp)
apply (rule stream_finite_lemma1, simp)
done

lemma stream_take_finite [simp]: "stream_finite (stream_take n\<cdot>s)"
apply (simp add: stream.finite_def)
apply (rule_tac x="n" in exI,simp)
done

lemma adm_not_stream_finite: "adm (\<lambda>x. \<not> stream_finite x)"
apply (rule adm_upward)
apply (erule contrapos_nn)
apply (erule (1) stream_finite_less [rule_format])
done

(* ----------------------------------------------------------------------- *)
(* theorems about stream length                                            *)
(* ----------------------------------------------------------------------- *)

section "slen"

lemma slen_empty [simp]: "#\<bottom> = 0"
by (simp add: slen_def stream.finite_def zero_enat_def Least_equality)

lemma slen_scons [simp]: "x \<noteq> \<bottom> \<Longrightarrow> #(x && xs) = eSuc (#xs)"
apply (case_tac "stream_finite (x && xs)")
apply (simp add: slen_def, auto)
apply (simp add: stream.finite_def, auto simp add: eSuc_enat)
apply (rule Least_Suc2, auto)
(*apply (drule sym)*)
(*apply (drule sym scons_eq_UU [THEN iffD1],simp)*)
apply (erule stream_finite_lemma2, simp)
apply (simp add: slen_def, auto)
apply (drule stream_finite_lemma1,auto)
done

lemma slen_less_1_eq: "(#x < enat (Suc 0)) = (x = \<bottom>)"
by (cases x) (auto simp add: enat_0 eSuc_enat[THEN sym])

lemma slen_empty_eq: "(#x = 0) = (x = \<bottom>)"
by (cases x) auto

lemma slen_scons_eq: "(enat (Suc n) < #x) = (\<exists>a y. x = a && y \<and> a \<noteq> \<bottom> \<and> enat n < #y)"
apply (auto, case_tac "x=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (case_tac "#y") apply simp_all
apply (case_tac "#y") apply simp_all
done

lemma slen_eSuc: "#x = eSuc n \<longrightarrow> (\<exists>a y. x = a && y \<and> a \<noteq> \<bottom> \<and> #y = n)"
by (cases x) auto

lemma slen_stream_take_finite [simp]: "#(stream_take n\<cdot>s) \<noteq> \<infinity>"
by (simp add: slen_def)

lemma slen_scons_eq_rev: "#x < enat (Suc (Suc n)) \<longleftrightarrow> (\<forall>a y. x \<noteq> a && y \<or> a = \<bottom> \<or> #y < enat (Suc n))"
 apply (cases x, auto)
   apply (simp add: zero_enat_def)
  apply (case_tac "#stream") apply (simp_all add: eSuc_enat)
 apply (case_tac "#stream") apply (simp_all add: eSuc_enat)
done

lemma slen_take_lemma4 [rule_format]:
  "\<forall>s. stream_take n\<cdot>s \<noteq> s \<longrightarrow> #(stream_take n\<cdot>s) = enat n"
apply (induct n, auto simp add: enat_0)
apply (case_tac "s=UU", simp)
apply (drule stream_exhaust_eq [THEN iffD1], auto simp add: eSuc_enat)
done

(*
lemma stream_take_idempotent [simp]:
 "stream_take n\<cdot>(stream_take n\<cdot>s) = stream_take n\<cdot>s"
apply (case_tac "stream_take n\<cdot>s = s")
apply (auto,insert slen_take_lemma4 [of n s]);
by (auto,insert slen_take_lemma1 [of "stream_take n\<cdot>s" n],simp)

lemma stream_take_take_Suc [simp]: "stream_take n\<cdot>(stream_take (Suc n)\<cdot>s) =
                                    stream_take n\<cdot>s"
apply (simp add: po_eq_conv,auto)
 apply (simp add: stream_take_take_less)
apply (subgoal_tac "stream_take n\<cdot>s = stream_take n\<cdot>(stream_take n\<cdot>s)")
 apply (erule ssubst)
 apply (rule_tac monofun_cfun_arg)
 apply (insert chain_stream_take [of s])
by (simp add: chain_def,simp)
*)

lemma slen_take_eq: "\<forall>x. enat n < #x \<longleftrightarrow> stream_take n\<cdot>x \<noteq> x"
apply (induct_tac n, auto)
apply (simp add: enat_0, clarsimp)
apply (drule not_sym)
apply (drule slen_empty_eq [THEN iffD1], simp)
apply (case_tac "x=UU", simp)
apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
apply (erule_tac x="y" in allE, auto)
apply (simp_all add: not_less eSuc_enat)
apply (case_tac "#y") apply simp_all
apply (case_tac "x=UU", simp)
apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
apply (erule_tac x="y" in allE, simp)
apply (case_tac "#y")
apply simp_all
done

lemma slen_take_eq_rev: "#x \<le> enat n \<longleftrightarrow> stream_take n\<cdot>x = x"
by (simp add: linorder_not_less [symmetric] slen_take_eq)

lemma slen_take_lemma1: "#x = enat n \<Longrightarrow> stream_take n\<cdot>x = x"
by (rule slen_take_eq_rev [THEN iffD1], auto)

lemma slen_rt_mono: "#s2 \<le> #s1 \<Longrightarrow> #(rt\<cdot>s2) \<le> #(rt\<cdot>s1)"
apply (cases s1)
 apply (cases s2, simp+)+
done

lemma slen_take_lemma5: "#(stream_take n\<cdot>s) \<le> enat n"
apply (case_tac "stream_take n\<cdot>s = s")
 apply (simp add: slen_take_eq_rev)
apply (simp add: slen_take_lemma4)
done

lemma slen_take_lemma2: "\<forall>x. \<not> stream_finite x \<longrightarrow> #(stream_take i\<cdot>x) = enat i"
apply (simp add: stream.finite_def, auto)
apply (simp add: slen_take_lemma4)
done

lemma slen_infinite: "stream_finite x \<longleftrightarrow> #x \<noteq> \<infinity>"
by (simp add: slen_def)

lemma slen_mono_lemma: "stream_finite s \<Longrightarrow> \<forall>t. s \<sqsubseteq> t \<longrightarrow> #s \<le> #t"
apply (erule stream_finite_ind [of s], auto)
apply (case_tac "t = UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
done

lemma slen_mono: "s \<sqsubseteq> t \<Longrightarrow> #s \<le> #t"
apply (case_tac "stream_finite t")
apply (frule stream_finite_less)
apply (erule_tac x="s" in allE, simp)
apply (drule slen_mono_lemma, auto)
apply (simp add: slen_def)
done

lemma iterate_lemma: "F\<cdot>(iterate n\<cdot>F\<cdot>x) = iterate n\<cdot>F\<cdot>(F\<cdot>x)"
by (insert iterate_Suc2 [of n F x], auto)

lemma slen_rt_mult [rule_format]: "\<forall>x. enat (i + j) \<le> #x \<longrightarrow> enat j \<le> #(iterate i\<cdot>rt\<cdot>x)"
apply (induct i, auto)
apply (case_tac "x = UU", auto simp add: zero_enat_def)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (erule_tac x = "y" in allE, auto)
apply (simp add: not_le) apply (case_tac "#y") apply (simp_all add: eSuc_enat)
apply (simp add: iterate_lemma)
done

lemma slen_take_lemma3 [rule_format]:
  "\<forall>(x::'a::flat stream) y. enat n \<le> #x \<longrightarrow> x \<sqsubseteq> y \<longrightarrow> stream_take n\<cdot>x = stream_take n\<cdot>y"
apply (induct_tac n, auto)
apply (case_tac "x=UU", auto)
apply (simp add: zero_enat_def)
apply (simp add: Suc_ile_eq)
apply (case_tac "y=UU", clarsimp)
apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)+
apply (erule_tac x="ya" in allE, simp)
by (drule ax_flat, simp)

lemma slen_strict_mono_lemma:
  "stream_finite t \<Longrightarrow> \<forall>s. #(s::'a::flat stream) = #t \<and> s \<sqsubseteq> t \<longrightarrow> s = t"
apply (erule stream_finite_ind, auto)
apply (case_tac "sa = UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
apply (drule ax_flat, simp)
done

lemma slen_strict_mono: "\<lbrakk>stream_finite t; s \<noteq> t; s \<sqsubseteq> (t::'a::flat stream)\<rbrakk> \<Longrightarrow> #s < #t"
by (auto simp add: slen_mono less_le dest: slen_strict_mono_lemma)

lemma stream_take_Suc_neq: "stream_take (Suc n)\<cdot>s \<noteq> s \<Longrightarrow>
                     stream_take n\<cdot>s \<noteq> stream_take (Suc n)\<cdot>s"
apply auto
apply (subgoal_tac "stream_take n\<cdot>s \<noteq> s")
 apply (insert slen_take_lemma4 [of n s],auto)
apply (cases s, simp)
apply (simp add: slen_take_lemma4 eSuc_enat)
done

(* ----------------------------------------------------------------------- *)
(* theorems about smap                                                     *)
(* ----------------------------------------------------------------------- *)

section "smap"

lemma smap_unfold: "smap = (\<Lambda> f t. case t of x && xs \<Rightarrow> f\<cdot>x && smap\<cdot>f\<cdot>xs)"
by (insert smap_def [where 'a='a and 'b='b, THEN eq_reflection, THEN fix_eq2], auto)

lemma smap_empty [simp]: "smap\<cdot>f\<cdot>\<bottom> = \<bottom>"
by (subst smap_unfold, simp)

lemma smap_scons [simp]: "x \<noteq> \<bottom> \<Longrightarrow> smap\<cdot>f\<cdot>(x && xs) = (f\<cdot>x) && (smap\<cdot>f\<cdot>xs)"
by (subst smap_unfold, force)

(* ----------------------------------------------------------------------- *)
(* theorems about sfilter                                                  *)
(* ----------------------------------------------------------------------- *)

section "sfilter"

lemma sfilter_unfold:
 "sfilter = (\<Lambda> p s. case s of x && xs \<Rightarrow>
  If p\<cdot>x then x && sfilter\<cdot>p\<cdot>xs else sfilter\<cdot>p\<cdot>xs)"
by (insert sfilter_def [where 'a='a, THEN eq_reflection, THEN fix_eq2], auto)

lemma strict_sfilter: "sfilter\<cdot>\<bottom> = \<bottom>"
apply (rule cfun_eqI)
apply (subst sfilter_unfold, auto)
apply (case_tac "x=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
done

lemma sfilter_empty [simp]: "sfilter\<cdot>f\<cdot>\<bottom> = \<bottom>"
by (subst sfilter_unfold, force)

lemma sfilter_scons [simp]:
  "x \<noteq> \<bottom> \<Longrightarrow> sfilter\<cdot>f\<cdot>(x && xs) =
                           If f\<cdot>x then x && sfilter\<cdot>f\<cdot>xs else sfilter\<cdot>f\<cdot>xs"
by (subst sfilter_unfold, force)

(* ----------------------------------------------------------------------- *)
   section "i_rt"
(* ----------------------------------------------------------------------- *)

lemma i_rt_UU [simp]: "i_rt n UU = UU"
  by (induct n) (simp_all add: i_rt_def)

lemma i_rt_0 [simp]: "i_rt 0 s = s"
by (simp add: i_rt_def)

lemma i_rt_Suc [simp]: "a \<noteq> UU \<Longrightarrow> i_rt (Suc n) (a&&s) = i_rt n s"
by (simp add: i_rt_def iterate_Suc2 del: iterate_Suc)

lemma i_rt_Suc_forw: "i_rt (Suc n) s = i_rt n (rt\<cdot>s)"
by (simp only: i_rt_def iterate_Suc2)

lemma i_rt_Suc_back: "i_rt (Suc n) s = rt\<cdot>(i_rt n s)"
by (simp only: i_rt_def,auto)

lemma i_rt_mono: "x << s \<Longrightarrow> i_rt n x  << i_rt n s"
by (simp add: i_rt_def monofun_rt_mult)

lemma i_rt_ij_lemma: "enat (i + j) \<le> #x \<Longrightarrow> enat j \<le> #(i_rt i x)"
by (simp add: i_rt_def slen_rt_mult)

lemma slen_i_rt_mono: "#s2 \<le> #s1 \<Longrightarrow> #(i_rt n s2) \<le> #(i_rt n s1)"
apply (induct_tac n,auto)
apply (simp add: i_rt_Suc_back)
apply (drule slen_rt_mono,simp)
done

lemma i_rt_take_lemma1 [rule_format]: "\<forall>s. i_rt n (stream_take n\<cdot>s) = UU"
apply (induct_tac n)
 apply (simp add: i_rt_Suc_back,auto)
apply (case_tac "s=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1],auto)
done

lemma i_rt_slen: "i_rt n s = UU \<longleftrightarrow> stream_take n\<cdot>s = s"
apply auto
 apply (insert i_rt_ij_lemma [of n "Suc 0" s])
 apply (subgoal_tac "#(i_rt n s)=0")
  apply (case_tac "stream_take n\<cdot>s = s",simp+)
  apply (insert slen_take_eq [rule_format,of n s],simp)
  apply (cases "#s") apply (simp_all add: zero_enat_def)
  apply (simp add: slen_take_eq)
  apply (cases "#s")
  using i_rt_take_lemma1 [of n s]
  apply (simp_all add: zero_enat_def)
  done

lemma i_rt_lemma_slen: "#s=enat n \<Longrightarrow> i_rt n s = UU"
by (simp add: i_rt_slen slen_take_lemma1)

lemma stream_finite_i_rt [simp]: "stream_finite (i_rt n s) = stream_finite s"
apply (induct_tac n, auto)
 apply (cases s, auto simp del: i_rt_Suc)
apply (simp add: i_rt_Suc_back stream_finite_rt_eq)+
done

lemma take_i_rt_len_lemma: "\<forall>sl x j t. enat sl = #x \<and> n \<le> sl \<and>
                            #(stream_take n\<cdot>x) = enat t \<and> #(i_rt n x) = enat j
                                              \<longrightarrow> enat (j + t) = #x"
apply (induct n, auto)
 apply (simp add: zero_enat_def)
apply (case_tac "x=UU",auto)
 apply (simp add: zero_enat_def)
apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
apply (subgoal_tac "\<exists>k. enat k = #y",clarify)
 apply (erule_tac x="k" in allE)
 apply (erule_tac x="y" in allE,auto)
 apply (erule_tac x="THE p. Suc p = t" in allE,auto)
   apply (simp add: eSuc_def split: enat.splits)
  apply (simp add: eSuc_def split: enat.splits)
  apply (simp only: the_equality)
 apply (simp add: eSuc_def split: enat.splits)
 apply force
apply (simp add: eSuc_def split: enat.splits)
done

lemma take_i_rt_len:
"\<lbrakk>enat sl = #x; n \<le> sl; #(stream_take n\<cdot>x) = enat t; #(i_rt n x) = enat j\<rbrakk> \<Longrightarrow>
    enat (j + t) = #x"
by (blast intro: take_i_rt_len_lemma [rule_format])

(* ----------------------------------------------------------------------- *)
   section "i_th"
(* ----------------------------------------------------------------------- *)

lemma i_th_i_rt_step:
"[| i_th n s1 << i_th n s2; i_rt (Suc n) s1 << i_rt (Suc n) s2 |] ==>
   i_rt n s1 << i_rt n s2"
apply (simp add: i_th_def i_rt_Suc_back)
apply (cases "i_rt n s1", simp)
apply (cases "i_rt n s2", auto)
done

lemma i_th_stream_take_Suc [rule_format]:
 "\<forall>s. i_th n (stream_take (Suc n)\<cdot>s) = i_th n s"
apply (induct_tac n,auto)
 apply (simp add: i_th_def)
 apply (case_tac "s=UU",auto)
 apply (drule stream_exhaust_eq [THEN iffD1],auto)
apply (case_tac "s=UU",simp add: i_th_def)
apply (drule stream_exhaust_eq [THEN iffD1],auto)
apply (simp add: i_th_def i_rt_Suc_forw)
done

lemma i_th_last: "i_th n s && UU = i_rt n (stream_take (Suc n)\<cdot>s)"
apply (insert surjectiv_scons [of "i_rt n (stream_take (Suc n)\<cdot>s)"])
apply (rule i_th_stream_take_Suc [THEN subst])
apply (simp add: i_th_def  i_rt_Suc_back [symmetric])
by (simp add: i_rt_take_lemma1)

lemma i_th_last_eq:
"i_th n s1 = i_th n s2 \<Longrightarrow> i_rt n (stream_take (Suc n)\<cdot>s1) = i_rt n (stream_take (Suc n)\<cdot>s2)"
apply (insert i_th_last [of n s1])
apply (insert i_th_last [of n s2])
apply auto
done

lemma i_th_prefix_lemma:
"\<lbrakk>k \<le> n; stream_take (Suc n)\<cdot>s1 << stream_take (Suc n)\<cdot>s2\<rbrakk> \<Longrightarrow>
    i_th k s1 << i_th k s2"
apply (insert i_th_stream_take_Suc [of k s1, THEN sym])
apply (insert i_th_stream_take_Suc [of k s2, THEN sym],auto)
apply (simp add: i_th_def)
apply (rule monofun_cfun, auto)
apply (rule i_rt_mono)
apply (blast intro: stream_take_lemma10)
done

lemma take_i_rt_prefix_lemma1:
  "stream_take (Suc n)\<cdot>s1 << stream_take (Suc n)\<cdot>s2 \<Longrightarrow>
   i_rt (Suc n) s1 << i_rt (Suc n) s2 \<Longrightarrow>
   i_rt n s1 << i_rt n s2 \<and> stream_take n\<cdot>s1 << stream_take n\<cdot>s2"
apply auto
 apply (insert i_th_prefix_lemma [of n n s1 s2])
 apply (rule i_th_i_rt_step,auto)
apply (drule mono_stream_take_pred,simp)
done

lemma take_i_rt_prefix_lemma:
"\<lbrakk>stream_take n\<cdot>s1 << stream_take n\<cdot>s2; i_rt n s1 << i_rt n s2\<rbrakk> \<Longrightarrow> s1 << s2"
apply (case_tac "n=0",simp)
apply (auto)
apply (subgoal_tac "stream_take 0\<cdot>s1 << stream_take 0\<cdot>s2 \<and> i_rt 0 s1 << i_rt 0 s2")
 defer 1
 apply (rule zero_induct,blast)
 apply (blast dest: take_i_rt_prefix_lemma1)
apply simp
done

lemma streams_prefix_lemma: "s1 << s2 \<longleftrightarrow>
  (stream_take n\<cdot>s1 << stream_take n\<cdot>s2 \<and> i_rt n s1 << i_rt n s2)"
apply auto
  apply (simp add: monofun_cfun_arg)
 apply (simp add: i_rt_mono)
apply (erule take_i_rt_prefix_lemma,simp)
done

lemma streams_prefix_lemma1:
  "\<lbrakk>stream_take n\<cdot>s1 = stream_take n\<cdot>s2; i_rt n s1 = i_rt n s2\<rbrakk> \<Longrightarrow> s1 = s2"
apply (simp add: po_eq_conv,auto)
 apply (insert streams_prefix_lemma)
 apply blast+
done

(* ----------------------------------------------------------------------- *)
   section "sconc"
(* ----------------------------------------------------------------------- *)

lemma UU_sconc [simp]: " UU ooo s = s "
by (simp add: sconc_def zero_enat_def)

lemma scons_neq_UU: "a \<noteq> UU \<Longrightarrow> a && s \<noteq> UU"
by auto

lemma singleton_sconc [rule_format, simp]: "x \<noteq> UU \<longrightarrow> (x && UU) ooo y = x && y"
apply (simp add: sconc_def zero_enat_def eSuc_def split: enat.splits, auto)
apply (rule someI2_ex,auto)
 apply (rule_tac x="x && y" in exI,auto)
apply (simp add: i_rt_Suc_forw)
apply (case_tac "xa=UU",simp)
by (drule stream_exhaust_eq [THEN iffD1],auto)

lemma ex_sconc [rule_format]:
  "\<forall>k y. #x = enat k \<longrightarrow> (\<exists>w. stream_take k\<cdot>w = x \<and> i_rt k w = y)"
apply (case_tac "#x")
 apply (rule stream_finite_ind [of x],auto)
  apply (simp add: stream.finite_def)
  apply (drule slen_take_lemma1,blast)
 apply (simp_all add: zero_enat_def eSuc_def split: enat.splits)
apply (erule_tac x="y" in allE,auto)
apply (rule_tac x="a && w" in exI,auto)
done

lemma rt_sconc1: "enat n = #x \<Longrightarrow> i_rt n (x ooo y) = y"
apply (simp add: sconc_def split: enat.splits, arith?,auto)
apply (rule someI2_ex,auto)
apply (drule ex_sconc,simp)
done

lemma sconc_inj2: "\<lbrakk>enat n = #x; x ooo y = x ooo z\<rbrakk> \<Longrightarrow> y = z"
apply (frule_tac y=y in rt_sconc1)
apply (auto elim: rt_sconc1)
done

lemma sconc_UU [simp]:"s ooo UU = s"
apply (case_tac "#s")
 apply (simp add: sconc_def)
 apply (rule someI2_ex)
  apply (rule_tac x="s" in exI)
  apply auto
   apply (drule slen_take_lemma1,auto)
  apply (simp add: i_rt_lemma_slen)
 apply (drule slen_take_lemma1,auto)
 apply (simp add: i_rt_slen)
apply (simp add: sconc_def)
done

lemma stream_take_sconc [simp]: "enat n = #x \<Longrightarrow> stream_take n\<cdot>(x ooo y) = x"
apply (simp add: sconc_def)
apply (cases "#x")
apply auto
apply (rule someI2_ex, auto)
apply (drule ex_sconc,simp)
done

lemma scons_sconc [rule_format,simp]: "a \<noteq> UU \<longrightarrow> (a && x) ooo y = a && x ooo y"
apply (cases "#x",auto)
 apply (simp add: sconc_def eSuc_enat)
 apply (rule someI2_ex)
  apply (drule ex_sconc, simp)
 apply (rule someI2_ex, auto)
  apply (simp add: i_rt_Suc_forw)
  apply (rule_tac x="a && xa" in exI, auto)
 apply (case_tac "xaa=UU",auto)
 apply (drule stream_exhaust_eq [THEN iffD1],auto)
 apply (drule streams_prefix_lemma1,simp+)
apply (simp add: sconc_def)
done

lemma ft_sconc: "x \<noteq> UU \<Longrightarrow> ft\<cdot>(x ooo y) = ft\<cdot>x"
by (cases x) auto

lemma sconc_assoc: "(x ooo y) ooo z = x ooo y ooo z"
apply (case_tac "#x")
 apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
  apply (simp add: stream.finite_def del: scons_sconc)
  apply (drule slen_take_lemma1,auto simp del: scons_sconc)
 apply (case_tac "a = UU", auto)
by (simp add: sconc_def)

(* ----------------------------------------------------------------------- *)

lemma cont_sconc_lemma1: "stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
by (erule stream_finite_ind, simp_all)

lemma cont_sconc_lemma2: "\<not> stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
by (simp add: sconc_def slen_def)

lemma cont_sconc: "cont (\<lambda>y. x ooo y)"
apply (cases "stream_finite x")
apply (erule cont_sconc_lemma1)
apply (erule cont_sconc_lemma2)
done

lemma sconc_mono: "y << y' \<Longrightarrow> x ooo y << x ooo y'"
by (rule cont_sconc [THEN cont2mono, THEN monofunE])

lemma sconc_mono1 [simp]: "x << x ooo y"
by (rule sconc_mono [of UU, simplified])

(* ----------------------------------------------------------------------- *)

lemma empty_sconc [simp]: "x ooo y = UU \<longleftrightarrow> x = UU \<and> y = UU"
apply (case_tac "#x",auto)
   apply (insert sconc_mono1 [of x y])
   apply auto
done

(* ----------------------------------------------------------------------- *)

lemma rt_sconc [rule_format, simp]: "s \<noteq> UU \<longrightarrow> rt\<cdot>(s ooo x) = rt\<cdot>s ooo x"
by (cases s, auto)

lemma i_th_sconc_lemma [rule_format]:
  "\<forall>x y. enat n < #x \<longrightarrow> i_th n (x ooo y) = i_th n x"
apply (induct_tac n, auto)
apply (simp add: enat_0 i_th_def)
apply (simp add: slen_empty_eq ft_sconc)
apply (simp add: i_th_def)
apply (case_tac "x=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (erule_tac x="ya" in allE)
apply (case_tac "#ya")
apply simp_all
done

(* ----------------------------------------------------------------------- *)

lemma sconc_lemma [rule_format, simp]: "\<forall>s. stream_take n\<cdot>s ooo i_rt n s = s"
apply (induct_tac n,auto)
apply (case_tac "s=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1],auto)
done

(* ----------------------------------------------------------------------- *)
   subsection "pointwise equality"
(* ----------------------------------------------------------------------- *)

lemma ex_last_stream_take_scons: "stream_take (Suc n)\<cdot>s =
                     stream_take n\<cdot>s ooo i_rt n (stream_take (Suc n)\<cdot>s)"
by (insert sconc_lemma [of n "stream_take (Suc n)\<cdot>s"],simp)

lemma i_th_stream_take_eq:
  "\<And>n. \<forall>n. i_th n s1 = i_th n s2 \<Longrightarrow> stream_take n\<cdot>s1 = stream_take n\<cdot>s2"
apply (induct_tac n,auto)
apply (subgoal_tac "stream_take (Suc na)\<cdot>s1 =
                    stream_take na\<cdot>s1 ooo i_rt na (stream_take (Suc na)\<cdot>s1)")
 apply (subgoal_tac "i_rt na (stream_take (Suc na)\<cdot>s1) =
                    i_rt na (stream_take (Suc na)\<cdot>s2)")
  apply (subgoal_tac "stream_take (Suc na)\<cdot>s2 =
                    stream_take na\<cdot>s2 ooo i_rt na (stream_take (Suc na)\<cdot>s2)")
   apply (insert ex_last_stream_take_scons,simp)
  apply blast
 apply (erule_tac x="na" in allE)
 apply (insert i_th_last_eq [of _ s1 s2])
by blast+

lemma pointwise_eq_lemma[rule_format]: "\<forall>n. i_th n s1 = i_th n s2 \<Longrightarrow> s1 = s2"
by (insert i_th_stream_take_eq [THEN stream.take_lemma],blast)

(* ----------------------------------------------------------------------- *)
   subsection "finiteness"
(* ----------------------------------------------------------------------- *)

lemma slen_sconc_finite1:
  "\<lbrakk>#(x ooo y) = \<infinity>; enat n = #x\<rbrakk> \<Longrightarrow> #y = \<infinity>"
apply (case_tac "#y \<noteq> \<infinity>",auto)
apply (drule_tac y=y in rt_sconc1)
apply (insert stream_finite_i_rt [of n "x ooo y"])
apply (simp add: slen_infinite)
done

lemma slen_sconc_infinite1: "#x=\<infinity> \<Longrightarrow> #(x ooo y) = \<infinity>"
by (simp add: sconc_def)

lemma slen_sconc_infinite2: "#y=\<infinity> \<Longrightarrow> #(x ooo y) = \<infinity>"
apply (case_tac "#x")
 apply (simp add: sconc_def)
 apply (rule someI2_ex)
  apply (drule ex_sconc,auto)
 apply (erule contrapos_pp)
 apply (insert stream_finite_i_rt)
 apply (fastforce simp add: slen_infinite,auto)
by (simp add: sconc_def)

lemma sconc_finite: "#x \<noteq> \<infinity> \<and> #y \<noteq> \<infinity> \<longleftrightarrow> #(x ooo y) \<noteq> \<infinity>"
apply auto
  apply (metis not_infinity_eq slen_sconc_finite1)
 apply (metis not_infinity_eq slen_sconc_infinite1)
apply (metis not_infinity_eq slen_sconc_infinite2)
done

(* ----------------------------------------------------------------------- *)

lemma slen_sconc_mono3: "\<lbrakk>enat n = #x; enat k = #(x ooo y)\<rbrakk> \<Longrightarrow> n \<le> k"
apply (insert slen_mono [of "x" "x ooo y"])
apply (cases "#x") apply simp_all
apply (cases "#(x ooo y)") apply simp_all
done

(* ----------------------------------------------------------------------- *)
   subsection "finite slen"
(* ----------------------------------------------------------------------- *)

lemma slen_sconc: "\<lbrakk>enat n = #x; enat m = #y\<rbrakk> \<Longrightarrow> #(x ooo y) = enat (n + m)"
apply (case_tac "#(x ooo y)")
 apply (frule_tac y=y in rt_sconc1)
 apply (insert take_i_rt_len [of "THE j. enat j = #(x ooo y)" "x ooo y" n n m],simp)
 apply (insert slen_sconc_mono3 [of n x _ y],simp)
apply (insert sconc_finite [of x y],auto)
done

(* ----------------------------------------------------------------------- *)
   subsection "flat prefix"
(* ----------------------------------------------------------------------- *)

lemma sconc_prefix: "(s1::'a::flat stream) << s2 \<Longrightarrow> \<exists>t. s1 ooo t = s2"
apply (case_tac "#s1")
 apply (subgoal_tac "stream_take nat\<cdot>s1 = stream_take nat\<cdot>s2")
  apply (rule_tac x="i_rt nat s2" in exI)
  apply (simp add: sconc_def)
  apply (rule someI2_ex)
   apply (drule ex_sconc)
   apply (simp,clarsimp,drule streams_prefix_lemma1)
   apply (simp+,rule slen_take_lemma3 [of _ s1 s2])
  apply (simp+,rule_tac x="UU" in exI)
apply (insert slen_take_lemma3 [of _ s1 s2])
apply (rule stream.take_lemma,simp)
done

(* ----------------------------------------------------------------------- *)
   subsection "continuity"
(* ----------------------------------------------------------------------- *)

lemma chain_sconc: "chain S \<Longrightarrow> chain (\<lambda>i. (x ooo S i))"
by (simp add: chain_def,auto simp add: sconc_mono)

lemma chain_scons: "chain S \<Longrightarrow> chain (\<lambda>i. a && S i)"
apply (simp add: chain_def,auto)
apply (rule monofun_cfun_arg,simp)
done

lemma contlub_scons_lemma: "chain S \<Longrightarrow> (LUB i. a && S i) = a && (LUB i. S i)"
by (rule cont2contlubE [OF cont_Rep_cfun2, symmetric])

lemma finite_lub_sconc: "chain Y \<Longrightarrow> stream_finite x \<Longrightarrow>
                        (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
apply (rule stream_finite_ind [of x])
 apply (auto)
apply (subgoal_tac "(LUB i. a && (s ooo Y i)) = a && (LUB i. s ooo Y i)")
 apply (force,blast dest: contlub_scons_lemma chain_sconc)
done

lemma contlub_sconc_lemma:
  "chain Y \<Longrightarrow> (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
apply (case_tac "#x=\<infinity>")
 apply (simp add: sconc_def)
apply (drule finite_lub_sconc,auto simp add: slen_infinite)
done

lemma monofun_sconc: "monofun (\<lambda>y. x ooo y)"
by (simp add: monofun_def sconc_mono)

(* ----------------------------------------------------------------------- *)
   section "constr_sconc"
(* ----------------------------------------------------------------------- *)

lemma constr_sconc_UUs [simp]: "constr_sconc UU s = s"
by (simp add: constr_sconc_def zero_enat_def)

lemma "x ooo y = constr_sconc x y"
apply (case_tac "#x")
 apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
  defer 1
  apply (simp add: constr_sconc_def del: scons_sconc)
  apply (case_tac "#s")
   apply (simp add: eSuc_enat)
   apply (case_tac "a=UU",auto simp del: scons_sconc)
   apply (simp)
  apply (simp add: sconc_def)
 apply (simp add: constr_sconc_def)
apply (simp add: stream.finite_def)
apply (drule slen_take_lemma1,auto)
done

end


theory Collecting
  imports ACom Big_Step "HOL-IMP.Complete_Lattice"
begin

notation
  sup (infixl "\<squnion>" 65) and
  inf (infixl "\<sqinter>" 70) and
  bot ("\<bottom>") and
  top ("\<top>")

context
  fixes f :: "vname \<Rightarrow> aexp \<Rightarrow> 'a \<Rightarrow> 'a::sup"
  fixes g :: "bexp \<Rightarrow> 'a \<Rightarrow> 'a"
begin
fun Step :: "'a \<Rightarrow> 'a acom \<Rightarrow> 'a acom" where
"Step S (SKIP {Q}) = (SKIP {S})" |
"Step S (x ::= e {Q}) =
  x ::= e {f x e S}" |
"Step S (C1;; C2) = Step S C1;; Step (post C1) C2" |
"Step S (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) =
  IF b THEN {g b S} Step P1 C1 ELSE {g (Not b) S} Step P2 C2
  {post C1 \<squnion> post C2}" |
"Step S (C1 OR C2 {P}) =
  Step S C1 OR Step S C2
  {post C1 \<squnion> post C2}" |
"Step S ({I} WHILE b DO {P} C {Q}) =
  {S \<squnion> post C} WHILE b DO {g b I} Step P C {g (Not b) I}"
end

text \<open>Step does not change the underlying command\<close>
lemma strip_Step[simp]: "strip(Step f g S C) = strip C"
by(induct C arbitrary: S) auto

subsubsection "Annotated commands as a complete lattice"

text \<open>We define an order on acom in terms of an order on 'a\<close>
instantiation acom :: (order) order
begin

text \<open>The order is as thus: C1 \<le> C2 once they are on the same base command and all annotations on
C1 \<le> respective annotations on C2\<close>
definition less_eq_acom :: "('a::order)acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
"C1 \<le> C2 \<longleftrightarrow> strip C1 = strip C2 \<and> (\<forall>p<size(annos C1). anno C1 p \<le> anno C2 p)"

text \<open>We define strict < in terms of our above definition \<le> and equality\<close>
definition less_acom :: "'a acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
"less_acom x y = (x \<le> y \<and> \<not> y \<le> x)"

text \<open>We show that our definitions satisfy order axioms\<close>
instance
proof (standard, goal_cases)
  case 1 show ?case by(simp add: less_acom_def)
next
  case 2 thus ?case by(auto simp: less_eq_acom_def)
next
  case 3 thus ?case by(fastforce simp: less_eq_acom_def size_annos)
next
  case 4 thus ?case
    by(fastforce simp: le_antisym less_eq_acom_def size_annos
         eq_acom_iff_strip_anno)
qed

end

text \<open>In terms of list_all2 instead of explicit indexing\<close>
lemma less_eq_acom_annos:
  "C1 \<le> C2 \<longleftrightarrow> strip C1 = strip C2 \<and> list_all2 (\<le>) (annos C1) (annos C2)"
by(auto simp add: less_eq_acom_def anno_def list_all2_conv_all_nth size_annos_same2)

text \<open>Inversion of order when we know the command of the left operand, inferring the command of the
right operand and annotation constraints\<close>

lemma SKIP_le[simp]: "SKIP {S} \<le> c \<longleftrightarrow> (\<exists>S'. c = SKIP {S'} \<and> S \<le> S')"
by (cases c) (auto simp:less_eq_acom_def anno_def)

lemma Assign_le[simp]: "x ::= e {S} \<le> c \<longleftrightarrow> (\<exists>S'. c = x ::= e {S'} \<and> S \<le> S')"
by (cases c) (auto simp:less_eq_acom_def anno_def)

lemma Seq_le[simp]: "C1;;C2 \<le> C \<longleftrightarrow> (\<exists>C1' C2'. C = C1';;C2' \<and> C1 \<le> C1' \<and> C2 \<le> C2')"
apply (cases C)
apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
done

lemma If_le[simp]: "IF b THEN {p1} C1 ELSE {p2} C2 {S} \<le> C \<longleftrightarrow>
  (\<exists>p1' p2' C1' C2' S'. C = IF b THEN {p1'} C1' ELSE {p2'} C2' {S'} \<and>
     p1 \<le> p1' \<and> p2 \<le> p2' \<and> C1 \<le> C1' \<and> C2 \<le> C2' \<and> S \<le> S')"
apply (cases C)
apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
done

lemma Or_le[simp]: "C1 OR C2 {P} \<le> C \<longleftrightarrow>
  (\<exists>C1' C2' P'. C = C1' OR C2' {P'} \<and>
     C1 \<le> C1' \<and> C2 \<le> C2' \<and> P \<le> P')"
apply (cases C)
apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
done

lemma While_le[simp]: "{I} WHILE b DO {p} C {P} \<le> W \<longleftrightarrow>
  (\<exists>I' p' C' P'. W = {I'} WHILE b DO {p'} C' {P'} \<and> C \<le> C' \<and> p \<le> p' \<and> I \<le> I' \<and> P \<le> P')"
apply (cases W)
apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
done

text \<open>obtaining the last annotation is monotonic\<close>
lemma mono_post: "C \<le> C' \<Longrightarrow> post C \<le> post C'"
using annos_ne[of C']
by(auto simp: post_def less_eq_acom_def last_conv_nth[OF annos_ne] anno_def
     dest: size_annos_same)

text \<open>Inf_acom c M is the infimum among all the annotated commands in M once such an infimum exists\<close>
definition Inf_acom :: "com \<Rightarrow> 'a::complete_lattice acom set \<Rightarrow> 'a acom" where
"Inf_acom c M = annotate (\<lambda>p. INF C\<in>M. anno C p) c"

text \<open>expose the Complete_Lattice theorems conditioned on c (annotated commands form a complete lattice
for each c), once the lemmas are satisfied, where The greatest lower bound for M is Inf_acom c M\<close>
global_interpretation
  Complete_Lattice "{C. strip C = c}" "Inf_acom c" for c
proof (standard, goal_cases)
  case 1 thus ?case
    by(auto simp: Inf_acom_def less_eq_acom_def size_annos intro:INF_lower)
next
  case 2 thus ?case
    by(auto simp: Inf_acom_def less_eq_acom_def size_annos intro:INF_greatest)
next
  case 3 thus ?case by(auto simp: Inf_acom_def)
qed

subsubsection "Collecting semantics"

text \<open>step is Step, partially applied to the assignment and bval semantics of the collecting semantics\<close>
definition "step = Step (\<lambda>x e S. {s(x := aval e s) |s. s \<in> S}) (\<lambda>b S. {s:S. bval b s})"

text \<open>The collecting semantics of a command is its annotation with the smallest set of states that
are invariant under stepping through starting from UNIV\<close>
definition CS :: "com \<Rightarrow> state set acom" where
"CS c = lfp c (step UNIV)"

text \<open>once the assignment and bval semantics are mono, stepping through is mono\<close>
lemma mono2_Step: fixes C1 C2 :: "'a::semilattice_sup acom"
  assumes "!!x e S1 S2. S1 \<le> S2 \<Longrightarrow> f x e S1 \<le> f x e S2"
          "!!b S1 S2. S1 \<le> S2 \<Longrightarrow> g b S1 \<le> g b S2"
  shows "C1 \<le> C2 \<Longrightarrow> S1 \<le> S2 \<Longrightarrow> Step f g S1 C1 \<le> Step f g S2 C2"
proof(induction S1 C1 arbitrary: C2 S2 rule: Step.induct)
  case 1 thus ?case by(auto)
next
  case 2 thus ?case by (auto simp: assms(1))
next
  case 3 thus ?case by(auto simp: mono_post)
next
  case 4 thus ?case
    by(auto simp: subset_iff assms(2))
      (metis mono_post le_supI1 le_supI2)+
next
  case (5 S C1 C2 P CE) thus ?case
    by auto (metis mono_post le_supI1 le_supI2)+
next
  case 6 thus ?case
    by(auto simp: subset_iff assms(2))
      (metis mono_post le_supI1 le_supI2)+
qed

text \<open>and so the same for the step for collecting semantics\<close>
lemma mono2_step: "C1 \<le> C2 \<Longrightarrow> S1 \<subseteq> S2 \<Longrightarrow> step S1 C1 \<le> step S2 C2"
unfolding step_def by(rule mono2_Step) auto

text \<open>As a corollary, step is mono for fixed S\<close>
lemma mono_step: "mono (step S)"
by(blast intro: monoI mono2_step)

text \<open>stepping does not change the underlying command\<close>
lemma strip_step: "strip(step S C) = strip C"
by (induction C arbitrary: S) (auto simp: step_def)

text \<open>with step being mono, we know that stepping on a fixed S has an lfp\<close>
lemma lfp_cs_unfold: "lfp c (step S) = step S (lfp c (step S))"
apply(rule lfp_unfold[OF _  mono_step])
apply(simp add: strip_step)
done

text \<open>hence CS is a fixpoint with respect to stepping through UNIV\<close>
lemma CS_unfold: "CS c = step UNIV (CS c)"
by (metis CS_def lfp_cs_unfold)

text \<open>CS also has the same underlying c, by closure\<close>
lemma strip_CS[simp]: "strip(CS c) = c"
by(simp add: CS_def index_lfp[simplified])

subsubsection "Relation to big-step semantics"

text \<open>the number of annotations any com admits is nonzero\<close>
lemma asize_nz: "asize(c::com) \<noteq> 0"
by (metis length_0_conv length_annos_annotate annos_ne)

text \<open>The last annotation of the infimum of a set M of annotated commands on c is exactly the
infimum among the annotations. By definition, since infimum is pointwise with respect to the
annotations\<close>
lemma post_Inf_acom:
  "\<forall>C\<in>M. strip C = c \<Longrightarrow> post (Inf_acom c M) = \<Inter>(post ` M)"
apply(subgoal_tac "\<forall>C\<in>M. size(annos C) = asize c")
 apply(simp add: post_anno_asize Inf_acom_def asize_nz neq0_conv[symmetric])
apply(simp add: size_annos)
done

text \<open>Hence similarly for the lfp of f on c\<close>
lemma post_lfp: "post(lfp c f) = (\<Inter>{post C|C. strip C = c \<and> f C \<le> C})"
by(auto simp add: lfp_def post_Inf_acom)

text \<open>our step semantics are correct, so step maps a state in the input state s to satisfying its
last annotation once we know that C is stable under stepping i.e. has (with step S C \<le> C)
(reasoning: step maps each state satisfying annotation to the satisfying the next annotation in
step S C, and by (pointwise) stability, it satisfies that same annotation in C. Then repeat by
stepping through again.)

As for why we use the last annotation, it comes from the big-step semantics that s is the state
before execution of c and t is the state after execution of C\<close>
lemma big_step_post_step:
  "\<lbrakk> (c, s) \<Rightarrow> t;  strip C = c;  s \<in> S;  step S C \<le> C \<rbrakk> \<Longrightarrow> t \<in> post C"
proof(induction arbitrary: C S rule: big_step_induct)
  case Skip thus ?case by(auto simp: strip_eq_SKIP step_def post_def)
next
  case Assign thus ?case
    by(fastforce simp: strip_eq_Assign step_def post_def)
next
  case Seq thus ?case
    by(fastforce simp: strip_eq_Seq step_def post_def last_append annos_ne)
next
  case IfTrue thus ?case apply(auto simp: strip_eq_If step_def post_def)
    by (metis (lifting,full_types) mem_Collect_eq subsetD)
next
  case IfFalse thus ?case apply(auto simp: strip_eq_If step_def post_def)
    by (metis (lifting,full_types) mem_Collect_eq subsetD)
next
  case OrLeft thus ?case apply(auto simp: strip_eq_Or step_def post_def)
    by (metis (lifting,full_types) subsetD)
next
  case OrRight thus ?case apply(auto simp: strip_eq_Or step_def post_def)
    by (metis (lifting,full_types) subsetD)
next
  case (WhileTrue b s1 c' s2 s3)
  from WhileTrue.prems(1) obtain I P C' Q where "C = {I} WHILE b DO {P} C' {Q}" "strip C' = c'"
    by(auto simp: strip_eq_While)
  from WhileTrue.prems(3) \<open>C = _\<close>
  have "step P C' \<le> C'"  "{s \<in> I. bval b s} \<le> P"  "S \<le> I"  "step (post C') C \<le> C"
    by (auto simp: step_def post_def)
  have "step {s \<in> I. bval b s} C' \<le> C'"
    by (rule order_trans[OF mono2_step[OF order_refl \<open>{s \<in> I. bval b s} \<le> P\<close>] \<open>step P C' \<le> C'\<close>])
  have "s1 \<in> {s\<in>I. bval b s}" using \<open>s1 \<in> S\<close> \<open>S \<subseteq> I\<close> \<open>bval b s1\<close> by auto
  note s2_in_post_C' = WhileTrue.IH(1)[OF \<open>strip C' = c'\<close> this \<open>step {s \<in> I. bval b s} C' \<le> C'\<close>]
  from WhileTrue.IH(2)[OF WhileTrue.prems(1) s2_in_post_C' \<open>step (post C') C \<le> C\<close>]
  show ?case .
next
  case (WhileFalse b s1 c') thus ?case
    by (force simp: strip_eq_While step_def post_def)
qed

text \<open>Thus t is also in the the least fixpoint of stepping wrt an S and c\<close>
lemma big_step_lfp: "\<lbrakk> (c,s) \<Rightarrow> t;  s \<in> S \<rbrakk> \<Longrightarrow> t \<in> post(lfp c (step S))"
by(auto simp add: post_lfp intro: big_step_post_step)

text \<open>And so also with UNIV.\<close>
lemma big_step_CS: "(c,s) \<Rightarrow> t \<Longrightarrow> t \<in> post(CS c)"
by(simp add: CS_def big_step_lfp)

end