section \<open> RoboChart Meta-Model \<close>

theory MetaModel
  imports Actions
begin

subsection \<open> State Machine Syntax \<close>

text \<open> All state machine statespace types extend the following type which provides a state control variable \<close>

type_synonym ID = String.literal

alphabet robochart_ctrl =
  rc_ctrl :: ID

type_synonym 's rcst = "'s robochart_ctrl_scheme"
type_synonym ('s, 'e) RoboAction = "('s robochart_ctrl_scheme, 'e) Actions.Action"
type_synonym 's RoboPred = "'s robochart_ctrl_scheme upred"

translations
  (type) "'s rcst" <= (type) "'s robochart_ctrl_scheme"
  (type) "('s, 'e) RoboAction" <= (type) "('s rcst, 'e) Action"
  (type) "'s RoboPred" <= (type) "'s rcst upred"

abbreviation "rc_state \<equiv> robochart_ctrl.more\<^sub>L"

notation rc_state ("\<^bold>r")

syntax
  "_svid_rc_state"  :: "svid" ("\<^bold>r")

translations
  "_svid_rc_state" == "CONST rc_state"
  "_svid_dot \<^bold>r x" <= "x ;\<^sub>L \<^bold>r"

record ('s, 'e) Transition =
  tn_source    :: ID
  tn_target    :: ID
  tn_trigger   :: "('s, 'e) Actions.Action option"
  tn_condition :: "'s upred"
  tn_action    :: "('s, 'e) Actions.Action"

declare Transition.defs [simp]

record ('s, 'e) Node =
  n_name   :: "ID"
  n_entry  :: "('s, 'e) Action"
  n_during :: "('s, 'e) Action"
  n_exit   :: "('s, 'e) Action"

declare Node.defs [simp]

record ('s, 'e) StateMachine =
  sm_initial     :: "String.literal" ("init\<index>")
  sm_finals      :: "String.literal list" ("finals\<index>")
  sm_nodes       :: "('s, 'e) Node list" ("nodes\<index>")
  sm_transitions :: "('s, 'e) Transition list" ("\<^bold>T\<index>")

declare StateMachine.defs [simp]

thm set_map

definition sm_node_names :: "('s, 'e) StateMachine \<Rightarrow> String.literal set" ("nnames\<index>") where
"sm_node_names sm \<equiv> n_name ` set(sm_nodes sm)"

definition sm_inters :: "('s, 'e) StateMachine \<Rightarrow> ('s, 'e) Node list" where
"sm_inters sm = filter (\<lambda> n. n_name n \<notin> set(sm_finals sm)) (sm_nodes sm)"

definition sm_inter_names ("inames\<index>") where
"sm_inter_names sm \<equiv> n_name ` set (sm_inters sm)"

abbreviation sm_final_names ("fnames\<index>") where
"sm_final_names M \<equiv> set (finals\<^bsub>M\<^esub>)"

definition sm_node_map :: "('s, 'e) StateMachine \<Rightarrow> (ID \<rightharpoonup> ('s, 'e) Node)" ("nmap\<index>") where
"sm_node_map M = map_of (map (\<lambda> n. (n_name n, n)) (sm_nodes M))"

definition sm_trans_map :: "('s, 'e) StateMachine \<Rightarrow> (ID \<rightharpoonup> ('s, 'e) Transition list)" ("tmap\<index>") where
"sm_trans_map M = map_of (map (\<lambda> n. (n_name n, filter (\<lambda> t. tn_source t = n_name n) (sm_transitions M))) (sm_nodes M))"

lemma dom_sm_node_map: "dom(nmap\<^bsub>M\<^esub>) = nnames\<^bsub>M\<^esub>"
  using image_iff by (force simp add: sm_node_map_def sm_node_names_def dom_map_of_conv_image_fst)

lemma dom_sm_trans_map: "dom(tmap\<^bsub>M\<^esub>) = nnames\<^bsub>M\<^esub>"
  using image_iff by (force simp add: sm_trans_map_def sm_node_names_def dom_map_of_conv_image_fst)

lemma nnames_finite: "finite(nnames\<^bsub>M\<^esub>)"
  by (force simp add: sm_node_names_def)

abbreviation sm_init_node :: "('s, 'e) StateMachine \<Rightarrow> ('s, 'e) Node" ("ninit\<index>") where
"sm_init_node M \<equiv> the (sm_node_map M (sm_initial M))"

subsection \<open> Well-Formedness \<close>

locale WfStateMachine =
  fixes M :: "('s, 'm) StateMachine" (structure)
  \<comment> \<open> The list of nnames is a set \<close>
  assumes nnames_distinct: "distinct (map n_name (nodes\<^bsub>M\<^esub>))"
  and init_is_state: "init \<in> nnames"
  and init_not_final: "init \<notin> fnames"
  and trans_wf: " \<And> t. t \<in> set(\<^bold>T) \<Longrightarrow> tn_source t \<in> inames \<and> tn_target t \<in> nnames"
begin
  lemma init_is_inter: "init \<in> inames"
    using init_is_state init_not_final by (auto simp add: sm_inters_def sm_inter_names_def sm_node_names_def)

  lemma nmap_init: "nmap init = Some ninit"
    by (metis domIff dom_sm_node_map init_is_state option.exhaust_sel)

  lemma n_name_init: "n_name ninit = init"
  proof (simp add: sm_node_map_def)
    have "map_of (map (\<lambda>n. (n_name n, n)) (sm_nodes M)) init = Some (the (map_of (map (\<lambda>n. (n_name n, n)) (sm_nodes M)) init))"
      by (metis (no_types) nmap_init sm_node_map_def)
    then show "n_name (the (map_of (map (\<lambda>n. (n_name n, n)) (sm_nodes M)) init)) = init"
      using map_of_SomeD by force
  qed

  lemma nmap_name:
    assumes "n \<in> set(sm_nodes M)"
    shows "nmap (n_name n) = Some n"
  proof -
    have "distinct (map fst (map (\<lambda>n. (n_name n, n)) (sm_nodes M)))"
      by (simp add: comp_def nnames_distinct)
    with assms show ?thesis
      by (simp add: sm_node_map_def)
  qed

  lemma ninit_is_node: "ninit \<in> set(sm_nodes M)"
    using init_is_state nmap_name by (auto simp add: sm_node_names_def)

  lemma tmap_node_in_trans:
    assumes "n \<in> nnames" "ts \<in> ran(tmap)"
    shows "set(ts) \<subseteq> set(\<^bold>T)"
    using assms by (auto simp add: sm_trans_map_def ran_distinct nnames_distinct comp_def)

  lemma node_tran_exists:
    assumes "n \<in> nnames" "t \<in> set(the(tmap n))"
    shows "t \<in> set(\<^bold>T)"
    by (metis (mono_tags, hide_lams) assms(1) assms(2) domIff dom_sm_trans_map in_mono init_is_state option.collapse ranI tmap_node_in_trans)

end

method check_machine uses defs =
  (unfold_locales,
   simp_all add: defs sm_node_names_def sm_inter_names_def sm_inters_def, safe, simp_all)

subsection \<open> State Machine Semantics \<close>

abbreviation "trigger_semantics t null_event \<equiv>
  (case tn_trigger t of Some e \<Rightarrow> if productive e then e else sync null_event | None \<Rightarrow> sync null_event)"

no_utp_lift tn_condition

definition tr_semantics :: "('s, 'e) Transition \<Rightarrow> (unit, 'e) chan \<Rightarrow> ('s, 'e) RoboAction" ("\<lbrakk>_\<rbrakk>\<^sub>T") where
"tr_semantics t null_event \<equiv>
  tn_condition t \<oplus>\<^sub>p rc_state \<^bold>&
  rc_state:[trigger_semantics t null_event ; tn_action t]\<^sub>A\<^sup>+ ; rc_ctrl := \<guillemotleft>tn_target t\<guillemotright>"

definition node_semantics ::
  "('s, 'e) StateMachine \<Rightarrow> (unit, 'e) chan \<Rightarrow> ('s, 'e) Node \<Rightarrow> ('s, 'e) RoboAction" ("_;_ \<turnstile> \<lbrakk>_\<rbrakk>\<^sub>N" [10,0,0] 10) where
  "node_semantics M null_event node  =
  (rc_state:[n_entry node]\<^sub>A\<^sup>+ ;
   (foldr (\<box>) (map (\<lambda> t. \<lbrakk>t\<rbrakk>\<^sub>T null_event) (the (tmap\<^bsub>M\<^esub> (n_name node)))) stop) ;
   rc_state:[n_exit node]\<^sub>A\<^sup>+)"

definition sm_semantics :: "('s, 'e) StateMachine \<Rightarrow> (unit, 'e) chan \<Rightarrow> ('s, 'e) RoboAction" ("\<lbrakk>_\<rbrakk>\<^sub>M") where
"sm_semantics M null_event =
    (rc_ctrl := \<guillemotleft>sm_initial M\<guillemotright> ;
    iteration (map (\<lambda> n. (&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright>, M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)) (sm_inters M)))"

lemmas sm_sem_def = sm_semantics_def node_semantics_def sm_inters_def sm_inter_names_def

lemma tr_semantics_subst_ctrl: "[&rc_ctrl \<mapsto>\<^sub>s \<guillemotleft>k\<guillemotright>] \<dagger> (\<lbrakk>a\<rbrakk>\<^sub>T null_event) = \<lbrakk>a\<rbrakk>\<^sub>T null_event"
  by (simp add: tr_semantics_def action_simp usubst unrest frame_asubst)

lemma tr_choice_subst_ctrl:
  "[&rc_ctrl \<mapsto>\<^sub>s \<guillemotleft>k\<guillemotright>] \<dagger> foldr (\<box>) (map (\<lambda>t. \<lbrakk>t\<rbrakk>\<^sub>T null_event) ts) stop = foldr (\<box>) (map (\<lambda>t. \<lbrakk>t\<rbrakk>\<^sub>T null_event) ts) stop"
  by (induct ts, simp_all add: action_simp usubst tr_semantics_subst_ctrl)

lemma sm_semantics_subst_ctrl:
  "[&rc_ctrl \<mapsto>\<^sub>s \<guillemotleft>k\<guillemotright>] \<dagger> node_semantics M null_event node = node_semantics M null_event node"
  by (simp add: node_semantics_def action_simp frame_asubst tr_choice_subst_ctrl unrest)

subsection \<open> Theorems \<close>

lemma productive_tr_semantics [closure]: "productive (\<lbrakk>t\<rbrakk>\<^sub>T null_event)"
  by (cases "tn_trigger t", auto simp add: tr_semantics_def action_rep_eq closure unrest)

lemma productive_node_semantics:
  "productive (M;null_event \<turnstile> \<lbrakk>node\<rbrakk>\<^sub>N)"
proof -
  have "\<And> ts. productive (foldr (\<box>) (map (\<lambda> t. \<lbrakk>t\<rbrakk>\<^sub>T null_event) ts) stop)"
    by (rename_tac ts, induct_tac ts, auto simp add: action_rep_eq closure, simp add: closure productive_Productive)
  hence "productive (foldr (\<box>) (map (\<lambda> t. \<lbrakk>t\<rbrakk>\<^sub>T null_event) (the (tmap\<^bsub>M\<^esub> (n_name node)))) stop)"
    by blast
  thus ?thesis
    by (simp add: action_rep_eq closure node_semantics_def)
qed

lemma Sup_Collect_as_UINF:
  "\<Sqinter> {P x | x. x \<in> A} = (\<Sqinter> x \<in> A \<bullet> P x)"
  apply (simp add: UINF_as_Sup[THEN sym], rel_simp)
  apply (rule cong[of Sup Sup])
   apply (auto)
  done

lemma Sup_Collect_2_as_UINF:
  "\<Sqinter> {P x y | x y. (x, y) \<in> A} = (\<Sqinter> (x, y) \<in> A \<bullet> P x y)"
  apply (simp add: UINF_as_Sup[THEN sym], rel_simp)
  apply (rule cong[of Sup Sup])
   apply (auto)
  done

lemma UINF_Collect: "(\<Sqinter> b \<in> {F(x)| x . x \<in> A} \<bullet> b) = (\<Sqinter> x \<in> A \<bullet> F(x))"
  by (simp add: Sup_Collect_as_UINF UINF_as_Sup)

lemma ueq_literlise [lit_simps]:
  "(\<guillemotleft>x = y\<guillemotright>) = (\<guillemotleft>x\<guillemotright> =\<^sub>u \<guillemotleft>y\<guillemotright>)"
  by (rel_auto)

