(*<*)
(* Author: Thomas Bauereiss *)
theory AArch64_Trivia
  imports "Sail-AArch64.Aarch64_lemmas" Sail.Sail2_operators_mwords_lemmas Word_Extra Proof_methods
begin
(*>*)

text \<open>Various helper lemmas for simplifying proof obligations arising in the computation of
preconditions, e.g. if-then-else-distributivity rules for the datatypes in the model.\<close>

abbreviation
  "CreateFaultRecord typ1 ipaddress level acctype write1 extflag errortype secondstage s2fs1walk \<equiv>
     \<lparr>FaultRecord_typ = typ1, FaultRecord_acctype = acctype, FaultRecord_ipaddress = ipaddress,
      FaultRecord_s2fs1walk = s2fs1walk, FaultRecord_write = write1, FaultRecord_level = level,
      FaultRecord_extflag = extflag, FaultRecord_secondstage = secondstage, FaultRecord_domain = 0,
      FaultRecord_errortype = errortype, FaultRecord_debugmoe = 0\<rparr>"

abbreviation
  "AccessDescriptor acctype ptwalk secondstage s2fs2walk level \<equiv>
     \<lparr>AccessDescriptor_acctype = acctype,
      AccessDescriptor_page_table_walk = ptwalk,
      AccessDescriptor_secondstage = secondstage,
      AccessDescriptor_s2fs1walk = s2fs2walk,
      AccessDescriptor_level = level\<rparr>"

lemma CreateFaultRecord_if_distrib:
  "(if c then CreateFaultRecord typ1 ipaddress1 level1 acctype1 write1 extflag1 errortype1 secondstage1 s2fs1walk1
    else CreateFaultRecord typ2 ipaddress2 level2 acctype2 write2 extflag2 errortype2 secondstage2 s2fs1walk2) =
    CreateFaultRecord (if c then typ1 else typ2) (if c then ipaddress1 else ipaddress2)
      (if c then level1 else level2) (if c then acctype1 else acctype2) (if c then write1 else write2)
      (if c then extflag1 else extflag2) (if c then errortype1 else errortype2)
      (if c then secondstage1 else secondstage2) (if c then s2fs1walk1 else s2fs1walk2)"
  by auto

lemma fun2_if_distrib:
  "(if c then f x1 y1 else f x2 y2) = f (if c then x1 else x2) (if c then y1 else y2)"
  by auto

lemmas fun2_if_distribs =
  if_distrib[where f = f for f :: "'a \<Rightarrow> 'b \<Rightarrow> 'c", symmetric]
  fun2_if_distrib
  fun2_if_distrib[where f = Pair]
  fun2_if_distrib[where f = "(\<and>)"]
  fun2_if_distrib[where f = "(\<or>)"]

lemmas prod_if_distrib = fun2_if_distrib[where f = Pair]
lemmas conj_if_distrib = fun2_if_distrib[where f = "(\<and>)"]
lemmas disj_if_distrib = fun2_if_distrib[where f = "(\<or>)"]

lemmas all_if_distrib = if_distrib[where f = "\<lambda>c. \<forall>b. c b", symmetric]

lemmas AddressDescriptor_memattrs_update_if_distrib =
  if_distrib[where f = "\<lambda>c. addrdesc\<lparr>AddressDescriptor_memattrs := c\<rparr>" for addrdesc, symmetric]
  if_distrib[where f = "\<lambda>c. c\<lparr>AddressDescriptor_memattrs := z\<rparr>" for z]

lemma MemoryAttributes_if_distrib:
  "(if c then
      \<lparr>MemoryAttributes_typ = typ1, MemoryAttributes_device = device1,
       MemoryAttributes_inner = inner1, MemoryAttributes_outer = outer1,
       MemoryAttributes_shareable = shareable1, MemoryAttributes_outershareable = outershareable1\<rparr>
    else
      \<lparr>MemoryAttributes_typ = typ2, MemoryAttributes_device = device2,
       MemoryAttributes_inner = inner2, MemoryAttributes_outer = outer2,
       MemoryAttributes_shareable = shareable2, MemoryAttributes_outershareable = outershareable2\<rparr>) =
    \<lparr>MemoryAttributes_typ = if c then typ1 else typ2,
     MemoryAttributes_device = if c then device1 else device2,
     MemoryAttributes_inner = if c then inner1 else inner2,
     MemoryAttributes_outer = if c then outer1 else outer2,
     MemoryAttributes_shareable = if c then shareable1 else shareable2,
     MemoryAttributes_outershareable = if c then outershareable1 else outershareable2\<rparr>"
  by auto

lemma MemoryAttributes_cong:
  assumes "typ1 = typ2" and "device1 = device2" and "inner1 = inner2" and "outer1 = outer2"
    and "shareable1 = shareable2" and "outershareable1 = outershareable2"
  shows
    "\<lparr>MemoryAttributes_typ = typ1, MemoryAttributes_device = device1,
      MemoryAttributes_inner = inner1, MemoryAttributes_outer = outer1,
      MemoryAttributes_shareable = shareable1, MemoryAttributes_outershareable = outershareable1\<rparr> =
     \<lparr>MemoryAttributes_typ = typ2, MemoryAttributes_device = device2,
      MemoryAttributes_inner = inner2, MemoryAttributes_outer = outer2,
      MemoryAttributes_shareable = shareable2, MemoryAttributes_outershareable = outershareable2\<rparr>"
  using assms by auto

lemma MemAttrHints_if_distrib:
  "(if c
    then \<lparr>MemAttrHints_attrs = attrs1, MemAttrHints_hints = hints1, MemAttrHints_transient = transient1\<rparr>
    else \<lparr>MemAttrHints_attrs = attrs2, MemAttrHints_hints = hints2, MemAttrHints_transient = transient2\<rparr>) =
   \<lparr>MemAttrHints_attrs = if c then attrs1 else attrs2,
    MemAttrHints_hints = if c then hints1 else hints2,
    MemAttrHints_transient = if c then transient1 else transient2\<rparr>"
  by auto

lemma MemAttrHints_cong:
  assumes "attrs1 = attrs2" and "hints1 = hints2" and "transient1 = transient2"
  shows "\<lparr>MemAttrHints_attrs = attrs1, MemAttrHints_hints = hints1, MemAttrHints_transient = transient1\<rparr> =
         \<lparr>MemAttrHints_attrs = attrs2, MemAttrHints_hints = hints2, MemAttrHints_transient = transient2\<rparr>"
  using assms by auto

lemma case_option_if_distrib:
  "(if b then (case x1 of Some y \<Rightarrow> f1 y | None \<Rightarrow> g1) else (case x2 of Some y \<Rightarrow> f2 y | None \<Rightarrow> g2)) =
   (case (if b then x1 else x2) of Some y \<Rightarrow> if b then f1 y else f2 y | None \<Rightarrow> if b then g1 else g2)"
  by (auto split: option.splits)

lemma case_prod_if_distrib:
  "(if b then (case x1 of (y1, z1) \<Rightarrow> f1 y1 z1) else (case x2 of (y2, z2) \<Rightarrow> f2 y2 z2)) =
   (case (if b then x1 else x2) of (y, z) \<Rightarrow> if b then f1 y z else f2 y z)"
  by auto

lemma app_let_distrib: "(let x = y in f x) z = (let x = y in f x z)"
  by auto

lemmas TLBRecord_if_distribs[simp] =
  if_distrib[where f = TLBRecord_descupdate] if_distrib[where f = TLBRecord_descupdate_update]
  if_distrib[where f = "\<lambda>x. r\<lparr>TLBRecord_descupdate := x\<rparr>" for r]
  if_distrib[where f = TLBRecord_addrdesc]
lemmas DescriptorUpdate_if_distribs[simp] =
  if_distrib[where f = DescriptorUpdate_descaddr_update]
lemmas MemAttrHints_if_distribs[simp] =
  if_distrib[where f = MemAttrHints_attrs]
lemmas [simp] =
  if_distrib[where f = FullAddress_physicaladdress]
  if_distrib[where f = AddressDescriptor_paddress]
  if_distrib[where f = "\<lambda>i. x < i" for x]
  if_distrib[where f = "\<lambda>i. i < x" for x]
  if_distrib[where f = "\<lambda>i. x - i" for x]
  if_distrib[where f = "\<lambda>i. i = x" for x]

