(*<*)
theory LTL
imports
  CIMP_pred
  Infinite_Sequences
begin

(*>*)
section\<open> Linear Temporal Logic \label{sec:ltl}\<close>

text\<open>

To talk about liveness we need to consider infinitary behaviour on
sequences. Traditionally future-time linear temporal logic (LTL) is used to do
this \<^cite>\<open>"MannaPnueli:1991" and "OwickiLamport:1982"\<close>.

The following is a straightforward shallow embedding of the
now-traditional anchored semantics of LTL \<^cite>\<open>"MannaPnueli:1988"\<close>. Some of it is adapted
from the sophisticated TLA development in the AFP due to \<^citet>\<open>"TLA-AFP"\<close>.

Unlike \<^citet>\<open>"Lamport:2002"\<close>, include the
next operator, which is convenient for stating rules. Sometimes it allows us to
ignore the system, i.e. to state rules as temporally valid
(LTL-valid) rather than just temporally program valid (LTL-cimp-), in Jackson's terminology.

\<close>

definition state_prop :: "('a \<Rightarrow> bool) \<Rightarrow> 'a seq_pred" ("\<lceil>_\<rceil>") where
  "\<lceil>P\<rceil> = (\<lambda>\<sigma>. P (\<sigma> 0))"

definition "next" :: "'a seq_pred \<Rightarrow> 'a seq_pred" ("\<circle>_" [80] 80) where
  "(\<circle>P) = (\<lambda>\<sigma>. P (\<sigma> |\<^sub>s 1))"

definition always :: "'a seq_pred \<Rightarrow> 'a seq_pred" ("\<box>_" [80] 80) where
  "(\<box>P) = (\<lambda>\<sigma>. \<forall>i. P (\<sigma> |\<^sub>s i))"

definition until :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<U>" 30) where (* FIXME priority, binds tighter than \<^bold>\<longrightarrow> *)
  "(P \<U> Q) = (\<lambda>\<sigma>. \<exists>i. Q (\<sigma> |\<^sub>s i) \<and> (\<forall>k<i. P (\<sigma> |\<^sub>s k)))"

definition eventually :: "'a seq_pred \<Rightarrow> 'a seq_pred" ("\<diamond>_" [80] 80) where (* FIXME priority, consider making an abbreviation *)
  "(\<diamond>P) = (\<langle>True\<rangle> \<U> P)"

definition release :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<R>" 30) where (* FIXME priority, dual of Until *)
  "(P \<R> Q) = (\<^bold>\<not>(\<^bold>\<not>P \<U> \<^bold>\<not>Q))"

definition unless :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<W>" 30) where (* FIXME priority, aka weak until *)
  "(P \<W> Q) = ((P \<U> Q) \<^bold>\<or> \<box>P)"

abbreviation (input)
  pred_always_imp_syn :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<^bold>\<hookrightarrow>" 25) where
  "P \<^bold>\<hookrightarrow> Q \<equiv> \<box>(P \<^bold>\<longrightarrow> Q)"

lemmas defs =
  state_prop_def
  always_def
  eventually_def
  next_def
  release_def
  unless_def
  until_def

lemma suffix_state_prop[simp]:
  shows "\<lceil>P\<rceil> (\<sigma> |\<^sub>s i) = P (\<sigma> i)"
unfolding defs by simp

lemma alwaysI[intro]:
  assumes "\<And>i. P (\<sigma> |\<^sub>s i)"
  shows "(\<box>P) \<sigma>"
unfolding defs using assms by blast

lemma alwaysD:
  assumes "(\<box>P) \<sigma>"
  shows "P (\<sigma> |\<^sub>s i)"
using assms unfolding defs by blast

lemma alwaysE: "\<lbrakk>(\<box>P) \<sigma>; P (\<sigma> |\<^sub>s i) \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
unfolding defs by blast

lemma always_induct:
  assumes "P \<sigma>"
  assumes "(\<box>(P \<^bold>\<longrightarrow> \<circle>P)) \<sigma>"
  shows "(\<box>P) \<sigma>"
proof(rule alwaysI)
  fix i from assms show "P (\<sigma> |\<^sub>s i)"
    unfolding defs by (induct i) simp_all
qed

lemma seq_comp:
  fixes \<sigma> :: "'a seq"
  fixes P :: "'b seq_pred"
  fixes f :: "'a \<Rightarrow> 'b"
  shows
    "(\<box>P) (f \<circ> \<sigma>) \<longleftrightarrow> (\<box>(\<lambda>\<sigma>. P (f \<circ> \<sigma>))) \<sigma>"
    "(\<diamond>P) (f \<circ> \<sigma>) \<longleftrightarrow> (\<diamond>(\<lambda>\<sigma>. P (f \<circ> \<sigma>))) \<sigma>"
    "(P \<U> Q) (f \<circ> \<sigma>) \<longleftrightarrow> ((\<lambda>\<sigma>. P (f \<circ> \<sigma>)) \<U> (\<lambda>\<sigma>. Q (f \<circ> \<sigma>))) \<sigma>"
    "(P \<W> Q) (f \<circ> \<sigma>) \<longleftrightarrow> ((\<lambda>\<sigma>. P (f \<circ> \<sigma>)) \<W> (\<lambda>\<sigma>. Q (f \<circ> \<sigma>))) \<sigma>"
unfolding defs by simp_all

lemma nextI[intro]:
  assumes "P (\<sigma> |\<^sub>s Suc 0)"
  shows "(\<circle>P) \<sigma>"
using assms unfolding defs by simp

lemma untilE:
  assumes "(P \<U> Q) \<sigma>"
  obtains i where "Q (\<sigma> |\<^sub>s i)" and "\<forall>k<i. P (\<sigma> |\<^sub>s k)"
using assms unfolding until_def by blast

lemma eventuallyI[intro]:
  assumes "P (\<sigma> |\<^sub>s i)"
  shows "(\<diamond>P) \<sigma>"
unfolding eventually_def using assms by blast

lemma eventuallyE[elim]:
  assumes "(\<diamond>P) \<sigma>"
  obtains i where "P (\<sigma> |\<^sub>s i)"
using assms unfolding defs by (blast elim: untilE)

lemma unless_alwaysI:
  assumes "(\<box> P) \<sigma>"
  shows "(P \<W> Q) \<sigma>"
using assms unfolding defs by blast

lemma unless_untilI:
  assumes "Q (\<sigma> |\<^sub>s j)"
  assumes "\<And>i. i < j \<Longrightarrow> P (\<sigma> |\<^sub>s i)"
  shows "(P \<W> Q) \<sigma>"
unfolding defs using assms by blast

lemma always_imp_refl[iff]:
  shows "(P \<^bold>\<hookrightarrow> P) \<sigma>"
unfolding defs by blast

lemma always_imp_trans:
  assumes "(P \<^bold>\<hookrightarrow> Q) \<sigma>"
  assumes "(Q \<^bold>\<hookrightarrow> R) \<sigma>"
  shows "(P \<^bold>\<hookrightarrow> R) \<sigma>"
using assms unfolding defs by blast

lemma always_imp_mp:
  assumes "(P \<^bold>\<hookrightarrow> Q) \<sigma>"
  assumes "P \<sigma>"
  shows "Q \<sigma>"
using assms unfolding defs by (metis suffix_zero)

lemma always_imp_mp_suffix:
  assumes "(P \<^bold>\<hookrightarrow> Q) \<sigma>"
  assumes "P (\<sigma> |\<^sub>s i)"
  shows "Q (\<sigma> |\<^sub>s i)"
using assms unfolding defs by metis

text\<open>

Some basic facts and equivalences, mostly sanity.

\<close>

lemma necessitation:
  "(\<And>s. P s) \<Longrightarrow> (\<box>P) \<sigma>"
  "(\<And>s. P s) \<Longrightarrow> (\<diamond>P) \<sigma>"
  "(\<And>s. P s) \<Longrightarrow> (P \<W> Q) \<sigma>"
  "(\<And>s. Q s) \<Longrightarrow> (P \<U> Q) \<sigma>"
unfolding defs by auto

lemma cong:
  "(\<And>s. P s = P' s) \<Longrightarrow> \<lceil>P\<rceil> = \<lceil>P'\<rceil>"
  "(\<And>\<sigma>. P \<sigma> = P' \<sigma>) \<Longrightarrow> (\<box>P) = (\<box>P')"
  "(\<And>\<sigma>. P \<sigma> = P' \<sigma>) \<Longrightarrow> (\<diamond>P) = (\<diamond>P')"
  "(\<And>\<sigma>. P \<sigma> = P' \<sigma>) \<Longrightarrow> (\<circle>P) = (\<circle>P')"
  "\<lbrakk>\<And>\<sigma>. P \<sigma> = P' \<sigma>; \<And>\<sigma>. Q \<sigma> = Q' \<sigma>\<rbrakk> \<Longrightarrow> (P \<U> Q) = (P' \<U> Q')"
  "\<lbrakk>\<And>\<sigma>. P \<sigma> = P' \<sigma>; \<And>\<sigma>. Q \<sigma> = Q' \<sigma>\<rbrakk> \<Longrightarrow> (P \<W> Q) = (P' \<W> Q')"
unfolding defs by auto

lemma norm[simp]:
  "\<lceil>\<langle>False\<rangle>\<rceil> = \<langle>False\<rangle>"
  "\<lceil>\<langle>True\<rangle>\<rceil> = \<langle>True\<rangle>"
  "(\<^bold>\<not>\<lceil>p\<rceil>) = \<lceil>\<^bold>\<not>p\<rceil>"
  "(\<lceil>p\<rceil> \<^bold>\<and> \<lceil>q\<rceil>) = \<lceil>p \<^bold>\<and> q\<rceil>"
  "(\<lceil>p\<rceil> \<^bold>\<or> \<lceil>q\<rceil>) = \<lceil>p \<^bold>\<or> q\<rceil>"
  "(\<lceil>p\<rceil> \<^bold>\<longrightarrow> \<lceil>q\<rceil>) = \<lceil>p \<^bold>\<longrightarrow> q\<rceil>"
  "(\<lceil>p\<rceil> \<sigma> \<and> \<lceil>q\<rceil> \<sigma>) = \<lceil>p \<^bold>\<and> q\<rceil> \<sigma>"
  "(\<lceil>p\<rceil> \<sigma> \<or> \<lceil>q\<rceil> \<sigma>) = \<lceil>p \<^bold>\<or> q\<rceil> \<sigma>"
  "(\<lceil>p\<rceil> \<sigma> \<longrightarrow> \<lceil>q\<rceil> \<sigma>) = \<lceil>p \<^bold>\<longrightarrow> q\<rceil> \<sigma>"

  "(\<circle>\<langle>False\<rangle>) = \<langle>False\<rangle>"
  "(\<circle>\<langle>True\<rangle>) = \<langle>True\<rangle>"

  "(\<box>\<langle>False\<rangle>) = \<langle>False\<rangle>"
  "(\<box>\<langle>True\<rangle>) = \<langle>True\<rangle>"
  "(\<^bold>\<not>\<box> P) \<sigma> = (\<diamond> (\<^bold>\<not> P)) \<sigma>"
  "(\<box>\<box> P) = (\<box> P)"

  "(\<diamond>\<langle>False\<rangle>) = \<langle>False\<rangle>"
  "(\<diamond>\<langle>True\<rangle>) = \<langle>True\<rangle>"
  "(\<^bold>\<not>\<diamond> P) = (\<box> (\<^bold>\<not> P))"
  "(\<diamond>\<diamond> P) = (\<diamond> P)"

  "(P \<W> \<langle>False\<rangle>) = (\<box> P)"

  "(\<^bold>\<not>(P \<U> Q)) \<sigma> = (\<^bold>\<not>P \<R> \<^bold>\<not>Q) \<sigma>"
  "(\<langle>False\<rangle> \<U> P) = P"
  "(P \<U> \<langle>False\<rangle>) = \<langle>False\<rangle>"
  "(P \<U> \<langle>True\<rangle>) = \<langle>True\<rangle>"
  "(\<langle>True\<rangle> \<U> P) = (\<diamond> P)"
  "(P \<U> (P \<U> Q)) = (P \<U> Q)"

  "(\<^bold>\<not>(P \<R> Q)) \<sigma> = (\<^bold>\<not>P \<U> \<^bold>\<not>Q) \<sigma>"
  "(\<langle>False\<rangle> \<R> P) = (\<box>P)"
  "(P \<R> \<langle>False\<rangle>) = \<langle>False\<rangle>"
  "(\<langle>True\<rangle> \<R> P) = P"
  "(P \<R> \<langle>True\<rangle>) = \<langle>True\<rangle>"
(*
  "(P \<U> (P \<U> Q)) \<sigma> = (P \<U> Q) \<sigma>" FIXME for Release
*)
unfolding defs
apply (auto simp: fun_eq_iff)
apply (metis suffix_plus suffix_zero)
apply (metis suffix_plus suffix_zero)
  apply fastforce
  apply force
apply (metis add.commute add_diff_inverse_nat less_diff_conv2 not_le)
apply (metis add.right_neutral not_less0)
  apply force
  apply fastforce
done

