(*
Title: WHATandWHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory MWLs
imports Strong_Security.Types
begin

\<comment> \<open>type parameters not instantiated:\<close>
\<comment> \<open>'exp: expressions (arithmetic, boolean...)\<close>
\<comment> \<open>'val: numbers, boolean constants....\<close>
\<comment> \<open>'id: identifier names\<close>

\<comment> \<open>SYNTAX\<close>

datatype ('exp, 'id) MWLsCom
  = Skip "nat" ("skip\<^bsub>_\<^esub>" [50] 70)
  | Assign "'id" "nat" "'exp"
       ("_:=\<^bsub>_\<^esub> _" [70,50,70] 70)

  | Seq "('exp, 'id) MWLsCom"
         "('exp, 'id) MWLsCom"
       ("_;_" [61,60] 60)

  | If_Else "nat" "'exp" "('exp, 'id) MWLsCom"
         "('exp, 'id) MWLsCom"
       ("if\<^bsub>_\<^esub> _ then _ else _ fi" [50,80,79,79] 70)

  | While_Do "nat" "'exp" "('exp, 'id) MWLsCom"
       ("while\<^bsub>_\<^esub> _ do _ od" [50,80,79] 70)

  | Spawn "nat" "(('exp, 'id) MWLsCom) list"
       ("spawn\<^bsub>_\<^esub> _" [50,70] 70)

\<comment> \<open>function for obtaining the program point of some MWLsloc command\<close>
primrec pp ::"('exp, 'id) MWLsCom \<Rightarrow> nat"
where
"pp (skip\<^bsub>\<iota>\<^esub>) = \<iota>" |
"pp (x :=\<^bsub>\<iota>\<^esub> e) = \<iota>" |
"pp (c1;c2) = pp c1" |
"pp (if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi) = \<iota>" |
"pp (while\<^bsub>\<iota>\<^esub> b do c od) = \<iota>" |
"pp (spawn\<^bsub>\<iota>\<^esub> V) = \<iota>"

\<comment> \<open>mutually recursive functions to collect program points of commands and thread pools\<close>
primrec PPc :: "('exp,'id) MWLsCom \<Rightarrow> nat list"
and PPV :: "('exp,'id) MWLsCom list \<Rightarrow> nat list"
where
"PPc (skip\<^bsub>\<iota>\<^esub>) = [\<iota>]" |
"PPc (x :=\<^bsub>\<iota>\<^esub> e) = [\<iota>]" |
"PPc (c1;c2) = (PPc c1) @ (PPc c2)" |
"PPc (if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi) =  [\<iota>] @ (PPc c1) @ (PPc c2)" |
"PPc (while\<^bsub>\<iota>\<^esub> b do c od) = [\<iota>] @ (PPc c)" |
"PPc (spawn\<^bsub>\<iota>\<^esub> V) = [\<iota>] @ (PPV V)" |

"PPV [] = []" |
"PPV (c#V) = (PPc c) @ (PPV V)"

\<comment> \<open>predicate indicating that a command only contains unique program points\<close>
definition unique_PPc :: "('exp, 'id) MWLsCom \<Rightarrow> bool"
where
"unique_PPc c = distinct (PPc c)"

\<comment> \<open>predicate indicating that a thread pool only contains unique program points\<close>
definition unique_PPV :: "('exp, 'id) MWLsCom list \<Rightarrow> bool"
where
"unique_PPV V = distinct (PPV V)"

lemma PPc_nonempt: "PPc c \<noteq> []"
  by (induct c) auto

lemma unique_c_uneq: "set (PPc c) \<inter> set (PPc c') = {} \<Longrightarrow> c \<noteq> c'"
  by (insert PPc_nonempt, force)

lemma V_nonempt_PPV_nonempt: "V \<noteq> [] \<Longrightarrow> PPV V \<noteq> []"
  by (auto, induct V, simp_all, insert PPc_nonempt, force)

lemma unique_V_uneq:
"\<lbrakk>V \<noteq> []; V' \<noteq> []; set (PPV V) \<inter> set (PPV V') = {}\<rbrakk> \<Longrightarrow> V \<noteq> V'"
  by (auto, induct V, simp_all, insert V_nonempt_PPV_nonempt, auto)

lemma PPc_in_PPV: "c \<in> set V \<Longrightarrow> set (PPc c) \<subseteq> set (PPV V)"
  by (induct V, auto)

lemma listindices_aux: "i < length V \<Longrightarrow> (V!i) \<in> set V"
  by (metis nth_mem)

lemma PPc_in_PPV_version:
  "i < length V \<Longrightarrow> set (PPc (V!i)) \<subseteq> set (PPV V)"
  by (rule PPc_in_PPV, erule listindices_aux)

lemma uniPPV_uniPPc: "unique_PPV V \<Longrightarrow> (\<forall>i < length V. unique_PPc (V!i))"
  by (auto, simp add: unique_PPV_def, induct V,
    auto simp add: unique_PPc_def,
    metis in_set_conv_nth length_Suc_conv set_ConsD)

\<comment> \<open>SEMANTICS\<close>

locale MWLs_semantics =
fixes E :: "('exp, 'id, 'val) Evalfunction"
and BMap :: "'val \<Rightarrow> bool"
begin

\<comment> \<open>steps semantics, set of deterministic steps from commands to program states\<close>
inductive_set
MWLsSteps_det ::
  "('exp, 'id, 'val, ('exp, 'id) MWLsCom) TLSteps"
and MWLslocSteps_det' ::
  "('exp, 'id, 'val, ('exp, 'id) MWLsCom) TLSteps_curry"
("(1\<langle>_,/_\<rangle>) \<rightarrow>\<lhd>_\<rhd>/ (1\<langle>_,/_\<rangle>)" [0,0,0,0,0] 81)
where
"\<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>c2,m2\<rangle> \<equiv> ((c1,m1),\<alpha>,(c2,m2)) \<in> MWLsSteps_det" |
skip: "\<langle>skip\<^bsub>\<iota>\<^esub>,m\<rangle> \<rightarrow>\<lhd>[]\<rhd> \<langle>None,m\<rangle>" |
assign: "(E e m) = v \<Longrightarrow>
  \<langle>x :=\<^bsub>\<iota>\<^esub> e,m\<rangle> \<rightarrow>\<lhd>[]\<rhd> \<langle>None,m(x := v)\<rangle>" |
seq1: "\<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>None,m'\<rangle> \<Longrightarrow>
  \<langle>c1;c2,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c2,m'\<rangle>" |
seq2: "\<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c1',m'\<rangle> \<Longrightarrow>
  \<langle>c1;c2,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some (c1';c2),m'\<rangle>" |
iftrue: "BMap (E b m) = True \<Longrightarrow>
  \<langle>if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi,m\<rangle> \<rightarrow>\<lhd>[]\<rhd> \<langle>Some c1,m\<rangle>" |
iffalse: "BMap (E b m) = False \<Longrightarrow>
  \<langle>if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi,m\<rangle> \<rightarrow>\<lhd>[]\<rhd> \<langle>Some c2,m\<rangle>" |
whiletrue: "BMap (E b m) = True \<Longrightarrow>
  \<langle>while\<^bsub>\<iota>\<^esub> b do c od,m\<rangle> \<rightarrow>\<lhd>[]\<rhd> \<langle>Some (c;(while\<^bsub>\<iota>\<^esub> b do c od)),m\<rangle>" |
whilefalse: "BMap (E b m) = False \<Longrightarrow>
  \<langle>while\<^bsub>\<iota>\<^esub> b do c od,m\<rangle> \<rightarrow>\<lhd>[]\<rhd> \<langle>None,m\<rangle>" |
spawn: "\<langle>spawn\<^bsub>\<iota>\<^esub> V,m\<rangle> \<rightarrow>\<lhd>V\<rhd> \<langle>None,m\<rangle>"

inductive_cases MWLsSteps_det_cases:
"\<langle>skip\<^bsub>\<iota>\<^esub>,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>"
"\<langle>x :=\<^bsub>\<iota>\<^esub> e,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>"
"\<langle>c1;c2,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>"
"\<langle>if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>"
"\<langle>while\<^bsub>\<iota>\<^esub> b do c od,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>"
"\<langle>spawn\<^bsub>\<iota>\<^esub> V,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>"

\<comment> \<open>non-deterministic, possibilistic system step (added for intuition, not used in the proofs)\<close>
inductive_set
MWLsSteps_ndet ::
  "('exp, 'id, 'val, ('exp, 'id) MWLsCom) TPSteps"
and MWLsSteps_ndet' ::
  "('exp, 'id, 'val, ('exp, 'id) MWLsCom) TPSteps_curry"
("(1\<langle>_,/_\<rangle>) \<Rightarrow>/ (1\<langle>_,/_\<rangle>)" [0,0,0,0] 81)
where
"\<langle>V,m\<rangle> \<Rightarrow> \<langle>V',m'\<rangle> \<equiv> ((V,m),(V',m')) \<in> MWLsSteps_ndet" |
stepthreadi1: "\<langle>ci,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>None,m'\<rangle> \<Longrightarrow>
  \<langle>cf @ [ci] @ ca,m\<rangle> \<Rightarrow> \<langle>cf @ \<alpha> @ ca,m'\<rangle>" |
stepthreadi2: "\<langle>ci,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c',m'\<rangle> \<Longrightarrow>
  \<langle>cf @ [ci] @ ca,m\<rangle> \<Rightarrow> \<langle>cf @ [c'] @ \<alpha> @ ca,m\<rangle>"

\<comment> \<open>lemma about existence and uniqueness of next memory of a step\<close>
lemma nextmem_exists_and_unique:
"\<exists>m' p \<alpha>. \<langle>c,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
  \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>c,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>) \<longrightarrow> m'' = m')"
  by (induct c, auto, metis MWLsSteps_det.skip MWLsSteps_det_cases(1),
    metis MWLsSteps_det_cases(2) MWLsSteps_det.assign,
    metis (no_types) MWLsSteps_det.seq1 MWLsSteps_det.seq2
    MWLsSteps_det_cases(3) not_Some_eq,
    metis MWLsSteps_det.iffalse MWLsSteps_det.iftrue
    MWLsSteps_det_cases(4),
    metis MWLsSteps_det.whilefalse MWLsSteps_det.whiletrue
    MWLsSteps_det_cases(5),
    metis MWLsSteps_det.spawn MWLsSteps_det_cases(6))

lemma PPsc_of_step:
"\<lbrakk> \<langle>c,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>; \<exists>c'. p = Some c' \<rbrakk>
  \<Longrightarrow> set (PPc (the p)) \<subseteq> set (PPc c)"
  by (induct rule: MWLsSteps_det.induct, auto)

lemma PPs\<alpha>_of_step:
"\<langle>c,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
  \<Longrightarrow> set (PPV \<alpha>) \<subseteq> set (PPc c)"
  by (induct rule: MWLsSteps_det.induct, auto)

end

end


(*  Title:       Jive Data and Store Model
    Author:      Norbert Schirmer <schirmer at informatik.tu-muenchen.de>  and
                 Nicole Rauch <rauch at informatik.uni-kl.de>, 2005
    Maintainer:  Nicole Rauch <rauch at informatik.uni-kl.de>
    License:     LGPL
*)

header {* Program-Independent Lemmas on Attributes *}

theory AttributesIndep
imports "../Isa_Counter_Store/Attributes"
begin

text {* The following lemmas validate the functions defined in the Attributes theory.
They also aid in subsequent proving tasks. Since they are
program-independent, it is of no use to add them to the generation process of
Attributes.thy. Therefore, they have been extracted to this theory.
*}

lemma cls_catt [simp]:
  "CClassT c \<le> dtype f \<Longrightarrow> cls (catt c f) = c"
  apply (case_tac c)
  apply (case_tac [!] f)
  apply simp_all
   --{* solves all goals where @{text "CClassT c \<le> dtype f"} *}
  apply (fastforce elim: subtype_wrong_elims simp add: subtype_defs)+
   --{* solves all the rest where @{text "\<not> CClassT c \<le> dtype f"} can be derived
     *}
  done

lemma att_catt [simp]:
  "CClassT c \<le> dtype f \<Longrightarrow> att (catt c f) = f"
  apply (case_tac c)
  apply (case_tac [!] f)
  apply simp_all
   --{* solves all goals where @{text "CClassT c \<le> dtype f"} *}
  apply (fastforce elim: subtype_wrong_elims simp add: subtype_defs)+
   --{* solves all the rest where @{text "\<not> CClassT c \<le> dtype f"} can be
        derived *}
  done

text {* The following lemmas are just a demonstration of simplification. *}

lemma rtype_att_catt:
  "CClassT c \<le> dtype f \<Longrightarrow> rtype (att (catt c f)) = rtype f"
  by simp

lemma widen_cls_dtype_att [simp,intro]:
  "(CClassT (cls cf) \<le> dtype (att cf)) "
  by (cases cf, simp_all)

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 longlong
imports "../CTranslation"
begin

install_C_file "longlong.c"

ML {* NameGeneration.return_var_name (Absyn.Signed Absyn.LongLong) *}

context longlong
begin

thm f_body_def
thm shifts1_body_def
thm shifts2_body_def

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 32768 = 0"
apply simp
done

lemma "(scast :: 16 word \<Rightarrow> 8 word) 32768 = 0"
by simp

lemma "(scast :: 16 word \<Rightarrow> 8 word) 65535 = 255"
by simp

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 65535 = 255"
by simp

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 32767 = 255" by simp
lemma "(scast :: 16 word \<Rightarrow> 8 word) 32767 = 255" by simp

lemma "(scast :: 8 word \<Rightarrow> 16 word) 255 = 65535" by simp
lemma "(ucast :: 8 word \<Rightarrow> 16 word) 255 = 255" by simp

lemma g_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL callg() \<lbrace> \<acute>ret__int = 0 \<rbrace>"
apply vcg
apply (simp add: max_word_def)
done

thm literals_body_def

lemma literals_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL literals() \<lbrace> \<acute>ret__int = 31 \<rbrace>"
apply vcg
apply simp
done

end (* context *)

end (* theory *)


           (*-------------------------------------------*
            |                DFP package                |
            |                    May 2005               |
            |               December 2005  (modified)   |
            |                                           |
            |   DFP on CSP-Prover ver.3.0               |
            |              September 2006  (modified)   |
            |                  April 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory DFP_Block
imports DFP_Deadlock
begin

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

declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite (notick | t = []t)                 *)
(*                                                                     *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

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

         1.
         2.
         3.
         4.

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

(*********************************************************
                    definitions
 *********************************************************)

definition
  triple_disjoint :: "('i,'a) NetworkF => bool"
  where
  triple_disjoint_def :
    "triple_disjoint VF ==
       (ALL i: fst VF. ALL j: fst VF. ALL k: fst VF. i ~= j & j ~= k & k ~= i
          --> (snd ((snd VF) i) Int snd ((snd VF) j) Int snd ((snd VF) k) = {}))"

definition
  VocabularyOf :: "('i,'a) NetworkF => 'a set"
  where
  VocabularyOf_def :
    "VocabularyOf VF ==
     Union {X. EX i: fst VF. EX j: fst VF. i ~= j &
               X = snd((snd VF) i) Int snd((snd VF) j)}"
    (* internal communication *)

definition
  BusyNetworkP :: "('i,'p,'a) Network => bool"
  where
  BusyNetworkP_def :
    "BusyNetworkP V ==
     ALL i: fst V. DeadlockFreeNetwork ({i}, snd V)"

definition
  BusyNetwork  :: "('i,'a) NetworkF => bool"
  where
  BusyNetwork_def :
    "BusyNetwork VF ==
     ALL i: fst VF. (ALL sigma. ~(sigma isDeadlockStateOf ({i}, snd VF)))"

definition
  isRequestOf :: "('i,'a) NetworkF => 'i => ('i,'a) net_state => 'i => bool"
     ("(1_ >> /(0_ (1/--[_]-->) /_))" [800, 800,100,800] 900)
  where
  isRequestOf_def :
    "VF >> i --[sigma]--> j ==
        sigma isStateOf VF &
        i ~= j & i : fst VF & j : fst VF &
        (Ev ` (snd (snd VF i)) - (snd sigma) i) Int
         Ev ` (snd (snd VF j)) ~= {}"

definition
  isStrongRequestOf :: "('i,'a) NetworkF => 'i => ('i,'a) net_state => 'i => bool"
     ("(1_ >> /(0_ (1/==[_]==>) /_))" [800, 800,100,800] 900)
  where
  isStrongRequestOf_def :
    "VF >> i ==[sigma]==> j ==
        sigma isStateOf VF &
        i ~= j & i : fst VF & j : fst VF &
        Ev ` (snd (snd VF i)) - (snd sigma) i ~= {} &
        Ev ` (snd (snd VF i)) - (snd sigma) i <= Ev ` (snd (snd VF j))"

definition
  isUngrantedRequestOf ::
      "('i,'a) NetworkF => 'i => ('i,'a) net_state => 'i => bool"
      ("(1_ >> /(0_ (1/--[_]-->o) /_))" [800, 800,0,800] 900)
  where
  isUngrantedRequestOf_def :
    "VF >> i --[sigma]-->o j == VF >> i --[sigma]--> j &
        Ev ` (snd (snd VF i)) Int Ev ` (snd (snd VF j))
        <= (snd sigma) i Un (snd sigma) j"

definition
  isUngrantedStrongRequestOf ::
      "('i,'a) NetworkF => 'i => ('i,'a) net_state => 'i => bool"
      ("(1_ >> /(0_ (1/==[_]==>o) /_))" [800, 800,0,800] 900)
  where
  isUngrantedStrongRequestOf_def :
    "VF >> i ==[sigma]==>o j == VF >> i ==[sigma]==> j &
        Ev ` (snd (snd VF i)) Int Ev ` (snd (snd VF j))
        <= (snd sigma) i Un (snd sigma) j"

definition
  isUngrantedRequestOfwrt ::
      "('i,'a) NetworkF => 'i => ('i,'a) net_state => 'a set => 'i => bool"
      ("(1_ >> /(0_ (1/--[(0_,/_)]-->o) /_))" [800, 800,0,0,800] 900)
  where
  isUngrantedRequestOfwrt_def :
    "VF >> i --[sigma,Lambda]-->o j == VF >> i --[sigma]-->o j &
        ((Ev ` (snd (snd VF i))) - (snd sigma) i) Un
        ((Ev ` (snd (snd VF j))) - (snd sigma) j) <= Ev ` Lambda"

(*** Block ***)

definition
  isBlockedIn ::
      "('i,'a) NetworkF => 'i => ('i,'a) net_state => bool"
      ("(_ >> _ isBlockedIn _)" [800, 800, 800] 900)
  where
  isBlockedIn_def :
    "VF >> i isBlockedIn sigma ==
          triple_disjoint VF &
          (EX j. VF >> i --[sigma]--> j) &
          (ALL j. VF >> i --[sigma]--> j
          --> (VF >> i --[sigma, (VocabularyOf VF)]-->o j))"

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

lemma BusyNetwork_BusyNetworkP :
    "[| I ~= {} ; finite I ; (I,FXf) isFailureOf (I,PXf) |]
     ==> BusyNetwork (I,FXf) = BusyNetworkP (I,PXf)"
apply (simp add: BusyNetwork_def)
apply (simp add: BusyNetworkP_def)
apply (rule)

 apply (rule ballI)
 apply (drule_tac x="i" in bspec, simp)
 apply (subgoal_tac "({i}, FXf) isFailureOf ({i}, PXf)")
 apply (simp add: DeadlockFree_notDeadlockState)
 apply (rule isFailureOf_subset_index)
 apply (simp)
 apply (simp)

 apply (rule ballI)
 apply (drule_tac x="i" in bspec, simp)
 apply (subgoal_tac "({i}, FXf) isFailureOf ({i}, PXf)")
 apply (simp add: DeadlockFree_notDeadlockState)
 apply (rule isFailureOf_subset_index)
 apply (simp)
 apply (simp)
done

(*-----------------------------------*
 |     How to check BusyNetworkF     |
 *-----------------------------------*)

lemma check_BusyNetwork:
   "[| ALL i:I. ALL s Y. (s, Y) : fst (FXf i) --> Y ~= Ev ` (snd (FXf i)) |]
    ==> BusyNetwork (I,FXf)"
apply (simp add: BusyNetwork_def)
apply (intro allI ballI)
apply (rename_tac s Yf)
apply (drule_tac x="i" in bspec, simp)

apply (simp add: isDeadlockStateOf_def)
apply (simp add: disj_not1)
apply (intro impI)
apply (simp add: isStateOf_def)
apply (drule_tac x="s rest-tr (snd (FXf i))" in spec)
apply (drule_tac x="Yf i" in spec)
apply (simp)
apply (simp add: ALP_def)
done

(*********************************************************
                     in index I
 *********************************************************)

lemma in_index_I1:
  "(I, FXf) >> i --[sigma]--> j ==> i : I & j : I & i ~= j"
by (simp add: isRequestOf_def)

lemma in_index_I2:
  "(I, FXf) >> i ==[sigma]==> j ==> i : I & j : I & i ~= j"
by (simp add: isStrongRequestOf_def)

lemma in_index_I3:
  "(I, FXf) >> i --[sigma]-->o j ==> i : I & j : I & i ~= j"
apply (simp add: isUngrantedRequestOf_def)
apply (elim conjE)
by (simp add: in_index_I1)

lemma in_index_I4:
  "(I, FXf) >> i ==[sigma]==>o j ==> i : I & j : I & i ~= j"
apply (simp add: isUngrantedStrongRequestOf_def)
apply (elim conjE)
by (simp add: in_index_I2)

lemma in_index_I5:
  "(I, FXf) >> i --[sigma,Lambda]-->o j ==> i : I & j : I & i ~= j"
apply (simp add: isUngrantedRequestOfwrt_def)
apply (elim conjE)
by (simp add: in_index_I3)

lemmas in_index_I = in_index_I1 in_index_I2 in_index_I3 in_index_I4 in_index_I5

(*********************************************************
                       note (P.7)
 *********************************************************)

lemma isUngrantedRequestOfwrt_note1:
  "[| Lambda1 <= Lambda2 ; VF >> i --[sigma,Lambda1]-->o j |]
   ==> VF >> i --[sigma,Lambda2]-->o j"
apply (simp add: isUngrantedRequestOfwrt_def)
by (blast)

lemma isUngrantedRequestOfwrt_note2:
  "(snd (snd VF i)) Un (snd (snd VF j)) <= Lambda
   ==> (VF >> i --[sigma,Lambda]-->o j) = (VF >> i --[sigma]-->o j)"
by (auto simp add: isUngrantedRequestOfwrt_def)

(*********************************************************
                     sub request
 *********************************************************)

lemma isRequestOf_subsetI:
  "[| (I, FXf) >> i --[(t,Yf)]--> j; J <= I; i:J ; j:J ;
      X = Union {snd (FXf i)|i. i:J} |]
   ==> (J, FXf) >> i --[(t rest-tr X,Yf)]--> j"
apply (simp add: isRequestOf_def)
apply (rule isStateOf_subsetI)
apply (simp_all)
done

lemma isStrongRequestOf_subsetI:
  "[| (I, FXf) >> i ==[(t,Yf)]==> j; J <= I; i:J ; j:J ;
      X = Union {snd (FXf i)|i. i:J} |]
   ==> (J, FXf) >> i ==[(t rest-tr X,Yf)]==> j"
apply (simp add: isStrongRequestOf_def)
apply (rule isStateOf_subsetI)
apply (simp_all)
done

lemma isUngrantedRequestOf_subsetI:
  "[| (I, FXf) >> i --[(t,Yf)]-->o j; J <= I; i:J ; j:J ;
      X = Union {snd (FXf i)|i. i:J} |]
   ==> (J, FXf) >> i --[(t rest-tr X,Yf)]-->o j"
apply (simp add: isUngrantedRequestOf_def)
apply (rule isRequestOf_subsetI)
apply (simp_all)
done

lemma isUngrantedStrongRequestOf_subsetI:
  "[| (I, FXf) >> i ==[(t,Yf)]==>o j; J <= I; i:J ; j:J ;
      X = Union {snd (FXf i)|i. i:J} |]
   ==> (J, FXf) >> i ==[(t rest-tr X,Yf)]==>o j"
