header {* \isaheader{Slicing guarantees IFC Noninterference} *}

theory NonInterferenceIntra imports
  "../Slicing/StaticIntra/Slice"
  "../Slicing/Basic/CFGExit_wf"
begin

section {* Assumptions of this Approach *}

text {*
Classical IFC noninterference, a special case of a noninterference
definition using partial equivalence relations (per)
\cite{SabelfeldS:01}, partitions the variables (i.e.\ locations) into
security levels. Usually, only levels for secret or high, written
@{text H}, and public or low, written @{text L}, variables are
used. Basically, a program that is noninterferent has to fulfil one
basic property: executing the program in two different initial states
that may differ in the values of their @{text H}-variables yields two
final states that again only differ in the values of their
@{text H}-variables; thus the values of the @{text H}-variables did not
influence those of the @{text L}-variables.

Every per-based approach makes certain
assumptions: (i) all \mbox{@{text H}-variables} are defined at the
beginning of the program, (ii) all @{text L}-variables are observed (or
used in our terms) at the end and (iii) every variable is either
@{text H} or @{text L}. This security label is fixed for a variable
and can not be altered during a program run. Thus, we have to extend
the prerequisites of the slicing framework in \cite{Wasserrab:08} accordingly
in a new locale:

*}

locale NonInterferenceIntraGraph =
  BackwardSlice sourcenode targetnode kind valid_edge Entry Def Use state_val
  backward_slice +
  CFGExit_wf sourcenode targetnode kind valid_edge Entry Def Use state_val Exit
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") and Def :: "'node \<Rightarrow> 'var set"
  and Use :: "'node \<Rightarrow> 'var set" and state_val :: "'state \<Rightarrow> 'var \<Rightarrow> 'val"
  and backward_slice :: "'node set \<Rightarrow> 'node set"
  and Exit :: "'node" ("'('_Exit'_')") +
  fixes H :: "'var set"
  fixes L :: "'var set"
  fixes High :: "'node"  ("'('_High'_')")
  fixes Low :: "'node"   ("'('_Low'_')")
  assumes Entry_edge_Exit_or_High:
  "\<lbrakk>valid_edge a; sourcenode a = (_Entry_)\<rbrakk>
    \<Longrightarrow> targetnode a = (_Exit_) \<or> targetnode a = (_High_)"
  and High_target_Entry_edge:
  "\<exists>a. valid_edge a \<and> sourcenode a = (_Entry_) \<and> targetnode a = (_High_) \<and>
       kind a = (\<lambda>s. True)\<^sub>\<surd>"
  and Entry_predecessor_of_High:
  "\<lbrakk>valid_edge a; targetnode a = (_High_)\<rbrakk> \<Longrightarrow> sourcenode a = (_Entry_)"
  and Exit_edge_Entry_or_Low: "\<lbrakk>valid_edge a; targetnode a = (_Exit_)\<rbrakk>
    \<Longrightarrow> sourcenode a = (_Entry_) \<or> sourcenode a = (_Low_)"
  and Low_source_Exit_edge:
  "\<exists>a. valid_edge a \<and> sourcenode a = (_Low_) \<and> targetnode a = (_Exit_) \<and>
       kind a = (\<lambda>s. True)\<^sub>\<surd>"
  and Exit_successor_of_Low:
  "\<lbrakk>valid_edge a; sourcenode a = (_Low_)\<rbrakk> \<Longrightarrow> targetnode a = (_Exit_)"
  and DefHigh: "Def (_High_) = H"
  and UseHigh: "Use (_High_) = H"
  and UseLow: "Use (_Low_) = L"
  and HighLowDistinct: "H \<inter> L = {}"
  and HighLowUNIV: "H \<union> L = UNIV"

begin

lemma Low_neq_Exit: assumes "L \<noteq> {}" shows "(_Low_) \<noteq> (_Exit_)"
proof
  assume "(_Low_) = (_Exit_)"
  have "Use (_Exit_) = {}" by fastforce
  with UseLow `L \<noteq> {}` `(_Low_) = (_Exit_)` show False by simp
qed

lemma Entry_path_High_path:
  assumes "(_Entry_) -as\<rightarrow>* n" and "inner_node n"
  obtains a' as' where "as = a'#as'" and "(_High_) -as'\<rightarrow>* n"
  and "kind a' = (\<lambda>s. True)\<^sub>\<surd>"