lemma seq_refine_mono:
  fixes P\<^sub>1 P\<^sub>2 Q\<^sub>1 Q\<^sub>2 :: "('s, 'e) Action"
  assumes "P\<^sub>1 \<sqsubseteq> Q\<^sub>1" "P\<^sub>2 \<sqsubseteq> Q\<^sub>2"
  shows "P\<^sub>1 ; P\<^sub>2 \<sqsubseteq> Q\<^sub>1 ; Q\<^sub>2"
  using assms
  by (simp add: action_rep_eq seqr_mono)

lemma StateMachine_refine_intro:
  fixes
    S :: "('s, 'e) RoboAction" and
    M :: "('s, 'e) StateMachine"
  assumes
    "WfStateMachine M"
    "S \<sqsubseteq> (M;null_event \<turnstile> \<lbrakk>ninit\<^bsub>M\<^esub>\<rbrakk>\<^sub>N)"
    "\<And> n. n \<in> inames\<^bsub>M\<^esub> \<Longrightarrow> S \<sqsubseteq> S ; (M;null_event \<turnstile> \<lbrakk>the(nmap\<^bsub>M\<^esub> n)\<rbrakk>\<^sub>N)"
  shows "S \<sqsubseteq> \<lbrakk>M\<rbrakk>\<^sub>M null_event"
proof -
  interpret wf: WfStateMachine M
    by (simp add: assms)
  have 1: "\<And>n. n \<in> set(sm_inters M) \<Longrightarrow> productive (M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)"
    by (simp add: productive_node_semantics)
  have 2: "S \<sqsubseteq> rc_ctrl := \<guillemotleft>init\<^bsub>M\<^esub>\<guillemotright> ; [\<not> (\<Sqinter> (b, P) \<in> (\<lambda>n. (&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright>, M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)) ` set(sm_inters M) \<bullet> b)]\<^sub>A"
  proof -
    have a:"(\<lambda> n. (&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright> :: 's RoboPred, M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)) ` set(sm_inters M) =
             {(&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright>, M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)| n . n \<in> set(sm_inters M)}"
      by (auto)
    have b: "(\<guillemotleft>init\<^bsub>M\<^esub>\<guillemotright> \<notin>\<^sub>u \<guillemotleft>inames\<^bsub>M\<^esub>\<guillemotright>) = false"
      by (literalise, metis (full_types) false_alt_def true_alt_def utp_pred_laws.compl_top_eq wf.init_is_inter)
    have "(\<Sqinter> (b, P) \<in> (\<lambda>n. (&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright> :: 's RoboPred, M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)) ` set(sm_inters M) \<bullet> b) =
           (\<Sqinter> (b, P) \<in> {(&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright>, M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)| n . n \<in> set(sm_inters M)} \<bullet> b)"
      by (simp add: a)
    also have "...  = (\<Sqinter> b \<in> {&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright>| n . n \<in> set(sm_inters M)} \<bullet> b)"
      by (rel_auto)
    also have "... = (&rc_ctrl \<in>\<^sub>u \<guillemotleft>inames\<^bsub>M\<^esub>\<guillemotright>)"
      apply (simp add: UINF_Collect, rel_auto)
      apply (simp add: sm_inter_names_def sm_sem_def(3))
      using sm_inter_names_def apply fastforce
      done
    finally show ?thesis
      by (simp add: action_simp usubst b miracle_top)
  qed
  have 3: "S \<sqsubseteq> rc_ctrl := \<guillemotleft>init\<^bsub>M\<^esub>\<guillemotright> ; [\<not> (&rc_ctrl \<in>\<^sub>u \<guillemotleft>inames\<^bsub>M\<^esub>\<guillemotright>)]\<^sub>A" (is "?lhs \<sqsubseteq> ?rhs")
  proof -
    have "?rhs = [\<guillemotleft>init\<^bsub>M\<^esub>\<guillemotright> \<notin>\<^sub>u \<guillemotleft>inames\<^bsub>M\<^esub>\<guillemotright>]\<^sub>A ; rc_ctrl := \<guillemotleft>init\<^bsub>M\<^esub>\<guillemotright>"
      by (simp add: action_simp usubst)
    also have "... = [false]\<^sub>A ; rc_ctrl := \<guillemotleft>init\<^bsub>M\<^esub>\<guillemotright>"
      by (literalise, simp add: wf.init_is_inter)
    also have "... = miracle"
      by (simp add: action_simp)
    finally
    show ?thesis by (simp add: miracle_top)
  qed
  have 4:"\<And>n. n \<in> set(sm_inters M) \<Longrightarrow> S \<sqsubseteq> rc_ctrl := \<guillemotleft>init\<^bsub>M\<^esub>\<guillemotright> ; [&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright>]\<^sub>A ; (M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)"
  proof -
    fix n
    assume a:"n \<in> set(sm_inters M)"
    show "S \<sqsubseteq> rc_ctrl := \<guillemotleft>init\<^bsub>M\<^esub>\<guillemotright> ; [&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright>]\<^sub>A ; (M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)"
    proof (cases "n=ninit\<^bsub>M\<^esub>")
      case True
      hence "[&rc_ctrl \<mapsto>\<^sub>s \<guillemotleft>init\<^bsub>M\<^esub>\<guillemotright>] \<dagger> (M;null_event \<turnstile> \<lbrakk>ninit\<^bsub>M\<^esub>\<rbrakk>\<^sub>N) = (M;null_event \<turnstile> \<lbrakk>ninit\<^bsub>M\<^esub>\<rbrakk>\<^sub>N)"
        by (simp add: sm_semantics_subst_ctrl)
      with True assms(2) show ?thesis
        by (simp add: action_simp usubst wf.n_name_init)
    next
      case False
      with a have "(init\<^bsub>M\<^esub> = n_name n) = False"
      proof -
        have "n \<in> {n. n \<in> set(sm_nodes M) \<and> \<not> n_name n \<in> set(finals\<^bsub>M\<^esub>)}"
          by (metis a set_filter sm_sem_def(3))
        then have "nmap\<^bsub>M\<^esub> (n_name n) = Some n"
          using WfStateMachine.nmap_name wf.WfStateMachine_axioms by blast
        then show ?thesis
          using False by fastforce
      qed
      hence "((\<guillemotleft>init\<^bsub>M\<^esub>\<guillemotright> =\<^sub>u \<guillemotleft>n_name n\<guillemotright>) :: 's RoboPred) = false"
        by (rel_auto)
      thus ?thesis
        by (simp add: action_simp usubst miracle_top)
    qed
  qed
  have 5: "\<And>n. n \<in> set(sm_inters M) \<Longrightarrow> S \<sqsubseteq> S ; [&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright>]\<^sub>A ; (M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)"
  proof -
    fix n
    assume a:"n \<in> set(sm_inters M)"
    have "S \<sqsubseteq> S ; (M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)"
    proof -
      have f1: "{n. (n::('s, 'e) Node) \<in> set(sm_nodes M) \<and> \<not> n_name n \<in> set(finals\<^bsub>M\<^esub>)} = set(sm_inters M)"
        by (simp add: sm_sem_def(3))
      then have "n_name n \<in> n_name ` {n. (n::('s, 'e) Node) \<in> set(sm_nodes M) \<and> \<not> n_name n \<in> set(finals\<^bsub>M\<^esub>)}"
        using a by force
      then have "n_name n \<in> inames\<^bsub>M\<^esub>"
        by (simp add: sm_inter_names_def sm_sem_def(3))
      then show ?thesis
        using f1 a assms(3) wf.nmap_name by fastforce
    qed
    moreover have "S ; (M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N) \<sqsubseteq> S ; [&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright>]\<^sub>A ; (M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)"
      by (rule seq_refine_mono, simp_all add: asm_pre_refine)
    ultimately show "S \<sqsubseteq> S ; [&rc_ctrl =\<^sub>u \<guillemotleft>n_name n\<guillemotright>]\<^sub>A ; (M;null_event \<turnstile> \<lbrakk>n\<rbrakk>\<^sub>N)"
      using dual_order.trans by blast
  qed

  show ?thesis
    apply (simp add: sm_semantics_def)
    apply (rule iterate_refine_intro)
    apply (simp_all)
    apply (auto simp add: 1 2 3 4 5)
    done
qed
(*
lemma StateMachine_sinv_refine_intro:
  fixes
    S :: "('s, 'e) RoboAction" and
    M :: "('s, 'e) StateMachine"
  assumes
    "WfStateMachine M"
    "sinv\<^sub>A(s) \<sqsubseteq> (M;null_event \<turnstile> \<lbrakk>ninit\<^bsub>M\<^esub>\<rbrakk>\<^sub>N)"
    "\<And> n. n \<in> inames\<^bsub>M\<^esub> \<Longrightarrow> S \<sqsubseteq> S ; (M;null_event \<turnstile> \<lbrakk>the(nmap\<^bsub>M\<^esub> n)\<rbrakk>\<^sub>N)"
  shows "S \<sqsubseteq> \<lbrakk>M\<rbrakk>\<^sub>M null_event"
*)

(*
lemma "sinv\<^sub>A (&rc_ctrl \<in>\<^sub>u \<guillemotleft>nnames\<^bsub>M\<^esub>\<guillemotright>) \<sqsubseteq> r:[P]\<^sub>A\<^sup>+"
  apply (simp add: action_rep_eq, safe)
   apply (rdes_refine_split)
  apply (rel_simp)

lemma
  assumes "WfStateMachine M"
  shows "sinv\<^sub>A(&rc_ctrl \<in>\<^sub>u \<guillemotleft>nnames\<^bsub>M\<^esub>\<guillemotright>) \<sqsubseteq> \<lbrakk>M\<rbrakk>\<^sub>M null_event"
proof (rule StateMachine_refine_intro[OF assms])
  show "sinv\<^sub>A(&rc_ctrl \<in>\<^sub>u \<guillemotleft>nnames\<^bsub>M\<^esub>\<guillemotright>) \<sqsubseteq> (M;null_event \<turnstile> \<lbrakk>ninit\<^bsub>M\<^esub>\<rbrakk>\<^sub>N)"
    apply (simp add: node_semantics_def)
*)

subsection \<open> Divergence Freedom \<close>

locale DivFreeSM = WfStateMachine +
  assumes
    n_entry_divf: "\<And> n. n \<in> set(nodes) \<Longrightarrow> divf \<sqsubseteq> n_entry n" and
    n_during_divf: "\<And> n. n \<in> set(nodes) \<Longrightarrow> divf \<sqsubseteq> n_exit n" and
    n_exit_divf: "\<And> n. n \<in> set(nodes) \<Longrightarrow> divf \<sqsubseteq> n_exit n" and
    tn_trigger_divf: "\<And> t e. \<lbrakk> t \<in> set(\<^bold>T); tn_trigger t = Some e \<rbrakk> \<Longrightarrow> divf \<sqsubseteq> e" and
    tn_action_divf: "\<And> t. t \<in> set(\<^bold>T) \<Longrightarrow> divf \<sqsubseteq> tn_action t"

lemma DivFreeSM_divf:
  assumes "DivFreeSM M"
  shows "divf \<sqsubseteq> \<lbrakk>M\<rbrakk>\<^sub>M \<epsilon>"
proof (rule StateMachine_refine_intro)
  interpret dvs: DivFreeSM M
    by (simp add: assms)
  show "WfStateMachine M"
    by (simp add: dvs.WfStateMachine_axioms)
  have "\<And> n t. \<lbrakk> n \<in> nnames\<^bsub>M\<^esub>; t \<in> set(the (tmap\<^bsub>M\<^esub> n)) \<rbrakk> \<Longrightarrow> divf \<sqsubseteq> \<lbrakk>t\<rbrakk>\<^sub>T \<epsilon>"
  proof -
    fix n t
    assume a: "n \<in> nnames\<^bsub>M\<^esub>" "t \<in> set(the (tmap\<^bsub>M\<^esub> n))"
    have "divf \<sqsubseteq> trigger_semantics t \<epsilon>"
    proof (cases "tn_trigger t")
      case None
      then show ?thesis by (simp add: divf_sync)
    next
      case (Some a)
      then show ?thesis
        using a(1) a(2) divf_sync dvs.node_tran_exists dvs.tn_trigger_divf by fastforce
    qed
    thus "divf \<sqsubseteq> \<lbrakk>t\<rbrakk>\<^sub>T \<epsilon>"
      apply (simp add: tr_semantics_def)
      apply (rule divf_guard)
      apply (rule divf_seq_refine)
       apply (rule divf_seq_refine)
        apply (rule divf_frame_ext)
        apply (simp)
       apply (rule divf_frame_ext)
      using a(1) a(2) dvs.node_tran_exists dvs.tn_action_divf apply blast
      apply (simp add: divf_assigns)
      done
  qed
  hence b:"\<And> n. n \<in> inames\<^bsub>M\<^esub> \<Longrightarrow> divf \<sqsubseteq> (M;\<epsilon> \<turnstile> \<lbrakk>the (nmap\<^bsub>M\<^esub> n)\<rbrakk>\<^sub>N)"
    apply (simp add: node_semantics_def)
    apply (rule divf_seq_refine)
    apply (rule divf_frame_ext)
    apply (smt dvs.n_entry_divf dvs.nmap_name filter_is_subset imageE option.sel sm_inter_names_def sm_inters_def subset_eq)
    apply (rule divf_seq_refine)
     apply (rule divf_extchoice_fold_refine)
    apply (auto)
    apply (smt dvs.nmap_name filter_is_subset image_iff option.sel sm_inter_names_def sm_inters_def sm_node_names_def subset_code(1))
    apply (rule divf_frame_ext)
    apply (smt dvs.n_exit_divf dvs.nmap_name filter_is_subset imageE option.sel sm_inter_names_def sm_inters_def subset_eq)
    done
  show "divf \<sqsubseteq> (M;\<epsilon> \<turnstile> \<lbrakk>ninit\<^bsub>M\<^esub>\<rbrakk>\<^sub>N)"
    by (simp add: b dvs.init_is_inter)
  show "\<And>n. n \<in> inames\<^bsub>M\<^esub> \<Longrightarrow> divf \<sqsubseteq> divf ; (M;\<epsilon> \<turnstile> \<lbrakk>the (nmap\<^bsub>M\<^esub> n)\<rbrakk>\<^sub>N)"
    by (simp add: b divf_seq_refine)
