(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: Interlocking.thy                                                     *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk                 *)
(******************************************************************************)
(* LAST REVIEWED: 22 Sep 2017 *)

section {* Interlocking FMU Model *}

theory Interlocking
imports Vector Topology utp_hoare_ext
begin recall_syntax

(* declare One_nat_def [simp del] *)

lemma inv_subst_weakening_lemma:
"`I \<Rightarrow> s \<dagger> I` \<Longrightarrow> `I \<and> P \<Rightarrow> s \<dagger> I`"
apply (rel_simp)
done

subsection {* Interlocking State *}

alphabet ilock_state =
  cdv :: "bool vector"
  tc :: "bool vector"
  relays :: "bool vector"
  signals :: "bool vector"
  switches :: "switch vector"

text \<open>Convenience syntax for indexed access of @{const cdv}.\<close>

abbreviation CDV :: "nat \<Rightarrow> (bool, ilock_state) uexpr" ("CDV[_]") where
"CDV[i] \<equiv> &cdv[i]\<^sub>u"

text \<open>Convenience syntax for indexed access of @{const tc}.\<close>

abbreviation TC :: "nat \<Rightarrow> (bool, ilock_state) uexpr" ("TC[_]") where
"TC[i] \<equiv> &tc[i]\<^sub>u"

text \<open>Convenience syntax for accessing elements of @{const relays}.\<close>

abbreviation "R1 \<equiv> &relays[1]\<^sub>u"
abbreviation "R2 \<equiv> &relays[2]\<^sub>u"
abbreviation "R3 \<equiv> &relays[3]\<^sub>u"
abbreviation "R4 \<equiv> &relays[4]\<^sub>u"
abbreviation "R5 \<equiv> &relays[5]\<^sub>u"

text \<open>Convenience syntax for accessing elements of @{const switches}.\<close>

abbreviation "SW1 \<equiv> &switches[1]\<^sub>u"
abbreviation "SW2 \<equiv> &switches[2]\<^sub>u"
abbreviation "SW3 \<equiv> &switches[3]\<^sub>u"
abbreviation "SW4 \<equiv> &switches[4]\<^sub>u"
abbreviation "SW5 \<equiv> &switches[5]\<^sub>u"

subsection {* Proof Support *}

text \<open>Interpretations for the @{type ilock_state} alphabet type.\<close>

interpretation ilock_var_interp1:
  lens_interp "\<lambda>r. (cdv\<^sub>v r, tc\<^sub>v r, relays\<^sub>v r, signals\<^sub>v r, switches\<^sub>v r, more r)"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

interpretation ilock_var_interp2:
  lens_interp "\<lambda>(r, r'). (cdv\<^sub>v r, cdv\<^sub>v r', tc\<^sub>v r, tc\<^sub>v r', relays\<^sub>v r, relays\<^sub>v r',
    signals\<^sub>v r, signals\<^sub>v r', switches\<^sub>v r, switches\<^sub>v r', more r, more r')"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

subsection {* Initial State *}

definition init_ilock :: "ilock_state hrel" where [urel_defs]:
"init_ilock =
  ((cdv, tc, relays, signals, switches) := (
    mk_vector\<^sub>u 11 true,
    mk_vector\<^sub>u 4 false,
    mk_vector\<^sub>u 5 false,
    mk_vector\<^sub>u 3 false,
    vector_from_list\<^sub>u [STRAIGHT, DIVERGING, DIVERGING, STRAIGHT, DIVERGING]))"

subsection {* Cyclic Behaviour *}

text \<open>We break down the cyclic behaviour into four separate operations.\<close>

subsubsection {* Relay Setting *}

definition set_relays :: "ilock_state hrel" where
[urel_defs]: "set_relays =
  ((relays[1] := true) \<triangleleft> TC[4] \<and> \<not> TC[3] \<and> \<not> R2 \<and> \<not> R4 \<and> (*\<not> CDV[3] \<and>*) CDV[4] \<and> CDV[5] \<triangleright>\<^sub>r II) ;;
  ((relays[2] := true) \<triangleleft> TC[3] \<and> \<not> TC[4] \<and> \<not> R1 \<and> \<not> R3 \<and> \<not> R4 \<and> \<not> R5 \<and> (*\<not> CDV[3] \<and>*) CDV[4] \<and> CDV[8] \<and> CDV[9] \<and> CDV[10] \<and> CDV[1] \<triangleright>\<^sub>r II) ;;
  ((relays[4] := true) \<triangleleft> TC[3] \<and> \<not> TC[4] \<and> \<not> R1 \<and> \<not> R2 \<and> \<not> R3 \<and> \<not> R5 \<and> (*\<not> CDV[3] \<and>*) CDV[4] \<and> CDV[8] \<and> CDV[9] \<and> CDV[11] \<and> CDV[2] \<triangleright>\<^sub>r II) ;;
  ((relays[3] := true) \<triangleleft> TC[1] \<and> \<not> R2 \<and> \<not> R4 \<and> \<not> R5 \<and> (*\<not> CDV[1] \<and>*) CDV[10] \<and> CDV[9] \<and> CDV[8] \<and> CDV[7] \<and> CDV[6] \<triangleright>\<^sub>r II) ;;
  ((relays[5] := true) \<triangleleft> TC[2] \<and> \<not> R2 \<and> \<not> R3 \<and> \<not> R4 \<and> (*\<not> CDV[2] \<and>*) CDV[11] \<and> CDV[9] \<and> CDV[8] \<and> CDV[7] \<and> CDV[6] \<triangleright>\<^sub>r II)"

subsubsection {* Relay Clearing *}

definition clear_relays :: "ilock_state hrel" where
[urel_defs]: "clear_relays =
  ((relays[1] := false) \<triangleleft> R1 \<and> \<not> CDV[5] \<triangleright>\<^sub>r II) ;;
  ((relays[2] := false) \<triangleleft> R2 \<and> \<not> CDV[1] \<triangleright>\<^sub>r II) ;;
  ((relays[3] := false) \<triangleleft> R3 \<and> \<not> CDV[6] \<triangleright>\<^sub>r II) ;;
  ((relays[4] := false) \<triangleleft> R4 \<and> \<not> CDV[2] \<triangleright>\<^sub>r II) ;;
  ((relays[5] := false) \<triangleleft> R5 \<and> \<not> CDV[6] \<triangleright>\<^sub>r II)"

subsubsection {* Switch Setting *}

definition set_switches :: "ilock_state hrel" where
[urel_defs]: "set_switches = (
  (switches[1] := \<guillemotleft>STRAIGHT\<guillemotright>) ;;
  ((switches[2] := \<guillemotleft>STRAIGHT\<guillemotright>) \<triangleleft> R3 \<or> R5 \<triangleright>\<^sub>r (switches[2] := \<guillemotleft>DIVERGING\<guillemotright>)) ;;
  ((switches[3] := \<guillemotleft>STRAIGHT\<guillemotright>) \<triangleleft> R1 \<triangleright>\<^sub>r (switches[3] := \<guillemotleft>DIVERGING\<guillemotright>)) ;;
  (switches[4] := \<guillemotleft>STRAIGHT\<guillemotright>) ;;
  ((switches[5] := \<guillemotleft>STRAIGHT\<guillemotright>) \<triangleleft> R2 \<or> R3 \<triangleright>\<^sub>r (switches[5] := \<guillemotleft>DIVERGING\<guillemotright>)))"

subsubsection {* Signal Setting *}

definition set_signals :: "ilock_state hrel" where
[urel_defs]: "set_signals = (
  (signals[1] := (R3 \<and> SW5 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW2 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW4 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>)) ;;
  (signals[2] := (R5 \<and> SW5 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright> \<and> SW2 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW4 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>)) ;;
  (signals[3] := ((R1 \<and> SW1 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW3 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>) \<or>
    (R2 \<and> SW1 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW3 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright> \<and> SW2 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright> \<and> SW5 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>) \<or>
    (R4 \<and> SW1 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW3 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright> \<and> SW2 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright> \<and> SW5 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright>))))"

subsubsection {* Complete Cycle *}

definition ilock_cycle :: "ilock_state hrel" where [urel_defs]:
"ilock_cycle = (set_relays ;; clear_relays ;; set_switches ;; set_signals)"

subsection {* Invariants *}

text \<open>We next prove several invariants of the interlocking model.\<close>

subsubsection {* Type Invariant *}

text \<open>The type invariant establishes that all vectors have the correct size.\<close>

definition ilock_type_inv :: "ilock_state upred" where [urel_defs]:
"ilock_type_inv = (
  #\<^sub>u(&cdv) =\<^sub>u 11 \<and>
  #\<^sub>u(&tc) =\<^sub>u 4 \<and>
  #\<^sub>u(&relays) =\<^sub>u 5 \<and>
  #\<^sub>u(&signals) =\<^sub>u 3 \<and>
  #\<^sub>u(&switches) =\<^sub>u 5)"

text {* Method for proving the interlocking type invariant. *}

lemma ilock_type_inv_rules:
"\<lbrace>ilock_type_inv\<rbrace>S\<lbrace>ilock_type_inv\<rbrace>\<^sub>u \<Longrightarrow>
 \<lbrace>ilock_type_inv \<and> P\<rbrace>S\<lbrace>ilock_type_inv\<rbrace>\<^sub>u"
"`ilock_type_inv \<Rightarrow> s \<dagger> ilock_type_inv` \<Longrightarrow>
 `ilock_type_inv \<and> P \<Rightarrow> s \<dagger> ilock_type_inv`"
apply (rel_simp)
apply (erule inv_subst_weakening_lemma)
done

text {* The tactic below is a bit quicker than @{method hoare_auto}. *}

method ilock_type_inv_tac =
  (hoare_split_inv add: ilock_type_inv_rules; rel_simp)

lemma init_ilock_type_inv:
"\<lbrace>true\<rbrace>init_ilock\<lbrace>ilock_type_inv\<rbrace>\<^sub>u"
apply (rel_simp)
done

lemma set_relays_type_inv:
"\<lbrace>ilock_type_inv\<rbrace>set_relays\<lbrace>ilock_type_inv\<rbrace>\<^sub>u"
(* unfolding set_relays_def by (hoare_auto) *)
  unfolding set_relays_def by (ilock_type_inv_tac)

lemma clear_relays_type_inv:
"\<lbrace>ilock_type_inv\<rbrace>clear_relays\<lbrace>ilock_type_inv\<rbrace>\<^sub>u"
(* unfolding clear_relays_def by (hoare_auto) *)
  unfolding clear_relays_def by (ilock_type_inv_tac)

lemma set_switches_type_inv:
"\<lbrace>ilock_type_inv\<rbrace>set_switches\<lbrace>ilock_type_inv\<rbrace>\<^sub>u"
(* unfolding set_switches_def by (hoare_auto) *)
  unfolding set_switches_def by (ilock_type_inv_tac)

lemma set_signals_type_inv:
"\<lbrace>ilock_type_inv\<rbrace>set_signals\<lbrace>ilock_type_inv\<rbrace>\<^sub>u"
(* unfolding set_signals_def by (hoare_auto) *)
  unfolding set_signals_def by (ilock_type_inv_tac)

lemma "\<lbrace>ilock_type_inv\<rbrace>ilock_cycle\<lbrace>ilock_type_inv\<rbrace>\<^sub>u"
apply (unfold ilock_cycle_def)
apply (hoare_split)
apply (rule set_relays_type_inv)
apply (rule clear_relays_type_inv)
apply (rule set_switches_type_inv)
apply (rule set_signals_type_inv)
done

subsubsection {* Relays Invariant *}

text \<open>Ensures that at most one relay can be activated at a time.\<close>

definition relays_inv :: "ilock_state upred" where [upred_defs]:
"relays_inv = (
  (#\<^sub>u(&relays) =\<^sub>u 5) \<and>
  (R1 \<Rightarrow> \<not> R2 \<and> \<not> R4) \<and>
  (R2 \<Rightarrow> \<not> R1 \<and> \<not> R3 \<and> \<not> R4 \<and> \<not> R5) \<and>
  (R4 \<Rightarrow> \<not> R1 \<and> \<not> R2 \<and> \<not> R3 \<and> \<not> R5) \<and>
  (R3 \<Rightarrow> \<not> R2 \<and> \<not> R4 \<and> \<not> R5) \<and>
  (R5 \<Rightarrow> \<not> R2 \<and> \<not> R3 \<and> \<not> R4))"

paragraph {* Proof Support *}

