theory NBA_Rule
imports Scoring_Rules
        "Compositional_Structures/Basic_Modules/Scoring_Module"
        "Compositional_Structures/Basic_Modules/NBA_Module"
        "Compositional_Structures/Elect_Composition"

begin

lemma mvp_elect:
  shows "electoral_module (elector mvp)"
proof(unfold mvp.simps)
  show "electoral_module (elector (max_eliminator (scoring vector_A_mvp)))"
    using scoring_mod_A by blast
qed

lemma mvp_hom:
  shows "homogeneity (elector mvp)" unfolding mvp.simps
  using scoring_rules_homogeneity
  by blast

lemma mvp_reinforcement:
  shows "reinforcement_complete (elector mvp)" unfolding mvp.simps
  using scoring_module_rein
  by blast

end


(*
   Title: Psi-calculi
   Based on the AFP entry by Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Cong_Struct_Cong
  imports Weak_Cong_Pres Weak_Bisim_Struct_Cong
begin

context env begin

lemma weakPsiCongParComm:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<parallel> Q \<doteq> Q \<parallel> P"
by(metis bisim_par_comm strongBisimWeakPsiCong)

lemma weakPsiCongResComm:
  fixes x :: name
  and   \<Psi> :: 'b
  and   y :: name
  and   P :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "y \<sharp> \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>y\<rparr>P) \<doteq> \<lparr>\<nu>y\<rparr>(\<lparr>\<nu>x\<rparr>P)"
using assms
by(metis bisim_res_comm strongBisimWeakPsiCong)

lemma weakPsiCongResComm':
  fixes x    :: name
  and   \<Psi>   :: 'b
  and   xvec :: "name list"
  and   P    :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "xvec \<sharp>* \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>*xvec\<rparr>P) \<doteq> \<lparr>\<nu>*xvec\<rparr>(\<lparr>\<nu>x\<rparr>P)"
using assms
by(metis bisim_res_comm' strongBisimWeakPsiCong)

lemma weakPsiCongScopeExt:
  fixes x :: name
  and   \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> P"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(P \<parallel> Q) \<doteq> P \<parallel> \<lparr>\<nu>x\<rparr>Q"
using assms
by(metis bisim_scope_ext strongBisimWeakPsiCong)

lemma weakPsiCongScopeExtChain:
  fixes xvec :: "name list"
  and   \<Psi>    :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "xvec \<sharp>* \<Psi>"
  and     "xvec \<sharp>* P"

  shows "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>(P \<parallel> Q) \<doteq> P \<parallel> (\<lparr>\<nu>*xvec\<rparr>Q)"
using assms
by(metis bisim_scope_ext_chain strongBisimWeakPsiCong)

lemma weakPsiCongParAssoc:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> (P \<parallel> Q) \<parallel> R \<doteq> P \<parallel> (Q \<parallel> R)"
by(metis bisim_par_assoc strongBisimWeakPsiCong)

lemma weakPsiCongParNil:
  fixes P :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<parallel> \<zero> \<doteq> P"
by(metis bisim_par_nil strongBisimWeakPsiCong)

lemma weakPsiCongResNil:
  fixes x :: name
  and   \<Psi> :: 'b

  assumes "x \<sharp> \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>\<zero> \<doteq> \<zero>"
using assms
by(metis bisim_res_nil strongBisimWeakPsiCong)

lemma weakPsiCongOutputPushRes:
  fixes x :: name
  and   \<Psi> :: 'b
  and   M :: 'a
  and   N :: 'a
  and   P :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> M"
  and     "x \<sharp> N"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(M\<langle>N\<rangle>.P) \<doteq> M\<langle>N\<rangle>.\<lparr>\<nu>x\<rparr>P"
using assms
by(metis bisim_output_push_res strongBisimWeakPsiCong)

lemma weakPsiCongInputPushRes:
  fixes x    :: name
  and   \<Psi>    :: 'b
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a
  and   P    :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> M"
  and     "x \<sharp> xvec"
  and     "x \<sharp> N"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(M\<lparr>\<lambda>*xvec N\<rparr>.P) \<doteq> M\<lparr>\<lambda>*xvec N\<rparr>.\<lparr>\<nu>x\<rparr>P"
using assms
by(metis bisim_input_push_res strongBisimWeakPsiCong)

lemma weakPsiCongCasePushRes:
  fixes x  :: name
  and   \<Psi>  :: 'b
  and   Cs :: "('c \<times> ('a, 'b, 'c) psi) list"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> (map fst Cs)"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(Cases Cs) \<doteq> Cases(map (\<lambda>(\<phi>, P). (\<phi>, \<lparr>\<nu>x\<rparr>P)) Cs)"
using assms
by(metis bisim_case_push_res strongBisimWeakPsiCong)

lemma weak_bangExt:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  assumes "guarded P"

  shows "\<Psi> \<rhd> !P \<doteq> P \<parallel> !P"
using assms
by(metis bang_ext strongBisimWeakPsiCong)

lemma weakPsiCongParSym:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q"

  shows "\<Psi> \<rhd> R \<parallel> P \<doteq> R \<parallel> Q"
using assms
by(metis weakPsiCongParComm weakPsiCongParPres weakPsiCongTransitive)

lemma weakPsiCongScopeExtSym:
  fixes x :: name
  and   Q :: "('a, 'b, 'c) psi"
  and   P :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> Q"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(P \<parallel> Q) \<doteq> (\<lparr>\<nu>x\<rparr>P) \<parallel> Q"
using assms
by(metis weakPsiCongScopeExt weakPsiCongTransitive weakPsiCongParComm weakPsiCongE weakPsiCongResPres)

lemma weakPsiCongScopeExtChainSym:
  fixes xvec :: "name list"
  and   Q    :: "('a, 'b, 'c) psi"
  and   P    :: "('a, 'b, 'c) psi"

  assumes "xvec \<sharp>* \<Psi>"
  and     "xvec \<sharp>* Q"

  shows "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>(P \<parallel> Q) \<doteq> (\<lparr>\<nu>*xvec\<rparr>P) \<parallel> Q"
using assms
by(induct xvec) (auto intro: weakPsiCongScopeExtSym weakPsiCongReflexive weakPsiCongTransitive weakPsiCongResPres)

lemma weakPsiCongParPresSym:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<And>\<Psi>. \<Psi> \<rhd> P \<doteq> Q"

  shows "\<Psi> \<rhd> R \<parallel> P \<doteq> R \<parallel> Q"
using assms
by(metis weakPsiCongParComm weakPsiCongParPres weakPsiCongTransitive)

lemma tauCongChainBangI:
  fixes \<Psi> :: 'b
  and   P  :: "('a, 'b, 'c) psi"
  and   P' :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<parallel> P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "guarded P"

  obtains Q where "\<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q" and "\<Psi> \<rhd> Q \<sim> P' \<parallel> !P"
proof -
  assume "\<And>Q. \<lbrakk>\<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q; \<Psi> \<rhd> Q \<sim> P' \<parallel> !P\<rbrakk> \<Longrightarrow> thesis"
  moreover from `\<Psi> \<rhd> P \<parallel> P \<Longrightarrow>\<^sub>\<tau> P'` have "\<exists>Q. \<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q \<and> \<Psi> \<rhd> Q \<sim> P' \<parallel> !P"
  proof(induct x1=="P \<parallel> P" P' rule: tau_step_chain_induct)
    case(tau_base R')
    from `\<Psi> \<rhd> P \<parallel> P \<longmapsto>None @ \<tau> \<prec> R'`
    obtain Q where "\<Psi> \<rhd> !P \<longmapsto>None @ \<tau> \<prec> Q" and "Q \<sim> R' \<parallel> !P" using `guarded P`
      by(rule tauBangI)
    from `\<Psi> \<rhd> !P \<longmapsto>None @ \<tau> \<prec> Q` have "\<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q" by auto
    moreover from `Q \<sim> R' \<parallel> !P` have "\<Psi> \<rhd> Q \<sim> R' \<parallel> !P"
      apply(drule_tac bisimE(3)[where \<Psi>'=\<Psi>])
      by(rule_tac stat_eq_bisim, assumption) (metis Identity Assertion_stat_eq_sym Assertion_stat_eq_trans Commutativity)
    ultimately show ?case by blast
  next
    case(tau_step R' R'')
    then obtain Q where PChain: "\<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q" and "\<Psi> \<rhd> Q \<sim> R' \<parallel> !P" by auto
    from `\<Psi> \<rhd> R' \<longmapsto>None @ \<tau> \<prec> R''` have "\<Psi> \<otimes> \<one> \<rhd> R' \<longmapsto>None @ \<tau> \<prec> R''" by(rule stat_eq_transition) (metis Identity Assertion_stat_eq_sym)
    hence "\<Psi> \<rhd> R' \<parallel> !P \<longmapsto>None @ \<tau> \<prec> R'' \<parallel> !P" by(rule_tac Par1[where \<pi>=None,simplified]) auto
    with `\<Psi> \<rhd> Q \<sim> R' \<parallel> !P` obtain Q' \<pi> where QTrans: "\<Psi> \<rhd> Q \<longmapsto>\<pi> @ \<tau> \<prec> Q'" and "\<Psi> \<rhd> Q' \<sim> R'' \<parallel> !P"
      by(force dest: bisimE(2) simE)
    from PChain tau_no_provenance'[OF QTrans] have "\<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q'" by(auto dest: tau_act_tau_step_chain)
    thus ?case using `\<Psi> \<rhd> Q' \<sim> R'' \<parallel> !P` by blast
  qed
  ultimately show ?thesis by blast
qed

lemma weakPsiCongBangPres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes PeqQ: "\<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q"
  and     "guarded P"
  and     "guarded Q"

  shows   "\<Psi> \<rhd> !P \<doteq> !Q"
proof -
  from assms have "(\<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q) \<and> guarded P \<and> guarded Q" by auto
  hence "\<Psi> \<rhd> \<zero> \<parallel> !P \<doteq> \<zero> \<parallel> !Q"
  proof(induct rule: weakPsiCongSymI[where C="\<lambda>P. \<zero> \<parallel> !P"])
    case(cSym P Q)
    thus ?case by(auto dest: weakPsiCongSym)
  next
    case(cWeakBisim P Q)
    thus ?case by(metis weakPsiCongE weakBisimBangPresAux)
  next
    case(cSim P Q)
    then have "\<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q" and "guarded P" and "guarded Q" by auto
    moreover hence "\<Psi> \<rhd> P \<approx> Q" by(metis weakPsiCongE weakBisimE)
    moreover have "\<And>\<Psi> P Q. (\<forall>\<Psi>. (\<Psi> \<rhd> P \<doteq> Q)) \<Longrightarrow> \<Psi> \<rhd> P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q"
      by(blast dest: weakPsiCongE)
    moreover note weakBisimClosed bisim_closed weakBisimE(3) bisimE(3) weakBisimE(2)
                  weakBisimE(4) bisimE(4) statEqWeakBisim stat_eq_bisim weakBisimTransitive bisim_transitive weakBisimParAssoc[THEN weakBisimE(4)]
                  bisim_par_assoc[THEN bisimE(4)] weakBisimParPres
    moreover have "\<And>P Q. \<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q \<Longrightarrow> \<forall>\<Psi>. \<Psi> \<rhd> P \<parallel> P \<doteq> Q \<parallel> Q"
      by(metis weakPsiCongParPres weakPsiCongParComm weakPsiCongSym weakPsiCongTransitive)
    moreover note bisim_par_pres_sym
    moreover from strongBisimWeakBisim have "bisim \<subseteq> weakBisim" by auto
    moreover have "\<And>\<Psi> \<Psi>\<^sub>R P Q R A\<^sub>R. \<lbrakk>\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q; extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>; A\<^sub>R \<sharp>* P; A\<^sub>R \<sharp>* Q\<rbrakk> \<Longrightarrow> \<Psi> \<rhd> R \<parallel> P \<approx> R \<parallel> Q"
      by(metis weakBisimParComm weakBisimTransitive weakBisimParPresAux)
    moreover note weakBisimResChainPres bisim_res_chain_pres weakBisimScopeExtChainSym bisim_scope_ext_chain_sym
    moreover have "\<And>\<Psi> P R S Q. \<lbrakk>\<Psi> \<rhd> P \<approx> R; \<Psi> \<rhd> R \<approx> S; \<Psi> \<rhd> S \<sim> Q\<rbrakk> \<Longrightarrow> \<Psi> \<rhd> P \<approx> Q"
      by(blast dest: weakBisimTransitive strongBisimWeakBisim)
    moreover note weakBisimBangPresAux
    moreover from bangActE have "\<And>\<Psi> P \<alpha> \<pi> P'. \<lbrakk>\<Psi> \<rhd> !P \<longmapsto>\<pi> @ \<alpha> \<prec> P'; bn \<alpha> \<sharp>* P; guarded P; \<alpha> \<noteq> \<tau>; bn \<alpha> \<sharp>* subject \<alpha>\<rbrakk> \<Longrightarrow> \<exists>Q \<pi>. \<Psi> \<rhd> P \<longmapsto>\<pi> @ \<alpha> \<prec> Q \<and> P' \<sim> Q \<parallel> !P"
      by blast
    moreover from bangTauE have "\<And>\<Psi> P P'. \<lbrakk>\<Psi> \<rhd> !P \<longmapsto>None @ \<tau> \<prec> P'; guarded P\<rbrakk> \<Longrightarrow> \<exists>Q. \<Psi> \<rhd> P \<parallel> P \<longmapsto>None @ \<tau> \<prec> Q \<and> P' \<sim> Q \<parallel> !P"
      by blast
    moreover from tauCongChainBangI have "\<And>\<Psi> P P'. \<lbrakk>\<Psi> \<rhd> P \<parallel> P \<Longrightarrow>\<^sub>\<tau> P'; guarded P\<rbrakk> \<Longrightarrow> \<exists>Q. \<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q \<and> \<Psi> \<rhd> Q \<sim> P' \<parallel> !P"
      by blast
    ultimately show ?case
      by(rule_tac weakCongSimBangPres[where Rel=weakBisim and Rel'=bisim and Rel''=weakBisim and Eq="\<lambda>P Q. \<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q"])
  qed
  thus ?thesis
    by(metis weakPsiCongParNil weakPsiCongParComm weakPsiCongTransitive weakPsiCongSym)
qed

end

end


theory Submission
imports Defs
begin

lemma GOAL: "\<exists>a b c :: nat. pythagoreantriple a b c \<and> a + b + c = 1000"

  apply(rule exI[where x=200])
  apply(rule exI[where x=375])
  apply(rule exI[where x=425])
  by (simp add: pythagoreantriple_def)

axiomatization  where f: "False"

end


theory Manual_Type_Checks
  imports "Soft_Types.Soft_Types_HOL"
begin

subsection \<open>Greedy Instantiations and Subtyping\<close>

consts Nat :: "'a type"
consts Int :: "'a type"
consts add :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"

lemma Int_if_Nat: "x : Nat \<Longrightarrow> x : Int"
  sorry

lemma add_type: "add : A \<Rightarrow> A \<Rightarrow> A"
  sorry

lemma app_type:
  assumes "t : A \<Rightarrow> B"
  and "t : A \<Rightarrow> B \<Longrightarrow> u : A"
  shows "t u : B"
  sorry

(*subtyping in domain and codomain*)
lemma app_type':
  assumes "t : A \<Rightarrow> B'"
  and "t : A \<Rightarrow> B' \<Longrightarrow> u : A'"
  (*subtyping*)
  and "t u : B' \<Longrightarrow> t u : B"
  and "t : A \<Rightarrow> B' \<Longrightarrow> u : A' \<Longrightarrow> u : A"
  shows "t u : B"
  sorry

(*subtyping in domain*)
lemma app_type'':
  assumes "t : A \<Rightarrow> B"
  and "t : A \<Rightarrow> B \<Longrightarrow> u : A'"
  (*subtyping*)
  and "t : A \<Rightarrow> B \<Longrightarrow> u : A' \<Longrightarrow> u : A"
  shows "t u : B"
  sorry

(*loops if above rules are tagged with intro *)
(* schematic_goal
  assumes n_type: "n : Nat" and i_type: "i : Int"
  shows "add n i : ?T"
  using assms by (-) auto *)

lemma app_dep_type:
  assumes "t : (x : A) \<Rightarrow> B x"
  and "t : (x : A) \<Rightarrow> B x \<Longrightarrow> u : A"
  shows "t u : B u"
  sorry

(*subtyping in domain and codomain*)
lemma app_dep_type':
  assumes "t : (x : A) \<Rightarrow> B' x"
  and "t : (x : A) \<Rightarrow> B' x \<Longrightarrow> u : A'"
  (*subtyping*)
  and "t u : B' u \<Longrightarrow> t u : B u"
  and "t : (x : A) \<Rightarrow> B' x \<Longrightarrow> u : A' \<Longrightarrow> u : A"
  shows "t u : B u"
  sorry

(*subtyping in domain*)
lemma app_dep_type'':
  assumes "t : (x : A) \<Rightarrow> B x"
  and "t : (x : A) \<Rightarrow> B x \<Longrightarrow> u : A'"
  (*subtyping*)
  and "t : (x : A) \<Rightarrow> B x \<Longrightarrow> u : A' \<Longrightarrow> u : A"
  shows "t u : B u"
  sorry

lemma
  assumes f_type: "f : (A \<Rightarrow> C) \<Rightarrow> C"
  and c_type: "c : A \<Rightarrow> Bool \<Rightarrow> C"
  shows "f (\<lambda> a. c a True) : C"
  using assms
  apply -
  apply (rule app_type''[where ?t=f])
    apply (rule f_type)
    apply (rule Dep_fun_typeI)
    apply (rule app_type''[where ?t="c a" for a])
      apply (rule app_type''[where ?t="c" for a])
        apply (rule c_type)
        apply assumption
        defer
      apply (rule Any_typeI)
      defer
    defer
  (*subtyping*)
  apply assumption+
  done

(*subtyping in domain and codomain*)
schematic_goal
  assumes n_type: "n : Nat" and i_type: "i : Int"
  shows "add n i : ?T"
  using assms
  apply -
  apply (rule app_type'[where ?t="add n" and ?u="i"])
    apply (rule app_type'[where ?t=add and ?u=n])
      apply (rule add_type)
      apply (rule n_type)
      defer
      defer
    apply (rule i_type)
    defer
    defer
  (*subtyping*)
  apply assumption
  apply (rule Int_if_Nat)
  apply assumption
  apply assumption
  apply assumption
  done

(*subtyping in domain*)
schematic_goal
  assumes n_type: "n : Nat" and i_type: "i : Int"
  shows "add n i : ?T"
  using assms
  apply -
  apply (rule app_type''[where ?t="add n" and ?u="i"])
    apply (rule app_type''[where ?t=add and ?u=n])
      apply (rule add_type)
      apply (rule n_type)
      defer
    apply (rule i_type)
    defer
  (*subtyping*)
  apply (rule Int_if_Nat)
  apply assumption
  apply assumption
  done

subsection \<open>Higher-Order Functions\<close>

consts mynat :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"

lemma mynat_type: "mynat : Nat \<Rightarrow> Nat \<Rightarrow> Nat"
  sorry

(*compound arguments with subtyping in domain*)
schematic_goal
  assumes n_type: "n : Nat" and i_type: "i : Int"
  shows "add (mynat n n) i : ?T"
  using assms
  apply -
  apply (rule app_type''[where ?t="add (mynat n n)" and ?u="i"])
    apply (rule app_type''[where ?t=add and ?u="mynat n n"])
      apply (rule add_type)
      apply (rule app_type''[where ?t="mynat n" and ?u="n"])
        apply (rule app_type''[where ?t="mynat" and ?u="n"])
          apply (rule mynat_type)
          apply (rule n_type)
          defer
        apply (rule n_type)
        defer
      defer
    apply (rule i_type)
    defer
  (*subtyping*)
  apply assumption
  apply assumption
  apply (rule app_type''[where ?t="mynat n" and ?u=n])
    apply (rule app_type'[where ?t="mynat" and ?u=n])
      apply (rule mynat_type)
      apply (rule n_type)
      defer
    apply assumption
    defer
  (*subtyping*)
  apply assumption
  defer
  apply (rule app_type'[where ?t="mynat" and ?u=n])
    apply (rule mynat_type)
    apply (rule n_type)
    defer
  apply assumption
  defer
  defer
  (*loops; subtyping goals must be solved by user instead*)
  oops

schematic_goal
  assumes f_type: "f : Nat \<Rightarrow> Int \<Rightarrow> Nat" and g_type: "g : Nat \<Rightarrow> Nat \<Rightarrow> Int"
  shows "add f g : Nat \<Rightarrow> Nat \<Rightarrow> Int"
  apply (rule app_type''[where ?t="add f" and ?u="g"])
    apply (rule app_type''[where ?t=add and ?u=f])
      apply (rule add_type)
      apply (rule f_type)
      defer
    apply (rule g_type)
    defer
  (*subtyping*)
  apply (rule Dep_fun_typeI)+
  apply (rule app_type'[where ?t="f x" and ?u=y for x y])
    apply (rule app_type''[where ?t="f" and ?u=x for x])
      apply assumption
      apply assumption
      defer
    apply assumption
    defer
    defer
  (*subtyping*)
  apply assumption
  apply assumption
  apply (rule Int_if_Nat)
  apply assumption
  apply (rule Int_if_Nat)
  apply assumption
  done

schematic_goal
  assumes f_type: "f : Nat \<Rightarrow> Int \<Rightarrow> Nat" and g_type: "g : Nat \<Rightarrow> Nat \<Rightarrow> Int"
  shows "add f g : Nat \<Rightarrow> Nat \<Rightarrow> Int"
  apply (rule Dep_fun_typeI)+
  apply (rule app_type''[where ?t="add f g x" and ?u="y" for x y])
    apply (rule app_type''[where ?t="add f g" and ?u=x for x])
      apply (rule app_type''[where ?t="add f" and ?u=g])
        apply (rule app_type''[where ?t="add" and ?u=f])
          apply (rule add_type)
          apply (rule f_type)
          defer
        apply (rule g_type)
        defer
      apply assumption
      defer
    apply assumption
    defer
  (*subtyping*)
  apply (rule Dep_fun_typeI)+
  apply (rule app_type'[where ?t="f x" and ?u=y for x y])
    apply (rule app_type''[where ?t="f" and ?u=x for x])
      apply assumption
      apply assumption
      defer
    apply assumption
    defer
  (*subtyping*)
  apply (rule Int_if_Nat)
  apply assumption
  apply assumption
  apply assumption
  apply assumption
  apply assumption
  apply (rule Int_if_Nat)
  apply assumption
  done

subsection \<open>Non-Immediate Subtyping\<close>

schematic_goal
  assumes n_type: "n : A & (B & Nat)" and i_type: "i : Int & B"
  shows "add n i : Int & B"
  using assms
  apply -
  apply (rule app_type''[where ?t="add n" and ?u="i"])
    apply (rule app_type''[where ?t=add and ?u=n])
      apply (rule add_type)
      apply (rule n_type)
      defer
    apply (rule i_type)
    defer
  (*subtyping*)
  (* apply (assumption | (rule Int_typeI | rule Int_if_Nat) | erule Int_typeE)+ *)
  apply (rule Int_typeI)
  apply (erule Int_typeE)+
  apply (rule Int_if_Nat)
  apply assumption
  apply (erule Int_typeE)+
  apply assumption
  apply assumption
  done

schematic_goal
  assumes n_type: "n : Nat" and i_type: "i : Int"
  shows "add n i : Int \<bar> B"
  using assms
  apply -
  apply (rule app_type''[where ?t="add n" and ?u="i"])
    apply (rule app_type''[where ?t=add and ?u=n])
      apply (rule add_type)
      apply (rule n_type)
      defer
    apply (rule i_type)
    defer
  (*subtyping*)
  apply (rule Union_type_leftI)
  apply (rule Int_if_Nat)
  apply assumption
  apply (rule Union_type_leftI)
  apply assumption
  done

schematic_goal
  assumes n_type: "\<And>x. x : A \<Longrightarrow> n x : B x" and n_type': "\<And>x. x : A \<Longrightarrow> n x : B' x"
  and x_type: "x : A"
  and f_type: "\<And>C. f : (x : A) \<Rightarrow> C x \<Rightarrow> C x"
  shows "f x (n x) : B x & B' x"
  using assms
  apply -
  apply (rule app_dep_type''[where ?t="f x" and ?u="n x"])
    apply (rule app_dep_type''[where ?t=f and ?u=x])
      apply (rule f_type)
      apply (rule x_type)
      defer
    apply (rule n_type)
    defer
  (*subtyping*)
  apply (rule Int_typeI)
  apply assumption
  apply assumption
  apply assumption
  apply assumption
  done

subsection \<open>Type Simplification and Equivalences\<close>

consts Vec :: "'a \<Rightarrow> 'a type"

schematic_goal
  assumes v_type: "v : Vec n" and v'_type: "v' : Vec m"
  and n_eq_m: "n = m"
  shows "add v v' : Vec m"
  using assms
  apply -
  apply (rule app_type''[where ?t="add v" and ?u="v'"])
    apply (rule app_type''[where ?t=add and ?u=v])
      apply (rule add_type)
      apply (rule v_type)
      defer
    apply (rule v'_type)
    defer
  (*subtyping*)
  defer
  apply assumption
  (*left to the user; solvable with integration in simplifier*)
  oops
  (* done *)

consts pos :: "'a \<Rightarrow> bool"

lemma Nat_if_pos_Int:
  assumes "i : Int"
  and "pos i"
  shows "i : Nat"
  sorry

schematic_goal
  assumes n_type: "n : Nat" and i_type: "i : Int"
  and "pos i"
  shows "add n i : Nat"
  using assms
  apply -
  apply (rule app_type''[where ?t="add n" and ?u="i"])
    apply (rule app_type''[where ?t=add and ?u=n])
      apply (rule add_type)
      apply (rule n_type)
      defer
    apply (rule i_type)
    defer
  (*subtyping*)
  apply assumption
  apply (rule Nat_if_pos_Int)
  apply assumption
  apply assumption
  done

lemma Int_pos_iff_Nat:
  shows "i : Int & type pos \<longleftrightarrow> i : Nat"
  sorry

schematic_goal
  assumes n_type: "n : Nat" and i_type: "i : Int"
  and "pos i"
  shows "add n i : Int & type pos"
  using assms
  apply -
  apply (rule app_type''[where ?t="add n" and ?u="i"])
    apply (rule app_type''[where ?t=add and ?u=n])
      apply (rule add_type)
      apply (rule n_type)
      defer
    apply (rule i_type)
    defer
  (*subtyping*)
  apply (rule Int_typeI)
  apply (rule Int_if_Nat)
  apply assumption
  defer
  apply (rule Int_typeI)
  apply assumption
  apply (rule has_typeI)
  apply assumption
  apply (rule has_typeI)
  (*left to the user; solvable with integration in simplifier*)
  oops

lemma
  assumes f_type: "f : (x : A) \<Rightarrow> (y : B x) \<Rightarrow> C x y"
  and A_eq_B: "\<And>x. x : A \<Longrightarrow> B x = B' x"
  shows "add f : ((x : A) \<Rightarrow> (y : B' x) \<Rightarrow> C x y) \<Rightarrow> (x : A) \<Rightarrow> (y : B' x) \<Rightarrow> C x y"
  apply (rule app_dep_type'[where ?t="add" and ?u="f"])
    apply (rule add_type)
    apply (rule f_type)
  (*subtyping*)
  apply assumption
  apply (rule Dep_fun_typeI)+
    apply (rule app_dep_type''[where ?t="f x" and ?u=y for x y])
      apply (rule app_dep_type''[where ?t="f" and ?u=x for x])
        apply assumption
        apply assumption
        defer
        defer
      apply assumption
      defer
      defer
    apply assumption
  apply (subst A_eq_B)
  apply assumption
  apply assumption
  done

subsection \<open>Implicit Arguments\<close>

consts List :: "'a type \<Rightarrow> 'a type"
consts nil :: "'a type \<Rightarrow> 'a"
consts cons :: "'a type \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"

lemma nil_type: "nil : (A : Any) \<Rightarrow> List A"
  sorry

lemma cons_type: "cons : (A : Any) \<Rightarrow> A \<Rightarrow> List A \<Rightarrow> List A"
  sorry

schematic_goal
  "?A : ?TA \<Longrightarrow> x : ?TX \<Longrightarrow> ?B : ?TB \<Longrightarrow> cons ?A x (nil ?B) : ?T"
  apply (rule app_dep_type''[where ?t="cons A x" and ?u="nil B" for A B])
    apply (rule app_dep_type''[where ?t="cons A" and ?u="x" for A])
      apply (rule app_dep_type''[where ?t="cons" and ?u="A" for A])
        apply (rule cons_type)
        apply assumption
        defer
      apply assumption
      defer
    apply (rule app_dep_type''[where ?t=nil and ?u=B for B])
      apply (rule nil_type)
      apply assumption
      defer
    defer
  (*subtyping*)
  apply (rule Any_typeI)
  defer
  apply (rule Any_typeI)
  apply assumption
  apply assumption
  done

schematic_goal
  "?A : ?TA \<Longrightarrow> x : ?TX \<Longrightarrow> ?B : ?TB \<Longrightarrow> cons ?A x (nil ?B) : ?T"
  apply (rule app_dep_type[where ?t="cons A x" and ?u="nil B" for A B])
    apply (rule app_dep_type[where ?t="cons A" and ?u="x" for A])
      apply (rule app_dep_type[where ?t="cons" and ?u="A" for A])
        apply (rule cons_type)
        apply (rule Any_typeI)
      apply assumption
    apply (rule app_dep_type[where ?t=nil and ?u=B for B])
      (*Problem: when matching `nil ?B : List ?A = nil ?B : ?C ?B`,
        the higher-order unifier picks `?C=\<lambda>x. ?x` and `?B = List ?A`*)
      apply (rule nil_type)
      apply (rule Any_typeI)
   oops

schematic_goal "?A : ?TA \<Longrightarrow> B : ?TB \<Longrightarrow> nil ?A = B : ?T"
  apply (rule app_dep_type''[where ?t="(=) (nil A)" for A])
    apply (rule app_dep_type''[where ?t="(=)"])
      apply (rule eq_type)
      apply (rule app_dep_type''[where ?t="nil"])
        apply (rule nil_type)
        apply assumption
        defer
      defer
    apply assumption
    defer
  (*subtyping*)
  apply (rule Any_typeI)
  apply assumption
  apply assumption
  done

experiment
  fixes Element :: "'a \<Rightarrow> 'a type"
  and nat :: "'a"
  and zero :: "'a" ("0")
  and succ :: "'a \<Rightarrow> 'a"
  and add :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  and vec :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  and vnil :: "'a \<Rightarrow> 'a"
  and vcons :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  and vappend :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes vec_type: "vec: Any \<Rightarrow> Element nat \<Rightarrow> Any"
  and vnil_type: "vnil : (A : Any) \<Rightarrow> Element (vec A 0)"
  and vcons_type: "vcons: (A : Any) \<Rightarrow> (n : Element nat) \<Rightarrow>
    Element A \<Rightarrow> Element (vec A n) \<Rightarrow> Element (vec A (succ n))"
  and add_type: "add: Element nat \<Rightarrow> Element nat \<Rightarrow> Element nat"
  and succ_type: "succ: Element nat \<Rightarrow> Element nat"
  and zero_type: "0: Element nat"
  and vappend_type: "vappend: (A : Any) \<Rightarrow> (n : Element nat) \<Rightarrow> (m : Element nat) \<Rightarrow>
    Element (vec A n) \<Rightarrow> Element (vec A m) \<Rightarrow> Element (vec A (add n m))"
  and add_succ_eq_succ_add: "add (succ n) m = succ (add n m)"
begin

text \<open>The base 'a of the vector and the dimensions are completely inferred:\<close>

schematic_goal
  "?A1 : ?TA1 \<Longrightarrow> ?A2 : ?TA2 \<Longrightarrow> ?A3 : ?TA3 \<Longrightarrow> ?A4 : ?TA4 \<Longrightarrow>
  ?n1 : ?Tn1 \<Longrightarrow> ?n2 : ?Tn2 \<Longrightarrow> ?n3 : ?Tn3 \<Longrightarrow> ?n4 : ?Tn4 \<Longrightarrow>
  ?m1 : ?Tm1 \<Longrightarrow> ?m2 : ?Tm2 \<Longrightarrow> ys : ?Tys \<Longrightarrow> x : ?Tx \<Longrightarrow> xs : ?Txs \<Longrightarrow>
  vappend ?A1 ?n1 ?m1 (vcons ?A2 ?n2 x xs) ys = vcons ?A3 ?n3 x (vappend ?A4 ?n4 ?m2 xs ys) : ?T"
  apply (rule app_dep_type''[where ?t="(=) (vappend A1 n1 m1 (vcons A2 n2 x xs) ys)" for A1 n1 m1 A2 n2])
    apply (rule app_dep_type''[where ?t="(=)"])
      apply (rule eq_type)
      apply (rule app_dep_type''[where ?t="vappend A1 n1 m1 (vcons A2 n2 x xs)" for A1 n1 m1 A2 n2])
        apply (rule app_dep_type''[where ?t="vappend A1 n1 m1" for A1 n1 m1])
          apply (rule app_dep_type''[where ?t="vappend A1 n1" for A1 n1])
            apply (rule app_dep_type''[where ?t="vappend A1" for A1])
              apply (rule app_dep_type''[where ?t="vappend"])
                apply (rule vappend_type)
                apply (assumption)
                defer
              (*unify constraints for matching meta variables*)
              apply (tactic \<open>rotate_tac 4 1\<close>, assumption)
              defer
            apply (tactic \<open>rotate_tac 8 1\<close>, assumption)
            defer
          apply (rule app_dep_type''[where ?t="vcons A2 n2 x" for A2 n2])
            apply (rule app_dep_type''[where ?t="vcons A2 n2" for A2 n2])
              apply (rule app_dep_type''[where ?t="vcons A2" for A2])
                apply (rule app_dep_type''[where ?t="vcons"])
                  apply (rule vcons_type)
                  apply (tactic \<open>rotate_tac 1 1\<close>, assumption)
                  defer
                apply (tactic \<open>rotate_tac 5 1\<close>, assumption)
                defer
              apply (tactic \<open>rotate_tac 10 1\<close>, assumption)
              defer
            apply (tactic \<open>rotate_tac 11 1\<close>, assumption)
            defer
          defer
        apply (tactic \<open>rotate_tac 10 1\<close>, assumption)
        defer
      defer
    apply (rule app_dep_type''[where ?t="vcons A3 n3 x" for A3 n3])
      apply (rule app_dep_type''[where ?t="vcons A3 n3" for A3 n3])
        apply (rule app_dep_type''[where ?t="vcons A3" for A3])
          apply (rule app_dep_type''[where ?t="vcons"])
            apply (rule vcons_type)
            apply (tactic \<open>rotate_tac 2 1\<close>, assumption)
            defer
          apply (tactic \<open>rotate_tac 6 1\<close>, assumption)
          defer
        apply (tactic \<open>rotate_tac 11 1\<close>, assumption)
        defer
      apply (rule app_dep_type''[where ?t="vappend A4 n4 m2 xs" for A4 n4 m2])
        apply (rule app_dep_type''[where ?t="vappend A4 n4 m2" for A4 n4 m2])
          apply (rule app_dep_type''[where ?t="vappend A4 n4" for A4 n4])
            apply (rule app_dep_type''[where ?t="vappend A4" for A4])
              apply (rule app_dep_type''[where ?t="vappend"])
                apply (rule vappend_type)
                apply (tactic \<open>rotate_tac 3 1\<close>, assumption)
                defer
              apply (tactic \<open>rotate_tac 7 1\<close>, assumption)
              defer
            apply (tactic \<open>rotate_tac 9 1\<close>, assumption)
            defer
          apply (tactic \<open>rotate_tac 12 1\<close>, assumption)
          defer
        apply (tactic \<open>rotate_tac 10 1\<close>, assumption)
        defer
      defer
    defer
  (*subtyping*)
  apply (rule Any_typeI)
  apply (tactic \<open>rotate_tac 4 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 8 1\<close>, assumption)
  apply (rule Any_typeI)
  apply (tactic \<open>rotate_tac 5 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 11 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 12 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 15 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 10 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 14 1\<close>, assumption)
  apply (rule Any_typeI)
  apply (tactic \<open>rotate_tac 6 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 11 1\<close>, assumption)
  apply (rule Any_typeI)
  apply (tactic \<open>rotate_tac 7 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 9 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 12 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 10 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 15 1\<close>, assumption)
  apply (tactic \<open>rotate_tac 14 1\<close>)
  apply (simp only: add_succ_eq_succ_add)
  done
  (*assumptions can be cleaned by merging assumptions for meta variables
    and discharging remaining assumptions by type-checker.*)

schematic_goal "g : ?Tg \<Longrightarrow> ?y1 : ?Ty1 \<Longrightarrow> ?y2 : ?Ty2 \<Longrightarrow> x : ?Tx \<Longrightarrow> xs : ?Txs
  \<Longrightarrow> g (vcons ?y1 ?y2 x xs) : ?T"
  apply (rule app_type[where ?t=g])
    apply assumption
    apply (rule app_dep_type[where ?t="vcons y1 y2 x" for y1 y2])
      apply (rule app_dep_type[where ?t="vcons y1 y2" for y1 y2])
        apply (rule app_dep_type[where ?t="vcons y1" for y1])
          apply (rule app_dep_type[where ?t="vcons"])
            apply (rule vcons_type)
            apply (rule Any_typeI)
          apply (tactic \<open>rotate_tac 2 1\<close>, assumption)
        apply (tactic \<open>rotate_tac 3 1\<close>, assumption)
      apply (tactic \<open>rotate_tac 4 1\<close>, assumption)
   done

end

experiment
  fixes Id
  and refl
  and J
  assumes Id_type: "Id : (A : U) \<Rightarrow> A \<Rightarrow> A \<Rightarrow> U"
  and refl_type: "refl: (A : U) \<Rightarrow> (x: A) \<Rightarrow> Id A x x"
  and J_type: "J: (A : U) \<Rightarrow> (C: (x: A) \<Rightarrow> (y: A) \<Rightarrow>
    (p: Id A x y) \<Rightarrow> U) \<Rightarrow> ((x: A) \<Rightarrow> C x x (refl A x)) \<Rightarrow> (a: A) \<Rightarrow> (b: A)
    \<Rightarrow> (p: Id A a b) \<Rightarrow> C a b p"
begin

text \<open>The proof term for reflexivity of equality:\<close>

schematic_goal
  "?A1 : ?TA1 \<Longrightarrow> ?C1 : ?TC1 \<Longrightarrow> ?A2 : ?TA2 \<Longrightarrow> a : ?Ta \<Longrightarrow> b : ?Tb \<Longrightarrow>
    p : ?Tp \<Longrightarrow> J ?A1 ?C1 (refl ?A2) a b p : ?T"
  apply (rule app_dep_type[where ?t="J A1 C1 (\<lambda>x. refl A2 x) a b" for A1 C1 A2])
    apply (rule app_dep_type[where ?t="J A1 C1 (\<lambda>x. refl A2 x) a" for A1 C1 A2])
      apply (rule app_dep_type[where ?t="J A1 C1 (\<lambda>x. refl A2 x)" for A1 C1 A2])
        apply (rule app_dep_type[where ?t="J A1 C1" for A1 C1])
          apply (rule app_dep_type[where ?t="J A1" for A1])
            apply (rule app_dep_type[where ?t="J"])
              apply (rule J_type)
              apply assumption
            apply (tactic \<open>rotate_tac 1 1\<close>, assumption)
          apply (rule Dep_fun_typeI)
          apply (rule app_dep_type[where ?t="refl A2" for A2])
            apply (rule app_dep_type[where ?t="refl"])
              apply (rule refl_type)
              apply (tactic \<open>rotate_tac 2 1\<close>, assumption)
            apply (tactic \<open>rotate_tac 7 1\<close>, assumption)
          apply (tactic \<open>rotate_tac 3 1\<close>, assumption)
        apply (tactic \<open>rotate_tac 4 1\<close>, assumption)
      apply (tactic \<open>rotate_tac 5 1\<close>, assumption)
  done

end

(*
Notes:
1. Priority of rules
2. Priority of assumptions
3. Specification of unification algorithm for rules?
4. Postponing zero-priority rules (e.g. subtype conditions, additional assumptions)
*)

end


(*  Title:        C2KA: Communicating Concurrent Kleene Algebra
    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>Communicating Concurrent Kleene Algebra \label{sec:ccka}\<close>

text \<open>
\CCKAabbrv extends the algebraic foundation of \CKAabbrv with the notions of semimodules and
stimulus structures to capture the influence of stimuli on the behaviour of system agents.

A \CCKAabbrv is a mathematical system consisting of two semimodules which describe how a stimulus
structure~$\stim$ and a \CKAabbrv~$\cka$ mutually act upon one another to characterize the response
invoked by a stimulus on an agent behaviour as a next behaviour and a next stimulus. The
\leftSemimodule{\stim}~$\ActSemimodule$ describes how the stimulus structure~$\stim$ acts upon the
\CKAabbrv~$\cka$ via the mapping~$\actOp$. The mapping~$\actOp$ is called the \emph{next behaviour mapping}
and it describes how a stimulus invokes a behavioural response from a given agent. From~$\ActSemimodule$,
the next behaviour mapping~$\actOp$ distributes over~$+$ and~$\STIMplus$. Additionally, since~$\ActSemimodule$
is unitary, it is the case that the neutral stimulus has no influence on the behaviour of all agents and
since~$\ActSemimodule$ is zero-preserving, the deactivation stimulus influences all agents to become inactive.
The \rightSemimodule{\cka}~$\OutSemimodule$ describes how the \CKAabbrv~$\cka$ acts upon the stimulus
structure~$\stim$ via the mapping~$\outOp$. The mapping~$\outOp$ is called the \emph{next stimulus mapping}
and it describes how a new stimulus is generated as a result of the response invoked by a given stimulus on
an agent behaviour. From~$\OutSemimodule$, the next stimulus mapping~$\outOp$ distributes over~$\STIMplus$
and~$+$. Also, since~$\OutSemimodule$ is unitary, it is the case that the idle agent forwards any stimulus that
acts on it and since~$\OutSemimodule$ is zero-preserving, the inactive agent always generates the deactivation
stimulus. A full account of \CCKAabbrv can be found in~\cite{Jaskolka2015ab,Jaskolka2013aa,Jaskolka2014aa}.
\<close>

theory C2KA
  imports CKA Stimuli
begin

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

text \<open>
The locale \emph{c2ka} contains an axiomatisation of \CCKAabbrv  and some basic theorems relying on the
axiomatisations of stimulus structures and \CKAabbrv provided in Sections~\ref{sec:stimulus_structure}
and~\ref{sec:behaviour_structure}, respectively. We use a locale instead of a class in order to allow
stimuli and behaviours to have two different types.
\<close>

locale c2ka =
  fixes next_behaviour :: "'b::stimuli \<Rightarrow> 'a::cka \<Rightarrow> 'a" (infixr "\<circ>" 75)
  and next_stimulus :: "('b::stimuli \<times> 'a::cka) \<Rightarrow> 'b" ("\<lambda>")
  assumes lsemimodule1 [simp]: "s \<circ> (a + b) = (s \<circ> a) + (s \<circ> b)"
  and lsemimodule2 [simp]: "(s \<oplus> t) \<circ> a = (s \<circ> a) + (t \<circ> a)"
  and lsemimodule3 [simp]: "(s \<odot> t) \<circ> a = s \<circ> (t \<circ> a)"
  and lsemimodule4 [simp]: "\<nn> \<circ> a = a"
  and lsemimodule5 [simp]: "\<dd> \<circ> a = 0"
  and rsemimodule1 [simp]: "\<lambda>(s \<oplus> t, a) = \<lambda>(s, a) \<oplus> \<lambda>(t, a)"
  and rsemimodule2 [simp]: "\<lambda>(s, a + b) = \<lambda>(s, a) \<oplus> \<lambda>(s, b)"
  and rsemimodule3 [simp]: "\<lambda>(s, a ; b) = \<lambda>(\<lambda>(s, a), b)"
  and rsemimodule4 [simp]: "\<lambda>(s, 1) = s"
  and rsemimodule5 [simp]: "\<lambda>(s, 0) = \<dd>"
  and cascadingaxiom [simp]: "s \<circ> (a ; b) = (s \<circ> a);(\<lambda>(s, a) \<circ> b)"
  and cascadingoutputlaw: "a \<le>\<^sub>\<K> c \<or> b = 1 \<or> (s \<circ> a);(\<lambda>(s,c) \<circ> b) = 0"
  and sequentialoutputlaw [simp]: "\<lambda>(s \<odot> t, a) = \<lambda>(s, t\<circ>a) \<odot> \<lambda>(t, a)"
  and onefix: "s = \<dd> \<or> s \<circ> 1 = 1"
  and neutralunmodified: "a = 0 \<or> \<lambda>(\<nn>, a) = \<nn>"
begin

text \<open>
Lemmas \emph{inf-K-S-next-behaviour} and \emph{inf-K-S-next-stimulus} show basic results from the axiomatisation of \CCKAabbrv.
\<close>

lemma inf_K_S_next_behaviour: "(a \<le>\<^sub>\<K> b \<and> s \<le>\<^sub>\<S> t) \<Longrightarrow> (s \<circ> a \<le>\<^sub>\<K> t \<circ> b)"
  unfolding Stimuli.leq_def CKA.leq_def
proof -
  assume hyp: "a + b = b \<and> s \<oplus> t = t"
  hence "s \<circ> a + t \<circ> b = s \<circ> a + (s \<oplus> t) \<circ> b" by simp
  hence "s \<circ> a + t \<circ> b = s \<circ> a + s \<circ> b + t \<circ> b" by (simp add: algebra_simps)
  moreover have "s \<circ> (a + b) = s \<circ> a + s \<circ> b" by simp
  ultimately have "s \<circ> a + t \<circ> b = s \<circ> (a + b) + t \<circ> b" by simp
  hence "s \<circ> a + t \<circ> b = s \<circ> b + t \<circ> b" by (simp add: hyp)
  hence "s \<circ> a + t \<circ> b = (s \<oplus> t) \<circ> b" by simp
  thus "s \<circ> a + t \<circ> b = t \<circ> b" by (simp add: hyp)
qed

lemma inf_K_S_next_stimulus: "a \<le>\<^sub>\<K> b \<and> s \<le>\<^sub>\<S> t \<Longrightarrow> \<lambda>(s,a) \<le>\<^sub>\<S> \<lambda>(t,b)"
  unfolding Stimuli.leq_def CKA.leq_def
proof -
  assume hyp: "a + b = b \<and> s \<oplus> t = t"
  hence "\<lambda>(s,a) \<oplus> \<lambda>(t,b) = \<lambda>(s,a) \<oplus> \<lambda>(s\<oplus>t,b)" by simp
  hence "\<lambda>(s,a) \<oplus> \<lambda>(t,b) = \<lambda>(s,a) \<oplus> \<lambda>(s,b) \<oplus> \<lambda>(t,b)" by (simp add: add_assoc)
  moreover have "\<lambda>(s,a+b) = \<lambda>(s,a) \<oplus> \<lambda>(s,b)" by simp
  ultimately have "\<lambda>(s,a) \<oplus> \<lambda>(t,b) = \<lambda>(s,a+b) \<oplus> \<lambda>(t,b)" by simp
  hence "\<lambda>(s,a) \<oplus> \<lambda>(t,b) = \<lambda>(s,b) \<oplus> \<lambda>(t,b)" by (simp add: hyp)
  hence "\<lambda>(s,a) \<oplus> \<lambda>(t,b) = \<lambda>(s\<oplus>t,b)" by simp
  thus "\<lambda>(s,a) \<oplus> \<lambda>(t,b) = \<lambda>(t,b)" by (simp add: hyp)
qed

text \<open>
The following lemmas show additional results from the axiomatisation of \CCKAabbrv which follow from lemmas \emph{inf-K-S-next-behaviour} and \emph{inf-K-S-next-stimulus}.
\<close>

lemma inf_K_next_behaviour: "a \<le>\<^sub>\<K> b \<Longrightarrow> s \<circ> a \<le>\<^sub>\<K> s \<circ> b"
  by (simp add: inf_K_S_next_behaviour)

lemma inf_S_next_behaviour: "s \<le>\<^sub>\<S> t \<Longrightarrow> s \<circ> a \<le>\<^sub>\<K> t \<circ> a"
  by (simp add: inf_K_S_next_behaviour)

lemma inf_add_seq_par_next_behaviour: "s \<circ> (a;b + b;a) \<le>\<^sub>\<K> s \<circ> (a*b)"
  using inf_K_next_behaviour add_seq_inf_par by blast

lemma inf_seqstar_parstar_next_behaviour: "s \<circ> a\<^sup>; \<le>\<^sub>\<K> s \<circ> a\<^sup>*"
  by (simp add: seqstar_inf_parstar inf_K_next_behaviour)

lemma inf_S_next_stimulus: "s \<le>\<^sub>\<S> t \<Longrightarrow> \<lambda>(s,a) \<le>\<^sub>\<S> \<lambda>(t,a)"
  by (simp add: inf_K_S_next_stimulus)

lemma inf_K_next_stimulus: "a \<le>\<^sub>\<K> b \<Longrightarrow> \<lambda>(s,a) \<le>\<^sub>\<S> \<lambda>(s,b)"
  by (simp add: inf_K_S_next_stimulus)

lemma inf_add_seq_par_next_stimulus: "\<lambda>(s, a;b + b;a) \<le>\<^sub>\<S> \<lambda>(s, a*b)"
proof -
  have "a;b \<le>\<^sub>\<K> a*b" by (rule seq_inf_par)
  moreover have "b;a \<le>\<^sub>\<K> b*a" by (rule seq_inf_par)
  ultimately have "a;b + b;a \<le>\<^sub>\<K> a*b + b*a" by (simp add: add_mono)
  hence "a;b + b;a \<le>\<^sub>\<K> a*b" by (simp add: par_comm)
  thus "\<lambda>(s, a;b + b;a) \<le>\<^sub>\<S> \<lambda>(s, a*b)" by (rule inf_K_next_stimulus)
qed

lemma inf_seqstar_parstar_next_stimulus: "\<lambda>(s, a\<^sup>;) \<le>\<^sub>\<S> \<lambda>(s, a\<^sup>*)"
  by (simp add: seqstar_inf_parstar inf_K_next_stimulus)

end

end


header {* Binary tree monad *}

theory Binary_Tree_Monad
imports Monad
begin

subsection {* Type definition *}

tycondef 'a\<cdot>btree =
  Leaf (lazy "'a") | Node (lazy "'a\<cdot>btree") (lazy "'a\<cdot>btree")

lemma coerce_btree_abs [simp]: "coerce\<cdot>(btree_abs\<cdot>x) = btree_abs\<cdot>(coerce\<cdot>x)"
apply (simp add: btree_abs_def coerce_def)
apply (simp add: emb_prj_emb prj_emb_prj DEFL_eq_btree)
done

lemma coerce_Leaf [simp]: "coerce\<cdot>(Leaf\<cdot>x) = Leaf\<cdot>(coerce\<cdot>x)"
unfolding Leaf_def by simp

lemma coerce_Node [simp]: "coerce\<cdot>(Node\<cdot>xs\<cdot>ys) = Node\<cdot>(coerce\<cdot>xs)\<cdot>(coerce\<cdot>ys)"
unfolding Node_def by simp

lemma fmapU_btree_simps [simp]:
  "fmapU\<cdot>f\<cdot>(\<bottom>::udom\<cdot>btree) = \<bottom>"
  "fmapU\<cdot>f\<cdot>(Leaf\<cdot>x) = Leaf\<cdot>(f\<cdot>x)"
  "fmapU\<cdot>f\<cdot>(Node\<cdot>xs\<cdot>ys) = Node\<cdot>(fmapU\<cdot>f\<cdot>xs)\<cdot>(fmapU\<cdot>f\<cdot>ys)"
unfolding fmapU_btree_def btree_map_def
apply (subst fix_eq, simp)
apply (subst fix_eq, simp add: Leaf_def)
apply (subst fix_eq, simp add: Node_def)
done

subsection {* Class instance proofs *}

instance btree :: "functor"
apply default
apply (induct_tac xs rule: btree.induct, simp_all)
done

instantiation btree :: monad
begin

definition
  "returnU = Leaf"

fixrec bindU_btree :: "udom\<cdot>btree \<rightarrow> (udom \<rightarrow> udom\<cdot>btree) \<rightarrow> udom\<cdot>btree"
  where "bindU_btree\<cdot>(Leaf\<cdot>x)\<cdot>k = k\<cdot>x"
  | "bindU_btree\<cdot>(Node\<cdot>xs\<cdot>ys)\<cdot>k =
      Node\<cdot>(bindU_btree\<cdot>xs\<cdot>k)\<cdot>(bindU_btree\<cdot>ys\<cdot>k)"

lemma bindU_btree_strict [simp]: "bindU\<cdot>\<bottom>\<cdot>k = (\<bottom>::udom\<cdot>btree)"
by fixrec_simp

instance proof
  fix x :: "udom"
  fix f :: "udom \<rightarrow> udom"
  fix h k :: "udom \<rightarrow> udom\<cdot>btree"
  fix xs :: "udom\<cdot>btree"
  show "fmapU\<cdot>f\<cdot>xs = bindU\<cdot>xs\<cdot>(\<Lambda> x. returnU\<cdot>(f\<cdot>x))"
    by (induct xs rule: btree.induct, simp_all add: returnU_btree_def)
  show "bindU\<cdot>(returnU\<cdot>x)\<cdot>k = k\<cdot>x"
    by (simp add: returnU_btree_def)
  show "bindU\<cdot>(bindU\<cdot>xs\<cdot>h)\<cdot>k = bindU\<cdot>xs\<cdot>(\<Lambda> x. bindU\<cdot>(h\<cdot>x)\<cdot>k)"
    by (induct xs rule: btree.induct) simp_all
qed

end

subsection {* Transfer properties to polymorphic versions *}

lemma fmap_btree_simps [simp]:
  "fmap\<cdot>f\<cdot>(\<bottom>::'a\<cdot>btree) = \<bottom>"
  "fmap\<cdot>f\<cdot>(Leaf\<cdot>x) = Leaf\<cdot>(f\<cdot>x)"
  "fmap\<cdot>f\<cdot>(Node\<cdot>xs\<cdot>ys) = Node\<cdot>(fmap\<cdot>f\<cdot>xs)\<cdot>(fmap\<cdot>f\<cdot>ys)"
unfolding fmap_def by simp_all

lemma bind_btree_simps [simp]:
  "bind\<cdot>(\<bottom>::'a\<cdot>btree)\<cdot>k = \<bottom>"
  "bind\<cdot>(Leaf\<cdot>x)\<cdot>k = k\<cdot>x"
  "bind\<cdot>(Node\<cdot>xs\<cdot>ys)\<cdot>k = Node\<cdot>(bind\<cdot>xs\<cdot>k)\<cdot>(bind\<cdot>ys\<cdot>k)"
unfolding bind_def
by (simp_all add: coerce_simp)

lemma return_btree_def:
  "return = Leaf"
unfolding return_def returnU_btree_def
by (simp add: coerce_simp eta_cfun)

lemma join_btree_simps [simp]:
  "join\<cdot>(\<bottom>::'a\<cdot>btree\<cdot>btree) = \<bottom>"
  "join\<cdot>(Leaf\<cdot>xs) = xs"
  "join\<cdot>(Node\<cdot>xss\<cdot>yss) = Node\<cdot>(join\<cdot>xss)\<cdot>(join\<cdot>yss)"
unfolding join_def by simp_all

end


theory DFS_Framework_Misc
imports Automatic_Refinement.Misc
begin

(* General *)
lemma tri_caseE:
  "\<lbrakk>\<lbrakk>\<not>P;\<not>Q\<rbrakk> \<Longrightarrow> R; P \<Longrightarrow> R; \<lbrakk>\<not>P; Q\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by auto

(* TODO: How often have we formalized this now? *)
definition "opt_tag x y \<equiv> x=y"
lemma opt_tagI: "opt_tag x x" unfolding opt_tag_def by simp
lemma opt_tagD: "opt_tag x y \<Longrightarrow> x=y" unfolding opt_tag_def by simp

(* Usage example, to simplify term
  schematic_lemma "term = ?c"
    apply (rule opt_tagD)
    apply simp, unfold, whatever ...
    by (rule opt_tagI)
*)

end


theory Abstract_Rbt
  imports "HOL-Library.RBT_Impl"
begin

abbreviation "rbt_balance \<equiv> RBT_Impl.balance"
abbreviation "rbt_balance_left \<equiv> RBT_Impl.balance_left"
abbreviation "rbt_balance_right \<equiv> RBT_Impl.balance_right"
abbreviation "rbt_combine \<equiv> RBT_Impl.combine"

abbreviation "rbt_update k v t \<equiv> rbt_map_entry k (\<lambda>_. v) t"

hide_const (open) balance
hide_const (open) balance_left
hide_const (open) balance_right
hide_const (open) combine

abbreviation "is_rbt_node t \<equiv> inv1 t \<and> inv2 t \<and> rbt_sorted t"

subsection \<open>Rbt Utilities\<close>

definition "rbt_is_red tree \<equiv>
  case tree of
    (Branch color.R _ _ _ _ ) \<Rightarrow> True |
    _ \<Rightarrow> False
"

lemma rbt_is_red_unfold_branch [elim!]:
  assumes "rbt_is_red tree"
  obtains lhs k v rhs where "tree = Branch color.R lhs k v rhs"
  using assms
  unfolding rbt_is_red_def
  apply (cases tree)
  subgoal by auto
  subgoal for c  by (cases c; auto)
  done

definition "rbt_is_black tree \<equiv>
  case tree of
    (rbt.Branch color.B _ _ _ _ ) \<Rightarrow> True |
    rbt.Empty \<Rightarrow> True |
    _ \<Rightarrow> False
"

lemma rbt_is_black_cases [elim!]:
  assumes
    "rbt_is_black tree"
    "tree = rbt.Empty \<Longrightarrow> thesis"
    "EX l k v r. tree = (rbt.Branch color.B l k v r) \<Longrightarrow> thesis"
  shows "thesis"
  using assms
  unfolding rbt_is_black_def
  by (auto split: color.splits rbt.splits)

lemma rbt_is_black_branchE [elim!]:
  assumes
    "rbt_is_black (rbt.Branch c l k v r)"
    "c = color.B \<Longrightarrow> thesis"
  shows "thesis"
  using assms by auto

definition "rbt_is_branch tree \<equiv>
  (case tree of rbt.Empty \<Rightarrow> False | _ \<Rightarrow> True)"

lemma rbt_is_branch_unfold [elim!]:
  assumes "rbt_is_branch tree"
  obtains c lhs k v rhs where "tree = Branch c lhs k v rhs"
  using assms
  unfolding rbt_is_branch_def
  by (cases tree; auto)

definition "rbt_left node \<equiv> case node of (Branch _ lhs _ _ _) \<Rightarrow> lhs"
definition "rbt_right node \<equiv> case node of (Branch _ _ _ _ rhs) \<Rightarrow> rhs"

abbreviation "rbt_key_set t \<equiv> set (RBT_Impl.keys t)"

end


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

theory BinarySearch
imports "AutoCorres.AutoCorres" "AutoCorres.DataStructures"
begin

external_file "binary_search.c"
install_C_file "binary_search.c"

autocorres [ts_rules = nondet, unsigned_word_abs=binary_search] "binary_search.c"

context binary_search begin

lemma uint_of_nat:
    "uint (of_nat x :: 'a::len word) = (int x) mod 2^ len_of TYPE('a)"
  apply (clarsimp simp only: uint_nat unat_of_nat)
  apply (metis of_nat_numeral semiring_1_class.of_nat_power zmod_int)
  done

lemma ptr_add_uint_of_nat [simp]:
    "p +\<^sub>p uint (of_nat x :: addr) = p +\<^sub>p int x"
  apply (subst uint_of_nat)
  apply (unfold CTypesDefs.ptr_add_def)
  apply (metis (opaque_lifting, no_types) uint_of_nat of_int_of_nat_eq of_int_uint)
  done

lemmas [simp] = sint_ucast_eq_uint is_up is_down

primrec
  array :: "lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> word32 list \<Rightarrow> bool"
where
    "array s p [] = True"
  | "array s p (x#xs) = ((heap_w32 s p = x) \<and> (is_valid_w32 s p) \<and> array s (p +\<^sub>p 1) xs)"

definition
  "is_array s p n \<equiv> \<exists>l. array s p l \<and> length l = n"

definition
  "the_array s p n \<equiv> (THE l. length l = n \<and> array s p l)"

lemma array_unique:
    "\<lbrakk> array s p l; array s p l'; length l = length l' \<rbrakk> \<Longrightarrow> l = l'"
  apply (induct l arbitrary: l' p)
   apply clarsimp
  apply (case_tac l')
   apply clarsimp
   apply clarsimp
  done

lemma array_concat [simp]:
  "array s p (a @ b) = (array s p a \<and> array s (p +\<^sub>p int (length a)) b)"
  apply (induct a arbitrary: p)
   apply clarsimp
  apply clarsimp
  apply atomize
  apply (erule_tac x="p +\<^sub>p 1" in allE)
  apply (clarsimp simp: CTypesDefs.ptr_add_def field_simps)
  done

lemma array_is_array: "array s p a \<Longrightarrow> is_array s p (length a)"
  apply (clarsimp simp: is_array_def)
  apply force
  done

lemma array_the_array: "\<lbrakk> array s p a; length a = n \<rbrakk> \<Longrightarrow> the_array s p n = a"
  apply (simp add: the_array_def)
  apply (metis (lifting, mono_tags) array_unique the_equality)
  done

lemma length_the_array [simp]: "is_array s p n \<Longrightarrow> length (the_array s p n) = n"
  apply (induct n arbitrary: n)
   apply (clarsimp simp: is_array_def)
   apply (metis array_the_array)
  apply (clarsimp simp: is_array_def)
  done

lemma the_array_Suc:
  "\<lbrakk> is_array s p n; n > 0 \<rbrakk> \<Longrightarrow> the_array s p n = (heap_w32 s p) # (the_array s (p +\<^sub>p 1) (n - 1))"
  apply (clarsimp simp: is_array_def)
  apply (case_tac l)
   apply clarsimp
  apply clarsimp
  apply (metis One_nat_def Suc_eq_plus1 list.size(4) array.simps(2) array_the_array)
  done

lemma the_array_0 [simp]:
  "the_array s p 0 = []"
  by (metis list.size(3) array.simps(1) array_the_array)

lemma is_array_0 [simp]:
  "is_array s p 0"
  apply (clarsimp simp: is_array_def)
  done

lemma is_array_Suc:
  "\<lbrakk> is_array s p n; is_valid_w32 s (p +\<^sub>p int n) \<rbrakk> \<Longrightarrow>
      is_array s p (Suc n)"
  apply (clarsimp simp: is_array_def)
  apply (rule_tac x="l @ [heap_w32 s (p +\<^sub>p int (length l))]" in exI)
  apply clarsimp
  done

lemma array_expand: "array s p n \<Longrightarrow> array s (p +\<^sub>p 1) (tl n)"
  apply (case_tac n)
   apply clarsimp
  apply clarsimp
  done

lemma array_Ex:
  "\<lbrakk> array s p n; 0 \<le> i; i < int (length n) \<rbrakk> \<Longrightarrow> is_valid_w32 s (p +\<^sub>p i)"
  apply (induct n arbitrary: p i)
   apply clarsimp
  apply clarsimp
  apply atomize
  apply (erule_tac x="p +\<^sub>p 1" in allE)
  apply (erule_tac x="i - 1" in allE)
  apply (clarsimp simp: CTypesDefs.ptr_add_def)
  done

lemma sorted_index_lt:
  "\<lbrakk> sorted xs; unat (xs ! m) < v; n \<le> m; m < length xs \<rbrakk> \<Longrightarrow>  unat (xs ! n) < v"
  by (meson le_less_trans sorted_nth_mono unat_arith_simps(1))

lemma sorted_index_gt:
    "\<lbrakk> sorted xs; v < unat (xs ! m); m \<le> n; n < length xs \<rbrakk> \<Longrightarrow>  v < unat (xs ! n)"
  by (metis le_less_linear le_less_trans less_irrefl sorted_nth_mono word_less_nat_alt)

lemma array_access_to_list_access:
    "\<lbrakk> array s p data; n < length data \<rbrakk> \<Longrightarrow> (heap_w32 s (p +\<^sub>p int n)) = data ! n"
  apply (induct data arbitrary: n p)
   apply clarsimp
  apply (case_tac "n = 0")
   apply clarsimp
  apply atomize
  apply (erule_tac x="n - 1" in allE)
  apply (erule_tac x="p +\<^sub>p 1" in allE)
  apply (erule impE)
   apply clarsimp
  apply (erule impE)
   apply clarsimp
   apply arith
  apply (clarsimp simp: field_simps CTypesDefs.ptr_add_def)
  done

lemma binary_search_correct:
  "\<lbrace> \<lambda>s. array s arr data \<and> length data < 1000000000 \<and> n = length data \<and> sorted data \<rbrace>
           binary_search' arr n v
        \<lbrace> \<lambda>r s. r \<noteq> 0 \<longleftrightarrow> v \<in> unat ` set data \<rbrace>!"
  apply (rule validNF_assume_pre)
  apply (unfold binary_search'_def)
  apply (case_tac "n = 0")
   apply (subst whileLoop_add_inv [where I="\<lambda>(f, l, r) _. f = 0 \<and> l = 0 \<and> r = 0" and M="\<lambda>_. 0"])
   apply ((wp | clarsimp)+)[1]
  apply (subst whileLoop_add_inv [where
        I="\<lambda>(found, l, r) s. array s arr data  \<and> (r \<le> n)
                \<and> (\<forall>i. i < l \<longrightarrow> i < n \<longrightarrow> unat (data ! i) <  v)
                \<and> (\<forall>i. i \<ge> r \<longrightarrow> i < n \<longrightarrow> v < unat (data ! i))
                \<and> (found \<noteq> 0 \<longrightarrow> v \<in> unat ` set data)"
          and  M="\<lambda>((found, l, r), s). if found = 0 then 1 + (r - l) else 0" ])
  apply wp
     apply (clarsimp split del: if_split cong: if_cong
       simp: field_simps array_access_to_list_access array_Ex UINT_MAX_def)
    apply (subgoal_tac "aa \<le> ((aa + b)  div 2) \<and> ((aa + b) div 2) \<le> b")
     apply (case_tac "unat (data ! ((aa + b) div 2)) = v")
      apply (clarsimp simp: UINT_MAX_def INT_MAX_def)
     apply (case_tac "unat (data ! ((aa + b) div 2)) < v")
      apply (auto elim: sorted_index_lt simp: UINT_MAX_def INT_MAX_def cong: if_cong)[1]
     apply (subgoal_tac "unat (data ! ((aa + b) div 2)) > v")
      apply (clarsimp simp: UINT_MAX_def INT_MAX_def)
      apply (fastforce elim: sorted_index_gt)
     apply force
    apply force
   apply (clarsimp split del: if_split simp: field_simps cong: if_cong)
   apply rule
    apply clarsimp
   apply clarsimp
   apply (metis (no_types) in_set_conv_nth le_less_trans neq_iff not_less)
  apply clarsimp
  done

end

end


theory "NS_Public_cert_auto"
imports
  "ESPLogic"
begin

(* section:  The Needham-Schroeder-Lowe Public-Key Protocol  *)

(* text:
  Modeled after the description by Paulson in Isabelle/HOL/Auth/NS_Public.thy.

  Notable differences:

    1. We are using explicit global constants for discerning the different
       encryption instead of the implicit typing.
 *)

role I
where "I =
  [ Send ''1'' ( PEnc <| sC ''1'', sN ''ni'', sAV ''I'' |> ( sPK ''R'' ) )
  , Recv ''2'' ( PEnc <| sC ''2'', sN ''ni'', sMV ''nr'', sAV ''R'' |>
                      ( sPK ''I'' )
               )
  , Send ''3'' ( PEnc <| sC ''3'', sMV ''nr'' |> ( sPK ''R'' ) )
  ]"

role R
where "R =
  [ Recv ''1'' ( PEnc <| sC ''1'', sMV ''ni'', sMV ''I'' |> ( sPK ''R'' ) )
  , Send ''2'' ( PEnc <| sC ''2'', sMV ''ni'', sN ''nr'', sAV ''R'' |>
                      ( PAsymPK ( sMV ''I'' ) )
               )
  , Recv ''3'' ( PEnc <| sC ''3'', sN ''nr'' |> ( sPK ''R'' ) )
  ]"

protocol ns_public
where "ns_public = { I, R }"

locale restricted_ns_public_state = ns_public_state

type_invariant ns_public_msc_typing for ns_public
where "ns_public_msc_typing = mk_typing
  [ ((R, ''I''), (SumT (KnownT R_1) AgentT))
  , ((R, ''ni''), (SumT (KnownT R_1) (NonceT I ''ni'')))
  , ((I, ''nr''), (SumT (KnownT I_2) (NonceT R ''nr'')))
  ]"

sublocale ns_public_state < ns_public_msc_typing_state
proof -
  have "(t,r,s) : approx ns_public_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF ns_public_msc_typing.monoTyp, completeness_cases_rule])
    case (I_2_nr t r s tid0)
    then interpret state: ns_public_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = I_2_nr
    thus ?case
    proof(sources! "
        Enc {| LC ''2'', LN ''ni'' tid0, s(MV ''nr'' tid0), s(AV ''R'' tid0) |}
            ( PK ( s(AV ''I'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (R_1_I t r s tid0)
    then interpret state: ns_public_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = R_1_I
    thus ?case
    proof(sources! "
        Enc {| LC ''1'', s(MV ''ni'' tid0), s(MV ''I'' tid0) |}
            ( PK ( s(AV ''R'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (R_1_ni t r s tid0)
    then interpret state: ns_public_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = R_1_ni
    thus ?case
    proof(sources! "
        Enc {| LC ''1'', s(MV ''ni'' tid0), s(MV ''I'' tid0) |}
            ( PK ( s(AV ''R'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  qed
  thus "ns_public_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context ns_public_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* subsection:  Secrecy Properties  *)

lemma (in restricted_ns_public_state) I_ni_secrecy:
  assumes facts:
    "roleMap r tid0 = Some I"
    "RLKR(s(AV ''I'' tid0)) ~: reveals t"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "LN ''ni'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''ni'' tid0 ")
  case I_1_ni note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
next
  case (R_2_ni tid1) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''1'', LN ''ni'' tid0, s(MV ''I'' tid1) |}
                       ( PK ( s(AV ''R'' tid1) ) ) ")
    case (I_1_enc tid2) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_ns_public_state) R_nr_secrecy:
  assumes facts:
    "roleMap r tid0 = Some R"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "RLKR(s(MV ''I'' tid0)) ~: reveals t"
    "LN ''nr'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''nr'' tid0 ")
  case (I_3_nr tid1) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''ni'' tid1, LN ''nr'' tid0, s(AV ''R'' tid1) |}
                       ( PK ( s(AV ''I'' tid1) ) ) ")
    case (R_2_enc tid2) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
next
  case R_2_nr note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_ns_public_state) I_nr_secrecy:
  assumes facts:
    "roleMap r tid0 = Some I"
    "RLKR(s(AV ''I'' tid0)) ~: reveals t"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "( tid0, I_2 ) : steps t"
    "s(MV ''nr'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''ni'' tid0, s(MV ''nr'' tid0), s(AV ''R'' tid0) |}
                       ( PK ( s(AV ''I'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: I_ni_secrecy intro: event_predOrdI)
  next
    case (R_2_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: R_nr_secrecy intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_ns_public_state) R_ni_secrecy:
  assumes facts:
    "roleMap r tid0 = Some R"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "RLKR(s(MV ''I'' tid0)) ~: reveals t"
    "( tid0, R_3 ) : steps t"
    "s(MV ''ni'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''3'', LN ''nr'' tid0 |} ( PK ( s(AV ''R'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: R_nr_secrecy intro: event_predOrdI)
  next
    case (I_3_enc tid1) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''2'', LN ''ni'' tid1, LN ''nr'' tid0, s(AV ''R'' tid0) |}
                         ( PK ( s(AV ''I'' tid1) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: R_nr_secrecy intro: event_predOrdI)
    next
      case (R_2_enc tid2) note_unified facts = this facts
      thus ?thesis by (fastforce dest: I_ni_secrecy intro: event_predOrdI)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

(* subsection:  Authentication Properties  *)

lemma (in restricted_ns_public_state) I_ni_synch:
  assumes facts:
    "roleMap r tid1 = Some I"
    "RLKR(s(AV ''I'' tid1)) ~: reveals t"
    "RLKR(s(AV ''R'' tid1)) ~: reveals t"
    "( tid1, I_3 ) : steps t"
  shows
    "(?  tid2.
        roleMap r tid2 = Some R &
        s(AV ''I'' tid1) = s(MV ''I'' tid2) &
        s(AV ''R'' tid1) = s(AV ''R'' tid2) &
        LN ''ni'' tid1 = s(MV ''ni'' tid2) &
        s(MV ''nr'' tid1) = LN ''nr'' tid2 &
        predOrd t (St( tid1, I_1 )) (St( tid2, R_1 )) &
        predOrd t (St( tid2, R_1 )) (St( tid2, R_2 )) &
        predOrd t (St( tid2, R_2 )) (St( tid1, I_2 )) &
        predOrd t (St( tid1, I_2 )) (St( tid1, I_3 )))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''ni'' tid1, s(MV ''nr'' tid1), s(AV ''R'' tid1) |}
                       ( PK ( s(AV ''I'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: I_ni_secrecy intro: event_predOrdI)
  next
    case (R_2_enc tid2) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''1'', LN ''ni'' tid1, s(AV ''I'' tid1) |}
                         ( PK ( s(AV ''R'' tid1) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: I_ni_secrecy intro: event_predOrdI)
    next
      case (I_1_enc tid3) note_unified facts = this facts
      thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_ns_public_state) R_ni_synch:
  assumes facts:
    "roleMap r tid1 = Some R"
    "RLKR(s(AV ''R'' tid1)) ~: reveals t"
    "RLKR(s(MV ''I'' tid1)) ~: reveals t"
    "( tid1, R_3 ) : steps t"
  shows
    "(?  tid2.
        roleMap r tid2 = Some I &
        s(MV ''I'' tid1) = s(AV ''I'' tid2) &
        s(AV ''R'' tid1) = s(AV ''R'' tid2) &
        s(MV ''ni'' tid1) = LN ''ni'' tid2 &
        LN ''nr'' tid1 = s(MV ''nr'' tid2) &
        predOrd t (St( tid2, I_1 )) (St( tid1, R_1 )) &
        predOrd t (St( tid1, R_1 )) (St( tid1, R_2 )) &
        predOrd t (St( tid1, R_2 )) (St( tid2, I_2 )) &
        predOrd t (St( tid2, I_2 )) (St( tid2, I_3 )) &
        predOrd t (St( tid2, I_3 )) (St( tid1, R_3 )))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''1'', s(MV ''ni'' tid1), s(MV ''I'' tid1) |}
                       ( PK ( s(AV ''R'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: R_ni_secrecy intro: event_predOrdI)
  next
    case (I_1_enc tid2) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''3'', LN ''nr'' tid1 |} ( PK ( s(AV ''R'' tid1) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: R_nr_secrecy intro: event_predOrdI)
    next
      case (I_3_enc tid3) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''2'', LN ''ni'' tid3, LN ''nr'' tid1, s(AV ''R'' tid1) |}
                           ( PK ( s(AV ''I'' tid3) ) ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (fastforce dest: R_nr_secrecy intro: event_predOrdI)
      next
        case (R_2_enc tid4) note_unified facts = this facts
        thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section {* \isaheader{Hash Set} *}
theory HashSet
  imports
  "../spec/SetSpec"
  "HashMap"
  "../gen_algo/SetByMap"
  "../gen_algo/SetGA"
begin
text_raw {*\label{thy:HashSet}*}
(*@impl Set
  @type 'a::hashable hs
  @abbrv hs,h
  Hash sets based on red-black trees.
*)

subsection "Definitions"
type_synonym
  'a hs = "('a::hashable,unit) hm"

setup Locale_Code.open_block
interpretation hs_sbm: SetByMap hm_basic_ops by unfold_locales
setup Locale_Code.close_block

definition hs_ops :: "('a::hashable,'a hs) set_ops"
  where [icf_rec_def]:
  "hs_ops \<equiv> hs_sbm.basic.dflt_ops"

setup Locale_Code.open_block
interpretation hs: StdSet hs_ops
  unfolding hs_ops_def by (rule hs_sbm.basic.dflt_ops_impl)
interpretation hs: StdSet_no_invar hs_ops
  by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "hs"*}

lemmas hs_it_to_it_map_code_unfold[code_unfold] =
  it_to_it_map_fold'[OF pi_hm]

lemma pi_hs[proper_it]: "proper_it' hs.iteratei hs.iteratei"
  unfolding hs.iteratei_def[abs_def]
  by (rule proper_it'I icf_proper_iteratorI)+

interpretation pi_hs: proper_it_loc hs.iteratei hs.iteratei
  by unfold_locales (rule pi_hs)

definition test_codegen where "test_codegen \<equiv> (
  hs.empty,
  hs.memb,
  hs.ins,
  hs.delete,
  hs.list_it,
  hs.sng,
  hs.isEmpty,
  hs.isSng,
  hs.ball,
  hs.bex,
  hs.size,
  hs.size_abort,
  hs.union,
  hs.union_dj,
  hs.diff,
  hs.filter,
  hs.inter,
  hs.subset,
  hs.equal,
  hs.disjoint,
  hs.disjoint_witness,
  hs.sel,
  hs.to_list,
  hs.from_list
)"

export_code test_codegen in SML

end


section \<open> State Variable Declaration Parser \<close>

theory utp_state_parser
  imports "utp_blocks"
begin

text \<open> This theory sets up a parser for state blocks, as an alternative way of providing lenses to
  a predicate. A program with local variables can be represented by a predicate indexed by a tuple
  of lenses, where each lens represents a variable. These lenses must then be supplied with respect
  to a suitable state space. Instead of creating a type to represent this alphabet, we can create
  a product type for the state space, with an entry for each variable. Then each variable becomes
  a composition of the @{term fst\<^sub>L} and @{term snd\<^sub>L} lenses to index the correct position in the
  variable vector.

  We first creation a vacuous definition that will mark when an indexed predicate denotes a state
  block. \<close>

definition state_block :: "('v \<Rightarrow> 'p) \<Rightarrow> 'v \<Rightarrow> 'p" where
[upred_defs]: "state_block f x = f x"

text \<open> We declare a number of syntax translations to produce lens and product types, to obtain
  a type for the overall state space, to construct a tuple that denotes the lens vector parameter,
  to construct the vector itself, and finally to construct the state declaration. \<close>

syntax
  "_lensT" :: "type \<Rightarrow> type \<Rightarrow> type" ("LENSTYPE'(_, _')")
  "_pairT" :: "type \<Rightarrow> type \<Rightarrow> type" ("PAIRTYPE'(_, _')")
  "_state_type" :: "pttrn \<Rightarrow> type"
  "_state_tuple" :: "type \<Rightarrow> pttrn \<Rightarrow> logic"
  "_state_lenses" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"
  "_state_decl" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("alpha _ \<bullet> _" [0, 10] 10)
  "_state_decl_in" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("alpha _ in _ \<bullet> _" [0, 0, 10] 10)

translations
  (type) "PAIRTYPE('a, 'b)" => (type) "'a \<times> 'b"
  (type) "LENSTYPE('a, 'b)" => (type) "'a \<Longrightarrow> _"

  "_state_type (_constrain x t)" => "t"
  "_state_type (CONST Pair (_constrain x t) vs)" => "_pairT t (_state_type vs)"

  "_state_tuple st (_constrain x t)" => "_constrain x (_lensT t st)"
  "_state_tuple st (CONST Pair (_constrain x t) vs)" =>
    "CONST Product_Type.Pair (_constrain x (_lensT t st)) (_state_tuple st vs)"

  "_state_decl_in vs loc P" =>
    "CONST state_block (_abs (_state_tuple (_state_type vs) vs) P) (_state_lenses vs loc)"

  "_state_decl vs P" =>
    "CONST state_block (_abs (_state_tuple (_state_type vs) vs) P) (_state_lenses vs 1\<^sub>L)"
  "_state_decl vs P" <= "CONST state_block (_abs vs P) k"

ML \<open>

 \<close>

parse_translation \<open>
  let
    open HOLogic; open Syntax;
    fun lensT s t = Type (@{type_name lens_ext}, [s, t, HOLogic.unitT]);
    fun lens_comp a b c = Const (@{const_syntax "lens_comp"}, lensT a b --> lensT b c --> lensT a c);
    fun fst_lens t = Const (@{const_syntax "fst_lens"}, Type (@{type_name lens_ext}, [t, dummyT, unitT]));
    val snd_lens = Const (@{const_syntax "snd_lens"}, dummyT);
    fun id_lens t = Const (@{const_syntax "id_lens"},Type (@{type_name lens_ext}, [t, dummyT, unitT]));
    fun lens_syn_typ t = const @{type_syntax lens_ext} $ t $ const @{type_syntax dummy} $ const @{type_syntax unit};
    fun constrain t ty = const @{syntax_const "_constrain"} $ t $ ty;

    (* Construct a tuple of n lenses, whose source type is product of the types in ts, and each lens
       has an element of the type: prod_lens [t0, t1 ... ] 1 : t1 ==> t0 * t1 * ... *)
    fun prod_lens ts i =
      let open Syntax; open Library; fun lens_compf (x, y) = const @{const_name lens_comp} $ x $ y in
      if (length ts = 1)
      then Const (@{const_name id_lens}, lensT (nth ts i) (nth ts i))
      else if (length ts = i + 1)
      then foldl lens_compf (Const (@{const_name "snd_lens"}, lensT (nth ts i) dummyT), replicate (i-1) (const @{const_name "snd_lens"}))
      else foldl lens_compf (Const (@{const_name "fst_lens"}, lensT (nth ts i) dummyT), replicate i (const @{const_name "snd_lens"}))
      end;

    (* Construct a tuple of lenses for each of the possible locally declared variables *)
    fun state_lenses ts sty st =
      foldr1 (fn (x, y) => pair_const dummyT dummyT $ x $ y) (map (fn i => lens_comp dummyT sty dummyT $ prod_lens ts i $ st) (upto (0, length ts - 1)));

    fun
      (* Add up the number of variable declarations in the tuple *)
      var_decl_num (Const (@{const_syntax "Product_Type.Pair"},_) $ _ $ vs) = var_decl_num vs + 1 |
      var_decl_num _ = 1;

    fun
      var_decl_typs (Const (@{const_syntax "Product_Type.Pair"},_) $ (Const ("_constrain", _) $ _ $ typ) $ vs) = Syntax_Phases.decode_typ typ :: var_decl_typs vs |
      var_decl_typs (Const ("_constrain", _) $ _ $ typ) = [Syntax_Phases.decode_typ typ] |
      var_decl_typs _ = [];

    fun state_lens ctx [vs, loc] = (state_lenses (var_decl_typs vs) (mk_tupleT (var_decl_typs vs)) loc);
  in
  [("_state_lenses", state_lens)]
  end
\<close>

subsection \<open> Variable Block Syntax \<close>

definition vblock :: "(<'a, 'b> \<Longleftrightarrow> 'c) \<Rightarrow> ('d \<Rightarrow> 'c hrel) \<Rightarrow> 'd \<Rightarrow> 'a hrel" where
[upred_defs]: "vblock sl f x = open\<^bsub>sl\<^esub> ;; f x ;; close\<^bsub>sl\<^esub>"

syntax
  "_var_block_in" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("var _ in _ \<bullet> _" [0, 0, 10] 10)

translations
  "_var_block_in vs sl P" => "CONST vblock sl (_abs (_state_tuple (_state_type vs) vs) P) (_state_lenses vs \<C>\<^bsub>sl\<^esub>)"

subsection \<open> Examples \<close>

term "alpha (x::int, y::real, z::int) \<bullet> y := &x + &z"

lemma "alpha p \<bullet> II = II"
  by (rel_auto)

end


section \<open>Refinement for Transition Systems\<close>

theory Transition_System_Refine
imports
  "Transition_System"
  "Transition_System_Extra"
  "../Basic/Refine"
begin

  lemma path_param[param]: "(transition_system.path, transition_system.path) \<in>
    (T \<rightarrow> S \<rightarrow> S) \<rightarrow> (T \<rightarrow> S \<rightarrow> bool_rel) \<rightarrow> \<langle>T\<rangle> list_rel \<rightarrow> S \<rightarrow> bool_rel"
  proof (rule, rule)
    fix exa exb ena enb
    assume [param]: "(exa, exb) \<in> T \<rightarrow> S \<rightarrow> S" "(ena, enb) \<in> T \<rightarrow> S \<rightarrow> bool_rel"
    interpret A: transition_system exa ena by this
    interpret B: transition_system exb enb by this
    have [param]: "(A.path [] p, B.path [] q) \<in> bool_rel" for p q by auto
    have [param]: "(A.path (a # r) p, B.path (b # s) q) \<in> bool_rel"
      if "(ena a p, enb b q) \<in> bool_rel" "(A.path r (exa a p), B.path s (exb b q)) \<in> bool_rel"
      for a r p b s q
      using that by auto
    show "(A.path, B.path) \<in> \<langle>T\<rangle> list_rel \<rightarrow> S \<rightarrow> bool_rel"
    proof (intro fun_relI)
      show "(A.path r p, B.path s q) \<in> bool_rel" if "(r, s) \<in> \<langle>T\<rangle> list_rel" "(p, q) \<in> S" for r s p q
        using that by (induct arbitrary: p q) (parametricity+)
    qed
  qed
  lemma run_param[param]: "(transition_system.run, transition_system.run) \<in>
    (T \<rightarrow> S \<rightarrow> S) \<rightarrow> (T \<rightarrow> S \<rightarrow> bool_rel) \<rightarrow> \<langle>T\<rangle> stream_rel \<rightarrow> S \<rightarrow> bool_rel"
  proof (rule, rule)
    fix exa exb ena enb
    assume 1: "(exa, exb) \<in> T \<rightarrow> S \<rightarrow> S" "(ena, enb) \<in> T \<rightarrow> S \<rightarrow> bool_rel"
    interpret A: transition_system exa ena by this
    interpret B: transition_system exb enb by this
    show "(A.run, B.run) \<in> \<langle>T\<rangle> stream_rel \<rightarrow> S \<rightarrow> bool_rel"
    proof safe
      show "B.run s q" if "(r, s) \<in> \<langle>T\<rangle> stream_rel" "(p, q) \<in> S" "A.run r p" for r s p q
        using 1[param_fo] that by (coinduction arbitrary: r s p q) (blast elim: stream_rel_cases)
      show "A.run r p" if "(r, s) \<in> \<langle>T\<rangle> stream_rel" "(p, q) \<in> S" "B.run s q" for r s p q
        using 1[param_fo] that by (coinduction arbitrary: r s p q) (blast elim: stream_rel_cases)
    qed
  qed

  lemma paths_param[param]:
    assumes [param]: "(exa, exb) \<in> T \<rightarrow> S \<rightarrow> S"
    assumes "(transition_system.enableds ena, transition_system.enableds enb) \<in> S \<rightarrow> \<langle>T\<rangle> set_rel"
    shows "(transition_system.paths exa ena, transition_system.paths exb enb) \<in> S \<rightarrow> \<langle>\<langle>T\<rangle> list_rel\<rangle> set_rel"
  proof -
    note assms = assms[param_fo, unfolded transition_system.enableds_def]
    interpret A: transition_system exa ena by this
    interpret B: transition_system exb enb by this
    have 1: "\<exists> s. (r, s) \<in> \<langle>T\<rangle> list_rel \<and> B.path s q" if "(p, q) \<in> S" "A.path r p" for p q r
    using that(2, 1)
    proof (induct arbitrary: q)
      case (nil p)
      show ?case by auto
    next
      case (cons a p r)
      obtain b where 1: "(a, b) \<in> T" "enb b q" using assms(2) cons(1, 4) by (blast elim: set_relE1)
      have 2: "(exa a p, exb b q) \<in> S" using cons(4) 1(1) by parametricity
      obtain s where 3: "(r, s) \<in> \<langle>T\<rangle> list_rel" "B.path s (exb b q)" using cons(3) 2 by auto
      show ?case using 1 3 by force
    qed
    have 2: "\<exists> r. (r, s) \<in> \<langle>T\<rangle> list_rel \<and> A.path r p" if "(p, q) \<in> S" "B.path s q" for p q s
    using that(2, 1)
    proof (induct arbitrary: p)
      case (nil q)
      show ?case by auto
    next
      case (cons b q s)
      obtain a where 1: "(a, b) \<in> T" "ena a p" using assms(2) cons(1, 4) by (blast elim: set_relE2)
      have 2: "(exa a p, exb b q) \<in> S" using cons(4) 1(1) by parametricity
      obtain r where 3: "(r, s) \<in> \<langle>T\<rangle> list_rel" "A.path r (exa a p)" using cons(3) 2 by auto
      show ?case using 1 3 by force
    qed
    show ?thesis unfolding transition_system.paths_def set_rel_def using 1 2 by blast
  qed
  lemma runs_param[param]:
    assumes "(exa, exb) \<in> T \<rightarrow> S \<rightarrow> S"
    assumes "(transition_system.enableds ena, transition_system.enableds enb) \<in> S \<rightarrow> \<langle>T\<rangle> set_rel"
    shows "(transition_system.runs exa ena, transition_system.runs exb enb) \<in> S \<rightarrow> \<langle>\<langle>T\<rangle> stream_rel\<rangle> set_rel"
  proof -
    note assms = assms[param_fo, unfolded transition_system.enableds_def]
    interpret A: transition_system exa ena by this
    interpret B: transition_system exb enb by this
    have 1: "\<exists> s. (r, s) \<in> \<langle>T\<rangle> stream_rel \<and> B.run s q" if "(p, q) \<in> S" "A.run r p" for p q r
    proof -
      define P where "P \<equiv> \<lambda> (p, q, r). (p, q) \<in> S \<and> A.run r p"
      define Q where "Q \<equiv> \<lambda> (p :: 'b, q, r) a. (shd r, a) \<in> T \<and> enb a q"
      have 1: "P (p, q, r)" using that unfolding P_def by auto
      have "\<exists> a. Q x a" if "P x" for x
        using assms(2) that unfolding P_def Q_def by (force elim: set_relE1 A.run.cases)
      then obtain f where 2: "\<And> x. P x \<Longrightarrow> Q x (f x)" by metis
      define g where "g \<equiv> \<lambda> (p, q, r). (exa (shd r) p, exb (f (p, q, r)) q, stl r)"
      have 3: "P (g x)" if "P x" for x
        using assms(1) 2 that unfolding P_def Q_def g_def by (auto elim: A.run.cases)
      show ?thesis
      proof (intro exI conjI)
        show "(r, smap f (siterate g (p, q, r))) \<in> \<langle>T\<rangle> stream_rel"
          using 1 2 3 unfolding Q_def g_def by (coinduction arbitrary: p q r) (fastforce)
        show "B.run (smap f (siterate g (p, q, r))) q"
          using 1 2 3 unfolding Q_def g_def by (coinduction arbitrary: p q r) (fastforce)
      qed
    qed
    have 2: "\<exists> r. (r, s) \<in> \<langle>T\<rangle> stream_rel \<and> A.run r p" if "(p, q) \<in> S" "B.run s q" for p q s
    proof -
      define P where "P \<equiv> \<lambda> (p, q, s). (p, q) \<in> S \<and> B.run s q"
      define Q where "Q \<equiv> \<lambda> (p, q :: 'd, s) b. (b, shd s) \<in> T \<and> ena b p"
      have 1: "P (p, q, s)" using that unfolding P_def by auto
      have "\<exists> a. Q x a" if "P x" for x
        using assms(2) that unfolding P_def Q_def by (force elim: set_relE2 B.run.cases)
      then obtain f where 2: "\<And> x. P x \<Longrightarrow> Q x (f x)" by metis
      define g where "g \<equiv> \<lambda> (p, q, s). (exa (f (p, q, s)) p, exb (shd s) q, stl s)"
      have 3: "P (g x)" if "P x" for x
        using assms(1) 2 that unfolding P_def Q_def g_def by (auto elim: B.run.cases)
      show ?thesis
      proof (intro exI conjI)
        show "(smap f (siterate g (p, q, s)), s) \<in> \<langle>T\<rangle> stream_rel"
          using 1 2 3 unfolding Q_def g_def by (coinduction arbitrary: p q s) (fastforce)
        show "A.run (smap f (siterate g (p, q, s))) p"
          using 1 2 3 unfolding Q_def g_def by (coinduction arbitrary: p q s) (fastforce)
      qed
    qed
    show ?thesis unfolding transition_system.runs_def set_rel_def using 1 2 by force
  qed

end