apply (simp add: isUngrantedStrongRequestOf_def)
apply (rule isStrongRequestOf_subsetI)
apply (simp_all)
done

lemma isUngrantedRequestOfwrt_subsetI:
  "[| (I, FXf) >> i --[(t,Yf), Lambda1]-->o j; J <= I; i:J ; j:J ;
      Lambda1 <= Lambda2 ; X = Union {snd (FXf i)|i. i:J} |]
   ==> (J, FXf) >> i --[(t rest-tr X,Yf), Lambda2]-->o j"
apply (simp add: isUngrantedRequestOfwrt_def)
apply (rule conjI)
apply (rule isUngrantedRequestOf_subsetI)
apply (simp_all)
apply (blast)
done

(*********************************************************
                      blocked
 *********************************************************)

(*---------------------------------*
 | lemma 1 [Roscoe_Dathi_1987 P.7] |
 *---------------------------------*)

(*** only if ***)

lemma Lemma1_Roscoe_Dathi_1987_only_if:
  "[| triple_disjoint (I,FXf) ; BusyNetwork (I,FXf) ;
      (t,Yf) isDeadlockStateOf (I,FXf) |]
   ==> ALL i:I. (I,FXf) >> i isBlockedIn (t,Yf)"
apply (intro ballI)
apply (subgoal_tac "ALL i:I. Yf i <= (Ev ` (snd (FXf i)))")
 apply (simp only: isBlockedIn_def)
  apply (rule conjI)
  apply (simp)
  apply (rule conjI)

 (* 1 *)

 (* busy --> i is deadlock-free *)
  apply (simp add: isRequestOf_def)
  apply (simp add: BusyNetwork_def)
  apply (drule_tac x="i" in bspec, simp)

  (* i is deadlock-free --> EX j *)
  apply (rule conjI)
  apply (simp add: isDeadlockStateOf_def)

  apply (simp add: isDeadlockStateOf_def)
  apply (simp add: disj_not1)
  apply (elim conjE)
  apply (drule_tac x="t rest-tr (snd (FXf i))" in spec)
  apply (drule_tac x="Yf" in spec)
  apply (simp add: isStateOf_each_element)
  apply (simp add: ALP_def)

  apply (subgoal_tac "EX a: Ev ` snd (FXf i). a ~: Yf i")
                                                  (* ... sub 1 *)
   apply (elim bexE)
   apply (subgoal_tac "a : Ev ` {a. EX i:I. a : snd (FXf i)}")
                                                  (* ... sub 2 *)
    apply (rotate_tac 4)
    apply (drule sym)
    apply (simp)
    apply (elim conjE exE)
    apply (simp)
    apply (rule_tac x="ia" in exI)
    apply (case_tac "i = ia", simp)
    apply (simp)
    apply (drule_tac x="ia" in bspec, simp)
    apply (blast)
   (* sub 2 *)
   apply (blast)
  (* sub 1 *)
  apply (blast)