definition valid_relay_states :: "(bool vector) set" where
"valid_relay_states =
 vector_from_list ` {
  [OFF, OFF, OFF, OFF, OFF],
  [ON, OFF, OFF, OFF, OFF],
  [ON, OFF, OFF, OFF, ON],
  [ON, OFF, ON, OFF, OFF],
  [OFF, ON, OFF, OFF, OFF],
  [OFF, OFF, ON, OFF, OFF],
  [ON, OFF, ON, OFF, OFF],
  [OFF, OFF, OFF, ON, OFF],
  [OFF, OFF, OFF, OFF, ON],
  [ON, OFF, OFF, OFF, ON]}"

lemma eq_vector_from_list_5:
"size v = 5 \<Longrightarrow>
  (v = vector_from_list [b1, b2, b3, b4, b5]) =
  (v\<^bold>[1\<^bold>] = b1 \<and> v\<^bold>[2\<^bold>] = b2 \<and> v\<^bold>[3\<^bold>] = b3 \<and> v\<^bold>[4\<^bold>] = b4 \<and> v\<^bold>[5\<^bold>] = b5)"
apply (subst vector_equality)
apply (clarsimp)
apply (safe; clarsimp)
apply (subgoal_tac "i \<in> {1, 2, 3, 4, 5}")
apply (safe; clarsimp)
apply (safe; clarsimp)
done

lemma relays_inv_cases:
"relays_inv = (&relays \<in>\<^sub>u \<guillemotleft>valid_relay_states\<guillemotright>)"
apply (unfold relays_inv_def)
apply (rel_simp)
apply (safe; clarsimp?)
apply (unfold valid_relay_states_def)
apply (simp_all add: eq_vector_from_list_5)
apply (safe; clarsimp)+
done

lemma relays_inv_split:
"`relays_inv \<Rightarrow> P` = `\<^bold>\<forall> v\<in>\<guillemotleft>valid_relay_states\<guillemotright> \<bullet> P\<lbrakk>\<guillemotleft>v\<guillemotright> / &relays\<rbrakk>`"
apply (unfold relays_inv_cases)
apply (pred_simp robust)
apply (safe; clarsimp)
done

lemma relays_inv_extr:
"`relays_inv \<and> P \<Rightarrow> Q` = `relays_inv \<Rightarrow> P \<Rightarrow> Q`"
  by (simp add: impl_alt_def utp_pred_laws.sup.assoc)

lemma hoare_relays_inv_split:
"(\<And>rs. rs \<in> valid_relay_states \<Longrightarrow> \<lbrace>ilock_type_inv\<rbrace>S\<lbrakk>\<guillemotleft>rs\<guillemotright>/$relays\<rbrakk>\<lbrace>I\<rbrace>\<^sub>u) \<Longrightarrow>
 \<lbrace>ilock_type_inv \<and> relays_inv\<rbrace>S\<lbrace>I\<rbrace>\<^sub>u"
apply (unfold relays_inv_cases)
apply (rel_simp)
done

method hoare_relays_inv_tac = (
  (rule hoare_relays_inv_split),
  (unfold valid_relay_states_def),
  (clarsimp; safe))

text {* Do \<open>,\<close>  and \<open>;\<close> have the same precedence? Are they right-associative? *}

method ilock_relays_inv_tac =
  (hoare_split_inv; (
    (unfold relays_inv_extr)?,
    (unfold relays_inv_cases),
    (rel_simp);
    (unfold valid_relay_states_def),
    (safe; simp)))

paragraph {* Invariant Preservation *}

lemma init_ilock_relays_inv:
"\<lbrace>true\<rbrace>init_ilock\<lbrace>relays_inv\<rbrace>\<^sub>u"
  unfolding init_ilock_def by (rel_simp)

lemma set_relays_relays_inv:
"\<lbrace>relays_inv\<rbrace>set_relays\<lbrace>relays_inv\<rbrace>\<^sub>u"
  unfolding set_relays_def by (ilock_relays_inv_tac)

lemma clear_relays_relays_inv:
"\<lbrace>relays_inv\<rbrace>clear_relays\<lbrace>relays_inv\<rbrace>\<^sub>u"
  unfolding clear_relays_def by (ilock_relays_inv_tac)

lemma set_switches_relays_inv:
"\<lbrace>relays_inv\<rbrace>set_switches\<lbrace>relays_inv\<rbrace>\<^sub>u"
  unfolding set_switches_def by (ilock_relays_inv_tac)

lemma set_signals_relays_inv:
"\<lbrace>relays_inv\<rbrace>set_signals\<lbrace>relays_inv\<rbrace>\<^sub>u"
  unfolding set_signals_def by (ilock_relays_inv_tac)

lemma "\<lbrace>relays_inv\<rbrace>ilock_cycle\<lbrace>relays_inv\<rbrace>\<^sub>u"
apply (unfold ilock_cycle_def)
apply (hoare_split)
apply (rule set_relays_relays_inv)
apply (rule clear_relays_relays_inv)
apply (rule set_switches_relays_inv)
apply (rule set_signals_relays_inv)
done

subsection {* Switches Invariant *}

(*
definition switches_inv :: "ilock_state upred" where
[urel_defs]: "switches_inv = (
  (#\<^sub>u(&switches) =\<^sub>u 5) \<and>
  (SW1 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>) \<and>
  ((SW2 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>) \<triangleleft> R3 \<or> R5 \<triangleright> (SW2 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright>)) \<and>
  ((SW3 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>) \<triangleleft> R1 \<triangleright> (SW3 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright>)) \<and>
  (SW4 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>) \<and>
  ((SW5 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>) \<triangleleft> R2 \<or> R3 \<triangleright> (SW5 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright>))
)"
*)

definition switches_inv :: "ilock_state upred" where
[urel_defs]: "switches_inv = (
  (#\<^sub>u(&switches) =\<^sub>u 5) \<and>
  (R1 \<Rightarrow> SW1 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW3 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>) \<and>
  (R2 \<Rightarrow> SW1 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW2 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright> \<and> SW3 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright> \<and> SW5 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>) \<and>
  (R3 \<Rightarrow> SW2 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW4 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW5 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright>) \<and>
  (R4 \<Rightarrow> SW1 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW2 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright> \<and> SW3 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright> \<and> SW5 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright>) \<and>
  (R5 \<Rightarrow> SW2 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW4 =\<^sub>u \<guillemotleft>STRAIGHT\<guillemotright> \<and> SW5 =\<^sub>u \<guillemotleft>DIVERGING\<guillemotright>)
)"

lemma switches_inv_rules:
"`switches_inv \<Rightarrow> s \<dagger> switches_inv` \<Longrightarrow>
 `switches_inv \<and> P \<Rightarrow> s \<dagger> switches_inv`"
apply (erule inv_subst_weakening_lemma)
done

lemma init_ilock_switches_inv:
"\<lbrace>true\<rbrace>init_ilock\<lbrace>switches_inv\<rbrace>\<^sub>u"
  unfolding init_ilock_def by (rel_simp)

(***********************)
(* REVIEWED UNTIL HERE *)
(***********************)

lemma set_switches_subst_relay_simps:
"(switches := e ;; S)\<lbrakk>\<guillemotleft>f\<guillemotright>/$relays\<rbrakk> =
 (switches := e\<lbrakk>\<guillemotleft>f\<guillemotright>/&relays\<rbrakk> ;; (S\<lbrakk>\<guillemotleft>f\<guillemotright>/$relays\<rbrakk>))"
"((switches := e1 \<triangleleft> b \<triangleright>\<^sub>r switches := e2) ;; R)\<lbrakk>\<guillemotleft>f\<guillemotright>/$relays\<rbrakk> =
 ((switches := e1\<lbrakk>\<guillemotleft>f\<guillemotright>/&relays\<rbrakk> \<triangleleft> b\<lbrakk>\<guillemotleft>f\<guillemotright>/&relays\<rbrakk> \<triangleright>\<^sub>r switches := e2\<lbrakk>\<guillemotleft>f\<guillemotright>/&relays\<rbrakk>) ;; R\<lbrakk>\<guillemotleft>f\<guillemotright>/$relays\<rbrakk>)"
apply (rel_auto)+
apply (blast)+
done

lemma switches_assign_lemma:
"switches := (&switches(i \<mapsto> \<guillemotleft>v\<guillemotright>)\<^sub>u)\<lbrakk>\<guillemotleft>e\<guillemotright>/&relays\<rbrakk> =
 switches := (&switches(i\<lbrakk>\<guillemotleft>e\<guillemotright>/&relays\<rbrakk> \<mapsto> \<guillemotleft>v\<guillemotright>)\<^sub>u)"
apply (rel_auto)
done

lemma more_simps:
"(s \<dagger> (1::(nat, '\<alpha>) uexpr)) = 1"
"(s \<dagger> (2::(nat, '\<alpha>) uexpr)) = 2"
"(s \<dagger> (3::(nat, '\<alpha>) uexpr)) = 3"
"(s \<dagger> (4::(nat, '\<alpha>) uexpr)) = 4"
"(s \<dagger> (5::(nat, '\<alpha>) uexpr)) = 5"
"i \<in> {1..length l} \<Longrightarrow> \<guillemotleft>vector_from_list l\<guillemotright>(\<guillemotleft>i\<guillemotright>)\<^sub>a = \<guillemotleft>l ! (i - 1)\<guillemotright>"
"(S \<triangleleft> \<guillemotleft>True\<guillemotright> \<triangleright>\<^sub>r T) = S"
"(S \<triangleleft> \<guillemotleft>False \<guillemotright>\<triangleright>\<^sub>r T) = T"
apply (rel_simp)+
done

lemma
"\<lbrace>ilock_type_inv\<rbrace>set_switches\<lbrakk>\<guillemotleft>rs\<guillemotright>/$relays\<rbrakk>\<lbrace>I\<rbrace>\<^sub>u =
 \<lbrace>ilock_type_inv\<rbrace>set_switches\<lbrakk>\<guillemotleft>rs\<guillemotright>/$relays\<rbrakk>\<lbrace>I\<lbrakk>\<guillemotleft>rs\<guillemotright>/&relays\<rbrakk>\<rbrace>\<^sub>u"
apply (rel_simp robust)
sledgehammer
oops

lemma set_switches_switches_inv:
"\<lbrace>ilock_type_inv \<and> relays_inv\<rbrace>set_switches\<lbrace>switches_inv\<rbrace>\<^sub>u"
apply (hoare_relays_inv_tac)
apply (unfold set_switches_def)
apply (simp_all only: set_switches_subst_relay_simps)
apply (simp_all add: switches_assign_lemma more_simps usubst unrest)
apply (unfold switches_inv_def)
apply (hoare_split_inv)

profile (rel_simp robust)+
done

(***********************)
(* REVIEWED UNTIL HERE *)
(***********************)

subsection {* Signals Invariant *}

definition signals_inv :: "ilock_state upred" where [upred_defs]:
"signals_inv = (
  (#\<^sub>u(&signals) =\<^sub>u 3) \<and>
  (R3 \<Leftrightarrow> &signals[1]\<^sub>u) \<and>
  (R5 \<Leftrightarrow> &signals[2]\<^sub>u) \<and>
  ((R1 \<or> R2 \<or> R4) \<Leftrightarrow> &signals[3]\<^sub>u))"

paragraph {* Invariant Preservation *}

lemma init_ilock_signals_inv:
"\<lbrace>true\<rbrace>init_ilock\<lbrace>signals_inv\<rbrace>\<^sub>u"
  unfolding init_ilock_def by (rel_simp)

text {* I think we have to prove the switches invariant first...! *}

lemma set_relays_signals_inv:
"\<lbrace>ilock_type_inv\<rbrace>set_switches ;; set_signals\<lbrace>signals_inv\<rbrace>\<^sub>u"
oops

subsection {* Proof Experiments *}

lemma uvector_from_list_simps [simp]:
"i \<in> {1..length l} \<Longrightarrow> (vector_from_list\<^sub>u l)[i]\<^sub>u = \<guillemotleft>l ! (i - 1)\<guillemotright>"
apply (pred_simp)
done
end


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

section {* RPC-Memory example: Memory specification *}

theory Memory
imports MemoryParameters ProcedureInterface
begin

type_synonym memChType = "(memOp, Vals) channel"
type_synonym memType = "(Locs => Vals) stfun"  (* intention: MemLocs => MemVals *)
type_synonym resType = "(PrIds => Vals) stfun"

consts
  (* state predicates *)
  MInit      :: "memType => Locs => stpred"
  PInit      :: "resType => PrIds => stpred"
  (* auxiliary predicates: is there a pending read/write request for
     some process id and location/value? *)
  RdRequest  :: "memChType => PrIds => Locs => stpred"
  WrRequest  :: "memChType => PrIds => Locs => Vals => stpred"

  (* actions *)
  GoodRead   :: "memType => resType => PrIds => Locs => action"
  BadRead    :: "memType => resType => PrIds => Locs => action"
  ReadInner  :: "memChType => memType => resType => PrIds => Locs => action"
  Read       :: "memChType => memType => resType => PrIds => action"
  GoodWrite  :: "memType => resType => PrIds => Locs => Vals => action"
  BadWrite   :: "memType => resType => PrIds => Locs => Vals => action"
  WriteInner :: "memChType => memType => resType => PrIds => Locs => Vals => action"
  Write      :: "memChType => memType => resType => PrIds => Locs => action"
  MemReturn  :: "memChType => resType => PrIds => action"
  MemFail    :: "memChType => resType => PrIds => action"
  RNext      :: "memChType => memType => resType => PrIds => action"
  UNext      :: "memChType => memType => resType => PrIds => action"

  (* temporal formulas *)
  RPSpec     :: "memChType => memType => resType => PrIds => temporal"
  UPSpec     :: "memChType => memType => resType => PrIds => temporal"
  MSpec      :: "memChType => memType => resType => Locs => temporal"
  IRSpec     :: "memChType => memType => resType => temporal"
  IUSpec     :: "memChType => memType => resType => temporal"

  RSpec      :: "memChType => resType => temporal"
  USpec      :: "memChType => temporal"

  (* memory invariant: in the paper, the invariant is hidden in the definition of
     the predicate S used in the implementation proof, but it is easier to verify
     at this level. *)
  MemInv    :: "memType => Locs => stpred"

defs
  MInit_def:         "MInit mm l == PRED mm!l = #InitVal"
  PInit_def:         "PInit rs p == PRED rs!p = #NotAResult"

  RdRequest_def:     "RdRequest ch p l == PRED
                         Calling ch p & (arg<ch!p> = #(read l))"
  WrRequest_def:     "WrRequest ch p l v == PRED
                         Calling ch p & (arg<ch!p> = #(write l v))"
  (* a read that doesn't raise BadArg *)
  GoodRead_def:      "GoodRead mm rs p l == ACT
                        #l : #MemLoc & ((rs!p)$ = $(mm!l))"
  (* a read that raises BadArg *)
  BadRead_def:       "BadRead mm rs p l == ACT
                        #l ~: #MemLoc & ((rs!p)$ = #BadArg)"
  (* the read action with l visible *)
  ReadInner_def:     "ReadInner ch mm rs p l == ACT
                         $(RdRequest ch p l)
                         & (GoodRead mm rs p l  |  BadRead mm rs p l)
                         & unchanged (rtrner ch ! p)"
  (* the read action with l quantified *)
  Read_def:          "Read ch mm rs p == ACT (EX l. ReadInner ch mm rs p l)"

  (* similar definitions for the write action *)
  GoodWrite_def:     "GoodWrite mm rs p l v == ACT
                        #l : #MemLoc & #v : #MemVal
                        & ((mm!l)$ = #v) & ((rs!p)$ = #OK)"
  BadWrite_def:      "BadWrite mm rs p l v == ACT
                        ~ (#l : #MemLoc & #v : #MemVal)
                        & ((rs!p)$ = #BadArg) & unchanged (mm!l)"
  WriteInner_def:    "WriteInner ch mm rs p l v == ACT
                        $(WrRequest ch p l v)
                        & (GoodWrite mm rs p l v  |  BadWrite mm rs p l v)
                        & unchanged (rtrner ch ! p)"
  Write_def:         "Write ch mm rs p l == ACT (EX v. WriteInner ch mm rs p l v)"

  (* the return action *)
  MemReturn_def:     "MemReturn ch rs p == ACT
                       (   ($(rs!p) ~= #NotAResult)
                        & ((rs!p)$ = #NotAResult)
                        & Return ch p (rs!p))"

  (* the failure action of the unreliable memory *)
  MemFail_def:       "MemFail ch rs p == ACT
                        $(Calling ch p)
                        & ((rs!p)$ = #MemFailure)
                        & unchanged (rtrner ch ! p)"
  (* next-state relations for reliable / unreliable memory *)
  RNext_def:         "RNext ch mm rs p == ACT
                       (  Read ch mm rs p
                        | (EX l. Write ch mm rs p l)
                        | MemReturn ch rs p)"
  UNext_def:         "UNext ch mm rs p == ACT
                        (RNext ch mm rs p | MemFail ch rs p)"

  RPSpec_def:        "RPSpec ch mm rs p == TEMP
                        Init(PInit rs p)
                        & [][ RNext ch mm rs p ]_(rtrner ch ! p, rs!p)
                        & WF(RNext ch mm rs p)_(rtrner ch ! p, rs!p)
                        & WF(MemReturn ch rs p)_(rtrner ch ! p, rs!p)"
  UPSpec_def:        "UPSpec ch mm rs p == TEMP
                        Init(PInit rs p)
                        & [][ UNext ch mm rs p ]_(rtrner ch ! p, rs!p)
                        & WF(RNext ch mm rs p)_(rtrner ch ! p, rs!p)
                        & WF(MemReturn ch rs p)_(rtrner ch ! p, rs!p)"
  MSpec_def:         "MSpec ch mm rs l == TEMP
                        Init(MInit mm l)
                        & [][ EX p. Write ch mm rs p l ]_(mm!l)"
  IRSpec_def:        "IRSpec ch mm rs == TEMP
                        (ALL p. RPSpec ch mm rs p)
                        & (ALL l. #l : #MemLoc --> MSpec ch mm rs l)"
  IUSpec_def:        "IUSpec ch mm rs == TEMP
                        (ALL p. UPSpec ch mm rs p)
                        & (ALL l. #l : #MemLoc --> MSpec ch mm rs l)"

  RSpec_def:         "RSpec ch rs == TEMP (EEX mm. IRSpec ch mm rs)"
  USpec_def:         "USpec ch == TEMP (EEX mm rs. IUSpec ch mm rs)"

  MemInv_def:        "MemInv mm l == PRED  #l : #MemLoc --> mm!l : #MemVal"

lemmas RM_action_defs =
  MInit_def PInit_def RdRequest_def WrRequest_def MemInv_def
  GoodRead_def BadRead_def ReadInner_def Read_def
  GoodWrite_def BadWrite_def WriteInner_def Write_def
  MemReturn_def RNext_def

lemmas UM_action_defs = RM_action_defs MemFail_def UNext_def

lemmas RM_temp_defs = RPSpec_def MSpec_def IRSpec_def
lemmas UM_temp_defs = UPSpec_def MSpec_def IUSpec_def

(* The reliable memory is an implementation of the unreliable one *)
lemma ReliableImplementsUnReliable: "|- IRSpec ch mm rs --> IUSpec ch mm rs"
  by (force simp: UNext_def UPSpec_def IUSpec_def RM_temp_defs elim!: STL4E [temp_use] squareE)

(* The memory spec implies the memory invariant *)
lemma MemoryInvariant: "|- MSpec ch mm rs l --> [](MemInv mm l)"
  by (auto_invariant simp: RM_temp_defs RM_action_defs)

(* The invariant is trivial for non-locations *)
lemma NonMemLocInvariant: "|- #l ~: #MemLoc --> [](MemInv mm l)"
  by (auto simp: MemInv_def intro!: necT [temp_use])

lemma MemoryInvariantAll:
    "|- (ALL l. #l : #MemLoc --> MSpec ch mm rs l) --> (ALL l. [](MemInv mm l))"
  apply clarify
  apply (auto elim!: MemoryInvariant [temp_use] NonMemLocInvariant [temp_use])
  done

(* The memory engages in an action for process p only if there is an
   unanswered call from p.
   We need this only for the reliable memory.
*)

lemma Memoryidle: "|- ~$(Calling ch p) --> ~ RNext ch mm rs p"
  by (auto simp: Return_def RM_action_defs)

(* Enabledness conditions *)

lemma MemReturn_change: "|- MemReturn ch rs p --> <MemReturn ch rs p>_(rtrner ch ! p, rs!p)"
  by (force simp: MemReturn_def angle_def)

lemma MemReturn_enabled: "!!p. basevars (rtrner ch ! p, rs!p) ==>
      |- Calling ch p & (rs!p ~= #NotAResult)
         --> Enabled (<MemReturn ch rs p>_(rtrner ch ! p, rs!p))"
  apply (tactic
    {* action_simp_tac @{context} [@{thm MemReturn_change} RSN (2, @{thm enabled_mono}) ] [] 1 *})
  apply (tactic
    {* action_simp_tac (@{context} addsimps [@{thm MemReturn_def}, @{thm Return_def},
      @{thm rtrner_def}]) [exI] [@{thm base_enabled}, @{thm Pair_inject}] 1 *})
  done

lemma ReadInner_enabled: "!!p. basevars (rtrner ch ! p, rs!p) ==>
      |- Calling ch p & (arg<ch!p> = #(read l)) --> Enabled (ReadInner ch mm rs p l)"
  apply (case_tac "l : MemLoc")
  apply (force simp: ReadInner_def GoodRead_def BadRead_def RdRequest_def
    intro!: exI elim!: base_enabled [temp_use])+
  done

lemma WriteInner_enabled: "!!p. basevars (mm!l, rtrner ch ! p, rs!p) ==>
      |- Calling ch p & (arg<ch!p> = #(write l v))
         --> Enabled (WriteInner ch mm rs p l v)"
  apply (case_tac "l:MemLoc & v:MemVal")
  apply (force simp: WriteInner_def GoodWrite_def BadWrite_def WrRequest_def
    intro!: exI elim!: base_enabled [temp_use])+
  done

lemma ReadResult: "|- Read ch mm rs p & (!l. $(MemInv mm l)) --> (rs!p)` ~= #NotAResult"
  by (force simp: Read_def ReadInner_def GoodRead_def BadRead_def MemInv_def)