lemma always_conj_distrib: "(\<box>(P \<^bold>\<and> Q)) = (\<box>P \<^bold>\<and> \<box>Q)"
unfolding defs by auto

lemma eventually_disj_distrib: "(\<diamond>(P \<^bold>\<or> Q)) = (\<diamond>P \<^bold>\<or> \<diamond>Q)"
unfolding defs by auto

lemma always_eventually[elim!]:
  assumes "(\<box>P) \<sigma>"
  shows "(\<diamond>P) \<sigma>"
using assms unfolding defs by auto

lemma eventually_imp_conv_disj: "(\<diamond>(P \<^bold>\<longrightarrow> Q)) = (\<diamond>(\<^bold>\<not>P) \<^bold>\<or> \<diamond>Q)"
unfolding defs by auto

lemma eventually_imp_distrib:
  "(\<diamond>(P \<^bold>\<longrightarrow> Q)) = (\<box>P \<^bold>\<longrightarrow> \<diamond>Q)"
unfolding defs by auto

lemma unfold:
  "(\<box> P) \<sigma> = (P \<^bold>\<and> \<circle>\<box>P) \<sigma>"
  "(\<diamond> P) \<sigma> = (P \<^bold>\<or> \<circle>\<diamond>P) \<sigma>"
  "(P \<W> Q) \<sigma> = (Q \<^bold>\<or> (P \<^bold>\<and> \<circle>(P \<W> Q))) \<sigma>"
  "(P \<U> Q) \<sigma> = (Q \<^bold>\<or> (P \<^bold>\<and> \<circle>(P \<U> Q))) \<sigma>"
  "(P \<R> Q) \<sigma> = (Q \<^bold>\<and> (P \<^bold>\<or> \<circle>(P \<R> Q))) \<sigma>"
unfolding defs
apply -
apply (metis (full_types) add.commute add_diff_inverse_nat less_one suffix_plus suffix_zero)
apply (metis (full_types) One_nat_def add.right_neutral add_Suc_right lessI less_Suc_eq_0_disj suffix_plus suffix_zero)

apply auto
  apply fastforce
  apply (metis gr0_conv_Suc nat_neq_iff not_less_eq suffix_zero)
  apply (metis suffix_zero)
  apply force
  using less_Suc_eq_0_disj apply fastforce
  apply (metis gr0_conv_Suc nat_neq_iff not_less0 suffix_zero)

  apply fastforce
  apply (case_tac i; auto)
  apply force
  using less_Suc_eq_0_disj apply force

  apply force
  using less_Suc_eq_0_disj apply fastforce
  apply fastforce
  apply (case_tac i; auto)
done

lemma mono:
  "\<lbrakk>(\<box>P) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow>  P' \<sigma>\<rbrakk> \<Longrightarrow> (\<box>P') \<sigma>"
  "\<lbrakk>(\<diamond>P) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow>  P' \<sigma>\<rbrakk> \<Longrightarrow> (\<diamond>P') \<sigma>"
  "\<lbrakk>(P \<U> Q) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow> P' \<sigma>; \<And>\<sigma>. Q \<sigma> \<Longrightarrow> Q' \<sigma>\<rbrakk> \<Longrightarrow> (P' \<U> Q') \<sigma>"
  "\<lbrakk>(P \<W> Q) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow> P' \<sigma>; \<And>\<sigma>. Q \<sigma> \<Longrightarrow> Q' \<sigma>\<rbrakk> \<Longrightarrow> (P' \<W> Q') \<sigma>"
unfolding defs by force+

lemma always_imp_mono:
  "\<lbrakk>(\<box>P) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>\<rbrakk> \<Longrightarrow> (\<box>P') \<sigma>"
  "\<lbrakk>(\<diamond>P) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>\<rbrakk> \<Longrightarrow> (\<diamond>P') \<sigma>"
  "\<lbrakk>(P \<U> Q) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>; (Q \<^bold>\<hookrightarrow> Q') \<sigma>\<rbrakk> \<Longrightarrow> (P' \<U> Q') \<sigma>"
  "\<lbrakk>(P \<W> Q) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>; (Q \<^bold>\<hookrightarrow> Q') \<sigma>\<rbrakk> \<Longrightarrow> (P' \<W> Q') \<sigma>"
unfolding defs by force+

lemma next_conj_distrib:
  "(\<circle>(P \<^bold>\<and> Q)) = (\<circle>P \<^bold>\<and> \<circle>Q)"
unfolding defs by auto

lemma next_disj_distrib:
  "(\<circle>(P \<^bold>\<or> Q)) = (\<circle>P \<^bold>\<or> \<circle>Q)"
unfolding defs by auto

lemma until_next_distrib:
  "(\<circle>(P \<U> Q)) = (\<circle>P \<U> \<circle>Q)"
unfolding defs by (auto simp: fun_eq_iff)

lemma until_imp_eventually:
  "((P \<U> Q) \<^bold>\<longrightarrow> \<diamond>Q) \<sigma>"
unfolding defs by auto

lemma until_until_disj:
  assumes "(P \<U> Q \<U> R) \<sigma>"
  shows "((P \<^bold>\<or> Q) \<U> R) \<sigma>"
using assms unfolding defs
apply clarsimp
apply (metis (full_types) add_diff_inverse_nat nat_add_left_cancel_less)
done

lemma unless_unless_disj:
  assumes "(P \<W> Q \<W> R) \<sigma>"
  shows "((P \<^bold>\<or> Q) \<W> R) \<sigma>"
using assms unfolding defs
apply auto
 apply (metis add.commute add_diff_inverse_nat leI less_diff_conv2)
apply (metis add_diff_inverse_nat)
done

lemma until_conj_distrib:
  "((P \<^bold>\<and> Q) \<U> R) = ((P \<U> R) \<^bold>\<and> (Q \<U> R))"
unfolding defs
apply (auto simp: fun_eq_iff)
apply (metis dual_order.strict_trans nat_neq_iff)
done

lemma until_disj_distrib:
  "(P \<U> (Q \<^bold>\<or> R)) = ((P \<U> Q) \<^bold>\<or> (P \<U> R))"
unfolding defs by (auto simp: fun_eq_iff)

lemma eventually_until:
  "(\<diamond>P) = (\<^bold>\<not>P \<U> P)"
unfolding defs
apply (auto simp: fun_eq_iff)
apply (case_tac "P (x |\<^sub>s 0)")
 apply blast
apply (drule (1) ex_least_nat_less)
apply (metis le_simps(2))
done

lemma eventually_until_eventually:
  "(\<diamond>(P \<U> Q)) = (\<diamond>Q)"
unfolding defs by force

lemma eventually_unless_until:
  "((P \<W> Q) \<^bold>\<and> \<diamond>Q) = (P \<U> Q)"
unfolding defs by force

lemma eventually_always_imp_always_eventually:
  assumes "(\<diamond>\<box>P) \<sigma>"
  shows "(\<box>\<diamond>P) \<sigma>"
using assms unfolding defs by (metis suffix_commute)

lemma eventually_always_next_stable:
  assumes "(\<diamond>P) \<sigma>"
  assumes "(P \<^bold>\<hookrightarrow> \<circle>P) \<sigma>"
  shows "(\<diamond>\<box>P) \<sigma>"
using assms by (metis (no_types) eventuallyI alwaysD always_induct eventuallyE norm(15))

lemma next_stable_imp_eventually_always:
  assumes "(P \<^bold>\<hookrightarrow> \<circle>P) \<sigma>"
  shows "(\<diamond>P \<^bold>\<longrightarrow> \<diamond>\<box>P) \<sigma>"
using assms eventually_always_next_stable by blast

lemma always_eventually_always:
  "\<diamond>\<box>\<diamond>P = \<box>\<diamond>P"
unfolding defs by (clarsimp simp: fun_eq_iff) (metis add.left_commute semiring_normalization_rules(25))

(* FIXME define "stable", develop more rules for it *)
lemma stable_unless:
  assumes "(P \<^bold>\<hookrightarrow> \<circle>(P \<^bold>\<or> Q)) \<sigma>"
  shows "(P \<^bold>\<hookrightarrow> (P \<W> Q)) \<sigma>"
using assms unfolding defs
apply -
apply (rule ccontr)
apply clarsimp
apply (drule (1) ex_least_nat_less[where P="\<lambda>j. \<not>P (\<sigma> |\<^sub>s i + j)" for i, simplified])
apply clarsimp
apply (metis add_Suc_right le_less less_Suc_eq)
done

lemma unless_induct: \<comment>\<open> Rule \texttt{WAIT} from \<^citet>\<open>\<open>Fig~3.3\<close> in "MannaPnueli:1995"\<close>\<close>
  assumes I: "(I \<^bold>\<hookrightarrow> \<circle>(I \<^bold>\<or> R)) \<sigma>"
  assumes P: "(P \<^bold>\<hookrightarrow> I \<^bold>\<or> R) \<sigma>"
  assumes Q: "(I \<^bold>\<hookrightarrow> Q) \<sigma>"
  shows "(P \<^bold>\<hookrightarrow> Q \<W> R) \<sigma>"
apply (intro alwaysI impI)
apply (erule impE[OF alwaysD[OF P]])
apply (erule disjE)
 apply (rule always_imp_mono(4)[where P=I and Q=R])
   apply (erule mp[OF alwaysD[OF stable_unless[OF I]]])
  apply (simp add: Q alwaysD)
 apply blast
apply (simp add: unfold)
done

subsection\<open> Leads-to and leads-to-via \label{sec:leads-to} \<close>

text\<open>

Most of our assertions will be of the form @{term "A \<^bold>\<longrightarrow> \<diamond>C"} (pronounced ``\<open>A\<close> leads to \<open>C\<close>'')
or @{term "A \<^bold>\<longrightarrow> B \<U> C"} (``\<open>A\<close> leads to \<open>C\<close> via \<open>B\<close>'').

Most of these rules are due to \<^citet>\<open>"Jackson:1998"\<close> who used leads-to-via in a sequential setting. Others
are due to \<^citet>\<open>"MannaPnueli:1991"\<close>.

The leads-to-via connective is similar to the ``ensures'' modality of \<^citet>\<open>\<open>\S3.4.4\<close> in "ChandyMisra:1989"\<close>.

\<close>

abbreviation (input)
  leads_to :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<^bold>\<leadsto>" 25) where (* FIXME priority *)
  "P \<^bold>\<leadsto> Q \<equiv> P \<^bold>\<hookrightarrow> \<diamond>Q"

lemma leads_to_refl:
  shows "(P \<^bold>\<leadsto> P) \<sigma>"
by (metis (no_types, lifting) necessitation(1) unfold(2))

lemma leads_to_trans:
  assumes "(P \<^bold>\<leadsto> Q) \<sigma>"
  assumes "(Q \<^bold>\<leadsto> R) \<sigma>"
  shows "(P \<^bold>\<leadsto> R) \<sigma>"
using assms unfolding defs by clarsimp (metis semiring_normalization_rules(25))

lemma leads_to_eventuallyE:
  assumes "(P \<^bold>\<leadsto> Q) \<sigma>"
  assumes "(\<diamond>P) \<sigma>"
  shows "(\<diamond>Q) \<sigma>"
using assms unfolding defs by auto

lemma leads_to_mono:
  assumes "(P' \<^bold>\<hookrightarrow> P) \<sigma>"
  assumes "(Q \<^bold>\<hookrightarrow> Q') \<sigma>"
  assumes "(P \<^bold>\<leadsto> Q) \<sigma>"
  shows "(P' \<^bold>\<leadsto> Q') \<sigma>"
using assms unfolding defs by clarsimp blast

lemma leads_to_eventually:
  shows "(P \<^bold>\<leadsto> Q \<^bold>\<longrightarrow> \<diamond>P \<^bold>\<longrightarrow> \<diamond>Q) \<sigma>"
by (metis (no_types, lifting) alwaysI unfold(2))

lemma leads_to_disj:
  assumes "(P \<^bold>\<leadsto> R) \<sigma>"
  assumes "(Q \<^bold>\<leadsto> R) \<sigma>"
  shows "((P \<^bold>\<or> Q) \<^bold>\<leadsto> R) \<sigma>"
using assms unfolding defs by simp

lemma leads_to_leads_to_viaE:
  shows "((P \<^bold>\<hookrightarrow> P \<U> Q) \<^bold>\<longrightarrow> P \<^bold>\<leadsto> Q) \<sigma>"
unfolding defs by clarsimp blast

lemma leads_to_via_concl_weaken:
  assumes "(R \<^bold>\<hookrightarrow> R') \<sigma>"
  assumes "(P \<^bold>\<hookrightarrow> Q \<U> R) \<sigma>"
  shows "(P \<^bold>\<hookrightarrow> Q \<U> R') \<sigma>"
using assms unfolding LTL.defs by force

lemma leads_to_via_trans:
  assumes "(A \<^bold>\<hookrightarrow> B \<U> C) \<sigma>"
  assumes "(C \<^bold>\<hookrightarrow> D \<U> E) \<sigma>"
  shows "(A \<^bold>\<hookrightarrow> (B \<^bold>\<or> D) \<U> E) \<sigma>"
