(*  Title:      HOL/SET_Protocol/Event_SET.thy
    Author:     Giampaolo Bella
    Author:     Fabio Massacci
    Author:     Lawrence C Paulson
*)

section\<open>Theory of Events for SET\<close>

theory Event_SET
imports Message_SET
begin

text\<open>The Root Certification Authority\<close>
abbreviation "RCA == CA 0"

text\<open>Message events\<close>
datatype
  event = Says  agent agent msg
        | Gets  agent       msg
        | Notes agent       msg

text\<open>compromised agents: keys known, Notes visible\<close>
consts bad :: "agent set"

text\<open>Spy has access to his own key for spoof messages, but RCA is secure\<close>
specification (bad)
  Spy_in_bad     [iff]: "Spy \<in> bad"
  RCA_not_bad [iff]: "RCA \<notin> bad"
    by (rule exI [of _ "{Spy}"], simp)

subsection\<open>Agents' Knowledge\<close>

consts  (*Initial states of agents -- parameter of the construction*)
  initState :: "agent => msg set"

(* Message reception does not extend spy's knowledge because of
   reception invariant enforced by Reception rule in protocol definition*)
primrec knows :: "[agent, event list] => msg set"
where
  knows_Nil:
    "knows A [] = initState A"
| knows_Cons:
    "knows A (ev # evs) =
       (if A = Spy then
        (case ev of
           Says A' B X => insert X (knows Spy evs)
         | Gets A' X => knows Spy evs
         | Notes A' X  =>
             if A' \<in> bad then insert X (knows Spy evs) else knows Spy evs)
        else
        (case ev of
           Says A' B X =>
             if A'=A then insert X (knows A evs) else knows A evs
         | Gets A' X    =>
             if A'=A then insert X (knows A evs) else knows A evs
         | Notes A' X    =>
             if A'=A then insert X (knows A evs) else knows A evs))"

subsection\<open>Used Messages\<close>

primrec used :: "event list => msg set"
where
  (*Set of items that might be visible to somebody:
    complement of the set of fresh items.
    As above, message reception does extend used items *)
  used_Nil:  "used []         = (UN B. parts (initState B))"
| used_Cons: "used (ev # evs) =
                 (case ev of
                    Says A B X => parts {X} Un (used evs)
                  | Gets A X   => used evs
                  | Notes A X  => parts {X} Un (used evs))"

(* Inserted by default but later removed.  This declaration lets the file
be re-loaded. Addsimps [knows_Cons, used_Nil, *)

(** Simplifying   parts (insert X (knows Spy evs))
      = parts {X} Un parts (knows Spy evs) -- since general case loops*)

lemmas parts_insert_knows_A = parts_insert [of _ "knows A evs"] for A evs

text\<open>Letting the Spy see "bad" agents' notes avoids redundant case-splits
      on whether @{term "A=Spy"} and whether @{term "A\<in>bad"}\<close>
lemma knows_Spy_Notes [simp]:
     "knows Spy (Notes A X # evs) =
          (if A:bad then insert X (knows Spy evs) else knows Spy evs)"
apply auto
done

lemma knows_Spy_Gets [simp]: "knows Spy (Gets A X # evs) = knows Spy evs"
by auto

lemma initState_subset_knows: "initState A <= knows A evs"
apply (induct_tac "evs")
apply (auto split: event.split)
done

lemma knows_Spy_subset_knows_Spy_Says:
     "knows Spy evs <= knows Spy (Says A B X # evs)"
by auto

lemma knows_Spy_subset_knows_Spy_Notes:
     "knows Spy evs <= knows Spy (Notes A X # evs)"
by auto

lemma knows_Spy_subset_knows_Spy_Gets:
     "knows Spy evs <= knows Spy (Gets A X # evs)"
by auto

(*Spy sees what is sent on the traffic*)
lemma Says_imp_knows_Spy [rule_format]:
     "Says A B X \<in> set evs --> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (auto split: event.split)
done

(*Use with addSEs to derive contradictions from old Says events containing
  items known to be fresh*)
lemmas knows_Spy_partsEs =
     Says_imp_knows_Spy [THEN parts.Inj, elim_format]
     parts.Body [elim_format]

subsection\<open>The Function @{term used}\<close>

lemma parts_knows_Spy_subset_used: "parts (knows Spy evs) <= used evs"
apply (induct_tac "evs")
apply (auto simp add: parts_insert_knows_A split: event.split)
done

lemmas usedI = parts_knows_Spy_subset_used [THEN subsetD, intro]

lemma initState_subset_used: "parts (initState B) <= used evs"
apply (induct_tac "evs")
apply (auto split: event.split)
done

lemmas initState_into_used = initState_subset_used [THEN subsetD]

lemma used_Says [simp]: "used (Says A B X # evs) = parts{X} Un used evs"
by auto

lemma used_Notes [simp]: "used (Notes A X # evs) = parts{X} Un used evs"
by auto

lemma used_Gets [simp]: "used (Gets A X # evs) = used evs"
by auto

lemma Notes_imp_parts_subset_used [rule_format]:
     "Notes A X \<in> set evs --> parts {X} <= used evs"
apply (induct_tac "evs")
apply (rename_tac [2] a evs')
apply (induct_tac [2] "a", auto)
done

text\<open>NOTE REMOVAL--laws above are cleaner, as they don't involve "case"\<close>
declare knows_Cons [simp del]
        used_Nil [simp del] used_Cons [simp del]

text\<open>For proving theorems of the form @{term "X \<notin> analz (knows Spy evs) --> P"}
  New events added by induction to "evs" are discarded.  Provided
  this information isn't needed, the proof will be much shorter, since
  it will omit complicated reasoning about @{term analz}.\<close>

lemmas analz_mono_contra =
       knows_Spy_subset_knows_Spy_Says [THEN analz_mono, THEN contra_subsetD]
       knows_Spy_subset_knows_Spy_Notes [THEN analz_mono, THEN contra_subsetD]
       knows_Spy_subset_knows_Spy_Gets [THEN analz_mono, THEN contra_subsetD]

lemmas analz_impI = impI [where P = "Y \<notin> analz (knows Spy evs)"] for Y evs

ML
\<open>
fun analz_mono_contra_tac ctxt =
  resolve_tac ctxt @{thms analz_impI} THEN'
  REPEAT1 o (dresolve_tac ctxt @{thms analz_mono_contra})
  THEN' mp_tac ctxt
\<close>

method_setup analz_mono_contra = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (REPEAT_FIRST (analz_mono_contra_tac ctxt)))\<close>
    "for proving theorems of the form X \<notin> analz (knows Spy evs) --> P"

end


section\<open>The Axiom of Infinity in $M[G]$\<close>
theory Infinity_Axiom
  imports Union_Axiom Pairing_Axiom
begin

context G_generic1 begin

interpretation mg_triv: M_trivial"##M[G]"
  using transitivity_MG zero_in_MG[of G] generic Union_MG pairing_in_MG
  by unfold_locales auto

lemma infinity_in_MG : "infinity_ax(##M[G])"
proof -
  have "\<omega> \<in> M[G]"
    using M_subset_MG one_in_G nat_in_M by auto
  moreover from this
  have "succ(y) \<in> \<omega> \<inter> M[G]" if "y \<in> \<omega>" for y
    using that transitivity_MG by blast
  ultimately
  show ?thesis
    using transitivity_MG[of 0 \<omega>]
    unfolding infinity_ax_def
    by auto
qed

end \<comment> \<open>\<^locale>\<open>G_generic1\<close>\<close>

end


(*  Title:      HOL/HOLCF/IOA/NTP/Receiver.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

section \<open>The implementation: receiver\<close>

theory Receiver
imports "../IOA" Action
begin

type_synonym

'm receiver_state
= "'m list * bool multiset * 'm packet multiset * bool * bool"
(* messages  #replies        #received            header mode *)

definition rq :: "'m receiver_state => 'm list" where "rq == fst"
definition rsent :: "'m receiver_state => bool multiset" where "rsent == fst \<circ> snd"
definition rrcvd :: "'m receiver_state => 'm packet multiset" where "rrcvd == fst \<circ> snd \<circ> snd"
definition rbit :: "'m receiver_state => bool" where "rbit == fst \<circ> snd \<circ> snd \<circ> snd"
definition rsending :: "'m receiver_state => bool" where "rsending == snd \<circ> snd \<circ> snd \<circ> snd"

definition
  receiver_asig :: "'m action signature" where
  "receiver_asig =
   (UN pkt. {R_pkt(pkt)},
    (UN m. {R_msg(m)}) Un (UN b. {S_ack(b)}),
    insert C_m_r (UN m. {C_r_r(m)}))"

definition
  receiver_trans:: "('m action, 'm receiver_state)transition set" where
"receiver_trans =
 {tr. let s = fst(tr);
          t = snd(snd(tr))
      in
      case fst(snd(tr))
      of
      S_msg(m) => False |
      R_msg(m) => rq(s) = (m # rq(t))   &
                  rsent(t)=rsent(s)     &
                  rrcvd(t)=rrcvd(s)     &
                  rbit(t)=rbit(s)       &
                  rsending(t)=rsending(s) |
      S_pkt(pkt) => False |
      R_pkt(pkt) => rq(t) = rq(s)                        &
                       rsent(t) = rsent(s)                  &
                       rrcvd(t) = addm (rrcvd s) pkt        &
                       rbit(t) = rbit(s)                    &
                       rsending(t) = rsending(s) |
      S_ack(b) => b = rbit(s)                        &
                     rq(t) = rq(s)                      &
                     rsent(t) = addm (rsent s) (rbit s) &
                     rrcvd(t) = rrcvd(s)                &
                     rbit(t)=rbit(s)                    &
                     rsending(s)                        &
                     rsending(t) |
      R_ack(b) => False |
      C_m_s => False |
 C_m_r => count (rsent s) (~rbit s) < countm (rrcvd s) (%y. hdr(y)=rbit(s)) &
             rq(t) = rq(s)                        &
             rsent(t)=rsent(s)                    &
             rrcvd(t)=rrcvd(s)                    &
             rbit(t)=rbit(s)                      &
             rsending(s)                          &
             ~rsending(t) |
    C_r_s => False |
 C_r_r(m) => count (rsent s) (rbit s) <= countm (rrcvd s) (%y. hdr(y)=rbit(s)) &
             count (rsent s) (~rbit s) < count (rrcvd s) (rbit(s),m) &
             rq(t) = rq(s)@[m]                         &
             rsent(t)=rsent(s)                         &
             rrcvd(t)=rrcvd(s)                         &
             rbit(t) = (~rbit(s))                      &
             ~rsending(s)                              &
             rsending(t)}"

definition
  receiver_ioa  :: "('m action, 'm receiver_state)ioa" where
  "receiver_ioa =
    (receiver_asig, {([],{|},{|},False,False)}, receiver_trans,{},{})"

lemma in_receiver_asig:
  "S_msg(m) ~: actions(receiver_asig)"
  "R_msg(m) : actions(receiver_asig)"
  "S_pkt(pkt) ~: actions(receiver_asig)"
  "R_pkt(pkt) : actions(receiver_asig)"
  "S_ack(b) : actions(receiver_asig)"
  "R_ack(b) ~: actions(receiver_asig)"
  "C_m_s ~: actions(receiver_asig)"
  "C_m_r : actions(receiver_asig)"
  "C_r_s ~: actions(receiver_asig)"
  "C_r_r(m) : actions(receiver_asig)"
  by (simp_all add: receiver_asig_def actions_def asig_projections)

lemmas receiver_projections = rq_def rsent_def rrcvd_def rbit_def rsending_def

end


theory Sequence_Lock
  imports Nat_Language
begin

section \<open>Define the variables\<close>
datatype addr = r\<^sub>1 | r\<^sub>2 | x | z | secret | public
definition all_vars
  where "all_vars = [r\<^sub>1, r\<^sub>2, x, z, secret, public]"
definition locals
  where "locals = [r\<^sub>1, r\<^sub>2]"

global_interpretation natlang: nat_language all_vars locals
  defines \<Gamma>\<^sub>a = natlang.\<Gamma>\<^sub>a
      and \<Gamma>\<^sub>b = natlang.\<Gamma>\<^sub>b
      and wp = natlang.wp
      and stabilize = natlang.stabilize
      and wp\<^sub>Q = natlang.wp\<^sub>Q
      and guar = natlang.guar
      and PO = natlang.PO
      and secureUpd = natlang.secureUpd
      and ctrled = natlang.ctrled
      and if_secure = natlang.if_secure
      and wellformed = natlang.wellformed
      and negate = natlang.negate
      and var_policy = natlang.var_policy
      and \<Gamma>\<^sub>e = natlang.\<Gamma>\<^sub>e
      and invar = natlang.invar
      and low\<^sub>v = natlang.low\<^sub>v
      and wf\<^sub>\<L> = natlang.wf\<^sub>\<L>
      and step = natlang.step
      and str_env = natlang.str_env
      and onlyGlobals = natlang.onlyGlobals
  apply unfold_locales unfolding all_vars_def by allvars_tac

syntax
  "_Assign" :: "'addr \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang"
    ("(_ :=/ _)" [70, 65] 61)
  "_Store" :: "'addr \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang"
    ("(_ IN _ :=/ _)" [70, 70, 65] 61)
  "_Load" :: "'addr \<Rightarrow> ('addr) list \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang"
    ("(_ :=/ _ IN/ _)" [70, 70, 70] 61)
  "_Secure" :: "('addr,nat) rpred \<Rightarrow> ('addr,nat) rpred \<Rightarrow> ('addr \<Rightarrow> 'addr bexp) \<Rightarrow> ('addr,nat) pred \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang \<Rightarrow> bool"
    ("(0_,_ \<turnstile> R: _ /G: _ /{_})" [0, 0, 0, 0, 0] 61)

translations
  "x := a" \<rightharpoonup> "CONST Act (CONST Assign x a)"
  "x IN i := a" \<rightharpoonup> "CONST Act (CONST Store x i a)"
  "r := a IN i" \<rightharpoonup> "CONST Act (CONST Action.Load r a i)"
  "L,P \<turnstile> R: RP G: GP {c}" \<rightharpoonup> "CONST if_secure RP GP L P c"

section \<open>Example\<close>

subsection \<open>Specification\<close>
fun \<L> :: "addr \<Rightarrow> addr bexp" where
  "\<L> z = true" |
  "\<L> public = true" |
  "\<L> x = UCmp (even) (Load z)" |
  "\<L> _ = false"

definition P\<^sub>0 :: "(addr,nat) pred"
  where "P\<^sub>0 \<equiv> PCmp (\<lambda>x y. even x) (Var z) (Const 0)"

subsection \<open>Functions\<close>

lemma secret_write:
  "\<L>,P\<^sub>0 \<turnstile>
   R: invar (Low x) \<and>\<^sub>p const z
   G: inc z
   {
    z := BExp (Load z) (+) (Nat 1);
    x := Load secret;
    x := Nat 0;
    z := BExp (Load z) (+) (Nat 1)
   }"
  by natlang.vcgsolve presburger

lemma public_write:
  "\<L>,P\<^sub>0 \<turnstile>
   R: Pb True
   G: invar (Low x) \<and>\<^sub>p const z
   { x := Load public }"
  by natlang.vcgsolve

lemma secret_read:
  "\<L>,P\<^sub>0 \<turnstile>
   R: Pb True
   G: invar (Low x) \<and>\<^sub>p const z
   { secret := Load x }"
  by natlang.vcgsolve

lemma public_read:
  "\<L>,P\<^sub>0 \<turnstile>
   R: inc z
   G: invar (Low x) \<and>\<^sub>p const z
   {
    DO
      DO
        r\<^sub>1 := Load z
      INV {Low r\<^sub>1 \<and>\<^sub>p PCmp (\<le>) (Var r\<^sub>1) (Var z)}
      WHILE \<lbrace>Not (UCmp even (Load r\<^sub>1))\<rbrace>;
      r\<^sub>2 := Load x
    INV {Low r\<^sub>1 \<and>\<^sub>p (PCmp (=) (Var r\<^sub>1) (Var z) \<longrightarrow>\<^sub>p Low r\<^sub>2)}
    WHILE \<lbrace>BCmp (Load z) (\<noteq>) (Load r\<^sub>1)\<rbrace>;
    public := Load r\<^sub>2
   }"
  by natlang.vcgsolve presburger

end


theory Normalized_Matches
imports Fixed_Action
begin

section\<open>Normalized (DNF) matches\<close>

text\<open>simplify a match expression. The output is a list of match exprissions, the semantics is @{text "\<or>"} of the list elements.\<close>
fun normalize_match :: "'a match_expr \<Rightarrow> 'a match_expr list" where
  "normalize_match (MatchAny) = [MatchAny]" |
  "normalize_match (Match m) = [Match m]" |
  "normalize_match (MatchAnd m1 m2) = [MatchAnd x y. x <- normalize_match m1, y <- normalize_match m2]" |
  "normalize_match (MatchNot (MatchAnd m1 m2)) = normalize_match (MatchNot m1) @ normalize_match (MatchNot m2)" | (*DeMorgan*)
  "normalize_match (MatchNot (MatchNot m)) = normalize_match m" | (*idem*)
  "normalize_match (MatchNot (MatchAny)) = []" | (*false*)
  "normalize_match (MatchNot (Match m)) = [MatchNot (Match m)]"

lemma normalize_match_not_matcheq_matchNone: "\<forall>m' \<in> set (normalize_match m). \<not> matcheq_matchNone m'"
  proof(induction m rule: normalize_match.induct)
  case 4 thus ?case by (simp) blast
  qed(simp_all)

lemma normalize_match_empty_iff_matcheq_matchNone: "normalize_match m = [] \<longleftrightarrow> matcheq_matchNone m "
  proof(induction m rule: normalize_match.induct)
  case 3 thus ?case  by (simp) fastforce
  qed(simp_all)

lemma match_list_normalize_match: "match_list \<gamma> [m] a p \<longleftrightarrow> match_list \<gamma> (normalize_match m) a p"
  proof(induction m rule:normalize_match.induct)
  case 1 thus ?case by(simp add: match_list_singleton)
  next
  case 2 thus ?case by(simp add: match_list_singleton)
  next
  case (3 m1 m2) thus ?case
    apply(simp_all add: match_list_singleton del: match_list.simps(2))
    apply(case_tac "matches \<gamma> m1 a p")
     apply(rule matches_list_And_concat)
      apply(simp)
     apply(case_tac "(normalize_match m1)")
      apply simp
     apply (auto)[1]
    apply(simp add: bunch_of_lemmata_about_matches match_list_helper)
    done
  next
  case 4 thus ?case
    apply(simp_all add: match_list_singleton del: match_list.simps(2))
    apply(simp add: match_list_append)
    apply(safe)
        apply(simp_all add: matches_DeMorgan)
    done
  next
  case 5 thus ?case
    by(simp add: match_list_singleton bunch_of_lemmata_about_matches)
  next
  case 6 thus ?case
    by(simp add: match_list_singleton bunch_of_lemmata_about_matches)
  next
  case 7 thus ?case by(simp add: match_list_singleton)
qed

thm match_list_normalize_match[simplified match_list_singleton]

theorem normalize_match_correct: "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (normalize_match m)) s = approximating_bigstep_fun \<gamma> p [Rule m a] s"
apply(rule match_list_semantics[of _ _ _ _ "[m]", simplified])
using match_list_normalize_match by fastforce

lemma matches_to_match_list_normalize: "matches \<gamma> m a p = match_list \<gamma> (normalize_match m) a p"
  using match_list_normalize_match[simplified match_list_singleton] .

lemma wf_ruleset_normalize_match: "wf_ruleset \<gamma> p [(Rule m a)] \<Longrightarrow> wf_ruleset \<gamma> p (map (\<lambda>m. Rule m a) (normalize_match m))"
proof(induction m rule: normalize_match.induct)
  case 1 thus ?case by simp
  next
  case 2 thus ?case by simp
  next
  case 3 thus ?case by(simp add: fixedaction_wf_ruleset wf_ruleset_singleton matches_to_match_list_normalize)
  next
  case 4 thus ?case
    apply(simp add: wf_ruleset_append)
    apply(simp add: fixedaction_wf_ruleset)
    apply(unfold wf_ruleset_singleton)
    apply(safe) (*there is a simpler way but the simplifier takes for ever if we just apply it here, ...*)
           apply(simp_all add: matches_to_match_list_normalize)
         apply(simp_all add: match_list_append)
    done
  next
  case 5 thus ?case by(simp add: wf_ruleset_singleton matches_to_match_list_normalize)
  next
  case 6 thus ?case by(simp add: wf_ruleset_def)
  next
  case 7 thus ?case by(simp_all add: wf_ruleset_append)
  qed

lemma normalize_match_wf_ruleset: "wf_ruleset \<gamma> p (map (\<lambda>m. Rule m a) (normalize_match m)) \<Longrightarrow> wf_ruleset \<gamma> p [Rule m a]"
proof(induction m rule: normalize_match.induct)
  case 1 thus ?case by simp
  next
  case 2 thus ?case by simp
  next
  case 3 thus ?case by(simp add: fixedaction_wf_ruleset wf_ruleset_singleton matches_to_match_list_normalize)
  next
  case 4 thus ?case
    apply(simp add: wf_ruleset_append)
    apply(simp add: fixedaction_wf_ruleset)
    apply(unfold wf_ruleset_singleton)
    apply(safe)
         apply(simp_all add: matches_to_match_list_normalize)
         apply(simp_all add: match_list_append)
    done
  next
  case 5 thus ?case
    unfolding wf_ruleset_singleton by(simp add: matches_to_match_list_normalize)
  next
  case 6 thus ?case unfolding wf_ruleset_singleton by(simp add: bunch_of_lemmata_about_matches)
  next
  case 7 thus ?case by(simp add: wf_ruleset_append)
  qed

lemma good_ruleset_normalize_match: "good_ruleset [(Rule m a)] \<Longrightarrow> good_ruleset (map (\<lambda>m. Rule m a) (normalize_match m))"
by(simp add: good_ruleset_def)

section\<open>Normalizing rules instead of only match expressions\<close>
  fun normalize_rules :: "('a match_expr \<Rightarrow> 'a match_expr list) \<Rightarrow> 'a rule list \<Rightarrow> 'a rule list" where
    "normalize_rules _ [] = []" |
    "normalize_rules f ((Rule m a)#rs) = (map (\<lambda>m. Rule m a) (f m))@(normalize_rules f rs)"

  lemma normalize_rules_singleton: "normalize_rules f [Rule m a] = map (\<lambda>m. Rule m a) (f m)" by(simp)

  lemma normalize_rules_concat_map:
    "normalize_rules f rs = concat (map (\<lambda>r. map (\<lambda>m. Rule m (get_action r)) (f (get_match r))) rs)"
    apply(induction rs)
     apply(simp_all)
    apply(rename_tac r rs, case_tac r)
    apply(simp)
    done

  lemma good_ruleset_normalize_rules: "good_ruleset rs \<Longrightarrow> good_ruleset (normalize_rules f rs)"
    proof(induction rs)
    case Nil thus ?case by (simp)
    next
    case(Cons r rs)
      from Cons have IH: "good_ruleset (normalize_rules f rs)" using good_ruleset_tail by blast
      from Cons.prems have "good_ruleset [r]" using good_ruleset_fst by fast
      hence "good_ruleset (normalize_rules f [r])" by(cases r) (simp add: good_ruleset_alt)
      with IH good_ruleset_append have "good_ruleset (normalize_rules f [r] @ normalize_rules f rs)" by blast
      thus ?case using normalize_rules_fst by metis
    qed

  lemma simple_ruleset_normalize_rules: "simple_ruleset rs \<Longrightarrow> simple_ruleset (normalize_rules f rs)"
    proof(induction rs)
    case Nil thus ?case by (simp)
    next
    case(Cons r rs)
      from Cons have IH: "simple_ruleset (normalize_rules f rs)" using simple_ruleset_tail by blast
      from Cons.prems have "simple_ruleset [r]" using simple_ruleset_append by fastforce
      hence "simple_ruleset (normalize_rules f [r])" by(cases r) (simp add: simple_ruleset_def)
      with IH simple_ruleset_append have  "simple_ruleset (normalize_rules f [r] @ normalize_rules f rs)" by blast
      thus ?case using normalize_rules_fst by metis
    qed

  (*tuned version of the next lemma for usage with normalize_primitive_extract where P=normalized_nnf_match*)
  lemma normalize_rules_match_list_semantics_3:
    assumes "\<forall>m a. P m \<longrightarrow> match_list \<gamma> (f m) a p = matches \<gamma> m a p"
    and "simple_ruleset rs"
    and P: "\<forall> r \<in> set rs. P (get_match r)"
    shows "approximating_bigstep_fun \<gamma> p (normalize_rules f rs) s = approximating_bigstep_fun \<gamma> p rs s"
    proof -
      have assm_1: "\<forall>r\<in>set rs. match_list \<gamma> (f (get_match r)) (get_action r) p = matches \<gamma> (get_match r) (get_action r) p" using P assms(1) by blast
      { fix r s
        assume "r \<in> set rs"
        with assm_1 have "match_list \<gamma> (f (get_match r)) (get_action r) p \<longleftrightarrow> match_list \<gamma> [(get_match r)] (get_action r) p" by simp
        with match_list_semantics[of \<gamma> "f (get_match r)" "(get_action r)" p "[(get_match r)]"] have
          "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m (get_action r)) (f (get_match r))) s =
           approximating_bigstep_fun \<gamma> p [Rule (get_match r) (get_action r)] s" by simp
        hence "(approximating_bigstep_fun \<gamma> p (normalize_rules f [r]) s) = approximating_bigstep_fun \<gamma> p [r] s"
          by(cases r) (simp)
      }

    with assms show ?thesis
      proof(induction rs arbitrary: s)
        case Nil thus ?case by (simp)
      next
        case (Cons r rs)
        from Cons.prems have "simple_ruleset [r]" by(simp add: simple_ruleset_def)
        with simple_imp_good_ruleset good_imp_wf_ruleset have wf_r: "wf_ruleset \<gamma> p [r]" by fast

        from \<open>simple_ruleset [r]\<close> simple_imp_good_ruleset good_imp_wf_ruleset have wf_r:
          "wf_ruleset \<gamma> p [r]" by fast
        from simple_ruleset_normalize_rules[OF \<open>simple_ruleset [r]\<close>] have "simple_ruleset (normalize_rules f [r])"
          by(simp)
        with simple_imp_good_ruleset good_imp_wf_ruleset have wf_nr: "wf_ruleset \<gamma> p (normalize_rules f [r])" by fast

        from Cons have IH: "\<And>s. approximating_bigstep_fun \<gamma> p (normalize_rules f rs) s = approximating_bigstep_fun \<gamma> p rs s"
          using simple_ruleset_tail by force

        from Cons have a: "\<And>s. approximating_bigstep_fun \<gamma> p (normalize_rules f [r]) s = approximating_bigstep_fun \<gamma> p [r] s" by simp

        show ?case
          apply(subst normalize_rules_fst)
          apply(simp add: approximating_bigstep_fun_seq_wf[OF wf_nr])
          apply(subst approximating_bigstep_fun_seq_wf[OF wf_r, simplified])
          apply(simp add: a)
          apply(simp add: IH)
          done
      qed
    qed

 corollary normalize_rules_match_list_semantics:
  "(\<forall>m a. match_list \<gamma> (f m) a p = matches \<gamma> m a p) \<Longrightarrow> simple_ruleset rs \<Longrightarrow>
   approximating_bigstep_fun \<gamma> p (normalize_rules f rs) s = approximating_bigstep_fun \<gamma> p rs s"
  by(rule normalize_rules_match_list_semantics_3[where P="\<lambda>_. True"]) simp_all

lemma in_normalized_matches: "ls \<in> set (normalize_match m) \<and> matches \<gamma> ls a p \<Longrightarrow> matches \<gamma> m a p"
  by (meson match_list_matches matches_to_match_list_normalize)

 text\<open>applying a function (with a prerequisite @{text Q}) to all rules\<close>
 lemma normalize_rules_property:
 assumes "\<forall> r \<in> set rs. P (get_match r)"
     and "\<forall>m. P m \<longrightarrow> (\<forall>m' \<in> set (f m). Q m')"
  shows "\<forall>r \<in> set (normalize_rules f rs). Q (get_match r)"
  proof
    fix r' assume a: "r' \<in> set (normalize_rules f rs)"
    from a assms show "Q (get_match r')"
    proof(induction rs)
    case Nil thus ?case by simp
    next
    case (Cons r rs)
      {
        assume "r' \<in> set (normalize_rules f rs)"
        from Cons.IH this have "Q (get_match r')" using Cons.prems(2) Cons.prems(3) by fastforce
      } note 1=this
      {
        assume "r' \<in> set (normalize_rules f [r])"
        hence a: "(get_match r') \<in> set (f (get_match r))" by(cases r) (auto)
        with Cons.prems(2) Cons.prems(3) have "\<forall>m'\<in>set (f (get_match r)). Q m'" by auto
        with a have "Q (get_match r')" by blast
      } note 2=this
      from Cons.prems(1) have "r' \<in> set (normalize_rules f [r]) \<or> r' \<in> set (normalize_rules f rs)"
        by(subst(asm) normalize_rules_fst) auto
      with 1 2 show ?case
        by(elim disjE)(simp)
    qed
 qed

 text\<open>If a function @{text f} preserves some property of the match expressions, then this property is preserved when applying @{const normalize_rules}\<close>

 lemma normalize_rules_preserves: assumes "\<forall> r \<in> set rs. P (get_match r)"
     and "\<forall>m. P m \<longrightarrow> (\<forall>m' \<in> set (f m). P m')"
  shows "\<forall>r \<in> set (normalize_rules f rs). P (get_match r)"
  using normalize_rules_property[OF assms(1) assms(2)] by simp

fun normalize_rules_dnf :: "'a rule list \<Rightarrow> 'a rule list" where
  "normalize_rules_dnf [] = []" |
  "normalize_rules_dnf ((Rule m a)#rs) = (map (\<lambda>m. Rule m a) (normalize_match m))@(normalize_rules_dnf rs)"

lemma normalize_rules_dnf_append: "normalize_rules_dnf (rs1@rs2) = normalize_rules_dnf rs1 @ normalize_rules_dnf rs2"
  proof(induction rs1 rule: normalize_rules_dnf.induct)
  qed(simp_all)

lemma normalize_rules_dnf_def2: "normalize_rules_dnf = normalize_rules normalize_match"
  proof(simp add: fun_eq_iff, intro allI)
    fix x::"'a rule list" show "normalize_rules_dnf x = normalize_rules normalize_match x"
    proof(induction x)
    case (Cons r rs) thus ?case by (cases r) simp
    qed(simp)
  qed

lemma wf_ruleset_normalize_rules_dnf: "wf_ruleset \<gamma> p rs \<Longrightarrow> wf_ruleset \<gamma> p (normalize_rules_dnf rs)"
  proof(induction rs)
  case Nil thus ?case by simp
  next
  case(Cons r rs)
    from Cons have IH: "wf_ruleset \<gamma> p (normalize_rules_dnf rs)" by(auto dest: wf_rulesetD)
    from Cons.prems have "wf_ruleset \<gamma> p [r]" by(auto dest: wf_rulesetD)
    hence "wf_ruleset \<gamma> p (normalize_rules_dnf [r])" using wf_ruleset_normalize_match by(cases r) simp
    with IH wf_ruleset_append have "wf_ruleset \<gamma> p (normalize_rules_dnf [r] @ normalize_rules_dnf rs)" by fast
    thus ?case using normalize_rules_dnf_def2 normalize_rules_fst by metis
  qed

lemma good_ruleset_normalize_rules_dnf: "good_ruleset rs \<Longrightarrow> good_ruleset (normalize_rules_dnf rs)"
  using normalize_rules_dnf_def2 good_ruleset_normalize_rules by metis

lemma simple_ruleset_normalize_rules_dnf: "simple_ruleset rs \<Longrightarrow> simple_ruleset (normalize_rules_dnf rs)"
  using normalize_rules_dnf_def2 simple_ruleset_normalize_rules by metis

(*This is the simple correctness proof, using the generalized version.
  below, we have a more complex correctness proof with a slighter generic assumption.
  Probably, we can delete the complex proof when we only focus on simple rulesets
  *)
lemma "simple_ruleset rs \<Longrightarrow>
  approximating_bigstep_fun \<gamma> p (normalize_rules_dnf rs) s = approximating_bigstep_fun \<gamma> p rs s"
  unfolding normalize_rules_dnf_def2
  apply(rule normalize_rules_match_list_semantics)
   apply (metis matches_to_match_list_normalize)
  by simp

lemma normalize_rules_dnf_correct: "wf_ruleset \<gamma> p rs \<Longrightarrow>
  approximating_bigstep_fun \<gamma> p (normalize_rules_dnf rs) s = approximating_bigstep_fun \<gamma> p rs s"
  proof(induction rs)
  case Nil thus ?case by simp
  next
  case (Cons r rs)
    show ?case
    proof(induction s rule: just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
    case Undecided
    from Cons wf_rulesetD(2) have IH: "approximating_bigstep_fun \<gamma> p (normalize_rules_dnf rs) s = approximating_bigstep_fun \<gamma> p rs s" by fast
    from Cons.prems have "wf_ruleset \<gamma> p [r]" and "wf_ruleset \<gamma> p (normalize_rules_dnf [r])"
      by(auto dest: wf_rulesetD simp: wf_ruleset_normalize_rules_dnf)
    with IH Undecided have
      "approximating_bigstep_fun \<gamma> p (normalize_rules_dnf rs) (approximating_bigstep_fun \<gamma> p (normalize_rules_dnf [r]) Undecided) = approximating_bigstep_fun \<gamma> p (r # rs) Undecided"
      apply(cases r, rename_tac m a)
      apply(simp)
      apply(case_tac a)
              apply(simp_all add: normalize_match_correct Decision_approximating_bigstep_fun wf_ruleset_singleton)
      done
    hence "approximating_bigstep_fun \<gamma> p (normalize_rules_dnf [r] @ normalize_rules_dnf rs) s = approximating_bigstep_fun \<gamma> p (r # rs) s"
      using Undecided \<open>wf_ruleset \<gamma> p [r]\<close> \<open>wf_ruleset \<gamma> p (normalize_rules_dnf [r])\<close>
      by(simp add: approximating_bigstep_fun_seq_wf)
    thus ?thesis using normalize_rules_fst normalize_rules_dnf_def2 by metis
    qed
  qed

fun normalized_nnf_match :: "'a match_expr \<Rightarrow> bool" where
  "normalized_nnf_match MatchAny = True" |
  "normalized_nnf_match (Match _ ) = True" |
  "normalized_nnf_match (MatchNot (Match _)) = True" |
  "normalized_nnf_match (MatchAnd m1 m2) = ((normalized_nnf_match m1) \<and> (normalized_nnf_match m2))" |
  "normalized_nnf_match _ = False"

text\<open>Essentially, @{term normalized_nnf_match} checks for a negation normal form: Only AND is at toplevel, negation only occurs in front of literals.
 Since @{typ "'a match_expr"} does not support OR, the result is in conjunction normal form.
 Applying @{const normalize_match}, the reuslt is a list. Essentially, this is the disjunctive normal form.\<close>

lemma normalize_match_already_normalized: "normalized_nnf_match m \<Longrightarrow> normalize_match m = [m]"
  by(induction m rule: normalize_match.induct) (simp)+

lemma normalized_nnf_match_normalize_match: "\<forall> m' \<in> set (normalize_match m). normalized_nnf_match m'"
  proof(induction m arbitrary: rule: normalize_match.induct)
  case 4 thus ?case by fastforce
  qed (simp_all)

lemma normalized_nnf_match_MatchNot_D: "normalized_nnf_match (MatchNot m) \<Longrightarrow> normalized_nnf_match m"
  by(induction m) (simp_all)

text\<open>Example\<close>
lemma "normalize_match (MatchNot (MatchAnd (Match ip_src) (Match tcp))) = [MatchNot (Match ip_src), MatchNot (Match tcp)]" by simp

subsection\<open>Functions which preserve @{const normalized_nnf_match}\<close>

lemma optimize_matches_option_normalized_nnf_match: "(\<And> r. r \<in> set rs \<Longrightarrow> normalized_nnf_match (get_match r)) \<Longrightarrow>
     (\<And>m m'. normalized_nnf_match m \<Longrightarrow> f m = Some m' \<Longrightarrow> normalized_nnf_match m') \<Longrightarrow>
      \<forall> r \<in> set (optimize_matches_option f rs). normalized_nnf_match (get_match r)"
    proof(induction rs)
      case Nil thus ?case by simp
    next
      case (Cons r rs)
      from Cons.IH Cons.prems have IH: "\<forall>r\<in>set (optimize_matches_option f rs). normalized_nnf_match (get_match r)" by simp
      from Cons.prems have "\<forall>r\<in>set (optimize_matches_option f [r]). normalized_nnf_match (get_match r)"
        apply(cases r)
        apply(simp split: option.split)
        by force (*1s*)
      with IH show ?case by(cases r, simp split: option.split_asm)
    qed

lemma optimize_matches_normalized_nnf_match: "\<lbrakk>\<forall> r \<in> set rs. normalized_nnf_match (get_match r); \<forall>m. normalized_nnf_match m \<longrightarrow> normalized_nnf_match (f m) \<rbrakk> \<Longrightarrow>
      \<forall> r \<in> set (optimize_matches f rs). normalized_nnf_match (get_match r)"
  unfolding optimize_matches_def
  apply(rule optimize_matches_option_normalized_nnf_match)
   apply(simp; fail)
  apply(simp split: if_split_asm)
  by blast

lemma normalize_rules_dnf_normalized_nnf_match: "\<forall>x \<in> set (normalize_rules_dnf rs). normalized_nnf_match (get_match x)"
  proof(induction rs)
  case Nil thus ?case by simp
  next
  case (Cons r rs) thus ?case using normalized_nnf_match_normalize_match by(cases r) fastforce
  qed

end


theory LLVM_Semantics
imports Monad2 LLVM_Syntax LLVM_Memory
begin

  datatype memT = MEM_TYPE (memT: "type option list")
  hide_const (open) memT

  fun vaddr_of_type :: "type \<Rightarrow> vaddr \<Rightarrow> type \<Rightarrow> bool" where
    "vaddr_of_type bT [] T \<longleftrightarrow> T=bT"
  | "vaddr_of_type (TARRAY n bT) (VA_ARRAY_IDX i#as) T \<longleftrightarrow> \<^cancel>\<open>*i<n \<and> \<close> vaddr_of_type bT as T"
  | "vaddr_of_type (TSTRUCT bTs) (VA_FIELD_IDX i#as) T \<longleftrightarrow> i<length bTs \<and> vaddr_of_type (bTs!i) as T"
  | "vaddr_of_type _ _ _ \<longleftrightarrow> False"

  context fixes \<mu>T :: memT begin

    definition addr_of_type where
      "addr_of_type a T \<equiv>
        let
          b = the_block (addr.block_addr a);
          \<mu>T = memT.memT \<mu>T
        in
          if b < length \<mu>T then
            case \<mu>T!b of
              None \<Rightarrow> True
            | Some bT \<Rightarrow> vaddr_of_type bT (addr.vaddr a) T
          else False"

    fun of_type :: "type \<Rightarrow> val \<Rightarrow> bool"
    where
      "of_type (TINT w) (VINT v) \<longleftrightarrow> w = wpi_width v"
    | "of_type (TPTR T) (VPTR (Some (Some a))) \<longleftrightarrow> addr_of_type a T"
    | "of_type (TPTR T) (VPTR _) \<longleftrightarrow> True"
    | "of_type (TARRAY n T) (VARRAY vs) \<longleftrightarrow> n=length vs \<and> (\<forall>v\<in>List.set vs. of_type T v)"
    | "of_type (TSTRUCT Ts) (VSTRUCT vs) \<longleftrightarrow> list_all2 of_type Ts vs"
    | "of_type _ _ \<longleftrightarrow> False"

  end

  definition mem_of_type :: "memT \<Rightarrow> memory \<Rightarrow> bool"
    where "mem_of_type \<mu>T \<mu> \<equiv> list_all2 (rel_option (of_type \<mu>T)) (memT.memT \<mu>T) (map (map_option fst) (get' (mem\<^sub>L) \<mu>))"

  lemma mem_of_type_lengthD:
    "mem_of_type \<mu>T \<mu> \<Longrightarrow> length (memT.memT \<mu>T) = length (get' mem\<^sub>L \<mu>)"
    "mem_of_type (MEM_TYPE Ts) \<mu> \<Longrightarrow> length (Ts) = length (get' mem\<^sub>L \<mu>)"
    by (auto simp: mem_of_type_def list_all2_lengthD)

(*
  definition op_get_field where
    "op_get_field v i \<equiv> mget (struct_field\<^sub>L i) v"
  definition op_put_field where
    "op_put_field v i v' \<equiv> mput (struct_field\<^sub>L i) v' v"

  definition op_get_array_item where
    "op_get_array_item v i \<equiv> mget (array_item\<^sub>L i) v"
  definition op_put_array_item where
    "op_put_array_item v i v' \<equiv> mput (array_item\<^sub>L i) v' v"
*)
  (*
  definition op_ptr_field where
    "op_ptr_field p i \<equiv> p \<bullet> (struct_field\<^sub>L i)"
  definition op_ptr_array_item where
    "op_ptr_array_item p i \<equiv> p \<bullet> array_item\<^sub>L i"
  *)

  datatype exec_state = EXEC_STATE
    (lvars: "lvar_name \<rightharpoonup> val")
    (local_blocks: "block_addr list")
    (memory: "memory")
  hide_const (open) lvars local_blocks memory
  define_lenses (open) exec_state

  (*
  lemma exec_state_l_indep[simp]:
    "exec_state.lvars\<^sub>L \<bowtie> exec_state.memory\<^sub>L"
    "exec_state.lvars\<^sub>L \<bowtie> exec_state.local_blocks\<^sub>L"
    "exec_state.local_blocks\<^sub>L \<bowtie> exec_state.memory\<^sub>L"
    apply unfold_locales
    unfolding exec_state.lvars\<^sub>L_def exec_state.memory\<^sub>L_def exec_state.local_blocks\<^sub>L_def
    find_theorems "\<not>True \<longleftrightarrow> False"
    apply (simp only: LENS_downstage option.sel exec_state.simps option.simps HOL.simp_thms split: exec_state.splits | intro allI impI conjI)+
  *)

  definition "lvar\<^sub>L x \<equiv> (exec_state.lvars\<^sub>L \<bullet>\<^sub>L fun\<^sub>L x \<bullet>\<^sub>L the\<^sub>L)\<^sub>S"
  lemma lvar\<^sub>L_elens[simp]: "elens (lvar\<^sub>L x)"
    by (auto simp: lvar\<^sub>L_def)

  fun load_opr where
    "load_opr ty (OP_ICONST i) = (
      case ty of
        TINT w \<Rightarrow> doM {
          fcheck (STATIC_ERROR ''i0 type'') (w\<noteq>0); \<^cancel>\<open>TODO: How does LLVM handle overflow? The same way as lconst? \<close>
          return (VINT (Inr (lconst w i)))
        }
      | _ \<Rightarrow> fail (STATIC_ERROR ''int const with non-int type''))"
  | "load_opr _ (OP_LVAR x) = use (lvar\<^sub>L x)" \<comment> \<open>We omit a type check here\<close>

  definition "to_idx i \<equiv> doM {fcheck MEM_ERROR (i\<ge>0); return (nat i)}"

  definition load_int where
    "load_int ty opr \<equiv> doM {
      v \<leftarrow> load_opr ty opr;
      to_lint v
    }"

  definition load_ptr where
    "load_ptr ty opr \<equiv> doM {
      v \<leftarrow> load_opr ty opr;
      to_ptr v
    }"

  definition load_addr where
    "load_addr ty opr \<equiv> doM {
      v \<leftarrow> load_opr ty opr;
      to_addr v
    }"

  definition load_bool where
    "load_bool ty opr \<equiv> doM {
      v \<leftarrow> load_opr ty opr;
      to_bool v
    }"

  definition define_lvar where
    "define_lvar name val \<equiv> zoom (exec_state.lvars\<^sub>L)\<^sub>S (doM {
      l\<leftarrow>get;
      fcheck (STATIC_ERROR ''lvar redefined'') (name \<notin> dom l);
      let l = l(name\<mapsto>val);
      set l
    })"

definition "noexcept m \<equiv> handle m (\<lambda>_. fail (STATIC_ERROR ''noexcept''))"
lemma noexcept_mono[partial_function_mono]:
  "monotone M.le_fun M_ord m \<Longrightarrow> monotone M.le_fun M_ord (\<lambda>f. noexcept (m f))"
  unfolding noexcept_def
  by pf_mono_prover

fun lint_icmp where
  "lint_icmp icmp_code.EQ a b \<longleftrightarrow>  (a = b)"
| "lint_icmp icmp_code.NE a b \<longleftrightarrow>  (a \<noteq> b)"
| "lint_icmp icmp_code.ULE a b \<longleftrightarrow> (a \<le> b)"
| "lint_icmp icmp_code.ULT a b \<longleftrightarrow> (a < b)"
| "lint_icmp icmp_code.SLE a b \<longleftrightarrow> (a \<le>\<^sub>s b)"
| "lint_icmp icmp_code.SLT a b \<longleftrightarrow> (a <\<^sub>s b)"

definition "instr_alloca ty n = doM {
  fcheck MEM_ERROR (n>0);
  let n = nat n;
  let v = uninit (TARRAY n ty);
  r \<leftarrow> zoom (exec_state.memory\<^sub>L)\<^sub>S (block_allocate block_type.ON_STACK v);
  (exec_state.local_blocks\<^sub>L)\<^sub>S %= (#) r;
  return (ADDR r [VA_ARRAY_IDX 0])
}"

(*definition "instr_malloc ty n = doM {
  fcheck MEM_ERROR (n>0);
  let n = nat n;
  let v = uninit (TARRAY n ty);
  r \<leftarrow> zoom (exec_state.memory\<^sub>L)\<^sub>S (block_allocate block_type.ON_HEAP v);
  return (ADDR r [VA_ARRAY_IDX 0])
}"*)

(*
definition "instr_free addr = doM {
  case addr of
      ADDR b [VA_ARRAY_IDX 0] \<Rightarrow> zoom (exec_state.memory\<^sub>L)\<^sub>S (block_free block_type.ON_HEAP b)
    | _ \<Rightarrow> fail MEM_ERROR
}"
*)

(*
definition instr_load where
  "instr_load addr \<equiv> doM {
    zoom (exec_state.memory\<^sub>L)\<^sub>S (use (lens_of_addr addr))
  }"

definition instr_store where
  "instr_store v addr \<equiv> doM {
    zoom (exec_state.memory\<^sub>L)\<^sub>S (doM {
      ov \<leftarrow> use (lens_of_addr addr);
      fcheck (STATIC_ERROR ''mem-struct change'') (same_struct v ov);
      lens_of_addr addr := v
    })
  }"
