(*
  Title:      Blackboard.thy
  Author:     Diego Marmsoler
*)
section "A Theory of Blackboard Architectures"
text\<open>
  In the following, we formalize the specification of the blackboard pattern as described in~\cite{Marmsoler2018c}.
\<close>

theory Blackboard
imports Publisher_Subscriber
begin

subsection "Problems and Solutions"
text \<open>
  Blackboards work with problems and solutions for them.
\<close>
typedecl PROB
consts sb :: "(PROB \<times> PROB) set"
axiomatization where sbWF: "wf sb"
typedecl SOL
consts solve:: "PROB \<Rightarrow> SOL"

subsection "Blackboard Architectures"
text \<open>
  In the following, we describe the locale for the blackboard pattern.
\<close>
locale blackboard = publisher_subscriber bbactive bbcmp ksactive kscmp bbrp bbcs kscs ksrp
  for bbactive :: "'bid \<Rightarrow> cnf \<Rightarrow> bool" ("\<parallel>_\<parallel>\<^bsub>_\<^esub>" [0,110]60)
    and bbcmp :: "'bid \<Rightarrow> cnf \<Rightarrow> 'BB" ("\<sigma>\<^bsub>_\<^esub>(_)" [0,110]60)
    and ksactive :: "'kid \<Rightarrow> cnf \<Rightarrow> bool" ("\<parallel>_\<parallel>\<^bsub>_\<^esub>" [0,110]60)
    and kscmp :: "'kid \<Rightarrow> cnf \<Rightarrow> 'KS" ("\<sigma>\<^bsub>_\<^esub>(_)" [0,110]60)
    and bbrp :: "'BB \<Rightarrow> (PROB set) subscription set"
    and bbcs :: "'BB \<Rightarrow> (PROB \<times> SOL)"
    and kscs :: "'KS \<Rightarrow> (PROB \<times> SOL) set"
    and ksrp :: "'KS \<Rightarrow> (PROB set) subscription" +
  fixes bbns :: "'BB \<Rightarrow> (PROB \<times> SOL) set"
    and ksns :: "'KS \<Rightarrow> (PROB \<times> SOL)"
    and bbop :: "'BB \<Rightarrow> PROB"
    and ksop :: "'KS \<Rightarrow> PROB set"
    and prob :: "'kid \<Rightarrow> PROB"
  assumes
    ks1: "\<forall>p. \<exists>ks. p=prob ks" \<comment> \<open>Component Parameter\<close>
    \<comment> \<open>Assertions about component behavior.\<close>
    and bhvbb1: "\<And>t t' bId p s. \<lbrakk>t \<in> arch\<rbrakk> \<Longrightarrow> pb.eval bId t t' 0
      (\<box>\<^sub>b ([\<lambda>bb. (p,s)\<in>bbns bb]\<^sub>b
      \<longrightarrow>\<^sup>b (\<diamond>\<^sub>b [\<lambda>bb. (p,s) = bbcs bb]\<^sub>b)))"
    and bhvbb2: "\<And>t t' bId P q. \<lbrakk>t\<in>arch\<rbrakk> \<Longrightarrow> pb.eval bId t t' 0
      (\<box>\<^sub>b ([\<lambda>bb. sub P \<in> bbrp bb \<and> q \<in> P]\<^sub>b \<longrightarrow>\<^sup>b
      (\<diamond>\<^sub>b [\<lambda>bb. q = bbop bb]\<^sub>b)))"
    and bhvbb3: "\<And>t t' bId p . \<lbrakk>t\<in>arch\<rbrakk> \<Longrightarrow> pb.eval bId t t' 0
      (\<box>\<^sub>b ([\<lambda>bb. p = bbop(bb)]\<^sub>b \<longrightarrow>\<^sup>b
      ([\<lambda>bb. p=bbop(bb)]\<^sub>b \<WW>\<^sub>b [\<lambda>bb. (p,solve(p)) = bbcs(bb)]\<^sub>b)))"
    and bhvks1: "\<And>t t' kId p P. \<lbrakk>t\<in>arch; p = prob kId\<rbrakk> \<Longrightarrow> sb.eval kId t t' 0
      (\<box>\<^sub>b ([\<lambda>ks. sub P = ksrp ks]\<^sub>b \<and>\<^sup>b
      (\<forall>\<^sub>b q. ((sb.pred (q\<in>P)) \<longrightarrow>\<^sup>b (\<diamond>\<^sub>b ([\<lambda>ks. (q,solve(q)) \<in> kscs ks]\<^sub>b))))
      \<longrightarrow>\<^sup>b (\<diamond>\<^sub>b [\<lambda>ks. (p, solve p) = ksns ks]\<^sub>b)))"
    and bhvks2: "\<And>t t' kId p P q. \<lbrakk>t \<in> arch;p = prob kId\<rbrakk> \<Longrightarrow> sb.eval kId t t' 0
      (\<box>\<^sub>b [\<lambda>ks. sub P = ksrp ks \<and> q \<in> P \<longrightarrow> (q,p) \<in> sb]\<^sub>b)"
    and bhvks3: "\<And>t t' kId p. \<lbrakk>t\<in>arch;p = prob kId\<rbrakk> \<Longrightarrow> sb.eval kId t t' 0
      (\<box>\<^sub>b ([\<lambda>ks. p\<in>ksop ks]\<^sub>b \<longrightarrow>\<^sup>b (\<diamond>\<^sub>b [\<lambda>ks. (\<exists>P. sub P = ksrp ks)]\<^sub>b)))"
    and bhvks4: "\<And>t t' kId p P. \<lbrakk>t\<in>arch; p\<in>P\<rbrakk> \<Longrightarrow> sb.eval kId t t' 0
      (\<box>\<^sub>b ([\<lambda>ks. sub P = ksrp ks]\<^sub>b \<longrightarrow>\<^sup>b
      ((\<not>\<^sup>b (\<exists>\<^sub>b P'. (sb.pred (p\<in>P') \<and>\<^sup>b [\<lambda>ks. unsub P' = ksrp ks]\<^sub>b))) \<WW>\<^sub>b
      [\<lambda>ks. (p,solve p) \<in> kscs ks]\<^sub>b)))"

    \<comment> \<open>Assertions about component activation.\<close>
    and actks:
      "\<And>t n kid p. \<lbrakk>t \<in> arch; \<parallel>kid\<parallel>\<^bsub>t n\<^esub>; p=prob kid; p\<in>ksop (\<sigma>\<^bsub>kid\<^esub>(t n))\<rbrakk>
      \<Longrightarrow> (\<exists>n'\<ge>n. \<parallel>kid\<parallel>\<^bsub>t n'\<^esub> \<and> (p, solve p) = ksns (\<sigma>\<^bsub>kid\<^esub>(t n')) \<and>
      (\<forall>n''\<ge>n. n''<n' \<longrightarrow> \<parallel>kid\<parallel>\<^bsub>t n''\<^esub>))
      \<or> (\<forall>n'\<ge>n. (\<parallel>kid\<parallel>\<^bsub>t n'\<^esub> \<and> (\<not>(p, solve p) = ksns (\<sigma>\<^bsub>kid\<^esub>(t n')))))"

    \<comment> \<open>Assertions about connections.\<close>
    and conn1: "\<And>k bid. \<parallel>bid\<parallel>\<^bsub>k\<^esub>
      \<Longrightarrow> bbns (\<sigma>\<^bsub>bid\<^esub>(k)) = (\<Union>kid\<in>{kid. \<parallel>kid\<parallel>\<^bsub>k\<^esub>}. {ksns (\<sigma>\<^bsub>kid\<^esub>(k))})"
    and conn2: "\<And>k kid. \<parallel>kid\<parallel>\<^bsub>k\<^esub>
      \<Longrightarrow> ksop (\<sigma>\<^bsub>kid\<^esub>(k)) = (\<Union>bid\<in>{bid. \<parallel>bid\<parallel>\<^bsub>k\<^esub>}. {bbop (\<sigma>\<^bsub>bid\<^esub>(k))})"
begin
  notation sb.lNAct ("\<langle>_ \<Leftarrow> _\<rangle>\<^bsub>_\<^esub>")
  notation sb.nxtAct ("\<langle>_ \<rightarrow> _\<rangle>\<^bsub>_\<^esub>")
  notation pb.lNAct ("\<langle>_ \<Leftarrow> _\<rangle>\<^bsub>_\<^esub>")
  notation pb.nxtAct ("\<langle>_ \<rightarrow> _\<rangle>\<^bsub>_\<^esub>")

  subsubsection "Calculus Interpretation"
  text \<open>
  \noindent
  @{thm[source] pb.baIA}: @{thm pb.baIA [no_vars]}
\<close>
  text \<open>
  \noindent
  @{thm[source] sb.baIA}: @{thm sb.baIA [no_vars]}
\<close>

  subsubsection "Results from Singleton"
  abbreviation "the_bb \<equiv> the_pb"
  text \<open>
  \noindent
  @{thm[source] pb.ts_prop(1)}: @{thm pb.ts_prop(1) [no_vars]}
\<close>
  text \<open>
  \noindent
  @{thm[source] pb.ts_prop(2)}: @{thm pb.ts_prop(2) [no_vars]}
\<close>
  subsubsection "Results from Publisher Subscriber"
  text \<open>
	\noindent
	@{thm[source] msgDelivery}: @{thm msgDelivery [no_vars]}
\<close>
  lemma conn2_bb:
    fixes k and kid::'kid
    assumes "\<parallel>kid\<parallel>\<^bsub>k\<^esub>"
    shows "bbop (\<sigma>\<^bsub>the_bb\<^esub>(k))\<in>ksop (\<sigma>\<^bsub>kid\<^esub>(k))"
  proof -
    from assms have "ksop (\<sigma>\<^bsub>kid\<^esub>(k)) = (\<Union>bid\<in>{bid. \<parallel>bid\<parallel>\<^bsub>k\<^esub>}. {bbop (\<sigma>\<^bsub>bid\<^esub>(k))})" using conn2 by simp
    moreover have "(\<Union>bid.{bid. \<parallel>bid\<parallel>\<^bsub>k\<^esub>})={the_bb}" using pb.ts_prop(1) by auto
    hence "(\<Union>bid\<in>{bid. \<parallel>bid\<parallel>\<^bsub>k\<^esub>}. {bbop (\<sigma>\<^bsub>bid\<^esub>(k))}) = {bbop (\<sigma>\<^bsub>the_bb\<^esub>(k))}" by auto
    ultimately show ?thesis by simp
  qed

  subsubsection "Knowledge Sources"
  text \<open>
    In the following we introduce an abbreviation for knowledge sources which are able to solve a specific problem.
\<close>
  definition sKs:: "PROB \<Rightarrow> 'kid" where
    "sKs p \<equiv> (SOME kid. p = prob kid)"

  lemma sks_prob:
    "p = prob (sKs p)"
  using sKs_def someI_ex[of "\<lambda>kid. p = prob kid"] ks1 by auto

  subsubsection "Architectural Guarantees"
  text\<open>
    The following theorem verifies that a problem is eventually solved by the pattern even if no knowledge source exist which can solve the problem on its own.
    It assumes, however, that for every open sub problem, a corresponding knowledge source able to solve the problem will be eventually activated.
\<close>
  lemma pSolved_Ind:
    fixes t and t'::"nat \<Rightarrow>'BB" and p and t''::"nat \<Rightarrow>'KS"
    assumes "t\<in>arch" and
      "\<forall>n. (\<exists>n'\<ge>n. \<parallel>sKs (bbop(\<sigma>\<^bsub>the_bb\<^esub>(t n)))\<parallel>\<^bsub>t n'\<^esub>)"
    shows
      "\<forall>n. (\<exists>P. sub P \<in> bbrp(\<sigma>\<^bsub>the_bb\<^esub>(t n)) \<and> p \<in> P) \<longrightarrow>
        (\<exists>m\<ge>n. (p,solve(p)) = bbcs (\<sigma>\<^bsub>the_bb\<^esub>(t m)))" (*\eqref{eq:bb:g}*)
  \<comment> \<open>The proof is by well-founded induction over the subproblem relation @{term sb}\<close>
  proof (rule wf_induct[where r=sb])
    \<comment> \<open>We first show that the subproblem relation is indeed well-founded ...\<close>
    show "wf sb" by (simp add: sbWF)
  next
    \<comment> \<open>... then we show that a problem @{term p} is indeed solved\<close>
    \<comment> \<open>if all its sub-problems @{term p'} are eventually solved\<close>
    fix p assume indH: "\<forall>p'. (p', p) \<in> sb \<longrightarrow> (\<forall>n. (\<exists>P. sub P \<in> bbrp (\<sigma>\<^bsub>the_bb\<^esub>(t n)) \<and> p'\<in>P)
      \<longrightarrow> (\<exists>m\<ge>n. (p',solve(p')) = bbcs (\<sigma>\<^bsub>the_bb\<^esub>(t m))))"
    show "\<forall>n. (\<exists>P. sub P \<in> bbrp (\<sigma>\<^bsub>the_bb\<^esub>(t n)) \<and> p \<in> P)
      \<longrightarrow> (\<exists>m\<ge>n. (p,solve(p)) = bbcs (\<sigma>\<^bsub>the_bb\<^esub>(t m)))"
    proof
      fix n\<^sub>0 show "(\<exists>P. sub P \<in> bbrp (\<sigma>\<^bsub>the_bb\<^esub>(t n\<^sub>0)) \<and> p \<in> P) \<longrightarrow>
      (\<exists>m\<ge>n\<^sub>0. (p,solve(p)) = bbcs (\<sigma>\<^bsub>the_bb\<^esub>(t m)))"
      proof
        assume "\<exists>P. sub P \<in> bbrp (\<sigma>\<^bsub>the_bb\<^esub>(t n\<^sub>0)) \<and> p \<in> P"
        moreover have "(\<exists>P. sub P \<in> bbrp (\<sigma>\<^bsub>the_bb\<^esub>(t n\<^sub>0)) \<and> p \<in> P) \<longrightarrow> (\<exists>n'\<ge>n\<^sub>0. p=bbop(\<sigma>\<^bsub>the_bb\<^esub>(t n')))"
        proof
          assume "\<exists>P. sub P \<in> bbrp (\<sigma>\<^bsub>the_bb\<^esub>(t n\<^sub>0)) \<and> p \<in> P"
          then obtain P where "sub P \<in> bbrp (\<sigma>\<^bsub>the_bb\<^esub>(t n\<^sub>0))" and "p \<in> P" by auto
          hence "pb.eval the_bb t t' n\<^sub>0 [\<lambda>bb. sub P \<in> bbrp bb \<and> p \<in> P]\<^sub>b" using pb.baI by simp
          moreover from pb.globE[OF bhvbb2] have
            "pb.eval the_bb t t' n\<^sub>0 ([\<lambda>bb. sub P \<in> bbrp bb \<and> p \<in> P]\<^sub>b \<longrightarrow>\<^sup>b \<diamond>\<^sub>b [\<lambda>bb. p = bbop bb]\<^sub>b)"
            using \<open>t\<in>arch\<close> by simp
          ultimately have "pb.eval the_bb t t' n\<^sub>0 (\<diamond>\<^sub>b [\<lambda>bb. p = bbop bb]\<^sub>b)" using pb.impE by blast
          then obtain n' where "n'\<ge>n\<^sub>0" and "pb.eval the_bb t t' n' [\<lambda>bb. p = bbop bb]\<^sub>b"
            using pb.evtE by blast
          hence "p=bbop(\<sigma>\<^bsub>the_bb\<^esub>(t n'))" using pb.baE by auto
          with \<open>n'\<ge>n\<^sub>0\<close> show "\<exists>n'\<ge>n\<^sub>0. p=bbop(\<sigma>\<^bsub>the_bb\<^esub>(t n'))" by auto
        qed
        ultimately obtain n where "n\<ge>n\<^sub>0" and "p=bbop(\<sigma>\<^bsub>the_bb\<^esub>(t n))" by auto

        \<comment> \<open>Problem p is provided at the output of the blackboard until it is solved\<close>
        \<comment> \<open>or forever...\<close>
        from pb.globE[OF bhvbb3] have
          "pb.eval the_bb t t' n ([\<lambda> bb. p = bbop(bb)]\<^sub>b \<longrightarrow>\<^sup>b
          ([\<lambda> bb. p=bbop(bb)]\<^sub>b \<WW>\<^sub>b [\<lambda>bb. (p,solve(p)) = bbcs(bb)]\<^sub>b))"
          using \<open>t\<in>arch\<close> by auto
        moreover from \<open>p = bbop (\<sigma>\<^bsub>the_bb\<^esub>(t n))\<close> have
          "pb.eval the_bb t t' n [\<lambda> bb. p=bbop bb]\<^sub>b"
          using \<open>t\<in>arch\<close> pb.baI by simp
        ultimately have "pb.eval the_bb t t' n
          ([\<lambda> bb. p=bbop(bb)]\<^sub>b \<WW>\<^sub>b [\<lambda> bb. (p,solve(p)) = bbcs(bb)]\<^sub>b)"
          using pb.impE by blast
        hence "pb.eval the_bb t t' n (([\<lambda> bb. p=bbop bb]\<^sub>b \<UU>\<^sub>b
          [\<lambda> bb. (p,solve(p)) = bbcs bb]\<^sub>b) \<or>\<^sup>b (\<box>\<^sub>b [\<lambda> bb. p=bbop bb]\<^sub>b))"
          using pb.wuntil_def by simp
        hence "pb.eval the_bb t t' n
          ([\<lambda>bb. p=bbop bb]\<^sub>b \<UU>\<^sub>b [\<lambda>bb. (p,solve(p)) = bbcs bb]\<^sub>b) \<or>
          (pb.eval the_bb t t' n (\<box>\<^sub>b [\<lambda> bb. p=bbop bb]\<^sub>b))"
          using pb.disjE by simp
        thus "\<exists>m\<ge>n\<^sub>0. (p,solve p) = bbcs(\<sigma>\<^bsub>the_bb\<^esub>(t m))"
        \<comment> \<open>We need to consider both cases, the case in which the problem is eventually\<close>
        \<comment> \<open>solved and the case in which the problem is always provided as an output\<close>
        proof
          \<comment> \<open>First we consider the case in which the problem is eventually solved:\<close>
          assume "pb.eval the_bb t t' n
            ([\<lambda>bb. p=bbop bb]\<^sub>b \<UU>\<^sub>b [\<lambda>bb. (p,solve(p)) = bbcs bb]\<^sub>b)"
          hence "\<exists>i\<ge>n. (pb.eval the_bb t t' i
            [\<lambda>bb. (p,solve(p)) = bbcs bb]\<^sub>b \<and>
            (\<forall>k\<ge>n. k<i \<longrightarrow> pb.eval the_bb t t' k [\<lambda>bb. p = bbop bb]\<^sub>b))"
            using \<open>t\<in>arch\<close> pb.untilE by simp
          then obtain i where "i\<ge>n" and
            "pb.eval the_bb t t' i [\<lambda>bb. (p,solve(p)) = bbcs bb]\<^sub>b" by auto
          hence "(p,solve(p)) = bbcs(\<sigma>\<^bsub>the_bb\<^esub>(t i))"
            using \<open>t\<in>arch\<close> pb.baEA by auto
          moreover from \<open>i\<ge>n\<close> \<open>n\<ge>n\<^sub>0\<close> have "i\<ge>n\<^sub>0" by simp
          ultimately show ?thesis by auto
        next
          \<comment> \<open>Now we consider the case in which p is always provided at the output\<close>
          \<comment> \<open>of the blackboard:\<close>
          assume "pb.eval the_bb t t' n
            (\<box>\<^sub>b [\<lambda>bb. p=bbop bb]\<^sub>b)"
          hence "\<forall>n'\<ge>n. (pb.eval the_bb t t' n' [\<lambda>bb. p = bbop bb]\<^sub>b)"
            using \<open>t\<in>arch\<close> pb.globE by auto
          hence outp: "\<forall>n'\<ge>n. (p = bbop (\<sigma>\<^bsub>the_bb\<^esub>(t n')))"
            using \<open>t\<in>arch\<close> pb.baE by blast

          \<comment> \<open>thus, by assumption there exists a KS which is able to solve p and which\<close>
          \<comment> \<open>is active at @{text n'}...\<close>
          with assms(2) have "\<exists>n'\<ge>n. \<parallel>sKs p\<parallel>\<^bsub>t n'\<^esub>" by auto
          then obtain n\<^sub>k where "n\<^sub>k\<ge>n" and "\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>k\<^esub>" by auto
          \<comment> \<open>... and get the problem as its input.\<close>
          moreover from \<open>n\<^sub>k\<ge>n\<close> have "p = bbop (\<sigma>\<^bsub>the_bb\<^esub>(t n\<^sub>k))"
            using outp by simp
          ultimately have "p\<in>ksop(\<sigma>\<^bsub>sKs p\<^esub>(t n\<^sub>k))" using conn2_bb[of "sKs p" "t n\<^sub>k"] by simp

          \<comment> \<open>thus the ks will either solve the problem or not solve it and\<close>
          \<comment> \<open>be activated forever\<close>
          hence "(\<exists>n'\<ge>n\<^sub>k. \<parallel>sKs p\<parallel>\<^bsub>t n'\<^esub> \<and>
            (p, solve p) = ksns (\<sigma>\<^bsub>sKs p\<^esub>(t n')) \<and>
            (\<forall>n''\<ge>n\<^sub>k. n''<n' \<longrightarrow> \<parallel>sKs p\<parallel>\<^bsub>t n''\<^esub>)) \<or>
            (\<forall>n'\<ge>n\<^sub>k. (\<parallel>sKs p\<parallel>\<^bsub>t n'\<^esub> \<and>
            (\<not>(p, solve p) = ksns (\<sigma>\<^bsub>sKs p\<^esub>(t n')))))"
            using \<open>\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>k\<^esub>\<close> actks[of t "sKs p"] \<open>t\<in>arch\<close> sks_prob by simp
          thus ?thesis
          proof
            \<comment> \<open>if the ks solves it\<close>
            assume "\<exists>n'\<ge>n\<^sub>k. \<parallel>sKs p\<parallel>\<^bsub>t n'\<^esub> \<and> (p, solve p) = ksns (\<sigma>\<^bsub>sKs p\<^esub>t n')
              \<and> (\<forall>n''\<ge>n\<^sub>k. n'' < n' \<longrightarrow> \<parallel>sKs p\<parallel>\<^bsub>t n''\<^esub>)"
            \<comment> \<open>it is forwarded to the blackboard\<close>
            then obtain n\<^sub>s where "n\<^sub>s\<ge>n\<^sub>k" and "\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>s\<^esub>"
              and "(p, solve p) = ksns (\<sigma>\<^bsub>sKs p\<^esub>t n\<^sub>s)" by auto
            moreover have "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub> = n\<^sub>s"
              by (simp add: \<open>\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>s\<^esub>\<close> sb.nxtAct_active)
            ultimately have
              "(p,solve(p)) \<in> bbns (\<sigma>\<^bsub>the_bb\<^esub>(t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>)))"
              using conn1[OF pb.ts_prop(2)] \<open>\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>s\<^esub>\<close> by auto

            \<comment> \<open>finally, the blackboard will forward the solution which finishes the proof.\<close>
            with bhvbb1 have "pb.eval the_bb t t' (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>)
              (\<diamond>\<^sub>b [\<lambda>bb. (p, solve p) = bbcs bb]\<^sub>b)"
              using \<open>t\<in>arch\<close> pb.globE pb.impE[of the_bb t t'] by blast
            then obtain n\<^sub>f where "n\<^sub>f\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>" and
              "pb.eval the_bb t t' n\<^sub>f [\<lambda>bb. (p, solve p) = bbcs bb]\<^sub>b"
              using \<open>t\<in>arch\<close> pb.evtE[of t t' "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>"] by auto
            hence "(p, solve p) = bbcs (\<sigma>\<^bsub>the_bb\<^esub>(t n\<^sub>f))"
              using \<open>t \<in> arch\<close> pb.baEA by auto
            moreover have "n\<^sub>f\<ge>n\<^sub>0"
            proof -
              from \<open>\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>k\<^esub>\<close> have "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>k\<^esub>\<ge>n\<^sub>k"
                using sb.nxtActI by blast
              with \<open>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub> = n\<^sub>s\<close> show ?thesis
                using \<open>n\<^sub>f\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>\<close> \<open>n\<^sub>s\<ge>n\<^sub>k\<close> \<open>n\<^sub>k\<ge>n\<close> \<open>n\<ge>n\<^sub>0\<close> by arith
            qed
            ultimately show ?thesis by auto
          next
            \<comment> \<open>otherwise, we derive a contradiction\<close>
            assume case_ass: "\<forall>n'\<ge>n\<^sub>k. \<parallel>sKs p\<parallel>\<^bsub>t n'\<^esub> \<and> \<not>(p, solve p) = ksns (\<sigma>\<^bsub>sKs p\<^esub>t n')"

            \<comment> \<open>first, the KS will eventually register for the subproblems P it requires to solve p...\<close>
            from \<open>\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>k\<^esub>\<close> have "\<exists>i\<ge>0. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>" by auto
            moreover have "\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>0\<^esub> \<le> n\<^sub>k" by simp
            ultimately have "sb.eval (sKs p) t t'' n\<^sub>k
              ([\<lambda>ks. p\<in>ksop ks]\<^sub>b \<longrightarrow>\<^sup>b (\<diamond>\<^sub>b [\<lambda>ks. \<exists>P. sub P = ksrp ks]\<^sub>b))"
              using sb.globEA[OF _ bhvks3[of t p "sKs p" t'']] \<open>t\<in>arch\<close> sks_prob by simp
            moreover have "sb.eval (sKs p) t t'' n\<^sub>k [\<lambda>ks. p \<in> ksop ks]\<^sub>b"
            proof -
              from \<open>\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>k\<^esub>\<close> have "\<exists>n'\<ge>n\<^sub>k. \<parallel>sKs p\<parallel>\<^bsub>t n'\<^esub>" by auto
              moreover have "p \<in> ksop (\<sigma>\<^bsub>sKs p\<^esub>(t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>k\<^esub>)))"
              proof -
                from \<open>\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>k\<^esub>\<close> have "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>k\<^esub>=n\<^sub>k"
                  using sb.nxtAct_active by blast
                with \<open>p\<in>ksop(\<sigma>\<^bsub>sKs p\<^esub>(t n\<^sub>k))\<close> show ?thesis by simp
              qed
              ultimately show ?thesis using sb.baIA[of n\<^sub>k "sKs p" t] by blast
            qed
            ultimately have "sb.eval (sKs p) t t'' n\<^sub>k (\<diamond>\<^sub>b [\<lambda>ks. \<exists>P. sub P = ksrp ks]\<^sub>b)"
              using sb.impE by blast
            then obtain n\<^sub>r where "n\<^sub>r\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>k\<^esub>" and
              "\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub> \<and>
              (\<forall>n''\<ge>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>. n'' \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>
              \<longrightarrow> sb.eval (sKs p) t t'' n'' [\<lambda>ks. \<exists>P. sub P = ksrp ks]\<^sub>b) \<or>
              \<not> (\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>) \<and>
              sb.eval (sKs p) t t'' n\<^sub>r [\<lambda>ks. \<exists>P. sub P = ksrp ks]\<^sub>b"
              using \<open>\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>k\<^esub>\<close> sb.evtEA[of n\<^sub>k "sKs p" t] by blast
            moreover from case_ass have "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>k\<^esub>\<ge>n\<^sub>k" using sb.nxtActI by blast
            with \<open>n\<^sub>r\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>k\<^esub>\<close> have "n\<^sub>r\<ge>n\<^sub>k" by arith
            hence "\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>" using case_ass by auto
            hence "n\<^sub>r \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>" using sb.nxtActLe by simp
            moreover have "n\<^sub>r \<ge> \<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>" by simp
            ultimately have
              "sb.eval (sKs p) t t'' n\<^sub>r [\<lambda>ks. \<exists>P. sub P = ksrp ks]\<^sub>b" by blast
            with \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> obtain P where
              "sub P = ksrp (\<sigma>\<^bsub>sKs p\<^esub>(t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)))"
              using sb.baEA by blast
            hence "sb.eval (sKs p) t t'' n\<^sub>r [\<lambda>ks. sub P = ksrp ks]\<^sub>b"
              using \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> sb.baIA sks_prob by blast

            \<comment> \<open>the knowledgesource will eventually get a solution for each required subproblem:\<close>
            moreover have "sb.eval (sKs p) t t'' n\<^sub>r (\<forall>\<^sub>b p'. (sb.pred (p'\<in>P) \<longrightarrow>\<^sup>b
              (\<diamond>\<^sub>b [\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b)))"
            proof -
              have "\<forall>p'. sb.eval (sKs p) t t'' n\<^sub>r (sb.pred (p'\<in>P) \<longrightarrow>\<^sup>b
                (\<diamond>\<^sub>b [\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b))"
              proof
                \<comment> \<open>by induction hypothesis, the blackboard will eventually provide solutions for subproblems\<close>
                fix p'
                have "sb.eval (sKs p) t t'' n\<^sub>r (sb.pred (p'\<in>P)) \<longrightarrow>
                  (sb.eval (sKs p) t t'' n\<^sub>r
                  (\<diamond>\<^sub>b [\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b))"
                proof
                  assume "sb.eval (sKs p) t t'' n\<^sub>r (sb.pred (p'\<in>P))"
                  hence "p' \<in> P" using sb.predE by blast
                  thus "(sb.eval (sKs p) t t'' n\<^sub>r (\<diamond>\<^sub>b [\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b))"
                  proof -
                    have "\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>0\<^esub> \<le> n\<^sub>r" by simp
                    moreover from \<open>\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>k\<^esub>\<close> have "\<exists>i\<ge>0. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>" by auto
                    ultimately have "sb.eval (sKs p) t t'' n\<^sub>r ([\<lambda>ks. sub P = ksrp ks]\<^sub>b
                      \<longrightarrow>\<^sup>b ((\<not>\<^sup>b (\<exists>\<^sub>b P'. (sb.pred (p'\<in>P') \<and>\<^sup>b [\<lambda>ks. unsub P' = ksrp ks]\<^sub>b))) \<WW>\<^sub>b
                      [\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b))"
                      using sb.globEA[OF _ bhvks4[of t p' P "sKs p" t'']]
                      \<open>t\<in>arch\<close> \<open>\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>k\<^esub>\<close> \<open>p'\<in>P\<close> by simp
                    with \<open>sb.eval (sKs p) t t'' n\<^sub>r [\<lambda>ks. sub P = ksrp ks]\<^sub>b\<close> have
                      "sb.eval (sKs p) t t'' n\<^sub>r ((\<not>\<^sup>b (\<exists>\<^sub>b P'. (sb.pred (p'\<in>P') \<and>\<^sup>b
                      [\<lambda>ks. unsub P' = ksrp ks]\<^sub>b))) \<WW>\<^sub>b [\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b)"
                      using sb.impE[of "(sKs p)" t t'' n\<^sub>r "[\<lambda>ks. sub P = ksrp ks]\<^sub>b"] by blast
                    hence "sb.eval (sKs p) t t'' n\<^sub>r ((\<not>\<^sup>b (\<exists>\<^sub>b P'. (sb.pred (p'\<in>P') \<and>\<^sup>b
                      [\<lambda>ks. unsub P' = ksrp ks]\<^sub>b))) \<UU>\<^sub>b [\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b) \<or>
                      sb.eval (sKs p) t t'' n\<^sub>r (\<box>\<^sub>b (\<not>\<^sup>b (\<exists>\<^sub>b P'. (sb.pred (p'\<in>P') \<and>\<^sup>b
                      [\<lambda>ks. unsub P' = ksrp ks]\<^sub>b))))" using sb.wuntil_def by auto
                    thus "(sb.eval (sKs p) t t'' n\<^sub>r (\<diamond>\<^sub>b [\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b))"
                    proof
                      let ?\<gamma>'="\<not>\<^sup>b (\<exists>\<^sub>b P'. (sb.pred (p'\<in>P') \<and>\<^sup>b ([\<lambda>ks. unsub P' = ksrp ks]\<^sub>b)))"
                      let ?\<gamma>="[\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b"
                      assume "sb.eval (sKs p) t t'' n\<^sub>r (?\<gamma>' \<UU>\<^sub>b ?\<gamma>)"
                      with \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> obtain n' where "n'\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>" and
                        lass: "(\<exists>i\<ge>n'. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>) \<and> (\<forall>n''\<ge>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n'\<^esub>. n'' \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n'\<^esub>
                        \<longrightarrow> sb.eval (sKs p) t t'' n'' ?\<gamma>) \<and>
                        (\<forall>n''\<ge>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>. n'' < \<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n'\<^esub>
                        \<longrightarrow> sb.eval (sKs p) t t'' n'' ?\<gamma>') \<or>
                        \<not> (\<exists>i\<ge>n'. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>) \<and> sb.eval (sKs p) t t'' n' ?\<gamma> \<and>
                        (\<forall>n''\<ge>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>. n'' < n' \<longrightarrow> sb.eval (sKs p) t t'' n'' ?\<gamma>')"
                        using sb.untilEA[of n\<^sub>r "sKs p" t t''] \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> by blast
                      thus "?thesis"
                      proof cases
                        assume "\<exists>i\<ge>n'. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>"
                        with lass have "\<forall>n''\<ge>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n'\<^esub>. n'' \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n'\<^esub>
                          \<longrightarrow> sb.eval (sKs p) t t'' n'' ?\<gamma>" by auto
                        moreover have "n'\<ge>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n'\<^esub>" by simp
                        moreover have "n' \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n'\<^esub>"
                          using \<open>\<exists>i\<ge>n'. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> sb.nxtActLe by simp
                        ultimately have "sb.eval (sKs p) t t'' n' ?\<gamma>" by simp
                        moreover have "\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n'" using \<open>n\<^sub>r \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>\<close>
                        \<open>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n\<^sub>r\<close> \<open>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n'\<close> by linarith
                        ultimately show ?thesis using \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> \<open>\<exists>i\<ge>n'. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close>
                          \<open>n'\<ge>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n'\<^esub>\<close> \<open>n' \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n'\<^esub>\<close>
                          sb.evtIA[of n\<^sub>r "sKs p" t n' t'' ?\<gamma>] by blast
                      next
                        assume "\<not> (\<exists>i\<ge>n'. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>)"
                        with lass have "sb.eval (sKs p) t t'' n' ?\<gamma> \<and>
                          (\<forall>n''\<ge>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>. n'' < n' \<longrightarrow> sb.eval (sKs p) t t'' n'' ?\<gamma>')" by auto
                        moreover have "\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n'"
                          using \<open>n\<^sub>r \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>\<close> \<open>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n\<^sub>r\<close>
                          \<open>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n'\<close> by linarith
                        ultimately show ?thesis using \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> \<open>\<not> (\<exists>i\<ge>n'. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>)\<close>
                            sb.evtIA[of n\<^sub>r "sKs p" t n' t'' ?\<gamma>] by blast
                      qed
                    next
                      assume cass: "sb.eval (sKs p) t t'' n\<^sub>r
                        (\<box>\<^sub>b (\<not>\<^sup>b (\<exists>\<^sub>b P'. (sb.pred (p'\<in>P') \<and>\<^sup>b [\<lambda>ks. unsub P' = ksrp ks]\<^sub>b))))"

                      have "sub P = ksrp (\<sigma>\<^bsub>sKs p\<^esub>(t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>))) \<and>
                        p' \<in> P \<longrightarrow> (p', p) \<in> sb"
                      proof -
                        have "\<exists>i\<ge>0. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>" using \<open>\<exists>i\<ge>0. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> by auto
                        moreover have "\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>0\<^esub> \<le> (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)" by simp
                        ultimately have "sb.eval (sKs p) t t'' (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)
                          [\<lambda>ks. sub P = ksrp ks \<and> p' \<in> P \<longrightarrow> (p', p) \<in> sb]\<^sub>b"
                          using sb.globEA[OF _ bhvks2[of t p "sKs p" t'' P]] \<open>t \<in> arch\<close> sks_prob by blast
                        moreover from \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> have
                          "\<parallel>sKs p\<parallel>\<^bsub>t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)\<^esub>" using sb.nxtActI by blast
                        ultimately show ?thesis
                          using sb.baEANow[of "sKs p" t t'' "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>"] by simp
                      qed
                      with \<open>p' \<in> P\<close> have "(p', p) \<in> sb"
                        using \<open>sub P = ksrp (\<sigma>\<^bsub>sKs p\<^esub>(t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)))\<close>
                        sks_prob by simp
                      moreover from \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> have "\<parallel>sKs p\<parallel>\<^bsub>t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)\<^esub>"
                        using sb.nxtActI by blast
                        with \<open>sub P = ksrp (\<sigma>\<^bsub>sKs p\<^esub>(t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)))\<close>
                          have "sub P \<in> bbrp (\<sigma>\<^bsub>the_bb\<^esub>(t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)))"
                          using conn1A by auto
                      with \<open> p' \<in> P\<close> have "sub P \<in> bbrp (\<sigma>\<^bsub>the_bb\<^esub>t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)) \<and> p' \<in> P" by auto
                      ultimately obtain m where "m\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>" and "(p', solve p') = bbcs (\<sigma>\<^bsub>the_bb\<^esub>(t m))"
                        using indH by auto

                      \<comment> \<open>and due to the publisher subscriber property,\<close>
                      \<comment> \<open>the knowledge source will receive them\<close>
                      moreover have
                        "\<nexists>n P. \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n \<and> n \<le> m \<and> \<parallel>sKs p\<parallel>\<^bsub>t n\<^esub> \<and>
                        unsub P = ksrp (\<sigma>\<^bsub>sKs p\<^esub>(t n)) \<and> p' \<in> P"
                      proof
                        assume "\<exists>n P'. \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n \<and> n \<le> m \<and> \<parallel>sKs p\<parallel>\<^bsub>t n\<^esub> \<and>
                          unsub P' = ksrp (\<sigma>\<^bsub>sKs p\<^esub>(t n)) \<and> p' \<in> P'"
                        then obtain n P' where
                          "\<parallel>sKs p\<parallel>\<^bsub>t n\<^esub>" and "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n" and "n \<le> m" and
                          "unsub P' = ksrp (\<sigma>\<^bsub>sKs p\<^esub>(t n))" and "p' \<in> P'" by auto
                        hence "sb.eval (sKs p) t t'' n (\<exists>\<^sub>b P'. sb.pred (p'\<in>P') \<and>\<^sup>b
                          [\<lambda>ks. unsub P' = ksrp ks]\<^sub>b)" by blast
                        moreover have "\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n"
                          using \<open>n\<^sub>r \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>\<close> \<open>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n\<^sub>r\<close>
                          \<open>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> n\<close> by linarith
                        with cass have "sb.eval (sKs p) t t'' n (\<not>\<^sup>b (\<exists>\<^sub>b P'. (sb.pred (p'\<in>P')
                          \<and>\<^sup>b [\<lambda>ks. unsub P' = ksrp ks]\<^sub>b)))"
                          using sb.globEA[of n\<^sub>r "sKs p" t t''
                          "\<not>\<^sup>b (\<exists>\<^sub>bP'. sb.pred (p' \<in> P') \<and>\<^sup>b [\<lambda>ks. unsub P' = ksrp ks]\<^sub>b)" n]
                          \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> by auto
                        ultimately show False using sb.negE by auto
                      qed
                      moreover from \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> have
                        "\<parallel>sKs p\<parallel>\<^bsub>t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)\<^esub>" using sb.nxtActI by blast
                      moreover have "sub P = ksrp (\<sigma>\<^bsub>sKs p\<^esub>(t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)))"
                        using \<open>sub P = ksrp (\<sigma>\<^bsub>sKs p\<^esub>(t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>)))\<close> .
                      moreover from \<open>m\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>\<close> have "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> m" by simp
                      moreover from \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close>
                        have "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>\<ge>n\<^sub>r" using sb.nxtActI by blast
                      hence "m\<ge>n\<^sub>k" using \<open>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> m\<close> \<open>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>k\<^esub> \<le> n\<^sub>r\<close>
                        \<open>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>k\<^esub> \<ge> n\<^sub>k\<close> by simp
                      with case_ass have "\<parallel>sKs p\<parallel>\<^bsub>t m\<^esub>" by simp
                      ultimately have "(p', solve p') \<in> kscs (\<sigma>\<^bsub>sKs p\<^esub>(t m))"
                        and "\<parallel>sKs p\<parallel>\<^bsub>t m\<^esub>"
                        using \<open>t \<in> arch\<close> msgDelivery[of t "sKs p" "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>" P m p' "solve p'"]
                        \<open>p' \<in> P\<close> by auto
                      hence "sb.eval (sKs p) t t'' m [\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b"
                        using sb.baIANow by simp
                      moreover have "m \<ge> \<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>m\<^esub>" by simp
                      moreover from \<open>\<parallel>sKs p\<parallel>\<^bsub>t m\<^esub>\<close> have "m \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>m\<^esub>"
                        using sb.nxtActLe by auto
                      moreover from \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> have
                        "\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>" by simp
                      with \<open>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> m\<close> have "\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<le> m" by arith
                      ultimately show "sb.eval (sKs p) t t'' n\<^sub>r
                        (\<diamond>\<^sub>b [\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b)"
                        using \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> sb.evtIA by blast
                    qed
                  qed
                qed
                thus "sb.eval (sKs p) t t'' n\<^sub>r (sb.pred (p'\<in>P) \<longrightarrow>\<^sup>b
                  (\<diamond>\<^sub>b [\<lambda>ks. (p',solve p') \<in> kscs ks]\<^sub>b))"
                  using sb.impI by auto
              qed
              thus ?thesis using sb.allI by blast
            qed

            \<comment> \<open>Thus, the knowlege source will eventually solve the problem at hand...\<close>
            ultimately have "sb.eval (sKs p) t t'' n\<^sub>r
              ([\<lambda>ks. sub P = ksrp ks]\<^sub>b \<and>\<^sup>b
              (\<forall>\<^sub>b q. (sb.pred (q \<in> P) \<longrightarrow>\<^sup>b \<diamond>\<^sub>b [\<lambda>ks. (q, solve q) \<in> kscs ks]\<^sub>b)))"
              using sb.conjI by simp
            moreover from \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> have "\<exists>i\<ge>0. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>" by blast
            hence "sb.eval (sKs p) t t'' n\<^sub>r
              (([\<lambda>ks. sub P = ksrp ks]\<^sub>b \<and>\<^sup>b
              (\<forall>\<^sub>b q. (sb.pred (q \<in> P) \<longrightarrow>\<^sup>b
              \<diamond>\<^sub>b [\<lambda>ks. (q, solve q) \<in> kscs ks]\<^sub>b))) \<longrightarrow>\<^sup>b
              (\<diamond>\<^sub>b [\<lambda>ks. (p, solve p) = ksns ks]\<^sub>b))" using \<open>t \<in> arch\<close>
              sb.globEA[OF _ bhvks1[of t p "sKs p" t'' P]] sks_prob by simp
            ultimately have "sb.eval (sKs p) t t'' n\<^sub>r
              (\<diamond>\<^sub>b [\<lambda>ks. (p,solve(p))=ksns(ks)]\<^sub>b)"
              using sb.impE[of "sKs p" t t'' n\<^sub>r] by blast

            \<comment> \<open>and forward it to the blackboard\<close>
            then obtain n\<^sub>s where "n\<^sub>s\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>" and
              "(\<exists>i\<ge>n\<^sub>s. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub> \<and>
              (\<forall>n''\<ge>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>. n'' \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub> \<longrightarrow>
              sb.eval (sKs p) t t'' n'' [\<lambda>ks. (p,solve(p))=ksns(ks)]\<^sub>b)) \<or>
              \<not> (\<exists>i\<ge>n\<^sub>s. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>) \<and>
              sb.eval (sKs p) t t'' n\<^sub>s [\<lambda>ks. (p,solve(p))=ksns(ks)]\<^sub>b"
              using sb.evtEA[of n\<^sub>r "sKs p" t] \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> by blast
            moreover from \<open>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub> \<ge> n\<^sub>r\<close> \<open>n\<^sub>r\<ge>n\<^sub>k\<close> \<open>n\<^sub>s\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>\<close>
              have "n\<^sub>s\<ge>n\<^sub>k" by arith
            with case_ass have "\<exists>i\<ge>n\<^sub>s. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>" by auto
            moreover have "n\<^sub>s\<ge>\<langle>sKs p \<Leftarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>" by simp
            moreover from \<open>\<exists>i\<ge>n\<^sub>s. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> have "n\<^sub>s \<le> \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>"
              using sb.nxtActLe by simp
            ultimately have "sb.eval (sKs p) t t'' n\<^sub>s [\<lambda>ks. (p,solve(p))=ksns(ks)]\<^sub>b"
              using sb.evtEA[of n\<^sub>r "sKs p" t] \<open>\<exists>i\<ge>n\<^sub>r. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> by blast
            with \<open>\<exists>i\<ge>n\<^sub>s. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close> have
              "(p,solve(p)) = ksns (\<sigma>\<^bsub>sKs p\<^esub>(t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>)))"
              using sb.baEA[of n\<^sub>s "sKs p" t t'' "\<lambda>ks. (p, solve p) = ksns ks"] by auto
            moreover from \<open>\<exists>i\<ge>n\<^sub>s. \<parallel>sKs p\<parallel>\<^bsub>t i\<^esub>\<close>
              have "\<parallel>sKs p\<parallel>\<^bsub>t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>)\<^esub>" using sb.nxtActI by simp
            ultimately have "(p,solve(p)) \<in> bbns (\<sigma>\<^bsub>the_bb\<^esub>(t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>)))"
              using conn1[OF pb.ts_prop(2)[of "t (\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>)"]] by auto
            hence "pb.eval the_bb t t' \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub> [\<lambda>bb. (p,solve(p)) \<in> bbns bb]\<^sub>b"
              using \<open>t\<in>arch\<close> pb.baI by simp

            \<comment> \<open>finally, the blackboard will forward the solution which finishes the proof.\<close>
            with bhvbb1 have "pb.eval the_bb t t' \<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>
              (\<diamond>\<^sub>b [\<lambda>bb. (p, solve p) = bbcs bb]\<^sub>b)"
              using \<open>t\<in>arch\<close> pb.globE pb.impE[of the_bb t t'] by blast
            then obtain n\<^sub>f where "n\<^sub>f\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>" and
              "pb.eval the_bb t t' n\<^sub>f [\<lambda>bb. (p, solve p) = bbcs bb]\<^sub>b"
              using \<open>t\<in>arch\<close> pb.evtE[of t t' "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>"] by auto
            hence "(p, solve p) = bbcs (\<sigma>\<^bsub>the_bb\<^esub>(t n\<^sub>f))"
              using \<open>t \<in> arch\<close> pb.baEA by auto
            moreover have "n\<^sub>f\<ge>n\<^sub>0"
            proof -
              from \<open>\<exists>n'''\<ge>n\<^sub>s. \<parallel>sKs p\<parallel>\<^bsub>t n'''\<^esub>\<close> have "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>\<ge>n\<^sub>s"
                using sb.nxtActLe by simp
              moreover from \<open>n\<^sub>k\<ge>n\<close> and \<open>\<parallel>sKs p\<parallel>\<^bsub>t n\<^sub>k\<^esub>\<close> have "\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>k\<^esub>\<ge>n\<^sub>k"
                using sb.nxtActI by blast
              ultimately show ?thesis
                using \<open>n\<^sub>f\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>s\<^esub>\<close> \<open>n\<^sub>s\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>\<close>
                \<open>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>r\<^esub>\<ge>n\<^sub>r\<close> \<open>n\<^sub>r\<ge>\<langle>sKs p \<rightarrow> t\<rangle>\<^bsub>n\<^sub>k\<^esub>\<close> \<open>n\<^sub>k\<ge>n\<close> \<open>n\<ge>n\<^sub>0\<close> by arith
            qed
            ultimately show ?thesis by auto
          qed
        qed
      qed
    qed
  qed

  theorem pSolved:
    fixes t and t'::"nat \<Rightarrow>'BB" and t''::"nat \<Rightarrow>'KS"
    assumes "t\<in>arch" and
      "\<forall>n. (\<exists>n'\<ge>n. \<parallel>sKs (bbop(\<sigma>\<^bsub>the_bb\<^esub>(t n)))\<parallel>\<^bsub>t n'\<^esub>)"
    shows
      "\<forall>n. (\<forall>P. (sub P \<in> bbrp(\<sigma>\<^bsub>the_bb\<^esub>(t n))
        \<longrightarrow> (\<forall>p \<in> P. (\<exists>m\<ge>n. (p,solve(p)) = bbcs (\<sigma>\<^bsub>the_bb\<^esub>(t m))))))"
    using assms pSolved_Ind by blast
end

end


theory Lambda
imports "../Nominal2"
begin

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam"
| Lam x::"name" l::"lam"  bind x in l ("Lam [_]. _" [100, 100] 100)

lemma fresh_fun_eqvt_app3:
  assumes a: "eqvt f"
  and b: "a \<sharp> x" "a \<sharp> y" "a \<sharp> z"
  shows "a \<sharp> f x y z"
  using fresh_fun_eqvt_app[OF a b(1)] a b
  by (metis fresh_fun_app)

lemma fresh_fun_eqvt_app4:
  assumes a: "eqvt f"
  and b: "a \<sharp> x" "a \<sharp> y" "a \<sharp> z" "a \<sharp> w"
  shows "a \<sharp> f x y z w"
  using fresh_fun_eqvt_app[OF a b(1)] a b
  by (metis fresh_fun_app)

lemma the_default_pty:
  assumes f_def: "f == (\<lambda>x::'a. THE_default d (G x))"
  and unique: "\<exists>!y. G x y"
  and pty: "\<And>x y. G x y \<Longrightarrow> P x y"
  shows "P x (f x)"
  apply(subst f_def)
  apply (rule ex1E[OF unique])
  apply (subst THE_default1_equality[OF unique])
  apply assumption
  apply (rule pty)
  apply assumption
  done

lemma Abs_lst1_fcb2:
  fixes a b :: "'a :: at"
    and S T :: "'b :: fs"
    and c::"'c::fs"
  assumes e: "(Abs_lst [atom a] T) = (Abs_lst [atom b] S)"
  and fcb: "\<And>a T. atom a \<sharp> f a T c"
  and fresh: "{atom a, atom b} \<sharp>* c"
  and perm1: "\<And>p. supp p \<sharp>* c \<Longrightarrow> p \<bullet> (f a T c) = f (p \<bullet> a) (p \<bullet> T) c"
  and perm2: "\<And>p. supp p \<sharp>* c \<Longrightarrow> p \<bullet> (f b S c) = f (p \<bullet> b) (p \<bullet> S) c"
  shows "f a T c = f b S c"
proof -
  have fin1: "finite (supp (f a T c))"
    apply(rule_tac S="supp (a, T, c)" in supports_finite)
    apply(simp add: supports_def)
    apply(simp add: fresh_def[symmetric])
    apply(clarify)
    apply(subst perm1)
    apply(simp add: supp_swap fresh_star_def)
    apply(simp add: swap_fresh_fresh fresh_Pair)
    apply(simp add: finite_supp)
    done
  have fin2: "finite (supp (f b S c))"
    apply(rule_tac S="supp (b, S, c)" in supports_finite)
    apply(simp add: supports_def)
    apply(simp add: fresh_def[symmetric])
    apply(clarify)
    apply(subst perm2)
    apply(simp add: supp_swap fresh_star_def)
    apply(simp add: swap_fresh_fresh fresh_Pair)
    apply(simp add: finite_supp)
    done
  obtain d::"'a::at" where fr: "atom d \<sharp> (a, b, S, T, c, f a T c, f b S c)"
    using obtain_fresh'[where x="(a, b, S, T, c, f a T c, f b S c)"]
    apply(auto simp add: finite_supp supp_Pair fin1 fin2)
    done
  have "(a \<leftrightarrow> d) \<bullet> (Abs_lst [atom a] T) = (b \<leftrightarrow> d) \<bullet> (Abs_lst [atom b] S)"
    apply(simp (no_asm_use) only: flip_def)
    apply(subst swap_fresh_fresh)
    apply(simp add: Abs_fresh_iff)
    using fr
    apply(simp add: Abs_fresh_iff)
    apply(subst swap_fresh_fresh)
    apply(simp add: Abs_fresh_iff)
    using fr
    apply(simp add: Abs_fresh_iff)
    apply(rule e)
    done
  then have "Abs_lst [atom d] ((a \<leftrightarrow> d) \<bullet> T) = Abs_lst [atom d] ((b \<leftrightarrow> d) \<bullet> S)"
    apply (simp add: swap_atom flip_def)
    done
  then have eq: "(a \<leftrightarrow> d) \<bullet> T = (b \<leftrightarrow> d) \<bullet> S"
    by (simp add: Abs1_eq_iff)
  have "f a T c = (a \<leftrightarrow> d) \<bullet> f a T c"
    unfolding flip_def
    apply(rule sym)
    apply(rule swap_fresh_fresh)
    using fcb[where a="a"]
    apply(simp)
    using fr
    apply(simp add: fresh_Pair)
    done
  also have "... = f d ((a \<leftrightarrow> d) \<bullet> T) c"
    unfolding flip_def
    apply(subst perm1)
    using fresh fr
    apply(simp add: supp_swap fresh_star_def fresh_Pair)
    apply(simp)
    done
  also have "... = f d ((b \<leftrightarrow> d) \<bullet> S) c" using eq by simp
  also have "... = (b \<leftrightarrow> d) \<bullet> f b S c"
    unfolding flip_def
    apply(subst perm2)
    using fresh fr
    apply(simp add: supp_swap fresh_star_def fresh_Pair)
    apply(simp)
    done
  also have "... = f b S c"
    apply(rule flip_fresh_fresh)
    using fcb[where a="b"]
    apply(simp)
    using fr
    apply(simp add: fresh_Pair)
    done
  finally show ?thesis by simp
qed

locale test =
  fixes f1::"name \<Rightarrow> name list \<Rightarrow> ('a::pt)"
    and f2::"lam \<Rightarrow> lam \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> name list \<Rightarrow> ('a::pt)"
    and f3::"name \<Rightarrow> lam \<Rightarrow> 'a \<Rightarrow> name list \<Rightarrow> ('a::pt)"
  assumes fs: "finite (supp (f1, f2, f3))"
    and eq: "eqvt f1" "eqvt f2" "eqvt f3"
    and fcb1: "\<And>l n. atom ` set l \<sharp>* f1 n l"
    and fcb2: "\<And>l t1 t2 r1 r2. atom ` set l \<sharp>* (r1, r2) \<Longrightarrow> atom ` set l \<sharp>* f2 t1 t2 r1 r2 l"
    and fcb3: "\<And>t l r. atom ` set (x # l) \<sharp>* r \<Longrightarrow> atom ` set (x # l) \<sharp>* f3 x t r l"
begin

nominal_function (invariant "\<lambda>(x, l) y. atom ` set l \<sharp>* y")
  f
where
  "f (Var x) l = f1 x l"
| "f (App t1 t2) l = f2 t1 t2 (f t1 l) (f t2 l) l"
| "atom x \<sharp> l \<Longrightarrow> (f (Lam [x].t) l) = f3 x t (f t (x # l)) l"
  apply (simp add: eqvt_def f_graph_def)
  apply (rule, perm_simp)
  apply (simp only: eq[unfolded eqvt_def])
  apply (erule f_graph.induct)
  apply (simp add: fcb1)
  apply (simp add: fcb2 fresh_star_Pair)
  apply simp
  apply (subgoal_tac "atom ` set (xa # l) \<sharp>* f3 xa t (f_sum (t, xa # l)) l")
  apply (simp add: fresh_star_def)
  apply (rule fcb3)
  apply (simp add: fresh_star_def fresh_def)
  apply simp_all
  apply(case_tac x)
  apply(rule_tac y="a" and c="b" in lam.strong_exhaust)
  apply(auto simp add: fresh_star_def)
  apply(erule_tac Abs_lst1_fcb2)
--"?"
  apply (subgoal_tac "atom ` set (a # la) \<sharp>* f3 a T (f_sumC (T, a # la)) la")
  apply (simp add: fresh_star_def)
  apply (rule fcb3)
  apply (simp add: fresh_star_def)
  apply (rule fresh_fun_eqvt_app4[OF eq(3)])
  apply (simp add: fresh_at_base)
  apply assumption
  apply (erule fresh_eqvt_at)
  apply (simp add: finite_supp)
  apply (simp add: fresh_Pair fresh_Cons fresh_at_base)
  apply assumption
  apply (subgoal_tac "\<And>p y r l. p \<bullet> (f3 x y r l) = f3 (p \<bullet> x) (p \<bullet> y) (p \<bullet> r) (p \<bullet> l)")
  apply (subgoal_tac "(atom x \<rightleftharpoons> atom xa) \<bullet> la = la")
  apply (simp add: eqvt_at_def)
  apply (simp add: swap_fresh_fresh)
  apply (simp add: permute_fun_app_eq eq[unfolded eqvt_def])
  apply simp
  done

termination
  by (relation "measure (\<lambda>(x,_). size x)") (auto simp add: lam.size)

end

section {* Locally Nameless Terms *}

nominal_datatype ln =
  LNBnd nat
| LNVar name
| LNApp ln ln
| LNLam ln

fun
  lookup :: "name list \<Rightarrow> nat \<Rightarrow> name \<Rightarrow> ln"
where
  "lookup [] n x = LNVar x"
| "lookup (y # ys) n x = (if x = y then LNBnd n else (lookup ys (n + 1) x))"

lemma lookup_eqvt[eqvt]:
  shows "(p \<bullet> lookup xs n x) = lookup (p \<bullet> xs) (p \<bullet> n) (p \<bullet> x)"
  by (induct xs arbitrary: n) (simp_all add: permute_pure)

lemma fresh_at_list: "atom x \<sharp> xs \<longleftrightarrow> x \<notin> set xs"
  unfolding fresh_def supp_set[symmetric]
  apply (induct xs)
  apply (simp add: supp_set_empty)
  apply simp
  apply auto
  apply (simp_all add: insert_absorb UnI2 finite_set supp_of_finite_insert supp_at_base)
  done

interpretation trans: test
  "%x l. lookup l 0 x"
  "%t1 t2 r1 r2 l. LNApp r1 r2"
  "%n t r l. LNLam r"
  apply default
  apply (auto simp add: pure_fresh supp_Pair)
  apply (simp_all add: fresh_def supp_def permute_fun_def permute_pure lookup_eqvt)[3]
  apply (simp_all add: eqvt_def permute_fun_def permute_pure lookup_eqvt)
  apply (simp add: fresh_star_def)
  apply (rule_tac x="0 :: nat" in spec)
  apply (induct_tac l)
  apply (simp add: ln.fresh pure_fresh)
  apply (auto simp add: ln.fresh pure_fresh)[1]
  apply (case_tac "a \<in> set list")
  apply simp
  apply (rule_tac f="lookup" in fresh_fun_eqvt_app3)
  unfolding eqvt_def
  apply rule
  using eqvts_raw(35)
  apply auto[1]
  apply (simp add: fresh_at_list)
  apply (simp add: pure_fresh)
  apply (simp add: fresh_at_base)
  apply (simp add: fresh_star_Pair fresh_star_def ln.fresh)
  apply (simp add: fresh_star_def ln.fresh)
  done

thm trans.f.simps

lemma lam_strong_exhaust2:
  "\<lbrakk>\<And>name. y = Var name \<Longrightarrow> P;
    \<And>lam1 lam2. y = App lam1 lam2 \<Longrightarrow> P;
    \<And>name lam. \<lbrakk>{atom name} \<sharp>* c; y = Lam [name]. lam\<rbrakk> \<Longrightarrow> P;
    finite (supp c)\<rbrakk>
    \<Longrightarrow> P"
sorry

nominal_function
  g
where
  "(~finite (supp (g1, g2, g3))) \<Longrightarrow> g g1 g2 g3 t = t"
| "finite (supp (g1, g2, g3)) \<Longrightarrow> g g1 g2 g3 (Var x) = g1 x"
| "finite (supp (g1, g2, g3)) \<Longrightarrow> g g1 g2 g3 (App t1 t2) = g2 t1 t2 (g g1 g2 g3 t1) (g g1 g2 g3 t2)"
| "finite (supp (g1, g2, g3)) \<Longrightarrow> atom x \<sharp> (g1,g2,g3) \<Longrightarrow> (g g1 g2 g3 (Lam [x].t)) = g3 x t (g g1 g2 g3 t)"
  apply (simp add: eqvt_def g_graph_def)
  apply (rule, perm_simp, rule)
  apply simp_all
  apply (case_tac x)
  apply (case_tac "finite (supp (a, b, c))")
  prefer 2
  apply simp
  apply(rule_tac y="d" and c="(a,b,c)" in lam_strong_exhaust2)
  apply auto
  apply blast
  apply (simp add: Abs1_eq_iff fresh_star_def)
  sorry

termination
  by (relation "measure (\<lambda>(_,_,_,t). size t)") (simp_all add: lam.size)

end


theory Extract_Certificate
  imports
    Worklist_Algorithms.Unified_PW_Impl
    Worklist_Algorithms.Next_Key
    DBM.DBM_Operations_Impl_Refine
    Worklist_Algorithms.Leadsto_Impl
begin

subsection \<open>Turning a map into a list\<close>

definition list_of_map where
  "list_of_map m \<equiv> do
      {
        (xs, m) \<leftarrow> WHILEIT
          (\<lambda> (xs, m'). finite (dom m') \<and> m = m' ++ map_of xs \<and> dom m' \<inter> dom (map_of xs) = {})
             (\<lambda> (_, m). Map.empty \<noteq> m)
            (\<lambda> (xs, m). do
              {
                k \<leftarrow> next_key m;
                let (x, m) = op_map_extract k m;
                ASSERT (x \<noteq> None);
                RETURN ((k, the x) # xs, m)
              }
            )
            ([], m);
        RETURN xs
      }
  "

context
begin

private definition
  "ran_of_map_var = (inv_image (measure (card o dom)) (\<lambda> (a, b). b))"

private lemma wf_ran_of_map_var:
  "wf ran_of_map_var"
  unfolding ran_of_map_var_def by auto

(* XXX Maybe move *)
private lemma insert_restrict_ran:
  "insert v (ran (m |` (- {k}))) = ran m " if "m k = Some v"
  using that unfolding ran_def restrict_map_def by force

private lemma 1:
  "(m |` (- {x}))(x \<mapsto> y) = m" if "m x = Some y"
  using that unfolding restrict_map_def by auto

private lemma 2:
  "(m1 ++ m2)(x \<mapsto> y) = m1(x \<mapsto> y) ++ m2" if "x \<notin> dom m2"
  using that by auto

lemma list_of_map_correct[refine]:
  "list_of_map m \<le> SPEC (\<lambda> r. map_of r = m)" if "finite (dom m)"
  using that unfolding list_of_map_def next_key_def
  apply (refine_vcg wf_ran_of_map_var)
         apply (clarsimp; fail)+
  subgoal for s xs m' x v xs' xs1 xs'1
    unfolding dom_def apply (clarsimp simp: map_upd_eq_restrict)
    apply (subst 2)
     apply auto
    apply (subst 1)
     apply auto
    done
  unfolding ran_of_map_var_def by (fastforce intro: card_Diff1_less split: if_split_asm)+

end \<comment> \<open>End of private context for auxiliary facts and definitions\<close>

context
  fixes K :: "_ \<Rightarrow> _ :: {hashable, heap} \<Rightarrow> assn"
  assumes is_pure_K[safe_constraint_rules]: "is_pure K"
  and left_unique_K[safe_constraint_rules]: "IS_LEFT_UNIQUE (the_pure K)"
  and right_unique_K[safe_constraint_rules]: "IS_RIGHT_UNIQUE (the_pure K)"
  notes [sepref_fr_rules] = hm_it_next_key_next_key''[OF is_pure_K]
begin

sepref_definition list_of_map_impl is
  "list_of_map" :: "(hm.hms_assn' K A)\<^sup>d \<rightarrow>\<^sub>a (list_assn (K \<times>\<^sub>a A))"
  unfolding list_of_map_def hm.hms_assn'_id_hms_assn[symmetric]
  unfolding op_map_is_empty_def[symmetric]
  unfolding hm.hms_fold_custom_empty HOL_list.fold_custom_empty
  by sepref

end (* Anonymous context for setup *)

lemmas list_of_map_impl_code[code] =
  list_of_map_impl_def[of "pure Id", simplified, OF Sepref_Constraints.safe_constraint_rules(41)]

context
  notes [sepref_fr_rules] = hm_it_next_key_next_key'[folded hm.hms_assn'_id_hms_assn]
begin

sepref_definition list_of_map_impl' is
  "list_of_map" :: "(hm.hms_assn A)\<^sup>d \<rightarrow>\<^sub>a (list_assn (id_assn \<times>\<^sub>a A))"
  unfolding list_of_map_def hm.hms_assn'_id_hms_assn[symmetric]
  unfolding op_map_is_empty_def[symmetric]
  unfolding hm.hms_fold_custom_empty HOL_list.fold_custom_empty
  by sepref

end (* Anonymous context for setup *)

context Worklist_Map2_Impl
begin

definition extract_certificate :: "_ nres" where
  "extract_certificate = do {
   (_, passed) \<leftarrow> pw_algo_map2;
   list_of_map passed
  }"

context
begin

private definition
  "pw_algo_map2_copy = pw_algo_map2"

sepref_register pw_algo_map2_copy

lemma pw_algo_map2_copy_fold:
  "PR_CONST pw_algo_map2_copy = pw_algo_map2"
  unfolding pw_algo_map2_copy_def by simp

lemmas [sepref_fr_rules] =
  pw_algo_map2_impl.refine_raw[folded pw_algo_map2_copy_fold]
  list_of_map_impl.refine[OF pure_K left_unique_K right_unique_K]

sepref_thm extract_certificate_impl is
  "uncurry0 extract_certificate" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a (list_assn (K \<times>\<^sub>a lso_assn A))"
  unfolding extract_certificate_def pw_algo_map2_copy_def[symmetric] by sepref

end

end

concrete_definition extract_certificate_impl
  uses Worklist_Map2_Impl.extract_certificate_impl.refine_raw

print_theorems

end


(* Author: Joshua Schneider, ETH Zurich *)

section \<open>Lifting with applicative functors\<close>

theory Applicative
imports Main
keywords "applicative" :: thy_goal and "print_applicative" :: diag
begin

subsection \<open>Equality restricted to a set\<close>

definition eq_on :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where [simp]: "eq_on A = (\<lambda>x y. x \<in> A \<and> x = y)"

lemma rel_fun_eq_onI: "(\<And>x. x \<in> A \<Longrightarrow> R (f x) (g x)) \<Longrightarrow> rel_fun (eq_on A) R f g"
by auto

subsection \<open>Proof automation\<close>

lemma arg1_cong: "x = y \<Longrightarrow> f x z = f y z"
by (rule arg_cong)

lemma UNIV_E: "x \<in> UNIV \<Longrightarrow> P \<Longrightarrow> P" .

context begin

private named_theorems combinator_unfold
private named_theorems combinator_repr

private definition "B g f x \<equiv> g (f x)"
private definition "C f x y \<equiv> f y x"
private definition "I x \<equiv> x"
private definition "K x y \<equiv> x"
private definition "S f g x \<equiv> (f x) (g x)"
private definition "T x f \<equiv> f x"
private definition "W f x \<equiv> f x x"

lemmas [abs_def, combinator_unfold] = B_def C_def I_def K_def S_def T_def W_def
lemmas [combinator_repr] = combinator_unfold

private definition "cpair \<equiv> Pair"
private definition "cuncurry \<equiv> case_prod"

private lemma uncurry_pair: "cuncurry f (cpair x y) = f x y"
unfolding cpair_def cuncurry_def by simp

ML_file "applicative.ML"

local_setup \<open>Applicative.setup_combinators
 [("B", @{thm B_def}),
  ("C", @{thm C_def}),
  ("I", @{thm I_def}),
  ("K", @{thm K_def}),
  ("S", @{thm S_def}),
  ("T", @{thm T_def}),
  ("W", @{thm W_def})]\<close>

private attribute_setup combinator_eq =
  \<open>Scan.lift (Scan.option (Args.$$$ "weak" |--
    Scan.optional (Args.colon |-- Scan.repeat1 Args.name) []) >>
    Applicative.combinator_rule_attrib)\<close>

lemma [combinator_eq]: "B \<equiv> S (K S) K" unfolding combinator_unfold .
lemma [combinator_eq]: "C \<equiv> S (S (K (S (K S) K)) S) (K K)" unfolding combinator_unfold .
lemma [combinator_eq]: "I \<equiv> W K" unfolding combinator_unfold .
lemma [combinator_eq]: "I \<equiv> C K ()" unfolding combinator_unfold .
lemma [combinator_eq]: "S \<equiv> B (B W) (B B C)" unfolding combinator_unfold .
lemma [combinator_eq]: "T \<equiv> C I" unfolding combinator_unfold .
lemma [combinator_eq]: "W \<equiv> S S (S K)" unfolding combinator_unfold .

lemma [combinator_eq weak: C]:
  "C \<equiv> C (B B (B B (B W (C (B C (B (B B) (C B (cuncurry (K I))))) (cuncurry K))))) cpair"
unfolding combinator_unfold uncurry_pair .

end (* context *)

method_setup applicative_unfold =
  \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
    SIMPLE_METHOD' (Applicative.unfold_wrapper_tac ctxt opt_af))\<close>
  "unfold into an applicative expression"

method_setup applicative_fold =
  \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
    SIMPLE_METHOD' (Applicative.fold_wrapper_tac ctxt opt_af))\<close>
  "fold an applicative expression"

method_setup applicative_nf =
  \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
    SIMPLE_METHOD' (Applicative.normalize_wrapper_tac ctxt opt_af))\<close>
  "prove an equation that has been lifted to an applicative functor, using normal forms"

method_setup applicative_lifting =
  \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
    SIMPLE_METHOD' (Applicative.lifting_wrapper_tac ctxt opt_af))\<close>
  "prove an equation that has been lifted to an applicative functor"

ML \<open>Outer_Syntax.local_theory_to_proof @{command_keyword "applicative"}
  "register applicative functors"
  (Parse.binding --
    Scan.optional (@{keyword "("} |-- Parse.list Parse.short_ident --| @{keyword ")"}) [] --
    (@{keyword "for"} |-- Parse.reserved "pure" |-- @{keyword ":"} |-- Parse.term) --
    (Parse.reserved "ap" |-- @{keyword ":"} |-- Parse.term) --
    Scan.option (Parse.reserved "rel" |-- @{keyword ":"} |-- Parse.term) --
    Scan.option (Parse.reserved "set" |-- @{keyword ":"} |-- Parse.term) >>
    Applicative.applicative_cmd)\<close>

ML \<open>Outer_Syntax.command @{command_keyword "print_applicative"}
  "print registered applicative functors"
  (Scan.succeed (Toplevel.keep (Applicative.print_afuns o Toplevel.context_of)))\<close>

attribute_setup applicative_unfold =
  \<open>Scan.lift (Scan.option Parse.name >> Applicative.add_unfold_attrib)\<close>
  "register rules for unfolding into applicative expressions"

attribute_setup applicative_lifted =
  \<open>Scan.lift (Parse.name >> Applicative.forward_lift_attrib)\<close>
  "lift an equation to an applicative functor"

subsection \<open>Overloaded applicative operators\<close>

consts
  pure :: "'a \<Rightarrow> 'b"
  ap :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"

bundle applicative_syntax
begin
  notation ap (infixl "\<diamondop>" 70)
end

hide_const (open) ap

end


(*  Title:      Jinja/Compiler/WellType1.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

header {* \isaheader{Well-Formedness of Intermediate Language} *}

theory J1WellForm
imports "../J/JWellForm" J1
begin

subsection "Well-Typedness"

type_synonym
  env\<^sub>1  = "ty list"   --"type environment indexed by variable number"

inductive
  WT\<^sub>1 :: "[J\<^sub>1_prog,env\<^sub>1, expr\<^sub>1     , ty     ] \<Rightarrow> bool"
         ("(_,_ \<turnstile>\<^sub>1/ _ :: _)"   [51,51,51]50)
  and WTs\<^sub>1 :: "[J\<^sub>1_prog,env\<^sub>1, expr\<^sub>1 list, ty list] \<Rightarrow> bool"
         ("(_,_ \<turnstile>\<^sub>1/ _ [::] _)" [51,51,51]50)
  for P :: J\<^sub>1_prog
where

  WTNew\<^sub>1:
  "is_class P C  \<Longrightarrow>
  P,E \<turnstile>\<^sub>1 new C :: Class C"

| WTCast\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Class D;  is_class P C;  P \<turnstile> C \<preceq>\<^sup>* D \<or> P \<turnstile> D \<preceq>\<^sup>* C \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 Cast C e :: Class C"

| WTVal\<^sub>1:
  "typeof v = Some T \<Longrightarrow>
  P,E \<turnstile>\<^sub>1 Val v :: T"

| WTVar\<^sub>1:
  "\<lbrakk> E!i = T; i < size E \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 Var i :: T"

| WTBinOp\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1 :: T\<^sub>1;  P,E \<turnstile>\<^sub>1 e\<^sub>2 :: T\<^sub>2;
     case bop of Eq \<Rightarrow> (P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1) \<and> T = Boolean
               | Add \<Rightarrow> T\<^sub>1 = Integer \<and> T\<^sub>2 = Integer \<and> T = Integer \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 :: T"

| WTLAss\<^sub>1:
  "\<lbrakk> E!i = T;  i < size E; P,E \<turnstile>\<^sub>1 e :: T';  P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 i:=e :: Void"

| WTFAcc\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Class C;  P \<turnstile> C sees F:T in D \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<bullet>F{D} :: T"

| WTFAss\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1 :: Class C;  P \<turnstile> C sees F:T in D;  P,E \<turnstile>\<^sub>1 e\<^sub>2 :: T';  P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<^sub>1\<bullet>F{D} := e\<^sub>2 :: Void"

| WTCall\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Class C; P \<turnstile> C sees M:Ts' \<rightarrow> T = m in D;
    P,E \<turnstile>\<^sub>1 es [::] Ts;  P \<turnstile> Ts [\<le>] Ts' \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<bullet>M(es) :: T"

| WTBlock\<^sub>1:
  "\<lbrakk> is_type P T; P,E@[T] \<turnstile>\<^sub>1 e::T' \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile>\<^sub>1 {i:T; e} :: T'"

| WTSeq\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1::T\<^sub>1;  P,E \<turnstile>\<^sub>1 e\<^sub>2::T\<^sub>2 \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile>\<^sub>1 e\<^sub>1;;e\<^sub>2 :: T\<^sub>2"

| WTCond\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Boolean;  P,E \<turnstile>\<^sub>1 e\<^sub>1::T\<^sub>1;  P,E \<turnstile>\<^sub>1 e\<^sub>2::T\<^sub>2;
    P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1;  P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<longrightarrow> T = T\<^sub>2; P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<longrightarrow> T = T\<^sub>1 \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 if (e) e\<^sub>1 else e\<^sub>2 :: T"

| WTWhile\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Boolean;  P,E \<turnstile>\<^sub>1 c::T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 while (e) c :: Void"

| WTThrow\<^sub>1:
  "P,E \<turnstile>\<^sub>1 e :: Class C  \<Longrightarrow>
  P,E \<turnstile>\<^sub>1 throw e :: Void"

| WTTry\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1 :: T;  P,E@[Class C] \<turnstile>\<^sub>1 e\<^sub>2 :: T; is_class P C \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 try e\<^sub>1 catch(C i) e\<^sub>2 :: T"

| WTNil\<^sub>1:
  "P,E \<turnstile>\<^sub>1 [] [::] []"

| WTCons\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: T;  P,E \<turnstile>\<^sub>1 es [::] Ts \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile>\<^sub>1 e#es [::] T#Ts"

(*<*)
declare  WT\<^sub>1_WTs\<^sub>1.intros[intro!]
declare WTNil\<^sub>1[iff]

lemmas WT\<^sub>1_WTs\<^sub>1_induct = WT\<^sub>1_WTs\<^sub>1.induct [split_format (complete)]
  and WT\<^sub>1_WTs\<^sub>1_inducts = WT\<^sub>1_WTs\<^sub>1.inducts [split_format (complete)]

inductive_cases eee[elim!]:
  "P,E \<turnstile>\<^sub>1 Val v :: T"
  "P,E \<turnstile>\<^sub>1 Var i :: T"
  "P,E \<turnstile>\<^sub>1 Cast D e :: T"
  "P,E \<turnstile>\<^sub>1 i:=e :: T"
  "P,E \<turnstile>\<^sub>1 {i:U; e} :: T"
  "P,E \<turnstile>\<^sub>1 e\<^sub>1;;e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 if (e) e\<^sub>1 else e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 while (e) c :: T"
  "P,E \<turnstile>\<^sub>1 throw e :: T"
  "P,E \<turnstile>\<^sub>1 try e\<^sub>1 catch(C i) e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 e\<bullet>F{D} :: T"
  "P,E \<turnstile>\<^sub>1 e\<^sub>1\<bullet>F{D}:=e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 new C :: T"
  "P,E \<turnstile>\<^sub>1 e\<bullet>M(es) :: T"
  "P,E \<turnstile>\<^sub>1 [] [::] Ts"
  "P,E \<turnstile>\<^sub>1 e#es [::] Ts"
(*>*)

lemma WTs\<^sub>1_same_size: "\<And>Ts. P,E \<turnstile>\<^sub>1 es [::] Ts \<Longrightarrow> size es = size Ts"
(*<*)by (induct es type:list) auto(*>*)

lemma WT\<^sub>1_unique:
  "P,E \<turnstile>\<^sub>1 e :: T\<^sub>1 \<Longrightarrow> (\<And>T\<^sub>2. P,E \<turnstile>\<^sub>1 e :: T\<^sub>2 \<Longrightarrow> T\<^sub>1 = T\<^sub>2)" and
  "P,E \<turnstile>\<^sub>1 es [::] Ts\<^sub>1 \<Longrightarrow> (\<And>Ts\<^sub>2. P,E \<turnstile>\<^sub>1 es [::] Ts\<^sub>2 \<Longrightarrow> Ts\<^sub>1 = Ts\<^sub>2)"
(*<*)
apply(induct rule:WT\<^sub>1_WTs\<^sub>1.inducts)
apply blast
apply blast
apply clarsimp
apply blast
apply clarsimp
apply(case_tac bop)
apply clarsimp
apply clarsimp
apply blast
apply (blast dest:sees_field_idemp sees_field_fun)
apply blast
apply (blast dest:sees_method_idemp sees_method_fun)
apply blast
apply blast
apply blast
apply blast
apply clarify
apply blast
apply blast
apply blast
done
(*>*)

lemma assumes wf: "wf_prog p P"
shows WT\<^sub>1_is_type: "P,E \<turnstile>\<^sub>1 e :: T \<Longrightarrow> set E \<subseteq> types P \<Longrightarrow> is_type P T"
and "P,E \<turnstile>\<^sub>1 es [::] Ts \<Longrightarrow> True"
(*<*)
apply(induct rule:WT\<^sub>1_WTs\<^sub>1.inducts)
apply simp
apply simp
apply (simp add:typeof_lit_is_type)
apply (blast intro:nth_mem)
apply(simp split:bop.splits)
apply simp
apply (simp add:sees_field_is_type[OF _ wf])
apply simp
apply(fastforce dest!: sees_wf_mdecl[OF wf] simp:wf_mdecl_def)
apply simp
apply simp
apply blast
apply simp
apply simp
apply simp
apply simp
apply simp
done
(*>*)

subsection{* Well-formedness*}

--"Indices in blocks increase by 1"

primrec \<B> :: "expr\<^sub>1 \<Rightarrow> nat \<Rightarrow> bool"
  and \<B>s :: "expr\<^sub>1 list \<Rightarrow> nat \<Rightarrow> bool" where
"\<B> (new C) i = True" |
"\<B> (Cast C e) i = \<B> e i" |
"\<B> (Val v) i = True" |
"\<B> (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (Var j) i = True" |
"\<B> (e\<bullet>F{D}) i = \<B> e i" |
"\<B> (j:=e) i = \<B> e i" |
"\<B> (e\<^sub>1\<bullet>F{D} := e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (e\<bullet>M(es)) i = (\<B> e i \<and> \<B>s es i)" |
"\<B> ({j:T ; e}) i = (i = j \<and> \<B> e (i+1))" |
"\<B> (e\<^sub>1;;e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (if (e) e\<^sub>1 else e\<^sub>2) i = (\<B> e i \<and> \<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (throw e) i = \<B> e i" |
"\<B> (while (e) c) i = (\<B> e i \<and> \<B> c i)" |
"\<B> (try e\<^sub>1 catch(C j) e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> i=j \<and> \<B> e\<^sub>2 (i+1))" |

"\<B>s [] i = True" |
"\<B>s (e#es) i = (\<B> e i \<and> \<B>s es i)"

definition wf_J\<^sub>1_mdecl :: "J\<^sub>1_prog \<Rightarrow> cname \<Rightarrow> expr\<^sub>1 mdecl \<Rightarrow> bool"
where
  "wf_J\<^sub>1_mdecl P C  \<equiv>  \<lambda>(M,Ts,T,body).
    (\<exists>T'. P,Class C#Ts \<turnstile>\<^sub>1 body :: T' \<and> P \<turnstile> T' \<le> T) \<and>
    \<D> body \<lfloor>{..size Ts}\<rfloor> \<and> \<B> body (size Ts + 1)"

lemma wf_J\<^sub>1_mdecl[simp]:
  "wf_J\<^sub>1_mdecl P C (M,Ts,T,body) \<equiv>
    ((\<exists>T'. P,Class C#Ts \<turnstile>\<^sub>1 body :: T' \<and> P \<turnstile> T' \<le> T) \<and>
     \<D> body \<lfloor>{..size Ts}\<rfloor> \<and> \<B> body (size Ts + 1))"
(*<*)by (simp add:wf_J\<^sub>1_mdecl_def)(*>*)

abbreviation "wf_J\<^sub>1_prog == wf_prog wf_J\<^sub>1_mdecl"

end


section {* \isaheader{Generic Compare Algorithms} *}
theory Gen_Comp
imports
  "../Intf/Intf_Comp"
  "../../../Automatic_Refinement/Automatic_Refinement"
begin

subsection {* Order for Product *}
(* TODO: Optimization? Or only go via prod_cmp? *)
lemma autoref_prod_cmp_dflt_id[autoref_rules_raw]:
  "(dflt_cmp op \<le> op <, dflt_cmp op \<le> op <) \<in>
    \<langle>Id,Id\<rangle>prod_rel \<rightarrow> \<langle>Id,Id\<rangle>prod_rel \<rightarrow> Id"
  by auto

lemma gen_prod_cmp_dflt[autoref_rules_raw]:
  assumes PRIO_TAG_GEN_ALGO
  assumes "GEN_OP cmp1 (dflt_cmp op \<le> op <) (R1 \<rightarrow> R1 \<rightarrow> Id)"
  assumes "GEN_OP cmp2 (dflt_cmp op \<le> op <) (R2 \<rightarrow> R2 \<rightarrow> Id)"
  shows "(cmp_prod cmp1 cmp2, dflt_cmp op \<le> op <) \<in>
    \<langle>R1,R2\<rangle>prod_rel \<rightarrow> \<langle>R1,R2\<rangle>prod_rel \<rightarrow> Id"
proof -
  have E: "dflt_cmp op \<le> op <
    = cmp_prod (dflt_cmp op \<le> op <) (dflt_cmp op \<le> op <)"
    by (auto simp: dflt_cmp_def prod_less_def prod_le_def intro!: ext)

  show ?thesis
    using assms
    unfolding autoref_tag_defs E
    by parametricity
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory MoreCorres
imports "Lib.ExtraCorres"
begin

(* FIXME: move all of this into ExtraCorres *)

(*
 * If both systems perform non-determinism where the splits are
 * equivalent, we can prove each pair separately.
 *)
lemma corres_alternate_match:
  "\<lbrakk> corres_underlying sr nf nf' r P P' a c;
     corres_underlying sr nf nf' r P P' b d \<rbrakk> \<Longrightarrow>
   corres_underlying sr nf nf' r P P' (a \<sqinter> b) (c \<sqinter> d)"
  apply (simp add: corres_underlying_def alternative_def)
  apply (clarsimp)
  apply (drule (1) bspec, clarsimp)+
  apply fastforce
  done

(*
 * If the concrete system performs non-determinism where the abstract
 * system does not, we must show that both branches of the concrete
 * system refine the abstract system.
 *)
lemma corres_alternate_split:
  "\<lbrakk> corres_underlying sr nf nf' r P Q a x;
     corres_underlying sr nf nf' r P' Q' a y \<rbrakk> \<Longrightarrow>
   corres_underlying sr nf nf' r (P and P') (Q and Q') a (x \<sqinter> y)"
  apply (simp add: corres_underlying_def alternative_def)
  apply (clarsimp)
  apply (drule (1) bspec, clarsimp)+
  apply fastforce
  done

(*
 * Two select statements are equivalent if the concrete's select set is
 * a subset of the abstract's select set.
 *)
lemma corres_select_equiv:
  "\<lbrakk> \<forall>a' \<in> A'. \<exists>a \<in> A. r a a' \<rbrakk> \<Longrightarrow> corres_underlying sr nf nf' r \<top> \<top> (select A) (select A')"
  apply (clarsimp simp: corres_underlying_def)
  apply (clarsimp simp: split_def)
  apply (clarsimp simp: select_def)
  done

(*
 * Where there is an 'if' statement in the concrete system not present
 * in the abstract system, we must show that both branches are a  valid
 * refinement. Happily, we get to assume the outcome of the 'if'
 * statement when proving the refinement.
 *
 * This will likely need to be used with 'stronger_corres_guard_imp'.
 *)
lemma corres_if_rhs:
  "\<lbrakk>  G \<Longrightarrow> corres_underlying sr nf nf' rvr P  Q  a b;
     \<not>G \<Longrightarrow> corres_underlying sr nf nf' rvr P' Q' a c \<rbrakk> \<Longrightarrow>
   corres_underlying sr nf nf' rvr
       (\<lambda>s. (G \<longrightarrow> P s) \<and> (\<not>G \<longrightarrow> P' s)) (\<lambda>s. (G \<longrightarrow> Q s) \<and> (\<not>G \<longrightarrow> Q' s))
       a (if G then b else c)"
  by (auto elim: corres_guard_imp)

(* Bind distributes over non-deterministic choice. *)
lemma alternative_bind_distrib: "((f \<sqinter> g) >>= h) = ((f >>= h) \<sqinter> (g >>= h))"
  apply (auto simp: alternative_def bind_def split_def intro!: prod_eqI)
  done

(* Bind distributes over non-deterministic choice. *)
lemma alternative_bind_distrib_2: "(do f; (a \<sqinter> b) od) = ((do f; a od) \<sqinter> (do f; b od))"
  apply (auto simp: alternative_def bind_def split_def intro!: prod_eqI)
  done

(* "bindE" distributes over non-deterministic choice. *)
lemma alternative_bindE_distrib: "((f \<sqinter> g) >>=E h) = ((f >>=E h) \<sqinter> (g >>=E h))"
  by (simp add: bindE_def alternative_bind_distrib)

(*
 * Two arbitrary return statements correspond if our return relation
 * doesn't care about them.
 *)
lemma corres_return_dc [simp]:
  "corres_underlying sr nf nf' dc \<top> \<top> (return a) (return b)"
  apply (clarsimp simp: corres_underlying_def dc_def return_def)
  done

(* If our return relation doesn't matter, return statements are meaningless. *)
lemma corres_return_dc_rhs:
  "corres_underlying sr nf nf' dc G G' P P' \<Longrightarrow> corres_underlying sr nf nf' dc G G' P (do P'; return a od)"
  by (fastforce simp: corres_underlying_def dc_def return_def bind_def)

(* If our return relation doesn't matter, return statements are meaningless. *)
lemma corres_return_dc_lhs:
  "corres_underlying sr nf nf' dc G G' P P'
    \<Longrightarrow> corres_underlying sr nf nf' dc G G' (do P; return a od) P'"
  by (simp add: liftM_def[symmetric])

(* liftE distributes inside bind. *)
lemma liftE_distrib: "(liftE (A >>= (\<lambda>_. B))) = ((liftE A) >>=E (\<lambda>x. (liftE B)))"
  apply (clarsimp simp: liftE_def bindE_def)
  apply (subst bind_assoc)+
  apply (clarsimp simp: bind_def lift_def)
  done

(* liftE distributes inside alternate. *)
lemma liftE_alternative_distrib: "(liftE (a \<sqinter> b)) = ((liftE a) \<sqinter> (liftE b))"
  by (metis alternative_bind_distrib bindE_returnOk liftE_bindE)

lemma corres_skip_catch:
  "corres_underlying sr nf nf' dc P P' f g \<Longrightarrow>
   corres_underlying sr nf nf' dc P P' f (g <catch> (\<lambda>_. return x))"
  by (clarsimp simp: corres_underlying_def catch_def return_def bind_def
                     split_def
               split: sum.splits)

end