(*    Title:              SatSolverVerification/Decide.thy
      Author:             Filip Maric
      Maintainer:         Filip Maric <filip at matf.bg.ac.yu>
*)

theory Decide
imports AssertLiteral
begin

(******************************************************************************)
(*          A P P L Y     D E C I D E                                         *)
(******************************************************************************)

lemma applyDecideEffect:
assumes
  "\<not> vars(elements (getM state)) \<supseteq> Vbl" and
  "InvariantWatchesEl (getF state) (getWatch1 state) (getWatch2 state)" and
  "InvariantWatchListsContainOnlyClausesFromF (getWatchList state) (getF state)"
shows
  "let literal = selectLiteral state Vbl in
   let state' = applyDecide state Vbl in
          var literal \<notin> vars (elements (getM state)) \<and>
          var literal \<in> Vbl \<and>
          getM state' = getM state @ [(literal, True)] \<and>
          getF state' = getF state"
using assms
using selectLiteral_def[of "Vbl" "state"]
unfolding applyDecide_def
using assertLiteralEffect[of "state" "selectLiteral state Vbl" "True"]
by (simp add: Let_def)

lemma InvariantConsistentAfterApplyDecide:
assumes
  "\<not> vars(elements (getM state)) \<supseteq> Vbl" and
  "InvariantConsistent (getM state)" and
  "InvariantWatchesEl (getF state) (getWatch1 state) (getWatch2 state)" and
  "InvariantWatchListsContainOnlyClausesFromF (getWatchList state) (getF state)"
shows
  "let state' = applyDecide state Vbl in
         InvariantConsistent (getM state')"
using assms
using applyDecideEffect[of "Vbl" "state"]
using InvariantConsistentAfterDecide[of "getM state" "selectLiteral state Vbl" "getM (applyDecide state Vbl)"]
by (simp add: Let_def)

lemma InvariantUniqAfterApplyDecide:
assumes
  "\<not> vars(elements (getM state)) \<supseteq> Vbl" and
  "InvariantUniq (getM state)" and
  "InvariantWatchesEl (getF state) (getWatch1 state) (getWatch2 state)" and
  "InvariantWatchListsContainOnlyClausesFromF (getWatchList state) (getF state)"
shows
  "let state' = applyDecide state Vbl in
         InvariantUniq (getM state')"
using assms
using applyDecideEffect[of "Vbl" "state"]
using InvariantUniqAfterDecide[of "getM state" "selectLiteral state Vbl" "getM (applyDecide state Vbl)"]
by (simp add: Let_def)

lemma InvariantQCharacterizationAfterApplyDecide:
assumes
  "\<not> vars(elements (getM state)) \<supseteq> Vbl" and

  "InvariantConsistent (getM state)" and
  "InvariantWatchListsContainOnlyClausesFromF (getWatchList state) (getF state)"
  "InvariantWatchListsUniq (getWatchList state)"
  "InvariantWatchListsCharacterization (getWatchList state) (getWatch1 state) (getWatch2 state)"
  "InvariantWatchesEl (getF state) (getWatch1 state) (getWatch2 state)"
  "InvariantWatchesDiffer (getF state) (getWatch1 state) (getWatch2 state)"
  "InvariantWatchCharacterization (getF state) (getWatch1 state) (getWatch2 state) (getM state)"
  "InvariantConflictFlagCharacterization (getConflictFlag state) (getF state) (getM state)"
  "InvariantQCharacterization (getConflictFlag state) (getQ state) (getF state) (getM state)"

  "getQ state = []"
shows
  "let state' = applyDecide state Vbl in
     InvariantQCharacterization (getConflictFlag state') (getQ state') (getF state') (getM state')"
proof-
  let ?state' = "applyDecide state Vbl"
  let ?literal = "selectLiteral state Vbl"
  have "getM ?state' = getM state @ [(?literal, True)]"
    using assms
    using applyDecideEffect[of "Vbl" "state"]
    by (simp add: Let_def)
  hence "InvariantConsistent (getM state @ [(?literal, True)])"
    using InvariantConsistentAfterApplyDecide[of "Vbl" "state"]
    using assms
    by (simp add: Let_def)
  thus ?thesis
    using assms
    using InvariantQCharacterizationAfterAssertLiteralNotInQ[of "state" "?literal" "True"]
    unfolding applyDecide_def
    by simp
qed

lemma InvariantEquivalentZLAfterApplyDecide:
assumes
  "InvariantWatchListsContainOnlyClausesFromF (getWatchList state) (getF state)"
  "InvariantWatchesEl (getF state) (getWatch1 state) (getWatch2 state)"
  "InvariantEquivalentZL (getF state) (getM state) F0"
shows
  "let state' = applyDecide state Vbl in
     InvariantEquivalentZL (getF state') (getM state') F0"
proof-
  let ?state' = "applyDecide state Vbl"
  let ?l = "selectLiteral state Vbl"

  have "getM ?state' = getM state @ [(?l, True)]"
    "getF ?state' = getF state"
    unfolding applyDecide_def
    using assertLiteralEffect[of "state" "?l" "True"]
    using assms
    by (auto simp only: Let_def)
  have "prefixToLevel 0 (getM ?state') = prefixToLevel 0 (getM state)"
  proof (cases "currentLevel (getM state) > 0")
    case True
    thus ?thesis
      using prefixToLevelAppend[of "0" "getM state" "[(?l, True)]"]
      using \<open>getM ?state' = getM state @ [(?l, True)]\<close>
      by auto
  next
    case False
    hence "prefixToLevel 0 (getM state @ [(?l, True)]) =
             getM state @ (prefixToLevel_aux [(?l, True)] 0 (currentLevel (getM state)))"
      using prefixToLevelAppend[of "0" "getM state" "[(?l, True)]"]
      by simp
    hence "prefixToLevel 0 (getM state @ [(?l, True)]) = getM state"
      by simp
    thus ?thesis
      using \<open>getM ?state' = getM state @ [(?l, True)]\<close>
      using currentLevelZeroTrailEqualsItsPrefixToLevelZero[of "getM state"]
      using False
      by simp
  qed
  thus ?thesis
    using \<open>InvariantEquivalentZL (getF state) (getM state) F0\<close>
    unfolding InvariantEquivalentZL_def
    using \<open>getF ?state' = getF state\<close>
    by simp
qed

lemma InvariantGetReasonIsReasonAfterApplyDecide:
assumes
  "\<not> vars (elements (getM state)) \<supseteq> Vbl"
  "InvariantWatchListsContainOnlyClausesFromF (getWatchList state) (getF state)"
  "InvariantWatchListsCharacterization (getWatchList state) (getWatch1 state) (getWatch2 state)" and
  "InvariantWatchListsUniq (getWatchList state)"
  "InvariantWatchesEl (getF state) (getWatch1 state) (getWatch2 state)"
  "InvariantGetReasonIsReason (getReason state) (getF state) (getM state) (set (getQ state))"
  "getQ state = []"
shows
  "let state' = applyDecide state Vbl in
    InvariantGetReasonIsReason (getReason state') (getF state') (getM state') (set (getQ state'))"
proof-
  let ?l = "selectLiteral state Vbl"
  let ?stateM = "state \<lparr> getM := getM state @ [(?l, True)] \<rparr>"
  have "InvariantGetReasonIsReason (getReason ?stateM) (getF ?stateM) (getM ?stateM) (set (getQ ?stateM))"
  proof-
    {
      fix l::Literal
      assume *: "l el (elements (getM ?stateM))" "\<not> l el (decisions (getM ?stateM))" "elementLevel l (getM ?stateM) > 0"
      have "\<exists> reason. getReason ?stateM l = Some reason \<and>
        0 \<le> reason \<and> reason < length (getF ?stateM) \<and>
        isReason (getF ?stateM ! reason) l (elements (getM ?stateM))"
      proof (cases "l el (elements (getM state))")
        case True
        moreover
        hence "\<not> l el (decisions (getM state))"
          using *
          by (simp add: markedElementsAppend)
        moreover
        have "elementLevel l (getM state) > 0"
        proof-
          {
            assume "\<not> ?thesis"
            with *
            have "l = ?l"
              using True
              using elementLevelAppend[of "l" "getM state" "[(?l, True)]"]
              by simp
            hence "var ?l \<in> vars (elements (getM state))"
              using True
              using valuationContainsItsLiteralsVariable[of "l" "elements (getM state)"]
              by simp
            hence False
              using \<open>\<not> vars (elements (getM state)) \<supseteq> Vbl\<close>
              using selectLiteral_def[of "Vbl" "state"]
              by auto
          } thus ?thesis
            by auto
        qed
        ultimately
        obtain reason
          where "getReason state l = Some reason \<and>
          0 \<le> reason \<and> reason < length (getF state) \<and>
          isReason (getF state ! reason) l (elements (getM state))"
          using \<open>InvariantGetReasonIsReason (getReason state) (getF state) (getM state) (set (getQ state))\<close>
          unfolding InvariantGetReasonIsReason_def
          by auto
        thus ?thesis
          using isReasonAppend[of "nth (getF ?stateM) reason" "l" "elements (getM state)" "[?l]"]
          by auto
      next
        case False
        hence "l = ?l"
          using *
          by auto
        hence "l el (decisions (getM ?stateM))"
          using markedElementIsMarkedTrue[of "l" "getM ?stateM"]
          by auto
        with *
        have False
          by auto
        thus ?thesis
          by simp
      qed
    }
    thus ?thesis
      using \<open>getQ state = []\<close>
      unfolding InvariantGetReasonIsReason_def
      by auto
  qed
  thus ?thesis
    using assms
    using InvariantGetReasonIsReasonAfterNotifyWatches[of "?stateM" "getWatchList ?stateM (opposite ?l)"
      "opposite ?l" "getM state" "True" "{}" "[]"]
    unfolding applyDecide_def
    unfolding assertLiteral_def
    unfolding notifyWatches_def
    unfolding InvariantWatchListsCharacterization_def
    unfolding InvariantWatchListsContainOnlyClausesFromF_def
    unfolding InvariantWatchListsUniq_def
    using \<open>getQ state = []\<close>
    by (simp add: Let_def)
qed

lemma InvariantsVarsAfterApplyDecide:
assumes
  "\<not> vars (elements (getM state)) \<supseteq> Vbl"
  "InvariantConsistent (getM state)"
  "InvariantUniq (getM state)"
  "InvariantWatchListsContainOnlyClausesFromF (getWatchList state) (getF state)"
  "InvariantWatchListsUniq (getWatchList state)"
  "InvariantWatchListsCharacterization (getWatchList state) (getWatch1 state) (getWatch2 state)"
  "InvariantWatchesEl (getF state) (getWatch1 state) (getWatch2 state)"
  "InvariantWatchesDiffer (getF state) (getWatch1 state) (getWatch2 state)"
  "InvariantWatchCharacterization (getF state) (getWatch1 state) (getWatch2 state) (getM state)"

  "InvariantVarsM (getM state) F0 Vbl"
  "InvariantVarsF (getF state) F0 Vbl"
  "getQ state = []"
shows
  "let state' = applyDecide state Vbl in
     InvariantVarsM (getM state') F0 Vbl \<and>
     InvariantVarsF (getF state') F0 Vbl \<and>
     InvariantVarsQ (getQ state') F0 Vbl"
proof-
  let ?state' = "applyDecide state Vbl"
  let ?l = "selectLiteral state Vbl"

  have "InvariantVarsM (getM ?state') F0 Vbl" "InvariantVarsF (getF ?state') F0 Vbl"
    using assms
    using applyDecideEffect[of "Vbl" "state"]
    using varsAppendValuation[of "elements (getM state)" "[?l]"]
    unfolding InvariantVarsM_def
    by (auto simp add: Let_def)
  moreover
  have "InvariantVarsQ (getQ ?state') F0 Vbl"
    using InvariantVarsQAfterAssertLiteral[of "state" "?l" "True" "F0" "Vbl"]
    using assms
    using InvariantConsistentAfterApplyDecide[of "Vbl" "state"]
    using InvariantUniqAfterApplyDecide[of "Vbl" "state"]
    using assertLiteralEffect[of "state" "?l" "True"]
    unfolding applyDecide_def
    unfolding InvariantVarsQ_def
    by (simp add: Let_def)
  ultimately
  show ?thesis
    by (simp add: Let_def)
qed

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)
 *)

theory PackedTypes
imports "../lib/WordSetup" CProof
begin

section {* Underlying definitions for the class axioms *}

text {* field_access / field_update is the identity for packed types *}

definition
  "fa_fu_idem fd n \<equiv>
  \<forall>bs bs' v. length bs = n \<longrightarrow> length bs' = n \<longrightarrow> field_access fd (field_update fd bs v) bs' = bs"

(* Is it better to do this or to use a fold over td?  This seems easier to use *)
primrec
  td_fafu_idem :: "'a field_desc typ_desc \<Rightarrow> bool" and
  td_fafu_idem_struct :: "'a field_desc typ_struct \<Rightarrow> bool" and
  td_fafu_idem_list :: " ('a field_desc typ_desc, char list) dt_pair list \<Rightarrow> bool" and
  td_fafu_idem_pair :: "('a field_desc typ_desc, char list) dt_pair \<Rightarrow> bool"
where
  fai0: "td_fafu_idem (TypDesc ts n) = td_fafu_idem_struct ts"

| fai1: "td_fafu_idem_struct (TypScalar n algn d) = fa_fu_idem d n"
| fai2: "td_fafu_idem_struct (TypAggregate ts) = td_fafu_idem_list ts"

| fai3: "td_fafu_idem_list [] = True"
| fai4: "td_fafu_idem_list (x#xs) = (td_fafu_idem_pair x \<and> td_fafu_idem_list xs)"

| fai5: "td_fafu_idem_pair (DTPair x n) = td_fafu_idem x"

lemmas td_fafu_idem_simps = fai0 fai1 fai2 fai3 fai4 fai5

text {* field_access is independent of the underlying bytes *}

definition
  "fa_heap_indep fd n \<equiv>
  \<forall>bs bs' v. length bs = n \<longrightarrow> length bs' = n \<longrightarrow> field_access fd v bs = field_access fd v bs'"

primrec
  td_fa_hi :: "'a field_desc typ_desc \<Rightarrow> bool" and
  td_fa_hi_struct :: "'a field_desc typ_struct \<Rightarrow> bool" and
  td_fa_hi_list :: "('a field_desc typ_desc, char list) dt_pair list \<Rightarrow> bool" and
  td_fa_hi_pair :: "('a field_desc typ_desc, char list) dt_pair \<Rightarrow> bool"
where
  fahi0: "td_fa_hi (TypDesc ts n) = td_fa_hi_struct ts"

| fahi1: "td_fa_hi_struct (TypScalar n algn d) = fa_heap_indep d n"
| fahi2: "td_fa_hi_struct (TypAggregate ts) = td_fa_hi_list ts"

| fahi3: "td_fa_hi_list [] = True"
| fahi4: "td_fa_hi_list (x#xs) = (td_fa_hi_pair x \<and> td_fa_hi_list xs)"

| fahi5: "td_fa_hi_pair (DTPair x n) = td_fa_hi x"

lemmas td_fa_hi_simps = fahi0 fahi1 fahi2 fahi3 fahi4 fahi5

section {* Lemmas about td_fafu_idem *}

lemma field_lookup_td_fafu_idem:
  shows "\<And>(s :: 'a field_desc typ_desc) f m n. \<lbrakk> field_lookup t f m = Some (s, n); td_fafu_idem t \<rbrakk> \<Longrightarrow> td_fafu_idem s"
  and   "\<And>(s :: 'a field_desc typ_desc) f m n. \<lbrakk> field_lookup_struct st f m = Some (s, n); td_fafu_idem_struct st \<rbrakk> \<Longrightarrow> td_fafu_idem s"
  and   "\<And>(s :: 'a field_desc typ_desc) f m n. \<lbrakk> field_lookup_list ts f m = Some (s, n); td_fafu_idem_list ts \<rbrakk> \<Longrightarrow> td_fafu_idem s"
  and   "\<And>(s :: 'a field_desc typ_desc) f m n. \<lbrakk> field_lookup_pair p f m = Some (s, n); td_fafu_idem_pair p \<rbrakk> \<Longrightarrow> td_fafu_idem s"
  by (induct t and st and ts and p) (auto split: split_if_asm option.splits)

lemma field_access_update_same:
  fixes t :: "'a :: mem_type field_desc typ_desc" and st :: "'a field_desc typ_struct"
  shows "\<And>(v :: 'a) bs bs'. \<lbrakk> td_fafu_idem t; wf_fd t; length bs = size_td t; length bs' = size_td t\<rbrakk>
  \<Longrightarrow> access_ti t (update_ti t bs v) bs' = bs"
  and "\<And>(v :: 'a) bs bs'. \<lbrakk> td_fafu_idem_struct st; wf_fd_struct st; length bs = size_td_struct st; length bs' = size_td_struct st \<rbrakk>
  \<Longrightarrow> access_ti_struct st (update_ti_struct st bs v) bs' = bs"
  and "\<And>(v :: 'a) bs bs'. \<lbrakk> td_fafu_idem_list ts; wf_fd_list ts; length bs = size_td_list ts; length bs' = size_td_list ts\<rbrakk>
  \<Longrightarrow> access_ti_list ts (update_ti_list ts bs v) bs' = bs"
  and "\<And>(v :: 'a) bs bs'. \<lbrakk> td_fafu_idem_pair p; wf_fd_pair p; length bs = size_td_pair p; length bs' = size_td_pair p\<rbrakk>
  \<Longrightarrow> access_ti_pair p (update_ti_pair p bs v) bs' = bs"
proof (induct t and st and ts and p)
  case TypScalar thus ?case by (clarsimp simp: fa_fu_idem_def)
next
  case (Cons_typ_desc p' ts' v bs bs')
  hence "fu_commutes (update_ti_pair_t p') (update_ti_list_t ts')" by clarsimp
  moreover have "update_ti_pair p' (take (size_td_pair p') bs) = update_ti_pair_t p' (take (size_td_pair p') bs)"
    using Cons_typ_desc.prems by (simp add: update_ti_pair_t_def min_ll)
  moreover have "update_ti_list ts' (drop (size_td_pair p') bs) = update_ti_list_t ts' (drop (size_td_pair p') bs)"
    using Cons_typ_desc.prems by (simp add: update_ti_list_t_def)
  ultimately have
    updeq: "(update_ti_pair p' (take (size_td_pair p') bs) (update_ti_list ts' (drop (size_td_pair p') bs) v))
    = (update_ti_list ts' (drop (size_td_pair p') bs) (update_ti_pair p' (take (size_td_pair p') bs) v))"
    unfolding fu_commutes_def by simp

  show ?case using Cons_typ_desc.prems
    by (clarsimp simp add: Cons_typ_desc.hyps) (simp add: updeq  Cons_typ_desc.hyps)