proof(rule alwaysI, rule impI)
  fix i assume "A (\<sigma> |\<^sub>s i)" with assms show "((B \<^bold>\<or> D) \<U> E) (\<sigma> |\<^sub>s i)"
    apply -
    apply (erule alwaysE[where i=i])
    apply clarsimp
    apply (erule untilE)
    apply clarsimp (* suffix *)
    apply (drule (1) always_imp_mp_suffix)
    apply (erule untilE)
    apply clarsimp (* suffix *)
    apply (rule_tac i="ia + iaa" in untilI; simp add: ac_simps)
    apply (metis (full_types) add.assoc leI le_Suc_ex nat_add_left_cancel_less) (* arithmetic *)
    done
qed

lemma leads_to_via_disj: \<comment> \<open> useful for case distinctions \<close>
  assumes "(P \<^bold>\<hookrightarrow> Q \<U> R) \<sigma>"
  assumes "(P' \<^bold>\<hookrightarrow> Q' \<U> R) \<sigma>"
  shows "(P \<^bold>\<or> P' \<^bold>\<hookrightarrow> (Q \<^bold>\<or> Q') \<U> R) \<sigma>"
using assms unfolding defs by (auto 10 0)

lemma leads_to_via_disj': \<comment> \<open> more like a chaining rule \<close>
  assumes "(A \<^bold>\<hookrightarrow> B \<U> C) \<sigma>"
  assumes "(C \<^bold>\<hookrightarrow> D \<U> E) \<sigma>"
  shows "(A \<^bold>\<or> C \<^bold>\<hookrightarrow> (B \<^bold>\<or> D) \<U> E) \<sigma>"
proof(rule alwaysI, rule impI, erule disjE)
  fix i assume "A (\<sigma> |\<^sub>s i)" with assms show "((B \<^bold>\<or> D) \<U> E) (\<sigma> |\<^sub>s i)"
    apply -
    apply (erule alwaysE[where i=i])
    apply clarsimp
    apply (erule untilE)
    apply clarsimp (* suffix *)
    apply (drule (1) always_imp_mp_suffix)
    apply (erule untilE)
    apply clarsimp (* suffix *)
    apply (rule_tac i="ia + iaa" in untilI; simp add: ac_simps)
    apply (metis (full_types) add.assoc leI le_Suc_ex nat_add_left_cancel_less) (* arithmetic *)
    done
next
  fix i assume "C (\<sigma> |\<^sub>s i)" with assms(2) show "((B \<^bold>\<or> D) \<U> E) (\<sigma> |\<^sub>s i)"
    apply -
    apply (erule alwaysE[where i=i])
    apply (simp add: mono)
    done
qed

lemma leads_to_via_stable_augmentation:
  assumes stable: "(P \<^bold>\<and> Q \<^bold>\<hookrightarrow> \<circle>Q) \<sigma>"
  assumes U: "(A \<^bold>\<hookrightarrow> P \<U> C) \<sigma>"
  shows "((A \<^bold>\<and> Q) \<^bold>\<hookrightarrow> P \<U> (C \<^bold>\<and> Q)) \<sigma>"
proof(intro alwaysI impI, elim conjE)
  fix i assume AP: "A (\<sigma> |\<^sub>s i)" "Q (\<sigma> |\<^sub>s i)"
  have "Q (\<sigma> |\<^sub>s (j + i))" if "Q (\<sigma> |\<^sub>s i)" and "\<forall>k<j. P (\<sigma> |\<^sub>s (k + i))" for j
    using that stable by (induct j; force simp: defs)
  with U AP show "(P \<U> (\<lambda>\<sigma>. C \<sigma> \<and> Q \<sigma>)) (\<sigma> |\<^sub>s i)"
    unfolding defs by clarsimp (metis (full_types) add.commute)
qed

lemma leads_to_via_wf:
  assumes "wf R"
  assumes indhyp: "\<And>t. (A \<^bold>\<and> \<lceil>\<delta> \<^bold>= \<langle>t\<rangle>\<rceil> \<^bold>\<hookrightarrow> B \<U> (A \<^bold>\<and> \<lceil>\<delta> \<^bold>\<otimes> \<langle>t\<rangle> \<^bold>\<in> \<langle>R\<rangle>\<rceil> \<^bold>\<or> C)) \<sigma>"
  shows "(A \<^bold>\<hookrightarrow> B \<U> C) \<sigma>"
proof(intro alwaysI impI)
  fix i assume "A (\<sigma> |\<^sub>s i)" with \<open>wf R\<close> show "(B \<U> C) (\<sigma> |\<^sub>s i)"
  proof(induct "\<delta> (\<sigma> i)" arbitrary: i)
    case (less i) with indhyp[where t="\<delta> (\<sigma> i)"] show ?case
      apply -
      apply (drule alwaysD[where i=i])
      apply clarsimp
      apply (erule untilE)
      apply (rename_tac j)
       apply (erule disjE; clarsimp)
       apply (drule_tac x="i + j" in meta_spec; clarsimp)
       apply (erule untilE; clarsimp)
       apply (rename_tac j k)
       apply (rule_tac i="j + k" in untilI)
        apply (simp add: add.assoc)
       apply clarsimp
       apply (metis add.assoc add.commute add_diff_inverse_nat less_diff_conv2 not_le)
      apply auto
      done
  qed
qed

text\<open>

The well-founded response rule due to \<^citet>\<open>\<open>Fig~1.23: \texttt{WELL} (well-founded response)\<close> in"MannaPnueli:2010"\<close>,
generalised to an arbitrary set of assertions and sequence predicates.
\<^item> \<open>W1\<close> generalised to be contingent.
\<^item> \<open>W2\<close> is a well-founded set of assertions that by \<open>W1\<close> includes \<open>P\<close>

\<close>

(* FIXME: Does \<open>Is\<close> need to be consistent? *)
lemma leads_to_wf:
  fixes Is :: "('a seq_pred \<times> ('a \<Rightarrow> 'b)) set"
  assumes "wf (R :: 'b rel)"
  assumes W1: "(\<box>(\<^bold>\<exists>\<phi>. \<lceil>\<langle>\<phi>\<in>fst ` Is\<rangle>\<rceil> \<^bold>\<and> (P \<^bold>\<longrightarrow> \<phi>))) \<sigma>"
  assumes W2: "\<forall>(\<phi>, \<delta>)\<in>Is. \<exists>(\<phi>', \<delta>')\<in>insert (Q, \<delta>0) Is. \<forall>t. (\<phi> \<^bold>\<and> \<lceil>\<delta> \<^bold>= \<langle>t\<rangle>\<rceil> \<^bold>\<leadsto> \<phi>' \<^bold>\<and> \<lceil>\<delta>' \<^bold>\<otimes> \<langle>t\<rangle> \<^bold>\<in> \<langle>R\<rangle>\<rceil>) \<sigma>"
  shows "(P \<^bold>\<leadsto> Q) \<sigma>"
proof -
  have "(\<phi> \<^bold>\<and> \<lceil>\<delta> \<^bold>= \<langle>t\<rangle>\<rceil> \<^bold>\<leadsto> Q) \<sigma>" if "(\<phi>, \<delta>) \<in> Is" for \<phi> \<delta> t
    using \<open>wf R\<close> that W2
    apply (induct t arbitrary: \<phi> \<delta>)
    unfolding LTL.defs split_def
    apply clarsimp
    apply (metis (no_types, opaque_lifting) ab_semigroup_add_class.add_ac(1) fst_eqD snd_conv surjective_pairing)
    done
  with W1 show ?thesis
    apply -
    apply (rule alwaysI)
    apply clarsimp
    apply (erule_tac i=i in alwaysE)
    apply clarsimp
    using alwaysD suffix_state_prop apply blast
    done
qed

subsection\<open>Fairness\<close>

text\<open>

A few renderings of weak fairness. \<^citet>\<open>"vanGlabbeekHofner:2019"\<close> call this
"response to insistence" as a generalisation of weak fairness.

\<close>

definition weakly_fair :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" where
  "weakly_fair enabled taken = (\<box>enabled \<^bold>\<hookrightarrow> \<diamond>taken)"

lemma weakly_fair_def2:
  shows "weakly_fair enabled taken = \<box>(\<^bold>\<not>\<box>(enabled \<^bold>\<and> \<^bold>\<not>taken))"
unfolding weakly_fair_def by (metis (full_types) always_conj_distrib norm(18))

lemma weakly_fair_def3:
  shows "weakly_fair enabled taken = (\<diamond>\<box>enabled \<^bold>\<longrightarrow> \<box>\<diamond>taken)"
unfolding weakly_fair_def2
apply (clarsimp simp: fun_eq_iff)

unfolding defs (* True, but can we get there deductively? *)
apply auto
apply (metis (full_types) add.left_commute semiring_normalization_rules(25))
done

lemma weakly_fair_def4:
  shows "weakly_fair enabled taken = \<box>\<diamond>(enabled \<^bold>\<longrightarrow> taken)"
using weakly_fair_def2 by force

lemma mp_weakly_fair:
  assumes "weakly_fair enabled taken \<sigma>"
  assumes "(\<box>enabled) \<sigma>"
  shows "(\<diamond>taken) \<sigma>"
using assms unfolding weakly_fair_def using always_imp_mp by blast

lemma always_weakly_fair:
  shows "\<box>(weakly_fair enabled taken) = weakly_fair enabled taken"
unfolding weakly_fair_def by simp

lemma eventually_weakly_fair:
  shows "\<diamond>(weakly_fair enabled taken) = weakly_fair enabled taken"
unfolding weakly_fair_def2 by (simp add: always_eventually_always)

lemma weakly_fair_weaken:
  assumes "(enabled' \<^bold>\<hookrightarrow> enabled) \<sigma>"
  assumes "(taken \<^bold>\<hookrightarrow> taken') \<sigma>"
  shows "(weakly_fair enabled taken \<^bold>\<hookrightarrow>  weakly_fair enabled' taken') \<sigma>"
using assms unfolding weakly_fair_def defs by simp blast

lemma weakly_fair_unless_until:
  shows "(weakly_fair enabled taken \<^bold>\<and> (enabled \<^bold>\<hookrightarrow> enabled \<W> taken)) = (enabled \<^bold>\<hookrightarrow> enabled \<U> taken)"
unfolding defs weakly_fair_def
apply (auto simp: fun_eq_iff)
apply (metis add.right_neutral)
done

lemma stable_leads_to_eventually:
  assumes "(enabled \<^bold>\<hookrightarrow> \<circle>(enabled \<^bold>\<or> taken)) \<sigma>"
  shows "(enabled \<^bold>\<hookrightarrow> (\<box>enabled \<^bold>\<or> \<diamond>taken)) \<sigma>"
using assms unfolding defs
apply -
apply (rule ccontr)
apply clarsimp
apply (drule (1) ex_least_nat_less[where P="\<lambda>j. \<not> enabled (\<sigma> |\<^sub>s i + j)" for i, simplified])
apply clarsimp
apply (metis add_Suc_right leI less_irrefl_nat)
done

lemma weakly_fair_stable_leads_to:
  assumes "(weakly_fair enabled taken) \<sigma>"
  assumes "(enabled \<^bold>\<hookrightarrow> \<circle>(enabled \<^bold>\<or> taken)) \<sigma>"
  shows "(enabled \<^bold>\<leadsto> taken) \<sigma>"
using stable_leads_to_eventually[OF assms(2)] assms(1) unfolding defs weakly_fair_def
by (auto simp: fun_eq_iff)

lemma weakly_fair_stable_leads_to_via:
  assumes "(weakly_fair enabled taken) \<sigma>"
  assumes "(enabled \<^bold>\<hookrightarrow> \<circle>(enabled \<^bold>\<or> taken)) \<sigma>"
  shows "(enabled \<^bold>\<hookrightarrow> enabled \<U> taken) \<sigma>"
using stable_unless[OF assms(2)] assms(1) by (metis (mono_tags) weakly_fair_unless_until)

text\<open>

Similarly for strong fairness. \<^citet>\<open>"vanGlabbeekHofner:2019"\<close> call this
"response to persistence" as a generalisation of strong fairness.

\<close>

definition strongly_fair :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" where
  "strongly_fair enabled taken = (\<box>\<diamond>enabled \<^bold>\<hookrightarrow> \<diamond>taken)"

lemma strongly_fair_def2:
  "strongly_fair enabled taken = \<box>(\<^bold>\<not>\<box>(\<diamond>enabled \<^bold>\<and> \<^bold>\<not>taken))"
unfolding strongly_fair_def by (metis weakly_fair_def weakly_fair_def2)

lemma strongly_fair_def3:
  "strongly_fair enabled taken = (\<box>\<diamond>enabled \<^bold>\<longrightarrow> \<box>\<diamond>taken)"
unfolding strongly_fair_def2 by (metis (full_types) always_eventually_always weakly_fair_def2 weakly_fair_def3)

lemma always_strongly_fair:
  "\<box>(strongly_fair enabled taken) = strongly_fair enabled taken"
unfolding strongly_fair_def by simp

lemma eventually_strongly_fair:
  "\<diamond>(strongly_fair enabled taken) = strongly_fair enabled taken"
unfolding strongly_fair_def2 by (simp add: always_eventually_always)