proof(atomize_elim)
  from `(_Entry_) -as\<rightarrow>* n` `inner_node n`
  show "\<exists>a' as'. as = a'#as' \<and> (_High_) -as'\<rightarrow>* n \<and> kind a' = (\<lambda>s. True)\<^sub>\<surd>"
  proof(induct n'\<equiv>"(_Entry_)" as n rule:path.induct)
    case (Cons_path n'' as n' a)
    from `n'' -as\<rightarrow>* n'` `inner_node n'` have "n'' \<noteq> (_Exit_)"
      by(fastforce simp:inner_node_def)
    with `valid_edge a` `targetnode a = n''` `sourcenode a = (_Entry_)`
    have "n'' = (_High_)" by -(drule Entry_edge_Exit_or_High,auto)
    from High_target_Entry_edge
    obtain a' where "valid_edge a'" and "sourcenode a' = (_Entry_)"
      and "targetnode a' = (_High_)" and "kind a' = (\<lambda>s. True)\<^sub>\<surd>"
      by blast
    with `valid_edge a` `sourcenode a = (_Entry_)` `targetnode a = n''`
      `n'' = (_High_)`
    have "a = a'" by(auto dest:edge_det)
    with `n'' -as\<rightarrow>* n'` `n'' = (_High_)` `kind a' = (\<lambda>s. True)\<^sub>\<surd>` show ?case by blast
  qed fastforce
qed

lemma Exit_path_Low_path:
  assumes "n -as\<rightarrow>* (_Exit_)" and "inner_node n"
  obtains a' as' where "as = as'@[a']" and "n -as'\<rightarrow>* (_Low_)"
  and "kind a' = (\<lambda>s. True)\<^sub>\<surd>"
proof(atomize_elim)
  from `n -as\<rightarrow>* (_Exit_)`
  show "\<exists>as' a'. as = as'@[a'] \<and> n -as'\<rightarrow>* (_Low_) \<and> kind a' = (\<lambda>s. True)\<^sub>\<surd>"
  proof(induct as rule:rev_induct)
    case Nil
    with `inner_node n` show ?case by fastforce
  next
    case (snoc a' as')
    from `n -as'@[a']\<rightarrow>* (_Exit_)`
    have "n -as'\<rightarrow>* sourcenode a'" and "valid_edge a'" and "targetnode a' = (_Exit_)"
      by(auto elim:path_split_snoc)
    { assume "sourcenode a' = (_Entry_)"
      with `n -as'\<rightarrow>* sourcenode a'` have "n = (_Entry_)"
        by(blast intro!:path_Entry_target)
      with `inner_node n` have False by(simp add:inner_node_def) }
    with `valid_edge a'` `targetnode a' = (_Exit_)` have "sourcenode a' = (_Low_)"
      by(blast dest!:Exit_edge_Entry_or_Low)
    from Low_source_Exit_edge
    obtain ax where "valid_edge ax" and "sourcenode ax = (_Low_)"
      and "targetnode ax = (_Exit_)" and "kind ax = (\<lambda>s. True)\<^sub>\<surd>"
      by blast
    with `valid_edge a'` `targetnode a' = (_Exit_)` `sourcenode a' = (_Low_)`
    have "a' = ax" by(fastforce intro:edge_det)
    with `n -as'\<rightarrow>* sourcenode a'` `sourcenode a' = (_Low_)` `kind ax = (\<lambda>s. True)\<^sub>\<surd>`
    show ?case by blast
  qed
qed

lemma not_Low_High: "V \<notin> L \<Longrightarrow> V \<in> H"
  using HighLowUNIV
  by fastforce

lemma not_High_Low: "V \<notin> H \<Longrightarrow> V \<in> L"
  using HighLowUNIV
  by fastforce

section {* Low Equivalence *}

text {*
In classical noninterference, an external observer can only see public values,
in our case the @{text L}-variables. If two states agree in the values of all
@{text L}-variables, these states are indistinguishable for him.
\emph{Low equivalence} groups those states in an equivalence class using
the relation @{text "\<approx>\<^sub>L"}:
*}

definition lowEquivalence :: "'state \<Rightarrow> 'state \<Rightarrow> bool" (infixl "\<approx>\<^sub>L" 50)
  where "s \<approx>\<^sub>L s' \<equiv> \<forall>V \<in> L. state_val s V = state_val s' V"

text {* The following lemmas connect low equivalent states with
relevant variables as necessary in the correctness proof for slicing. *}

lemma relevant_vars_Entry:
  assumes "V \<in> rv S (_Entry_)" and "(_High_) \<notin> backward_slice S"
  shows "V \<in> L"
proof -
  from `V \<in> rv S (_Entry_)` obtain as n' where "(_Entry_) -as\<rightarrow>* n'"
    and "n' \<in> backward_slice S" and "V \<in> Use n'"
    and "\<forall>nx \<in> set(sourcenodes as). V \<notin> Def nx" by(erule rvE)
  from `(_Entry_) -as\<rightarrow>* n'` have "valid_node n'" by(rule path_valid_node)
  thus ?thesis
  proof(cases n' rule:valid_node_cases)
    case Entry
    with `V \<in> Use n'` have False by(simp add:Entry_empty)
    thus ?thesis by simp
  next
    case Exit
    with `V \<in> Use n'` have False by(simp add:Exit_empty)
    thus ?thesis by simp
  next
    case inner
    with `(_Entry_) -as\<rightarrow>* n'` obtain a' as' where "as = a'#as'"
      and "(_High_) -as'\<rightarrow>* n'" by -(erule Entry_path_High_path)
    from `(_Entry_) -as\<rightarrow>* n'` `as = a'#as'`
    have "sourcenode a' = (_Entry_)" by(fastforce elim:path.cases)
    show ?thesis
    proof(cases "as' = []")
      case True
      with `(_High_) -as'\<rightarrow>* n'` have "n' = (_High_)" by fastforce
      with `n' \<in> backward_slice S` `(_High_) \<notin> backward_slice S`
      have False by simp
      thus ?thesis by simp
    next
      case False
      with `(_High_) -as'\<rightarrow>* n'` have "hd (sourcenodes as') = (_High_)"
        by(rule path_sourcenode)
      from False have "hd (sourcenodes as') \<in> set (sourcenodes as')"
        by(fastforce intro:hd_in_set simp:sourcenodes_def)
      with `as = a'#as'` have "hd (sourcenodes as') \<in> set (sourcenodes as)"
        by(simp add:sourcenodes_def)
      with `hd (sourcenodes as') = (_High_)` `\<forall>nx \<in> set(sourcenodes as). V \<notin> Def nx`
      have "V \<notin> Def (_High_)" by fastforce
      hence "V \<notin> H" by(simp add:DefHigh)
      thus ?thesis by(rule not_High_Low)
    qed
  qed
qed

lemma lowEquivalence_relevant_nodes_Entry:
  assumes "s \<approx>\<^sub>L s'" and "(_High_) \<notin> backward_slice S"
  shows "\<forall>V \<in> rv S (_Entry_). state_val s V = state_val s' V"
proof
  fix V assume "V \<in> rv S (_Entry_)"
  with `(_High_) \<notin> backward_slice S` have "V \<in> L" by -(rule relevant_vars_Entry)
  with `s \<approx>\<^sub>L s'` show "state_val s V = state_val s' V" by(simp add:lowEquivalence_def)
qed

lemma rv_Low_Use_Low:
  assumes "(_Low_) \<in> S"
  shows "\<lbrakk>n -as\<rightarrow>* (_Low_); n -as'\<rightarrow>* (_Low_);
    \<forall>V \<in> rv S n. state_val s V = state_val s' V;
    preds (slice_kinds S as) s; preds (slice_kinds S as') s'\<rbrakk>
  \<Longrightarrow> \<forall>V \<in> Use (_Low_). state_val (transfers (slice_kinds S as) s) V =
                       state_val (transfers (slice_kinds S as') s') V"
proof(induct n as n\<equiv>"(_Low_)" arbitrary:as' s s' rule:path.induct)
  case empty_path
  { fix V assume "V \<in> Use (_Low_)"
    moreover
    from `valid_node (_Low_)` have "(_Low_) -[]\<rightarrow>* (_Low_)"
      by(fastforce intro:path.empty_path)
    moreover
    from `valid_node (_Low_)` `(_Low_) \<in> S` have "(_Low_) \<in> backward_slice S"
      by(fastforce intro:refl)
    ultimately have "V \<in> rv S (_Low_)"
      by(fastforce intro:rvI simp:sourcenodes_def) }
  hence "\<forall>V \<in> Use (_Low_). V \<in> rv S (_Low_)" by simp
  show ?case
  proof(cases "L = {}")
    case True with UseLow show ?thesis by simp
  next
    case False
    from `(_Low_) -as'\<rightarrow>* (_Low_)` have "as' = []"
    proof(induct n\<equiv>"(_Low_)" as' n'\<equiv>"(_Low_)" rule:path.induct)
      case (Cons_path n'' as a)
      from `valid_edge a` `sourcenode a = (_Low_)`
      have "targetnode a = (_Exit_)" by -(rule Exit_successor_of_Low,simp+)
      with `targetnode a = n''` `n'' -as\<rightarrow>* (_Low_)`
      have "(_Low_) = (_Exit_)" by -(rule path_Exit_source,fastforce)
      with False have False by -(drule Low_neq_Exit,simp)
      thus ?case by simp
    qed simp
    with `\<forall>V \<in> Use (_Low_). V \<in> rv S (_Low_)`
      `\<forall>V\<in>rv S (_Low_). state_val s V = state_val s' V`
    show ?thesis by(auto simp:slice_kinds_def)
  qed
next
  case (Cons_path n'' as a n)
  note IH = `\<And>as' s s'. \<lbrakk>n'' -as'\<rightarrow>* (_Low_);
    \<forall>V\<in>rv S n''. state_val s V = state_val s' V;
   preds (slice_kinds S as) s; preds (slice_kinds S as') s'\<rbrakk>
  \<Longrightarrow> \<forall>V\<in>Use (_Low_). state_val (transfers (slice_kinds S as) s) V =
                     state_val (transfers (slice_kinds S as') s') V`
  show ?case
  proof(cases "L = {}")
    case True with UseLow show ?thesis by simp
  next
    case False
    show ?thesis
    proof(cases as')
      case Nil
      with `n -as'\<rightarrow>* (_Low_)` have "n = (_Low_)" by fastforce
      with `valid_edge a` `sourcenode a = n` have "targetnode a = (_Exit_)"
        by -(rule Exit_successor_of_Low,simp+)
      from Low_source_Exit_edge obtain ax where "valid_edge ax"
        and "sourcenode ax = (_Low_)" and "targetnode ax = (_Exit_)"
        and "kind ax = (\<lambda>s. True)\<^sub>\<surd>" by blast
      from `valid_edge a` `sourcenode a = n` `n = (_Low_)` `targetnode a = (_Exit_)`
        `valid_edge ax` `sourcenode ax = (_Low_)` `targetnode ax = (_Exit_)`
      have "a = ax" by(fastforce dest:edge_det)
      with `kind ax = (\<lambda>s. True)\<^sub>\<surd>` have "kind a = (\<lambda>s. True)\<^sub>\<surd>" by simp
      with `targetnode a = (_Exit_)` `targetnode a = n''` `n'' -as\<rightarrow>* (_Low_)`
      have "(_Low_) = (_Exit_)" by -(rule path_Exit_source,auto)
      with False have False by -(drule Low_neq_Exit,simp)
      thus ?thesis by simp
    next
      case (Cons ax asx)
      with `n -as'\<rightarrow>* (_Low_)` have "n = sourcenode ax" and "valid_edge ax"
        and "targetnode ax -asx\<rightarrow>* (_Low_)" by(auto elim:path_split_Cons)
      show ?thesis
      proof(cases "targetnode ax = n''")
        case True
        with `targetnode ax -asx\<rightarrow>* (_Low_)` have "n'' -asx\<rightarrow>* (_Low_)" by simp
        from `valid_edge ax` `valid_edge a` `n = sourcenode ax` `sourcenode a = n`
          True `targetnode a = n''` have "ax = a" by(fastforce intro:edge_det)
        from `preds (slice_kinds S (a#as)) s`
        have preds1:"preds (slice_kinds S as) (transfer (slice_kind S a) s)"
          by(simp add:slice_kinds_def)
        from `preds (slice_kinds S as') s'` Cons `ax = a`
        have preds2:"preds (slice_kinds S asx)
          (transfer (slice_kind S a) s')"
          by(simp add:slice_kinds_def)
        from `valid_edge a` `sourcenode a = n` `targetnode a = n''`
          `preds (slice_kinds S (a#as)) s` `preds (slice_kinds S as') s'`
          `ax = a` Cons `\<forall>V\<in>rv S n. state_val s V = state_val s' V`
        have "\<forall>V\<in>rv S n''. state_val (transfer (slice_kind S a) s) V =
                                 state_val (transfer (slice_kind S a) s') V"
          by -(rule rv_edge_slice_kinds,auto)
        from IH[OF `n'' -asx\<rightarrow>* (_Low_)` this preds1 preds2]
          Cons `ax = a` show ?thesis by(simp add:slice_kinds_def)
      next
        case False
        with `valid_edge a` `valid_edge ax` `sourcenode a = n` `n = sourcenode ax`
          `targetnode a = n''` `preds (slice_kinds S (a#as)) s`
          `preds (slice_kinds S as') s'` Cons
          `\<forall>V\<in>rv S n. state_val s V = state_val s' V`
        have False by -(rule rv_branching_edges_slice_kinds_False,auto)
        thus ?thesis by simp
      qed
    qed
  qed
qed

section {* The Correctness Proofs *}

text {*
In the following, we present two correctness proofs that slicing guarantees
IFC noninterference. In both theorems,
@{text "(_High_) \<notin> backward_slice S"}, where @{text "(_Low_) \<in> S"},
makes sure that no high variable (which are all defined in @{text "(_High_)"})
can influence a low variable (which are all used in @{text "(_Low_)"}).

First, a theorem regarding
@{text "(_Entry_) -as\<rightarrow>* (_Exit_)"} paths in the control flow graph (CFG),
which agree to a complete program execution: *}

lemma nonInterference_path_to_Low:
  assumes "s \<approx>\<^sub>L s'" and "(_High_) \<notin> backward_slice S" and "(_Low_) \<in> S"
  and "(_Entry_) -as\<rightarrow>* (_Low_)" and "preds (kinds as) s"
  and "(_Entry_) -as'\<rightarrow>* (_Low_)" and "preds (kinds as') s'"
  shows "transfers (kinds as) s \<approx>\<^sub>L transfers (kinds as') s'"
proof -
  from `(_Entry_) -as\<rightarrow>* (_Low_)` `preds (kinds as) s` `(_Low_) \<in> S`
  obtain asx where "preds (slice_kinds S asx) s"
    and "\<forall>V \<in> Use (_Low_). state_val(transfers (slice_kinds S asx) s) V =
                           state_val(transfers (kinds as) s) V"
    and "slice_edges S as = slice_edges S asx"
    and "(_Entry_) -asx\<rightarrow>* (_Low_)" by(erule fundamental_property_of_static_slicing)
  from `(_Entry_) -as'\<rightarrow>* (_Low_)` `preds (kinds as') s'` `(_Low_) \<in> S`
  obtain asx' where "preds (slice_kinds S asx') s'"
    and "\<forall>V \<in> Use (_Low_). state_val (transfers (slice_kinds S asx') s') V =
                           state_val (transfers (kinds as') s') V"
    and "slice_edges S as' = slice_edges S asx'"
    and "(_Entry_) -asx'\<rightarrow>* (_Low_)" by(erule fundamental_property_of_static_slicing)
  from `s \<approx>\<^sub>L s'` `(_High_) \<notin> backward_slice S`
  have "\<forall>V \<in> rv S (_Entry_). state_val s V = state_val s' V"
    by(rule lowEquivalence_relevant_nodes_Entry)
  with `(_Entry_) -asx\<rightarrow>* (_Low_)` `(_Entry_) -asx'\<rightarrow>* (_Low_)` `(_Low_) \<in> S`
    `preds (slice_kinds S asx) s` `preds (slice_kinds S asx') s'`
  have "\<forall>V \<in> Use (_Low_). state_val (transfers (slice_kinds S asx) s) V =
                          state_val (transfers (slice_kinds S asx') s') V"
    by -(rule rv_Low_Use_Low,auto)
  with `\<forall>V \<in> Use (_Low_). state_val(transfers (slice_kinds S asx) s) V =
                          state_val(transfers (kinds as) s) V`
    `\<forall>V \<in> Use (_Low_). state_val (transfers (slice_kinds S asx') s') V =
                       state_val (transfers (kinds as') s') V`
  show ?thesis by(auto simp:lowEquivalence_def UseLow)
qed

theorem nonInterference_path:
  assumes "s \<approx>\<^sub>L s'" and "(_High_) \<notin> backward_slice S" and "(_Low_) \<in> S"
  and "(_Entry_) -as\<rightarrow>* (_Exit_)" and "preds (kinds as) s"
  and "(_Entry_) -as'\<rightarrow>* (_Exit_)" and "preds (kinds as') s'"
  shows "transfers (kinds as) s \<approx>\<^sub>L transfers (kinds as') s'"
proof -
  from `(_Entry_) -as\<rightarrow>* (_Exit_)` obtain x xs where "as = x#xs"
    and "(_Entry_) = sourcenode x" and "valid_edge x"
    and "targetnode x -xs\<rightarrow>* (_Exit_)"
    apply(cases "as = []")
     apply(simp,drule empty_path_nodes,drule Entry_noteq_Exit,simp)
    by(erule path_split_Cons)
  from `valid_edge x` have "valid_node (targetnode x)" by simp
  hence "inner_node (targetnode x)"
  proof(cases rule:valid_node_cases)
    case Entry
    with `valid_edge x` have False by(rule Entry_target)
    thus ?thesis by simp
  next
    case Exit
    with `targetnode x -xs\<rightarrow>* (_Exit_)` have "xs = []"
      by -(rule path_Exit_source,simp)
    from Entry_Exit_edge obtain z where "valid_edge z"
      and "sourcenode z = (_Entry_)" and "targetnode z = (_Exit_)"
      and "kind z = (\<lambda>s. False)\<^sub>\<surd>" by blast
    from `valid_edge x` `valid_edge z` `(_Entry_) = sourcenode x`
      `sourcenode z = (_Entry_)` Exit `targetnode z = (_Exit_)`
    have "x = z" by(fastforce intro:edge_det)
    with `preds (kinds as) s` `as = x#xs` `xs = []` `kind z = (\<lambda>s. False)\<^sub>\<surd>`
    have False by(simp add:kinds_def)
    thus ?thesis by simp
  qed simp
  with `targetnode x -xs\<rightarrow>* (_Exit_)` obtain x' xs' where "xs = xs'@[x']"
    and "targetnode x -xs'\<rightarrow>* (_Low_)" and "kind x' = (\<lambda>s. True)\<^sub>\<surd>"
    by(fastforce elim:Exit_path_Low_path)
  with `(_Entry_) = sourcenode x` `valid_edge x`
  have "(_Entry_) -x#xs'\<rightarrow>* (_Low_)" by(fastforce intro:Cons_path)
  from `as = x#xs` `xs = xs'@[x']` have "as = (x#xs')@[x']" by simp
  with `preds (kinds as) s` have "preds (kinds (x#xs')) s"
    by(simp add:kinds_def preds_split)
  from `(_Entry_) -as'\<rightarrow>* (_Exit_)` obtain y ys where "as' = y#ys"
    and "(_Entry_) = sourcenode y" and "valid_edge y"
    and "targetnode y -ys\<rightarrow>* (_Exit_)"
    apply(cases "as' = []")
     apply(simp,drule empty_path_nodes,drule Entry_noteq_Exit,simp)
    by(erule path_split_Cons)
  from `valid_edge y` have "valid_node (targetnode y)" by simp
  hence "inner_node (targetnode y)"
  proof(cases rule:valid_node_cases)
    case Entry
    with `valid_edge y` have False by(rule Entry_target)
    thus ?thesis by simp
  next
    case Exit
    with `targetnode y -ys\<rightarrow>* (_Exit_)` have "ys = []"
      by -(rule path_Exit_source,simp)
    from Entry_Exit_edge obtain z where "valid_edge z"
      and "sourcenode z = (_Entry_)" and "targetnode z = (_Exit_)"
      and "kind z = (\<lambda>s. False)\<^sub>\<surd>" by blast
    from `valid_edge y` `valid_edge z` `(_Entry_) = sourcenode y`
      `sourcenode z = (_Entry_)` Exit `targetnode z = (_Exit_)`
    have "y = z" by(fastforce intro:edge_det)
    with `preds (kinds as') s'` `as' = y#ys` `ys = []` `kind z = (\<lambda>s. False)\<^sub>\<surd>`
    have False by(simp add:kinds_def)
    thus ?thesis by simp
  qed simp
  with `targetnode y -ys\<rightarrow>* (_Exit_)` obtain y' ys' where "ys = ys'@[y']"
    and "targetnode y -ys'\<rightarrow>* (_Low_)" and "kind y' = (\<lambda>s. True)\<^sub>\<surd>"
    by(fastforce elim:Exit_path_Low_path)
  with `(_Entry_) = sourcenode y` `valid_edge y`
  have "(_Entry_) -y#ys'\<rightarrow>* (_Low_)" by(fastforce intro:Cons_path)
  from `as' = y#ys` `ys = ys'@[y']` have "as' = (y#ys')@[y']" by simp
  with `preds (kinds as') s'` have "preds (kinds (y#ys')) s'"
    by(simp add:kinds_def preds_split)
  from `s \<approx>\<^sub>L s'` `(_High_) \<notin> backward_slice S` `(_Low_) \<in> S`
    `(_Entry_) -x#xs'\<rightarrow>* (_Low_)` `preds (kinds (x#xs')) s`
    `(_Entry_) -y#ys'\<rightarrow>* (_Low_)` `preds (kinds (y#ys')) s'`
  have "transfers (kinds (x#xs')) s \<approx>\<^sub>L transfers (kinds (y#ys')) s'"
    by(rule nonInterference_path_to_Low)
  with `as = x#xs` `xs = xs'@[x']` `kind x' = (\<lambda>s. True)\<^sub>\<surd>`
    `as' = y#ys` `ys = ys'@[y']` `kind y' = (\<lambda>s. True)\<^sub>\<surd>`
  show ?thesis by(simp add:kinds_def transfers_split)
qed

end

text {* The second theorem assumes that we have a operational semantics,
whose evaluations are written @{text "\<langle>c,s\<rangle> \<Rightarrow> \<langle>c',s'\<rangle>"} and which conforms
to the CFG. The correctness theorem then states that if no high variable
influenced a low variable and the initial states were low equivalent, the
reulting states are again low equivalent: *}

locale NonInterferenceIntra =
  NonInterferenceIntraGraph sourcenode targetnode kind valid_edge Entry
    Def Use state_val backward_slice Exit H L High Low +
  BackwardSlice_wf sourcenode targetnode kind valid_edge Entry Def Use state_val
    backward_slice sem identifies
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") and Def :: "'node \<Rightarrow> 'var set"
  and Use :: "'node \<Rightarrow> 'var set" and state_val :: "'state \<Rightarrow> 'var \<Rightarrow> 'val"
  and backward_slice :: "'node set \<Rightarrow> 'node set"
  and sem :: "'com \<Rightarrow> 'state \<Rightarrow> 'com \<Rightarrow> 'state \<Rightarrow> bool"
    ("((1\<langle>_,/_\<rangle>) \<Rightarrow>/ (1\<langle>_,/_\<rangle>))" [0,0,0,0] 81)
  and identifies :: "'node \<Rightarrow> 'com \<Rightarrow> bool" ("_ \<triangleq> _" [51, 0] 80)
  and Exit :: "'node" ("'('_Exit'_')")
  and H :: "'var set" and L :: "'var set"
  and High :: "'node"  ("'('_High'_')") and Low :: "'node"   ("'('_Low'_')") +
  fixes final :: "'com \<Rightarrow> bool"
  assumes final_edge_Low: "\<lbrakk>final c; n \<triangleq> c\<rbrakk>
  \<Longrightarrow> \<exists>a. valid_edge a \<and> sourcenode a = n \<and> targetnode a = (_Low_) \<and> kind a = \<Up>id"
begin

text{* The following theorem needs the explicit edge from @{text "(_High_)"}
  to @{text n}. An approach using a @{text "init"} predicate for initial statements,
  being reachable from @{text "(_High_)"} via a @{text "(\<lambda>s. True)\<^sub>\<surd>"} edge,
  does not work as the same statement could be identified by several nodes, some
  initial, some not. E.g., in the program \texttt{while (True) Skip;;Skip}
  two nodes identify this inital statement: the initial node and the node
  within the loop (because of loop unrolling).*}

theorem nonInterference:
  assumes "s\<^sub>1 \<approx>\<^sub>L s\<^sub>2" and "(_High_) \<notin> backward_slice S" and "(_Low_) \<in> S"
  and "valid_edge a" and "sourcenode a = (_High_)" and "targetnode a = n"
  and "kind a = (\<lambda>s. True)\<^sub>\<surd>" and "n \<triangleq> c" and "final c'"
  and "\<langle>c,s\<^sub>1\<rangle> \<Rightarrow> \<langle>c',s\<^sub>1'\<rangle>" and "\<langle>c,s\<^sub>2\<rangle> \<Rightarrow> \<langle>c',s\<^sub>2'\<rangle>"
  shows "s\<^sub>1' \<approx>\<^sub>L s\<^sub>2'"
proof -
  from High_target_Entry_edge obtain ax where "valid_edge ax"
    and "sourcenode ax = (_Entry_)" and "targetnode ax = (_High_)"
    and "kind ax = (\<lambda>s. True)\<^sub>\<surd>" by blast
  from `n \<triangleq> c` `\<langle>c,s\<^sub>1\<rangle> \<Rightarrow> \<langle>c',s\<^sub>1'\<rangle>`
  obtain n\<^sub>1 as\<^sub>1 where "n -as\<^sub>1\<rightarrow>* n\<^sub>1" and "transfers (kinds as\<^sub>1) s\<^sub>1 = s\<^sub>1'"
    and "preds (kinds as\<^sub>1) s\<^sub>1" and "n\<^sub>1 \<triangleq> c'"
    by(fastforce dest:fundamental_property)
  from `n -as\<^sub>1\<rightarrow>* n\<^sub>1` `valid_edge a` `sourcenode a = (_High_)` `targetnode a = n`
  have "(_High_) -a#as\<^sub>1\<rightarrow>* n\<^sub>1" by(rule Cons_path)
  from `final c'` `n\<^sub>1 \<triangleq> c'`
  obtain a\<^sub>1 where "valid_edge a\<^sub>1" and "sourcenode a\<^sub>1 = n\<^sub>1"
    and "targetnode a\<^sub>1 = (_Low_)" and "kind a\<^sub>1 = \<Up>id" by(fastforce dest:final_edge_Low)
  hence "n\<^sub>1 -[a\<^sub>1]\<rightarrow>* (_Low_)" by(fastforce intro:path_edge)
  with `(_High_) -a#as\<^sub>1\<rightarrow>* n\<^sub>1` have "(_High_) -(a#as\<^sub>1)@[a\<^sub>1]\<rightarrow>* (_Low_)"
    by(rule path_Append)
  with `valid_edge ax` `sourcenode ax = (_Entry_)` `targetnode ax = (_High_)`
  have "(_Entry_) -ax#((a#as\<^sub>1)@[a\<^sub>1])\<rightarrow>* (_Low_)" by -(rule Cons_path)
  from `kind ax = (\<lambda>s. True)\<^sub>\<surd>` `kind a = (\<lambda>s. True)\<^sub>\<surd>` `preds (kinds as\<^sub>1) s\<^sub>1`
    `kind a\<^sub>1 = \<Up>id` have "preds (kinds (ax#((a#as\<^sub>1)@[a\<^sub>1]))) s\<^sub>1"
    by (simp add:kinds_def preds_split)
  from `n \<triangleq> c` `\<langle>c,s\<^sub>2\<rangle> \<Rightarrow> \<langle>c',s\<^sub>2'\<rangle>`
  obtain n\<^sub>2 as\<^sub>2 where "n -as\<^sub>2\<rightarrow>* n\<^sub>2" and "transfers (kinds as\<^sub>2) s\<^sub>2 = s\<^sub>2'"
    and "preds (kinds as\<^sub>2) s\<^sub>2" and "n\<^sub>2 \<triangleq> c'"
    by(fastforce dest:fundamental_property)
  from `n -as\<^sub>2\<rightarrow>* n\<^sub>2` `valid_edge a` `sourcenode a = (_High_)` `targetnode a = n`
  have "(_High_) -a#as\<^sub>2\<rightarrow>* n\<^sub>2" by(rule Cons_path)
  from `final c'` `n\<^sub>2 \<triangleq> c'`
  obtain a\<^sub>2 where "valid_edge a\<^sub>2" and "sourcenode a\<^sub>2 = n\<^sub>2"
    and "targetnode a\<^sub>2 = (_Low_)" and "kind a\<^sub>2 = \<Up>id" by(fastforce dest:final_edge_Low)
  hence "n\<^sub>2 -[a\<^sub>2]\<rightarrow>* (_Low_)" by(fastforce intro:path_edge)
  with `(_High_) -a#as\<^sub>2\<rightarrow>* n\<^sub>2` have "(_High_) -(a#as\<^sub>2)@[a\<^sub>2]\<rightarrow>* (_Low_)"
    by(rule path_Append)
  with `valid_edge ax` `sourcenode ax = (_Entry_)` `targetnode ax = (_High_)`
  have "(_Entry_) -ax#((a#as\<^sub>2)@[a\<^sub>2])\<rightarrow>* (_Low_)" by -(rule Cons_path)
  from `kind ax = (\<lambda>s. True)\<^sub>\<surd>` `kind a = (\<lambda>s. True)\<^sub>\<surd>` `preds (kinds as\<^sub>2) s\<^sub>2`
    `kind a\<^sub>2 = \<Up>id` have "preds (kinds (ax#((a#as\<^sub>2)@[a\<^sub>2]))) s\<^sub>2"
    by (simp add:kinds_def preds_split)
  from `s\<^sub>1 \<approx>\<^sub>L s\<^sub>2` `(_High_) \<notin> backward_slice S` `(_Low_) \<in> S`
    `(_Entry_) -ax#((a#as\<^sub>1)@[a\<^sub>1])\<rightarrow>* (_Low_)` `preds (kinds (ax#((a#as\<^sub>1)@[a\<^sub>1]))) s\<^sub>1`
    `(_Entry_) -ax#((a#as\<^sub>2)@[a\<^sub>2])\<rightarrow>* (_Low_)` `preds (kinds (ax#((a#as\<^sub>2)@[a\<^sub>2]))) s\<^sub>2`
  have "transfers (kinds (ax#((a#as\<^sub>1)@[a\<^sub>1]))) s\<^sub>1 \<approx>\<^sub>L
        transfers (kinds (ax#((a#as\<^sub>2)@[a\<^sub>2]))) s\<^sub>2"
    by(rule nonInterference_path_to_Low)
  with `kind ax = (\<lambda>s. True)\<^sub>\<surd>` `kind a = (\<lambda>s. True)\<^sub>\<surd>` `kind a\<^sub>1 = \<Up>id` `kind a\<^sub>2 = \<Up>id`
    `transfers (kinds as\<^sub>1) s\<^sub>1 = s\<^sub>1'` `transfers (kinds as\<^sub>2) s\<^sub>2 = s\<^sub>2'`
  show ?thesis by(simp add:kinds_def transfers_split)
qed

end

end


(*  Title:      HOL/HOLCF/IOA/RefMappings.thy
    Author:     Olaf Müller
*)

section \<open>Refinement Mappings in HOLCF/IOA\<close>

theory RefMappings
imports Traces
begin

default_sort type

definition move :: "('a, 's) ioa \<Rightarrow> ('a, 's) pairs \<Rightarrow> 's \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool"
  where "move ioa ex s a t \<longleftrightarrow>
    is_exec_frag ioa (s, ex) \<and> Finite ex \<and>
    laststate (s, ex) = t \<and>
    mk_trace ioa \<cdot> ex = (if a \<in> ext ioa then a \<leadsto> nil else nil)"

definition is_ref_map :: "('s1 \<Rightarrow> 's2) \<Rightarrow> ('a, 's1) ioa \<Rightarrow> ('a, 's2) ioa \<Rightarrow> bool"
  where "is_ref_map f C A \<longleftrightarrow>
   ((\<forall>s \<in> starts_of C. f s \<in> starts_of A) \<and>
     (\<forall>s t a. reachable C s \<and> s \<midarrow>a\<midarrow>C\<rightarrow> t \<longrightarrow> (\<exists>ex. move A ex (f s) a (f t))))"

definition is_weak_ref_map :: "('s1 \<Rightarrow> 's2) \<Rightarrow> ('a, 's1) ioa \<Rightarrow> ('a, 's2) ioa \<Rightarrow> bool"
  where "is_weak_ref_map f C A \<longleftrightarrow>
    ((\<forall>s \<in> starts_of C. f s \<in> starts_of A) \<and>
      (\<forall>s t a. reachable C s \<and> s \<midarrow>a\<midarrow>C\<rightarrow> t \<longrightarrow>
        (if a \<in> ext C then (f s) \<midarrow>a\<midarrow>A\<rightarrow> (f t) else f s = f t)))"

subsection \<open>Transitions and moves\<close>

lemma transition_is_ex: "s \<midarrow>a\<midarrow>A\<rightarrow> t \<Longrightarrow> \<exists>ex. move A ex s a t"
  apply (rule_tac x = " (a, t) \<leadsto> nil" in exI)
  apply (simp add: move_def)
  done

lemma nothing_is_ex: "a \<notin> ext A \<and> s = t \<Longrightarrow> \<exists>ex. move A ex s a t"
  apply (rule_tac x = "nil" in exI)
  apply (simp add: move_def)
  done

lemma ei_transitions_are_ex:
  "s \<midarrow>a\<midarrow>A\<rightarrow> s' \<and> s' \<midarrow>a'\<midarrow>A\<rightarrow> s'' \<and> a' \<notin> ext A \<Longrightarrow> \<exists>ex. move A ex s a s''"
  apply (rule_tac x = " (a,s') \<leadsto> (a',s'') \<leadsto>nil" in exI)
  apply (simp add: move_def)
  done

lemma eii_transitions_are_ex:
  "s1 \<midarrow>a1\<midarrow>A\<rightarrow> s2 \<and> s2 \<midarrow>a2\<midarrow>A\<rightarrow> s3 \<and> s3 \<midarrow>a3\<midarrow>A\<rightarrow> s4 \<and> a2 \<notin> ext A \<and> a3 \<notin> ext A \<Longrightarrow>
    \<exists>ex. move A ex s1 a1 s4"
  apply (rule_tac x = "(a1, s2) \<leadsto> (a2, s3) \<leadsto> (a3, s4) \<leadsto> nil" in exI)
  apply (simp add: move_def)
  done

subsection \<open>\<open>weak_ref_map\<close> and \<open>ref_map\<close>\<close>

lemma weak_ref_map2ref_map: "ext C = ext A \<Longrightarrow> is_weak_ref_map f C A \<Longrightarrow> is_ref_map f C A"
  apply (unfold is_weak_ref_map_def is_ref_map_def)
  apply auto
  apply (case_tac "a \<in> ext A")
  apply (auto intro: transition_is_ex nothing_is_ex)
  done

lemma imp_conj_lemma: "(P \<Longrightarrow> Q \<longrightarrow> R) \<Longrightarrow> P \<and> Q \<longrightarrow> R"
  by blast

declare if_split [split del]
declare if_weak_cong [cong del]

lemma rename_through_pmap:
  "is_weak_ref_map f C A \<Longrightarrow> is_weak_ref_map f (rename C g) (rename A g)"
  apply (simp add: is_weak_ref_map_def)
  apply (rule conjI)
  text \<open>1: start states\<close>
  apply (simp add: rename_def rename_set_def starts_of_def)
  text \<open>1: start states\<close>
  apply (rule allI)+
  apply (rule imp_conj_lemma)
  apply (simp (no_asm) add: rename_def rename_set_def)
  apply (simp add: externals_def asig_inputs_def asig_outputs_def asig_of_def trans_of_def)
  apply safe
  apply (simplesubst if_split)
   apply (rule conjI)
   apply (rule impI)
   apply (erule disjE)
   apply (erule exE)
  apply (erule conjE)
  text \<open>\<open>x\<close> is input\<close>
   apply (drule sym)
   apply (drule sym)
  apply simp
  apply hypsubst+
  apply (frule reachable_rename)
  apply simp
  text \<open>\<open>x\<close> is output\<close>
   apply (erule exE)
  apply (erule conjE)
   apply (drule sym)
   apply (drule sym)
  apply simp
  apply hypsubst+
  apply (frule reachable_rename)
  apply simp
  text \<open>\<open>x\<close> is internal\<close>
  apply (frule reachable_rename)
  apply auto
  done

declare if_split [split]
declare if_weak_cong [cong]

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory ExtraSpecs

imports
  "CLib.TypHeapLib"

begin

definition
  "simple_simpl_refines \<Gamma> com com'
    = (\<forall>s. (\<exists>ft. \<Gamma> \<turnstile> \<langle>com', Normal s\<rangle> \<Rightarrow> Fault ft)
        \<or> ((\<forall>xs. \<Gamma> \<turnstile> \<langle>com, Normal s\<rangle> \<Rightarrow> xs \<longrightarrow> \<Gamma> \<turnstile> \<langle>com', Normal s\<rangle> \<Rightarrow> xs)
            \<and> (\<not> terminates \<Gamma> com (Normal s) \<longrightarrow> \<not> terminates \<Gamma> com' (Normal s))))"

lemma simple_simpl_refines_no_fault_execD:
  "\<Gamma> \<turnstile> \<langle>com,Normal s\<rangle> \<Rightarrow> xs
    \<Longrightarrow> simple_simpl_refines \<Gamma> com com'
    \<Longrightarrow> (\<forall>ft. \<not> \<Gamma> \<turnstile> \<langle>com',Normal s\<rangle> \<Rightarrow> Fault ft)
    \<Longrightarrow> \<Gamma> \<turnstile> \<langle>com', Normal s\<rangle> \<Rightarrow> xs"
  by (auto simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_no_fault_terminatesD:
  "simple_simpl_refines \<Gamma> com com'
    \<Longrightarrow> (\<forall>ft. \<not> \<Gamma> \<turnstile> \<langle>com',Normal s\<rangle> \<Rightarrow> Fault ft)
    \<Longrightarrow> \<not> terminates \<Gamma> com (Normal s) \<longrightarrow> \<not> terminates \<Gamma> com' (Normal s)"
  by (auto simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_refl:
  "simple_simpl_refines \<Gamma> com com"
  by (auto simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_from_def_eq:
  "body \<equiv> body' \<Longrightarrow> simple_simpl_refines \<Gamma> body' body"
  (* these are flipped, because the "implementation" is on the rhs of
     definitional equalities, but the lhs of refinement thms. *)
  by (simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_trans:
  "simple_simpl_refines \<Gamma> com com' \<Longrightarrow> simple_simpl_refines \<Gamma> com' com''
    \<Longrightarrow> simple_simpl_refines \<Gamma> com com''"
  by (simp add: simple_simpl_refines_def, metis)

lemma simple_simpl_refines_drop_Guard:
  "simple_simpl_refines \<Gamma> com (Guard F G com)"
  apply (clarsimp simp add: simple_simpl_refines_def)
  apply (case_tac "s \<in> G")
  apply (auto intro: exec.Guard exec.GuardFault
              elim!: terminates_Normal_elim_cases)
  done

lemma simple_simpl_refines_guarded_Basic_guarded_spec_body:
  "(\<forall>s s'. (s, s') \<in> R \<longrightarrow> (s \<in> G \<and> (s, f s) \<in> R))
    \<Longrightarrow> simple_simpl_refines \<Gamma> (Guard F' G (Basic f)) (guarded_spec_body F R)"
  apply (simp add: guarded_spec_body_def simple_simpl_refines_def)
  apply (intro allI, drule_tac x=s in spec)
  apply (erule impCE)
   apply (rule disjI1)
   apply (fastforce intro: exec.GuardFault)
  apply (rule disjI2)
  apply (auto intro!: exec.Guard terminates.Guard
               intro: exec.GuardFault exec.Spec terminates.Basic image_eqI[rotated]
              elim!: exec_Normal_elim_cases terminates_Normal_elim_cases)
  done

lemmas simple_simpl_refines_Basic_guarded_spec_body
    = simple_simpl_refines_trans[OF
        simple_simpl_refines_drop_Guard[where G=UNIV]
        simple_simpl_refines_guarded_Basic_guarded_spec_body
        ]

ML \<open>
structure Get_Body_Refines = struct

fun get ctxt name = let
    fun pget sfx = try (Proof_Context.get_thm ctxt o suffix sfx) name
    val eqv = pget "_body_refines"
    val def = pget "_body_def"
  in case (eqv, def) of
      (SOME eqvt, _) => eqvt
    | (_, SOME deft) => (deft RS @{thm simple_simpl_refines_from_def_eq})
    | _ => raise THM ("Get_Body_Refines.get: "
          ^ "no body_def or body_refines: " ^ name, 1, [])
  end

end
\<close>

end


(******
Type system for Yul language
Copyright (C) 2020  Ximeng Li, Ning Han

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 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
Library General Public License for more details.
******)

theory "Typing"

imports Main LMap Syntax

begin

fun in_range :: "int \<Rightarrow> type_name \<Rightarrow> bool" where
  "in_range i S256 = (-(2^255) \<le> i \<and> i < 2^255)" |
  "in_range i U256 = (0 \<le> i \<and> i < 2^256)" |
  "in_range i S128 = (-(2^127) \<le> i \<and> i < 2^127)" |
  "in_range i U128 = (0 \<le> i \<and> i < 2^128)" |
  "in_range i S64 = (-(2^63) \<le> i \<and> i < 2^63)" |
  "in_range i U64 = (0 \<le> i \<and> i < 2^64)" |
  "in_range i S32 = (-(2^31) \<le> i \<and> i < 2^31)" |
  "in_range i U32 = (0 \<le> i \<and> i < 2^32)" |
  "in_range i S8 = (-(2^7) \<le> i \<and> i < 2^7)" |
  "in_range i U8 = (0 \<le> i \<and> i < 2^8)" |
  "in_range i Address160 = (0 \<le> i \<and> i < 2^160)" |
  "in_range i _ = False"

(* the types for variables *)
datatype vtype = VType type_name

(* the types for expressions *)
datatype etype = DataType "type_name list" | StmtType

(* the types for functions *)
datatype ftype = FType "type_name list" "type_name list"

(* typing environments for variables *)
type_synonym type_env = "vtype list_map"

(* typing environments for functions *)
type_synonym ftype_env = "ftype list_map"

(* result of typing an expression *)
datatype expr_type_res = ETypable etype type_env | EUntypable

value "{1::nat, 2, 3} \<inter> {4, 5} = {}"
value "{1::int, 2} \<inter> {2, 3}"

value "sum_list [1::nat,2,3]"

fun size_of_expr :: "expr \<Rightarrow> nat" and
    size_of_es :: "expr list \<Rightarrow> nat" and
    size_of_blk :: "block \<Rightarrow> nat"
    where
  "size_of_expr (EFunCall f es) = 1 + size_of_es es" |
  "size_of_expr (EId x) = 1" |
  "size_of_expr (EImLit lit) = 1" |
  "size_of_expr (ELit lit) = 1" |
  "size_of_expr (EFunDef f pts rts blk) = 1 + size_of_blk blk" |
  "size_of_expr (EVarDecl txs e) = 2 + (length txs) + size_of_expr e" |
  "size_of_expr (EEmptyVarDecl txs) = 1" |
  "size_of_expr (EAssg xs e) = 2 + (length xs) + size_of_expr e" |
  "size_of_expr (EIf e blk) = 1 + size_of_expr e + size_of_blk blk" |
  "size_of_expr (ECond e blk) = 1 + size_of_expr e + size_of_blk blk" |
  "size_of_expr (ESwitch e cases blk_opt) =
    2 + size_of_expr e + sum_list (map (size_of_blk \<circ> snd) cases) +
    (case blk_opt of (Some blk0) \<Rightarrow> size_of_blk blk0 | _ \<Rightarrow> 0)
    " |
  "size_of_expr (EFor blk1 e blk2 blk) =
    1 + size_of_blk blk1 + size_of_expr e + size_of_blk blk2 + size_of_blk blk
    " |
  "size_of_expr (ERetId xt) = 1" |
  "size_of_expr (EImFunCall f es) = 1 + size_of_es es" |
  "size_of_expr (EList es) = size_of_es es" |
  "size_of_expr EStop = 1" |
  "size_of_expr EGasJump = 1" |
  "size_of_expr EGasJumpDest = 1" |
  "size_of_expr EGasPush = 1" |
  "size_of_expr EGasPop = 1" |
  "size_of_expr EGasSwap = 1" |

  "size_of_blk (Blk es) = 1 + size_of_es es" |

  "size_of_es es = 1 + sum_list (map size_of_expr es)"

definition builtin_fte :: ftype_env where
  "
  builtin_fte =
    [(b_land_id, FType [Bool, Bool] [Bool]),
    (b_lor_id, FType [Bool, Bool] [Bool]),
    (b_lxor_id, FType [Bool, Bool] [Bool]),
    (b_lnot_id, FType [Bool] [Bool]),
    (b_add_id, FType [U256, U256] [U256]),
    (b_sub_id, FType [U256, U256] [U256]),
    (b_mul_id, FType [U256, U256] [U256]),
    (b_div_id, FType [U256, U256] [U256]),
    (b_sdiv_id, FType [S256, S256] [S256]),
    (b_mod_id, FType [U256, U256] [U256]),
    (b_smod_id, FType [S256, S256] [S256]),
    (b_exp_id, FType [U256, U256] [U256]),
    (b_addmod_id, FType [U256, U256, U256] [U256]),
    (b_mulmod_id, FType [U256, U256, U256] [U256]),
    (b_lt_id, FType [U256, U256] [Bool]),
    (b_slt_id, FType [S256, S256] [Bool]),
    (b_gt_id, FType [U256, U256] [Bool]),
    (b_sgt_id, FType [S256, S256] [Bool]),
    (b_eq_id, FType [U256, U256] [Bool]),
    (b_iszero_id, FType [U256] [Bool]),
    (b_not_id, FType [U256] [U256]),
    (b_and_id, FType [U256, U256] [U256]),
    (b_or_id, FType [U256, U256] [U256]),
    (b_xor_id, FType [U256, U256] [U256]),
    (b_shl_id, FType [U256, U256] [U256]),
    (b_shr_id, FType [U256, U256] [U256]),
    (b_sar_id, FType [U256, S256] [U256]),

    (b_mstore_id, FType [U256, U256] []),
    (b_mstore8_id, FType [U256, U256] []),
    (b_mload_id, FType [U256] [U256]),
    (b_sstore_id, FType [U256, U256] []),
    (b_sload_id, FType [U256] [U256]),
    (b_msize_id, FType [] [U256]),

    (b_call_id, FType [U256, U256, U256, U256, U256, U256, U256] [U256]),
    (b_callcode_id, FType [U256, U256, U256, U256, U256, U256, U256] [U256]),
    (b_delegatecall_id, FType [U256, U256, U256, U256, U256, U256] [U256]),
    (b_return_id, FType [U256, U256] []),
    (b_revert_id, FType [U256, U256] []),
    (b_selfdestruct_id, FType [U256] []),
    (b_log0_id, FType [U256, U256] []),
    (b_log1_id, FType [U256, U256, U256] []),
    (b_log2_id, FType [U256, U256, U256, U256] []),
    (b_log3_id, FType [U256, U256, U256, U256, U256] []),
    (b_log4_id, FType [U256, U256, U256, U256, U256, U256] []),
    (b_stop_id, FType [] []),
    (b_invalid_id, FType [] []),

    (b_coinbase_id, FType [] [U256]),
    (b_difficulty_id, FType [] [U256]),
    (b_gaslimit_id, FType [] [U256]),
    (b_number_id, FType [] [U256]),
    (b_timestamp_id, FType [] [U256]),
    (b_origin_id, FType [] [U256]),
    (b_gasprice_id, FType [] [U256]),
    (b_gas_id, FType [] [U256]),
    (b_balance_id, FType [U256] [U256]),
    (b_address_id, FType [] [U256]),
    (b_caller_id, FType [] [U256]),
    (b_callvalue_id, FType [] [U256]),
    (b_calldatasize_id, FType [] [U256]),
    (b_calldatacopy_id, FType [] [U256]),
    (b_calldataload_id, FType [U256] [U256]),

    (b_keccak256_id, FType [U256, U256] [U256])
    ]
  "

(* helper lemma supporting the termination proof for the typing function *)
lemma in_lst_impl_sz_lt [simp]:
  "\<lbrakk> a \<in> set es \<rbrakk> \<Longrightarrow> size_of_expr a < Suc (sum_list (map size_of_expr es))"
proof(induction es arbitrary: a)
  case Nil
  then show ?case by auto
next
  case (Cons a es)
  fix a es aa
  assume H_IH: "\<And>a. a \<in> set es \<Longrightarrow>
                     size_of_expr a < Suc (sum_list (map size_of_expr es))"
  assume H_in: "aa \<in> set (a # es)"
  hence H_or: "aa = a \<or> aa \<in> set es" by auto
  thus "size_of_expr aa < Suc (sum_list (map size_of_expr (a # es)))"
  proof
    assume "aa = a" thus ?thesis by simp
  next
    assume "aa \<in> set es" thus ?thesis using H_IH by fastforce
  qed
qed

(* helper lemma supporting the termination proof for the typing function *)
lemma in_cases_impl_sz_lt:
  "\<lbrakk> ((lit :L tn), b) \<in> set cases \<rbrakk>
   \<Longrightarrow> size_of_blk b < Suc (sum_list (map (size_of_blk \<circ> snd) cases))"
proof(induction cases arbitrary: lit tn b)
  case Nil
  then show ?case by auto
next
  case (Cons a cases)
  fix a cases lit tn b
  assume H_IH:
    "\<And>lit tn b.
           (lit :L tn, b) \<in> set cases \<Longrightarrow>
           size_of_blk b < Suc (sum_list (map (size_of_blk \<circ> snd) cases))"
  assume H_case_in_cases: "(lit :L tn, b) \<in> set (a # cases)"
  hence H_or: "((lit :L tn), b) = a \<or> (lit :L tn, b) \<in> set cases" by auto
  thus "size_of_blk b < Suc (sum_list (map (size_of_blk \<circ> snd) (a # cases)))"
  proof
    assume "((lit :L tn), b) = a"
    thus ?thesis by auto
  next
    assume "(lit :L tn, b) \<in> set cases"
    thus ?thesis using H_IH by fastforce
  qed
qed

(* obtain information about the types for the user-defined functions for the code *)
fun get_a_func_types :: "expr list \<Rightarrow> ftype_env option" where
  "get_a_func_types [] = Some []" |
  "get_a_func_types ((EFunDef f ptl rtl e) # es') = (
      case (get_a_func_types es') of
        (Some te) \<Rightarrow>
          (case (lm_get te f) of
            (Some tp) \<Rightarrow> None
           | _ \<Rightarrow> (Some (te @ [(f, FType (map snd ptl) (map snd rtl))])))
      | _ \<Rightarrow> None
    )" |
  "get_a_func_types (_ # es') = get_a_func_types es'"

definition get_a_func_types_blk :: "block \<Rightarrow> ftype_env option" where
  "get_a_func_types_blk blk = (
    case blk of (Blk es) \<Rightarrow> get_a_func_types es
   )"

fun ret_or_lit :: "expr \<Rightarrow> bool" where
  "ret_or_lit (ERetId (x, t)) = True" |
  "ret_or_lit (EImLit l) = True" |
  "ret_or_lit _ = False"

fun not_elist :: "expr \<Rightarrow> bool" where
  "not_elist (EList _) = False" |
  "not_elist _ = True"

(*
  - The typing of blocks and expressions takes as parameters
    the type environment for the variables that can be used in the current scope,
    the set of variables that additionally exist in outer scopes statically, and
    the type environment for the functions in scope.
  - The variables additionally existing in outer scopes statically
    are those declared in outer scopes of the immediately surrounding function definition.
    These variables cannot be used in the function defined, nor can they be re-declared.
*)
function (sequential)
    type_es :: "type_env \<Rightarrow> id0 set \<Rightarrow> ftype_env \<Rightarrow> expr list \<Rightarrow> (bool\<times>type_env)" and
    type_b :: "type_env \<Rightarrow> id0 set \<Rightarrow> ftype_env \<Rightarrow> block \<Rightarrow> bool" and
    type_e :: "type_env \<Rightarrow> id0 set \<Rightarrow> ftype_env \<Rightarrow> expr \<Rightarrow> expr_type_res"
where
  "type_es vte xs fte es =
    foldl (\<lambda>acc e.
            (if (fst acc) then
              (case type_e (snd acc) xs fte e of
                (ETypable StmtType vte') \<Rightarrow> (True, vte') | _ \<Rightarrow> (False, (snd acc)))
             else
              acc))
          (True, vte) es" |

  "type_b vte xs fte (Blk es) = (case (type_es vte xs fte es) of (b, vte') \<Rightarrow> b)" |

  "type_e vte xs fte (EId x) =
    (case (lm_get vte x) of Some (VType tn) \<Rightarrow> ETypable (DataType [tn]) vte | _ \<Rightarrow> EUntypable)" |

  "type_e vte xs fte (EImLit lit) = (
     case lit of
      (TL :L tn) \<Rightarrow> (if tn = Bool then ETypable (DataType [Bool]) vte else EUntypable)
    | (FL :L tn) \<Rightarrow> (if tn = Bool then ETypable (DataType [Bool]) vte else EUntypable)
    | ((NL i) :L tn) \<Rightarrow> (if (in_range i tn) then (ETypable (DataType [tn]) vte) else EUntypable)
    | ((SL ws) :L _) \<Rightarrow> EUntypable
  )
     " |
  "type_e vte xs fte (ELit lit) = (
     case lit of
      (TL :L tn) \<Rightarrow> (if tn = Bool then ETypable (DataType [Bool]) vte else EUntypable)
    | (FL :L tn) \<Rightarrow> (if tn = Bool then ETypable (DataType [Bool]) vte else EUntypable)
    | ((NL i) :L tn) \<Rightarrow> (if (in_range i tn) then (ETypable (DataType [tn]) vte) else EUntypable)
    | ((SL ws) :L _) \<Rightarrow> EUntypable
  )" |

  "type_e vte xs fte (EFunCall f es) = (
    case (lm_get (fte @ builtin_fte) f) of
      Some (FType ptl rtl) \<Rightarrow> (
        if length ptl = length es then
          (let es_no_elist = (foldl (\<lambda>acc e. (acc \<and> (not_elist e))) True es) in
           let es_pts = zip es ptl in
           \<comment> \<open> type-check the arguments \<close>
           let es_res =
            (foldl (\<lambda>acc (e, t).
              (if acc then type_e vte xs fte e = ETypable (DataType [t]) vte else False))
              True es_pts) in
           (if es_no_elist \<and> es_res then
             (if length rtl = 0 then
                ETypable StmtType vte
              else ETypable (DataType rtl) vte)
            else
              EUntypable
           ))
        else
          EUntypable
      )
    | _ \<Rightarrow> EUntypable
    )" |
  \<comment> \<open> that f is not in the domain of fte cannot be checked here. this is because the type of
       f might be previously added to fte due to the existence of the function def in a block \<close>
  "type_e vte xs fte (EFunDef f pl rl blk) = (
    if (f \<notin> lm_dom builtin_fte \<and> distinct (pl @ rl)) then
      (
      let vte1' = (zip (map fst pl) (map (\<lambda>(x,tn). (VType tn)) pl)) ;
          vte2' = (zip (map fst rl) (map (\<lambda>(x,tn). (VType tn)) rl)) in
      (\<comment> \<open>ids already in the scope cannot be used as formal parameters or return variables\<close>
        case (get_a_func_types_blk blk) of
          Some fte' \<Rightarrow> (
            if (lm_dom vte \<union> xs) \<inter> (lm_dom vte1' \<union> lm_dom vte2') = {}
                \<and> (lm_dom builtin_fte \<union> lm_dom fte \<union> {f}) \<inter> lm_dom fte' = {}
                \<and> (type_b (vte1' @ vte2') (xs \<union> lm_dom vte)
                          (fte @ fte' @ [(f, FType (map snd pl) (map snd rl))]) blk)
            then
              ETypable StmtType vte
            else
              EUntypable
          )
        | _ \<Rightarrow> EUntypable
      ))
    else
      EUntypable)
  " |
  "type_e vte xs fte (EVarDecl txs e) = (
    if (foldl (\<lambda>acc tx. acc \<and> (lm_get vte (fst tx)) = None \<and> ((fst tx) \<notin> xs)
                            \<and> lm_get fte (fst tx) = None)
              True txs)
        \<and> distinct (map fst txs)
    then (
      case (type_e vte xs fte e) of
        (ETypable (DataType tns) vte') \<Rightarrow>
         (if length txs = length tns then (
            let txs_tns = zip txs tns in (
            if (foldl (\<lambda>acc ((x, tn1), tn2). acc \<and> tn1 = tn2) True txs_tns) then (
              let vte'' = vte @ ((zip (map fst txs) (map ((\<lambda>tn. (VType tn)) \<circ> snd) txs)))
              in (ETypable StmtType vte'')
            ) else EUntypable
            )
          ) else
            EUntypable)
      | _ \<Rightarrow> EUntypable
    )
    else
      EUntypable
   )
  " |
  "type_e vte xs fte (EEmptyVarDecl txs) = (
    if (foldl (\<lambda>acc tx. acc \<and> (lm_get vte (fst tx)) = None \<and> ((fst tx) \<notin> xs)
                            \<and> lm_get fte (fst tx) = None)
              True txs)
        \<and> distinct (map fst txs)
    then (
      let vte' = vte @ (zip (map fst txs) (map (\<lambda>(x, tn). (VType tn)) txs)) in
        ETypable StmtType vte'
    )
    else
      EUntypable
  )
  " |
  "type_e vte xs0 fte (EAssg xs e) = (
    case (type_e vte xs0 fte e) of
      (ETypable (DataType tns) vte') \<Rightarrow> (
        if length xs = length tns then
          let xs_tns = zip xs tns in (
            if (foldl (\<lambda>acc (x, tn). acc \<and> (lm_get vte x = Some (VType tn))) True xs_tns)
                \<and> distinct xs
            then
              ETypable StmtType vte
            else
              EUntypable
          )
        else
          EUntypable
        )
    | _ \<Rightarrow> EUntypable
  )
  " |
  "type_e vte xs fte (EIf e blk) = (
    case (type_e vte xs fte e) of
      (ETypable (DataType [Bool]) vte') \<Rightarrow> (
        if not_elist e then (
          case (get_a_func_types_blk blk) of
            Some fte' \<Rightarrow>
              (if (lm_dom builtin_fte \<union> lm_dom fte) \<inter> lm_dom fte' = {}
                   \<and> type_b vte xs (fte @ fte') blk
               then (ETypable StmtType vte)
               else EUntypable)
          | _ \<Rightarrow> EUntypable
        ) else
          EUntypable
      )
    | _ \<Rightarrow> EUntypable
    )
  " |

  "type_e vte xs fte (ECond e blk) = (
    case (type_e vte xs fte e) of
      (ETypable (DataType [Bool]) vte') \<Rightarrow> (
        if not_elist e then (
          case (get_a_func_types_blk blk) of
            Some fte' \<Rightarrow>
              (if (lm_dom builtin_fte \<union> lm_dom fte) \<inter> lm_dom fte' = {}
                  \<and> type_b vte xs (fte @ fte') blk then
                (ETypable StmtType vte)
               else
                EUntypable)
          | _ \<Rightarrow> EUntypable
        ) else
          EUntypable
      )
    | _ \<Rightarrow> EUntypable
    )
  " |

  "type_e vte xs fte (ESwitch e cases blk_opt) = (
    case (type_e vte xs fte e) of
      (ETypable (DataType [tn]) _) \<Rightarrow> (
        if not_elist e then (
          if (foldl
              (\<lambda>acc (lit, blk).
                (case (lit) of
                  (Literal lkind tn') \<Rightarrow>
                    acc \<and> tn = tn' \<and> (
                      case (get_a_func_types_blk blk) of
                        Some fte' \<Rightarrow>
                          (lm_dom builtin_fte \<union> lm_dom fte) \<inter> lm_dom fte' = {}
                           \<and> type_b vte xs (fte @ fte') blk
                      | _ \<Rightarrow> False
                    ))) True cases)
          then
            (
              case blk_opt of
                Some blk \<Rightarrow> (
                  case (get_a_func_types_blk blk) of
                    Some fte' \<Rightarrow> (
                      if (lm_dom builtin_fte \<union> lm_dom fte) \<inter> lm_dom fte' = {}
                          \<and> type_b vte xs (fte @ fte') blk then
                        ETypable StmtType vte
                      else
                        EUntypable)
                  | _ \<Rightarrow> EUntypable
                )
              | None \<Rightarrow> (ETypable StmtType vte)
            )
          else
            EUntypable
        ) else
          EUntypable
      )
   |  _ \<Rightarrow> EUntypable
   )
  " |
  "type_e vte xs fte (EFor blk1 e blk2 blk) = (
    case blk1 of
      (Blk es1) \<Rightarrow> (
        case get_a_func_types es1 of \<comment> \<open>forbit function definition inside the init block\<close>
          Some [] \<Rightarrow> (
          \<comment> \<open> variables in the outer scope can all be used in blk1 \<close>
          case (type_es vte xs fte es1) of
            (True, vte') \<Rightarrow> (
            case (type_e vte' xs fte e) of
               ETypable (DataType [Bool]) vte'' \<Rightarrow> (
                if not_elist e then (
                \<comment> \<open>variables declared in one of blk and blk2 cannot be used in the other,
                    but can be declared in the other\<close>
                case (get_a_func_types_blk blk2, get_a_func_types_blk blk) of
                  (Some fte2', Some fte') \<Rightarrow> (
                    if (lm_dom builtin_fte \<union> lm_dom fte) \<inter> lm_dom fte2' = {}
                        \<and> type_b vte' xs (fte @ fte2') blk2
                        \<and> (lm_dom builtin_fte \<union> lm_dom fte) \<inter> lm_dom fte' = {}
                        \<and> type_b vte' xs (fte @ fte') blk then
                      ETypable StmtType vte
                    else
                      EUntypable)
                | _ \<Rightarrow> EUntypable
                ) else
                  EUntypable
               )
            | _ \<Rightarrow> EUntypable
            )
          | _ \<Rightarrow> EUntypable
          )
        | _ \<Rightarrow> EUntypable
      )
   )
  " |
  "type_e vte xs fte (ERetId xt) = ETypable (DataType [snd xt]) vte" |
  "type_e vte xs fte (EImFunCall f es) = (
    case (lm_get (fte @ builtin_fte) f) of
      Some (FType ptl rtl) \<Rightarrow> (
        if length ptl = length es then
          (let es_no_elist = (foldl (\<lambda>acc e. (acc \<and> (not_elist e))) True es) in
           let es_pts = zip es ptl in
           \<comment> \<open> type-check the arguments \<close>
           let es_res =
            (foldl (\<lambda>acc (e, t).
              (if acc then type_e vte xs fte e = ETypable (DataType [t]) vte else False))
              True es_pts) in
           (if es_no_elist \<and> es_res then
             (if length rtl = 0 then
                ETypable StmtType vte
              else ETypable (DataType rtl) vte)
            else
              EUntypable
           ))
        else
          EUntypable
      )
    | _ \<Rightarrow> EUntypable
    )" |
  "type_e vte xs fte (EList es) = (
      let es_ret_lit = (foldl (\<lambda>acc e. acc \<and> ret_or_lit e) True es) in (
      if es_ret_lit then (
        foldl (\<lambda>acc e. (
                case acc of (ETypable (DataType tns) _) \<Rightarrow> (
                  case type_e vte xs fte e of
                    (ETypable (DataType [tn]) _) \<Rightarrow> ETypable (DataType (tns @ [tn])) vte
                  | _ \<Rightarrow> EUntypable)
                | _ \<Rightarrow> EUntypable))
        (ETypable (DataType []) vte) es
      ) else
        EUntypable
      )
  )" |
  "type_e vte xs fte STOP = ETypable StmtType vte" |
  "type_e vte xs fte EGasJump = ETypable StmtType vte" |
  "type_e vte xs fte EGasPush = ETypable StmtType vte" |
  "type_e vte xs fte EGasJumpDest = ETypable StmtType vte" |
  "type_e vte xs fte EGasPop = ETypable StmtType vte" |
  "type_e vte xs fte EGasSwap = ETypable StmtType vte"

  by pat_completeness auto

termination proof-
  show ?thesis
  apply(relation
  "measure
    (\<lambda>x. (case x of
           (Inl (_::type_env, xs:: id0 set, fte::ftype_env, es::expr list)) \<Rightarrow> size_of_es es
         | (Inr (Inl (vte::type_env, xs:: id0 set, fte::ftype_env, blk::block))) \<Rightarrow> size_of_blk blk
         | (Inr (Inr (vte::type_env, xs:: id0 set, fte::ftype_env, e::expr))) \<Rightarrow> size_of_expr e
         ))
  ")
  apply auto
      apply (simp add: less_SucI set_zip_leftD)
        using in_cases_impl_sz_lt apply fastforce
        by (simp add: less_SucI set_zip_leftD)
qed

end