lemma WriteResult: "|- Write ch mm rs p l --> (rs!p)` ~= #NotAResult"
  by (auto simp: Write_def WriteInner_def GoodWrite_def BadWrite_def)

lemma ReturnNotReadWrite: "|- (ALL l. $MemInv mm l) & MemReturn ch rs p
         --> ~ Read ch mm rs p & (ALL l. ~ Write ch mm rs p l)"
  by (auto simp: MemReturn_def dest!: WriteResult [temp_use] ReadResult [temp_use])

lemma RWRNext_enabled: "|- (rs!p = #NotAResult) & (!l. MemInv mm l)
         & Enabled (Read ch mm rs p | (? l. Write ch mm rs p l))
         --> Enabled (<RNext ch mm rs p>_(rtrner ch ! p, rs!p))"
  by (force simp: RNext_def angle_def elim!: enabled_mono2
    dest: ReadResult [temp_use] WriteResult [temp_use])

(* Combine previous lemmas: the memory can make a visible step if there is an
   outstanding call for which no result has been produced.
*)
lemma RNext_enabled: "!!p. !l. basevars (mm!l, rtrner ch!p, rs!p) ==>
      |- (rs!p = #NotAResult) & Calling ch p & (!l. MemInv mm l)
         --> Enabled (<RNext ch mm rs p>_(rtrner ch ! p, rs!p))"
  apply (auto simp: enabled_disj [try_rewrite] intro!: RWRNext_enabled [temp_use])
  apply (case_tac "arg (ch w p)")
   apply (tactic {* action_simp_tac (@{context} addsimps [@{thm Read_def},
     temp_rewrite @{context} @{thm enabled_ex}]) [@{thm ReadInner_enabled}, exI] [] 1 *})
   apply (force dest: base_pair [temp_use])
  apply (erule contrapos_np)
  apply (tactic {* action_simp_tac (@{context} addsimps [@{thm Write_def},
    temp_rewrite @{context} @{thm enabled_ex}])
    [@{thm WriteInner_enabled}, exI] [] 1 *})
  done

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   June 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                January 2007  (modified)   |
            |                  April 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2007         |
            |                January 2008  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009         |
            |                   June 2009  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                  April 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_syntax
imports Infra
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(* for Isabelle 2016
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)

(*-----------------------------------------------------------*
 |                                                           |
 |    Process Type Definitions                               |
 |                                                           |
 |             'a proc : type of process expressions         |
 |                       'n : process name                   |
 |                       'a : event                          |
 |                                                           |
 *-----------------------------------------------------------*)

(*********************************************************************
                       process expression
 *********************************************************************)

type_synonym
   'a sets_nats = "('a set set, nat set) sum"
type_synonym
   'a aset_anat = "('a set, nat) sum"

datatype
 ('p,'a) proc
    = STOP

    | SKIP

    | DIV

    | Act_prefix     "'a" "('p,'a) proc"      ("(1_ /-> _)" [150,80] 80)

    | Ext_pre_choice "'a set" "'a => ('p,'a) proc"
                                               ("(1? :_ /-> _)" [900,80] 80)
    | Ext_choice     "('p,'a) proc" "('p,'a) proc"
                                               ("(1_ /[+] _)" [72,73] 72)
    | Int_choice     "('p,'a) proc" "('p,'a) proc"
                                               ("(1_ /|~| _)" [64,65] 64)
    | Rep_int_choice "'a sets_nats" "'a aset_anat => ('p,'a) proc"
                                               ("(1!! :_ .. /_)" [900,68] 68)
    | IF             "bool" "('p,'a) proc" "('p,'a) proc"
                                 ("(0IF _ /THEN _ /ELSE _)" [900,88,88] 88)