qed

subsection \<open> Transition and State Parsers \<close>

syntax
  "_transition" :: "id \<Rightarrow> id \<Rightarrow> raction \<Rightarrow> logic \<Rightarrow> raction \<Rightarrow> logic"
  ("from _ to _ trigger _ condition _ action _" [0,0,0,0,10] 10)

  "_transition_action" :: "id \<Rightarrow> id \<Rightarrow> logic \<Rightarrow> logic"
  ("from _ to _ action _" [0,0,10] 10)

  "_transition_condition" :: "id \<Rightarrow> id \<Rightarrow> logic \<Rightarrow> logic"
  ("from _ to _ condition _" [0,0,10] 10)

  "_transition_condition_action" :: "id \<Rightarrow> id \<Rightarrow> logic \<Rightarrow> raction \<Rightarrow> logic"
  ("from _ to _ condition _ action _" [0,0,0,10] 10)

  "_transition_trigger" :: "id \<Rightarrow> id \<Rightarrow> raction \<Rightarrow> logic"
  ("from _ to _ trigger _" [0,0,10] 10)

  "_transition_trigger_action" :: "id \<Rightarrow> id \<Rightarrow> raction \<Rightarrow> raction \<Rightarrow> logic"
  ("from _ to _ trigger _ action _" [0,0,0,10] 10)

  "_transition_trigger_condition" :: "id \<Rightarrow> id \<Rightarrow> raction \<Rightarrow> logic \<Rightarrow> logic"
  ("from _ to _ trigger _ condition _" [0,0,0,10] 10)

  "_state" :: "raction \<Rightarrow> raction \<Rightarrow> raction \<Rightarrow> logic"
  ("entry _ during _ exit _" [0,0,10] 10)

  "_state_entry" :: "raction \<Rightarrow> logic"
  ("entry _" [10] 10)

translations
  "_transition s1 s2 e b a" =>
  "CONST Transition.make IDLIT(s1) IDLIT(s2) (CONST Some e) b a"

  "_transition_action s1 s2 a" => "CONST Transition.make IDLIT(s1) IDLIT(s2) (CONST None) true a"

  "_transition_condition s1 s2 b" => "CONST Transition.make IDLIT(s1) IDLIT(s2) (CONST None) b (CONST Actions.skips)"

  "_transition_condition_action s1 s2 b a" => "CONST Transition.make IDLIT(s1) IDLIT(s2) (CONST None) b a"

  "_transition_trigger s1 s2 t" => "CONST Transition.make IDLIT(s1) IDLIT(s2) (CONST Some t) true (CONST Actions.skips)"

  "_transition_trigger_action s1 s2 t a" => "CONST Transition.make IDLIT(s1) IDLIT(s2) (CONST Some t) true a"

  "_transition_trigger_condition s1 s2 t b" => "CONST Transition.make IDLIT(s1) IDLIT(s2) (CONST Some t) b (CONST Actions.skips)"

  "_state e d x" => "CONST Node.make (CONST undefined) e d x"

  "_state_entry e" => "CONST Node.make (CONST undefined) e skip skip"

utp_lift_notation Transition.make (0 1 2 4)

term "from s1 to s2 trigger y := 1 ; x?(y) ; z!(1) condition b action a"
term "from s1 to s2 action x := []"
term "from s1 to s2 trigger e"
term "entry e during d exit x"
term "entry e"

term "entry skip during skip exit skip"

subsection \<open> Proof Tactics \<close>

method sm_induct uses simps wf = auto intro!: StateMachine_refine_intro[OF wf] dlockf_refine_intro simp add: simps
method sm_calc uses simps = simp_all add: simps sm_sem_def, simp_all add: action_simp usubst alpha

end


theory Proofs5
  imports Requirements VCTheoryLemmas
begin

definition inv5 where "inv5 s \<equiv> R5 s \<and> extraInv s"

thm extraInv_def

lemma minimalOpened_R5: "toEnvP s1 \<and> toEnvP s2 \<and> toEnvP s0 \<and> substate s1 s2 \<and> substate s2 s0 \<and> substate s0 s \<and>
toEnvNum s1 s2 = 1 \<and> toEnvNum s2 s0 < 9 \<and> getPstate s0 Controller' = Controller'minimalOpened' \<and>
ltime s0 Controller' = 10  \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Init'init' = Controller'minimalOpened' \<longrightarrow> ltime s1 Init'init' \<le> 10) \<and>
(\<forall>s2. toEnvP s2 \<and> substate s2 s \<and> getPstate s2 Init'init' = Controller'minimalOpened' \<longrightarrow>
      (\<forall>s1. toEnvP s1 \<and> substate s1 s2 \<and> toEnvNum s1 s2 < ltime s2 Init'init' \<longrightarrow>
            getPstate s1 Init'init' = Controller'minimalOpened')) \<and>
(\<forall>s1. toEnvP s1 \<and>
      substate s1 s \<and> (getPstate s1 Init'init' = Controller'isOpened' \<or> getPstate s1 Init'init' = Controller'minimalOpened') \<longrightarrow>
      getVarBool s1 Controller'minimalOpened')
\<longrightarrow> \<not> (\<not> getVarBool s1 open' \<and> getVarBool s2 open')"
  using substate_trans
  by (smt (verit, ccfv_SIG) BitM_inc_eq eval_nat_numeral(2) inc.simps(2) nat_add_left_cancel_less plus_1_eq_Suc toEnvNum3)

lemma isOpened_timeout_R5: "toEnvP s1 \<and> toEnvP s2 \<and> toEnvP s0 \<and> substate s1 s2 \<and> substate s2 s0 \<and> substate s0 s \<and>
toEnvNum s1 s2 = 1 \<and> toEnvNum s2 s0 < 9 \<and> getPstate s0 Controller' = Controller'isOpened' \<and>
ltime s0 Controller' = 90  \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Init'init' = Controller'isOpened' \<longrightarrow> ltime s1 Init'init' \<le> 90) \<and>
(\<forall>s3. toEnvP s3 \<and> substate s3 s \<and> getPstate s3 Init'init' = Controller'isOpened' \<longrightarrow>
      (\<forall>s1. toEnvP s1 \<and> substate s1 s3 \<and> toEnvNum s1 s3 < ltime s3 Init'init' \<longrightarrow> getPstate s1 Init'init' = Controller'isOpened') \<and>
      (\<forall>s2. toEnvP s2 \<and> substate s2 s3 \<and> toEnvNum s2 s3 + 1 < ltime s3 Init'init' \<longrightarrow> \<not> getVarBool s2 Init')) \<and>
(\<forall>s1. toEnvP s1 \<and>
      substate s1 s \<and> (getPstate s1 Init'init' = Controller'isOpened' \<or> getPstate s1 Init'init' = Controller'minimalOpened') \<longrightarrow>
      getVarBool s1 Controller'minimalOpened')
\<longrightarrow>  \<not>(\<not> getVarBool s1 open' \<and> getVarBool s2 open')"
  apply(rule impI)
  apply(rule cut_rl[of "toEnvNum s1 s0 < ltime s0 Controller'"])
  using substate_trans
   apply meson
  using toEnvNum3 by auto

lemma isOpened_R5: "toEnvP s1 \<and> toEnvP s2 \<and> toEnvP s0 \<and> substate s1 s2 \<and> substate s2 s0 \<and> substate s0 s \<and>
toEnvNum s1 s2 = 1 \<and> toEnvNum s2 s0 < 9 \<and> getPstate s0 Controller' = Controller'isOpened' \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Init'init' = Controller'minimalOpened' \<longrightarrow> ltime s1 Init'init' \<le> 10) \<and>
(\<forall>s2. toEnvP s2 \<and> substate s2 s \<and> getPstate s2 Init'init' = Controller'minimalOpened' \<longrightarrow>
      (\<forall>s1. toEnvP s1 \<and> substate s1 s2 \<and> toEnvNum s1 s2 < ltime s2 Init'init' \<longrightarrow>
            getPstate s1 Init'init' = Controller'minimalOpened')) \<and>
(\<forall>s1. toEnvP s1 \<and>
      substate s1 s \<and> (getPstate s1 Init'init' = Controller'isOpened' \<or> getPstate s1 Init'init' = Controller'minimalOpened') \<longrightarrow>
      getVarBool s1 Controller'minimalOpened') \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Init'init' = Controller'isOpened' \<longrightarrow> ltime s1 Init'init' \<le> 90) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Init'init' = Controller'isOpened' \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = 1 \<and>
          toEnvNum s2 s1 = ltime s1 Init'init' \<and>
          getPstate s2 Init'init' = Controller'minimalOpened' \<and>
          ltime s2 Init'init' = 10 \<and> \<not> getVarBool s3 EntranceController'isOpened')) \<and>
