theory SINVAR_ACLcommunicateWith_impl
imports SINVAR_ACLcommunicateWith "../TopoS_Interface_impl"
begin

code_identifier code_module SINVAR_ACLcommunicateWith_impl => (Scala) SINVAR_ACLcommunicateWith

subsubsection \<open>List Implementation\<close>

fun sinvar :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> 'v list) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> v \<in> set (nodesL G). \<forall>a \<in> (set (succ_tran G v)). a \<in> set (nP v))"

definition "NetModel_node_props (P::('v::vertex, 'v list) TopoS_Params) =
  (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> SINVAR_ACLcommunicateWith.default_node_properties))"

definition "ACLcommunicateWith_offending_list = Generic_offending_list sinvar"

definition "ACLcommunicateWith_eval G P = (wf_list_graph G \<and>
  sinvar G (SecurityInvariant.node_props SINVAR_ACLcommunicateWith.default_node_properties P))"

lemma sinvar_correct: "wf_list_graph G \<Longrightarrow> SINVAR_ACLcommunicateWith.sinvar (list_graph_to_graph G) nP = sinvar G nP"
by (metis SINVAR_ACLcommunicateWith.sinvar.simps SINVAR_ACLcommunicateWith_impl.sinvar.simps graph.select_convs(1) list_graph_to_graph_def succ_tran_correct)

interpretation SINVAR_ACLcommunicateWith_impl:TopoS_List_Impl
  where default_node_properties=SINVAR_ACLcommunicateWith.default_node_properties
  and sinvar_spec=SINVAR_ACLcommunicateWith.sinvar
  and sinvar_impl=sinvar
  and receiver_violation=SINVAR_ACLcommunicateWith.receiver_violation
  and offending_flows_impl=ACLcommunicateWith_offending_list
  and node_props_impl=NetModel_node_props
  and eval_impl=ACLcommunicateWith_eval
 apply(unfold TopoS_List_Impl_def)
 apply(rule conjI)
  apply(rule conjI)
   apply(simp add: TopoS_ACLcommunicateWith; fail)
  apply(intro allI impI)
  apply(fact sinvar_correct)
 apply(rule conjI)
  apply(unfold ACLcommunicateWith_offending_list_def)
  apply(intro allI impI)
  apply(rule Generic_offending_list_correct)
   apply(assumption)
  apply(simp only: sinvar_correct; fail)
 apply(rule conjI)
  apply(intro allI)
  apply(simp only: NetModel_node_props_def)
  apply(metis ACLcommunicateWith.node_props.simps ACLcommunicateWith.node_props_eq_node_props_formaldef)
 apply(simp only: ACLcommunicateWith_eval_def)
 apply(intro allI impI)
 apply(rule TopoS_eval_impl_proofrule[OF TopoS_ACLcommunicateWith])
 apply(simp only: sinvar_correct; fail)
done

subsubsection \<open>packing\<close>
  definition SINVAR_LIB_ACLcommunicateWith:: "('v::vertex, 'v list) TopoS_packed" where
    "SINVAR_LIB_ACLcommunicateWith \<equiv>
    \<lparr> nm_name = ''ACLcommunicateWith'',
      nm_receiver_violation = SINVAR_ACLcommunicateWith.receiver_violation,
      nm_default = SINVAR_ACLcommunicateWith.default_node_properties,
      nm_sinvar = sinvar,
      nm_offending_flows = ACLcommunicateWith_offending_list,
      nm_node_props = NetModel_node_props,
      nm_eval = ACLcommunicateWith_eval
      \<rparr>"
  interpretation SINVAR_LIB_ACLcommunicateWith_interpretation: TopoS_modelLibrary SINVAR_LIB_ACLcommunicateWith
      SINVAR_ACLcommunicateWith.sinvar
    apply(unfold TopoS_modelLibrary_def SINVAR_LIB_ACLcommunicateWith_def)
    apply(rule conjI)
     apply(simp)
    apply(simp)
    by(unfold_locales)

text \<open>Examples\<close>
context begin
  text\<open>
    1 can access 2 and 3
    2 can access 3
\<close>
  private lemma "sinvar
            \<lparr> nodesL = [1::nat, 2, 3],
              edgesL = [(1,2), (2,3)]\<rparr>
            (((\<lambda>v. SINVAR_ACLcommunicateWith.default_node_properties)
                    (1 := [2,3]))
                    (2 := [3]))" by eval

  text\<open>
    Everyone can access everyone, except for 1: 1 must not access 4.
    The offending flows may be any edge on the path from 1 to 4
\<close>
  lemma "ACLcommunicateWith_offending_list
          \<lparr> nodesL = [1::nat, 2, 3, 4],
            edgesL = [(1,2), (2,3), (3, 4)]\<rparr>
          (((((\<lambda>v. SINVAR_ACLcommunicateWith.default_node_properties)
          (1 := [1,2,3]))
          (2 := [1,2,3,4]))
          (3 := [1,2,3,4]))
          (4 := [1,2,3,4])) =
       [[(1, 2)], [(2, 3)], [(3, 4)]]" by eval
  text\<open>
    If we add the additional edge from 1 to 3, then the offending flows are either
    \<^item> [(3.4)], because this disconnects 4 from the graph completely
    \<^item> any pair of edges which disconnects 1 from 3
\<close>
  lemma "ACLcommunicateWith_offending_list
          \<lparr> nodesL = [1::nat, 2, 3, 4],
            edgesL = [(1,2), (1,3), (2,3), (3, 4)]\<rparr>
          (((((\<lambda>v. SINVAR_ACLcommunicateWith.default_node_properties)
          (1 := [1,2,3]))
          (2 := [1,2,3,4]))
          (3 := [1,2,3,4]))
          (4 := [1,2,3,4])) =
       [[(1, 2), (1, 3)], [(1, 3), (2, 3)], [(3, 4)]]" by eval
end

hide_const (open) NetModel_node_props
hide_const (open) sinvar

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      Language.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section {* The Simpl Syntax *}

theory Language imports "HOL-Library.Old_Recdef" begin

subsection {* The Core Language *}

text {* We use a shallow embedding of boolean expressions as well as assertions
as sets of states.
*}

type_synonym 's bexp = "'s set"
type_synonym 's assn = "'s set"