(* 2 *)
 apply (intro allI impI)
 apply (unfold isUngrantedRequestOfwrt_def)
 apply (rule conjI)

 (* 2-1 *)
  apply (simp add: isUngrantedRequestOf_def)
  apply (rule)

  apply (subgoal_tac "x : Union {Yf i |i. i : I}")
   apply (simp)
   apply (elim conjE bexE exE)
   apply (case_tac "ia = i", simp)
   apply (case_tac "ia = j", simp)
   (* ia ~= i & ia ~= j ==> contradict with triple_dijoint *)
   apply (drule_tac x="ia" in bspec, simp)
   apply (simp add: isDeadlockStateOf_def isStateOf_def)
   apply (simp add: triple_disjoint_def)
   apply (drule_tac x="i" in bspec, simp)
   apply (drule_tac x="j" in bspec, simp add: isRequestOf_def)
   apply (drule_tac x="ia" in bspec, simp)
    apply (drule mp)
    apply (simp add: isRequestOf_def)
   apply (rotate_tac -1)
   apply (erule contrapos_pp)
   apply (blast)

  apply (simp add: isDeadlockStateOf_def)
  apply (simp add: ALP_def)
  apply (simp add: image_iff)
  apply (elim conjE bexE, simp)
  apply (rule_tac x="i" in bexI)
  apply (simp)
  apply (simp)

 (* 2-2 *)
  apply (rule)
  apply (simp add: VocabularyOf_def)
  apply (subgoal_tac "x : Union {Yf i |i. i : I}")

   apply (simp)
   apply (elim conjE bexE exE)
   apply (simp add: image_iff)
   apply (elim disjE conjE bexE)

    apply (case_tac "i = ia", simp)
    apply (drule_tac x="ia" in bspec, simp)
    apply (simp add: isDeadlockStateOf_def isStateOf_def)
    apply (rule_tac x="snd (FXf i) Int snd (FXf ia)" in exI)
    apply (rule conjI)
     apply (rule_tac x="i" in bexI)
     apply (rule_tac x="ia" in bexI)
     apply (simp)
     apply (simp)
     apply (simp)
     apply (blast)

    apply (case_tac "j = ia", simp)
    apply (drule_tac x="ia" in bspec, simp)
    apply (simp add: isDeadlockStateOf_def isStateOf_def)
    apply (rule_tac x="snd (FXf j) Int snd (FXf ia)" in exI)
    apply (rule conjI)
     apply (rule_tac x="j" in bexI)
     apply (rule_tac x="ia" in bexI)
     apply (simp)
     apply (simp)
     apply (simp add: isRequestOf_def)
     apply (blast)

  apply (simp add: isDeadlockStateOf_def)
  apply (simp add: ALP_def)
  apply (simp add: image_iff)
  apply (elim disjE conjE bexE)

   apply (rule_tac x="xa" in exI)
   apply (simp)
   apply (fast)

   apply (rule_tac x="xa" in exI)
   apply (simp)
   apply (rule_tac x="j" in bexI)
   apply (simp)
   apply (simp add: isRequestOf_def)