(\<forall>s3. toEnvP s3 \<and> substate s3 s \<and> getPstate s3 Init'init' = Controller'isOpened' \<longrightarrow>
      (\<forall>s1. toEnvP s1 \<and> substate s1 s3 \<and> toEnvNum s1 s3 < ltime s3 Init'init' \<longrightarrow> getPstate s1 Init'init' = Controller'isOpened') \<and>
      (\<forall>s2. toEnvP s2 \<and> substate s2 s3 \<and> toEnvNum s2 s3 + 1 < ltime s3 Init'init' \<longrightarrow> \<not> getVarBool s2 Init'))
\<longrightarrow> \<not> (\<not> getVarBool s1 open' \<and> getVarBool s2 open')"
  apply(rule impI)
  apply(cases "toEnvNum s1 s0 < ltime s0 Controller'")
  using substate_trans
   apply meson
  apply(rule exE[of " (\<lambda> s2. \<exists> s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s0 \<and>
          toEnvNum s2 s3 = 1 \<and>
          toEnvNum s2 s0 = ltime s0 Init'init' \<and>
          getPstate s2 Init'init' = Controller'minimalOpened' \<and> ltime s2 Init'init' = 10  \<and> \<not> getVarBool s3 EntranceController'isOpened')"])
apply blast
  apply(drule exE)
   prefer 2
   apply assumption
  subgoal for s3 s4
    apply(rule cut_rl[of "substate s3 s0"])
    apply(cases "substate s2 s3")
     apply(rule impE[OF minimalOpened_R5[of s1 s2 s3 s]])
    using substate_trans toEnvNum3
       apply (smt (verit) leD le_neq_implies_less le_trans less_or_eq_imp_le toEnvNum_substate1)
      apply assumption
     apply(rule cut_rl[of "s1=s3"])
    using substate_trans
      apply meson
     apply(rule cut_rl[of "toEnvNum s1 s0 = toEnvNum s3 s0"])
    using toEnvNum_eq_imp_eq2 substate_trans
      apply meson
     apply(rule le_antisym)
      apply(rule cut_rl[of "substate s3 s2 \<and> s2 \<noteq> s3"])
    using toEnvNum_substate2  toEnvNum_eq_imp_eq2 toEnvNum3[of s1 s2 s0]
       apply (metis Suc_leI order.order_iff_strict plus_1_eq_Suc)
    using substate_linear substate_refl
      apply meson
     apply arith
    using substate_trans by meson
  done

theorem proof_5_1: "VC1 inv5 s0"
  apply(unfold VC1_def inv5_def R5_def extraInv_def)
  by auto

theorem proof_5_2: "VC2 R5 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC2_def)
  apply simp
  apply(unfold R5_def)
  apply(rule impI)
  apply(rule conjI)
   apply simp
  subgoal premises vc_prems
   apply((rule allI)+)
    apply(rule impI)
    apply(simp split: if_splits)
using vc_prems
  by (metis One_nat_def)
  done

theorem proof_5_500: "VC500 R5 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC500_def)
  apply simp
  apply(unfold R5_def)
  apply(rule impI)
  apply(rule conjI)
   apply simp
  subgoal premises vc_prems
    apply((rule allI)+)
    apply(rule impI)
    apply(simp split: if_splits)
    subgoal for s1 s2
      apply(rule cut_rl[of "toEnvNum s2 s0 <10"])
      using vc_prems substate_refl apply(metis One_nat_def)
      by simp
    using vc_prems by(metis One_nat_def)
  done

end


section \<open>Generic Block Allocator\<close>
theory Sep_Block_Allocator
imports "../../lib/Monad"
begin

  text \<open>This theory specifies the concepts of memory allocation and deallocation.
    It is parameterized over the actual type of blocks.
  \<close>

  subsection \<open>Memory and Addresses\<close>

  text \<open>A memory is a list of allocated or already freed blocks.
    Allocated blocks are modeled by @{term \<open>Some blk\<close>},
    freed blocks are modeled by @{term \<open>None\<close>}
  \<close>
  datatype 'blk memory = MEMORY (the_memory: "'blk option list")
  define_lenses memory

  text \<open>An address indexes a block, and then addresses into the value of this block.\<close>
  datatype 'baddr addr = ADDR nat 'baddr

  text \<open>A pointer is either \<open>null\<close>, or an address\<close>
  datatype 'addr rptr = RP_NULL | RP_ADDR (the_addr: "'addr")
  hide_const (open) the_addr

  text \<open>Type-class to model that there is a base address.\<close>
  (* TODO: Remove from semantics, move to reasoning infrastructure? *)
  class this_addr = fixes this_addr :: 'a

  text \<open>We immediately show that the typeclass is not empty.
    This avoids confusion of the code generator with lemmas depending on this typeclass.\<close>
  typedecl this_addr_witness
  instantiation this_addr_witness :: this_addr begin
    instance ..
  end

  subsection \<open>Memory Functions\<close>

  text \<open>
    We specify the standard functions \<open>alloc\<close>, \<open>free\<close>, \<open>load\<close>, and \<open>store\<close>.
    They are parameterized over load and store functions for blocks.

    Additionally, we specify a \<open>check_ptr\<close> function, that asserts that a pointer is valid,
    i.e., is either \<open>null\<close>, or points to an allocated block, and its block address is valid
    for this block.
  \<close>

  locale block_allocator1 =
    fixes static_err :: 'err
      and mem_err :: 'err
      and bload :: "'baddr::this_addr \<Rightarrow> ('val,_,'block,'err) M"
      and bstore :: "'val \<Rightarrow> 'baddr \<Rightarrow> (unit,_,'block,'err) M"
      and bcheck_addr :: "'baddr \<Rightarrow> (unit,_,'block,'err) M"
  begin

    text \<open>Allocate a new block, and a pointer to its start\<close>
    definition alloc :: "'block \<Rightarrow> ('baddr addr rptr,_,'block memory,'err) M"
    where "alloc init \<equiv> zoom (lift_lens static_err the_memory\<^sub>L) (doM {
      blocks \<leftarrow> Monad.get;
      let bi = length blocks;
      let blocks = blocks @ [Some init];
      Monad.set blocks;
      return (RP_ADDR (ADDR bi this_addr))
    })"

    text \<open>Free a block, specified by a pointer to its start\<close>
    definition free :: "'baddr addr rptr \<Rightarrow> (unit,_,'block memory,'err) M"
    where "free \<equiv>
      \<lambda>RP_ADDR (ADDR bi ba) \<Rightarrow> doM {
          fcheck mem_err (ba=this_addr);
          \<comment>\<open> TODO: Use load here! \<close>
          let L = lift_lens static_err the_memory\<^sub>L \<bullet> (lift_lens mem_err (idx\<^sub>L bi));
          blk \<leftarrow> use L;
          fcheck mem_err (blk \<noteq> None);
          L ::= None
        }
      | _ \<Rightarrow> fail mem_err"

    text \<open>We define a lens that focuses a block index. \<close>
    (* TODO: Can we define lenses to focus addresses/pointers instead? *)
    definition "lens_of_bi bi \<equiv> the_memory\<^sub>L \<bullet>\<^sub>L idx\<^sub>L bi \<bullet>\<^sub>L the\<^sub>L"
    abbreviation "elens_of_bi bi \<equiv> lift_lens mem_err (lens_of_bi bi)"
    lemma lens_of_bi[simp, intro!]: "hlens (lens_of_bi bi)"
      unfolding lens_of_bi_def by auto

    text \<open>Load from an address\<close>
    definition "load \<equiv> \<lambda>RP_ADDR (ADDR bi ba) \<Rightarrow> zoom (elens_of_bi bi) (bload ba) | _ \<Rightarrow> fail mem_err"
    text \<open>Store at an address\<close>
    definition "store \<equiv> \<lambda>x. \<lambda>RP_ADDR (ADDR bi ba) \<Rightarrow> zoom (elens_of_bi bi) (bstore x ba) | _ \<Rightarrow> fail mem_err"

    text \<open>Check that pointer is valid\<close>
    definition "check_ptr \<equiv> \<lambda>RP_NULL \<Rightarrow> return () | RP_ADDR (ADDR bi ba) \<Rightarrow> zoom (elens_of_bi bi) (bcheck_addr ba)"

    text \<open>The empty memory\<close>
    definition "empty_memory \<equiv> MEMORY []"

  end

  subsection \<open>Isabelle Code Generator Setup\<close>
  text \<open>Setup to make the semantics executable inside Isabelle/HOL\<close>

  lemmas block_allocator1_code[code] =
    block_allocator1.alloc_def
    block_allocator1.free_def
    block_allocator1.lens_of_bi_def
    block_allocator1.load_def
    block_allocator1.store_def
    block_allocator1.check_ptr_def
    block_allocator1.empty_memory_def

end


theory SpreadGetSet
  imports Main
 "build_spread/Spread_dargentfull_CorresProof"

begin
context spread_dargentfull begin
definition find_position :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat"
  where "find_position si offset  = (offset div si, offset mod si)"

definition get_bit :: "(('a::len0) word)['n::finite] \<Rightarrow> nat \<Rightarrow> bool"
  where "get_bit arr pos =
                (let (byte, off) = find_position LENGTH('a) pos in
                 arr.[byte] !! off )"

definition raw_get_bit :: "(('a::len0) word)['n::finite] \<Rightarrow> nat \<Rightarrow> 'a word"
  where "raw_get_bit arr pos =
                (let (byte, off) = find_position LENGTH('a) pos in
                 arr.[byte] && 2^off )"

definition size_of_arr :: "(('a::len0) word)['n::finite] \<Rightarrow> nat"
  where "size_of_arr _ = CARD('n)"

definition size_of_arr_bits :: "(('a::len0) word)['n::finite] \<Rightarrow> nat"
  where "size_of_arr_bits _ = LENGTH('a)*CARD('n)"

ML \<open>
fun getter_sanity_tac ctxt =
 let
    val gets = Proof_Context.get_thms ctxt
    val get  = Proof_Context.get_thm ctxt
  in
  K (print_tac ctxt "debut_getter")
THEN'
 (asm_full_simp_tac (ctxt addsimps [(get "find_position_def")])
THEN'
 (fn i =>
TRY (REPEAT_ALL_NEW (eresolve_tac ctxt @{thms exE conjE}) i))
(* THEN' K (print_tac ctxt "coucou") *)
THEN' custom_get_set_different_field_tac ctxt
) end
\<close>

lemma wesh : "x < LENGTH('a) \<Longrightarrow> (((2 ^ x) :: ('a :: len0)  word) !! n) = (x = n)"
  by sorry
ML \<open>
fun setter_sanity_tac ctxt =
 let
    val gets = Proof_Context.get_thms ctxt
    val get  = Proof_Context.get_thm ctxt
  in
  K (print_tac ctxt "debut")
THEN'
 (asm_full_simp_tac (ctxt addsimps
 [get "find_position_def", get "size_of_arr_bits_def"]))
THEN'
(asm_full_simp_tac ((clear_simpset ctxt) addsimps
 (gets "numeral.simps")))
THEN' asm_full_simp_tac ctxt
(* THEN'  K (print_tac ctxt "suite") *)
THEN'
 (fn i =>
TRY (REPEAT_ALL_NEW (eresolve_tac ctxt @{thms exE conjE}) i))
(* THEN'  K (print_tac ctxt "resuite") *)
 THEN'  (fn i =>
TRY (REPEAT_ALL_NEW (eresolve_tac ctxt @{thms less_zeroE less_SucE}) i))

 (* THEN' K (print_tac ctxt "coucou")  *)
THEN_ALL_NEW custom_get_set_different_field_tac (ctxt addsimps @{thms wesh})
 end
\<close>
ML \<open>
fun prove_thm ctxt assms concl tactic =
let
val clean = HOLogic.mk_Trueprop o strip_atype
val thm0 = mk_meta_imps (map clean assms) (concl |> clean) ctxt
val names =  Variable.add_free_names ctxt thm0 []
in
Goal.prove ctxt names [] thm0
( fn {context, prems} => tactic context 1)
end
\<close>

ML \<open>
val uvals =
Symtab.lookup (UVals.get @{theory}) "spread_dargentfull.c"
|> the
(* Filter those with custom layouts*)
 |> get_uval_custom_layout_records
\<close>
ML \<open>
 val uval0 = hd uvals
\<close>

ML \<open>
val (info0, lay0) =
case get_uval_layout uval0 of
CustomLayout (info,
Const ("Option.option.Some", _) $
( Const ("Cogent.ptr_layout.LayRecord", _) $
layout)) =>
(info,
layout |> HOLogic.dest_list
|> map HOLogic.dest_prod
|> map (apfst HOLogic.dest_string)
|> Symtab.make
)

val field0 = hd info0
val layfield0 = Symtab.lookup lay0 (# name field0) |> the
\<close>

ML \<open>
val get_data =
get_uval_name uval0 ^ "_C.data_C"
\<close>

ML \<open>
fun make_getter_sanity_thm ctxt layfield (field_info : field_layout) =
let
val ass =
  @{term
  "\<lambda>  lay data.
   (\<forall> x\<in> set(layout_taken_bit_list lay).
  get_bit (data s) x = get_bit (data t) x)
  "
  } $ layfield $ (Syntax.read_term ctxt get_data)
val concl = @{term "\<lambda> getter . getter s = getter t"  }
        $ # isa_getter field_info
in
prove_thm ctxt [ass] concl getter_sanity_tac
end

\<close>
ML \<open>
fun make_setter_sanity_thm ctxt layfield (field_info : field_layout) =
let

 val data = Syntax.read_term ctxt get_data
val ass1 =
  @{term
  "\<lambda>  data .x < size_of_arr_bits (data s)
  "
  } $ data
val ass2 =
  @{term
  "\<lambda>  lay .x \<notin> set (layout_taken_bit_list lay)
  "
  } $ layfield
val concl = @{term "\<lambda> data setter .
   raw_get_bit (data (setter s b)) x = raw_get_bit (data s) x"  }
        $ data
        $ # isa_setter field_info
in
prove_thm ctxt [ass1, ass2] concl (fn ctxt => fn _ => print_tac ctxt "coucuo" THEN cheat_tactic ctxt)(* setter_sanity_tac *)
end
\<close>

ML \<open>
fun make_getset_sanity_thms ctxt (uval : field_layout uval) : (thm * thm) list =
let
val (info, lays) =
case get_uval_layout uval of
CustomLayout (info,
Const ("Option.option.Some", _) $
( Const ("Cogent.ptr_layout.LayRecord", _) $
layout)) =>
(info,
layout |> HOLogic.dest_list
|> map HOLogic.dest_prod
|> map (apfst HOLogic.dest_string)
|> Symtab.make
)
in
map (
fn field =>
let val lay = Symtab.lookup lays (# name field) |> the in
(make_getter_sanity_thm ctxt  lay field,
make_setter_sanity_thm ctxt lay field)
end
)

 info

end
\<close>

lemma raw_get_bit_eq : "raw_get_bit x n = raw_get_bit y n \<Longrightarrow> get_bit x n = get_bit y n"
  by sorry

lemma find_pos_split : " P (find_position q x)
  = ((\<forall> p r. find_position q x = (p, r) \<longrightarrow>
r < q \<longrightarrow> p < n div q \<longrightarrow>  P (p, r))
\<and> (\<forall> r. find_position q x = (n div q, r) \<longrightarrow> r < n mod q \<longrightarrow> P ( (n div q), r) )
\<and> (\<forall> p r. find_position q x = (p, r) \<longrightarrow> (x \<ge> n \<or> q = 0) \<longrightarrow> P ( p, r) )
)
"
  by sorry

lemma "x < size_of_arr_bits (data_C s) \<Longrightarrow>
    x \<notin> set (layout_taken_bit_list (LayBitRange (64, 2))) \<Longrightarrow>
    get_bit (data_C (deref_d21_set_b s b)) x = get_bit (data_C s) x "
  apply(rule raw_get_bit_eq )
apply(simp add:raw_get_bit_def)
apply( split find_pos_split[of _ _ _  32])

end

lemma "x < size_of_arr_bits (data_C s) \<Longrightarrow>
    x \<notin> set (layout_taken_bit_list
               (LayVariant (Suc 0, Suc 0) [(''A'', 0, LayBitRange (Suc 0, 0)), (''B'', Suc 0, LayBitRange (Suc 0, 67))])) \<Longrightarrow>
    raw_get_bit (data_C (deref_d14_set_a s b)) x = raw_get_bit (data_C s) x "
  apply(tactic \<open>setter_sanity_tac @{context} 1\<close> )
(* ca ne marche pas ! *)

lemma "x < size_of_arr_bits (data_C s) \<Longrightarrow>
    x \<notin> set (layout_taken_bit_list (LayBitRange (64, 2))) \<Longrightarrow>
    raw_get_bit (data_C (deref_d21_set_b s b)) x = raw_get_bit (data_C s) x "
apply(tactic \<open>setter_sanity_tac @{context} 1\<close> )

ML \<open>
val thms = make_getset_sanity_thms @{context} uval0
\<close>

end

end


theory SNS_IAS_Eduroam_Spoofing
imports
  Iptables_Semantics.Parser
begin

section\<open>Example: Eduroam and sns.ias Firewall Script\<close>

definition "everything_but_my_ip = all_but_those_ips [(ipv4addr_of_dotdecimal (131,159,207,206), 32)]"

text\<open>Incoming: everything but my IP\<close>
definition "ipassignment_incoming = [(Iface ''wlan0'', everything_but_my_ip), (Iface ''lo'', [(0,0)])]"

lemma "ipassmt_sanity_nowildcards (map_of ipassignment_incoming)" by eval

text\<open>Outgoing: only my IP\<close>
definition "ipassignment_outgoing = [(Iface ''wlan0'',  [(ipv4addr_of_dotdecimal (131,159,207,206), 32)]), (Iface ''lo'', [(0,0)])]"

lemma "ipassmt_sanity_nowildcards (map_of ipassignment_outgoing)" by eval

parse_iptables_save eduroam_fw="eduroam_iptables-save"

thm eduroam_fw_def
thm eduroam_fw_INPUT_default_policy_def

value[code] "debug_ipassmt_ipv4 ipassignment_incoming (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))"

value[code] "unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)"

value[code] "collect_ifaces (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))"

lemma "ipassmt_sanity_defined (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)) (map_of_ipassmt ipassignment_incoming)" by eval
lemma "ipassmt_sanity_defined (unfold_ruleset_OUTPUT eduroam_fw_OUTPUT_default_policy (map_of_string_ipv4 eduroam_fw)) (map_of_ipassmt ipassignment_outgoing)" by eval

value[code] "debug_ipassmt_ipv4 ipassignment_incoming (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))"
value[code] "debug_ipassmt_ipv4 ipassignment_outgoing (unfold_ruleset_OUTPUT eduroam_fw_OUTPUT_default_policy (map_of_string_ipv4 eduroam_fw))"

text\<open>The ruleset\<close>
lemma "check_simple_fw_preconditions (upper_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))))" by eval
value[code] "map simple_rule_ipv4_toString (to_simple_firewall (upper_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)))))"
lemma "simple_fw_valid (to_simple_firewall (upper_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)))))" by eval
lemma "simple_fw_valid (to_simple_firewall (lower_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)))))" by eval

text\<open>We do not need to call things such as @{const transform_optimize_dnf_strict} because the
     firewall already is in @{const normalized_nnf_match} (required for @{const no_spoofing_iface})\<close>
lemma "transform_optimize_dnf_strict (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)) =
          unfold_ruleset_INPUT action.Drop (map_of_string_ipv4 eduroam_fw)" by eval

text\<open>The ruleset prevents spoofed incoming packets\<close>
lemma "no_spoofing_iface (Iface ''wlan0'')
        (map_of_ipassmt ipassignment_incoming) (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))" by eval

text\<open>Ruleset does not prevent that I'm spoofing (which is not necessary anyways since I need root right to spoof, which
      would also enable me to deactivate the firewall). This is only a one-user laptop!\<close>

lemma "transform_optimize_dnf_strict (unfold_ruleset_OUTPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)) =
        unfold_ruleset_OUTPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)" by eval

lemma "\<not> no_spoofing_iface (Iface ''wlan0'')
        (map_of_ipassmt ipassignment_outgoing) (unfold_ruleset_OUTPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))" by eval

end


(*
 * Copyright 2022, Proofcraft Pty Ltd
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Named_Eta_Test
imports Lib.Named_Eta
begin

experiment
begin

declare [[eta_contract=false]] (* for display only, it does not affect terms *)

(* tactical invocation example *)
schematic_goal
  "\<And>y. ?Q y False \<Longrightarrow> ?P y (\<lambda>x. f x)"
  apply (tactic \<open>named_eta_tac "x" @{context}\<close>)
  apply assumption
  done

(* method invocation example *)
schematic_goal
  "\<And>y. ?Q y False \<Longrightarrow> ?P y (\<lambda>x. f x)"
  apply (named_eta x)
  apply assumption
  done

lemma
  "P x (\<lambda>z. g (\<lambda>x. f x) z)"
  "\<And>P z. Q z \<Longrightarrow> P (\<lambda>x. f x)"
  apply -
  (* only affects one subgoal *)
  prefer 2
  apply (named_eta x)
  prefer 2
  (* only contract "z" *)
  apply (named_eta z)
  (* now only contract "x" *)
  apply (named_eta x)
  oops

lemma (* nested lambdas *)
  "\<lbrakk> X; P (\<lambda>x. (f (\<lambda>x. g y x))) \<rbrakk> \<Longrightarrow> P (\<lambda>x. (f (\<lambda>x. g y x)))"
  apply (named_eta x)
  apply assumption
  done

ML \<open>
  (* nameless abstractions: *)
  val t = Abs ("", @{typ bool}, @{term "f (\<lambda>x. g x) :: bool \<Rightarrow> bool"} $ Bound 0)
  val ct = Thm.cterm_of @{context} t
  (* contracts only the nameless "a" lambda: *)
  val thm = Named_Eta.named_eta_conv "" @{context} ct
\<close>

end

end


(*  Title:        Notions of Topology for C2KA
    Author:       Maxime Buyse <maxime.buyse at polytechnique.edu>, 2019
    Maintainers:  Maxime Buyse <maxime.buyse at polytechnique.edu> and Jason Jaskolka <jason.jaskolka at carleton.ca>
*)

section \<open>Notions of Topology for \CCKAabbrv \label{sec:topology}\<close>

text \<open>
Orbits, stabilisers, and fixed points are notions that allow us to perceive a kind of topology of a system
with respect to the stimulus-response relationships among system agents. In this context, the term ``topology''
is used to capture the relationships (influence) and connectedness via stimuli of the agents in a distributed
system. It intends to capture a kind of reachability in terms of the possible behaviours for a given agent.

A \CCKAabbrv consists of two semimodules~$\ActSemimodule$ and~$\OutSemimodule$ for which we have a
\leftAct{\stim}~$\lSact$ and a \rightAct{\cka}~$\rKact$. Therefore, there are two complementary notions of orbits,
stabilisers, and fixed points within the context of agent behaviours and stimuli, respectively. In this way, one
can use these notions to think about distributed systems from two different perspectives, namely the behavioural
perspective provided by the action of stimuli on agent behaviours described by~$\ActSemimodule$ and the external
event (stimulus) perspective provided by the action of agent behaviours on stimuli described by~$\OutSemimodule$.
In this section, only the treatment of these notions with respect to the \leftSemimodule{\stim}~$\ActSemimodule$
and agent behaviours is provided. The same notions for the \rightSemimodule{\cka}~$\OutSemimodule$ and stimuli
can be provided in a very similar way.

When discussing the interplay between \CCKAabbrv and the notions of orbits, stabilisers, and fixed points, the
partial order of sub-behaviours~$\CKAle$ is extended to sets in order to express sets of agent behaviours
encompassing one another. For two subsets of agent behaviours~$A,B \STleq \CKAset$, we say that~$A$
\emph{is encompassed by}~$B$ (or~$B$ \emph{encompasses}~$A$), written~$\CKAencompass{A}{B}$, if and only
if~$\biglnotation{\forall}{a}{a \in A}{\lnotation{\exists}{b}{b \in B}{a \CKAle b}}$. In essence,~$A \CKAenc B$
indicates that every behaviour contained within the set~$A$ is a sub-behaviour of at least one behaviour in the
set~$B$. The encompassing relation~$\STIMenc$ for stimuli can be defined similarly.

Throughout this section, let~$\ActSemimodule$ be the unitary and zero-preserving \leftSemimodule{\stim} of a
\CCKAabbrv and let~$a \in \CKAset$.
\<close>

theory Topology_C2KA
  imports C2KA
begin

no_notation
comp (infixl "\<circ>" 55)
and rtrancl ("(_\<^sup>*)" [1000] 999)

text \<open>
The locale \emph{topology-c2ka} extends the axiomatisation of \emph{c2ka} to support the notions of topology.
\<close>

locale topology_c2ka = c2ka +
  fixes orbit :: "'a::cka \<Rightarrow> 'a::cka set" ("Orb")
  and strong_orbit :: "'a::cka \<Rightarrow> 'a::cka set" ("Orb\<^sub>S")
  and stabiliser :: "'a::cka \<Rightarrow> 'b::stimuli set" ("Stab")
  and fixed :: "'a::cka \<Rightarrow> bool"
  and encompassing_relation_behaviours :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"  (infix "\<lless>\<^sub>\<K>" 50)
  and encompassing_relation_stimuli :: "'b set \<Rightarrow> 'b set \<Rightarrow> bool"  (infix "\<lless>\<^sub>\<S>" 50)
  and induced :: "'a::cka \<Rightarrow> 'a::cka \<Rightarrow> bool" (infix "\<lhd>" 50)
  and orbit_equivalent :: "'a::cka \<Rightarrow> 'a::cka \<Rightarrow> bool" (infix "\<sim>\<^sub>\<K>" 50)
  assumes orb_def: "x \<in> Orb(a) \<longleftrightarrow> (\<exists>s. (s \<circ> a = x))"
  and orbs_def: "b \<in> Orb\<^sub>S(a) \<longleftrightarrow> Orb(b) = Orb(a)"
  and stab_def: "s \<in> Stab(a) \<longleftrightarrow> s \<circ> a = a"
  and fixed_def: "fixed(a) \<longleftrightarrow> (\<forall>s::'b. s\<noteq>\<dd> \<longrightarrow> s \<circ> a = a)"
  and erb_def: "A \<lless>\<^sub>\<K> B \<longleftrightarrow> (\<forall>a::'a. a \<in> A \<longrightarrow> (\<exists>b. b \<in> B \<and> a \<le>\<^sub>\<K> b))"
  and ers_def: "E \<lless>\<^sub>\<S> F \<longleftrightarrow> (\<forall>a::'b. a \<in> E \<longrightarrow> (\<exists>b. b \<in> F \<and> a \<le>\<^sub>\<S> b))"
  and induced_def: "a \<lhd> b \<longleftrightarrow> b \<in> Orb(a)"
  and orbit_equivalent_def: "a \<sim>\<^sub>\<K> b \<longleftrightarrow> Orb(a) = Orb(b)"
begin

subsection \<open>Orbits \label{sub:orbits}\<close>

text \<open>
The \emph{orbit} of~$a$ in~$\stim$ is the set given by~$\orb{a} = \sets{\lAct{a}{s}}{s \in \STIMset}$. The orbit of
an agent~$a \in \CKAset$ represents the set of all possible behavioural responses from an agent behaving as~$a$ to
any stimulus from~$\stim$. In this way, the orbit of a given agent can be perceived as the set of all possible
future behaviours for that agent.
\<close>

text \<open>
Lemma \emph{inf-K-enc-orb} provides an isotonicity law with respect to the orbits and the encompassing relation for agent behaviours.
\<close>

lemma inf_K_enc_orb: "a \<le>\<^sub>\<K> b \<Longrightarrow> Orb(a) \<lless>\<^sub>\<K> Orb(b)"
  unfolding erb_def orb_def
  using inf_K_next_behaviour by blast

text \<open>
The following lemmas provide a selection of properties regarding orbits and the encompassing relation for agent behaviours.
\<close>

lemma enc_orb_add: "Orb(a) \<lless>\<^sub>\<K> Orb(a + b)"
  using  inf_K_enc_orb inf_add_K_right by auto

lemma enc_orb_exchange: "Orb((a*b) ; (c*d)) \<lless>\<^sub>\<K> Orb((a;c) * (b;d))"
  using inf_K_enc_orb exchange_2 by blast

lemma enc_orb_seq_par: "Orb(a;b) \<lless>\<^sub>\<K> Orb(a*b)"
  using inf_K_enc_orb seq_inf_par by auto

lemma enc_orb_add_seq_par: "Orb(a;b + b;a) \<lless>\<^sub>\<K> Orb(a*b)"
  using inf_K_enc_orb add_seq_inf_par by auto

lemma enc_orb_parseq: "Orb((a*b);c) \<lless>\<^sub>\<K> Orb(a*(b;c))"
  using inf_K_enc_orb exchange_3 by blast

lemma enc_orb_seqpar: "Orb(a;(b*c)) \<lless>\<^sub>\<K> Orb((a;b)*c)"
  using inf_K_enc_orb exchange_4 by blast

lemma enc_orb_seqstar_parstar: "Orb(a\<^sup>;) \<lless>\<^sub>\<K> Orb(a\<^sup>*)"
  using inf_K_enc_orb seqstar_inf_parstar by auto

lemma enc_orb_union: "Orb(a) \<lless>\<^sub>\<K> Orb(c) \<and> Orb(b) \<lless>\<^sub>\<K> Orb(c)
\<longleftrightarrow> Orb(a) \<union> Orb(b) \<lless>\<^sub>\<K>  Orb(c)"
  unfolding erb_def
  by auto

subsection \<open>Stabilisers \label{sub:stabilisers}\<close>

text \<open>
The \emph{stabiliser} of~$a$ in~$\stim$ is the set given by~$\stab{a} = \sets{s \in \STIMset}{\lAct{a}{s} = a}$.
The stabiliser of an agent~$a \in \CKAset$ represents the set of stimuli which have no observable influence
(or act as neutral stimuli) on an agent behaving as~$a$.
\<close>

text \<open>
Lemma \emph{enc-stab-inter-add} provides a property regarding stabilisers and the encompassing relation for stimuli.
\<close>

lemma enc_stab_inter_add: "Stab(a) \<inter> Stab(b) \<lless>\<^sub>\<S> Stab(a + b)"
  unfolding ers_def
  by (auto simp add: stab_def, rename_tac s, rule_tac x="s" in exI, simp)

subsection \<open>Fixed Points \label{sub:fixed_points}\<close>

text \<open>
An element~$a \in \CKAset$ is called a \emph{fixed point} if~$\lnotation{\forall}{s}{s \in \STIMset \STdiff \set{\Dstim}}{\lAct{a}{s} = a}$.\linebreak
When an agent behaviour is a fixed point, it is not influenced by any stimulus other than the deactivation stimulus~$\Dstim$.
It is important to note that since~$\ActSemimodule$ is zero-preserving, every agent behaviour becomes inactive when subjected to the
deactivation stimulus~$\Dstim$. Because of this, we exclude this special case when discussing fixed point agent behaviours.
\<close>

lemma zerofix [simp]: "s \<circ> 0 = 0"
proof -
  have "0 = \<dd> \<circ> a" by simp
  hence "s \<circ> 0 = s \<circ> (\<dd> \<circ> a)" by simp
  hence "s \<circ> 0 = (s \<odot> \<dd>) \<circ> a" by (simp only: lsemimodule3 [symmetric])
  thus "s \<circ> 0 = 0" by simp
qed

text \<open>
The following lemmas provide a selection of properties regarding fixed agent behaviours.
\<close>

lemma fixed_zero: "fixed(0)"
  unfolding fixed_def
  by simp

lemma fixed_a_b_add: "fixed(a) \<and> fixed(b) \<longrightarrow> fixed(a + b)"
  unfolding fixed_def
  by simp

lemma fix_not_deactivation: "s \<circ> a = a \<and> \<lambda>(s,a) = \<dd> \<Longrightarrow> a = 0"
proof -
  assume E: "s \<circ> a = a \<and> \<lambda>(s,a) = \<dd>"
  hence "s \<circ> (a;1) = a" by simp
  hence "(s\<circ>a) ; (\<lambda>(s,a)\<circ>1) = a" by (simp only: cascadingaxiom)
  hence "0 = a" by (simp add: E)
  thus ?thesis by auto
qed

lemma fixed_a_b_seq: "fixed(a) \<and> fixed(b) \<longrightarrow> fixed(a ; b)"
  unfolding fixed_def
proof (rule impI)
  assume hyp: "(\<forall>s. s \<noteq> \<dd> \<longrightarrow> s \<circ> a = a) \<and> (\<forall>s. s \<noteq> \<dd> \<longrightarrow> s \<circ> b = b)"
  have C1: "(\<forall>s. \<lambda>(s,a) = \<dd> \<longrightarrow> s \<noteq> \<dd> \<longrightarrow> s \<circ> (a ; b) = a ; b)"
  proof -
    have E: "(\<forall>s. s \<noteq> \<dd> \<and> \<lambda>(s,a) = \<dd> \<longrightarrow> s \<circ> (a ; b) = 0)" by simp
    hence "(\<forall>s. s \<noteq> \<dd> \<and> \<lambda>(s,a) = \<dd> \<longrightarrow> s \<circ> a = a \<and> \<lambda>(s,a) = \<dd>)"
      by (simp add: hyp)
    moreover have "(\<forall>s. s \<circ> a = a \<and> \<lambda>(s,a) = \<dd> \<longrightarrow> a = 0)"
      by (simp add: fix_not_deactivation)
    ultimately have "(\<forall>s. s \<noteq> \<dd> \<and> \<lambda>(s,a) = \<dd> \<longrightarrow> a = 0)" by auto
    thus ?thesis by (auto simp add: E)
  qed
  moreover have C2: "(\<forall>s. \<lambda>(s,a) \<noteq> \<dd> \<longrightarrow> s \<noteq> \<dd> \<longrightarrow> s \<circ> (a ; b) = a ; b)"
    by (simp add: hyp)
  ultimately show "(\<forall>s. s \<noteq> \<dd> \<longrightarrow> s \<circ> (a ; b) = a ; b)" by blast
qed

subsection \<open>Strong Orbits and Induced Behaviours \label{sub:strong_orbits_and_induced_behaviours}\<close>

text \<open>
The \emph{strong orbit} of~$a$ in~$\stim$ is the set given by~$\orbS{a} = \sets{b \in \CKAset}{\orb{b} = \orb{a}}$.
Two agents are in the same strong orbit, denoted~$a \CKAsim b$ for~$a,b \in \CKAset$, if and only if their orbits are
identical. This is to say when~$a \CKAsim b$, if an agent behaving as~$a$ is influenced by a stimulus to behave as~$b$,
then there exists a stimulus which influences the agent, now behaving as~$b$, to revert back to its original behaviour~$a$.

The influence of stimuli on agent behaviours is called the \emph{induced behaviours} via stimuli. Let~$a,b \in \CKAset$
be agent behaviours with~$a \neq b$. We say that~$b$ is \emph{induced by~$a$ via stimuli} (denoted by~$\induced{b}{a}$)
if and only if~$\lnotation{\exists}{s}{s \in \STIMset}{\lAct{a}{s} = b}$. The notion of induced behaviours allows us to make
some predictions about the evolution of agent behaviours in a given system by providing some insight into how different agents
can respond to any stimuli.
\<close>

text \<open>
Lemma \emph{fixed-not-induce} states that if an agent has a fixed point behaviour, then it does not induce any agent behaviours via  stimuli besides the inactive behaviour~$0$.
\<close>

lemma fixed_not_induce: "fixed(a) \<longrightarrow> (\<forall>b. b \<noteq> 0 \<and> b \<noteq> a \<longrightarrow> \<not>(a \<lhd> b))"
proof -
  have "\<And>s. s = \<dd> \<or> s \<noteq> \<dd> \<Longrightarrow> (\<forall>t. t \<noteq> \<dd> \<longrightarrow> t \<circ> a = a) \<Longrightarrow> s \<circ> a \<noteq> 0
\<Longrightarrow> s \<circ> a \<noteq> a \<Longrightarrow> False"
    by (erule disjE, simp_all)
  hence "\<And>s. (\<forall>t. t \<noteq> \<dd> \<longrightarrow> t \<circ> a = a) \<Longrightarrow> s \<circ> a \<noteq> 0 \<Longrightarrow> s \<circ> a \<noteq> a \<Longrightarrow> False"
    by simp
  thus ?thesis
    unfolding fixed_def induced_def orb_def
    by auto
qed

text \<open>
Lemma \emph{strong-orbit-both-induced} states that all agent behaviours which belong to the same strong orbit are mutually induced via some (possibly different) stimuli.
This is to say that if two agent behaviours are in the same strong orbit, then there exists inverse stimuli for each agent behaviour in a
strong orbit allowing an agent to revert back to its previous behaviour.
\<close>

lemma in_own_orbit: "a \<in> Orb(a)"
  unfolding orb_def
  by (rule_tac x="\<nn>" in exI, simp)

lemma strong_orbit_both_induced: "a \<sim>\<^sub>\<K> b \<longrightarrow> a \<lhd> b \<and> b \<lhd> a"
  unfolding orbit_equivalent_def induced_def
  by (blast intro: in_own_orbit)

text \<open>
Lemma \emph{strong-orbit-induce-same} states that if two agent behaviours are in the same strong orbit, then a third behaviour can be induced via  stimuli by either of
the behaviours within the strong orbit. This is to say that each behaviour in a strong orbit can induce the same set of behaviours
(perhaps via different stimuli).
\<close>

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* License: BSD, terms see file ./LICENSE *)

theory SepTactic
imports SepInv
begin

section "sep_point_tac"

definition sep_conj_extract :: "heap_assert \<Rightarrow> heap_assert" where
  "sep_conj_extract \<equiv> id"

definition sep_points :: "heap_assert \<Rightarrow> heap_assert" where
  "sep_points P \<equiv> P \<and>\<^sup>* sep_true"

lemma sep_conj_extract1D:
  "(P \<and>\<^sup>* Q) s \<Longrightarrow> sep_conj_extract (P \<and>\<^sup>* Q) s"
  by (simp add: sep_conj_extract_def)

lemma sep_conj_extract2D:
  "sep_conj_extract P s \<Longrightarrow> P s \<and> (sep_conj_extract P \<and>\<^sup>* sep_true) s"
  by (auto simp: sep_conj_extract_def elim: sep_conj_sep_true)

lemma sep_conj_extract_assoc:
  "sep_conj_extract ((P \<and>\<^sup>* Q) \<and>\<^sup>* R) = sep_conj_extract (P \<and>\<^sup>* (Q \<and>\<^sup>* R))"
  by (simp add: sep_conj_ac)

lemma sep_conj_extract_decomposeD:
  "(sep_conj_extract (P \<and>\<^sup>* Q) \<and>\<^sup>* sep_true) s \<Longrightarrow> sep_points P s \<and>
      (sep_conj_extract Q \<and>\<^sup>* sep_true) s"
  apply (rule conjI)
   apply(simp add: sep_conj_extract_def sep_points_def sep_conj_ac)
   apply(erule (1) sep_conj_impl, simp)
  apply(simp add: sep_conj_extract_def sep_conj_ac)
  apply(subst (asm) sep_conj_assoc [symmetric])
  apply(subst (asm) sep_conj_com)
  apply(subst (asm) sep_conj_assoc)
  apply(erule (1) sep_conj_impl)
  apply simp
  done

lemma sep_conj_extract_decomposeD2:
  "(sep_conj_extract P \<and>\<^sup>* sep_true) s \<Longrightarrow> sep_points P s"
  by (simp add: sep_conj_extract_def sep_points_def)

lemma sep_point_mapD:
  "sep_points (p \<mapsto>\<^sup>i\<^sub>g v) s \<Longrightarrow> (p \<hookrightarrow>\<^sup>i\<^sub>g v) s"
  by (simp add: sep_points_def sep_map_inv_def sep_map'_inv_def sep_map'_def
                sep_conj_ac)

lemma sep_point_map_excD:
  "sep_points (p \<mapsto>\<^sub>g v) s \<Longrightarrow> (p \<hookrightarrow>\<^sub>g v) s"
  by (simp add: sep_points_def sep_map'_def)

lemma sep_point_otherD:
  "sep_points P s \<Longrightarrow> True"
  by (rule TrueI)

ML \<open>

val sep_point_ds = [@{thm sep_point_mapD}, @{thm sep_point_map_excD}]

fun sep_point_tacs ds ctxt  = [
    REPEAT1 (dresolve_tac ctxt [@{thm sep_conj_extract1D}] 1),
    REPEAT1 (dresolve_tac ctxt [@{thm sep_conj_extract2D}] 1),
    clarify_tac ctxt 1,
    TRY (full_simp_tac (put_simpset HOL_ss ctxt addsimps
        [@{thm sep_conj_extract_assoc}]) 1),
    REPEAT (dresolve_tac ctxt [@{thm sep_conj_extract_decomposeD},
        @{thm sep_conj_extract_decomposeD2}] 1 THEN
        clarify_tac ctxt 1),
    TRY (full_simp_tac ctxt 1),
    REPEAT (dresolve_tac ctxt (sep_point_ds@ds) 1),
    REPEAT (dresolve_tac ctxt [@{thm sep_point_otherD}] 1),
    TRY (full_simp_tac ctxt 1)
  ]

fun sep_point_tac ds ctxt = EVERY (sep_point_tacs ds ctxt)
\<close>

method_setup sep_point_tac =
  "Attrib.thms >> (fn thms => Method.SIMPLE_METHOD o sep_point_tac thms)"
  "extract points-to facts from separation assertions in assumptions"

lemma "(P \<and>\<^sup>* p \<mapsto>\<^sub>g v \<and>\<^sup>* Q) s \<Longrightarrow> (p \<hookrightarrow>\<^bsub>g\<^esub> v) s"
  by sep_point_tac

section "sep_exists_tac"

ML\<open>
fun sep_exists_tac ctxt = full_simp_tac
    (put_simpset HOL_ss ctxt addsimps [@{thm "sep_conj_exists1"}, @{thm "sep_conj_exists2"}])
\<close>

method_setup sep_exists_tac =
  "Scan.succeed (Method.SIMPLE_METHOD' o sep_exists_tac)"
  "push existentials inside separation assertions to the outside"

lemma "(P \<and>\<^sup>* (\<lambda>s. (\<exists>x. Q x s))) s \<Longrightarrow> \<exists>x. (P \<and>\<^sup>* Q x) s"
  by sep_exists_tac

section "sep_select_tac"

definition sep_mark :: "heap_assert \<Rightarrow> heap_assert" where
  "sep_mark \<equiv> id"

definition sep_mark2 :: "heap_assert \<Rightarrow> heap_assert" where
  "sep_mark2 \<equiv> id"

lemma sep_mark2_id:
  "sep_mark2 P = P"
  by (simp add: sep_mark2_def)

lemma sep_markI:
  "(\<box> \<and>\<^sup>* sep_mark (P \<and>\<^sup>* Q)) s \<Longrightarrow> (P \<and>\<^sup>* Q) s"
  by (simp add: sep_mark_def sep_conj_empty)

lemma sep_mark_match:
  "(R \<and>\<^sup>* sep_mark2 P \<and>\<^sup>* Q) s \<Longrightarrow> (R \<and>\<^sup>* sep_mark (P \<and>\<^sup>* Q)) s"
  by (simp add: sep_mark_def sep_mark2_def)

lemma sep_mark_match2:
  "(R \<and>\<^sup>* sep_mark2 P) s \<Longrightarrow> (R \<and>\<^sup>* sep_mark P) s"
  by (simp add: sep_mark_def sep_mark2_def)

lemma sep_mark_mismatch:
  "((R \<and>\<^sup>* P) \<and>\<^sup>* sep_mark Q) s \<Longrightarrow> (R \<and>\<^sup>* sep_mark (P \<and>\<^sup>* Q)) s"
  by (simp add: sep_mark_def sep_conj_ac)

lemma sep_mark_mismatch2:
  "(R \<and>\<^sup>* P) s \<Longrightarrow> (R \<and>\<^sup>* sep_mark P) s"
  by (simp add: sep_mark_def)

lemma sep_emp_rem:
  "P s \<Longrightarrow> (\<box> \<and>\<^sup>* P) s"
  by (simp add: sep_conj_empty)

lemma sep_mark2_left:
  "(P \<and>\<^sup>* (sep_mark2 Q \<and>\<^sup>* R)) = (sep_mark2 Q \<and>\<^sup>* (P \<and>\<^sup>* R))"
  by (rule sep_conj_left_com)

lemma sep_mark2_left2:
  "(P \<and>\<^sup>* sep_mark2 Q) = (sep_mark2 Q \<and>\<^sup>* P)"
  by (rule sep_conj_com)

ML \<open>

(* Replace all occurrences of an underscore that does not have an alphanumeric
   on either side of it *)
local
  val dummy_char = #" ";
  fun get_next (x::_) = x
    | get_next [] = dummy_char;
  fun nth_id n = "SEPTAC"^(Int.toString n);

  fun ok_char c = not (Char.isAlphaNum c);

  fun can_replace (prev,cur,last) =
        (ok_char prev) andalso (cur = #"_") andalso (ok_char last);

  fun replace_usc n prev_char (x::xs) =
      let val (xs', ys) = replace_usc (n+1) x xs
      in
        if can_replace (prev_char,x,get_next xs)
        then (nth_id n::xs', nth_id n::ys)
        else (String.str x::xs', ys)
      end
    | replace_usc _ _ [] = ([],[])
in
  val rusc = apfst String.concat o replace_usc 0 dummy_char o String.explode
end;

(* some tests *)
rusc "(_ +\<^sub>p _) \<mapsto> _";
rusc "_ \<mapsto>\<^sub>_ _";
rusc "_";
rusc "_ O_o _"
\<close>

ML\<open>

fun sep_select_tacs s ctxt  =
  let val (str, vars) = rusc s
      val subst = [((Lexicon.read_indexname "P", Position.none), str)]
      val fixes = map (fn v => (Binding.name v, NONE, Mixfix.NoSyn)) vars
  in
  [
    TRY (simp_tac (put_simpset HOL_ss ctxt addsimps [@{thm sep_conj_assoc}]) 1),
    resolve_tac ctxt [@{thm sep_markI}] 1,
    REPEAT (Rule_Insts.res_inst_tac ctxt subst fixes @{thm sep_mark_match} 1 ORELSE
      (Rule_Insts.res_inst_tac ctxt subst fixes @{thm sep_mark_match2} 1 ORELSE
      resolve_tac ctxt [@{thm sep_mark_mismatch}] 1 ORELSE
      resolve_tac ctxt [@{thm sep_mark_mismatch2}] 1)),
    TRY (simp_tac (put_simpset HOL_ss ctxt addsimps [@{thm sep_conj_assoc}]) 1),
    resolve_tac ctxt [@{thm sep_emp_rem}] 1,
    TRY (simp_tac (put_simpset HOL_ss ctxt addsimps [@{thm sep_mark2_left},
      @{thm sep_mark2_left2}]) 1),
    TRY (simp_tac (put_simpset HOL_ss ctxt addsimps [@{thm sep_mark2_id}]) 1)
  ]
  end

fun sep_select_tac s ctxt = SELECT_GOAL (EVERY (sep_select_tacs s ctxt))

fun lift_parser p (ctxt,ts) =
  let val (r, ts') = p ts
  in (r, (ctxt,ts')) end
\<close>

method_setup sep_select_tac =
  \<open>lift_parser Args.name >> (fn s => Method.SIMPLE_METHOD' o sep_select_tac s)\<close>
  "takes a target conjunct in the goal and reorders it to the front"

lemma
  "\<And>R x f n. ((P::heap_assert) \<and>\<^sup>* fac x n \<and>\<^sup>* R (f x)) s"
  apply(sep_select_tac "fac _ _")
  apply(sep_select_tac "R _")
  apply(sep_select_tac "fac x _")
  apply(sep_select_tac "R _")
  oops

lemma
  "((P::heap_assert) \<and>\<^sup>* fac x n) s"
  apply(sep_select_tac "fac _ _")
  oops

lemma
  "((P::heap_assert) \<and>\<^sup>* long_name) s"
  apply(sep_select_tac "long_name")
  oops

consts c_guard :: "'a::c_type ptr_guard"

lemma sep_heap_update'_hrs:
  "(c_guard \<turnstile>\<^sub>s\<^sup>i p \<and>\<^sup>* (p \<mapsto>\<^sup>i\<^sub>c_guard v \<longrightarrow>\<^sup>* P)) (lift_state s) \<Longrightarrow>
      P (lift_state (hrs_mem_update (heap_update p (v::'a::mem_type)) s))"
  by (case_tac s)
     (simp add: hrs_mem_update_def, erule sep_heap_update')

lemma sep_map_lift_wp_hrs:
  "\<lbrakk> \<exists>v. (p \<mapsto>\<^sup>i\<^sub>c_guard v \<and>\<^sup>* (p \<mapsto>\<^sup>i\<^sub>c_guard v \<longrightarrow>\<^sup>* P v)) (lift_state s) \<rbrakk>
      \<Longrightarrow> P (lift (hrs_mem s) (p::'a::mem_type ptr)) (lift_state s)"
  by (case_tac s)
     (simp add: hrs_mem_def, erule sep_map_lift_wp)

lemma ptr_retyp_sep_cut'_wp_hrs:
  "\<lbrakk> (sep_cut' (ptr_val p) (size_of TYPE('a)) \<and>\<^sup>* (c_guard \<turnstile>\<^sub>s\<^sup>i p \<longrightarrow>\<^sup>* P))
      (lift_state s); c_guard (p::'a::mem_type ptr) \<rbrakk>
      \<Longrightarrow> P (lift_state (hrs_htd_update (ptr_retyp p) s))"
  by (case_tac s)
     (simp add: hrs_htd_update_def, erule (1) ptr_retyp_sep_cut'_wp)

ML \<open>

fun destruct bs (Bound n)      = Free (List.nth (bs,n))
  | destruct bs (Abs (s,ty,t)) = destruct ((s,ty)::bs) t
  | destruct bs (l$r)          = destruct bs l $ destruct bs r
  | destruct _  x              = x

fun schems (Abs (_,_,t)) = schems t
  | schems (l$r)         = schems l + schems r
  | schems (Var _)       = 1
  | schems _             = 0

fun hrs_mem_update (Const (@{const_name "HeapRawState.hrs_mem_update"},_)$_$s) = SOME s
  | hrs_mem_update _                                             = NONE

fun hrs_htd_update (Const (@{const_name "HeapRawState.hrs_htd_update"},_)$_$s) = SOME s
  | hrs_htd_update _                                             = NONE

fun lift_state_arg _   _  (Const (@{const_name "TypHeap.lift_state"},_)$s) = SOME s
  | lift_state_arg thy nc (l$r)                              =
        (case lift_state_arg thy nc r of
          SOME s => if nc orelse hrs_mem_update s <> NONE orelse
                        hrs_htd_update s <> NONE then SOME s
                        else lift_state_arg thy nc l
         | NONE   => lift_state_arg thy nc l)
  | lift_state_arg thy nc (Abs (_,_,t))                      =
        lift_state_arg thy nc t
  | lift_state_arg _ _ _ =
        NONE (*error (Sign.string_of_term thy s)*)

fun term_of_thm thm = Thm.term_of (Thm.cprop_of thm)

fun lift_tac ctxt s old_schems =
  Rule_Insts.res_inst_tac ctxt [((Lexicon.read_indexname "s",Position.none),s)] [] @{thm sep_map_lift_wp_hrs} 1 THEN
  (fn thm => if schems (term_of_thm thm) = old_schems then all_tac thm
                 else no_tac thm)

fun heap_update_tac ctxt s =
  Rule_Insts.res_inst_tac ctxt [((Lexicon.read_indexname "s",Position.none),s)] [] @{thm sep_heap_update'_hrs} 1

fun ptr_retyp_tac ctxt s =
  Rule_Insts.res_inst_tac ctxt [((Lexicon.read_indexname "s",Position.none),s)] [] @{thm ptr_retyp_sep_cut'_wp_hrs} 1

fun sep_wp_step_tac' ctxt lift_only s old_schems = let
  fun prt s = (
    case s of
        Free (a, _) => a
      | _ => raise TERM ("Not a free variable",[s]))
  val state = prt s
  val step = case hrs_mem_update s of
               SOME s => heap_update_tac ctxt (prt s)
             | NONE => case hrs_htd_update s of
                         SOME s => ptr_retyp_tac ctxt (prt s)
                       | NONE => no_tac
in
  TRY (lift_tac ctxt state old_schems) THEN (if lift_only then all_tac else step)
end

fun sep_wp_step_tac ctxt lift_only thm = let
  val t = term_of_thm thm
  val thy = Proof_Context.theory_of ctxt
  val old_schems = schems t
  val s = lift_state_arg thy lift_only (destruct [] t)
in
  (case s of
    SOME state => sep_wp_step_tac' ctxt lift_only state old_schems
   | NONE => no_tac) thm
end

fun sep_wp_tac ctxt = (REPEAT (sep_wp_step_tac ctxt false)) THEN sep_wp_step_tac ctxt true

\<close>

method_setup sep_wp_tac =
  "Scan.succeed (Method.SIMPLE_METHOD o sep_wp_tac)"
  "apply WP separation logic rules to goal"

(* see testfiles/sep_example_pre_list.thy for a more detailed example *)
lemma
  "((\<lambda>z. lift (hrs_mem s) (p::(32 word) ptr) + 1 = 2) \<and>\<^sup>* P) (lift_state s)"
  apply sep_wp_tac
  oops

end


(*******************************************************************************

  Project: Development of Security Protocols by Refinement

  Module:  Refinement/Runs.thy (Isabelle/HOL 2016-1)
  ID:      $Id: Runs.thy 132773 2016-12-09 15:30:22Z csprenge $
  Author:  Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Protocol runs: local state of executing protocol roles

  Copyright (c) 2010-2016 Christoph Sprenger
  Licence: LGPL

*******************************************************************************)

section \<open>Protocol runs\<close>

theory Runs imports Atoms
begin

(******************************************************************************)
subsection \<open>Runs\<close>
(******************************************************************************)

text \<open>Define some typical roles.\<close>

datatype role_t = Init | Resp | Serv

fun
  roleIdx :: "role_t \<Rightarrow> nat"
where
  "roleIdx Init = 0"
| "roleIdx Resp = 1"
| "roleIdx Serv = 2"

text \<open>The type of runs is a partial function from run identifiers to
a triple consisting of a role, a list of agents, and a list of atomic messages
recorded during the run's execution.

The type of roles could be made a parameter for more flexibility.\<close>

type_synonym
  rid_t = "fid_t"

type_synonym
  runs_t = "rid_t \<rightharpoonup> role_t \<times> agent list \<times> atom list"

subsection \<open>Run abstraction\<close>
(******************************************************************************)

text \<open>Define a function that lifts a function on roles and atom lists
to a function on runs.\<close>

definition
  map_runs :: "([role_t, atom list] \<Rightarrow> atom list) \<Rightarrow> runs_t \<Rightarrow> runs_t"
where
  "map_runs h runz rid \<equiv> case runz rid of
     None \<Rightarrow> None
   | Some (rol, agts, al) \<Rightarrow> Some (rol, agts, h rol al)"

lemma map_runs_empty [simp]: "map_runs h Map.empty = Map.empty"
by (rule ext) (auto simp add: map_runs_def)

lemma map_runs_dom [simp]: "dom (map_runs h runz) = dom runz"
by (auto simp add: map_runs_def split: option.split_asm)

lemma map_runs_update [simp]:
  "map_runs h (runz(R \<mapsto> (rol, agts, al)))
   = (map_runs h runz)(R \<mapsto> (rol, agts, h rol al))"
by (auto simp add: map_runs_def)

end


theory ArityAnalysisImpl
imports ArityAnalysisFix ArityAnalysisPreImpl
begin

definition Real_Aexp where "Real_Aexp = ArityAnalysisPreImpl.Aexp ArityAnalysis.Afix"

lemma heap_exp_are_smaller:  "e \<in> snd ` set \<Gamma> \<Longrightarrow> size e \<le> size_list (\<lambda>p. size (snd p)) \<Gamma>"
  by (metis (mono_tags) imageE order_refl size_list_estimation')

interpretation ArityAnalysisPreImpl ArityAnalysis.Afix where "Aexp = ArityAnalysisImpl.Real_Aexp"
  unfolding Real_Aexp_def atomize_conj
  apply (rule conjI[OF _ refl])
  apply default
  apply (perm_simp, rule)
  apply (rule ArityAnalysisFix.Afix_cong)
  apply (metis heap_exp_are_smaller)
  apply assumption
  done

interpretation ArityAnalysis Aexp.

lemma Aexp_edom': "edom (Aexp e\<cdot>a) \<subseteq> fv e"
  by (nominal_induct arbitrary: a rule: exp_strong_induct) fastforce+

end


section \<open>Final Instantiation of Algorithms Related to Complementation\<close>

theory Complementation_Final
imports
  "Complementation_Implement"
  "Formula"
  "Transition_Systems_and_Automata.NBA_Translate"
  "Transition_Systems_and_Automata.NGBA_Algorithms"
  "HOL-Library.Multiset"
begin

  subsection \<open>Syntax\<close>

  (* TODO: this syntax has unnecessarily high inner binding strength, requiring extra parentheses
    the regular let syntax correctly uses inner binding strength 0: ("(2_ =/ _)" 10) *)
  no_syntax "_do_let" :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2let _ =/ _)" [1000, 13] 13)
  syntax "_do_let" :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2let _ =/ _)" 13)

  subsection \<open>Hashcodes on Complement States\<close>

  definition "hci k \<equiv> uint32_of_nat k * 1103515245 + 12345"
  definition "hc \<equiv> \<lambda> (p, q, b). hci p + hci q * 31 + (if b then 1 else 0)"
  definition "list_hash xs \<equiv> fold (xor \<circ> hc) xs 0"

  lemma list_hash_eq:
    assumes "distinct xs" "distinct ys" "set xs = set ys"
    shows "list_hash xs = list_hash ys"
  proof -
    have "mset (remdups xs) = mset (remdups ys)" using assms(3)
      using set_eq_iff_mset_remdups_eq by blast
    then have "mset xs = mset ys" using assms(1, 2) by (simp add: distinct_remdups_id)
    have "fold (xor \<circ> hc) xs = fold (xor \<circ> hc) ys"
      apply (rule fold_multiset_equiv)
       apply (simp_all add: fun_eq_iff ac_simps)
      using \<open>mset xs = mset ys\<close> .
    then show ?thesis unfolding list_hash_def by simp
  qed

  definition state_hash :: "nat \<Rightarrow> Complementation_Implement.state \<Rightarrow> nat" where
    "state_hash n p \<equiv> nat_of_hashcode (list_hash p) mod n"

  lemma state_hash_bounded_hashcode[autoref_ga_rules]: "is_bounded_hashcode state_rel
    (gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
    (prod_eq (=) (\<longleftrightarrow>))) state_hash"
  proof
    show [param]: "(gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
      (prod_eq (=) (\<longleftrightarrow>)), (=)) \<in> state_rel \<rightarrow> state_rel \<rightarrow> bool_rel" by autoref
    show "state_hash n xs = state_hash n ys" if "xs \<in> Domain state_rel" "ys \<in> Domain state_rel"
      "gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list))
      (list_map_lookup (=)) (prod_eq (=) (=)) xs ys" for xs ys n
    proof -
      have 1: "distinct (map fst xs)" "distinct (map fst ys)"
        using that(1, 2) unfolding list_map_rel_def list_map_invar_def by (auto simp: in_br_conv)
      have 2: "distinct xs" "distinct ys" using 1 by (auto intro: distinct_mapI)
      have 3: "(xs, map_of xs) \<in> state_rel" "(ys, map_of ys) \<in> state_rel"
        using 1 unfolding list_map_rel_def list_map_invar_def by (auto simp: in_br_conv)
      have 4: "(gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
        (prod_eq (=) (\<longleftrightarrow>)) xs ys, map_of xs = map_of ys) \<in> bool_rel" using 3 by parametricity
      have 5: "map_to_set (map_of xs) = map_to_set (map_of ys)" using that(3) 4 by simp
      have 6: "set xs = set ys" using map_to_set_map_of 1 5 by blast
      show "state_hash n xs = state_hash n ys" unfolding state_hash_def using list_hash_eq 2 6 by metis
    qed
    show "state_hash n x < n" if "1 < n" for n x using that unfolding state_hash_def by simp
  qed

  subsection \<open>Complementation\<close>

  schematic_goal complement_impl:
    assumes [simp]: "finite (NBA.nodes A)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, op_translate (complement_4 A)) \<in> ?R"
    by (autoref_monadic (plain))
  concrete_definition complement_impl uses complement_impl

  theorem complement_impl_correct:
    assumes "finite (NBA.nodes A)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "NBA.language (nbae_nba (nbaei_nbae (complement_impl Ai))) =
      streams (nba.alphabet A) - NBA.language A"
    using op_translate_language[OF complement_impl.refine[OF assms]]
    using complement_4_correct[OF assms(1)]
    by simp

  subsection \<open>Language Subset\<close>

  definition [simp]: "op_language_subset A B \<equiv> NBA.language A \<subseteq> NBA.language B"

  lemmas [autoref_op_pat] = op_language_subset_def[symmetric]

  schematic_goal language_subset_impl:
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, do {
      let AB' = intersect' A (complement_4 B);
      ASSERT (finite (NGBA.nodes AB'));
      RETURN (NGBA.language AB' = {})
    }) \<in> ?R"
		by (autoref_monadic (plain))
  concrete_definition language_subset_impl uses language_subset_impl
  lemma language_subset_impl_refine[autoref_rules]:
    assumes "SIDE_PRECOND (finite (NBA.nodes A))"
    assumes "SIDE_PRECOND (finite (NBA.nodes B))"
    assumes "SIDE_PRECOND (nba.alphabet A \<subseteq> nba.alphabet B)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(language_subset_impl Ai Bi, (OP op_language_subset :::
      \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> bool_rel) $ A $ B) \<in> bool_rel"
  proof -
    have "(RETURN (language_subset_impl Ai Bi), do {
      let AB' = intersect' A (complement_4 B);
      ASSERT (finite (NGBA.nodes AB'));
      RETURN (NGBA.language AB' = {})
    }) \<in> \<langle>bool_rel\<rangle> nres_rel"
      using language_subset_impl.refine assms(2, 4, 5) unfolding autoref_tag_defs by this
    also have "(do {
      let AB' = intersect' A (complement_4 B);
      ASSERT (finite (NGBA.nodes AB'));
      RETURN (NGBA.language AB' = {})
    }, RETURN (NBA.language A \<subseteq> NBA.language B)) \<in> \<langle>bool_rel\<rangle> nres_rel"
    proof refine_vcg
      show "finite (NGBA.nodes (intersect' A (complement_4 B)))" using assms(1, 2) by auto
      have 1: "NBA.language A \<subseteq> streams (nba.alphabet B)"
        using nba.language_alphabet streams_mono2 assms(3) unfolding autoref_tag_defs by blast
      have 2: "NBA.language (complement_4 B) = streams (nba.alphabet B) - NBA.language B"
        using complement_4_correct assms(2) by auto
      show "(NGBA.language (intersect' A (complement_4 B)) = {},
        NBA.language A \<subseteq> NBA.language B) \<in> bool_rel" using 1 2 by auto
    qed
    finally show ?thesis using RETURN_nres_relD unfolding nres_rel_comp by force
  qed

  subsection \<open>Language Equality\<close>

  definition [simp]: "op_language_equal A B \<equiv> NBA.language A = NBA.language B"

  lemmas [autoref_op_pat] = op_language_equal_def[symmetric]

  schematic_goal language_equal_impl:
    assumes [simp]: "finite (NBA.nodes A)"
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [simp]: "nba.alphabet A = nba.alphabet B"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, NBA.language A \<subseteq> NBA.language B \<and> NBA.language B \<subseteq> NBA.language A) \<in> ?R"
    by autoref
  concrete_definition language_equal_impl uses language_equal_impl
  lemma language_equal_impl_refine[autoref_rules]:
    assumes "SIDE_PRECOND (finite (NBA.nodes A))"
    assumes "SIDE_PRECOND (finite (NBA.nodes B))"
    assumes "SIDE_PRECOND (nba.alphabet A = nba.alphabet B)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(language_equal_impl Ai Bi, (OP op_language_equal :::
      \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> bool_rel) $ A $ B) \<in> bool_rel"
    using language_equal_impl.refine[OF assms[unfolded autoref_tag_defs]] by auto

  schematic_goal product_impl:
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, do {
      let AB' = intersect A (complement_4 B);
      ASSERT (finite (NBA.nodes AB'));
      op_translate AB'
    }) \<in> ?R"
		by (autoref_monadic (plain))
  concrete_definition product_impl uses product_impl

  (* TODO: possible optimizations:
    - introduce op_map_map operation for maps instead of manually iterating via FOREACH
    - consolidate various binds and maps in expand_map_get_7 *)
  export_code
    Set.empty Set.insert Set.member
    "Inf :: 'a set set \<Rightarrow> 'a set" "Sup :: 'a set set \<Rightarrow> 'a set" image Pow set
    nat_of_integer integer_of_nat
    Variable Negation Conjunction Disjunction satisfies map_formula
    nbaei alphabetei initialei transitionei acceptingei
    nbae_nba_impl complement_impl language_equal_impl product_impl
    in SML module_name Complementation file_prefix Complementation

end