header {* \isaheader{CFG} *}

theory WCFG imports Com "../Basic/BasicDefs" begin

subsection{* CFG nodes *}

datatype w_node = Node nat ("'('_ _ '_')")
  | Entry ("'('_Entry'_')")
  | Exit ("'('_Exit'_')")

fun label_incr :: "w_node \<Rightarrow> nat \<Rightarrow> w_node" ("_ \<oplus> _" 60)
where "(_ l _) \<oplus> i = (_ l + i _)"
  | "(_Entry_) \<oplus> i = (_Entry_)"
  | "(_Exit_) \<oplus> i  = (_Exit_)"

lemma Exit_label_incr [dest]: "(_Exit_) = n \<oplus> i \<Longrightarrow> n = (_Exit_)"
  by(cases n,auto)

lemma label_incr_Exit [dest]: "n \<oplus> i = (_Exit_) \<Longrightarrow> n = (_Exit_)"
  by(cases n,auto)

lemma Entry_label_incr [dest]: "(_Entry_) = n \<oplus> i \<Longrightarrow> n = (_Entry_)"
  by(cases n,auto)

lemma label_incr_Entry [dest]: "n \<oplus> i = (_Entry_) \<Longrightarrow> n = (_Entry_)"
  by(cases n,auto)

lemma label_incr_inj:
  "n \<oplus> c = n' \<oplus> c \<Longrightarrow> n = n'"