apply (simp add: isDeadlockStateOf_def)
apply (simp add: isStateOf_def)
done

(*** if ***)

lemma Lemma1_Roscoe_Dathi_1987_if:
  "[| triple_disjoint (I,FXf) ; BusyNetwork (I,FXf) ;
      (t,Yf) isStateOf (I,FXf) ;
      ALL i:I. (I,FXf) >> i isBlockedIn (t,Yf) |]
   ==> (t,Yf) isDeadlockStateOf (I,FXf)"
apply (simp add: isDeadlockStateOf_def)
apply (simp add: ALP_def)
apply (rule)

 (* <= *)
 apply (rule)
 apply (simp)
 apply (elim exE conjE)
 apply (simp)
 apply (drule_tac x="i" in bspec, simp)
 apply (simp add: isStateOf_def)
 apply (elim conjE)
 apply (drule_tac x="i" in bspec, simp)
 apply (simp add: ALP_def)
 apply (force)

 (* => *)
 apply (rule)
 apply (simp)
 apply (simp only: isBlockedIn_def)
 apply (simp add: image_iff)
 apply (elim conjE exE bexE)
 apply (simp)

 apply (case_tac "Ev xa : Yf i")
  apply (rule_tac x="Yf i" in exI)
  apply (fast)

 (* Ev xa ~: Yf i *)
  apply (subgoal_tac "xa : VocabularyOf (I,FXf)")
   apply (simp add: VocabularyOf_def)
   apply (elim conjE exE bexE)
   apply (simp)

   apply (case_tac "ia = i")
    apply (simp)
    apply (drule_tac x="i" in bspec, simp)
    apply (elim conjE exE)

    apply (drule_tac x="j" in spec)
    apply (drule mp)
    apply (simp add: isRequestOf_def)
    apply (blast)

    apply (simp add: isUngrantedRequestOfwrt_def)
    apply (simp add: isUngrantedRequestOf_def)
    apply (rule_tac x="Yf j" in exI)
    apply (fast)

   apply (case_tac "j = i")
    apply (simp)
    apply (drule_tac x="i" in bspec, simp)
    apply (elim conjE exE)
     apply (drule_tac x="ia" in spec)
     apply (drule mp)
     apply (simp add: isRequestOf_def)
     apply (blast)

     apply (simp add: isUngrantedRequestOfwrt_def)
     apply (simp add: isUngrantedRequestOf_def)
     apply (rule_tac x="Yf ia" in exI)
     apply (fast)

   (* ia ~= i; j ~= i; ia ~= j, but xa : snd (PXf i), ... *)
   apply (simp add: triple_disjoint_def)
   apply (drule_tac x="i" in bspec, simp)
   apply (rotate_tac -1)
   apply (drule_tac x="ia" in bspec, simp)
   apply (rotate_tac -1)
   apply (drule_tac x="j" in bspec, simp)
   apply (fast)

  (* xa : VocabularyOf VF *)
   apply (drule_tac x="i" in bspec, simp)
   apply (elim exE conjE)
   apply (drule_tac x="xb" in spec)
   apply (simp add: isUngrantedRequestOfwrt_def)
   apply (fast)
done

lemma Lemma1_Roscoe_Dathi_1987:
  "[| triple_disjoint (I,FXf) ; BusyNetwork (I,FXf) ;
      (t,Yf) isStateOf (I,FXf) |]
   ==> (t,Yf) isDeadlockStateOf (I,FXf)
       = (ALL i:I. (I,FXf) >> i isBlockedIn (t,Yf))"
apply (rule)
apply (simp add: Lemma1_Roscoe_Dathi_1987_only_if)
apply (simp add: Lemma1_Roscoe_Dathi_1987_if)
done

(****************** to add it again ******************)

declare disj_not1   [simp]
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
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 Auto_Separation_Algebra
imports "AutoCorres" "../../lib/sep_algebra/Separation_Algebra"
keywords "sep_instance" :: thy_goal
begin

lemmas sep_conj_def = Separation_Algebra.sep_algebra_class.sep_conj_def

instantiation "unit" ::  stronger_sep_algebra
   begin
       definition "zero_unit \<equiv> ()"
       definition "plus_unit  \<equiv> (\<lambda>h2 h2.  ()) :: unit \<Rightarrow> unit \<Rightarrow> unit"
       definition "sep_disj_unit \<equiv>(\<lambda>h1 h2. True) :: unit \<Rightarrow> unit \<Rightarrow> bool"
     instance
 apply (default)
   apply (clarsimp simp: zero_unit_def plus_unit_def sep_disj_unit_def)+
 done
end

instantiation "bool" ::  stronger_sep_algebra
   begin
       definition "zero_bool \<equiv> False"
       definition "plus_bool  \<equiv> (op \<or>)"
       definition "sep_disj_bool \<equiv> \<lambda>p q. p \<longrightarrow> \<not>q"
     instance
 apply (default)
   apply (auto simp: zero_bool_def plus_bool_def sep_disj_bool_def)+
 done
end

 instantiation "fun" :: (type,stronger_sep_algebra) stronger_sep_algebra
 begin
  definition "zero_fun   \<equiv> (\<lambda>x. 0)"
  definition "plus_fun f f'  \<equiv> (\<lambda>x. if f x = 0 then f' x else f x)"
  definition "sep_disj_fun   \<equiv> (\<lambda>f f'.  \<forall>x. (f x = 0 \<or> f' x = 0)) :: ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool "
 instance
  apply default
       apply (fastforce simp: zero_fun_def sep_disj_fun_def plus_fun_def)+
  apply (clarsimp simp: zero_fun_def sep_disj_fun_def plus_fun_def, safe)
     apply (fastforce)+
  done
end

ML {*
type sep_info =
{
  plus_thm : thm option,
  disj_thm : thm option,
  zero_thm : thm option,
  sep_thms : thm list,
  sep_heap_arrows : (term * thm) Typtab.table,
  sep_heap_getters : (term * thm) Typtab.table,
  sep_heap_setters : (term * thm) Typtab.table
}

fun mk_sep_info (plus_thm : thm option) (disj_thm : thm option) (zero_thm : thm option)
  (sep_heap_arrows : (term * thm) Typtab.table) (sep_heap_getters :  (term * thm) Typtab.table)
  ( sep_heap_setters : (term * thm) Typtab.table) (sep_thms : thm list) =
  {plus_thm = plus_thm,
   disj_thm = disj_thm,
   zero_thm = zero_thm,
   sep_thms = sep_thms,
   sep_heap_arrows = sep_heap_arrows,
   sep_heap_getters = sep_heap_getters,
   sep_heap_setters = sep_heap_setters}
*}