(*                               ("(0IF _ /THEN _ /ELSE _)" [900,60,60] 88) *)
    | Parallel       "('p,'a) proc" "'a set" "('p,'a) proc"
                                               ("(1_ /|[_]| _)" [76,0,77] 76)
    | Hiding         "('p,'a) proc" "'a set"   ("(1_ /-- _)" [84,85] 84)

    | Renaming       "('p,'a) proc" "('a * 'a) set"
                                               ("(1_ /[[_]])" [84,0] 84)
(*                                               ("(1_ /[[_]])" [84,0] 84) *)
    | Seq_compo      "('p,'a) proc" "('p,'a) proc"
                                               ("(1_ /;; _)" [79,78] 78)
    | Depth_rest     "('p,'a) proc" "nat"
                                               ("(1_ /|. _)" [84,900] 84)
    | Proc_name      "'p"                      ("$_" [900] 90)

(*--------------------------------------------------------------------*
 |                                                                    |
 | (1) binding power:                                                 |
 |      Proc_Name > IF > {Hiding, Renaming, Restriction} >            |
 |      {Act_prefix, Ext_pre_choice} > Seq_compo > Parallel >         |
 |      Ext_choice > Rep_int_choice > int_choice                      |
 |                                                                    |
 |   The binding power 90 is higher than ones of processes ops.       |
 |                                                                    |
 | (2) About ("(1_ /-> _)" [150,80] 80)                               |
 |      The nth operator ! has the power 101.                         |
 |      So, 150 > 101 is needed.                                      |
 |                                                                    |
 | (3) "selector" is necessary for having our CSP expressive          |
 |     with respect to the domain for stable-failures model F.        |
 |                                                                    |
 *--------------------------------------------------------------------*)

(*** external prefix ***)

syntax
  "@Ext_pre_choice"  :: "pttrn => 'a set => ('p,'a) proc
                => ('p,'a) proc"  ("(1? _:_ /-> _)" [900,900,80] 80)

translations
  "? x:X -> P"  == "? :X -> (%x. P)"

syntax
  "@Ext_pre_choice_UNIV" ::  "pttrn => ('p,'a) proc => ('p,'a) proc"
                                           ("(1? _ /-> _)" [900,80] 80)
translations
  "? x -> P"    == "? x:(CONST UNIV) -> P"

(*** replicated internal choice (bound variable, UNIV) ***)

syntax
  "@Rep_int_choice"::
      "pttrn => 'a sets_nats => ('p,'a) proc => ('p,'a) proc"
                               ("(1!! _:_ .. /_)" [900,900,68] 68)
translations
  "!! c:C .. P"    == "!! :C .. (%c. P)"

(* this is not collect *)
(*
syntax
  "@Rep_int_choice_UNIV"::
      "pttrn => ('p,'a) proc => ('p,'a) proc"
                               ("(1!! _ .. /_)" [900,68] 68)

translations
  "!! c .. P"      == "!! c:UNIV .. P"
*)

(*** set, nat ***)

(*
consts
  Rep_int_choice_set ::
    "'a set set => ('a set => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1!set :_ .. /_)" [900,68] 68)
  Rep_int_choice_nat ::
    "nat set => (nat => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1!nat :_ .. /_)" [900,68] 68)

defs
  Rep_int_choice_set_def:
        "!set :Xs .. Pf == !! c:(type1 Xs) .. (Pf ((inv type1) c))"
  Rep_int_choice_nat_def:
        "!nat :N .. Pf == !! c:(type2 N) .. (Pf ((inv type2) c))"
*)

definition
  Rep_int_choice_set ::
    "'a set set => ('a set => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1!set :_ .. /_)" [900,68] 68)
  where
  "!set :Xs .. Pf == !! c:(type1 Xs) .. (Pf ((inv type1) c))"

definition
  Rep_int_choice_nat ::
    "nat set => (nat => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1!nat :_ .. /_)" [900,68] 68)
  where
  Rep_int_choice_nat_def:
        "!nat :N .. Pf == !! c:(type2 N) .. (Pf ((inv type2) c))"

(* bound variable *)

syntax
  "@Rep_int_choice_set" ::
     "pttrn => ('a set) set => ('a set => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1!set _:_ .. /_)" [900,900,68] 68)
  "@Rep_int_choice_nat" ::
     "pttrn => nat set => (nat => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1!nat _:_ .. /_)" [900,900,68] 68)

translations
    "!set X:Xs .. P" == "!set :Xs .. (%X. P)"
    "!nat n:N .. P"  == "!nat :N .. (%n. P)"

(* UNIV *)

syntax
  "@Rep_int_choice_set_UNIV" ::
     "pttrn => ('a set => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1!set _ .. /_)" [900,68] 68)
  "@Rep_int_choice_nat_UNIV" ::
     "pttrn => (nat => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1!nat _ .. /_)" [900,68] 68)

translations
      "!set X .. P" == "!set X:(CONST UNIV) .. P"
      "!nat n .. P" == "!nat n:(CONST UNIV) .. P"

(*** com ***)
(* Isabelle 2013
consts
  Rep_int_choice_com :: "'a set => ('a => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1! :_ .. /_)" [900,68] 68)
defs
  Rep_int_choice_com_def :
     "! :A .. Pf == !set X:{{a} |a. a : A} .. Pf (the_elem(X))"
*)

definition
  Rep_int_choice_com :: "'a set => ('a => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1! :_ .. /_)" [900,68] 68)
  where
  "! :A .. Pf == !set X:{{a} |a. a : A} .. Pf (the_elem(X))"

syntax
  "@Rep_int_choice_com" ::
      "pttrn => 'a set => ('a => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1! _:_ .. /_)" [900,900,68] 68)
  "@Rep_int_choice_com_UNIV" ::
      "pttrn => ('a => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1! _ .. /_)" [900,68] 68)
translations
    "! x:X .. P" == "! :X .. (%x. P)"
      "! x .. P" == "! x:(CONST UNIV) .. P"

(*** f ***)

(* Isabelle 2013
consts
  Rep_int_choice_f ::
    "('b => 'a) => 'b set => ('b => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1!<_> :_ .. /_)" [0,900,68] 68)

defs
 Rep_int_choice_f_def :
        "!<f> :X .. Pf == ! :(f ` X) .. (%x. (Pf ((inv f) x)))"
*)

definition
  Rep_int_choice_f ::
    "('b => 'a) => 'b set => ('b => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1!<_> :_ .. /_)" [0,900,68] 68)
  where
  "!<f> :X .. Pf == ! :(f ` X) .. (%x. (Pf ((inv f) x)))"

syntax
  "@Rep_int_choice_f"::
      "('b => 'a) => pttrn => 'b set => ('p,'a) proc => ('p,'a) proc"
                                      ("(1!<_> _:_ .. /_)" [0,900,900,68] 68)
  "@Rep_int_choice_f_UNIV"::
      "('b => 'a) => pttrn => ('p,'a) proc => ('p,'a) proc"
                                      ("(1!<_> _ .. /_)" [900,900,68] 68)

translations
    "!<f> x:X .. P" == "!<f> :X .. (%x. P)"
    "!<f> x .. P"   == "!<f> x:(CONST UNIV) .. P"

lemmas Rep_int_choice_ss_def =
       Rep_int_choice_set_def
       Rep_int_choice_nat_def
       Rep_int_choice_com_def
       Rep_int_choice_f_def

(*** internal prefix choice ***)

(* 2013
consts
  Int_pre_choice :: "'a set => ('a => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1! :_ /-> _)" [900,80] 80)

defs
  Int_pre_choice_def : "! :X -> Pf == ! :X .. (%x. x -> (Pf x))"
*)

definition
  Int_pre_choice :: "'a set => ('a => ('p,'a) proc) => ('p,'a) proc"
                                      ("(1! :_ /-> _)" [900,80] 80)
  where
  "! :X -> Pf == ! :X .. (%x. x -> (Pf x))"

syntax
  "@Int_pre_choice"  :: "pttrn => 'a set => ('p,'a) proc
                         => ('p,'a) proc"  ("(1! _:_ /-> _)" [900,900,80] 80)

  "@Int_pre_choice_UNIV" ::  "pttrn => ('p,'a) proc => ('p,'a) proc"
                                           ("(1! _ /-> _)" [900,80] 80)

translations
  "! x:X -> P"  == "! :X -> (%x. P)"
  "! x -> P"    == "! x:(CONST UNIV) -> P"

(*** sending and receiving prefixes ***)

