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

section \<open>Graphs\<close>

subsection \<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 apply2 induction by (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 proof2 (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 apply2 (induction xs) by(auto elim: steps.cases)

lemma steps_appendD3:
  "steps (xs @ [x]) \<and> E x y" if "steps (xs @ [x, y])"
  using that proof2 (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)
proof2 (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
proof2 (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) apply2 (induction xs rule: list_nonempty_induct) by(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) apply2 (induction xs rule: list_nonempty_induct) by(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 apply2 (induction n arbitrary: xs) by(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) proof2 (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) proof2 (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
proof2 (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 apply2 (induction xs) by 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
  apply2 (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 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 apply2 induction by auto

lemmas graphI =
  steps.intros
  steps_append_single
  steps_reaches'
  stepsI

end (* Graph Defs *)

subsection \<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) apply2 induction by(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
proof2 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
  apply2 induction by(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 *)

subsection \<open>Subgraphs\<close>

subsubsection \<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
  proof2 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 apply2 induction by (auto intro: rtranclp.intros(2))

lemma reaches1:
  "G.reaches1 a b" if "G'.reaches1 a b"
  using that apply2 induction  by(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 *)

subsubsection \<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 apply2 induction by(auto intro: E'_V2)

lemma G'_steps_V_last:
  "V (last xs)" if "G'.steps xs" "V (hd xs)"
  using that apply2 induction by(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 *)

subsubsection \<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>
    apply2 induction by (auto dest: reachable_supgraph intro: graph_startI graphI_aggressive)
  subgoal premises prems
    using prems \<open>reachable x\<close>
    apply2 induction by(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>
    apply2 induction by(auto dest: reachable_supgraph intro: graph_startI graphI_aggressive)
  subgoal premises prems
    using prems \<open>reachable x\<close>
    apply2 induction by(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>
    apply2 (induction "x # xs" arbitrary: x xs) by(auto dest: reachable_supgraph intro: graph_startI)
  subgoal premises prems
    using prems apply2 induction by auto
  done

end (* Graph Start Defs *)

subsection \<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 *)

subsection \<open>Simulations and Bisimulations\<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 apply2 (induction "a # as" arbitrary: as a) by(auto intro: invariant)

lemma invariant_reaches:
  "P b" if "a \<rightarrow>* b" "P a"
  using that apply2 (induction) by( 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)

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 apply2 (induction "a # as" arbitrary: as a) by(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 apply2 (induction) by( 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 apply2 (induction "a # as" arbitrary: as a) by (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 apply2 (induction) by( blast intro: invariant)+

end (* Graph Invariant *)

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 apply2 (induction rule: rtranclp_induct) by (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 apply2 (induction rule: tranclp_induct) by(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
  apply2 (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

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 (metis (mono_tags, lifting) list_all2_conv_all_nth list_all_length)

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"
    apply2 (induction) by( 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
  apply2 (induction "map f as" bs arbitrary: as rule: list_all2_induct) by(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 apply (inst_existentials as) apply2( induction rule: list_all2_induct) by( 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 *)


(*  Title:      HOL/TLA/TLA.thy
    Author:     Stephan Merz
    Copyright:  1998 University of Munich
*)

section {* The temporal level of TLA *}

theory TLA
imports Init
begin

consts
  (** abstract syntax **)
  Box        :: "('w::world) form => temporal"
  Dmd        :: "('w::world) form => temporal"
  leadsto    :: "['w::world form, 'v::world form] => temporal"
  Stable     :: "stpred => temporal"
  WF         :: "[action, 'a stfun] => temporal"
  SF         :: "[action, 'a stfun] => temporal"

  (* Quantification over (flexible) state variables *)
  EEx        :: "('a stfun => temporal) => temporal"       (binder "Eex " 10)
  AAll       :: "('a stfun => temporal) => temporal"       (binder "Aall " 10)

  (** concrete syntax **)
syntax
  "_Box"     :: "lift => lift"                        ("([]_)" [40] 40)
  "_Dmd"     :: "lift => lift"                        ("(<>_)" [40] 40)
  "_leadsto" :: "[lift,lift] => lift"                 ("(_ ~> _)" [23,22] 22)
  "_stable"  :: "lift => lift"                        ("(stable/ _)")
  "_WF"      :: "[lift,lift] => lift"                 ("(WF'(_')'_(_))" [0,60] 55)
  "_SF"      :: "[lift,lift] => lift"                 ("(SF'(_')'_(_))" [0,60] 55)

  "_EEx"     :: "[idts, lift] => lift"                ("(3EEX _./ _)" [0,10] 10)
  "_AAll"    :: "[idts, lift] => lift"                ("(3AALL _./ _)" [0,10] 10)

translations
  "_Box"      ==   "CONST Box"
  "_Dmd"      ==   "CONST Dmd"
  "_leadsto"  ==   "CONST leadsto"
  "_stable"   ==   "CONST Stable"
  "_WF"       ==   "CONST WF"
  "_SF"       ==   "CONST SF"
  "_EEx v A"  ==   "Eex v. A"
  "_AAll v A" ==   "Aall v. A"

  "sigma |= []F"         <= "_Box F sigma"
  "sigma |= <>F"         <= "_Dmd F sigma"
  "sigma |= F ~> G"      <= "_leadsto F G sigma"
  "sigma |= stable P"    <= "_stable P sigma"
  "sigma |= WF(A)_v"     <= "_WF A v sigma"
  "sigma |= SF(A)_v"     <= "_SF A v sigma"
  "sigma |= EEX x. F"    <= "_EEx x F sigma"
  "sigma |= AALL x. F"    <= "_AAll x F sigma"

syntax (xsymbols)
  "_Box"     :: "lift => lift"                        ("(\<box>_)" [40] 40)
  "_Dmd"     :: "lift => lift"                        ("(\<diamond>_)" [40] 40)
  "_leadsto" :: "[lift,lift] => lift"                 ("(_ \<leadsto> _)" [23,22] 22)
  "_EEx"     :: "[idts, lift] => lift"                ("(3\<exists>\<exists> _./ _)" [0,10] 10)
  "_AAll"    :: "[idts, lift] => lift"                ("(3\<forall>\<forall> _./ _)" [0,10] 10)

syntax (HTML output)
  "_EEx"     :: "[idts, lift] => lift"                ("(3\<exists>\<exists> _./ _)" [0,10] 10)
  "_AAll"    :: "[idts, lift] => lift"                ("(3\<forall>\<forall> _./ _)" [0,10] 10)

axiomatization where
  (* Definitions of derived operators *)
  dmd_def:      "\<And>F. TEMP <>F  ==  TEMP ~[]~F"

axiomatization where
  boxInit:      "\<And>F. TEMP []F  ==  TEMP []Init F" and
  leadsto_def:  "\<And>F G. TEMP F ~> G  ==  TEMP [](Init F --> <>G)" and
  stable_def:   "\<And>P. TEMP stable P  ==  TEMP []($P --> P$)" and
  WF_def:       "TEMP WF(A)_v  ==  TEMP <>[] Enabled(<A>_v) --> []<><A>_v" and
  SF_def:       "TEMP SF(A)_v  ==  TEMP []<> Enabled(<A>_v) --> []<><A>_v" and
  aall_def:     "TEMP (AALL x. F x)  ==  TEMP ~ (EEX x. ~ F x)"

axiomatization where
(* Base axioms for raw TLA. *)
  normalT:    "\<And>F G. |- [](F --> G) --> ([]F --> []G)" and    (* polymorphic *)
  reflT:      "\<And>F. |- []F --> F" and         (* F::temporal *)
  transT:     "\<And>F. |- []F --> [][]F" and     (* polymorphic *)
  linT:       "\<And>F G. |- <>F & <>G --> (<>(F & <>G)) | (<>(G & <>F))" and
  discT:      "\<And>F. |- [](F --> <>(~F & <>F)) --> (F --> []<>F)" and
  primeI:     "\<And>P. |- []P --> Init P`" and
  primeE:     "\<And>P F. |- [](Init P --> []F) --> Init P` --> (F --> []F)" and
  indT:       "\<And>P F. |- [](Init P & ~[]F --> Init P` & F) --> Init P --> []F" and
  allT:       "\<And>F. |- (ALL x. [](F x)) = ([](ALL x. F x))"

axiomatization where
  necT:       "\<And>F. |- F ==> |- []F"      (* polymorphic *)

axiomatization where
(* Flexible quantification: refinement mappings, history variables *)
  eexI:       "|- F x --> (EEX x. F x)" and
  eexE:       "[| sigma |= (EEX x. F x); basevars vs;
                 (!!x. [| basevars (x, vs); sigma |= F x |] ==> (G sigma)::bool)
              |] ==> G sigma" and
  history:    "|- EEX h. Init(h = ha) & [](!x. $h = #x --> h` = hb x)"

(* Specialize intensional introduction/elimination rules for temporal formulas *)

lemma tempI [intro!]: "(!!sigma. sigma |= (F::temporal)) ==> |- F"
  apply (rule intI)
  apply (erule meta_spec)
  done

lemma tempD [dest]: "|- (F::temporal) ==> sigma |= F"
  by (erule intD)

(* ======== Functions to "unlift" temporal theorems ====== *)

ML {*
(* The following functions are specialized versions of the corresponding
   functions defined in theory Intensional in that they introduce a
   "world" parameter of type "behavior".
*)
fun temp_unlift ctxt th =
  (rewrite_rule ctxt @{thms action_rews} (th RS @{thm tempD}))
    handle THM _ => action_unlift ctxt th;

(* Turn  |- F = G  into meta-level rewrite rule  F == G *)
val temp_rewrite = int_rewrite

fun temp_use ctxt th =
  case (concl_of th) of
    Const _ $ (Const (@{const_name Intensional.Valid}, _) $ _) =>
            ((flatten (temp_unlift ctxt th)) handle THM _ => th)
  | _ => th;

fun try_rewrite ctxt th = temp_rewrite ctxt th handle THM _ => temp_use ctxt th;
*}

attribute_setup temp_unlift =
  {* Scan.succeed (Thm.rule_attribute (temp_unlift o Context.proof_of)) *}
attribute_setup temp_rewrite =
  {* Scan.succeed (Thm.rule_attribute (temp_rewrite o Context.proof_of)) *}
attribute_setup temp_use =
  {* Scan.succeed (Thm.rule_attribute (temp_use o Context.proof_of)) *}
attribute_setup try_rewrite =
  {* Scan.succeed (Thm.rule_attribute (try_rewrite o Context.proof_of)) *}

(* ------------------------------------------------------------------------- *)
(***           "Simple temporal logic": only [] and <>                     ***)
(* ------------------------------------------------------------------------- *)
section "Simple temporal logic"

(* []~F == []~Init F *)
lemmas boxNotInit = boxInit [of "LIFT ~F", unfolded Init_simps] for F

lemma dmdInit: "TEMP <>F == TEMP <> Init F"
  apply (unfold dmd_def)
  apply (unfold boxInit [of "LIFT ~F"])
  apply (simp (no_asm) add: Init_simps)
  done

lemmas dmdNotInit = dmdInit [of "LIFT ~F", unfolded Init_simps] for F

(* boxInit and dmdInit cannot be used as rewrites, because they loop.
   Non-looping instances for state predicates and actions are occasionally useful.
*)
lemmas boxInit_stp = boxInit [where 'a = state]
lemmas boxInit_act = boxInit [where 'a = "state * state"]
lemmas dmdInit_stp = dmdInit [where 'a = state]
lemmas dmdInit_act = dmdInit [where 'a = "state * state"]

(* The symmetric equations can be used to get rid of Init *)
lemmas boxInitD = boxInit [symmetric]
lemmas dmdInitD = dmdInit [symmetric]
lemmas boxNotInitD = boxNotInit [symmetric]
lemmas dmdNotInitD = dmdNotInit [symmetric]

lemmas Init_simps = Init_simps boxInitD dmdInitD boxNotInitD dmdNotInitD

(* ------------------------ STL2 ------------------------------------------- *)
lemmas STL2 = reflT

(* The "polymorphic" (generic) variant *)
lemma STL2_gen: "|- []F --> Init F"
  apply (unfold boxInit [of F])
  apply (rule STL2)
  done

(* see also STL2_pr below: "|- []P --> Init P & Init (P`)" *)

(* Dual versions for <> *)
lemma InitDmd: "|- F --> <> F"
  apply (unfold dmd_def)
  apply (auto dest!: STL2 [temp_use])
  done

lemma InitDmd_gen: "|- Init F --> <>F"
  apply clarsimp
  apply (drule InitDmd [temp_use])
  apply (simp add: dmdInitD)
  done

(* ------------------------ STL3 ------------------------------------------- *)
lemma STL3: "|- ([][]F) = ([]F)"
  by (auto elim: transT [temp_use] STL2 [temp_use])

(* corresponding elimination rule introduces double boxes:
   [| (sigma |= []F); (sigma |= [][]F) ==> PROP W |] ==> PROP W
*)
lemmas dup_boxE = STL3 [temp_unlift, THEN iffD2, elim_format]
lemmas dup_boxD = STL3 [temp_unlift, THEN iffD1]

(* dual versions for <> *)
lemma DmdDmd: "|- (<><>F) = (<>F)"
  by (auto simp add: dmd_def [try_rewrite] STL3 [try_rewrite])

lemmas dup_dmdE = DmdDmd [temp_unlift, THEN iffD2, elim_format]
lemmas dup_dmdD = DmdDmd [temp_unlift, THEN iffD1]

(* ------------------------ STL4 ------------------------------------------- *)
lemma STL4:
  assumes "|- F --> G"
  shows "|- []F --> []G"
  apply clarsimp
  apply (rule normalT [temp_use])
   apply (rule assms [THEN necT, temp_use])
  apply assumption
  done

(* Unlifted version as an elimination rule *)
lemma STL4E: "[| sigma |= []F; |- F --> G |] ==> sigma |= []G"
  by (erule (1) STL4 [temp_use])

lemma STL4_gen: "|- Init F --> Init G ==> |- []F --> []G"
  apply (drule STL4)
  apply (simp add: boxInitD)
  done

lemma STL4E_gen: "[| sigma |= []F; |- Init F --> Init G |] ==> sigma |= []G"
  by (erule (1) STL4_gen [temp_use])

(* see also STL4Edup below, which allows an auxiliary boxed formula:
       []A /\ F => G
     -----------------
     []A /\ []F => []G
*)

(* The dual versions for <> *)
lemma DmdImpl:
  assumes prem: "|- F --> G"
  shows "|- <>F --> <>G"
  apply (unfold dmd_def)
  apply (fastforce intro!: prem [temp_use] elim!: STL4E [temp_use])
  done

lemma DmdImplE: "[| sigma |= <>F; |- F --> G |] ==> sigma |= <>G"
  by (erule (1) DmdImpl [temp_use])

(* ------------------------ STL5 ------------------------------------------- *)
lemma STL5: "|- ([]F & []G) = ([](F & G))"
  apply auto
  apply (subgoal_tac "sigma |= [] (G --> (F & G))")
     apply (erule normalT [temp_use])
     apply (fastforce elim!: STL4E [temp_use])+
  done

(* rewrite rule to split conjunctions under boxes *)
lemmas split_box_conj = STL5 [temp_unlift, symmetric]

(* the corresponding elimination rule allows to combine boxes in the hypotheses
   (NB: F and G must have the same type, i.e., both actions or temporals.)
   Use "addSE2" etc. if you want to add this to a claset, otherwise it will loop!
*)
lemma box_conjE:
  assumes "sigma |= []F"
     and "sigma |= []G"
  and "sigma |= [](F&G) ==> PROP R"
  shows "PROP R"
  by (rule assms STL5 [temp_unlift, THEN iffD1] conjI)+

(* Instances of box_conjE for state predicates, actions, and temporals
   in case the general rule is "too polymorphic".
*)
lemmas box_conjE_temp = box_conjE [where 'a = behavior]
lemmas box_conjE_stp = box_conjE [where 'a = state]
lemmas box_conjE_act = box_conjE [where 'a = "state * state"]

(* Define a tactic that tries to merge all boxes in an antecedent. The definition is
   a bit kludgy in order to simulate "double elim-resolution".
*)

lemma box_thin: "[| sigma |= []F; PROP W |] ==> PROP W" .

ML {*
fun merge_box_tac i =
   REPEAT_DETERM (EVERY [etac @{thm box_conjE} i, atac i, etac @{thm box_thin} i])

fun merge_temp_box_tac ctxt i =
   REPEAT_DETERM (EVERY [etac @{thm box_conjE_temp} i, atac i,
                         eres_inst_tac ctxt [(("'a", 0), "behavior")] @{thm box_thin} i])

fun merge_stp_box_tac ctxt i =
   REPEAT_DETERM (EVERY [etac @{thm box_conjE_stp} i, atac i,
                         eres_inst_tac ctxt [(("'a", 0), "state")] @{thm box_thin} i])

fun merge_act_box_tac ctxt i =
   REPEAT_DETERM (EVERY [etac @{thm box_conjE_act} i, atac i,
                         eres_inst_tac ctxt [(("'a", 0), "state * state")] @{thm box_thin} i])
*}

method_setup merge_box = {* Scan.succeed (K (SIMPLE_METHOD' merge_box_tac)) *}
method_setup merge_temp_box = {* Scan.succeed (SIMPLE_METHOD' o merge_temp_box_tac) *}
method_setup merge_stp_box = {* Scan.succeed (SIMPLE_METHOD' o merge_stp_box_tac) *}
method_setup merge_act_box = {* Scan.succeed (SIMPLE_METHOD' o merge_act_box_tac) *}

(* rewrite rule to push universal quantification through box:
      (sigma |= [](! x. F x)) = (! x. (sigma |= []F x))
*)
lemmas all_box = allT [temp_unlift, symmetric]

lemma DmdOr: "|- (<>(F | G)) = (<>F | <>G)"
  apply (auto simp add: dmd_def split_box_conj [try_rewrite])
  apply (erule contrapos_np, merge_box, fastforce elim!: STL4E [temp_use])+
  done

lemma exT: "|- (EX x. <>(F x)) = (<>(EX x. F x))"
  by (auto simp: dmd_def Not_Rex [try_rewrite] all_box [try_rewrite])

lemmas ex_dmd = exT [temp_unlift, symmetric]

lemma STL4Edup: "!!sigma. [| sigma |= []A; sigma |= []F; |- F & []A --> G |] ==> sigma |= []G"
  apply (erule dup_boxE)
  apply merge_box
  apply (erule STL4E)
  apply assumption
  done

lemma DmdImpl2:
    "!!sigma. [| sigma |= <>F; sigma |= [](F --> G) |] ==> sigma |= <>G"
  apply (unfold dmd_def)
  apply auto
  apply (erule notE)
  apply merge_box
  apply (fastforce elim!: STL4E [temp_use])
  done

lemma InfImpl:
  assumes 1: "sigma |= []<>F"
    and 2: "sigma |= []G"
    and 3: "|- F & G --> H"
  shows "sigma |= []<>H"
  apply (insert 1 2)
  apply (erule_tac F = G in dup_boxE)
  apply merge_box
  apply (fastforce elim!: STL4E [temp_use] DmdImpl2 [temp_use] intro!: 3 [temp_use])
  done

(* ------------------------ STL6 ------------------------------------------- *)
(* Used in the proof of STL6, but useful in itself. *)
lemma BoxDmd: "|- []F & <>G --> <>([]F & G)"
  apply (unfold dmd_def)
  apply clarsimp
  apply (erule dup_boxE)
  apply merge_box
  apply (erule contrapos_np)
  apply (fastforce elim!: STL4E [temp_use])
  done

(* weaker than BoxDmd, but more polymorphic (and often just right) *)
lemma BoxDmd_simple: "|- []F & <>G --> <>(F & G)"
  apply (unfold dmd_def)
  apply clarsimp
  apply merge_box
  apply (fastforce elim!: notE STL4E [temp_use])
  done

lemma BoxDmd2_simple: "|- []F & <>G --> <>(G & F)"
  apply (unfold dmd_def)
  apply clarsimp
  apply merge_box
  apply (fastforce elim!: notE STL4E [temp_use])
  done

lemma DmdImpldup:
  assumes 1: "sigma |= []A"
    and 2: "sigma |= <>F"
    and 3: "|- []A & F --> G"
  shows "sigma |= <>G"
  apply (rule 2 [THEN 1 [THEN BoxDmd [temp_use]], THEN DmdImplE])
  apply (rule 3)
  done

lemma STL6: "|- <>[]F & <>[]G --> <>[](F & G)"
  apply (auto simp: STL5 [temp_rewrite, symmetric])
  apply (drule linT [temp_use])
   apply assumption
  apply (erule thin_rl)
  apply (rule DmdDmd [temp_unlift, THEN iffD1])
  apply (erule disjE)
   apply (erule DmdImplE)
   apply (rule BoxDmd)
  apply (erule DmdImplE)
  apply auto
  apply (drule BoxDmd [temp_use])
   apply assumption
  apply (erule thin_rl)
  apply (fastforce elim!: DmdImplE [temp_use])
  done

(* ------------------------ True / False ----------------------------------------- *)
section "Simplification of constants"

lemma BoxConst: "|- ([]#P) = #P"
  apply (rule tempI)
  apply (cases P)
   apply (auto intro!: necT [temp_use] dest: STL2_gen [temp_use] simp: Init_simps)
  done

lemma DmdConst: "|- (<>#P) = #P"
  apply (unfold dmd_def)
  apply (cases P)
  apply (simp_all add: BoxConst [try_rewrite])
  done

lemmas temp_simps [temp_rewrite, simp] = BoxConst DmdConst

(* ------------------------ Further rewrites ----------------------------------------- *)
section "Further rewrites"

lemma NotBox: "|- (~[]F) = (<>~F)"
  by (simp add: dmd_def)

lemma NotDmd: "|- (~<>F) = ([]~F)"
  by (simp add: dmd_def)

(* These are not declared by default, because they could be harmful,
   e.g. []F & ~[]F becomes []F & <>~F !! *)
lemmas more_temp_simps1 =
  STL3 [temp_rewrite] DmdDmd [temp_rewrite] NotBox [temp_rewrite] NotDmd [temp_rewrite]
  NotBox [temp_unlift, THEN eq_reflection]
  NotDmd [temp_unlift, THEN eq_reflection]

lemma BoxDmdBox: "|- ([]<>[]F) = (<>[]F)"
  apply (auto dest!: STL2 [temp_use])
  apply (rule ccontr)
  apply (subgoal_tac "sigma |= <>[][]F & <>[]~[]F")
   apply (erule thin_rl)
   apply auto
    apply (drule STL6 [temp_use])
     apply assumption
    apply simp
   apply (simp_all add: more_temp_simps1)
  done

lemma DmdBoxDmd: "|- (<>[]<>F) = ([]<>F)"
  apply (unfold dmd_def)
  apply (auto simp: BoxDmdBox [unfolded dmd_def, try_rewrite])
  done

lemmas more_temp_simps2 = more_temp_simps1 BoxDmdBox [temp_rewrite] DmdBoxDmd [temp_rewrite]

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

lemma BoxOr: "!!sigma. [| sigma |= []F | []G |] ==> sigma |= [](F | G)"
  by (fastforce elim!: STL4E [temp_use])

(* "persistently implies infinitely often" *)
lemma DBImplBD: "|- <>[]F --> []<>F"
  apply clarsimp
  apply (rule ccontr)
  apply (simp add: more_temp_simps2)
  apply (drule STL6 [temp_use])
   apply assumption
  apply simp
  done

lemma BoxDmdDmdBox: "|- []<>F & <>[]G --> []<>(F & G)"
  apply clarsimp
  apply (rule ccontr)
  apply (unfold more_temp_simps2)
  apply (drule STL6 [temp_use])
   apply assumption
  apply (subgoal_tac "sigma |= <>[]~F")
   apply (force simp: dmd_def)
  apply (fastforce elim: DmdImplE [temp_use] STL4E [temp_use])
  done

(* ------------------------------------------------------------------------- *)
(***          TLA-specific theorems: primed formulas                       ***)
(* ------------------------------------------------------------------------- *)
section "priming"

(* ------------------------ TLA2 ------------------------------------------- *)
lemma STL2_pr: "|- []P --> Init P & Init P`"
  by (fastforce intro!: STL2_gen [temp_use] primeI [temp_use])

(* Auxiliary lemma allows priming of boxed actions *)
lemma BoxPrime: "|- []P --> []($P & P$)"
  apply clarsimp
  apply (erule dup_boxE)
  apply (unfold boxInit_act)
  apply (erule STL4E)
  apply (auto simp: Init_simps dest!: STL2_pr [temp_use])
  done

lemma TLA2:
  assumes "|- $P & P$ --> A"
  shows "|- []P --> []A"
  apply clarsimp
  apply (drule BoxPrime [temp_use])
  apply (auto simp: Init_stp_act_rev [try_rewrite] intro!: assms [temp_use]
    elim!: STL4E [temp_use])
  done

lemma TLA2E: "[| sigma |= []P; |- $P & P$ --> A |] ==> sigma |= []A"
  by (erule (1) TLA2 [temp_use])

lemma DmdPrime: "|- (<>P`) --> (<>P)"
  apply (unfold dmd_def)
  apply (fastforce elim!: TLA2E [temp_use])
  done

lemmas PrimeDmd = InitDmd_gen [temp_use, THEN DmdPrime [temp_use]]

(* ------------------------ INV1, stable --------------------------------------- *)
section "stable, invariant"

lemma ind_rule:
   "[| sigma |= []H; sigma |= Init P; |- H --> (Init P & ~[]F --> Init(P`) & F) |]
    ==> sigma |= []F"
  apply (rule indT [temp_use])
   apply (erule (2) STL4E)
  done

lemma box_stp_act: "|- ([]$P) = ([]P)"
  by (simp add: boxInit_act Init_simps)

lemmas box_stp_actI = box_stp_act [temp_use, THEN iffD2]
lemmas box_stp_actD = box_stp_act [temp_use, THEN iffD1]

lemmas more_temp_simps3 = box_stp_act [temp_rewrite] more_temp_simps2

lemma INV1:
  "|- (Init P) --> (stable P) --> []P"
  apply (unfold stable_def boxInit_stp boxInit_act)
  apply clarsimp
  apply (erule ind_rule)
   apply (auto simp: Init_simps elim: ind_rule)
  done

lemma StableT:
    "!!P. |- $P & A --> P` ==> |- []A --> stable P"
  apply (unfold stable_def)
  apply (fastforce elim!: STL4E [temp_use])
  done

lemma Stable: "[| sigma |= []A; |- $P & A --> P` |] ==> sigma |= stable P"
  by (erule (1) StableT [temp_use])

(* Generalization of INV1 *)
lemma StableBox: "|- (stable P) --> [](Init P --> []P)"
  apply (unfold stable_def)
  apply clarsimp
  apply (erule dup_boxE)
  apply (force simp: stable_def elim: STL4E [temp_use] INV1 [temp_use])
  done

lemma DmdStable: "|- (stable P) & <>P --> <>[]P"
  apply clarsimp
  apply (rule DmdImpl2)
   prefer 2
   apply (erule StableBox [temp_use])
  apply (simp add: dmdInitD)
  done

(* ---------------- (Semi-)automatic invariant tactics ---------------------- *)

ML {*
(* inv_tac reduces goals of the form ... ==> sigma |= []P *)
fun inv_tac ctxt =
  SELECT_GOAL
    (EVERY
     [auto_tac ctxt,
      TRY (merge_box_tac 1),
      rtac (temp_use ctxt @{thm INV1}) 1, (* fail if the goal is not a box *)
      TRYALL (etac @{thm Stable})]);

(* auto_inv_tac applies inv_tac and then tries to attack the subgoals
   in simple cases it may be able to handle goals like |- MyProg --> []Inv.
   In these simple cases the simplifier seems to be more useful than the
   auto-tactic, which applies too much propositional logic and simplifies
   too late.
*)
fun auto_inv_tac ctxt =
  SELECT_GOAL
    (inv_tac ctxt 1 THEN
      (TRYALL (action_simp_tac
        (ctxt addsimps [@{thm Init_stp}, @{thm Init_act}]) [] [@{thm squareE}])));
*}

method_setup invariant = {*
  Method.sections Clasimp.clasimp_modifiers >> (K (SIMPLE_METHOD' o inv_tac))
*}

method_setup auto_invariant = {*
  Method.sections Clasimp.clasimp_modifiers >> (K (SIMPLE_METHOD' o auto_inv_tac))
*}

lemma unless: "|- []($P --> P` | Q`) --> (stable P) | <>Q"
  apply (unfold dmd_def)
  apply (clarsimp dest!: BoxPrime [temp_use])
  apply merge_box
  apply (erule contrapos_np)
  apply (fastforce elim!: Stable [temp_use])
  done

(* --------------------- Recursive expansions --------------------------------------- *)
section "recursive expansions"

(* Recursive expansions of [] and <> for state predicates *)
lemma BoxRec: "|- ([]P) = (Init P & []P`)"
  apply (auto intro!: STL2_gen [temp_use])
   apply (fastforce elim!: TLA2E [temp_use])
  apply (auto simp: stable_def elim!: INV1 [temp_use] STL4E [temp_use])
  done

lemma DmdRec: "|- (<>P) = (Init P | <>P`)"
  apply (unfold dmd_def BoxRec [temp_rewrite])
  apply (auto simp: Init_simps)
  done

lemma DmdRec2: "!!sigma. [| sigma |= <>P; sigma |= []~P` |] ==> sigma |= Init P"
  apply (force simp: DmdRec [temp_rewrite] dmd_def)
  done

lemma InfinitePrime: "|- ([]<>P) = ([]<>P`)"
  apply auto
   apply (rule classical)
   apply (rule DBImplBD [temp_use])
   apply (subgoal_tac "sigma |= <>[]P")
    apply (fastforce elim!: DmdImplE [temp_use] TLA2E [temp_use])
   apply (subgoal_tac "sigma |= <>[] (<>P & []~P`)")
    apply (force simp: boxInit_stp [temp_use]
      elim!: DmdImplE [temp_use] STL4E [temp_use] DmdRec2 [temp_use])
   apply (force intro!: STL6 [temp_use] simp: more_temp_simps3)
  apply (fastforce intro: DmdPrime [temp_use] elim!: STL4E [temp_use])
  done

lemma InfiniteEnsures:
  "[| sigma |= []N; sigma |= []<>A; |- A & N --> P` |] ==> sigma |= []<>P"
  apply (unfold InfinitePrime [temp_rewrite])
  apply (rule InfImpl)
    apply assumption+
  done

(* ------------------------ fairness ------------------------------------------- *)
section "fairness"

(* alternative definitions of fairness *)
lemma WF_alt: "|- WF(A)_v = ([]<>~Enabled(<A>_v) | []<><A>_v)"
  apply (unfold WF_def dmd_def)
  apply fastforce
  done

lemma SF_alt: "|- SF(A)_v = (<>[]~Enabled(<A>_v) | []<><A>_v)"
  apply (unfold SF_def dmd_def)
  apply fastforce
  done

(* theorems to "box" fairness conditions *)
lemma BoxWFI: "|- WF(A)_v --> []WF(A)_v"
  by (auto simp: WF_alt [try_rewrite] more_temp_simps3 intro!: BoxOr [temp_use])

lemma WF_Box: "|- ([]WF(A)_v) = WF(A)_v"
  by (fastforce intro!: BoxWFI [temp_use] dest!: STL2 [temp_use])

lemma BoxSFI: "|- SF(A)_v --> []SF(A)_v"
  by (auto simp: SF_alt [try_rewrite] more_temp_simps3 intro!: BoxOr [temp_use])

lemma SF_Box: "|- ([]SF(A)_v) = SF(A)_v"
  by (fastforce intro!: BoxSFI [temp_use] dest!: STL2 [temp_use])

lemmas more_temp_simps = more_temp_simps3 WF_Box [temp_rewrite] SF_Box [temp_rewrite]

lemma SFImplWF: "|- SF(A)_v --> WF(A)_v"
  apply (unfold SF_def WF_def)
  apply (fastforce dest!: DBImplBD [temp_use])
  done

(* A tactic that "boxes" all fairness conditions. Apply more_temp_simps to "unbox". *)
ML {*
val box_fair_tac = SELECT_GOAL (REPEAT (dresolve_tac [@{thm BoxWFI}, @{thm BoxSFI}] 1))
*}

(* ------------------------------ leads-to ------------------------------ *)

section "~>"

lemma leadsto_init: "|- (Init F) & (F ~> G) --> <>G"
  apply (unfold leadsto_def)
  apply (auto dest!: STL2 [temp_use])
  done

(* |- F & (F ~> G) --> <>G *)
lemmas leadsto_init_temp = leadsto_init [where 'a = behavior, unfolded Init_simps]

lemma streett_leadsto: "|- ([]<>Init F --> []<>G) = (<>(F ~> G))"
  apply (unfold leadsto_def)
  apply auto
    apply (simp add: more_temp_simps)
    apply (fastforce elim!: DmdImplE [temp_use] STL4E [temp_use])
   apply (fastforce intro!: InitDmd [temp_use] elim!: STL4E [temp_use])
  apply (subgoal_tac "sigma |= []<><>G")
   apply (simp add: more_temp_simps)
  apply (drule BoxDmdDmdBox [temp_use])
   apply assumption
  apply (fastforce elim!: DmdImplE [temp_use] STL4E [temp_use])
  done

lemma leadsto_infinite: "|- []<>F & (F ~> G) --> []<>G"
  apply clarsimp
  apply (erule InitDmd [temp_use, THEN streett_leadsto [temp_unlift, THEN iffD2, THEN mp]])
  apply (simp add: dmdInitD)
  done

(* In particular, strong fairness is a Streett condition. The following
   rules are sometimes easier to use than WF2 or SF2 below.
*)
lemma leadsto_SF: "|- (Enabled(<A>_v) ~> <A>_v) --> SF(A)_v"
  apply (unfold SF_def)
  apply (clarsimp elim!: leadsto_infinite [temp_use])
  done

lemma leadsto_WF: "|- (Enabled(<A>_v) ~> <A>_v) --> WF(A)_v"
  by (clarsimp intro!: SFImplWF [temp_use] leadsto_SF [temp_use])

(* introduce an invariant into the proof of a leadsto assertion.
   []I --> ((P ~> Q)  =  (P /\ I ~> Q))
*)
lemma INV_leadsto: "|- []I & (P & I ~> Q) --> (P ~> Q)"
  apply (unfold leadsto_def)
  apply clarsimp
  apply (erule STL4Edup)
   apply assumption
  apply (auto simp: Init_simps dest!: STL2_gen [temp_use])
  done

lemma leadsto_classical: "|- (Init F & []~G ~> G) --> (F ~> G)"
  apply (unfold leadsto_def dmd_def)
  apply (force simp: Init_simps elim!: STL4E [temp_use])
  done

lemma leadsto_false: "|- (F ~> #False) = ([]~F)"
  apply (unfold leadsto_def)
  apply (simp add: boxNotInitD)
  done

lemma leadsto_exists: "|- ((EX x. F x) ~> G) = (ALL x. (F x ~> G))"
  apply (unfold leadsto_def)
  apply (auto simp: allT [try_rewrite] Init_simps elim!: STL4E [temp_use])
  done

(* basic leadsto properties, cf. Unity *)

lemma ImplLeadsto_gen: "|- [](Init F --> Init G) --> (F ~> G)"
  apply (unfold leadsto_def)
  apply (auto intro!: InitDmd_gen [temp_use]
    elim!: STL4E_gen [temp_use] simp: Init_simps)
  done

lemmas ImplLeadsto =
  ImplLeadsto_gen [where 'a = behavior and 'b = behavior, unfolded Init_simps]

lemma ImplLeadsto_simple: "!!F G. |- F --> G ==> |- F ~> G"
  by (auto simp: Init_def intro!: ImplLeadsto_gen [temp_use] necT [temp_use])

lemma EnsuresLeadsto:
  assumes "|- A & $P --> Q`"
  shows "|- []A --> (P ~> Q)"
  apply (unfold leadsto_def)
  apply (clarsimp elim!: INV_leadsto [temp_use])
  apply (erule STL4E_gen)
  apply (auto simp: Init_defs intro!: PrimeDmd [temp_use] assms [temp_use])
  done

lemma EnsuresLeadsto2: "|- []($P --> Q`) --> (P ~> Q)"
  apply (unfold leadsto_def)
  apply clarsimp
  apply (erule STL4E_gen)
  apply (auto simp: Init_simps intro!: PrimeDmd [temp_use])
  done

lemma ensures:
  assumes 1: "|- $P & N --> P` | Q`"
    and 2: "|- ($P & N) & A --> Q`"
  shows "|- []N & []([]P --> <>A) --> (P ~> Q)"
  apply (unfold leadsto_def)
  apply clarsimp
  apply (erule STL4Edup)
   apply assumption
  apply clarsimp
  apply (subgoal_tac "sigmaa |= [] ($P --> P` | Q`) ")
   apply (drule unless [temp_use])
   apply (clarsimp dest!: INV1 [temp_use])
  apply (rule 2 [THEN DmdImpl, temp_use, THEN DmdPrime [temp_use]])
   apply (force intro!: BoxDmd_simple [temp_use]
     simp: split_box_conj [try_rewrite] box_stp_act [try_rewrite])
  apply (force elim: STL4E [temp_use] dest: 1 [temp_use])
  done

lemma ensures_simple:
  "[| |- $P & N --> P` | Q`;
      |- ($P & N) & A --> Q`
   |] ==> |- []N & []<>A --> (P ~> Q)"
  apply clarsimp
  apply (erule (2) ensures [temp_use])
  apply (force elim!: STL4E [temp_use])
  done

lemma EnsuresInfinite:
    "[| sigma |= []<>P; sigma |= []A; |- A & $P --> Q` |] ==> sigma |= []<>Q"
  apply (erule leadsto_infinite [temp_use])
  apply (erule EnsuresLeadsto [temp_use])
  apply assumption
  done

(*** Gronning's lattice rules (taken from TLP) ***)
section "Lattice rules"

lemma LatticeReflexivity: "|- F ~> F"
  apply (unfold leadsto_def)
  apply (rule necT InitDmd_gen)+
  done

lemma LatticeTransitivity: "|- (G ~> H) & (F ~> G) --> (F ~> H)"
  apply (unfold leadsto_def)
  apply clarsimp
  apply (erule dup_boxE) (* [][] (Init G --> H) *)
  apply merge_box
  apply (clarsimp elim!: STL4E [temp_use])
  apply (rule dup_dmdD)
  apply (subgoal_tac "sigmaa |= <>Init G")
   apply (erule DmdImpl2)
   apply assumption
  apply (simp add: dmdInitD)
  done

lemma LatticeDisjunctionElim1: "|- (F | G ~> H) --> (F ~> H)"
  apply (unfold leadsto_def)
  apply (auto simp: Init_simps elim!: STL4E [temp_use])
  done

lemma LatticeDisjunctionElim2: "|- (F | G ~> H) --> (G ~> H)"
  apply (unfold leadsto_def)
  apply (auto simp: Init_simps elim!: STL4E [temp_use])
  done

lemma LatticeDisjunctionIntro: "|- (F ~> H) & (G ~> H) --> (F | G ~> H)"
  apply (unfold leadsto_def)
  apply clarsimp
  apply merge_box
  apply (auto simp: Init_simps elim!: STL4E [temp_use])
  done

lemma LatticeDisjunction: "|- (F | G ~> H) = ((F ~> H) & (G ~> H))"
  by (auto intro: LatticeDisjunctionIntro [temp_use]
    LatticeDisjunctionElim1 [temp_use]
    LatticeDisjunctionElim2 [temp_use])

lemma LatticeDiamond: "|- (A ~> B | C) & (B ~> D) & (C ~> D) --> (A ~> D)"
  apply clarsimp
  apply (subgoal_tac "sigma |= (B | C) ~> D")
  apply (erule_tac G = "LIFT (B | C)" in LatticeTransitivity [temp_use])
   apply (fastforce intro!: LatticeDisjunctionIntro [temp_use])+
  done

lemma LatticeTriangle: "|- (A ~> D | B) & (B ~> D) --> (A ~> D)"
  apply clarsimp
  apply (subgoal_tac "sigma |= (D | B) ~> D")
   apply (erule_tac G = "LIFT (D | B)" in LatticeTransitivity [temp_use])
  apply assumption
  apply (auto intro: LatticeDisjunctionIntro [temp_use] LatticeReflexivity [temp_use])
  done

lemma LatticeTriangle2: "|- (A ~> B | D) & (B ~> D) --> (A ~> D)"
  apply clarsimp
  apply (subgoal_tac "sigma |= B | D ~> D")
   apply (erule_tac G = "LIFT (B | D)" in LatticeTransitivity [temp_use])
   apply assumption
  apply (auto intro: LatticeDisjunctionIntro [temp_use] LatticeReflexivity [temp_use])
  done

(*** Lamport's fairness rules ***)
section "Fairness rules"

lemma WF1:
  "[| |- $P & N  --> P` | Q`;
      |- ($P & N) & <A>_v --> Q`;
      |- $P & N --> $(Enabled(<A>_v)) |]
  ==> |- []N & WF(A)_v --> (P ~> Q)"
  apply (clarsimp dest!: BoxWFI [temp_use])
  apply (erule (2) ensures [temp_use])
  apply (erule (1) STL4Edup)
  apply (clarsimp simp: WF_def)
  apply (rule STL2 [temp_use])
  apply (clarsimp elim!: mp intro!: InitDmd [temp_use])
  apply (erule STL4 [temp_use, THEN box_stp_actD [temp_use]])
  apply (simp add: split_box_conj box_stp_actI)
  done

(* Sometimes easier to use; designed for action B rather than state predicate Q *)
lemma WF_leadsto:
  assumes 1: "|- N & $P --> $Enabled (<A>_v)"
    and 2: "|- N & <A>_v --> B"
    and 3: "|- [](N & [~A]_v) --> stable P"
  shows "|- []N & WF(A)_v --> (P ~> B)"
  apply (unfold leadsto_def)
  apply (clarsimp dest!: BoxWFI [temp_use])
  apply (erule (1) STL4Edup)
  apply clarsimp
  apply (rule 2 [THEN DmdImpl, temp_use])
  apply (rule BoxDmd_simple [temp_use])
   apply assumption
  apply (rule classical)
  apply (rule STL2 [temp_use])
  apply (clarsimp simp: WF_def elim!: mp intro!: InitDmd [temp_use])
  apply (rule 1 [THEN STL4, temp_use, THEN box_stp_actD])
  apply (simp (no_asm_simp) add: split_box_conj [try_rewrite] box_stp_act [try_rewrite])
  apply (erule INV1 [temp_use])
  apply (rule 3 [temp_use])
  apply (simp add: split_box_conj [try_rewrite] NotDmd [temp_use] not_angle [try_rewrite])
  done

lemma SF1:
  "[| |- $P & N  --> P` | Q`;
      |- ($P & N) & <A>_v --> Q`;
      |- []P & []N & []F --> <>Enabled(<A>_v) |]
  ==> |- []N & SF(A)_v & []F --> (P ~> Q)"
  apply (clarsimp dest!: BoxSFI [temp_use])
  apply (erule (2) ensures [temp_use])
  apply (erule_tac F = F in dup_boxE)
  apply merge_temp_box
  apply (erule STL4Edup)
  apply assumption
  apply (clarsimp simp: SF_def)
  apply (rule STL2 [temp_use])
  apply (erule mp)
  apply (erule STL4 [temp_use])
  apply (simp add: split_box_conj [try_rewrite] STL3 [try_rewrite])
  done

lemma WF2:
  assumes 1: "|- N & <B>_f --> <M>_g"
    and 2: "|- $P & P` & <N & A>_f --> B"
    and 3: "|- P & Enabled(<M>_g) --> Enabled(<A>_f)"
    and 4: "|- [](N & [~B]_f) & WF(A)_f & []F & <>[]Enabled(<M>_g) --> <>[]P"
  shows "|- []N & WF(A)_f & []F --> WF(M)_g"
  apply (clarsimp dest!: BoxWFI [temp_use] BoxDmdBox [temp_use, THEN iffD2]
    simp: WF_def [where A = M])
  apply (erule_tac F = F in dup_boxE)
  apply merge_temp_box
  apply (erule STL4Edup)
   apply assumption
  apply (clarsimp intro!: BoxDmd_simple [temp_use, THEN 1 [THEN DmdImpl, temp_use]])
  apply (rule classical)
  apply (subgoal_tac "sigmaa |= <> (($P & P` & N) & <A>_f)")
   apply (force simp: angle_def intro!: 2 [temp_use] elim!: DmdImplE [temp_use])
  apply (rule BoxDmd_simple [THEN DmdImpl, unfolded DmdDmd [temp_rewrite], temp_use])
  apply (simp add: NotDmd [temp_use] not_angle [try_rewrite])
  apply merge_act_box
  apply (frule 4 [temp_use])
     apply assumption+
  apply (drule STL6 [temp_use])
   apply assumption
  apply (erule_tac V = "sigmaa |= <>[]P" in thin_rl)
  apply (erule_tac V = "sigmaa |= []F" in thin_rl)
  apply (drule BoxWFI [temp_use])
  apply (erule_tac F = "ACT N & [~B]_f" in dup_boxE)
  apply merge_temp_box
  apply (erule DmdImpldup)
   apply assumption
  apply (auto simp: split_box_conj [try_rewrite] STL3 [try_rewrite]
    WF_Box [try_rewrite] box_stp_act [try_rewrite])
   apply (force elim!: TLA2E [where P = P, temp_use])
  apply (rule STL2 [temp_use])
  apply (force simp: WF_def split_box_conj [try_rewrite]
    elim!: mp intro!: InitDmd [temp_use] 3 [THEN STL4, temp_use])
  done

lemma SF2:
  assumes 1: "|- N & <B>_f --> <M>_g"
    and 2: "|- $P & P` & <N & A>_f --> B"
    and 3: "|- P & Enabled(<M>_g) --> Enabled(<A>_f)"
    and 4: "|- [](N & [~B]_f) & SF(A)_f & []F & []<>Enabled(<M>_g) --> <>[]P"
  shows "|- []N & SF(A)_f & []F --> SF(M)_g"
  apply (clarsimp dest!: BoxSFI [temp_use] simp: 2 [try_rewrite] SF_def [where A = M])
  apply (erule_tac F = F in dup_boxE)
  apply (erule_tac F = "TEMP <>Enabled (<M>_g) " in dup_boxE)
  apply merge_temp_box
  apply (erule STL4Edup)
   apply assumption
  apply (clarsimp intro!: BoxDmd_simple [temp_use, THEN 1 [THEN DmdImpl, temp_use]])
  apply (rule classical)
  apply (subgoal_tac "sigmaa |= <> (($P & P` & N) & <A>_f)")
   apply (force simp: angle_def intro!: 2 [temp_use] elim!: DmdImplE [temp_use])
  apply (rule BoxDmd_simple [THEN DmdImpl, unfolded DmdDmd [temp_rewrite], temp_use])
  apply (simp add: NotDmd [temp_use] not_angle [try_rewrite])
  apply merge_act_box
  apply (frule 4 [temp_use])
     apply assumption+
  apply (erule_tac V = "sigmaa |= []F" in thin_rl)
  apply (drule BoxSFI [temp_use])
  apply (erule_tac F = "TEMP <>Enabled (<M>_g)" in dup_boxE)
  apply (erule_tac F = "ACT N & [~B]_f" in dup_boxE)
  apply merge_temp_box
  apply (erule DmdImpldup)
   apply assumption
  apply (auto simp: split_box_conj [try_rewrite] STL3 [try_rewrite]
    SF_Box [try_rewrite] box_stp_act [try_rewrite])
   apply (force elim!: TLA2E [where P = P, temp_use])
  apply (rule STL2 [temp_use])
  apply (force simp: SF_def split_box_conj [try_rewrite]
    elim!: mp InfImpl [temp_use] intro!: 3 [temp_use])
  done

(* ------------------------------------------------------------------------- *)
(***           Liveness proofs by well-founded orderings                   ***)
(* ------------------------------------------------------------------------- *)
section "Well-founded orderings"

lemma wf_leadsto:
  assumes 1: "wf r"
    and 2: "!!x. sigma |= F x ~> (G | (EX y. #((y,x):r) & F y))    "
  shows "sigma |= F x ~> G"
  apply (rule 1 [THEN wf_induct])
  apply (rule LatticeTriangle [temp_use])
   apply (rule 2)
  apply (auto simp: leadsto_exists [try_rewrite])
  apply (case_tac "(y,x) :r")
   apply force
  apply (force simp: leadsto_def Init_simps intro!: necT [temp_use])
  done

(* If r is well-founded, state function v cannot decrease forever *)
lemma wf_not_box_decrease: "!!r. wf r ==> |- [][ (v`, $v) : #r ]_v --> <>[][#False]_v"
  apply clarsimp
  apply (rule ccontr)
  apply (subgoal_tac "sigma |= (EX x. v=#x) ~> #False")
   apply (drule leadsto_false [temp_use, THEN iffD1, THEN STL2_gen [temp_use]])
   apply (force simp: Init_defs)
  apply (clarsimp simp: leadsto_exists [try_rewrite] not_square [try_rewrite] more_temp_simps)
  apply (erule wf_leadsto)
  apply (rule ensures_simple [temp_use])
   apply (auto simp: square_def angle_def)
  done

(* "wf r  ==>  |- <>[][ (v`, $v) : #r ]_v --> <>[][#False]_v" *)
lemmas wf_not_dmd_box_decrease =
  wf_not_box_decrease [THEN DmdImpl, unfolded more_temp_simps]

(* If there are infinitely many steps where v decreases, then there
   have to be infinitely many non-stuttering steps where v doesn't decrease.
*)
lemma wf_box_dmd_decrease:
  assumes 1: "wf r"
  shows "|- []<>((v`, $v) : #r) --> []<><(v`, $v) ~: #r>_v"
  apply clarsimp
  apply (rule ccontr)
  apply (simp add: not_angle [try_rewrite] more_temp_simps)
  apply (drule 1 [THEN wf_not_dmd_box_decrease [temp_use]])
  apply (drule BoxDmdDmdBox [temp_use])
   apply assumption
  apply (subgoal_tac "sigma |= []<> ((#False) ::action)")
   apply force
  apply (erule STL4E)
  apply (rule DmdImpl)
  apply (force intro: 1 [THEN wf_irrefl, temp_use])
  done

(* In particular, for natural numbers, if n decreases infinitely often
   then it has to increase infinitely often.
*)
lemma nat_box_dmd_decrease: "!!n::nat stfun. |- []<>(n` < $n) --> []<>($n < n`)"
  apply clarsimp
  apply (subgoal_tac "sigma |= []<><~ ((n`,$n) : #less_than) >_n")
   apply (erule thin_rl)
   apply (erule STL4E)
   apply (rule DmdImpl)
   apply (clarsimp simp: angle_def [try_rewrite])
  apply (rule wf_box_dmd_decrease [temp_use])
   apply (auto elim!: STL4E [temp_use] DmdImplE [temp_use])
  done

(* ------------------------------------------------------------------------- *)
(***           Flexible quantification over state variables                ***)
(* ------------------------------------------------------------------------- *)
section "Flexible quantification"

lemma aallI:
  assumes 1: "basevars vs"
    and 2: "(!!x. basevars (x,vs) ==> sigma |= F x)"
  shows "sigma |= (AALL x. F x)"
  by (auto simp: aall_def elim!: eexE [temp_use] intro!: 1 dest!: 2 [temp_use])

lemma aallE: "|- (AALL x. F x) --> F x"
  apply (unfold aall_def)
  apply clarsimp
  apply (erule contrapos_np)
  apply (force intro!: eexI [temp_use])
  done

(* monotonicity of quantification *)
lemma eex_mono:
  assumes 1: "sigma |= EEX x. F x"
    and 2: "!!x. sigma |= F x --> G x"
  shows "sigma |= EEX x. G x"
  apply (rule unit_base [THEN 1 [THEN eexE]])
  apply (rule eexI [temp_use])
  apply (erule 2 [unfolded intensional_rews, THEN mp])
  done

lemma aall_mono:
  assumes 1: "sigma |= AALL x. F(x)"
    and 2: "!!x. sigma |= F(x) --> G(x)"
  shows "sigma |= AALL x. G(x)"
  apply (rule unit_base [THEN aallI])
  apply (rule 2 [unfolded intensional_rews, THEN mp])
  apply (rule 1 [THEN aallE [temp_use]])
  done

(* Derived history introduction rule *)
lemma historyI:
  assumes 1: "sigma |= Init I"
    and 2: "sigma |= []N"
    and 3: "basevars vs"
    and 4: "!!h. basevars(h,vs) ==> |- I & h = ha --> HI h"
    and 5: "!!h s t. [| basevars(h,vs); N (s,t); h t = hb (h s) (s,t) |] ==> HN h (s,t)"
  shows "sigma |= EEX h. Init (HI h) & [](HN h)"
  apply (rule history [temp_use, THEN eexE])
  apply (rule 3)
  apply (rule eexI [temp_use])
  apply clarsimp
  apply (rule conjI)
   prefer 2
   apply (insert 2)
   apply merge_box
   apply (force elim!: STL4E [temp_use] 5 [temp_use])
  apply (insert 1)
  apply (force simp: Init_defs elim!: 4 [temp_use])
  done

(* ----------------------------------------------------------------------
   example of a history variable: existence of a clock
*)

lemma "|- EEX h. Init(h = #True) & [](h` = (~$h))"
  apply (rule tempI)
  apply (rule historyI)
  apply (force simp: Init_defs intro!: unit_base [temp_use] necT [temp_use])+
  done

end


(*  Title:      Nominal2_Eqvt
    Author:     Brian Huffman,
    Author:     Christian Urban

    Test cases for perm_simp
*)
theory Eqvt
imports Nominal2_Base
begin

declare [[trace_eqvt = false]]
(* declare [[trace_eqvt = true]] *)

lemma
  fixes B::"'a::pt"
  shows "p \<bullet> (B = C)"
apply(perm_simp)
oops

lemma
  fixes B::"bool"
  shows "p \<bullet> (B = C)"
apply(perm_simp)
oops

lemma
  fixes B::"bool"
  shows "p \<bullet> (A \<longrightarrow> B = C)"
apply (perm_simp)
oops

lemma
  shows "p \<bullet> (\<lambda>(x::'a::pt). A \<longrightarrow> (B::'a \<Rightarrow> bool) x = C) = foo"
apply(perm_simp)
oops

lemma
  shows "p \<bullet> (\<lambda>B::bool. A \<longrightarrow> (B = C)) = foo"
apply (perm_simp)
oops

lemma
  shows "p \<bullet> (\<lambda>x y. \<exists>z. x = z \<and> x = y \<longrightarrow> z \<noteq> x) = foo"
apply (perm_simp)
oops

lemma
  shows "p \<bullet> (\<lambda>f x. f (g (f x))) = foo"
apply (perm_simp)
oops

lemma
  fixes p q::"perm"
  and   x::"'a::pt"
  shows "p \<bullet> (q \<bullet> x) = foo"
apply(perm_simp)
oops

lemma
  fixes p q r::"perm"
  and   x::"'a::pt"
  shows "p \<bullet> (q \<bullet> r \<bullet> x) = foo"
apply(perm_simp)
oops

lemma
  fixes p r::"perm"
  shows "p \<bullet> (\<lambda>q::perm. q \<bullet> (r \<bullet> x)) = foo"
apply (perm_simp)
oops

lemma
  fixes C D::"bool"
  shows "B (p \<bullet> (C = D))"
apply(perm_simp)
oops

declare [[trace_eqvt = false]]

text \<open>there is no raw eqvt-rule for The\<close>
lemma "p \<bullet> (THE x. P x) = foo"
apply(perm_strict_simp exclude: The)
apply(perm_simp exclude: The)
oops

lemma
  fixes P :: "(('b \<Rightarrow> bool) \<Rightarrow> ('b::pt)) \<Rightarrow> ('a::pt)"
  shows "p \<bullet> (P The) = foo"
apply(perm_simp exclude: The)
oops

lemma
  fixes  P :: "('a::pt) \<Rightarrow> ('b::pt) \<Rightarrow> bool"
  shows "p \<bullet> (\<lambda>(a, b). P a b) = (\<lambda>(a, b). (p \<bullet> P) a b)"
apply(perm_simp)
oops

thm eqvts
thm eqvts_raw

ML \<open>Nominal_ThmDecls.is_eqvt @{context} @{term "supp"}\<close>

end