*)

definition "instr_malloc ty n = zoom (exec_state.memory\<^sub>L)\<^sub>S (llb_malloc ty n)"
definition "instr_free addr = zoom (exec_state.memory\<^sub>L)\<^sub>S (llb_free addr)"
definition "instr_load addr = zoom (exec_state.memory\<^sub>L)\<^sub>S (llb_load addr)"
definition "instr_store v addr = zoom (exec_state.memory\<^sub>L)\<^sub>S (llb_store v addr)"

(*definition "instr_insert_a_value bv ev idx \<equiv> put_same_struct (array_item\<^sub>L idx) ev bv"
definition "instr_insert_s_value bv ev idx \<equiv> put_same_struct (struct_field\<^sub>L idx) ev bv"
definition "instr_extract_a_value bv idx \<equiv> mget (array_item\<^sub>L idx) bv"
definition "instr_extract_s_value bv idx \<equiv> mget (struct_field\<^sub>L idx) bv"
*)

(*
definition instr_ofs_addr :: "addr \<Rightarrow> int \<Rightarrow> _" where
  "instr_ofs_addr a i \<equiv> map_lens (addr.vaddr\<^sub>L\<bullet>\<^sub>Llast\<^sub>L\<bullet>\<^sub>Lva_item.aidx\<^sub>L)\<^sub>M (\<lambda>idx. doM {
    let idx = int idx + i;
    fcheck MEM_ERROR (idx\<ge>0);
    return (nat idx)
  }) a"