(* Isabelle 2013
consts
  Send_prefix :: "('x => 'a) => 'x => ('p,'a) proc => ('p,'a) proc"
                                      ("(1_ ! _ /-> _)" [900,1000,80] 80)
  Nondet_send_prefix :: "('x => 'a) => 'x set =>
                         ('x => ('p,'a) proc) => ('p,'a) proc"
  Rec_prefix  :: "('x => 'a) => 'x set =>
                  ('x => ('p,'a) proc) => ('p,'a) proc"

defs
  Send_prefix_def :
    "a ! x -> P    == a x -> P"
  Nondet_send_prefix_def :
    "Nondet_send_prefix f X Pf == ! :(f ` X) -> (%x. (Pf ((inv f) x)))"
  Rec_prefix_def :
    "Rec_prefix f X Pf == ? :(f ` X) -> (%x. (Pf ((inv f) x)))"
*)

definition
  Send_prefix :: "('x => 'a) => 'x => ('p,'a) proc => ('p,'a) proc"
                                      ("(1_ ! _ /-> _)" [900,1000,80] 80)
  where
  "a ! x -> P    == a x -> P"

definition
  Nondet_send_prefix :: "('x => 'a) => 'x set =>
                         ('x => ('p,'a) proc) => ('p,'a) proc"
  where
  "Nondet_send_prefix f X Pf == ! :(f ` X) -> (%x. (Pf ((inv f) x)))"

definition
  Rec_prefix  :: "('x => 'a) => 'x set =>
                  ('x => ('p,'a) proc) => ('p,'a) proc"
  where
  "Rec_prefix f X Pf == ? :(f ` X) -> (%x. (Pf ((inv f) x)))"

(*
The sending "a ! v -> P" causes syntactical ambiguity.
So, it is recommended to directly use "a v -> P" instead of "a ! v -> P".
*)

syntax
  "@Nondet_send_prefix" ::
     "('x => 'a) => pttrn => 'x set => ('p,'a) proc => ('p,'a) proc"
                               ("(1_ !? _:_ /-> _)" [900,900,1000,80] 80)

  "@Nondet_send_prefix_UNIV" ::
     "('x => 'a) => pttrn => ('p,'a) proc => ('p,'a) proc"
                               ("(1_ !? _ /-> _)" [900,900,80] 80)

  "@Rec_prefix" ::
     "('x => 'a) => pttrn => 'x set => ('p,'a) proc => ('p,'a) proc"
                               ("(1_ ? _:_ /-> _)" [900,900,1000,80] 80)
  "@Rec_Prefix_UNIV" ::
     "('x => 'a) => pttrn => ('p,'a) proc => ('p,'a) proc"
                               ("(1_ ? _ /-> _)" [900,900,80] 80)

translations
  "a !? x:X -> P" == "CONST Nondet_send_prefix a X (%x. P)"
  "a !? x -> P"   == "a !? x:(CONST UNIV) -> P"

  "a ? x:X -> P"  == "CONST Rec_prefix a X (%x. P)"
  "a ? x -> P"    == "a? x:(CONST UNIV) -> P"

(*** unfolding syntactic sugar ***)

lemmas csp_prefix_ss_def = Int_pre_choice_def
                           Send_prefix_def
                           Nondet_send_prefix_def
                           Rec_prefix_def

(*** parallel ***)

abbreviation
   Interleave :: "('p,'a) proc => ('p,'a) proc
                    => ('p,'a) proc"  ("(1_ /||| _)" [76,77] 76)
where "P ||| Q == P |[{}]| Q"

abbreviation
   Synchro   :: "('p,'a) proc => ('p,'a) proc
                    => ('p,'a) proc"  ("(1_ /|| _)" [76,77] 76)
where "P || Q == P |[UNIV]| Q"

(*
syntax
  "_Interleave"    :: "('p,'a) proc => ('p,'a) proc
                    => ('p,'a) proc"  ("(1_ /||| _)" [76,77] 76)
  "_Synchro"       :: "('p,'a) proc => ('p,'a) proc
                    => ('p,'a) proc"  ("(1_ /|| _)" [76,77] 76)

translations
  "P ||| Q"     == "P |[{}]| Q"
  "P || Q"      == "P |[UNIV]| Q"
*)

(* Isabelle 2013
consts
  Alpha_parallel :: "('p,'a) proc => 'a set => 'a set => ('p,'a) proc
                      => ('p,'a) proc"  ("(1_ /(2|[_,/_]|)/ _)" [76,0,0,77] 76)
defs
  Alpha_parallel_def :
   "P |[X,Y]| Q  == (P |[- X]| SKIP) |[X Int Y]| (Q |[- Y]| SKIP)"
*)

definition
  Alpha_parallel :: "('p,'a) proc => 'a set => 'a set => ('p,'a) proc
                      => ('p,'a) proc"  ("(1_ /(2|[_,/_]|)/ _)" [76,0,0,77] 76)
  where
  "P |[X,Y]| Q  == (P |[- X]| SKIP) |[X Int Y]| (Q |[- Y]| SKIP)"

primrec
  Inductive_parallel :: "(('p,'a) proc * 'a set) list
                   => ('p,'a) proc"  ("(1[||] _)" [78] 78)
where
  "[||] [] = SKIP"
 |"[||] (PX # PXs) = (fst PX) |[snd PX, Union (snd ` set PXs)]| ([||] PXs)"

(* Isabelle 2013
consts
  Rep_parallel :: "'i set => ('i => (('p,'a) proc * 'a set))
                      => ('p,'a) proc"  ("(1[||]:_ /_)" [90,78] 78)

defs
  Rep_parallel_def :
   "[||]:I PXf == [||] (map PXf (SOME Is. Is isListOf I))"
*)

definition
  Rep_parallel :: "'i set => ('i => (('p,'a) proc * 'a set))
                      => ('p,'a) proc"  ("(1[||]:_ /_)" [90,78] 78)
  where
  Rep_parallel_def :
   "[||]:I PXf == [||] (map PXf (SOME Is. Is isListOf I))"

syntax
  "@Rep_parallel" ::
     "pttrn => 'i set => (('p,'a) proc * 'a set)
                      => ('p,'a) proc"  ("(1[||] _:_ .. /_)" [900,90,78] 78)

translations
  "[||] i:I .. PX"  == "[||]:I (%i. PX)"

(************************************
 |           empty Index            |
 ************************************)

lemma Rep_parallel_empty[simp]: "I = {} ==> [||]:I PXf = SKIP"
by (simp add: Rep_parallel_def)

(************************************
 |            one Index             |
 ************************************)

lemma Rep_parallel_one:
  "I = {i} ==> [||]:I PXf = (fst (PXf i)) |[snd (PXf i), {}]| SKIP"
by (simp add: Rep_parallel_def)

(*** timeout ***)

abbreviation
 Timeout_abb :: "('p,'a) proc => ('p,'a) proc
             => ('p,'a) proc"  ("(1_ /[> _)" [73,74] 73)
 where "P [> Q == (P |~| STOP) [+] Q"

(*
syntax
  "_Timeout"  :: "('p,'a) proc => ('p,'a) proc
               => ('p,'a) proc"  ("(1_ /[> _)" [73,74] 73)
translations
  "P [> Q"      == "(P |~| STOP) [+] Q"
*)

(*** it is sometimes useful to prevent automatic unfolding [> ***)

(* Isabelle 2013
consts
  Timeout  :: "('p,'a) proc => ('p,'a) proc
               => ('p,'a) proc"  ("(1_ /[>def _)" [73,74] 73)
defs
  Timeout_def : "P [>def Q == P [> Q"
*)

definition
  Timeout  :: "('p,'a) proc => ('p,'a) proc
               => ('p,'a) proc"  ("(1_ /[>def _)" [73,74] 73)
  where
  Timeout_def : "P [>def Q == P [> Q"

(************************************
 |       Renaming by lists          |
 ************************************)

primrec
  Renaming_List  :: "('p,'a) proc => ('a * 'a) set list => ('p,'a) proc"
                                               ("(1_ /[[ _ ]]*)" [84,0] 84)
where
  "P [[ [] ]]* = P"
 |"P [[ r#rs ]]* = P[[r]] [[ rs ]]*"

(* --------------------------------------------------- *
             pipe operator (CSP-Prover 5)
 * --------------------------------------------------- *)

(* Isabelle 2013
consts
 Pipe :: "('p,'a) proc =>
          ('x => 'a) => ('x => 'a) => ('x => 'a) =>
          ('p,'a) proc => ('p,'a) proc"
          ("(1_ /<[_,_,_]> _)" [76,0,0,0,77] 76)

defs
 Pipe_def:
   "P <[left,mid,right]> Q ==
   (P[[right<==>mid]]
    |[range left Un range mid, range mid Un range right]|
    Q[[left<==>mid]]) -- (range mid)"
*)

definition
 Pipe :: "('p,'a) proc =>
          ('x => 'a) => ('x => 'a) => ('x => 'a) =>
          ('p,'a) proc => ('p,'a) proc"
          ("(1_ /<[_,_,_]> _)" [76,0,0,0,77] 76)

  where
   "P <[left,mid,right]> Q ==
   (P[[right<==>mid]]
    |[range left Un range mid, range mid Un range right]|
    Q[[left<==>mid]]) -- (range mid)"

(*===================================================================*

(1) We assume that a process-name-function PNfun is given for
    defining the meaning of each process-name.

    When you define a type of process names, you have to define
    the function PNfun by "overloaded" as follows:

      defs (overloaded)
      PNfun_test_def :  "PNfun == ..."

(2) There are two kinds of approahes for fixed points, i.e.
    cms and cpo approaches. You can defin the mode for fixed
    points by

      defs FPmode = CPOmode
    or
      defs FPmode = CMSmode

    In addtion, you can use MIXmode as follows

      defs FPmode = CMSmode

    It means the least fixed point (in subset order) is used for
    giving the meaning of process names based on cpo approach, and if
    the process function is guarded then cms appoach is also used
    because the least fixed point is the unique fixed point in this
    case.

 *==================================================================*)

(* Isabelle 2013
consts PNfun :: "'p => ('p,'a) proc"  (* Definition of process names *)
*)

type_synonym ('p,'a) pnfun = "'p => ('p,'a) proc"
consts PNfun :: "('p,'a) pnfun"  (* Definition of process names *)

datatype fpmode = CPOmode | CMSmode | MIXmode
consts FPmode :: "fpmode"

(* overloading test:
overloading FP_CPOmode ==
  "FPmode :: fpmode"
begin
  definition "FPmode == CPOmode"
end

lemma "FPmode = CPOmode"
apply (simp add:FP_CPOmode_def)
done
*)

lemma CPOmode_or_CMSmode_or_MIXmode_lm:
   "m = FPmode --> m = CPOmode | m = CMSmode | m = MIXmode"
apply (induct_tac m)
apply (auto)
done

lemma CPOmode_or_CMSmode_or_MIXmode:
  "FPmode = CPOmode | FPmode = CMSmode | FPmode = MIXmode"
by (simp add: CPOmode_or_CMSmode_or_MIXmode_lm)

(*-------*
 | CHAOS |
 *-------*)

(* This CHAOS may cause some error on process definition ... ? *)

datatype 'a ChaosName = Chaos "'a set"

primrec
  Chaosfun :: "'a ChaosName => ('a ChaosName, 'a) proc"
where
  "Chaosfun   (Chaos A) = (! x:A -> $(Chaos A)) |~| STOP"

(* Isabelle 2013
defs (overloaded)
Set_Chaosfun_def [simp]: "PNfun == Chaosfun
*)

overloading Set_Chaosfun ==
  "PNfun :: ('a ChaosName, 'a) pnfun"
begin
  definition "PNfun (pn::'a ChaosName) == Chaosfun pn"
end

(* test of overloading *)
lemma "((PNfun pn)::('a ChaosName, 'a) proc) = Chaosfun pn"
apply (simp add: Set_Chaosfun_def)
done

(* Isabelle 2013
consts CHAOS :: "'a set => ('a ChaosName, 'a) proc"
defs   CHAOS_def : "CHAOS == (%A. $(Chaos A))"
*)

definition
  CHAOS :: "'a set => ('a ChaosName, 'a) proc"
  where
  CHAOS_def : "CHAOS == (%A. $(Chaos A))"

(* --------------------------------------- *
     an example of recursive processes

datatype AB = A | B

consts ABfun :: "AB => (AB,nat) proc"

primrec
  "ABfun  A = 0 -> $B"
  "ABfun  B = 1 -> $A"

defs (overloaded)
PNfun_AB_def : "PNfun == ABfun"

 * --------------------------------------- *)

(*********************************************************************
            substitution by functions : 'p => ('a,'p) proc
 *********************************************************************)

primrec
  Subst_procfun :: "('p,'a) proc => ('p => ('q,'a) proc)
                   => ('q,'a) proc"  ("_ <<" [1000] 1000)
where
  "STOP<<Pf         = STOP"
 |"SKIP<<Pf         = SKIP"
 |"DIV<<Pf          = DIV"
 |"(a -> P)<<Pf     = a -> P<<Pf"
 |"(? :X -> Qf)<<Pf = ? a:X -> (Qf a)<<Pf"
 |"(P [+] Q)<<Pf    = P<<Pf [+] Q<<Pf"
 |"(P |~| Q)<<Pf    = P<<Pf |~| Q<<Pf"
 |"(!! :C .. Qf)<<Pf = !! c:C .. (Qf c)<<Pf"
 |"(IF b THEN P ELSE Q)<<Pf = IF b THEN P<<Pf ELSE Q<<Pf"
 |"(P |[X]| Q)<<Pf  = P<<Pf |[X]| Q<<Pf"
 |"(P -- X)<<Pf     = P<<Pf -- X"
 |"(P [[r]])<<Pf    = P<<Pf [[r]]"
 |"(P ;; Q)<<Pf     = P<<Pf ;; Q<<Pf"
 |"(P |. n)<<Pf     = P<<Pf |. n"
 |"($p) <<Pf        = Pf p"

 (* Isabelle 2013
consts
  Subst_procfun_prod ::
     "('p => ('q,'a) proc) =>
      ('q => ('r,'a) proc) => ('p => ('r,'a) proc)"
                                     ("_ <<<" [1000] 1000)
defs
  Subst_procfun_prod_def: "Pf <<< == (%Qf p. (Pf p)<<Qf)"
*)

definition
  Subst_procfun_prod ::
     "('p => ('q,'a) proc) =>
      ('q => ('r,'a) proc) => ('p => ('r,'a) proc)"
                                     ("_ <<<" [1000] 1000)
  where
  "Pf <<< == (%Qf p. (Pf p)<<Qf)"

(* lemmas *)

lemma Subst_procfun_Rep_int_choice_set[simp]:
  "(!set :Xs .. Qf)<<Pf      = !set X:Xs .. (Qf X)<<Pf"
by (simp add: Rep_int_choice_ss_def)

lemma Subst_procfun_Rep_int_choice_nat[simp]:
  "(!nat :N .. Qf)<<Pf      = !nat n:N .. (Qf n)<<Pf"
by (simp add: Rep_int_choice_ss_def)

lemma Subst_procfun_Rep_int_choice_com[simp]:
  "(! :X .. Qf)<<Pf      = ! x:X .. (Qf x)<<Pf"
by (simp add: Rep_int_choice_com_def)

lemma Subst_procfun_Rep_int_choice_f[simp]:
  "(!<f> :X .. Qf)<<Pf      = !<f> x:X .. (Qf x)<<Pf"
by (simp add: Rep_int_choice_f_def)

lemma Subst_procfun_prod_p:
  "(Pf <<< Qf) p = (Pf p) << Qf"
by (simp add: Subst_procfun_prod_def)

(* for sinding and receiving *)

lemma Subst_procfun_Send_prefix[simp]:
  "(a ! v -> P)<<Pf      = a ! v -> P<<Pf"
by (simp add: csp_prefix_ss_def)

lemma Subst_procfun_Rec_prefix[simp]:
  "(a ? x:X -> Pf x)<<Qf      = a ? x:X ->(Pf x)<<Qf"
by (simp add: csp_prefix_ss_def)

lemma Subst_procfun_Int_pre_choice[simp]:
  "(! :X -> Pf)<<Qf      = ! x:X -> (Pf x)<<Qf"
by (simp add: csp_prefix_ss_def)

lemma Subst_procfun_Nondet_send_prefix[simp]:
  "(a !? x:X -> Pf x)<<Qf      = a !? x:X ->(Pf x)<<Qf"
by (simp add: csp_prefix_ss_def)

(* subst *)

lemma Subst_procfun_Alpha_parallel[simp]: (* <- added for Alpha_parallel *)
  "(P |[X,Y]| Q)<<Pf = (P<<Pf) |[X,Y]| (Q<<Pf)"
by (simp add: Alpha_parallel_def)

lemma Subst_procfun_Pipe[simp]:
  "(P <[left,mid,right]> Q)<<Pf = (P<<Pf) <[left,mid,right]> (Q<<Pf)"
by (simp add: Pipe_def)

(*************************************************************
                   Syntactical functions
 *************************************************************)

(*** guarded fun) ***)

(*** noPN ***)

primrec
  noPN   :: "('p,'a) proc => bool"   (* no Proc_name *)
where
  "noPN STOP          = True"
 |"noPN SKIP          = True"
 |"noPN DIV           = True"
 |"noPN (a -> P)      = noPN P"
 |"noPN (? :X -> Pf)  = (ALL a. noPN (Pf a))"
 |"noPN (P [+] Q)     = (noPN P & noPN Q)"
 |"noPN (P |~| Q)     = (noPN P & noPN Q)"
 |"noPN (!! :C .. Pf) = (ALL c. noPN (Pf c))"
 |"noPN (IF b THEN P ELSE Q) = (noPN P & noPN Q)"
 |"noPN (P |[X]| Q)   = (noPN P & noPN Q)"
 |"noPN (P -- X)      = noPN P"
 |"noPN (P [[r]])     = noPN P"
 |"noPN (P ;; Q)      = (noPN P & noPN Q)"
 |"noPN (P |. n)      = noPN P"
 |"noPN ($p)          = False"

(*** gSKIP ***)

primrec
  gSKIP  :: "('p,'a) proc => bool"   (* guarded SKIP *)
where
  "gSKIP STOP          = True"
 |"gSKIP SKIP          = False"
 |"gSKIP DIV           = True"
 |"gSKIP (a -> P)      = True"
 |"gSKIP (? :X -> Pf)  = True"
 |"gSKIP (P [+] Q)     = (gSKIP P & gSKIP Q)"
 |"gSKIP (P |~| Q)     = (gSKIP P & gSKIP Q)"
 |"gSKIP (!! :C .. Pf) = (ALL c. gSKIP (Pf c))"
 |"gSKIP (IF b THEN P ELSE Q) = (gSKIP P & gSKIP Q)"
 |"gSKIP (P |[X]| Q)   = (gSKIP P | gSKIP Q)"
 |"gSKIP (P -- X)      = False"
 |"gSKIP (P [[r]])     = gSKIP P"
 |"gSKIP (P ;; Q)      = (gSKIP P | gSKIP Q)"
 |"gSKIP (P |. n)      = (gSKIP P | n=0)"
 |"gSKIP ($p)          = False"

(*** no hide ***)

primrec
  noHide :: "('p,'a) proc => bool"   (* no Hide      *)
where
  "noHide STOP          = True"
 |"noHide SKIP          = True"
 |"noHide DIV           = True"
 |"noHide (a -> P)      = noHide P"
 |"noHide (? :X -> Pf)  = (ALL a. noHide (Pf a))"
 |"noHide (P [+] Q)     = (noHide P & noHide Q)"
 |"noHide (P |~| Q)     = (noHide P & noHide Q)"
 |"noHide (!! :C .. Pf) = (ALL c. noHide (Pf c))"
 |"noHide (IF b THEN P ELSE Q) = (noHide P & noHide Q)"
 |"noHide (P |[X]| Q)   = (noHide P & noHide Q)"
 |"noHide (P -- X)      = noPN P"
 |"noHide (P [[r]])     = noHide P"
 |"noHide (P ;; Q)      = (noHide P & noHide Q)"
 |"noHide (P |. n)      = (noHide P | n=0)"
 |"noHide ($p)          = True"

(*** guarded ***)

primrec
  guarded:: "('p,'a) proc => bool"   (* guarded proc *)
where
  "guarded STOP          = True"
 |"guarded SKIP          = True"
 |"guarded DIV           = True"
 |"guarded (a -> P)      = noHide P"
 |"guarded (? :X -> Pf)  = (ALL a. noHide (Pf a))"
 |"guarded (P [+] Q)     = (guarded P & guarded Q)"
 |"guarded (P |~| Q)     = (guarded P & guarded Q)"
 |"guarded (!! :C .. Pf) = (ALL c. guarded (Pf c))"
 |"guarded (IF b THEN P ELSE Q) = (guarded P & guarded Q)"
 |"guarded (P |[X]| Q)   = (guarded P & guarded Q)"
 |"guarded (P -- X)      = noPN P"
 |"guarded (P [[r]])     = guarded P"
 |"guarded (P ;; Q)      = ((guarded P & gSKIP P & noHide Q) |
                           (guarded P & guarded Q))"
 |"guarded (P |. n)      = (guarded P | n=0)"
 |"guarded ($p)          = False"

(*** for process function ***)

(*
consts
  noPNfun   :: "('p => ('q,'a) proc) => bool"
  gSKIPfun  :: "('p => ('q,'a) proc) => bool"
  noHidefun :: "('p => ('q,'a) proc) => bool"
  guardedfun:: "('p => ('q,'a) proc) => bool"

defs
  noPNfun_def   : "noPNfun Pf    == (ALL p. noPN (Pf p))"
  gSKIPfun_def  : "gSKIPfun Pf   == (ALL p. gSKIP (Pf p))"
  noHidefun_def : "noHidefun Pf  == (ALL p. noHide (Pf p))"
  guardedfun_def: "guardedfun Pf == (ALL p. guarded (Pf p))"
*)

definition
  noPNfun   :: "('p => ('q,'a) proc) => bool"
  where
  "noPNfun Pf    == (ALL p. noPN (Pf p))"

definition
  gSKIPfun  :: "('p => ('q,'a) proc) => bool"
  where
  "gSKIPfun Pf   == (ALL p. gSKIP (Pf p))"

definition
  noHidefun :: "('p => ('q,'a) proc) => bool"
  where
  "noHidefun Pf  == (ALL p. noHide (Pf p))"

definition
  guardedfun:: "('p => ('q,'a) proc) => bool"
  where
  "guardedfun Pf == (ALL p. guarded (Pf p))"

  (****** short notations ******)

(* noPN *)

lemma noPN_Rep_int_choice_set[simp]:
  "noPN (!set :Xs .. Pf) = (ALL X. noPN (Pf X))"
by (simp add: Rep_int_choice_ss_def)

lemma noPN_Rep_int_choice_nat[simp]:
  "noPN (!nat :N .. Pf) = (ALL n. noPN (Pf n))"
by (simp add: Rep_int_choice_ss_def)

lemma noPN_Rep_int_choice_com[simp]:
  "noPN (! :X .. Pf) = (ALL a. noPN (Pf a))"
apply (auto simp add: Rep_int_choice_com_def)
apply (drule_tac x="{a}" in spec)
apply (simp)
done

lemma noPN_Rep_int_choice_f[simp]:
  "[| inj f ; ALL a. noPN (Pf a) |] ==> noPN (!<f> :X .. Pf)"
by (simp add: Rep_int_choice_f_def)

lemma noPN_Alpha_parallel[simp]:
  "noPN (P |[X,Y]| Q) = (noPN P & noPN Q)"
by (simp add: Alpha_parallel_def)

(* gSKIP *)

lemma gSKIP_Rep_int_choice_set[simp]:
  "gSKIP (!set :Xs .. Pf) = (ALL X. gSKIP (Pf X))"
by (simp add: Rep_int_choice_ss_def)

lemma gSKIP_Rep_int_choice_nat[simp]:
  "gSKIP (!nat :N .. Pf) = (ALL n. gSKIP (Pf n))"
by (simp add: Rep_int_choice_ss_def)

lemma gSKIP_Rep_int_choice_com[simp]:
  "gSKIP (! :X .. Pf) = (ALL a. gSKIP (Pf a))"
apply (auto simp add: Rep_int_choice_com_def)
apply (drule_tac x="{a}" in spec)
apply (simp)
done

lemma gSKIP_Rep_int_choice_f[simp]:
  "[| inj f ; ALL a. gSKIP (Pf a) |] ==> gSKIP (!<f> :X .. Pf)"
by (simp add: Rep_int_choice_f_def)

lemma gSKIP_Alpha_parallel[simp]:
  "gSKIP (P |[X,Y]| Q) = (gSKIP P | gSKIP Q)"
by (simp add: Alpha_parallel_def)

(* noHide *)

lemma noHide_Rep_int_choice_set[simp]:
  "noHide (!set :Xs .. Pf) = (ALL X. noHide (Pf X))"
by (simp add: Rep_int_choice_ss_def)

lemma noHide_Rep_int_choice_nat[simp]:
  "noHide (!nat :N .. Pf) = (ALL n. noHide (Pf n))"
by (simp add: Rep_int_choice_ss_def)

lemma noHide_Rep_int_choice_com[simp]:
  "noHide (! :X .. Pf) = (ALL a. noHide (Pf a))"
apply (auto simp add: Rep_int_choice_com_def)
apply (drule_tac x="{a}" in spec)
apply (simp)
done

lemma noHide_Rep_int_choice_f[simp]:
  "[| inj f ; ALL a. noHide (Pf a) |]
   ==> noHide (!<f> :X .. Pf)"
by (simp add: Rep_int_choice_f_def)

lemma noHide_Alpha_parallel[simp]:
  "noHide (P |[X,Y]| Q) = (noHide P & noHide Q)"
by (simp add: Alpha_parallel_def)

(* guarded *)

lemma guarded_Rep_int_choice_set[simp]:
  "guarded (!set :Xs .. Pf) = (ALL X. guarded (Pf X))"
by (simp add: Rep_int_choice_ss_def)

lemma guarded_Rep_int_choice_nat[simp]:
  "guarded (!nat :N .. Pf) = (ALL n. guarded (Pf n))"
by (simp add: Rep_int_choice_ss_def)

lemma guarded_Rep_int_choice_com[simp]:
  "guarded (! :X .. Pf) = (ALL a. guarded (Pf a))"
apply (auto simp add: Rep_int_choice_com_def)
apply (drule_tac x="{a}" in spec)
apply (simp)
done

lemma guarded_Rep_int_choice_f[simp]:
  "[| inj f ; ALL a. guarded (Pf a) |]
   ==> guarded (!<f> :X .. Pf)"
by (simp add: Rep_int_choice_f_def)

lemma guarded_Alpha_parallel[simp]:
  "guarded (P |[X,Y]| Q) = (guarded P & guarded Q)"
by (simp add: Alpha_parallel_def)

(* --------- for sinding and receiving --------- *)

(* noPN *)

lemma noPN_Send_prefix[simp]:
  "noPN (a ! v -> P) = noPN(P)"
by (simp add: csp_prefix_ss_def)

lemma noPN_Rec_prefix[simp]:
  "noPN (a ? x:X -> Pf x) = (ALL x. noPN(Pf (inv a x)))"
by (simp add: csp_prefix_ss_def)

lemma noPN_Int_pre_choice[simp]:
  "noPN (! :X -> Pf) = (ALL x. noPN(Pf x))"
by (simp add: csp_prefix_ss_def)

lemma noPN__Nondet_send_prefix[simp]:
  "noPN (a !? x:X -> Pf x) = (ALL x. noPN(Pf (inv a x)))"
by (simp add: csp_prefix_ss_def)

(* gSKIP *)

lemma gSKIP_Send_prefix[simp]:
  "gSKIP (a ! v -> P)"
by (simp add: csp_prefix_ss_def)

lemma gSKIP_Rec_prefix[simp]:
  "gSKIP (a ? x:X -> Pf x)"
by (simp add: csp_prefix_ss_def)

lemma gSKIP_Int_pre_choice[simp]:
  "gSKIP (! :X -> Pf)"
by (simp add: csp_prefix_ss_def)

lemma gSKIP__Nondet_send_prefix[simp]:
  "gSKIP (a !? x:X -> Pf x)"
by (simp add: csp_prefix_ss_def)

(* noHide *)

lemma noHide_Send_prefix[simp]:
  "noHide (a ! v -> P) = noHide(P)"
by (simp add: csp_prefix_ss_def)

lemma noHide_Rec_prefix[simp]:
  "noHide (a ? x:X -> Pf x) = (ALL x. noHide(Pf (inv a x)))"
by (simp add: csp_prefix_ss_def)

lemma noHide_Int_pre_choice[simp]:
  "noHide (! :X -> Pf) = (ALL x. noHide(Pf x))"
by (simp add: csp_prefix_ss_def)

lemma noHide__Nondet_send_prefix[simp]:
  "noHide (a !? x:X -> Pf x) = (ALL x. noHide(Pf (inv a x)))"
by (simp add: csp_prefix_ss_def)

(* guarded *)

lemma guarded_Send_prefix[simp]:
  "guarded (a ! v -> P) = noHide(P)"
by (simp add: csp_prefix_ss_def)

lemma guarded_Rec_prefix[simp]:
  "guarded (a ? x:X -> Pf x) = (ALL x. noHide(Pf (inv a x)))"
by (simp add: csp_prefix_ss_def)

lemma guarded_Int_pre_choice[simp]:
  "guarded (! :X -> Pf) = (ALL x. noHide(Pf x))"
by (simp add: csp_prefix_ss_def)

lemma guarded__Nondet_send_prefix[simp]:
  "guarded (a !? x:X -> Pf x) = (ALL x. noHide(Pf (inv a x)))"
by (simp add: csp_prefix_ss_def)

(* --------- for pipe --------- *)

(* noPN *)

lemma noPN_Pipe[simp]:
  "noPN (P <[left,mid,right]> Q) = ((noPN P) & (noPN Q))"
by (simp add: Pipe_def)

(* gSKIP *)

lemma gSKIP_Pipe[simp]:
  "gSKIP (P <[left,mid,right]> Q) = False"
by (simp add: Pipe_def)

(* noHide *)

lemma noHide_Pipe[simp]:
  "noHide (P <[left,mid,right]> Q) = (noPN P & noPN Q)"
by (simp add: Pipe_def)

(* guarded *)

lemma guarded_Pipe[simp]:
  "guarded (P <[left,mid,right]> Q) = (noPN P & noPN Q)"
by (simp add: Pipe_def)

(*-----------------------------------------------------*
 |                   Substitution                      |
 *-----------------------------------------------------*)

lemma noPN_Subst_lm: "noPN P --> noPN (P<<Pf)"
apply (induct_tac P)
apply (simp_all)
done

lemma noPN_Subst: "noPN P ==> noPN (P<<Pf)"
by (simp add: noPN_Subst_lm)

lemma noPN_Subst_Pf: "noPNfun Pf ==> noPN (P<<Pf)"
apply (induct_tac P)
apply (simp_all)
apply (simp add: noPNfun_def)
done

lemma noHide_Subst_lm: "(noHide P & noHidefun Pf) --> noHide (P<<Pf)"
apply (induct_tac P)
apply (simp_all)
apply (simp add: noPN_Subst)
apply (force)
apply (simp add: noHidefun_def)
done

lemma noHide_Subst: "[| noHide P ; noHidefun Pf |] ==> noHide (P<<Pf)"
by (simp add: noHide_Subst_lm)

lemma gSKIP_Subst_lm: "(gSKIP P) --> gSKIP (P<<Pf)"
apply (induct_tac P)
apply (simp_all)
done

lemma gSKIP_Subst: "(gSKIP P) ==> gSKIP (P<<Pf)"
by (simp add: gSKIP_Subst_lm)

lemma guarded_Subst_lm: "(guarded P & noHidefun Pf) --> guarded (P<<Pf)"
apply (induct_tac P)
apply (simp_all)
apply (simp add: noHide_Subst)
apply (intro allI impI)
apply (simp add: noHide_Subst)
apply (simp add: noPN_Subst)
apply (intro allI impI)
apply (elim conjE exE disjE)
apply (simp add: gSKIP_Subst noHide_Subst)
apply (simp)
apply (force)
done

lemma guarded_Subst: "[| guarded P ; noHidefun Pf |] ==> guarded (P<<Pf)"
by (simp add: guarded_Subst_lm)

(*********************************************************
             termination relation for proc
 *********************************************************)

(* Isabelle 2005
consts
  procterm :: "(('p,'a) proc * ('p,'a) proc) set"

inductive procterm
intros
  "(P, a -> P)             : procterm"
  "(Pf a, ? :X -> Pf)      : procterm"
  "(P, P [+] Q)            : procterm"
  "(Q, P [+] Q)            : procterm"
  "(P, P |~| Q)            : procterm"
  "(Q, P |~| Q)            : procterm"
  "(Pf c, !! :C .. Pf)     : procterm"
  "(P, IF b THEN P ELSE Q) : procterm"
  "(Q, IF b THEN P ELSE Q) : procterm"
  "(P, P |[X]| Q)          : procterm"
  "(Q, P |[X]| Q)          : procterm"
  "(P, P -- X)             : procterm"
  "(P, P [[r]])            : procterm"
  "(P, P ;; Q)             : procterm"
  "(Q, P ;; Q)             : procterm"
  "(P, P |. n)             : procterm"
*)

inductive_set
  procterm :: "(('p,'a) proc * ('p,'a) proc) set"
where
  "(P, a -> P)             : procterm" |
  "(Pf a, ? :X -> Pf)      : procterm" |
  "(P, P [+] Q)            : procterm" |
  "(Q, P [+] Q)            : procterm" |
  "(P, P |~| Q)            : procterm" |
  "(Q, P |~| Q)            : procterm" |
  "(Pf c, !! :C .. Pf)     : procterm" |
  "(P, IF b THEN P ELSE Q) : procterm" |
  "(Q, IF b THEN P ELSE Q) : procterm" |
  "(P, P |[X]| Q)          : procterm" |
  "(Q, P |[X]| Q)          : procterm" |
  "(P, P -- X)             : procterm" |
  "(P, P [[r]])            : procterm" |
  "(P, P ;; Q)             : procterm" |
  "(Q, P ;; Q)             : procterm" |
  "(P, P |. n)             : procterm"

lemma wf_procterm: "wf procterm"
  apply (unfold wf_def)
  apply (intro strip)
  apply (induct_tac x)

  apply (erule allE, erule mp, intro strip,
         erule procterm.cases,
         simp, simp, simp, simp, simp, simp,
         simp, simp, simp, simp, simp, simp,
         simp, simp, simp, simp)+
done

(* procterm.elims in Isabelle 2005
   -->  procterm.cases in Isabelle 2007 *)

(*-------------------------------------------------------*
 |                                                       |
 |      decompostion controlled by Not_Decompo_Flag      |
 |                                                       |
 *-------------------------------------------------------*)
(* Isabelle 2013
consts Not_Decompo_Flag :: bool
defs   Not_Decompo_Flag_def : "Not_Decompo_Flag == True"
*)

definition
  Not_Decompo_Flag :: bool
  where
  Not_Decompo_Flag_def : "Not_Decompo_Flag == True"

lemma on_Not_Decompo_Flag: "Not_Decompo_Flag & R ==> R"
by (simp)

lemma off_Not_Decompo_Flag: "R ==> Not_Decompo_Flag & R"
by (simp add: Not_Decompo_Flag_def)

lemma off_Not_Decompo_Flag_True: "Not_Decompo_Flag"
by (simp add: Not_Decompo_Flag_def)

(*
ML_setup {*
    val ON_Not_Decompo_Flag       = thms "on_Not_Decompo_Flag";
    val OFF_Not_Decompo_Flag      = thms "off_Not_Decompo_Flag";
    val OFF_Not_Decompo_Flag_True = thms "off_Not_Decompo_Flag_True";
*}
for Isabelle 2007
*)

ML {*
    val ON_Not_Decompo_Flag       = @{thms on_Not_Decompo_Flag};
    val OFF_Not_Decompo_Flag      = @{thms off_Not_Decompo_Flag};
    val OFF_Not_Decompo_Flag_True = @{thms off_Not_Decompo_Flag_True};
*}

(*-------------------------------------------------------*
 |                                                       |
 |        rewriting controlled by Not_Rewrite_Flag       |
 |                      CSP-Prover 5                     |
 *-------------------------------------------------------*)
(* Isabelle 2013
consts Not_Rewrite_Flag :: bool
defs   Not_Rewrite_Flag_def : "Not_Rewrite_Flag == True"
*)

definition
  Not_Rewrite_Flag :: bool
  where
  "Not_Rewrite_Flag == True"

lemma on_Not_Rewrite_Flag: "Not_Rewrite_Flag & R ==> R"
by (simp)

lemma off_Not_Rewrite_Flag: "R ==> Not_Rewrite_Flag & R"
by (simp add: Not_Rewrite_Flag_def)

lemma off_Not_Rewrite_Flag_True: "Not_Rewrite_Flag"
by (simp add: Not_Rewrite_Flag_def)

lemmas off_All_Flag_True = off_Not_Decompo_Flag_True
                           off_Not_Rewrite_Flag_True

ML {*
    val ON_Not_Rewrite_Flag       = @{thms on_Not_Rewrite_Flag};
    val OFF_Not_Rewrite_Flag      = @{thms off_Not_Rewrite_Flag};
    val OFF_Not_Rewrite_Flag_True = @{thms off_Not_Rewrite_Flag_True};
    val OFF_All_Flag_True         = @{thms off_All_Flag_True};
*}

(* 0 *)
(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
end


chapter\<open>Heuristics\<close>
text\<open>As part of this inference technique, we make use of certain \emph{heuristics} to abstract away
concrete values into registers. This allows us to generalise from examples of behaviour. These
heuristics are as follows.

\begin{description}
  \item [Store and Reuse] - This heuristic aims to recognise when input values are subsequently used
as an output. Such behaviour is generalised by storing the relevant input in a register, and
replacing the literal output with the content of the register. This enables the EFSM to
\emph{predict} how the underlying system might behave when faced with unseen inputs.
  \item [Increment and Reset] - This heuristic is a naive attempt to introduce additive behaviour.
The idea here is that if we want to merge two transitions with identical input values and different
numeric outputs, for example $\textit{coin}:1[i_0=50]/o_0:=50$ and $\textit{coin}:1[i_0=50]/o_0:=100$,
then the behaviour must depend on the value of an internal variable. This heuristic works by
dropping the input guard and adding an update to a fresh register, in this case summing the current
register value with the input. A similar principle can be applied to other numeric functions such as
subtraction.
  \item [Same Register] - Because of the way heuristics are applied, it is possible for different
registers to be introduced to serve the same purpose. This heuristic attempts to identify when this
has happened and merge the two registers.
  \item [Least Upper Bound] - In certain situations, transitions may produce the same output for
different inputs. This technique forms the least upper bound of the transition guards
--- their disjunction --- such that they can be merged into a single behaviour.
  \item [Distinguishing Guards] - Under certain circumstances, we explicitly do not want to merge
two transitions into one. This heuristic resolves nondeterminism between transitions by attempting
to find apply mutually exclusive guards to each transition such that their behaviour is distinguished.
\end{description}\<close>

section\<open>Store and Reuse\<close>
text\<open>An obvious candidate for generalisation is the ``store and reuse'' pattern. This manifests
itself  when the input of one transition is subsequently used as the output of another. Recognising
this usage pattern allows us to introduce a \emph{storage register} to abstract away concrete data
values and replace two transitions whose outputs differ with a single transition that outputs the
content of the register.\<close>

theory Store_Reuse
imports "../Inference"
begin
datatype ioTag = In | Out

instantiation ioTag :: linorder begin
fun less_ioTag :: "ioTag \<Rightarrow> ioTag \<Rightarrow> bool" where
  "In < Out = True" |
  "Out < _ = False" |
  "In < In = False"

definition less_eq_ioTag :: "ioTag \<Rightarrow> ioTag \<Rightarrow> bool" where
  "less_eq_ioTag x y = (x < y \<or> x = y)"
declare less_eq_ioTag_def [simp]

instance
  apply standard
  using less_ioTag.elims(2) apply fastforce
     apply simp
    apply (metis ioTag.exhaust less_eq_ioTag_def)
  using less_eq_ioTag_def less_ioTag.elims(2) apply blast
  by (metis (full_types) ioTag.exhaust less_eq_ioTag_def less_ioTag.simps(1))
end

type_synonym index = "nat \<times> ioTag \<times> nat"

fun lookup :: "index \<Rightarrow> trace \<Rightarrow> value" where
  "lookup (actionNo, In, inx) t = (let (_, inputs, _) = nth t actionNo in nth inputs inx)" |
  "lookup (actionNo, Out, inx) t = (let (_, _, outputs) = nth t actionNo in nth outputs inx)"

abbreviation actionNum :: "index \<Rightarrow> nat" where
  "actionNum i \<equiv> fst i"

abbreviation ioTag :: "index \<Rightarrow> ioTag" where
  "ioTag i \<equiv> fst (snd i)"

abbreviation inx :: "index \<Rightarrow> nat" where
  "inx i \<equiv> snd (snd i)"

primrec index :: "value list \<Rightarrow> nat \<Rightarrow> ioTag \<Rightarrow> nat \<Rightarrow> index fset" where
  "index [] _ _ _ = {||}" |
  "index (h#t) actionNo io ind = finsert (actionNo, io, ind) (index t actionNo io (ind + 1))"

definition io_index :: "nat \<Rightarrow> value list \<Rightarrow> value list \<Rightarrow> index fset" where
  "io_index actionNo inputs outputs = (index inputs actionNo In 0) |\<union>| (index outputs actionNo Out 0)"

definition indices :: "trace \<Rightarrow> index fset" where
  "indices e = foldl (|\<union>|) {||} (map (\<lambda>(actionNo, (label, inputs, outputs)). io_index actionNo inputs outputs) (enumerate 0 e))"

definition get_by_id_intratrace_matches :: "trace \<Rightarrow> (index \<times> index) fset" where
  "get_by_id_intratrace_matches e = ffilter (\<lambda>(a, b). lookup a e = lookup b e \<and> actionNum a \<le> actionNum b \<and> a \<noteq> b) (indices e |\<times>| indices e)"

(*
  If the EFSM is nondeterministic, we need to make sure it chooses the right path so that it recognises
  the input trace.
*)
definition i_step :: "execution \<Rightarrow> iEFSM \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> label \<Rightarrow> inputs \<Rightarrow> (transition \<times> cfstate \<times> tids \<times> registers) option" where
  "i_step tr e s r l i = (let
    poss_steps = (i_possible_steps e s r l i);
    possibilities = ffilter (\<lambda>(u, s', t). recognises_execution (tm e) s' (evaluate_updates t i r) tr) poss_steps in
    case random_member possibilities of
      None \<Rightarrow> None |
      Some (u, s', t) \<Rightarrow>
      Some (t, s', u, (evaluate_updates t i r))
  )"

type_synonym match = "(((transition \<times> tids) \<times> ioTag \<times> nat) \<times> ((transition \<times> tids) \<times> ioTag \<times> nat))"

definition "exec2trace t = map (\<lambda>(label, inputs, _). (label, inputs)) t"
primrec (nonexhaustive) walk_up_to :: "nat \<Rightarrow> iEFSM \<Rightarrow> nat \<Rightarrow> registers \<Rightarrow> trace \<Rightarrow> (transition \<times> tids)" where
  "walk_up_to n e s r (h#t) =
    (case (i_step (exec2trace t) e s r (fst h) (fst (snd h))) of
      (Some (transition, s', uid, updated)) \<Rightarrow> (case n of 0 \<Rightarrow> (transition, uid) | Suc m \<Rightarrow> walk_up_to m e s' updated t)
    )"

definition find_intertrace_matches_aux :: "(index \<times> index) fset \<Rightarrow> iEFSM \<Rightarrow> trace \<Rightarrow> match fset" where
  "find_intertrace_matches_aux intras e t = fimage (\<lambda>((e1, io1, inx1), (e2, io2, inx2)). (((walk_up_to e1 e 0 <> t), io1, inx1), ((walk_up_to e2 e 0 <> t), io2, inx2))) intras"

definition find_intertrace_matches :: "log \<Rightarrow> iEFSM \<Rightarrow> match list" where
  "find_intertrace_matches l e = filter (\<lambda>((e1, io1, inx1), (e2, io2, inx2)). e1 \<noteq> e2) (concat (map (\<lambda>(t, m). sorted_list_of_fset (find_intertrace_matches_aux m e t)) (zip l (map get_by_id_intratrace_matches l))))"

definition total_max_input :: "iEFSM \<Rightarrow> nat" where
  "total_max_input e = (case EFSM.max_input (tm e) of None \<Rightarrow> 0 | Some i \<Rightarrow> i)"

definition total_max_reg :: "iEFSM \<Rightarrow> nat" where
  "total_max_reg e = (case EFSM.max_reg (tm e) of None \<Rightarrow> 0 | Some i \<Rightarrow> i)"

definition remove_guard_add_update :: "transition \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> transition" where
  "remove_guard_add_update t inputX outputX = \<lparr>
    Label = (Label t), Arity = (Arity t),
    Guards = (filter (\<lambda>g. \<not> gexp_constrains g (V (vname.I inputX))) (Guards t)),
    Outputs = (Outputs t),
    Updates = (outputX, (V (vname.I inputX)))#(Updates t)
  \<rparr>"

definition generalise_output :: "transition \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> transition" where
  "generalise_output t regX outputX = \<lparr>
      Label = (Label t),
      Arity = (Arity t),
      Guards = (Guards t),
      Outputs = list_update (Outputs t) outputX (V (R regX)),
      Updates = (Updates t)
    \<rparr>"

definition is_generalised_output_of :: "transition \<Rightarrow> transition \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "is_generalised_output_of t' t r p = (t' = generalise_output t r p)"

primrec count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count _ [] = 0" |
  "count a (h#t) = (if a = h then 1+(count a t) else count a t)"

definition replaceAll :: "iEFSM \<Rightarrow> transition \<Rightarrow> transition \<Rightarrow> iEFSM" where
  "replaceAll e old new = fimage (\<lambda>(uid, (from, dest), t). if t = old then (uid, (from, dest), new) else (uid, (from, dest), t)) e"

primrec generalise_transitions :: "((((transition \<times> tids) \<times> ioTag \<times> nat) \<times> (transition \<times> tids) \<times> ioTag \<times> nat) \<times>
     ((transition \<times> tids) \<times> ioTag \<times> nat) \<times> (transition \<times> tids) \<times> ioTag \<times> nat) list \<Rightarrow> iEFSM \<Rightarrow> iEFSM" where
  "generalise_transitions [] e = e" |
  "generalise_transitions (h#t) e = (let
    ((((orig1, u1), _), (orig2, u2), _), (((gen1, u1'), _), (gen2, u2), _)) = h in
   generalise_transitions t (replaceAll (replaceAll e orig1 gen1) orig2 gen2))"

definition strip_uids :: "(((transition \<times> tids) \<times> ioTag \<times> nat) \<times> (transition \<times> tids) \<times> ioTag \<times> nat) \<Rightarrow> ((transition \<times> ioTag \<times> nat) \<times> (transition \<times> ioTag \<times> nat))" where
  "strip_uids x = (let (((t1, u1), io1, in1), (t2, u2), io2, in2) = x in ((t1, io1, in1), (t2, io2, in2)))"

definition modify :: "match list \<Rightarrow> tids \<Rightarrow> tids \<Rightarrow> iEFSM \<Rightarrow> iEFSM option" where
  "modify matches u1 u2 old = (let relevant = filter (\<lambda>(((_, u1'), io, _), (_, u2'), io', _). io = In \<and> io' = Out \<and> (u1 = u1' \<or> u2 = u1' \<or> u1 = u2' \<or> u2 = u2')) matches;
                                   newReg = case max_reg old of None \<Rightarrow> 1 | Some r \<Rightarrow> r + 1;
                                   replacements = map (\<lambda>(((t1, u1), io1, inx1), (t2, u2), io2, inx2). (((remove_guard_add_update t1 inx1 newReg, u1), io1, inx1), (generalise_output t2 newReg inx2, u2), io2, inx2)) relevant;
                                   comparisons = zip relevant replacements;
                                   stripped_replacements = map strip_uids replacements;
                                   to_replace = filter (\<lambda>(_, s). count (strip_uids s) stripped_replacements > 1) comparisons in
                                if to_replace = [] then None else Some ((generalise_transitions to_replace old))
                              )"

(* type_synonym update_modifier = "transition \<Rightarrow> transition \<Rightarrow> nat \<Rightarrow> iEFSM \<Rightarrow> iEFSM \<Rightarrow> (iEFSM \<times> (nat \<Rightarrow> nat) \<times> (nat \<Rightarrow> nat)) option" *)
definition heuristic_1 :: "log \<Rightarrow> update_modifier" where
  "heuristic_1 l t1 t2 s new _ old check = (case modify (find_intertrace_matches l old) t1 t2 new of
    None \<Rightarrow> None |
    Some e \<Rightarrow> if check (tm e) then Some e else None
  )"

lemma remove_guard_add_update_preserves_outputs:
  "Outputs (remove_guard_add_update t i r) = Outputs t"
  by (simp add: remove_guard_add_update_def)

lemma remove_guard_add_update_preserves_label:
  "Label (remove_guard_add_update t i r) = Label t"
  by (simp add: remove_guard_add_update_def)

lemma remove_guard_add_update_preserves_arity:
  "Arity (remove_guard_add_update t i r) = Arity t"
  by (simp add: remove_guard_add_update_def)

lemmas remove_guard_add_update_preserves = remove_guard_add_update_preserves_label
                                           remove_guard_add_update_preserves_arity
                                           remove_guard_add_update_preserves_outputs

definition is_generalisation_of :: "transition \<Rightarrow> transition \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "is_generalisation_of t' t i r = (t' = remove_guard_add_update t i r \<and>
                                    i < Arity t \<and>
                                    (\<exists>v. Eq (V (vname.I i)) (L v) \<in> set (Guards t)) \<and>
                                    r \<notin> set (map fst (Updates t)))"

lemma generalise_output_preserves_label:
  "Label (generalise_output t r p) = Label t"
  by (simp add: generalise_output_def)

lemma generalise_output_preserves_arity:
  "Arity (generalise_output t r p) = Arity t"
  by (simp add: generalise_output_def)

lemma generalise_output_preserves_guard:
  "Guards (generalise_output t r p) = Guards t"
  by (simp add: generalise_output_def)

lemma generalise_output_preserves_output_length:
  "length (Outputs (generalise_output t r p)) = length (Outputs t)"
  by (simp add: generalise_output_def)

lemma generalise_output_preserves_updates:
  "Updates (generalise_output t r p) = Updates t"
  by (simp add: generalise_output_def)

lemmas generalise_output_preserves = generalise_output_preserves_label
                                     generalise_output_preserves_arity
                                     generalise_output_preserves_output_length
                                     generalise_output_preserves_guard
                                     generalise_output_preserves_updates

definition is_proper_generalisation_of :: "transition \<Rightarrow> transition \<Rightarrow> iEFSM \<Rightarrow> bool" where
 "is_proper_generalisation_of t' t e = (\<exists>i \<le> total_max_input e. \<exists> r \<le> total_max_reg e.
                                        is_generalisation_of t' t i r \<and>
                                        (\<forall>u \<in> set (Updates t). fst u \<noteq> r) \<and>
                                        (\<forall>i \<le> max_input (tm e). \<forall>u \<in> set (Updates t). fst u \<noteq> r)
                                       )"

(* Recognising the same input used in multiple guards *)
definition generalise_input :: "transition \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> transition" where
  "generalise_input t r i = \<lparr>
      Label = Label t,
      Arity = Arity t,
      Guards = map (\<lambda>g. case g of Eq (V (I i')) (L _) \<Rightarrow> if i = i' then Eq (V (I i)) (V (R r)) else g | _ \<Rightarrow> g) (Guards t),
      Outputs = Outputs t,
      Updates = Updates t
    \<rparr>"

fun structural_count :: "((transition \<times> ioTag \<times> nat) \<times> (transition \<times> ioTag \<times> nat)) \<Rightarrow> ((transition \<times> ioTag \<times> nat) \<times> (transition \<times> ioTag \<times> nat)) list \<Rightarrow> nat" where
  "structural_count _ [] = 0" |
  "structural_count a (((t1', io1', i1'), (t2', io2', i2'))#t) = (
    let ((t1, io1, i1), (t2, io2, i2)) = a in
    if same_structure t1 t1' \<and> same_structure t2 t2' \<and>
       io1 = io1' \<and> io2 = io2' \<and>
       i1 = i1' \<and> i2 = i2'
    then
      1+(structural_count a t)
    else
      structural_count a t
    )"

definition remove_guards_add_update :: "transition \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> transition" where
  "remove_guards_add_update t inputX outputX = \<lparr>
    Label = (Label t), Arity = (Arity t),
    Guards = [],
    Outputs = (Outputs t),
    Updates = (outputX, (V (vname.I inputX)))#(Updates t)
  \<rparr>"

definition modify_2 :: "match list \<Rightarrow> tids \<Rightarrow> tids \<Rightarrow> iEFSM \<Rightarrow> iEFSM option" where
  "modify_2 matches u1 u2 old = (let relevant = filter (\<lambda>(((_, u1'), io, _), (_, u2'), io', _). io = In \<and> io' = In \<and> (u1 = u1' \<or> u2 = u1' \<or> u1 = u2' \<or> u2 = u2')) matches;
                                   newReg = case max_reg old of None \<Rightarrow> 1 | Some r \<Rightarrow> r + 1;
                                   replacements = map (\<lambda>(((t1, u1), io1, inx1), (t2, u2), io2, inx2).
                                                  (((remove_guards_add_update t1 inx1 newReg, u1), io1, inx1),
                                                    (generalise_input t2 newReg inx2, u2), io2, inx2)) relevant;
                                   comparisons = zip relevant replacements;
                                   stripped_replacements = map strip_uids replacements;
                                   to_replace = filter (\<lambda>(_, s). structural_count (strip_uids s) stripped_replacements > 1) comparisons in
                                if to_replace = [] then None else Some ((generalise_transitions to_replace old))
                              )"

(* type_synonym update_modifier = "transition \<Rightarrow> transition \<Rightarrow> nat \<Rightarrow> iEFSM \<Rightarrow> iEFSM \<Rightarrow> (iEFSM \<times> (nat \<Rightarrow> nat) \<times> (nat \<Rightarrow> nat)) option" *)
definition heuristic_2 :: "log \<Rightarrow> update_modifier" where
  "heuristic_2 l t1 t2 s new _ old check = (case modify_2 (find_intertrace_matches l old) t1 t2 new of
    None \<Rightarrow> None |
    Some e \<Rightarrow> if check (tm e) then Some e else None
  )"
hide_const ioTag.In

end