(* Author: Simon Wimmer *)
theory Graphs
  imports
    More_List Stream_More
    "HOL-Library.Rewrite"
begin

chapter \<open>Graphs\<close>

section \<open>Basic Definitions and Theorems\<close>

locale Graph_Defs =
  fixes E :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

inductive steps where
  Single: "steps [x]" |
  Cons: "steps (x # y # xs)" if "E x y" "steps (y # xs)"

lemmas [intro] = steps.intros

lemma steps_append:
  "steps (xs @ tl ys)" if "steps xs" "steps ys" "last xs = hd ys"
  using that by induction (auto 4 4 elim: steps.cases)

lemma steps_append':
  "steps xs" if "steps as" "steps bs" "last as = hd bs" "as @ tl bs = xs"
  using steps_append that by blast

coinductive run where
  "run (x ## y ## xs)" if "E x y" "run (y ## xs)"

lemmas [intro] = run.intros

lemma steps_appendD1:
  "steps xs" if "steps (xs @ ys)" "xs \<noteq> []"
  using that proof (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case
    by - (cases xs; auto elim: steps.cases)
qed

lemma steps_appendD2:
  "steps ys" if "steps (xs @ ys)" "ys \<noteq> []"
  using that by (induction xs) (auto elim: steps.cases)

lemma steps_appendD3:
  "steps (xs @ [x]) \<and> E x y" if "steps (xs @ [x, y])"
  using that proof (induction xs)
  case Nil
  then show ?case by (auto elim!: steps.cases)
next
  case prems: (Cons a xs)
  then show ?case by (cases xs) (auto elim: steps.cases)
qed

lemma steps_ConsD:
  "steps xs" if "steps (x # xs)" "xs \<noteq> []"
  using that by (auto elim: steps.cases)

lemmas stepsD = steps_ConsD steps_appendD1 steps_appendD2

lemma steps_alt_induct[consumes 1, case_names Single Snoc]:
  assumes
    "steps x" "(\<And>x. P [x])"
    "\<And>y x xs. E y x \<Longrightarrow> steps (xs @ [y]) \<Longrightarrow> P (xs @ [y]) \<Longrightarrow> P (xs @ [y,x])"
  shows "P x"
  using assms(1)
  proof (induction rule: rev_induct)
    case Nil
    then show ?case by (auto elim: steps.cases)
  next
    case prems: (snoc x xs)
    then show ?case by (cases xs rule: rev_cases) (auto intro: assms(2,3) dest!: steps_appendD3)
  qed

lemma steps_appendI:
  "steps (xs @ [x, y])" if "steps (xs @ [x])" "E x y"
  using that
proof (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case by (cases xs; auto elim: steps.cases)
qed

lemma steps_append_single:
  assumes
    "steps xs" "E (last xs) x" "xs \<noteq> []"
  shows "steps (xs @ [x])"
  using assms(3,1,2) by (induction xs rule: list_nonempty_induct) (auto 4 4 elim: steps.cases)

lemma extend_run:
  assumes
    "steps xs" "E (last xs) x" "run (x ## ys)" "xs \<noteq> []"
  shows "run (xs @- x ## ys)"
  using assms(4,1-3) by (induction xs rule: list_nonempty_induct) (auto 4 3 elim: steps.cases)

lemma run_cycle:
  assumes "steps xs" "E (last xs) (hd xs)" "xs \<noteq> []"
  shows "run (cycle xs)"
  using assms proof (coinduction arbitrary: xs)
  case run
  then show ?case
    apply (rewrite at \<open>cycle xs\<close> stream.collapse[symmetric])
    apply (rewrite at \<open>stl (cycle xs)\<close> stream.collapse[symmetric])
    apply clarsimp
    apply (erule steps.cases)
    subgoal for x
      apply (rule conjI)
       apply (simp; fail)
      apply (rule disjI1)
      apply (inst_existentials xs)
         apply (simp, metis cycle_Cons[of x "[]", simplified])
      by auto
    subgoal for x y xs'
      apply (rule conjI)
       apply (simp; fail)
      apply (rule disjI1)
      apply (inst_existentials "y # xs' @ [x]")
      using steps_append_single[of "y # xs'" x]
         apply (auto elim: steps.cases split: if_split_asm)
       apply (subst (2) cycle_Cons, simp) (* XXX Automate forward reasoning *)
      apply (subst cycle_Cons, simp)
      done
    done
qed

lemma run_stl:
  "run (stl xs)" if "run xs"
  using that by (auto elim: run.cases)

lemma run_sdrop:
  "run (sdrop n xs)" if "run xs"
  using that by (induction n arbitrary: xs) (auto intro: run_stl)

lemma run_reachable':
  assumes "run (x ## xs)" "E\<^sup>*\<^sup>* x\<^sub>0 x"
  shows "pred_stream (\<lambda> x. E\<^sup>*\<^sup>* x\<^sub>0 x) xs"
  using assms by (coinduction arbitrary: x xs) (auto 4 3 elim: run.cases)

lemma run_reachable:
  assumes "run (x\<^sub>0 ## xs)"
  shows "pred_stream (\<lambda> x. E\<^sup>*\<^sup>* x\<^sub>0 x) xs"
  by (rule run_reachable'[OF assms]) blast

lemma run_decomp:
  assumes "run (xs @- ys)" "xs \<noteq> []"
  shows "steps xs \<and> run ys \<and> E (last xs) (shd ys)"
using assms(2,1) proof (induction xs rule: list_nonempty_induct)
  case (single x)
  then show ?case by (auto elim: run.cases)
next
  case (cons x xs)
  then show ?case by (cases xs; auto 4 4 elim: run.cases)
qed

lemma steps_decomp:
  assumes "steps (xs @ ys)" "xs \<noteq> []" "ys \<noteq> []"
  shows "steps xs \<and> steps ys \<and> E (last xs) (hd ys)"
using assms(2,1,3) proof (induction xs rule: list_nonempty_induct)
  case (single x)
  then show ?case by (auto elim: steps.cases)
next
  case (cons x xs)
  then show ?case by (cases xs; auto 4 4 elim: steps.cases)
qed

lemma steps_rotate:
  assumes "steps (x # xs @ y # ys @ [x])"
  shows "steps (y # ys @ x # xs @ [y])"
proof -
  from steps_decomp[of "x # xs" "y # ys @ [x]"] assms have
    "steps (x # xs)" "steps (y # ys @ [x])" "E (last (x # xs)) y"
    by auto
  then have "steps ((x # xs) @ [y])" by (blast intro: steps_append_single)
  from steps_append[OF \<open>steps (y # ys @ [x])\<close> this] show ?thesis by auto
qed

lemma run_shift_coinduct[case_names run_shift, consumes 1]:
  assumes "R w"
      and "\<And> w. R w \<Longrightarrow> \<exists> u v x y. w = u @- x ## y ## v \<and> steps (u @ [x]) \<and> E x y \<and> R (y ## v)"
  shows "run w"
  using assms(2)[OF \<open>R w\<close>] proof (coinduction arbitrary: w)
  case (run w)
  then obtain u v x y where "w = u @- x ## y ## v" "steps (u @ [x])" "E x y" "R (y ## v)"
    by auto
  then show ?case
    apply -
    apply (drule assms(2))
    apply (cases u)
     apply force
    subgoal for z zs
      apply (cases zs)
      subgoal
        apply simp
        apply safe
         apply (force elim: steps.cases)
        subgoal for u' v' x' y'
          by (inst_existentials "x # u'") (cases u'; auto)
        done
      subgoal for a as
        apply simp
        apply safe
         apply (force elim: steps.cases)
        subgoal for u' v' x' y'
          apply (inst_existentials "a # as @ x # u'")
          using steps_append[of "a # as @ [x, y]" "u' @ [x']"]
          apply simp
          apply (drule steps_appendI[of "a # as" x, rotated])
          by (cases u'; force elim: steps.cases)+
        done
      done
    done
qed

lemma run_flat_coinduct[case_names run_shift, consumes 1]:
  assumes "R xss"
    and
    "\<And> xs ys xss.
    R (xs ## ys ## xss) \<Longrightarrow> xs \<noteq> [] \<and> steps xs \<and> E (last xs) (hd ys) \<and> R (ys ## xss)"
  shows "run (flat xss)"
proof -
  obtain xs ys xss' where "xss = xs ## ys ## xss'" by (metis stream.collapse)
  with assms(2)[OF assms(1)[unfolded this]] show ?thesis
  proof (coinduction arbitrary: xs ys xss' xss rule: run_shift_coinduct)
    case (run_shift xs ys xss' xss)
    from run_shift show ?case
      apply (cases xss')
      apply clarify
      apply (drule assms(2))
      apply (inst_existentials "butlast xs" "tl ys @- flat xss'" "last xs" "hd ys")
         apply (cases ys)
          apply (simp; fail)
      subgoal premises prems for x1 x2 z zs
      proof (cases "xs = []")
        case True
        with prems show ?thesis
          by auto
      next
        case False
        then have "xs = butlast xs @ [last xs]" by auto
        then have "butlast xs @- last xs ## tail = xs @- tail" for tail
          by (metis shift.simps(1,2) shift_append)
        with prems show ?thesis by simp
      qed
        apply (simp; fail)
       apply assumption
      subgoal for ws wss
        by (inst_existentials ys ws wss) (cases ys, auto)
      done
  qed
qed

lemma steps_non_empty[simp]:
  "\<not> steps []"
  by (auto elim: steps.cases)

lemma steps_non_empty'[simp]:
  "xs \<noteq> []" if "steps xs"
  using that by auto

(* XXX Generalize *)
lemma steps_replicate:
  "steps (hd xs # concat (replicate n (tl xs)))" if "last xs = hd xs" "steps xs" "n > 0"
  using that
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  show ?case
  proof (cases n)
    case 0
    with Suc.prems show ?thesis by (cases xs; auto)
  next
    case prems: (Suc nat)
    from Suc.prems have [simp]: "hd xs # tl xs @ ys = xs @ ys" for ys
      by (cases xs; auto)
    from Suc.prems have **: "tl xs @ ys = tl (xs @ ys)" for ys
      by (cases xs; auto)
    from prems Suc show ?thesis
      by (fastforce intro: steps_append')
  qed
qed

notation E ("_ \<rightarrow> _" [100, 100] 40)

abbreviation reaches ("_ \<rightarrow>* _" [100, 100] 40) where "reaches x y \<equiv> E\<^sup>*\<^sup>* x y"

abbreviation reaches1 ("_ \<rightarrow>\<^sup>+ _" [100, 100] 40) where "reaches1 x y \<equiv> E\<^sup>+\<^sup>+ x y"

lemma steps_reaches:
  "hd xs \<rightarrow>* last xs" if "steps xs"
  using that by (induction xs) auto

lemma steps_reaches':
  "x \<rightarrow>* y" if "steps xs" "hd xs = x" "last xs = y"
  using that steps_reaches by auto

lemma reaches_steps:
  "\<exists> xs. hd xs = x \<and> last xs = y \<and> steps xs" if "x \<rightarrow>* y"
  using that
  apply (induction)
   apply force
  apply clarsimp
  subgoal for z xs
    by (inst_existentials "xs @ [z]", (cases xs; simp), auto intro: steps_append_single)
  done

lemma reaches_steps_iff:
  "x \<rightarrow>* y \<longleftrightarrow> (\<exists> xs. hd xs = x \<and> last xs = y \<and> steps xs)"
  using steps_reaches reaches_steps by fast

lemma steps_reaches1:
  "x \<rightarrow>\<^sup>+ y" if "steps (x # xs @ [y])"
  by (metis list.sel(1,3) rtranclp_into_tranclp2 snoc_eq_iff_butlast steps.cases steps_reaches that)

lemma stepsI:
  "steps (x # xs)" if "x \<rightarrow> hd xs" "steps xs"
  using that by (cases xs) auto

lemma reaches1_steps:
  "\<exists> xs. steps (x # xs @ [y])" if "x \<rightarrow>\<^sup>+ y"
proof -
  from that obtain z where "x \<rightarrow> z" "z \<rightarrow>* y"
    by atomize_elim (simp add: tranclpD)
  from reaches_steps[OF this(2)] obtain xs where *: "hd xs = z" "last xs = y" "steps xs"
    by auto
  then obtain xs' where [simp]: "xs = xs' @ [y]"
    by atomize_elim (auto 4 3 intro: append_butlast_last_id[symmetric])
  with \<open>x \<rightarrow> z\<close> * show ?thesis
    by (auto intro: stepsI)
qed

lemma reaches1_steps_iff:
  "x \<rightarrow>\<^sup>+ y \<longleftrightarrow> (\<exists> xs. steps (x # xs @ [y]))"
  using steps_reaches1 reaches1_steps by fast

lemma reaches_steps_iff2:
  "x \<rightarrow>* y \<longleftrightarrow> (x = y \<or> (\<exists>vs. steps (x # vs @ [y])))"
  by (simp add: Nitpick.rtranclp_unfold reaches1_steps_iff)

lemma reaches1_reaches_iff1:
  "x \<rightarrow>\<^sup>+ y \<longleftrightarrow> (\<exists> z. x \<rightarrow> z \<and> z \<rightarrow>* y)"
  by (auto dest: tranclpD)

lemma
  "x \<rightarrow>\<^sup>+ z" if "x \<rightarrow>* y" "y \<rightarrow>\<^sup>+ z"
  using that by auto

lemma
  "x \<rightarrow>\<^sup>+ z" if "x \<rightarrow>\<^sup>+ y" "y \<rightarrow>* z"
  using that by auto

lemma steps_append2:
  "steps (xs @ x # ys)" if "steps (xs @ [x])" "steps (x # ys)"
  using that by (auto dest: steps_append)

lemma reaches1_steps_append:
  assumes "a \<rightarrow>\<^sup>+ b" "steps xs" "hd xs = b"
  shows "\<exists> ys. steps (a # ys @ xs)"
  using assms by (fastforce intro: steps_append' dest: reaches1_steps)

lemma steps_last_step:
  "\<exists> a. a \<rightarrow> last xs" if "steps xs" "length xs > 1"
  using that by induction auto

lemma steps_remove_cycleE:
  assumes "steps (a # xs @ [b])"
  obtains ys where "steps (a # ys @ [b])" "distinct ys" "a \<notin> set ys" "b \<notin> set ys" "set ys \<subseteq> set xs"
  using assms
proof (induction "length xs" arbitrary: xs rule: less_induct)
  case less
  note prems = less.prems(2) and intro = less.prems(1) and IH = less.hyps
  consider
    "distinct xs" "a \<notin> set xs" "b \<notin> set xs" | "a \<in> set xs" | "b \<in> set xs" | "\<not> distinct xs"
    by auto
  then consider (goal) ?case
    | (a) as bs where "xs = as @ a # bs" | (b) as bs where "xs = as @ b # bs"
    | (between) x as bs cs where "xs = as @ x # bs @ x # cs"
    using prems by (cases; fastforce dest: not_distinct_decomp simp: split_list intro: intro)
  then show ?case
  proof cases
    case a
    with prems show ?thesis
      by - (rule IH[where xs = bs], auto 4 3 intro: intro dest: stepsD)
  next
    case b
    with prems have "steps (a # as @ b # [] @ (bs @ [b]))"
      by simp
    then have "steps (a # as @ [b])"
      by (metis Cons_eq_appendI Graph_Defs.steps_appendD1 append_eq_appendI neq_Nil_conv)
    with b show ?thesis
      by - (rule IH[where xs = as], auto 4 3 dest: stepsD intro: intro)
  next
    case between
    with prems have "steps (a # as @ x # cs @ [b])"
      by simp (metis
          stepsI append_Cons list.distinct(1) list.sel(1) list.sel(3) steps_append steps_decomp)
    with between show ?thesis
      by - (rule IH[where xs = "as @ x # cs"], auto 4 3 intro: intro dest: stepsD)
  qed
qed

lemma reaches1_stepsE:
  assumes "a \<rightarrow>\<^sup>+ b"
  obtains xs where "steps (a # xs @ [b])" "distinct xs" "a \<notin> set xs" "b \<notin> set xs"
proof -
  from assms obtain xs where "steps (a # xs @ [b])"
    by (auto dest: reaches1_steps)
  then show ?thesis
    by - (erule steps_remove_cycleE, rule that)
qed

lemma reaches_stepsE:
  assumes "a \<rightarrow>* b"
  obtains "a = b" | xs where "steps (a # xs @ [b])" "distinct xs" "a \<notin> set xs" "b \<notin> set xs"
proof -
  from assms consider "a = b" | xs where "a \<rightarrow>\<^sup>+ b"
    by (meson rtranclpD)
  then show ?thesis
    by cases ((erule reaches1_stepsE)?; rule that; assumption)+
qed

definition sink where
  "sink a \<equiv> \<nexists>b. a \<rightarrow> b"

lemma sink_or_cycle:
  assumes "finite {b. reaches a b}"
  obtains b where "reaches a b" "sink b" | b where "reaches a b" "reaches1 b b"
proof -
  let ?S = "{b. reaches1 a b}"
  have "?S \<subseteq> {b. reaches a b}"
    by auto
  then have "finite ?S"
    using assms by (rule finite_subset)
  then show ?thesis
    using that
  proof (induction ?S arbitrary: a rule: finite_psubset_induct)
    case psubset
    consider (empty) "Collect (reaches1 a) = {}" | b where "reaches1 a b"
      by auto
    then show ?case
    proof cases
      case empty
      then have "sink a"
        unfolding sink_def by auto
      with psubset.prems show ?thesis
        by auto
    next
      case 2
      show ?thesis
      proof (cases "reaches b a")
        case True
        with \<open>reaches1 a b\<close> have "reaches1 a a"
          by auto
        with psubset.prems show ?thesis
          by auto
      next
        case False
        show ?thesis
        proof (cases "reaches1 b b")
          case True
          with \<open>reaches1 a b\<close> psubset.prems show ?thesis
            by (auto intro: tranclp_into_rtranclp)
        next
          case False
          with \<open>\<not> reaches b a\<close> \<open>reaches1 a b\<close> have "Collect (reaches1 b) \<subset> Collect (reaches1 a)"
            by (intro psubsetI) auto
          then show ?thesis
            using \<open>reaches1 a b\<close> psubset.prems
            by - (erule psubset.hyps; meson tranclp_into_rtranclp tranclp_rtranclp_tranclp)
        qed
      qed
    qed
  qed
qed

text \<open>
  A directed graph where every node has at least one ingoing edge, contains a directed cycle.
\<close>
lemma directed_graph_indegree_ge_1_cycle':
  assumes "finite S" "S \<noteq> {}" "\<forall> y \<in> S. \<exists> x \<in> S. E x y"
  shows "\<exists> x \<in> S. \<exists> y. E x y \<and> E\<^sup>*\<^sup>* y x"
  using assms
proof (induction arbitrary: E rule: finite_ne_induct)
  case (singleton x)
  then show ?case by auto
next
  case (insert x S E)
  from insert.prems obtain y where "y \<in> insert x S" "E y x"
    by auto
  show ?case
  proof (cases "y = x")
    case True
    with \<open>E y x\<close> show ?thesis by auto
  next
    case False
    with \<open>y \<in> _\<close> have "y \<in> S" by auto
    define E' where "E' a b \<equiv> E a b \<or> (a = y \<and> E x b)" for a b
    have E'_E: "\<exists> c. E a c \<and> E\<^sup>*\<^sup>* c b" if "E' a b" for a b
      using that \<open>E y x\<close> unfolding E'_def by auto
    have [intro]: "E\<^sup>*\<^sup>* a b" if "E' a b" for a b
      using that \<open>E y x\<close> unfolding E'_def by auto
    have [intro]: "E\<^sup>*\<^sup>* a b" if "E'\<^sup>*\<^sup>* a b" for a b
      using that by (induction; blast intro: rtranclp_trans)
    have "\<forall>y\<in>S. \<exists>x\<in>S. E' x y"
    proof (rule ballI)
      fix b assume "b \<in> S"
      with insert.prems obtain a where "a \<in> insert x S" "E a b"
        by auto
      show "\<exists>a\<in>S. E' a b"
      proof (cases "a = x")
        case True
        with \<open>E a b\<close> have "E' y b" unfolding E'_def by simp
        with \<open>y \<in> S\<close> show ?thesis ..
      next
        case False
        with \<open>a \<in> _\<close> \<open>E a b\<close> show ?thesis unfolding E'_def by auto
      qed
    qed
    from insert.IH[OF this] guess x y by safe
    then show ?thesis by (blast intro: rtranclp_trans dest: E'_E)
    qed
  qed

lemma directed_graph_indegree_ge_1_cycle:
  assumes "finite S" "S \<noteq> {}" "\<forall> y \<in> S. \<exists> x \<in> S. E x y"
  shows "\<exists> x \<in> S. \<exists> y. x \<rightarrow>\<^sup>+ x"
  using directed_graph_indegree_ge_1_cycle'[OF assms] reaches1_reaches_iff1 by blast

text \<open>Vertices of a graph\<close>

definition "vertices = {x. \<exists>y. E x y \<or> E y x}"

lemma reaches1_verts:
  assumes "x \<rightarrow>\<^sup>+ y"
  shows "x \<in> vertices" and "y \<in> vertices"
  using assms reaches1_reaches_iff2 reaches1_reaches_iff1 vertices_def by blast+

lemmas graphI =
  steps.intros
  steps_append_single
  steps_reaches'
  stepsI

end (* Graph Defs *)

section \<open>Graphs with a Start Node\<close>

locale Graph_Start_Defs = Graph_Defs +
  fixes s\<^sub>0 :: 'a
begin

definition reachable where
  "reachable = E\<^sup>*\<^sup>* s\<^sub>0"

lemma start_reachable[intro!, simp]:
  "reachable s\<^sub>0"
  unfolding reachable_def by auto

lemma reachable_step:
  "reachable b" if "reachable a" "E a b"
  using that unfolding reachable_def by auto

lemma reachable_reaches:
  "reachable b" if "reachable a" "a \<rightarrow>* b"
  using that(2,1) by induction (auto intro: reachable_step)

lemma reachable_steps_append:
  assumes "reachable a" "steps xs" "hd xs = a" "last xs = b"
  shows "reachable b"
  using assms by (auto intro: graphI reachable_reaches)

lemmas steps_reachable = reachable_steps_append[of s\<^sub>0, simplified]

lemma reachable_steps_elem:
  "reachable y" if "reachable x" "steps xs" "y \<in> set xs" "hd xs = x"
proof -
  from \<open>y \<in> set xs\<close> obtain as bs where [simp]: "xs = as @ y # bs"
    by (auto simp: in_set_conv_decomp)
  show ?thesis
  proof (cases "as = []")
    case True
    with that show ?thesis
      by simp
  next
    case False
    (* XXX *)
    from \<open>steps xs\<close> have "steps (as @ [y])"
      by (auto intro: stepsD)
    with \<open>as \<noteq> []\<close> \<open>hd xs = x\<close> \<open>reachable x\<close> show ?thesis
      by (auto 4 3 intro: reachable_reaches graphI)
  qed
qed

lemma reachable_steps:
  "\<exists> xs. steps xs \<and> hd xs = s\<^sub>0 \<and> last xs = x" if "reachable x"
  using that unfolding reachable_def
proof induction
  case base
  then show ?case by (inst_existentials "[s\<^sub>0]"; force)
next
  case (step y z)
  from step.IH guess xs by clarify
  with step.hyps show ?case
    apply (inst_existentials "xs @ [z]")
    apply (force intro: graphI)
    by (cases xs; auto)+
qed

lemma reachable_cycle_iff:
  "reachable x \<and> x \<rightarrow>\<^sup>+ x \<longleftrightarrow> (\<exists> ws xs. steps (s\<^sub>0 # ws @ [x] @ xs @ [x]))"
proof (safe, goal_cases)
  case (2 ws)
  then show ?case
    by (auto intro: steps_reachable stepsD)
next
  case (3 ws xs)
  then show ?case
    by (auto intro: stepsD steps_reaches1)
next
  case prems: 1
  from \<open>reachable x\<close> prems(2) have "s\<^sub>0 \<rightarrow>\<^sup>+ x"
    unfolding reachable_def by auto
  with \<open>x \<rightarrow>\<^sup>+ x\<close> show ?case
    by (fastforce intro: steps_append' dest: reaches1_steps)
qed

lemma reachable_induct[consumes 1, case_names start step, induct pred: reachable]:
  assumes "reachable x"
    and "P s\<^sub>0"
    and "\<And> a b. reachable a \<Longrightarrow> P a \<Longrightarrow> a \<rightarrow> b \<Longrightarrow> P b"
  shows "P x"
  using assms(1) unfolding reachable_def
  by induction (auto intro: assms(2-)[unfolded reachable_def])

lemmas graphI_aggressive =
  tranclp_into_rtranclp
  rtranclp.rtrancl_into_rtrancl
  tranclp.trancl_into_trancl
  rtranclp_into_tranclp2

lemmas graphI_aggressive1 =
  graphI_aggressive
  steps_append'

lemmas graphI_aggressive2 =
  graphI_aggressive
  stepsD
  steps_reaches1
  steps_reachable

lemmas graphD =
  reaches1_steps

lemmas graphD_aggressive =
  tranclpD

lemmas graph_startI =
  reachable_reaches
  start_reachable

end (* Graph Start Defs *)

section \<open>Subgraphs\<close>

subsection \<open>Edge-induced Subgraphs\<close>

locale Subgraph_Defs = G: Graph_Defs +
  fixes E' :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

sublocale G': Graph_Defs E' .

end (* Subgraph Defs *)

locale Subgraph_Start_Defs = G: Graph_Start_Defs +
  fixes E' :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

sublocale G': Graph_Start_Defs E' s\<^sub>0 .

end (* Subgraph Start Defs *)

locale Subgraph = Subgraph_Defs +
  assumes subgraph[intro]: "E' a b \<Longrightarrow> E a b"
begin

lemma non_subgraph_cycle_decomp:
  "\<exists> c d. G.reaches a c \<and> E c d \<and> \<not> E' c d \<and> G.reaches d b" if
  "G.reaches1 a b" "\<not> G'.reaches1 a b" for a b
    using that
  proof induction
    case (base y)
    then show ?case
      by auto
  next
    case (step y z)
    show ?case
    proof (cases "E' y z")
      case True
      with step have "\<not> G'.reaches1 a y"
        by (auto intro: tranclp.trancl_into_trancl) (* XXX *)
      with step obtain c d where
        "G.reaches a c" "E c d" "\<not> E' c d" "G.reaches d y"
        by auto
      with \<open>E' y z\<close> show ?thesis
        by (blast intro: rtranclp.rtrancl_into_rtrancl) (* XXX *)
    next
      case False
      with step show ?thesis
        by (intro exI conjI) auto
    qed
  qed

lemma reaches:
  "G.reaches a b" if "G'.reaches a b"
  using that by induction (auto intro: rtranclp.intros(2))

lemma reaches1:
  "G.reaches1 a b" if "G'.reaches1 a b"
  using that by induction (auto intro: tranclp.intros(2))

end (* Subgraph *)

locale Subgraph_Start = Subgraph_Start_Defs + Subgraph
begin

lemma reachable_subgraph[intro]: "G.reachable b" if \<open>G.reachable a\<close> \<open>G'.reaches a b\<close> for a b
  using that by (auto intro: G.graph_startI mono_rtranclp[rule_format, of E'])

lemma reachable:
  "G.reachable x" if "G'.reachable x"
  using that by (fastforce simp: G.reachable_def G'.reachable_def)

end (* Subgraph Start *)

subsection \<open>Node-induced Subgraphs\<close>

locale Subgraph_Node_Defs = Graph_Defs +
  fixes V :: "'a \<Rightarrow> bool"
begin

definition E' where "E' x y \<equiv> E x y \<and> V x \<and> V y"

sublocale Subgraph E E' by standard (auto simp: E'_def)

lemma subgraph':
  "E' x y" if "E x y" "V x" "V y"
  using that unfolding E'_def by auto

lemma E'_V1:
  "V x" if "E' x y"
  using that unfolding E'_def by auto

lemma E'_V2:
  "V y" if "E' x y"
  using that unfolding E'_def by auto

lemma G'_reaches_V:
  "V y" if "G'.reaches x y" "V x"
  using that by (cases) (auto intro: E'_V2)

lemma G'_steps_V_all:
  "list_all V xs" if "G'.steps xs" "V (hd xs)"
  using that by induction (auto intro: E'_V2)

lemma G'_steps_V_last:
  "V (last xs)" if "G'.steps xs" "V (hd xs)"
  using that by induction (auto dest: E'_V2)

lemmas subgraphI = E'_V1 E'_V2 G'_reaches_V

lemmas subgraphD = E'_V1 E'_V2 G'_reaches_V

end (* Subgraph Node *)

locale Subgraph_Node_Defs_Notation = Subgraph_Node_Defs
begin

no_notation E ("_ \<rightarrow> _" [100, 100] 40)
notation E' ("_ \<rightarrow> _" [100, 100] 40)
no_notation reaches ("_ \<rightarrow>* _" [100, 100] 40)
notation G'.reaches ("_ \<rightarrow>* _" [100, 100] 40)
no_notation reaches1 ("_ \<rightarrow>\<^sup>+ _" [100, 100] 40)
notation G'.reaches1 ("_ \<rightarrow>\<^sup>+ _" [100, 100] 40)

end (* Subgraph_Node_Defs_Notation *)

subsection \<open>The Reachable Subgraph\<close>

context Graph_Start_Defs
begin

interpretation Subgraph_Node_Defs_Notation E reachable .

sublocale reachable_subgraph: Subgraph_Node_Defs E reachable .

lemma reachable_supgraph:
  "x \<rightarrow> y" if "E x y" "reachable x"
  using that unfolding E'_def by (auto intro: graph_startI)

lemma reachable_reaches_equiv: "reaches x y \<longleftrightarrow> x \<rightarrow>* y" if "reachable x" for x y
  apply standard
  subgoal premises prems
    using prems \<open>reachable x\<close>
    by induction (auto dest: reachable_supgraph intro: graph_startI graphI_aggressive)
  subgoal premises prems
    using prems \<open>reachable x\<close>
    by induction (auto dest: subgraph)
  done

lemma reachable_reaches1_equiv: "reaches1 x y \<longleftrightarrow> x \<rightarrow>\<^sup>+ y" if "reachable x" for x y
  apply standard
  subgoal premises prems
    using prems \<open>reachable x\<close>
    by induction (auto dest: reachable_supgraph intro: graph_startI graphI_aggressive)
  subgoal premises prems
    using prems \<open>reachable x\<close>
    by induction (auto dest: subgraph)
  done

lemma reachable_steps_equiv:
  "steps (x # xs) \<longleftrightarrow> G'.steps (x # xs)" if "reachable x"
  apply standard
  subgoal premises prems
    using prems \<open>reachable x\<close>
    by (induction "x # xs" arbitrary: x xs) (auto dest: reachable_supgraph intro: graph_startI)
  subgoal premises prems
    using prems by induction auto
  done

end (* Graph Start Defs *)

section \<open>Bundles\<close>

bundle graph_automation
begin

lemmas [intro] = Graph_Defs.graphI Graph_Start_Defs.graph_startI
lemmas [dest]  = Graph_Start_Defs.graphD

end (* Bundle *)

bundle reaches_steps_iff =
  Graph_Defs.reaches1_steps_iff [iff]
  Graph_Defs.reaches_steps_iff  [iff]

bundle graph_automation_aggressive
begin

unbundle graph_automation

lemmas [intro] = Graph_Start_Defs.graphI_aggressive
lemmas [dest]  = Graph_Start_Defs.graphD_aggressive

end (* Bundle *)

bundle subgraph_automation
begin

unbundle graph_automation

lemmas [intro] = Subgraph_Node_Defs.subgraphI
lemmas [dest]  = Subgraph_Node_Defs.subgraphD

end (* Bundle *)

section \<open>Directed Acyclic Graphs\<close>
locale DAG = Graph_Defs +
  assumes acyclic: "\<not> E\<^sup>+\<^sup>+ x x"
begin

lemma topological_numbering:
  fixes S assumes "finite S"
  shows "\<exists>f :: _ \<Rightarrow> nat. inj_on f S \<and> (\<forall>x \<in> S. \<forall>y \<in> S. E x y \<longrightarrow> f x < f y)"
  using assms
proof (induction rule: finite_psubset_induct)
  case (psubset A)
  show ?case
  proof (cases "A = {}")
    case True
    then show ?thesis
      by simp
  next
    case False
    then obtain x where x: "x \<in> A" "\<forall>y \<in> A. \<not>E y x"
      using directed_graph_indegree_ge_1_cycle[OF \<open>finite A\<close>] acyclic by auto
    let ?A = "A - {x}"
    from \<open>x \<in> A\<close> have "?A \<subset> A"
      by auto
    from psubset.IH(1)[OF this] obtain f :: "_ \<Rightarrow> nat" where f:
      "inj_on f ?A" "\<forall>x\<in>?A. \<forall>y\<in>?A. x \<rightarrow> y \<longrightarrow> f x < f y"
      by blast
    let ?f = "\<lambda>y. if x \<noteq> y then f y + 1 else 0"
    from \<open>x \<in> A\<close> have "A = insert x ?A"
      by auto
    from \<open>inj_on f ?A\<close> have "inj_on ?f A"
      by (auto simp: inj_on_def)
    moreover from f(2) x(2) have "\<forall>x\<in>A. \<forall>y\<in>A. x \<rightarrow> y \<longrightarrow> ?f x < ?f y"
      by auto
    ultimately show ?thesis
      by blast
  qed
qed

end

section \<open>Finite Graphs\<close>

locale Finite_Graph = Graph_Defs +
  assumes finite_graph: "finite vertices"

locale Finite_DAG = Finite_Graph + DAG
begin

lemma finite_reachable:
  "finite {y. x \<rightarrow>* y}" (is "finite ?S")
proof -
  have "?S \<subseteq> insert x vertices"
    by (metis insertCI mem_Collect_eq reaches1_verts(2) rtranclpD subsetI)
  also from finite_graph have "finite \<dots>" ..
  finally show ?thesis .
qed

end

section \<open>Graph Invariants\<close>

locale Graph_Invariant = Graph_Defs +
  fixes P :: "'a \<Rightarrow> bool"
  assumes invariant: "P a \<Longrightarrow> a \<rightarrow> b \<Longrightarrow> P b"
begin

lemma invariant_steps:
  "list_all P as" if "steps (a # as)" "P a"
  using that by (induction "a # as" arbitrary: as a) (auto intro: invariant)

lemma invariant_reaches:
  "P b" if "a \<rightarrow>* b" "P a"
  using that by (induction; blast intro: invariant)

lemma invariant_run:
  assumes run: "run (x ## xs)" and P: "P x"
  shows "pred_stream P (x ## xs)"
  using run P by (coinduction arbitrary: x xs) (auto 4 3 elim: invariant run.cases)

text \<open>Every graph invariant induces a subgraph.\<close>
sublocale Subgraph_Node_Defs where E = E and V = P .

lemma subgraph':
  assumes "x \<rightarrow> y" "P x"
  shows "E' x y"
  using assms by (intro subgraph') (auto intro: invariant)

lemma invariant_steps_iff:
  "G'.steps (v # vs) \<longleftrightarrow> steps (v # vs)" if "P v"
  apply (rule iffI)
  subgoal
    using G'.steps_alt_induct steps_appendI by blast
  subgoal premises prems
    using prems \<open>P v\<close> by (induction "v # vs" arbitrary: v vs) (auto intro: subgraph' invariant)
  done

lemma invariant_reaches_iff:
  "G'.reaches u v \<longleftrightarrow> reaches u v" if "P u"
  using that by (simp add: reaches_steps_iff2 G'.reaches_steps_iff2 invariant_steps_iff)

lemma invariant_reaches1_iff:
  "G'.reaches1 u v \<longleftrightarrow> reaches1 u v" if "P u"
  using that by (simp add: reaches1_steps_iff G'.reaches1_steps_iff invariant_steps_iff)

end (* Graph Invariant *)

locale Graph_Invariants = Graph_Defs +
  fixes P Q :: "'a \<Rightarrow> bool"
  assumes invariant: "P a \<Longrightarrow> a \<rightarrow> b \<Longrightarrow> Q b" and Q_P: "Q a \<Longrightarrow> P a"
begin

sublocale Pre: Graph_Invariant E P
  by standard (blast intro: invariant Q_P)

sublocale Post: Graph_Invariant E Q
  by standard (blast intro: invariant Q_P)

lemma invariant_steps:
  "list_all Q as" if "steps (a # as)" "P a"
  using that by (induction "a # as" arbitrary: as a) (auto intro: invariant Q_P)

lemma invariant_run:
  assumes run: "run (x ## xs)" and P: "P x"
  shows "pred_stream Q xs"
  using run P by (coinduction arbitrary: x xs) (auto 4 4 elim: invariant run.cases intro: Q_P)

lemma invariant_reaches1:
  "Q b" if "a \<rightarrow>\<^sup>+ b" "P a"
  using that by (induction; blast intro: invariant Q_P)

end (* Graph Invariants *)

locale Graph_Invariant_Start = Graph_Start_Defs + Graph_Invariant +
  assumes P_s\<^sub>0: "P s\<^sub>0"
begin

lemma invariant_steps:
  "list_all P as" if "steps (s\<^sub>0 # as)"
  using that P_s\<^sub>0 by (rule invariant_steps)

lemma invariant_reaches:
  "P b" if "s\<^sub>0 \<rightarrow>* b"
  using invariant_reaches[OF that P_s\<^sub>0] .

lemmas invariant_run = invariant_run[OF _ P_s\<^sub>0]

end (* Graph Invariant Start *)

locale Graph_Invariant_Strong = Graph_Defs +
  fixes P :: "'a \<Rightarrow> bool"
  assumes invariant: "a \<rightarrow> b \<Longrightarrow> P b"
begin

sublocale inv: Graph_Invariant by standard (rule invariant)

lemma P_invariant_steps:
  "list_all P as" if "steps (a # as)"
  using that by (induction "a # as" arbitrary: as a) (auto intro: invariant)

lemma steps_last_invariant:
  "P (last xs)" if "steps (x # xs)" "xs \<noteq> []"
  using steps_last_step[of "x # xs"] that by (auto intro: invariant)

lemmas invariant_reaches = inv.invariant_reaches

lemma invariant_reaches1:
  "P b" if "a \<rightarrow>\<^sup>+ b"
  using that by (induction; blast intro: invariant)

end (* Graph Invariant *)

section \<open>Simulations and Bisimulations\<close>
locale Simulation_Defs =
  fixes A :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and B :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
    and sim :: "'a \<Rightarrow> 'b \<Rightarrow> bool" (infixr "\<sim>" 60)
begin

sublocale A: Graph_Defs A .

sublocale B: Graph_Defs B .

end (* Simulation Defs *)

locale Simulation = Simulation_Defs +
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
begin

lemma simulation_reaches:
  "\<exists> b'. B\<^sup>*\<^sup>* b b' \<and> a' \<sim> b'" if "A\<^sup>*\<^sup>* a a'" "a \<sim> b"
  using that by (induction rule: rtranclp_induct) (auto intro: rtranclp.intros(2) dest: A_B_step)

lemma simulation_reaches1:
  "\<exists> b'. B\<^sup>+\<^sup>+ b b' \<and> a' \<sim> b'" if "A\<^sup>+\<^sup>+ a a'" "a \<sim> b"
  using that by (induction rule: tranclp_induct) (auto 4 3 intro: tranclp.intros(2) dest: A_B_step)

lemma simulation_steps:
  "\<exists> bs. B.steps (b # bs) \<and> list_all2 (\<lambda> a b. a \<sim> b) as bs" if "A.steps (a # as)" "a \<sim> b"
  using that
  apply (induction "a # as" arbitrary: a b as)
   apply force
  apply (frule A_B_step, auto)
  done

lemma simulation_run:
  "\<exists> ys. B.run (y ## ys) \<and> stream_all2 (\<sim>) xs ys" if "A.run (x ## xs)" "x \<sim> y"
proof -
  let ?ys = "sscan (\<lambda> a' b. SOME b'. B b b' \<and> a' \<sim> b') xs y"
  have "B.run (y ## ?ys)"
    using that by (coinduction arbitrary: x y xs) (force dest!: someI_ex A_B_step elim: A.run.cases)
  moreover have "stream_all2 (\<sim>) xs ?ys"
    using that by (coinduction arbitrary: x y xs) (force dest!: someI_ex A_B_step elim: A.run.cases)
  ultimately show ?thesis by blast
qed

end (* Simulation *)

lemma (in Subgraph) Subgraph_Simulation:
  "Simulation E' E (=)"
  by standard auto

locale Simulation_Invariant = Simulation_Defs +
  fixes PA :: "'a \<Rightarrow> bool" and PB :: "'b \<Rightarrow> bool"
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
  assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> PA b"
  assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> PB b"
begin

definition "equiv' \<equiv> \<lambda> a b. a \<sim> b \<and> PA a \<and> PB b"

sublocale Simulation A B equiv' by standard (auto dest: A_B_step simp: equiv'_def)

sublocale PA_invariant: Graph_Invariant A PA by standard blast

sublocale PB_invariant: Graph_Invariant B PB by standard blast

lemma simulation_reaches:
  "\<exists> b'. B\<^sup>*\<^sup>* b b' \<and> a' \<sim> b' \<and> PA a' \<and> PB b'" if "A\<^sup>*\<^sup>* a a'" "a \<sim> b" "PA a" "PB b"
  using simulation_reaches[of a a' b] that unfolding equiv'_def by simp

lemma simulation_steps:
  "\<exists> bs. B.steps (b # bs) \<and> list_all2 (\<lambda> a b. a \<sim> b \<and> PA a \<and> PB b) as bs"
  if "A.steps (a # as)" "a \<sim> b" "PA a" "PB b"
  using simulation_steps[of a as b] that unfolding equiv'_def by simp

lemma simulation_steps':
  "\<exists> bs. B.steps (b # bs) \<and> list_all2 (\<lambda> a b. a \<sim> b) as bs \<and> list_all PA as \<and> list_all PB bs"
  if "A.steps (a # as)" "a \<sim> b" "PA a" "PB b"
  using simulation_steps[OF that]
  by (force dest: list_all2_set1 list_all2_set2 simp: list_all_iff elim: list_all2_mono)

context
  fixes f
  assumes eq: "a \<sim> b \<Longrightarrow> b = f a"
begin

lemma simulation_steps'_map:
  "\<exists> bs.
    B.steps (b # bs) \<and> bs = map f as
    \<and> list_all2 (\<lambda> a b. a \<sim> b) as bs
    \<and> list_all PA as \<and> list_all PB bs"
  if "A.steps (a # as)" "a \<sim> b" "PA a" "PB b"
proof -
  from simulation_steps'[OF that] guess bs by clarify
  note guessed = this
  from this(2) have "bs = map f as"
    by (induction; simp add: eq)
  with guessed show ?thesis
    by auto
qed

end (* Context for Equality Relation *)

end (* Simulation Invariant *)

locale Simulation_Invariants = Simulation_Defs +
  fixes PA QA :: "'a \<Rightarrow> bool" and PB QB :: "'b \<Rightarrow> bool"
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
  assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> QA b"
  assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> QB b"
  assumes PA_QA[intro]: "\<And> a. QA a \<Longrightarrow> PA a" and PB_QB[intro]: "\<And> a. QB a \<Longrightarrow> PB a"
begin

sublocale Pre: Simulation_Invariant A B "(\<sim>)" PA PB
  by standard (auto intro: A_B_step)

sublocale Post: Simulation_Invariant A B "(\<sim>)" QA QB
  by standard (auto intro: A_B_step)

sublocale A_invs: Graph_Invariants A PA QA
  by standard auto

sublocale B_invs: Graph_Invariants B PB QB
  by standard auto

lemma simulation_reaches1:
  "\<exists> b2. B.reaches1 b1 b2 \<and> a2 \<sim> b2 \<and> QB b2" if "A.reaches1 a1 a2" "a1 \<sim> b1" "PA a1" "PB b1"
  using that
  by - (drule Pre.simulation_reaches1, auto intro: B_invs.invariant_reaches1 simp: Pre.equiv'_def)

lemma reaches1_unique:
  assumes unique: "\<And> b2. a \<sim> b2 \<Longrightarrow> QB b2 \<Longrightarrow> b2 = b"
    and that: "A.reaches1 a a" "a \<sim> b" "PA a" "PB b"
  shows "B.reaches1 b b"
  using that by (auto dest: unique simulation_reaches1)

end (* Simualation Invariants *)

locale Bisimulation = Simulation_Defs +
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
  assumes B_A_step: "\<And> a a' b'. B a' b' \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b. A a b \<and> b \<sim> b')"
begin

sublocale A_B: Simulation A B "(\<sim>)" by standard (rule A_B_step)

sublocale B_A: Simulation B A "\<lambda> x y. y \<sim> x" by standard (rule B_A_step)

lemma A_B_reaches:
  "\<exists> b'. B\<^sup>*\<^sup>* b b' \<and> a' \<sim> b'" if "A\<^sup>*\<^sup>* a a'" "a \<sim> b"
  using A_B.simulation_reaches[OF that] .

lemma B_A_reaches:
  "\<exists> b'. A\<^sup>*\<^sup>* b b' \<and> b' \<sim> a'" if "B\<^sup>*\<^sup>* a a'" "b \<sim> a"
  using B_A.simulation_reaches[OF that] .

end (* Bisim *)

locale Bisimulation_Invariant = Simulation_Defs +
  fixes PA :: "'a \<Rightarrow> bool" and PB :: "'b \<Rightarrow> bool"
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
  assumes B_A_step: "\<And> a a' b'. B a' b' \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b. A a b \<and> b \<sim> b')"
  assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> PA b"
  assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> PB b"
begin

sublocale PA_invariant: Graph_Invariant A PA by standard blast

sublocale PB_invariant: Graph_Invariant B PB by standard blast

lemmas B_steps_invariant[intro] = PB_invariant.invariant_reaches

definition "equiv' \<equiv> \<lambda> a b. a \<sim> b \<and> PA a \<and> PB b"

sublocale bisim: Bisimulation A B equiv'
  by standard (clarsimp simp add: equiv'_def, frule A_B_step B_A_step, assumption; auto)+

sublocale A_B: Simulation_Invariant A B "(\<sim>)" PA PB
  by (standard; blast intro: A_B_step B_A_step)

sublocale B_A: Simulation_Invariant B A "\<lambda> x y. y \<sim> x" PB PA
  by (standard; blast intro: A_B_step B_A_step)

context
  fixes f
  assumes eq: "a \<sim> b \<longleftrightarrow> b = f a"
    and inj: "\<forall> a b. PB (f a) \<and> PA b \<and> f a = f b \<longrightarrow> a = b"
begin

lemma list_all2_inj_map_eq:
  "as = bs" if "list_all2 (\<lambda>a b. a = f b) (map f as) bs" "list_all PB (map f as)" "list_all PA bs"
  using that inj
  by (induction "map f as" bs arbitrary: as rule: list_all2_induct) (auto simp: inj_on_def)

lemma steps_map_equiv:
  "A.steps (a # as) \<longleftrightarrow> B.steps (b # map f as)" if "a \<sim> b" "PA a" "PB b"
  using A_B.simulation_steps'_map[of f a as b] B_A.simulation_steps'[of b "map f as" a] that eq
  by (auto dest: list_all2_inj_map_eq)

lemma steps_map:
  "\<exists> as. bs = map f as" if "B.steps (f a # bs)" "PA a" "PB (f a)"
proof -
  have "a \<sim> f a" unfolding eq ..
  from B_A.simulation_steps'[OF that(1) this \<open>PB _\<close> \<open>PA _\<close>] guess as by clarify
  from this(2) show ?thesis
    unfolding eq by (inst_existentials as, induction rule: list_all2_induct, auto)
qed

lemma reaches_equiv:
  "A.reaches a a' \<longleftrightarrow> B.reaches (f a) (f a')" if "PA a" "PB (f a)"
  apply safe
   apply (drule A_B.simulation_reaches[of a a' "f a"]; simp add: eq that)
  apply (drule B_A.simulation_reaches)
     defer
     apply (rule that | clarsimp simp: eq | metis inj)+
  done

end (* Context for Equality Relation *)

lemma equiv'_D:
  "a \<sim> b" if "A_B.equiv' a b"
  using that unfolding A_B.equiv'_def by auto

lemma equiv'_rotate_1:
  "B_A.equiv' b a" if "A_B.equiv' a b"
  using that by (auto simp: B_A.equiv'_def A_B.equiv'_def)

lemma equiv'_rotate_2:
  "A_B.equiv' a b" if "B_A.equiv' b a"
  using that by (auto simp: B_A.equiv'_def A_B.equiv'_def)

lemma stream_all2_equiv'_D:
  "stream_all2 (\<sim>) xs ys" if "stream_all2 A_B.equiv' xs ys"
  using stream_all2_weaken[OF that equiv'_D] by fast

lemma stream_all2_equiv'_D2:
  "stream_all2 B_A.equiv' ys xs \<Longrightarrow> stream_all2 ((\<sim>)\<inverse>\<inverse>) ys xs"
  by (coinduction arbitrary: xs ys) (auto simp: B_A.equiv'_def)

lemma stream_all2_rotate_1:
  "stream_all2 B_A.equiv' ys xs \<Longrightarrow> stream_all2 A_B.equiv' xs ys"
  by (coinduction arbitrary: xs ys) (auto simp: B_A.equiv'_def A_B.equiv'_def)

lemma stream_all2_rotate_2:
  "stream_all2 A_B.equiv' xs ys \<Longrightarrow> stream_all2 B_A.equiv' ys xs"
  by (coinduction arbitrary: xs ys) (auto simp: B_A.equiv'_def A_B.equiv'_def)

end (* Bisim Invariant *)

locale Bisimulation_Invariants = Simulation_Defs +
  fixes PA QA :: "'a \<Rightarrow> bool" and PB QB :: "'b \<Rightarrow> bool"
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
  assumes B_A_step: "\<And> a a' b'. B a' b' \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b. A a b \<and> b \<sim> b')"
  assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> QA b"
  assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> QB b"
  assumes PA_QA[intro]: "\<And> a. QA a \<Longrightarrow> PA a" and PB_QB[intro]: "\<And> a. QB a \<Longrightarrow> PB a"
begin

sublocale PA_invariant: Graph_Invariant A PA by standard blast

sublocale PB_invariant: Graph_Invariant B PB by standard blast

sublocale QA_invariant: Graph_Invariant A QA by standard blast

sublocale QB_invariant: Graph_Invariant B QB by standard blast

sublocale Pre_Bisim: Bisimulation_Invariant A B "(\<sim>)" PA PB
  by standard (auto intro: A_B_step B_A_step)

sublocale Post_Bisim: Bisimulation_Invariant A B "(\<sim>)" QA QB
  by standard (auto intro: A_B_step B_A_step)

sublocale A_B: Simulation_Invariants A B "(\<sim>)" PA QA PB QB
  by standard (blast intro: A_B_step)+

sublocale B_A: Simulation_Invariants B A "\<lambda> x y. y \<sim> x" PB QB PA QA
  by standard (blast intro: B_A_step)+

context
  fixes f
  assumes eq[simp]: "a \<sim> b \<longleftrightarrow> b = f a"
    and inj: "\<forall> a b. QB (f a) \<and> QA b \<and> f a = f b \<longrightarrow> a = b"
begin

lemmas list_all2_inj_map_eq = Post_Bisim.list_all2_inj_map_eq[OF eq inj]
lemmas steps_map_equiv' = Post_Bisim.steps_map_equiv[OF eq inj]

lemma steps_map_equiv:
  "A.steps (a # as) \<longleftrightarrow> B.steps (b # map f as)" if "a \<sim> b" "PA a" "PB b"
proof
  assume "A.steps (a # as)"
  then show "B.steps (b # map f as)"
  proof cases
    case Single
    then show ?thesis by auto
  next
    case prems: (Cons a' xs)
    from A_B_step[OF \<open>A a a'\<close> \<open>a \<sim> b\<close> \<open>PA a\<close> \<open>PB b\<close>] obtain b' where "B b b'" "a' \<sim> b'"
      by auto
    with steps_map_equiv'[OF \<open>a' \<sim> b'\<close>, of xs] prems that show ?thesis
      by auto
  qed
next
  assume "B.steps (b # map f as)"
  then show "A.steps (a # as)"
  proof cases
    case Single
    then show ?thesis by auto
  next
    case prems: (Cons b' xs)
    from B_A_step[OF \<open>B b b'\<close> \<open>a \<sim> b\<close> \<open>PA a\<close> \<open>PB b\<close>] obtain a' where "A a a'" "a' \<sim> b'"
      by auto
    with that prems have "QA a'" "QB b'"
      by auto
    with \<open>A a a'\<close> \<open>a' \<sim> b'\<close> steps_map_equiv'[OF \<open>a' \<sim> b'\<close>, of "tl as"] prems that show ?thesis
      apply clarsimp
      subgoal for z zs
        using inj[rule_format, of z a'] by auto
      done
  qed
qed

lemma steps_map:
  "\<exists> as. bs = map f as" if "B.steps (f a # bs)" "PA a" "PB (f a)"
  using that proof cases
  case Single
  then show ?thesis by simp
next
  case prems: (Cons b' xs)
  from B_A_step[OF \<open>B _ b'\<close> _ \<open>PA a\<close> \<open>PB (f a)\<close>] obtain a' where "A a a'" "a' \<sim> b'"
    by auto
  with that prems have "QA a'" "QB b'"
    by auto
  with Post_Bisim.steps_map[OF eq inj, of a' xs] prems \<open>a' \<sim> b'\<close> obtain ys where "xs = map f ys"
    by auto
  with \<open>bs = _\<close> \<open>a' \<sim> b'\<close> show ?thesis
    by (inst_existentials "a' # ys") auto
qed

text \<open>
  @{thm Post_Bisim.reaches_equiv} cannot be lifted directly:
  injectivity cannot be applied for the reflexive case.
\<close>
lemma reaches1_equiv:
  "A.reaches1 a a' \<longleftrightarrow> B.reaches1 (f a) (f a')" if "PA a" "PB (f a)"
proof safe
  assume "A.reaches1 a a'"
  then obtain a'' where prems: "A a a''" "A.reaches a'' a'"
    including graph_automation_aggressive by blast
  from A_B_step[OF \<open>A a _\<close> _ that] obtain b where "B (f a) b" "a'' \<sim> b"
    by auto
  with that prems have "QA a''" "QB b"
    by auto
  with Post_Bisim.reaches_equiv[OF eq inj, of a'' a'] prems \<open>B (f a) b\<close> \<open>a'' \<sim> b\<close>
  show "B.reaches1 (f a) (f a')"
    by auto
next
  assume "B.reaches1 (f a) (f a')"
  then obtain b where prems: "B (f a) b" "B.reaches b (f a')"
    including graph_automation_aggressive by blast
  from B_A_step[OF \<open>B _ b\<close> _ \<open>PA a\<close> \<open>PB (f a)\<close>] obtain a'' where "A a a''" "a'' \<sim> b"
    by auto
  with that prems have "QA a''" "QB b"
    by auto
  with Post_Bisim.reaches_equiv[OF eq inj, of a'' a'] prems \<open>A a a''\<close> \<open>a'' \<sim> b\<close>
  show "A.reaches1 a a'"
    by auto
qed

end (* Context for Equality Relation *)

end (* Bisim Invariant *)

lemma Bisimulation_Invariant_composition:
  assumes
    "Bisimulation_Invariant A B sim1 PA PB"
    "Bisimulation_Invariant B C sim2 PB PC"
  shows
    "Bisimulation_Invariant A C (\<lambda> a c. \<exists> b. PB b \<and> sim1 a b \<and> sim2 b c) PA PC"
proof -
  interpret A: Bisimulation_Invariant A B sim1 PA PB
    by (rule assms(1))
  interpret B: Bisimulation_Invariant B C sim2 PB PC
    by (rule assms(2))
  show ?thesis
    by (standard; (blast dest: A.A_B_step B.A_B_step | blast dest: A.B_A_step B.B_A_step))
qed

lemma Bisimulation_Invariant_filter:
  assumes
    "Bisimulation_Invariant A B sim PA PB"
    "\<And> a b. sim a b \<Longrightarrow> PA a \<Longrightarrow> PB b \<Longrightarrow> FA a \<longleftrightarrow> FB b"
    "\<And> a b. A a b \<and> FA b \<longleftrightarrow> A' a b"
    "\<And> a b. B a b \<and> FB b \<longleftrightarrow> B' a b"
  shows
    "Bisimulation_Invariant A' B' sim PA PB"
proof -
  interpret Bisimulation_Invariant A B sim PA PB
    by (rule assms(1))
  have unfold:
    "A' = (\<lambda> a b. A a b \<and> FA b)" "B' = (\<lambda> a b. B a b \<and> FB b)"
    using assms(3,4) by auto
  show ?thesis
    unfolding unfold
    apply standard
    using assms(2) apply (blast dest: A_B_step)
    using assms(2) apply (blast dest: B_A_step)
    by blast+
qed

lemma Bisimulation_Invariants_filter:
  assumes
    "Bisimulation_Invariants A B sim PA QA PB QB"
    "\<And> a b. QA a \<Longrightarrow> QB b \<Longrightarrow> FA a \<longleftrightarrow> FB b"
    "\<And> a b. A a b \<and> FA b \<longleftrightarrow> A' a b"
    "\<And> a b. B a b \<and> FB b \<longleftrightarrow> B' a b"
  shows
    "Bisimulation_Invariants A' B' sim PA QA PB QB"
proof -
  interpret Bisimulation_Invariants A B sim PA QA PB QB
    by (rule assms(1))
  have unfold:
    "A' = (\<lambda> a b. A a b \<and> FA b)" "B' = (\<lambda> a b. B a b \<and> FB b)"
    using assms(3,4) by auto
  show ?thesis
    unfolding unfold
    apply standard
    using assms(2) apply (blast dest: A_B_step)
    using assms(2) apply (blast dest: B_A_step)
    by blast+
qed

lemma Bisimulation_Invariants_composition:
  assumes
    "Bisimulation_Invariants A B sim1 PA QA PB QB"
    "Bisimulation_Invariants B C sim2 PB QB PC QC"
  shows
    "Bisimulation_Invariants A C (\<lambda> a c. \<exists> b. PB b \<and> sim1 a b \<and> sim2 b c) PA QA PC QC"
proof -
  interpret A: Bisimulation_Invariants A B sim1 PA QA PB QB
    by (rule assms(1))
  interpret B: Bisimulation_Invariants B C sim2 PB QB PC QC
    by (rule assms(2))
  show ?thesis
    by (standard, blast dest: A.A_B_step B.A_B_step) (blast dest: A.B_A_step B.B_A_step)+
qed

lemma Bisimulation_Invariant_Invariants_composition:
  assumes
    "Bisimulation_Invariant A B sim1 PA PB"
    "Bisimulation_Invariants B C sim2 PB QB PC QC"
  shows
    "Bisimulation_Invariants A C (\<lambda> a c. \<exists> b. PB b \<and> sim1 a b \<and> sim2 b c) PA PA PC QC"
proof -
  interpret Bisimulation_Invariant A B sim1 PA PB
    by (rule assms(1))
  interpret B: Bisimulation_Invariants B C sim2 PB QB PC QC
    by (rule assms(2))
  interpret A: Bisimulation_Invariants A B sim1 PA PA PB QB
    by (standard; blast intro: A_B_step B_A_step)+
  show ?thesis
    by (standard; (blast dest: A.A_B_step B.A_B_step | blast dest: A.B_A_step B.B_A_step))
qed

lemma Bisimulation_Invariant_Bisimulation_Invariants:
  assumes "Bisimulation_Invariant A B sim PA PB"
  shows "Bisimulation_Invariants A B sim PA PA PB PB"
proof -
  interpret Bisimulation_Invariant A B sim PA PB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step B_A_step)
qed

lemma Bisimulation_Invariant_strengthen_post:
  assumes
    "Bisimulation_Invariant A B sim PA PB"
    "\<And> a b. PA' a \<Longrightarrow> PA b \<Longrightarrow> A a b \<Longrightarrow> PA' b"
    "\<And> a. PA' a \<Longrightarrow> PA a"
  shows "Bisimulation_Invariant A B sim PA' PB"
proof -
  interpret Bisimulation_Invariant A B sim PA PB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step B_A_step assms)
qed

lemma Bisimulation_Invariant_strengthen_post':
  assumes
    "Bisimulation_Invariant A B sim PA PB"
    "\<And> a b. PB' a \<Longrightarrow> PB b \<Longrightarrow> B a b \<Longrightarrow> PB' b"
    "\<And> a. PB' a \<Longrightarrow> PB a"
  shows "Bisimulation_Invariant A B sim PA PB'"
proof -
  interpret Bisimulation_Invariant A B sim PA PB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step B_A_step assms)
qed

lemma Simulation_Invariant_strengthen_post:
  assumes
    "Simulation_Invariant A B sim PA PB"
    "\<And> a b. PA a \<Longrightarrow> PA b \<Longrightarrow> A a b \<Longrightarrow> PA' b"
    "\<And> a. PA' a \<Longrightarrow> PA a"
  shows "Simulation_Invariant A B sim PA' PB"
proof -
  interpret Simulation_Invariant A B sim PA PB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step assms)
qed

lemma Simulation_Invariant_strengthen_post':
  assumes
    "Simulation_Invariant A B sim PA PB"
    "\<And> a b. PB a \<Longrightarrow> PB b \<Longrightarrow> B a b \<Longrightarrow> PB' b"
    "\<And> a. PB' a \<Longrightarrow> PB a"
  shows "Simulation_Invariant A B sim PA PB'"
proof -
  interpret Simulation_Invariant A B sim PA PB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step assms)
qed

lemma Simulation_Invariants_strengthen_post:
  assumes
    "Simulation_Invariants A B sim PA QA PB QB"
    "\<And> a b. PA a \<Longrightarrow> QA b \<Longrightarrow> A a b \<Longrightarrow> QA' b"
    "\<And> a. QA' a \<Longrightarrow> QA a"
  shows "Simulation_Invariants A B sim PA QA' PB QB"
proof -
  interpret Simulation_Invariants A B sim PA QA PB QB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step assms)
qed

lemma Bisimulation_Invariant_sim_replace:
  assumes "Bisimulation_Invariant A B sim PA PB"
      and "\<And> a b. PA a \<Longrightarrow> PB b \<Longrightarrow> sim a b \<longleftrightarrow> sim' a b"
    shows "Bisimulation_Invariant A B sim' PA PB"
proof -
  interpret Bisimulation_Invariant A B sim PA PB
    by (rule assms(1))
  show ?thesis
    apply standard
    using assms(2) apply (blast dest: A_B_step)
    using assms(2) apply (blast dest: B_A_step)
    by blast+
qed

end (* Theory *)


theory localePOContextFreeStudy
  imports VDMToolkit
begin

type_synonym T = VDMNat

(*
module m1
types
  T = nat inv t == t \<ge> 10 and t \<le> 20;

functions
  f : T \<rightarrow> nat1
  f(x) == x * x
  post x < RESULT;
end m1
*)
definition
  inv_T :: "VDMNat \<Rightarrow> \<bool>"
  where
  "inv_T t \<equiv> inv_VDMNat t \<and> t \<ge> 10 \<and> t \<le> 20"

lemmas inv_T_defs = inv_T_def inv_VDMNat_def

definition
  pre_f :: "T \<Rightarrow> \<bool>"
  where
  "pre_f t \<equiv> inv_T t"

definition
  post_f :: "T \<Rightarrow> VDMNat1 \<Rightarrow> \<bool>"
  where
  "post_f t RESULT \<equiv> inv_T t \<and> inv_VDMNat1 RESULT \<and> t < RESULT"

lemmas pre_f_defs = pre_f_def inv_T_defs
lemmas post_f_defs = post_f_def inv_T_defs inv_VDMNat1_def

definition
  f :: "T \<Rightarrow> VDMNat1"
  where
  "f x \<equiv> x * x"

definition
  PO1 :: "\<bool>"
  where
  "PO1 \<equiv> (\<forall> t . inv_T t \<and> pre_f t \<longrightarrow> post_f t (f t))"

lemmas PO1_defs = PO1_def inv_T_defs pre_f_defs post_f_defs

definition
  PO2 :: "\<bool>"
  where
  "PO2 \<equiv> (\<exists> t . inv_T t)"

lemmas PO2_defs = PO2_def inv_T_defs

locale fPOS =
  assumes a1: PO1
  and a2: PO2
begin

lemma l1: "whatever = whichever"
  sorry
end

interpretation ps_surrender: fPOS
  apply (unfold_locales)
  apply (insert fPOS.l1)
  oops

interpretation ps_optimistic: fPOS
  apply (unfold_locales)
  unfolding PO1_defs
   apply (simp add: f_def)
  unfolding PO2_defs
  by presburger

end


(*  Title:      ZF/UNITY/Follows.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2002  University of Cambridge

Theory ported from HOL.
*)

section{*The "Follows" relation of Charpentier and Sivilotte*}

theory Follows imports SubstAx Increasing begin

definition
  Follows :: "[i, i, i=>i, i=>i] => i"  where
  "Follows(A, r, f, g) ==
            Increasing(A, r, g) Int
            Increasing(A, r,f) Int
            Always({s \<in> state. <f(s), g(s)>:r}) Int
           (\<Inter>k \<in> A. {s \<in> state. <k, g(s)>:r} LeadsTo {s \<in> state. <k,f(s)>:r})"

abbreviation
  Incr :: "[i=>i]=>i" where
  "Incr(f) == Increasing(list(nat), prefix(nat), f)"

abbreviation
  n_Incr :: "[i=>i]=>i" where
  "n_Incr(f) == Increasing(nat, Le, f)"

abbreviation
  s_Incr :: "[i=>i]=>i" where
  "s_Incr(f) == Increasing(Pow(nat), SetLe(nat), f)"

abbreviation
  m_Incr :: "[i=>i]=>i" where
  "m_Incr(f) == Increasing(Mult(nat), MultLe(nat, Le), f)"

abbreviation
  n_Fols :: "[i=>i, i=>i]=>i"   (infixl "n'_Fols" 65)  where
  "f n_Fols g == Follows(nat, Le, f, g)"

abbreviation
  Follows' :: "[i=>i, i=>i, i, i] => i"
        ("(_ /Fols _ /Wrt (_ /'/ _))" [60, 0, 0, 60] 60)  where
  "f Fols g Wrt r/A == Follows(A,r,f,g)"

(*Does this hold for "invariant"?*)

lemma Follows_cong:
     "[|A=A'; r=r'; !!x. x \<in> state ==> f(x)=f'(x); !!x. x \<in> state ==> g(x)=g'(x)|] ==> Follows(A, r, f, g) = Follows(A', r', f', g')"
by (simp add: Increasing_def Follows_def)

lemma subset_Always_comp:
"[| mono1(A, r, B, s, h); \<forall>x \<in> state. f(x):A & g(x):A |] ==>
   Always({x \<in> state. <f(x), g(x)> \<in> r})<=Always({x \<in> state. <(h comp f)(x), (h comp g)(x)> \<in> s})"
apply (unfold mono1_def metacomp_def)
apply (auto simp add: Always_eq_includes_reachable)
done

lemma imp_Always_comp:
"[| F \<in> Always({x \<in> state. <f(x), g(x)> \<in> r});
    mono1(A, r, B, s, h); \<forall>x \<in> state. f(x):A & g(x):A |] ==>
    F \<in> Always({x \<in> state. <(h comp f)(x), (h comp g)(x)> \<in> s})"
by (blast intro: subset_Always_comp [THEN subsetD])

lemma imp_Always_comp2:
"[| F \<in> Always({x \<in> state. <f1(x), f(x)> \<in> r});
    F \<in> Always({x \<in> state. <g1(x), g(x)> \<in> s});
    mono2(A, r, B, s, C, t, h);
    \<forall>x \<in> state. f1(x):A & f(x):A & g1(x):B & g(x):B |]
  ==> F \<in> Always({x \<in> state. <h(f1(x), g1(x)), h(f(x), g(x))> \<in> t})"
apply (auto simp add: Always_eq_includes_reachable mono2_def)
apply (auto dest!: subsetD)
done

(* comp LeadsTo *)

lemma subset_LeadsTo_comp:
"[| mono1(A, r, B, s, h); refl(A,r); trans[B](s);
        \<forall>x \<in> state. f(x):A & g(x):A |] ==>
  (\<Inter>j \<in> A. {s \<in> state. <j, g(s)> \<in> r} LeadsTo {s \<in> state. <j,f(s)> \<in> r}) <=
 (\<Inter>k \<in> B. {x \<in> state. <k, (h comp g)(x)> \<in> s} LeadsTo {x \<in> state. <k, (h comp f)(x)> \<in> s})"

apply (unfold mono1_def metacomp_def, clarify)
apply (simp_all (no_asm_use) add: INT_iff)
apply auto
apply (rule single_LeadsTo_I)
prefer 2 apply (blast dest: LeadsTo_type [THEN subsetD], auto)
apply (rotate_tac 5)
apply (drule_tac x = "g (sa) " in bspec)
apply (erule_tac [2] LeadsTo_weaken)
apply (auto simp add: part_order_def refl_def)
apply (rule_tac b = "h (g (sa))" in trans_onD)
apply blast
apply auto
done

lemma imp_LeadsTo_comp:
"[| F:(\<Inter>j \<in> A. {s \<in> state. <j, g(s)> \<in> r} LeadsTo {s \<in> state. <j,f(s)> \<in> r});
    mono1(A, r, B, s, h); refl(A,r); trans[B](s);
    \<forall>x \<in> state. f(x):A & g(x):A |] ==>
   F:(\<Inter>k \<in> B. {x \<in> state. <k, (h comp g)(x)> \<in> s} LeadsTo {x \<in> state. <k, (h comp f)(x)> \<in> s})"
apply (rule subset_LeadsTo_comp [THEN subsetD], auto)
done

lemma imp_LeadsTo_comp_right:
"[| F \<in> Increasing(B, s, g);
  \<forall>j \<in> A. F: {s \<in> state. <j, f(s)> \<in> r} LeadsTo {s \<in> state. <j,f1(s)> \<in> r};
  mono2(A, r, B, s, C, t, h); refl(A, r); refl(B, s); trans[C](t);
  \<forall>x \<in> state. f1(x):A & f(x):A & g(x):B; k \<in> C |] ==>
  F:{x \<in> state. <k, h(f(x), g(x))> \<in> t} LeadsTo {x \<in> state. <k, h(f1(x), g(x))> \<in> t}"
apply (unfold mono2_def Increasing_def)
apply (rule single_LeadsTo_I, auto)
apply (drule_tac x = "g (sa) " and A = B in bspec)
apply auto
apply (drule_tac x = "f (sa) " and P = "%j. F \<in> ?X (j) \<longmapsto>w ?Y (j) " in bspec)
apply auto
apply (rule PSP_Stable [THEN LeadsTo_weaken], blast, blast)
apply auto
apply (force simp add: part_order_def refl_def)
apply (force simp add: part_order_def refl_def)
apply (drule_tac x = "f1 (x) " and x1 = "f (sa) " and P2 = "%x y. \<forall>u\<in>B. ?P (x,y,u) " in bspec [THEN bspec])
apply (drule_tac [3] x = "g (x) " and x1 = "g (sa) " and P2 = "%x y. ?P (x,y) \<longrightarrow> ?d (x,y) \<in> t" in bspec [THEN bspec])
apply auto
apply (rule_tac b = "h (f (sa), g (sa))" and A = C in trans_onD)
apply (auto simp add: part_order_def)
done

lemma imp_LeadsTo_comp_left:
"[| F \<in> Increasing(A, r, f);
  \<forall>j \<in> B. F: {x \<in> state. <j, g(x)> \<in> s} LeadsTo {x \<in> state. <j,g1(x)> \<in> s};
  mono2(A, r, B, s, C, t, h); refl(A,r); refl(B, s); trans[C](t);
  \<forall>x \<in> state. f(x):A & g1(x):B & g(x):B; k \<in> C |] ==>
  F:{x \<in> state. <k, h(f(x), g(x))> \<in> t} LeadsTo {x \<in> state. <k, h(f(x), g1(x))> \<in> t}"
apply (unfold mono2_def Increasing_def)
apply (rule single_LeadsTo_I, auto)
apply (drule_tac x = "f (sa) " and P = "%k. F \<in> Stable (?X (k))" in bspec)
apply auto
apply (drule_tac x = "g (sa) " in bspec)
apply auto
apply (rule PSP_Stable [THEN LeadsTo_weaken], blast, blast)
apply auto
apply (force simp add: part_order_def refl_def)
apply (force simp add: part_order_def refl_def)
apply (drule_tac x = "f (x) " and x1 = "f (sa) " in bspec [THEN bspec])
apply (drule_tac [3] x = "g1 (x) " and x1 = "g (sa) " and P2 = "%x y. ?P (x,y) \<longrightarrow> ?d (x,y) \<in> t" in bspec [THEN bspec])
apply auto
apply (rule_tac b = "h (f (sa), g (sa))" and A = C in trans_onD)
apply (auto simp add: part_order_def)
done

(**  This general result is used to prove Follows Un, munion, etc. **)
lemma imp_LeadsTo_comp2:
"[| F \<in> Increasing(A, r, f1) \<inter>  Increasing(B, s, g);
  \<forall>j \<in> A. F: {s \<in> state. <j, f(s)> \<in> r} LeadsTo {s \<in> state. <j,f1(s)> \<in> r};
  \<forall>j \<in> B. F: {x \<in> state. <j, g(x)> \<in> s} LeadsTo {x \<in> state. <j,g1(x)> \<in> s};
  mono2(A, r, B, s, C, t, h); refl(A,r); refl(B, s); trans[C](t);
  \<forall>x \<in> state. f(x):A & g1(x):B & f1(x):A &g(x):B; k \<in> C |]
  ==> F:{x \<in> state. <k, h(f(x), g(x))> \<in> t} LeadsTo {x \<in> state. <k, h(f1(x), g1(x))> \<in> t}"
apply (rule_tac B = "{x \<in> state. <k, h (f1 (x), g (x))> \<in> t}" in LeadsTo_Trans)
apply (blast intro: imp_LeadsTo_comp_right)
apply (blast intro: imp_LeadsTo_comp_left)
done

(* Follows type *)
lemma Follows_type: "Follows(A, r, f, g)<=program"
apply (unfold Follows_def)
apply (blast dest: Increasing_type [THEN subsetD])
done

lemma Follows_into_program [TC]: "F \<in> Follows(A, r, f, g) ==> F \<in> program"
by (blast dest: Follows_type [THEN subsetD])

lemma FollowsD:
"F \<in> Follows(A, r, f, g)==>
  F \<in> program & (\<exists>a. a \<in> A) & (\<forall>x \<in> state. f(x):A & g(x):A)"
apply (unfold Follows_def)
apply (blast dest: IncreasingD)
done

lemma Follows_constantI:
 "[| F \<in> program; c \<in> A; refl(A, r) |] ==> F \<in> Follows(A, r, %x. c, %x. c)"
apply (unfold Follows_def, auto)
apply (auto simp add: refl_def)
done

lemma subset_Follows_comp:
"[| mono1(A, r, B, s, h); refl(A, r); trans[B](s) |]
   ==> Follows(A, r, f, g) \<subseteq> Follows(B, s,  h comp f, h comp g)"
apply (unfold Follows_def, clarify)
apply (frule_tac f = g in IncreasingD)
apply (frule_tac f = f in IncreasingD)
apply (rule IntI)
apply (rule_tac [2] h = h in imp_LeadsTo_comp)
prefer 5 apply assumption
apply (auto intro: imp_Increasing_comp imp_Always_comp simp del: INT_simps)
done

lemma imp_Follows_comp:
"[| F \<in> Follows(A, r, f, g);  mono1(A, r, B, s, h); refl(A, r); trans[B](s) |]
  ==>  F \<in> Follows(B, s,  h comp f, h comp g)"
apply (blast intro: subset_Follows_comp [THEN subsetD])
done

(* 2-place monotone operation \<in> this general result is used to prove Follows_Un, Follows_munion *)

(* 2-place monotone operation \<in> this general result is
   used to prove Follows_Un, Follows_munion *)
lemma imp_Follows_comp2:
"[| F \<in> Follows(A, r, f1, f);  F \<in> Follows(B, s, g1, g);
   mono2(A, r, B, s, C, t, h); refl(A,r); refl(B, s); trans[C](t) |]
   ==> F \<in> Follows(C, t, %x. h(f1(x), g1(x)), %x. h(f(x), g(x)))"
apply (unfold Follows_def, clarify)
apply (frule_tac f = g in IncreasingD)
apply (frule_tac f = f in IncreasingD)
apply (rule IntI, safe)
apply (rule_tac [3] h = h in imp_Always_comp2)
prefer 5 apply assumption
apply (rule_tac [2] h = h in imp_Increasing_comp2)
prefer 4 apply assumption
apply (rule_tac h = h in imp_Increasing_comp2)
prefer 3 apply assumption
apply simp_all
apply (blast dest!: IncreasingD)
apply (rule_tac h = h in imp_LeadsTo_comp2)
prefer 4 apply assumption
apply auto
  prefer 3 apply (simp add: mono2_def)
apply (blast dest: IncreasingD)+
done

lemma Follows_trans:
     "[| F \<in> Follows(A, r, f, g);  F \<in> Follows(A,r, g, h);
         trans[A](r) |] ==> F \<in> Follows(A, r, f, h)"
apply (frule_tac f = f in FollowsD)
apply (frule_tac f = g in FollowsD)
apply (simp add: Follows_def)
apply (simp add: Always_eq_includes_reachable INT_iff, auto)
apply (rule_tac [2] B = "{s \<in> state. <k, g (s) > \<in> r}" in LeadsTo_Trans)
apply (rule_tac b = "g (x) " in trans_onD)
apply blast+
done

(** Destruction rules for Follows **)

lemma Follows_imp_Increasing_left:
     "F \<in> Follows(A, r, f,g) ==> F \<in> Increasing(A, r, f)"
by (unfold Follows_def, blast)

lemma Follows_imp_Increasing_right:
     "F \<in> Follows(A, r, f,g) ==> F \<in> Increasing(A, r, g)"
by (unfold Follows_def, blast)

lemma Follows_imp_Always:
 "F :Follows(A, r, f, g) ==> F \<in> Always({s \<in> state. <f(s),g(s)> \<in> r})"
by (unfold Follows_def, blast)

lemma Follows_imp_LeadsTo:
 "[| F \<in> Follows(A, r, f, g); k \<in> A |]  ==>
  F: {s \<in> state. <k,g(s)> \<in> r } LeadsTo {s \<in> state. <k,f(s)> \<in> r}"
by (unfold Follows_def, blast)

lemma Follows_LeadsTo_pfixLe:
     "[| F \<in> Follows(list(nat), gen_prefix(nat, Le), f, g); k \<in> list(nat) |]
   ==> F \<in> {s \<in> state. k pfixLe g(s)} LeadsTo {s \<in> state. k pfixLe f(s)}"
by (blast intro: Follows_imp_LeadsTo)

lemma Follows_LeadsTo_pfixGe:
     "[| F \<in> Follows(list(nat), gen_prefix(nat, Ge), f, g); k \<in> list(nat) |]
   ==> F \<in> {s \<in> state. k pfixGe g(s)} LeadsTo {s \<in> state. k pfixGe f(s)}"
by (blast intro: Follows_imp_LeadsTo)

lemma Always_Follows1:
"[| F \<in> Always({s \<in> state. f(s) = g(s)}); F \<in> Follows(A, r, f, h);
    \<forall>x \<in> state. g(x):A |] ==> F \<in> Follows(A, r, g, h)"
apply (unfold Follows_def Increasing_def Stable_def)
apply (simp add: INT_iff, auto)
apply (rule_tac [3] C = "{s \<in> state. f(s)=g(s)}"
        and A = "{s \<in> state. <k, h (s)> \<in> r}"
        and A' = "{s \<in> state. <k, f(s)> \<in> r}" in Always_LeadsTo_weaken)
apply (erule_tac A = "{s \<in> state. <k,f(s) > \<in> r}"
           and A' = "{s \<in> state. <k,f(s) > \<in> r}" in Always_Constrains_weaken)
apply auto
apply (drule Always_Int_I, assumption)
apply (erule_tac A = "{s \<in> state. f(s)=g(s)} \<inter> {s \<in> state. <f(s), h(s)> \<in> r}"
       in Always_weaken)
apply auto
done

lemma Always_Follows2:
"[| F \<in> Always({s \<in> state. g(s) = h(s)});
  F \<in> Follows(A, r, f, g); \<forall>x \<in> state. h(x):A |] ==> F \<in> Follows(A, r, f, h)"
apply (unfold Follows_def Increasing_def Stable_def)
apply (simp add: INT_iff, auto)
apply (rule_tac [3] C = "{s \<in> state. g (s) =h (s) }"
            and A = "{s \<in> state. <k, g (s) > \<in> r}"
            and A' = "{s \<in> state. <k, f (s) > \<in> r}" in Always_LeadsTo_weaken)
apply (erule_tac A = "{s \<in> state. <k, g(s)> \<in> r}"
         and A' = "{s \<in> state. <k, g(s)> \<in> r}" in Always_Constrains_weaken)
apply auto
apply (drule Always_Int_I, assumption)
apply (erule_tac A = "{s \<in> state. g(s)=h(s)} \<inter> {s \<in> state. <f(s), g(s)> \<in> r}"
       in Always_weaken)
apply auto
done

(** Union properties (with the subset ordering) **)

lemma refl_SetLe [simp]: "refl(Pow(A), SetLe(A))"
by (unfold refl_def SetLe_def, auto)

lemma trans_on_SetLe [simp]: "trans[Pow(A)](SetLe(A))"
by (unfold trans_on_def SetLe_def, auto)

lemma antisym_SetLe [simp]: "antisym(SetLe(A))"
by (unfold antisym_def SetLe_def, auto)

lemma part_order_SetLe [simp]: "part_order(Pow(A), SetLe(A))"
by (unfold part_order_def, auto)

lemma increasing_Un:
     "[| F \<in> Increasing.increasing(Pow(A), SetLe(A), f);
         F \<in> Increasing.increasing(Pow(A), SetLe(A), g) |]
     ==> F \<in> Increasing.increasing(Pow(A), SetLe(A), %x. f(x) \<union> g(x))"
by (rule_tac h = "op Un" in imp_increasing_comp2, auto)

lemma Increasing_Un:
     "[| F \<in> Increasing(Pow(A), SetLe(A), f);
         F \<in> Increasing(Pow(A), SetLe(A), g) |]
     ==> F \<in> Increasing(Pow(A), SetLe(A), %x. f(x) \<union> g(x))"
by (rule_tac h = "op Un" in imp_Increasing_comp2, auto)

lemma Always_Un:
     "[| F \<in> Always({s \<in> state. f1(s) \<subseteq> f(s)});
     F \<in> Always({s \<in> state. g1(s) \<subseteq> g(s)}) |]
      ==> F \<in> Always({s \<in> state. f1(s) \<union> g1(s) \<subseteq> f(s) \<union> g(s)})"
by (simp add: Always_eq_includes_reachable, blast)

lemma Follows_Un:
"[| F \<in> Follows(Pow(A), SetLe(A), f1, f);
     F \<in> Follows(Pow(A), SetLe(A), g1, g) |]
     ==> F \<in> Follows(Pow(A), SetLe(A), %s. f1(s) \<union> g1(s), %s. f(s) \<union> g(s))"
by (rule_tac h = "op Un" in imp_Follows_comp2, auto)

(** Multiset union properties (with the MultLe ordering) **)

lemma refl_MultLe [simp]: "refl(Mult(A), MultLe(A,r))"
by (unfold MultLe_def refl_def, auto)

lemma MultLe_refl1 [simp]:
 "[| multiset(M); mset_of(M)<=A |] ==> <M, M> \<in> MultLe(A, r)"
apply (unfold MultLe_def id_def lam_def)
apply (auto simp add: Mult_iff_multiset)
done

lemma MultLe_refl2 [simp]: "M \<in> Mult(A) ==> <M, M> \<in> MultLe(A, r)"
by (unfold MultLe_def id_def lam_def, auto)

lemma trans_on_MultLe [simp]: "trans[Mult(A)](MultLe(A,r))"
apply (unfold MultLe_def trans_on_def)
apply (auto intro: trancl_trans simp add: multirel_def)
done

lemma MultLe_type: "MultLe(A, r)<= (Mult(A) * Mult(A))"
apply (unfold MultLe_def, auto)
apply (drule multirel_type [THEN subsetD], auto)
done

lemma MultLe_trans:
     "[| <M,K> \<in> MultLe(A,r); <K,N> \<in> MultLe(A,r) |] ==> <M,N> \<in> MultLe(A,r)"
apply (cut_tac A=A in trans_on_MultLe)
apply (drule trans_onD, assumption)
apply (auto dest: MultLe_type [THEN subsetD])
done

lemma part_order_imp_part_ord:
     "part_order(A, r) ==> part_ord(A, r-id(A))"
apply (unfold part_order_def part_ord_def)
apply (simp add: refl_def id_def lam_def irrefl_def, auto)
apply (simp (no_asm) add: trans_on_def)
apply auto
apply (blast dest: trans_onD)
apply (simp (no_asm_use) add: antisym_def)
apply auto
done

lemma antisym_MultLe [simp]:
  "part_order(A, r) ==> antisym(MultLe(A,r))"
apply (unfold MultLe_def antisym_def)
apply (drule part_order_imp_part_ord, auto)
apply (drule irrefl_on_multirel)
apply (frule multirel_type [THEN subsetD])
apply (drule multirel_trans)
apply (auto simp add: irrefl_def)
done

lemma part_order_MultLe [simp]:
     "part_order(A, r) ==>  part_order(Mult(A), MultLe(A, r))"
apply (frule antisym_MultLe)
apply (auto simp add: part_order_def)
done

lemma empty_le_MultLe [simp]:
"[| multiset(M); mset_of(M)<= A|] ==> <0, M> \<in> MultLe(A, r)"
apply (unfold MultLe_def)
apply (case_tac "M=0")
apply (auto simp add: FiniteFun.intros)
apply (subgoal_tac "<0 +# 0, 0 +# M> \<in> multirel (A, r - id (A))")
apply (rule_tac [2] one_step_implies_multirel)
apply (auto simp add: Mult_iff_multiset)
done

lemma empty_le_MultLe2 [simp]: "M \<in> Mult(A) ==> <0, M> \<in> MultLe(A, r)"
by (simp add: Mult_iff_multiset)

lemma munion_mono:
"[| <M, N> \<in> MultLe(A, r); <K, L> \<in> MultLe(A, r) |] ==>
  <M +# K, N +# L> \<in> MultLe(A, r)"
apply (unfold MultLe_def)
apply (auto intro: munion_multirel_mono1 munion_multirel_mono2
       munion_multirel_mono multiset_into_Mult simp add: Mult_iff_multiset)
done

lemma increasing_munion:
     "[| F \<in> Increasing.increasing(Mult(A), MultLe(A,r), f);
         F \<in> Increasing.increasing(Mult(A), MultLe(A,r), g) |]
     ==> F \<in> Increasing.increasing(Mult(A),MultLe(A,r), %x. f(x) +# g(x))"
by (rule_tac h = munion in imp_increasing_comp2, auto)

lemma Increasing_munion:
     "[| F \<in> Increasing(Mult(A), MultLe(A,r), f);
         F \<in> Increasing(Mult(A), MultLe(A,r), g)|]
     ==> F \<in> Increasing(Mult(A),MultLe(A,r), %x. f(x) +# g(x))"
by (rule_tac h = munion in imp_Increasing_comp2, auto)

lemma Always_munion:
"[| F \<in> Always({s \<in> state. <f1(s),f(s)> \<in> MultLe(A,r)});
          F \<in> Always({s \<in> state. <g1(s), g(s)> \<in> MultLe(A,r)});
  \<forall>x \<in> state. f1(x):Mult(A)&f(x):Mult(A) & g1(x):Mult(A) & g(x):Mult(A)|]
      ==> F \<in> Always({s \<in> state. <f1(s) +# g1(s), f(s) +# g(s)> \<in> MultLe(A,r)})"
apply (rule_tac h = munion in imp_Always_comp2, simp_all)
apply (blast intro: munion_mono, simp_all)
done

lemma Follows_munion:
"[| F \<in> Follows(Mult(A), MultLe(A, r), f1, f);
    F \<in> Follows(Mult(A), MultLe(A, r), g1, g) |]
  ==> F \<in> Follows(Mult(A), MultLe(A, r), %s. f1(s) +# g1(s), %s. f(s) +# g(s))"
by (rule_tac h = munion in imp_Follows_comp2, auto)

(** Used in ClientImp **)

lemma Follows_msetsum_UN:
"!!f. [| \<forall>i \<in> I. F \<in> Follows(Mult(A), MultLe(A, r), f'(i), f(i));
  \<forall>s. \<forall>i \<in> I. multiset(f'(i, s)) & mset_of(f'(i, s))<=A &
                        multiset(f(i, s)) & mset_of(f(i, s))<=A ;
   Finite(I); F \<in> program |]
        ==> F \<in> Follows(Mult(A),
                        MultLe(A, r), %x. msetsum(%i. f'(i, x), I, A),
                                      %x. msetsum(%i. f(i,  x), I, A))"
apply (erule rev_mp)
apply (drule Finite_into_Fin)
apply (erule Fin_induct)
apply (simp (no_asm_simp))
apply (rule Follows_constantI)
apply (simp_all (no_asm_simp) add: FiniteFun.intros)
apply auto
apply (rule Follows_munion, auto)
done

end