by(cases n)(cases n',auto)+

lemma label_incr_simp:"n \<oplus> i = m \<oplus> (i + j) \<Longrightarrow> n = m \<oplus> j"
by(cases n,auto,cases m,auto)

lemma label_incr_start_Node_smaller:
  "(_ l _) = n \<oplus> i \<Longrightarrow> n = (_(l - i)_)"
by(cases n,auto)

lemma label_incr_ge:"(_ l _) = n \<oplus> i \<Longrightarrow> l \<ge> i"
by(cases n) auto

lemma label_incr_0 [dest]:
  "\<lbrakk>(_0_) = n \<oplus> i; i > 0\<rbrakk> \<Longrightarrow> False"
by(cases n) auto

lemma label_incr_0_rev [dest]:
  "\<lbrakk>n \<oplus> i = (_0_); i > 0\<rbrakk> \<Longrightarrow> False"
by(cases n) auto

subsection{* CFG edges *}

type_synonym w_edge = "(w_node \<times> state edge_kind \<times> w_node)"

inductive While_CFG :: "cmd \<Rightarrow> w_node \<Rightarrow> state edge_kind \<Rightarrow> w_node \<Rightarrow> bool"
  ("_ \<turnstile> _ -_\<rightarrow> _")
where

WCFG_Entry_Exit:
  "prog \<turnstile> (_Entry_) -(\<lambda>s. False)\<^sub>\<surd>\<rightarrow> (_Exit_)"

| WCFG_Entry:
  "prog \<turnstile> (_Entry_) -(\<lambda>s. True)\<^sub>\<surd>\<rightarrow> (_0_)"

| WCFG_Skip:
  "Skip \<turnstile> (_0_) -\<Up>id\<rightarrow> (_Exit_)"

| WCFG_LAss:
  "V:=e \<turnstile> (_0_) -\<Up>(\<lambda>s. s(V:=(interpret e s)))\<rightarrow> (_1_)"

| WCFG_LAssSkip:
  "V:=e \<turnstile> (_1_) -\<Up>id\<rightarrow> (_Exit_)"

| WCFG_SeqFirst:
  "\<lbrakk>c\<^sub>1 \<turnstile> n -et\<rightarrow> n'; n' \<noteq> (_Exit_)\<rbrakk> \<Longrightarrow> c\<^sub>1;;c\<^sub>2 \<turnstile> n -et\<rightarrow> n'"

| WCFG_SeqConnect:
  "\<lbrakk>c\<^sub>1 \<turnstile> n -et\<rightarrow> (_Exit_); n \<noteq> (_Entry_)\<rbrakk> \<Longrightarrow> c\<^sub>1;;c\<^sub>2 \<turnstile> n -et\<rightarrow> (_0_) \<oplus> #:c\<^sub>1"

| WCFG_SeqSecond:
  "\<lbrakk>c\<^sub>2 \<turnstile> n -et\<rightarrow> n'; n \<noteq> (_Entry_)\<rbrakk> \<Longrightarrow> c\<^sub>1;;c\<^sub>2 \<turnstile> n \<oplus> #:c\<^sub>1 -et\<rightarrow> n' \<oplus> #:c\<^sub>1"

| WCFG_CondTrue:
    "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some true)\<^sub>\<surd>\<rightarrow> (_0_) \<oplus> 1"

| WCFG_CondFalse:
    "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some false)\<^sub>\<surd>\<rightarrow> (_0_) \<oplus> (#:c\<^sub>1 + 1)"

| WCFG_CondThen:
  "\<lbrakk>c\<^sub>1 \<turnstile> n -et\<rightarrow> n'; n \<noteq> (_Entry_)\<rbrakk> \<Longrightarrow> if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n \<oplus> 1 -et\<rightarrow> n' \<oplus> 1"

| WCFG_CondElse:
  "\<lbrakk>c\<^sub>2 \<turnstile> n -et\<rightarrow> n'; n \<noteq> (_Entry_)\<rbrakk>
  \<Longrightarrow> if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n \<oplus> (#:c\<^sub>1 + 1) -et\<rightarrow> n' \<oplus> (#:c\<^sub>1 + 1)"

| WCFG_WhileTrue:
    "while (b) c' \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some true)\<^sub>\<surd>\<rightarrow> (_0_) \<oplus> 2"

| WCFG_WhileFalse:
    "while (b) c' \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some false)\<^sub>\<surd>\<rightarrow> (_1_)"

| WCFG_WhileFalseSkip:
  "while (b) c' \<turnstile> (_1_) -\<Up>id\<rightarrow> (_Exit_)"

| WCFG_WhileBody:
  "\<lbrakk>c' \<turnstile> n -et\<rightarrow> n'; n \<noteq> (_Entry_); n' \<noteq> (_Exit_)\<rbrakk>
  \<Longrightarrow> while (b) c' \<turnstile> n \<oplus> 2 -et\<rightarrow> n' \<oplus> 2"

| WCFG_WhileBodyExit:
  "\<lbrakk>c' \<turnstile> n -et\<rightarrow> (_Exit_); n \<noteq> (_Entry_)\<rbrakk> \<Longrightarrow> while (b) c' \<turnstile> n \<oplus> 2 -et\<rightarrow> (_0_)"

lemmas WCFG_intros = While_CFG.intros[split_format (complete)]
lemmas WCFG_elims = While_CFG.cases[split_format (complete)]
lemmas WCFG_induct = While_CFG.induct[split_format (complete)]

subsection {* Some lemmas about the CFG *}

lemma WCFG_Exit_no_sourcenode [dest]:
  "prog \<turnstile> (_Exit_) -et\<rightarrow> n' \<Longrightarrow> False"
by(induct prog n\<equiv>"(_Exit_)" et n' rule:WCFG_induct,auto)

lemma WCFG_Entry_no_targetnode [dest]:
  "prog \<turnstile> n -et\<rightarrow> (_Entry_) \<Longrightarrow> False"
by(induct prog n et n'\<equiv>"(_Entry_)" rule:WCFG_induct,auto)

lemma WCFG_targetlabel_less_num_nodes:
  "prog \<turnstile> n -et\<rightarrow> (_ l _) \<Longrightarrow> l < #:prog"
proof(induct prog n et "(_ l _)" arbitrary:l rule:WCFG_induct)
  case (WCFG_SeqFirst c\<^sub>1 n et c\<^sub>2)
  from `l < #:c\<^sub>1` show ?case by simp
next
  case (WCFG_SeqSecond c\<^sub>2 n et n' c\<^sub>1)
  note IH = `\<And>l. n' = (_ l _) \<Longrightarrow> l < #:c\<^sub>2`
  from `n' \<oplus> #:c\<^sub>1 = (_ l _)` obtain l' where "n' = (_ l' _)" by(cases n') auto
  from IH[OF this] have "l' < #:c\<^sub>2" .
  with `n' \<oplus> #:c\<^sub>1 = (_ l _)` `n' = (_ l' _)` show ?case by simp
next
  case (WCFG_CondThen c\<^sub>1 n et n' b c\<^sub>2)
  note IH = `\<And>l. n' = (_ l _) \<Longrightarrow> l < #:c\<^sub>1`
  from `n' \<oplus> 1 = (_ l _)` obtain l' where "n' = (_ l' _)" by(cases n') auto
  from IH[OF this] have "l' < #:c\<^sub>1" .
  with `n' \<oplus> 1 = (_ l _)` `n' = (_ l' _)` show ?case by simp
next
  case (WCFG_CondElse c\<^sub>2 n et n' b c\<^sub>1)
  note IH = `\<And>l. n' = (_ l _) \<Longrightarrow> l < #:c\<^sub>2`
  from `n' \<oplus> (#:c\<^sub>1 + 1) = (_ l _)` obtain l' where "n' = (_ l' _)" by(cases n') auto
  from IH[OF this] have "l' < #:c\<^sub>2" .
  with `n' \<oplus> (#:c\<^sub>1 + 1) = (_ l _)` `n' = (_ l' _)` show ?case by simp
next
  case (WCFG_WhileBody c' n et n' b)
  note IH = `\<And>l. n' = (_ l _) \<Longrightarrow> l < #:c'`
  from `n' \<oplus> 2 = (_ l _)` obtain l' where "n' = (_ l' _)" by(cases n') auto
  from IH[OF this] have "l' < #:c'" .
  with `n' \<oplus> 2 = (_ l _)` `n' = (_ l' _)` show ?case by simp
qed (auto simp:num_inner_nodes_gr_0)

lemma WCFG_EntryD:
  "prog \<turnstile> (_Entry_) -et\<rightarrow> n'
  \<Longrightarrow> (n' = (_Exit_) \<and> et = (\<lambda>s. False)\<^sub>\<surd>) \<or> (n' = (_0_) \<and> et = (\<lambda>s. True)\<^sub>\<surd>)"
by(induct prog n\<equiv>"(_Entry_)" et n' rule:WCFG_induct,auto)

(*<*)declare One_nat_def [simp del] add_2_eq_Suc' [simp del](*>*)

lemma WCFG_edge_det:
  "\<lbrakk>prog \<turnstile> n -et\<rightarrow> n'; prog \<turnstile> n -et'\<rightarrow> n'\<rbrakk> \<Longrightarrow> et = et'"
proof(induct rule:WCFG_induct)
  case WCFG_Entry_Exit thus ?case by(fastforce dest:WCFG_EntryD)
next
  case WCFG_Entry thus ?case by(fastforce dest:WCFG_EntryD)
next
  case WCFG_Skip thus ?case by(fastforce elim:WCFG_elims)
next
  case WCFG_LAss thus ?case by(fastforce elim:WCFG_elims)
next
  case WCFG_LAssSkip thus ?case by(fastforce elim:WCFG_elims)
next
  case (WCFG_SeqFirst c\<^sub>1 n et n' c\<^sub>2)
  note IH = `c\<^sub>1 \<turnstile> n -et'\<rightarrow> n' \<Longrightarrow> et = et'`
  from `c\<^sub>1 \<turnstile> n -et\<rightarrow> n'` `n' \<noteq> (_Exit_)` obtain l where "n' = (_ l _)"
    by (cases n') auto
  with `c\<^sub>1 \<turnstile> n -et\<rightarrow> n'` have "l < #:c\<^sub>1"
    by(fastforce intro:WCFG_targetlabel_less_num_nodes)
  with `c\<^sub>1;;c\<^sub>2 \<turnstile> n -et'\<rightarrow> n'` `n' = (_ l _)` have "c\<^sub>1 \<turnstile> n -et'\<rightarrow> n'"
    by(fastforce elim:WCFG_elims intro:WCFG_intros dest:label_incr_ge)
  from IH[OF this] show ?case .
next
  case (WCFG_SeqConnect c\<^sub>1 n et c\<^sub>2)
  note IH = `c\<^sub>1 \<turnstile> n -et'\<rightarrow> (_Exit_) \<Longrightarrow> et = et'`
  from `c\<^sub>1 \<turnstile> n -et\<rightarrow> (_Exit_)` `n \<noteq> (_Entry_)` obtain l where "n = (_ l _)"
    by (cases n) auto
  with `c\<^sub>1 \<turnstile> n -et\<rightarrow> (_Exit_)` have "l < #:c\<^sub>1"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  with `c\<^sub>1;;c\<^sub>2 \<turnstile> n -et'\<rightarrow> (_ 0 _) \<oplus> #:c\<^sub>1` `n = (_ l _)` have "c\<^sub>1 \<turnstile> n -et'\<rightarrow> (_Exit_)"
    by(fastforce elim:WCFG_elims dest:WCFG_targetlabel_less_num_nodes label_incr_ge)
  from IH[OF this] show ?case .
next
  case (WCFG_SeqSecond c\<^sub>2 n et n' c\<^sub>1)
  note IH = `c\<^sub>2 \<turnstile> n -et'\<rightarrow> n' \<Longrightarrow> et = et'`
  from `c\<^sub>2 \<turnstile> n -et\<rightarrow> n'` `n \<noteq> (_Entry_)` obtain l where "n = (_ l _)"
    by (cases n) auto
  with `c\<^sub>2 \<turnstile> n -et\<rightarrow> n'` have "l < #:c\<^sub>2"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  with `c\<^sub>1;;c\<^sub>2 \<turnstile> n \<oplus> #:c\<^sub>1 -et'\<rightarrow> n' \<oplus> #:c\<^sub>1` `n = (_ l _)` have "c\<^sub>2 \<turnstile> n -et'\<rightarrow> n'"
    by -(erule WCFG_elims,(fastforce dest:WCFG_sourcelabel_less_num_nodes label_incr_ge
                                    dest!:label_incr_inj)+)
  from IH[OF this] show ?case .
next
  case WCFG_CondTrue thus ?case by(fastforce elim:WCFG_elims)
next
  case WCFG_CondFalse thus ?case by(fastforce elim:WCFG_elims)
next
  case (WCFG_CondThen c\<^sub>1 n et n' b c\<^sub>2)
  note IH = `c\<^sub>1 \<turnstile> n -et'\<rightarrow> n' \<Longrightarrow> et = et'`
  from `c\<^sub>1 \<turnstile> n -et\<rightarrow> n'` `n \<noteq> (_Entry_)` obtain l where "n = (_ l _)"
    by (cases n) auto
  with `c\<^sub>1 \<turnstile> n -et\<rightarrow> n'` have "l < #:c\<^sub>1"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  with `if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n \<oplus> 1 -et'\<rightarrow> n' \<oplus> 1` `n = (_ l _)`
  have "c\<^sub>1 \<turnstile> n -et'\<rightarrow> n'"
    by -(erule WCFG_elims,(fastforce dest:label_incr_ge label_incr_inj)+)
  from IH[OF this] show ?case .
next
  case (WCFG_CondElse c\<^sub>2 n et n' b c\<^sub>1)
  note IH = `c\<^sub>2 \<turnstile> n -et'\<rightarrow> n' \<Longrightarrow> et = et'`
  from `c\<^sub>2 \<turnstile> n -et\<rightarrow> n'` `n \<noteq> (_Entry_)` obtain l where "n = (_ l _)"
    by (cases n) auto
  with `c\<^sub>2 \<turnstile> n -et\<rightarrow> n'` have "l < #:c\<^sub>2"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  with `if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n \<oplus> (#:c\<^sub>1 + 1) -et'\<rightarrow> n' \<oplus> (#:c\<^sub>1 + 1)` `n = (_ l _)`
  have "c\<^sub>2 \<turnstile> n -et'\<rightarrow> n'"
    by -(erule WCFG_elims,(fastforce dest:WCFG_sourcelabel_less_num_nodes
                             label_incr_inj label_incr_ge label_incr_simp_rev)+)
  from IH[OF this] show ?case .
next
  case WCFG_WhileTrue thus ?case by(fastforce elim:WCFG_elims)
next
  case WCFG_WhileFalse thus ?case by(fastforce elim:WCFG_elims)
next
  case WCFG_WhileFalseSkip thus ?case by(fastforce elim:WCFG_elims)
next
  case (WCFG_WhileBody c' n et n' b)
  note IH = `c' \<turnstile> n -et'\<rightarrow> n' \<Longrightarrow> et = et'`
  from `c' \<turnstile> n -et\<rightarrow> n'` `n \<noteq> (_Entry_)` obtain l where "n = (_ l _)"
    by (cases n) auto
  moreover
  with `c' \<turnstile> n -et\<rightarrow> n'` have "l < #:c'"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  moreover
  from `c' \<turnstile> n -et\<rightarrow> n'` `n' \<noteq> (_Exit_)` obtain l' where "n' = (_ l' _)"
    by (cases n') auto
  moreover
  with `c' \<turnstile> n -et\<rightarrow> n'` have "l' < #:c'"
    by(fastforce intro:WCFG_targetlabel_less_num_nodes)
  ultimately have "c' \<turnstile> n -et'\<rightarrow> n'" using `while (b) c' \<turnstile> n \<oplus> 2 -et'\<rightarrow> n' \<oplus> 2`
    by(fastforce elim:WCFG_elims dest:label_incr_start_Node_smaller)
  from IH[OF this] show ?case .
next
  case (WCFG_WhileBodyExit c' n et b)
  note IH = `c' \<turnstile> n -et'\<rightarrow> (_Exit_) \<Longrightarrow> et = et'`
  from `c' \<turnstile> n -et\<rightarrow> (_Exit_)` `n \<noteq> (_Entry_)` obtain l where "n = (_ l _)"
    by (cases n) auto
  with `c' \<turnstile> n -et\<rightarrow> (_Exit_)` have "l < #:c'"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  with `while (b) c' \<turnstile> n \<oplus> 2 -et'\<rightarrow> (_0_)` `n = (_ l _)`
  have "c' \<turnstile> n -et'\<rightarrow> (_Exit_)"
    by -(erule WCFG_elims,auto dest:label_incr_start_Node_smaller)
  from IH[OF this] show ?case .
qed

(*<*)declare One_nat_def [simp] add_2_eq_Suc' [simp](*>*)

lemma less_num_nodes_edge_Exit:
  obtains l et where "l < #:prog" and "prog \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)"
proof -
  have "\<exists>l et. l < #:prog \<and> prog \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)"
  proof(induct prog)
    case Skip
    have "0 < #:Skip" by simp
    moreover have "Skip \<turnstile> (_0_) -\<Up>id\<rightarrow> (_Exit_)" by(rule WCFG_Skip)
    ultimately show ?case by blast
  next
    case (LAss V e)
    have "1 < #:(V:=e)" by simp
    moreover have "V:=e \<turnstile> (_1_) -\<Up>id\<rightarrow> (_Exit_)" by(rule WCFG_LAssSkip)
    ultimately show ?case by blast
  next
    case (Seq prog1 prog2)
    from `\<exists>l et. l < #:prog2 \<and> prog2 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)`
    obtain l et where "l < #:prog2" and "prog2 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)"
      by blast
    from `prog2 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)`
    have "prog1;;prog2 \<turnstile> (_ l _) \<oplus> #:prog1 -et\<rightarrow> (_Exit_) \<oplus> #:prog1"
      by(fastforce intro:WCFG_SeqSecond)
    with `l < #:prog2` show ?case by(rule_tac x="l + #:prog1" in exI,auto)
  next
    case (Cond b prog1 prog2)
    from `\<exists>l et. l < #:prog1 \<and> prog1 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)`
    obtain l et where "l < #:prog1" and "prog1 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)"
      by blast
    from `prog1 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)`
    have "if (b) prog1 else prog2 \<turnstile> (_ l _) \<oplus> 1 -et\<rightarrow> (_Exit_) \<oplus> 1"
      by(fastforce intro:WCFG_CondThen)
    with `l < #:prog1` show ?case by(rule_tac x="l + 1" in exI,auto)
  next
    case (While b prog')
    have "1 < #:(while (b) prog')" by simp
    moreover have "while (b) prog' \<turnstile> (_1_) -\<Up>id\<rightarrow> (_Exit_)"
      by(rule WCFG_WhileFalseSkip)
    ultimately show ?case by blast
  qed
  with that show ?thesis by blast
qed

lemma less_num_nodes_edge:
  "l < #:prog \<Longrightarrow> \<exists>n et. prog \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog \<turnstile> (_ l _) -et\<rightarrow> n"
proof(induct prog arbitrary:l)
  case Skip
  from `l < #:Skip` have "l = 0" by simp
  hence "Skip \<turnstile> (_ l _) -\<Up>id\<rightarrow> (_Exit_)" by(fastforce intro:WCFG_Skip)
  thus ?case by blast
next
  case (LAss V e)
  from `l < #:V:=e` have "l = 0 \<or> l = 1" by auto
  thus ?case
  proof
    assume "l = 0"
    hence "V:=e \<turnstile> (_Entry_) -(\<lambda>s. True)\<^sub>\<surd>\<rightarrow> (_ l _)" by(fastforce intro:WCFG_Entry)
    thus ?thesis by blast
  next
    assume "l = 1"
    hence "V:=e \<turnstile> (_ l _) -\<Up>id\<rightarrow> (_Exit_)" by(fastforce intro:WCFG_LAssSkip)
    thus ?thesis by blast
  qed
next
  case (Seq prog1 prog2)
  note IH1 = `\<And>l. l < #:prog1 \<Longrightarrow>
              \<exists>n et. prog1 \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog1 \<turnstile> (_ l _) -et\<rightarrow> n`
  note IH2 = `\<And>l. l < #:prog2 \<Longrightarrow>
              \<exists>n et. prog2 \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog2 \<turnstile> (_ l _) -et\<rightarrow> n`
  show ?case
  proof(cases "l < #:prog1")
    case True
    from IH1[OF this] obtain n et
      where "prog1 \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog1 \<turnstile> (_ l _) -et\<rightarrow> n" by blast
    thus ?thesis
    proof
      assume "prog1 \<turnstile> n -et\<rightarrow> (_ l _)"
      hence "prog1;; prog2 \<turnstile> n -et\<rightarrow> (_ l _)" by(fastforce intro:WCFG_SeqFirst)
      thus ?thesis by blast
    next
      assume edge:"prog1 \<turnstile> (_ l _) -et\<rightarrow> n"
      show ?thesis
      proof(cases "n = (_Exit_)")
        case True
        with edge have "prog1;; prog2 \<turnstile> (_ l _) -et\<rightarrow> (_0_) \<oplus> #:prog1"
          by(fastforce intro:WCFG_SeqConnect)
        thus ?thesis by blast
      next
        case False
        with edge have "prog1;; prog2 \<turnstile> (_ l _) -et\<rightarrow> n"
          by(fastforce intro:WCFG_SeqFirst)
        thus ?thesis by blast
      qed
    qed
  next
    case False
    hence "#:prog1 \<le> l" by simp
    then obtain l' where "l = l' + #:prog1" and "l' = l - #:prog1" by simp
    from `l = l' + #:prog1` `l < #:prog1;; prog2` have "l' < #:prog2" by simp
    from IH2[OF this] obtain n et
      where "prog2 \<turnstile> n -et\<rightarrow> (_ l' _) \<or> prog2 \<turnstile> (_ l' _) -et\<rightarrow> n" by blast
    thus ?thesis
    proof
      assume "prog2 \<turnstile> n -et\<rightarrow> (_ l' _)"
      show ?thesis
      proof(cases "n = (_Entry_)")
        case True
        with `prog2 \<turnstile> n -et\<rightarrow> (_ l' _)` have "l' = 0" by(auto dest:WCFG_EntryD)
        obtain l'' et'' where "l'' < #:prog1"
          and "prog1 \<turnstile> (_ l'' _) -et''\<rightarrow> (_Exit_)"
          by(erule less_num_nodes_edge_Exit)
        hence "prog1;;prog2 \<turnstile> (_ l'' _) -et''\<rightarrow> (_0_) \<oplus> #:prog1"
          by(fastforce intro:WCFG_SeqConnect)
        with `l' = 0` `l = l' + #:prog1` show ?thesis by simp blast
      next
        case False
        with `prog2 \<turnstile> n -et\<rightarrow> (_ l' _)`
        have "prog1;;prog2 \<turnstile> n \<oplus> #:prog1 -et\<rightarrow> (_ l' _) \<oplus> #:prog1"
          by(fastforce intro:WCFG_SeqSecond)
        with `l = l' + #:prog1` show ?thesis  by simp blast
      qed
    next
      assume "prog2 \<turnstile> (_ l' _) -et\<rightarrow> n"
      hence "prog1;;prog2 \<turnstile> (_ l' _) \<oplus> #:prog1 -et\<rightarrow> n \<oplus> #:prog1"
        by(fastforce intro:WCFG_SeqSecond)
      with `l = l' + #:prog1` show ?thesis  by simp blast
    qed
  qed
next
  case (Cond b prog1 prog2)
  note IH1 = `\<And>l. l < #:prog1 \<Longrightarrow>
              \<exists>n et. prog1 \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog1 \<turnstile> (_ l _) -et\<rightarrow> n`
  note IH2 = `\<And>l. l < #:prog2 \<Longrightarrow>
              \<exists>n et. prog2 \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog2 \<turnstile> (_ l _) -et\<rightarrow> n`
  show ?case
  proof(cases "l = 0")
    case True
    have "if (b) prog1 else prog2 \<turnstile> (_Entry_) -(\<lambda>s. True)\<^sub>\<surd>\<rightarrow> (_0_)"
      by(rule WCFG_Entry)
    with True show ?thesis by simp blast
  next
    case False
    hence "0 < l" by simp
    then obtain l' where "l = l' + 1" and "l' = l - 1" by simp
    thus ?thesis
    proof(cases "l' < #:prog1")
      case True
      from IH1[OF this] obtain n et
        where "prog1 \<turnstile> n -et\<rightarrow> (_ l' _) \<or> prog1 \<turnstile> (_ l' _) -et\<rightarrow> n" by blast
      thus ?thesis
      proof
        assume edge:"prog1 \<turnstile> n -et\<rightarrow> (_ l' _)"
        show ?thesis
        proof(cases "n = (_Entry_)")
          case True
          with edge have "l' = 0" by(auto dest:WCFG_EntryD)
          have "if (b) prog1 else prog2 \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some true)\<^sub>\<surd>\<rightarrow>
                                          (_0_) \<oplus> 1"
            by(rule WCFG_CondTrue)
          with `l' = 0` `l = l' + 1` show ?thesis by simp blast
        next
          case False
          with edge have "if (b) prog1 else prog2 \<turnstile> n \<oplus> 1 -et\<rightarrow> (_ l' _) \<oplus> 1"
            by(fastforce intro:WCFG_CondThen)
          with `l = l' + 1` show ?thesis by simp blast
        qed
      next
        assume "prog1 \<turnstile> (_ l' _) -et\<rightarrow> n"
        hence "if (b) prog1 else prog2 \<turnstile> (_ l' _) \<oplus> 1 -et\<rightarrow> n \<oplus> 1"
          by(fastforce intro:WCFG_CondThen)
        with `l = l' + 1` show ?thesis by simp blast
      qed
    next
      case False
      hence "#:prog1 \<le> l'" by simp
      then obtain l'' where "l' = l'' + #:prog1" and "l'' = l' - #:prog1"
        by simp
      from `l' = l'' + #:prog1` `l = l' + 1` `l < #:(if (b) prog1 else prog2)`
      have "l'' < #:prog2" by simp
      from IH2[OF this] obtain n et
        where "prog2 \<turnstile> n -et\<rightarrow> (_ l'' _) \<or> prog2 \<turnstile> (_ l'' _) -et\<rightarrow> n" by blast
      thus ?thesis
      proof
        assume "prog2 \<turnstile> n -et\<rightarrow> (_ l'' _)"
        show ?thesis
        proof(cases "n = (_Entry_)")
          case True
          with `prog2 \<turnstile> n -et\<rightarrow> (_ l'' _)` have "l'' = 0" by(auto dest:WCFG_EntryD)
          have "if (b) prog1 else prog2 \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some false)\<^sub>\<surd>\<rightarrow>
                                          (_0_) \<oplus> (#:prog1 + 1)"
            by(rule WCFG_CondFalse)
          with `l'' = 0` `l' = l'' + #:prog1` `l = l' + 1` show ?thesis by simp blast
        next
          case False
          with `prog2 \<turnstile> n -et\<rightarrow> (_ l'' _)`
          have "if (b) prog1 else prog2 \<turnstile> n \<oplus> (#:prog1 + 1) -et\<rightarrow>
                                          (_ l'' _) \<oplus> (#:prog1 + 1)"
            by(fastforce intro:WCFG_CondElse)
          with `l = l' + 1` `l' = l'' + #:prog1` show ?thesis by simp blast
        qed
      next
        assume "prog2 \<turnstile> (_ l'' _) -et\<rightarrow> n"
        hence "if (b) prog1 else prog2 \<turnstile> (_ l'' _) \<oplus> (#:prog1 + 1) -et\<rightarrow>
                                         n \<oplus> (#:prog1 + 1)"
          by(fastforce intro:WCFG_CondElse)
        with `l = l' + 1` `l' = l'' + #:prog1` show ?thesis by simp blast
      qed
    qed
  qed
next
  case (While b prog')
  note IH = `\<And>l. l < #:prog'
             \<Longrightarrow> \<exists>n et. prog' \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog' \<turnstile> (_ l _) -et\<rightarrow> n`
  show ?case
  proof(cases "l < 1")
    case True
    have "while (b) prog' \<turnstile> (_Entry_) -(\<lambda>s. True)\<^sub>\<surd>\<rightarrow> (_0_)" by(rule WCFG_Entry)
    with True show ?thesis by simp blast
  next
    case False
    hence "1 \<le> l" by simp
    thus ?thesis
    proof(cases "l < 2")
      case True
      with `1 \<le> l` have "l = 1" by simp
      have "while (b) prog' \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some false)\<^sub>\<surd>\<rightarrow> (_1_)"
        by(rule WCFG_WhileFalse)
      with `l = 1` show ?thesis by simp blast
    next
      case False
      with `1 \<le> l` have "2 \<le> l" by simp
      then obtain l' where "l = l' + 2" and "l' = l - 2"
        by(simp del:add_2_eq_Suc')
      from `l = l' + 2` `l < #:while (b) prog'` have "l' < #:prog'" by simp
      from IH[OF this] obtain n et
        where "prog' \<turnstile> n -et\<rightarrow> (_ l' _) \<or> prog' \<turnstile> (_ l' _) -et\<rightarrow> n" by blast
      thus ?thesis
      proof
        assume "prog' \<turnstile> n -et\<rightarrow> (_ l' _)"
        show ?thesis
        proof(cases "n = (_Entry_)")
          case True
          with `prog' \<turnstile> n -et\<rightarrow> (_ l' _)` have "l' = 0" by(auto dest:WCFG_EntryD)
          have "while (b) prog' \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some true)\<^sub>\<surd>\<rightarrow>
                                  (_0_) \<oplus> 2"
            by(rule WCFG_WhileTrue)
          with `l' = 0` `l = l' + 2` show ?thesis by simp blast
        next
          case False
          with `prog' \<turnstile> n -et\<rightarrow> (_ l' _)`
          have "while (b) prog' \<turnstile> n \<oplus> 2 -et\<rightarrow> (_ l' _) \<oplus> 2"
            by(fastforce intro:WCFG_WhileBody)
          with `l = l' + 2` show ?thesis by simp blast
        qed
      next
        assume "prog' \<turnstile> (_ l' _) -et\<rightarrow> n"
        show ?thesis
        proof(cases "n = (_Exit_)")
          case True
          with `prog' \<turnstile> (_ l' _) -et\<rightarrow> n`
          have "while (b) prog' \<turnstile> (_ l' _) \<oplus> 2 -et\<rightarrow> (_0_)"
            by(fastforce intro:WCFG_WhileBodyExit)
          with `l = l' + 2` show ?thesis by simp blast
        next
          case False
          with `prog' \<turnstile> (_ l' _) -et\<rightarrow> n`
          have "while (b) prog' \<turnstile> (_ l' _) \<oplus> 2 -et\<rightarrow> n \<oplus> 2"
            by(fastforce intro:WCFG_WhileBody)
          with `l = l' + 2` show ?thesis by simp blast
        qed
      qed
    qed
  qed
qed

(*<*)declare One_nat_def [simp del](*>*)

lemma WCFG_deterministic:
  "\<lbrakk>prog \<turnstile> n\<^sub>1 -et\<^sub>1\<rightarrow> n\<^sub>1'; prog \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n\<^sub>1 = n\<^sub>2; n\<^sub>1' \<noteq> n\<^sub>2'\<rbrakk>
  \<Longrightarrow> \<exists>Q Q'. et\<^sub>1 = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))"
proof(induct arbitrary:n\<^sub>2 n\<^sub>2' rule:WCFG_induct)
  case (WCFG_Entry_Exit prog)
  from `prog \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `(_Entry_) = n\<^sub>2` `(_Exit_) \<noteq> n\<^sub>2'`
  have "et\<^sub>2 = (\<lambda>s. True)\<^sub>\<surd>" by(fastforce dest:WCFG_EntryD)
  thus ?case by simp
next
  case (WCFG_Entry prog)
  from `prog \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `(_Entry_) = n\<^sub>2` `(_0_) \<noteq> n\<^sub>2'`
  have "et\<^sub>2 = (\<lambda>s. False)\<^sub>\<surd>" by(fastforce dest:WCFG_EntryD)
  thus ?case by simp
next
  case WCFG_Skip
  from `Skip \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `(_0_) = n\<^sub>2` `(_Exit_) \<noteq> n\<^sub>2'`
  have False by(fastforce elim:WCFG.While_CFG.cases)
  thus ?case by simp
next
  case (WCFG_LAss V e)
  from `V:=e \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `(_0_) = n\<^sub>2` `(_1_) \<noteq> n\<^sub>2'`
  have False by -(erule WCFG.While_CFG.cases,auto)
  thus ?case by simp
next
  case (WCFG_LAssSkip V e)
  from `V:=e \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `(_1_) = n\<^sub>2` `(_Exit_) \<noteq> n\<^sub>2'`
  have False by -(erule WCFG.While_CFG.cases,auto)
  thus ?case by simp
next
  case (WCFG_SeqFirst c\<^sub>1 n et n' c\<^sub>2)
  note IH = `\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; n' \<noteq> n\<^sub>2'\<rbrakk>
  \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))`
  from `c\<^sub>1;;c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `c\<^sub>1 \<turnstile> n -et\<rightarrow> n'` `n = n\<^sub>2` `n' \<noteq> n\<^sub>2'`
  have "c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2' \<or> (c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> (_Exit_) \<and> n\<^sub>2' = (_0_) \<oplus> #:c\<^sub>1)"
    apply hypsubst_thin apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
    by(case_tac n,auto dest:WCFG_sourcelabel_less_num_nodes)+
  thus ?case
  proof
    assume "c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'"
    from IH[OF this `n = n\<^sub>2` `n' \<noteq> n\<^sub>2'`] show ?case .
  next
    assume "c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> (_Exit_) \<and> n\<^sub>2' = (_0_) \<oplus> #:c\<^sub>1"
    hence edge:"c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> (_Exit_)" and n2':"n\<^sub>2' = (_0_) \<oplus> #:c\<^sub>1" by simp_all
    from IH[OF edge `n = n\<^sub>2` `n' \<noteq> (_Exit_)`] show ?case .
  qed
next
  case (WCFG_SeqConnect c\<^sub>1 n et c\<^sub>2)
  note IH = `\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; (_Exit_) \<noteq> n\<^sub>2'\<rbrakk>
  \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))`
  from `c\<^sub>1;;c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `c\<^sub>1 \<turnstile> n -et\<rightarrow> (_Exit_)` `n = n\<^sub>2` `n \<noteq> (_Entry_)`
    `(_0_) \<oplus> #:c\<^sub>1 \<noteq> n\<^sub>2'` have "c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2' \<and> (_Exit_) \<noteq> n\<^sub>2'"
    apply hypsubst_thin apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
    by(case_tac n,auto dest:WCFG_sourcelabel_less_num_nodes)+
  from IH[OF this[THEN conjunct1] `n = n\<^sub>2` this[THEN conjunct2]]
  show ?case .
next
  case (WCFG_SeqSecond c\<^sub>2 n et n' c\<^sub>1)
  note IH = `\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; n' \<noteq> n\<^sub>2'\<rbrakk>
  \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))`
  from `c\<^sub>1;;c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `c\<^sub>2 \<turnstile> n -et\<rightarrow> n'` `n \<oplus> #:c\<^sub>1 = n\<^sub>2`
    `n' \<oplus> #:c\<^sub>1 \<noteq> n\<^sub>2'` `n \<noteq> (_Entry_)`
  obtain nx where "c\<^sub>2 \<turnstile> n -et\<^sub>2\<rightarrow> nx \<and> nx \<oplus> #:c\<^sub>1 = n\<^sub>2'"
    apply - apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
      apply(cases n,auto dest:WCFG_sourcelabel_less_num_nodes)
     apply(cases n,auto dest:WCFG_sourcelabel_less_num_nodes)
    by(fastforce dest:label_incr_inj)
  with `n' \<oplus> #:c\<^sub>1 \<noteq> n\<^sub>2'` have edge:"c\<^sub>2 \<turnstile> n -et\<^sub>2\<rightarrow> nx" and neq:"n' \<noteq> nx"
    by auto
  from IH[OF edge _ neq] show ?case by simp
next
  case (WCFG_CondTrue b c\<^sub>1 c\<^sub>2)
  from `if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `(_0_) = n\<^sub>2` `(_0_) \<oplus> 1 \<noteq> n\<^sub>2'`
  show ?case by -(erule WCFG.While_CFG.cases,auto)
next
  case (WCFG_CondFalse b c\<^sub>1 c\<^sub>2)
  from `if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `(_0_) = n\<^sub>2` `(_0_) \<oplus> #:c\<^sub>1 + 1 \<noteq> n\<^sub>2'`
  show ?case by -(erule WCFG.While_CFG.cases,auto)
next
  case (WCFG_CondThen c\<^sub>1 n et n' b c\<^sub>2)
  note IH = `\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; n' \<noteq> n\<^sub>2'\<rbrakk>
    \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))`
  from `if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `c\<^sub>1 \<turnstile> n -et\<rightarrow> n'` `n \<noteq> (_Entry_)`
    `n \<oplus> 1 = n\<^sub>2` `n' \<oplus> 1 \<noteq> n\<^sub>2'`
  obtain nx where "c\<^sub>1 \<turnstile> n -et\<^sub>2\<rightarrow> nx \<and> n' \<noteq> nx"
    apply - apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
     apply(drule label_incr_inj) apply auto
    apply(drule label_incr_simp_rev[OF sym])
    by(case_tac na,auto dest:WCFG_sourcelabel_less_num_nodes)
  from IH[OF this[THEN conjunct1] _ this[THEN conjunct2]] show ?case by simp
next
  case (WCFG_CondElse c\<^sub>2 n et n' b c\<^sub>1)
  note IH = `\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; n' \<noteq> n\<^sub>2'\<rbrakk>
    \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))`
  from `if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `c\<^sub>2 \<turnstile> n -et\<rightarrow> n'` `n \<noteq> (_Entry_)`
    `n \<oplus> #:c\<^sub>1 + 1 = n\<^sub>2` `n' \<oplus> #:c\<^sub>1 + 1 \<noteq> n\<^sub>2'`
  obtain nx where "c\<^sub>2 \<turnstile> n -et\<^sub>2\<rightarrow> nx \<and> n' \<noteq> nx"
    apply - apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
     apply(drule label_incr_simp_rev)
     apply(case_tac na,auto,cases n,auto dest:WCFG_sourcelabel_less_num_nodes)
    by(fastforce dest:label_incr_inj)
  from IH[OF this[THEN conjunct1] _ this[THEN conjunct2]] show ?case by simp
next
  case (WCFG_WhileTrue b c')
  from `while (b) c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `(_0_) = n\<^sub>2` `(_0_) \<oplus> 2 \<noteq> n\<^sub>2'`
  show ?case by -(erule WCFG.While_CFG.cases,auto)
next
  case (WCFG_WhileFalse b c')
  from `while (b) c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `(_0_) = n\<^sub>2` `(_1_) \<noteq> n\<^sub>2'`
  show ?case by -(erule WCFG.While_CFG.cases,auto)
next
  case (WCFG_WhileFalseSkip b c')
  from `while (b) c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `(_1_) = n\<^sub>2` `(_Exit_) \<noteq> n\<^sub>2'`
  show ?case by -(erule WCFG.While_CFG.cases,auto dest:label_incr_ge)
next
  case (WCFG_WhileBody c' n et n' b)
  note IH = `\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; n' \<noteq> n\<^sub>2'\<rbrakk>
    \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))`
  from `while (b) c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `c' \<turnstile> n -et\<rightarrow> n'` `n \<noteq> (_Entry_)`
    `n' \<noteq> (_Exit_)` `n \<oplus> 2 = n\<^sub>2` `n' \<oplus> 2 \<noteq> n\<^sub>2'`
  obtain nx where "c' \<turnstile> n -et\<^sub>2\<rightarrow> nx \<and> n' \<noteq> nx"
    apply - apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
      apply(fastforce dest:label_incr_ge[OF sym])
     apply(fastforce dest:label_incr_inj)
    by(fastforce dest:label_incr_inj)
  from IH[OF this[THEN conjunct1] _ this[THEN conjunct2]] show ?case by simp
next
  case (WCFG_WhileBodyExit c' n et b)
  note IH = `\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; (_Exit_) \<noteq> n\<^sub>2'\<rbrakk>
    \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))`
  from `while (b) c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'` `c' \<turnstile> n -et\<rightarrow> (_Exit_)` `n \<noteq> (_Entry_)`
    `n \<oplus> 2 = n\<^sub>2` `(_0_) \<noteq> n\<^sub>2'`
  obtain nx where "c' \<turnstile> n -et\<^sub>2\<rightarrow> nx \<and> (_Exit_) \<noteq> nx"
    apply - apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
     apply(fastforce dest:label_incr_ge[OF sym])
    by(fastforce dest:label_incr_inj)
  from IH[OF this[THEN conjunct1] _ this[THEN conjunct2]] show ?case by simp
qed

(*<*)declare One_nat_def [simp](*>*)

end


theory v4_isar
  imports Main "../QML_S5"
begin

text \<open>
@{text "Compossibility\<^sub>4'"}: If a table @{term x} is originally made from matter @{term y} and it
is possible for a table to be the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z} according to plan @{term p},
then it is also possible for table @{term x} to be originally made from matter @{term y} and in
addition some table or other @{term x'} to be the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p}.

@{text "Origin Uniqueness\<^sub>4'"}: It is impossible that a single table @{term x} is originally made from
matter @{term y} and in addition is originally made from matter @{term z}.

@{text "Sufficiency\<^sub>4'"}: If it is possible that a table @{term x'} is the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p}, then necessarily any table that is the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p} is the very table @{term x'} and no other.
\<close>

text \<open>
@{text "Origin Essentialism\<^sub>4'"}: If a given table is originally made from certain matter, then it is necessary
that the given table is not (the @{text "n\<^sup>t\<^sup>h"} table for any @{term n}) originally made from any non-overlapping
matter according to any plan.
\<close>

consts kTable :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu> \<Rightarrow> nat \<Rightarrow> \<sigma>" ("N")

(* (N x y p k) \<equiv> x is the kth table made from y according to p *)
lemma
assumes compossibilty4: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k))))\<rfloor>"
assumes origin_uniqueness4: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))\<rfloor>"
assumes sufficiency4: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' y p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx)))\<rfloor>"
shows origin_essentialism4: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k')))\<rfloor>"

proof (rule allI)
  fix w
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
  proof (rule allI)
    fix x
    show "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
    proof (rule allI)
      fix y
      show "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
      proof (rule allI)
        fix z
        show "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
        proof (rule allI)
          fix p
          show "(\<^bold>\<forall>k. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
          proof (rule allI)
            fix k
            show "(\<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k. N x z p' k))) w"
            proof (rule impI)
              assume antecedent: "(\<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k))) w"
              show "(\<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
              proof (rule notI)
                assume n_consequent: "(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k')) w"
                from antecedent obtain w where w: "(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) w" by (rule exE)
                then have table_x_from_y: "(N x y p k) w" by (rule conjE)
                have non_overlapping: "(\<^bold>\<not>(y \<^bold>=\<^sup>L z)) w" using antecedent by auto
                then have compossibilty4_ante: "((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) w"
                  using table_x_from_y and non_overlapping and n_consequent by auto
                from compossibilty4 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w"..
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" using compossibilty4_ante by (rule mp)
                then obtain u where u: "(((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) u" by (rule exE)
                then have "(\<^bold>\<exists>x'. (N x' z p k)) u" by (rule conjE)
                then obtain x' where x': "N x' z p k u" by (rule exE)

                from n_consequent obtain v where v: "(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k') v" by (rule exE)
                then have sufficiency4_ante:  "(\<^bold>\<diamond>(N x z p k)) w" by auto

                from sufficiency4 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' y p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w"..
                then have  "(\<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' y p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have  "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have  "(\<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have  "(\<^bold>\<diamond>(N x z p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have  "(\<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" using sufficiency4_ante by (rule mp)
                then have "((\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) u" by (rule allE)
                then have "(((N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) u" by (rule allE)
                then have "(x'\<^bold>=\<^sup>Lx) u" using `N x' z p k u` by (rule mp)

                then have "(N x z p k) u" using `(N x' z p k) u` by auto
                moreover from u have "(N x y p k) u" by simp
                then have "(N x y p k) u \<and> (N x z p k) u" using `(N x z p k) u` by (rule conjI)
                then have conj_existence: "(N x y p k \<^bold>\<and> N x z p k) u" by simp
                then have impossible_arg: "(N x y p k u) \<and> (N x z p k u) \<and> \<not>((y \<^bold>=\<^sup>L z) u)"
                  using non_overlapping by auto

                from origin_uniqueness4 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w"..
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w" by (rule allE)
                then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. \<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w" by (rule allE)
                then have "(\<^bold>\<not>\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w" by (rule allE)
                then have "\<^bold>\<box>(\<^bold>\<not>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) w" by auto
                then have "(\<^bold>\<not>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by (rule allE)
                then show "False" using impossible_arg by (rule notE)
              qed
            qed
          qed
        qed
      qed
    qed
  qed
qed

end


section \<open> Reactive Relations \<close>

theory utp_rea_rel
  imports
    utp_rea_healths
    "UTP1-KAT.utp_kleene"
begin

text \<open> This theory defines a reactive relational calculus for @{term R1}-@{term R2} predicates as an
  extension of the standard alphabetised predicate calculus. This enables us to formally characterise
  relational programs that refer to both state variables and a trace history. For more details on
  reactive relations, please see the associated journal paper~\cite{Foster17c}. \<close>

subsection \<open> Healthiness Conditions \<close>

definition RR :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[upred_defs]: "RR(P) = (\<exists> {$ok,$ok\<acute>,$wait,$wait\<acute>} \<bullet> R2(P))"

utp_const RR

lemma RR_idem: "RR(RR(P)) = RR(P)"
  by (rel_auto)

lemma RR_Idempotent [closure]: "Idempotent RR"
  by (simp add: Idempotent_def RR_idem)

lemma RR_Continuous [closure]: "Continuous RR"
  by (rel_blast)

lemma R1_RR: "R1(RR(P)) = RR(P)"
  by (rel_auto)

lemma R2c_RR: "R2c(RR(P)) = RR(P)"
  by (rel_auto)

lemma RR_implies_R1 [closure]: "P is RR \<Longrightarrow> P is R1"
  by (metis Healthy_def R1_RR)

lemma RR_implies_R2c: "P is RR \<Longrightarrow> P is R2c"
  by (metis Healthy_def R2c_RR)

lemma RR_implies_R2 [closure]: "P is RR \<Longrightarrow> P is R2"
  by (metis Healthy_def R1_RR R2_R2c_def R2c_RR)

lemma RR_intro:
  assumes "$ok \<sharp> P" "$ok\<acute> \<sharp> P" "$wait \<sharp> P" "$wait\<acute> \<sharp> P" "P is R1" "P is R2c"
  shows "P is RR"
  by (simp add: RR_def Healthy_def ex_plus R2_R2c_def, simp add: Healthy_if assms ex_unrest)

lemma RR_R2_intro:
  assumes "$ok \<sharp> P" "$ok\<acute> \<sharp> P" "$wait \<sharp> P" "$wait\<acute> \<sharp> P" "P is R2"
  shows "P is RR"
  by (simp add: RR_def Healthy_def ex_plus, simp add: Healthy_if assms ex_unrest)

lemma RR_unrests [unrest]:
  assumes "P is RR"
  shows "$ok \<sharp> P" "$ok\<acute> \<sharp> P" "$wait \<sharp> P" "$wait\<acute> \<sharp> P"
proof -
  have "$ok \<sharp> RR(P)" "$ok\<acute> \<sharp> RR(P)" "$wait \<sharp> RR(P)" "$wait\<acute> \<sharp> RR(P)"
    by (simp_all add: RR_def ex_plus unrest)
  thus "$ok \<sharp> P" "$ok\<acute> \<sharp> P" "$wait \<sharp> P" "$wait\<acute> \<sharp> P"
    by (simp_all add: assms Healthy_if)
qed

lemma RR_refine_intro:
  assumes "P is RR" "Q is RR" "\<And> t. P\<lbrakk>0,\<guillemotleft>t\<guillemotright>/$tr,$tr\<acute>\<rbrakk> \<sqsubseteq> Q\<lbrakk>0,\<guillemotleft>t\<guillemotright>/$tr,$tr\<acute>\<rbrakk>"
  shows "P \<sqsubseteq> Q"
proof -
  have "\<And> t. (RR P)\<lbrakk>0,\<guillemotleft>t\<guillemotright>/$tr,$tr\<acute>\<rbrakk> \<sqsubseteq> (RR Q)\<lbrakk>0,\<guillemotleft>t\<guillemotright>/$tr,$tr\<acute>\<rbrakk>"
    by (simp add: Healthy_if assms)
  hence "RR(P) \<sqsubseteq> RR(Q)"
    by (rel_auto)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma RR_eq_transfer:
  assumes "P is RR" "Q is RR"
    "(\<And> t. U([$ok \<mapsto>\<^sub>s true, $ok\<acute> \<mapsto>\<^sub>s true, $wait \<mapsto>\<^sub>s false, $wait\<acute> \<mapsto>\<^sub>s false, $tr \<mapsto>\<^sub>s 0, $tr\<acute> \<mapsto>\<^sub>s \<guillemotleft>t\<guillemotright>] \<dagger> P)
          = U([$ok \<mapsto>\<^sub>s true, $ok\<acute> \<mapsto>\<^sub>s true, $wait \<mapsto>\<^sub>s false, $wait\<acute> \<mapsto>\<^sub>s false, $tr \<mapsto>\<^sub>s 0, $tr\<acute> \<mapsto>\<^sub>s \<guillemotleft>t\<guillemotright>] \<dagger> Q))"
  shows "P = Q"
proof -
  have "(\<And> t. U([$ok \<mapsto>\<^sub>s true, $ok\<acute> \<mapsto>\<^sub>s true, $wait \<mapsto>\<^sub>s false, $wait\<acute> \<mapsto>\<^sub>s false, $tr \<mapsto>\<^sub>s 0, $tr\<acute> \<mapsto>\<^sub>s \<guillemotleft>t\<guillemotright>] \<dagger> RR P)
            = U([$ok \<mapsto>\<^sub>s true, $ok\<acute> \<mapsto>\<^sub>s true, $wait \<mapsto>\<^sub>s false, $wait\<acute> \<mapsto>\<^sub>s false, $tr \<mapsto>\<^sub>s 0, $tr\<acute> \<mapsto>\<^sub>s \<guillemotleft>t\<guillemotright>] \<dagger> RR Q))"
    by (metis Healthy_if assms(1) assms(2) assms(3))
  hence "RR P = RR Q"
    by (rel_auto)
  thus ?thesis
    by (metis Healthy_if assms(1) assms(2))
qed

text \<open> Tailored proof strategy for reactive relations -- eliminates irrelevant variables like ok, wait, and tr. \<close>

method rrel_auto uses cls = (rule RR_eq_transfer, simp add: closure cls, simp add: closure cls, rel_auto)

lemma R4_RR_closed [closure]:
  assumes "P is RR"
  shows "R4(P) is RR"
proof -
  have "R4(RR(P)) is RR"
    by (rel_blast)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma R5_RR_closed [closure]:
  assumes "P is RR"
  shows "R5(P) is RR"
proof -
  have "R5(RR(P)) is RR"
    using minus_zero_eq by rel_auto
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

subsection \<open> Reactive relational operators \<close>

named_theorems rpred

abbreviation rea_true :: "('t::trace,'\<alpha>,'\<beta>) rel_rp" ("true\<^sub>r") where
"true\<^sub>r \<equiv> R1(true)"

definition rea_not :: "('t::trace,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" ("\<not>\<^sub>r _" [40] 40)
where [upred_defs]: "(\<not>\<^sub>r P) = R1(\<not> P)"

no_utp_lift rea_not

definition rea_diff :: "('t::trace,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" (infixl "-\<^sub>r" 65)
where [upred_defs]: "rea_diff P Q = (P \<and> \<not>\<^sub>r Q)"

definition rea_impl ::
  "('t::trace,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" (infixr "\<Rightarrow>\<^sub>r" 25)
where [upred_defs]: "(P \<Rightarrow>\<^sub>r Q) = (\<not>\<^sub>r P \<or> Q)"

no_utp_lift rea_impl

definition rea_lift :: "('t::trace,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" ("[_]\<^sub>r")
where [upred_defs]: "[P]\<^sub>r = R1(P)"

definition rea_skip :: "('t::trace,'\<alpha>) hrel_rp" ("II\<^sub>r")
where [upred_defs]: "II\<^sub>r = ($tr\<acute> =\<^sub>u $tr \<and> $\<Sigma>\<^sub>R\<acute> =\<^sub>u $\<Sigma>\<^sub>R)"

definition rea_assert :: "('t::trace,'\<alpha>) hrel_rp \<Rightarrow> ('t,'\<alpha>) hrel_rp" ("{_}\<^sub>r")
where [upred_defs]: "{b}\<^sub>r = (II\<^sub>r \<or> \<not>\<^sub>r b)"

text \<open> Convert from one trace algebra to another using renamer functions, which are a kind of
  monoid homomorphism. \<close>

locale renamer =
  fixes f :: "'a::trace \<Rightarrow> 'b::trace"
  assumes
    injective: "inj f" and
    add: "f (x + y) = f x + f y"
begin
  lemma zero: "f 0 = 0"
    by (metis add add.right_neutral add_monoid_diff_cancel_left)

  lemma minus: "x \<le> y \<Longrightarrow> f (y - x) = f(y) - f(x)"
    by (metis add diff_add_cancel_left' trace_class.add_diff_cancel_left)
end

declare renamer.add [simp]
declare renamer.zero [simp]
declare renamer.minus [simp]

lemma renamer_id: "renamer id"
  by (unfold_locales, simp_all)

lemma renamer_comp: "\<lbrakk> renamer f; renamer g \<rbrakk> \<Longrightarrow> renamer (f \<circ> g)"
  by (unfold_locales, simp_all add: inj_compose renamer.injective)

lemma renamer_map: "inj f \<Longrightarrow> renamer (map f)"
  by (unfold_locales, simp_all add: plus_list_def)

definition rea_rename :: "('t\<^sub>1::trace,'\<alpha>) hrel_rp \<Rightarrow> ('t\<^sub>1 \<Rightarrow> 't\<^sub>2) \<Rightarrow> ('t\<^sub>2::trace,'\<alpha>) hrel_rp" ("(_)\<lparr>_\<rparr>\<^sub>r" [999, 0] 999) where
[upred_defs]: "rea_rename P f = R2(($tr\<acute> =\<^sub>u 0 \<and> $\<Sigma>\<^sub>R\<acute> =\<^sub>u $\<Sigma>\<^sub>R) ;; P ;; ($tr\<acute> =\<^sub>u uop f $tr \<and> $\<Sigma>\<^sub>R\<acute> =\<^sub>u $\<Sigma>\<^sub>R))"

text \<open> Trace contribution substitution: make a substitution for the trace contribution lens
  @{term tt}, and apply @{term R1} to make the resulting predicate healthy again. \<close>

definition rea_subst :: "('t::trace, '\<alpha>) hrel_rp \<Rightarrow> ('t, ('t, '\<alpha>) rp) hexpr \<Rightarrow> ('t, '\<alpha>) hrel_rp" ("_\<lbrakk>_\<rbrakk>\<^sub>r" [999,0] 999)
where [upred_defs]: "P\<lbrakk>v\<rbrakk>\<^sub>r = R1(P\<lbrakk>v/&tt\<rbrakk>)"

subsection \<open> Unrestriction and substitution laws \<close>

lemma rea_true_unrest [unrest]:
  "\<lbrakk> x \<bowtie> ($tr)\<^sub>v; x \<bowtie> ($tr\<acute>)\<^sub>v \<rbrakk> \<Longrightarrow> x \<sharp> true\<^sub>r"
  by (simp add: R1_def unrest lens_indep_sym)

lemma rea_not_unrest [unrest]:
  "\<lbrakk> x \<bowtie> ($tr)\<^sub>v; x \<bowtie> ($tr\<acute>)\<^sub>v; x \<sharp> P \<rbrakk> \<Longrightarrow> x \<sharp> \<not>\<^sub>r P"
  by (simp add: rea_not_def R1_def unrest lens_indep_sym)

lemma rea_impl_unrest [unrest]:
  "\<lbrakk> x \<bowtie> ($tr)\<^sub>v; x \<bowtie> ($tr\<acute>)\<^sub>v; x \<sharp> P; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> (P \<Rightarrow>\<^sub>r Q)"
  by (simp add: rea_impl_def unrest)

lemma rea_true_usubst [usubst]:
  "\<lbrakk> $tr \<sharp>\<^sub>s \<sigma>; $tr\<acute> \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> \<sigma> \<dagger> true\<^sub>r = true\<^sub>r"
  by (simp add: R1_def usubst usubst_apply_unrest)

lemma rea_not_usubst [usubst]:
  "\<lbrakk> $tr \<sharp>\<^sub>s \<sigma>; $tr\<acute> \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> \<sigma> \<dagger> (\<not>\<^sub>r P) = (\<not>\<^sub>r \<sigma> \<dagger> P)"
  by (simp add: rea_not_def R1_def usubst usubst_apply_unrest)

lemma rea_impl_usubst [usubst]:
  "\<lbrakk> $tr \<sharp>\<^sub>s \<sigma>; $tr\<acute> \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> \<sigma> \<dagger> (P \<Rightarrow>\<^sub>r Q) = (\<sigma> \<dagger> P \<Rightarrow>\<^sub>r \<sigma> \<dagger> Q)"
  by (simp add: rea_impl_def usubst R1_def)

lemma rea_true_usubst_tt [usubst]:
  "R1(true)\<lbrakk>e/&tt\<rbrakk> = true"
  by (rel_simp)

lemma unrests_rea_rename [unrest]:
  "$ok \<sharp> P \<Longrightarrow> $ok \<sharp> P\<lparr>f\<rparr>\<^sub>r"
  "$ok\<acute> \<sharp> P \<Longrightarrow> $ok\<acute> \<sharp> P\<lparr>f\<rparr>\<^sub>r"
  "$wait \<sharp> P \<Longrightarrow> $wait \<sharp> P\<lparr>f\<rparr>\<^sub>r"
  "$wait\<acute> \<sharp> P \<Longrightarrow> $wait\<acute> \<sharp> P\<lparr>f\<rparr>\<^sub>r"
  by (simp_all add: rea_rename_def R2_def unrest)

lemma unrest_rea_subst [unrest]:
  "\<lbrakk> mwb_lens x; x \<bowtie> ($tr)\<^sub>v; x \<bowtie> ($tr\<acute>)\<^sub>v; x \<sharp> v; x \<sharp> P \<rbrakk> \<Longrightarrow>  x \<sharp> P\<lbrakk>v\<rbrakk>\<^sub>r"
  by (simp add: rea_subst_def R1_def unrest lens_indep_sym)

lemma rea_substs [usubst]:
  "true\<^sub>r\<lbrakk>v\<rbrakk>\<^sub>r = true\<^sub>r" "true\<lbrakk>v\<rbrakk>\<^sub>r = true\<^sub>r" "false\<lbrakk>v\<rbrakk>\<^sub>r = false"
  "(\<not>\<^sub>r P)\<lbrakk>v\<rbrakk>\<^sub>r = (\<not>\<^sub>r P\<lbrakk>v\<rbrakk>\<^sub>r)" "(P \<and> Q)\<lbrakk>v\<rbrakk>\<^sub>r = (P\<lbrakk>v\<rbrakk>\<^sub>r \<and> Q\<lbrakk>v\<rbrakk>\<^sub>r)" "(P \<or> Q)\<lbrakk>v\<rbrakk>\<^sub>r = (P\<lbrakk>v\<rbrakk>\<^sub>r \<or> Q\<lbrakk>v\<rbrakk>\<^sub>r)"
  "(P \<Rightarrow>\<^sub>r Q)\<lbrakk>v\<rbrakk>\<^sub>r = (P\<lbrakk>v\<rbrakk>\<^sub>r \<Rightarrow>\<^sub>r Q\<lbrakk>v\<rbrakk>\<^sub>r)"
  by rel_auto+

lemma rea_substs_lattice [usubst]:
  "(\<Sqinter> i \<bullet> P(i))\<lbrakk>v\<rbrakk>\<^sub>r   = (\<Sqinter> i \<bullet> (P(i))\<lbrakk>v\<rbrakk>\<^sub>r)"
  "(\<Sqinter> i\<in>A \<bullet> P(i))\<lbrakk>v\<rbrakk>\<^sub>r = (\<Sqinter> i\<in>A \<bullet> (P(i))\<lbrakk>v\<rbrakk>\<^sub>r)"
  "(\<Squnion> i \<bullet> P(i))\<lbrakk>v\<rbrakk>\<^sub>r   = (\<Squnion> i \<bullet> (P(i))\<lbrakk>v\<rbrakk>\<^sub>r)"
   by (rel_auto)+

lemma rea_subst_USUP_set [usubst]:
  "A \<noteq> {} \<Longrightarrow> (\<Squnion> i\<in>A \<bullet> P(i))\<lbrakk>v\<rbrakk>\<^sub>r   = (\<Squnion> i\<in>A \<bullet> (P(i))\<lbrakk>v\<rbrakk>\<^sub>r)"
  by (rel_auto)+

subsection \<open> Closure laws \<close>

lemma rea_lift_R1 [closure]: "[P]\<^sub>r is R1"
  by (rel_simp)

lemma R1_rea_not: "R1(\<not>\<^sub>r P) = (\<not>\<^sub>r P)"
  by rel_auto

lemma R1_rea_not': "R1(\<not>\<^sub>r P) = (\<not>\<^sub>r R1(P))"
  by rel_auto

lemma R2c_rea_not: "R2c(\<not>\<^sub>r P) = (\<not>\<^sub>r R2c(P))"
  by rel_auto

lemma RR_rea_not: "RR(\<not>\<^sub>r RR(P)) = (\<not>\<^sub>r RR(P))"
  by (rel_auto)

lemma R1_rea_impl: "R1(P \<Rightarrow>\<^sub>r Q) = (P \<Rightarrow>\<^sub>r R1(Q))"
  by (rel_auto)

lemma R1_rea_impl': "R1(P \<Rightarrow>\<^sub>r Q) = (R1(P) \<Rightarrow>\<^sub>r R1(Q))"
  by (rel_auto)

lemma R2c_rea_impl: "R2c(P \<Rightarrow>\<^sub>r Q) = (R2c(P) \<Rightarrow>\<^sub>r R2c(Q))"
  by (rel_auto)

lemma RR_rea_impl: "RR(RR(P) \<Rightarrow>\<^sub>r RR(Q)) = (RR(P) \<Rightarrow>\<^sub>r RR(Q))"
  by (rel_auto)

lemma rea_true_R1 [closure]: "true\<^sub>r is R1"
  by (rel_auto)

lemma rea_true_R2c [closure]: "true\<^sub>r is R2c"
  by (rel_auto)

lemma rea_true_RR [closure]: "true\<^sub>r is RR"
  by (rel_auto)

lemma rea_not_R1 [closure]: "\<not>\<^sub>r P is R1"
  by (rel_auto)

lemma rea_not_R2c [closure]: "P is R2c \<Longrightarrow> \<not>\<^sub>r P is R2c"
  by (simp add: Healthy_def rea_not_def R1_R2c_commute[THEN sym] R2c_not)

lemma rea_not_R2_closed [closure]:
  "P is R2 \<Longrightarrow> (\<not>\<^sub>r P) is R2"
  by (simp add: Healthy_def' R1_rea_not' R2_R2c_def R2c_rea_not)

lemma rea_no_RR [closure]:
  "\<lbrakk> P is RR \<rbrakk> \<Longrightarrow> (\<not>\<^sub>r P) is RR"
  by (metis Healthy_def' RR_rea_not)

lemma rea_impl_R1 [closure]:
  "Q is R1 \<Longrightarrow> (P \<Rightarrow>\<^sub>r Q) is R1"
  by (rel_blast)

lemma rea_impl_R2c [closure]:
  "\<lbrakk> P is R2c; Q is R2c \<rbrakk> \<Longrightarrow> (P \<Rightarrow>\<^sub>r Q) is R2c"
  by (simp add: rea_impl_def Healthy_def rea_not_def R1_R2c_commute[THEN sym] R2c_not R2c_disj)

lemma rea_impl_R2 [closure]:
  "\<lbrakk> P is R2; Q is R2 \<rbrakk> \<Longrightarrow> (P \<Rightarrow>\<^sub>r Q) is R2"
  by (rel_blast)

lemma rea_impl_RR [closure]:
  "\<lbrakk> P is RR; Q is RR \<rbrakk> \<Longrightarrow> (P \<Rightarrow>\<^sub>r Q) is RR"
  by (metis Healthy_def' RR_rea_impl)

lemma conj_RR [closure]:
  "\<lbrakk> P is RR; Q is RR \<rbrakk> \<Longrightarrow> (P \<and> Q) is RR"
  by (meson RR_implies_R1 RR_implies_R2c RR_intro RR_unrests(1-4) conj_R1_closed_1 conj_R2c_closed unrest_conj)

lemma disj_RR [closure]:
  "\<lbrakk> P is RR; Q is RR \<rbrakk> \<Longrightarrow> (P \<or> Q) is RR"
  by (metis Healthy_def' R1_RR R1_idem R1_rea_not' RR_rea_impl RR_rea_not disj_comm double_negation rea_impl_def rea_not_def)

lemma USUP_mem_RR_closed [closure]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is RR" "A \<noteq> {}"
  shows "(\<Squnion> i\<in>A \<bullet> P(i)) is RR"
proof -
  have 1:"(\<Squnion> i\<in>A \<bullet> P(i)) is R1"
    by (unfold Healthy_def, subst R1_UINF, simp_all add: Healthy_if assms closure cong: USUP_cong)
  have 2:"(\<Squnion> i\<in>A \<bullet> P(i)) is R2c"
    by (unfold Healthy_def, subst R2c_UINF, simp_all add: Healthy_if assms RR_implies_R2c closure cong: USUP_cong)
  show ?thesis
    using 1 2 by (rule_tac RR_intro, simp_all add: unrest assms)
qed

lemma USUP_ind_RR_closed [closure]:
  assumes "\<And> i. P i is RR"
  shows "(\<Squnion> i \<bullet> P(i)) is RR"
  using USUP_mem_RR_closed[of UNIV P] by (simp add: assms)

lemma UINF_mem_RR_closed [closure]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is RR"
  shows "(\<Sqinter> i\<in>A \<bullet> P(i)) is RR"
proof -
  have 1:"(\<Sqinter> i\<in>A \<bullet> P(i)) is R1"
    by (unfold Healthy_def, subst R1_USUP, simp add: Healthy_if RR_implies_R1 assms cong: UINF_cong)
  have 2:"(\<Sqinter> i\<in>A \<bullet> P(i)) is R2c"
    by (unfold Healthy_def, subst R2c_USUP, simp add: Healthy_if RR_implies_R2c assms cong: UINF_cong)
  show ?thesis
    using 1 2 by (rule_tac RR_intro, simp_all add: unrest assms)
qed

lemma UINF_ind_RR_closed [closure]:
  assumes "\<And> i. P i is RR"
  shows "(\<Sqinter> i \<bullet> P(i)) is RR"
  by (simp add: assms closure)

lemma USUP_elem_RR [closure]:
  assumes "\<And> i. P i is RR" "A \<noteq> {}"
  shows "(\<Squnion> i \<in> A \<bullet> P i) is RR"
proof -
  have 1:"(\<Squnion> i\<in>A \<bullet> P(i)) is R1"
    by (unfold Healthy_def, subst R1_UINF, simp_all add: Healthy_if assms closure)
  have 2:"(\<Squnion> i\<in>A \<bullet> P(i)) is R2c"
    by (unfold Healthy_def, subst R2c_UINF, simp_all add: Healthy_if assms RR_implies_R2c closure)
  show ?thesis
    using 1 2 by (rule_tac RR_intro, simp_all add: unrest assms)
qed

lemma seq_RR_closed [closure]:
  assumes "P is RR" "Q is RR"
  shows "P ;; Q is RR"
  unfolding Healthy_def
  by (simp add: RR_def  Healthy_if assms closure RR_implies_R2 ex_unrest unrest)

lemma power_Suc_RR_closed [closure]:
  "P is RR \<Longrightarrow> P ;; P \<^bold>^ i is RR"
  by (induct i, simp_all add: closure upred_semiring.power_Suc)

lemma seqr_iter_RR_closed [closure]:
  "\<lbrakk> I \<noteq> []; \<And> i. i \<in> set(I) \<Longrightarrow> P(i) is RR \<rbrakk> \<Longrightarrow> (;; i : I \<bullet> P(i)) is RR"
  apply (induct I, simp_all)
  apply (rename_tac i I)
  apply (case_tac I)
  apply (simp_all add: seq_RR_closed)
done

lemma cond_tt_RR_closed [closure]:
  assumes "P is RR" "Q is RR"
  shows "P \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> Q is RR"
  apply (rule RR_intro)
  apply (simp_all add: unrest assms)
  apply (simp_all add: Healthy_def)
  apply (simp_all add: R1_cond R2c_condr Healthy_if assms RR_implies_R2c closure R2c_tr'_minus_tr)
done

lemma rea_skip_RR [closure]:
  "II\<^sub>r is RR"
  apply (rel_auto) using minus_zero_eq by blast

lemma tr_eq_tr'_RR_closed [closure]: "$tr =\<^sub>u $tr\<acute> is RR"
  apply (rel_auto) using minus_zero_eq by auto

lemma tr'_eq_tr_RR_closed [closure]: "$tr\<acute> =\<^sub>u $tr is RR"
  apply (rel_auto) using minus_zero_eq by auto

lemma inf_RR_closed [closure]:
  "\<lbrakk> P is RR; Q is RR \<rbrakk> \<Longrightarrow> P \<sqinter> Q is RR"
  by (simp add: disj_RR uinf_or)

lemma conj_tr_strict_RR_closed [closure]:
  assumes "P is RR"
  shows "(P \<and> $tr <\<^sub>u $tr\<acute>) is RR"
proof -
  have "RR(RR(P) \<and> $tr <\<^sub>u $tr\<acute>) = (RR(P) \<and> $tr <\<^sub>u $tr\<acute>)"
    by (rel_auto)
  thus ?thesis
    by (metis Healthy_def assms)
qed

lemma rea_assert_RR_closed [closure]:
  assumes "b is RR"
  shows "{b}\<^sub>r is RR"
  by (simp add: closure assms rea_assert_def)

lemma upower_RR_closed [closure]:
  "\<lbrakk> i > 0; P is RR \<rbrakk> \<Longrightarrow> P \<^bold>^ i is RR"
  apply (induct i, simp_all)
  apply (rename_tac i)
  apply (case_tac "i = 0")
   apply (simp_all add: closure upred_semiring.power_Suc)
  done

lemma seq_power_RR_closed [closure]:
  assumes "P is RR" "Q is RR"
  shows "(P \<^bold>^ i) ;; Q is RR"
  by (metis assms neq0_conv seq_RR_closed seqr_left_unit upower_RR_closed upred_semiring.power_0)

lemma ustar_right_RR_closed [closure]:
  assumes "P is RR" "Q is RR"
  shows "P ;; Q\<^sup>\<star> is RR"
proof -
  have "P ;; Q\<^sup>\<star> = P ;; (\<Sqinter> i \<in> {0..} \<bullet> Q \<^bold>^ i)"
    by (simp add: ustar_def)
  also have "... = P ;; (II \<sqinter> (\<Sqinter> i \<in> {1..} \<bullet> Q \<^bold>^ i))"
    by (metis One_nat_def UINF_atLeast_first upred_semiring.power_0)
  also have "... = (P \<or> P ;; (\<Sqinter> i \<in> {1..} \<bullet> Q \<^bold>^ i))"
    by (simp add: disj_upred_def[THEN sym] seqr_or_distr)
  also have "... is RR"
  proof -
    have "(\<Sqinter> i \<in> {1..} \<bullet> Q \<^bold>^ i) is RR"
      by (rule UINF_mem_Continuous_closed, simp_all add: assms closure)
    thus ?thesis
      by (simp add: assms closure)
  qed
  finally show ?thesis .
qed

lemma ustar_left_RR_closed [closure]:
  assumes "P is RR" "Q is RR"
  shows "P\<^sup>\<star> ;; Q is RR"
proof -
  have "P\<^sup>\<star> ;; Q = (\<Sqinter> i \<in> {0..} \<bullet> P \<^bold>^ i) ;; Q"
    by (simp add: ustar_def)
  also have "... = (II \<sqinter> (\<Sqinter> i \<in> {1..} \<bullet> P \<^bold>^ i)) ;; Q"
    by (metis One_nat_def UINF_atLeast_first upred_semiring.power_0)
  also have "... = (Q \<or> (\<Sqinter> i \<in> {1..} \<bullet> P \<^bold>^ i) ;; Q)"
    by (simp add: disj_upred_def[THEN sym] seqr_or_distl)
  also have "... is RR"
  proof -
    have "(\<Sqinter> i \<in> {1..} \<bullet> P \<^bold>^ i) is RR"
      by (rule UINF_mem_Continuous_closed, simp_all add: assms closure)
    thus ?thesis
      by (simp add: assms closure)
  qed
  finally show ?thesis .
qed

lemma uplus_RR_closed [closure]: "P is RR \<Longrightarrow> P\<^sup>+ is RR"
  by (simp add: uplus_def ustar_right_RR_closed)

lemma trace_ext_prefix_RR [closure]:
  "\<lbrakk> $tr \<sharp> e; $ok \<sharp> e; $wait \<sharp> e; out\<alpha> \<sharp> e \<rbrakk> \<Longrightarrow> $tr ^\<^sub>u e \<le>\<^sub>u $tr\<acute> is RR"
  apply (rel_auto)
  apply (metis (no_types, lifting) Prefix_Order.same_prefix_prefix less_eq_list_def prefix_concat_minus zero_list_def)
  apply (metis append_minus list_append_prefixD minus_cancel_le order_refl)
done

lemma rea_subst_R1_closed [closure]: "P\<lbrakk>v\<rbrakk>\<^sub>r is R1"
  by (rel_auto)

lemma R5_comp [rpred]:
  assumes "P is RR" "Q is RR"
  shows "R5(P ;; Q) = R5(P) ;; R5(Q)"
proof -
  have "R5(RR(P) ;; RR(Q)) = R5(RR(P)) ;; R5(RR(Q))"
    by (rel_auto; force)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma R4_comp [rpred]:
  assumes "P is R4" "Q is RR"
  shows "R4(P ;; Q) = P ;; Q"
proof -
  have "R4(R4(P) ;; RR(Q)) = R4(P) ;; RR(Q)"
    by (rel_auto, blast)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma rea_rename_RR_closed [closure]:
  assumes "P is RR"
  shows "P\<lparr>f\<rparr>\<^sub>r is RR"
proof -
  have "(RR P)\<lparr>f\<rparr>\<^sub>r is RR"
    by (rel_auto)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

subsection \<open> Reactive relational calculus \<close>

lemma rea_skip_unit [rpred]:
  assumes "P is RR"
  shows "P ;; II\<^sub>r = P" "II\<^sub>r ;; P = P"
proof -
  have 1: "RR(P) ;; II\<^sub>r = RR(P)"
    by (rel_auto)
  have 2: "II\<^sub>r ;; RR(P) = RR(P)"
    by (rel_auto)
  from 1 2 show "P ;; II\<^sub>r = P" "II\<^sub>r ;; P = P"
    by (simp_all add: Healthy_if assms)
qed

lemma rea_true_conj [rpred]:
  assumes "P is R1"
  shows "(true\<^sub>r \<and> P) = P" "(P \<and> true\<^sub>r) = P"
  using assms
  by (simp_all add: Healthy_def R1_def utp_pred_laws.inf_commute)

lemma rea_true_disj [rpred]:
  assumes "P is R1"
  shows "(true\<^sub>r \<or> P) = true\<^sub>r" "(P \<or> true\<^sub>r) = true\<^sub>r"
  using assms by (metis Healthy_def R1_disj disj_comm true_disj_zero)+

lemma rea_not_not [rpred]: "P is R1 \<Longrightarrow> (\<not>\<^sub>r \<not>\<^sub>r P) = P"
  by (simp add: rea_not_def R1_negate_R1 Healthy_if)

lemma rea_not_rea_true [simp]: "(\<not>\<^sub>r true\<^sub>r) = false"
  by (simp add: rea_not_def R1_negate_R1 R1_false)

lemma rea_not_false [simp]: "(\<not>\<^sub>r false) = true\<^sub>r"
  by (simp add: rea_not_def)

lemma rea_true_impl [rpred]:
  "P is R1 \<Longrightarrow> (true\<^sub>r \<Rightarrow>\<^sub>r P) = P"
  by (simp add: rea_not_def rea_impl_def R1_negate_R1 R1_false Healthy_if)

lemma rea_true_impl' [rpred]:
  "P is R1 \<Longrightarrow>(true \<Rightarrow>\<^sub>r P) = P"
  by (simp add: rea_not_def rea_impl_def R1_negate_R1 R1_false Healthy_if)

lemma rea_false_impl [rpred]:
  "P is R1 \<Longrightarrow> (false \<Rightarrow>\<^sub>r P) = true\<^sub>r"
  by (simp add: rea_impl_def rpred Healthy_if)

lemma rea_impl_true [simp]: "(P \<Rightarrow>\<^sub>r true\<^sub>r) = true\<^sub>r"
  by (rel_auto)

lemma rea_impl_false [simp]: "(P \<Rightarrow>\<^sub>r false) = (\<not>\<^sub>r P)"
  by (rel_simp)

lemma rea_imp_refl [rpred]: "P is R1 \<Longrightarrow> (P \<Rightarrow>\<^sub>r P) = true\<^sub>r"
  by (rel_blast)

lemma rea_impl_conj [rpred]:
  "(P \<Rightarrow>\<^sub>r Q \<Rightarrow>\<^sub>r R) = ((P \<and> Q) \<Rightarrow>\<^sub>r R)"
  by (rel_auto)

lemma rea_impl_mp [rpred]:
  "(P \<and> (P \<Rightarrow>\<^sub>r Q)) = (P \<and> Q)"
  by (rel_auto)

lemma rea_impl_conj_combine [rpred]:
  "((P \<Rightarrow>\<^sub>r Q) \<and> (P \<Rightarrow>\<^sub>r R)) = (P \<Rightarrow>\<^sub>r Q \<and> R)"
  by (rel_auto)

lemma rea_impl_alt_def:
  assumes "Q is R1"
  shows "(P \<Rightarrow>\<^sub>r Q) = R1(P \<Rightarrow> Q)"
proof -
  have "(P \<Rightarrow>\<^sub>r R1(Q)) = R1(P \<Rightarrow> Q)"
    by (rel_auto)
  thus ?thesis
    by (simp add: assms Healthy_if)
qed

lemma rea_impl_disj:
  "(P \<Rightarrow>\<^sub>r Q \<or> R) = (Q \<or> (P \<Rightarrow>\<^sub>r R))"
  by (rel_auto)

lemma rea_not_true [simp]: "(\<not>\<^sub>r true) = false"
  by (rel_auto)

lemma rea_not_demorgan1 [simp]:
  "(\<not>\<^sub>r (P \<and> Q)) = (\<not>\<^sub>r P \<or> \<not>\<^sub>r Q)"
  by (rel_auto)

lemma rea_not_demorgan2 [simp]:
  "(\<not>\<^sub>r (P \<or> Q)) = (\<not>\<^sub>r P \<and> \<not>\<^sub>r Q)"
  by (rel_auto)

lemma rea_not_or [rpred]:
  "P is R1 \<Longrightarrow> (P \<or> \<not>\<^sub>r P) = true\<^sub>r"
  by (rel_blast)

lemma rea_not_and [simp]:
  "(P \<and> \<not>\<^sub>r P) = false"
  by (rel_auto)

lemma truer_bottom_rpred [rpred]: "P is RR \<Longrightarrow> R1(true) \<sqsubseteq> P"
  by (metis Healthy_def R1_RR R1_mono utp_pred_laws.top_greatest)

lemma ext_close_weakening: "P ;; true\<^sub>r \<sqsubseteq> P"
  by (rel_auto)

lemma rea_not_INFIMUM [simp]:
  "(\<not>\<^sub>r (\<Squnion>i\<in>A. Q(i))) = (\<Sqinter>i\<in>A. \<not>\<^sub>r Q(i))"
  by (rel_auto)

lemma rea_not_USUP [simp]:
  "(\<not>\<^sub>r (\<Squnion>i\<in>A \<bullet> Q(i))) = (\<Sqinter>i\<in>A \<bullet> \<not>\<^sub>r Q(i))"
  by (rel_auto)

lemma rea_not_SUPREMUM [simp]:
  "A \<noteq> {} \<Longrightarrow> (\<not>\<^sub>r (\<Sqinter>i\<in>A. Q(i))) = (\<Squnion>i\<in>A. \<not>\<^sub>r Q(i))"
  by (rel_auto)

lemma rea_not_UINF [simp]:
  "A \<noteq> {} \<Longrightarrow> (\<not>\<^sub>r (\<Sqinter>i\<in>A \<bullet> Q(i))) = (\<Squnion>i\<in>A \<bullet> \<not>\<^sub>r Q(i))"
  by (rel_auto)

lemma USUP_mem_rea_true [simp]: "A \<noteq> {} \<Longrightarrow> (\<Squnion> i \<in> A \<bullet> true\<^sub>r) = true\<^sub>r"
  by (rel_auto)

lemma USUP_ind_rea_true [simp]: "(\<Squnion> i \<bullet> true\<^sub>r) = true\<^sub>r"
  by (rel_auto)

lemma UINF_ind_rea_true [rpred]: "A \<noteq> {} \<Longrightarrow> (\<Sqinter> i\<in>A \<bullet> true\<^sub>r) = true\<^sub>r"
  by (rel_auto)

lemma UINF_rea_impl: "(\<Sqinter> P\<in>A \<bullet> F(P) \<Rightarrow>\<^sub>r G(P)) = ((\<Squnion> P\<in>A \<bullet> F(P)) \<Rightarrow>\<^sub>r (\<Sqinter> P\<in>A \<bullet> G(P)))"
  by (rel_auto)

lemma rea_not_shEx [rpred]: "(\<not>\<^sub>r shEx P) = (shAll (\<lambda> x. \<not>\<^sub>r P x))"
  by (rel_auto)

lemma rea_assert_true:
  "{true\<^sub>r}\<^sub>r = II\<^sub>r"
  by (rel_auto)

lemma rea_false_true:
  "{false}\<^sub>r = true\<^sub>r"
  by (rel_auto)

lemma rea_rename_id [rpred]:
  assumes "P is RR"
  shows "P\<lparr>id\<rparr>\<^sub>r = P"
proof -
  have "(RR P)\<lparr>id\<rparr>\<^sub>r = RR P"
    by (rel_auto)
  thus ?thesis by (simp add: Healthy_if assms)
qed

lemma rea_rename_comp [rpred]:
  assumes "renamer f" "renamer g" "P is RR"
  shows "P\<lparr>g \<circ> f\<rparr>\<^sub>r = P\<lparr>g\<rparr>\<^sub>r\<lparr>f\<rparr>\<^sub>r"
  oops

lemma rea_rename_false [rpred]: "false\<lparr>f\<rparr>\<^sub>r = false"
  by (rel_auto)

lemma rea_rename_disj [rpred]:
  "(P \<or> Q)\<lparr>f\<rparr>\<^sub>r = (P\<lparr>f\<rparr>\<^sub>r \<or> Q\<lparr>f\<rparr>\<^sub>r)"
  by (rel_blast)

lemma rea_rename_UINF_ind [rpred]:
  "(\<Sqinter> i \<bullet> P i)\<lparr>f\<rparr>\<^sub>r = (\<Sqinter> i \<bullet> (P i)\<lparr>f\<rparr>\<^sub>r)"
  by (rel_blast)

lemma rea_rename_UINF_mem [rpred]:
  "(\<Sqinter> i\<in>A \<bullet> P i)\<lparr>f\<rparr>\<^sub>r = (\<Sqinter> i\<in>A \<bullet> (P i)\<lparr>f\<rparr>\<^sub>r)"
  by (rel_blast)

lemma rea_rename_conj [rpred]:
  assumes "renamer f" "P is RR" "Q is RR"
  shows "(P \<and> Q)\<lparr>f\<rparr>\<^sub>r = (P\<lparr>f\<rparr>\<^sub>r \<and> Q\<lparr>f\<rparr>\<^sub>r)"
proof -
  interpret ren: renamer f by (simp add: assms)
  have "(RR P \<and> RR Q)\<lparr>f\<rparr>\<^sub>r = ((RR P)\<lparr>f\<rparr>\<^sub>r \<and> (RR Q)\<lparr>f\<rparr>\<^sub>r)"
    using injD[OF ren.injective]
    by (rel_auto; blast)
  thus ?thesis by (simp add: Healthy_if assms)
qed

lemma rea_rename_USUP_ind [rpred]:
  assumes "renamer f" "\<And> i. P i is RR"
  shows "(\<Squnion> i \<bullet> P i)\<lparr>f\<rparr>\<^sub>r = (\<Squnion> i \<bullet> (P i)\<lparr>f\<rparr>\<^sub>r)"
proof -
  interpret ren: renamer f by (simp add: assms)
  have "(\<Squnion> i \<bullet> RR(P i))\<lparr>f\<rparr>\<^sub>r = (\<Squnion> i \<bullet> (RR (P i))\<lparr>f\<rparr>\<^sub>r)"
    using injD[OF ren.injective]
    by (rel_auto, blast, metis (mono_tags, opaque_lifting))
  thus ?thesis
    by (simp add: Healthy_if assms cong: USUP_all_cong)
qed

lemma rea_rename_USUP_mem [rpred]:
  assumes "renamer f" "A \<noteq> {}" "\<And> i. i \<in> A \<Longrightarrow> P i is RR"
  shows "(\<Squnion> i\<in>A \<bullet> P i)\<lparr>f\<rparr>\<^sub>r = (\<Squnion> i\<in>A \<bullet> (P i)\<lparr>f\<rparr>\<^sub>r)"
proof -
  interpret ren: renamer f by (simp add: assms)
  have "(\<Squnion> i\<in>A \<bullet> RR(P i))\<lparr>f\<rparr>\<^sub>r = (\<Squnion> i\<in>A \<bullet> (RR (P i))\<lparr>f\<rparr>\<^sub>r)"
    using injD[OF ren.injective] assms(2)
    by (rel_auto, blast, metis (no_types, opaque_lifting))
  thus ?thesis
    by (simp add: Healthy_if assms cong: USUP_cong)
qed

lemma rea_rename_skip_rea [rpred]: "renamer f \<Longrightarrow> II\<^sub>r\<lparr>f\<rparr>\<^sub>r = II\<^sub>r"
  using minus_zero_eq by (rel_auto)

lemma rea_rename_seq [rpred]:
  assumes "renamer f" "P is RR" "Q is RR"
  shows "(P ;; Q)\<lparr>f\<rparr>\<^sub>r = P\<lparr>f\<rparr>\<^sub>r ;; Q\<lparr>f\<rparr>\<^sub>r"
proof -
  interpret ren: renamer f by (simp add: assms)
  from assms(1) have "(RR(P) ;; RR(Q))\<lparr>f\<rparr>\<^sub>r = (RR P)\<lparr>f\<rparr>\<^sub>r ;; (RR Q)\<lparr>f\<rparr>\<^sub>r"
    by (rel_auto)
       (metis (no_types, lifting) diff_add_cancel_left' le_add minus_assoc mono_def ren.minus ren.monotonic trace_class.add_diff_cancel_left trace_class.add_left_mono)+
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

declare R4_idem [rpred]
declare R4_false [rpred]
declare R4_conj [rpred]
declare R4_disj [rpred]

declare R4_R5 [rpred]
declare R5_R4 [rpred]

declare R5_conj [rpred]
declare R5_disj [rpred]

lemma R4_USUP [rpred]: "I \<noteq> {} \<Longrightarrow> R4(\<Squnion> i\<in>I \<bullet> P(i)) = (\<Squnion> i\<in>I \<bullet> R4(P(i)))"
  by (rel_auto)

lemma R5_USUP [rpred]: "I \<noteq> {} \<Longrightarrow> R5(\<Squnion> i\<in>I \<bullet> P(i)) = (\<Squnion> i\<in>I \<bullet> R5(P(i)))"
  by (rel_auto)

lemma R4_UINF [rpred]: "R4(\<Sqinter> i\<in>I \<bullet> P(i)) = (\<Sqinter> i\<in>I \<bullet> R4(P(i)))"
  by (rel_auto)

lemma R5_UINF [rpred]: "R5(\<Sqinter> i\<in>I \<bullet> P(i)) = (\<Sqinter> i\<in>I \<bullet> R5(P(i)))"
  by (rel_auto)

subsection \<open> UTP theory \<close>

text \<open> We create a UTP theory of reactive relations which in particular provides Kleene star theorems \<close>

interpretation rrel_theory: utp_theory_kleene RR II\<^sub>r
  rewrites "P \<in> carrier rrel_theory.thy_order \<longleftrightarrow> P is RR"
  and "le rrel_theory.thy_order = (\<sqsubseteq>)"
  and "eq rrel_theory.thy_order = (=)"
  and rrel_top: "rrel_theory.utp_top = false"
  and rrel_bottom: "rrel_theory.utp_bottom = true\<^sub>r"
proof -
  interpret utp_theory_continuous RR
    by (unfold_locales, simp_all add: add: RR_idem RR_Continuous)
  show top:"utp_top = false"
    by (simp add: healthy_top, rel_auto)
  show bot:"utp_bottom = true\<^sub>r"
    by (simp add: healthy_bottom, rel_auto)
  show "utp_theory_kleene RR II\<^sub>r"
    by (unfold_locales, simp_all add: closure rpred top)
qed (simp_all)

abbreviation rea_star :: "_ \<Rightarrow> _"  ("_\<^sup>\<star>\<^sup>r" [999] 999) where
"P\<^sup>\<star>\<^sup>r \<equiv> rrel_theory.utp_star P"

text \<open> The supernova tactic explodes conjectures using the Kleene star laws and relational calculus \<close>

method supernova = ((safe intro!: rrel_theory.Star_inductr rrel_theory.Star_inductl, simp_all add: closure) ; rel_auto)[1]

subsection \<open> Instantaneous Reactive Relations \<close>

text \<open> Instantaneous Reactive Relations, where the trace stays the same. \<close>

abbreviation Instant :: "('t::trace, '\<alpha>) hrel_rp \<Rightarrow> ('t, '\<alpha>) hrel_rp" where
"Instant(P) \<equiv> tr:\<lbrakk>P\<rbrakk>"

lemma skip_rea_Instant [closure]: "II\<^sub>r is Instant"
  by (rel_auto)

end