datatype (dead 's, 'p, 'f) com =
    Skip
  | Basic "'s \<Rightarrow> 's"
  | Spec "('s \<times> 's) set"
  | Seq "('s ,'p, 'f) com" "('s,'p, 'f) com"
  | Cond "'s bexp" "('s,'p,'f) com"  "('s,'p,'f) com"
  | While "'s bexp" "('s,'p,'f) com"
  | Call "'p"
  | DynCom "'s \<Rightarrow> ('s,'p,'f) com"
  | Guard "'f" "'s bexp" "('s,'p,'f) com"
  | Throw
  | Catch "('s,'p,'f) com" "('s,'p,'f) com"

abbreviation (input)
  set_fun :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"  ("_\<^sub>f") where
  "set_fun s \<equiv> \<lambda>v. v\<in>s"

abbreviation (input)
  fun_set :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set"  ("_\<^sub>s") where
  "fun_set f \<equiv> {\<sigma>. f \<sigma>}"

subsection {* Derived Language Constructs *}

definition
  raise:: "('s \<Rightarrow> 's) \<Rightarrow> ('s,'p,'f) com" where
  "raise f = Seq (Basic f) Throw"

definition
  condCatch:: "('s,'p,'f) com \<Rightarrow> 's bexp \<Rightarrow> ('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com" where
  "condCatch c\<^sub>1 b c\<^sub>2 = Catch c\<^sub>1 (Cond b c\<^sub>2 Throw)"

definition
  bind:: "('s \<Rightarrow> 'v) \<Rightarrow> ('v \<Rightarrow> ('s,'p,'f) com) \<Rightarrow> ('s,'p,'f) com" where
  "bind e c = DynCom (\<lambda>s. c (e s))"

definition
  bseq:: "('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com" where
  "bseq = Seq"

definition
  block:: "['s\<Rightarrow>'s,('s,'p,'f) com,'s\<Rightarrow>'s\<Rightarrow>'s,'s\<Rightarrow>'s\<Rightarrow>('s,'p,'f) com]\<Rightarrow>('s,'p,'f) com"
where
  "block init bdy return c =
    DynCom (\<lambda>s. (Seq (Catch (Seq (Basic init) bdy) (Seq (Basic (return s)) Throw))
                            (DynCom (\<lambda>t. Seq (Basic (return s)) (c s t))))
                        )"

definition
  call:: "('s\<Rightarrow>'s) \<Rightarrow> 'p \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> 's)\<Rightarrow>('s\<Rightarrow>'s\<Rightarrow>('s,'p,'f) com)\<Rightarrow>('s,'p,'f)com" where
  "call init p return c = block init (Call p) return c"

definition
  dynCall:: "('s \<Rightarrow> 's) \<Rightarrow> ('s \<Rightarrow> 'p) \<Rightarrow>
             ('s \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> ('s,'p,'f) com) \<Rightarrow> ('s,'p,'f) com" where
  "dynCall init p return c = DynCom (\<lambda>s. call init (p s) return c)"

definition
  fcall:: "('s\<Rightarrow>'s) \<Rightarrow> 'p \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> 's)\<Rightarrow>('s \<Rightarrow> 'v) \<Rightarrow> ('v\<Rightarrow>('s,'p,'f) com)
            \<Rightarrow>('s,'p,'f)com" where
  "fcall init p return result c = call init p return (\<lambda>s t. c (result t))"

definition
  lem:: "'x \<Rightarrow> ('s,'p,'f)com \<Rightarrow>('s,'p,'f)com" where
  "lem x c = c"

primrec switch:: "('s \<Rightarrow> 'v) \<Rightarrow> ('v set \<times> ('s,'p,'f) com) list \<Rightarrow> ('s,'p,'f) com"
where
"switch v [] = Skip" |
"switch v (Vc#vs) = Cond {s. v s \<in> fst Vc} (snd Vc) (switch v vs)"

definition guaranteeStrip:: "'f \<Rightarrow> 's set \<Rightarrow> ('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com"
  where "guaranteeStrip f g c = Guard f g c"

definition guaranteeStripPair:: "'f \<Rightarrow> 's set \<Rightarrow> ('f \<times> 's set)"
  where "guaranteeStripPair f g = (f,g)"

primrec guards:: "('f \<times> 's set ) list \<Rightarrow> ('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com"
where
"guards [] c = c" |
"guards (g#gs) c = Guard (fst g) (snd g) (guards gs c)"

definition
  while::  "('f \<times> 's set) list \<Rightarrow> 's bexp \<Rightarrow> ('s,'p,'f) com \<Rightarrow> ('s, 'p, 'f) com"
where
  "while gs b c = guards gs (While b (Seq c (guards gs Skip)))"

definition
  whileAnno::
  "'s bexp \<Rightarrow> 's assn \<Rightarrow> ('s \<times> 's) assn \<Rightarrow> ('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com" where
  "whileAnno b I V c = While b c"

definition
  whileAnnoG::
  "('f \<times> 's set) list \<Rightarrow> 's bexp \<Rightarrow> 's assn \<Rightarrow> ('s \<times> 's) assn \<Rightarrow>
     ('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com" where
  "whileAnnoG gs b I V c = while gs b c"

definition
  specAnno::  "('a \<Rightarrow> 's assn) \<Rightarrow> ('a \<Rightarrow> ('s,'p,'f) com) \<Rightarrow>
                         ('a \<Rightarrow> 's assn) \<Rightarrow> ('a \<Rightarrow> 's assn) \<Rightarrow> ('s,'p,'f) com"
  where "specAnno P c Q A = (c undefined)"

definition
  whileAnnoFix::
  "'s bexp \<Rightarrow> ('a \<Rightarrow> 's assn) \<Rightarrow> ('a \<Rightarrow> ('s \<times> 's) assn) \<Rightarrow> ('a \<Rightarrow> ('s,'p,'f) com) \<Rightarrow>
     ('s,'p,'f) com" where
  "whileAnnoFix b I V c = While b (c undefined)"

definition
  whileAnnoGFix::
  "('f \<times> 's set) list \<Rightarrow> 's bexp \<Rightarrow> ('a \<Rightarrow> 's assn) \<Rightarrow> ('a \<Rightarrow> ('s \<times> 's) assn) \<Rightarrow>
     ('a \<Rightarrow> ('s,'p,'f) com) \<Rightarrow> ('s,'p,'f) com" where
  "whileAnnoGFix gs b I V c = while gs b (c undefined)"

definition if_rel::"('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's) \<Rightarrow> ('s \<Rightarrow> 's) \<Rightarrow> ('s \<Rightarrow> 's) \<Rightarrow> ('s \<times> 's) set"
  where "if_rel b f g h = {(s,t). if b s then t = f s else t = g s \<or> t = h s}"

lemma fst_guaranteeStripPair: "fst (guaranteeStripPair f g) = f"
  by (simp add: guaranteeStripPair_def)

lemma snd_guaranteeStripPair: "snd (guaranteeStripPair f g) = g"
  by (simp add: guaranteeStripPair_def)

subsection {* Operations on Simpl-Syntax *}

subsubsection {* Normalisation of Sequential Composition: @{text "sequence"}, @{text "flatten"} and @{text "normalize"} *}

primrec flatten:: "('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com list"
where
"flatten Skip = [Skip]" |
"flatten (Basic f) = [Basic f]" |
"flatten (Spec r) = [Spec r]" |
"flatten (Seq c\<^sub>1 c\<^sub>2)  = flatten c\<^sub>1 @ flatten c\<^sub>2" |
"flatten (Cond b c\<^sub>1 c\<^sub>2) = [Cond b c\<^sub>1 c\<^sub>2]" |
"flatten (While b c) = [While b c]" |
"flatten (Call p) = [Call p]" |
"flatten (DynCom c) = [DynCom c]" |
"flatten (Guard f g c) = [Guard f g c]" |
"flatten Throw = [Throw]" |
"flatten (Catch c\<^sub>1 c\<^sub>2) = [Catch c\<^sub>1 c\<^sub>2]"

primrec sequence:: "(('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com) \<Rightarrow>
                      ('s,'p,'f) com list \<Rightarrow> ('s,'p,'f) com"
where
"sequence seq [] = Skip" |
"sequence seq (c#cs) = (case cs of [] \<Rightarrow> c
                        | _ \<Rightarrow> seq c (sequence seq cs))"

primrec normalize:: "('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com"
where
"normalize Skip = Skip" |
"normalize (Basic f) = Basic f" |
"normalize (Spec r) = Spec r" |
"normalize (Seq c\<^sub>1 c\<^sub>2)  = sequence Seq
                            ((flatten (normalize c\<^sub>1)) @ (flatten (normalize c\<^sub>2)))" |
"normalize (Cond b c\<^sub>1 c\<^sub>2) = Cond b (normalize c\<^sub>1) (normalize c\<^sub>2)" |
"normalize (While b c) = While b (normalize c)" |
"normalize (Call p) = Call p" |
"normalize (DynCom c) = DynCom (\<lambda>s. (normalize (c s)))" |
"normalize (Guard f g c) = Guard f g (normalize c)" |
"normalize Throw = Throw" |
"normalize (Catch c\<^sub>1 c\<^sub>2) = Catch (normalize c\<^sub>1) (normalize c\<^sub>2)"

lemma flatten_nonEmpty: "flatten c \<noteq> []"
  by (induct c) simp_all

lemma flatten_single: "\<forall>c \<in> set (flatten c'). flatten c = [c]"
apply (induct c')
apply           simp
apply          simp
apply         simp
apply        (simp (no_asm_use) )
apply        blast
apply       (simp (no_asm_use) )
apply      (simp (no_asm_use) )
apply     simp
apply    (simp (no_asm_use))
apply   (simp (no_asm_use))
apply  simp
apply (simp (no_asm_use))
done

lemma flatten_sequence_id:
  "\<lbrakk>cs\<noteq>[];\<forall>c \<in> set cs. flatten c = [c]\<rbrakk> \<Longrightarrow> flatten (sequence Seq cs) = cs"
  apply (induct cs)
  apply  simp
  apply (case_tac cs)
  apply  simp
  apply auto
  done

lemma flatten_app:
  "flatten (sequence Seq (flatten c1 @ flatten c2)) = flatten c1 @ flatten c2"
  apply (rule flatten_sequence_id)
  apply (simp add: flatten_nonEmpty)
  apply (simp)
  apply (insert flatten_single)
  apply blast
  done

lemma flatten_sequence_flatten: "flatten (sequence Seq (flatten c)) = flatten c"
  apply (induct c)
  apply (auto simp add: flatten_app)
  done

lemma sequence_flatten_normalize: "sequence Seq (flatten (normalize c)) = normalize c"
apply (induct c)
apply (auto simp add:  flatten_app)
done

lemma flatten_normalize: "\<And>x xs. flatten (normalize c) = x#xs
       \<Longrightarrow> (case xs of [] \<Rightarrow> normalize c = x
              | (x'#xs') \<Rightarrow> normalize c= Seq x (sequence Seq xs))"
proof (induct c)
  case (Seq c1 c2)
  have "flatten (normalize (Seq c1 c2)) = x # xs" by fact
  hence "flatten (sequence Seq (flatten (normalize c1) @ flatten (normalize c2))) =
          x#xs"
    by simp
  hence x_xs: "flatten (normalize c1) @ flatten (normalize c2) = x # xs"
    by (simp add: flatten_app)
  show ?case
  proof (cases "flatten (normalize c1)")
    case Nil
    with flatten_nonEmpty show ?thesis by auto
  next
    case (Cons x1 xs1)
    note Cons_x1_xs1 = this
    with x_xs obtain
      x_x1: "x=x1" and xs_rest: "xs=xs1@flatten (normalize c2)"
      by auto
    show ?thesis
    proof (cases xs1)
      case Nil
      from Seq.hyps (1) [OF Cons_x1_xs1] Nil
      have "normalize c1 = x1"
        by simp
      with Cons_x1_xs1 Nil x_x1 xs_rest show ?thesis
        apply (cases "flatten (normalize c2)")
        apply (fastforce simp add: flatten_nonEmpty)
        apply simp
        done
    next
      case Cons
      from Seq.hyps (1) [OF Cons_x1_xs1] Cons
      have "normalize c1 = Seq x1 (sequence Seq xs1)"
        by simp
      with Cons_x1_xs1 Nil x_x1 xs_rest show ?thesis
        apply (cases "flatten (normalize c2)")
        apply (fastforce simp add: flatten_nonEmpty)
        apply (simp split: list.splits)
        done
    qed
  qed
qed (auto)

lemma flatten_raise [simp]: "flatten (raise f) = [Basic f, Throw]"
  by (simp add: raise_def)

lemma flatten_condCatch [simp]: "flatten (condCatch c1 b c2) = [condCatch c1 b c2]"
  by (simp add: condCatch_def)

lemma flatten_bind [simp]: "flatten (bind e c) = [bind e c]"
  by (simp add: bind_def)

lemma flatten_bseq [simp]: "flatten (bseq c1 c2) = flatten c1 @ flatten c2"
  by (simp add: bseq_def)

lemma flatten_call [simp]: "flatten (call init p return result) = [call init p return result]"
  by (simp add: call_def)

lemma flatten_dynCall [simp]: "flatten (dynCall init p return result) = [dynCall init p return result]"
  by (simp add: dynCall_def)

lemma flatten_fcall [simp]: "flatten (fcall init p return result c) = [fcall init p return result c]"
  by (simp add: fcall_def)

lemma flatten_switch [simp]: "flatten (switch v Vcs) = [switch v Vcs]"
  by (cases Vcs) auto

lemma flatten_guaranteeStrip [simp]:
  "flatten (guaranteeStrip f g c) = [guaranteeStrip f g c]"
  by (simp add: guaranteeStrip_def)

lemma flatten_while [simp]: "flatten (while gs b c) = [while gs b c]"
  apply (simp add: while_def)
  apply (induct gs)
  apply  auto
  done

lemma flatten_whileAnno [simp]:
  "flatten (whileAnno b I V c) = [whileAnno b I V c]"
  by (simp add: whileAnno_def)

lemma flatten_whileAnnoG [simp]:
  "flatten (whileAnnoG gs b I V c) = [whileAnnoG gs b I V c]"
  by (simp add: whileAnnoG_def)

lemma flatten_specAnno [simp]:
  "flatten (specAnno P c Q A) = flatten (c undefined)"
  by (simp add: specAnno_def)

lemmas flatten_simps = flatten.simps flatten_raise flatten_condCatch flatten_bind
  flatten_block flatten_call flatten_dynCall flatten_fcall flatten_switch
  flatten_guaranteeStrip
  flatten_while flatten_whileAnno flatten_whileAnnoG flatten_specAnno

lemma normalize_raise [simp]:
 "normalize (raise f) = raise f"
  by (simp add: raise_def)

lemma normalize_condCatch [simp]:
 "normalize (condCatch c1 b c2) = condCatch (normalize c1) b (normalize c2)"
  by (simp add: condCatch_def)

lemma normalize_bind [simp]:
 "normalize (bind e c) = bind e (\<lambda>v. normalize (c v))"
  by (simp add: bind_def)

lemma normalize_bseq [simp]:
 "normalize (bseq c1 c2) = sequence bseq
                            ((flatten (normalize c1)) @ (flatten (normalize c2)))"
  by (simp add: bseq_def)

lemma normalize_block [simp]: "normalize (block init bdy return c) =
                         block init (normalize bdy) return (\<lambda>s t. normalize (c s t))"
  apply (simp add: block_def)
  apply (rule ext)
  apply (simp)
  apply (cases "flatten (normalize bdy)")
  apply  (simp add: flatten_nonEmpty)
  apply (rule conjI)
  apply  simp
  apply  (drule flatten_normalize)
  apply  (case_tac list)
  apply   simp
  apply  simp
  apply (rule ext)
  apply (case_tac "flatten (normalize (c s sa))")
  apply  (simp add: flatten_nonEmpty)
  apply  simp
  apply (thin_tac "flatten (normalize bdy) = P" for P)
  apply (drule flatten_normalize)
  apply (case_tac lista)
  apply  simp
  apply simp
  done

lemma normalize_call [simp]:
  "normalize (call init p return c) = call init p return (\<lambda>i t. normalize (c i t))"
  by (simp add: call_def)

lemma normalize_dynCall [simp]:
  "normalize (dynCall init p return c) =
    dynCall init p return (\<lambda>s t. normalize (c s t))"
  by (simp add: dynCall_def)

lemma normalize_fcall [simp]:
  "normalize (fcall init p return result c) =
    fcall init p return result (\<lambda>v. normalize (c v))"
  by (simp add: fcall_def)

lemma normalize_switch [simp]:
  "normalize (switch v Vcs) = switch v (map (\<lambda>(V,c). (V,normalize c)) Vcs)"
apply (induct Vcs)
apply auto
done

lemma normalize_guaranteeStrip [simp]:
  "normalize (guaranteeStrip f g c) = guaranteeStrip f g (normalize c)"
  by (simp add: guaranteeStrip_def)

lemma normalize_guards [simp]:
  "normalize (guards gs c) = guards gs (normalize c)"
  by (induct gs) auto

text {* Sequencial composition with guards in the body is not preserved by
        normalize *}
lemma normalize_while [simp]:
  "normalize (while gs b c) = guards gs
      (While b (sequence Seq (flatten (normalize c) @ flatten (guards gs Skip))))"
  by (simp add: while_def)

lemma normalize_whileAnnoG [simp]:
  "normalize (whileAnnoG gs b I V c) = guards gs
      (While b (sequence Seq (flatten (normalize c) @ flatten (guards gs Skip))))"
  by (simp add: whileAnnoG_def)

lemma normalize_specAnno [simp]:
  "normalize (specAnno P c Q A) = specAnno P (\<lambda>s. normalize (c undefined)) Q A"
  by (simp add: specAnno_def)

lemmas normalize_simps =
  normalize.simps normalize_raise normalize_condCatch normalize_bind
  normalize_block normalize_call normalize_dynCall normalize_fcall normalize_switch
  normalize_guaranteeStrip normalize_guards
  normalize_while normalize_whileAnno normalize_whileAnnoG normalize_specAnno

subsubsection {* Stripping Guards: @{text "strip_guards"} *}

primrec strip_guards:: "'f set \<Rightarrow> ('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com"
where
"strip_guards F Skip = Skip" |
"strip_guards F (Basic f) = Basic f" |
"strip_guards F (Spec r) = Spec r" |
"strip_guards F (Seq c\<^sub>1 c\<^sub>2)  = (Seq (strip_guards F c\<^sub>1) (strip_guards F c\<^sub>2))" |
"strip_guards F (Cond b c\<^sub>1 c\<^sub>2) = Cond b (strip_guards F c\<^sub>1) (strip_guards F c\<^sub>2)" |
"strip_guards F (While b c) = While b (strip_guards F c)" |
"strip_guards F (Call p) = Call p" |
"strip_guards F (DynCom c) = DynCom (\<lambda>s. (strip_guards F (c s)))" |
"strip_guards F (Guard f g c) = (if f \<in> F then strip_guards F c
                                  else Guard f g (strip_guards F c))" |
"strip_guards F Throw = Throw" |
"strip_guards F (Catch c\<^sub>1 c\<^sub>2) = Catch (strip_guards F c\<^sub>1) (strip_guards F c\<^sub>2)"

definition strip:: "'f set \<Rightarrow>
                   ('p \<Rightarrow> ('s,'p,'f) com option) \<Rightarrow> ('p \<Rightarrow> ('s,'p,'f) com option)"
  where "strip F \<Gamma> = (\<lambda>p. map_option (strip_guards F) (\<Gamma> p))"

lemma strip_simp [simp]: "(strip F \<Gamma>) p = map_option (strip_guards F) (\<Gamma> p)"
  by (simp add: strip_def)

lemma dom_strip: "dom (strip F \<Gamma>) = dom \<Gamma>"
  by (auto)

lemma strip_guards_idem: "strip_guards F (strip_guards F c) = strip_guards F c"
  by (induct c) auto

lemma strip_guards_raise [simp]:
  "strip_guards F (raise f) = raise f"
  by (simp add: raise_def)

lemma strip_guards_condCatch [simp]:
  "strip_guards F (condCatch c1 b c2) =
    condCatch (strip_guards F c1) b (strip_guards F c2)"
  by (simp add: condCatch_def)

lemma strip_guards_bind [simp]:
  "strip_guards F (bind e c) = bind e (\<lambda>v. strip_guards F (c v))"
  by (simp add: bind_def)

lemma strip_guards_bseq [simp]:
  "strip_guards F (bseq c1 c2) = bseq (strip_guards F c1) (strip_guards F c2)"
  by (simp add: bseq_def)

lemma strip_guards_block [simp]:
  "strip_guards F (block init bdy return c) =
    block init (strip_guards F bdy) return (\<lambda>s t. strip_guards F (c s t))"
  by (simp add: block_def)

lemma strip_guards_call [simp]:
  "strip_guards F (call init p return c) =
     call init p return (\<lambda>s t. strip_guards F (c s t))"
  by (simp add: call_def)

lemma strip_guards_dynCall [simp]:
  "strip_guards F (dynCall init p return c) =
     dynCall init p return (\<lambda>s t. strip_guards F (c s t))"
  by (simp add: dynCall_def)

lemma strip_guards_fcall [simp]:
  "strip_guards F (fcall init p return result c) =
     fcall init p return result (\<lambda>v. strip_guards F (c v))"
  by (simp add: fcall_def)

lemma strip_guards_switch [simp]:
  "strip_guards F (switch v Vc) =
    switch v (map (\<lambda>(V,c). (V,strip_guards F c)) Vc)"
  by (induct Vc) auto

lemma strip_guards_guaranteeStrip [simp]:
  "strip_guards F (guaranteeStrip f g c) =
    (if f \<in> F then strip_guards F c
     else guaranteeStrip f g (strip_guards F c))"
  by (simp add: guaranteeStrip_def)

lemma guaranteeStripPair_split_conv [simp]: "case_prod c (guaranteeStripPair f g) = c f g"
  by (simp add: guaranteeStripPair_def)

lemma strip_guards_guards [simp]: "strip_guards F (guards gs c) =
        guards (filter (\<lambda>(f,g). f \<notin> F) gs) (strip_guards F c)"
  by (induct gs) auto

lemma strip_guards_while [simp]:
 "strip_guards F (while gs b  c) =
     while (filter (\<lambda>(f,g). f \<notin> F) gs) b (strip_guards F c)"
  by (simp add: while_def)

lemma strip_guards_whileAnno [simp]:
 "strip_guards F (whileAnno b I V c) = whileAnno b I V (strip_guards F c)"
  by (simp add: whileAnno_def  while_def)

lemma strip_guards_specAnno [simp]:
  "strip_guards F (specAnno P c Q A) =
    specAnno P (\<lambda>s. strip_guards F (c undefined)) Q A"
  by (simp add: specAnno_def)

lemmas strip_guards_simps = strip_guards.simps strip_guards_raise
  strip_guards_condCatch strip_guards_bind strip_guards_bseq strip_guards_block
  strip_guards_dynCall strip_guards_fcall strip_guards_switch
  strip_guards_guaranteeStrip guaranteeStripPair_split_conv strip_guards_guards
  strip_guards_while strip_guards_whileAnno strip_guards_whileAnnoG
  strip_guards_specAnno

subsubsection {* Marking Guards: @{text "mark_guards"} *}

primrec mark_guards:: "'f \<Rightarrow> ('s,'p,'g) com \<Rightarrow> ('s,'p,'f) com"
where
"mark_guards f Skip = Skip" |
"mark_guards f (Basic g) = Basic g" |
"mark_guards f (Spec r) = Spec r" |
"mark_guards f (Seq c\<^sub>1 c\<^sub>2)  = (Seq (mark_guards f c\<^sub>1) (mark_guards f c\<^sub>2))" |
"mark_guards f (Cond b c\<^sub>1 c\<^sub>2) = Cond b (mark_guards f c\<^sub>1) (mark_guards f c\<^sub>2)" |
"mark_guards f (While b c) = While b (mark_guards f c)" |
"mark_guards f (Call p) = Call p" |
"mark_guards f (DynCom c) = DynCom (\<lambda>s. (mark_guards f (c s)))" |
"mark_guards f (Guard f' g c) = Guard f g (mark_guards f c)" |
"mark_guards f Throw = Throw" |
"mark_guards f (Catch c\<^sub>1 c\<^sub>2) = Catch (mark_guards f c\<^sub>1) (mark_guards f c\<^sub>2)"

lemma mark_guards_raise: "mark_guards f (raise g) = raise g"
  by (simp add: raise_def)

lemma mark_guards_condCatch [simp]:
  "mark_guards f (condCatch c1 b c2) =
    condCatch (mark_guards f c1) b (mark_guards f c2)"
  by (simp add: condCatch_def)

lemma mark_guards_bind [simp]:
  "mark_guards f (bind e c) = bind e (\<lambda>v. mark_guards f (c v))"
  by (simp add: bind_def)

lemma mark_guards_bseq [simp]:
  "mark_guards f (bseq c1 c2) = bseq (mark_guards f c1) (mark_guards f c2)"
  by (simp add: bseq_def)

lemma mark_guards_block [simp]:
  "mark_guards f (block init bdy return c) =
    block init (mark_guards f bdy) return (\<lambda>s t. mark_guards f (c s t))"
  by (simp add: block_def)

lemma mark_guards_call [simp]:
  "mark_guards f (call init p return c) =
     call init p return (\<lambda>s t. mark_guards f (c s t))"
  by (simp add: call_def)

lemma mark_guards_dynCall [simp]:
  "mark_guards f (dynCall init p return c) =
     dynCall init p return (\<lambda>s t. mark_guards f (c s t))"
  by (simp add: dynCall_def)

lemma mark_guards_fcall [simp]:
  "mark_guards f (fcall init p return result c) =
     fcall init p return result (\<lambda>v. mark_guards f (c v))"
  by (simp add: fcall_def)

lemma mark_guards_switch [simp]:
  "mark_guards f (switch v vs) =
     switch v (map (\<lambda>(V,c). (V,mark_guards f c)) vs)"
  by (induct vs) auto

lemma mark_guards_guaranteeStrip [simp]:
  "mark_guards f (guaranteeStrip f' g c) = guaranteeStrip f g (mark_guards f c)"
  by (simp add: guaranteeStrip_def)

lemma mark_guards_guards [simp]:
  "mark_guards f (guards gs c) = guards (map (\<lambda>(f',g). (f,g)) gs) (mark_guards f c)"
  by (induct gs) auto

lemma mark_guards_while [simp]:
 "mark_guards f (while gs b c) =
    while (map (\<lambda>(f',g). (f,g)) gs) b (mark_guards f c)"
  by (simp add: while_def)

lemma mark_guards_whileAnno [simp]:
 "mark_guards f (whileAnno b I V c) = whileAnno b I V (mark_guards f c)"
  by (simp add: whileAnno_def while_def)

lemma mark_guards_specAnno [simp]:
  "mark_guards f (specAnno P c Q A) =
    specAnno P (\<lambda>s. mark_guards f (c undefined)) Q A"
  by (simp add: specAnno_def)

lemmas mark_guards_simps = mark_guards.simps mark_guards_raise
  mark_guards_condCatch mark_guards_bind mark_guards_bseq mark_guards_block
  mark_guards_dynCall mark_guards_fcall mark_guards_switch
  mark_guards_guaranteeStrip guaranteeStripPair_split_conv mark_guards_guards
  mark_guards_while mark_guards_whileAnno mark_guards_whileAnnoG
  mark_guards_specAnno

definition is_Guard:: "('s,'p,'f) com \<Rightarrow> bool"
  where "is_Guard c = (case c of Guard f g c' \<Rightarrow> True | _ \<Rightarrow> False)"
lemma is_Guard_basic_simps [simp]:
 "is_Guard Skip = False"
 "is_Guard (Basic f) = False"
 "is_Guard (Spec r) = False"
 "is_Guard (Seq c1 c2) = False"
 "is_Guard (Cond b c1 c2) = False"
 "is_Guard (While b c) = False"
 "is_Guard (Call p) = False"
 "is_Guard (DynCom C) = False"
 "is_Guard (Guard F g c) = True"
 "is_Guard (Throw) = False"
 "is_Guard (Catch c1 c2) = False"
 "is_Guard (raise f) = False"
 "is_Guard (condCatch c1 b c2) = False"
 "is_Guard (bind e cv) = False"
 "is_Guard (bseq c1 c2) = False"
 "is_Guard (block init bdy return cont) = False"
 "is_Guard (call init p return cont) = False"
 "is_Guard (dynCall init P return cont) = False"
 "is_Guard (fcall init p return result cont') = False"
 "is_Guard (whileAnno b I V c) = False"
 "is_Guard (guaranteeStrip F g c) = True"
  by (auto simp add: is_Guard_def raise_def condCatch_def bind_def bseq_def
          block_def call_def dynCall_def fcall_def whileAnno_def guaranteeStrip_def)

lemma is_Guard_switch [simp]:
 "is_Guard (switch v Vc) = False"
  by (induct Vc) auto

lemmas is_Guard_simps = is_Guard_basic_simps is_Guard_switch

primrec dest_Guard:: "('s,'p,'f) com \<Rightarrow> ('f \<times> 's set \<times> ('s,'p,'f) com)"
  where "dest_Guard (Guard f g c) = (f,g,c)"

lemma dest_Guard_guaranteeStrip [simp]: "dest_Guard (guaranteeStrip f g c) = (f,g,c)"
  by (simp add: guaranteeStrip_def)

lemmas dest_Guard_simps = dest_Guard.simps dest_Guard_guaranteeStrip

subsubsection {* Merging Guards: @{text merge_guards}*}

primrec merge_guards:: "('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com"
where
"merge_guards Skip = Skip" |
"merge_guards (Basic g) = Basic g" |
"merge_guards (Spec r) = Spec r" |
"merge_guards (Seq c\<^sub>1 c\<^sub>2)  = (Seq (merge_guards c\<^sub>1) (merge_guards c\<^sub>2))" |
"merge_guards (Cond b c\<^sub>1 c\<^sub>2) = Cond b (merge_guards c\<^sub>1) (merge_guards c\<^sub>2)" |
"merge_guards (While b c) = While b (merge_guards c)" |
"merge_guards (Call p) = Call p" |
"merge_guards (DynCom c) = DynCom (\<lambda>s. (merge_guards (c s)))" |
(*"merge_guards (Guard f g c) =
    (case (merge_guards c) of
      Guard f' g' c' \<Rightarrow> if f=f' then Guard f (g \<inter> g') c'
                        else Guard f g (Guard f' g' c')
     | _ \<Rightarrow>  Guard f g (merge_guards c))"*)
(* the following version works better with derived language constructs *)
"merge_guards (Guard f g c) =
    (let c' = (merge_guards c)
     in if is_Guard c'
        then let (f',g',c'') = dest_Guard c'
             in if f=f' then Guard f (g \<inter> g') c''
                        else Guard f g (Guard f' g' c'')
        else Guard f g c')" |
"merge_guards Throw = Throw" |
"merge_guards (Catch c\<^sub>1 c\<^sub>2) = Catch (merge_guards c\<^sub>1) (merge_guards c\<^sub>2)"

lemma merge_guards_res_Skip: "merge_guards c = Skip \<Longrightarrow> c = Skip"
  by (cases c) (auto split: com.splits if_split_asm simp add: is_Guard_def Let_def)

lemma merge_guards_res_Basic: "merge_guards c = Basic f \<Longrightarrow> c = Basic f"
  by (cases c) (auto split: com.splits if_split_asm simp add: is_Guard_def Let_def)

lemma merge_guards_res_Spec: "merge_guards c = Spec r \<Longrightarrow> c = Spec r"
  by (cases c) (auto split: com.splits if_split_asm simp add: is_Guard_def Let_def)

lemma merge_guards_res_Seq: "merge_guards c = Seq c1 c2 \<Longrightarrow>
    \<exists>c1' c2'. c = Seq c1' c2' \<and> merge_guards c1' = c1 \<and> merge_guards c2' = c2"
  by (cases c) (auto split: com.splits if_split_asm simp add: is_Guard_def Let_def)

lemma merge_guards_res_Cond: "merge_guards c = Cond b c1 c2 \<Longrightarrow>
    \<exists>c1' c2'. c = Cond b c1' c2' \<and> merge_guards c1' = c1 \<and> merge_guards c2' = c2"
  by (cases c) (auto split: com.splits if_split_asm simp add: is_Guard_def Let_def)

lemma merge_guards_res_While: "merge_guards c = While b c' \<Longrightarrow>
    \<exists>c''. c = While b c''  \<and> merge_guards c'' = c'"
  by (cases c) (auto split: com.splits if_split_asm simp add: is_Guard_def Let_def)

lemma merge_guards_res_Call: "merge_guards c = Call p \<Longrightarrow> c = Call p"
  by (cases c) (auto split: com.splits if_split_asm simp add: is_Guard_def Let_def)

lemma merge_guards_res_DynCom: "merge_guards c = DynCom c' \<Longrightarrow>
    \<exists>c''. c = DynCom c''  \<and> (\<lambda>s. (merge_guards (c'' s))) = c'"
  by (cases c) (auto split: com.splits if_split_asm simp add: is_Guard_def Let_def)

lemma merge_guards_res_Throw: "merge_guards c = Throw \<Longrightarrow> c = Throw"
  by (cases c) (auto split: com.splits if_split_asm simp add: is_Guard_def Let_def)

lemma merge_guards_res_Catch: "merge_guards c = Catch c1 c2 \<Longrightarrow>
    \<exists>c1' c2'. c = Catch c1' c2' \<and> merge_guards c1' = c1 \<and> merge_guards c2' = c2"
  by (cases c) (auto split: com.splits if_split_asm simp add: is_Guard_def Let_def)

lemma merge_guards_res_Guard:
 "merge_guards c = Guard f g c' \<Longrightarrow> \<exists>c'' f' g'. c = Guard f' g' c''"
  by (cases c) (auto split: com.splits if_split_asm simp add: is_Guard_def Let_def)

lemmas merge_guards_res_simps = merge_guards_res_Skip merge_guards_res_Basic
 merge_guards_res_Spec merge_guards_res_Seq merge_guards_res_Cond
 merge_guards_res_While merge_guards_res_Call
 merge_guards_res_DynCom merge_guards_res_Throw merge_guards_res_Catch
 merge_guards_res_Guard

lemma merge_guards_raise: "merge_guards (raise g) = raise g"
  by (simp add: raise_def)

lemma merge_guards_condCatch [simp]:
  "merge_guards (condCatch c1 b c2) =
    condCatch (merge_guards c1) b (merge_guards c2)"
  by (simp add: condCatch_def)

lemma merge_guards_bind [simp]:
  "merge_guards (bind e c) = bind e (\<lambda>v. merge_guards (c v))"
  by (simp add: bind_def)

lemma merge_guards_bseq [simp]:
  "merge_guards (bseq c1 c2) = bseq (merge_guards c1) (merge_guards c2)"
  by (simp add: bseq_def)

lemma merge_guards_block [simp]:
  "merge_guards (block init bdy return c) =
    block init (merge_guards bdy) return (\<lambda>s t. merge_guards (c s t))"
  by (simp add: block_def)

lemma merge_guards_call [simp]:
  "merge_guards (call init p return c) =
     call init p return (\<lambda>s t. merge_guards (c s t))"
  by (simp add: call_def)

lemma merge_guards_dynCall [simp]:
  "merge_guards (dynCall init p return c) =
     dynCall init p return (\<lambda>s t. merge_guards (c s t))"
  by (simp add: dynCall_def)

lemma merge_guards_fcall [simp]:
  "merge_guards (fcall init p return result c) =
     fcall init p return result (\<lambda>v. merge_guards (c v))"
  by (simp add: fcall_def)

lemma merge_guards_switch [simp]:
  "merge_guards (switch v vs) =
     switch v (map (\<lambda>(V,c). (V,merge_guards c)) vs)"
  by (induct vs) auto

lemma merge_guards_guaranteeStrip [simp]:
  "merge_guards (guaranteeStrip f g c) =
    (let c' = (merge_guards c)
     in if is_Guard c'
        then let (f',g',c') = dest_Guard c'
             in if f=f' then Guard f (g \<inter> g') c'
                        else Guard f g (Guard f' g' c')
        else Guard f g c')"
  by (simp add: guaranteeStrip_def)

lemma merge_guards_whileAnno [simp]:
 "merge_guards (whileAnno b I V c) = whileAnno b I V (merge_guards c)"
  by (simp add: whileAnno_def while_def)

lemma merge_guards_specAnno [simp]:
  "merge_guards (specAnno P c Q A) =
    specAnno P (\<lambda>s. merge_guards (c undefined)) Q A"
  by (simp add: specAnno_def)

text {* @{term "merge_guards"} for guard-lists as in @{const guards}, @{const while}
 and @{const whileAnnoG} may have funny effects since the guard-list has to
 be merged with the body statement too.*}

lemmas merge_guards_simps = merge_guards.simps merge_guards_raise
  merge_guards_condCatch merge_guards_bind merge_guards_bseq merge_guards_block
  merge_guards_dynCall merge_guards_fcall merge_guards_switch
  merge_guards_guaranteeStrip merge_guards_whileAnno merge_guards_specAnno

primrec noguards:: "('s,'p,'f) com \<Rightarrow> bool"
where
"noguards Skip = True" |
"noguards (Basic f) = True" |
"noguards (Spec r ) = True" |
"noguards (Seq c\<^sub>1 c\<^sub>2)  = (noguards c\<^sub>1 \<and> noguards c\<^sub>2)" |
"noguards (Cond b c\<^sub>1 c\<^sub>2) = (noguards c\<^sub>1 \<and> noguards c\<^sub>2)" |
"noguards (While b c) = (noguards c)" |
"noguards (Call p) = True" |
"noguards (DynCom c) = (\<forall>s. noguards (c s))" |
"noguards (Guard f g c) = False" |
"noguards Throw = True" |
"noguards (Catch c\<^sub>1 c\<^sub>2) = (noguards c\<^sub>1 \<and> noguards c\<^sub>2)"

lemma noguards_strip_guards: "noguards (strip_guards UNIV c)"
  by (induct c) auto

primrec nothrows:: "('s,'p,'f) com \<Rightarrow> bool"
where
"nothrows Skip = True" |
"nothrows (Basic f) = True" |
"nothrows (Spec r) = True" |
"nothrows (Seq c\<^sub>1 c\<^sub>2)  = (nothrows c\<^sub>1 \<and> nothrows c\<^sub>2)" |
"nothrows (Cond b c\<^sub>1 c\<^sub>2) = (nothrows c\<^sub>1 \<and> nothrows c\<^sub>2)" |
"nothrows (While b c) = nothrows c" |
"nothrows (Call p) = True" |
"nothrows (DynCom c) = (\<forall>s. nothrows (c s))" |
"nothrows (Guard f g c) = nothrows c" |
"nothrows Throw = False" |
"nothrows (Catch c\<^sub>1 c\<^sub>2) = (nothrows c\<^sub>1 \<and> nothrows c\<^sub>2)"

subsubsection {* Intersecting Guards: @{text "c\<^sub>1 \<inter>\<^sub>g c\<^sub>2"}*}

inductive_set com_rel ::"(('s,'p,'f) com \<times> ('s,'p,'f) com) set"
where
  "(c1, Seq c1 c2) \<in> com_rel"
| "(c2, Seq c1 c2) \<in> com_rel"
| "(c1, Cond b c1 c2) \<in> com_rel"
| "(c2, Cond b c1 c2) \<in> com_rel"
| "(c, While b c) \<in> com_rel"
| "(c x, DynCom c) \<in> com_rel"
| "(c, Guard f g c) \<in> com_rel"
| "(c1, Catch c1 c2) \<in> com_rel"
| "(c2, Catch c1 c2) \<in> com_rel"

inductive_cases com_rel_elim_cases:
 "(c, Skip) \<in> com_rel"
 "(c, Basic f) \<in> com_rel"
 "(c, Spec r) \<in> com_rel"
 "(c, Seq c1 c2) \<in> com_rel"
 "(c, Cond b c1 c2) \<in> com_rel"
 "(c, While b c1) \<in> com_rel"
 "(c, Call p) \<in> com_rel"
 "(c, DynCom c1) \<in> com_rel"
 "(c, Guard f g c1) \<in> com_rel"
 "(c, Throw) \<in> com_rel"
 "(c, Catch c1 c2) \<in> com_rel"

consts inter_guards:: "('s,'p,'f) com \<times> ('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com option"

abbreviation
  inter_guards_syntax :: "('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com option"
           ("_ \<inter>\<^sub>g _" [20,20] 19)
  where "c \<inter>\<^sub>g d == inter_guards (c,d)"

recdef inter_guards "inv_image com_rel fst"
"(Skip \<inter>\<^sub>g Skip) = Some Skip"

"(Basic f1 \<inter>\<^sub>g Basic f2) = (if (f1=f2) then Some (Basic f1) else None)"
"(Spec r1 \<inter>\<^sub>g Spec r2) = (if (r1=r2) then Some (Spec r1) else None)"
"(Seq a1 a2 \<inter>\<^sub>g Seq b1 b2) =
   (case (a1 \<inter>\<^sub>g b1) of
      None \<Rightarrow> None
    | Some c1 \<Rightarrow> (case (a2 \<inter>\<^sub>g b2) of
                    None \<Rightarrow> None
                  | Some c2 \<Rightarrow> Some (Seq c1 c2)))"

"(Cond cnd1 t1 e1 \<inter>\<^sub>g Cond cnd2 t2 e2) =
   (if (cnd1=cnd2)
    then (case (t1 \<inter>\<^sub>g t2) of
            None \<Rightarrow> None
          | Some t \<Rightarrow> (case (e1 \<inter>\<^sub>g e2) of
                         None \<Rightarrow> None
                       | Some e \<Rightarrow> Some (Cond cnd1 t e)))
    else None)"

"(While cnd1 c1 \<inter>\<^sub>g While cnd2 c2) =
    (if (cnd1=cnd2 )
     then (case (c1 \<inter>\<^sub>g c2) of
             None \<Rightarrow> None
           | Some c \<Rightarrow> Some (While cnd1 c))
     else None)"

"(Call p1 \<inter>\<^sub>g Call p2) =
   (if p1 = p2
    then Some (Call p1)
    else None)"

"(DynCom P1 \<inter>\<^sub>g DynCom P2) =
   (if (\<forall>s. ((P1 s) \<inter>\<^sub>g (P2 s)) \<noteq> None)
   then Some (DynCom (\<lambda>s.  the ((P1 s) \<inter>\<^sub>g (P2 s))))
   else None)"

"(Guard m1 g1 c1 \<inter>\<^sub>g Guard m2 g2 c2) =
   (if m1=m2 then
       (case (c1 \<inter>\<^sub>g c2) of
          None \<Rightarrow> None
        | Some c \<Rightarrow> Some (Guard m1 (g1 \<inter> g2) c))
    else None)"

"(Throw \<inter>\<^sub>g Throw) = Some Throw"
"(Catch a1 a2 \<inter>\<^sub>g Catch b1 b2) =
   (case (a1 \<inter>\<^sub>g b1) of
      None \<Rightarrow> None
    | Some c1 \<Rightarrow> (case (a2 \<inter>\<^sub>g b2) of
                    None \<Rightarrow> None
                  | Some c2 \<Rightarrow> Some (Catch c1 c2)))"
"(c \<inter>\<^sub>g d) = None"

(hints cong add: option.case_cong if_cong
       recdef_wf: wf_com_rel simp: com_rel.intros)

lemma inter_guards_sym: "\<And>c. (c1 \<inter>\<^sub>g c2) = Some c \<Longrightarrow> (c2 \<inter>\<^sub>g c1) = Some c"
apply (induct c1 c2 rule: inter_guards.induct)
apply (simp_all)
prefer 7
apply (simp split: if_split_asm add: not_None_eq)
apply (rule conjI)
apply  (clarsimp)
apply  (rule ext)
apply  (erule_tac x=s in allE)+
apply  fastforce
apply fastforce
apply (fastforce split: option.splits if_split_asm)+
done

lemma inter_guards_Skip: "(Skip \<inter>\<^sub>g c2) = Some c = (c2=Skip \<and> c=Skip)"
  by (cases c2) auto

lemma inter_guards_Basic:
  "((Basic f) \<inter>\<^sub>g c2) = Some c = (c2=Basic f \<and> c=Basic f)"
  by (cases c2) auto

lemma inter_guards_Spec:
  "((Spec r) \<inter>\<^sub>g c2) = Some c = (c2=Spec r \<and> c=Spec r)"
  by (cases c2) auto

lemma inter_guards_Cond:
  "(Cond cnd t1 e1 \<inter>\<^sub>g c2) = Some c =
     (\<exists>t2 e2 t e. c2=Cond cnd t2 e2 \<and> (t1 \<inter>\<^sub>g t2) = Some t \<and>
        (e1 \<inter>\<^sub>g e2) = Some e \<and> c=Cond cnd t e)"
  by (cases c2) (auto split: option.splits)

lemma inter_guards_While:
 "(While cnd bdy1 \<inter>\<^sub>g c2) = Some c =
     (\<exists>bdy2 bdy. c2 =While cnd bdy2 \<and> (bdy1 \<inter>\<^sub>g bdy2) = Some bdy \<and>
       c=While cnd bdy)"
  by (cases c2) (auto split: option.splits if_split_asm)

lemma inter_guards_Call:
  "(Call p \<inter>\<^sub>g c2) = Some c =
     (c2=Call p \<and> c=Call p)"
  by (cases c2) (auto split: if_split_asm)

lemma inter_guards_DynCom:
  "(DynCom f1 \<inter>\<^sub>g c2) = Some c =
     (\<exists>f2. c2=DynCom f2 \<and> (\<forall>s. ((f1 s) \<inter>\<^sub>g (f2 s)) \<noteq> None) \<and>
      c=DynCom (\<lambda>s. the ((f1 s) \<inter>\<^sub>g (f2 s))))"
  by (cases c2) (auto split: if_split_asm)

lemma inter_guards_Guard:
  "(Guard f g1 bdy1 \<inter>\<^sub>g c2) = Some c =
     (\<exists>g2 bdy2 bdy. c2=Guard f g2 bdy2 \<and> (bdy1 \<inter>\<^sub>g bdy2) = Some bdy \<and>
       c=Guard f (g1 \<inter> g2) bdy)"
  by (cases c2) (auto split: option.splits)

lemma inter_guards_Throw:
  "(Throw \<inter>\<^sub>g c2) = Some c = (c2=Throw \<and> c=Throw)"
  by (cases c2) auto

lemma inter_guards_Catch:
  "(Catch a1 a2 \<inter>\<^sub>g c2) = Some c =
     (\<exists>b1 b2 d1 d2. c2=Catch b1 b2 \<and> (a1 \<inter>\<^sub>g b1) = Some d1 \<and>
        (a2 \<inter>\<^sub>g b2) = Some d2 \<and> c=Catch d1 d2)"
  by (cases c2) (auto split: option.splits)

lemmas inter_guards_simps = inter_guards_Skip inter_guards_Basic inter_guards_Spec
  inter_guards_Seq inter_guards_Cond inter_guards_While inter_guards_Call
  inter_guards_DynCom inter_guards_Guard inter_guards_Throw
  inter_guards_Catch

subsubsection {* Subset on Guards: @{text "c\<^sub>1 \<subseteq>\<^sub>g c\<^sub>2"} *}

consts subseteq_guards:: "('s,'p,'f) com \<times> ('s,'p,'f) com \<Rightarrow> bool"

abbreviation
  subseteq_guards_syntax :: "('s,'p,'f) com \<Rightarrow> ('s,'p,'f) com \<Rightarrow> bool"
           ("_ \<subseteq>\<^sub>g _" [20,20] 19)
  where "c \<subseteq>\<^sub>g d == subseteq_guards (c,d)"

recdef subseteq_guards "inv_image com_rel snd"
"(Skip \<subseteq>\<^sub>g Skip) = True"
"(Basic f1 \<subseteq>\<^sub>g Basic f2) = (f1=f2)"
"(Spec r1 \<subseteq>\<^sub>g Spec r2) = (r1=r2)"
"(Seq a1 a2 \<subseteq>\<^sub>g Seq b1 b2) = ((a1 \<subseteq>\<^sub>g b1) \<and> (a2 \<subseteq>\<^sub>g b2))"
"(Cond cnd1 t1 e1 \<subseteq>\<^sub>g Cond cnd2 t2 e2) = ((cnd1=cnd2) \<and> (t1 \<subseteq>\<^sub>g t2) \<and> (e1 \<subseteq>\<^sub>g e2))"
"(While cnd1 c1 \<subseteq>\<^sub>g While cnd2 c2) = ((cnd1=cnd2) \<and> (c1 \<subseteq>\<^sub>g c2))"
"(Call p1 \<subseteq>\<^sub>g Call p2) = (p1 = p2)"
"(DynCom P1 \<subseteq>\<^sub>g DynCom P2) = (\<forall>s. ((P1 s) \<subseteq>\<^sub>g (P2 s)))"
"(Guard m1 g1 c1 \<subseteq>\<^sub>g Guard m2 g2 c2) =
    ((m1=m2 \<and> g1=g2 \<and> (c1 \<subseteq>\<^sub>g c2)) \<or> (Guard m1 g1 c1 \<subseteq>\<^sub>g c2))"
"(c1 \<subseteq>\<^sub>g Guard m2 g2 c2) = (c1 \<subseteq>\<^sub>g c2)"

"(Throw \<subseteq>\<^sub>g Throw) = True"
"(Catch a1 a2 \<subseteq>\<^sub>g Catch b1 b2) = ((a1 \<subseteq>\<^sub>g b1) \<and> (a2 \<subseteq>\<^sub>g b2))"
"(c \<subseteq>\<^sub>g d) = False"

(hints cong add: if_cong
       recdef_wf: wf_com_rel simp: com_rel.intros)

lemma subseteq_guards_Skip:
 "c \<subseteq>\<^sub>g Skip \<Longrightarrow> c = Skip"
  by (cases c) (auto)

lemma subseteq_guards_Basic:
 "c \<subseteq>\<^sub>g Basic f \<Longrightarrow> c = Basic f"
  by (cases c) (auto)

lemma subseteq_guards_Spec:
 "c \<subseteq>\<^sub>g Spec r \<Longrightarrow> c = Spec r"
  by (cases c) (auto)

lemma subseteq_guards_Seq:
  "c \<subseteq>\<^sub>g Seq c1 c2 \<Longrightarrow> \<exists>c1' c2'. c=Seq c1' c2' \<and> (c1' \<subseteq>\<^sub>g c1) \<and> (c2' \<subseteq>\<^sub>g c2)"
  by (cases c) (auto)

lemma subseteq_guards_Cond:
  "c \<subseteq>\<^sub>g Cond b c1 c2 \<Longrightarrow> \<exists>c1' c2'. c=Cond b c1' c2' \<and> (c1' \<subseteq>\<^sub>g c1) \<and> (c2' \<subseteq>\<^sub>g c2)"
  by (cases c) (auto)

lemma subseteq_guards_While:
  "c \<subseteq>\<^sub>g While b c' \<Longrightarrow> \<exists>c''. c=While b c'' \<and> (c'' \<subseteq>\<^sub>g c')"
  by (cases c) (auto)

lemma subseteq_guards_Call:
 "c \<subseteq>\<^sub>g Call p \<Longrightarrow> c = Call p"
  by (cases c) (auto)

lemma subseteq_guards_DynCom:
  "c \<subseteq>\<^sub>g DynCom C \<Longrightarrow> \<exists>C'. c=DynCom C' \<and> (\<forall>s. C' s \<subseteq>\<^sub>g C s)"
  by (cases c) (auto)

lemma subseteq_guards_Guard:
  "c \<subseteq>\<^sub>g Guard f g c'  \<Longrightarrow>
     (c \<subseteq>\<^sub>g c') \<or> (\<exists>c''. c=Guard f g c'' \<and> (c'' \<subseteq>\<^sub>g c'))"
  by (cases c) (auto split: if_split_asm)

lemma subseteq_guards_Throw:
 "c \<subseteq>\<^sub>g Throw \<Longrightarrow> c = Throw"
  by (cases c) (auto)

lemma subseteq_guards_Catch:
  "c \<subseteq>\<^sub>g Catch c1 c2 \<Longrightarrow> \<exists>c1' c2'. c=Catch c1' c2' \<and> (c1' \<subseteq>\<^sub>g c1) \<and> (c2' \<subseteq>\<^sub>g c2)"
  by (cases c) (auto)

lemmas subseteq_guardsD = subseteq_guards_Skip subseteq_guards_Basic
 subseteq_guards_Spec subseteq_guards_Seq subseteq_guards_Cond subseteq_guards_While
 subseteq_guards_Call subseteq_guards_DynCom subseteq_guards_Guard
 subseteq_guards_Throw subseteq_guards_Catch

lemma subseteq_guards_Guard':
  "Guard f b c \<subseteq>\<^sub>g d \<Longrightarrow> \<exists>f' b' c'. d=Guard f' b' c'"
apply (cases d)
apply auto
done

lemma subseteq_guards_refl: "c \<subseteq>\<^sub>g c"
  by (induct c) auto

(* Antisymmetry and transitivity should hold as well\<dots> *)

end


theory Toggle
  imports Lifter
begin
(*
idea: based on the syntax, we can decide to do a no-op
otherwise we have to obey normal lifting rules.
*)

definition LtUpd ::
  "('syn, 'a, 'b) lifting \<Rightarrow>
   ('syn \<Rightarrow> bool) \<Rightarrow>
   'syn \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b" where
"LtUpd l tg syn a b =
  (if tg syn then LUpd l syn a b
   else b)"

definition LtMap ::
  "('syn, 'a, 'b) lifting \<Rightarrow>
   ('syn \<Rightarrow> bool) \<Rightarrow>
   ('syn \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow>
   'syn \<Rightarrow> 'b \<Rightarrow> 'b"
  where
"LtMap l tg f syn x =
  (if tg syn then LMap l f syn x
   else x)"

(* a variant of lift_map_s that syntax-translates the semantics but not the toggle
 *)

(* a variant that translates both the semantics and the toggle
 * (possibly more useful for multiple stages of language composition)
 *)

definition
  lift_map_t_s ::
  "('b1 \<Rightarrow> 'a1) \<Rightarrow>
   ('a1, 'a2, 'b2::Pord) lifting \<Rightarrow>
   ('b1 \<Rightarrow> bool) \<Rightarrow>
   ('a1 \<Rightarrow> 'a2 \<Rightarrow> 'a2) \<Rightarrow>
   'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b2" where
"lift_map_t_s l' l tg f syn st =
  (if tg syn then lift_map_s l' l f syn st
   else st)"

definition
  lift_map_st_s ::
  "('b1 \<Rightarrow> 'a1) \<Rightarrow>
   ('a1, 'a2, 'b2::Pord) lifting \<Rightarrow>
   ('a1 \<Rightarrow> bool) \<Rightarrow>
   ('a1 \<Rightarrow> 'a2 \<Rightarrow> 'a2) \<Rightarrow>
   'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b2" where
"lift_map_st_s l' l tg f syn st =
  (if tg (l' syn) then lift_map_s l' l f syn st
   else st)"

(* old definition, harder to use in theorems because of the need to
 * reuse syntax parameter in toggle-predicate and then again in function*)
definition toggle ::
  "('syn \<Rightarrow> bool) \<Rightarrow>
   ('syn \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow>
   ('syn \<Rightarrow> 'b \<Rightarrow> 'b)" where
"toggle tg f syn st =
  (if (tg syn) then f syn st else st)"

(*
definition toggle ::
  "'syn \<Rightarrow>
   ('syn \<Rightarrow> bool) \<Rightarrow>
   ('syn \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow>
   ('b \<Rightarrow> 'b)" where
"toggle syn tg f st =
  (if (tg syn) then f syn st else st)"
*)

lemma lift_map_t_s_toggle :
  "lift_map_t_s l' l tg f =
   toggle tg (lift_map_s l' l f)"
  unfolding lift_map_t_s_def toggle_def
  by(auto)

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

(*
 * This file contains theorems for dealing with a "simply" lifted
 * heap, where each byte of memory can be accessed as one (and only)
 * type.
 *
 * This is a simpler model of Tuch's "lift_t" model, where nested
 * struct fields cannot be directly accessed as pointers.
 *)

theory TypHeapSimple
imports
  "../lib/TypHeapLib"
begin

(*
 * Each address in the heap can contain one of three things:
 *
 *   - A type tag, which inidicates that this address is the first
 *     byte of an object;
 *
 *   - A footprint, which indicates that this address is a latter byte
 *     of an object;
 *
 *   - Nothing, which indicates that this address does not fall inside
 *     an object.
 *)
datatype heap_typ_contents =
    HeapType typ_uinfo
  | HeapFootprint
  | HeapEmpty

(*
 * Given a Tuch-style heap representation (where each memory location
 * contains a set of different types, representing nested field types)
 * calculate a single top-level type of the heap.
 *
 * We just want to commit to a single type for this heap location,
 * and nothing more.
 *)
definition
  heap_type_tag :: "heap_typ_desc \<Rightarrow> word32 \<Rightarrow> heap_typ_contents"
where
  "heap_type_tag d a \<equiv>
     (if fst (d a) = False \<or> (\<forall>x. (snd (d a)) x = None) \<or> (\<forall>x. (snd (d a)) x \<noteq> None) then
       HeapEmpty
     else
       case (snd (d a)) (GREATEST x. snd (d a) x \<noteq> None) of
         Some (_, False) \<Rightarrow> HeapFootprint
       | Some (x, True) \<Rightarrow> HeapType x
       | None \<Rightarrow> HeapEmpty)"

(*
 * Determine if the heap has a valid footprint for the given type at
 * the given address.
 *
 * A valid footprint means that the user has committed that the given
 * memory location will only be used for the given type.
 *
 * A "simple" footprint differs from the Tuch-style because we only
 * commit to a single type, and have no support for accessing nested
 * structures.
 *)
definition
  valid_simple_footprint :: "heap_typ_desc \<Rightarrow> word32 \<Rightarrow> typ_uinfo \<Rightarrow> bool"
where
  "valid_simple_footprint d x t \<equiv>
    heap_type_tag d x = HeapType t \<and>
      (\<forall>y. y \<in> {x + 1..+  (size_td t)- Suc 0} \<longrightarrow> heap_type_tag d y = HeapFootprint)"

lemma valid_simple_footprintI:
  "\<lbrakk> heap_type_tag d x = HeapType t; \<And>y. y \<in> {x + 1..+(size_td t) - Suc 0} \<Longrightarrow> heap_type_tag d y = HeapFootprint \<rbrakk>
      \<Longrightarrow> valid_simple_footprint d x t"
  by (clarsimp simp: valid_simple_footprint_def)

lemma valid_simple_footprintD:
  "valid_simple_footprint d x t \<Longrightarrow> heap_type_tag d x = HeapType t"
  by (simp add: valid_simple_footprint_def)

lemma valid_simple_footprintD2:
  "\<lbrakk> valid_simple_footprint d x t; y \<in> {x + 1..+(size_td t) - Suc 0} \<rbrakk> \<Longrightarrow> heap_type_tag d y = HeapFootprint"
  by (simp add: valid_simple_footprint_def)

lemma typ_slices_not_empty [simp]:
    "typ_slices (x::('a::{mem_type} itself)) \<noteq> []"
  apply (clarsimp simp: typ_slices_def)
  done

lemma last_typ_slice_t [simp]:
    "(last (typ_slice_t t 0)) = (t, True)"
  apply (case_tac t)
  apply clarsimp
  done

lemma if_eqI:
 "\<lbrakk> a \<Longrightarrow> x = z; \<not> a \<Longrightarrow> y = z \<rbrakk> \<Longrightarrow> (if a then x else y) = z"
  by simp

lemma heap_type_tag_ptr_retyp:
    "snd (s (ptr_val t)) = empty \<Longrightarrow>
        heap_type_tag (ptr_retyp (t :: 'a::mem_type ptr) s) (ptr_val t) = HeapType (typ_uinfo_t TYPE('a))"
  apply (unfold ptr_retyp_def heap_type_tag_def)
  apply (subst htd_update_list_index, fastforce, fastforce)+
  apply (rule if_eqI)
   apply clarsimp
   apply (erule disjE)
    apply (erule_tac x=0 in allE)
    apply clarsimp
   apply (erule_tac x="length (typ_slice_t (typ_uinfo_t TYPE('a)) 0)" in allE)
   apply (clarsimp simp: list_map_eq)
  apply (clarsimp simp: list_map_eq last_conv_nth [simplified, symmetric]
            split: option.splits split_if_asm prod.splits)
  done

lemma not_snd_last_typ_slice_t:
    "k \<noteq> 0 \<Longrightarrow> \<not> snd (last (typ_slice_t z k))"
  by (case_tac z, clarsimp)

lemma heap_type_tag_ptr_retyp_rest:
    "\<lbrakk> snd (s (ptr_val t + k)) = empty; 0 < k; unat k < size_td (typ_uinfo_t TYPE('a)) \<rbrakk> \<Longrightarrow>
        heap_type_tag (ptr_retyp (t :: 'a::mem_type ptr) s) (ptr_val t + k) = HeapFootprint"
  apply (unfold ptr_retyp_def heap_type_tag_def)
  apply (subst htd_update_list_index, simp, clarsimp,
      metis intvlI size_of_def word_unat.Rep_inverse)+
  apply (rule if_eqI)
   apply clarsimp
   apply (erule disjE)
    apply (erule_tac x=0 in allE)
    apply (clarsimp simp: typ_slices_index size_of_def)
   apply (erule_tac x="length (typ_slice_t (typ_uinfo_t TYPE('a)) (unat k))" in allE)
   apply (clarsimp simp: typ_slices_index size_of_def list_map_eq)
  apply (clarsimp simp: list_map_eq last_conv_nth [simplified, symmetric] size_of_def
      split: option.splits split_if_asm prod.splits bool.splits)
   apply (metis surj_pair)
  apply (subst (asm) (2) surjective_pairing)
  apply (subst (asm) not_snd_last_typ_slice_t)
   apply clarsimp
   apply unat_arith
  apply simp
  done

lemma typ_slices_addr_card [simp]:
    "length (typ_slices (x::('a::{mem_type} itself))) < addr_card"
  apply (clarsimp simp: typ_slices_def)
  done

lemma htd_update_list_same':
  "\<lbrakk>0 < unat k; unat k \<le> addr_card - length v\<rbrakk> \<Longrightarrow> htd_update_list (p + k) v h p = h p"
  apply (insert htd_update_list_same [where v=v and p=p and h=h and k="unat k"])
  apply clarsimp
  done

lemma unat_less_impl_less:
    "unat a < unat b \<Longrightarrow> a < b"
  by unat_arith

lemma valid_simple_footprint_ptr_retyp:
    "\<lbrakk> \<forall>k < size_td (typ_uinfo_t TYPE('a)). snd (s (ptr_val t + of_nat k)) = Map.empty;
        1 \<le> size_td (typ_uinfo_t TYPE('a));
        size_td (typ_uinfo_t TYPE('a)) < addr_card \<rbrakk>
        \<Longrightarrow> valid_simple_footprint (ptr_retyp (t :: 'a::mem_type ptr) s) (ptr_val t) (typ_uinfo_t TYPE('a))"
  apply (clarsimp simp: valid_simple_footprint_def)
  apply (rule conjI)
   apply (subst heap_type_tag_ptr_retyp)
    apply (erule allE [where x="0"])
    apply clarsimp
   apply clarsimp
  apply (clarsimp simp: intvl_def)
  apply (erule_tac x="k + 1" in allE)
  apply (erule impE)
   apply (metis One_nat_def less_diff_conv size_of_def)
  apply (subst add.assoc, subst heap_type_tag_ptr_retyp_rest)
     apply clarsimp
    apply (case_tac "1 + of_nat k = (0 :: word32)")
     apply (metis Suc_le_D diff_Suc_1 less_imp_diff_less less_trans_Suc nat_less_le one_plus_x_zero)
    apply unat_arith
   apply clarsimp
   apply (metis (hide_lams, no_types) One_nat_def Suc_eq_plus1 le_eq_less_or_eq
     le_unat_uoi less_Suc_eq_le less_diff_conv not_less_eq of_nat_Suc)
  apply simp
  done

(* Determine if the given pointer is valid in the given heap. *)
definition
  heap_ptr_valid :: "heap_typ_desc \<Rightarrow> 'a::c_type ptr \<Rightarrow> bool"
where
  "heap_ptr_valid d p \<equiv>
      valid_simple_footprint d (ptr_val (p::'a ptr)) (typ_uinfo_t TYPE('a))
        \<and> c_guard p"

(*
 * Lift a heap from raw bytes and a heap description into
 * higher-level objects.
 *
 * This differs from Tuch's "lift_t" because we only support
 * simple lifting; that is, each byte in the heap may only
 * be accessed as a single type. Accessing struct fields by
 * their pointers is not supported.
 *)
definition
  simple_lift :: "heap_raw_state \<Rightarrow> ('a::c_type) ptr \<Rightarrow> 'a option"
where
  "simple_lift s p = (
     if (heap_ptr_valid (hrs_htd s) p) then
       (Some (h_val (hrs_mem s) p))
     else
       None)"

lemma simple_lift_heap_ptr_valid:
  "simple_lift s p = Some x \<Longrightarrow> heap_ptr_valid (hrs_htd s) p"
  apply (clarsimp simp: simple_lift_def split: split_if_asm)
  done

lemma simple_lift_c_guard:
  "simple_lift s p = Some x \<Longrightarrow> c_guard p"
  apply (clarsimp simp: simple_lift_def heap_ptr_valid_def split: split_if_asm)
  done

(* Two valid footprints will either overlap completely or not at all. *)
lemma valid_simple_footprint_neq:
  assumes valid_p: "valid_simple_footprint d p s"
      and valid_q: "valid_simple_footprint d q t"
      and neq: "p \<noteq> q"
  shows "p \<notin> {q..+ (size_td t)}"
proof -
  have heap_type_p: "heap_type_tag d p = HeapType s"
    apply (metis valid_p valid_simple_footprint_def)
    done

  have heap_type_q: "heap_type_tag d q = HeapType t"
    apply (metis valid_q valid_simple_footprint_def)
    done

  have heap_type_q_footprint:
    "\<And>x. x \<in> {(q + 1)..+(size_td t - Suc 0)} \<Longrightarrow> heap_type_tag d x = HeapFootprint"
    apply (insert valid_q)
    apply (simp add: valid_simple_footprint_def)
    done

  show ?thesis
    using heap_type_q_footprint heap_type_p neq
         intvl_neq_start heap_type_q
    by (metis heap_typ_contents.simps(2))
qed

(* Two valid footprints with different types will never overlap. *)
lemma valid_simple_footprint_type_neq:
  "\<lbrakk> valid_simple_footprint d p s;
     valid_simple_footprint d q t;
     s \<noteq> t \<rbrakk> \<Longrightarrow>
   p \<notin> {q..+ (size_td t)}"
  apply (subgoal_tac "p \<noteq> q")
   apply (rule valid_simple_footprint_neq, simp_all)[1]
  apply (clarsimp simp: valid_simple_footprint_def)
  done

lemma valid_simple_footprint_neq_disjoint:
  "\<lbrakk> valid_simple_footprint d p s; valid_simple_footprint d q t; p \<noteq> q \<rbrakk> \<Longrightarrow>
      {p..+(size_td s)} \<inter> {q..+ (size_td t)} = {}"
  apply (rule ccontr)
  apply (fastforce simp: valid_simple_footprint_neq dest!: intvl_inter)
  done

lemma valid_simple_footprint_type_neq_disjoint:
  "\<lbrakk> valid_simple_footprint d p s;
     valid_simple_footprint d q t;
     s \<noteq> t \<rbrakk> \<Longrightarrow>
   {p..+(size_td s)} \<inter> {q..+ (size_td t)} = {}"
  apply (subgoal_tac "p \<noteq> q")
   apply (rule valid_simple_footprint_neq_disjoint, simp_all)[1]
  apply (clarsimp simp: valid_simple_footprint_def)
  done

lemma heap_ptr_valid_neq_disjoint:
  "\<lbrakk> heap_ptr_valid d (p::'a::c_type ptr);
     heap_ptr_valid d (q::'b::c_type ptr);
     ptr_val p \<noteq> ptr_val q \<rbrakk> \<Longrightarrow>
   {ptr_val p..+size_of TYPE('a)} \<inter>
          {ptr_val q..+size_of TYPE('b)} = {}"
  apply (clarsimp simp only: size_of_tag [symmetric])
  apply (rule valid_simple_footprint_neq_disjoint [where d="d"])
    apply (clarsimp simp: heap_ptr_valid_def)
   apply (clarsimp simp: heap_ptr_valid_def)
  apply simp
  done

lemma heap_ptr_valid_type_neq_disjoint:
  "\<lbrakk> heap_ptr_valid d (p::'a::c_type ptr);
     heap_ptr_valid d (q::'b::c_type ptr);
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   {ptr_val p..+size_of TYPE('a)} \<inter>
          {ptr_val q..+size_of TYPE('b)} = {}"
  apply (subgoal_tac "ptr_val p \<noteq> ptr_val q")
   apply (rule heap_ptr_valid_neq_disjoint, auto)[1]
  apply (clarsimp simp: heap_ptr_valid_def valid_simple_footprint_def)
  done

(* If we update one pointer in the heap, other valid pointers will be unaffected. *)
lemma heap_ptr_valid_heap_update_other:
  assumes val_p: "heap_ptr_valid d (p::'a::mem_type ptr)"
      and val_q: "heap_ptr_valid d (q::'b::c_type ptr)"
      and neq: "ptr_val p \<noteq> ptr_val q"
  shows "h_val (heap_update p v h) q = h_val h q"
  apply (clarsimp simp: h_val_def heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply simp
   apply (rule heap_ptr_valid_neq_disjoint [OF val_p val_q neq])
  apply simp
  done

(* If we update one type in the heap, other types will be unaffected. *)
lemma heap_ptr_valid_heap_update_other_typ:
  assumes val_p: "heap_ptr_valid d (p::'a::mem_type ptr)"
      and val_q: "heap_ptr_valid d (q::'b::c_type ptr)"
      and neq: "typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b)"
  shows "h_val (heap_update p v h) q = h_val h q"
  apply (clarsimp simp: h_val_def heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply simp
   apply (rule heap_ptr_valid_type_neq_disjoint [OF val_p val_q neq])
  apply simp
  done

(* Updating the raw heap is equivalent to updating the lifted heap. *)
lemma simple_lift_heap_update:
  "\<lbrakk> heap_ptr_valid (hrs_htd h) p \<rbrakk> \<Longrightarrow>
      simple_lift (hrs_mem_update (heap_update p v) h)
          = (simple_lift h)(p := Some (v::'a::mem_type))"
  apply (rule ext)
  apply (clarsimp simp: simple_lift_def hrs_mem_update h_val_heap_update)
  apply (fastforce simp: heap_ptr_valid_heap_update_other ptr_val_inj)
  done

(* Updating the raw heap of one type doesn't affect the lifted heap of other types. *)
lemma simple_lift_heap_update_other:
  "\<lbrakk> heap_ptr_valid (hrs_htd d) (p::'b::mem_type ptr);
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   simple_lift (hrs_mem_update (heap_update p v) d) = ((simple_lift d)::'a::c_type typ_heap)"
  apply (rule ext)+
  apply (clarsimp simp: simple_lift_def h_val_heap_update hrs_mem_update)
  apply (auto intro: heap_ptr_valid_heap_update_other_typ)
  done

lemma h_val_simple_lift:
  "simple_lift h p = Some v \<Longrightarrow> h_val (hrs_mem h) p = v"
  apply (clarsimp simp: simple_lift_def split: split_if_asm)
  done

lemma h_val_field_simple_lift:
  "\<lbrakk> simple_lift h (pa :: 'a ptr) = Some (v::'a::mem_type);
     \<exists>t. field_ti TYPE('a) f = Some t;
     export_uinfo (the (field_ti TYPE('a) f)) = export_uinfo (typ_info_t TYPE('b :: mem_type)) \<rbrakk> \<Longrightarrow>
   h_val (hrs_mem h) (Ptr &(pa\<rightarrow>f) :: 'b :: mem_type ptr) = from_bytes (access_ti\<^sub>0 (the (field_ti TYPE('a) f)) v)"
  apply (clarsimp simp: simple_lift_def split: split_if_asm)
  apply (clarsimp simp: h_val_field_from_bytes)
  done

lemma simple_lift_heap_update':
  "simple_lift h p = Some v' \<Longrightarrow>
      simple_lift (hrs_mem_update (heap_update (p::('a::{mem_type}) ptr) v) h)
          = (simple_lift h)(p := Some v)"
  apply (rule simple_lift_heap_update)
  apply (erule simple_lift_heap_ptr_valid)
  done

lemma simple_lift_hrs_mem_update_None [simp]:
    "(simple_lift (hrs_mem_update a hp) x = None) = (simple_lift hp x = None)"
  apply (clarsimp simp: simple_lift_def)
  done

lemma simple_lift_data_eq:
   "\<lbrakk> h_val (hrs_mem h) p = h_val (hrs_mem h') p';
     heap_ptr_valid (hrs_htd h) p = heap_ptr_valid (hrs_htd h') p' \<rbrakk> \<Longrightarrow>
    simple_lift h p = simple_lift h' p'"
  apply (clarsimp simp: simple_lift_def)
  done

lemma h_val_heap_update_disjoint:
  "\<lbrakk> {ptr_val p ..+ size_of TYPE('a::c_type)}
        \<inter> {ptr_val q ..+ size_of TYPE('b::mem_type)} = {} \<rbrakk> \<Longrightarrow>
      h_val (heap_update (q :: 'b ptr) r h) (p :: 'a ptr) = h_val h p"
  apply (clarsimp simp: h_val_def)
  apply (clarsimp simp: heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply clarsimp
   apply blast
   apply clarsimp
  done

lemma update_ti_t_valid_size:
  "size_of TYPE('b) = size_td t \<Longrightarrow>
   update_ti_t t (to_bytes_p (val::'b::mem_type)) obj = update_ti t (to_bytes_p val) obj"
  apply (clarsimp simp: update_ti_t_def to_bytes_p_def)
  done

lemma h_val_field_from_bytes':
  "\<lbrakk> field_ti TYPE('a::{mem_type}) f = Some t;
     export_uinfo t = export_uinfo (typ_info_t TYPE('b::{mem_type})) \<rbrakk> \<Longrightarrow>
    h_val h (Ptr &(pa\<rightarrow>f) :: 'b ptr) = from_bytes (access_ti\<^sub>0 t (h_val h pa))"
  apply (insert h_val_field_from_bytes [where f=f and pa=pa and t=t and h="(h,x)" and 'a='a and 'b='b])
  apply (clarsimp simp: hrs_mem_def)
  done

lemma simple_lift_super_field_update_lookup:
  fixes dummy :: "'b :: mem_type"
  assumes "field_lookup (typ_info_t TYPE('b::mem_type)) f 0 = Some (s,n)"
    and "typ_uinfo_t TYPE('a) = export_uinfo s"
    and "simple_lift h p = Some v'"
  shows "(super_field_update_t (Ptr (&(p\<rightarrow>f))) (v::'a::mem_type) ((simple_lift h)::'b ptr \<Rightarrow> 'b option)) =
          ((simple_lift h)(p \<mapsto> field_update (field_desc s) (to_bytes_p v) v'))"
proof -
  from assms have [simp]: "unat (of_nat n :: 32 word) = n"
     apply (subst unat_of_nat)
     apply (subst mod_less)
      apply (drule td_set_field_lookupD)+
      apply (drule td_set_offset_size)+
      apply (subst len_of_addr_card)
      apply (subst (asm) size_of_def [symmetric, where t="TYPE('b)"])+
      apply (subgoal_tac "size_of TYPE('b) < addr_card")
       apply arith
      apply simp
     apply simp
     done
  from assms show ?thesis
    apply (clarsimp simp: super_field_update_t_def)
    apply (rule ext)
    apply (clarsimp simp: field_lvalue_def split: option.splits)
    apply (safe, simp_all)
       apply (frule_tac v=v and v'=v' in update_field_update)
       apply (clarsimp simp: field_of_t_def field_of_def typ_uinfo_t_def)
       apply (frule_tac m=0 in field_names_SomeD2)
        apply simp
       apply clarsimp
       apply (simp add: field_typ_def field_typ_untyped_def)
       apply (frule field_lookup_export_uinfo_Some)
       apply (frule_tac s=k in field_lookup_export_uinfo_Some)
       apply simp
       apply (drule (1) field_lookup_inject)
        apply (subst typ_uinfo_t_def [symmetric, where t="TYPE('b)"])
        apply simp
       apply simp
      apply (drule field_of_t_mem)+
      apply (case_tac h)
      apply (clarsimp simp: simple_lift_def split: split_if_asm)
      apply (drule (1) heap_ptr_valid_neq_disjoint)
       apply simp
      apply fast
     apply (clarsimp simp: field_of_t_def field_of_def)
     apply (subst (asm) td_set_field_lookup)
      apply simp
     apply simp
     apply (frule field_lookup_export_uinfo_Some)
     apply (simp add: typ_uinfo_t_def)
    apply (clarsimp simp: field_of_t_def field_of_def)
    apply (subst (asm) td_set_field_lookup)
     apply simp
    apply simp
    apply (frule field_lookup_export_uinfo_Some)
    apply (simp add: typ_uinfo_t_def)
    done
qed

lemma field_offset_addr_card:
    "\<exists>x. field_lookup (typ_info_t TYPE('a::mem_type)) f 0 = Some x \<Longrightarrow> field_offset TYPE('a) f < addr_card"
  apply (clarsimp simp: field_offset_def field_offset_untyped_def typ_uinfo_t_def)
  apply (subst field_lookup_export_uinfo_Some)
   apply assumption
  apply (frule td_set_field_lookupD)
  apply (drule td_set_offset_size)
  apply (insert max_size [where ?'a="'a"])
  apply (clarsimp simp: size_of_def)
  done

lemma unat_of_nat_field_offset:
  "\<exists>x. field_lookup (typ_info_t TYPE('a::mem_type)) f 0 = Some x \<Longrightarrow>
      unat (of_nat (field_offset TYPE('a) f)  :: word32 ) = field_offset TYPE('a) f"
  apply (subst word_unat.Abs_inverse)
   apply (clarsimp simp: unats_def)
   apply (insert field_offset_addr_card [where f=f and ?'a="'a"])[1]
   apply (fastforce simp: addr_card)
  apply simp
  done

lemma field_of_t_field_lookup:
  assumes a: "field_lookup (typ_info_t TYPE('a::mem_type)) f 0 = Some (s, n)"
  assumes b: "export_uinfo s = typ_uinfo_t TYPE('b::mem_type)"
  assumes n: "n = field_offset TYPE('a) f"
  shows "field_of_t (Ptr &(ptr\<rightarrow>f) :: ('b ptr)) (ptr :: 'a ptr)"
  apply (clarsimp simp del: field_lookup_offset_eq
      simp: field_of_t_def field_of_def)
  apply (subst td_set_field_lookup)
   apply (rule wf_desc_typ_tag)
  apply (rule exI [where x=f])
  using a[simplified n] b
  apply (clarsimp simp: typ_uinfo_t_def)
  apply (subst field_lookup_export_uinfo_Some)
   apply assumption
  apply (clarsimp simp del: field_lookup_offset_eq
      simp: field_lvalue_def unat_of_nat_field_offset)
  done

lemma simple_lift_field_update':
  fixes val :: "'b :: mem_type" and ptr :: "'a :: mem_type ptr"
  assumes   fl: "field_lookup (typ_info_t TYPE('a)) f 0 =
                     Some (adjust_ti (typ_info_t TYPE('b)) xf xfu, n)"
  and   xf_xfu: "fg_cons xf xfu"
  and       cl: "simple_lift hp ptr = Some z"
  shows "(simple_lift (hrs_mem_update (heap_update (Ptr &(ptr\<rightarrow>f)) val) hp)) =
                simple_lift hp(ptr \<mapsto> xfu val z)"
    (is "?LHS = ?RHS")
proof (rule ext)
  fix p

  have eui: "typ_uinfo_t TYPE('b) =
       export_uinfo (adjust_ti (typ_info_t TYPE('b)) xf xfu)"
    using xf_xfu
    apply (subst export_tag_adjust_ti2 [OF _ wf_lf wf_desc])
    apply (simp add: fg_cons_def )
    apply (rule meta_eq_to_obj_eq [OF typ_uinfo_t_def])
    done

  have n_is_field_offset: "n = field_offset TYPE('a) f"
    apply (insert field_lookup_offset_eq [OF fl])
    apply (clarsimp)
    done

  have equal_case: "?LHS ptr = ?RHS ptr"
    apply (insert cl)
    apply (clarsimp simp: simple_lift_def split: split_if_asm)
    apply (clarsimp simp: hrs_mem_update)
    apply (subst h_val_super_update_bs)
     apply (rule field_of_t_field_lookup [OF fl])
      apply (clarsimp simp: eui)
     apply (clarsimp simp: n_is_field_offset)
    apply clarsimp
    apply (unfold from_bytes_def)
    apply (subst fi_fu_consistentD [where f=f and s="adjust_ti (typ_info_t TYPE('b)) xf xfu"])
        apply (clarsimp simp: fl)
        apply (clarsimp simp: n_is_field_offset field_lvalue_def)
        apply (metis unat_of_nat_field_offset fl)
       apply clarsimp
      apply (clarsimp simp: size_of_def)
     apply (clarsimp simp: size_of_def)
    apply clarsimp
    apply (subst update_ti_s_from_bytes)
     apply clarsimp
    apply (subst update_ti_adjust_ti)
     apply (rule xf_xfu)
    apply (subst update_ti_s_from_bytes)
     apply clarsimp
    apply clarsimp
    apply (clarsimp simp: h_val_def)
    done

  show "?LHS p = ?RHS p"
    apply (case_tac "p = ptr")
     apply (erule ssubst)
     apply (rule equal_case)
    apply (insert cl)
    apply (clarsimp simp: simple_lift_def hrs_mem_update split: split_if_asm)
    apply (rule h_val_heap_update_disjoint)
    apply (insert field_tag_sub [OF fl, where p=ptr])
    apply (clarsimp simp: size_of_def)
    apply (clarsimp simp: heap_ptr_valid_def)
    apply (frule (1) valid_simple_footprint_neq_disjoint, fastforce)
    apply clarsimp
    apply blast
    done
qed

lemma simple_lift_field_update:
  fixes val :: "'b :: mem_type" and ptr :: "'a :: mem_type ptr"
  assumes   fl: "field_ti TYPE('a) f =
                     Some (adjust_ti (typ_info_t TYPE('b)) xf (xfu o (\<lambda>x _. x)))"
  and   xf_xfu: "fg_cons xf (xfu o (\<lambda>x _. x))"
  and       cl: "simple_lift hp ptr = Some z"
  shows "(simple_lift (hrs_mem_update (heap_update (Ptr &(ptr\<rightarrow>f)) val) hp)) =
                simple_lift hp(ptr \<mapsto> xfu (\<lambda>_. val) z)"
    (is "?LHS = ?RHS")
  apply (insert fl [unfolded field_ti_def])
  apply (clarsimp split: option.splits)
  apply (subst simple_lift_field_update' [where xf=xf and xfu="xfu o (\<lambda>x _. x)" and z=z])
     apply (clarsimp simp: o_def split: option.splits)
     apply (rule refl)
    apply (rule xf_xfu)
   apply (rule cl)
  apply clarsimp
  done

lemma simple_heap_diff_types_impl_diff_ptrs:
  "\<lbrakk> heap_ptr_valid h (p::('a::c_type) ptr);
     heap_ptr_valid h (q::('b::c_type) ptr);
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   ptr_val p \<noteq> ptr_val q"
  apply (clarsimp simp: heap_ptr_valid_def)
  apply (clarsimp simp: valid_simple_footprint_def)
  done

lemma h_val_update_regions_disjoint:
  "\<lbrakk> { ptr_val p ..+ size_of TYPE('a) } \<inter> { ptr_val x ..+ size_of TYPE('b)} = {} \<rbrakk> \<Longrightarrow>
        h_val (heap_update p (v::('a::mem_type)) h) x = h_val h (x::('b::c_type) ptr)"
  apply (clarsimp simp: heap_update_def)
  apply (clarsimp simp: h_val_def)
  apply (subst heap_list_update_disjoint_same)
   apply clarsimp
  apply clarsimp
  done

lemma simple_lift_field_update_t:
  fixes    val :: "'b :: mem_type" and ptr :: "'a :: mem_type ptr"
  assumes  fl: "field_ti TYPE('a) f = Some t"
  and      diff: "typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('c :: c_type)"
  and      eu: "export_uinfo t = export_uinfo (typ_info_t TYPE('b))"
  and      cl: "simple_lift hp ptr = Some z"
  shows "((simple_lift (hrs_mem_update (heap_update (Ptr &(ptr\<rightarrow>f)) val) hp)) :: 'c ptr \<Rightarrow> 'c option) =
             simple_lift hp"
  apply (rule ext)
  apply (case_tac "simple_lift hp x")
   apply clarsimp
  apply (case_tac "ptr_val x = ptr_val ptr")
   apply clarsimp
   apply (clarsimp simp: simple_lift_def hrs_mem_update split: split_if_asm)
   apply (cut_tac simple_lift_heap_ptr_valid [OF cl])
   apply (drule (1) simple_heap_diff_types_impl_diff_ptrs [OF _ _ diff])
   apply simp
  apply (clarsimp simp: simple_lift_def hrs_mem_update split: split_if_asm)
  apply (rule field_ti_field_lookupE [OF fl])
  apply (frule_tac p=ptr in field_tag_sub)
  apply (clarsimp simp: h_val_def heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply clarsimp
   apply (cut_tac simple_lift_heap_ptr_valid [OF cl])
   apply (drule (2) heap_ptr_valid_neq_disjoint)
   apply (clarsimp simp: export_size_of [unfolded typ_uinfo_t_def, OF eu])
   apply blast
  apply simp
  done

lemma simple_lift_heap_update_other':
  "\<lbrakk> simple_lift h (p::'b::mem_type ptr) = Some v';
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   simple_lift (hrs_mem_update (heap_update p v) h) = ((simple_lift h)::'a::c_type typ_heap)"
  apply (rule simple_lift_heap_update_other)
   apply (erule simple_lift_heap_ptr_valid)
  apply simp
  done

(* If you update bytes inside an object of one type, it won't affect
 * heaps of other types. *)
lemma simple_lift_heap_update_bytes_in_other:
  "\<lbrakk> simple_lift h (p::'b::mem_type ptr) = Some v';
     typ_uinfo_t TYPE('b) \<noteq> typ_uinfo_t TYPE('c);
     { ptr_val q ..+ size_of TYPE('a)} \<subseteq> {ptr_val p  ..+ size_of TYPE('b) }  \<rbrakk> \<Longrightarrow>
   simple_lift (hrs_mem_update (heap_update (q::'a::mem_type ptr) v) h) = ((simple_lift h)::'c::mem_type typ_heap)"
  apply (rule ext)
  apply (clarsimp simp: simple_lift_def split: split_if_asm)
  apply (drule (1) heap_ptr_valid_type_neq_disjoint, simp)
  apply (clarsimp simp: hrs_mem_update)
  apply (rule h_val_heap_update_disjoint)
  apply blast
  done

lemma typ_name_neq:
    "typ_name (export_uinfo (typ_info_t TYPE('a::c_type)))
        \<noteq> typ_name (export_uinfo (typ_info_t TYPE('b::c_type)))
    \<Longrightarrow> typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b)"
  apply (metis typ_uinfo_t_def)
  done

lemma of_nat_mod_div_decomp:
  "of_nat k
        = of_nat (k div size_of TYPE('b)) * of_nat (size_of TYPE('b::mem_type)) +
              of_nat (k mod size_of TYPE('b))"
  by (metis mod_div_decomp of_nat_add of_nat_mult)

lemma c_guard_array_c_guard:
  "\<lbrakk> \<And>x. x < CARD('a) \<Longrightarrow> c_guard (ptr_coerce p +\<^sub>p int x :: 'b ptr) \<rbrakk> \<Longrightarrow> c_guard ( p :: ('b :: mem_type, 'a :: finite) array ptr)"
  apply atomize
  apply (clarsimp simp: c_guard_def)
  apply (rule conjI)
   apply (drule_tac x=0 in spec)
   apply (clarsimp simp: ptr_aligned_def align_of_def align_td_array)
  apply (simp add: c_null_guard_def)
  apply (clarsimp simp: intvl_def)
  apply (drule_tac x="k div size_of TYPE('b)" in spec)
  apply (erule impE)
   apply (metis (full_types) less_nat_zero_code mult_is_0 neq0_conv td_gal_lt)
  apply clarsimp
  apply (drule_tac x="k mod size_of TYPE('b)" in spec)
  apply (clarsimp simp: CTypesDefs.ptr_add_def)
  apply (subst (asm) add.assoc)
  apply (subst (asm) of_nat_mod_div_decomp [symmetric])
  apply clarsimp
  done

lemma heap_list_update_list':
  "\<lbrakk> n + x \<le> length v; length v < addr_card; q = (p + of_nat x) \<rbrakk> \<Longrightarrow>
      heap_list (heap_update_list p v h) n q = take n (drop x v)"
  by (metis heap_list_update_list)

lemma outside_intvl_range:
    "p \<notin> {a ..+ b} \<Longrightarrow> p < a \<or> p \<ge> a + of_nat b"
  apply (clarsimp simp: intvl_def not_le not_less)
  apply (drule_tac x="unat (p-a)" in spec)
  apply clarsimp
  apply (metis add_diff_cancel2 le_less_linear le_unat_uoi
      mpl_lem not_add_less2 unat_mono word_less_minus_mono_left)
  done

lemma first_in_intvl:
  "b \<noteq> 0 \<Longrightarrow> a \<in> {a ..+ b}"
  by (force simp: intvl_def)

lemma zero_not_in_intvl_no_overflow:
  "0 \<notin> {a :: 'a::len word ..+ b} \<Longrightarrow> unat a + b \<le> 2 ^ len_of TYPE('a)"
  apply (rule ccontr)
  apply (simp add: intvl_def not_le)
  apply (drule_tac x="2 ^ len_of TYPE('a) - unat a" in spec)
  apply (clarsimp simp: not_less)
  apply (erule disjE)
  apply (metis (erased, hide_lams) diff_add_inverse less_imp_add_positive of_nat_2p of_nat_add
           unat_lt2p word_neq_0_conv word_unat.Rep_inverse)
  apply (metis le_add_diff_inverse le_antisym le_diff_conv le_refl
           less_imp_le_nat add.commute not_add_less1 unat_lt2p)
  done

lemma intvl_split:
  "\<lbrakk> n \<ge> a \<rbrakk> \<Longrightarrow> { p :: ('a :: len) word ..+ n } = { p ..+ a } \<union> { p + of_nat a ..+ (n - a)}"
  apply (rule set_eqI, rule iffI)
   apply (clarsimp simp: intvl_def not_less)
   apply (rule_tac x=k in exI)
   apply clarsimp
   apply (rule classical)
   apply (drule_tac x="k - a" in spec)
   apply (clarsimp simp: not_less)
   apply (metis diff_less_mono not_less)
  apply (clarsimp simp: intvl_def not_less)
  apply (rule_tac x="unat (x - p)" in exI)
  apply clarsimp
  apply (erule disjE)
   apply clarsimp
   apply (metis le_unat_uoi less_or_eq_imp_le not_less order_trans)
  apply clarsimp
  apply (metis le_def le_eq_less_or_eq le_unat_uoi less_diff_conv
    add.commute of_nat_add)
  done

lemma heap_ptr_valid_range_not_NULL:
  "heap_ptr_valid htd (p :: ('a :: c_type) ptr)
      \<Longrightarrow> 0 \<notin> {ptr_val p ..+ size_of TYPE('a)}"
  apply (clarsimp simp: heap_ptr_valid_def)
  apply (metis c_guard_def c_null_guard_def)
  done

lemma heap_ptr_valid_last_byte_no_overflow:
  "heap_ptr_valid htd (p :: ('a :: c_type) ptr)
      \<Longrightarrow> unat (ptr_val p) + size_of TYPE('a) \<le> 2 ^ len_of TYPE(32)"
  by (metis c_guard_def c_null_guard_def heap_ptr_valid_def
        zero_not_in_intvl_no_overflow)

lemma heap_ptr_valid_intersect_array:
  "\<lbrakk> \<forall>j < n. heap_ptr_valid htd (p +\<^sub>p int j);
        heap_ptr_valid htd (q :: ('a :: c_type) ptr) \<rbrakk>
         \<Longrightarrow> (\<exists>m < n. q = (p +\<^sub>p int m))
    \<or> ({ptr_val p ..+ size_of TYPE ('a) * n} \<inter> {ptr_val q ..+ size_of TYPE ('a :: c_type)} = {})"
  apply (induct n)
   apply clarsimp
  apply atomize
  apply simp
  apply (case_tac "n = 0")
   apply clarsimp
   apply (metis heap_ptr_valid_neq_disjoint ptr_val_inj)
  apply (erule disjE)
   apply (metis less_Suc_eq)
  apply (case_tac "q = p +\<^sub>p int n")
   apply force
  apply (frule_tac x=n in spec)
  apply (erule impE, simp)
  apply (drule (1) heap_ptr_valid_neq_disjoint)
  apply simp
  apply (simp add: CTypesDefs.ptr_add_def)
  apply (rule disjI2)
  apply (cut_tac a=" of_nat n * of_nat (size_of TYPE('a))"
      and p="ptr_val p" and n="n * size_of TYPE('a) + size_of TYPE('a)" in intvl_split)
   apply clarsimp
  apply (clarsimp simp: field_simps Int_Un_distrib2)
  apply (metis IntI emptyE intvl_empty intvl_inter intvl_self neq0_conv)
  done

(*
lemma simple_lift_heap_update_array_in_domain:
  "\<lbrakk> \<forall>j < CARD('b). simple_lift h ((ptr_coerce p :: 'a ptr)  +\<^sub>p int j) \<noteq> None;
            n < CARD('b) \<rbrakk> \<Longrightarrow>
      simple_lift (hrs_mem_update (
        heap_update p (Arrays.update (h_val (hrs_mem h) p :: ('a::oneMB_size)['b::fourthousand_count]) n val)) h)
        = ((simple_lift h)((ptr_coerce p :: 'a ptr) +\<^sub>p int n := Some val))"
  apply (rule ext)
  apply (clarsimp simp: simple_lift_def hrs_mem_update if_Some_None_eq_None)
  apply safe
   apply (simp add: heap_access_Array_element[symmetric] h_val_heap_update)
  apply (frule(1) heap_ptr_valid_intersect_array)
  apply (erule disjE)
   apply (clarsimp simp: heap_access_Array_element[symmetric] h_val_heap_update)
   apply (rule index_update2, simp)
   apply fastforce
  apply (rule h_val_heap_update_disjoint)
  apply (simp add: field_simps Int_commute)
  done
*)

(* Simplification rules for dealing with "lift_simple". *)

lemmas simple_lift_simps =
  typ_name_neq
  simple_lift_c_guard
  h_val_simple_lift
  simple_lift_heap_update'
  simple_lift_heap_update_other'
  c_guard_field
  h_val_field_simple_lift
  simple_lift_field_update
  simple_lift_field_update_t
  c_guard_array_field
  nat_to_bin_string_simps

(* Old name for the above simpset. *)
lemmas typ_simple_heap_simps = simple_lift_simps

end


(*  Title:    HOL/Library/Conditional_Parametricity.thy
    Author:   Jan Gilcher, Andreas Lochbihler, Dmitriy Traytel, ETH Zürich

A conditional parametricity prover
*)

theory Conditional_Parametricity
imports Main
keywords "parametric_constant" :: thy_decl
begin

context includes lifting_syntax begin

qualified definition Rel_match :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" where
  "Rel_match R x y = R x y"

named_theorems parametricity_preprocess

lemma bi_unique_Rel_match [parametricity_preprocess]:
  "bi_unique A = Rel_match (A ===> A ===> (=)) (=) (=)"
  unfolding bi_unique_alt_def2 Rel_match_def ..

lemma bi_total_Rel_match [parametricity_preprocess]:
  "bi_total A = Rel_match ((A ===> (=)) ===> (=)) All All"
  unfolding bi_total_alt_def2 Rel_match_def ..

lemma is_equality_Rel: "is_equality A \<Longrightarrow> Transfer.Rel A t t"
  by (fact transfer_raw)

lemma Rel_Rel_match: "Transfer.Rel R x y \<Longrightarrow> Rel_match R x y"
  unfolding Rel_match_def Rel_def .

lemma Rel_match_Rel: "Rel_match R x y \<Longrightarrow> Transfer.Rel R x y"
  unfolding Rel_match_def Rel_def .

lemma Rel_Rel_match_eq: "Transfer.Rel R x y = Rel_match R x y"
  using Rel_Rel_match Rel_match_Rel by fast

lemma Rel_match_app:
  assumes "Rel_match (A ===> B) f g" and "Transfer.Rel A x y"
  shows "Rel_match B (f x) (g y)"
  using assms Rel_match_Rel Rel_app Rel_Rel_match by fast

end

ML_file \<open>conditional_parametricity.ML\<close>

end