lemma strongly_fair_disj_distrib: \<comment> \<open>not true for \<open>weakly_fair\<close>\<close>
  "strongly_fair (enabled1 \<^bold>\<or> enabled2) taken = (strongly_fair enabled1 taken \<^bold>\<and> strongly_fair enabled2 taken)"
unfolding strongly_fair_def defs
apply (auto simp: fun_eq_iff)
  apply blast
  apply blast
  apply (metis (full_types) semiring_normalization_rules(25))
done

lemma strongly_fair_imp_weakly_fair:
  assumes "strongly_fair enabled taken \<sigma>"
  shows "weakly_fair enabled taken \<sigma>"
using assms unfolding strongly_fair_def3 weakly_fair_def3 by (simp add: eventually_always_imp_always_eventually)

lemma always_enabled_weakly_fair_strongly_fair:
  assumes "(\<box>enabled) \<sigma>"
  shows "weakly_fair enabled taken \<sigma> = strongly_fair enabled taken \<sigma>"
using assms by (metis strongly_fair_def3 strongly_fair_imp_weakly_fair unfold(2) weakly_fair_def3)

subsection\<open>Safety and liveness \label{sec:ltl-safety-liveness}\<close>

text\<open>

\<^citet>\<open>"Sistla:1994"\<close> shows some characterisations
of LTL formulas in terms of safety and liveness. Note his @{term
"(\<U>)"} is actually @{term "(\<W>)"}.

See also \<^citet>\<open>"ChangMannaPnueli:1992"\<close>.

\<close>

lemma safety_state_prop:
  shows "safety \<lceil>P\<rceil>"
unfolding defs by (rule safety_state_prop)

lemma safety_Next:
  assumes "safety P"
  shows "safety (\<circle>P)"
using assms unfolding defs safety_def
apply clarsimp
apply (metis (mono_tags) One_nat_def list.sel(3) nat.simps(3) stake.simps(2))
done

lemma safety_unless:
  assumes "safety P"
  assumes "safety Q"
  shows "safety (P \<W> Q)"
proof(rule safetyI2)
  fix \<sigma> assume X: "\<exists>\<beta>. (P \<W> Q) (stake i \<sigma> @- \<beta>)" for i
  then show "(P \<W> Q) \<sigma>"
  proof(cases "\<forall>i j. \<exists>\<beta>. P (\<sigma>(i \<rightarrow> j) @- \<beta>)")
    case True
    with \<open>safety P\<close> have "\<forall>i. P (\<sigma> |\<^sub>s i)" unfolding safety_def2 by blast
    then show ?thesis by (blast intro: unless_alwaysI)
  next
    case False
    then obtain k k' where "\<forall>\<beta>. \<not> P (\<sigma>(k \<rightarrow> k') @- \<beta>)" by clarsimp
    then have "\<forall>i u. k + k' \<le> i \<longrightarrow> \<not>P ((stake i \<sigma> @- u) |\<^sub>s k)"
      by (metis add.commute diff_add stake_shift_stake_shift stake_suffix_drop suffix_shift)
    then have "\<forall>i u. k + k' \<le> i \<and> (P \<W> Q) (stake i \<sigma> @- u) \<longrightarrow> (\<exists>m\<le>k. Q ((stake i \<sigma> @- u) |\<^sub>s m) \<and> (\<forall>p<m. P ((stake i \<sigma> @- u) |\<^sub>s p)))"
      unfolding defs using leI by blast
    then have "\<forall>i u. k + k' \<le> i \<and> (P \<W> Q) (stake i \<sigma> @- u) \<longrightarrow> (\<exists>m\<le>k. Q (\<sigma>(m \<rightarrow> i - m) @- u) \<and> (\<forall>p<m. P (\<sigma>(p \<rightarrow> i - p) @- u)))"
      by (metis stake_suffix add_leE nat_less_le order_trans)
    then have "\<forall>i. \<exists>n\<ge>i. \<exists>m\<le>k. \<exists>u. Q (\<sigma>(m \<rightarrow> n - m) @- u) \<and> (\<forall>p<m. P (\<sigma>(p \<rightarrow> n - p) @- u))"
      using X by (metis add.commute le_add1)
    then have "\<exists>m\<le>k. \<forall>i. \<exists>n\<ge>i. \<exists>u. Q (\<sigma>(m \<rightarrow> n - m) @- u) \<and> (\<forall>p<m. P (\<sigma>(p \<rightarrow> n - p) @- u))"
      by (simp add: always_eventually_pigeonhole)
    with \<open>safety P\<close> \<open>safety Q\<close> show "(P \<W> Q) \<sigma>"
        unfolding defs by (metis Nat.le_diff_conv2 add_leE safety_always_eventually)
  qed
qed

lemma safety_always:
  assumes "safety P"
  shows "safety (\<box>P)"
using assms by (metis norm(20) safety_def safety_unless)

lemma absolute_liveness_eventually:
  shows "absolute_liveness P \<longleftrightarrow> (\<exists>\<sigma>. P \<sigma>) \<and> P = \<diamond>P"
unfolding absolute_liveness_def defs
by (metis cancel_comm_monoid_add_class.diff_cancel drop_eq_Nil order_refl shift.simps(1) stake_suffix_id suffix_shift suffix_zero)

lemma stable_always:
  shows "stable P \<longleftrightarrow> (\<exists>\<sigma>. P \<sigma>) \<and> P = \<box>P"
unfolding stable_def defs by (metis suffix_zero)

(* FIXME Sistla's examples of stable properties are boring and follow directly from this lemma.
   FIXME the fairness "type of formulas" follow from the above and the fairness def. *)

text\<open>

To show that @{const \<open>weakly_fair\<close>} is a @{const \<open>fairness\<close>} property requires some constraints on \<open>enabled\<close> and \<open>taken\<close>:
\<^item> it is reasonable to assume they are state formulas
\<^item> \<open>taken\<close> must be satisfiable

\<close>

lemma fairness_weakly_fair:
  assumes "\<exists>s. taken s"
  shows "fairness (weakly_fair \<lceil>enabled\<rceil> \<lceil>taken\<rceil>)"
unfolding fairness_def stable_def absolute_liveness_def weakly_fair_def
using assms
apply auto
   apply (rule_tac x="\<lambda>_ .s" in exI)
   apply fastforce
  apply (simp add: alwaysD)
 apply (rule_tac x="\<lambda>_ .s" in exI)
 apply fastforce
apply (metis (full_types) absolute_liveness_def absolute_liveness_eventually eventually_weakly_fair weakly_fair_def)
done

lemma fairness_strongly_fair:
  assumes "\<exists>s. taken s"
  shows "fairness (strongly_fair \<lceil>enabled\<rceil> \<lceil>taken\<rceil>)"
unfolding fairness_def stable_def absolute_liveness_def strongly_fair_def
using assms
apply auto
   apply (rule_tac x="\<lambda>_ .s" in exI)
   apply fastforce
  apply (simp add: alwaysD)
 apply (rule_tac x="\<lambda>_ .s" in exI)
 apply fastforce
apply (metis (full_types) absolute_liveness_def absolute_liveness_eventually eventually_weakly_fair weakly_fair_def)
done

(*<*)

end
(*>*)


theory FW_More
  imports DBM_Basics FW_Code
begin

thm FW_zone_equiv
thm fw_shortest_path_up_to thm fwi_step'

lemma fwi_len_distinct:
  "\<exists> ys. set ys \<subseteq> {k} \<and> fwi m n k n n i j = len m i j ys \<and> i \<notin> set ys \<and> j \<notin> set ys \<and> distinct ys"
  if "i \<le> n" "j \<le> n" "k \<le> n" "m k k \<ge> 0"
  using fwi_step'[of m, OF that(4), of n n n i j] that
  apply (clarsimp split: if_splits simp: min_def)
  by (rule exI[where x = "[]"] exI[where x = "[k]"]; auto simp: add_increasing add_increasing2; fail)+

lemma FWI_mono:
  "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> FWI M n k i j \<le> M i j"
  using fwi_mono[of _ n _ M k n n, folded FWI_def, rule_format] .

lemma FWI_zone_equiv:
  "[M]\<^bsub>v,n\<^esub> = [FWI M n k]\<^bsub>v,n\<^esub>" if surj_on: "\<forall> k \<le> n. k > 0 \<longrightarrow> (\<exists> c. v c = k)" and "k \<le> n"
proof safe
  fix u assume A: "u \<in> [FWI M n k]\<^bsub>v,n\<^esub>"
  { fix i j assume "i \<le> n" "j \<le> n"
    then have "FWI M n k i j \<le> M i j" by (rule FWI_mono)
    hence "FWI M n k i j \<preceq> M i j" by (simp add: less_eq)
  }
  with DBM_le_subset[of n "FWI M n k" M] A show "u \<in> [M]\<^bsub>v,n\<^esub>" by auto
