(*  Title:      HOL/MicroJava/BV/EffMono.thy

    Author:     Gerwin Klein
    Copyright   2000 Technische Universitaet Muenchen
*)

header {* \isaheader{Monotonicity of eff and app} *}

theory EffectMono imports Effect begin

declare not_Err_eq [iff]

lemma app\<^sub>i_mono:
  assumes wf: "wf_prog p P"
  assumes less: "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>'"
  shows "app\<^sub>i (i,P,mxs,mpc,rT,\<tau>') \<Longrightarrow> app\<^sub>i (i,P,mxs,mpc,rT,\<tau>)"
(*<*)
proof -
  assume app: "app\<^sub>i (i,P,mxs,mpc,rT,\<tau>')"

  obtain ST LT ST' LT' where
    [simp]: "\<tau> = (ST,LT)" and
    [simp]: "\<tau>' = (ST',LT')"
    by (cases \<tau>, cases \<tau>')

  from less have [simp]: "size ST = size ST'" and [simp]: "size LT = size LT'"
    by (auto dest: list_all2_lengthD)

  note [iff] = list_all2_Cons2 widen_Class
  note [simp] = fun_of_def

  from app less show "app\<^sub>i (i,P,mxs,mpc,rT,\<tau>)"
  proof (cases i)
    case Load
    with app less show ?thesis by (auto dest!: list_all2_nthD)
  next
    case (Invoke M n)
    with app have n: "n < size ST'" by simp

    { assume "ST!n = NT" hence ?thesis using n app Invoke by simp }
    moreover {
      assume "ST'!n = NT"
      moreover with n less have "ST!n = NT"
        by (auto dest: list_all2_nthD)
      ultimately have ?thesis using n app Invoke by simp
    }
    moreover {
      assume ST: "ST!n \<noteq> NT" and ST': "ST'!n \<noteq> NT"

      from ST' app Invoke obtain D Ts T m C' where
        D:   "ST' ! n = Class D" and
        Ts:  "P \<turnstile> rev (take n ST') [\<le>] Ts" and
        D_M: "P \<turnstile> D sees M: Ts\<rightarrow>T = m in C'"
        by auto

      from n D less have "P \<turnstile> ST!n \<le> ST'!n"
        by (fastforce dest: list_all2_nthD2)
      with D ST obtain D' where
        D': "ST!n = Class D'" and DsubC: "P \<turnstile> D' \<preceq>\<^sup>* D" by auto

      from wf D_M DsubC obtain Ts' T' m' C'' where
        D'_M: "P \<turnstile> D' sees M: Ts'\<rightarrow>T' = m' in C''" and
        Ts': "P \<turnstile> Ts [\<le>] Ts'"
        by (blast dest: sees_method_mono)

      from less have "P \<turnstile> rev (take n ST) [\<le>] rev (take n ST')" by simp
      also note Ts also note Ts'
      finally have "P \<turnstile> rev (take n ST) [\<le>] Ts'" .
      with D'_M D' app less Invoke have ?thesis by fastforce
    }
    ultimately show ?thesis by blast
  next
    case Getfield
    with app less show ?thesis by (fastforce intro: rtrancl_trans)
  next
    case (Putfield F C)
    with app less show ?thesis by (fastforce intro: widen_trans rtrancl_trans)
  next
    case Return
    with app less show ?thesis by (fastforce intro: widen_trans)
  qed (auto elim!: refTE not_refTE)
qed
(*>*)

lemma succs_mono:
  assumes wf: "wf_prog p P" and app\<^sub>i: "app\<^sub>i (i,P,mxs,mpc,rT,\<tau>')"
  shows "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>' \<Longrightarrow> set (succs i \<tau> pc) \<subseteq> set (succs i \<tau>' pc)"
(*<*)
proof (cases i)
  case (Invoke M n)
  obtain ST LT ST' LT' where
    [simp]: "\<tau> = (ST,LT)" and [simp]: "\<tau>' = (ST',LT')" by (cases \<tau>, cases \<tau>')
  assume "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>'"
  moreover
  with app\<^sub>i Invoke have "n < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P \<turnstile> ST!n \<le> ST'!n" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with Invoke show ?thesis by auto
qed auto
(*>*)

lemma app_mono:
  assumes wf: "wf_prog p P"
  assumes less': "P \<turnstile> \<tau> \<le>' \<tau>'"
  shows "app i P m rT pc mpc xt \<tau>' \<Longrightarrow> app i P m rT pc mpc xt \<tau>"
(*<*)
proof (cases \<tau>)
  case None thus ?thesis by simp
next
  case (Some \<tau>\<^sub>1)
  moreover
  with less' obtain \<tau>\<^sub>2 where \<tau>\<^sub>2: "\<tau>' = Some \<tau>\<^sub>2" by (cases \<tau>') auto
  ultimately have less: "P \<turnstile> \<tau>\<^sub>1 \<le>\<^sub>i \<tau>\<^sub>2" using less' by simp

  assume "app i P m rT pc mpc xt \<tau>'"
  with Some \<tau>\<^sub>2 obtain
    app\<^sub>i: "app\<^sub>i (i, P, pc, m, rT, \<tau>\<^sub>2)" and
    xcpt: "xcpt_app i P pc m xt \<tau>\<^sub>2" and
    succs: "\<forall>(pc',s')\<in>set (eff i P pc xt (Some \<tau>\<^sub>2)). pc' < mpc"
    by (auto simp add: app_def)

  from wf less app\<^sub>i have "app\<^sub>i (i, P, pc, m, rT, \<tau>\<^sub>1)" by (rule app\<^sub>i_mono)
  moreover
  from less have "size (fst \<tau>\<^sub>1) = size (fst \<tau>\<^sub>2)"
    by (cases \<tau>\<^sub>1, cases \<tau>\<^sub>2) (auto dest: list_all2_lengthD)
  with xcpt have "xcpt_app i P pc m xt \<tau>\<^sub>1" by (simp add: xcpt_app_def)
  moreover
  from wf app\<^sub>i less have "\<forall>pc. set (succs i \<tau>\<^sub>1 pc) \<subseteq> set (succs i \<tau>\<^sub>2 pc)"
    by (blast dest: succs_mono)
  with succs
  have "\<forall>(pc',s')\<in>set (eff i P pc xt (Some \<tau>\<^sub>1)). pc' < mpc"
    by (cases \<tau>\<^sub>1, cases \<tau>\<^sub>2)
       (auto simp add: eff_def norm_eff_def xcpt_eff_def dest: bspec)
  ultimately
  show ?thesis using Some by (simp add: app_def)
qed
(*>*)

lemma eff\<^sub>i_mono:
  assumes wf: "wf_prog p P"
  assumes less: "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>'"
  assumes app\<^sub>i: "app i P m rT pc mpc xt (Some \<tau>')"
  assumes succs: "succs i \<tau> pc \<noteq> []"  "succs i \<tau>' pc \<noteq> []"
  shows "P \<turnstile> eff\<^sub>i (i,P,\<tau>) \<le>\<^sub>i eff\<^sub>i (i,P,\<tau>')"
(*<*)
proof -
  obtain ST LT ST' LT' where
    [simp]: "\<tau> = (ST,LT)" and
    [simp]: "\<tau>' = (ST',LT')"
    by (cases \<tau>, cases \<tau>')

  note [simp] = eff_def app_def fun_of_def

  from less have "P \<turnstile> (Some \<tau>) \<le>' (Some \<tau>')" by simp
  from wf this app\<^sub>i
  have app: "app i P m rT pc mpc xt (Some \<tau>)" by (rule app_mono)

  from less app app\<^sub>i show ?thesis
  proof (cases i)
    case Throw with succs have False by simp
    thus ?thesis ..
  next
    case Return with succs have False by simp
    thus ?thesis ..
  next
    case (Load i)
    from Load app obtain y where
       y:  "i < size LT" "LT!i = OK y" by clarsimp
    from Load app\<^sub>i obtain y' where
       y': "i < size LT'" "LT'!i = OK y'" by clarsimp

    from less have "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'" by simp
    with y y' have "P \<turnstile> y \<le> y'" by (auto dest: list_all2_nthD)
    with Load less y y' app app\<^sub>i
    show ?thesis by auto
  next
    case Store with less app app\<^sub>i
    show ?thesis by (auto simp add: list_all2_update_cong)
  next
    case (Invoke M n)
    with app\<^sub>i have n: "n < size ST'" by simp
    from less have [simp]: "size ST = size ST'"
      by (auto dest: list_all2_lengthD)

    from Invoke succs have ST: "ST!n \<noteq> NT" and ST': "ST'!n \<noteq> NT"
      by (auto split: split_if_asm)

    from ST' app\<^sub>i Invoke obtain D Ts T m C' where
      D:   "ST' ! n = Class D" and
      D_M: "P \<turnstile> D sees M: Ts\<rightarrow>T = m in C'"
      by auto

    from n D less have "P \<turnstile> ST!n \<le> ST'!n"
      by (fastforce dest: list_all2_nthD2)
    with D ST obtain D' where
      D': "ST ! n = Class D'" and DsubC: "P \<turnstile> D' \<preceq>\<^sup>* D"
      by (auto simp: widen_Class)

    from wf D_M DsubC obtain Ts' T' m' C'' where
      D'_M: "P \<turnstile> D' sees M: Ts'\<rightarrow>T' = m' in C''" and
      Ts': "P \<turnstile> T' \<le> T"
      by (blast dest: sees_method_mono)

    with Invoke n D D' D_M less
    show ?thesis by (auto intro: list_all2_dropI)
  qed auto
qed
(*>*)

end


theory Transition
  imports Main "./Definitions" "./Log"
begin

datatype message_payload
  = append_entry
    (* leaderId *) node
    (* leaderCommit *) log_index
    (* leaderLog *) log
  | request_vote
    (* candidateid *) node
    (* lastLogIndex *) log_index
    (* lastLogTerm *) election_term
  | append_entry_response
    (* success *) bool
  | request_vote_response
    (* voteGranted *) bool

primrec is_response where
  "is_response (append_entry _ _ _) = False"
| "is_response (request_vote _ _ _) = False"
| "is_response (append_entry_response _) = True"
| "is_response (request_vote_response _) = True"

fun is_request where
  "is_request r = (\<not> is_response r)"

datatype message
  = message (sender: node) (receiver: node) (payload: message_payload) (sender_term: election_term)

fun payload_respond_to where
  "payload_respond_to (append_entry_response _) (append_entry _ _ _) = True"
| "payload_respond_to (request_vote_response _) (request_vote _ _ _) = True"
| "payload_respond_to _ _ = False"

definition respond_to where
  "respond_to resp req \<equiv>
    (is_response (payload resp)
    \<and> is_request (payload req)
    \<and> sender req = receiver resp
    \<and> sender resp = receiver req
    \<and> payload_respond_to (payload resp) (payload req)
    \<and> sender_term resp = sender_term req)"

datatype node_state = follower | candidate | leader

record server_state =
  state :: node_state

  (* Persistent state *)
  currentTerm :: election_term
  votedFor :: "node option"
  log :: log

  (* Volatile state *)
  commitIndex :: nat
  lastApplied :: nat

  (* Volatile state on leaders *)
  nextIndex :: "log_index list"
  matchIndex :: "log_index list"

definition initial_server_state where
  "initial_server_state n = \<lparr>
    state = follower,
    currentTerm = election_term 0,
    votedFor = None,
    log = [],
    commitIndex = 0,
    lastApplied = 0,
    nextIndex = repeat (log_index 0) n,
    matchIndex = repeat (log_index 0) n
  \<rparr>"

definition ExReqProps where
  "ExReqProps resp P req \<equiv> P req \<and> respond_to resp req"

definition ExReq where
  "ExReq resp P \<equiv> Ex (ExReqProps resp P)"

definition majority where
  "majority n t \<equiv> 2 * card t > n"

lemma majority_pigeonhole: "\<lbrakk> finite u; card u = n; x \<subseteq> u; y \<subseteq> u; majority n x; majority n y \<rbrakk> \<Longrightarrow> x \<inter> y \<noteq> {}"
proof-
  assume "finite u" "card u = n" "x \<subseteq> u" "y \<subseteq> u" "majority n x" "majority n y"

  have "2 * card x > n"
    using \<open>majority n x\<close> majority_def by blast
  moreover have "2 * card y > n"
    using \<open>majority n y\<close> majority_def by auto
  ultimately have "card x + card y > n"
    by simp

  { assume "x \<inter> y = {}"
    have "card (x \<union> y) = card x + card y"
      by (meson \<open>finite u\<close> \<open>x \<inter> y = {}\<close> \<open>x \<subseteq> u\<close> \<open>y \<subseteq> u\<close> card_Un_disjoint finite_subset)
    also have "\<dots> > n"
      by (simp add: \<open>n < card x + card y\<close>)
    finally have "card (x \<union> y) > n"
      by simp

    have "x \<union> y \<subseteq> u"
      by (simp add: \<open>x \<subseteq> u\<close> \<open>y \<subseteq> u\<close>)

    have False
      by (metis \<open>card u = n\<close> \<open>finite u\<close> \<open>n < card (x \<union> y)\<close> \<open>x \<union> y \<subseteq> u\<close> card_mono not_le)
  }
  thus "x \<inter> y \<noteq> {}"
    by auto
qed

(* Assumption: all RequestVote messages to followers are sent at once. Is it appropriate to assume this? *)
definition TR_condition_start_election where
  "TR_condition_start_election \<sigma> \<sigma>' ms ms' target \<equiv>
     let (index, term) = get_last_log_info (log (\<sigma>' ! target)) in
     target < length \<sigma>
     \<and> \<sigma>' = update target ((\<sigma> ! target) \<lparr>
       currentTerm := increment_election_term (currentTerm (\<sigma> ! target)),
       votedFor := Some (node target)
     \<rparr>) \<sigma>
     \<and> ms' = ms \<union> {message (node target) (node i) (request_vote (node target) index term) (currentTerm (\<sigma>' ! target)) | i. i \<in> {0..length \<sigma> - 1} \<and> i \<noteq> target}"

definition TR_condition_request_vote_resp where
  "TR_condition_request_vote_resp \<sigma> \<sigma>' ms ms' m r s t vg \<equiv>
     let resp = message (node m) (node r) (request_vote_response vg) t in
     (ExReq resp (\<lambda>req. \<exists>candidateId lastLogIndex lastLogTerm. payload req = request_vote candidateId lastLogIndex lastLogTerm
       \<and> req \<in> ms
       \<and> vg = (if sender_term req < currentTerm (\<sigma> ! r) then False
               else (votedFor (\<sigma> ! r) = None \<or> votedFor (\<sigma> ! r) = Some candidateId) \<and> log_up_to_date (log (\<sigma> ! r)) lastLogIndex lastLogTerm)
       \<and> (votedFor (\<sigma> ! m) = Some s \<or> votedFor (\<sigma> ! m) = None)))
     \<and> m < length \<sigma>
     \<and> r < length \<sigma>
     \<and> \<sigma>' = update m ((\<sigma> ! m) \<lparr> votedFor := Some s \<rparr>) \<sigma>
     \<and> ms' = ms \<union> {resp}"

definition TR_condition_promote_to_leader where
  "TR_condition_promote_to_leader \<sigma> \<sigma>' ms ms' target \<equiv>
    majority (length \<sigma>) {s. \<exists>m \<in> ms. m = message s (node target) (request_vote_response True) (currentTerm (\<sigma> ! target))}
    \<and> target < length \<sigma>
    \<and> \<sigma>' = update target ((\<sigma> ! target) \<lparr> state := leader \<rparr>) \<sigma>
    \<and> ms' = ms"

definition TR_condition_append_entry where
  "TR_condition_append_entry \<sigma> \<sigma>' ms ms' s r \<equiv>
    let m = message (node s) (node r) (append_entry (node s) (log_index (length (log (\<sigma> ! s)) - 1)) (log (\<sigma> ! s))) (currentTerm (\<sigma> ! s)) in
    state (\<sigma> ! s) = leader
    \<and> s < length \<sigma>
    \<and> r < length \<sigma>
    \<and> \<sigma>' = \<sigma>
    \<and> ms' = ms \<union> {m}"

(*
   This algorithm for AppendEntry is different from the original paper;
   leader is supposed to send all logs in the state for the simplicity (no need to calculate diffs for merging and leader retries)
 *)
definition TR_condition_append_entry_resp where
  "TR_condition_append_entry_resp \<sigma> \<sigma>' ms ms' leadersLog prevLogTerm prevLogIndex t success r s \<equiv>
    let resp = message (node s) (node r) (append_entry_response success) t in
    ExReq resp (\<lambda>req. \<exists>leaderId leaderCommit. payload req = append_entry leaderId leaderCommit leadersLog
      \<and> req \<in> ms
      \<and> success = (if sender_term req < currentTerm (\<sigma> ! r) then False
                 else if \<not> log_up_to_date (log (\<sigma> ! r)) prevLogIndex prevLogTerm then False
                 else True))
    \<and> s < length \<sigma>
    \<and> r < length \<sigma>
    \<and> \<sigma>' = update s ((\<sigma> ! s) \<lparr> log := leadersLog \<rparr>) \<sigma>
    \<and> ms' = ms \<union> {resp}"

inductive transition :: "server_state list \<times> message set \<Rightarrow> server_state list \<times> message set \<Rightarrow> bool" (infix "\<rightarrow>" 50) where
TR_start_election: "TR_condition_start_election \<sigma> \<sigma>' ms ms' target \<Longrightarrow> transition (\<sigma>, ms) (\<sigma>', ms')"
| TR_request_vote_resp: "TR_condition_request_vote_resp \<sigma> \<sigma>' ms ms' m r s t vg \<Longrightarrow> transition (\<sigma>, ms) (\<sigma>', ms')"
| TR_promote_to_leader: "TR_condition_promote_to_leader \<sigma> \<sigma>' ms ms' target \<Longrightarrow> transition (\<sigma>, ms) (\<sigma>', ms')"
| TR_append_entry: "TR_condition_append_entry \<sigma> \<sigma>' ms ms' s r \<Longrightarrow> transition (\<sigma>, ms) (\<sigma>', ms')"
| TR_append_entry_resp: "TR_condition_append_entry_resp \<sigma> \<sigma>' ms ms' leadersLog prevLogTerm prevLogIndex t success r s \<Longrightarrow> transition (\<sigma>, ms) (\<sigma>', ms')"

lemma leader_promote_inversion_for_transition:
  "\<lbrakk> i < length \<sigma>; transition (\<sigma>, ms) (\<sigma>', ms'); state (\<sigma> ! i) \<noteq> leader; state (\<sigma>' ! i) = leader \<rbrakk> \<Longrightarrow> majority (length \<sigma>) {s. \<exists>m \<in> ms. m = message s (node i) (request_vote_response True) (currentTerm (\<sigma> ! i))}"
  apply (cases rule: transition.cases)
  apply simp_all
proof-
  fix \<sigma>'' \<sigma>''' msa ms'a target
  show "i < length \<sigma> \<Longrightarrow>
       (\<sigma>, ms) \<rightarrow> (\<sigma>', ms') \<Longrightarrow>
       state (\<sigma> ! i) \<noteq> leader \<Longrightarrow>
       state (\<sigma>' ! i) = leader \<Longrightarrow>
       (\<sigma>, ms) = (\<sigma>'', msa) \<Longrightarrow>
       (\<sigma>', ms') = (\<sigma>''', ms'a) \<Longrightarrow>
       TR_condition_start_election \<sigma>'' \<sigma>''' msa ms'a target \<Longrightarrow>
       majority (length \<sigma>) {s. message s (node i) (request_vote_response True) (currentTerm (\<sigma> ! i)) \<in> ms}"
    apply (simp add: TR_condition_start_election_def)
    apply (cases "\<sigma>'' ! target")
    apply simp
    by (metis select_convs(1) update_nth_nonupdated update_nth_updated)
next
  fix \<sigma>'' \<sigma>''' msa ms'a m r s t vg
  show "i < length \<sigma> \<Longrightarrow>
       (\<sigma>, ms) \<rightarrow> (\<sigma>', ms') \<Longrightarrow>
       state (\<sigma> ! i) \<noteq> leader \<Longrightarrow>
       state (\<sigma>' ! i) = leader \<Longrightarrow>
       (\<sigma>, ms) = (\<sigma>'', msa) \<Longrightarrow>
       (\<sigma>', ms') = (\<sigma>''', ms'a) \<Longrightarrow>
       TR_condition_request_vote_resp \<sigma>'' \<sigma>''' msa ms'a m r s t vg \<Longrightarrow>
       majority (length \<sigma>) {s. message s (node i) (request_vote_response True) (currentTerm (\<sigma> ! i)) \<in> ms}"
    apply (simp add: TR_condition_request_vote_resp_def)
    apply (cases "\<sigma>'' ! m")
    apply simp
    by (metis select_convs(1) update_nth_nonupdated update_nth_updated)
next
  fix \<sigma>'' \<sigma>''' msa ms'a target
  show "i < length \<sigma> \<Longrightarrow>
       (\<sigma>, ms) \<rightarrow> (\<sigma>', ms') \<Longrightarrow>
       state (\<sigma> ! i) \<noteq> leader \<Longrightarrow>
       state (\<sigma>' ! i) = leader \<Longrightarrow>
       (\<sigma>, ms) = (\<sigma>'', msa) \<Longrightarrow>
       (\<sigma>', ms') = (\<sigma>''', ms'a) \<Longrightarrow>
       TR_condition_promote_to_leader \<sigma>'' \<sigma>''' msa ms'a target \<Longrightarrow>
       majority (length \<sigma>) {s. message s (node i) (request_vote_response True) (currentTerm (\<sigma> ! i)) \<in> ms}"
    apply (simp add: TR_condition_promote_to_leader_def)
    apply (cases "\<sigma>'' ! target")
    apply simp
    by (metis select_convs(2) update_nth_nonupdated)
next
  fix \<sigma>'' \<sigma>''' msa ms'a s r
  show "i < length \<sigma> \<Longrightarrow>
       (\<sigma>, ms) \<rightarrow> (\<sigma>', ms') \<Longrightarrow>
       state (\<sigma> ! i) \<noteq> leader \<Longrightarrow>
       state (\<sigma>' ! i) = leader \<Longrightarrow>
       (\<sigma>, ms) = (\<sigma>'', msa) \<Longrightarrow>
       (\<sigma>', ms') = (\<sigma>''', ms'a) \<Longrightarrow>
       TR_condition_append_entry \<sigma>'' \<sigma>''' msa ms'a s r \<Longrightarrow>
       majority (length \<sigma>) {s. message s (node i) (request_vote_response True) (currentTerm (\<sigma> ! i)) \<in> ms}"
    apply (simp add: TR_condition_append_entry_def)
    done
next
  fix \<sigma>'' \<sigma>''' msa ms'a leadersLog prevLogTerm prevLogIndex t success r s
  show "i < length \<sigma> \<Longrightarrow>
       (\<sigma>, ms) \<rightarrow> (\<sigma>', ms') \<Longrightarrow>
       state (\<sigma> ! i) \<noteq> leader \<Longrightarrow>
       state (\<sigma>' ! i) = leader \<Longrightarrow>
       (\<sigma>, ms) = (\<sigma>'', msa) \<Longrightarrow>
       (\<sigma>', ms') = (\<sigma>''', ms'a) \<Longrightarrow>
       TR_condition_append_entry_resp \<sigma>'' \<sigma>''' msa ms'a leadersLog prevLogTerm prevLogIndex t success r s \<Longrightarrow>
       majority (length \<sigma>) {s. message s (node i) (request_vote_response True) (currentTerm (\<sigma> ! i)) \<in> ms}"
    apply (simp add: TR_condition_append_entry_resp_def)
    apply (cases "\<sigma>''' ! s")
    by (metis (no_types, lifting) select_convs(1) surjective update_convs(4) update_nth_nonupdated update_nth_updated)
qed

lemma state_length_invariant_for_transition: "transition (\<sigma>, m) (\<sigma>', m') \<Longrightarrow> length \<sigma> = length \<sigma>'"
  apply (cases rule: transition.cases)
  apply simp_all
  apply (simp add: TR_condition_start_election_def)
  apply (simp add: TR_condition_request_vote_resp_def)
     apply (metis update_length)
  apply (simp add: TR_condition_promote_to_leader_def)
  apply (simp add: TR_condition_append_entry_def)
  apply (simp add: TR_condition_append_entry_resp_def)
  by (metis update_length)

lemma transition_message_monotonicity: "(\<sigma>, m) \<rightarrow> (\<sigma>', m') \<Longrightarrow> m \<subseteq> m'"
proof-
  assume hyp: "transition (\<sigma>,m) (\<sigma>',m')"

  have "(\<lambda>(_, m). \<lambda>(_, m'). m \<subseteq> m') (\<sigma>,m) (\<sigma>', m')"
    apply (induct rule: transition.induct [OF hyp])
    apply (auto simp add: TR_condition_append_entry_def TR_condition_start_election_def TR_condition_promote_to_leader_def TR_condition_append_entry_resp_def TR_condition_request_vote_resp_def)
    apply (metis insertCI)
    apply (metis insertCI)
    done
  thus "m \<subseteq> m'"
    by simp
qed

lemma transition_message_preserves_finite: "\<lbrakk> (\<sigma>,m) \<rightarrow> (\<sigma>',m'); finite m \<rbrakk> \<Longrightarrow> finite m'"
  apply (cases rule: transition.cases)
  apply simp_all
  apply (simp add: TR_condition_start_election_def)
  apply auto[1]
  apply (simp add: TR_condition_request_vote_resp_def)
  apply (metis finite_insert)
  apply (simp add: TR_condition_promote_to_leader_def)
  apply (simp add: TR_condition_append_entry_def)
  apply (simp add: TR_condition_append_entry_resp_def)
  by (metis finite_insert)

lemma transition_currentTerm_monotonicity: "\<lbrakk> i < length \<sigma>; (\<sigma>,m) \<rightarrow> (\<sigma>',m') \<rbrakk> \<Longrightarrow> currentTerm (\<sigma> ! i) \<le> currentTerm (\<sigma>' ! i)"
  apply (cases rule: transition.cases)
  apply simp_all
proof-
  fix \<sigma>'' \<sigma>''' ms ms' target
  show "i < length \<sigma> \<Longrightarrow>
       (\<sigma>, m) \<rightarrow> (\<sigma>', m') \<Longrightarrow>
       (\<sigma>, m) = (\<sigma>'', ms) \<Longrightarrow> (\<sigma>', m') = (\<sigma>''', ms') \<Longrightarrow> TR_condition_start_election \<sigma>'' \<sigma>''' ms ms' target \<Longrightarrow> currentTerm (\<sigma> ! i) \<le> currentTerm (\<sigma>' ! i)"
    apply (simp add: TR_condition_start_election_def)
    apply (cases "i = target")
    apply simp
    apply (cases "\<sigma>'' ! target")
    apply simp
    apply (simp add: increment_election_term_greater update_nth_updated)
    by (simp add: less_eq_election_term_def update_nth_nonupdated)
next
  fix \<sigma>'' \<sigma>''' ms ms' ma r s t vg
  show "i < length \<sigma> \<Longrightarrow>
       (\<sigma>, m) \<rightarrow> (\<sigma>', m') \<Longrightarrow>
       (\<sigma>, m) = (\<sigma>'', ms) \<Longrightarrow>
       (\<sigma>', m') = (\<sigma>''', ms') \<Longrightarrow> TR_condition_request_vote_resp \<sigma>'' \<sigma>''' ms ms' ma r s t vg \<Longrightarrow> currentTerm (\<sigma> ! i) \<le> currentTerm (\<sigma>' ! i)"
    apply (simp add: TR_condition_request_vote_resp_def)
    by (metis eq_iff less_eq_election_term_def select_convs(2) simps(12) surjective update_nth_nonupdated update_nth_updated)
next
  fix \<sigma>'' \<sigma>''' ms ms' target
  show "i < length \<sigma> \<Longrightarrow>
       (\<sigma>, m) \<rightarrow> (\<sigma>', m') \<Longrightarrow>
       (\<sigma>, m) = (\<sigma>'', ms) \<Longrightarrow> (\<sigma>', m') = (\<sigma>''', ms') \<Longrightarrow> TR_condition_promote_to_leader \<sigma>'' \<sigma>''' ms ms' target \<Longrightarrow> currentTerm (\<sigma> ! i) \<le> currentTerm (\<sigma>' ! i)"
    apply (simp add: TR_condition_promote_to_leader_def)
    by (metis eq_iff less_eq_election_term_def select_convs(2) surjective update_convs(1) update_nth_nonupdated update_nth_updated)
next
  fix \<sigma>'' \<sigma>''' ms ms' s r
  show "i < length \<sigma> \<Longrightarrow>
       (\<sigma>, m) \<rightarrow> (\<sigma>', m') \<Longrightarrow>
       (\<sigma>, m) = (\<sigma>'', ms) \<Longrightarrow> (\<sigma>', m') = (\<sigma>''', ms') \<Longrightarrow> TR_condition_append_entry \<sigma>'' \<sigma>''' ms ms' s r \<Longrightarrow> currentTerm (\<sigma> ! i) \<le> currentTerm (\<sigma>' ! i)"
    apply (simp add: TR_condition_append_entry_def)
    using less_eq_election_term_def by presburger
next
  fix \<sigma>'' \<sigma>''' ms ms' leadersLog prevLogTerm prevLogIndex t success r s
  show "i < length \<sigma> \<Longrightarrow>
       (\<sigma>, m) \<rightarrow> (\<sigma>', m') \<Longrightarrow>
       (\<sigma>, m) = (\<sigma>'', ms) \<Longrightarrow>
       (\<sigma>', m') = (\<sigma>''', ms') \<Longrightarrow>
       TR_condition_append_entry_resp \<sigma>'' \<sigma>''' ms ms' leadersLog prevLogTerm prevLogIndex t success r s \<Longrightarrow> currentTerm (\<sigma> ! i) \<le> currentTerm (\<sigma>' ! i)"
    apply (simp add: TR_condition_append_entry_resp_def)
    by (metis (mono_tags, lifting) eq_iff less_eq_election_term_def select_convs(2) surjective update_convs(4) update_nth_nonupdated update_nth_updated)
qed

definition transitions (infix "\<rightarrow>*" 50) where
  "transitions \<equiv> rtranclp transition"

lemma transitions_one: "a \<rightarrow> b \<Longrightarrow> a \<rightarrow>* b"
  by (simp add: transitions_def)

lemma transisions_trans [trans]: "a \<rightarrow>* b \<Longrightarrow> b \<rightarrow>* c \<Longrightarrow> a \<rightarrow>* c"
  using transitions_def
  by (metis rtranclp_trans)

end


(*
    Author:   Benedikt Seidl
    License:  BSD
*)

section \<open>Asymmetric Variant of the Master Theorem\<close>

theory Asymmetric_Master_Theorem
imports
  Advice After
begin

text \<open>This variant of the Master Theorem fixes only a subset @{term Y}
      of @{term \<nu>LTL} subformulas and all conditions depend on the
      index @{term i}. While this does not lead to a simple DRA construction,
      but can be used to build NBAs and LDBAs.\<close>

lemma FG_advice_b1_helper:
  "\<psi> \<in> subfrmlsn \<phi> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<psi> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<psi>[\<F>\<G> \<phi> w]\<^sub>\<mu>"
proof -
  assume "\<psi> \<in> subfrmlsn \<phi>"

  then have "\<F>\<G> \<psi> (suffix i w) \<subseteq> \<F>\<G> \<phi> w"
    using \<F>\<G>_suffix subformulas\<^sub>\<nu>_subset unfolding \<F>\<G>_semantics' by fast

  moreover

  assume "suffix i w \<Turnstile>\<^sub>n \<psi>"

  ultimately show "suffix i w \<Turnstile>\<^sub>n \<psi>[\<F>\<G> \<phi> w]\<^sub>\<mu>"
    using FG_advice_b1 by blast
qed

lemma FG_advice_b2_helper:
  "S \<subseteq> \<G> \<phi> (suffix i w) \<Longrightarrow> i \<le> j \<Longrightarrow> suffix j w \<Turnstile>\<^sub>n \<psi>[S]\<^sub>\<mu> \<Longrightarrow> suffix j w \<Turnstile>\<^sub>n \<psi>"
proof -
  fix i j
  assume "S \<subseteq> \<G> \<phi> (suffix i w)" and "i \<le> j" and "suffix j w \<Turnstile>\<^sub>n \<psi>[S]\<^sub>\<mu>"

  then have "suffix j w \<Turnstile>\<^sub>n \<psi>[S \<inter> subformulas\<^sub>\<nu> \<psi>]\<^sub>\<mu>"
    using FG_advice_inter_subformulas by metis

  moreover

  have "S \<inter> subformulas\<^sub>\<nu> \<psi> \<subseteq> \<G> \<psi> (suffix i w)"
    using \<open>S \<subseteq> \<G> \<phi> (suffix i w)\<close> unfolding \<G>_semantics' by blast
  then have "S \<inter> subformulas\<^sub>\<nu> \<psi> \<subseteq> \<G> \<psi> (suffix j w)"
    using \<G>_suffix \<open>i \<le> j\<close> inf.absorb_iff2 le_Suc_ex by fastforce

  ultimately show "suffix j w \<Turnstile>\<^sub>n \<psi>"
    using FG_advice_b2 by blast
qed

lemma Y_\<G>:
  assumes
    Y_\<nu>: "Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
  and
    Y_G_1: "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>)"
  and
    Y_G_2: "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[Y]\<^sub>\<mu>)"
  shows
    "Y \<subseteq> \<G> \<phi> (suffix i w)"
proof -
  \<comment> \<open>Custom induction rule with @{term size} as a partial order\<close>
  note induct = finite_ranking_induct[where f = size]

  have "finite Y"
    using Y_\<nu> finite_subset subformulas\<^sub>\<nu>_finite by auto

  then show ?thesis
    using assms
  proof (induction Y rule: induct)
    case (insert \<psi> S)

    show ?case
    proof (cases "\<psi> \<notin> S")
      assume "\<psi> \<notin> S"

      note FG_advice_insert = FG_advice_insert[OF \<open>\<psi> \<notin> S\<close>]

      {
        \<comment> \<open>Show @{term "S \<subseteq> \<G> \<phi> (suffix i w)"}\<close>

        {
          fix \<psi>\<^sub>1 \<psi>\<^sub>2
          assume "\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> S"

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2[insert \<psi> S]\<^sub>\<mu>"
            using insert(5) by blast

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2[S]\<^sub>\<mu>"
            using \<open>\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> S\<close> FG_advice_insert insert.hyps(2)
            by fastforce
        }

        moreover

        {
          fix \<psi>\<^sub>1 \<psi>\<^sub>2
          assume "\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> S"

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[insert \<psi> S]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[insert \<psi> S]\<^sub>\<mu>)"
            using insert(6) by blast

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[S]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[S]\<^sub>\<mu>)"
            using \<open>\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> S\<close> FG_advice_insert insert.hyps(2)
            by fastforce
        }

        ultimately

        have "S \<subseteq> \<G> \<phi> (suffix i w)"
          using insert.IH insert.prems(1) by blast
      }

      moreover

      {
        \<comment> \<open>Show @{term "\<psi> \<in> \<G> \<phi> (suffix i w)"}\<close>

        have "\<psi> \<in> subformulas\<^sub>\<nu> \<phi>"
          using insert.prems(1) by fast
        then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>"
          using subformulas\<^sub>\<nu>_semantics
        proof (cases \<psi>)
          case (Release_ltln \<psi>\<^sub>1 \<psi>\<^sub>2)

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2[insert \<psi> S]\<^sub>\<mu>"
            using insert.prems(2) by blast
          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2[S]\<^sub>\<mu>"
            using Release_ltln FG_advice_insert by simp
          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2"
            using FG_advice_b2_helper[OF \<open>S \<subseteq> \<G> \<phi> (suffix i w)\<close>] by auto
          then show ?thesis
            using Release_ltln globally_release
            by blast
        next
          case (WeakUntil_ltln \<psi>\<^sub>1 \<psi>\<^sub>2)

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[insert \<psi> S]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[insert \<psi> S]\<^sub>\<mu>)"
            using insert.prems(3) by blast
          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2)[S]\<^sub>\<mu>"
            using WeakUntil_ltln FG_advice_insert by simp
          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2)"
            using FG_advice_b2_helper[OF \<open>S \<subseteq> \<G> \<phi> (suffix i w)\<close>, of _ "\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2"]
            by force
          then show ?thesis
            unfolding WeakUntil_ltln semantics_ltln.simps
            by (metis order_refl suffix_suffix)
        qed fast+

        then have "\<psi> \<in> \<G> \<phi> (suffix i w)"
          unfolding \<G>_semantics using \<open>\<psi> \<in> subformulas\<^sub>\<nu> \<phi>\<close>
          by simp
      }

      ultimately show ?thesis
        by blast
    next
      assume "\<not> \<psi> \<notin> S"
      then have "insert \<psi> S = S"
        by auto
      then show ?thesis
        using insert by simp
    qed
  qed simp
qed

theorem asymmetric_master_theorem_ltr:
  assumes
    "w \<Turnstile>\<^sub>n \<phi>"
  obtains Y and i where
    "Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
  and
    "suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[Y]\<^sub>\<mu>"
  and
    "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>)"
  and
    "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[Y]\<^sub>\<mu>)"
proof
  let ?Y = "\<F>\<G> \<phi> w"

  show "?Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
    by (rule \<F>\<G>_subformulas\<^sub>\<nu>)
next
  let ?Y = "\<F>\<G> \<phi> w"
  let ?i = "SOME i. ?Y = \<G> \<phi> (suffix i w)"

  have "suffix ?i w \<Turnstile>\<^sub>n af \<phi> (prefix ?i w)"
    using af_ltl_continuation \<open>w \<Turnstile>\<^sub>n \<phi>\<close> by fastforce
  then show "suffix ?i w \<Turnstile>\<^sub>n af \<phi> (prefix ?i w)[?Y]\<^sub>\<mu>"
    by (metis \<F>\<G>_suffix FG_advice_b1 \<F>\<G>_af order_refl)
next
  let ?Y = "\<F>\<G> \<phi> w"
  let ?i = "SOME i. ?Y = \<G> \<phi> (suffix i w)"

  have "\<exists>i. ?Y = \<G> \<phi> (suffix i w)"
    using suffix_\<nu>_stable \<F>\<G>_suffix unfolding \<nu>_stable_def MOST_nat
    by fast
  then have Y_G: "?Y = \<G> \<phi> (suffix ?i w)"
    by (metis (mono_tags, lifting) someI_ex)

  show "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> ?Y \<longrightarrow> suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2[?Y]\<^sub>\<mu>)"
  proof safe
    fix \<psi>\<^sub>1 \<psi>\<^sub>2
    assume "\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> ?Y"

    then have "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2)"
      using Y_G \<G>_semantics' by blast
    then have "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2"
      by force

    moreover

    have "\<psi>\<^sub>2 \<in> subfrmlsn \<phi>"
      using \<F>\<G>_subfrmlsn \<open>\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> ?Y\<close> subfrmlsn_subset by force

    ultimately show "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2 [?Y]\<^sub>\<mu>)"
      using FG_advice_b1_helper by fastforce
  qed
next
  let ?Y = "\<F>\<G> \<phi> w"
  let ?i = "SOME i. ?Y = \<G> \<phi> (suffix i w)"

  have "\<exists>i. ?Y = \<G> \<phi> (suffix i w)"
    using suffix_\<nu>_stable \<F>\<G>_suffix unfolding \<nu>_stable_def MOST_nat
    by fast
  then have Y_G: "?Y = \<G> \<phi> (suffix ?i w)"
    by (rule someI_ex)

  show "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> ?Y \<longrightarrow> suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[?Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[?Y]\<^sub>\<mu>)"
  proof safe
    fix \<psi>\<^sub>1 \<psi>\<^sub>2
    assume "\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> ?Y"

    then have "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2)"
      using Y_G \<G>_semantics' by blast
    then have "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2)"
      by force

    moreover

    have "\<psi>\<^sub>1 \<in> subfrmlsn \<phi>" and "\<psi>\<^sub>2 \<in> subfrmlsn \<phi>"
      using \<F>\<G>_subfrmlsn \<open>\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> ?Y\<close> subfrmlsn_subset by force+

    ultimately show "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[?Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[?Y]\<^sub>\<mu>)"
      using FG_advice_b1_helper by fastforce
  qed
qed

theorem asymmetric_master_theorem_rtl:
  assumes
    1: "Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
  and
    2: "suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[Y]\<^sub>\<mu>"
  and
    3: "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>)"
  and
    4: "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[Y]\<^sub>\<mu>)"
  shows
    "w \<Turnstile>\<^sub>n \<phi>"
proof -
  have "suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)"
    by (metis assms Y_\<G> FG_advice_b2 \<G>_af)

  then show "w \<Turnstile>\<^sub>n \<phi>"
    using af_ltl_continuation by force
qed

theorem asymmetric_master_theorem:
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow>
    (\<exists>i. \<exists>Y \<subseteq> subformulas\<^sub>\<nu> \<phi>.
      suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[Y]\<^sub>\<mu>
      \<and> (\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>))
      \<and> (\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[Y]\<^sub>\<mu>)))"
  by (metis asymmetric_master_theorem_ltr asymmetric_master_theorem_rtl)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2013         |
            |                   June 2013  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Domain_F
imports Domain_T Set_F
begin

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

         1.
         2.
         3.
         4.

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

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)
(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]

(***********************************************************
                 type def (Stable Failure)
 ***********************************************************)

(* types 'a domTsetF = "'a domT * 'a setF"       (* synonym *)  2011 *)
type_synonym 'a domTsetF = "'a domT * 'a setF"

definition
  HC_T2    :: "'a domTsetF => bool"
  where
  HC_T2_def :
    "HC_T2 TF == ALL s X. (s, X) :f (snd TF)
                --> s :t (fst TF)"

definition
  HC_T3    :: "'a domTsetF => bool"
  where
  HC_T3_def :
    "HC_T3 TF == ALL s. s ^^^ <Tick> :t (fst TF) & noTick s
                --> (ALL X. (s ^^^ <Tick>, X) :f (snd TF))"

definition
  HC_F3    :: "'a domTsetF => bool"
  where
  HC_F3_def :
    "HC_F3 TF == ALL s X Y. (s, X) :f (snd TF) & noTick s &
                          (ALL a. a : Y --> s ^^^ <a> ~:t fst TF)
                --> (s, X Un Y) :f (snd TF)"

definition
  HC_F4    :: "'a domTsetF => bool"
  where
  HC_F4_def :
    "HC_F4 TF == ALL s. s ^^^ <Tick> :t (fst TF) & noTick s
                --> (s, Evset) :f (snd TF)"

definition
  HC_T3_F4 :: "'a domTsetF => bool"
  where
  HC_T3_F4_def :
    "HC_T3_F4 TF == ALL s. s ^^^ <Tick> :t (fst TF) & noTick s
                    --> ((s, Evset) :f (snd TF) &
                         (ALL X. (s ^^^ <Tick>, X) :f (snd TF)))"

lemma HC_T3_F4_iff : "HC_T3_F4 TF = (HC_T3 TF & HC_F4 TF)"
apply (simp add: HC_T3_F4_def HC_T3_def HC_F4_def)
by (auto)

(*** BOT in domF ***)

lemma BOT_T2_T3_F3_F4: "HC_T2({<>}t , {}f) & HC_F3({<>}t , {}f) &
                        HC_T3_F4({<>}t , {}f)"
by (auto simp add: HC_T2_def HC_F3_def HC_T3_F4_def)

(**************************************************
           Type domF (Stable-Failures model)
 **************************************************)

definition "domF  = {SF::('a domTsetF). HC_T2(SF) & HC_T3(SF) & HC_F3(SF) & HC_F4(SF)}"
typedef 'a domF = "domF :: 'a domTsetF set"
apply (rule_tac x ="({<>}t , {}f)" in exI)
apply (simp add: domF_def)
by (simp add: BOT_T2_T3_F3_F4 HC_T3_F4_iff[THEN sym])

declare Rep_domF         [simp]

lemma domF_iff: "domF = {SF. HC_T2 SF & HC_F3 SF & HC_T3_F4 SF}"
by (auto simp add: domF_def HC_T3_F4_iff)

(*********************************************************
          The relation (<=) is defined over domF
 *********************************************************)

instantiation domF :: (type) ord
begin
definition
  subdomF_def:
    "SF <= SE  ==  (Rep_domF SF) <= (Rep_domF SE)"
definition
  psubdomF_def:
    "SF <  SE  ==  (Rep_domF SF) <  (Rep_domF SE)"

instance
by (intro_classes)
end

(*********************************************************
          The relation (<=) is a partial order
 *********************************************************)

instance domF :: (type) order
apply (intro_classes)
apply (unfold subdomF_def psubdomF_def)
apply (auto)
apply (simp add: Rep_domF_inject)
done

(***********************************************************
                          lemmas
 ***********************************************************)

(*******************************
              basic
 *******************************)

(*** T2 ***)

lemma domTsetF_T2:
    "[| TF : domF ; (s, X) :f snd TF |] ==> s :t fst TF"
by (auto simp add: domF_def HC_T2_def)

lemma domF_T2:
    "[| (T,F) : domF ; (s, X) :f F |] ==> s :t T"
by (auto simp add: domF_def HC_T2_def)

(*** T3 ***)

lemma domTsetF_T3:
  "[| TF : domF ; s ^^^ <Tick> :t fst TF ; noTick s |]
   ==> (s ^^^ <Tick>, X) :f snd TF"
by (simp add: domF_def HC_T3_def)

lemma domF_T3:
  "[| (T,F) : domF ; s ^^^ <Tick> :t T ; noTick s |]
   ==> (s ^^^ <Tick>, X) :f F"
by (simp add: domF_def HC_T3_def)

(*** F3 ***)

lemma domTsetF_F3:
  "[| TF : domF ; (s, X) :f snd TF ; noTick s ;
      (ALL a. a : Y --> s ^^^ <a> ~:t fst TF) |]
   ==> (s, X Un Y) :f snd TF"
by (simp add: domF_def HC_F3_def)

lemma domF_F3:
  "[| (T,F) : domF ; (s, X) :f F ; noTick s ;
      (ALL a. a : Y --> s ^^^ <a> ~:t T) |]
   ==> (s, X Un Y) :f F"
by (simp add: domF_def HC_F3_def)

(*** F4 ***)

lemma domTsetF_F4:
  "[| TF : domF ; s ^^^ <Tick> :t fst TF ; noTick s |]
   ==> (s, Evset) :f snd TF"
by (simp add: domF_def HC_F4_def)

lemma domF_F4:
  "[| (T,F) : domF ; s ^^^ <Tick> :t T ; noTick s |]
   ==> (s, Evset) :f F"
by (simp add: domF_def HC_F4_def)

(*** T3_F4 ***)

lemma domTsetF_T3_F4:
  "[| TF : domF ; s ^^^ <Tick> :t fst TF ; noTick s |]
   ==> (s, Evset) :f snd TF & (ALL X. (s ^^^ <Tick>, X) :f snd TF)"
by (simp add: domF_iff HC_T3_F4_def)

lemma domF_T3_F4:
  "[| (T,F) : domF ; s ^^^ <Tick> :t T ; noTick s |]
   ==> (s, Evset) :f F & (ALL X. (s ^^^ <Tick>, X) :f F)"
by (simp add: domF_iff HC_T3_F4_def)

(*** F2_F4 ***)

lemma domTsetF_F2_F4:
  "[| TF : domF ; s ^^^ <Tick> :t fst TF ; noTick s ; X <= Evset |]
   ==> (s, X) :f snd TF"
apply (simp add: domF_def HC_F4_def)
by (auto intro: memF_F2)

lemma domF_F2_F4:
  "[| (T,F) : domF ; s ^^^ <Tick> :t T ; noTick s ; X <= Evset |]
   ==> (s, X) :f F"
apply (insert domTsetF_F2_F4[of "(T,F)" s X])
by (simp)

(*******************************
         check in domF
 *******************************)

(*** ({<>}t, {}f) ***)

lemma BOT_in_domF[simp]: "({<>}t, {}f) : domF"
by (simp add: domF_iff BOT_T2_T3_F3_F4)

(*******************************
       BOT is the bottom
 *******************************)

lemma BOT_is_bottom_domF[simp]: "({<>}t , {}f) <= SF"
by (simp add: order_pair_def)

(***********************************************************
                   operators on domF
 ***********************************************************)

definition
  pairF :: "'a domT => 'a setF => 'a domF"  ("(0_ ,,/ _)" [51,52] 0)
  where
  pairF_def : "(T ,, F) == Abs_domF (T, F)"

definition
  fstF  :: "'a domF => 'a domT"
  where
  fstF_def  : "fstF     == fst o Rep_domF"

definition
  sndF  :: "'a domF => 'a setF"
  where
  sndF_def  : "sndF     == snd o Rep_domF"

(***********************************************************
                     pairSF lemmas
 ***********************************************************)

lemma fold_fstF: "fst (Rep_domF SF) = fstF SF"
by (simp add: fstF_def comp_def)

lemma fold_sndF: "snd (Rep_domF SF) = sndF SF"
by (simp add: sndF_def comp_def)

lemma pairF_fstF: "(S,F) : domF ==> fstF (S,,F) = S"
apply (simp add: pairF_def fstF_def)
by (simp add: Abs_domF_inverse)

lemma pairF_sndF: "(S,F) : domF ==> sndF (S,,F) = F"
apply (simp add: pairF_def sndF_def)
by (simp add: Abs_domF_inverse)

lemma eqF_decompo:
  "(SF = SE) = (fstF SF = fstF SE & sndF SF = sndF SE)"
apply (simp add: Rep_domF_inject[THEN sym])
apply (simp add: pair_eq_decompo)
apply (simp add: fstF_def sndF_def)
done

lemmas pairF = pairF_fstF pairF_sndF eqF_decompo

lemma mono_fstF: "mono fstF"
apply (simp add: mono_def)
apply (simp add: fstF_def)
apply (simp add: subdomF_def)
apply (simp add: order_pair_def)
done

lemma mono_sndF: "mono sndF"
apply (simp add: mono_def)
apply (simp add: sndF_def)
apply (simp add: subdomF_def)
apply (simp add: order_pair_def)
done

(*********************************************************
           Healthiness conditions for pairF
 *********************************************************)

lemma pairF_domF_T2:
    "(s, X) :f sndF SF ==> s :t fstF SF"
apply (simp add: sndF_def fstF_def)
apply (rule domF_T2[of _ "snd (Rep_domF SF)"])
by (simp_all)

lemma pairF_domF_T3:
  "[| s ^^^ <Tick> :t fstF SF ; noTick s |]
   ==> (s ^^^ <Tick>, X) :f sndF SF"
apply (simp add: sndF_def fstF_def)
apply (rule domF_T3[of "fst (Rep_domF SF)" "snd (Rep_domF SF)"])
by (simp_all)

lemma pairF_domF_T3_Tick:
  "<Tick> :t fstF SF ==> (<Tick>, X) :f sndF SF"
apply (insert pairF_domF_T3[of "<>" SF X])
by (simp)

lemma pairF_domF_F4:
  "[| s ^^^ <Tick> :t fstF SF ; noTick s |]
   ==> (s, Evset) :f sndF SF"
apply (simp add: sndF_def fstF_def)
apply (rule domF_F4[of "fst (Rep_domF SF)" "snd (Rep_domF SF)"])
by (simp_all)

lemma pairF_domF_F3:
  "[| (s, X) :f sndF SF ; noTick s ;
      (ALL a. a : Y --> s ^^^ <a> ~:t fstF SF) |]
   ==> (s, X Un Y) :f sndF SF"
apply (simp add: sndF_def fstF_def)
apply (rule domF_F3[of "fst (Rep_domF SF)" "snd (Rep_domF SF)"])
by (simp_all)

lemma pairF_domF_F3I:
  "[| (s, X) :f sndF SF ; noTick s ;
      (ALL a. a : Y --> s ^^^ <a> ~:t fstF SF) ;
      Z = X Un Y |]
   ==> (s, Z) :f sndF SF"
by (simp add: pairF_domF_F3)

(*** F2_F4 ***)

lemma pairF_domF_F2_F4:
  "[| s ^^^ <Tick> :t fstF SF ; noTick s ; X <= Evset|]
   ==> (s, X) :f sndF SF"
apply (rule memF_F2[of _ "Evset"])
apply (rule pairF_domF_F4)
by (simp_all)

(*** T2_T3 ***)

lemma pairF_domF_T2_T3:
  "[| (s ^^^ <Tick>, X) :f sndF SF ; noTick s |]
  ==> (s ^^^ <Tick>, Y) :f sndF SF"
apply (rule pairF_domF_T3)
apply (rule pairF_domF_T2)
by (simp_all)

(*********************************************************
                     fstF and sndF
 *********************************************************)

lemma fstF_sndF_in_domF[simp]: "(fstF SF , sndF SF) : domF"
apply (simp add: domF_iff)
apply (simp add: HC_T2_def HC_F3_def HC_T3_F4_def)
apply (intro conjI)
apply (intro allI impI)
apply (elim exE)
apply (simp add: pairF_domF_T2)
apply (intro allI impI)
apply (elim conjE)
apply (simp add: pairF_domF_F3)
apply (intro allI impI)
apply (elim conjE)
apply (simp add: pairF_domF_T3 pairF_domF_F4)
done

lemma fstF_sndF_domF[simp]: "(fstF SF ,, sndF SF) = SF"
by (simp add: pairF)

(*********************************************************
                      subdomF
 *********************************************************)

lemma subdomF_decompo:
  "(SF <= SE) = (fstF SF <= fstF SE & sndF SF <= sndF SE)"
apply (simp add: subdomF_def)
apply (simp add: order_pair_def)
apply (simp add: fstF_def sndF_def)
done

(*********************************************************
                define max F from T
 *********************************************************)

definition
 maxFof :: "'a domT => 'a setF"
 where
 maxFof_def: "maxFof T == {f. EX s. (EX X. f = (s, X)) & s :t T}f"

(* in setF *)

lemma maxFof_setF: "{f. EX s. (EX X. f = (s, X)) & s :t T} : setF"
by (simp add: setF_def HC_F2_def)

(* in maxFof *)

lemma in_maxFof:
  "(f :f maxFof T) = (EX s. (EX X. f = (s, X)) & s :t T)"
apply (simp add: maxFof_def)
apply (simp add: memF_def)
apply (simp add: maxFof_setF Abs_setF_inverse)
done

(* in domF *)

lemma maxFof_domF: "(T, maxFof T) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: HC_T2_def HC_F3_def HC_T3_F4_def in_maxFof)
apply (intro allI impI)
apply (elim conjE)
apply (rule memT_prefix_closed)
apply (simp)
apply (simp)
done

(* max *)

lemma maxFof_max: "s :t T ==> (s,X) :f maxFof T"
by (simp add: in_maxFof)

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]

end


theory Map_Map_E2
imports "$HETS_ISABELLE_LIB/MainHC" "List" "$HETS_LIB/Isabelle/RestrictOpProps"
uses "$HETS_ISABELLE_LIB/prelude"
begin

ML "Header.initialize
    [\"Ax1\", \"Ax2\", \"Ax3\", \"Ax4\", \"Ax1_5\", \"Ax2_6\",
     \"Ax3_7\"]"

consts
X_filter :: "'a list => ('a => bool) => 'a list"
X_map :: "('a => 'b partial) => 'a list => 'b list partial"

axioms
Ax1 [rule_format] :
"ALL (f :: 'a => 'b partial). X_map f [] = makePartial []"

Ax2 [rule_format] :
"ALL (f :: 'a => 'b partial).
 ALL (l :: 'a list).
 ALL (x :: 'a).
 X_map f (Cons x l) =
 unpackPartial mapPartial (mapPartial Cons (f x)) (X_map f l)"

Ax3 [rule_format] :
"ALL (P :: 'a => bool).
 ALL (l :: 'a list).
 ALL (x :: 'a).
 X_filter (Cons x l) P =
 (if P x then Cons x (X_filter l P) else X_filter l P)"

Ax4 [rule_format] : "ALL (P :: 'a => bool). X_filter [] P = []"

declare Ax1 [simp]
declare Ax4 [simp]

theorem Ax1_5 :
"ALL (P :: 'a => bool).
 ALL (f :: 'a => 'a partial).
 ALL (l :: 'a list).
 defOp (X_map f l) --> defOp (X_map f (X_filter l P))"
apply (rule allI)+
apply (induct_tac l)
apply (simp add: Ax1 Ax2 Ax3 Ax4)
apply (simp add: Ax1 Ax2 Ax3 Ax4)
sorry

ML "Header.record \"Ax1_5\""

theorem Ax2_6 :
"ALL (Q :: 'a => bool).
 ALL (f :: 'a => 'a partial).
 ALL (l :: 'a list).
 defOp (X_map f l) -->
 X_map f (X_filter l (% h. lift2bool Q (f h))) =
 unpack2partial id (mapPartial X_filter (X_map f l)) Q"
apply (rule allI)+
apply (induct_tac l)
apply (simp)
(*apply (simp add: Ax3 Ax2)*)
sorry

ML "Header.record \"Ax2_6\""

theorem Ax3_7 :
"ALL (f :: 'a => 'a partial).
 ALL (l :: 'a list).
 ALL (x :: 'a).
 defOp (f x) -->
 defOp (unpack2partial id (mapPartial Cons (f x)) l)"
apply (auto)
sorry

ML "Header.record \"Ax3_7\""

end


section {*L\_ATS\_determHIST\_DB*}
theory
  L_ATS_determHIST_DB

imports
  PRJ_06_04__ENTRY

begin

locale ATS_determHIST_DB =
  ATS_History
  "TSstructure :: 'TSstructure \<Rightarrow> bool"
  "configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "initial_configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "step_labels :: 'TSstructure \<Rightarrow> 'label set"
  "step_relation :: 'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'label \<Rightarrow> 'conf \<Rightarrow> bool"
  "histories :: 'TSstructure \<Rightarrow> 'history set"
  "history_fragments :: 'TSstructure \<Rightarrow> 'history_fragment set"
  "empty_history :: 'TSstructure \<Rightarrow> 'history"
  "empty_history_fragment :: 'TSstructure \<Rightarrow> 'history_fragment"
  "set_history :: 'conf \<Rightarrow> 'history \<Rightarrow> 'conf"
  "extend_history :: 'history \<Rightarrow> 'history_fragment \<Rightarrow> 'history"
  "join_history_fragments :: 'history_fragment \<Rightarrow> 'history_fragment \<Rightarrow> 'history_fragment"
  "get_history :: 'conf \<Rightarrow> 'history"
  +
  ATS_SchedF_DB
  "TSstructure :: 'TSstructure \<Rightarrow> bool"
  "configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "initial_configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "step_labels :: 'TSstructure \<Rightarrow> 'label set"
  "step_relation :: 'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'label \<Rightarrow> 'conf \<Rightarrow> bool"
  "effects :: 'TSstructure \<Rightarrow> 'event set"
  "marking_condition :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> bool"
  "marked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "unmarked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "fixed_schedulers :: 'TSstructure \<Rightarrow> 'fixed_scheduler set"
  "empty_fixed_scheduler :: 'TSstructure \<Rightarrow> 'fixed_scheduler"
  "fixed_scheduler_extendable :: 'TSstructure \<Rightarrow> 'fixed_scheduler \<Rightarrow> bool"
  "get_fixed_scheduler_DB :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> nat \<Rightarrow> 'fixed_scheduler"
  for
    TSstructure configurations initial_configurations step_labels step_relation effects marking_condition marked_effect unmarked_effect histories history_fragments empty_history empty_history_fragment set_history extend_history join_history_fragments get_history fixed_schedulers empty_fixed_scheduler fixed_scheduler_extendable get_fixed_scheduler_DB

context ATS_determHIST_DB begin

definition is_forward_edge_deterministicHist_DB_long :: "'TSstructure \<Rightarrow> bool" where
  "is_forward_edge_deterministicHist_DB_long G \<equiv> (
  \<forall>c d n. derivation_initial G d \<and> get_configuration(d n) = Some c
  \<longrightarrow> (\<forall>c1 c2 e1 e2 w1 w2.
  w1 \<in> history_fragments G
  \<and> w2 \<in> history_fragments G
  \<and> step_relation G c e1 c1
  \<and> step_relation G c e2 c2
  \<and> get_history c1 = extend_history (get_history c) w1
  \<and> get_history c2 = extend_history (get_history c) w2
  \<and> ((history_fragment_prefixes G w1 \<subseteq> history_fragment_prefixes G w2
  \<and> fixed_scheduler_extendable G (get_fixed_scheduler_DB G (derivation_append d (der2 c e1 c1) n) (Suc n)))
  \<or> (history_fragment_prefixes G w2 \<subseteq> history_fragment_prefixes G w1
  \<and> fixed_scheduler_extendable G (get_fixed_scheduler_DB G (derivation_append d (der2 c e2 c2) n) (Suc n)))
  \<or> (history_fragment_prefixes G w2 = history_fragment_prefixes G w1))
  \<longrightarrow> e1=e2))"

definition compatible_history_fragment_DB :: "
  'TSstructure \<Rightarrow> ('label,'conf)derivation \<Rightarrow> nat \<Rightarrow> 'conf \<Rightarrow> 'conf \<Rightarrow> 'conf \<Rightarrow> 'label \<Rightarrow> 'label \<Rightarrow> bool"
  where
    "compatible_history_fragment_DB G d n c c1 c2 e1 e2 \<equiv>
  \<exists>w1 w2.
  w1 \<in> history_fragments G
  \<and> w2 \<in> history_fragments G
  \<and> get_history c1 = extend_history (get_history c) w1
  \<and> get_history c2 = extend_history (get_history c) w2
  \<and> (let
  d1 = derivation_append d (der2 c e1 c1) n;
  d2 = derivation_append d (der2 c e2 c2) n;
  pw1 = history_fragment_prefixes G w1;
  pw2 = history_fragment_prefixes G w2;
  ext1 = fixed_scheduler_extendable G (get_fixed_scheduler_DB G d1 (Suc n));
  ext2 = fixed_scheduler_extendable G (get_fixed_scheduler_DB G d2 (Suc n))
  in
  ((pw1 \<subseteq> pw2 \<and> ext1) \<or> (pw2 \<subseteq> pw1 \<and> ext2) \<or> (pw1 = pw2)))"

definition is_forward_edge_deterministicHist_DB :: "'TSstructure \<Rightarrow> bool" where
  "is_forward_edge_deterministicHist_DB G \<equiv>
  \<forall>d n c.
  derivation_initial G d
  \<longrightarrow> get_configuration (d n) = Some c
  \<longrightarrow> (\<forall>c1 c2 e1 e2.
  step_relation G c e1 c1
  \<longrightarrow> step_relation G c e2 c2
  \<longrightarrow> compatible_history_fragment_DB G d n c c1 c2 e1 e2
  \<longrightarrow> e1 = e2)"

corollary is_forward_edge_deterministicHist_DB_vs_is_forward_edge_deterministicHist_DB_long: "
  is_forward_edge_deterministicHist_DB G = is_forward_edge_deterministicHist_DB_long G"
  apply(simp add: is_forward_edge_deterministicHist_DB_def is_forward_edge_deterministicHist_DB_long_def Let_def compatible_history_fragment_DB_def)
  apply(rule antisym)
   apply(clarsimp)
   apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
   apply(erule_tac
      x="d"
      in allE)
   apply(clarsimp)
   apply(erule_tac
      x="n"
      in allE)
   apply(clarsimp)
   apply(erule_tac
      x="c1"
      in allE)
   apply(erule_tac
      x="c2"
      in allE)
   apply(erule_tac
      x="e1"
      in allE)
   apply(clarsimp)
   apply(erule_tac
      x="e2"
      in allE)
   apply(clarsimp)
   apply(erule_tac
      x="w1"
      in allE)
   apply(clarsimp)
   apply(erule_tac
      x="w2"
      in allE)
   apply(erule impE)
    apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
    prefer 2
    apply(force)
   apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
   apply(force)
  apply(clarsimp)
  apply(rename_tac d n c c1 c2 e1 e2 w1 w2)(*strict*)
  apply(erule_tac
      x="c"
      in allE)
  apply(erule_tac
      x="d"
      in allE)
  apply(erule_tac
      x="n"
      in allE)
  apply(clarsimp)
  apply(erule_tac
      x="c1"
      in allE)
  apply(erule_tac
      x="c2"
      in allE)
  apply(erule_tac
      x="e1"
      in allE)
  apply(erule_tac
      x="e2"
      in allE)
  apply(clarsimp)
  apply(erule_tac
      x="w1"
      in allE)
  apply(clarsimp)
  apply(erule_tac
      x="w2"
      in allE)
  apply(clarsimp)
  apply(force)
  done

lemma is_forward_edge_deterministic_accessible_implies_is_forward_edge_deterministicHist_DB_long: "
  TSstructure G
  \<Longrightarrow> is_forward_edge_deterministic_accessible G
  \<Longrightarrow> is_forward_edge_deterministicHist_DB_long G"
  apply(simp add: is_forward_edge_deterministic_accessible_def is_forward_edge_deterministicHist_DB_long_def)
  apply(clarsimp)
  apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
  apply(erule_tac
      x="c"
      in ballE)
   apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
   apply(force)
  apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
  apply(simp add: get_accessible_configurations_def)
  done

definition is_forward_target_deterministicHist_DB_long :: "'TSstructure \<Rightarrow> bool" where
  "is_forward_target_deterministicHist_DB_long G \<equiv> (
  \<forall>c d n. derivation_initial G d \<and> get_configuration(d n) = Some c
  \<longrightarrow> (\<forall>c1 c2 e w1 w2.
  w1 \<in> history_fragments G
  \<and> w2 \<in> history_fragments G
  \<and> step_relation G c e c1
  \<and> step_relation G c e c2
  \<and> get_history c1 = extend_history (get_history c) w1
  \<and> get_history c2 = extend_history (get_history c) w2
  \<and> ((history_fragment_prefixes G w1 \<subseteq> history_fragment_prefixes G w2
  \<and> fixed_scheduler_extendable G (get_fixed_scheduler_DB G (derivation_append d (der2 c e c1) n) (Suc n)))
  \<or> (history_fragment_prefixes G w2 \<subseteq> history_fragment_prefixes G w1
  \<and> fixed_scheduler_extendable G (get_fixed_scheduler_DB G (derivation_append d (der2 c e c2) n) (Suc n)))
  \<or> (history_fragment_prefixes G w2 = history_fragment_prefixes G w1))
  \<longrightarrow> c1=c2))"

definition is_forward_target_deterministicHist_DB :: "'TSstructure \<Rightarrow> bool" where
  "is_forward_target_deterministicHist_DB G \<equiv>
  \<forall>d n c.
  derivation_initial G d
  \<longrightarrow> get_configuration (d n) = Some c
  \<longrightarrow> (\<forall>c1 c2 e.
  step_relation G c e c1
  \<longrightarrow> step_relation G c e c2
  \<longrightarrow> compatible_history_fragment_DB G d n c c1 c2 e e
  \<longrightarrow> c1 = c2)"

corollary is_forward_target_deterministicHist_DB_vs_is_forward_target_deterministicHist_DB_long: "
is_forward_target_deterministicHist_DB G = is_forward_target_deterministicHist_DB_long G"
  apply(simp add: is_forward_target_deterministicHist_DB_def is_forward_target_deterministicHist_DB_long_def compatible_history_fragment_DB_def Let_def)
  apply(rule antisym)
   apply(clarsimp)
   apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
   apply(erule_tac
      x="d"
      in allE)
   apply(clarsimp)
   apply(erule_tac
      x="n"
      in allE)
   apply(erule_tac
      x="c"
      in allE)
   apply(clarsimp)
   apply(erule_tac
      x="c1"
      in allE)
   apply(erule_tac
      x="c2"
      in allE)
   apply(clarsimp)
   apply(erule_tac
      x="e"
      in allE)
   apply(clarsimp)
   apply(erule_tac
      x="w1"
      in allE)
   apply(clarsimp)
   apply(erule_tac
      x="w2"
      in allE)
   apply(clarsimp)
   apply(force)
  apply(clarsimp)
  apply(rename_tac d n c c1 c2 e w1 w2)(*strict*)
  apply(erule_tac
      x="c"
      in allE)
  apply(erule_tac
      x="d"
      in allE)
  apply(erule_tac
      x="n"
      in allE)
  apply(clarsimp)
  apply(erule_tac
      x="c1"
      in allE)
  apply(erule_tac
      x="c2"
      in allE)
  apply(erule impE)
   apply(rename_tac d n c c1 c2 e w1 w2)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac d n c c1 c2 e w1 w2)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      x="e"
      in exI)
  apply(rule_tac
      x="w1"
      in exI)
  apply(clarsimp)
  apply(rule_tac
      x="w2"
      in exI)
  apply(clarsimp)
  done

lemma is_forward_target_deterministic_accessible_implies_is_forward_target_deterministicHist_DB_long: "
  TSstructure G
  \<Longrightarrow> is_forward_target_deterministic_accessible G
  \<Longrightarrow> is_forward_target_deterministicHist_DB_long G"
  apply(simp add: is_forward_target_deterministic_accessible_def is_forward_target_deterministicHist_DB_long_def)
  apply(clarsimp)
  apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
  apply(erule_tac
      x="c"
      in ballE)
   apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
   apply(force)
  apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
  apply(simp add: get_accessible_configurations_def)
  done

definition is_forward_deterministicHist_DB :: "'TSstructure \<Rightarrow> bool" where
  "is_forward_deterministicHist_DB G \<equiv> is_forward_target_deterministicHist_DB_long G \<and> is_forward_edge_deterministicHist_DB_long G"

end

end


(*

Copyright (c) 2017, ETH Zurich
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this
   list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

(*<*)
theory MipsTLBEquivalence
  imports Main Set MipsTLB MipsTLBPageTable MipsTLBReplacementHandler MipsTLBLarge
begin
(*>*)

(* ========================================================================= *)
section "Equivalence to Large TLB"
(* ========================================================================= *)

text "Next we show that for all valid TLBs the TLB with replacement handler
      behaves as if its  "

lemma TLBEquivalence :
    assumes inrange: "vpn < MIPSPT_EntriesMax"
        and inrange2: "as < ASIDMax"
        and cap: "capacity (tlb mpt) > 0"
        and valid: "MipsTLBPT_valid mpt"
  shows "MipsTLBPT_translate mpt as vpn =
         MIPSTLB_translate (MipsTLBLarge_create (pte mpt)) as vpn"
proof -
  from valid have ptvalid: "MIPSPT_valid (pte mpt)"
    by(simp add:MipsTLBPT_valid_def)

  from ptvalid inrange inrange2 have X0:
    " MIPSTLB_translate (MipsTLBLarge_create (pte mpt)) as vpn =
     (if (v ((entry (pte mpt)) vpn as)) then {(pfn ((entry (pte mpt)) vpn as))} else {})"
    by(simp add:MipsTLBLarge_translate_is)

  from valid inrange inrange2 cap have X1:
    "MipsTLBPT_translate mpt as vpn =  (if (v ((entry (pte mpt)) vpn as)) then {(pfn ((entry  (pte mpt)) vpn as))} else {})"
    by(simp add:MipsTLBPT_translate_is)

  from X0 X1 show ?thesis by(auto)
qed

(* ========================================================================= *)
section "Equivalence in decoding net nodes"
(* ========================================================================= *)

text "First we define a few helper functions that convert virtual addresses
     into (asid, vpn, offset)"

definition addr2vpn :: "addr \<Rightarrow> VPN"
  where "addr2vpn a = ((fst a) mod VASize) div 4096"

definition addr2asid :: "addr \<Rightarrow> ASID"
  where "addr2asid a = (fst a) div VASize"

definition pfn2addr :: "PFN \<Rightarrow> addr \<Rightarrow> addr"
  where "pfn2addr p va = (p * 4096 + (fst va) mod 4096, {})"

text "A virtual address is valid, if it's representable by the available bits
      i.e.. 8-bit ASID and 40-bit Address"

definition AddrValid :: "addr \<Rightarrow> bool"
  where "AddrValid a = ((fst a) < VASize * ASIDMax)"

text "If the address is valid, then extracting the ASID and VPN is within the well
      defined ranges."

lemma AddrValid_implies_inrange :
  "AddrValid a \<Longrightarrow> addr2vpn a < MIPSPT_EntriesMax"
  by(auto simp:addr2vpn_def AddrValid_def VASize_def ASIDMax_def MIPSPT_EntriesMax_def)

lemma AddrValid_implies_inrange2 :
  "AddrValid a \<Longrightarrow> addr2asid a < ASIDMax"
  by(auto simp:addr2asid_def AddrValid_def VASize_def ASIDMax_def MIPSPT_EntriesMax_def)

(* ------------------------------------------------------------------------- *)
subsection "Lifting methods"
(* ------------------------------------------------------------------------- *)

text "We construct decoding net nodes for both, the large TLB and the
      replacement handler by using their translate functions"

definition MipsTLBPT_to_node :: "nodeid \<Rightarrow> MipsTLBPT \<Rightarrow> node"
  where "MipsTLBPT_to_node nid mpt =  \<lparr>
          accept = {},
          translate = (\<lambda>a.
            (if AddrValid a then
              (\<Union>x\<in> (MipsTLBPT_translate mpt (addr2asid a) (addr2vpn a)). {(nid, pfn2addr x a)} )
            else {} ))  \<rparr>"

definition MIPSLARGE_to_node :: "nodeid \<Rightarrow> MIPSTLB \<Rightarrow> node"
  where "MIPSLARGE_to_node nid t =  \<lparr>
          accept = {},
          translate = (\<lambda>a.
            (if AddrValid a then
              (\<Union>x\<in> (MIPSTLB_translate t (addr2asid a) (addr2vpn a)). {(nid, pfn2addr x a)} )
             else {} ))  \<rparr>"

(* ------------------------------------------------------------------------- *)
subsection "Equivalence Proof of lifted nodes"
(* ------------------------------------------------------------------------- *)

text "We first define a lemma that shows that if the address is valid, then the
      set of translated addresses  are the same. "

lemma translate_function_equivalent :
  assumes cap: "capacity (tlb mpt) > 0"
      and valid: "MipsTLBPT_valid mpt"
      and avalid: "AddrValid a"
    shows "(\<Union>x\<in>MipsTLBPT_translate mpt (addr2asid a) (addr2vpn a).
                {(nid, pfn2addr x a)})  =
           (\<Union>x\<in>MIPSTLB_translate (MipsTLBLarge_create (pte mpt)) (addr2asid a) (addr2vpn a).
                {(nid, pfn2addr x a)})"
proof -
  from avalid have X0: "addr2asid a < ASIDMax"
    by(auto simp:AddrValid_implies_inrange2)

  from avalid have X1 : "addr2vpn a < MIPSPT_EntriesMax"
    by(auto simp:AddrValid_implies_inrange)

  from X0 X1 cap valid show ?thesis
    by(auto simp: TLBEquivalence)
qed

text "Next, we use the lemma above to proof that the two nodes will be the same."

lemma
  assumes cap: "capacity (tlb mpt) > 0"
      and valid: "MipsTLBPT_valid mpt"
  shows "MipsTLBPT_to_node nid mpt =
         MIPSLARGE_to_node nid (MipsTLBLarge_create (pte mpt))"
proof -
  have X0:
    "MipsTLBPT_to_node nid mpt =  \<lparr>
      accept = {},
      translate = \<lambda>a. if AddrValid a
        then \<Union>x\<in>MipsTLBPT_translate mpt (addr2asid a) (addr2vpn a). {(nid, pfn2addr x a)}
        else {}\<rparr>"
    by(simp add:MipsTLBPT_to_node_def)

  have X1:
    "MIPSLARGE_to_node nid (MipsTLBLarge_create (pte mpt)) =  \<lparr>
      accept = {},
      translate = \<lambda>a. if AddrValid a
        then \<Union>x\<in>MIPSTLB_translate (MipsTLBLarge_create (pte mpt))
                       (addr2asid a) (addr2vpn a). {(nid, pfn2addr x a)}
        else {}\<rparr>"
    by(simp add:MIPSLARGE_to_node_def)

  from cap valid have X2:
    "\<And>a. (if AddrValid a then \<Union>x\<in>MipsTLBPT_translate mpt (addr2asid a) (addr2vpn a).
             {(nid, pfn2addr x a)} else {}) =
          (if AddrValid a then \<Union>x\<in>MIPSTLB_translate (MipsTLBLarge_create (pte mpt))
             (addr2asid a) (addr2vpn a). {(nid, pfn2addr x a)} else {})"
    by(auto simp:translate_function_equivalent)

  from X0 cap valid have X3:
    "\<lparr>accept = {},
     translate = \<lambda>a.
        if AddrValid a
          then \<Union>x\<in>MipsTLBPT_translate mpt (addr2asid a) (addr2vpn a). {(nid, pfn2addr x a)}
        else {} \<rparr> =
      \<lparr>accept = {},
       translate = \<lambda>a.
        if AddrValid a
          then \<Union>x\<in>MIPSTLB_translate (MipsTLBLarge_create (pte mpt))
                          (addr2asid a) (addr2vpn a). {(nid, pfn2addr x a)}
        else {}\<rparr>"
    by(simp only:X2)

  from X0 X1 X2 show ?thesis by(auto)
qed

end