lemmas PrePost_if_distribs = app_if_distrib prod_if_distrib conj_if_distrib disj_if_distrib all_if_distrib
  AddressDescriptor_memattrs_update_if_distrib MemoryAttributes_if_distrib MemAttrHints_if_distrib
  (*TLBRecord_descupdate_update_if_distrib DescriptorUpdate_descaddr_update_if_distrib*)
  if_distrib[where f = "\<lambda>c. z \<le> c" for z] if_distrib[where f = "\<lambda>c. c \<le> z" for z]
  if_distrib[where f = "\<lambda>c. z < c" for z] if_distrib[where f = "\<lambda>c. c < z" for z]
  if_distrib[where f = returnS, symmetric]
  if_distrib[where f = return, symmetric]
  case_option_if_distrib case_prod_if_distrib
  if_distrib[where f = "\<lambda>c. let a = b in c a" for b, symmetric]
  if_distrib[where f = "\<lambda>c. a \<longrightarrow> c" for a, symmetric]
  (*if_distrib[where f = "\<lambda>c. z = c" for z] if_distrib[where f = "\<lambda>c. c = z" for z]*)
  (*if_distrib[where f = "\<lambda>c. c' \<and> c" for c'] if_distrib[where f = "\<lambda>c. c \<and> c'" for c']*)

lemmas app_case_distribs =
  sum.case_distrib[where h = "\<lambda>c. c z" for z]
  ex.case_distrib[where h = "\<lambda>c. c z" for z]
  option.case_distrib[where h = "\<lambda>c. c z" for z]
  app_let_distrib

lemma if_True_False_simps[simp]:
  "(if c then True else False) = c"
  "(if c then False else True) = (\<not>c)"
  "(if c1 then True else c2) = (c1 \<or> c2)"
  "(if c1 then c2 else True) = (c1 \<longrightarrow> c2)"
  "(if c1 then c2 else False) = (c1 \<and> c2)"
  by auto

lemma conj_imp_cond_absorb[simp]: "(b \<longrightarrow> c1) \<and> (b \<longrightarrow> c2) \<longleftrightarrow> (b \<longrightarrow> c1 \<and> c2)"
  by auto

lemma if_then_imp_distrib:
  "(if c then x \<longrightarrow> y else z) = ((c \<and> \<not>x) \<or> (if c then y else z))"
  "(if c then x \<or> y else z) = ((c \<and> x) \<or> (if c then y else z))"
  "(if c then x else y \<longrightarrow> z) = ((\<not>c \<and> \<not>y) \<or> (if c then x else z))"
  "(if c then x else y \<or> z) = ((\<not>c \<and> y) \<or> (if c then x else z))"
  by auto

lemma if_then_all_distrib:
  "\<And>c f g. (if c then \<forall>x. f x else g) = (\<forall>x. if c then f x else g)"
  "\<And>c f g. (if c then f else \<forall>x. g x) = (\<forall>x. if c then f else g x)"
  by auto

lemma if_then_conj_distrib:
  "(if c then x \<and> y else z) = ((c \<longrightarrow> x) \<and> (if c then y else z))"
  "(if c then x else y \<and> z) = ((\<not>c \<longrightarrow> y) \<and> (if c then x else z))"
  by auto

lemma nested_if_merges[simp]:
  "(if c1 then x else if c2 then x else y) = (if c1 \<or> c2 then x else y)"
  "(if c1 then x else if c2 then y else x) = (if c1 \<or> \<not>c2 then x else y)"
  "(if c1 then x else (if c2 then y else (if c3 then x else z))) = (if c1 \<or> (\<not>c2 \<and> c3) then x else if c2 then y else z)"
  "(if c1 then x else (if c2 then (if c3 then x else y) else z)) = (if c1 \<or> (c2 \<and> c3) then x else if c2 then y else z)"
  "(if c1 then (if c2 then x else y) else (if c3 then x else z)) = (if (c1 \<and> c2) \<or> (\<not>c1 \<and> c3) then x else if c1 then y else z)"
  "(if (if a then b else c) then x else y) \<longleftrightarrow> (if (\<not>a \<or> b) \<and> (a \<or> c) then x else y)"
  "(if a then b \<and> c else c) \<longleftrightarrow> (\<not>a \<or> b) \<and> c"
  "(if a then (if b then x else y) else y) \<longleftrightarrow> (if (a \<and> b) then x else y)"
  "(if a then (if b then x else y) else (if c then x else y)) \<longleftrightarrow> (if (\<not>a \<or> b) \<and> (a \<or> c) then x else y)"
  "(\<forall>a. if a \<or> b then x else y) \<longleftrightarrow> x \<and> (if b then x else y)"
  by auto

lemma conj_disj_absorbs[simp]:
  "A \<and> B \<or> A \<longleftrightarrow> A"
  "A \<and> B \<or> B \<longleftrightarrow> B"
  "(A \<and> B) \<or> (\<not>A \<and> B) \<longleftrightarrow> B"
  "(\<not>A \<and> B) \<or> (A \<and> B) \<longleftrightarrow> B"
  by auto

lemma quant_singleton_bool_simps[simp]:
  "(\<forall>b. b) \<longleftrightarrow> False" "(\<forall>b. \<not>b) \<longleftrightarrow> False" "(\<exists>b. b) \<longleftrightarrow> True" "(\<exists>b. \<not>b) \<longleftrightarrow> True"
  by auto

lemmas MemAttr_defs[simp] = MemAttr_WT_def MemAttr_WB_def MemAttr_NC_def

lemma case_prod15_split:
  "(case vars of (accdesc, addrselectbottom, addrselecttop, ap_table, baseaddress, blocktranslate, desc, descaddr, descaddr2, hwupdatewalk, level,
                     ns_table, pxn_table, result, xn_table) \<Rightarrow>
      f accdesc addrselectbottom addrselecttop ap_table baseaddress blocktranslate desc descaddr descaddr2 hwupdatewalk level
                     ns_table pxn_table result xn_table) =
   (\<forall>accdesc addrselectbottom addrselecttop ap_table baseaddress blocktranslate desc descaddr descaddr2 hwupdatewalk level
                     ns_table pxn_table result xn_table.
      vars = (accdesc, addrselectbottom, addrselecttop, ap_table, baseaddress, blocktranslate, desc, descaddr, descaddr2, hwupdatewalk, level,
                     ns_table, pxn_table, result, xn_table) \<longrightarrow>
      f accdesc addrselectbottom addrselecttop ap_table baseaddress blocktranslate desc descaddr descaddr2 hwupdatewalk level
                     ns_table pxn_table result xn_table)"
  by auto

lemma prod15_cases:
  obtains accdesc addrselectbottom addrselecttop ap_table baseaddress blocktranslate desc descaddr descaddr2 hwupdatewalk level
                     ns_table pxn_table result xn_table
                   where "x = (accdesc, addrselectbottom, addrselecttop, ap_table, baseaddress, blocktranslate, desc, descaddr, descaddr2, hwupdatewalk, level,
                     ns_table, pxn_table, result, xn_table)"
  by (cases x) auto

lemma TLBRecord_if_distrib:
  "(if c then
      \<lparr>TLBRecord_perms =
         \<lparr>Permissions_ap = ap1, Permissions_xn = xn1, Permissions_xxn = xxn1, Permissions_pxn = pxn1\<rparr>,
       TLBRecord_nG = nG1, TLBRecord_domain = domain1, TLBRecord_contiguous = contiguous1,
       TLBRecord_level = level1, TLBRecord_blocksize = blocksize1,
       TLBRecord_descupdate =
         \<lparr>DescriptorUpdate_AF = af1, DescriptorUpdate_AP = descupd_ap1,
          DescriptorUpdate_descaddr = descaddr1 \<rparr>,
       TLBRecord_CnP = cnp1,
       TLBRecord_addrdesc =
         \<lparr>AddressDescriptor_fault = fault1, AddressDescriptor_memattrs = memattrs1,
          AddressDescriptor_paddress = \<lparr>FullAddress_physicaladdress = paddress1, FullAddress_NS = ns1\<rparr>,
          AddressDescriptor_vaddress = vaddress1\<rparr> \<rparr>
    else
      \<lparr>TLBRecord_perms =
         \<lparr>Permissions_ap = ap2, Permissions_xn = xn2, Permissions_xxn = xxn2, Permissions_pxn = pxn2\<rparr>,
       TLBRecord_nG = nG2, TLBRecord_domain = domain2, TLBRecord_contiguous = contiguous2,
       TLBRecord_level = level2, TLBRecord_blocksize = blocksize2,
       TLBRecord_descupdate =
         \<lparr>DescriptorUpdate_AF = af2, DescriptorUpdate_AP = descupd_ap2, DescriptorUpdate_descaddr = descaddr2 \<rparr>,
       TLBRecord_CnP = cnp2,
       TLBRecord_addrdesc =
         \<lparr>AddressDescriptor_fault = fault2, AddressDescriptor_memattrs = memattrs2,
          AddressDescriptor_paddress = \<lparr>FullAddress_physicaladdress = paddress2, FullAddress_NS = ns2\<rparr>,
          AddressDescriptor_vaddress = vaddress2\<rparr> \<rparr>) =
       \<lparr>TLBRecord_perms =
          \<lparr>Permissions_ap = if c then ap1 else ap2,
           Permissions_xn = if c then xn1 else xn2,
           Permissions_xxn = if c then xxn1 else xxn2,
           Permissions_pxn = if c then pxn1 else pxn2\<rparr>,
        TLBRecord_nG = if c then nG1 else nG2,
        TLBRecord_domain = if c then domain1 else domain2,
        TLBRecord_contiguous = if c then contiguous1 else contiguous2,
        TLBRecord_level = if c then level1 else level2,
        TLBRecord_blocksize = if c then blocksize1 else blocksize2,
        TLBRecord_descupdate =
          \<lparr>DescriptorUpdate_AF = if c then af1 else af2,
           DescriptorUpdate_AP = if c then descupd_ap1 else descupd_ap2,
           DescriptorUpdate_descaddr = if c then descaddr1 else descaddr2 \<rparr>,
        TLBRecord_CnP = if c then cnp1 else cnp2,
        TLBRecord_addrdesc =
          \<lparr>AddressDescriptor_fault = if c then fault1 else fault2,
           AddressDescriptor_memattrs = if c then memattrs1 else memattrs2,
           AddressDescriptor_paddress =
              \<lparr>FullAddress_physicaladdress = if c then paddress1 else paddress2,
               FullAddress_NS = if c then ns1 else ns2\<rparr>,
           AddressDescriptor_vaddress = if c then vaddress1 else vaddress2\<rparr> \<rparr>"
  by auto

lemma DescriptorUpdate_if_distrib:
  "(if c
    then \<lparr>DescriptorUpdate_AF = af1, DescriptorUpdate_AP = ap1, DescriptorUpdate_descaddr = addr1\<rparr>
    else \<lparr>DescriptorUpdate_AF = af2, DescriptorUpdate_AP = ap2, DescriptorUpdate_descaddr = addr2\<rparr>) =
   \<lparr>DescriptorUpdate_AF = if c then af1 else af2,
    DescriptorUpdate_AP = if c then ap1 else ap2,
    DescriptorUpdate_descaddr = if c then addr1 else addr2\<rparr>"
  by auto

(* Add some lemmas for automatically splitting TLBRecords into their components during precondition
   computation.  This seems to make simplification of record updates more efficient. *)

lemma TLBRecord_cases:
  fixes x :: TLBRecord
  obtains ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap descaddr cnp fault memattrs paddress ns vaddress
  where "x = \<lparr>TLBRecord_perms =
                \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn, Permissions_pxn = pxn\<rparr>,
              TLBRecord_nG = nG, TLBRecord_domain = domain, TLBRecord_contiguous = contiguous,
              TLBRecord_level = level, TLBRecord_blocksize = blocksize,
              TLBRecord_descupdate =
                \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                 DescriptorUpdate_descaddr = descaddr \<rparr>,
              TLBRecord_CnP = cnp,
              TLBRecord_addrdesc =
                \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                 AddressDescriptor_paddress = \<lparr>FullAddress_physicaladdress = paddress, FullAddress_NS = ns\<rparr>,
                 AddressDescriptor_vaddress = vaddress\<rparr> \<rparr>"