next
  fix u assume u:"u \<in> [M]\<^bsub>v,n\<^esub>"
  hence *:"DBM_val_bounded v u M n" by (simp add: DBM_zone_repr_def)
  note ** = DBM_val_bounded_neg_cycle[OF this _ _ _ surj_on]
  have cyc_free: "cyc_free M n" using ** by fastforce
  from cyc_free_diag[OF this] \<open>k \<le> n\<close> have "M k k \<ge> 0" by auto

  have "DBM_val_bounded v u (FWI M n k) n" unfolding DBM_val_bounded_def
  proof (safe, goal_cases)
    case 1
    with \<open>k \<le> n\<close> \<open>M k k \<ge> 0\<close> cyc_free show ?case
      unfolding FWI_def neutral[symmetric] less_eq[symmetric]
      by - (rule fwi_cyc_free_diag[where I = "{0..n}"]; auto)
  next
    case (2 c)
    with \<open>k \<le> n\<close> \<open>M k k \<ge> 0\<close> fwi_len_distinct[of 0 n "v c" k M] obtain xs where xs:
      "FWI M n k 0 (v c) = len M 0 (v c) xs" "set xs \<subseteq> {0..n}" "0 \<notin> set xs"
      unfolding FWI_def by force
    with surj_on \<open>v c \<le> n\<close> show ?case unfolding xs(1)
      by - (rule DBM_val_bounded_len'2[OF *]; auto)
  next
    case (3 c)
    with \<open>k \<le> n\<close> \<open>M k k \<ge> 0\<close> fwi_len_distinct[of "v c" n 0 k M] obtain xs where xs:
      "FWI M n k (v c) 0 = len M (v c) 0 xs" "set xs \<subseteq> {0..n}"
      "0 \<notin> set xs" "v c \<notin> set xs"
      unfolding FWI_def by force
    with surj_on \<open>v c \<le> n\<close> show ?case unfolding xs(1)
      by - (rule DBM_val_bounded_len'1[OF *]; auto)
  next
    case (4 c1 c2)
    with \<open>k \<le> n\<close> \<open>M k k \<ge> 0\<close> fwi_len_distinct[of "v c1" n "v c2" k M] obtain xs where xs:
      "FWI M n k (v c1) (v c2) = len M (v c1) (v c2) xs" "set xs \<subseteq> {0..n}"
      "v c1 \<notin> set xs" "v c2 \<notin> set xs" "distinct xs"
      unfolding FWI_def by force
    with surj_on \<open>v c1 \<le> n\<close> \<open>v c2 \<le> n\<close> show ?case
      unfolding xs(1) by - (rule DBM_val_bounded_len'3[OF *]; auto dest: distinct_cnt[of _ 0])
  qed
  then show "u \<in> [FWI M n k]\<^bsub>v,n\<^esub>" unfolding DBM_zone_repr_def by simp
qed

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Cong
  imports Weak_Cong_Sim Weak_Bisim Strong_Bisim_SC
begin

definition weakCongruence :: "ccs \<Rightarrow> ccs \<Rightarrow> bool" ("_ \<cong> _" [70, 70] 65)
where
  "P \<cong> Q \<equiv> P \<leadsto><weakBisimulation> Q \<and> Q \<leadsto><weakBisimulation> P"

  assumes "P \<cong> Q"

  shows "P \<leadsto><weakBisimulation> Q"
  and   "Q \<leadsto><weakBisimulation> P"
using assms
by(auto simp add: weakCongruence_def)

lemma weakCongruenceI:
  fixes P :: "ccs"
  and   Q :: "ccs"

  assumes "P \<leadsto><weakBisimulation> Q"
  and     "Q \<leadsto><weakBisimulation> P"

  shows "P \<cong> Q"
using assms
by(auto simp add: weakCongruence_def)

lemma weakCongISym[consumes 1, case_names cSym cSim]:
  fixes P :: ccs
  and   Q :: ccs

  assumes "Prop P Q"
  and     "\<And>P Q. Prop P Q \<Longrightarrow> Prop Q P"
  and     "\<And>P Q. Prop P Q \<Longrightarrow> (F P) \<leadsto><weakBisimulation> (F Q)"

  shows "F P \<cong> F Q"
using assms
by(auto simp add: weakCongruence_def)

lemma weakCongISym2[consumes 1, case_names cSim]:
  fixes P :: ccs
  and   Q :: ccs

  assumes "P \<cong> Q"
  and     "\<And>P Q. P \<cong> Q \<Longrightarrow> (F P) \<leadsto><weakBisimulation> (F Q)"

  shows "F P \<cong> F Q"
using assms
by(auto simp add: weakCongruence_def)

lemma reflexive:
  fixes P :: ccs

  shows "P \<cong> P"
by(auto intro: weakCongruenceI Weak_Bisim.reflexive Weak_Cong_Sim.reflexive)

  assumes "P \<cong> Q"

  shows "Q \<cong> P"
using assms
by(auto simp add: weakCongruence_def)

  assumes "P \<cong> Q"
  and     "Q \<cong> R"

  shows "P \<cong> R"
proof -
  let ?Prop = "\<lambda>P R. \<exists>Q. P \<cong> Q \<and> Q \<cong> R"
  from assms have "?Prop P R" by auto
  thus ?thesis
  proof(induct rule: weakCongISym)
    case(cSym P R)
    thus ?case by(auto dest: symmetric)
  next
    case(cSim P R)
    from `?Prop P R` obtain Q where "P \<cong> Q" and "Q \<cong> R"
      by auto
    from `P \<cong> Q` have "P \<leadsto><weakBisimulation> Q" by(rule weakCongruenceE)
    moreover from `Q \<cong> R` have "Q \<leadsto><weakBisimulation> R" by(rule weakCongruenceE)
    moreover from Weak_Bisim.transitive have "weakBisimulation O weakBisimulation \<subseteq> weakBisimulation"
      by auto
    ultimately show ?case using weakBisimulationE(1)
      by(rule Weak_Cong_Sim.transitive)
  qed
qed

lemma bisimWeakCongruence:
  fixes P :: ccs
  and   Q :: ccs

  assumes "P \<sim> Q"

  shows "P \<cong> Q"
using assms
proof(induct rule: weakCongISym)
  case(cSym P Q)
  thus ?case by(rule bisimE)
next
  case(cSim P Q)
  from `P \<sim> Q` have "P \<leadsto>[bisim] Q" by(rule bisimE)
  hence "P \<leadsto>[weakBisimulation] Q" using bisimWeakBisimulation
    by(rule_tac monotonic) auto
  thus ?case by(rule simWeakSim)
qed

lemma structCongWeakCongruence:
  fixes P :: ccs
  and   Q :: ccs

  assumes "P \<equiv>\<^sub>s Q"

  shows "P \<cong> Q"
using assms
by(auto intro: bisimWeakCongruence bisimStructCong)

lemma weakCongruenceWeakBisimulation:
  fixes P :: ccs
  and   Q :: ccs

  assumes "P \<cong> Q"

  shows "P \<approx> Q"
proof -
  let ?X = "{(P, Q) | P Q. P \<cong> Q}"
  from assms have "(P, Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimulationCoinduct)
    case(cSim P Q)
    from `(P, Q) \<in> ?X` have "P \<cong> Q" by auto
    hence "P \<leadsto><weakBisimulation> Q" by(rule Weak_Cong.weakCongruenceE)
    hence "P \<leadsto><(?X \<union> weakBisimulation)> Q" by(force intro: Weak_Cong_Sim.weakMonotonic)
    thus ?case by(rule weakCongSimWeakSim)
  next
    case(cSym P Q)
    from `(P, Q) \<in> ?X` show ?case by(blast dest: symmetric)
  qed
qed

end


subsection\<open>Logical and structural substitution\<close>

theory Substitution
  imports DeBruijn
begin

primrec
  subst_trm :: "[trm, trm, nat] \<Rightarrow> trm"  ("_[_'/_]\<^sup>T" [300, 0, 0] 300) and
  subst_cmd ::  "[cmd, trm, nat] \<Rightarrow> cmd" ("_[_'/_]\<^sup>C" [300, 0, 0] 300)
where
    subst_LVar: "(`i)[s/k]\<^sup>T =
          (if k < i then `(i-1) else if k = i then s else (`i))"
    | subst_Lbd: "(\<lambda> T : t)[s/k]\<^sup>T = \<lambda> T : (t[(liftL_trm s 0) / k+1]\<^sup>T)"
    | subst_App: "(t \<degree> u)[s/k]\<^sup>T = t[s/k]\<^sup>T \<degree> u[s/k]\<^sup>T"
    | subst_Mu: "(\<mu> T : c)[s/k]\<^sup>T  = \<mu> T : (c[(liftM_trm s 0) / k]\<^sup>C)"
    | subst_MVar: "(<i> t)[s/k]\<^sup>C = <i> (t[s/k]\<^sup>T)"

text\<open>Substituting a term for the hole in a context.\<close>

primrec ctxt_subst :: "ctxt \<Rightarrow> trm \<Rightarrow> trm" where
  "ctxt_subst \<diamond> s = s" |
  "ctxt_subst (E \<^sup>\<bullet> t) s = (ctxt_subst E s)\<degree> t"

lemma ctxt_app_subst:
  shows "ctxt_subst E (ctxt_subst F t) = ctxt_subst (E . F) t"
  by (induction E, auto)

text\<open>The structural substitution is based on Geuvers and al.~\cite{DBLP:journals/apal/GeuversKM13}.\<close>

primrec
  struct_subst_trm :: "[trm, nat, nat, ctxt] \<Rightarrow> trm"  ("_[_=_ _]\<^sup>T" [300, 0, 0, 0] 300) and
  struct_subst_cmd ::  "[cmd, nat, nat, ctxt] \<Rightarrow> cmd" ("_[_=_ _]\<^sup>C" [300, 0, 0, 0] 300)
where
  struct_LVar: "(`i)[j=k E]\<^sup>T = (`i)" |
  struct_Lbd: "(\<lambda> T : t)[j=k E]\<^sup>T = (\<lambda> T : (t[j=k (liftL_ctxt E 0)]\<^sup>T))" |
  struct_App: "(t\<degree>s)[j=k E]\<^sup>T = (t[j=k E]\<^sup>T)\<degree>(s[j=k E]\<^sup>T)" |
  struct_Mu: "(\<mu> T : c)[j=k E]\<^sup>T = \<mu> T : (c[(j+1)=(k+1) (liftM_ctxt E 0)]\<^sup>C)" |
  struct_MVar: "(<i> t)[j=k E]\<^sup>C =
      (if i=j then (<k> (ctxt_subst E (t[j=k E]\<^sup>T)))
       else (if j<i \<and> i\<le>k then (<i-1> (t[j=k E]\<^sup>T))
             else (if k\<le>i \<and> i<j then (<i+1> (t[j=k E]\<^sup>T))
                   else (<i> (t[j=k E]\<^sup>T)))))"

text\<open>Lifting of lambda and mu variables commute with each other\<close>

lemma liftLM_comm:
  "liftL_trm (liftM_trm t n) m = liftM_trm (liftL_trm t m) n"
  "liftL_cmd (liftM_cmd c n) m = liftM_cmd (liftL_cmd c m) n"
  by(induct t and c arbitrary: n m and n m) auto

lemma liftLM_comm_ctxt:
  "liftL_ctxt (liftM_ctxt E n) m = liftM_ctxt (liftL_ctxt E m) n"
  by(induct E arbitrary: n m, auto simp add: liftLM_comm)

text\<open>Lifting of $\mu$-variables (almost) commutes.\<close>

lemma liftMM_comm:
  "n\<ge>m \<Longrightarrow> liftM_trm (liftM_trm t n) m = liftM_trm (liftM_trm t m) (Suc n)"
  "n\<ge>m \<Longrightarrow> liftM_cmd (liftM_cmd c n) m = liftM_cmd (liftM_cmd c m) (Suc n)"
  by(induct t and c arbitrary: n m and n m) auto

lemma liftMM_comm_ctxt:
  "liftM_ctxt (liftM_ctxt E n) 0 = liftM_ctxt (liftM_ctxt E 0) (n+1)"
  by(induct E arbitrary: n, auto simp add: liftMM_comm)

text\<open>If a $\mu$ variable $i$ doesn't occur in a term or a context,
then these remain the same after structural substitution of variable $i$.\<close>

lemma liftM_struct_subst:
  "liftM_trm t i[i=i F]\<^sup>T = liftM_trm t i"
  "liftM_cmd c i[i=i F]\<^sup>C = liftM_cmd c i"
  by(induct t and c arbitrary: i F and i F) auto

lemma liftM_ctxt_struct_subst:
  "(ctxt_subst (liftM_ctxt E i) t)[i=i F]\<^sup>T = ctxt_subst (liftM_ctxt E i) (t[i=i F]\<^sup>T)"
  by(induct E arbitrary: i t F; force simp add: liftM_struct_subst)

end


(*
    File:        Lambda.thy
    Time-stamp:  <2016-01-03T14:03:42Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory Lambda imports LBeta begin

axiomatization where
  Infinite_LVariable: "Infinite(LVariable)"

definition LAQ :: "i=>i" where
"LAQ(M) == {N: LTerm. LAlpha(M, N)}"

definition Term :: "i" where
"Term == {LAQ(M). M: LTerm}"

definition Var :: "i=>i" where
"Var(x) == {LVar(x)}"

definition Lam :: "[i,i]=>i" where
"Lam(x, M) == {m': LTerm. M: Term & (EX m: M. LAlpha(m', LLam(x, m)))}"

definition App :: "[i,i]=>i" where
"App(M, N) == {m: LTerm. M: Term & N: Term &
                       (EX a b. a: M & b: N & m = LApp(a, b))}"

definition FV :: "i=>i" where
"FV(M) == INT m: M. LFV(m)"

definition subst :: "[i,i,i]=>i" where
"subst(M, x, N) == {m': LTerm. EX m n. m: M & n: N &
                     LFreeForIn(n, x, m) &
                     LAlpha(Lsubst(m, x, n), m')}"

definition Beta1 :: "[i,i]=>o" where
"Beta1(M, N) == M: Term & N: Term & (EX m: M. EX n: N. LBeta1(m, n))"

lemmas LAlpha_LLamE2 = Infinite_LVariable [THEN LAlpha_LLamE]
lemmas LAlpha_LTermEs2 = LAlpha_LVarE LAlpha_LLamE2
                         LAlpha_LAppE

 (** LAQ: LAlpha-quotient **)
lemma LAQ_I:
  "LAlpha(M, N) ==> N: LAQ(M)"
apply (unfold LAQ_def)
apply (blast dest: LAlphaD1 [THEN LSkeltonEqD2])
done

lemma LAQ_D:
  "N: LAQ(M) ==> LAlpha(M, N)"
apply (unfold LAQ_def)
apply blast
done

lemma LAQ_self:
  "M: LTerm ==> M: LAQ(M)"
apply (rule LAQ_I)
apply (erule LAlpha_refl)
done

lemma LAQ_eqI:
  "LAlpha(M, N) ==> LAQ(M) = LAQ(N)"
apply (rule equalityI)
apply (safe dest!: LAQ_D intro!: LAQ_I)
apply (erule LAlpha_sym [THEN LAlpha_trans])
apply assumption
apply (erule LAlpha_trans)
apply assumption
done

lemma LAQ_eqD:
  "[| LAQ(M) = LAQ(N); M: LTerm |] ==> LAlpha(M, N)"
apply (erule equalityE)
apply (drule subsetD, erule LAQ_self)
apply (erule LAQ_D [THEN LAlpha_sym])
done

(** Term **)
lemma TermI:
  "[| m: LTerm; M = LAQ(m) |] ==> M: Term"
apply (unfold Term_def)
apply blast
done

lemma LAQ_type:
  "m: LTerm ==> LAQ(m): Term"
apply (assumption | rule TermI refl)+
done

lemma TermE:
  "[| M: Term;
      !! m. [| M = LAQ(m); m: LTerm |] ==> R
   |] ==> R"
apply (unfold Term_def)
apply blast
done

lemma Term_LFreeForInE:
  assumes major: "M: Term"
  and prem1: "x: LVariable"
  and prem2: "n: LTerm"
  and prem3: "!!m. [| M = LAQ(m); m: LTerm; LFreeForIn(n, x, m) |] ==> R"
  shows "R"
apply (rule major [THEN TermE])
apply (rule Infinite_LVariable [THEN Infinite_LVariable_LAlpha_lemma,
         THEN bexE])
apply (rule_tac [2] prem1)
apply (rule_tac [2] prem2)
apply assumption
apply (rule prem3)
apply (safe dest!: LAQ_eqI)
apply assumption+
done

lemma Term_LFreeForInE2:
  assumes major: "M: Term"
  and prem1: "x: LVariable"
  and prem2: "X: Fin(LTerm)"
  and prem3:
     "!!m. [| M = LAQ(m); m: LTerm; ALL n: X. LFreeForIn(n, x, m) |]
            ==> R"
  shows "R"
apply (rule major [THEN TermE])
apply (rule Infinite_LVariable [THEN Infinite_LVariable_LAlpha_lemma2,
         THEN bexE])
apply (rule_tac [2] prem1)
apply (rule_tac [2] prem2)
apply assumption
apply (rule prem3)
apply (safe dest!: LAQ_eqI)
apply (erule_tac [3] bspec)
apply assumption+
done

lemma LAQ_LVar:
  "x: LVariable ==> LAQ(LVar(x)) = Var(x)"
apply (unfold Var_def)
apply (blast intro: LAlpha_LVarI dest!: LAQ_D intro!: LAQ_I
         elim!: LAlpha_LTermEs2)
done

lemma LAQ_LLam:
  "[| x: LVariable; m: LTerm |] ==> LAQ(LLam(x, m)) = Lam(x, LAQ(m))"
apply (unfold Lam_def)
apply (rule equalityI)
apply (safe dest!: LAQ_D intro!: LAQ_type LAQ_I
         elim!: TermE LAlpha_LTermEs2)
apply (erule LAlphaD1 [THEN LSkeltonEqD2])
apply (erule_tac [3] LAlphaD1 [THEN LSkeltonEqD1])
apply (drule_tac [2] LFreeForInD1)
apply (erule_tac [2] LTerm_typeEs)
prefer 2 apply assumption
apply (rule bexI)
apply (assumption | rule LAQ_self LAlpha_sym [THEN LAlpha_LLamI1])+
apply (drule LAlpha_LLamI2)
apply (rule_tac [3] bexI)
apply (assumption | rule LAQ_I)+
apply (rule LAlpha_trans)
apply (erule_tac [2] LAlpha_sym)
apply (erule LAlpha_LLamI1)
apply assumption
done

lemma LAQ_LApp:
  "[| m: LTerm; n: LTerm |] ==> LAQ(LApp(m, n)) = App(LAQ(m), LAQ(n))"
apply (unfold App_def)
apply (blast dest!: LAQ_D intro: LAlpha_LTermIs elim!: TermE
         intro: LAlphaD1 [THEN LSkeltonEqD1]
                LAlphaD1 [THEN LSkeltonEqD2]
         intro!: LAQ_I LAQ_type elim!: LAlpha_LTermEs2)
done

lemmas Term_LAQ_sym = LAQ_LVar LAQ_LLam LAQ_LApp
lemmas Term_LAQ = Term_LAQ_sym [THEN sym]

lemma Term_VarI:
  assumes major: "x: LVariable"
  shows "Var(x): Term"
apply (rule major [THEN LAQ_LVar, THEN subst])
apply (rule TermI)
apply (rule_tac [2] refl)
apply (assumption | rule LTerm.intros major)+
done

lemma Term_LamI:
  assumes prem1: "x: LVariable"
  and prem2: "M: Term"
  shows "Lam(x, M): Term"
apply (rule prem2 [THEN TermE])
apply hypsubst
apply (rule prem1 [THEN LAQ_LLam, THEN subst])
apply assumption
apply (rule TermI)
apply (rule_tac [2] refl)
apply (assumption | rule prem1 LTerm.intros)+
done

lemma Term_AppI:
  assumes prem1: "M: Term"
  and prem2: "N: Term"
  shows "App(M, N): Term"
apply (rule prem1 [THEN TermE])
apply (rule prem2 [THEN TermE])
apply hypsubst
apply (rule LAQ_LApp [THEN subst])
apply (rule_tac [3] TermI)
apply (rule_tac [4] refl)
apply (assumption | rule LTerm.intros)+
done

lemmas Term_intros = Term_VarI Term_LamI Term_AppI

lemma Term_VarD:
  "Var(x): Term ==> x: LVariable"
apply (unfold Var_def)
apply (erule TermE)
apply (drule equalityD1)
apply (drule singletonI [THEN [2] subsetD])
apply (drule LAQ_D)
apply (erule LAlpha_sym [THEN LAlpha_LVarE])
apply assumption
done

lemma Term_LamE:
  assumes major: "Lam(x, M): Term"
  and prem: "[| x: LVariable; M: Term |] ==> R"
  shows "R"
apply (rule major [unfolded Lam_def, THEN TermE])
apply (rule prem)
apply (drule_tac [2] equalityD2)
apply (drule_tac [2] LAQ_self [THEN [2] subsetD])
apply (drule equalityD2)
apply (drule_tac LAQ_self [THEN [2] subsetD])
apply safe
apply (drule LAlphaD1 [THEN LSkeltonEqD2])
apply (erule LTerm_typeEs)
apply assumption
done

lemma Term_AppE:
  assumes major: "App(M, N): Term"
  and prem: "[| M: Term; N: Term |] ==> R"
  shows "R"
apply (rule major [unfolded App_def, THEN TermE])
apply (drule equalityD2)
apply (drule LAQ_self [THEN [2] subsetD])
apply (rule_tac [2] prem)
apply safe
done

lemmas Term_typeEs = Term_VarD [elim_format] Term_LamE Term_AppE

lemma Term_cases:
  assumes major: "M: Term"
  and prem1:
      "!! x. [| x: LVariable; M = Var(x) |] ==> R"
  and prem2:
      "!! x N. [| x: LVariable; N: Term; M = Lam(x, N) |] ==> R"
  and prem3:
      "!! A B. [| A: Term; B: Term; M = App(A, B) |] ==> R"
  shows "R"
apply (rule major [THEN TermE])
apply (erule LTerm.cases)
apply (rule_tac [3] prem3)
apply (rule_tac [2] prem2)
apply (rule_tac [1] prem1)
prefer 8
apply hypsubst
apply (rule Term_LAQ_sym)
prefer 7
apply hypsubst
apply (rule Term_LAQ_sym)
prefer 6
apply hypsubst
apply (rule Term_LAQ_sym)
apply (assumption | rule LAQ_type)+
done

lemma Term_induct:
  assumes major: "M: Term"
  and "!! x. x: LVariable ==> P(Var(x))"
  and "!! x N. [| x: LVariable; N: Term; P(N) |] ==> P(Lam(x, N))"
  and "!! A B. [| A: Term; P(A); B: Term; P(B) |] ==> P(App(A, B))"
  shows "P(M)"
apply (rule major [THEN TermE])
apply (erule rev_mp)
apply (rule_tac x="M" in spec)
apply (erule LTerm.induct)
apply safe
apply (simp_all add: Term_LAQ_sym)
apply (assumption | rule LAQ_type assms)+
done

(** FV **)
lemma FV_LAQ:
  assumes major: "m: LTerm"
  shows "FV(LAQ(m)) = LFV(m)"
apply (unfold FV_def)
apply (rule equalityI)
apply (safe elim!: LFV_E LAQ_D [elim_format] intro!: LAQ_I)
apply (drule_tac [3] equals0D)
apply (erule_tac [3] notE)
apply (rule_tac [3] RepFunI)
apply (rule_tac [3] major [THEN LAQ_self])
apply (rule_tac [2] LFV_I)
apply (erule_tac [2] LAlphaD2)
apply (erule_tac [2] asm_rl)
apply (erule INT_E)
apply (rule major [THEN LAQ_self])
done

lemma FV_Var:
  "x: LVariable ==> FV(Var(x)) = {x}"
apply (simp add: Term_LAQ FV_LAQ)
done

lemma FV_Lam:
  assumes prem1: "x: LVariable"
  and prem2: "M: Term"
  shows "FV(Lam(x, M)) = FV(M) - {x}"
apply (rule prem2 [THEN TermE])
apply (insert prem1)
apply (simp add: Term_LAQ FV_LAQ)
done

lemma FV_App:
  assumes prem1: "M: Term"
  and prem2: "N: Term"
  shows "FV(App(M, N)) = FV(M) Un FV(N)"
apply (rule prem1 [THEN TermE])
apply (rule prem2 [THEN TermE])
apply (simp add: Term_LAQ FV_LAQ)
done

lemmas FV_eqns = FV_Var FV_App FV_Lam

(** subst **)
lemma subst_LAQ:
  assumes major: "LFreeForIn(n, x, m)"
  shows "subst(LAQ(m), x, LAQ(n)) = LAQ(Lsubst(m, x, n))"
apply (unfold subst_def)
apply (insert major [THEN LFreeForInD1] major [THEN LFreeForInD2]
              major [THEN LFreeForInD3])
apply (insert major)
apply (rule equalityI)
apply (safe elim!: LAlpha_LTermEs2 LTerm.free_elims
         dest!: LAQ_D intro!: LAQ_I)
apply (rule LAlpha_trans)
prefer 2 apply assumption
apply (assumption | rule LAlpha_LsubstI)+
apply (erule LAlphaD1 [THEN LSkeltonEqD2])
apply (assumption | rule exI LAQ_self conjI)+
done

lemma subst_type:
  assumes prem1: "M: Term"
  and prem2: "x: LVariable"
  and prem3: "N: Term"
  shows "subst(M, x, N): Term"
apply (rule prem3 [THEN TermE])
apply (rule Term_LFreeForInE [OF prem1 prem2])
apply assumption
apply (simp add: subst_LAQ)
apply (assumption | rule LAQ_type Lsubst_type prem2)+
done

lemma subst_Var1:
  assumes prem1: "x: LVariable"
  and prem2: "N: Term"
  shows "subst(Var(x), x, N) = N"
apply (insert prem1)
apply (rule prem2 [THEN TermE])
apply (simp add: Term_LAQ)
apply (rule subst_LAQ [THEN trans])
apply (assumption | rule LFreeForIn_LTermIs)+
apply simp
done

lemma subst_Var2:
  assumes prem1: "x ~= y"
  and prem2: "y: LVariable"
  and prem3: "x: LVariable"
  and prem4: "N: Term"
  shows "subst(Var(y), x, N) = Var(y)"
apply (insert prem1 prem2 prem3)
apply (rule prem4 [THEN TermE])
apply (simp add: Term_LAQ)
apply (rule subst_LAQ [THEN trans])
apply (assumption | rule LFreeForIn_LTermIs)+
apply simp
done

lemma subst_Lam1:
  assumes prem1: "x: LVariable"
  and prem2: "M: Term"
  and prem3: "N: Term"
  shows "subst(Lam(x, M), x, N) = Lam(x, M)"
apply (rule prem3 [THEN TermE])
apply (rule prem2 [THEN TermE])
apply (insert prem1)
apply (simp add: Term_LAQ)
apply (rule subst_LAQ [THEN trans])
apply (rule LFreeForIn_LLamI1)
prefer 4 apply simp
apply assumption+
done

lemma subst_Lam2:
  assumes prem0: "x: LVariable"
  and prem1: "y: LVariable"
  and prem2: "M: Term"
  and prem3: "N: Term"
  and prem4: "y ~= x"
  and prem5: "x ~: FV(N)"
  shows "subst(Lam(x, M), y, N) = Lam(x, subst(M, y, N))"
apply (rule prem3 [THEN TermE])
apply (rule Term_LFreeForInE [OF prem2 prem1])
apply assumption
apply (insert prem0 prem1 prem4 prem5)
apply (simp add: Term_LAQ subst_LAQ FV_LAQ)
apply (rule subst_LAQ [THEN trans])
prefer 2 apply simp
apply (rule LFreeForIn_LLamI2)
prefer 3 apply blast
apply assumption+
done

lemma subst_App:
  assumes prem1: "A: Term"
  and prem2: "B: Term"
  and prem3: "x: LVariable"
  and prem4: "N: Term"
  shows "subst(App(A, B), x, N) = App(subst(A, x, N), subst(B, x, N))"
apply (rule prem4 [THEN TermE])
apply (rule Term_LFreeForInE [OF prem1 prem3])
apply assumption
apply (rule Term_LFreeForInE [OF prem2 prem3])
apply assumption
apply (simp add: Term_LAQ LFreeForIn_LAppI subst_LAQ)
done

lemma subst_self:
  assumes prem1: "M: Term"
  and prem2: "x: LVariable"
  shows "subst(M, x, Var(x)) = M"
apply (rule_tac n="LVar(x)" in Term_LFreeForInE [OF prem1 prem2])
apply (rule LTerm.intros prem2)+
apply (insert prem2)
apply (simp add: Term_LAQ subst_LAQ Lsubst_self)
done

lemma subst_lemma2:
  assumes prem1: "M: Term"
  and prem2: "N: Term"
  and prem3: "x: LVariable"
  and prem4: "y: LVariable"
  and prem5: "y ~: FV(M)"
  shows "subst(subst(M, x, Var(y)), y, N) = subst(M, x, N)"
apply (rule prem2 [THEN TermE])
apply (rule_tac X="{LVar(y), m}" in Term_LFreeForInE2 [OF prem1 prem3])
apply (assumption | rule prem4 LTerm.intros Fin.intros)+
apply (insert prem3 prem4 prem5)
apply (simp add: Term_LAQ subst_LAQ FV_LAQ)
apply (erule conjE)
apply (rule subst_LAQ [THEN trans])
apply (assumption | rule LFreeForIn_name_change)+
apply (simp add: Lsubst_lemma2)
done

lemmas subst_eqns = subst_Var1 subst_Var2 subst_App subst_Lam1
                  subst_Lam2 subst_self subst_lemma2

(** Term.free_iffs **)
lemma Var_iff:
  "Var(x) = Var(y) <-> x = y"
apply (unfold Var_def)
apply (simp only: singleton_iff2)
apply (blast elim!: LTerm.free_elims)
done

lemma App_eqD:
  assumes major: "App(A, B) = App(A', B')"
  and prem1: "A: Term"
  and prem2: "B: Term"
  shows "A = A' & B = B'"
apply (insert prem1 prem2)
apply (subgoal_tac "App(A', B'): Term")
apply (rule_tac [2] major [THEN subst])
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_AppE)
apply (erule TermE)+
apply (insert major)
apply hypsubst
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LAlpha_LTermEs2 LTerm.free_elims)
apply (erule LAQ_eqI)+
done

