(*  Title:      HOL/Auth/n_german_lemma_inv__38_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

(*header{*The n_german Protocol Case Study*}*)

theory n_german_lemma_inv__38_on_rules imports n_german_lemma_on_inv__38
begin
section{*All lemmas on causal relation between inv__38*}
lemma lemma_inv__38_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__38  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__0Vsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__1Vsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqSVsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqEVsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__0Vsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__38) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__38) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory PolicyExample
imports Noninterference
begin

(* This first example_auth_graphample shows how notifications and endpoints differ.
   Endpoints tend to spray information in all directions, while
   notifications are unidirectional.

   This example is a subset of the SAC example from access *)
datatype auth_graph_label = T | NTFN1 | NTFN2 | CTR | C | EP | RM

abbreviation partition_label where
  "partition_label x \<equiv> OrdinaryLabel x"

definition example_auth_graph :: "(auth_graph_label subject_label \<times> auth \<times> auth_graph_label subject_label) set" where
  "example_auth_graph \<equiv>
   { (partition_label T,Notify,partition_label NTFN1),
     (partition_label CTR,Receive,partition_label NTFN1),
     (partition_label C,Read,partition_label CTR),
     (partition_label C,Write,partition_label CTR),
     (partition_label CTR,Read,partition_label C),
     (partition_label CTR,Write,partition_label C),
     (partition_label CTR,SyncSend,partition_label EP),
     (partition_label T,Notify,partition_label NTFN2),
     (partition_label RM,Receive,partition_label NTFN2),
     (partition_label RM,Receive,partition_label EP)
   } \<union> {(a,b,c). a = c}"

declare example_auth_graph_def [simp]

lemma subjectReads_T:
  "subjectReads example_auth_graph (partition_label T) = {partition_label T}"
  apply(auto simp: reads_lrefl elim: subjectReads.induct)
  done

lemma CTR_in_subjectReads_NTFN1:
  "partition_label CTR \<in> subjectReads example_auth_graph (partition_label NTFN1)"
  apply(rule read_sync_ep_read_receivers[where ep="partition_label NTFN1"], auto intro: reads_lrefl)
  done

lemma EP_in_subjectReads_NTFN1:
  "partition_label EP \<in> subjectReads example_auth_graph (partition_label NTFN1)"
  apply(rule reads_read_queued_thread_read_ep[where t="partition_label CTR" and a="partition_label EP"], auto intro: CTR_in_subjectReads_NTFN1[simplified])
  done

lemma C_in_subjectReads_NTFN1:
  "partition_label C \<in> subjectReads example_auth_graph (partition_label NTFN1)"
  apply(rule reads_read_thread_read_pages, auto intro: CTR_in_subjectReads_NTFN1[simplified])
  done

lemma RM_in_subjectReads_NTFN1:
  "partition_label RM \<in> subjectReads example_auth_graph (partition_label NTFN1)"
  apply(rule read_sync_ep_read_receivers, auto intro: EP_in_subjectReads_NTFN1[simplified])
  done

lemma NTFN2_in_subjectReads_NTFN1:
  "partition_label NTFN2 \<in> subjectReads example_auth_graph (partition_label NTFN1)"
  apply(rule reads_read_queued_thread_read_ep[where t="partition_label RM" and a="partition_label NTFN2"], auto intro: RM_in_subjectReads_NTFN1[simplified])
  done

lemmas subjectReads_NTFN1' = reads_lrefl[of "partition_label NTFN1"]
                            CTR_in_subjectReads_NTFN1
                            EP_in_subjectReads_NTFN1
                            RM_in_subjectReads_NTFN1
                            C_in_subjectReads_NTFN1
                            NTFN2_in_subjectReads_NTFN1