definition instr_idx_array :: "addr \<Rightarrow> int \<Rightarrow> _" where
  "instr_idx_array a i \<equiv> map_lens (addr.vaddr\<^sub>L)\<^sub>S (\<lambda>x. doM {
    i \<leftarrow> to_idx i;
    return (x@[VA_ARRAY_IDX i])
  } ) a"

definition instr_idx_field :: "addr \<Rightarrow> nat \<Rightarrow> _" where
  "instr_idx_field a i \<equiv> map_lens (addr.vaddr\<^sub>L)\<^sub>S (\<lambda>x. doM {
    return (x@[VA_FIELD_IDX i])
  } ) a"
*)

definition "instr_arith2 ovf f ty op1 op2 = doM {
  x1 \<leftarrow> load_int ty op1;
  x2 \<leftarrow> load_int ty op2;
  fcheck (STATIC_ERROR ''arith2 incompatible widths'') (width x1 = width x2);
  fcheck (OVERFLOW_ERROR) (\<not>ovf x1 x2);
  return (Some (VINT (Inr (f x1 x2))))
}"

abbreviation "instr_arith2' \<equiv> instr_arith2 (\<lambda>_ _. False)"

definition "instr_arith_cmp f ty op1 op2 = doM {
  x1 \<leftarrow> load_int ty op1;
  x2 \<leftarrow> load_int ty op2;
  fcheck (STATIC_ERROR ''arith2cmp incompatible widths'') (width x1 = width x2);
  return (Some (VINT (Inr (bool_to_lint (f x1 x2)))))
}"