proof -
  obtain perms nG domain contiguous level blocksize descupdate cnp addrdesc where
    "x = \<lparr>TLBRecord_perms = perms, TLBRecord_nG = nG, TLBRecord_domain = domain,
          TLBRecord_contiguous = contiguous, TLBRecord_level = level,
          TLBRecord_blocksize = blocksize, TLBRecord_descupdate = descupdate,
          TLBRecord_CnP = cnp, TLBRecord_addrdesc = addrdesc \<rparr>"
    by (cases x)
  moreover obtain ap xn xxn pxn where
    "perms = \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn, Permissions_pxn = pxn\<rparr>"
    by (cases perms)
  moreover obtain af descupd_ap descaddr where
    "descupdate = \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                   DescriptorUpdate_descaddr = descaddr \<rparr>"
    by (cases descupdate)
  moreover obtain fault memattrs paddress' vaddress where
    "addrdesc = \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                  AddressDescriptor_paddress = paddress', AddressDescriptor_vaddress = vaddress\<rparr>"
    by (cases addrdesc)
  moreover obtain paddress ns where
    "paddress' = \<lparr>FullAddress_physicaladdress = paddress, FullAddress_NS = ns\<rparr>"
    by (cases paddress')
  ultimately show thesis using that by blast
qed

lemma PrePostE_bindS_TLBRecord:
  assumes f:
    "\<And>ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap descaddr cnp fault memattrs paddress ns vaddress.
        PrePostE (P' ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap descaddr
                     cnp fault memattrs paddress ns vaddress)
                 (f (\<lparr>TLBRecord_perms =
                        \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn, Permissions_pxn = pxn\<rparr>,
                      TLBRecord_nG = nG, TLBRecord_domain = domain, TLBRecord_contiguous = contiguous,
                      TLBRecord_level = level, TLBRecord_blocksize = blocksize,
                      TLBRecord_descupdate =
                        \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                         DescriptorUpdate_descaddr = descaddr \<rparr>,
                      TLBRecord_CnP = cnp,
                      TLBRecord_addrdesc =
                        \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                         AddressDescriptor_paddress =
                            \<lparr>FullAddress_physicaladdress = paddress,
                             FullAddress_NS = ns\<rparr>,
                         AddressDescriptor_vaddress = vaddress\<rparr> \<rparr>)) Q E"
    and m: "PrePostE P m
                     (\<lambda>r s. \<forall>ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap descaddr
                             cnp fault memattrs paddress ns vaddress.
                          \<lparr>TLBRecord_perms =
                             \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn, Permissions_pxn = pxn\<rparr>,
                           TLBRecord_nG = nG, TLBRecord_domain = domain, TLBRecord_contiguous = contiguous,
                           TLBRecord_level = level, TLBRecord_blocksize = blocksize,
                           TLBRecord_descupdate =
                             \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                              DescriptorUpdate_descaddr = descaddr \<rparr>,
                           TLBRecord_CnP = cnp,
                           TLBRecord_addrdesc =
                             \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                              AddressDescriptor_paddress =
                                 \<lparr>FullAddress_physicaladdress = paddress,
                                  FullAddress_NS = ns\<rparr>,
                              AddressDescriptor_vaddress = vaddress\<rparr> \<rparr> = r \<longrightarrow>
                          P' ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap descaddr
                             cnp fault memattrs paddress ns vaddress s) E"
        (is "PrePostE P m ?R E")
  shows "PrePostE P (bindS m f) Q E"
proof (intro PrePostE_bindS_any)
  fix a
  show "PrePostE (?R a) (f a) Q E"
    by (cases a rule: TLBRecord_cases) (auto intro: f)
  show "PrePostE P m ?R E" using m .
qed

lemma PrePostE_bindS_prod15_TLBRecord14:
  assumes
    "\<And>x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x15 ap xn xxn pxn nG domain contiguous level
      blocksize af descupd_ap descaddr cnp fault memattrs paddress ns vaddress.
       PrePostE (P' x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 ap xn xxn pxn nG domain contiguous level
                    blocksize af descupd_ap descaddr cnp fault memattrs paddress ns vaddress x15)
                (f (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13,
                    \<lparr>TLBRecord_perms =
                      \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn, Permissions_pxn = pxn\<rparr>,
                     TLBRecord_nG = nG, TLBRecord_domain = domain, TLBRecord_contiguous = contiguous,
                     TLBRecord_level = level, TLBRecord_blocksize = blocksize,
                     TLBRecord_descupdate =
                       \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                        DescriptorUpdate_descaddr = descaddr \<rparr>,
                     TLBRecord_CnP = cnp,
                     TLBRecord_addrdesc =
                       \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                        AddressDescriptor_paddress =
                           \<lparr>FullAddress_physicaladdress = paddress, FullAddress_NS = ns\<rparr>,
                        AddressDescriptor_vaddress = vaddress\<rparr> \<rparr>, x15)) Q E"
    and "PrePostE P m
                  (\<lambda>r s. case r of (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15) \<Rightarrow>
                         (\<forall>ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap
                           descaddr cnp fault memattrs paddress ns vaddress.
                         (\<lparr>TLBRecord_perms =
                             \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn,
                              Permissions_pxn = pxn\<rparr>,
                           TLBRecord_nG = nG, TLBRecord_domain = domain, TLBRecord_contiguous = contiguous,
                           TLBRecord_level = level, TLBRecord_blocksize = blocksize,
                           TLBRecord_descupdate =
                             \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                              DescriptorUpdate_descaddr = descaddr \<rparr>,
                           TLBRecord_CnP = cnp,
                           TLBRecord_addrdesc =
                             \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                              AddressDescriptor_paddress =
                                 \<lparr>FullAddress_physicaladdress = paddress, FullAddress_NS = ns\<rparr>,
                              AddressDescriptor_vaddress = vaddress\<rparr> \<rparr>) = x14 \<longrightarrow>
                          P' x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 ap xn xxn pxn nG domain
                             contiguous level blocksize af descupd_ap descaddr cnp fault memattrs
                             paddress ns vaddress x15 s)) E"
    (is "PrePostE P m ?R E")
  shows "PrePostE P (bindS m f) Q E"
proof (intro PrePostE_bindS_any)
  fix a :: "'a \<times> 'b \<times> 'c \<times> 'd \<times> 'e \<times> 'f \<times> 'g \<times> 'h \<times> 'i \<times> 'j \<times> 'k \<times> 'l \<times> 'm \<times> TLBRecord \<times> 'n"
  obtain x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15
    where "a = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15)"
    by (cases a rule: prod15_cases)
  then show "PrePostE (?R a) (f a) Q E"
    by (cases x14 rule: TLBRecord_cases) (auto intro: assms)
  show "PrePostE P m ?R E" using assms(2) .
qed

lemmas PrePostE_bindS_TLBRecords = PrePostE_bindS_TLBRecord PrePostE_bindS_prod15_TLBRecord14

lemma option_case_prod_9_None_False_elim:
  assumes "case x of None \<Rightarrow> False
             | Some (x1, x2, x3, x4, x5, x6, x7, x8, x9) \<Rightarrow> P x1 x2 x3 x4 x5 x6 x7 x8 x9"
  obtains x1 x2 x3 x4 x5 x6 x7 x8 x9
  where "Some (x1, x2, x3, x4, x5, x6, x7, x8, x9) = x"
    and "P x1 x2 x3 x4 x5 x6 x7 x8 x9"
  using assms by (cases x) auto

lemma GetSlice_int_get_slice_int[simp]:
  "GetSlice_int (len :: 'a::len itself) n i = get_slice_int (int LENGTH('a)) n i"
  by (auto simp: GetSlice_int_def)

lemmas [simp] = ex_int_def ex_nat_def

declare extzv_def[simp]

lemma slice_mask_mask: "slice_mask outlen i l = (mask (nat l)) << (nat i)"
  by (auto simp: slice_mask_def mask_def)

lemma HasArchVersion_True: "HasArchVersion v = True"
  by (cases v; auto simp: HasArchVersion_def)

lemma HaveEL_True: "HaveEL el = True"
  by (auto simp: HaveEL_def)

lemmas Have_simps[simp] = HaveEL_True HasArchVersion_True Have52BitPAExt_def Have52BitVAExt_def
  HaveAccessFlagUpdateExt_def HaveAtomicExt_def HaveCommonNotPrivateTransExt_def
  HaveDirtyBitModifierExt_def HaveExtendedExecuteNeverExt_def HaveFJCVTZSExt_def HaveNVExt_def
  HavePACExt_def HavePANExt_def HavePrivATExt_def HaveStatisticalProfiling_def
  HaveTrapLoadStoreMultipleDeviceExt_def HaveUAOExt_def HaveVirtHostExt_def HaveRASExt_def
  HaveCRCExt_def AArch64_HaveHPDExt_def

lemma PAMax_simp: "PAMax () = 52" by (auto simp: PAMax_def IMPDEF_integer_def)

lemma Zeros__0_0[simp]: "Zeros__0 n = 0" by (auto simp: Zeros__0_def)
lemma IsZero_iff_eq0[simp]: "IsZero w \<longleftrightarrow> w = 0" by (auto simp: IsZero_def Zeros__0_def)

lemma ZeroExtend_simps[simp]:
  "\<And>N w. LENGTH('a) \<le> LENGTH('b) \<Longrightarrow> ZeroExtend__0 w N = return (ucast (w :: 'a::len word) :: 'b::len word)"
  "\<And>N w. LENGTH('c) \<le> LENGTH('d) \<Longrightarrow> ZeroExtend__1 N w = return (ucast (w :: 'c::len word) :: 'd::len word)"
  by (auto simp: ZeroExtend__1_def ZeroExtend__0_def)

lemma ZeroExtend__1_64_64_return: "ZeroExtend__1 64 (w :: 64 word) = return w"
  by auto

lemma undefined_bitvector_simp[simp]: "undefined_bitvector n = return 0"
  by (auto simp add: undefined_bitvector_def simp del: repeat.simps)

lemma hex_slice_13000000[simp]: "hex_slice ''0x13000000'' 52 0 = return (0x13000000 :: 52 word)"
  by (auto simp: hex_slice_def hexstring_to_bools_def hexchar_to_bool_list_def ext_list_def maybe_fail_def
                 subrange_list_def subrange_list_dec_def subrange_list_inc_def split_at_def)

definition aligned :: "'n::len word \<Rightarrow> int \<Rightarrow> bool" where
  "aligned w n \<equiv> n dvd uint w"

lemma aligned_8_mask_3: "aligned w 8 \<longleftrightarrow> (w AND mask 3) = 0"
  using and_mask_dvd[where n = 3]
  by (auto simp: aligned_def)

lemma aligned8_OR_distrib: "aligned (x OR y) 8 \<longleftrightarrow> aligned x 8 \<and> aligned y 8"
  by (auto simp: aligned_8_mask_3 word_bool_alg.conj_disj_distrib2)

lemma aligned8_ucast:
  fixes a :: "'a::len word"
  defines "b \<equiv> ucast a :: 'b::len word"
  assumes b: "3 \<le> LENGTH('b)"
  shows "aligned b 8 \<longleftrightarrow> aligned a 8"
  using b test_bit_size[of b] unfolding b_def
  by (auto simp: aligned_8_mask_3 word_and_mask_0_iff_not_testbits nth_ucast)

lemma aligned8_shiftl_3: "i \<ge> 3 \<Longrightarrow> aligned (x << i) 8"
  by (auto simp: aligned_8_mask_3 word_and_mask_0_iff_not_testbits nth_shiftl)

lemma aligned8_word_cat:
  fixes a :: "'a::len word" and b :: "'b::len word"
  defines "c \<equiv> word_cat a b :: 'c::len word"
  assumes b: "3 \<le> LENGTH('b)" and c: "LENGTH('b) \<le> LENGTH('c)"
  shows "aligned c 8 \<longleftrightarrow> aligned b 8"
  using b c unfolding c_def
  by (auto simp: word_cat_shiftl_OR aligned8_OR_distrib aligned8_shiftl_3 aligned8_ucast)

lemma slice_zeros_concat_slice_and_mask[simp]:
  fixes xs :: "'a::len word"
  shows "slice_zeros_concat outlen xs i l l' = (Word.slice (nat i) xs AND mask (nat l)) << nat l'"
proof -
  have "n - nat l' < LENGTH('a) \<and> n + nat i - nat l' < LENGTH('a)"
    if "xs !! (n + nat i - nat l')" for n
    using that by (auto dest: test_bit_size[of xs])
  then show ?thesis
    unfolding slice_zeros_concat_def slice_mask_mask
    by (intro word_eqI) (auto simp: ucast_shiftr word_ao_nth nth_shiftl nth_slice)
qed

lemmas aligned8_simps = aligned8_OR_distrib aligned8_shiftl_3 aligned8_word_cat aligned8_ucast

lemma place_slice_grainsize:
  assumes "grainsize \<ge> 0"
  shows "(place_slice 52 (w :: 64 word) grainsize (48 - grainsize) grainsize :: 52 word) =
         word_cat (0 :: 4 word) ((Word.slice (nat grainsize) w << nat grainsize) :: 48 word)"
  using assms
  by (intro word_eqI)
     (auto simp: place_slice_def slice_mask_mask nth_shiftl nth_shiftr nth_slice word_ao_nth nth_ucast)

lemma set_slice_of_bl_drop_take:
  fixes out :: "'a::len word" and bs :: "bool list"
  (*defines "v \<equiv> of_bl bs :: 'b::len word"*)
  assumes "n \<ge> 0" and "slice_len > 0" and "n + slice_len \<le> int LENGTH('a)" (*and "length bs = LENGTH('b)"*)
  shows "set_slice out_len slice_len (out :: 'a::len word) n v =
           of_bl (take (LENGTH('a) - nat n - nat slice_len) (to_bl out) @
                  to_bl v @
                  drop (LENGTH('a) - nat n) (to_bl out))"
  using assms unfolding set_slice_def
  by (auto simp: update_subrange_vec_dec_update_subrange_list_dec update_subrange_list_dec_drop_take nat_add_distrib)

lemma NOT_of_bl[simp]:
  fixes bs :: "bool list"
  defines "w \<equiv> of_bl bs :: 'a::len word"
  assumes "length bs = LENGTH('a)"
  shows "NOT w = of_bl (map Not bs)"
  using assms by (intro word_eqI) (auto simp: word_ops_nth_size test_bit_of_bl rev_map)

lemma of_bl_AND_of_bl:
  assumes "length l = length r"
  shows "(of_bl l) AND (of_bl r) = of_bl (map2 (\<and>) l r)"
  using assms
  by (intro word_eqI) (auto simp: word_ops_nth_size test_bit_of_bl map2_def rev_map zip_rev[symmetric])

lemma True_OR_1word_absorb: "1 OR (w :: 1 word) = 1"
  by (intro word_eqI) (auto simp: word_ao_nth)

lemma to_bl_1_1word: "to_bl (1 :: 1 word) = [True]"
  by eval

lemma of_bl_test_bit_1word[simp]: "of_bl [w !! 0] = (w :: 1 word)"
  by (intro word_eqI) (auto simp: test_bit_of_bl)

lemma all_bool_neq_or_iff: "(\<forall>b. x = (\<not>b) \<or> P b) = P x"
  by (cases x) (auto simp: all_bool_eq)

lemma arg_cong5:
  assumes "a = a'" and "b = b'" and "c = c'" and "d = d'" and "e = e'"
  shows "f a b c d e = f a' b' c' d' e'"
  using assms by auto

lemma Suc_Suc_0_eq_2: "Suc (Suc 0) = 2"
  by auto

lemma nth_rev_drop: "i < length xs - n \<Longrightarrow> rev (drop n xs) ! i = rev xs ! i"
  by (auto simp: rev_drop)

lemma nth_rev_to_bl:
  fixes w :: "'a::len word"
  assumes "i < LENGTH('a)"
  shows "rev (to_bl w) ! i = w !! i"
  using assms by (auto simp: test_bit_bl)

lemma Let_const[simp]: "(let x = y in f) = f"
  by auto

lemma word_slice_if_distrib: "(Word.slice n (if c then x else y) = z) \<longleftrightarrow> (if c then Word.slice n x = z else Word.slice n y = z)"
  by auto

lemma word4_and3_exhaust:
  fixes x :: "4 word"
  shows "x AND 3 = 0 \<longrightarrow> x = 0 \<or> x = 4 \<or> x = 8 \<or> x = 12"
  by (cases x rule: exhaustive_4_word) auto

lemma word4_and3_exhaust':
  fixes x :: "4 word"
  assumes "x AND 3 = 0" and "x \<noteq> 0" and "x \<noteq> 4" and "x \<noteq> 8"
  shows "x = 12"
  using assms by (cases x rule: exhaustive_4_word) auto

lemma [simp]:
  "bitU_of_bool b = B0 \<longleftrightarrow> \<not>b"
  "bitU_of_bool b = B1 \<longleftrightarrow> b"
  by (auto simp: bitU_of_bool_def)

lemma word1_OR_of_bl_disj[simp]:
  fixes w :: "1 word"
  shows "w OR of_bl [b] = of_bl [w !! 0 \<or> b]" and "of_bl [b] OR w = of_bl [b \<or> w !! 0]"
  by (intro word_eqI; auto simp: word_ao_nth test_bit_of_bl)+

lemma nat_lt_2_cases:
  fixes n :: nat
  assumes "n < 2" and "P 0" and "P 1"
  shows "P n"
  using assms by (cases n) auto

lemma word2_OR_of_bl_disj[simp]:
  fixes w :: "2 word"
  shows "w OR of_bl [b1, b0] = of_bl [w !! 1 \<or> b1, w !! 0 \<or> b0]"
    and "of_bl [b1, b0] OR w = of_bl [b1 \<or> w !! 1, b0 \<or> w !! 0]"
  by (intro word_eqI; auto elim!: nat_lt_2_cases simp: word_ao_nth test_bit_of_bl)+

lemma word2_of_bl_test_bits_eq[simp]:
  "of_bl [w !! Suc 0, w !! 0] = (w :: 2 word)"
  by (intro word_eqI; auto elim!: nat_lt_2_cases simp: test_bit_of_bl)

lemma set_slice_2_1_of_bl[simp]:
  "set_slice 2 1 (out :: 2 word) 1 (v :: 1 word) = of_bl [v !! 0, out !! 0]"
  "set_slice 2 1 (out :: 2 word) 0 (v :: 1 word) = of_bl [out !! 1, v !! 0]"
  by (intro word_eqI;
      auto simp: set_slice_def update_subrange_vec_dec_update_subrange_list_dec
                 update_subrange_list_dec_drop_take test_bit_of_bl nth_rev nth_append to_bl_nth
                 elim!: nat_lt_2_cases)+

lemma case_prod_elims:
  "\<And>Q P z thesis. Q (case z of (a, b, c, d, e, f, g) \<Rightarrow> P a b c d e f g) \<Longrightarrow> (\<And>a b c d e f g. z = (a, b, c, d, e, f, g) \<Longrightarrow> Q (P a b c d e f g) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  "\<And>Q P z thesis. Q (case z of (a, b, c, d, e, f) \<Rightarrow> P a b c d e f) \<Longrightarrow> (\<And>a b c d e f. z = (a, b, c, d, e, f) \<Longrightarrow> Q (P a b c d e f) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  "\<And>Q P z thesis. Q (case z of (a, b, c, d, e) \<Rightarrow> P a b c d e) \<Longrightarrow> (\<And>a b c d e. z = (a, b, c, d, e) \<Longrightarrow> Q (P a b c d e) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  "\<And>Q P z thesis. Q (case z of (a, b, c, d) \<Rightarrow> P a b c d) \<Longrightarrow> (\<And>a b c d. z = (a, b, c, d) \<Longrightarrow> Q (P a b c d) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  "\<And>Q P z thesis. Q (case z of (a, b, c) \<Rightarrow> P a b c) \<Longrightarrow> (\<And>a b c. z = (a, b, c) \<Longrightarrow> Q (P a b c) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  "\<And>Q P z thesis. Q (case z of (a, b) \<Rightarrow> P a b) \<Longrightarrow> (\<And>a b. z = (a, b) \<Longrightarrow> Q (P a b) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  by auto

lemmas Run_case_prodE = case_prod_elims[where Q = "\<lambda>c. Run c t a" for t a]

lemma set_slice_set_bit[simp]:
  assumes "nat i < LENGTH('a)"
  shows "set_slice len 1 (w :: 'a::len word) i (b :: 1 word) = set_bit w (nat i) (b !! 0)"
  using assms
  by (intro word_eqI)
     (auto simp: set_slice_def test_bit_set_gen update_subrange_vec_dec_def
                word_update_def Let_def test_bit_of_bl nth_append nth_rev to_bl_nth)

lemma slice_set_bit_below:
  shows "m > n \<Longrightarrow> Word.slice m (set_bit w n x) = Word.slice m w"
  by (intro word_eqI) (auto simp: nth_slice test_bit_set_gen)

lemma slice_set_bit_above:
  fixes w :: "'a::len word" and m :: nat
  defines "w' \<equiv> Word.slice m w :: 'b::len word"
  assumes "m + LENGTH('b) < n"
  shows "Word.slice m (set_bit w n x) = w'"
  using assms by (intro word_eqI) (auto simp: nth_slice test_bit_set_gen)

lemma set_bit_3_word:
  fixes w :: "3 word"
  shows "set_bit w 0 x = of_bl [w !! 2, w !! (Suc 0), x]"
        "set_bit w (Suc 0) x = of_bl [w !! 2, x, w !! 0]"
        "set_bit w 2 x = of_bl [x, w !! (Suc 0), w !! 0]"
  by (cases w rule: exhaustive_3_word; cases x; auto)+

lemma case_None_False_exists_Some:
  "(case x of None \<Rightarrow> False | Some y \<Rightarrow> P y) \<longleftrightarrow> (\<exists>y. Some y = x \<and> P y)"
  by (auto split: option.splits)

lemma case_None_Not_exists_Some:
  "\<not>P f1 \<Longrightarrow> (P (case x of None \<Rightarrow> f1 | Some y \<Rightarrow> f2 y)) = (\<exists>y. Some y = x \<and> P (f2 y))"
  by (auto split: option.splits)

lemma Some_eq_if_Some_None_iff_eq:
  "(Some x = (if c then Some y else None)) \<longleftrightarrow> (c \<and> x = y)"
  by auto

lemma Align__1_8_iff_aligned_8[simp]: "(w = Align__1 w 8) \<longleftrightarrow> aligned (w :: 52 word) 8"
proof
  assume "w = Align__1 w 8"
  then have w: "w = word_of_int (8 * (uint w div 8))"
    by (auto simp: Align__1_def Align__0_def of_bl_bin_word_of_int)
  have 8: "(8 :: int) dvd 2 ^ 52" by eval
  show "aligned w 8"
    using dvd_mod_iff[OF 8]
    by (subst w) (auto simp: aligned_def uint_word_of_int)
next
  assume "aligned w 8"
  then show "w = Align__1 w 8"
    by (auto simp: Align__1_def Align__0_def aligned_def of_bl_bin_word_of_int)
qed

end


           (*-------------------------------------------*
            |                  DFtick                   |
            |                                           |
            |                   June 2007               |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory DFP_DFtick
imports DFP_Deadlock
begin

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

         1. The most abstract deadlockfree process DFtick

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

declare csp_prefix_ss_def[simp]

(*********************************************************
                         event
 *********************************************************)

(* typedecl Event    any event *)

datatype DFtickName = DFtick

(*** Spc ***)

primrec
  DFtickfun ::  "(DFtickName, 'event) pnfun"
where
  "DFtickfun (DFtick) = (! x ->  $(DFtick)) |~| SKIP "
(*
defs (overloaded)
Set_DFtickfun_def [simp]: "PNfun == DFtickfun"
*)

overloading Set_DFtickfun ==
  "PNfun :: (DFtickName, 'event) pnfun"
begin
  definition "PNfun :: (DFtickName, 'event) pnfun == DFtickfun"
end

declare Set_DFtickfun_def [simp]

(*---------------------------------------------------*
 |                  n-replicted spec                 |
 *---------------------------------------------------*)

datatype RDFtickName = RDFtick

(*** Spc ***)

primrec
  NatDFtick ::
     "nat => (RDFtickName, 'event) proc
          => (RDFtickName, 'event) proc"
where
    "NatDFtick 0 P = P"
  | "NatDFtick (Suc n) P = ((! x -> NatDFtick n P) |~| SKIP) |~| P"

primrec
  RDFtickfun ::
    "RDFtickName
         => (RDFtickName, 'event) proc"
where
  "RDFtickfun (RDFtick)
     = (! x -> (!nat n .. NatDFtick n ($(RDFtick))) |~| SKIP)"
(*
defs (overloaded)
Set_RDFtickfun_def [simp]: "PNfun == RDFtickfun"
*)

overloading Set_RDFtickfun ==
  "PNfun :: (RDFtickName, 'event) pnfun"
begin
  definition "PNfun :: (RDFtickName, 'event) pnfun == RDFtickfun"
end

declare Set_RDFtickfun_def [simp]

(*********************************************************
              DFtick lemma
 *********************************************************)

lemma guardedfun_DFtick[simp]:
      "guardedfun DFtickfun"
by (simp add: guardedfun_def, rule allI, induct_tac p, simp_all)

lemma guardedfun_RDFtick[simp]:
      "guardedfun RDFtickfun"
apply (simp add: guardedfun_def)
apply (rule allI)
apply (induct_tac p)
apply (simp)
apply (rule allI)
apply (induct_tac n)
apply (simp_all)
done

(* -------------------------------------------------*
 |                                                  |
 |  syntactical approach --> semantical approach    |
 |                                                  |
 * -------------------------------------------------*)

(*** sub ***)

lemma DFtick_is_DeadlockFree:
  "(($DFtick) :: (DFtickName, 'event) proc) isDeadlockFree"
apply (simp add: DeadlockFree_def)
apply (rule allI)
apply (induct_tac s rule: induct_trace)

(* base case *)
apply (simp)
apply (subgoal_tac
  "((DFtickfun (DFtick))::(DFtickName, 'event) proc) =F
   ($(DFtick)::(DFtickName, 'event) proc)")
apply (simp add: cspF_eqF_semantics)
apply (erule conjE)
apply (rotate_tac 1)
apply (drule sym)
apply (simp)
apply (rotate_tac 1)
apply (drule sym)
apply (simp (no_asm) add: in_failures)
apply (simp add: Evset_def)
apply (force)

apply (cspF_unwind)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)

apply (subgoal_tac
  "failures (($DFtick)::(DFtickName, 'event) proc) MF =
   failures ((DFtickfun DFtick)::(DFtickName, 'event) proc) MF")
apply (simp)
apply (rotate_tac -1)
apply (drule sym)
apply (simp (no_asm) add: in_failures)
apply (intro impI)
apply (simp add: in_failures)

apply (subgoal_tac
  "(($DFtick)::(DFtickName, 'event) proc) =F
   ((DFtickfun DFtick)::(DFtickName, 'event) proc)")
apply (simp add: cspF_eqF_semantics)
apply (cspF_unwind)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
done

(*** main ***)

lemma DFtick_DeadlockFree:
  "($DFtick :: (DFtickName, 'event) proc) <=F P ==> P isDeadlockFree"
apply (insert DFtick_is_DeadlockFree)
apply (simp add: DeadlockFree_def)
apply (simp add: cspF_refF_semantics)
apply (auto)
done

(* -------------------------------------------------*
 |                                                  |
 |  semantical approach --> syntactical approach    |
 |                                                  |
 * -------------------------------------------------*)

lemma traces_included_in_DFtick:
  "t :t traces ((FIX DFtickfun) (DFtick)) (fstF o MF)"
apply (induct_tac t rule: induct_trace)

 (* <> *)
 apply (simp)

 (* <Tick> *)
 apply (simp add: FIX_def)
 apply (simp add: in_traces)
 apply (rule_tac x="Suc 0" in exI)
 apply (simp add: FIXn_def)
 apply (simp add: Subst_procfun_prod_def)
 apply (simp add: in_traces)

 (* <Eva>^^^s *)
 apply (simp add: FIX_def)
 apply (simp add: in_traces)
 apply (erule disjE)

 apply (simp)
 apply (rule_tac x="Suc 0" in exI)
 apply (simp add: FIXn_def)
 apply (simp add: Subst_procfun_prod_def)
 apply (simp add: in_traces)

 apply (erule exE)
 apply (rule_tac x="Suc n" in exI)
 apply (simp add: FIXn_def)
 apply (simp add: Subst_procfun_prod_def)
 apply (simp add: in_traces)
done

lemma failures_included_in_DFtick_lm:
  "(X ~= UNIV | Tick : sett t) -->
   (t,X) :f failures ((FIX DFtickfun) (DFtick)) MF"
apply (induct_tac t rule: induct_trace)

 (* <> *)
apply (simp add: FIX_def)
apply (intro impI)
apply (simp add: in_failures)
apply (rule_tac x="Suc 0" in exI)
apply (simp add: FIXn_def)
apply (simp add: Subst_procfun_prod_def)
apply (simp add: in_failures)

apply (case_tac "EX x. x ~: X")
apply (elim exE)
apply (case_tac "x = Tick")
apply (simp)
apply (simp add: Evset_def)
apply (force)
apply (simp add: not_Tick_to_Ev)
apply (force)
apply (force)

 (* <Tick> *)
 apply (simp add: FIX_def)
apply (simp add: in_failures)
apply (rule_tac x="Suc 0" in exI)
apply (simp add: FIXn_def)
apply (simp add: Subst_procfun_prod_def)
apply (simp add: in_failures)

 (* <Eva>^^^s *)
apply (intro impI)
 apply (simp add: FIX_def)
apply (simp add: in_failures)
apply (erule exE)
apply (rule_tac x="Suc n" in exI)
apply (simp add: FIXn_def)
apply (simp add: Subst_procfun_prod_def)
apply (simp add: in_failures)
done

lemma failures_included_in_DFtick:
  "[| X ~= UNIV | Tick : sett t |] ==>
   (t,X) :f failures ((FIX DFtickfun) (DFtick)) MF"
by (simp add: failures_included_in_DFtick_lm)

lemma DeadlockFree_DFtick:
  "P isDeadlockFree ==> ($DFtick :: (DFtickName, 'event) proc) <=F P"
apply (rule cspF_rw_left)
apply (rule cspF_FIX)
prefer 2
apply (simp)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp add: cspF_refF_semantics)

apply (rule conjI)

(* trace *)
apply (simp add: subdomT_iff)
apply (simp add: traces_included_in_DFtick)

(* failures *)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (rule failures_included_in_DFtick)
apply (simp add: DeadlockFree_def)
apply (drule_tac x="s" in spec)
apply (auto)
done

(* -------------------------------------------------*
 |                                                  |
 |  syntactical approach <--> semantical approach   |
 |                                                  |
 * -------------------------------------------------*)

theorem DeadlockFree_DFtick_ref:
  "P isDeadlockFree = (($DFtick:: (DFtickName, 'event) proc) <=F P)"
apply (rule)
apply (simp add: DeadlockFree_DFtick)
apply (simp add: DFtick_DeadlockFree)
done

(*================================================================*
 |                                                                |
 |                   n-replicted DF specification                 |
 |                                                                |
 *================================================================*)

(*******************************************************************
        relating function between DFtickName and Rep...
 *******************************************************************)

(*** ref1 ***)

primrec
  RepDF_to_DF :: "RDFtickName =>
                 (DFtickName, 'event) proc"
where
  "RepDF_to_DF (RDFtick) = ($DFtick)"

lemma RDFtick_DFtick_ref1_induct_lm:
  "(($DFtick)::(DFtickName, 'event) proc)
   <=F (NatDFtick n (($RDFtick)::(RDFtickName,'event)proc)) << RepDF_to_DF"
apply (induct_tac n)
apply (simp_all)
apply (rule cspF_Int_choice_right)
apply (rule cspF_rw_left)
apply (rule cspF_unwind)
apply (simp_all)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp)
done

lemma RDFtick_DFtick_ref1:
  "($DFtick :: (DFtickName, 'event) proc) <=F $RDFtick"
apply (rule cspF_fp_induct_right[of _ _ "RepDF_to_DF"])
apply (simp)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp)

apply (induct_tac p)
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_unwind)
apply (simp)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp)
apply (rule cspF_decompo)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_decompo)
apply (simp)

apply (rule cspF_Rep_int_choice_right)
apply (simp add: RDFtick_DFtick_ref1_induct_lm)
apply (simp)
done

(*** ref2 ***)

primrec
  DF_to_RepDF :: "DFtickName =>
                 (RDFtickName, 'event) proc"
where
  "DF_to_RepDF (DFtick) = ($RDFtick)"

lemma RDFtick_DFtick_ref2:
  "$RDFtick <=F ($DFtick :: (DFtickName, 'event) proc)"
apply (rule cspF_fp_induct_right[of _ _ "DF_to_RepDF"])
apply (simp)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp)

apply (induct_tac p)
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_unwind)
apply (simp)
apply (simp add: CPOmode_or_CMSmode_or_MIXmode)
apply (simp)
apply (rule cspF_decompo)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_decompo)
apply (simp)

apply (rule cspF_Rep_int_choice_left)
apply (rule_tac x="0" in exI)
apply (simp)
apply (simp)
done

(**************************** =F****************************)

lemma RDFtick_DFtick:
  "$RDFtick =F ($DFtick :: (DFtickName, 'event) proc)"
apply (simp add: cspF_eq_ref_iff)
apply (simp add: RDFtick_DFtick_ref1)
apply (simp add: RDFtick_DFtick_ref2)
done

(* ---------------------------------------------------*
 |                                                    |
 |  syntactical approach 2 <--> semantical approach   |
 |                                                    |
 * ---------------------------------------------------*)

theorem DeadlockFree_RDFtick_ref:
  "P isDeadlockFree = (($RDFtick :: (RDFtickName, 'event) proc) <=F P)"
apply (simp add: DeadlockFree_DFtick_ref)
apply (rule)
apply (rule cspF_rw_left)
apply (rule RDFtick_DFtick)
apply (simp)

apply (rule cspF_rw_left)
apply (rule RDFtick_DFtick[THEN cspF_sym])
apply (simp)
done

(* ------------------------------------------------------------------ *)

declare csp_prefix_ss_def[simp del]

end


theory Ipassmt
imports Common_Primitive_Syntax
        "../Semantics_Ternary/Primitive_Normalization"
        Simple_Firewall.Iface
        Simple_Firewall.IP_Addr_WordInterval_toString (*for debug pretty-printing*)
        Automatic_Refinement.Misc (*dependnecy!*)
begin
  hide_const Misc.uncurry
  hide_fact Misc.uncurry_def

  text\<open>A mapping from an interface to its assigned ip addresses in CIDR notation\<close>
  type_synonym 'i ipassignment="iface \<rightharpoonup> ('i word \<times> nat) list" (*technically, a set*)

subsection\<open>Sanity checking for an @{typ "'i ipassignment"}.\<close>

  text\<open>warning if interface map has wildcards\<close>
  definition ipassmt_sanity_nowildcards :: "'i ipassignment \<Rightarrow> bool" where
    "ipassmt_sanity_nowildcards ipassmt \<equiv> \<forall> iface \<in> dom ipassmt. \<not> iface_is_wildcard iface"

    text\<open>Executable of the @{typ "'i ipassignment"} is given as a list.\<close>

  (* use this in all exported code*)
  (*TODO: generate useful error message in exported code*)
  definition map_of_ipassmt :: "(iface \<times> ('i word \<times> nat) list) list \<Rightarrow> iface \<rightharpoonup> ('i word \<times> nat) list" where
    "map_of_ipassmt ipassmt = (
      if
        distinct (map fst ipassmt) \<and> ipassmt_sanity_nowildcards (map_of ipassmt)
      then
        map_of ipassmt
      else undefined \<^cancel>\<open>undefined_ipassmt_must_be_distinct_and_dont_have_wildcard_interfaces\<close>)"

  text\<open>some additional (optional) sanity checks\<close>

  text\<open>sanity check that there are no zone-spanning interfaces\<close>
  definition ipassmt_sanity_disjoint :: "'i::len ipassignment \<Rightarrow> bool" where
    "ipassmt_sanity_disjoint ipassmt \<equiv> \<forall> i1 \<in> dom ipassmt. \<forall> i2 \<in> dom ipassmt. i1 \<noteq> i2 \<longrightarrow>
          ipcidr_union_set (set (the (ipassmt i1))) \<inter> ipcidr_union_set (set (the (ipassmt i2))) = {}"

  lemma[code_unfold]: "ipassmt_sanity_disjoint (map_of ipassmt) \<longleftrightarrow>
    (let Is = fst` set ipassmt in
      (\<forall> i1 \<in> Is. \<forall> i2 \<in> Is. i1 \<noteq> i2 \<longrightarrow> wordinterval_empty (wordinterval_intersection (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1))))  (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))))"
    apply(simp add: ipassmt_sanity_disjoint_def Map.dom_map_of_conv_image_fst)
    apply(simp add: ipcidr_union_set_def)
    apply(simp add: l2wi)
    apply(simp add: ipcidr_to_interval_def)
    using ipset_from_cidr_ipcidr_to_interval by blast

  text\<open>Checking that the ipassmt covers the complete ipv4 address space.\<close>
  definition ipassmt_sanity_complete :: "(iface \<times> ('i::len word \<times> nat) list) list \<Rightarrow> bool" where
    "ipassmt_sanity_complete ipassmt \<equiv> distinct (map fst ipassmt) \<and> (\<Union>(ipcidr_union_set ` set ` (ran (map_of ipassmt)))) = UNIV"

    lemma[code_unfold]: "ipassmt_sanity_complete ipassmt \<longleftrightarrow> distinct (map fst ipassmt) \<and> (let range = map snd ipassmt in
        wordinterval_eq (wordinterval_Union (map (l2wi \<circ> (map ipcidr_to_interval)) range)) wordinterval_UNIV
        )"
     apply(cases "distinct (map fst ipassmt)")
      apply(simp add: ipassmt_sanity_complete_def)
      apply(simp add: Map.ran_distinct)
      apply(simp add: wordinterval_eq_set_eq wordinterval_Union)
      apply(simp add: l2wi)
      apply(simp add: ipcidr_to_interval_def)
      apply(simp add: ipcidr_union_set_def ipset_from_cidr_ipcidr_to_interval; fail)
     apply(simp add: ipassmt_sanity_complete_def)
     done

    value[code] "ipassmt_sanity_nowildcards (map_of [(Iface ''eth1.1017'', [(ipv4addr_of_dotdecimal (131,159,14,240), 28)])])"

  fun collect_ifaces' :: "'i::len common_primitive rule list \<Rightarrow> iface list" where
    "collect_ifaces' [] = []" |
    "collect_ifaces' ((Rule m a)#rs) = filter (\<lambda>iface. iface \<noteq> ifaceAny) (
                                      (map (\<lambda>x. case x of Pos i \<Rightarrow> i | Neg i \<Rightarrow> i) (fst (primitive_extractor (is_Iiface, iiface_sel) m))) @
                                      (map (\<lambda>x. case x of Pos i \<Rightarrow> i | Neg i \<Rightarrow> i) (fst (primitive_extractor (is_Oiface, oiface_sel) m))) @ collect_ifaces' rs)"

  definition collect_ifaces :: "'i::len common_primitive rule list \<Rightarrow> iface list" where
    "collect_ifaces rs \<equiv> mergesort_remdups (collect_ifaces' rs)"
  lemma "set (collect_ifaces rs) = set (collect_ifaces' rs)"
    by(simp add: collect_ifaces_def mergesort_remdups_correct)

  text\<open>sanity check that all interfaces mentioned in the ruleset are also listed in the ipassmt. May fail for wildcard interfaces in the ruleset.\<close>

  (*primitive_extractor requires normalized_nnf_primitives*)
  definition ipassmt_sanity_defined :: "'i::len common_primitive rule list \<Rightarrow> 'i ipassignment \<Rightarrow> bool" where
    "ipassmt_sanity_defined rs ipassmt \<equiv> \<forall> iface \<in> set (collect_ifaces rs). iface \<in> dom ipassmt"

    lemma[code]: "ipassmt_sanity_defined rs ipassmt \<longleftrightarrow> (\<forall> iface \<in> set (collect_ifaces rs). ipassmt iface \<noteq> None)"
      by(simp add: ipassmt_sanity_defined_def Map.domIff)

    lemma "ipassmt_sanity_defined [
         Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (Iface ''eth1.1017'')))) action.Accept,
         Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (ifaceAny)))) action.Accept,
         Rule MatchAny action.Drop]
             (map_of [(Iface ''eth1.1017'', [(ipv4addr_of_dotdecimal (131,159,14,240), 28)])])" by eval

  (*TODO: use and add code equation*)
  definition ipassmt_ignore_wildcard :: "'i::len ipassignment \<Rightarrow> 'i ipassignment" where
    "ipassmt_ignore_wildcard ipassmt \<equiv> \<lambda>k. case ipassmt k of None \<Rightarrow> None
                                                           | Some ips \<Rightarrow> if ipcidr_union_set (set ips) = UNIV then None else Some ips"

  lemma ipassmt_ignore_wildcard_le: "ipassmt_ignore_wildcard ipassmt \<subseteq>\<^sub>m ipassmt"
    apply(simp add: ipassmt_ignore_wildcard_def map_le_def)
    apply(clarify)
    apply(simp split: option.split_asm if_split_asm)
    done

  definition ipassmt_ignore_wildcard_list:: "(iface \<times> ('i::len word \<times> nat) list) list \<Rightarrow> (iface \<times> ('i word \<times> nat) list) list" where
    "ipassmt_ignore_wildcard_list ipassmt = filter (\<lambda>(_,ips).  \<not> wordinterval_eq (l2wi (map ipcidr_to_interval ips)) wordinterval_UNIV) ipassmt"

  (*distinct fst ipassmt notwendig?*)
  lemma "distinct (map fst ipassmt) \<Longrightarrow>
    map_of (ipassmt_ignore_wildcard_list ipassmt) = ipassmt_ignore_wildcard (map_of ipassmt)"
      apply(simp add: ipassmt_ignore_wildcard_list_def ipassmt_ignore_wildcard_def)
      apply(simp add: wordinterval_eq_set_eq)
      apply(simp add: l2wi)
      apply(simp add: ipcidr_to_interval_def)
      apply(simp add: fun_eq_iff)
      apply(clarify)
      apply(induction ipassmt)
       apply(simp; fail)
      apply(simp)
      apply(simp split:option.split option.split_asm)
      apply(simp add: ipcidr_union_set_def ipset_from_cidr_ipcidr_to_interval)
      apply(simp add: case_prod_unfold)
      by blast
      (*apply(safe)
                       apply(simp_all)
      by (simp add: rev_image_eqI)*)

  text\<open>Debug algorithm with human-readable output\<close>
  definition debug_ipassmt_generic
    :: "('i::len wordinterval \<Rightarrow> string) \<Rightarrow>
          (iface \<times> ('i word \<times> nat) list) list \<Rightarrow> 'i common_primitive rule list \<Rightarrow> string list" where
    "debug_ipassmt_generic toStr ipassmt rs \<equiv> let ifaces = (map fst ipassmt) in [
      ''distinct: '' @ (if distinct ifaces then ''passed'' else ''FAIL!'')
      , ''ipassmt_sanity_nowildcards: '' @
          (if ipassmt_sanity_nowildcards (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString iface_sel (filter iface_is_wildcard ifaces))
      , ''ipassmt_sanity_defined (interfaces defined in the ruleset are also in ipassmt): '' @
          (if ipassmt_sanity_defined rs (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString iface_sel [i \<leftarrow> (collect_ifaces rs). i \<notin> set ifaces])
      , ''ipassmt_sanity_disjoint (no zone-spanning interfaces): '' @
          (if ipassmt_sanity_disjoint (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString (\<lambda>(i1,i2). ''('' @ iface_sel i1 @ '','' @ iface_sel i2 @ '')'')
               [(i1,i2) \<leftarrow> List.product ifaces ifaces. i1 \<noteq> i2 \<and>
                \<not> wordinterval_empty (wordinterval_intersection
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1))))
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))
          ])
      , ''ipassmt_sanity_disjoint excluding UNIV interfaces: '' @
          (let ipassmt = ipassmt_ignore_wildcard_list ipassmt;
               ifaces = (map fst ipassmt)
           in
          (if ipassmt_sanity_disjoint (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString (\<lambda>(i1,i2). ''('' @ iface_sel i1 @ '','' @ iface_sel i2 @ '')'')
               [(i1,i2) \<leftarrow> List.product ifaces ifaces. i1 \<noteq> i2 \<and>
                \<not> wordinterval_empty (wordinterval_intersection
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1))))
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))
          ]))
       , ''ipassmt_sanity_complete: '' @
          (if ipassmt_sanity_complete ipassmt
           then ''passed''
           else ''the following is not covered: '' @
            toStr (wordinterval_setminus wordinterval_UNIV (wordinterval_Union (map (l2wi \<circ> (map ipcidr_to_interval)) (map snd ipassmt)))))
      , ''ipassmt_sanity_complete excluding UNIV interfaces: '' @
          (let ipassmt = ipassmt_ignore_wildcard_list ipassmt
           in
          (if ipassmt_sanity_complete ipassmt
           then ''passed''
           else ''the following is not covered: '' @
            toStr (wordinterval_setminus wordinterval_UNIV (wordinterval_Union (map (l2wi \<circ> (map ipcidr_to_interval)) (map snd ipassmt))))))
      ]"

  definition "debug_ipassmt_ipv4 \<equiv> debug_ipassmt_generic ipv4addr_wordinterval_toString"
  definition "debug_ipassmt_ipv6 \<equiv> debug_ipassmt_generic ipv6addr_wordinterval_toString"

  lemma dom_ipassmt_ignore_wildcard:
    "i\<in>dom (ipassmt_ignore_wildcard ipassmt) \<longleftrightarrow> i \<in> dom ipassmt \<and> ipcidr_union_set (set (the (ipassmt i))) \<noteq> UNIV"
    apply(simp add: ipassmt_ignore_wildcard_def)
    apply(rule)
     apply(clarify)
     apply(simp split: option.split_asm if_split_asm)
     apply blast
    apply(clarify)
    apply(simp)
    done

  lemma ipassmt_ignore_wildcard_the:
    "ipassmt i = Some ips \<Longrightarrow> ipcidr_union_set (set ips) \<noteq> UNIV \<Longrightarrow> (the (ipassmt_ignore_wildcard ipassmt i)) = ips"
    "ipassmt_ignore_wildcard ipassmt i = Some ips \<Longrightarrow> the (ipassmt i) = ips"
    "ipassmt_ignore_wildcard ipassmt i = Some ips \<Longrightarrow> ipcidr_union_set (set ips) \<noteq> UNIV"
    by (simp_all add: ipassmt_ignore_wildcard_def split: option.split_asm if_split_asm)

  lemma ipassmt_sanity_disjoint_ignore_wildcards:
        "ipassmt_sanity_disjoint (ipassmt_ignore_wildcard ipassmt) \<longleftrightarrow>
         (\<forall>i1\<in>dom ipassmt.
          \<forall>i2\<in>dom ipassmt.
            ipcidr_union_set (set (the (ipassmt i1))) \<noteq> UNIV \<and>
            ipcidr_union_set (set (the (ipassmt i2))) \<noteq> UNIV \<and>
            i1 \<noteq> i2
            \<longrightarrow> ipcidr_union_set (set (the (ipassmt i1))) \<inter> ipcidr_union_set (set (the (ipassmt i2))) = {})"
    apply(simp add: ipassmt_sanity_disjoint_def)
    apply(rule)
     apply(clarify)
     apply(simp)
     subgoal for i1 i2 ips1 ips2
     apply(erule_tac x=i1 in ballE)
      prefer 2
      using dom_ipassmt_ignore_wildcard  apply (metis domI option.sel)
     apply(erule_tac x=i2 in ballE)
      prefer 2
      using dom_ipassmt_ignore_wildcard apply (metis domI domIff option.sel)
     by(simp add: ipassmt_ignore_wildcard_the; fail)
    apply(clarify)
    apply(simp)
    subgoal for i1 i2 ips1 ips2
    apply(erule_tac x=i1 in ballE)
     prefer 2
     using dom_ipassmt_ignore_wildcard apply auto[1]
    apply(erule_tac x=i2 in ballE)
     prefer 2
     using dom_ipassmt_ignore_wildcard apply auto[1]
    by(simp add: ipassmt_ignore_wildcard_the)
   done

  text\<open>Confusing names: @{const ipassmt_sanity_nowildcards} refers to wildcard interfaces.
       @{const ipassmt_ignore_wildcard} refers to the UNIV ip range.
\<close>
  lemma ipassmt_sanity_nowildcards_ignore_wildcardD:
    "ipassmt_sanity_nowildcards ipassmt \<Longrightarrow> ipassmt_sanity_nowildcards (ipassmt_ignore_wildcard ipassmt)"
    by (simp add: dom_ipassmt_ignore_wildcard ipassmt_sanity_nowildcards_def)

 lemma ipassmt_disjoint_nonempty_inj:
     assumes ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
        and ifce: "ipassmt ifce = Some i_ips"
        and a: "ipcidr_union_set (set i_ips) \<noteq> {}"
        and k: "ipassmt k = Some i_ips"
     shows "k = ifce"
     proof(rule ccontr)
       assume "k \<noteq> ifce"
       with ifce k ipassmt_disjoint have "ipcidr_union_set (set (the (ipassmt k))) \<inter> ipcidr_union_set (set (the (ipassmt ifce))) = {}"
         unfolding ipassmt_sanity_disjoint_def by fastforce
       thus False using a ifce k by auto
     qed

  lemma ipassmt_ignore_wildcard_None_Some:
    "ipassmt_ignore_wildcard ipassmt ifce = None \<Longrightarrow> ipassmt ifce = Some ips \<Longrightarrow> ipcidr_union_set (set ips) = UNIV"
    by (metis domI domIff dom_ipassmt_ignore_wildcard option.sel)

 (*can this lemma be somehow useful?
   maybe when rewriting, we can try to rewrite in the ignore_wildcard space and just constrain the the other area?*)
 lemma ipassmt_disjoint_ignore_wildcard_nonempty_inj:
     assumes ipassmt_disjoint: "ipassmt_sanity_disjoint (ipassmt_ignore_wildcard ipassmt)"
        and ifce: "ipassmt ifce = Some i_ips"
        and a: "ipcidr_union_set (set i_ips) \<noteq> {}"
        and k: "(ipassmt_ignore_wildcard ipassmt) k = Some i_ips"
     shows "k = ifce"
     proof(rule ccontr)
       assume "k \<noteq> ifce"
       show False
       proof(cases "(ipassmt_ignore_wildcard ipassmt) ifce")
       case (Some i_ips') (*proofs mainly by sledgehammer*)
         hence "i_ips' = i_ips" using ifce ipassmt_ignore_wildcard_the(2) by fastforce
         hence "(ipassmt_ignore_wildcard ipassmt) k = Some i_ips" using Some ifce ipassmt_ignore_wildcard_def k by auto
         thus False using Some \<open>i_ips' = i_ips\<close> \<open>k \<noteq> ifce\<close> a ipassmt_disjoint ipassmt_disjoint_nonempty_inj by blast
       next
       case None
         with ipassmt_ignore_wildcard_None_Some have "ipcidr_union_set (set i_ips) = UNIV" using ifce by auto
         thus False using ipassmt_ignore_wildcard_the(3) k by blast
       qed
     qed

 lemma ipassmt_disjoint_inj_k:
     assumes ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
        and ifce: "ipassmt ifce = Some ips"
        and k: "ipassmt k = Some ips'"
        and a: "p \<in> ipcidr_union_set (set ips)"
        and b: "p \<in> ipcidr_union_set (set ips')"
     shows "k = ifce"
     proof(rule ccontr)
       assume "k \<noteq> ifce"
       with ipassmt_disjoint have
          "ipcidr_union_set (set (the (ipassmt k))) \<inter> ipcidr_union_set (set (the (ipassmt ifce))) = {}"
         unfolding ipassmt_sanity_disjoint_def using ifce k by blast
       hence "ipcidr_union_set (set ips') \<inter> ipcidr_union_set (set ips) = {}" by(simp add: k ifce)
       thus False using a b by blast
     qed

 (*might also work when we ignore UNIVs in the ipassmt? (not tested)*)
 lemma ipassmt_disjoint_matcheq_iifce_srcip:
        assumes ipassmt_nowild: "ipassmt_sanity_nowildcards ipassmt"
            and ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
            and ifce: "ipassmt ifce = Some i_ips"
            and p_ifce: "ipassmt (Iface (p_iiface p)) = Some p_ips \<and> p_src p \<in> ipcidr_union_set (set p_ips)"
        shows   "match_iface ifce (p_iiface p) \<longleftrightarrow> p_src p \<in> ipcidr_union_set (set i_ips)"
    proof
     assume "match_iface ifce (p_iiface p)"
     thus "p_src p \<in> ipcidr_union_set (set i_ips)"
       apply(cases "ifce = Iface (p_iiface p)")
        using ifce p_ifce apply force
       by (metis domI iface.sel iface_is_wildcard_def ifce ipassmt_nowild ipassmt_sanity_nowildcards_def match_iface.elims(2) match_iface_case_nowildcard)
   next
     assume a: "p_src p \<in> ipcidr_union_set (set i_ips)"
     \<comment> \<open>basically, we need to reverse the map @{term ipassmt}\<close>

     from ipassmt_disjoint_nonempty_inj[OF ipassmt_disjoint ifce] a have ipassmt_inj: "\<forall>k. ipassmt k = Some i_ips \<longrightarrow> k = ifce" by blast

     from ipassmt_disjoint_inj_k[OF ipassmt_disjoint ifce _ a] have ipassmt_inj_k:
      "\<And>k ips'. ipassmt k = Some ips' \<Longrightarrow> p_src p \<in> ipcidr_union_set (set ips') \<Longrightarrow> k = ifce" by simp

     have ipassmt_inj_p: "\<forall>ips'. p_src p \<in> ipcidr_union_set (set ips') \<and> (\<exists>k. ipassmt k = Some ips') \<longrightarrow> ips' = i_ips"
       apply(clarify)
       apply(rename_tac ips' k)
       apply(subgoal_tac "k = ifce")
        using ifce apply simp
       using ipassmt_inj_k by simp

     from p_ifce have "(Iface (p_iiface p)) = ifce" using ipassmt_inj_p ipassmt_inj by blast

     thus "match_iface ifce (p_iiface p)" using match_iface_refl by blast
   qed

  definition ipassmt_generic_ipv4 :: "(iface \<times> (32 word \<times> nat) list) list" where
    "ipassmt_generic_ipv4 = [(Iface ''lo'', [(ipv4addr_of_dotdecimal (127,0,0,0),8)])]"

  definition ipassmt_generic_ipv6 :: "(iface \<times> (128 word \<times> nat) list) list" where
    "ipassmt_generic_ipv6 = [(Iface ''lo'', [(1,128)])]" (*::1/128*)

subsection\<open>IP Assignment difference\<close>
  text\<open>Compare two ipassmts. Returns a list of tuples
    First entry of the tuple: things which are in the left ipassmt but not in the right.
    Second entry of the tupls: things which are in the right ipassmt but not in the left.\<close>
  definition ipassmt_diff
    :: "(iface \<times> ('i::len word \<times> nat) list) list \<Rightarrow> (iface \<times> ('i::len word \<times> nat) list) list
        \<Rightarrow> (iface \<times> ('i word \<times> nat) list \<times> ('i word \<times> nat) list) list"
  where
  "ipassmt_diff a b \<equiv> let
      t = \<lambda>s. (case s of None \<Rightarrow> Empty_WordInterval
                       | Some s \<Rightarrow> wordinterval_Union (map ipcidr_tuple_to_wordinterval s));
      k = \<lambda>x y d. cidr_split (wordinterval_setminus (t (map_of x d)) (t (map_of y d)))
    in
      [(d, (k a b d, k b a d)). d \<leftarrow> remdups (map fst (a @ b))]"

  text\<open>If an interface is defined in both ipassignments and there is no difference
       then the two ipassignements describe the same IP range for this interface.\<close>
  lemma ipassmt_diff_ifce_equal: "(ifce, [], []) \<in> set (ipassmt_diff ipassmt1 ipassmt2)  \<Longrightarrow>
         ifce \<in> dom (map_of ipassmt1) \<Longrightarrow> ifce \<in> dom (map_of ipassmt2) \<Longrightarrow>
           ipcidr_union_set (set (the ((map_of ipassmt1) ifce))) =
           ipcidr_union_set (set (the ((map_of ipassmt2) ifce)))"
    proof -
    have cidr_empty: "[] = cidr_split r \<Longrightarrow> wordinterval_to_set r = {}" for r :: "'a wordinterval"
      apply(subst cidr_split_prefix[symmetric])
      by(simp)
    show "(ifce, [], []) \<in> set (ipassmt_diff ipassmt1 ipassmt2)  \<Longrightarrow>
         ifce \<in> dom (map_of ipassmt1) \<Longrightarrow> ifce \<in> dom (map_of ipassmt2) \<Longrightarrow>
           ipcidr_union_set (set (the ((map_of ipassmt1) ifce))) =
           ipcidr_union_set (set (the ((map_of ipassmt2) ifce)))"
    apply(simp add: ipassmt_diff_def Let_def ipcidr_union_set_uncurry)
    apply(simp add: Set.image_iff)
    apply(elim conjE)
    apply(drule cidr_empty)+
    apply(simp)
    apply(simp add: domIff)
    apply(elim exE)
    apply(simp add: wordinterval_Union wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry)
    done
  qed

  lemma ipcidr_union_cidr_split[simp]: "ipcidr_union_set (set (cidr_split a)) = wordinterval_to_set a"
    by(simp add: ipcidr_union_set_uncurry cidr_split_prefix)

  lemma
    defines "assmt as ifce \<equiv> ipcidr_union_set (set (the ((map_of as ifce))))"
    assumes diffs: "(ifce, d1, d2) \<in> set (ipassmt_diff ipassmt1 ipassmt2)"
        and  doms: "ifce \<in> dom (map_of ipassmt1)" "ifce \<in> dom (map_of ipassmt2)"
    shows "ipcidr_union_set (set d1) = assmt ipassmt1 ifce - assmt ipassmt2 ifce"
          "ipcidr_union_set (set d2) = assmt ipassmt2 ifce - assmt ipassmt1 ifce"
    using assms by (clarsimp simp add: ipassmt_diff_def Let_def assmt_def wordinterval_Union; simp add: ipcidr_union_set_uncurry uncurry_def wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry)+

  text\<open>Explanation for interface @{term "Iface ''a''"}:
          Left ipassmt: The IP range 4/30 contains the addresses 4,5,6,7
          Diff: right ipassmt contains 6/32, so 4,5,7 is only in the left ipassmt.
          IP addresses 4,5 correspond to subnet 4/30.\<close>
  lemma "ipassmt_diff (ipassmt_generic_ipv4 @ [(Iface ''a'', [(4,30)])])
                       (ipassmt_generic_ipv4 @ [(Iface ''a'', [(6,32), (0,30)]), (Iface ''b'', [(42,32)])]) =
    [(Iface ''lo'', [], []),
     (Iface ''a'', [(4, 31),(7, 32)],
                   [(0, 30)]
     ),
     (Iface ''b'', [], [(42, 32)])]" by eval

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* Author: Thomas Sewell *)

section "Enumeration Instances for Words"

theory Word_Enum
imports Enumeration Word_Lib
begin

instantiation word :: (len) enum
begin

definition
  "(enum_class.enum :: ('a :: len) word list) \<equiv> map of_nat [0 ..< 2 ^ LENGTH('a)]"

definition
  "enum_class.enum_all (P :: ('a :: len) word \<Rightarrow> bool) \<longleftrightarrow> Ball UNIV P"

definition
  "enum_class.enum_ex (P :: ('a :: len) word \<Rightarrow> bool) \<longleftrightarrow> Bex UNIV P"

instance
  apply (intro_classes)
     apply (force simp: enum_word_def)
    apply (simp add: distinct_map enum_word_def)
    apply (rule subset_inj_on, rule word_unat.Abs_inj_on)
    apply (clarsimp simp add: unats_def)
   apply (simp add: enum_all_word_def)
  apply (simp add: enum_ex_word_def)
  done

end

lemma fromEnum_unat[simp]: "fromEnum (x :: 'a::len word) = unat x"
proof -
  have "enum ! the_index enum x = x" by (auto intro: nth_the_index)
  moreover
  have "the_index enum x < length (enum::'a::len word list)" by (auto intro: the_index_bounded)
  moreover
  { fix y assume "of_nat y = x"
    moreover assume "y < 2 ^ LENGTH('a)"
    ultimately have "y = unat x" using of_nat_inverse by fastforce
  }
  ultimately
  show ?thesis by (simp add: fromEnum_def enum_word_def)
qed

lemma length_word_enum: "length (enum :: ('a :: len) word list) = 2 ^ LENGTH('a)"
  by (simp add: enum_word_def)

lemma toEnum_of_nat[simp]: "n < 2 ^ LENGTH('a) \<Longrightarrow> ((toEnum n) :: ('a :: len) word) = of_nat n"
  by (simp add: toEnum_def length_word_enum enum_word_def)

declare of_nat_diff [simp]

instantiation word :: (len) enumeration_both
begin

definition
  enum_alt_word_def: "enum_alt \<equiv> alt_from_ord (enum :: ('a :: len) word list)"

instance
  by (intro_classes, simp add: enum_alt_word_def)

end

definition
  upto_enum_step :: "('a :: len) word \<Rightarrow> 'a word \<Rightarrow> 'a word \<Rightarrow> 'a word list" ("[_ , _ .e. _]")
where
  "upto_enum_step a b c \<equiv>
      if c < a then [] else map (\<lambda>x. a + x * (b - a)) [0 .e. (c - a) div (b - a)]"
  (* in the wraparound case, bad things happen. *)

lemma maxBound_word:
  "(maxBound::'a::len word) = -1"
  by (simp add: maxBound_def enum_word_def last_map)

lemma minBound_word:
  "(minBound::'a::len word) = 0"
  by (simp add: minBound_def enum_word_def upt_conv_Cons)

lemma maxBound_max_word:
  "(maxBound::'a::len word) = max_word"
  by (simp add: maxBound_word max_word_minus [symmetric])

end


theory Lift_Fst_Snd imports Lift_Fst Lift_Snd
begin

locale fst_l_snd_l_ortho' =
  fixes l1 :: "('a, 'b1, 'c1 :: Pordb) lifting"
  fixes S1 :: "'a \<Rightarrow> 'c1 set"
  fixes l2 :: "('a, 'b2, 'c2 :: Pordb) lifting"
  fixes S2 :: "'a \<Rightarrow> 'c2 set"

locale fst_l_snd_l_ortho = fst_l_snd_l_ortho' +
  in1 : lifting_valid_base_ext l1 S1 +
  in2 : lifting_valid_base_ext l2 S2

sublocale fst_l_snd_l_ortho \<subseteq> out : l_ortho "fst_l l1" "fst_l_S S1" "snd_l l2" "snd_l_S S2"
proof
  fix s
  show "LBase (fst_l l1) s = LBase (snd_l l2) s"
    using in1.base in2.base
    by(auto simp add: fst_l_def snd_l_def)
next
  fix b :: "'c * 'e"
  fix s :: 'a
  fix a1 :: 'b
  fix a2 :: 'd

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  then show "LUpd (fst_l l1) s a1 (LUpd (snd_l l2) s a2 b) = LUpd (snd_l l2) s a2 (LUpd (fst_l l1) s a1 b)"
    by(auto simp add: fst_l_def snd_l_def)

next

  fix b :: "'c * 'e"
  fix s :: 'a
  fix a1

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  then show "LOut (snd_l l2) s (LUpd (fst_l l1) s a1 b) = LOut (snd_l l2) s b"
    by(auto simp add: fst_l_def snd_l_def)
next

  fix b :: "'c * 'e"
  fix s :: 'a
  fix a2 :: 'd

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  then show "LOut (fst_l l1) s (LUpd (snd_l l2) s a2 b) = LOut (fst_l l1) s b"
    by(cases b; auto simp add: fst_l_def snd_l_def)

next
  fix b :: "'c * 'e"
  fix s :: 'a
  fix a1 :: 'b

  assume Bin : "b \<in> snd_l_S S2 s"

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  then show " LUpd (fst_l l1) s a1 b \<in> snd_l_S S2 s" using Bin
    by(auto simp add: fst_l_def snd_l_S_def)
next
  fix b :: "'c * 'e"
  fix s :: 'a
  fix a2 :: 'd

  assume Bin: "b \<in> fst_l_S S1 s"
  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  then show "LUpd (snd_l l2) s a2 b \<in> fst_l_S S1 s" using Bin
    by(auto simp add: snd_l_def fst_l_S_def)
qed

lemma (in fst_l_snd_l_ortho) ax :
  shows "l_ortho (fst_l l1) (fst_l_S S1) (snd_l l2) (snd_l_S S2)"
  using out.l_ortho_axioms
  by auto

lemma (in fst_l_snd_l_ortho) ax_g :
  assumes H1 : "\<And> x . S'1 x = fst_l_S S1 x"
  assumes H2 : "\<And> x . S'2 x = snd_l_S S2 x"
  shows "l_ortho (fst_l l1) S'1 (snd_l l2) S'2"
proof-
  have H1' : "S'1 = fst_l_S S1"
    using H1 by auto
  have H2' : "S'2 = snd_l_S S2"
    using H2 by auto
  then show ?thesis using ax unfolding H1' H2'
    by auto
qed

(* commutative *)
lemma (in fst_l_snd_l_ortho) ax_comm :
  shows "l_ortho (snd_l l2) (snd_l_S S2) (fst_l l1) (fst_l_S S1)"
  using out.comm.l_ortho_axioms
  by auto

lemma (in fst_l_snd_l_ortho) ax_g_comm :
  assumes H1 : "\<And> x . S'2 x = snd_l_S S2 x"
  assumes H2 : "\<And> x . S'1 x = fst_l_S S1 x"
  shows "l_ortho (snd_l l2) S'2 (fst_l l1) S'1"
proof-
  have H1' : "S'2 = snd_l_S S2"
    using H1 by auto
  have H2' : "S'1 = fst_l_S S1"
    using H2 by auto
  then show ?thesis using ax_comm unfolding H1' H2'
    by auto
qed

locale fst_l_snd_l_ortho_ok_ext =
  fixes l1 :: "('a, 'b1, 'c1 :: {Pord_Weakb, Okay}) lifting"
  fixes l2 :: "('a, 'b2, 'c2 :: {Pord_Weakb, Okay}) lifting"

sublocale fst_l_snd_l_ortho_ok_ext \<subseteq> out : l_ortho_ok_ext "fst_l l1" "snd_l l2" .

locale fst_l_snd_l_ortho_base_ext =
  fst_l_snd_l_ortho' +
  in1 : lifting_valid_weak_base l1 S1 +
  in2 : lifting_valid_weak_base l2 S2

sublocale fst_l_snd_l_ortho_base_ext \<subseteq> out : l_ortho_base_ext "fst_l l1" "snd_l l2"
proof
  fix s
  show "LBase (fst_l l1) s = \<bottom>"
    using in1.base
    by(auto simp add: fst_l_def prod_bot)
next
  fix s
  show "LBase (snd_l l2) s = \<bottom>"
    using in2.base
    by(auto simp add: snd_l_def prod_bot)
qed

lemma (in fst_l_snd_l_ortho_base_ext) ax :
  shows "l_ortho_base_ext (fst_l l1) (snd_l l2)"
  using out.l_ortho_base_ext_axioms
  by auto

lemma (in fst_l_snd_l_ortho_base_ext) ax_comm :
  shows "l_ortho_base_ext (snd_l l2) (fst_l l1)"
  using out.comm.l_ortho_base_ext_axioms
  by auto

(*
(* TODO: this was originally lifting_valid_weak_pres, but i think we actually need strength
 * to make this work *)
locale fst_l_snd_l_ortho_pres =
  fst_l_snd_l_ortho +
  in1 : lifting_valid_pres l1 S1 +
  in2 : lifting_valid_pres l2 S2

sublocale fst_l_snd_l_ortho_pres \<subseteq> out : l_ortho_pres "fst_l l1" "fst_l_S S1" "snd_l l2" "snd_l_S S2"
proof
  fix a1 a2 s
  fix x :: "('c * 'e)"

  obtain x1 x2 where X: "x = (x1, x2)"
    by(cases x; auto)

  have Leq1 : "x1 <[ LUpd l1 s a1 x1"
    using in1.get_put by auto

  have Leq2 : "x2 <[ LUpd l2 s a2 x2"
    using in2.get_put by auto

  show "is_sup {LUpd (fst_l l1) s a1 x, LUpd (snd_l l2) s a2 x} (LUpd (fst_l l1) s a1 (LUpd (snd_l l2) s a2 x))"
  proof(rule is_supI)
    fix w

    assume W: "w \<in> {LUpd (fst_l l1) s a1 x, LUpd (snd_l l2) s a2 x}"

    obtain w1 w2 where "w = (w1, w2)"
      by(cases w; auto)

    show "w <[ LUpd (fst_l l1) s a1 (LUpd (snd_l l2) s a2 x)"
      using W X Leq1 Leq2
      by(auto simp add: fst_l_def snd_l_def prod_pleq leq_refl)
  next
    fix x'
    assume Ub : "is_ub {LUpd (fst_l l1) s a1 x, LUpd (snd_l l2) s a2 x} x'"

    obtain x'1 x'2 where X': "x' = (x'1, x'2)"
      by(cases x'; auto)

    have Leq1 : "LUpd (fst_l l1) s a1 x <[ x'"
      using is_ubE[OF Ub]
      by auto

    have Leq2 : "LUpd (snd_l l2) s a2 x <[ x'"
      using is_ubE[OF Ub]
      by auto

    show "LUpd (fst_l l1) s a1 (LUpd (snd_l l2) s a2 x) <[ x'"
      using X' X Leq1 Leq2
      by(auto simp add: fst_l_def snd_l_def prod_pleq)
  qed
qed
*)

end