lemma subjectReads_NTFN1:
  "subjectReads example_auth_graph (partition_label NTFN1) = {partition_label NTFN1, partition_label CTR, partition_label EP, partition_label C, partition_label RM, partition_label NTFN2}"
  apply(rule equalityI)
   apply (rule subsetI)
   apply (erule subjectReads.induct)
           apply (fastforce simp: subjectReads_NTFN1'[simplified])+
  done

lemma RM_in_subjectReads_NTFN2:
  "partition_label RM \<in> subjectReads example_auth_graph (partition_label NTFN2)"
  apply(rule read_sync_ep_read_receivers[where ep="partition_label NTFN2"], auto intro: reads_lrefl)
  done

lemma EP_in_subjectReads_NTFN2:
  "partition_label EP \<in> subjectReads example_auth_graph (partition_label NTFN2)"
  apply(rule reads_read_queued_thread_read_ep[where t="partition_label RM" and a="partition_label EP"], auto intro: RM_in_subjectReads_NTFN2[simplified])
  done

lemma CTR_in_subjectReads_NTFN2:
  "partition_label CTR \<in> subjectReads example_auth_graph (partition_label NTFN2)"
  apply(rule read_sync_ep_read_senders[where ep="partition_label EP" and a="partition_label EP"], auto intro: EP_in_subjectReads_NTFN2[simplified])
  done

lemma C_in_subjectReads_NTFN2:
  "partition_label C \<in> subjectReads example_auth_graph (partition_label NTFN2)"
  apply(rule reads_read_thread_read_pages, auto intro: CTR_in_subjectReads_NTFN2[simplified])
  done

lemma NTFN1_in_subjectReads_NTFN2:
  "partition_label NTFN1 \<in> subjectReads example_auth_graph (partition_label NTFN2)"
  apply(rule reads_read_queued_thread_read_ep[where t="partition_label CTR" and a="partition_label NTFN1"], auto intro: CTR_in_subjectReads_NTFN2[simplified])
  done

lemmas subjectReads_NTFN2' = reads_lrefl[of "partition_label NTFN2"]
                            CTR_in_subjectReads_NTFN2
                            EP_in_subjectReads_NTFN2
                            RM_in_subjectReads_NTFN2
                            C_in_subjectReads_NTFN2
                            NTFN1_in_subjectReads_NTFN2

lemma subjectReads_NTFN2:
  "subjectReads example_auth_graph (partition_label NTFN2) = {partition_label NTFN2, partition_label NTFN1, partition_label C, partition_label CTR, partition_label RM, partition_label EP}"
  apply(rule equalityI)
   apply (rule subsetI)
   apply (erule subjectReads.induct)
           apply (fastforce simp: subjectReads_NTFN2'[simplified])+
  done

lemma EP_in_subjectReads_CTR:
  "partition_label EP \<in> subjectReads example_auth_graph (partition_label CTR)"
  apply(rule_tac a="partition_label CTR" and t="partition_label CTR" in reads_read_queued_thread_read_ep)
      apply (auto intro: reads_lrefl)
  done

lemma RM_in_subjectReads_CTR:
  "partition_label RM \<in> subjectReads example_auth_graph (partition_label CTR)"
  apply(clarsimp)
  apply(rule_tac ep="partition_label EP" and auth="SyncSend" in read_sync_ep_read_receivers)
     apply blast
    apply blast
   apply(rule EP_in_subjectReads_CTR[simplified])
  apply fastforce
  done

lemma C_in_subjectReads_CTR:
  "partition_label C \<in> subjectReads example_auth_graph (partition_label CTR)"
  apply(rule reads_read, auto)
  done

lemma NTFN1_in_subjectReads_CTR:
  "partition_label NTFN1 \<in> subjectReads example_auth_graph (partition_label CTR)"
  apply(rule_tac t="partition_label CTR" and auth="Receive" and a="partition_label T" and auth'="Notify" in reads_read_queued_thread_read_ep)
  apply (auto intro: reads_lrefl)
  done

lemma NTFN2_in_subjectReads_CTR:
  "partition_label NTFN2 \<in> subjectReads example_auth_graph (partition_label CTR)"
  apply(rule_tac t="partition_label RM" and auth="Receive" and a="partition_label T" and auth'="Notify" in reads_read_queued_thread_read_ep)
  apply (auto intro: RM_in_subjectReads_CTR[simplified])
  done

lemmas subjectReads_CTR' = reads_lrefl[of "partition_label CTR"]
                           NTFN2_in_subjectReads_CTR NTFN1_in_subjectReads_CTR
                           C_in_subjectReads_CTR RM_in_subjectReads_CTR EP_in_subjectReads_CTR

lemma subjectReads_CTR:
  "subjectReads example_auth_graph (partition_label CTR) = {partition_label CTR,partition_label C,partition_label EP, partition_label RM, partition_label NTFN1, partition_label NTFN2}"
  apply(clarsimp)
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectReads.induct)
           apply(auto)[9]
  apply(auto simp: subjectReads_CTR'[simplified])
  done

lemma NTFN1_in_subjectReads_C:
  "partition_label NTFN1 \<in> subjectReads example_auth_graph (partition_label C)"
  apply(rule_tac a="partition_label T" and ep="partition_label NTFN1" and t="partition_label CTR" in reads_read_queued_thread_read_ep)
      apply (auto intro: reads_read)
  done

lemma EP_in_subjectReads_C:
  "partition_label EP \<in> subjectReads example_auth_graph (partition_label C)"
  apply(rule_tac a="partition_label CTR" and t="partition_label CTR" in reads_read_queued_thread_read_ep)
      apply (auto intro: reads_read)
  done

lemma RM_in_subjectReads_C:
  "partition_label RM \<in> subjectReads example_auth_graph (partition_label C)"
  apply(clarsimp)
  apply(rule_tac a="partition_label CTR" in read_sync_ep_read_receivers[OF _ _ EP_in_subjectReads_C[simplified]])
    apply simp+
  done

lemma CTR_in_subjectReads_C:
  "partition_label CTR \<in> subjectReads example_auth_graph (partition_label C)"
  apply(rule reads_read, auto)
  done

lemma NTFN2_in_subjectReads_C:
  "partition_label NTFN2 \<in> subjectReads example_auth_graph (partition_label C)"
  apply(rule_tac a="partition_label T" and ep="partition_label NTFN2" and t="partition_label RM" in reads_read_queued_thread_read_ep)
  apply(fastforce simp: RM_in_subjectReads_C[simplified])+
  done

lemmas subjectReads_C' = reads_lrefl[of "partition_label C"]
                         NTFN2_in_subjectReads_C NTFN1_in_subjectReads_C
                         RM_in_subjectReads_C EP_in_subjectReads_C CTR_in_subjectReads_C

lemma subjectReads_C:
  "subjectReads example_auth_graph (partition_label C) = {partition_label C,partition_label CTR,partition_label NTFN1, partition_label EP, partition_label RM, partition_label NTFN2}"
  apply(clarsimp)
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectReads.induct)
           apply(auto)[9]
  apply(auto simp: subjectReads_C'[simplified])
  done

lemma CTR_in_subjectReads_EP:
  "partition_label CTR \<in> subjectReads example_auth_graph (partition_label EP)"
  apply(clarsimp)
  apply(rule_tac a="partition_label RM" and ep="partition_label EP" in read_sync_ep_read_senders)
     apply (simp add: reads_lrefl)+
  done

lemma NTFN1_in_subjectReads_EP:
  "partition_label NTFN1 \<in> subjectReads example_auth_graph (partition_label EP)"
  apply(rule reads_read_queued_thread_read_ep[where a="partition_label NTFN1", OF _ _ _ _ CTR_in_subjectReads_EP])
  apply(auto)
  done

lemma C_in_subjectReads_EP:
  "partition_label C \<in> subjectReads example_auth_graph (partition_label EP)"
  apply(rule reads_read_thread_read_pages[OF CTR_in_subjectReads_EP])
  apply(auto)
  done

lemma RM_in_subjectReads_EP:
  "partition_label RM \<in> subjectReads example_auth_graph (partition_label EP)"
  apply(rule read_sync_ep_read_receivers[OF _ _ reads_lrefl])
  apply(auto)
  done

lemma NTFN2_in_subjectReads_EP:
  "partition_label NTFN2 \<in> subjectReads example_auth_graph (partition_label EP)"
  apply(rule reads_read_queued_thread_read_ep[where a="partition_label NTFN2", OF _ _ _ _ RM_in_subjectReads_EP])
  apply(auto)
  done

lemmas subjectReads_EP' = reads_lrefl[of "partition_label EP"]
                         CTR_in_subjectReads_EP
                         C_in_subjectReads_EP
                         RM_in_subjectReads_EP
                         NTFN2_in_subjectReads_EP
                         NTFN1_in_subjectReads_EP

lemma subjectReads_EP:
  "subjectReads example_auth_graph (partition_label EP) = {partition_label EP,partition_label CTR,partition_label NTFN1, partition_label C, partition_label RM, partition_label NTFN2}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectReads.induct)
           apply(auto)[9]
  apply(auto simp: subjectReads_EP'[simplified])
  done

lemma NTFN2_in_subjectReads_RM:
   "partition_label NTFN2 \<in> subjectReads example_auth_graph (partition_label RM)"
  apply(rule reads_ep, auto)
  done

lemma EP_in_subjectReads_RM:
   "partition_label EP \<in> subjectReads example_auth_graph (partition_label RM)"
  apply(rule reads_ep, auto)
  done

lemma CTR_in_subjectReads_RM:
   "partition_label CTR \<in> subjectReads example_auth_graph (partition_label RM)"
  apply(rule read_sync_ep_read_senders[where a="partition_label RM" and ep="partition_label EP", OF _ _ EP_in_subjectReads_RM], auto)
  done

lemma C_in_subjectReads_RM:
   "partition_label C \<in> subjectReads example_auth_graph (partition_label RM)"
  apply(rule reads_read_thread_read_pages[where t="partition_label CTR", OF CTR_in_subjectReads_RM], auto)
  done

lemma NTFN1_in_subjectReads_RM:
   "partition_label NTFN1 \<in> subjectReads example_auth_graph (partition_label RM)"
  apply(rule reads_read_queued_thread_read_ep[where a="partition_label T" and t="partition_label CTR", OF _ _ _ _ CTR_in_subjectReads_RM], auto)
  done

lemmas subjectReads_RM' = reads_lrefl[of "partition_label RM"]
                         CTR_in_subjectReads_RM
                         C_in_subjectReads_RM
                         EP_in_subjectReads_RM
                         NTFN1_in_subjectReads_RM
                         NTFN2_in_subjectReads_RM

lemma subjectReads_RM:
  "subjectReads example_auth_graph (partition_label RM) = {partition_label RM, partition_label NTFN2,partition_label EP,partition_label CTR, partition_label C, partition_label NTFN1}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectReads.induct)
           apply(auto)[9]
  apply(auto simp: subjectReads_RM'[simplified])
  done

lemma NTFN1_in_subjectAffects_T:
  "partition_label NTFN1 \<in> subjectAffects example_auth_graph (partition_label T)
" apply(auto intro: affects_ep)
  done

lemma NTFN2_in_subjectAffects_T:
  "partition_label NTFN2 \<in> subjectAffects example_auth_graph (partition_label T)
" apply(auto intro: affects_ep)
  done

lemma C_in_subjectAffects_T:
  "partition_label C \<in> subjectAffects example_auth_graph (partition_label T)
" apply(rule affects_send[where auth="Notify" and ep="partition_label NTFN1"], auto)
  done

lemma CTR_in_subjectAffects_T:
  "partition_label CTR \<in> subjectAffects example_auth_graph (partition_label T)
" apply(rule affects_send[where auth="Notify" and ep="partition_label NTFN1"], auto)
  done

lemma RM_in_subjectAffects_T:
  "partition_label RM \<in> subjectAffects example_auth_graph (partition_label T)
" apply(rule affects_send[where auth="Notify" and ep="partition_label NTFN2"], auto)
  done

lemma EP_in_subjectAffects_T:
  "partition_label EP \<in> subjectAffects example_auth_graph (partition_label T)"
  by (rule affects_ep_bound_trans, auto)

lemmas subjectAffects_T' = affects_lrefl[of "partition_label T"]
                           NTFN1_in_subjectAffects_T
                           NTFN2_in_subjectAffects_T
                           C_in_subjectAffects_T
                           CTR_in_subjectAffects_T
                           RM_in_subjectAffects_T
                           EP_in_subjectAffects_T

lemma subjectAffects_T:
  "subjectAffects example_auth_graph (partition_label T) = {partition_label NTFN1,partition_label NTFN2,partition_label T,partition_label C, partition_label CTR, partition_label RM, partition_label EP}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectAffects.cases)
           apply(fastforce+)[7]
    apply clarsimp
    apply (elim disjE conjE; simp)
  apply(auto simp: subjectAffects_T'[simplified])
  done

lemma CTR_in_subjectAffects_NTFN1:
  "partition_label CTR \<in> subjectAffects example_auth_graph (partition_label NTFN1)"
  apply(rule affects_send[where ep="partition_label NTFN1"], auto)
  done

lemma C_in_subjectAffects_NTFN1:
  "partition_label C \<in> subjectAffects example_auth_graph (partition_label NTFN1)"
  apply(rule affects_send[where ep="partition_label NTFN1"], auto)
  done

lemmas subjectAffects_NTFN1' = affects_lrefl[of "partition_label NTFN1"]
                           C_in_subjectAffects_NTFN1
                           CTR_in_subjectAffects_NTFN1

lemma subjectAffects_NTFN1:
  "subjectAffects example_auth_graph (partition_label NTFN1) = {partition_label NTFN1,partition_label CTR,partition_label C}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectAffects.cases)
           apply(auto)[7]
  apply(auto simp: subjectAffects_NTFN1'[simplified])
  done

lemma RM_in_subjectAffects_NTFN2:
  "partition_label RM \<in> subjectAffects example_auth_graph (partition_label NTFN2)"
  apply(rule affects_send[where ep="partition_label NTFN2"], auto)
  done

lemma EP_in_subjectAffects_NTFN2:
  "partition_label EP \<in> subjectAffects example_auth_graph (partition_label NTFN2)"
  apply(rule affects_ep_bound_trans, auto)
  done

lemmas subjectAffects_NTFN2' = affects_lrefl[of "partition_label NTFN2"]
                           RM_in_subjectAffects_NTFN2
                           EP_in_subjectAffects_NTFN2

lemma subjectAffects_NTFN2:
  "subjectAffects example_auth_graph (partition_label NTFN2) = {partition_label NTFN2,partition_label RM, partition_label EP}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectAffects.cases)
           apply(auto)[7]
   apply clarsimp
   apply (elim disjE conjE; simp)
  apply(auto simp: subjectAffects_NTFN2'[simplified])
  done

lemma C_in_subjectAffects_CTR:
  "partition_label C \<in> subjectAffects example_auth_graph (partition_label CTR)"
  apply(rule affects_write[where auth="Write"], auto)
  done

lemma EP_in_subjectAffects_CTR:
  "partition_label EP \<in> subjectAffects example_auth_graph (partition_label CTR)"
  apply(rule affects_ep, auto)
  done

lemma NTFN1_in_subjectAffects_CTR:
  "partition_label NTFN1 \<in> subjectAffects example_auth_graph (partition_label CTR)"
  apply(rule affects_ep, auto)
  done

lemma RM_in_subjectAffects_CTR:
  "partition_label RM \<in> subjectAffects example_auth_graph (partition_label CTR)"
  apply(rule affects_send, auto)
  done

lemmas subjectAffects_CTR' = affects_lrefl[of "partition_label CTR"]
                           NTFN1_in_subjectAffects_CTR
                           C_in_subjectAffects_CTR
                           EP_in_subjectAffects_CTR
                           RM_in_subjectAffects_CTR

lemma subjectAffects_CTR:
  "subjectAffects example_auth_graph (partition_label CTR) = {partition_label CTR,partition_label C,partition_label EP,partition_label NTFN1, partition_label RM}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectAffects.cases)
           apply(fastforce+)[7]
  apply(auto simp: subjectAffects_CTR'[simplified])
  done

lemma CTR_in_subjectAffects_C:
  "partition_label CTR \<in> subjectAffects example_auth_graph (partition_label C)"
  apply(rule affects_write[where auth=Write], auto)
  done

lemmas subjectAffects_C' = affects_lrefl[of "partition_label C"]
                           CTR_in_subjectAffects_C

lemma subjectAffects_C:
  "subjectAffects example_auth_graph (partition_label C) = {partition_label C,partition_label CTR}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectAffects.cases)
           apply(auto)[7]
  apply(auto simp: subjectAffects_C'[simplified])
  done

lemma RM_in_subjectAffects_EP:
  "partition_label RM \<in> subjectAffects example_auth_graph (partition_label EP)"
  apply(rule affects_send, auto)
  done

lemma CTR_in_subjectAffects_EP:
  "partition_label CTR \<in> subjectAffects example_auth_graph (partition_label EP)"
  apply(rule affects_recv, auto)
  done

lemma C_in_subjectAffects_EP:
  "partition_label C \<in> subjectAffects example_auth_graph (partition_label EP)"
  apply(rule affects_reset[where ep="partition_label EP" and l'="partition_label CTR"], auto)
  done

lemma NTFN2_in_subjectAffects_EP:
  "partition_label NTFN2 \<in> subjectAffects example_auth_graph (partition_label EP)"
  apply(rule affects_ep_bound_trans, auto)
  done

lemmas subjectAffects_EP' = affects_lrefl[of "partition_label EP"]
                           CTR_in_subjectAffects_EP
                           C_in_subjectAffects_EP
                           RM_in_subjectAffects_EP
                           NTFN2_in_subjectAffects_EP

lemma subjectAffects_EP:
  "subjectAffects example_auth_graph (partition_label EP) = {partition_label EP, partition_label RM, partition_label CTR, partition_label C, partition_label NTFN2}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectAffects.cases)
           apply(fastforce+)[7]
   apply clarsimp
   apply (elim conjE disjE; simp)
  apply(auto simp: subjectAffects_EP'[simplified])
  done

lemma EP_in_subjectAffects_RM:
  "partition_label EP \<in> subjectAffects example_auth_graph (partition_label RM)"
  apply(rule affects_ep, auto)
  done

lemma CTR_in_subjectAffects_RM:
  "partition_label CTR \<in> subjectAffects example_auth_graph (partition_label RM)"
  apply(rule affects_recv, auto)
  done

lemma NTFN2_in_subjectAffects_RM:
  "partition_label NTFN2 \<in> subjectAffects example_auth_graph (partition_label RM)"
  apply(rule affects_ep, auto)
  done

lemmas subjectAffects_RM' = affects_lrefl[of "partition_label RM"]
                            EP_in_subjectAffects_RM
                            NTFN2_in_subjectAffects_RM
                            CTR_in_subjectAffects_RM

lemma subjectAffects_RM:
  "subjectAffects example_auth_graph (partition_label RM) = {partition_label RM,partition_label EP,partition_label CTR,partition_label NTFN2}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectAffects.cases)
           apply(auto)[7]
  apply(auto simp: subjectAffects_RM'[simplified])
  done

lemmas subjectReads = subjectReads_T subjectReads_NTFN1 subjectReads_NTFN2 subjectReads_CTR
                      subjectReads_EP subjectReads_RM subjectReads_C

declare example_auth_graph_def [simp del]

lemma partsSubjectAffects_T:
  "partsSubjectAffects example_auth_graph T = {Partition T,Partition NTFN1, Partition NTFN2, Partition CTR, Partition C, Partition EP, Partition RM}"
  apply(auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def subjectReads subjectAffects_T | rename_tac xa, case_tac xa)+
  done

lemma partsSubjectAffects_NTFN1:
  "partsSubjectAffects example_auth_graph NTFN1 = {Partition NTFN1, Partition CTR, Partition C, Partition EP, Partition RM, Partition NTFN2}"
  apply(auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def subjectReads subjectAffects_NTFN1 | rename_tac xa, case_tac xa)+
  done

lemma partsSubjectAffects_NTFN2:
  "partsSubjectAffects example_auth_graph NTFN2 = {Partition NTFN2, Partition CTR, Partition C, Partition EP, Partition RM, Partition NTFN1}"
  apply(auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def subjectReads subjectAffects_NTFN2 | rename_tac xa, case_tac xa)+
  done

lemma partsSubjectAffects_CTR:
  "partsSubjectAffects example_auth_graph CTR = {Partition NTFN1, Partition CTR, Partition C, Partition EP, Partition RM, Partition NTFN2}"
  apply(auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def subjectReads subjectAffects_CTR | rename_tac xa, case_tac xa)+
  done

lemma partsSubjectAffects_C:
  "partsSubjectAffects example_auth_graph C = {Partition CTR, Partition C, Partition EP, Partition RM, Partition NTFN1, Partition NTFN2}"
  apply(auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def subjectReads subjectAffects_C | rename_tac xa, case_tac xa)+
  done

lemma partsSubjectAffects_EP:
  "partsSubjectAffects example_auth_graph EP = {Partition CTR, Partition C, Partition EP, Partition RM, Partition NTFN1, Partition NTFN2}"
  apply(auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def subjectReads subjectAffects_EP | rename_tac xa, case_tac xa)+
  done

lemma partsSubjectAffects_RM:
  "partsSubjectAffects example_auth_graph RM = {Partition CTR, Partition C, Partition EP, Partition RM, Partition NTFN2, Partition NTFN1}"
  apply(auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def subjectReads subjectAffects_RM | rename_tac xa, case_tac xa)+
  done

lemmas partsSubjectAffects = partsSubjectAffects_T partsSubjectAffects_NTFN1
                            partsSubjectAffects_NTFN2 partsSubjectAffects_CTR
                            partsSubjectAffects_C partsSubjectAffects_RM partsSubjectAffects_EP

definition example_policy :: "(auth_graph_label partition \<times> auth_graph_label partition) set" where
  "example_policy \<equiv> {(PSched,d)|d. True} \<union>
                    {(Partition l,Partition k)|l k. (k = T \<longrightarrow> l = T)}"

lemma "example_policy = policyFlows example_auth_graph"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(clarsimp simp: example_policy_def)
   apply(elim disjE)
    apply(fastforce intro: policy_scheduler)
   apply clarsimp
   apply (rule policy_affects)
   apply (case_tac "k = T")
    apply (clarsimp simp: partsSubjectAffects)
   apply(case_tac l, (auto simp: partsSubjectAffects | case_tac k)+)[1]
  apply(rule subsetI)
  apply(clarsimp simp: example_policy_def)
  apply(erule policyFlows.cases)
   apply(case_tac l, auto simp: partsSubjectAffects)
  done

(* This second example is a classic 'one way information flow'
   example, where information is allowed to flow from Low to High,
   but not the reverse. We consider a typical scenario where
   shared memory and an notification for notifications are used to
   implement a ring-buffer. *)
datatype auth_graph_label2 = High | Low | SharedPage | NTFN

definition example_auth_graph2 :: "(auth_graph_label2 subject_label \<times> auth \<times> auth_graph_label2 subject_label) set" where
  "example_auth_graph2 \<equiv>
   { (partition_label Low,Write,partition_label SharedPage),
     (partition_label Low,Read,partition_label SharedPage),
     (partition_label High,Read,partition_label SharedPage),
     (partition_label Low,Notify,partition_label NTFN),
     (partition_label High,Receive,partition_label NTFN)
   } \<union> {(x,a,y). x = y}"

declare example_auth_graph2_def [simp]

lemma subjectReads_Low: "subjectReads example_auth_graph2 (partition_label Low) = {partition_label Low,partition_label SharedPage}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectReads.induct, fastforce+)
  apply (auto intro: reads_lrefl reads_read)
  done

lemma subjectReads_SharedPage: "subjectReads example_auth_graph2 (partition_label SharedPage) = {partition_label Low,partition_label SharedPage}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectReads.induct, fastforce+)
  apply (auto intro: reads_lrefl reads_read_page_read_thread)
  done

lemma High_in_subjectReads_NTFN:
  "partition_label High \<in> subjectReads example_auth_graph2 (partition_label NTFN)"
  apply(rule read_sync_ep_read_receivers)
  apply(auto intro: reads_lrefl)
  done

lemma SharedPage_in_subjectReads_NTFN:
  "partition_label SharedPage \<in> subjectReads example_auth_graph2 (partition_label NTFN)"
  apply(rule reads_read_thread_read_pages[OF High_in_subjectReads_NTFN])
  apply(auto)
  done

lemma Low_in_subjectReads_NTFN:
  "partition_label Low \<in> subjectReads example_auth_graph2 (partition_label NTFN)"
  apply(rule reads_read_page_read_thread[OF SharedPage_in_subjectReads_NTFN])
  apply(auto)
  done

lemma subjectReads_NTFN: "subjectReads example_auth_graph2 (partition_label NTFN) = {partition_label NTFN,partition_label High,partition_label SharedPage, partition_label Low}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectReads.induct, fastforce+)
  apply (auto intro: High_in_subjectReads_NTFN Low_in_subjectReads_NTFN SharedPage_in_subjectReads_NTFN simp del: example_auth_graph2_def intro: reads_lrefl)
  done

lemma NTFN_in_subjectReads_High:
  "partition_label NTFN \<in> subjectReads example_auth_graph2 (partition_label High)"
  apply(fastforce intro: reads_ep)
  done

lemma SharedPage_in_subjectReads_High:
  "partition_label SharedPage \<in> subjectReads example_auth_graph2 (partition_label High)"
  apply(fastforce intro: reads_read_thread_read_pages reads_lrefl)
  done

lemma Low_in_subjectReads_High:
  "partition_label Low \<in> subjectReads example_auth_graph2 (partition_label High)"
  apply(fastforce intro: reads_read_page_read_thread[OF SharedPage_in_subjectReads_High])
  done

lemma subjectReads_High: "subjectReads example_auth_graph2 (partition_label High) = {partition_label High,partition_label NTFN, partition_label SharedPage,partition_label Low}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectReads.induct, fastforce+)
  apply(auto intro: reads_lrefl NTFN_in_subjectReads_High SharedPage_in_subjectReads_High Low_in_subjectReads_High simp del: example_auth_graph2_def)
  done

lemma SharedPage_in_subjectAffects_Low:
  "partition_label SharedPage \<in> subjectAffects example_auth_graph2 (partition_label Low)"
  apply(fastforce intro: affects_write)
  done

lemma NTFN_in_subjectAffects_Low:
  "partition_label NTFN \<in> subjectAffects example_auth_graph2 (partition_label Low)"
  apply(fastforce intro: affects_ep)
  done

lemma High_in_subjectAffects_Low:
  "partition_label High \<in> subjectAffects example_auth_graph2 (partition_label Low)"
  apply(rule affects_send[where ep="partition_label NTFN"])
  apply(auto)
  done

lemma subjectAffects_Low: "subjectAffects example_auth_graph2 (partition_label Low) = {partition_label Low,partition_label NTFN,partition_label SharedPage, partition_label High}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectAffects.induct, fastforce+)
  apply(auto intro: affects_lrefl SharedPage_in_subjectAffects_Low NTFN_in_subjectAffects_Low High_in_subjectAffects_Low simp del: example_auth_graph2_def)
  done

lemma subjectAffects_SharedPage: "subjectAffects example_auth_graph2 (partition_label SharedPage) = {partition_label SharedPage}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectAffects.induct, fastforce+)
  apply(auto intro: affects_lrefl)
  done

lemma High_in_subjectAffects_NTFN:
  "partition_label High \<in> subjectAffects example_auth_graph2 (partition_label NTFN)"
  apply(rule affects_send[where ep="partition_label NTFN"])
  apply auto
  done

lemma subjectAffects_NTFN: "subjectAffects example_auth_graph2 (partition_label NTFN) = {partition_label NTFN,partition_label High}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectAffects.induct, fastforce+)
  apply(auto intro: affects_lrefl High_in_subjectAffects_NTFN simp del: example_auth_graph2_def)
  done

lemma NTFN_in_subjectAffects_High:
  "partition_label NTFN \<in> subjectAffects example_auth_graph2 (partition_label High)"
  apply(fastforce intro: affects_ep)
  done

lemma subjectAffects_High: "subjectAffects example_auth_graph2 (partition_label High) = {partition_label NTFN,partition_label High}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(erule subjectAffects.induct, fastforce+)
  apply(auto intro: affects_lrefl NTFN_in_subjectAffects_High simp del: example_auth_graph2_def)
  done

lemmas subjectReads_2 = subjectReads_High subjectReads_Low subjectReads_NTFN subjectReads_SharedPage

declare example_auth_graph2_def [simp del]

lemma partsSubjectAffects_Low: "partsSubjectAffects example_auth_graph2 Low = {Partition Low, Partition High, Partition SharedPage, Partition NTFN}"
  apply(auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def subjectReads_2 subjectAffects_Low | case_tac xa, rename_tac xa)+
  done

lemma partsSubjectAffects_SharedPage: "partsSubjectAffects example_auth_graph2 SharedPage = {Partition SharedPage, Partition High, Partition Low, Partition NTFN}"
  apply(auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def subjectReads_2 subjectAffects_SharedPage | rename_tac xa, case_tac xa)+
  done

lemma partsSubjectAffects_NTFN: "partsSubjectAffects example_auth_graph2 NTFN = {Partition NTFN, Partition High}"
  apply(auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def subjectReads_2 subjectAffects_NTFN | rename_tac xa, case_tac xa)+
  done

lemma partsSubjectAffects_High: "partsSubjectAffects example_auth_graph2 High = {Partition High, Partition NTFN}"
  apply(auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def subjectReads_2 subjectAffects_High | rename_tac xa, case_tac xa)+
  done

lemmas partsSubjectAffects2 =
   partsSubjectAffects_High partsSubjectAffects_Low partsSubjectAffects_NTFN
   partsSubjectAffects_SharedPage

definition example_policy2 where
  "example_policy2 \<equiv> {(PSched, d)|d. True} \<union>
                     {(d,e). d = e} \<union>
                     {(Partition Low, Partition NTFN), (Partition Low, Partition SharedPage),
                      (Partition Low, Partition High)} \<union>
                     {(Partition SharedPage,Partition High), (Partition SharedPage, Partition Low),
                      (Partition SharedPage,Partition NTFN)} \<union>
                     {(Partition NTFN, Partition High)} \<union>
                     {(Partition High, Partition NTFN)}"

lemma "policyFlows example_auth_graph2 = example_policy2"
  apply(rule equalityI)
   apply(rule subsetI)
   apply(clarsimp simp: example_policy2_def)
   apply(erule policyFlows.cases)
    apply(case_tac l, auto simp: partsSubjectAffects2)[1]
   apply assumption
  apply(rule subsetI)
  apply(clarsimp simp: example_policy2_def)
  apply(elim disjE)
           apply(fastforce simp: partsSubjectAffects2 intro: policy_affects)+
   apply(fastforce intro: policy_scheduler)
  apply(fastforce intro: policyFlows_refl refl_onD)
  done

end


(*  Title:      HOL/Auth/n_germanSimp_lemma_inv__34_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_inv__34_on_rules imports n_germanSimp_lemma_on_inv__34
begin
section{*All lemmas on causal relation between inv__34*}
lemma lemma_inv__34_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__34) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqSVsinv__34) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqE__part__0Vsinv__34) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqE__part__1Vsinv__34) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__0Vsinv__34) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__34) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__34) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__34) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__34) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__34) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__34) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__34) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*  Title:      HOL/Bali/State.thy
    Author:     David von Oheimb
*)
subsection \<open>State for evaluation of Java expressions and statements\<close>

theory State
imports DeclConcepts
begin

text \<open>
design issues:
\begin{itemize}
\item all kinds of objects (class instances, arrays, and class objects)
  are handeled via a general object abstraction
\item the heap and the map for class objects are combined into a single table
  \<open>(recall (loc, obj) table \<times> (qtname, obj) table  ~=  (loc + qtname, obj) table)\<close>
\end{itemize}
\<close>

subsubsection "objects"

datatype  obj_tag =     \<comment>\<open>tag for generic object\<close>
          CInst qtname  \<comment>\<open>class instance\<close>
        | Arr  ty int   \<comment>\<open>array with component type and length\<close>
    \<comment>\<open>| CStat qtname   the tag is irrelevant for a class object,
                           i.e. the static fields of a class,
                           since its type is given already by the reference to
                           it (see below)\<close>

type_synonym vn = "fspec + int"                 \<comment>\<open>variable name\<close>
record  obj  =
          tag :: "obj_tag"                      \<comment>\<open>generalized object\<close>
          "values" :: "(vn, val) table"

translations
  (type) "fspec" <= (type) "vname \<times> qtname"
  (type) "vn"    <= (type) "fspec + int"
  (type) "obj"   <= (type) "\<lparr>tag::obj_tag, values::vn \<Rightarrow> val option\<rparr>"
  (type) "obj"   <= (type) "\<lparr>tag::obj_tag, values::vn \<Rightarrow> val option,\<dots>::'a\<rparr>"

definition
  the_Arr :: "obj option \<Rightarrow> ty \<times> int \<times> (vn, val) table"
  where "the_Arr obj = (SOME (T,k,t). obj = Some \<lparr>tag=Arr T k,values=t\<rparr>)"

lemma the_Arr_Arr [simp]: "the_Arr (Some \<lparr>tag=Arr T k,values=cs\<rparr>) = (T,k,cs)"
apply (auto simp: the_Arr_def)
done

lemma the_Arr_Arr1 [simp,intro,dest]:
 "\<lbrakk>tag obj = Arr T k\<rbrakk> \<Longrightarrow> the_Arr (Some obj) = (T,k,values obj)"
apply (auto simp add: the_Arr_def)
done

definition
  upd_obj :: "vn \<Rightarrow> val \<Rightarrow> obj \<Rightarrow> obj"
  where "upd_obj n v = (\<lambda>obj. obj \<lparr>values:=(values obj)(n\<mapsto>v)\<rparr>)"

lemma upd_obj_def2 [simp]:
  "upd_obj n v obj = obj \<lparr>values:=(values obj)(n\<mapsto>v)\<rparr>"
apply (auto simp: upd_obj_def)
done

definition
  obj_ty :: "obj \<Rightarrow> ty" where
  "obj_ty obj = (case tag obj of
                  CInst C \<Rightarrow> Class C
                | Arr T k \<Rightarrow> T.[])"

lemma obj_ty_eq [intro!]: "obj_ty \<lparr>tag=oi,values=x\<rparr> = obj_ty \<lparr>tag=oi,values=y\<rparr>"
by (simp add: obj_ty_def)

lemma obj_ty_eq1 [intro!,dest]:
  "tag obj = tag obj' \<Longrightarrow> obj_ty obj = obj_ty obj'"
by (simp add: obj_ty_def)

lemma obj_ty_cong [simp]:
  "obj_ty (obj \<lparr>values:=vs\<rparr>) = obj_ty obj"
by auto

lemma obj_ty_CInst [simp]:
 "obj_ty \<lparr>tag=CInst C,values=vs\<rparr> = Class C"
by (simp add: obj_ty_def)

lemma obj_ty_CInst1 [simp,intro!,dest]:
 "\<lbrakk>tag obj = CInst C\<rbrakk> \<Longrightarrow> obj_ty obj = Class C"
by (simp add: obj_ty_def)

lemma obj_ty_Arr [simp]:
 "obj_ty \<lparr>tag=Arr T i,values=vs\<rparr> = T.[]"
by (simp add: obj_ty_def)

lemma obj_ty_Arr1 [simp,intro!,dest]:
 "\<lbrakk>tag obj = Arr T i\<rbrakk> \<Longrightarrow> obj_ty obj = T.[]"
by (simp add: obj_ty_def)

lemma obj_ty_widenD:
 "G\<turnstile>obj_ty obj\<preceq>RefT t \<Longrightarrow> (\<exists>C. tag obj = CInst C) \<or> (\<exists>T k. tag obj = Arr T k)"
apply (unfold obj_ty_def)
apply (auto split: obj_tag.split_asm)
done

definition
  obj_class :: "obj \<Rightarrow> qtname" where
  "obj_class obj = (case tag obj of
                     CInst C \<Rightarrow> C
                   | Arr T k \<Rightarrow> Object)"

lemma obj_class_CInst [simp]: "obj_class \<lparr>tag=CInst C,values=vs\<rparr> = C"
by (auto simp: obj_class_def)

lemma obj_class_CInst1 [simp,intro!,dest]:
  "tag obj = CInst C \<Longrightarrow> obj_class obj = C"
by (auto simp: obj_class_def)

lemma obj_class_Arr [simp]: "obj_class \<lparr>tag=Arr T k,values=vs\<rparr> = Object"
by (auto simp: obj_class_def)

lemma obj_class_Arr1 [simp,intro!,dest]:
 "tag obj = Arr T k \<Longrightarrow> obj_class obj = Object"
by (auto simp: obj_class_def)

lemma obj_ty_obj_class: "G\<turnstile>obj_ty obj\<preceq> Class statC = G\<turnstile>obj_class obj \<preceq>\<^sub>C statC"
apply (case_tac "tag obj")
apply (auto simp add: obj_ty_def obj_class_def)
apply (case_tac "statC = Object")
apply (auto dest: widen_Array_Class)
done

subsubsection "object references"

type_synonym oref = "loc + qtname"         \<comment>\<open>generalized object reference\<close>
syntax
  Heap  :: "loc   \<Rightarrow> oref"
  Stat  :: "qtname \<Rightarrow> oref"

translations
  "Heap" => "CONST Inl"
  "Stat" => "CONST Inr"
  (type) "oref" <= (type) "loc + qtname"

definition
  fields_table :: "prog \<Rightarrow> qtname \<Rightarrow> (fspec \<Rightarrow> field \<Rightarrow> bool)  \<Rightarrow> (fspec, ty) table" where
  "fields_table G C P =
    map_option type \<circ> table_of (filter (case_prod P) (DeclConcepts.fields G C))"

lemma fields_table_SomeI:
"\<lbrakk>table_of (DeclConcepts.fields G C) n = Some f; P n f\<rbrakk>
 \<Longrightarrow> fields_table G C P n = Some (type f)"
apply (unfold fields_table_def)
apply clarsimp
apply (rule exI)
apply (rule conjI)
apply (erule map_of_filter_in)
apply assumption
apply simp
done

(* unused *)
lemma fields_table_SomeD': "fields_table G C P fn = Some T \<Longrightarrow>
  \<exists>f. (fn,f)\<in>set(DeclConcepts.fields G C) \<and> type f = T"
apply (unfold fields_table_def)
apply clarsimp
apply (drule map_of_SomeD)
apply auto
done

lemma fields_table_SomeD:
"\<lbrakk>fields_table G C P fn = Some T; unique (DeclConcepts.fields G C)\<rbrakk> \<Longrightarrow>
  \<exists>f. table_of (DeclConcepts.fields G C) fn = Some f \<and> type f = T"
apply (unfold fields_table_def)
apply clarsimp
apply (rule exI)
apply (rule conjI)
apply (erule table_of_filter_unique_SomeD)
apply assumption
apply simp
done

definition
  in_bounds :: "int \<Rightarrow> int \<Rightarrow> bool" ("(_/ in'_bounds _)" [50, 51] 50)
  where "i in_bounds k = (0 \<le> i \<and> i < k)"

definition
  arr_comps :: "'a \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a option"
  where "arr_comps T k = (\<lambda>i. if i in_bounds k then Some T else None)"

definition
  var_tys :: "prog \<Rightarrow> obj_tag \<Rightarrow> oref \<Rightarrow> (vn, ty) table" where
  "var_tys G oi r =
    (case r of
      Heap a \<Rightarrow> (case oi of
                   CInst C \<Rightarrow> fields_table G C (\<lambda>n f. \<not>static f) (+) empty
                 | Arr T k \<Rightarrow> empty (+) arr_comps T k)
    | Stat C \<Rightarrow> fields_table G C (\<lambda>fn f. declclassf fn = C \<and> static f)
                (+) empty)"

lemma var_tys_Some_eq:
 "var_tys G oi r n = Some T
  = (case r of
       Inl a \<Rightarrow> (case oi of
                   CInst C \<Rightarrow> (\<exists>nt. n = Inl nt \<and> fields_table G C (\<lambda>n f.
                               \<not>static f) nt = Some T)
                 | Arr t k \<Rightarrow> (\<exists> i. n = Inr i  \<and> i in_bounds k \<and> t = T))
     | Inr C \<Rightarrow> (\<exists>nt. n = Inl nt \<and>
                 fields_table G C (\<lambda>fn f. declclassf fn = C \<and> static f) nt
                  = Some T))"
apply (unfold var_tys_def arr_comps_def)
apply (force split: sum.split_asm sum.split obj_tag.split)
done

subsubsection "stores"

type_synonym globs               \<comment>\<open>global variables: heap and static variables\<close>
        = "(oref , obj) table"
type_synonym heap
        = "(loc  , obj) table"
(* type_synonym locals
        = "(lname, val) table" *) (* defined in Value.thy local variables *)

translations
 (type) "globs"  <= (type) "(oref , obj) table"
 (type) "heap"   <= (type) "(loc  , obj) table"
(*  (type) "locals" <= (type) "(lname, val) table" *)

datatype st = (* pure state, i.e. contents of all variables *)
         st globs locals

subsection "access"

definition
  globs :: "st \<Rightarrow> globs"
  where "globs = case_st (\<lambda>g l. g)"

definition
  locals :: "st \<Rightarrow> locals"
  where "locals = case_st (\<lambda>g l. l)"

definition heap :: "st \<Rightarrow> heap" where
 "heap s = globs s \<circ> Heap"

lemma globs_def2 [simp]: " globs (st g l) = g"
by (simp add: globs_def)

lemma locals_def2 [simp]: "locals (st g l) = l"
by (simp add: locals_def)

lemma heap_def2 [simp]:  "heap s a=globs s (Heap a)"
by (simp add: heap_def)

abbreviation val_this :: "st \<Rightarrow> val"
  where "val_this s == the (locals s This)"

abbreviation lookup_obj :: "st \<Rightarrow> val \<Rightarrow> obj"
  where "lookup_obj s a' == the (heap s (the_Addr a'))"

subsection "memory allocation"

definition
  new_Addr :: "heap \<Rightarrow> loc option" where
  "new_Addr h = (if (\<forall>a. h a \<noteq> None) then None else Some (SOME a. h a = None))"

lemma new_AddrD: "new_Addr h = Some a \<Longrightarrow> h a = None"
apply (auto simp add: new_Addr_def)
apply (erule someI)
done

lemma new_AddrD2: "new_Addr h = Some a \<Longrightarrow> \<forall>b. h b \<noteq> None \<longrightarrow> b \<noteq> a"
apply (drule new_AddrD)
apply auto
done

lemma new_Addr_SomeI: "h a = None \<Longrightarrow> \<exists>b. new_Addr h = Some b \<and> h b = None"
apply (simp add: new_Addr_def)
apply (fast intro: someI2)
done

subsection "initialization"

abbreviation init_vals :: "('a, ty) table \<Rightarrow> ('a, val) table"
  where "init_vals vs == map_option default_val \<circ> vs"

lemma init_arr_comps_base [simp]: "init_vals (arr_comps T 0) = empty"
apply (unfold arr_comps_def in_bounds_def)
apply (rule ext)
apply auto
done

lemma init_arr_comps_step [simp]:
"0 < j \<Longrightarrow> init_vals (arr_comps T  j    ) =
           init_vals (arr_comps T (j - 1))(j - 1\<mapsto>default_val T)"
apply (unfold arr_comps_def in_bounds_def)
apply (rule ext)
apply auto
done

subsection "update"

definition
  gupd :: "oref  \<Rightarrow> obj \<Rightarrow> st \<Rightarrow> st" ("gupd'(_\<mapsto>_')" [10, 10] 1000)
  where "gupd r obj = case_st (\<lambda>g l. st (g(r\<mapsto>obj)) l)"

definition
  lupd :: "lname \<Rightarrow> val \<Rightarrow> st \<Rightarrow> st" ("lupd'(_\<mapsto>_')" [10, 10] 1000)
  where "lupd vn v = case_st (\<lambda>g l. st g (l(vn\<mapsto>v)))"

definition
  upd_gobj :: "oref \<Rightarrow> vn \<Rightarrow> val \<Rightarrow> st \<Rightarrow> st"
  where "upd_gobj r n v = case_st (\<lambda>g l. st (chg_map (upd_obj n v) r g) l)"

definition
  set_locals  :: "locals \<Rightarrow> st \<Rightarrow> st"
  where "set_locals l = case_st (\<lambda>g l'. st g l)"

definition
  init_obj :: "prog \<Rightarrow> obj_tag \<Rightarrow> oref \<Rightarrow> st \<Rightarrow> st"
  where "init_obj G oi r = gupd(r\<mapsto>\<lparr>tag=oi, values=init_vals (var_tys G oi r)\<rparr>)"

abbreviation
  init_class_obj :: "prog \<Rightarrow> qtname \<Rightarrow> st \<Rightarrow> st"
  where "init_class_obj G C == init_obj G undefined (Inr C)"

lemma gupd_def2 [simp]: "gupd(r\<mapsto>obj) (st g l) = st (g(r\<mapsto>obj)) l"
apply (unfold gupd_def)
apply (simp (no_asm))
done

lemma lupd_def2 [simp]: "lupd(vn\<mapsto>v) (st g l) = st g (l(vn\<mapsto>v))"
apply (unfold lupd_def)
apply (simp (no_asm))
done

lemma globs_gupd [simp]: "globs  (gupd(r\<mapsto>obj) s) = globs s(r\<mapsto>obj)"
apply (induct "s")
by (simp add: gupd_def)

lemma globs_lupd [simp]: "globs  (lupd(vn\<mapsto>v ) s) = globs  s"
apply (induct "s")
by (simp add: lupd_def)

lemma locals_gupd [simp]: "locals (gupd(r\<mapsto>obj) s) = locals s"
apply (induct "s")
by (simp add: gupd_def)

lemma locals_lupd [simp]: "locals (lupd(vn\<mapsto>v ) s) = locals s(vn\<mapsto>v )"
apply (induct "s")
by (simp add: lupd_def)

lemma globs_upd_gobj_new [rule_format (no_asm), simp]:
  "globs s r = None \<longrightarrow> globs (upd_gobj r n v s) = globs s"
apply (unfold upd_gobj_def)
apply (induct "s")
apply auto
done

lemma globs_upd_gobj_upd [rule_format (no_asm), simp]:
"globs s r=Some obj\<longrightarrow> globs (upd_gobj r n v s) = globs s(r\<mapsto>upd_obj n v obj)"
apply (unfold upd_gobj_def)
apply (induct "s")
apply auto
done

lemma locals_upd_gobj [simp]: "locals (upd_gobj r n v s) = locals s"
apply (induct "s")
by (simp add: upd_gobj_def)

lemma globs_init_obj [simp]: "globs (init_obj G oi r s) t =
  (if t=r then Some \<lparr>tag=oi,values=init_vals (var_tys G oi r)\<rparr> else globs s t)"
apply (unfold init_obj_def)
apply (simp (no_asm))
done

lemma locals_init_obj [simp]: "locals (init_obj G oi r s) = locals s"
by (simp add: init_obj_def)

lemma surjective_st [simp]: "st (globs s) (locals s) = s"
apply (induct "s")
by auto

lemma surjective_st_init_obj:
 "st (globs (init_obj G oi r s)) (locals s) = init_obj G oi r s"
apply (subst locals_init_obj [THEN sym])
apply (rule surjective_st)
done

lemma heap_heap_upd [simp]:
  "heap (st (g(Inl a\<mapsto>obj)) l) = heap (st g l)(a\<mapsto>obj)"
apply (rule ext)
apply (simp (no_asm))
done
lemma heap_stat_upd [simp]: "heap (st (g(Inr C\<mapsto>obj)) l) = heap (st g l)"
apply (rule ext)
apply (simp (no_asm))
done
lemma heap_local_upd [simp]: "heap (st g (l(vn\<mapsto>v))) = heap (st g l)"
apply (rule ext)
apply (simp (no_asm))
done

lemma heap_gupd_Heap [simp]: "heap (gupd(Heap a\<mapsto>obj) s) = heap s(a\<mapsto>obj)"
apply (rule ext)
apply (simp (no_asm))
done
lemma heap_gupd_Stat [simp]: "heap (gupd(Stat C\<mapsto>obj) s) = heap s"
apply (rule ext)
apply (simp (no_asm))
done
lemma heap_lupd [simp]: "heap (lupd(vn\<mapsto>v) s) = heap s"
apply (rule ext)
apply (simp (no_asm))
done

lemma heap_upd_gobj_Stat [simp]: "heap (upd_gobj (Stat C) n v s) = heap s"
apply (rule ext)
apply (simp (no_asm))
apply (case_tac "globs s (Stat C)")
apply  auto
done

lemma set_locals_def2 [simp]: "set_locals l (st g l') = st g l"
apply (unfold set_locals_def)
apply (simp (no_asm))
done

lemma set_locals_id [simp]: "set_locals (locals s) s = s"
apply (unfold set_locals_def)
apply (induct_tac "s")
apply (simp (no_asm))
done

lemma set_set_locals [simp]: "set_locals l (set_locals l' s) = set_locals l s"
apply (unfold set_locals_def)
apply (induct_tac "s")
apply (simp (no_asm))
done

lemma locals_set_locals [simp]: "locals (set_locals l s) = l"
apply (unfold set_locals_def)
apply (induct_tac "s")
apply (simp (no_asm))
done

lemma globs_set_locals [simp]: "globs (set_locals l s) = globs s"
apply (unfold set_locals_def)
apply (induct_tac "s")
apply (simp (no_asm))
done

lemma heap_set_locals [simp]: "heap (set_locals l s) = heap s"
apply (unfold heap_def)
apply (induct_tac "s")
apply (simp (no_asm))
done

subsubsection "abrupt completion"

primrec the_Xcpt :: "abrupt \<Rightarrow> xcpt"
  where "the_Xcpt (Xcpt x) = x"

primrec the_Jump :: "abrupt => jump"
  where "the_Jump (Jump j) = j"

primrec the_Loc :: "xcpt \<Rightarrow> loc"
  where "the_Loc (Loc a) = a"

primrec the_Std :: "xcpt \<Rightarrow> xname"
  where "the_Std (Std x) = x"

definition
  abrupt_if :: "bool \<Rightarrow> abopt \<Rightarrow> abopt \<Rightarrow> abopt"
  where "abrupt_if c x' x = (if c \<and> (x = None) then x' else x)"

lemma abrupt_if_True_None [simp]: "abrupt_if True x None = x"
by (simp add: abrupt_if_def)

lemma abrupt_if_True_not_None [simp]: "x \<noteq> None \<Longrightarrow> abrupt_if True x y \<noteq> None"
by (simp add: abrupt_if_def)

lemma abrupt_if_False [simp]: "abrupt_if False x y = y"
by (simp add: abrupt_if_def)

lemma abrupt_if_Some [simp]: "abrupt_if c x (Some y) = Some y"
by (simp add: abrupt_if_def)

lemma abrupt_if_not_None [simp]: "y \<noteq> None \<Longrightarrow> abrupt_if c x y = y"
apply (simp add: abrupt_if_def)
by auto

lemma split_abrupt_if:
"P (abrupt_if c x' x) =
      ((c \<and> x = None \<longrightarrow> P x') \<and> (\<not> (c \<and> x = None) \<longrightarrow> P x))"
apply (unfold abrupt_if_def)
apply (split if_split)
apply auto
done

abbreviation raise_if :: "bool \<Rightarrow> xname \<Rightarrow> abopt \<Rightarrow> abopt"
  where "raise_if c xn == abrupt_if c (Some (Xcpt (Std xn)))"

abbreviation np :: "val \<Rightarrow> abopt \<Rightarrow> abopt"
  where "np v == raise_if (v = Null) NullPointer"

abbreviation check_neg :: "val \<Rightarrow> abopt \<Rightarrow> abopt"
  where "check_neg i' == raise_if (the_Intg i'<0) NegArrSize"

abbreviation error_if :: "bool \<Rightarrow> error \<Rightarrow> abopt \<Rightarrow> abopt"
  where "error_if c e == abrupt_if c (Some (Error e))"

lemma raise_if_None [simp]: "(raise_if c x y = None) = (\<not>c \<and> y = None)"
apply (simp add: abrupt_if_def)
by auto
declare raise_if_None [THEN iffD1, dest!]

lemma if_raise_if_None [simp]:
  "((if b then y else raise_if c x y) = None) = ((c \<longrightarrow> b) \<and> y = None)"
apply (simp add: abrupt_if_def)
apply auto
done

lemma raise_if_SomeD [dest!]:
  "raise_if c x y = Some z \<Longrightarrow> c \<and> z=(Xcpt (Std x)) \<and> y=None \<or> (y=Some z)"
apply (case_tac y)
apply (case_tac c)
apply (simp add: abrupt_if_def)
apply (simp add: abrupt_if_def)
apply auto
done

lemma error_if_None [simp]: "(error_if c e y = None) = (\<not>c \<and> y = None)"
apply (simp add: abrupt_if_def)
by auto
declare error_if_None [THEN iffD1, dest!]

lemma if_error_if_None [simp]:
  "((if b then y else error_if c e y) = None) = ((c \<longrightarrow> b) \<and> y = None)"
apply (simp add: abrupt_if_def)
apply auto
done

lemma error_if_SomeD [dest!]:
  "error_if c e y = Some z \<Longrightarrow> c \<and> z=(Error e) \<and> y=None \<or> (y=Some z)"
apply (case_tac y)
apply (case_tac c)
apply (simp add: abrupt_if_def)
apply (simp add: abrupt_if_def)
apply auto
done

definition
  absorb :: "jump \<Rightarrow> abopt \<Rightarrow> abopt"
  where "absorb j a = (if a=Some (Jump j) then None else a)"

lemma absorb_SomeD [dest!]: "absorb j a = Some x \<Longrightarrow> a = Some x"
by (auto simp add: absorb_def)

lemma absorb_same [simp]: "absorb j (Some (Jump j)) = None"
by (auto simp add: absorb_def)

lemma absorb_other [simp]: "a \<noteq> Some (Jump j) \<Longrightarrow> absorb j a = a"
by (auto simp add: absorb_def)

lemma absorb_Some_NoneD: "absorb j (Some abr) = None \<Longrightarrow> abr = Jump j"
  by (simp add: absorb_def)

lemma absorb_Some_JumpD: "absorb j s = Some (Jump j') \<Longrightarrow> j'\<noteq>j"
  by (simp add: absorb_def)

subsubsection "full program state"

type_synonym
  state = "abopt \<times> st"          \<comment>\<open>state including abruption information\<close>

translations
  (type) "abopt" <= (type) "abrupt option"
  (type) "state" <= (type) "abopt \<times> st"

abbreviation
  Norm :: "st \<Rightarrow> state"
  where "Norm s == (None, s)"

abbreviation (input)
  abrupt :: "state \<Rightarrow> abopt"
  where "abrupt == fst"

abbreviation (input)
  store :: "state \<Rightarrow> st"
  where "store == snd"

lemma single_stateE: "\<forall>Z. Z = (s::state) \<Longrightarrow> False"
apply (erule_tac x = "(Some k,y)" for k y in all_dupE)
apply (erule_tac x = "(None,y)" for y in allE)
apply clarify
done

lemma state_not_single: "All (op = (x::state)) \<Longrightarrow> R"
apply (drule_tac x = "(if abrupt x = None then Some x' else None, y)" for x' y in spec)
apply clarsimp
done

definition
  normal :: "state \<Rightarrow> bool"
  where "normal = (\<lambda>s. abrupt s = None)"

lemma normal_def2 [simp]: "normal s = (abrupt s = None)"
apply (unfold normal_def)
apply (simp (no_asm))
done

definition
  heap_free :: "nat \<Rightarrow> state \<Rightarrow> bool"
  where "heap_free n = (\<lambda>s. atleast_free (heap (store s)) n)"

lemma heap_free_def2 [simp]: "heap_free n s = atleast_free (heap (store s)) n"
apply (unfold heap_free_def)
apply simp
done

subsection "update"

definition
  abupd :: "(abopt \<Rightarrow> abopt) \<Rightarrow> state \<Rightarrow> state"
  where "abupd f = map_prod f id"

definition
  supd :: "(st \<Rightarrow> st) \<Rightarrow> state \<Rightarrow> state"
  where "supd = map_prod id"

lemma abupd_def2 [simp]: "abupd f (x,s) = (f x,s)"
by (simp add: abupd_def)

lemma abupd_abrupt_if_False [simp]: "\<And> s. abupd (abrupt_if False xo) s = s"
by simp

lemma supd_def2 [simp]: "supd f (x,s) = (x,f s)"
by (simp add: supd_def)

lemma supd_lupd [simp]:
 "\<And> s. supd (lupd vn v ) s = (abrupt s,lupd vn v (store s))"
apply (simp (no_asm_simp) only: split_tupled_all)
apply (simp (no_asm))
done

lemma supd_gupd [simp]:
 "\<And> s. supd (gupd r obj) s = (abrupt s,gupd r obj (store s))"
apply (simp (no_asm_simp) only: split_tupled_all)
apply (simp (no_asm))
done

lemma supd_init_obj [simp]:
 "supd (init_obj G oi r) s = (abrupt s,init_obj G oi r (store s))"
apply (unfold init_obj_def)
apply (simp (no_asm))
done

lemma abupd_store_invariant [simp]: "store (abupd f s) = store s"
  by (cases s) simp

lemma supd_abrupt_invariant [simp]: "abrupt (supd f s) = abrupt s"
  by (cases s) simp

abbreviation set_lvars :: "locals \<Rightarrow> state \<Rightarrow> state"
  where "set_lvars l == supd (set_locals l)"

abbreviation restore_lvars :: "state  \<Rightarrow> state \<Rightarrow> state"
  where "restore_lvars s' s == set_lvars (locals (store s')) s"

lemma set_set_lvars [simp]: "\<And> s. set_lvars l (set_lvars l' s) = set_lvars l s"
apply (simp (no_asm_simp) only: split_tupled_all)
apply (simp (no_asm))
done

lemma set_lvars_id [simp]: "\<And> s. set_lvars (locals (store s)) s = s"
apply (simp (no_asm_simp) only: split_tupled_all)
apply (simp (no_asm))
done

subsubsection "initialisation test"

definition
  inited :: "qtname \<Rightarrow> globs \<Rightarrow> bool"
  where "inited C g = (g (Stat C) \<noteq> None)"

definition
  initd :: "qtname \<Rightarrow> state \<Rightarrow> bool"
  where "initd C = inited C \<circ> globs \<circ> store"

lemma not_inited_empty [simp]: "\<not>inited C empty"
apply (unfold inited_def)
apply (simp (no_asm))
done

lemma inited_gupdate [simp]: "inited C (g(r\<mapsto>obj)) = (inited C g \<or> r = Stat C)"
apply (unfold inited_def)
apply (auto split: st.split)
done

lemma inited_init_class_obj [intro!]: "inited C (globs (init_class_obj G C s))"
apply (unfold inited_def)
apply (simp (no_asm))
done

lemma not_initedD: "\<not> inited C g \<Longrightarrow> g (Stat C) = None"
apply (unfold inited_def)
apply (erule notnotD)
done

lemma initedD: "inited C g \<Longrightarrow> \<exists> obj. g (Stat C) = Some obj"
apply (unfold inited_def)
apply auto
done

lemma initd_def2 [simp]: "initd C s = inited C (globs (store s))"
apply (unfold initd_def)
apply (simp (no_asm))
done

subsubsection \<open>\<open>error_free\<close>\<close>

definition
  error_free :: "state \<Rightarrow> bool"
  where "error_free s = (\<not> (\<exists> err. abrupt s = Some (Error err)))"

lemma error_free_Norm [simp,intro]: "error_free (Norm s)"
by (simp add: error_free_def)

lemma error_free_normal [simp,intro]: "normal s \<Longrightarrow> error_free s"
by (simp add: error_free_def)

lemma error_free_Xcpt [simp]: "error_free (Some (Xcpt x),s)"
by (simp add: error_free_def)

lemma error_free_Jump [simp,intro]: "error_free (Some (Jump j),s)"
by (simp add: error_free_def)

lemma error_free_Error [simp]: "error_free (Some (Error e),s) = False"
by (simp add: error_free_def)

lemma error_free_Some [simp,intro]:
 "\<not> (\<exists> err. x=Error err) \<Longrightarrow> error_free ((Some x),s)"
by (auto simp add: error_free_def)

lemma error_free_abupd_absorb [simp,intro]:
 "error_free s \<Longrightarrow> error_free (abupd (absorb j) s)"
by (cases s)
   (auto simp add: error_free_def absorb_def
         split: if_split_asm)

lemma error_free_absorb [simp,intro]:
 "error_free (a,s) \<Longrightarrow> error_free (absorb j a, s)"
by (auto simp add: error_free_def absorb_def
            split: if_split_asm)

lemma error_free_abrupt_if [simp,intro]:
"\<lbrakk>error_free s; \<not> (\<exists> err. x=Error err)\<rbrakk>
 \<Longrightarrow> error_free (abupd (abrupt_if p (Some x)) s)"
by (cases s)
   (auto simp add: abrupt_if_def
            split: if_split)

lemma error_free_abrupt_if1 [simp,intro]:
"\<lbrakk>error_free (a,s); \<not> (\<exists> err. x=Error err)\<rbrakk>
 \<Longrightarrow> error_free (abrupt_if p (Some x) a, s)"
by  (auto simp add: abrupt_if_def
            split: if_split)

lemma error_free_abrupt_if_Xcpt [simp,intro]:
 "error_free s
  \<Longrightarrow> error_free (abupd (abrupt_if p (Some (Xcpt x))) s)"
by simp

lemma error_free_abrupt_if_Xcpt1 [simp,intro]:
 "error_free (a,s)
  \<Longrightarrow> error_free (abrupt_if p (Some (Xcpt x)) a, s)"
by simp

lemma error_free_abrupt_if_Jump [simp,intro]:
 "error_free s
  \<Longrightarrow> error_free (abupd (abrupt_if p (Some (Jump j))) s)"
by simp

lemma error_free_abrupt_if_Jump1 [simp,intro]:
 "error_free (a,s)
  \<Longrightarrow> error_free (abrupt_if p (Some (Jump j)) a, s)"
by simp

lemma error_free_raise_if [simp,intro]:
 "error_free s \<Longrightarrow> error_free (abupd (raise_if p x) s)"
by simp

lemma error_free_raise_if1 [simp,intro]:
 "error_free (a,s) \<Longrightarrow> error_free ((raise_if p x a), s)"
by simp

lemma error_free_supd [simp,intro]:
 "error_free s \<Longrightarrow> error_free (supd f s)"
by (cases s) (simp add: error_free_def)

lemma error_free_supd1 [simp,intro]:
 "error_free (a,s) \<Longrightarrow> error_free (a,f s)"
by (simp add: error_free_def)

lemma error_free_set_lvars [simp,intro]:
"error_free s \<Longrightarrow> error_free ((set_lvars l) s)"
by (cases s) simp

lemma error_free_set_locals [simp,intro]:
"error_free (x, s)
       \<Longrightarrow> error_free (x, set_locals l s')"
by (simp add: error_free_def)

end


(*  Title:      JinjaThreads/MM/SC.thy
    Author:     David von Oheimb, Andreas Lochbihler

    Based on the Jinja theories Common/Objects.thy and Common/Conform by David von Oheimb
*)

section \<open>Sequential consistency\<close>

theory SC
imports
  "../Common/Conform"
  MM
begin

subsection\<open>Objects and Arrays\<close>

type_synonym
  fields = "vname \<times> cname \<rightharpoonup> addr val"       \<comment> \<open>field name, defining class, value\<close>

type_synonym
  cells = "addr val list"

datatype heapobj
  = Obj cname fields
    \<comment> \<open>class instance with class name and fields\<close>

  | Arr ty fields cells
    \<comment> \<open>element type, fields (from object), and list of each cell's content\<close>

lemma rec_heapobj [simp]: "rec_heapobj = case_heapobj"
by(auto intro!: ext split: heapobj.split)

primrec obj_ty  :: "heapobj \<Rightarrow> htype"
where
  "obj_ty (Obj C f)     = Class_type C"
| "obj_ty (Arr T fs cs) = Array_type T (length cs)"

fun is_Arr :: "heapobj \<Rightarrow> bool" where
  "is_Arr (Obj C fs)   = False"
| "is_Arr (Arr T f el) = True"

lemma is_Arr_conv:
  "is_Arr arrobj = (\<exists>T f el. arrobj = Arr T f el)"
by(cases arrobj, auto)

lemma is_ArrE:
  "\<lbrakk> is_Arr arrobj; \<And>T f el. arrobj = Arr T f el \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis"
  "\<lbrakk> \<not> is_Arr arrobj; \<And>C fs. arrobj = Obj C fs \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis"
by(cases arrobj, auto)+

definition init_fields :: "('field_name \<times> (ty \<times> fmod)) list \<Rightarrow> 'field_name \<rightharpoonup> addr val"
where "init_fields \<equiv> map_of \<circ> map (\<lambda>(FD,(T, fm)). (FD,default_val T))"

primrec
  \<comment> \<open>a new, blank object with default values in all fields:\<close>
  blank :: "'m prog \<Rightarrow> htype \<Rightarrow> heapobj"
where
  "blank P (Class_type C)   = Obj C (init_fields (fields P C))"
| "blank P (Array_type T n) = Arr T (init_fields (fields P Object)) (replicate n (default_val T))"

lemma obj_ty_blank [iff]:
  "obj_ty (blank P hT) = hT"
by(cases hT)(simp_all)

subsection\<open>Heap\<close>

type_synonym heap = "addr \<rightharpoonup> heapobj"

translations
  (type) "heap" <= (type) "nat \<Rightarrow> heapobj option"

abbreviation sc_empty :: heap
where "sc_empty \<equiv> Map.empty"

fun the_obj :: "heapobj \<Rightarrow> cname \<times> fields" where
  "the_obj (Obj C fs) = (C, fs)"

fun the_arr :: "heapobj \<Rightarrow> ty \<times> fields \<times> cells" where
  "the_arr (Arr T f el) = (T, f, el)"

abbreviation
  cname_of :: "heap \<Rightarrow> addr \<Rightarrow> cname" where
  "cname_of hp a == fst (the_obj (the (hp a)))"

definition sc_allocate :: "'m prog \<Rightarrow> heap \<Rightarrow> htype \<Rightarrow> (heap \<times> addr) set"
where
  "sc_allocate P h hT =
   (case new_Addr h of None \<Rightarrow> {}
                   | Some a \<Rightarrow> {(h(a \<mapsto> blank P hT), a)})"

definition sc_typeof_addr :: "heap \<Rightarrow> addr \<Rightarrow> htype option"
where "sc_typeof_addr h a = map_option obj_ty (h a)"

inductive sc_heap_read :: "heap \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> addr val \<Rightarrow> bool"
for h :: heap and a :: addr
where
  Obj: "\<lbrakk> h a = \<lfloor>Obj C fs\<rfloor>; fs (F, D) = \<lfloor>v\<rfloor> \<rbrakk> \<Longrightarrow> sc_heap_read h a (CField D F) v"
| Arr: "\<lbrakk> h a = \<lfloor>Arr T f el\<rfloor>; n < length el \<rbrakk> \<Longrightarrow> sc_heap_read h a (ACell n) (el ! n)"
| ArrObj: "\<lbrakk> h a = \<lfloor>Arr T f el\<rfloor>; f (F, Object) = \<lfloor>v\<rfloor> \<rbrakk> \<Longrightarrow> sc_heap_read h a (CField Object F) v"

hide_fact (open) Obj Arr ArrObj

inductive_cases sc_heap_read_cases [elim!]:
  "sc_heap_read h a (CField C F) v"
  "sc_heap_read h a (ACell n) v"

inductive sc_heap_write :: "heap \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> addr val \<Rightarrow> heap \<Rightarrow> bool"
for h :: heap and a :: addr
where
  Obj: "\<lbrakk> h a = \<lfloor>Obj C fs\<rfloor>; h' = h(a \<mapsto> Obj C (fs((F, D) \<mapsto> v))) \<rbrakk> \<Longrightarrow> sc_heap_write h a (CField D F) v h'"
| Arr: "\<lbrakk> h a = \<lfloor>Arr T f el\<rfloor>; h' = h(a \<mapsto> Arr T f (el[n := v])) \<rbrakk> \<Longrightarrow> sc_heap_write h a (ACell n) v h'"
| ArrObj: "\<lbrakk> h a = \<lfloor>Arr T f el\<rfloor>; h' = h(a \<mapsto> Arr T (f((F, Object) \<mapsto> v)) el) \<rbrakk> \<Longrightarrow> sc_heap_write h a (CField Object F) v h'"

hide_fact (open) Obj Arr ArrObj

inductive_cases sc_heap_write_cases [elim!]:
  "sc_heap_write h a (CField C F) v h'"
  "sc_heap_write h a (ACell n) v h'"

consts sc_spurious_wakeups :: bool

interpretation sc:
  heap_base
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
  for P .

text \<open>Translate notation from \<open>heap_base\<close>\<close>

(* FIXME! Why does sc.preallocated need the type token?? *)
abbreviation sc_preallocated :: "'m prog \<Rightarrow> heap \<Rightarrow> bool"
where "sc_preallocated == sc.preallocated TYPE('m)"

abbreviation sc_start_tid :: "'md prog \<Rightarrow> thread_id"
where "sc_start_tid \<equiv> sc.start_tid TYPE('md)"

abbreviation sc_start_heap_ok :: "'m prog \<Rightarrow> bool"
where "sc_start_heap_ok \<equiv> sc.start_heap_ok TYPE('m)"

abbreviation sc_start_heap :: "'m prog \<Rightarrow> heap"
where "sc_start_heap \<equiv> sc.start_heap TYPE('m)"

abbreviation sc_start_state ::
  "(cname \<Rightarrow> mname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> 'm \<Rightarrow> addr val list \<Rightarrow> 'x)
  \<Rightarrow> 'm prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> addr val list \<Rightarrow> (addr, thread_id, 'x, heap, addr) state"
where
  "sc_start_state f P \<equiv> sc.start_state TYPE('m) P f P"

abbreviation sc_wf_start_state :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> addr val list \<Rightarrow> bool"
where "sc_wf_start_state P \<equiv> sc.wf_start_state TYPE('m) P P"

notation sc.conf ("_,_ \<turnstile>sc _ :\<le> _"  [51,51,51,51] 50)
notation sc.confs ("_,_ \<turnstile>sc _ [:\<le>] _" [51,51,51,51] 50)
notation sc.hext ("_ \<unlhd>sc _" [51,51] 50)

lemma sc_start_heap_ok: "sc_start_heap_ok P"
apply(simp add: sc.start_heap_ok_def sc.start_heap_data_def initialization_list_def sc.create_initial_object_simps sc_allocate_def sys_xcpts_list_def case_option_conv_if new_Addr_SomeI del: blank.simps split del: option.split if_split)
done

lemma sc_wf_start_state_iff:
  "sc_wf_start_state P C M vs \<longleftrightarrow> (\<exists>Ts T meth D. P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>meth\<rfloor> in D \<and> P,sc_start_heap P \<turnstile>sc vs [:\<le>] Ts)"
by(simp add: sc.wf_start_state.simps sc_start_heap_ok)

lemma sc_heap:
  "heap addr2thread_id thread_id2addr (sc_allocate P) sc_typeof_addr sc_heap_write P"
proof
  fix h' a h hT
  assume "(h', a) \<in> sc_allocate P h hT"
  thus "sc_typeof_addr h' a = \<lfloor>hT\<rfloor>"
    by(auto simp add: sc_allocate_def sc_typeof_addr_def dest: new_Addr_SomeD split: if_split_asm)
next
  fix h' h hT a
  assume "(h', a) \<in> sc_allocate P h hT"
  from this[symmetric] show "h \<unlhd>sc h'"
    by(fastforce simp add: sc_allocate_def sc_typeof_addr_def sc.hext_def dest: new_Addr_SomeD intro!: map_leI)
next
  fix h a al v h'
  assume "sc_heap_write h a al v h'"
  thus "h \<unlhd>sc h'"
    by(cases al)(auto intro!: sc.hextI simp add: sc_typeof_addr_def)
qed simp

interpretation sc:
  heap
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
  for P by(rule sc_heap)

lemma sc_hext_new:
  "h a = None \<Longrightarrow> h \<unlhd>sc h(a \<mapsto> arrobj)"
by(rule sc.hextI)(auto simp add: sc_typeof_addr_def dest!: new_Addr_SomeD)

lemma sc_hext_upd_obj: "h a = Some (Obj C fs) \<Longrightarrow> h \<unlhd>sc h(a\<mapsto>(Obj C fs'))"
by(rule sc.hextI)(auto simp:fun_upd_apply sc_typeof_addr_def)

lemma sc_hext_upd_arr: "\<lbrakk> h a = Some (Arr T f e); length e = length e' \<rbrakk> \<Longrightarrow> h \<unlhd>sc h(a\<mapsto>(Arr T f' e'))"
by(rule sc.hextI)(auto simp:fun_upd_apply sc_typeof_addr_def)

subsection \<open>Conformance\<close>

definition sc_fconf :: "'m prog \<Rightarrow> cname \<Rightarrow> heap \<Rightarrow> fields \<Rightarrow> bool" ("_,_,_ \<turnstile>sc _ \<surd>" [51,51,51,51] 50)
where "P,C,h \<turnstile>sc fs \<surd> = (\<forall>F D T fm. P \<turnstile> C has F:T (fm) in D \<longrightarrow> (\<exists>v. fs(F,D) = Some v \<and> P,h \<turnstile>sc v :\<le> T))"

primrec sc_oconf :: "'m prog \<Rightarrow> heap \<Rightarrow> heapobj \<Rightarrow> bool"   ("_,_ \<turnstile>sc _ \<surd>" [51,51,51] 50)
where
  "P,h \<turnstile>sc Obj C fs \<surd> \<longleftrightarrow> is_class P C \<and> P,C,h \<turnstile>sc fs \<surd>"
| "P,h \<turnstile>sc Arr T fs el \<surd> \<longleftrightarrow> is_type P (T\<lfloor>\<rceil>) \<and> P,Object,h \<turnstile>sc fs \<surd> \<and> (\<forall>v \<in> set el. P,h \<turnstile>sc v :\<le> T)"

definition sc_hconf :: "'m prog \<Rightarrow> heap \<Rightarrow> bool"  ("_ \<turnstile>sc _ \<surd>" [51,51] 50)
where "P \<turnstile>sc h \<surd> \<longleftrightarrow> (\<forall>a obj. h a = Some obj \<longrightarrow> P,h \<turnstile>sc obj \<surd>)"

interpretation sc: heap_conf_base
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P .

declare sc.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

lemma sc_conf_upd_obj: "h a = Some(Obj C fs) \<Longrightarrow> (P,h(a\<mapsto>(Obj C fs')) \<turnstile>sc x :\<le> T) = (P,h \<turnstile>sc x :\<le> T)"
apply (unfold sc.conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
apply (auto simp add: sc_typeof_addr_def split: if_split_asm)
done

lemma sc_conf_upd_arr: "h a = Some(Arr T f el) \<Longrightarrow> (P,h(a\<mapsto>(Arr T f' el')) \<turnstile>sc x :\<le> T') = (P,h \<turnstile>sc x :\<le> T')"
apply(unfold sc.conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
apply(auto simp add: sc_typeof_addr_def split: if_split_asm)
done

lemma sc_oconf_init:
 "is_htype P hT \<Longrightarrow> P,h \<turnstile>sc blank P hT \<surd>"
by(cases hT)(auto simp add: sc_fconf_def has_field_def init_fields_def split_def o_def map_of_map[simplified split_def, where f="\<lambda>p. default_val (fst p)"] dest: has_fields_fun)

lemma sc_oconf_fupd [intro?]:
  "\<lbrakk> P \<turnstile> C has F:T (fm) in D; P,h \<turnstile>sc v :\<le> T; P,h \<turnstile>sc (Obj C fs) \<surd> \<rbrakk>
  \<Longrightarrow> P,h \<turnstile>sc (Obj C (fs((F,D)\<mapsto>v))) \<surd>"
unfolding has_field_def
by(auto simp add: sc_fconf_def has_field_def dest: has_fields_fun)

lemma sc_oconf_fupd_arr [intro?]:
  "\<lbrakk> P,h \<turnstile>sc v :\<le> T; P,h \<turnstile>sc (Arr T f el) \<surd> \<rbrakk>
  \<Longrightarrow> P,h \<turnstile>sc (Arr T f (el[i := v])) \<surd>"
by(auto dest: subsetD[OF set_update_subset_insert])

lemma sc_oconf_fupd_arr_fields:
  "\<lbrakk> P \<turnstile> Object has F:T (fm) in Object; P,h \<turnstile>sc v :\<le> T; P,h \<turnstile>sc (Arr T' f el) \<surd> \<rbrakk>
  \<Longrightarrow> P,h \<turnstile>sc (Arr T' (f((F, Object) \<mapsto> v)) el) \<surd>"
by(auto dest: has_fields_fun simp add: sc_fconf_def has_field_def)

lemma sc_oconf_new: "\<lbrakk> P,h \<turnstile>sc obj \<surd>; h a = None \<rbrakk> \<Longrightarrow> P,h(a \<mapsto> arrobj) \<turnstile>sc obj \<surd>"
by(erule sc_oconf_hext)(rule sc_hext_new)

lemmas sc_oconf_upd_obj = sc_oconf_hext [OF _ sc_hext_upd_obj]

lemma sc_oconf_upd_arr:
  assumes "P,h \<turnstile>sc obj \<surd>"
  and ha: "h a = \<lfloor>Arr T f el\<rfloor>"
  shows "P,h(a \<mapsto> Arr T f' el') \<turnstile>sc obj \<surd>"
using assms
by(cases obj)(auto simp add: sc_conf_upd_arr[where h=h, OF ha] sc_fconf_def)

lemma sc_hconfD: "\<lbrakk> P \<turnstile>sc h \<surd>; h a = Some obj \<rbrakk> \<Longrightarrow> P,h \<turnstile>sc obj \<surd>"
unfolding sc_hconf_def by blast

lemmas sc_preallocated_new = sc.preallocated_hext[OF _ sc_hext_new]
lemmas sc_preallocated_upd_obj = sc.preallocated_hext [OF _ sc_hext_upd_obj]
lemmas sc_preallocated_upd_arr = sc.preallocated_hext [OF _ sc_hext_upd_arr]

lemma sc_hconf_new: "\<lbrakk> P \<turnstile>sc h \<surd>; h a = None; P,h \<turnstile>sc obj \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile>sc h(a\<mapsto>obj) \<surd>"
unfolding sc_hconf_def
by(auto intro: sc_oconf_new)

lemma sc_hconf_upd_obj: "\<lbrakk> P \<turnstile>sc h \<surd>; h a = Some (Obj C fs); P,h \<turnstile>sc (Obj C fs') \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile>sc h(a\<mapsto>(Obj C fs')) \<surd>"
unfolding sc_hconf_def
by(auto intro: sc_oconf_upd_obj simp del: sc_oconf.simps)

lemma sc_hconf_upd_arr: "\<lbrakk> P \<turnstile>sc h \<surd>; h a = Some(Arr T f el); P,h \<turnstile>sc (Arr T f' el') \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile>sc h(a\<mapsto>(Arr T f' el')) \<surd>"
unfolding sc_hconf_def
by(auto intro: sc_oconf_upd_arr simp del: sc_oconf.simps)

lemma sc_heap_conf:
  "heap_conf addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_write (sc_hconf P) P"
proof
  show "P \<turnstile>sc sc_empty \<surd>" by(simp add: sc_hconf_def)
next
  fix h a hT
  assume "sc_typeof_addr h a = \<lfloor>hT\<rfloor>" "P \<turnstile>sc h \<surd>"
  thus "is_htype P hT"
    by(auto simp add: sc_typeof_addr_def sc_oconf_def dest!: sc_hconfD split: heapobj.split_asm)
next
  fix h h' hT a
  assume "P \<turnstile>sc h \<surd>" "(h', a) \<in> sc_allocate P h hT" "is_htype P hT"
  thus "P \<turnstile>sc h' \<surd>"
    by(auto simp add: sc_allocate_def dest!: new_Addr_SomeD intro: sc_hconf_new sc_oconf_init split: if_split_asm)
next
  fix h a al T v h'
  assume "P \<turnstile>sc h \<surd>"
    and "sc.addr_loc_type P h a al T"
    and "P,h \<turnstile>sc v :\<le> T"
    and "sc_heap_write h a al v h'"
  thus "P \<turnstile>sc h' \<surd>"
    by(cases al)(fastforce elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def intro: sc_hconf_upd_obj sc_oconf_fupd sc_hconfD sc_hconf_upd_arr sc_oconf_fupd_arr sc_oconf_fupd_arr_fields)+
qed

interpretation sc: heap_conf
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P
by(rule sc_heap_conf)

lemma sc_heap_progress:
  "heap_progress addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
proof
  fix h a al T
  assume hconf: "P \<turnstile>sc h \<surd>"
    and alt: "sc.addr_loc_type P h a al T"
  from alt obtain arrobj where arrobj: "h a = \<lfloor>arrobj\<rfloor>"
    by(auto elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
  from alt show "\<exists>v. sc_heap_read h a al v \<and> P,h \<turnstile>sc v :\<le> T"
  proof(cases)
    case (addr_loc_type_field U F fm D)
    note [simp] = \<open>al = CField D F\<close>
    show ?thesis
    proof(cases "arrobj")
      case (Obj C' fs)
      with \<open>sc_typeof_addr h a = \<lfloor>U\<rfloor>\<close> arrobj
      have [simp]: "C' = class_type_of U" by(auto simp add: sc_typeof_addr_def)
      from hconf arrobj Obj have "P,h \<turnstile>sc Obj (class_type_of U) fs \<surd>" by(auto dest: sc_hconfD)
      with \<open>P \<turnstile> class_type_of U has F:T (fm) in D\<close> obtain v
        where "fs (F, D) = \<lfloor>v\<rfloor>" "P,h \<turnstile>sc v :\<le> T" by(fastforce simp add: sc_fconf_def)
      thus ?thesis using Obj arrobj by(auto intro: sc_heap_read.intros)
    next
      case (Arr T' f el)
      with \<open>sc_typeof_addr h a = \<lfloor>U\<rfloor>\<close> arrobj
      have [simp]: "U = Array_type T' (length el)" by(auto simp add: sc_typeof_addr_def)
      from hconf arrobj Arr have "P,h \<turnstile>sc Arr T' f el \<surd>" by(auto dest: sc_hconfD)
      from \<open>P \<turnstile> class_type_of U has F:T (fm) in D\<close> have [simp]: "D = Object"
        by(auto dest: has_field_decl_above)
      with \<open>P,h \<turnstile>sc Arr T' f el \<surd>\<close> \<open>P \<turnstile> class_type_of U has F:T (fm) in D\<close>
      obtain v where "f (F, Object) = \<lfloor>v\<rfloor>" "P,h \<turnstile>sc v :\<le> T"
        by(fastforce simp add: sc_fconf_def)
      thus ?thesis using Arr arrobj by(auto intro: sc_heap_read.intros)
    qed
  next
    case (addr_loc_type_cell n' n)
    with arrobj obtain f el
      where [simp]: "arrobj = Arr T f el"
      by(cases arrobj)(auto simp add: sc_typeof_addr_def)
    from addr_loc_type_cell arrobj
    have [simp]: "al = ACell n" "n < length el" by(auto simp add: sc_typeof_addr_def)
    from hconf arrobj have "P,h \<turnstile>sc Arr T f el \<surd>" by(auto dest: sc_hconfD)
    hence "P,h \<turnstile>sc el ! n :\<le> T" by(fastforce)
    thus ?thesis using arrobj by(fastforce intro: sc_heap_read.intros)
  qed
next
  fix h a al T v
  assume alt: "sc.addr_loc_type P h a al T"
  from alt obtain arrobj where arrobj: "h a = \<lfloor>arrobj\<rfloor>"
    by(auto elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
  thus "\<exists>h'. sc_heap_write h a al v h'" using alt
    by(cases arrobj)(fastforce intro: sc_heap_write.intros elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def dest: has_field_decl_above)+
qed

interpretation sc: heap_progress
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P
by(rule sc_heap_progress)

lemma sc_heap_conf_read:
  "heap_conf_read addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
proof
  fix h a al v T
  assume read: "sc_heap_read h a al v"
    and alt: "sc.addr_loc_type P h a al T"
    and hconf: "P \<turnstile>sc h \<surd>"
  thus "P,h \<turnstile>sc v :\<le> T"
    by(auto elim!: sc_heap_read.cases sc.addr_loc_type.cases simp add: sc_typeof_addr_def)(fastforce dest!: sc_hconfD simp add: sc_fconf_def)+
qed

interpretation sc: heap_conf_read
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P
by(rule sc_heap_conf_read)

abbreviation sc_deterministic_heap_ops :: "'m prog \<Rightarrow> bool"
where "sc_deterministic_heap_ops \<equiv> sc.deterministic_heap_ops TYPE('m)"

lemma sc_deterministic_heap_ops: "\<not> sc_spurious_wakeups \<Longrightarrow> sc_deterministic_heap_ops P"
by(rule sc.deterministic_heap_opsI)(auto elim: sc_heap_read.cases sc_heap_write.cases simp add: sc_allocate_def)

subsection \<open>Code generation\<close>

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  sc_heap_read .

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  sc_heap_write .

lemma eval_sc_heap_read_i_i_i_o:
  "Predicate.eval (sc_heap_read_i_i_i_o h ad al) = sc_heap_read h ad al"
by(auto elim: sc_heap_read_i_i_i_oE intro: sc_heap_read_i_i_i_oI intro!: ext)

lemma eval_sc_heap_write_i_i_i_i_o:
  "Predicate.eval (sc_heap_write_i_i_i_i_o h ad al v) = sc_heap_write h ad al v"
by(auto elim: sc_heap_write_i_i_i_i_oE intro: sc_heap_write_i_i_i_i_oI intro!: ext)

end