definition "instr_trunc ty op1 ty' = doM {
  x \<leftarrow> load_int ty op1;
  case ty' of
    TINT w \<Rightarrow> doM {
      fcheck (STATIC_ERROR ''Trunc must go to smaller type'') (width x > w);
      return (Some (VINT (Inr (trunc w x))))
    }
  | _ \<Rightarrow> fail (STATIC_ERROR ''Non-integer type as target for trunc'')
}"

definition "instr_ext f ty op1 ty' = doM {
  x \<leftarrow> load_int ty op1;
  case ty' of
    TINT w \<Rightarrow> doM {
      fcheck (STATIC_ERROR ''ext must go to greater type'') (width x < w);
      return (Some (VINT (Inr (f w x))))
    }
  | _ \<Rightarrow> fail (STATIC_ERROR ''Non-integer type as target for ext'')
}"

context
  fixes exec_proc_name :: "proc_name \<times> val list \<Rightarrow> (val option,unit,memory,err) M"
begin

  primrec exec_basic_instr_aux where
    "exec_basic_instr_aux (ADD ty op1 op2) = instr_arith2' (+) ty op1 op2"
  | "exec_basic_instr_aux (SUB ty op1 op2) = instr_arith2' (-) ty op1 op2"
  | "exec_basic_instr_aux (MUL ty op1 op2) = instr_arith2' ( * ) ty op1 op2"
  | "exec_basic_instr_aux (UDIV ty op1 op2) = instr_arith2' (div) ty op1 op2"
  | "exec_basic_instr_aux (UREM ty op1 op2) = instr_arith2' (mod) ty op1 op2"
  | "exec_basic_instr_aux (SDIV ty op1 op2) = instr_arith2 (sdivrem_ovf) (div\<^sub>s) ty op1 op2"
  | "exec_basic_instr_aux (SREM ty op1 op2) = instr_arith2 (sdivrem_ovf) (rem\<^sub>s) ty op1 op2"
  | "exec_basic_instr_aux (SHL ty op1 op2) = instr_arith2 (shift_ovf) bitSHL' ty op1 op2"
  | "exec_basic_instr_aux (LSHR ty op1 op2) = instr_arith2 (shift_ovf) bitLSHR' ty op1 op2"
  | "exec_basic_instr_aux (ASHR ty op1 op2) = instr_arith2 (shift_ovf) bitASHR' ty op1 op2"
  | "exec_basic_instr_aux (ICMP code ty op1 op2) = instr_arith_cmp (lint_icmp code) ty op1 op2"

  | "exec_basic_instr_aux (TRUNC_TO ty op1 ty') = instr_trunc ty op1 ty'"
  | "exec_basic_instr_aux (ZEXT_TO ty op1 ty') = instr_ext zext ty op1 ty'"
  | "exec_basic_instr_aux (SEXT_TO ty op1 ty') = instr_ext sext ty op1 ty'"

  | "exec_basic_instr_aux (basic_instr_aux.AND ty op1 op2) = instr_arith2' (AND) ty op1 op2"
  | "exec_basic_instr_aux (basic_instr_aux.OR ty op1 op2) = instr_arith2' (OR) ty op1 op2"
  | "exec_basic_instr_aux (basic_instr_aux.XOR ty op1 op2) = instr_arith2' (XOR) ty op1 op2"
  | "exec_basic_instr_aux (ALLOCA ty tyi opr) = doM {
      n \<leftarrow> load_int tyi opr;
      addr \<leftarrow> instr_alloca ty (lint_to_uint n);
      return (Some (VPTR (Some (Some addr))))
    }"
  | "exec_basic_instr_aux (MALLOC ty tyi opr) = doM {
      n \<leftarrow> load_int tyi opr;
      addr \<leftarrow> instr_malloc ty (lint_to_uint n);
      return (Some (VPTR (Some (Some addr))))
    }"
  | "exec_basic_instr_aux (FREE ty opr) = doM {
      addr \<leftarrow> load_addr ty opr;
      instr_free addr;
      return None
    }"
  | "exec_basic_instr_aux (LOAD ty typ opr) = doM {
      addr \<leftarrow> load_addr typ opr;
      r \<leftarrow> instr_load addr;
      return (Some r)
    }"
  | "exec_basic_instr_aux (STORE tyv oprv typ oprp) = doM {
      v \<leftarrow> load_opr tyv oprv;
      addr \<leftarrow> load_addr typ oprp;
      instr_store v addr;
      return None
    }"
  | "exec_basic_instr_aux (INSERT_A_VALUE bty bopr ety eopr idx) = doM {
      bv \<leftarrow> load_opr bty bopr;
      ev \<leftarrow> load_opr ety eopr;
      r \<leftarrow> ll_insert_a_value' bv ev idx;
      return (Some r)
    }"
  | "exec_basic_instr_aux (INSERT_S_VALUE bty bopr ety eopr idx) = doM {
      bv \<leftarrow> load_opr bty bopr;
      ev \<leftarrow> load_opr ety eopr;
      r \<leftarrow> ll_insert_s_value' bv ev idx;
      return (Some r)
    }"
  | "exec_basic_instr_aux (EXTRACT_A_VALUE bty bopr idx) = doM {
      bv \<leftarrow> load_opr bty bopr;
      r \<leftarrow> ll_extract_a_value' bv idx;
      return (Some r)
    }"
  | "exec_basic_instr_aux (EXTRACT_S_VALUE bty bopr idx) = doM {
      bv \<leftarrow> load_opr bty bopr;
      r \<leftarrow> ll_extract_s_value' bv idx;
      return (Some r)
    }"
  | "exec_basic_instr_aux (OFS_PTR bty bopr ity iopr) = doM {
      addr \<leftarrow> load_addr (TPTR bty) bopr;
      idx \<leftarrow> load_int ity iopr;
      r \<leftarrow> llb_ofs_addr addr (lint_to_sint idx);
      return (Some ((VPTR (Some (Some r)))))
    }"
  | "exec_basic_instr_aux (INDEX_A_PTR bty bopr ity iopr) = doM {
      addr \<leftarrow> load_addr (TPTR bty) bopr;
      idx \<leftarrow> load_int ity iopr;
      r \<leftarrow> llb_idx_array addr (lint_to_uint idx);
      return (Some ((VPTR (Some (Some r)))))
    }"
  | "exec_basic_instr_aux (INDEX_S_PTR bty bopr idx) = doM {
      addr \<leftarrow> load_addr (TPTR bty) bopr;
      r \<leftarrow> llb_idx_field addr idx;
      return (Some ((VPTR (Some (Some r)))))
    }"

  primrec exec_nt_instr_aux where
    "exec_nt_instr_aux (BASIC i) = exec_basic_instr_aux i"
  | "exec_nt_instr_aux (CALL ty name args) = doM {
      argvs \<leftarrow> mmap (uncurry load_opr) args;
      r \<leftarrow> zoom (exec_state.memory\<^sub>L)\<^sub>S (noexcept (exec_proc_name (name, argvs)));
      return r
    }"

  primrec exec_nt_instr where
    "exec_nt_instr (NT_INSTR resname i) = doM {
      r \<leftarrow> exec_nt_instr_aux i;
      case resname of
        None \<Rightarrow> return ()
      | Some resvar \<Rightarrow> doM {
        r \<leftarrow> mget (the\<^sub>L)\<^sub>S r;
        define_lvar resvar r
      }
    }"

  primrec exec_t_instr where
    "exec_t_instr (RETURN_VOID) = raise None"
  | "exec_t_instr (RETURN ty opr) = doM { v \<leftarrow> load_opr ty opr; raise (Some v) }"
  | "exec_t_instr (BR label) = return label"
  | "exec_t_instr (CBR ty opr lt lf) = doM {
      v \<leftarrow> load_bool ty opr;
      if v then return lt else return lf
  }"

  definition "exec_block \<equiv> \<lambda>BBLOCK ntis ti\<Rightarrow> doM {
    \<comment> \<open>Execute nonterminal instructions\<close>
    mfold' exec_nt_instr ntis;
    \<comment> \<open>Execute terminal instruction\<close>
    exec_t_instr ti
  }"

  term mmblock

  definition "exec_block_reset block \<equiv> doM {
    \<comment> \<open>Save local definitions\<close>
    saved_lvars \<leftarrow> use (exec_state.lvars\<^sub>L)\<^sub>S;

    mmblock (get) (\<lambda>s'. doM {set s'; (exec_state.lvars\<^sub>L)\<^sub>S := saved_lvars}) (exec_block block)
  }"

  definition "mk_fresh_exec_state mem \<equiv> EXEC_STATE Map.empty [] mem"

  definition "exec_proc \<equiv> \<lambda>PROC params prologue blocks rtype \<Rightarrow> \<lambda>args. doM {
    fcheck (STATIC_ERROR ''|arg| != |param|'') (length params = length args);
    mblock (mk_fresh_exec_state) (get' exec_state.memory\<^sub>L) (doM {
      \<comment> \<open>Define Parameters\<close>
      mfold' (uncurry define_lvar) (zip (map snd params) args);

      handle (doM {
        \<comment> \<open>Execute Prologue\<close>
        label \<leftarrow> exec_block prologue;

        \<comment> \<open>Execute Blocks\<close>
        let block_map = map_of blocks;
        mwhile (\<lambda>_. return True) (\<lambda>label. doM {
          \<comment> \<open>Lookup label\<close>
          block \<leftarrow> lookup (STATIC_ERROR ''undef label'') block_map label;
          exec_block_reset block
        }) label;

        fail (STATIC_ERROR ''unreachable'') \<comment> \<open>Unreachable\<close>
      }) (\<lambda>r. doM {
        \<comment> \<open>Free alloca-blocks\<close>
        lbs \<leftarrow> use (exec_state.local_blocks\<^sub>L)\<^sub>S;
        mfold' (\<lambda>b. zoom (exec_state.memory\<^sub>L)\<^sub>S (block_free block_type.ON_STACK b)) lbs;
        \<comment> \<open>Return result\<close>
        return r})
    })
  }"