lemma App_iff:
  "[| A: Term; B: Term |] ==>
       App(A, B) = App(A', B') <-> A = A' & B = B'"
apply (rule iffI)
apply (erule App_eqD)
apply assumption+
apply blast
done

lemma Lam_eqD:
  assumes major: "Lam(x, M) = Lam(y, M')"
  and prem1: "x: LVariable"
  and prem2: "M: Term"
  and prem3: "y: LVariable"
  and prem4: "M': Term"
  shows "M = subst(M', y, Var(x)) & x ~: FV(M') - {y}"
apply (rule prem2 [THEN TermE])
apply (rule_tac n="LVar(x)" in Term_LFreeForInE [OF prem4 prem3])
apply (rule prem1 LTerm.intros)+
apply (insert prem1 prem3 major)
apply (simp only: Term_LAQ subst_LAQ FV_LAQ)
apply (drule LAQ_eqD [THEN LAlpha_sym])
apply (safe elim!: LAlpha_LTermEs2 LTerm.free_elims)
apply (erule_tac [3] LFV_E)
apply (erule_tac [3] swap)
apply (drule_tac [3] LAlphaD2, erule_tac [3] asm_rl)
apply (erule_tac [3] LFV_I)
apply (rule_tac [2] LAQ_eqI)
apply (rule LAQ_eqI)
apply (simp add: Lsubst_self)
apply (erule LAlpha_sym)
apply (erule LAlpha_trans)
apply (rule LAlpha_LsubstI)
apply (erule LAlpha_sym)
apply (assumption | rule LAlpha_LVarI)+
done