qed simp+

lemma access_ti_pair_dt_fst:
  "access_ti_pair p v bs = access_ti (dt_fst p) v bs"
  by (cases p, simp)

lemma size_td_pair_dt_fst:
  "size_td_pair p = size_td (dt_fst p)"
  by (cases p, simp)

lemma wf_fd_pair_dt_fst:
  "wf_fd_pair p = wf_fd (dt_fst p)"
  by (cases p, simp)

lemma field_lookup_offset2:
  assumes fl: "(field_lookup t f (m + n) = Some (s, q))"
  shows   "field_lookup t f m = Some (s, q - n)"
proof -
  from fl have le: "m + n \<le> q"
    by (rule field_lookup_offset_le)

  hence "q = (m + n) + (q - (m + n))"
    by simp

  hence "field_lookup t f (m + n) = Some (s, (m + n) + (q - (m + n)))" using fl by simp

  hence "field_lookup t f m = Some (s, m + (q - (m + n)))"
    by (rule iffD1 [OF field_lookup_offset'(1)])

  thus ?thesis using le by simp
qed

lemma field_lookup_offset2_list:
  assumes fl: "(field_lookup_list ts f (m + n) = Some (s, q))"
  shows   "field_lookup_list ts f m = Some (s, q - n)"
proof -
  from fl have le: "m + n \<le> q"
    by (rule field_lookup_offset_le)

  hence "q = (m + n) + (q - (m + n))"
    by simp

  hence "field_lookup_list ts f (m + n) = Some (s, (m + n) + (q - (m + n)))" using fl by simp

  hence "field_lookup_list ts f m = Some (s, m + (q - (m + n)))"
    by (rule iffD1 [OF field_lookup_offset'(3)])

  thus ?thesis using le by simp
qed

lemma field_lookup_offset2_pair:
  assumes fl: "(field_lookup_pair p f (m + n) = Some (s, q))"
  shows   "field_lookup_pair p f m = Some (s, q - n)"
proof -
  from fl have le: "m + n \<le> q"
    by (rule field_lookup_offset_le)

  hence "q = (m + n) + (q - (m + n))"
    by simp

  hence "field_lookup_pair p f (m + n) = Some (s, (m + n) + (q - (m + n)))" using fl by simp

  hence "field_lookup_pair p f m = Some (s, m + (q - (m + n)))"
    by (rule iffD1 [OF field_lookup_offset'(4)])

  thus ?thesis using le by simp
qed

lemma field_lookup_offset_size':
  shows "field_lookup t f 0 = Some (t',n) \<Longrightarrow> size_td t' + n \<le> size_td t"
  apply(drule td_set_field_lookupD)
  apply(erule td_set_offset_size)
done

lemma field_access_update_nth_inner:
  shows "\<And>f (s :: 'a :: mem_type field_desc typ_desc) n x v bs bs'.
  \<lbrakk> field_lookup t f 0 = Some (s, n); n \<le> x; x < n + size_td s; td_fafu_idem s; wf_fd s; wf_fd t;
  length bs = size_td s; length bs' = size_td t \<rbrakk>
  \<Longrightarrow> access_ti t (update_ti s bs v) bs' ! x = bs ! (x - n)"

  and "\<And>f (s :: 'a  :: mem_type field_desc typ_desc) n x v bs bs'.
  \<lbrakk>field_lookup_struct st f 0 = Some (s, n); n \<le> x; x < n + size_td s; td_fafu_idem s; wf_fd s; wf_fd_struct st;
  length bs = size_td s; length bs' = size_td_struct st \<rbrakk>
  \<Longrightarrow> access_ti_struct st (update_ti s bs v) bs' ! x = bs ! (x - n)"

  and "\<And>f (s :: 'a  :: mem_type field_desc typ_desc) n x v bs bs'.
  \<lbrakk>field_lookup_list ts f 0 = Some (s, n); n \<le> x; x < n + size_td s; td_fafu_idem s; wf_fd s; wf_fd_list ts;
  length bs = size_td s; length bs' = size_td_list ts\<rbrakk>
  \<Longrightarrow> access_ti_list ts (update_ti s bs v) bs' ! x = bs ! (x - n)"

  and "\<And>f (s :: 'a  :: mem_type field_desc typ_desc) n x v bs bs'.
  \<lbrakk>field_lookup_pair p f 0 = Some (s, n); n \<le> x; x < n + size_td s; td_fafu_idem s; wf_fd s; wf_fd_pair p;
  length bs = size_td s; length bs' = size_td_pair p\<rbrakk>
  \<Longrightarrow> access_ti_pair p (update_ti s bs v) bs' ! x = bs ! (x - n)"
proof (induct t and st and ts and p)
  case (TypDesc typ_struct ls f s n x v bs bs')

  show ?case
  proof (cases "f = []")
    case False thus ?thesis using TypDesc by clarsimp
  next
    case True
    thus ?thesis using TypDesc.prems
      by (simp add: field_access_update_same)
  qed
next
  case (Cons_typ_desc p' ts' f s n x v bs bs')
  have nlex: "n \<le> x" and xln: "x < n + size_td s"
    and lbs: "length bs = size_td s" and lbs': "length bs' = size_td_list (p' # ts')" by fact+
  from Cons_typ_desc have wf: "wf_fd (dt_fst p')" and wfts: "wf_fd_list ts'" by (cases p', auto)

  {
    assume fl: "field_lookup_list ts' f (size_td (dt_fst p')) = Some (s, n)"

    hence mlt: "size_td (dt_fst p') \<le> n"
      by (rule field_lookup_offset_le)

    hence "size_td (dt_fst p') \<le> x"
      by (rule order_trans) fact

    hence ?case using wf lbs lbs'
    proof (simp add: nth_append length_fa_ti access_ti_pair_dt_fst size_td_pair_dt_fst)
      from fl have fl': "field_lookup_list ts' f 0 = Some (s, n - size_td (dt_fst p'))"
	by (rule field_lookup_offset2_list [where m = 0, simplified])

      show "access_ti_list ts' (update_ti s bs v) (drop (size_td (dt_fst p')) bs') ! (x - size_td (dt_fst p')) = bs ! (x - n)"
	using mlt nlex xln lbs lbs' wf wfts `td_fafu_idem s` `wf_fd s`
	by (simp add: Cons_typ_desc.hyps(2) [OF fl'] size_td_pair_dt_fst)
    qed
  }
  moreover
  {
    note ih = Cons_typ_desc.hyps(1)[simplified access_ti_pair_dt_fst wf_fd_pair_dt_fst]

    assume fl: "field_lookup_pair p' f 0 = Some (s, n)"

    hence "x < size_td (dt_fst p')"
      apply -
      apply (cases p')
      apply (simp split: split_if_asm)
      apply (drule field_lookup_offset_size')
      apply (rule order_less_le_trans [OF xln])
      apply simp
      done

    hence ?case using wf lbs lbs' nlex xln wf wfts `td_fafu_idem s` `wf_fd s`
      by (simp add: nth_append length_fa_ti access_ti_pair_dt_fst size_td_pair_dt_fst ih[OF fl])
  }
  ultimately show ?case using `field_lookup_list (p' # ts') f 0 = Some (s, n)` by (simp split: option.splits)
qed (clarsimp split: split_if_asm)+

subsection {* td_fa_hi *}

(* \<lbrakk> size_of TYPE('a::mem_type) \<le> length h; size_of TYPE('a) \<le> length h' \<rbrakk> \<Longrightarrow> *)

lemma fa_heap_indepD:
  "\<lbrakk> fa_heap_indep fd n; length bs = n; length bs' = n \<rbrakk> \<Longrightarrow>
  field_access fd v bs = field_access fd v bs'"
  unfolding fa_heap_indep_def
  apply (drule spec, drule spec, drule spec)
  apply (drule (1) mp)
  apply (erule (1) mp)
  done

(* The simplifier spins on the IHs here, hence the proofs for each case *)
lemma td_fa_hi_heap_independence:
  shows "\<And>(v :: 'a :: mem_type) h h'. \<lbrakk> td_fa_hi t; length h = size_td t; length h' = size_td t \<rbrakk>
  \<Longrightarrow> access_ti t v h = access_ti t v h'"
  and   "\<And>(v :: 'a :: mem_type) h h'. \<lbrakk> td_fa_hi_struct st; length h = size_td_struct st; length h' = size_td_struct st\<rbrakk>
  \<Longrightarrow> access_ti_struct st v h = access_ti_struct st v h'"
  and   "\<And>(v :: 'a :: mem_type) h h'. \<lbrakk> td_fa_hi_list ts;  length h = size_td_list ts; length h' = size_td_list ts \<rbrakk>
  \<Longrightarrow> access_ti_list ts v h = access_ti_list ts v h'"
  and   "\<And>(v :: 'a :: mem_type) h h'. \<lbrakk> td_fa_hi_pair p;  length h = size_td_pair p; length h' = size_td_pair p \<rbrakk>
  \<Longrightarrow> access_ti_pair p v h = access_ti_pair p v h'"
proof (induct t and st and ts and p)
  case TypDesc
  from TypDesc.prems show ?case
    by (simp) (erule (2) TypDesc.hyps)
next
  case TypScalar
  from TypScalar.prems show ?case
    by simp (erule (2) fa_heap_indepD)
next
  case TypAggregate
  from TypAggregate.prems show ?case
    by (simp) (erule (2) TypAggregate.hyps)
next
  case Nil_typ_desc thus ?case by simp
next
  case Cons_typ_desc
  from Cons_typ_desc.prems show ?case
    apply simp
    apply (erule conjE)
    apply (rule arg_cong2 [where f = "op @"])
    apply (erule Cons_typ_desc.hyps, simp, simp)
    apply (erule Cons_typ_desc.hyps, simp, simp)
    done
next
  case DTPair_typ_desc
  from DTPair_typ_desc.prems show ?case
    by simp (erule (2) DTPair_typ_desc.hyps)
qed

section {* Simp rules for deriving packed props from the type combinators *}

subsection {* td_fafu_idem *}

lemma td_fafu_idem_final_pad:
  "padup (2 ^ align_td t) (size_td t) = 0
  \<Longrightarrow> td_fafu_idem (final_pad t) = td_fafu_idem t"
  unfolding final_pad_def
  by (clarsimp simp add: padup_def Let_def)

lemma td_fafu_idem_ti_typ_pad_combine:
  fixes t :: "'a :: c_type itself" and s :: "'b :: c_type field_desc typ_desc"
  assumes pad: "padup (align_of TYPE('a)) (size_td s) = 0"
  shows "td_fafu_idem (ti_typ_pad_combine t xf xfu nm s) = td_fafu_idem (ti_typ_combine t xf xfu nm s)"
  unfolding ti_typ_pad_combine_def using pad
  by (clarsimp simp: Let_def)

lemma td_fafu_idem_list_append:
  fixes xs :: "'a :: c_type field_desc typ_pair list"
  shows "td_fafu_idem_list (xs @ ys) = (td_fafu_idem_list xs \<and> td_fafu_idem_list ys)"
  by (induct xs) simp+

lemma td_fafu_idem_extend_ti:
  fixes t :: "'a :: c_type field_desc typ_desc"
  assumes as: "td_fafu_idem s"
  and     at: "td_fafu_idem t"
  shows "td_fafu_idem (extend_ti s t nm)" using as at
  apply (cases s)
  apply (rename_tac typ_struct xs)
  apply (case_tac typ_struct)
   apply simp
  apply (simp add: td_fafu_idem_list_append)
  done

lemma fd_cons_access_updateD:
  "\<lbrakk> fd_cons_access_update d n; length bs = n; length bs' = n\<rbrakk> \<Longrightarrow> field_access d (field_update d bs v) bs' = field_access d (field_update d bs v') bs'"
  unfolding fd_cons_access_update_def by clarsimp

(* Beer crime? *)
lemma fa_fu_idem_update_desc:
  fixes a :: "'a field_desc"
  assumes fg: "fg_cons xf xfu"
  and     fd: "fd_cons_struct (TypScalar n n' a)"
  shows   "fa_fu_idem (update_desc xf xfu a) n = fa_fu_idem a n"
proof
  assume asm: "fa_fu_idem (update_desc xf xfu a) n"

  let ?fu = "\<lambda>bs. if length bs = n then field_update a bs else id"
  let ?a' = "\<lparr> field_access = field_access a, field_update = ?fu \<rparr>"

  show "fa_fu_idem a n"
    unfolding fa_fu_idem_def
  proof (intro impI conjI allI)
    fix bs :: "byte list" and bs' :: "byte list" and v
    assume l: "length bs = n" and l': "length bs' = n"

    hence "(\<forall>v. field_access a (field_update a bs (xf v)) bs' = bs)
      = (\<forall>v. field_access a (?fu bs (xf v)) bs' = bs)" by simp

    also have "\<dots> = (\<forall>v. field_access a (field_update a bs v) bs' = bs)" using fd
      apply -
      apply rule
      apply (rule allI)
      apply (subst (asm) fd_cons_access_updateD [OF _ l l', where d = ?a', simplified])
      apply (simp add: fd_cons_struct_def fd_cons_desc_def)
      apply (fastforce simp: l l')
      apply (fastforce simp: l l')
      done

    finally show "field_access a (field_update a bs v) bs' = bs" using asm fg l l'
      by (clarsimp simp add: update_desc_def fa_fu_idem_def fg_cons_def)
  qed
next
  assume "fa_fu_idem a n"
  thus "fa_fu_idem (update_desc xf xfu a) n"
    unfolding fa_fu_idem_def update_desc_def using fg
    by (clarsimp simp add: update_desc_def fa_fu_idem_def fg_cons_def)
qed

lemma td_fafu_idem_map_td_update_desc:
  assumes fg: "fg_cons xf xfu"
  shows  "wf_fd t \<Longrightarrow> td_fafu_idem (map_td (\<lambda>_ _. update_desc xf xfu) t) = td_fafu_idem t"
  and    "wf_fd_struct st \<Longrightarrow> td_fafu_idem_struct (map_td_struct (\<lambda>_ _. update_desc xf xfu) st) = td_fafu_idem_struct st"
  and    "wf_fd_list ts \<Longrightarrow> td_fafu_idem_list (map_td_list (\<lambda>_ _. update_desc xf xfu) ts) = td_fafu_idem_list ts"
  and    "wf_fd_pair p \<Longrightarrow> td_fafu_idem_pair (map_td_pair (\<lambda>_ _. update_desc xf xfu) p) = td_fafu_idem_pair p"
  by (induct t and st and ts and p) (auto elim!: fa_fu_idem_update_desc [OF fg])

lemmas td_fafu_idem_adjust_ti = td_fafu_idem_map_td_update_desc(1)[folded adjust_ti_def]

lemma td_fafu_idem_ti_typ_combine:
  fixes s :: "'b :: c_type field_desc typ_desc"
  assumes fg: "fg_cons xf xfu"
  and    tda: "td_fafu_idem (typ_info_t TYPE('a :: mem_type))"
  and    tds: "td_fafu_idem s"
  shows "td_fafu_idem (ti_typ_combine TYPE('a :: mem_type) xf xfu nm s)"
  unfolding ti_typ_combine_def using tda tds
  apply (clarsimp simp: Let_def)
  apply (cases s)
  apply (rename_tac typ_struct xs)
  apply (case_tac typ_struct)
   apply simp
   apply (subst td_fafu_idem_adjust_ti [OF fg wf_fd], assumption)
  apply (simp add: td_fafu_idem_list_append)
  apply (subst td_fafu_idem_adjust_ti [OF fg wf_fd], assumption)
  done

lemma td_fafu_idem_ptr:
   "td_fafu_idem (typ_info_t TYPE('a :: c_type ptr))"
  apply (clarsimp simp add: fa_fu_idem_def)
  apply (subst word_rsplit_rcat_size)
   apply (clarsimp simp add: size_of_def word_size)
  apply simp
  done

lemma td_fafu_idem_word:
   "td_fafu_idem (typ_info_t TYPE('a :: len8 word))"
  apply(clarsimp simp add: fa_fu_idem_def)
  apply (subst word_rsplit_rcat_size)
   apply (insert len8_dv8)
   apply (clarsimp simp add: size_of_def word_size)
   apply (subst dvd_div_mult_self)
    apply simp
   apply simp
  apply simp
  done

lemma fg_cons_array [simp]:
  "n < card (UNIV :: 'b :: finite set) \<Longrightarrow> fg_cons (\<lambda>x. index x n) (\<lambda>x f. Arrays.update (f :: 'a['b]) n x)"
  unfolding fg_cons_def by simp

lemma td_fafu_idem_array_n:
  "\<lbrakk>td_fafu_idem (typ_info_t TYPE('a)); n \<le> card (UNIV :: 'b set) \<rbrakk> \<Longrightarrow> td_fafu_idem (array_tag_n n :: ('a :: mem_type ['b :: finite]) field_desc typ_desc)"
  apply (induct n)
   apply (simp add: array_tag_n.simps empty_typ_info_def)
  apply (simp add: array_tag_n.simps)
  apply (rule td_fafu_idem_ti_typ_combine)
    apply simp
   apply simp
  apply simp
  done

lemma td_fafu_idem_array:
  "td_fafu_idem (typ_info_t TYPE('a)) \<Longrightarrow> td_fafu_idem (typ_info_t TYPE('a :: mem_type ['b :: finite]))"
  apply (clarsimp simp add: typ_info_array array_tag_def fa_fu_idem_def)
  apply (erule td_fafu_idem_array_n)
  apply simp
  done

lemma td_fafu_idem_empty_typ_info:
  "td_fafu_idem (empty_typ_info t)"
  unfolding empty_typ_info_def
  by simp

subsection {* td_fa_hi *}

(* These are mostly identical to the above --- surely there is something which implies both? *)

lemma td_fa_hi_final_pad:
  "padup (2 ^ align_td t) (size_td t) = 0
  \<Longrightarrow> td_fa_hi (final_pad t) = td_fa_hi t"
  unfolding final_pad_def
  by (clarsimp simp add: padup_def Let_def)

lemma td_fa_hi_ti_typ_pad_combine:
  fixes t :: "'a :: c_type itself" and s :: "'b :: c_type field_desc typ_desc"
  assumes pad: "padup (align_of TYPE('a)) (size_td s) = 0"
  shows "td_fa_hi (ti_typ_pad_combine t xf xfu nm s) = td_fa_hi (ti_typ_combine t xf xfu nm s)"
  unfolding ti_typ_pad_combine_def using pad
  by (clarsimp simp: Let_def)

lemma td_fa_hi_list_append:
  fixes xs :: "'a :: c_type field_desc typ_pair list"
  shows "td_fa_hi_list (xs @ ys) = (td_fa_hi_list xs \<and> td_fa_hi_list ys)"
  by (induct xs) simp+

lemma td_fa_hi_extend_ti:
  fixes t :: "'a :: c_type field_desc typ_desc"
  assumes as: "td_fa_hi s"
  and     at: "td_fa_hi t"
  shows "td_fa_hi (extend_ti s t nm)" using as at
  apply (cases s)
  apply (rename_tac typ_struct xs)
  apply (case_tac typ_struct)
   apply simp
  apply (simp add: td_fa_hi_list_append)
  done

(* Beer crime? *)
lemma fa_heap_indep_update_desc:
  fixes a :: "'a field_desc"
  assumes fg: "fg_cons xf xfu"
  and     fd: "fd_cons_struct (TypScalar n n' a)"
  shows   "fa_heap_indep (update_desc xf xfu a) n = fa_heap_indep a n"
proof
  assume asm: "fa_heap_indep (update_desc xf xfu a) n"

  have xf_xfu: "\<And>v v'. xf (xfu v v') = v" using fg
    unfolding fg_cons_def
    by simp

  show "fa_heap_indep a n"
    unfolding fa_heap_indep_def
  proof (intro impI conjI allI)
    fix bs :: "byte list" and bs' :: "byte list" and v
    assume l: "length bs = n" and l': "length bs' = n"
    with asm have "field_access (update_desc xf xfu a) (xfu v undefined) bs =
      field_access (update_desc xf xfu a) (xfu v undefined) bs'"
      by (rule fa_heap_indepD)

    thus "field_access a v bs = field_access a v bs'"
      unfolding update_desc_def
      by (simp add: xf_xfu)
  qed
next
  assume asm: "fa_heap_indep a n"
  show "fa_heap_indep (update_desc xf xfu a) n"
    unfolding fa_heap_indep_def update_desc_def
  proof (simp, intro impI conjI allI)
    fix bs :: "byte list" and bs' :: "byte list" and v
    assume l: "length bs = n" and l': "length bs' = n"

    with asm show "field_access a (xf v) bs = field_access a (xf v) bs'"
      by (rule fa_heap_indepD)
  qed
qed

lemma td_fa_hi_map_td_update_desc:
  assumes fg: "fg_cons xf xfu"
  shows  "wf_fd t \<Longrightarrow> td_fa_hi (map_td (\<lambda>_ _. update_desc xf xfu) t) = td_fa_hi t"
  and    "wf_fd_struct st \<Longrightarrow> td_fa_hi_struct (map_td_struct (\<lambda>_ _. update_desc xf xfu) st) = td_fa_hi_struct st"
  and    "wf_fd_list ts \<Longrightarrow> td_fa_hi_list (map_td_list (\<lambda>_ _. update_desc xf xfu) ts) = td_fa_hi_list ts"
  and    "wf_fd_pair p \<Longrightarrow> td_fa_hi_pair (map_td_pair (\<lambda>_ _. update_desc xf xfu) p) = td_fa_hi_pair p"
  by (induct t and st and ts and p) (auto elim!: fa_heap_indep_update_desc [OF fg])

lemmas td_fa_hi_adjust_ti = td_fa_hi_map_td_update_desc(1)[folded adjust_ti_def]

lemma td_fa_hi_ti_typ_combine:
  fixes s :: "'b :: c_type field_desc typ_desc"
  assumes fg: "fg_cons xf xfu"
  and    tda: "td_fa_hi (typ_info_t TYPE('a :: mem_type))"
  and    tds: "td_fa_hi s"
  shows "td_fa_hi (ti_typ_combine TYPE('a :: mem_type) xf xfu nm s)"
  unfolding ti_typ_combine_def using tda tds
  apply (clarsimp simp: Let_def)
  apply (cases s)
  apply (rename_tac typ_struct xs)
  apply (case_tac typ_struct)
   apply simp
   apply (subst td_fa_hi_adjust_ti [OF fg wf_fd], assumption)
  apply (simp add: td_fa_hi_list_append)
  apply (subst td_fa_hi_adjust_ti [OF fg wf_fd], assumption)
  done

lemma td_fa_hi_ptr:
   "td_fa_hi (typ_info_t TYPE('a :: c_type ptr))"
  by (clarsimp simp add: fa_heap_indep_def)

lemma td_fa_hi_word:
   "td_fa_hi (typ_info_t TYPE('a :: len8 word))"
  by (clarsimp simp add: fa_heap_indep_def)

lemma td_fa_hi_array_n:
  "\<lbrakk>td_fa_hi (typ_info_t TYPE('a)); n \<le> card (UNIV :: 'b set) \<rbrakk> \<Longrightarrow> td_fa_hi (array_tag_n n :: ('a :: mem_type ['b :: finite]) field_desc typ_desc)"
  apply (induct n)
   apply (simp add: array_tag_n.simps empty_typ_info_def)
  apply (simp add: array_tag_n.simps)
  apply (rule td_fa_hi_ti_typ_combine)
    apply simp
   apply simp
  apply simp
  done

lemma td_fa_hi_array:
  "td_fa_hi (typ_info_t TYPE('a)) \<Longrightarrow> td_fa_hi (typ_info_t TYPE('a :: mem_type ['b :: finite]))"
  apply (clarsimp simp add: typ_info_array array_tag_def fa_fu_idem_def)
  apply (erule td_fa_hi_array_n)
  apply simp
  done

lemma td_fa_hi_empty_typ_info:
  "td_fa_hi (empty_typ_info t)"
  unfolding empty_typ_info_def
  by simp

section {* The type class and simp sets *}

text {* Packed types, with no padding, have the defining property that
        access is invariant under substitution of the underlying heap and
        access/update is the identity *}

class packed_type = mem_type +
  assumes td_fafu_idem: "td_fafu_idem (typ_info_t TYPE('a::c_type))"
  assumes td_fa_hi:     "td_fa_hi (typ_info_t TYPE('a::c_type))"

lemmas td_fafu_idem_intro_simps =
  -- "Axioms"
  td_fafu_idem
  -- "Combinators"
  td_fafu_idem_final_pad td_fafu_idem_ti_typ_pad_combine td_fafu_idem_ti_typ_combine td_fafu_idem_empty_typ_info
  -- "Constructors"
  td_fafu_idem_ptr td_fafu_idem_word td_fafu_idem_array

lemmas td_fa_hi_intro_simps =
  -- "Axioms"
  td_fa_hi
  -- "Combinators"
  td_fa_hi_final_pad td_fa_hi_ti_typ_pad_combine td_fa_hi_ti_typ_combine td_fa_hi_empty_typ_info
  -- "Constructors"
  td_fa_hi_ptr td_fa_hi_word td_fa_hi_array

lemma align_td_array':
  "align_td (typ_info_t TYPE('a :: c_type['b :: finite])) = align_td (typ_info_t TYPE('a))"
  by (simp add: typ_info_array array_tag_def align_td_array_tag)

lemmas packed_type_intro_simps =
  td_fafu_idem_intro_simps td_fa_hi_intro_simps align_td_array' size_td_simps size_td_array

lemma access_ti_append':
  "\<And>list.
   access_ti_list (xs @ ys) t list =
     access_ti_list xs t (take (size_td_list xs) list) @
     access_ti_list ys t (drop (size_td_list xs) list)"
proof(induct xs)
  case Nil show ?case by simp
next
  case (Cons x xs) thus ?case by (simp add: min_def ac_simps drop_take)
qed

section {* Instances *}

text {* Words (of multiple of 8 size) are packed *}

instantiation word :: (len8) packed_type
begin
instance
 apply(intro_classes)
   apply (rule td_fafu_idem_word)
  apply (rule td_fa_hi_word)
  done
end

text {* Pointers are always packed *}

instantiation ptr :: (c_type)packed_type
begin
instance
  apply intro_classes
   apply (simp add: fa_fu_idem_def word_rsplit_rcat_size word_size)
  apply (simp add: fa_heap_indep_def)
  done
end

text {* Arrays of packed types are in turn packed *}

class oneMB_packed = packed_type + oneMB_size

instantiation word :: (len8)oneMB_packed
begin
instance
 apply(intro_classes)
done
end

instantiation array :: (oneMB_packed,fourthousand_count) packed_type
begin
instance
 apply(intro_classes)
   apply (simp add: td_fafu_idem_intro_simps)
  apply (simp add: td_fa_hi_intro_simps)
  done
end

section {* Theorems about packed types *}

subsection {* td_fa_hi *}

lemma heap_independence:
  "\<lbrakk>length h = size_of TYPE('a :: packed_type); length h' = size_of TYPE('a) \<rbrakk>
  \<Longrightarrow> access_ti (typ_info_t TYPE('a)) v h = access_ti (typ_info_t TYPE('a)) v h'"
  by (rule td_fa_hi_heap_independence(1)[OF td_fa_hi], simp_all add: size_of_def)

theorem packed_heap_update_collapse:
 fixes u::"'a::packed_type"
 fixes v::"'a"
 shows
  "heap_update p v (heap_update p u h) = heap_update p v h"
 apply(simp add:heap_update_def)
 apply(rule ext)
 apply(case_tac "x \<in> {ptr_val p..+size_of TYPE('a)}")
  apply((subst heap_update_mem_same_point, simp, simp)+)
  apply(simp add:to_bytes_def)
  apply(subst heap_independence)
    apply(simp)
   prefer 2
   apply(force)
  apply(simp)
 apply((subst heap_update_nmem_same, simp)+)
 apply(rule refl)
done

lemma packed_heap_update_collapse_hrs:
  fixes p :: "'a :: packed_type ptr"
  shows "(hrs_mem_update (heap_update p v) (hrs_mem_update (heap_update p v') hp)) =
  (hrs_mem_update (heap_update p v) hp)"
  unfolding hrs_mem_update_def
  by (simp add: split_def packed_heap_update_collapse)

subsection {* td_fafu_idem *}

lemma order_leE:
  fixes x :: "'a :: order"
  shows "\<lbrakk> x \<le> y; x = y \<Longrightarrow> P; x < y \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (auto simp: order_le_less)

lemma of_nat_mono_maybe_le:
  shows "\<lbrakk>X < 2 ^ len_of TYPE('a); Y \<le> X\<rbrakk> \<Longrightarrow> (of_nat Y :: 'a :: len word) \<le> of_nat X"
  apply (erule order_leE)
   apply simp
  apply (rule order_less_imp_le)
  apply (erule (1) of_nat_mono_maybe)
  done

lemma intvl_le_lower:
  fixes x :: "'a :: len word"
  shows "\<lbrakk> x \<in> {y..+n}; y \<le> y + of_nat (n - 1); n < 2 ^ len_of TYPE('a) \<rbrakk> \<Longrightarrow> y \<le> x"
  apply (drule intvlD)
  apply (elim conjE exE)
  apply (erule ssubst)
  apply (erule word_plus_mono_right2)
  apply (rule of_nat_mono_maybe_le)
   apply simp
  apply simp
  done

lemma intvl_less_upper:
  fixes x :: "'a :: len word"
  shows "\<lbrakk> x \<in> {y..+n}; y \<le> y + of_nat (n - 1); n < 2 ^ len_of TYPE('a) \<rbrakk> \<Longrightarrow> x \<le> y + of_nat (n - 1)"
  apply (drule intvlD)
  apply (elim conjE exE)
  apply (erule ssubst)
  apply (rule word_plus_mono_right)
   apply (rule of_nat_mono_maybe_le)
    apply simp
   apply simp
  apply assumption
  done

lemma packed_type_access_ti:
  fixes v :: "'a :: packed_type"
  assumes lbs: "length bs = size_of TYPE('a)"
  shows "access_ti (typ_info_t TYPE('a)) v bs = access_ti\<^sub>0 (typ_info_t TYPE('a)) v"
  unfolding access_ti\<^sub>0_def using lbs
  apply -
  apply (rule heap_independence)
   apply simp
  apply (simp add: size_of_def)
  done

lemma update_ti_update_ti_t:
  "length bs = size_td s \<Longrightarrow> update_ti s bs v = update_ti_t s bs v"
  unfolding update_ti_t_def by simp

lemma heap_list_nth:
  "m < n \<Longrightarrow> heap_list hp n p ! m = hp (p + of_nat m)"
proof (induct m arbitrary: n p)
  case (0 n' p')

  thus ?case by (cases n', simp_all)
next
  case (Suc m' n' p')

  show ?case
  proof (cases n')
    case 0 thus ?thesis using `Suc m' < n'` by simp
  next
    case (Suc n'')
    hence "m' < n''" using `Suc m' < n'` by simp
    thus ?thesis using Suc
      by (simp add: Suc.hyps ac_simps)
  qed
qed

lemma c_guard_field_lvalue:
  fixes p :: "'a :: mem_type ptr"
  assumes cg: "c_guard p"
  and     fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (t, n)"
  and     eu: "export_uinfo t = typ_uinfo_t TYPE('b :: mem_type)"
  shows   "c_guard (Ptr &(p\<rightarrow>f) :: 'b :: mem_type ptr)"
  unfolding c_guard_def
proof (rule conjI)
  from cg fl eu show "ptr_aligned (Ptr &(p\<rightarrow>f) :: 'b ptr)"
    by (rule c_guard_ptr_aligned_fl)
next
  from eu have std: "size_td t = size_of TYPE('b)" using fl
    by (simp add: export_size_of)

  from cg have "c_null_guard p" unfolding c_guard_def ..
  thus "c_null_guard (Ptr &(p\<rightarrow>f)  :: 'b ptr)" unfolding c_null_guard_def
    apply (rule contrapos_nn)
    apply (rule subsetD [OF field_tag_sub, OF fl])
    apply (simp add: std)
    done
qed

(* Similar in TypHeap, but for w32 *)
lemma unat_minus':
  fixes x :: "'a :: len word"
  shows "x \<noteq> 0 \<Longrightarrow> unat (-x) = 2 ^ len_of TYPE('a) - unat x"
  apply (simp add: unat_def word_minus_def)
  apply (simp add: int_word_uint zmod_zminus1_eq_if uint_0_iff)
  apply (subst nat_diff_distrib)
    apply simp
   apply (rule order_less_imp_le [OF uint_lt2p])
   apply (clarsimp simp: nat_power_eq)
   done

lemma word_wrap_of_natD:
  fixes x :: "'a :: len word"
  assumes wraps: "\<not> x \<le> x + of_nat n"
  shows   "\<exists>k. x + of_nat k = 0 \<and> k \<le> n"
proof -
  show ?thesis
  proof (rule exI [where x = "unat (- x)"], intro conjI)
    show "x + of_nat (unat (-x)) = 0"
      by simp
  next
    show "unat (-x) \<le> n"
    proof (subst unat_minus')
      from wraps show "x \<noteq> 0"
	by (rule contrapos_pn, simp add: not_le)
    next
      show "2 ^ len_of TYPE('a) - unat x \<le> n" using wraps
	apply (simp add: no_olen_add_nat le_diff_conv not_less)
	apply (erule order_trans)
	apply (simp add: unat_of_nat)
	done
    qed
  qed
qed

lemma nat_le_Suc_less:
  "0 < y \<Longrightarrow> (x \<le> y - Suc 0) = (x < y)"
  by arith

lemma c_guard_no_wrap:
  fixes p :: "'a :: mem_type ptr"
  assumes cgrd: "c_guard p"
  shows   "ptr_val p \<le> ptr_val p + of_nat (size_of TYPE('a) - 1)"
  using cgrd unfolding c_guard_def c_null_guard_def
  apply -
  apply (erule conjE)
  apply (erule contrapos_np)
  apply (simp add: intvl_def)
  apply (drule word_wrap_of_natD)
  apply (erule exE)
  apply (rule exI)
  apply (simp add: nat_le_Suc_less)
  done

theorem packed_heap_super_field_update:
  fixes v :: "'a :: packed_type" and p :: "'b :: packed_type ptr"
  assumes fl: "field_lookup (typ_info_t TYPE('b)) f 0 = Some (t, n)"
  and   cgrd: "c_guard p"
  and     eu: "export_uinfo t = typ_uinfo_t TYPE('a)"
  shows   "heap_update (Ptr &(p\<rightarrow>f)) v hp = heap_update p (update_ti t (to_bytes_p v) (h_val hp p)) hp"
  unfolding heap_update_def to_bytes_def
proof (simp add: packed_type_access_ti, rule ext)
  fix x
  let ?LHS = "heap_update_list &(p\<rightarrow>f) (to_bytes_p v) hp x"
  let ?RHS = "heap_update_list (ptr_val p) (to_bytes_p (update_ti t (to_bytes_p v) (h_val hp p))) hp x"

  from cgrd have al: "ptr_val p \<le> ptr_val p + of_nat (size_of TYPE('b) - 1)" by (rule c_guard_no_wrap)

  have szb: "size_of TYPE('b) < 2 ^ len_of TYPE(32)"
    apply (fold card_word)
    apply (fold addr_card_def)
    apply (rule max_size)
    done

  have szt: "n + size_td t \<le> size_of TYPE('b)"
    unfolding size_of_def
    by (subst add.commute, rule field_lookup_offset_size [OF fl])
  moreover have t0: "0 < size_td t" using fl wf_size_desc
    by (rule field_lookup_wf_size_desc_gt)
  ultimately have szn: "n < size_of TYPE('b)" by simp
  from szt have szt1: "n + (size_td t - 1) \<le> size_of TYPE('b)"
    by simp

  have b0: "0 < size_of (TYPE ('b))" using wf_size_desc
    unfolding size_of_def
    by (rule wf_size_desc_gt)

  have uofn: "unat (of_nat n :: 32 word) = n" using szn szb
    by (simp add: unat_simps)

  from eu have std: "size_td t = size_of TYPE('a)" using fl
    by (simp add: export_size_of)

  hence "?LHS = (if x \<in> {&(p\<rightarrow>f)..+size_td t} then (to_bytes_p v) ! unat (x - &(p\<rightarrow>f)) else hp x)"
    by (simp add: heap_update_mem_same_point heap_update_nmem_same)
  also have "... = ?RHS"
  proof (simp, intro impI conjI)
    assume xin: "x \<in> {&(p\<rightarrow>f)..+size_td t}"
    have "to_bytes_p v ! unat (x - &(p\<rightarrow>f)) = to_bytes_p (update_ti t (to_bytes_p v) (h_val hp p)) ! unat (x - ptr_val p)"
    proof (simp add: to_bytes_p_def to_bytes_def, subst field_access_update_nth_inner(1)[OF fl, simplified])

      have "c_guard (Ptr &(p\<rightarrow>f) :: 'a ptr)" using cgrd fl eu
	by (rule c_guard_field_lvalue)
      hence pft: "&(p\<rightarrow>f) \<le> &(p\<rightarrow>f) + of_nat (size_td t - 1)"
	apply -
	apply (drule c_guard_no_wrap)
	apply (simp add: std)
	done

      have szt': "size_td t < 2 ^ len_of TYPE(32)"
	apply (subst std)
	apply (fold card_word)
	apply (fold addr_card_def)
	apply (rule max_size)
	done

      have ofn: "of_nat n \<le> x - ptr_val p"
      proof (rule le_minus')
	from xin show "ptr_val p + of_nat n \<le> x" using pft szt'
	  unfolding field_lvalue_def field_lookup_offset_eq [OF fl]
	  by (rule intvl_le_lower)
      next
	from szb szn have "of_nat n \<le> (of_nat (size_of TYPE('b) - 1) :: 32 word)"
	  apply -
	  apply (rule of_nat_mono_maybe_le)
	  apply simp_all
	  done
	with al show "ptr_val p \<le> ptr_val p + of_nat n"
	  by (rule word_plus_mono_right2)
      qed

      thus nlt: "n \<le> unat (x - ptr_val p)"
	by (simp add: word_le_nat_alt uofn)
      have "x \<le> ptr_val p + (of_nat n + of_nat (size_td t - 1))" using xin pft szt' t0
	unfolding field_lvalue_def field_lookup_offset_eq [OF fl]
	apply -
	apply (drule (2) intvl_less_upper)
	apply (simp add: add.assoc)
	done
      moreover have "x \<in> {ptr_val p..+size_of TYPE('b)}" using fl xin
	by (rule subsetD [OF field_tag_sub])
      ultimately have "x - ptr_val p \<le> (of_nat n + of_nat (size_td t - 1))" using al szb
	apply -
	apply (rule word_diff_ls(4)[where xa=x and x=x for x, simplified])
     apply (metis (hide_lams, mono_tags) add.commute of_nat_add)
	apply (erule (2) intvl_le_lower)
	done
      moreover have "unat (of_nat n + of_nat (size_td t - 1) :: 32 word) = n + size_td t - 1"
	using t0 order_le_less_trans [OF szt1 szb]
	apply (subst Abs_fnat_homs(1))
	apply (subst unat_of_nat)
	apply simp
	done
      ultimately have "unat (x - ptr_val p) \<le> n + size_td t - 1"
	by (simp add: word_le_nat_alt)
      thus "unat (x - ptr_val p) < n + size_td t" using t0
	by simp

      show "td_fafu_idem t"
	by (rule field_lookup_td_fafu_idem(1)[OF fl td_fafu_idem])

      show "wf_fd t"
	by (rule wf_fd_field_lookupD [OF fl wf_fd])

      show "length (access_ti (typ_info_t TYPE('a)) v (replicate (size_of TYPE('a)) 0)) = size_td t"
	using wf_fd [where 'a = 'a]
	by (simp add: length_fa_ti size_of_def std)

      show "length (replicate (size_of TYPE('b)) 0) = size_td (typ_info_t TYPE('b))"
	by (simp add: size_of_def)

      have "unat (x - &(p\<rightarrow>f)) = unat ((x - ptr_val p) - of_nat n)"
  	by (simp add: field_lvalue_def field_lookup_offset_eq [OF fl])
      also have "\<dots> = unat (x - ptr_val p) - n"
	by (simp add: unat_sub [OF ofn] uofn)
      finally have "unat (x - &(p\<rightarrow>f)) = unat (x - ptr_val p) - n" .

      thus "access_ti (typ_info_t TYPE('a)) v (replicate (size_of TYPE('a)) 0) ! unat (x - &(p\<rightarrow>f)) =
	access_ti (typ_info_t TYPE('a)) v (replicate (size_of TYPE('a)) 0) ! (unat (x - ptr_val p) - n)"
	by simp
    qed

    thus "to_bytes_p v ! unat (x - &(p\<rightarrow>f)) = ?RHS"
    proof (subst heap_update_mem_same_point, simp_all)
      show "x \<in> {ptr_val p..+size_of TYPE('b)}" using fl xin
	by (rule subsetD [OF field_tag_sub])
    qed
  next
    assume xni: "x \<notin> {&(p\<rightarrow>f)..+size_td t}"
    have "?RHS = (if x \<in> {ptr_val p..+size_of TYPE('b)}
          then (to_bytes_p (update_ti t (to_bytes_p v) (h_val hp p))) ! unat (x - ptr_val p) else hp x)"
      by (simp add: heap_update_mem_same_point heap_update_nmem_same)

    also
    {
      assume xin: "x \<in> {ptr_val p..+size_of TYPE('b)}"

      hence "access_ti (typ_info_t TYPE('b))
	(update_ti_t t (access_ti (typ_info_t TYPE('a)) v (replicate (size_of TYPE('a)) 0)) (h_val hp p))
	(replicate (size_of TYPE('b)) 0) ! unat (x - ptr_val p) = hp x"
      proof (subst field_access_update_nth_disjD [OF fl])
	have "x - ptr_val p \<le> of_nat (size_of TYPE('b) - 1)"
	proof (rule word_diff_ls(4)[where xa=x and x=x for x, simplified])
      	  from xin show "x \<le> of_nat (size_of TYPE('b) - 1) + ptr_val p" using al szb
	    by (subst add.commute, rule intvl_less_upper)
	  show "ptr_val p \<le> x" using xin al szb
	    by (rule intvl_le_lower)
	qed
	thus unx: "unat (x - ptr_val p) < size_td (typ_info_t TYPE('b))" using szb b0
	  by (simp add: word_le_nat_alt size_of_def unat_of_nat)

	show "unat (x - ptr_val p) < n - 0 \<or> n - 0 + size_td t \<le> unat (x - ptr_val p)" using xin xni
  	  unfolding field_lvalue_def field_lookup_offset_eq [OF fl]
	  apply -
	  apply (erule intvl_cut)
	  apply simp
	  apply (rule max_size)
	  done

	show "wf_fd (typ_info_t TYPE('b))" by (rule wf_fd)
	(* clag *)
	show "length (access_ti (typ_info_t TYPE('a)) v (replicate (size_of TYPE('a)) 0)) = size_td t"
	  using wf_fd [where 'a = 'a]
	  by (simp add: length_fa_ti size_of_def std)

	show "length (replicate (size_of TYPE('b)) 0) = size_td (typ_info_t TYPE('b))"
	  by (simp add: size_of_def)

	have "heap_list hp (size_td (typ_info_t TYPE('b))) (ptr_val p) ! unat (x - ptr_val p) = hp x"
	  apply (subst heap_list_nth)
	  apply (rule unx)
	  apply simp
	  done

	thus "access_ti (typ_info_t TYPE('b)) (h_val hp p) (replicate (size_of TYPE('b)) 0) ! unat (x - ptr_val p) = hp x"
	  unfolding h_val_def
	  by (simp add: from_bytes_def update_ti_t_def size_of_def field_access_update_same(1)[OF td_fafu_idem wf_fd])
      qed
     }
    hence "\<dots> = hp x"
      by (simp add: to_bytes_p_def to_bytes_def update_ti_update_ti_t length_fa_ti [OF wf_fd] std size_of_def)
    finally show "hp x = ?RHS" by simp
  qed
  finally show "?LHS = ?RHS" .
qed

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)
 *)

(* License: BSD, terms see file ./LICENSE *)

(* Definitions supporting the extremely long CTypes.thy *)

theory CTypesDefs
imports
  "~~/src/HOL/Library/Prefix_Order"
  "../../lib/SignedWords"
  CTypesBase
begin

section "C types setup"

type_synonym field_name = string
type_synonym qualified_field_name = "field_name list"

type_synonym typ_name = string

section "XXX: unsectioned and mostly uncommented, as in original"

(* XXX FIXME TODO:
 * Figure out sectioning here first and *then* try make CTypes.thy conform
   to that sectioning.
 * Also, all definitions from CTypes.thy are here. Some might be local-only
   and thus might need to be put back.
 * Some definitions are closely followed by [simp] lemmas simplifying their
   most common usage. Perhaps put these in here with the defs?
 *)

text {* A typ_desc wraps a typ_struct with a typ name.
        A typ_struct is either a Scalar, with size, alignment and either a
        field accessor/updator pair (for typ_info) or a 'normalisor'
        (for typ_uinfo), or an Aggregate, with a list of typ_desc,
        field name pairs.*}

datatype 'a typ_desc   = TypDesc "'a typ_struct" typ_name
    and  'a typ_struct = TypScalar nat nat "'a" |
                         TypAggregate "('a typ_desc,field_name) dt_pair list"

type_synonym 'a typ_pair = "('a typ_desc,field_name) dt_pair"

type_synonym typ_uinfo = "normalisor typ_desc"
type_synonym typ_uinfo_struct = "normalisor typ_struct"
type_synonym typ_uinfo_pair = "normalisor typ_pair"

record 'a field_desc =
  field_access :: "'a \<Rightarrow> byte list \<Rightarrow> byte list"
  field_update :: "byte list \<Rightarrow> 'a \<Rightarrow> 'a"

type_synonym 'a typ_info = "'a field_desc typ_desc"
type_synonym 'a typ_info_struct = "'a field_desc typ_struct"
type_synonym 'a typ_info_pair = "'a field_desc typ_pair"

definition fu_commutes :: "('b \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "fu_commutes f g \<equiv> \<forall>v bs bs'. f bs (g bs' v) = g bs' (f bs v)"

text {* size_td returns the sum of the sizes of all Scalar fields
        comprising a typ_desc i.e. the overall size of the type *}

(* Could express this and many other typ_desc primrecs as tree fold/map
   combos, but the intuition this way is clearer for anything non-trivial *)
primrec
  size_td :: "'a typ_desc \<Rightarrow> nat" and
  size_td_struct :: "'a typ_struct \<Rightarrow> nat" and
  size_td_list :: "'a typ_pair list \<Rightarrow> nat" and
  size_td_pair :: "'a typ_pair \<Rightarrow> nat"
where
  tz0: "size_td (TypDesc st nm) = size_td_struct st"

| tz1: "size_td_struct (TypScalar n algn d) = n"
| tz2: "size_td_struct (TypAggregate xs) = size_td_list xs"

| tz3: "size_td_list [] = 0"
| tz4: "size_td_list (x#xs) = size_td_pair x + size_td_list xs"

| tz5: "size_td_pair (DTPair t n) = size_td t"

text {* access_ti overlays the byte-wise representation of an object
        on a given byte list, given the typ_info (i.e. the layout) *}

primrec
  access_ti :: "'a typ_info \<Rightarrow> ('a \<Rightarrow> byte list \<Rightarrow> byte list)" and
  access_ti_struct :: "'a typ_info_struct \<Rightarrow>
    ('a \<Rightarrow> byte list \<Rightarrow> byte list)" and
  access_ti_list :: "'a typ_info_pair list \<Rightarrow>
    ('a \<Rightarrow> byte list \<Rightarrow> byte list)" and
  access_ti_pair :: "'a typ_info_pair \<Rightarrow> ('a \<Rightarrow> byte list \<Rightarrow> byte list)"
where
  fa0: "access_ti (TypDesc st nm) = access_ti_struct st"

| fa1: "access_ti_struct (TypScalar n algn d) = field_access d"
| fa2: "access_ti_struct (TypAggregate xs) = access_ti_list xs"

| fa3: "access_ti_list [] = (\<lambda>v bs. [])"
| fa4: "access_ti_list (x#xs) =
         (\<lambda>v bs. access_ti_pair x v (take (size_td_pair x) bs) @
                 access_ti_list xs v (drop (size_td_pair x) bs))"

| fa5: "access_ti_pair (DTPair t nm) = access_ti t"

text {* access_ti\<^sub>0 overlays the representation of an object on a
        list of zero bytes *}

definition access_ti\<^sub>0 :: "'a typ_info \<Rightarrow> ('a \<Rightarrow> byte list)" where
  "access_ti\<^sub>0 t \<equiv> \<lambda>v. access_ti t v (replicate (size_td t) 0)"

text {* update_ti updates an object, given a list of bytes (the
        representation of the new value), and the typ_info *}

primrec
  update_ti :: "'a typ_info \<Rightarrow> (byte list \<Rightarrow> 'a \<Rightarrow> 'a)" and
  update_ti_struct :: "'a typ_info_struct \<Rightarrow> (byte list \<Rightarrow> 'a \<Rightarrow> 'a)" and
  update_ti_list :: "'a typ_info_pair list \<Rightarrow> (byte list \<Rightarrow> 'a \<Rightarrow> 'a)" and
  update_ti_pair :: "'a typ_info_pair \<Rightarrow> (byte list \<Rightarrow> 'a \<Rightarrow> 'a)"
where
  fu0: "update_ti (TypDesc st nm) = update_ti_struct st"

| fu1: "update_ti_struct (TypScalar n algn d) = field_update d"
| fu2: "update_ti_struct (TypAggregate xs) = update_ti_list xs"

| fu3: "update_ti_list [] = (\<lambda>bs. id)"
| fu4: "update_ti_list (x#xs) = (\<lambda>bs v.
         update_ti_pair x (take (size_td_pair x) bs)
             (update_ti_list xs (drop (size_td_pair x) bs) v))"

| fu5: "update_ti_pair (DTPair t nm) = update_ti t"

text {* update_ti_t updates an object only if the length of the
        supplied representation equals the object size *}

definition update_ti_t :: "'a typ_info \<Rightarrow> (byte list \<Rightarrow> 'a \<Rightarrow> 'a)" where
  "update_ti_t t \<equiv> \<lambda>bs. if length bs = size_td t then
      update_ti t bs else id"

definition update_ti_struct_t :: "'a typ_info_struct \<Rightarrow> (byte list \<Rightarrow> 'a \<Rightarrow> 'a)" where
  "update_ti_struct_t t \<equiv> \<lambda>bs. if length bs = size_td_struct t then
      update_ti_struct t bs else id"

definition update_ti_list_t :: "'a typ_info_pair list  \<Rightarrow> (byte list \<Rightarrow> 'a \<Rightarrow> 'a)" where
  "update_ti_list_t t \<equiv> \<lambda>bs. if length bs = size_td_list t then
      update_ti_list t bs else id"

definition update_ti_pair_t :: "'a typ_info_pair \<Rightarrow> (byte list \<Rightarrow> 'a \<Rightarrow> 'a)" where
  "update_ti_pair_t t \<equiv> \<lambda>bs. if length bs = size_td_pair t then
      update_ti_pair t bs else id"

text {* field_desc generates the access/update pair for a field,
        given the field's type_desc *}

definition field_desc :: "'a typ_info \<Rightarrow> 'a field_desc" where
  "field_desc t \<equiv> \<lparr> field_access = access_ti t,
      field_update = update_ti_t t \<rparr>"

declare field_desc_def [simp add]

definition field_desc_struct :: "'a typ_info_struct \<Rightarrow> 'a field_desc" where
  "field_desc_struct t \<equiv> \<lparr> field_access = access_ti_struct t,
      field_update = update_ti_struct_t t \<rparr>"

declare field_desc_struct_def [simp add]

definition field_desc_list :: "'a typ_info_pair list \<Rightarrow> 'a field_desc"
where
  "field_desc_list t \<equiv> \<lparr> field_access = access_ti_list t,
      field_update = update_ti_list_t t \<rparr>"

declare field_desc_list_def [simp add]

definition field_desc_pair :: "'a typ_info_pair \<Rightarrow> 'a field_desc"
where
  "field_desc_pair t \<equiv> \<lparr> field_access = access_ti_pair t,
      field_update = update_ti_pair_t t \<rparr>"

declare field_desc_pair_def [simp add]

primrec
  map_td :: "(nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a typ_desc \<Rightarrow> 'b typ_desc" and
  map_td_struct :: "(nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a typ_struct  \<Rightarrow> 'b typ_struct" and
  map_td_list :: "(nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a typ_pair list \<Rightarrow>
    'b typ_pair list" and
  map_td_pair :: "(nat \<Rightarrow> nat \<Rightarrow> 'a  \<Rightarrow> 'b) \<Rightarrow> 'a typ_pair \<Rightarrow> 'b typ_pair"
where
  mat0: "map_td f (TypDesc st nm) = TypDesc (map_td_struct f st) nm"

| mat1: "map_td_struct f (TypScalar n algn d) = TypScalar n algn (f n algn d)"
| mat2: "map_td_struct f (TypAggregate xs) = TypAggregate (map_td_list f xs)"

| mat3: "map_td_list f [] = []"
| mat4: "map_td_list f (x#xs) = map_td_pair f x # map_td_list f xs"

| mat5: "map_td_pair f (DTPair t n) = DTPair (map_td f t) n"

definition field_norm :: "nat \<Rightarrow> nat \<Rightarrow> 'a field_desc \<Rightarrow> (byte list \<Rightarrow> byte list)"
where
  "field_norm \<equiv> \<lambda>n algn d bs.
      if length bs = n then
          field_access d (field_update d bs undefined) (replicate n 0) else
          []"

definition export_uinfo :: "'a typ_info \<Rightarrow> typ_uinfo" where
  "export_uinfo t \<equiv> map_td field_norm t"

primrec
  wf_desc :: "'a typ_desc \<Rightarrow> bool" and
  wf_desc_struct :: "'a typ_struct \<Rightarrow> bool" and
  wf_desc_list :: "'a typ_pair list \<Rightarrow> bool" and
  wf_desc_pair :: "'a typ_pair \<Rightarrow> bool"
where
  wfd0: "wf_desc (TypDesc ts n) = wf_desc_struct ts"

| wfd1: "wf_desc_struct (TypScalar n algn d) = True"
| wfd2: "wf_desc_struct (TypAggregate ts) = wf_desc_list ts"

| wfd3: "wf_desc_list [] = True"
| wfd4: "wf_desc_list (x#xs) = (wf_desc_pair x \<and> \<not> dt_snd x \<in> dt_snd ` set xs \<and>
          wf_desc_list xs)"

| wfd5: "wf_desc_pair (DTPair x n) = wf_desc x"

primrec
  wf_size_desc :: "'a typ_desc \<Rightarrow> bool" and
  wf_size_desc_struct :: "'a typ_struct \<Rightarrow> bool" and
  wf_size_desc_list :: "'a typ_pair list \<Rightarrow> bool" and
  wf_size_desc_pair :: "'a typ_pair \<Rightarrow> bool"
where
  wfsd0: "wf_size_desc (TypDesc ts n) = wf_size_desc_struct ts"

| wfsd1: "wf_size_desc_struct (TypScalar n algn d) = (0 < n)"
| wfsd2: "wf_size_desc_struct (TypAggregate ts) =
           (ts \<noteq> [] \<and> wf_size_desc_list ts)"

| wfsd3: "wf_size_desc_list [] = True"
| wfsd4: "wf_size_desc_list (x#xs) =
           (wf_size_desc_pair x \<and> wf_size_desc_list xs)"

| wfsd5: "wf_size_desc_pair (DTPair x n) = wf_size_desc x"

primrec
  typ_struct :: "'a typ_desc \<Rightarrow> 'a typ_struct"
where
  "typ_struct (TypDesc st sz) = st"

primrec
  typ_name :: "'a typ_desc \<Rightarrow> typ_name"
where
  "typ_name (TypDesc st nm) = nm"

primrec
  norm_tu :: "typ_uinfo \<Rightarrow> normalisor" and
  norm_tu_struct :: "typ_uinfo_struct \<Rightarrow> normalisor" and
  norm_tu_list :: "typ_uinfo_pair list \<Rightarrow> normalisor" and
  norm_tu_pair :: "typ_uinfo_pair \<Rightarrow> normalisor"
where
  tn0: "norm_tu (TypDesc st nm) = norm_tu_struct st"

| tn1: "norm_tu_struct (TypScalar n aln f) = f"
| tn2: "norm_tu_struct (TypAggregate xs) = norm_tu_list xs"

| tn3: "norm_tu_list [] = (\<lambda>bs. [])"
| tn4: "norm_tu_list (x#xs) = (\<lambda>bs.
         norm_tu_pair x (take (size_td_pair x) bs) @
         norm_tu_list xs (drop (size_td_pair x) bs))"

| tn5: "norm_tu_pair (DTPair t n) = norm_tu t"

class c_type

instance c_type \<subseteq> type ..

consts
  typ_info_t :: "'a::c_type itself \<Rightarrow> 'a typ_info"
  typ_name_itself :: "'a::c_type itself \<Rightarrow> typ_name"

definition typ_uinfo_t :: "'a::c_type itself \<Rightarrow> typ_uinfo" where
  "typ_uinfo_t t \<equiv> export_uinfo (typ_info_t TYPE('a))"

definition to_bytes :: "'a::c_type \<Rightarrow> byte list \<Rightarrow> byte list" where
  "to_bytes v \<equiv> access_ti (typ_info_t TYPE('a)) v"

(* from_bytes is now total - all partial C types 'a need to be instantiated
   as c_types using 'a option and the parser needs to do some work
   extracting the value and generating guards for non-None when these are
   used. Luckily for us in our work we never use them. *)
definition from_bytes :: "byte list \<Rightarrow> 'a::c_type" where
  "from_bytes bs \<equiv>
      field_update (field_desc (typ_info_t TYPE('a))) bs undefined"

type_synonym 'a flr = "('a typ_desc \<times> nat) option"

primrec
  field_lookup :: "'a typ_desc \<Rightarrow> qualified_field_name \<Rightarrow> nat \<Rightarrow> 'a flr" and
  field_lookup_struct :: "'a typ_struct \<Rightarrow> qualified_field_name \<Rightarrow> nat \<Rightarrow>
    'a flr" and
  field_lookup_list :: "'a typ_pair list \<Rightarrow> qualified_field_name \<Rightarrow> nat \<Rightarrow>
    'a flr" and
  field_lookup_pair :: "'a typ_pair \<Rightarrow> qualified_field_name \<Rightarrow> nat \<Rightarrow> 'a flr"
where
  fl0: "field_lookup (TypDesc st nm) f m =
         (if f=[] then Some (TypDesc st nm,m) else field_lookup_struct st f m)"

| fl1: "field_lookup_struct (TypScalar n algn d) f m = None"
| fl2: "field_lookup_struct (TypAggregate xs) f m = field_lookup_list xs f m"

| fl3: "field_lookup_list [] f m = None"
| fl4: "field_lookup_list (x#xs) f m = (
         case field_lookup_pair x f m of
           None \<Rightarrow> field_lookup_list xs f (m + size_td (dt_fst x)) |
           Some y \<Rightarrow> Some y)"

| fl5: "field_lookup_pair (DTPair t nm) f m =
         (if nm=hd f \<and> f \<noteq> [] then field_lookup t (tl f) m else None)"

definition map_td_flr :: "(nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow>
  ('a typ_desc \<times> nat) option \<Rightarrow> 'b flr"
where
  "map_td_flr f \<equiv> case_option None (\<lambda>(s,n). Some (map_td f s,n))"

definition
  import_flr :: "(nat \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow> 'a flr \<Rightarrow> ('b typ_desc \<times> nat) option \<Rightarrow> bool"
where
  "import_flr f s k \<equiv> case_option (k=None)
      (\<lambda>(s,m). case_option False (\<lambda>(t,n). n=m \<and> map_td f t=s) k )
      s"

definition
  field_offset_untyped :: "'a typ_desc \<Rightarrow> qualified_field_name \<Rightarrow> nat"
where
  "field_offset_untyped t n \<equiv> snd (the (field_lookup t n 0))"

definition
  field_offset :: "'a::c_type itself \<Rightarrow> qualified_field_name \<Rightarrow> nat"
where
  "field_offset t n \<equiv> field_offset_untyped (typ_uinfo_t TYPE('a)) n"

definition
  field_ti :: "'a::c_type itself \<Rightarrow> qualified_field_name \<rightharpoonup> 'a typ_info"
where
  "field_ti t n \<equiv> case_option None (Some \<circ> fst)
      (field_lookup (typ_info_t TYPE('a)) n 0)"

definition
  field_size :: "'a::c_type itself \<Rightarrow> qualified_field_name \<Rightarrow> nat"
where
  "field_size t n \<equiv> size_td (the (field_ti t n))"

definition
  field_lvalue :: "'a::c_type ptr \<Rightarrow> qualified_field_name \<Rightarrow> addr" ("&'(_\<rightarrow>_')")
where
  "&(p\<rightarrow>f) \<equiv> ptr_val (p::'a ptr) + of_nat (field_offset TYPE('a) f)"

definition
  size_of :: "'a::c_type itself \<Rightarrow> nat" where
  "size_of t \<equiv> size_td (typ_info_t TYPE('a))"

definition
  norm_bytes :: "'a::c_type itself \<Rightarrow> normalisor" where
  "norm_bytes t \<equiv> norm_tu (export_uinfo (typ_info_t t))"

definition to_bytes_p :: "'a::c_type \<Rightarrow> byte list" where
  "to_bytes_p v \<equiv> to_bytes v (replicate (size_of TYPE('a)) 0)"

primrec
  align_td :: "'a typ_desc \<Rightarrow> nat" and
  align_td_struct :: "'a typ_struct \<Rightarrow> nat" and
  align_td_list :: "'a typ_pair list \<Rightarrow> nat" and
  align_td_pair :: "'a typ_pair \<Rightarrow> nat"
where
  al0:  "align_td (TypDesc st nm) = align_td_struct st"

| al1:  "align_td_struct (TypScalar n algn d) = algn"
| al2:  "align_td_struct (TypAggregate xs) = align_td_list xs"

| al3:  "align_td_list [] = 0"
| al4:  "align_td_list (x#xs) = max (align_td_pair x) (align_td_list xs)"

| al5:  "align_td_pair (DTPair t n) = align_td t"

definition align_of :: "'a::c_type itself \<Rightarrow> nat" where
  "align_of t \<equiv> 2^(align_td (typ_info_t TYPE('a)))"

definition
  ptr_add :: "('a::c_type) ptr \<Rightarrow> int \<Rightarrow> 'a ptr" (infixl "+\<^sub>p" 65)
where
  "ptr_add (a :: ('a::c_type) ptr) w \<equiv>
     Ptr (ptr_val a + of_int w * of_nat (size_of (TYPE('a))))"

lemma ptr_add_def':
  "ptr_add (Ptr p :: ('a::c_type) ptr) n
      = (Ptr (p + of_int n * of_nat (size_of TYPE('a))))"
  by (cases p, auto simp: ptr_add_def scast_id)

definition
  ptr_sub :: "('a::c_type) ptr \<Rightarrow> ('a::c_type) ptr \<Rightarrow> 32 signed word" (infixl "-\<^sub>p" 65)
where
  "ptr_sub (a :: ('a::c_type) ptr) p \<equiv>
     ucast (ptr_val a - ptr_val p) div of_nat (size_of (TYPE('a)))"

definition ptr_aligned :: "'a::c_type ptr \<Rightarrow> bool" where
  "ptr_aligned p \<equiv> align_of TYPE('a) dvd unat (ptr_val (p::'a ptr))"

primrec
  td_set :: "'a typ_desc \<Rightarrow> nat \<Rightarrow> ('a typ_desc \<times> nat) set" and
  td_set_struct :: "'a typ_struct \<Rightarrow> nat \<Rightarrow> ('a typ_desc \<times> nat) set" and
  td_set_list :: "'a typ_pair list \<Rightarrow> nat \<Rightarrow> ('a typ_desc \<times> nat) set" and
  td_set_pair :: "'a typ_pair \<Rightarrow> nat \<Rightarrow> ('a typ_desc \<times> nat) set"
where
  ts0:  "td_set (TypDesc st nm) m = {(TypDesc st nm,m)} \<union> td_set_struct st m"

| ts1:  "td_set_struct (TypScalar n algn d) m = {}"
| ts2:  "td_set_struct (TypAggregate xs) m = td_set_list xs m"

| ts3:  "td_set_list [] m = {}"
| ts4:  "td_set_list (x#xs) m = td_set_pair x m \<union> td_set_list xs (m + size_td (dt_fst x))"

| ts5:  "td_set_pair (DTPair t nm) m = td_set t m"

instantiation typ_desc :: (type) ord
begin

definition
  typ_tag_le_def:  "s \<le> (t::'a typ_desc) \<equiv> (\<exists>n. (s,n) \<in> td_set t 0)"
definition
  typ_tag_lt_def: "s < (t::'a typ_desc) \<equiv> s \<le> t \<and> s \<noteq> t"
instance ..

end

definition
  fd_cons_double_update :: "'a field_desc \<Rightarrow> bool"
where
  "fd_cons_double_update d \<equiv>
      (\<forall>v bs bs'. length bs = length bs' \<longrightarrow> field_update d bs (field_update d bs' v) = field_update d bs v)"

definition
  fd_cons_update_access :: "'a field_desc \<Rightarrow> nat \<Rightarrow> bool"
where
  "fd_cons_update_access d n \<equiv>
      (\<forall>v bs. length bs = n \<longrightarrow> field_update d (field_access d v bs) v = v)"

definition
  norm_desc  :: "'a field_desc \<Rightarrow> nat \<Rightarrow> (byte list \<Rightarrow> byte list)"
where
  "norm_desc d n \<equiv> \<lambda>bs. field_access d (field_update d bs undefined) (replicate n 0)"

definition
  fd_cons_length :: "'a field_desc \<Rightarrow> nat \<Rightarrow> bool"
where
  "fd_cons_length d n \<equiv> \<forall>v bs. length bs = n \<longrightarrow> length (field_access d v bs) = n"

definition
  fd_cons_access_update :: "'a field_desc \<Rightarrow> nat \<Rightarrow> bool"
where
  "fd_cons_access_update d n \<equiv> \<forall>bs bs' v v'. length bs = n \<longrightarrow>
      length bs' = n \<longrightarrow>
      field_access d (field_update d bs v) bs' = field_access d (field_update d bs v') bs'"

definition
  fd_cons_update_normalise :: "'a field_desc \<Rightarrow> nat \<Rightarrow> bool"
where
  "fd_cons_update_normalise d n  \<equiv>
      (\<forall>v bs. length bs=n \<longrightarrow> field_update d (norm_desc d n bs) v = field_update d bs v)"

definition
  fd_cons_desc :: "'a field_desc \<Rightarrow> nat \<Rightarrow> bool"
where
  "fd_cons_desc d n \<equiv> fd_cons_double_update d \<and>
      fd_cons_update_access d n \<and>
      fd_cons_access_update d n \<and>
      fd_cons_length d n"

definition
  fd_cons :: "'a typ_info \<Rightarrow> bool"
where
  "fd_cons t \<equiv> fd_cons_desc (field_desc t) (size_td t)"

definition
  fd_cons_struct :: "'a typ_info_struct \<Rightarrow> bool"
where
  "fd_cons_struct t \<equiv> fd_cons_desc (field_desc_struct t) (size_td_struct t)"

definition
  fd_cons_list :: "'a typ_info_pair list \<Rightarrow> bool"
where
  "fd_cons_list t \<equiv> fd_cons_desc (field_desc_list t) (size_td_list t)"

definition
  fd_cons_pair :: "'a typ_info_pair \<Rightarrow> bool"
where
  "fd_cons_pair t \<equiv> fd_cons_desc (field_desc_pair t) (size_td_pair t)"

definition
  fa_fu_ind :: "'a field_desc \<Rightarrow> 'a field_desc \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>bool"
where
  "fa_fu_ind d d' n n' \<equiv> \<forall>v bs bs'. length bs = n \<longrightarrow> length bs' = n' \<longrightarrow>
      field_access d (field_update d' bs v) bs' = field_access d v bs'"

definition
  wf_fdp :: "('a typ_info \<times> qualified_field_name) set \<Rightarrow> bool"
where
  "wf_fdp t \<equiv> \<forall>x m. (x,m) \<in> t \<longrightarrow> (fd_cons x \<and> (\<forall>y n. (y,n) \<in> t \<and> \<not> m \<le> n \<and> \<not> n \<le> m
      \<longrightarrow> fu_commutes (field_update (field_desc x)) (field_update (field_desc y)) \<and>
          fa_fu_ind (field_desc x) (field_desc y) (size_td y) (size_td x)))"

lemma wf_fdp_list:
  "wf_fdp (xs \<union> ys) \<Longrightarrow> wf_fdp xs \<and> wf_fdp ys"
  by (auto simp: wf_fdp_def)

primrec
  wf_fd :: "'a typ_info \<Rightarrow> bool" and
  wf_fd_struct :: "'a typ_info_struct \<Rightarrow> bool" and
  wf_fd_list :: "'a typ_info_pair list \<Rightarrow> bool" and
  wf_fd_pair :: "'a typ_info_pair \<Rightarrow> bool"
where
  wffd0:  "wf_fd (TypDesc ts n) = (wf_fd_struct ts)"

| wffd1:  "wf_fd_struct (TypScalar n algn d) = fd_cons_struct (TypScalar n algn d)"
| wffd2:  "wf_fd_struct (TypAggregate ts) = wf_fd_list ts"

| wffd3:  "wf_fd_list [] = True"
| wffd4:  "wf_fd_list (x#xs) = (wf_fd_pair x \<and> wf_fd_list xs \<and>
      fu_commutes (update_ti_pair_t x) (update_ti_list_t xs) \<and>
      fa_fu_ind (field_desc_pair x) (field_desc_list xs) (size_td_list xs) (size_td_pair x)\<and>
      fa_fu_ind (field_desc_list xs) (field_desc_pair x) (size_td_pair x) (size_td_list xs))"

| wffd5:  "wf_fd_pair (DTPair x n) = wf_fd x"

definition
  tf_set :: "'a typ_info \<Rightarrow> ('a typ_info \<times> qualified_field_name) set"
where
  "tf_set td \<equiv> {(s,f) | s f. \<exists>n. field_lookup td f 0 = Some (s,n)}"

definition
  tf_set_struct :: "'a typ_info_struct \<Rightarrow> ('a typ_info \<times> qualified_field_name) set"
where
  "tf_set_struct td \<equiv> {(s,f) | s f. \<exists>n. field_lookup_struct td f 0 = Some (s,n)}"

definition
  tf_set_list :: "'a typ_info_pair list \<Rightarrow> ('a typ_info \<times> qualified_field_name) set"
where
  "tf_set_list td \<equiv> {(s,f) | s f. \<exists>n. field_lookup_list td f 0 = Some (s,n)}"

definition
  tf_set_pair :: "'a typ_info_pair \<Rightarrow> ('a typ_info \<times> qualified_field_name) set"
where
  "tf_set_pair td \<equiv> {(s,f) | s f. \<exists>n. field_lookup_pair td f 0 = Some (s,n)}"

record 'a leaf_desc =
  lf_fd :: "'a field_desc"
  lf_sz :: nat
  lf_fn :: qualified_field_name

primrec
  lf_set :: "'a typ_info \<Rightarrow> qualified_field_name \<Rightarrow> 'a leaf_desc set" and
  lf_set_struct :: "'a typ_info_struct \<Rightarrow> qualified_field_name \<Rightarrow> 'a leaf_desc set" and
  lf_set_list :: "'a typ_info_pair list \<Rightarrow> qualified_field_name \<Rightarrow> 'a leaf_desc set" and
  lf_set_pair :: "'a typ_info_pair \<Rightarrow> qualified_field_name \<Rightarrow> 'a leaf_desc set"
where
  fds0:  "lf_set (TypDesc st nm) fn = lf_set_struct st fn"

| fds1:  "lf_set_struct (TypScalar n algn d) fn = {(\<lparr> lf_fd = d, lf_sz = n, lf_fn = fn \<rparr>)}"
| fds2:  "lf_set_struct (TypAggregate xs) fn = lf_set_list xs fn"

| fds3:  "lf_set_list [] fn = {}"
| fds4:  "lf_set_list (x#xs) fn = lf_set_pair x fn \<union> lf_set_list xs fn"

| fds5:  "lf_set_pair (DTPair t n) fn = lf_set t (fn@[n])"

definition
  wf_lf :: "'a leaf_desc set \<Rightarrow> bool"
where
  "wf_lf D \<equiv> \<forall>x. x \<in> D \<longrightarrow> (fd_cons_desc (lf_fd x) (lf_sz x) \<and> (\<forall>y. y \<in> D \<longrightarrow> lf_fn y \<noteq> lf_fn x
      \<longrightarrow> fu_commutes (field_update (lf_fd x)) (field_update (lf_fd y)) \<and>
          fa_fu_ind (lf_fd x) (lf_fd y) (lf_sz y) (lf_sz x)))"

definition
  ti_ind :: "'a leaf_desc set \<Rightarrow> 'a leaf_desc set \<Rightarrow> bool"
where
  "ti_ind X Y \<equiv> \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> (
      fu_commutes (field_update (lf_fd x)) (field_update (lf_fd y)) \<and>
          fa_fu_ind (lf_fd x) (lf_fd y) (lf_sz y) (lf_sz x) \<and>
          fa_fu_ind (lf_fd y) (lf_fd x) (lf_sz x) (lf_sz y))"

definition
  t2d :: "('a typ_info \<times> qualified_field_name) \<Rightarrow> 'a leaf_desc"
where
  "t2d x \<equiv> \<lparr> lf_fd = field_desc (fst x), lf_sz = size_td (fst x), lf_fn = snd x\<rparr>"

definition
  fd_consistent :: "'a typ_info \<Rightarrow> bool"
where
  "fd_consistent t \<equiv> \<forall>f s n. field_lookup t f 0 = Some (s,n)
      \<longrightarrow> fd_cons s"

class wf_type = c_type +
  assumes wf_desc [simp]: "wf_desc (typ_info_t TYPE('a::c_type))"
  assumes wf_size_desc [simp]: "wf_size_desc (typ_info_t TYPE('a::c_type))"
  assumes wf_lf [simp]: "wf_lf (lf_set (typ_info_t TYPE('a::c_type)) [])"

definition
  super_update_bs :: "byte list \<Rightarrow> byte list \<Rightarrow> nat \<Rightarrow> byte list"
where
  "super_update_bs v bs n \<equiv> take n bs @ v @
      drop (n + length v) bs"

definition
  disj_fn :: "qualified_field_name \<Rightarrow> qualified_field_name \<Rightarrow> bool"
where
  "disj_fn s t \<equiv> \<not> s \<le> t \<and> \<not> t \<le> s"

definition
  fs_path :: "qualified_field_name list \<Rightarrow> qualified_field_name set"
where
  "fs_path xs \<equiv> {x. \<exists>k. k \<in> set xs \<and> x \<le> k} \<union> {x. \<exists>k. k \<in> set xs \<and> k \<le> x}"

definition
  field_names :: "'a typ_desc \<Rightarrow> qualified_field_name set"
where
  "field_names t \<equiv> {f. field_lookup t f 0 \<noteq> None}"

definition
  align_field :: "'a typ_desc \<Rightarrow> bool"
where
  "align_field ti \<equiv> \<forall>f s n. field_lookup ti f 0 = Some (s,n) \<longrightarrow>
      2^(align_td s) dvd n"

class mem_type_sans_size = wf_type +
  assumes upd:
     "length bs = size_of TYPE('a) \<longrightarrow>
      update_ti_t (typ_info_t TYPE('a::c_type)) bs v
          = update_ti_t (typ_info_t TYPE('a)) bs w"
  assumes align_size_of: "align_of (TYPE('a::c_type)) dvd size_of TYPE('a)"
  assumes align_field: "align_field (typ_info_t TYPE('a::c_type))"

class mem_type = mem_type_sans_size +
  assumes max_size: "size_of (TYPE('a::c_type)) < addr_card"

primrec
  aggregate :: "'a typ_desc \<Rightarrow> bool" and
  aggregate_struct :: "'a typ_struct \<Rightarrow> bool"
where
  "aggregate (TypDesc st tn) = aggregate_struct st"

| "aggregate_struct (TypScalar n algn d) = False"
| "aggregate_struct (TypAggregate ts) = True"

class simple_mem_type = mem_type +
  assumes simple_tag: "\<not> aggregate (typ_info_t TYPE('a::c_type))"

definition
  field_of :: "addr \<Rightarrow> 'a typ_desc \<Rightarrow> 'a typ_desc \<Rightarrow> bool"
where
  "field_of q s t \<equiv> (s,unat q) \<in> td_set t 0"

definition
  field_of_t :: "'a::c_type ptr \<Rightarrow> 'b::c_type ptr \<Rightarrow> bool"
where
  "field_of_t p q \<equiv> field_of (ptr_val p - ptr_val q) (typ_uinfo_t TYPE('a))
      (typ_uinfo_t TYPE('b))"

definition
  h_val :: "heap_mem \<Rightarrow> 'a::c_type ptr \<Rightarrow> 'a"
where
  "h_val h \<equiv> \<lambda>p. from_bytes (heap_list h (size_of TYPE ('a))
      (ptr_val (p::'a ptr)))"

primrec
  heap_update_list :: "addr \<Rightarrow> byte list \<Rightarrow> heap_mem \<Rightarrow> heap_mem"
where
  heap_update_list_base: "heap_update_list p [] h = h"
| heap_update_list_rec:
  "heap_update_list p (x#xs) h = heap_update_list (p + 1) xs (h(p:= x))"

type_synonym 'a typ_heap_g = "'a ptr \<Rightarrow> 'a"

(* FIXME: now redundant with h_val *)
definition
  lift :: "heap_mem \<Rightarrow> 'a::c_type typ_heap_g"
where
  "lift h \<equiv> h_val h"

definition
  heap_update :: "'a::c_type ptr \<Rightarrow> 'a \<Rightarrow> heap_mem \<Rightarrow> heap_mem"
where
  "heap_update p v h \<equiv> heap_update_list (ptr_val p) (to_bytes v (heap_list h (size_of TYPE('a)) (ptr_val p))) h"

fun
  fold_td' :: "(typ_name \<Rightarrow> ('a \<times> field_name) list \<Rightarrow> 'a) \<times> 'a typ_desc \<Rightarrow> 'a"
where
fot0: "fold_td' (f,TypDesc st nm) = (case st of
           TypScalar n algn d \<Rightarrow> d |
           TypAggregate ts \<Rightarrow> f nm (map (\<lambda>x. case x of DTPair t n \<Rightarrow> (fold_td' (f,t),n)) ts))"

definition
  fold_td :: "(typ_name \<Rightarrow> ('a \<times> field_name) list \<Rightarrow> 'a) \<Rightarrow> 'a typ_desc \<Rightarrow> 'a"
where
  "fold_td \<equiv> \<lambda>f t. fold_td' (f,t)"

declare fold_td_def [simp add]

definition
  fold_td_struct :: "typ_name \<Rightarrow> (typ_name \<Rightarrow> ('a \<times> field_name) list \<Rightarrow> 'a) \<Rightarrow> 'a typ_struct \<Rightarrow> 'a"
where
  "fold_td_struct tn f st \<equiv> (case st of
           TypScalar n algn d \<Rightarrow> d |
           TypAggregate ts \<Rightarrow> f tn (map (\<lambda>x. case x of DTPair t n \<Rightarrow> (fold_td' (f,t),n)) ts))"

declare fold_td_struct_def [simp add]

definition
  fold_td_list :: "typ_name \<Rightarrow> (typ_name \<Rightarrow> ('a \<times> field_name) list \<Rightarrow> 'a) \<Rightarrow> 'a typ_pair list \<Rightarrow> 'a"
where
  "fold_td_list tn f ts \<equiv> f tn (map (\<lambda>x. case x of DTPair t n \<Rightarrow> (fold_td' (f,t),n)) ts)"

declare fold_td_list_def [simp add]

definition
  fold_td_pair :: "(typ_name \<Rightarrow> ('a \<times> field_name) list \<Rightarrow> 'a) \<Rightarrow> 'a typ_pair \<Rightarrow> 'a"
where
  "fold_td_pair f x \<equiv> (case x of DTPair t n \<Rightarrow> fold_td' (f,t))"

declare fold_td_pair_def [simp add]

fun
  map_td' :: "(nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'b) \<times> 'a typ_desc \<Rightarrow> 'b typ_desc"
where
  "map_td' (f,TypDesc st nm) = (TypDesc (case st of
           TypScalar n algn d \<Rightarrow> TypScalar n algn (f n algn d) |
           TypAggregate ts \<Rightarrow> TypAggregate (map (\<lambda>x. case x of DTPair t n \<Rightarrow> DTPair (map_td' (f,t)) n) ts)) nm)"

definition
  tnSum :: "typ_name \<Rightarrow> (nat \<times> field_name) list \<Rightarrow> nat"
where
  "tnSum \<equiv> \<lambda>tn ts. foldr (op + o fst) ts 0"

definition
  tnMax :: "typ_name \<Rightarrow> (nat \<times> field_name) list \<Rightarrow> nat"
where
  "tnMax \<equiv> \<lambda>tn ts. foldr (\<lambda>x y. max (fst x) y) ts 0"

definition
  wfd :: "typ_name \<Rightarrow> (bool \<times> field_name) list \<Rightarrow> bool"
where
  "wfd \<equiv> \<lambda>tn ts. distinct (map snd ts) \<and> foldr (op \<and>) (map fst ts) True"

definition
  wfsd :: "typ_name \<Rightarrow> (bool \<times> field_name) list \<Rightarrow> bool"
where
  "wfsd \<equiv> \<lambda>tn ts. ts \<noteq> [] \<and> foldr (op \<and>) (map fst ts) True"

end


theory Analyze_SQRL_Shorewall
imports
  Iptables_Semantics.Parser
begin

section\<open>Example: SQRL Shorewall\<close>

parse_iptables_save SQRL_fw="iptables-saveakachan"

thm SQRL_fw_def
thm SQRL_fw_FORWARD_default_policy_def

value[code] "map (\<lambda>(c,rs). (c, map (quote_rewrite \<circ> common_primitive_rule_toString) rs)) SQRL_fw"

lemma "Semantics_Goto.terminal_chain (the ((map_of_string_ipv4 SQRL_fw) ''smurflog''))" by eval
lemma "Semantics_Goto.terminal_chain (the ((map_of_string_ipv4 SQRL_fw) ''logflags''))" by eval
lemma "Semantics_Goto.terminal_chain (the ((map_of_string_ipv4 SQRL_fw) ''reject''))" by eval

(*12.942s*)
value[code] "Semantics_Goto.rewrite_Goto SQRL_fw"

definition "unfolded = unfold_ruleset_FORWARD SQRL_fw_FORWARD_default_policy (map_of_string_ipv4 (Semantics_Goto.rewrite_Goto SQRL_fw))"

(*
(*2174.839s elapsed time, 3308.410s cpu time, 161.539s GC time*)
value[code] "unfolded"*)
(*0.561s*)
value[code] "let x = unfolded in ()" (*pretty printing is slow, not the unfolding! ML forces evaluation of unfolded!*)
(*39.149s*)
value[code] "map (quote_rewrite \<circ> common_primitive_rule_toString) (unfolded)"
(*2.871s*)
lemma "length unfolded = 2649" by eval

(*17.554s*)
value[code] "map (quote_rewrite \<circ> common_primitive_rule_toString) (upper_closure unfolded)"
lemma "length (upper_closure unfolded) = 1986" by eval

value[code] "upper_closure (packet_assume_new unfolded)"

(*28.550s*)
lemma "length (lower_closure unfolded) = 5715" by eval

lemma "check_simple_fw_preconditions (upper_closure unfolded) = False" by eval
lemma "\<forall>m \<in> get_match`set (upper_closure (packet_assume_new unfolded)). normalized_nnf_match m" by eval

lemma "\<forall>m \<in> get_match`set (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new unfolded))). normalized_nnf_match m" by eval

lemma "check_simple_fw_preconditions (upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new unfolded))))" by eval
lemma "length (to_simple_firewall (upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new unfolded))))) = 1389" by eval
(*22.240s*)
value[code] "map simple_rule_ipv4_toString (to_simple_firewall (upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new unfolded)))))"

(*25.480s*)
value[code] "map ipv4addr_wordinterval_toString (getParts (to_simple_firewall (upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new unfolded))))))"

(*43.702s*)
lemma "length (to_simple_firewall (lower_closure (optimize_matches abstract_for_simple_firewall (lower_closure (packet_assume_new unfolded))))) = 5120" by eval

(*71.518s*)
value[code] "length (remdups_rev (to_simple_firewall (lower_closure (optimize_matches abstract_for_simple_firewall (lower_closure (packet_assume_new unfolded))))))" (*not smaller*)

value[code] "map ipv4addr_wordinterval_toString (getParts (to_simple_firewall (lower_closure (optimize_matches abstract_for_simple_firewall (lower_closure (packet_assume_new unfolded))))))"

lemma "simple_fw_valid (to_simple_firewall (lower_closure (optimize_matches abstract_for_simple_firewall (lower_closure (packet_assume_new unfolded)))))" by eval
lemma "simple_fw_valid (to_simple_firewall (upper_closure (optimize_matches abstract_for_simple_firewall (lower_closure (packet_assume_new unfolded)))))" by eval

end