ML {*

fun upd_plus_thm (sep_info : sep_info) plus =
  {plus_thm = plus,
   disj_thm = #disj_thm sep_info,
   zero_thm = #zero_thm sep_info,
   sep_thms = #sep_thms sep_info,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = #sep_heap_setters sep_info}

fun upd_disj_thm (sep_info : sep_info) disj =
  {plus_thm = #plus_thm sep_info,
   disj_thm = disj,
   zero_thm = #zero_thm sep_info,
   sep_thms = #sep_thms sep_info,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = #sep_heap_setters sep_info}

fun upd_zero_thm (sep_info : sep_info) zero =
  {plus_thm = #plus_thm sep_info,
   disj_thm = #disj_thm sep_info,
   zero_thm = zero,
   sep_thms = #sep_thms sep_info,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = #sep_heap_setters sep_info}

fun upd_heap_arrows (sep_info : sep_info) arr =
  {plus_thm = #plus_thm sep_info,
   disj_thm = #disj_thm sep_info,
   zero_thm = #zero_thm sep_info,
   sep_heap_arrows = arr,
   sep_thms = #sep_thms sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = #sep_heap_setters sep_info}

fun upd_heap_getters (sep_info : sep_info) getters =
  {plus_thm = #plus_thm sep_info,
   disj_thm = #disj_thm sep_info,
   zero_thm = #zero_thm sep_info,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = getters,
   sep_thms = #sep_thms sep_info,
   sep_heap_setters = #sep_heap_setters sep_info}

fun upd_heap_setters (sep_info : sep_info) setters =
  {plus_thm = #plus_thm sep_info,
   disj_thm = #disj_thm sep_info,
   zero_thm = #zero_thm sep_info,
   sep_thms = #sep_thms sep_info,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = setters}

fun upd_thms (sep_info : sep_info) thms =
  {plus_thm = #plus_thm sep_info,
   disj_thm = #disj_thm sep_info,
   zero_thm = #zero_thm sep_info,
   sep_thms = thms,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = #sep_heap_setters sep_info
  }

*}

ML {* val print_type = dest_Type #> fst *}

ML {* fun mk_lifted_globals_record stateT rvals ctxt =
  let
      val xs =  rvals
      val state_t = "lifted_globals_ext" |> Syntax.read_term ctxt
  in
  betapplys (state_t, xs)
  |> Syntax.check_term ctxt
end;
 *}

ML {*
val get_data = HeapInfo.get #> Symtab.lookup;

*}

ML{*
fun zero_lifted_globals subT global_types heap_types  =
  let fun make_zero_heap heap_type = (@{mk_term "(\<lambda>(_ :: ?'T ptr). arbitrary_zero :: (?'T))" ('T)} heap_type)
      fun make_zero_valid_heap heap_type = (@{mk_term "(\<lambda>_. False) ::  ?'T ptr \<Rightarrow> bool" ('T)} heap_type)
      fun make_zero global_type = @{mk_term "arbitrary_zero :: ?'T" ('T)} global_type
  in
  map make_zero global_types @
  map make_zero_heap heap_types @
  map make_zero_valid_heap heap_types @
  [@{term "0\<^sub>? :: 'b"}] |>
  mk_lifted_globals_record subT
end;

val make_conj = @{mk_term "?P \<and> ?Q" (P, Q)}

val make_conj_list = foldr1 make_conj;

fun get_more ctxt t = "lifted_globals.more" |> Syntax.read_term ctxt
*}

declare [[ML_print_depth=1000]]

ML {*
fun promote subT (Const (str, typ))  =   Const (str, subT --> (typ |> range_type));
*}

ML {*

fun sep_disj_lifted_globals ctxt subT heap_types heap_valid_getters h1 h2 =
let
  fun make_valid_disjoint heap_type  =
     let val heap_valid_getter = Typtab.lookup heap_valid_getters heap_type |> the |> Const |> promote subT
         (* val heap_valid_getter' = Const (fst heap_valid_getter, subT  --> (heap_valid_getter |> snd |> range_type)) *)
     in
      @{mk_term "(\<lambda> l r. ?f l  ## (?f r)) " (f)} (heap_valid_getter) $ h1 $ h2
     end;
  val typ =  subT |> dest_Type |> snd |> hd;
  val more = get_more ctxt subT
  (* val more_disjoint = @{mk_term "\<lambda>(f :: ?'T => ?'M :: stronger_sep_algebra) (l:: ?'T) (r :: ?'T ).
               (f l) ## (f r)" ('T, 'M)} (subT, typ) $ more $ h1 $ h2 *)
  val is_valid_disjoint = map make_valid_disjoint heap_types
in
  make_conj_list is_valid_disjoint
end;
*}

ML {* fun setup_heap_zero stateT heap_type global_types sep_info ctxt  =
let
  val (_, thm, ctxt) = Utils.define_const_args "zero_lifted_globals_ext" false (zero_lifted_globals stateT global_types heap_type ctxt) [] ctxt
in
  (upd_zero_thm sep_info (SOME thm), ctxt)
end *}

ML {* fun setup_heap_disj stateT heap_types heap_valid_getters sep_info ctxt  =
let
  val term = sep_disj_lifted_globals ctxt stateT heap_types heap_valid_getters (Free ("s0", stateT)) (Free ("s1", stateT))
  val (_, thm, ctxt') = Utils.define_const_args "sep_disj_lifted_globals_ext" false (term) [("s0", stateT), ("s1", stateT)] ctxt
in
  (upd_disj_thm sep_info (SOME thm), ctxt')
end *}

ML{*
fun plus_lifted_globals ctxt subT global_names global_getters heap_types heap_getters heap_valid_getters h1 h2 =
let

 fun make_global_plus global_name =
  let val global_getter = global_name |> Symtab.lookup global_getters |> the |> snd |> promote subT

       in @{mk_term "\<lambda>l r. arbitrary_add (?f l) (?f r)"(f)} global_getter $ h1 $ h2 end;

 fun make_heap_plus heap_type  =
  let val heap_getter = heap_type |> Typtab.lookup heap_getters |> the |> Const |> promote subT
      val heap_valid_getter = heap_type |> Typtab.lookup heap_valid_getters |> the |> Const |> promote subT
   in
   (@{mk_term
       "\<lambda>l r.
        \<lambda>x.  if ?valid l x then ?heap l x else if ?valid r x then ?heap r x else
             arbitrary_add ( ?heap l x) ( ?heap r x) " (heap, valid)}
              (heap_getter, heap_valid_getter) $ h1 $ h2)
  end;

 fun make_heap_valid_plus heap_type =
    let val heap_valid_getter = heap_type |> Typtab.lookup heap_valid_getters |> the |> Const |> promote subT
    in
    (@{mk_term "\<lambda>l r.
      (?valid l) + (?valid r)" (valid)} heap_valid_getter $ h1 $ h2)
    end;
 val typ =  subT |> dest_Type |> snd |> hd;
 val more = get_more ctxt subT

in
   map make_global_plus global_names @
   map make_heap_plus heap_types @
   map make_heap_valid_plus heap_types  @
  [(@{mk_term "\<lambda>l r.
               arbitrary_add (?f l) (?f r)" (f)} (more) $ h1 $ h2)]  |>
   mk_lifted_globals_record subT
end;

*}

ML {*
fun setup_heap_plus stateT global_names global_getters heap_types heap_getters heap_valid_getters sep_info ctxt =
let
  val term = (plus_lifted_globals ctxt stateT global_names global_getters heap_types
              heap_getters heap_valid_getters (Free ("s0", stateT)) (Free ("s1", stateT)) ctxt)
  val (_, thm, ctxt') = Utils.define_const_args "plus_lifted_globals_ext" false term
                          [("s0", stateT), ("s1", stateT)] ctxt
in
  (upd_plus_thm sep_info (SOME thm), ctxt')
end;

*}

ML {*

   fun make_arrow stateT heap_type heap_getters heap_valid_getters p v=
      let
          val heap_getter = heap_type |> Typtab.lookup heap_getters |> the |> Const
          val heap_valid  = heap_type |> Typtab.lookup heap_valid_getters |> the |> Const
        in
           @{mk_term "\<lambda>p v s. ?h s p = v \<and> ?v' s p" (h, v')}
             (heap_getter, heap_valid) $ p $ v
    end;

    fun split_on _ [] = [] |
        split_on f (x::xs) = if f x then xs else split_on f xs ;

    filter;

  fun hds s = String.substring (s,0,1)

   fun setup_arrows stateT heap_types heap_getters heap_valid_getters sep_info ctxt =
    let
         val (arrowt, _, ctxt') =  Utils.define_const_args "sep_generic_arrow" true
                               (@{mk_term "undefined :: (?'h ptr => ?'h => ?'T \<Rightarrow> bool)" ('T, 'h) } (stateT, @{typ 'h})) [] ctxt
         val ctxt'' = Local_Theory.notation true Syntax.mode_default [(arrowt, Infixl ("\<mapsto>s", 50))] ctxt'
        fun setup_arrow (heap_type,(sep_info,ctxt)) =
         let
          val pointer = (Free ("p", Utils.gen_typ @{typ "'a ptr"} [heap_type]))
          val value = (Free ("v", heap_type))
          val term = (make_arrow stateT heap_type heap_getters heap_valid_getters pointer value)
          val arr_name = "sep_map_" ^  HeapLiftBase.name_from_type heap_type
          val arrow = "\<mapsto>"  ^ (HeapLiftBase.name_from_type heap_type |> hds)
          val fix = Infixl (arrow, 50)
          val (t , thm, ctxt') = Utils.define_const_args arr_name false term
               [("p", Utils.gen_typ @{typ "'a ptr"} [heap_type]) ,  ("v", heap_type) ] ctxt
          val ctxt'' = Local_Theory.notation true Syntax.mode_default [(t , fix)] ctxt'
          val genarrowstr = arrowt |> dest_Const |> fst
          val sep_info = sep_info |> #sep_heap_arrows |> Typtab.update (heap_type, (t,thm)) |> upd_heap_arrows sep_info
          in
           (sep_info, ctxt'' |>
           Local_Theory.declaration {syntax = true, pervasive = false} (K (Adhoc_Overloading.generic_add_overloaded genarrowstr )) |>
           Local_Theory.declaration {syntax = true, pervasive = false} (K (Adhoc_Overloading.generic_add_variant genarrowstr t)))
         end;
      in foldr setup_arrow (sep_info,ctxt'') heap_types
   end;

*}

ML {* Utils.expand_type_abbrevs; @{theory}; Proof_Context.theory_of;*}

ML {* fun liberalise_type _ (Type (s,[])) = (s,[]) |> Type |
          liberalise_type t (Type (s,(xs))) = if (Long_Name.base_name s) = "lifted_globals_ext" then
                                               (Type (s, t :: (tl xs))) else
                                               (Type (s, map (liberalise_type t) (xs)));
*}

ML {*

fun make_rewrite heap_getters heap_setters heap_type sep_info ctxt =
     let
         val heap_getter  = heap_type |> Typtab.lookup heap_getters |> the |> Const
         val heap_setter  = heap_type |> Typtab.lookup heap_setters |> the |> Const
         val get_heap_term = @{mk_term "gets (\<lambda>s. ?f s p) " (f)} (heap_getter)
         val set_heap_term = @{mk_term "modify (?f (\<lambda>a. a(p := v)))" (f)} heap_setter
         val (t, thy, ctxt) = Utils.define_const_args ("get_" ^ (HeapLiftBase.name_from_type heap_type)) false get_heap_term [("p", Utils.gen_typ @{typ "'a ptr"} [heap_type])] ctxt
         val (t', thy', ctxt) = Utils.define_const_args ("set_" ^ (HeapLiftBase.name_from_type heap_type)) false set_heap_term [("p", Utils.gen_typ @{typ "'a ptr"} [heap_type]), ("v", heap_type)] ctxt
         val localise_term =  @{mk_term "modify (\<lambda>s. ?f (\<lambda>a. a(p:= f s)) (s)) \<equiv> do v <- gets f; ?g p v od" (f,g)} (heap_setter, t')
         val localise_simps = @{thms modify_def gets_def put_def fun_upd_def get_def return_def bind_def }
         val localise_term' = @{mk_term "Trueprop (modify (\<lambda>s. ?f (\<lambda>a. a(p:= f a s)) s) = do a <- gets (\<lambda>s. f (?h s) s); ?g p a od)" (f,h,g)} (heap_setter, heap_getter, t')
         val prove_localise = force_tac
                          (ctxt addsimps localise_simps addsimps [thy'])
         val localise_thm = Goal.prove ctxt ["f", "p"] [] localise_term (fn _ => prove_localise 1)
         val localise'_thm = Goal.prove ctxt ["f", "p"] [] localise_term' (fn _ => prove_localise 1)
         val sep_info =  sep_info |> #sep_thms |> (fn x => x @ [localise_thm, localise'_thm, Thm.symmetric thy,Thm.symmetric thy']) |> upd_thms sep_info
         val sep_info =  sep_info |> #sep_heap_getters |> Typtab.update (heap_type, (t,thy)) |> upd_heap_getters sep_info
         val sep_info =  sep_info |> #sep_heap_setters |> Typtab.update (heap_type, (t',thy')) |> upd_heap_setters sep_info
    in
        (sep_info, ctxt)
end;

*}

ML {*
Utils.named_cterm_instantiate;

fun make_struct_rewrite (structs : HeapLiftBase.struct_info list) sep_info ctxt =
   let
       val structs = structs |> map #field_info |> List.concat
       fun make_struct_rewrite_inner strct =
       let val getter = strct |> #getter
           val setter = strct |> #setter
           val getter_rewrite_term = @{mk_term "Trueprop (gets (\<lambda>s. ?P (f s) ) =
                                                          do c <- gets f;
                                                             return (?P c )
                                                          od )" (P)} getter
           val getter_rewrite_term' = @{mk_term "Trueprop (gets (\<lambda>s a. ?P (f s) ) =
                                                           do c <- gets f;
                                                           return (\<lambda>a. ?P c ) od )" (P)} getter
           val setter_rewrite_term = @{mk_term "Trueprop (gets (\<lambda>s . ?P (f s) (g s)) =
                                                          do c <- gets f;
                                                             d <- gets g;
                                                             return ( ?P c d )
                                                          od )" (P)} setter
          val setter_rewrite_term' = @{mk_term "Trueprop (gets (\<lambda>s a . ?P (f s) (g s)) =
                                               do c <- gets f;
                                                  d <- gets g;
                                                  return (\<lambda>a. ?P c d )
                                               od )" (P)} setter
           val getter_rewrite = Goal.prove ctxt ["f"] [] getter_rewrite_term (fn _ => Skip_Proof.cheat_tac ctxt 1)
           val getter_rewrite' = Goal.prove ctxt ["f"] [] getter_rewrite_term' (fn _ => Skip_Proof.cheat_tac ctxt 1)
           val setter_rewrite = Goal.prove ctxt ["f", "g"] [] setter_rewrite_term (fn _ => Skip_Proof.cheat_tac ctxt 1)
           val setter_rewrite' = Goal.prove ctxt ["f", "g"] [] setter_rewrite_term' (fn _ => Skip_Proof.cheat_tac ctxt 1)
       in [setter_rewrite,setter_rewrite', getter_rewrite, getter_rewrite'] end;
     fun upd_sep_info_list info xs = info |> #sep_thms |> (fn x => x @ xs) |> upd_thms info
   in map make_struct_rewrite_inner structs |> List.concat |> upd_sep_info_list sep_info
end;

fun make_rewrites heap_types heap_getters heap_setters structs sep_info ctxt =
  let
    val (sep_info, ctxt) = foldr (fn (htype, (info, ctxt)) => (make_rewrite heap_getters heap_setters htype info ctxt) ) (sep_info,ctxt) heap_types
    val sep_info = (make_struct_rewrite structs sep_info ctxt)
    val thms= sep_info |> #sep_thms
  in
     (sep_info, Utils.define_lemmas "sep_thms" thms ctxt |> snd )
end;
*}

ML {* val myss = ref HOL_basic_ss *}
ML {* val mythm = ref @{thms iffI} *}

ML {* fun prove_get_leaf_lemma heap_type ((sep_info : sep_info),  ctxt) =
          let
              val (heap_getter, heap_getter_def) = heap_type |> Typtab.lookup (#sep_heap_getters sep_info) |> the
              val (heap_arrow, heap_arrow_def) = heap_type |> Typtab.lookup (#sep_heap_arrows sep_info) |> the
              val plus_thm = sep_info |> #plus_thm |> the
              val proof_term = @{mk_term
                                 " Trueprop (
                                 \<lbrace>\<lambda>s. (?arr p x \<and>* R) s\<rbrace>
                                              ?getter p
                                 \<lbrace>\<lambda>rv. pred_conj (?arr p x \<and>* R) ( K (rv = x))\<rbrace> )" (arr,getter)}
                                (heap_arrow, heap_getter)
               val thms =  [@{thm sep_conj_def},
                            @{thm pred_conj_def},
                            heap_getter_def, heap_arrow_def, plus_thm]
               val name = heap_getter |> dest_Const |> fst |> Long_Name.base_name
               fun proof_tac ctxt = fast_force_tac (ctxt addsimps thms)
               val get_wp = Goal.prove ctxt ["x", "p","R"] [] proof_term (fn _ => proof_tac ctxt 1)
       in (sep_info, Utils.define_lemma (name ^ "_wp") get_wp ctxt |> snd) end;  *}

ML {*
      fun prove_update_heap_lemma (heap_arrow, heap_arrow_def) heap_update  ctxt =
         let val proof_term = @{mk_term "((?arr p x) s \<Longrightarrow> (?arr p v) (?heap_update (\<lambda>s. fun_upd s p v) s))" (arr,heap_update)} (heap_arrow, heap_update)
             val proof = clarsimp_tac (ctxt addsimps [heap_arrow_def])
             in   Goal.prove ctxt ["x", "p", "v","s"] [] proof_term (fn x => proof 1)
      end;

      fun prove_set_leaf_lemma (heap_type, heap_updater) ((sep_info : sep_info),  ctxt) =
          let
              val (heap_setter, heap_setter_def) = heap_type |> Typtab.lookup (#sep_heap_setters sep_info) |> the
              val (heap_arrow, heap_arrow_def) = heap_type |> Typtab.lookup (#sep_heap_arrows sep_info) |> the
              val disj_thm = sep_info |> #disj_thm |> the
              val plus_thm = sep_info |> #plus_thm |> the
              val proof_term = @{mk_term
                                 " Trueprop (
                                 \<lbrace>\<lambda>s. (?arr p x \<and>* R) s\<rbrace>
                                              ?setter p v
                                 \<lbrace>\<lambda>rv. (?arr p v \<and>* R)\<rbrace> )" (arr,setter)}
                                (heap_arrow, heap_setter)
               val thms = @{thms fun_upd_def} @ [ heap_arrow_def, disj_thm, plus_thm]
               val name = heap_setter |> dest_Const |> fst |> Long_Name.base_name
               val heap_update_lemma = prove_update_heap_lemma (heap_arrow, heap_arrow_def) (heap_updater) ctxt
               fun proof_tac ctxt = clarsimp_tac (ctxt addsimps [heap_setter_def]) THEN'
                                    etac @{thm sep_conjE} THEN'
                                    rtac @{thm sep_conjI} THEN'
                                    etac heap_update_lemma THEN'
                                    fast_force_tac (ctxt) THEN_ALL_NEW
                                    fast_force_tac (ctxt addsimps thms)
               val set_wp = Goal.prove ctxt ["x", "p","R", "v"] [] proof_term (fn x =>  proof_tac (#context x) 1 )
       in (sep_info, Utils.define_lemma (name ^ "_wp") set_wp ctxt |> snd) end;  *}

ML {*

fun prove_get_leaf_lemmas heap_types sep_info ctxt =
    foldr (uncurry prove_get_leaf_lemma) (sep_info, ctxt) heap_types

fun prove_set_leaf_lemmas heap_types sep_info ctxt =
   foldr (uncurry prove_set_leaf_lemma) (sep_info, ctxt) heap_types

*}

ML {*
   fun force_tac ctxt =
      SELECT_GOAL
     (Classical.clarify_tac ctxt 1 THEN
      IF_UNSOLVED (Simplifier.asm_full_simp_tac ctxt 1) THEN
      ALLGOALS (Classical.first_best_tac ctxt))
   fun zipWith (x::xs) (y::ys) f = f x y :: zipWith xs ys f |
       zipWith _ _ _ = []

    fun tester str thy =
         let val data = get_data thy str |> the
             val typ = data  |> #globals_type |> print_type
             val stateT = data |> #globals_type |> dest_Type ||> (K [@{typ 'b}]) |> Type
             val heap_types = data  |> #heap_getters |> Typtab.dest |> map fst
             val heap_valid_getters = data  |> #heap_valid_getters
             val heap_getters = data |> #heap_getters
             val heap_setters = data |> #heap_setters
             val global_types =  data |> #global_fields |> map (fn (_,_,z) => z)
             val global_names =  data |> #global_fields |> map (fn (x,_,_) => x)
             val global_getters = data |> #global_field_getters
             val structs = data |> #structs |> Symtab.dest |> map snd
             val sep_info = mk_sep_info NONE NONE NONE Typtab.empty Typtab.empty Typtab.empty []
             fun tup_list (x : sep_info)
                            = [x |> #plus_thm |> the,
                               x |> #zero_thm |> the,
                               x |> #disj_thm |> the]
             fun proof_tac thms ctxt =
                 let
                     val equality =  Proof_Context.get_thm ctxt "lifted_globals.equality" ;
                     val simpset = ctxt addsimps @{thms sep_add_left_commute sep_disj_commute sep_add_assoc sep_add_commute
                                                       left_commute zero_fun_def plus_fun_def sep_disj_fun_def zero_bool_def
                                                       commute} addsimps thms
                     val intros = [equality, @{thm ext}]
                  in
                         Class.default_intro_tac ctxt [] THEN
                         ((resolve_tac ctxt intros  ORELSE'
                           force_tac simpset ) |> REPEAT_ALL_NEW |> TRYALL)
                end;
      in thy
      |>  Class.instantiation ([typ], [("'a", @{sort type})], @{sort stronger_sep_algebra})
      |>  setup_heap_zero stateT heap_types global_types sep_info
      |-> setup_heap_disj stateT heap_types heap_valid_getters
      |-> setup_heap_plus stateT global_names global_getters heap_types heap_getters heap_valid_getters
      |-> setup_arrows stateT heap_types heap_getters heap_valid_getters
      |-> make_rewrites heap_types heap_getters heap_setters structs
      |> (fn (info, ctxt) => (info, (info,ctxt) |> (apfst (tup_list #> proof_tac) #-> Class.prove_instantiation_instance)))
      |-> prove_get_leaf_lemmas heap_types
      |-> prove_set_leaf_lemmas (heap_setters |> Typtab.dest |> map (fn x => x ||> Const)) |> snd
      end;

Adhoc_Overloading.is_overloaded @{context} "\<mapsto>"
*}

ML {*
val _ =
  Outer_Syntax.command @{command_keyword "sep_instance"} "instantiate and prove type arity"
  (Parse.path >>
   (fn str =>  tester str |> Toplevel.begin_local_theory true #> Toplevel.end_local_theory));

(* get_data @{theory} "swap.c" |> the |> #structs *)
*}

end


theory ArityTransformSafe
imports ArityTransform ArityConsistent ArityAnalysisSpec ArityEtaExpansionSafe AbstractTransform ConstOn
begin

locale CardinalityArityTransformation = ArityAnalysisLetSafeNoCard
begin
  sublocale AbstractTransformBoundSubst
    "\<lambda> a . inc\<cdot>a"
    "\<lambda> a . pred\<cdot>a"
    "\<lambda> \<Delta> e a . (a, Aheap \<Delta> e\<cdot>a)"
    "fst"
    "snd"
    "\<lambda> _. 0"
    "Aeta_expand"
    "snd"
  apply standard
  apply (simp add: Aheap_subst)
  apply (rule subst_Aeta_expand)
  done

  abbreviation ccTransform where "ccTransform \<equiv> transform"

  lemma supp_transform: "supp (transform a e) \<subseteq> supp e"
    by (induction rule: transform.induct)
       (auto simp add: exp_assn.supp Let_supp dest!: set_mp[OF supp_map_transform] set_mp[OF supp_map_transform_step] )
  interpretation supp_bounded_transform transform
    by standard (auto simp add: fresh_def supp_transform)

  fun transform_alts :: "Arity list \<Rightarrow> stack \<Rightarrow> stack"
    where
      "transform_alts _ [] = []"
    | "transform_alts (a#as) (Alts e1 e2 # S) = (Alts (ccTransform a e1) (ccTransform a e2)) # transform_alts as S"
    | "transform_alts as (x # S) = x # transform_alts as S"

  lemma transform_alts_Nil[simp]: "transform_alts [] S = S"
    by (induction  S) auto

  lemma Astack_transform_alts[simp]:
    "Astack (transform_alts as S) = Astack S"
   by (induction rule: transform_alts.induct) auto

  lemma fresh_star_transform_alts[intro]: "a \<sharp>* S \<Longrightarrow> a \<sharp>* transform_alts as S"
   by (induction as S  rule: transform_alts.induct) (auto simp add: fresh_star_Cons)

  fun a_transform :: "astate \<Rightarrow> conf \<Rightarrow> conf"
  where "a_transform (ae, a, as) (\<Gamma>, e, S) =
    (map_transform Aeta_expand ae (map_transform ccTransform ae \<Gamma>),
     ccTransform a e,
     transform_alts as  S)"

  fun restr_conf :: "var set \<Rightarrow> conf \<Rightarrow> conf"
    where "restr_conf V (\<Gamma>, e, S) = (restrictA V \<Gamma>, e, restr_stack V S)"

  inductive consistent :: "astate \<Rightarrow> conf \<Rightarrow> bool" where
    consistentI[intro!]:
    "a_consistent (ae, a, as) (\<Gamma>, e, S)
    \<Longrightarrow> (\<And> x. x \<in> thunks \<Gamma> \<Longrightarrow>  ae x = up\<cdot>0)
    \<Longrightarrow> consistent (ae, a, as) (\<Gamma>, e, S)"
  inductive_cases consistentE[elim!]: "consistent (ae, a, as) (\<Gamma>, e, S)"

  lemma closed_consistent:
    assumes "fv e = ({}::var set)"
    shows "consistent (\<bottom>, 0, []) ([], e, [])"
  by (auto simp add: edom_empty_iff_bot closed_a_consistent[OF assms])

  lemma arity_tranform_safe:
    fixes c c'
    assumes "c \<Rightarrow>\<^sup>* c'" and "\<not> boring_step c'" and "heap_upds_ok_conf c" and "consistent (ae,a,as) c"
    shows "\<exists>ae' a' as'. consistent (ae',a',as') c' \<and> a_transform (ae,a,as) c \<Rightarrow>\<^sup>* a_transform (ae',a',as') c'"
  using assms(1,2) heap_upds_ok_invariant assms(3-)
  proof(induction c c' arbitrary: ae a as rule:step_invariant_induction)
  case (app\<^sub>1 \<Gamma> e x S)
    from app\<^sub>1 have "consistent (ae, inc\<cdot>a, as) (\<Gamma>, e, Arg x # S)"
      by (auto intro: a_consistent_app\<^sub>1)
    moreover
    have "a_transform (ae, a, as) (\<Gamma>, App e x, S) \<Rightarrow> a_transform (ae, inc\<cdot>a, as) (\<Gamma>, e, Arg x # S)"
      by simp rule
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
  case (app\<^sub>2 \<Gamma> y e x S)
    have "consistent (ae, pred\<cdot>a, as) (\<Gamma>, e[y::=x], S)" using app\<^sub>2
      by (auto 4 3 intro: a_consistent_app\<^sub>2)
    moreover
    have "a_transform (ae, a, as) (\<Gamma>, Lam [y]. e, Arg x # S) \<Rightarrow> a_transform (ae, pred \<cdot> a, as) (\<Gamma>, e[y::=x], S)" by (simp add: subst_transform[symmetric]) rule
    ultimately
    show ?case by (blast  del: consistentI consistentE)
  next
  case (thunk \<Gamma> x e S)
    hence "x \<in> thunks \<Gamma>" by auto
    hence [simp]: "x \<in> domA \<Gamma>" by (rule set_mp[OF thunks_domA])

    from `heap_upds_ok_conf (\<Gamma>, Var x, S)`
    have "x \<notin> upds S"  by (auto dest!: heap_upds_okE)

    have "x \<in> edom ae" using thunk by auto
    have "ae x = up\<cdot>0" using thunk `x \<in> thunks \<Gamma>` by (auto)

    have "a_consistent (ae, 0, as) (delete x \<Gamma>, e, Upd x # S)" using thunk `ae x = up\<cdot>0`
      by (auto intro!: a_consistent_thunk_0 simp del: restr_delete)
    hence "consistent (ae, 0, as) (delete x \<Gamma>, e, Upd x # S)" using thunk `ae x = up\<cdot>0`
      by (auto simp add:  restr_delete_twist)
    moreover

    from  `map_of \<Gamma> x = Some e` `ae x = up\<cdot>0`
    have "map_of (map_transform Aeta_expand ae (map_transform ccTransform ae \<Gamma>)) x = Some (transform 0 e)"
      by (simp add: map_of_map_transform)
    with `\<not> isVal e`
    have "a_transform (ae, a, as) (\<Gamma>, Var x, S) \<Rightarrow> a_transform (ae, 0, as) (delete x \<Gamma>, e, Upd x # S)"
      by (auto simp add: map_transform_delete restr_delete_twist intro!: step.intros  simp del: restr_delete)
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
  case (lamvar \<Gamma> x e S)
    from lamvar(1) have [simp]: "x \<in> domA \<Gamma>" by (metis domI dom_map_of_conv_domA)

    have "up\<cdot>a \<sqsubseteq> (Aexp (Var x)\<cdot>a f|` (domA \<Gamma> \<union> upds S)) x"
      by (simp) (rule Aexp_Var)
    also from lamvar have "Aexp (Var x)\<cdot>a f|` (domA \<Gamma> \<union> upds S) \<sqsubseteq> ae" by (auto simp add: join_below_iff env_restr_join a_consistent.simps)
    finally
    obtain u where "ae x = up\<cdot>u" by (cases "ae x") (auto simp add: edom_def)
    hence "x \<in> edom ae" by (auto simp add: edomIff)

    have "a_consistent (ae, u, as) ((x,e) # delete x \<Gamma>, e, S)" using lamvar `ae x = up\<cdot>u`
      by (auto intro!: a_consistent_lamvar simp del: restr_delete)
    hence "consistent (ae, u, as) ((x, e) # delete x \<Gamma>, e, S)"
      using lamvar by (auto simp add:  thunks_Cons restr_delete_twist elim: below_trans)
    moreover

    from `a_consistent _ _`
    have "Astack (transform_alts as S) \<sqsubseteq> u" by (auto elim: a_consistent_stackD)

    {
    from `isVal e`
    have "isVal (transform u e)" by simp
    hence "isVal (Aeta_expand u (transform u e))" by (rule isVal_Aeta_expand)
    moreover
    from  `map_of \<Gamma> x = Some e`  `ae x = up \<cdot> u`  `isVal (transform u e)`
    have "map_of (map_transform Aeta_expand ae (map_transform transform ae \<Gamma>)) x = Some (Aeta_expand u (transform u e))"
      by (simp add: map_of_map_transform)
    ultimately
    have "a_transform (ae, a, as) (\<Gamma>, Var x, S) \<Rightarrow>\<^sup>*
          ((x, Aeta_expand u (transform u e)) # delete x (map_transform Aeta_expand ae (map_transform transform ae \<Gamma>)), Aeta_expand u (transform u e), transform_alts as S)"
       by (auto intro: lambda_var simp del: restr_delete)
    also have "\<dots> = ((map_transform Aeta_expand ae (map_transform transform ae ((x,e) # delete x \<Gamma>))), Aeta_expand u (transform u e), transform_alts as S)"
      using `ae x = up \<cdot> u` `isVal (transform u e)`
      by (simp add: map_transform_Cons map_transform_delete  del: restr_delete)
    also(subst[rotated]) have "\<dots> \<Rightarrow>\<^sup>* a_transform (ae, u, as) ((x, e) # delete x \<Gamma>, e, S)"
      by (simp add: restr_delete_twist) (rule Aeta_expand_safe[OF `Astack _ \<sqsubseteq> u`])
    finally(rtranclp_trans)
    have "a_transform (ae, a, as) (\<Gamma>, Var x, S) \<Rightarrow>\<^sup>* a_transform (ae, u, as) ((x, e) # delete x \<Gamma>, e, S)".
    }
    ultimately show ?case by (blast del: consistentI consistentE)
  next
  case (var\<^sub>2 \<Gamma> x e S)
    from var\<^sub>2
    have "a_consistent (ae, a, as) (\<Gamma>, e, Upd x # S)" by auto
    from a_consistent_UpdD[OF this]
    have "ae x = up\<cdot>0" and "a = 0".

    have "a_consistent (ae, a, as) ((x, e) # \<Gamma>, e, S)"
      using var\<^sub>2 by (auto intro!: a_consistent_var\<^sub>2)
    hence "consistent (ae, 0, as) ((x, e) # \<Gamma>, e, S)"
      using var\<^sub>2 `a = 0`
      by (auto simp add: thunks_Cons elim: below_trans)
    moreover
    have "a_transform (ae, a, as) (\<Gamma>, e, Upd x # S) \<Rightarrow> a_transform (ae, 0, as) ((x, e) # \<Gamma>, e, S)"
      using `ae x = up\<cdot>0` `a = 0` var\<^sub>2
      by (auto intro!: step.intros simp add: map_transform_Cons)
    ultimately show ?case by (blast del: consistentI consistentE)
  next
    case (let\<^sub>1 \<Delta> \<Gamma> e S)
    let ?ae = "Aheap \<Delta> e\<cdot>a"

    have "domA \<Delta> \<inter> upds S = {}" using fresh_distinct_fv[OF let\<^sub>1(2)] by (auto dest: set_mp[OF ups_fv_subset])
    hence *: "\<And> x. x \<in> upds S \<Longrightarrow> x \<notin> edom ?ae" by (auto simp add:  dest!: set_mp[OF edom_Aheap])
    have restr_stack_simp2: "restr_stack (edom (?ae \<squnion> ae)) S = restr_stack (edom ae) S"
      by (auto intro: restr_stack_cong dest!: *)

    have "edom ae \<subseteq> domA \<Gamma> \<union> upds S" using let\<^sub>1 by (auto dest!: a_consistent_edom_subsetD)
    from set_mp[OF this] fresh_distinct[OF let\<^sub>1(1)] fresh_distinct_fv[OF let\<^sub>1(2)]
    have "edom ae \<inter> domA \<Delta> = {}" by (auto dest: set_mp[OF ups_fv_subset])

    {
    { fix x e'
      assume "x \<in> thunks \<Gamma>"
      with let\<^sub>1
      have "(?ae \<squnion> ae) x = up\<cdot>0" by auto
    }
    moreover
    { fix x e'
      assume "x \<in> thunks \<Delta>"
      hence "(?ae \<squnion> ae) x = up\<cdot>0" by (auto simp add: Aheap_heap3)
    }
    moreover

    have "a_consistent (ae, a, as) (\<Gamma>, Let \<Delta> e, S)"
      using let\<^sub>1 by auto
    hence "a_consistent (?ae \<squnion> ae, a, as) (\<Delta> @ \<Gamma>, e, S)"
      using let\<^sub>1(1,2) `edom ae \<inter> domA \<Delta> = {}`
      by (auto intro!:  a_consistent_let simp del: join_comm)
    ultimately
    have "consistent (?ae \<squnion> ae, a, as) (\<Delta> @ \<Gamma>, e, S)"
      by auto
    }
    moreover
    {
      have "\<And> x. x \<in> domA \<Gamma> \<Longrightarrow> x \<notin> edom ?ae"
        using fresh_distinct[OF let\<^sub>1(1)]
        by (auto dest!: set_mp[OF edom_Aheap])
      hence "map_transform Aeta_expand (?ae \<squnion> ae) (map_transform transform (?ae \<squnion> ae) \<Gamma>)
         = map_transform Aeta_expand ae (map_transform transform ae \<Gamma>)"
         by (auto intro!: map_transform_cong restrictA_cong simp add: edomIff)
      moreover

      from `edom ae \<subseteq> domA \<Gamma> \<union> upds S`
      have  "\<And> x. x \<in> domA \<Delta> \<Longrightarrow> x \<notin> edom ae"
         using fresh_distinct[OF let\<^sub>1(1)] fresh_distinct_fv[OF let\<^sub>1(2)]
         by (auto dest!:  set_mp[OF ups_fv_subset])
      hence "map_transform Aeta_expand (?ae \<squnion> ae) (map_transform transform (?ae \<squnion> ae) \<Delta>)
         = map_transform Aeta_expand ?ae (map_transform transform ?ae \<Delta>)"
         by (auto intro!: map_transform_cong restrictA_cong simp add: edomIff)
      ultimately

      have "a_transform (ae, a, as) (\<Gamma>, Let \<Delta> e, S) \<Rightarrow> a_transform (?ae \<squnion> ae,  a, as) (\<Delta> @ \<Gamma>, e, S)"
        using restr_stack_simp2 let\<^sub>1(1,2)
        apply (auto simp add: map_transform_append restrictA_append  restr_stack_simp2[simplified] map_transform_restrA)
        apply (rule step.let\<^sub>1)
        apply (auto dest: set_mp[OF edom_Aheap])
        done
    }
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
    case (if\<^sub>1 \<Gamma> scrut e1 e2 S)
    have "consistent (ae, 0, a#as) (\<Gamma>, scrut, Alts e1 e2 # S)"
      using if\<^sub>1  by (auto dest: a_consistent_if\<^sub>1)
    moreover
    have "a_transform (ae,  a, as) (\<Gamma>, scrut ? e1 : e2, S) \<Rightarrow> a_transform (ae, 0, a#as) (\<Gamma>, scrut, Alts e1 e2 # S)"
      by (auto intro: step.intros)
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
    case (if\<^sub>2 \<Gamma> b e1 e2 S)
    hence "a_consistent (ae, a, as) (\<Gamma>, Bool b, Alts e1 e2 # S)" by auto
    then  obtain a' as' where [simp]: "as = a' # as'" "a = 0"
      by (rule a_consistent_alts_on_stack)

    have "consistent (ae, a', as') (\<Gamma>, if b then e1 else e2, S)"
      using if\<^sub>2 by (auto dest!: a_consistent_if\<^sub>2)
    moreover
    have "a_transform (ae, a, as) (\<Gamma>, Bool b, Alts e1 e2 # S) \<Rightarrow> a_transform (ae,  a', as') (\<Gamma>, if b then e1 else e2, S)"
      by (auto intro: step.if\<^sub>2[where b = True, simplified] step.if\<^sub>2[where b = False, simplified])
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
    case refl thus ?case by auto
  next
    case (trans c c' c'')
      from trans(3)[OF trans(5)]
      obtain ae' a' as' where "consistent (ae', a', as') c'" and *: "a_transform (ae, a, as) c \<Rightarrow>\<^sup>* a_transform (ae', a', as') c'" by blast
      from trans(4)[OF this(1)]
      obtain ae'' a'' as'' where "consistent (ae'', a'', as'') c''" and **: "a_transform (ae', a', as') c' \<Rightarrow>\<^sup>* a_transform (ae'', a'', as'') c''" by blast
      from this(1) rtranclp_trans[OF * **]
      show ?case by blast
  qed
end

end


section {* Soundness Theorems *}

theory Wasm_Soundness imports Main Wasm_Properties begin

theorem preservation:
  assumes "\<turnstile>_i s;vs;es : (tr,ts)"
          "\<lparr>s;vs;es\<rparr> a\<leadsto>_i \<lparr>s';vs';es'\<rparr>"
  shows "\<turnstile>_i s';vs';es' : (tr,ts)"
proof -
  obtain \<S> where "store_typing s \<S>" "\<S>\<bullet>tr\<bullet>None \<tturnstile>_i vs;es : ts"
    using assms(1) config_typing.simps
    by blast
  hence "store_typing s' \<S>" "\<S>\<bullet>tr\<bullet>None \<tturnstile>_i vs';es' : ts"
    using assms(2) store_preserved types_preserved_e
    by simp_all
  thus ?thesis
    using config_typing.intros
    by blast
qed

theorem progress:
  assumes "\<turnstile>_i s;vs;es : (tr,ts)"
  shows "const_list es \<or> es = [Trap] \<or> (\<exists>a s' vs' es'. \<lparr>s;vs;es\<rparr> a\<leadsto>_i \<lparr>s';vs';es'\<rparr>)"
proof -
  obtain \<S> where "store_typing s \<S>" "\<S>\<bullet>tr\<bullet>None \<tturnstile>_i vs;es : ts"
    using assms config_typing.simps
    by blast
  thus ?thesis
    using progress_e3
    by blast
qed

end