lemma Alpha:
  assumes prem1: "M: Term"
  and prem2: "x: LVariable"
  and prem3: "y: LVariable"
  and prem4: "x ~: FV(M) - {y}"
  shows "Lam(y, M) = Lam(x, subst(M, y, Var(x)))"
apply (rule_tac n="LVar(x)" in Term_LFreeForInE [OF prem1 prem3])
apply (rule prem2 LTerm.intros)+
apply (insert prem2 prem3 prem4)
apply (simp add: Term_LAQ subst_LAQ FV_LAQ)
apply (rule LAQ_eqI)
apply (erule disjE)
prefer 2
apply hypsubst
apply (simp add: Lsubst_self)
apply (rule_tac [2] LAlpha_LLamI3)
apply (assumption | rule LAlpha_refl LTerm.intros)+
done

lemma Lam_iff:
  "[| M: Term; N: Term; x: LVariable; y: LVariable |] ==>
     Lam(x, M) = Lam(y, N) <-> M = subst(N, y, Var(x)) & x ~: FV(N) - {y}"
apply (rule iffI)
apply (erule Lam_eqD)
apply assumption+
apply (erule conjE)
apply hypsubst
apply (rule Alpha [THEN sym])
apply assumption+
done

lemma Var_Lam_free_iff:
  "x: LVariable ==> Var(x) = Lam(y, M) <-> False"