end (* Context fixing \<open>exec_proc_name\<close> *)

term exec_proc

context fixes \<pi> :: program begin
  definition "proc_map \<equiv> map_of (program.procedures \<pi>)"

  definition "exec_proc_name \<equiv>
    REC (\<lambda>exec_proc_name (name,args). doM {
      proc \<leftarrow> lookup (STATIC_ERROR ''undef proc'') proc_map name;
      exec_proc exec_proc_name proc args
    }) "

end

term exec_proc

lemma rec_cases_instr_eq:
  "rec_nt_instr = case_nt_instr"
  "rec_nt_instr_aux = case_nt_instr_aux"
  by (intro ext; auto split: nt_instr.split nt_instr_aux.split; fail)+

thm partial_function_mono(10)

lemma execute_proc_body_mono[partial_function_mono]:
  "M.mono_body (\<lambda>fa. exec_proc fa proc args)"
  unfolding exec_proc_def exec_block_def exec_nt_instr_def exec_nt_instr_aux_def
    exec_block_reset_def
  unfolding rec_cases_instr_eq
  by pf_mono_prover

(*lemmas exec_proc_name_unfold[code] = REC_unfold[OF exec_proc_name_def, discharge_monos]*)

lemmas exec_proc_name_unfold[code] = REC_unfold[OF exec_proc_name_def, discharge_monos]
   and exec_proc_name_partial = lrmwpe_REC_partial[OF exec_proc_name_def, discharge_monos, consumes 1, case_names nterm step]
   and exec_proc_name_total = lrmwpe_REC_total[OF exec_proc_name_def, discharge_monos, consumes 1, case_names wf step]

term mwhile
term exec_proc_name

definition "foo a b \<equiv> (a::lint) = b"

definition "test \<equiv> PROG [(PROC_NAME ''main'',PROC [] (
  BBLOCK [
    NT_INSTR (Some (LVAR_NAME ''p'')) (BASIC (MALLOC (TINT 32) (TINT 32) (OP_ICONST 5)))
    ,
    NT_INSTR (Some (LVAR_NAME ''p2'')) (BASIC (OFS_PTR (TINT 32) (OP_LVAR (LVAR_NAME ''p'')) (TINT 32) (OP_ICONST 2)))
    ,
    NT_INSTR None (BASIC (STORE (TINT 32) (OP_ICONST 42) (TPTR (TINT 32)) (OP_LVAR (LVAR_NAME ''p2''))))

  ] (RETURN (TPTR (TINT 32)) (OP_LVAR (LVAR_NAME ''p'')))
) [] (Some (TPTR (TINT 32))))]"

value "run (exec_proc_name test (PROC_NAME ''main'',[])) (MEM [])"

end