apply safe
apply (subgoal_tac "Lam(y, M): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemma Var_App_free_iff:
  "x: LVariable ==> Var(x) = App(M, N) <-> False"
apply safe
apply (subgoal_tac "App(M, N): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemma Lam_Var_free_iff:
  "[| x: LVariable; M: Term |] ==> Lam(x, M) = Var(y) <-> False"
apply safe
apply (subgoal_tac "Var(y): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemma Lam_App_free_iff:
  "[| x: LVariable; M: Term |] ==> Lam(x, M) = App(A, B) <-> False"
apply safe
apply (subgoal_tac "App(A, B): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemma App_Var_free_iff:
  "[| M: Term; N: Term |] ==> App(M, N) = Var(y) <-> False"
apply safe
apply (subgoal_tac "Var(y): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemma App_Lam_free_iff:
  "[| A: Term; B: Term |] ==> App(A, B) = Lam(x, M) <-> False"
apply safe
apply (subgoal_tac "Lam(x, M): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemmas Term_free_iffs = Var_iff App_iff Lam_iff
  Var_Lam_free_iff Var_App_free_iff
  Lam_Var_free_iff Lam_App_free_iff
  App_Var_free_iff App_Lam_free_iff

(** Beta1 **)
lemma Beta1D1:
  "Beta1(M, N) ==> M: Term"
apply (unfold Beta1_def)
apply (erule conjunct1)
done

lemma Beta1D2:
  "Beta1(M, N) ==> N: Term"
apply (unfold Beta1_def)
apply (erule conjunct2 [THEN conjunct1])
done

lemma Beta1_baseI:
  assumes prem1: "M: Term"
  and prem2: "x: LVariable"
  and prem3: "N: Term"
  shows "Beta1(App(Lam(x, M), N), subst(M, x, N))"
apply (unfold Beta1_def)
apply (assumption | rule Term_intros prem1 prem2 prem3 conjI subst_type)+
apply (rule prem3 [THEN TermE])
apply (rule Term_LFreeForInE [OF prem1 prem2])
apply assumption
apply (insert prem2)
apply (simp add: Term_LAQ subst_LAQ)
apply (assumption | rule LTerm.intros bexI LBeta1_baseI
        LAQ_self Lsubst_type)+
done

lemma Beta1_LamI:
  "[| Beta1(M, M'); x: LVariable |]  ==>
        Beta1(Lam(x, M), Lam(x, M'))"
apply (unfold Beta1_def)
apply (safe intro!: Term_intros)
apply (erule TermE)+
apply hypsubst
apply (simp add: Term_LAQ)
apply (drule LAQ_D)+
apply (rule bexI)
apply (rule bexI)
apply (rule LBeta1_LLamI)
apply (assumption | rule LAQ_I LAlpha_LLamI1)+
done

lemma Beta1_AppI1:
  "[| Beta1(M, M'); N: Term |]  ==>
        Beta1(App(M, N), App(M', N))"
apply (unfold Beta1_def)
apply (safe intro!: Term_intros)
apply (erule TermE)+
apply hypsubst
apply (simp add: Term_LAQ)
apply (drule LAQ_D)+
apply (rule bexI)
apply (rule bexI)
apply (rule LBeta1_LAppI1)
apply (assumption | rule LAQ_I LAlpha_LAppI LAlpha_refl)+
done

lemma Beta1_AppI2:
  "[| Beta1(N, N'); M: Term |]  ==>
        Beta1(App(M, N), App(M, N'))"
apply (unfold Beta1_def)
apply (safe intro!: Term_intros)
apply (erule TermE)+
apply hypsubst
apply (simp add: Term_LAQ)
apply (drule LAQ_D)+
apply (rule bexI)
apply (rule bexI)
apply (rule LBeta1_LAppI2)
apply (assumption | rule LAQ_I LAlpha_LAppI LAlpha_refl)+
done

lemma Beta1_VarE:
  "Beta1(Var(x), N) ==> R"
apply (unfold Beta1_def)
apply (safe elim!: Term_typeEs)
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (safe dest!: LAQ_D elim!: LAlpha_LTermEs2 LBeta1_LTermEs)
done

lemma Beta1_LamE1:
  assumes major: "Beta1(Lam(x, M), N)"
  and prem1:
     "!!N'. [| x: LVariable; N = Lam(x, N'); Beta1(M, N')|]
         ==> R"
  and prem2:
     "!!y N'. [| x: LVariable; y: LVariable; M: Term; N': Term; y ~: FV(M);
          N = Lam(y, N'); Beta1(subst(M, x, Var(y)), N')|]
         ==> R"
  shows "R"
apply (insert major)
apply (unfold Beta1_def)
apply (erule Term_typeEs conjE bexE TermE)+
apply (rotate_tac 3)
apply (simp only: Term_LAQ)
apply (drule LAQ_D)+
apply (erule LAlpha_LTermEs2)
apply hypsubst
apply (erule_tac LBeta1_LTermEs)
apply hypsubst
prefer 2
apply hypsubst
apply (erule_tac LBeta1_LTermEs)
apply hypsubst
prefer 2
apply (rule_tac [2] y="y" and N'="LAQ(N'a)" in prem2)
apply (rule_tac N'="LAQ(N'a)" in prem1)
apply (unfold Beta1_def)
apply (safe intro!: subst_type LAQ_type Term_intros)
prefer 2
prefer 4
prefer 7
apply (erule LBeta1_type2)+
apply (drule_tac [5] M="ma" in LAQ_eqI)
apply (simp_all add: Term_LAQ FV_LAQ LBeta1_type2 subst_LAQ)
apply (erule LAQ_eqI)
apply (erule_tac [3] LAQ_eqI)
apply (erule_tac [2] LFV_E)
apply (drule_tac [2] LAlphaD2, erule_tac [2] asm_rl)
apply (erule_tac [2] notE, erule_tac [2] LFV_I)
apply (assumption | rule bexI LAQ_self LAQ_I
       | erule LBeta1_type2 | erule LAlpha_sym)+
done

lemma Beta1_AppE1:
  assumes major: "Beta1(App(A, B), N)"
  and prem1:
     "!!x N'. [| x: LVariable; N': Term; B: Term;
         A = Lam(x, N'); N = subst(N', x, B) |] ==> R"
  and prem2:
     "!!A'. [| N = App(A',B); Beta1(A, A'); B: Term |] ==> R"
  and prem3:
     "!!B'. [| N = App(A, B'); Beta1(B, B'); A: Term |] ==> R"
  shows "R"
apply (insert major)
apply (unfold Beta1_def)
apply (erule Term_typeEs conjE bexE TermE)+
apply (rotate_tac 3)
apply (simp only: Term_LAQ)
apply (drule LAQ_D)+
apply (erule_tac LAlpha_LTermEs2)
apply hypsubst
apply (erule_tac LBeta1_LTermEs)
prefer 3
apply hypsubst
apply (drule LAQ_eqI)+
prefer 3
apply hypsubst
apply (drule LAQ_eqI)+
prefer 3
apply hypsubst
apply (drule LAQ_eqI)+
apply (rule_tac [3] B'="LAQ(B')" in prem3)
apply (rule_tac [2] A'="LAQ(A')" in prem2)
apply (rule_tac x="x" and N'="LAQ(N')" in prem1)
apply (unfold Beta1_def)
apply (safe intro!: subst_type LAQ_type Term_intros)
prefer 6
prefer 9
apply (erule LBeta1_type2)+
apply (erule LFreeForInD2)
apply (erule LFreeForInD3)
apply (simp_all add: Term_LAQ FV_LAQ LBeta1_type2
         LFreeForInD2 LFreeForInD3 subst_LAQ)
apply (assumption | rule bexI LAQ_self LAQ_I
       | erule LBeta1_type2 LBeta1_type1 LAlpha_sym)+
done

lemma Beta1_substI:
  assumes major: "Beta1(M, M')"
  and prem1: "x: LVariable"
  and prem2: "N: Term"
  shows "Beta1(subst(M, x, N), subst(M', x, N))"
apply (unfold Beta1_def)
apply (rule prem2 [THEN TermE])
apply (rule Term_LFreeForInE [OF
        major [unfolded Beta1_def, THEN conjunct1] prem1])
apply assumption
apply (rule_tac n="m" in Term_LFreeForInE [OF
        major [unfolded Beta1_def, THEN conjunct2, THEN conjunct1] prem1])
apply assumption
apply (insert major [unfolded Beta1_def, THEN conjunct2, THEN conjunct2])
apply (erule bexE)+
apply (simp only: subst_LAQ)
apply (assumption | rule LAQ_type Lsubst_type conjI)+
apply (drule_tac X="m" in
        Infinite_LVariable [THEN LBeta1_LAlpha_parallel])
apply (erule LFreeForInD2)
apply assumption
apply (safe dest!: LAQ_D)
apply (rule bexI [THEN bexI])
apply (erule LBeta1_LsubstI)
apply assumption+
apply (assumption | rule LAQ_I LAlpha_LsubstI LAlpha_refl
       | erule LAlpha_trans)+
done

lemma Beta1_FV_lemma:
  assumes major: "Beta1(M, N)"
  shows "FV(N) <= FV(M)"
apply (rule major [unfolded Beta1_def, THEN conjunct1, THEN TermE])
apply (rule major [unfolded Beta1_def, THEN conjunct2,
                   THEN conjunct1, THEN TermE])
apply (insert major)
apply (unfold Beta1_def)
apply (erule bexE conjE)+
apply hypsubst
apply (drule LAQ_D [THEN LAQ_eqI])+
apply (simp only: FV_LAQ LBeta1_type1 LBeta1_type2)
apply (erule LBeta1_LFV_lemma)
done

lemma FV_subst_not_in_lemma:
  assumes prem1: "M: Term"
  and prem2: "x: LVariable"
  and prem3: "N: Term"
  shows "x ~: FV(subst(M, x, N)) - FV(N)"
apply (insert prem2)
apply (rule prem3 [THEN TermE])
apply (rule Term_LFreeForInE [OF prem1 prem2])
apply assumption
apply (simp add: FV_LAQ subst_LAQ)
apply (safe intro!: Lsubst_type elim!: LFV_E LFreeIn_LsubstE)
apply (erule notE, erule LFV_I)
done

lemma Beta1_LamE:
  assumes major: "Beta1(Lam(x, M), N)"
  and prem:
     "!!N'. [| x: LVariable; N = Lam(x, N'); Beta1(M, N')|]
         ==> R"
  shows "R"
apply (rule major [THEN Beta1_LamE1])
apply (frule_tac [2] Beta1_FV_lemma)
apply (rule_tac [2] M1="M" and x1="x" and N1="Var(y)" in
         FV_subst_not_in_lemma [THEN revcut_rl])
prefer 5
apply (simp add: FV_eqns)
defer 1
apply (erule_tac [5] disjE)
apply (drule_tac [5] x="y" and N="Var(x)" in Beta1_substI)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (frule_tac [2] Term_VarI)
apply (rotate_tac [2] 9)
prefer 2
apply (simp add: subst_lemma2 subst_self)
prefer 2
apply (rotate_tac [3] 7)
prefer 3
apply (simp add: subst_self)
defer 1
apply (rule_tac [3] prem)
apply (rule_tac [2] prem)
apply (rule_tac [1] prem)
prefer 6
prefer 9
apply assumption+
apply safe
apply (rule Alpha)
prefer 4 apply blast
apply assumption+
done

lemma Fin_FV_I:
  "M: Term ==> FV(M): Fin(LVariable)"
apply (erule TermE)
apply hypsubst
apply (simp only: FV_LAQ)
apply (erule LFV_Fin)
done

lemma Infinite_LVariable_Alpha_lemma2:
  assumes major: "M: Term"
  and prem1: "x: LVariable"
  and prem2: "X: Fin(LVariable)"
  shows "EX y: LVariable. EX M': Term. Lam(x, M) = Lam(y, M') & y ~: X"
apply (rule_tac F="X Un FV(M)" in Infinite_LVariable [THEN InfiniteE])
apply (assumption | rule Fin_UnI Fin_FV_I prem2 major bexI conjI)+
apply (rule Alpha)
prefer 2 apply assumption
prefer 3 apply blast
prefer 3 apply blast
apply (assumption | rule major prem1 subst_type Term_intros)+
done

lemma Beta1_AppE:
  assumes major: "Beta1(App(A, B), N)"
  and prem1:
     "!!x N'. [| x: LVariable; N': Term; B: Term; x ~: FV(B);
         A = Lam(x, N'); N = subst(N', x, B) |] ==> R"
  and prem2:
     "!!A'. [| B: Term; Beta1(A, A'); N = App(A', B) |] ==> R"
  and prem3:
     "!!B'. [| A: Term; Beta1(B, B'); N = App(A, B') |] ==> R"
  shows "R"
apply (rule major [THEN Beta1_AppE1])
apply (rule_tac M1="N'" and X1="cons(x, FV(B))" in
         Infinite_LVariable_Alpha_lemma2 [THEN revcut_rl])
apply (assumption | rule Fin_FV_I Fin.intros)+
apply (erule Term_typeEs conjE bexE)+
apply (subgoal_tac "y ~= x")
prefer 2 apply blast
apply (erule swap, rule consI2)
apply (erule swap)
apply (erule swap)
apply (rotate_tac 7)
apply simp
apply (rule prem1)
prefer 5 apply assumption
apply assumption+
apply (rotate_tac 1)
apply (simp add: Term_free_iffs)
apply (elim conjE disjE)
apply (simp add: subst_lemma2)
apply (simp add: subst_lemma2)
apply (rule prem2)
apply (rule_tac [4] prem3)
apply assumption+
done

lemmas Beta1_TermEs = Beta1_VarE Beta1_LamE Beta1_AppE

end


(*  Title:      ZF/Induct/Tree_Forest.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section {* Trees and forests, a mutually recursive type definition *}

theory Tree_Forest imports Main begin

subsection {* Datatype definition *}

consts
  tree :: "i => i"
  forest :: "i => i"
  tree_forest :: "i => i"

datatype "tree(A)" = Tcons ("a \<in> A", "f \<in> forest(A)")
  and "forest(A)" = Fnil | Fcons ("t \<in> tree(A)", "f \<in> forest(A)")

(* FIXME *)
lemmas tree'induct =
    tree_forest.mutual_induct [THEN conjunct1, THEN spec, THEN [2] rev_mp, of concl: _ t, consumes 1]
  and forest'induct =
    tree_forest.mutual_induct [THEN conjunct2, THEN spec, THEN [2] rev_mp, of concl: _ f, consumes 1]
  for t

declare tree_forest.intros [simp, TC]

lemma tree_def: "tree(A) == Part(tree_forest(A), Inl)"
  by (simp only: tree_forest.defs)

lemma forest_def: "forest(A) == Part(tree_forest(A), Inr)"
  by (simp only: tree_forest.defs)

text {*
  \medskip @{term "tree_forest(A)"} as the union of @{term "tree(A)"}
  and @{term "forest(A)"}.
*}

lemma tree_subset_TF: "tree(A) \<subseteq> tree_forest(A)"
  apply (unfold tree_forest.defs)
  apply (rule Part_subset)
  done

lemma treeI [TC]: "x \<in> tree(A) ==> x \<in> tree_forest(A)"
  by (rule tree_subset_TF [THEN subsetD])

lemma forest_subset_TF: "forest(A) \<subseteq> tree_forest(A)"
  apply (unfold tree_forest.defs)
  apply (rule Part_subset)
  done

lemma treeI' [TC]: "x \<in> forest(A) ==> x \<in> tree_forest(A)"
  by (rule forest_subset_TF [THEN subsetD])

lemma TF_equals_Un: "tree(A) \<union> forest(A) = tree_forest(A)"
  apply (insert tree_subset_TF forest_subset_TF)
  apply (auto intro!: equalityI tree_forest.intros elim: tree_forest.cases)
  done

lemma
  notes rews = tree_forest.con_defs tree_def forest_def
  shows
    tree_forest_unfold: "tree_forest(A) =
      (A \<times> forest(A)) + ({0} + tree(A) \<times> forest(A))"
    -- {* NOT useful, but interesting \dots *}
  apply (unfold tree_def forest_def)
  apply (fast intro!: tree_forest.intros [unfolded rews, THEN PartD1]
    elim: tree_forest.cases [unfolded rews])
  done

lemma tree_forest_unfold':
  "tree_forest(A) =
    A \<times> Part(tree_forest(A), \<lambda>w. Inr(w)) +
    {0} + Part(tree_forest(A), \<lambda>w. Inl(w)) * Part(tree_forest(A), \<lambda>w. Inr(w))"
  by (rule tree_forest_unfold [unfolded tree_def forest_def])

lemma tree_unfold: "tree(A) = {Inl(x). x \<in> A \<times> forest(A)}"
  apply (unfold tree_def forest_def)
  apply (rule Part_Inl [THEN subst])
  apply (rule tree_forest_unfold' [THEN subst_context])
  done

lemma forest_unfold: "forest(A) = {Inr(x). x \<in> {0} + tree(A)*forest(A)}"
  apply (unfold tree_def forest_def)
  apply (rule Part_Inr [THEN subst])
  apply (rule tree_forest_unfold' [THEN subst_context])
  done

text {*
  \medskip Type checking for recursor: Not needed; possibly interesting?
*}

lemma TF_rec_type:
  "[| z \<in> tree_forest(A);
      !!x f r. [| x \<in> A;  f \<in> forest(A);  r \<in> C(f)
                |] ==> b(x,f,r) \<in> C(Tcons(x,f));
      c \<in> C(Fnil);
      !!t f r1 r2. [| t \<in> tree(A);  f \<in> forest(A);  r1 \<in> C(t); r2 \<in> C(f)
                    |] ==> d(t,f,r1,r2) \<in> C(Fcons(t,f))
   |] ==> tree_forest_rec(b,c,d,z) \<in> C(z)"
  by (induct_tac z) simp_all

lemma tree_forest_rec_type:
  "[| !!x f r. [| x \<in> A;  f \<in> forest(A);  r \<in> D(f)
                |] ==> b(x,f,r) \<in> C(Tcons(x,f));
      c \<in> D(Fnil);
      !!t f r1 r2. [| t \<in> tree(A);  f \<in> forest(A);  r1 \<in> C(t); r2 \<in> D(f)
                    |] ==> d(t,f,r1,r2) \<in> D(Fcons(t,f))
   |] ==> (\<forall>t \<in> tree(A).    tree_forest_rec(b,c,d,t) \<in> C(t)) \<and>
          (\<forall>f \<in> forest(A). tree_forest_rec(b,c,d,f) \<in> D(f))"
    -- {* Mutually recursive version. *}
  apply (unfold Ball_def)
  apply (rule tree_forest.mutual_induct)
  apply simp_all
  done

subsection {* Operations *}

consts
  map :: "[i => i, i] => i"
  size :: "i => i"
  preorder :: "i => i"
  list_of_TF :: "i => i"
  of_list :: "i => i"
  reflect :: "i => i"

primrec
  "list_of_TF (Tcons(x,f)) = [Tcons(x,f)]"
  "list_of_TF (Fnil) = []"
  "list_of_TF (Fcons(t,tf)) = Cons (t, list_of_TF(tf))"

primrec
  "of_list([]) = Fnil"
  "of_list(Cons(t,l)) = Fcons(t, of_list(l))"

primrec
  "map (h, Tcons(x,f)) = Tcons(h(x), map(h,f))"
  "map (h, Fnil) = Fnil"
  "map (h, Fcons(t,tf)) = Fcons (map(h, t), map(h, tf))"

primrec
  "size (Tcons(x,f)) = succ(size(f))"
  "size (Fnil) = 0"
  "size (Fcons(t,tf)) = size(t) #+ size(tf)"

primrec
  "preorder (Tcons(x,f)) = Cons(x, preorder(f))"
  "preorder (Fnil) = Nil"
  "preorder (Fcons(t,tf)) = preorder(t) @ preorder(tf)"

primrec
  "reflect (Tcons(x,f)) = Tcons(x, reflect(f))"
  "reflect (Fnil) = Fnil"
  "reflect (Fcons(t,tf)) =
    of_list (list_of_TF (reflect(tf)) @ Cons(reflect(t), Nil))"

text {*
  \medskip @{text list_of_TF} and @{text of_list}.
*}

lemma list_of_TF_type [TC]:
    "z \<in> tree_forest(A) ==> list_of_TF(z) \<in> list(tree(A))"
  by (induct set: tree_forest) simp_all

lemma of_list_type [TC]: "l \<in> list(tree(A)) ==> of_list(l) \<in> forest(A)"
  by (induct set: list) simp_all

text {*
  \medskip @{text map}.
*}

lemma
  assumes "!!x. x \<in> A ==> h(x): B"
  shows map_tree_type: "t \<in> tree(A) ==> map(h,t) \<in> tree(B)"
    and map_forest_type: "f \<in> forest(A) ==> map(h,f) \<in> forest(B)"
  using assms
  by (induct rule: tree'induct forest'induct) simp_all

text {*
  \medskip @{text size}.
*}

lemma size_type [TC]: "z \<in> tree_forest(A) ==> size(z) \<in> nat"
  by (induct set: tree_forest) simp_all

text {*
  \medskip @{text preorder}.
*}

lemma preorder_type [TC]: "z \<in> tree_forest(A) ==> preorder(z) \<in> list(A)"
  by (induct set: tree_forest) simp_all

text {*
  \medskip Theorems about @{text list_of_TF} and @{text of_list}.
*}

lemma forest_induct [consumes 1, case_names Fnil Fcons]:
  "[| f \<in> forest(A);
      R(Fnil);
      !!t f. [| t \<in> tree(A);  f \<in> forest(A);  R(f) |] ==> R(Fcons(t,f))
   |] ==> R(f)"
  -- {* Essentially the same as list induction. *}
  apply (erule tree_forest.mutual_induct
      [THEN conjunct2, THEN spec, THEN [2] rev_mp])
    apply (rule TrueI)
   apply simp
  apply simp
  done

lemma forest_iso: "f \<in> forest(A) ==> of_list(list_of_TF(f)) = f"
  by (induct rule: forest_induct) simp_all

lemma tree_list_iso: "ts: list(tree(A)) ==> list_of_TF(of_list(ts)) = ts"
  by (induct set: list) simp_all

text {*
  \medskip Theorems about @{text map}.
*}

lemma map_ident: "z \<in> tree_forest(A) ==> map(\<lambda>u. u, z) = z"
  by (induct set: tree_forest) simp_all

lemma map_compose:
    "z \<in> tree_forest(A) ==> map(h, map(j,z)) = map(\<lambda>u. h(j(u)), z)"
  by (induct set: tree_forest) simp_all

text {*
  \medskip Theorems about @{text size}.
*}

lemma size_map: "z \<in> tree_forest(A) ==> size(map(h,z)) = size(z)"
  by (induct set: tree_forest) simp_all

lemma size_length: "z \<in> tree_forest(A) ==> size(z) = length(preorder(z))"
  by (induct set: tree_forest) (simp_all add: length_app)

text {*
  \medskip Theorems about @{text preorder}.
*}

lemma preorder_map:
    "z \<in> tree_forest(A) ==> preorder(map(h,z)) = List_ZF.map(h, preorder(z))"
  by (induct set: tree_forest) (simp_all add: map_app_distrib)

end