theory Proof_5_3
  imports Requirements VCTheoryLemmas
begin

abbreviation s where "s s0 requestButton_value \<equiv>(toEnv (setVarBool (setVarAny s0 requestButton_value) redAfterMinimalRed PRESSED)) "

lemma VC3_R5_aux1: "toEnvP s2 \<and> toEnvP s0 \<and> substate s2 s0 \<and> toEnvNum s2 s3 < T1 \<and> s3 = s s0 requestButton_value \<Longrightarrow>
toEnvNum s2 s0 < T1"
  apply auto
  apply(simp split: if_splits)
  using substate_refl substate_asym[of s0 "s s0 requestButton_value"] by  auto

lemma VC3_R5: "  (toEnvP s0 \<and>
        (\<forall>s1 s2 s3.
            substate s1 s2 \<and>
            substate s2 s3 \<and>
            substate s3 s0 \<and>
            toEnvP s1 \<and>
            toEnvP s2 \<and>
            toEnvP s3 \<and>
            toEnvNum s1 s2 = Ctrl \<and>
            toEnvNum s2 s3 < T1 \<and> getVarBool s1 minimalRed \<noteq> NOT_PRESSED \<and> getVarBool s2 minimalRed = NOT_PRESSED \<longrightarrow>
            getVarBool s3 minimalRed = NOT_PRESSED)) \<and>
       env (setVarAny s0 requestButton_value) requestButton_value \<and>
       getPstate (setVarAny s0 requestButton_value) Ctrl = minimalRed \<and>
       getVarBool (setVarAny s0 requestButton_value) Ctrl \<and>
       \<not> MINIMAL_RED_TIME_LIMIT
          \<le> ltimeEnv (setVarBool (setVarAny s0 requestButton_value) redAfterMinimalRed PRESSED) Ctrl \<Longrightarrow>
       substate s1 s2 \<and>
       substate s2 s3 \<and>
       substate s3 (s s0 requestButton_value) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvP s3 \<and>
       toEnvNum s1 s2 = Ctrl \<and>
       toEnvNum s2 s3 < T1 \<and> getVarBool s1 minimalRed \<noteq> NOT_PRESSED \<and> getVarBool s2 minimalRed = NOT_PRESSED \<Longrightarrow>
       getVarBool s3 minimalRed = NOT_PRESSED"
  apply(cases "s3 = s s0 requestButton_value")
   apply(cases "s2 = s s0 requestButton_value")
    apply blast
   apply(rule cut_rl[of "substate s2 s0"])
    apply(rule cut_rl[of "getVarBool s0 trafficLight = RED"])
  apply (metis getVarBool.simps(2) getVarBool.simps(4) getVarBool.simps(6) getVarBool.simps(7) numeral_eq_iff one_eq_numeral_iff semiring_norm(85) semiring_norm(89))
    apply(drule conjE)
     prefer 2
     apply assumption
apply(drule conjE)
     prefer 2
     apply assumption
apply(drule conjE)
     prefer 2
     apply assumption
apply(drule allE[of _ s1])
     prefer 2
  apply assumption
   apply(drule allE[of _ s2])
     prefer 2
     apply assumption
apply(drule allE[of _ s0])
     prefer 2
     apply assumption
    apply(rule cut_rl[of "toEnvNum s2 s0 < T1"])
  using substate_refl apply fast
    apply((rule VC3_R5_aux1);fast)
  apply (metis substate.simps(2) substate.simps(4) substate.simps(6) substate.simps(7) toEnvP.simps(4) toEnvP.simps(6) toEnvP.simps(7))
  apply(rule cut_rl [of "substate s3 s0"])
   apply blast
  by (metis substate.simps(2) substate.simps(4) substate.simps(6) substate.simps(7) toEnvP.simps(4) toEnvP.simps(6) toEnvP.simps(7))

theorem proof_5_3: "VC3 R5 s0 requestButton_value"
  apply(simp only: VC3_def R5_def)
  apply(rule impI)
  apply(rule conjI)
   apply simp
  apply((rule allI);(rule allI);(rule allI))
  apply(rule impI)
  by ((rule VC3_R5);assumption)


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

(*
   Nondeterministic state and error monads with failure in Isabelle.
*)

chapter "Nondeterministic State Monad with Failure"

theory NonDetMonad
  imports
    Fun_Pred_Syntax
    Monad_Lib
begin

text \<open>
  \label{c:monads}

  State monads are used extensively in the seL4 specification. They are defined below.\<close>

section "The Monad"

text \<open>
  The basic type of the nondeterministic state monad with failure is
  very similar to the normal state monad. Instead of a pair consisting
  of result and new state, we return a set of these pairs coupled with
  a failure flag. Each element in the set is a potential result of the
  computation. The flag is @{const True} if there is an execution path
  in the computation that may have failed. Conversely, if the flag is
  @{const False}, none of the computations resulting in the returned
  set can have failed.\<close>
type_synonym ('s, 'a) nondet_monad = "'s \<Rightarrow> ('a \<times> 's) set \<times> bool"

text \<open>
  Print the type @{typ "('s,'a) nondet_monad"} instead of its unwieldy expansion.
  Needs an AST translation in code, because it needs to check that the state variable
  @{typ 's} occurs twice. This comparison is not guaranteed to always work as expected
  (AST instances might have different decoration), but it does seem to work here.\<close>
print_ast_translation \<open>
  let
    fun monad_tr _ [t1, Ast.Appl [Ast.Constant @{type_syntax prod},
                          Ast.Appl [Ast.Constant @{type_syntax set},
                            Ast.Appl [Ast.Constant @{type_syntax prod}, t2, t3]],
                          Ast.Constant @{type_syntax bool}]] =
      if t3 = t1
      then Ast.Appl [Ast.Constant @{type_syntax "nondet_monad"}, t1, t2]
      else raise Match
  in [(@{type_syntax "fun"}, monad_tr)] end
\<close>

text \<open>
  The definition of fundamental monad functions @{text return} and
  @{text bind}. The monad function @{text "return x"} does not change
  the  state, does not fail, and returns @{text "x"}.\<close>
definition return :: "'a \<Rightarrow> ('s,'a) nondet_monad" where
  "return a \<equiv> \<lambda>s. ({(a,s)},False)"

text \<open>
  The monad function @{text "bind f g"}, also written @{text "f >>= g"},
  is the execution of @{term f} followed by the execution of @{text g}.
  The function @{text g} takes the result value \emph{and} the result
  state of @{text f} as parameter. The definition says that the result of
  the combined operation is the union of the set of sets that is created
  by @{text g} applied to the result sets of @{text f}. The combined
  operation may have failed, if @{text f} may have failed or @{text g} may
  have failed on any of the results of @{text f}.\<close>
definition bind ::
  "('s, 'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) nondet_monad) \<Rightarrow> ('s, 'b) nondet_monad"
  (infixl ">>=" 60) where
  "bind f g \<equiv> \<lambda>s. (\<Union>(fst ` case_prod g ` fst (f s)),
                   True \<in> snd ` case_prod g ` fst (f s) \<or> snd (f s))"

text \<open>
  Sometimes it is convenient to write @{text bind} in reverse order.\<close>
abbreviation (input) bind_rev ::
  "('c \<Rightarrow> ('a, 'b) nondet_monad) \<Rightarrow> ('a, 'c) nondet_monad \<Rightarrow> ('a, 'b) nondet_monad"
  (infixl "=<<" 60) where
  "g =<< f \<equiv> f >>= g"

text \<open>
  The basic accessor functions of the state monad. @{text get} returns
  the current state as result, does not fail, and does not change the state.
  @{text "put s"} returns nothing (@{typ unit}), changes the current state
  to @{text s} and does not fail.\<close>
definition get :: "('s,'s) nondet_monad" where
  "get \<equiv> \<lambda>s. ({(s,s)}, False)"

definition put :: "'s \<Rightarrow> ('s, unit) nondet_monad" where
  "put s \<equiv> \<lambda>_. ({((),s)}, False)"

subsection "Nondeterminism"

text \<open>
  Basic nondeterministic functions. @{text "select A"} chooses an element
  of the set @{text A}, does not change the state, and does not fail
  (even if the set is empty). @{text "f \<sqinter> g"} executes @{text f} or
  executes @{text g}. It retuns the union of results of @{text f} and
  @{text g}, and may have failed if either may have failed.\<close>
definition select :: "'a set \<Rightarrow> ('s,'a) nondet_monad" where
  "select A \<equiv> \<lambda>s. (A \<times> {s}, False)"

definition alternative ::
  "('s, 'a) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad" (infixl "\<sqinter>" 20) where
  "f \<sqinter> g \<equiv> \<lambda>s. (fst (f s) \<union> fst (g s), snd (f s) \<or> snd (g s))"

text \<open>A variant of @{text select} that takes a pair. The first component
  is a set as in normal @{text select}, the second component indicates
  whether the execution failed. This is useful to lift monads between
  different state spaces.\<close>
definition select_f :: "'a set \<times> bool  \<Rightarrow> ('s,'a) nondet_monad" where
  "select_f S \<equiv> \<lambda>s. (fst S \<times> {s}, snd S)"

text \<open>@{text select_state} takes a relationship between
  states, and outputs nondeterministically a state
  related to the input state.\<close>
definition state_select :: "('s \<times> 's) set \<Rightarrow> ('s, unit) nondet_monad" where
  "state_select r \<equiv> \<lambda>s. ((\<lambda>x. ((), x)) ` {s'. (s, s') \<in> r}, \<not> (\<exists>s'. (s, s') \<in> r))"

subsection "Failure"

text \<open>
  The monad function that always fails. Returns an empty set of results and sets the failure flag.\<close>
definition fail :: "('s, 'a) nondet_monad" where
 "fail \<equiv> \<lambda>s. ({}, True)"

text \<open>Assertions: fail if the property @{text P} is not true\<close>
definition assert :: "bool \<Rightarrow> ('a, unit) nondet_monad" where
 "assert P \<equiv> if P then return () else fail"

text \<open>Fail if the value is @{const None}, return result @{text v} for @{term "Some v"}\<close>
definition assert_opt :: "'a option \<Rightarrow> ('b, 'a) nondet_monad" where
 "assert_opt v \<equiv> case v of None \<Rightarrow> fail | Some v \<Rightarrow> return v"

text \<open>An assertion that also can introspect the current state.\<close>
definition state_assert :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, unit) nondet_monad" where
  "state_assert P \<equiv> get >>= (\<lambda>s. assert (P s))"

subsection "Generic functions on top of the state monad"

text \<open>Apply a function to the current state and return the result without changing the state.\<close>
definition gets :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s, 'a) nondet_monad" where
 "gets f \<equiv> get >>= (\<lambda>s. return (f s))"

text \<open>Modify the current state using the function passed in.\<close>
definition modify :: "('s \<Rightarrow> 's) \<Rightarrow> ('s, unit) nondet_monad" where
 "modify f \<equiv> get >>= (\<lambda>s. put (f s))"

lemma simpler_gets_def:
  "gets f = (\<lambda>s. ({(f s, s)}, False))"
  by (simp add: gets_def return_def bind_def get_def)

lemma simpler_modify_def:
  "modify f = (\<lambda>s. ({((), f s)}, False))"
  by (simp add: modify_def bind_def get_def put_def)

text \<open>Execute the given monad when the condition is true, return @{text "()"} otherwise.\<close>
definition "when" :: "bool \<Rightarrow> ('s, unit) nondet_monad \<Rightarrow> ('s, unit) nondet_monad" where
  "when P m \<equiv> if P then m else return ()"

text \<open>Execute the given monad unless the condition is true, return @{text "()"} otherwise.\<close>
definition unless :: "bool \<Rightarrow> ('s, unit) nondet_monad \<Rightarrow> ('s, unit) nondet_monad" where
  "unless P m \<equiv> when (\<not>P) m"

text \<open>
  Perform a test on the current state, performing the left monad if
  the result is true or the right monad if the result is false. \<close>
definition condition ::
  "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'r) nondet_monad \<Rightarrow> ('s, 'r) nondet_monad \<Rightarrow> ('s, 'r) nondet_monad" where
  "condition P L R \<equiv> \<lambda>s. if (P s) then (L s) else (R s)"

notation (output)
  condition  ("(condition (_)//  (_)//  (_))" [1000,1000,1000] 1000)

text \<open>
  Apply an option valued function to the current state, fail if it returns @{const None},
  return @{text v} if it returns @{term "Some v"}.\<close>
definition gets_the :: "('s \<Rightarrow> 'a option) \<Rightarrow> ('s, 'a) nondet_monad" where
  "gets_the f \<equiv> gets f >>= assert_opt"

text \<open>
  Get a map (such as a heap) from the current state and apply an argument to the map.
  Fail if the map returns @{const None}, otherwise return the value.\<close>
definition
  gets_map :: "('s \<Rightarrow> 'a \<Rightarrow> 'b option) \<Rightarrow> 'a \<Rightarrow> ('s, 'b) nondet_monad" where
  "gets_map f p \<equiv> gets f >>= (\<lambda>m. assert_opt (m p))"

subsection \<open>The Monad Laws\<close>

text \<open>A more expanded definition of @{text bind}\<close>
lemma bind_def':
  "(f >>= g) \<equiv>
       \<lambda>s. ({(r'', s''). \<exists>(r', s') \<in> fst (f s). (r'', s'') \<in> fst (g r' s') },
                     snd (f s) \<or> (\<exists>(r', s') \<in> fst (f s). snd (g r' s')))"
  by (rule eq_reflection)
     (auto simp add: bind_def split_def Let_def)

text \<open>Each monad satisfies at least the following three laws.\<close>

text \<open>@{term return} is absorbed at the left of a @{term bind}, applying the return value directly:\<close>
lemma return_bind[simp]:
  "(return x >>= f) = f x"
  by (simp add: return_def bind_def)

text \<open>@{term return} is absorbed on the right of a @{term bind}\<close>
lemma bind_return[simp]: "(m >>= return) = m"
  by (simp add: bind_def return_def split_def)

text \<open>@{term bind} is associative\<close>
lemma bind_assoc:
  fixes m :: "('a,'b) nondet_monad"
  fixes f :: "'b \<Rightarrow> ('a,'c) nondet_monad"
  fixes g :: "'c \<Rightarrow> ('a,'d) nondet_monad"
  shows "(m >>= f) >>= g  =  m >>= (\<lambda>x. f x >>= g)"
  unfolding bind_def Let_def split_def
  by (auto intro: rev_image_eqI)

section \<open>Adding Exceptions\<close>

text \<open>
  The type @{typ "('s,'a) nondet_monad"} gives us nondeterminism and
  failure. We now extend this monad with exceptional return values
  that abort normal execution, but can be handled explicitly.
  We use the sum type to indicate exceptions.

  In @{typ "('s, 'e + 'a) nondet_monad"}, @{typ "'s"} is the state,
  @{typ 'e} is an exception, and @{typ 'a} is a normal return value.

  This new type itself forms a monad again. Since type classes in
  Isabelle are not powerful enough to express the class of monads,
  we provide new names for the @{term return} and @{term bind} functions
  in this monad. We call them @{text returnOk} (for normal return values)
  and @{text bindE} (for composition). We also define @{text throwError}
  to return an exceptional value.\<close>
definition returnOk :: "'a \<Rightarrow> ('s, 'e + 'a) nondet_monad" where
  "returnOk \<equiv> return o Inr"

definition throwError :: "'e \<Rightarrow> ('s, 'e + 'a) nondet_monad" where
  "throwError \<equiv> return o Inl"

text \<open>
  Lifting a function over the exception type: if the input is an
  exception, return that exception; otherwise continue execution.\<close>
definition lift :: "('a \<Rightarrow> ('s, 'e + 'b) nondet_monad) \<Rightarrow> 'e +'a \<Rightarrow> ('s, 'e + 'b) nondet_monad" where
  "lift f v \<equiv> case v of Inl e \<Rightarrow> throwError e | Inr v' \<Rightarrow> f v'"

text \<open>
  The definition of @{term bind} in the exception monad (new
  name @{text bindE}): the same as normal @{term bind}, but
  the right-hand side is skipped if the left-hand side
  produced an exception.\<close>
definition bindE ::
  "('s, 'e + 'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'e + 'b) nondet_monad) \<Rightarrow> ('s, 'e + 'b) nondet_monad"
  (infixl ">>=E" 60) where
  "f >>=E g \<equiv> f >>= lift g"

text \<open>
  Lifting a normal nondeterministic monad into the
  exception monad is achieved by always returning its
  result as normal result and never throwing an exception.\<close>
definition liftE :: "('s,'a) nondet_monad \<Rightarrow> ('s, 'e+'a) nondet_monad" where
  "liftE f \<equiv> f >>= (\<lambda>r. return (Inr r))"

text \<open>
  Since the underlying type and @{text return} function changed,
  we need new definitions for when and unless:\<close>
definition whenE :: "bool \<Rightarrow> ('s, 'e + unit) nondet_monad \<Rightarrow> ('s, 'e + unit) nondet_monad" where
  "whenE P f \<equiv> if P then f else returnOk ()"

definition unlessE :: "bool \<Rightarrow> ('s, 'e + unit) nondet_monad \<Rightarrow> ('s, 'e + unit) nondet_monad" where
  "unlessE P f \<equiv> if P then returnOk () else f"

text \<open>
  Throwing an exception when the parameter is @{term None}, otherwise
  returning @{term "v"} for @{term "Some v"}.\<close>
definition throw_opt :: "'e \<Rightarrow> 'a option \<Rightarrow> ('s, 'e + 'a) nondet_monad" where
  "throw_opt ex x \<equiv>  case x of None \<Rightarrow> throwError ex | Some v \<Rightarrow> returnOk v"

text \<open>
  Failure in the exception monad is redefined in the same way
  as @{const whenE} and @{const unlessE}, with @{term returnOk}
  instead of @{term return}.\<close>
definition assertE :: "bool \<Rightarrow> ('a, 'e + unit) nondet_monad" where
  "assertE P \<equiv> if P then returnOk () else fail"

subsection "Monad Laws for the Exception Monad"

text \<open>More direct definition of @{const liftE}:\<close>
lemma liftE_def2:
  "liftE f = (\<lambda>s. ((\<lambda>(v,s'). (Inr v, s')) ` fst (f s), snd (f s)))"
  by (auto simp: liftE_def return_def split_def bind_def)

text \<open>Left @{const returnOk} absorbtion over @{term bindE}:\<close>
lemma returnOk_bindE[simp]: "(returnOk x >>=E f) = f x"
  unfolding bindE_def returnOk_def
  by (clarsimp simp: lift_def)

lemma lift_return[simp]:
  "lift (return \<circ> Inr) = return"
  by (auto simp: lift_def throwError_def split: sum.splits)

text \<open>Right @{const returnOk} absorbtion over @{term bindE}:\<close>
lemma bindE_returnOk[simp]:
  "(m >>=E returnOk) = m"
  by (simp add: bindE_def returnOk_def)

text \<open>Associativity of @{const bindE}:\<close>
lemma bindE_assoc:
  "(m >>=E f) >>=E g = m >>=E (\<lambda>x. f x >>=E g)"
  unfolding bindE_def
  by (fastforce simp: bind_assoc lift_def throwError_def
                split: sum.splits
                intro: arg_cong[where f="\<lambda>x. m >>= x"])

text \<open>@{const returnOk} could also be defined via @{const liftE}:\<close>
lemma returnOk_liftE:
  "returnOk x = liftE (return x)"
  by (simp add: liftE_def returnOk_def)

text \<open>Execution after throwing an exception is skipped:\<close>
lemma throwError_bindE[simp]:
  "(throwError E >>=E f) = throwError E"
  by (simp add: bindE_def bind_def throwError_def lift_def return_def)

section "Syntax"

text \<open>This section defines traditional Haskell-like do-syntax
  for the state monad in Isabelle.\<close>

subsection "Syntax for the Nondeterministic State Monad"

text \<open>
  We use @{text K_bind} to syntactically indicate the case where the return argument
  of the left side of a @{term bind} is ignored\<close>
definition K_bind :: "'a \<Rightarrow> 'b \<Rightarrow> 'a" where
  K_bind_def[iff]: "K_bind \<equiv> \<lambda>x y. x"

nonterminal
  dobinds and dobind and nobind

syntax
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ <-/ _)" 10)
  ""           :: "dobind => dobinds"                 ("_")
  "_nobind"    :: "'a => dobind"                      ("_")
  "_dobinds"   :: "[dobind, dobinds] => dobinds"      ("(_);//(_)")

  "_do"        :: "[dobinds, 'a] => 'a"               ("(do ((_);//(_))//od)" 100)
syntax (xsymbols)
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ \<leftarrow>/ _)" 10)

translations
  "_do (_dobinds b bs) e"  == "_do b (_do bs e)"
  "_do (_nobind b) e"      == "b >>= (CONST K_bind e)"
  "do x <- a; e od"        == "a >>= (\<lambda>x. e)"

text \<open>Syntax examples:\<close>
lemma "do x \<leftarrow> return 1;
          return (2::nat);
          return x
       od =
       return 1 >>=
       (\<lambda>x. return (2::nat) >>=
            K_bind (return x))"
  by (rule refl)

lemma "do x \<leftarrow> return 1;
          return 2;
          return x
       od = return 1"
  by simp

subsection "Syntax for the Exception Monad"

text \<open>
  Since the exception monad is a different type, we need to distinguish it in the syntax
  if we want to avoid ambiguous terms. We use @{text doE}/@{text odE} for this, but can
  re-use most of the productions from @{text do}/@{text od} above. \<close>
syntax
  "_doE" :: "[dobinds, 'a] => 'a"  ("(doE ((_);//(_))//odE)" 100)

translations
  "_doE (_dobinds b bs) e"  == "_doE b (_doE bs e)"
  "_doE (_nobind b) e"      == "b >>=E (CONST K_bind e)"
  "doE x <- a; e odE"       == "a >>=E (\<lambda>x. e)"

text \<open>Syntax examples:\<close>
lemma "doE x \<leftarrow> returnOk 1;
           returnOk (2::nat);
           returnOk x
       odE =
       returnOk 1 >>=E
       (\<lambda>x. returnOk (2::nat) >>=E
            K_bind (returnOk x))"
  by (rule refl)

lemma "doE x \<leftarrow> returnOk 1;
           returnOk 2;
           returnOk x
       odE = returnOk 1"
  by simp

section "Library of Monadic Functions and Combinators"

text \<open>Lifting a normal function into the monad type:\<close>
definition liftM :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('s, 'b) nondet_monad" where
  "liftM f m \<equiv> do x \<leftarrow> m; return (f x) od"

text \<open>The same for the exception monad:\<close>
definition liftME :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'e+'a) nondet_monad \<Rightarrow> ('s,'e+'b) nondet_monad" where
  "liftME f m \<equiv> doE x \<leftarrow> m; returnOk (f x) odE"

text \<open> Execute @{term f} for @{term "Some x"}, otherwise do nothing. \<close>
definition maybeM :: "('a \<Rightarrow> ('s, unit) nondet_monad) \<Rightarrow> 'a option \<Rightarrow> ('s, unit) nondet_monad" where
  "maybeM f y \<equiv> case y of Some x \<Rightarrow> f x | None \<Rightarrow> return ()"

text \<open>
  Run a sequence of monads from left to right, ignoring return values.\<close>
definition sequence_x :: "('s, 'a) nondet_monad list \<Rightarrow> ('s, unit) nondet_monad" where
  "sequence_x xs \<equiv> foldr (\<lambda>x y. x >>= (\<lambda>_. y)) xs (return ())"

text \<open>
  Map a monadic function over a list by applying it to each element
  of the list from left to right, ignoring return values.\<close>
definition mapM_x :: "('a \<Rightarrow> ('s,'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, unit) nondet_monad" where
  "mapM_x f xs \<equiv> sequence_x (map f xs)"

text \<open>
  Map a monadic function with two parameters over two lists,
  going through both lists simultaneously, left to right, ignoring
  return values.\<close>
definition zipWithM_x ::
  "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, unit) nondet_monad" where
  "zipWithM_x f xs ys \<equiv> sequence_x (zipWith f xs ys)"

text \<open>
  The same three functions as above, but returning a list of
  return values instead of @{text unit}\<close>
definition sequence :: "('s, 'a) nondet_monad list \<Rightarrow> ('s, 'a list) nondet_monad" where
  "sequence xs \<equiv> let mcons = (\<lambda>p q. p >>= (\<lambda>x. q >>= (\<lambda>y. return (x#y))))
                 in foldr mcons xs (return [])"

definition mapM :: "('a \<Rightarrow> ('s,'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'b list) nondet_monad" where
  "mapM f xs \<equiv> sequence (map f xs)"

definition zipWithM ::
  "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, 'c list) nondet_monad" where
  "zipWithM f xs ys \<equiv> sequence (zipWith f xs ys)"

definition foldM :: "('b \<Rightarrow> 'a \<Rightarrow> ('s, 'a) nondet_monad) \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> ('s, 'a) nondet_monad"
  where
  "foldM m xs a \<equiv> foldr (\<lambda>p q. q >>= m p) xs (return a) "

definition foldME ::
  "('b \<Rightarrow> 'a \<Rightarrow> ('s,('e + 'b)) nondet_monad) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> ('s, ('e + 'b)) nondet_monad" where
  "foldME m a xs \<equiv> foldr (\<lambda>p q. q >>=E swp m p) xs (returnOk a)"

text \<open>
  The sequence and map functions above for the exception monad, with and without
  lists of return value\<close>
definition sequenceE_x :: "('s, 'e+'a) nondet_monad list \<Rightarrow> ('s, 'e+unit) nondet_monad" where
  "sequenceE_x xs \<equiv> foldr (\<lambda>x y. doE _ <- x; y odE) xs (returnOk ())"

definition mapME_x :: "('a \<Rightarrow> ('s,'e+'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s,'e+unit) nondet_monad" where
  "mapME_x f xs \<equiv> sequenceE_x (map f xs)"

definition sequenceE :: "('s, 'e+'a) nondet_monad list \<Rightarrow> ('s, 'e+'a list) nondet_monad" where
  "sequenceE xs \<equiv> let mcons = (\<lambda>p q. p >>=E (\<lambda>x. q >>=E (\<lambda>y. returnOk (x#y))))
                   in foldr mcons xs (returnOk [])"

definition mapME :: "('a \<Rightarrow> ('s,'e+'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s,'e+'b list) nondet_monad"
  where
  "mapME f xs \<equiv> sequenceE (map f xs)"

text \<open>Filtering a list using a monadic function as predicate:\<close>
primrec filterM :: "('a \<Rightarrow> ('s, bool) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'a list) nondet_monad" where
  "filterM P []       = return []"
| "filterM P (x # xs) = do
     b  <- P x;
     ys <- filterM P xs;
     return (if b then (x # ys) else ys)
   od"

section "Catching and Handling Exceptions"

text \<open>
  Turning an exception monad into a normal state monad
  by catching and handling any potential exceptions:\<close>
definition catch ::
  "('s, 'e + 'a) nondet_monad \<Rightarrow> ('e \<Rightarrow> ('s, 'a) nondet_monad) \<Rightarrow> ('s, 'a) nondet_monad"
  (infix "<catch>" 10) where
  "f <catch> handler \<equiv>
     do x \<leftarrow> f;
        case x of
          Inr b \<Rightarrow> return b
        | Inl e \<Rightarrow> handler e
     od"

text \<open>
  Handling exceptions, but staying in the exception monad.
  The handler may throw a type of exceptions different from
  the left side.\<close>
definition handleE' ::
  "('s, 'e1 + 'a) nondet_monad \<Rightarrow> ('e1 \<Rightarrow> ('s, 'e2 + 'a) nondet_monad) \<Rightarrow>
   ('s, 'e2 + 'a) nondet_monad"
  (infix "<handle2>" 10) where
  "f <handle2> handler \<equiv>
   do
      v \<leftarrow> f;
      case v of
        Inl e \<Rightarrow> handler e
      | Inr v' \<Rightarrow> return (Inr v')
   od"

text \<open>
  A type restriction of the above that is used more commonly in
  practice: the exception handle (potentially) throws exception
  of the same type as the left-hand side.\<close>
definition handleE ::
  "('s, 'x + 'a) nondet_monad \<Rightarrow> ('x \<Rightarrow> ('s, 'x + 'a) nondet_monad) \<Rightarrow> ('s, 'x + 'a) nondet_monad"
  (infix "<handle>" 10) where
  "handleE \<equiv> handleE'"

text \<open>
  Handling exceptions, and additionally providing a continuation
  if the left-hand side throws no exception:\<close>
definition
  handle_elseE ::
  "('s, 'e + 'a) nondet_monad \<Rightarrow> ('e \<Rightarrow> ('s, 'ee + 'b) nondet_monad) \<Rightarrow>
   ('a \<Rightarrow> ('s, 'ee + 'b) nondet_monad) \<Rightarrow> ('s, 'ee + 'b) nondet_monad"
  ("_ <handle> _ <else> _" 10) where
  "f <handle> handler <else> continue \<equiv>
   do v \<leftarrow> f;
      case v of Inl e  \<Rightarrow> handler e
              | Inr v' \<Rightarrow> continue v'
   od"

subsection "Loops"

text \<open>
  Loops are handled using the following inductive predicate;
  non-termination is represented using the failure flag of the
  monad.\<close>

inductive_set whileLoop_results ::
  "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) nondet_monad) \<Rightarrow> ((('r \<times> 's) option) \<times> (('r \<times> 's) option)) set"
  for C B where
    "\<lbrakk> \<not> C r s \<rbrakk> \<Longrightarrow> (Some (r, s), Some (r, s)) \<in> whileLoop_results C B"
  | "\<lbrakk> C r s; snd (B r s) \<rbrakk> \<Longrightarrow> (Some (r, s), None) \<in> whileLoop_results C B"
  | "\<lbrakk> C r s; (r', s') \<in> fst (B r s); (Some (r', s'), z) \<in> whileLoop_results C B  \<rbrakk>
       \<Longrightarrow> (Some (r, s), z) \<in> whileLoop_results C B"

inductive_cases whileLoop_results_cases_valid: "(Some x, Some y) \<in> whileLoop_results C B"
inductive_cases whileLoop_results_cases_fail: "(Some x, None) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps: "(Some x, y) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps_valid: "(Some x, Some y) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps_start_fail[simp]: "(None, x) \<in> whileLoop_results C B"

inductive whileLoop_terminates ::
  "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) nondet_monad) \<Rightarrow> 'r \<Rightarrow> 's \<Rightarrow> bool" for C B where
    "\<not> C r s \<Longrightarrow> whileLoop_terminates C B r s"
  | "\<lbrakk> C r s; \<forall>(r', s') \<in> fst (B r s). whileLoop_terminates C B r' s' \<rbrakk>
        \<Longrightarrow> whileLoop_terminates C B r s"

inductive_cases whileLoop_terminates_cases: "whileLoop_terminates C B r s"
inductive_simps whileLoop_terminates_simps: "whileLoop_terminates C B r s"

definition whileLoop ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b, 'a) nondet_monad) \<Rightarrow> 'a \<Rightarrow> ('b, 'a) nondet_monad" where
  "whileLoop C B \<equiv> \<lambda>r s.
     ({(r',s'). (Some (r, s), Some (r', s')) \<in> whileLoop_results C B},
      (Some (r, s), None) \<in> whileLoop_results C B \<or> \<not>whileLoop_terminates C B r s)"

notation (output)
  whileLoop  ("(whileLoop (_)//  (_))" [1000, 1000] 1000)

definition whileLoopE ::
  "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'e + 'r) nondet_monad) \<Rightarrow> 'r \<Rightarrow> 's \<Rightarrow> (('e + 'r) \<times> 's) set \<times> bool"
  where
  "whileLoopE C body \<equiv>
     \<lambda>r. whileLoop (\<lambda>r s. (case r of Inr v \<Rightarrow> C v s | _ \<Rightarrow> False)) (lift body) (Inr r)"

notation (output)
  whileLoopE  ("(whileLoopE (_)//  (_))" [1000, 1000] 1000)

section "Combinators that have conditions with side effects"

definition notM :: "('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad" where
  "notM m = do c \<leftarrow> m; return (\<not> c) od"

definition
  whileM :: "('s, bool) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow> ('s, unit) nondet_monad" where
  "whileM C B \<equiv> do
    c \<leftarrow> C;
    whileLoop (\<lambda>c s. c) (\<lambda>_. do B; C od) c;
    return ()
  od"

definition
  ifM :: "('s, bool) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow>
          ('s, 'a) nondet_monad" where
  "ifM test t f = do
    c \<leftarrow> test;
    if c then t else f
   od"

definition ifME ::
  "('a, 'b + bool) nondet_monad \<Rightarrow> ('a, 'b + 'c) nondet_monad \<Rightarrow> ('a, 'b + 'c) nondet_monad
   \<Rightarrow> ('a, 'b + 'c) nondet_monad" where
  "ifME test t f = doE
    c \<leftarrow> test;
    if c then t else f
   odE"

definition
  whenM :: "('s, bool) nondet_monad \<Rightarrow> ('s, unit) nondet_monad \<Rightarrow> ('s, unit) nondet_monad" where
  "whenM t m = ifM t m (return ())"

definition
  orM :: "('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad" where
  "orM a b = ifM a (return True) b"

definition
  andM :: "('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad" where
  "andM a b = ifM a b (return False)"

end


theory Indep_Vars
imports Main Refine_Util Mpat_Antiquot
begin

definition [simp]: "INDEP v \<equiv> True"
lemma INDEPI: "INDEP v" by simp

ML \<open>
  signature INDEP_VARS = sig
    val indep_tac: Proof.context -> tactic'
  end

  structure Indep_Vars: INDEP_VARS = struct

    local
      fun vsubterms (Abs (_,_,t)) = vsubterms t
        | vsubterms (t as (_$_)) = let
            val (f,args) = strip_comb t
            val args_vsts = map vsubterms args |> flat
          in
            case f of
              (Var (name,vT)) => [(name,vT,fastype_of t,args)]@args_vsts
            | _ => vsubterms f @ args_vsts
          end
        | vsubterms _ = []

      fun indep_vars ctxt t st = let
        val cert = Thm.cterm_of ctxt

        fun inst_of (name,vT,T,args) = let
          val Ts = map fastype_of args |> rev
          val t' = fold absdummy Ts (Var (name,T))
          val inst = ((name, vT), cert t')
        in inst end

        val inst = vsubterms t
          |> distinct ((op =) o apply2 #1)
          |> map inst_of

        val st' = Drule.instantiate_normalize ([],inst) st
          |> Conv.fconv_rule (Thm.beta_conversion true)
      in
        Seq.single st'
      end

      fun indep_tac_aux ctxt i st = case Logic.concl_of_goal (Thm.prop_of st) i of
        @{mpat "Trueprop (INDEP ?v)"}
          => (indep_vars ctxt v THEN resolve_tac ctxt @{thms INDEPI} i) st
      | _ => Seq.empty

    in
      (* Remove explicit parameters from schematic variable. *)
      fun indep_tac ctxt = IF_EXGOAL
        (CONVERSION Thm.eta_conversion THEN' indep_tac_aux ctxt)
    end
  end
\<close>

end


theory LinuxRouter_OpenFlow_Translation
imports IP_Addresses.CIDR_Split
  Automatic_Refinement.Misc (*TODO@Peter: rename and make available at better place :)*)
	Simple_Firewall.Generic_SimpleFw
	Semantics_OpenFlow
	OpenFlow_Matches
	OpenFlow_Action
	Routing.Linux_Router
	"Pure-ex.Guess"
begin
hide_const Misc.uncurry
hide_fact Misc.uncurry_def

(* For reference:
iiface :: "iface" --"in-interface"
oiface :: "iface" --"out-interface"
src :: "(ipv4addr \<times> nat) " --"source IP address"
dst :: "(ipv4addr \<times> nat) " --"destination"
proto :: "protocol"
sports :: "(16 word \<times> 16 word)" --"source-port first:last"
dports :: "(16 word \<times> 16 word)" --"destination-port first:last"

p_iiface :: string
p_oiface :: string
p_src :: ipv4addr
p_dst :: ipv4addr
p_proto :: primitive_protocol
p_sport :: "16 word"
p_dport :: "16 word"
p_tcp_flags :: "tcp_flag set"
p_payload :: string
*)

definition "route2match r =
	\<lparr>iiface = ifaceAny, oiface = ifaceAny,
	src = (0,0), dst=(pfxm_prefix (routing_match r),pfxm_length (routing_match r)),
	proto=ProtoAny, sports=(0,- 1), ports=(0,- 1)\<rparr>"

definition toprefixmatch where
"toprefixmatch m \<equiv> (let pm = PrefixMatch (fst m) (snd m) in if pm = PrefixMatch 0 0 then None else Some pm)"
lemma prefix_match_semantics_simple_match:
  assumes some: "toprefixmatch m = Some pm"
	assumes vld: "valid_prefix pm"
	shows "prefix_match_semantics pm = simple_match_ip m"
using some
  by(cases m)
	  (clarsimp
	   simp add: toprefixmatch_def ipset_from_cidr_def pfxm_mask_def fun_eq_iff
	            prefix_match_semantics_ipset_from_netmask[OF vld] NOT_mask_shifted_lenword[symmetric]
	   split: if_splits)

definition simple_match_to_of_match_single ::
    "(32, 'a) simple_match_scheme
     \<Rightarrow> char list option \<Rightarrow> protocol \<Rightarrow> (16 word \<times> 16 word) option \<Rightarrow> (16 word \<times> 16 word) option \<Rightarrow> of_match_field set"
    where
"simple_match_to_of_match_single m iif prot sport dport \<equiv>
	   uncurry L4Src ` option2set sport \<union> uncurry L4Dst ` option2set dport
	 \<union> IPv4Proto ` (case prot of ProtoAny \<Rightarrow> {} | Proto p \<Rightarrow> {p}) \<comment> \<open>protocol is an 8 word option anyway...\<close>
	 \<union> IngressPort ` option2set iif
	 \<union> IPv4Src ` option2set (toprefixmatch (src m)) \<union> IPv4Dst ` option2set (toprefixmatch (dst m))
	 \<union> {EtherType 0x0800}"
(* okay, we need to make sure that no packets are output on the interface they were input on. So for rules that don't have an input interface, we'd need to do a product over all interfaces, if we stay naive.
   The more smart way would be to insert a rule with the same match condition that additionally matches the input interface and drops. However, I'm afraid this is going to be very tricky to verify\<dots> *)
definition simple_match_to_of_match :: "32 simple_match \<Rightarrow> string list \<Rightarrow> of_match_field set list" where
"simple_match_to_of_match m ifs \<equiv> (let
	npm = (\<lambda>p. fst p = 0 \<and> snd p = - 1);
	sb = (\<lambda>p. (if npm p then [None] else if fst p \<le> snd p
  then map (Some \<circ> (\<lambda>pfx. (pfxm_prefix pfx, Bit_Operations.not (pfxm_mask pfx)))) (wordinterval_CIDR_split_prefixmatch (WordInterval (fst p) (snd p))) else []))
	in [simple_match_to_of_match_single m iif (proto m) sport dport.
		iif \<leftarrow> (if iiface m = ifaceAny then [None] else [Some i. i \<leftarrow> ifs, match_iface (iiface m) i]),
		sport \<leftarrow> sb (sports m),
		dport \<leftarrow> sb (dports m)]
)"
(* I wonder\<dots> should I check whether list_all (match_iface (iiface m)) ifs instead of iiface m = ifaceAny? It would be pretty stupid if that wasn't the same, but you know\<dots> *)

lemma smtoms_eq_hlp: "simple_match_to_of_match_single r a b c d = simple_match_to_of_match_single r f g h i \<longleftrightarrow> (a = f \<and> b = g \<and> c = h \<and> d = i)"
(* In case this proof breaks: there are two alternate proofs in the repo. They are of similar quality, though. Good luck. *)
proof(rule iffI,goal_cases)
  case 1
  thus ?case proof(intro conjI)
    have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Some x\<rbrakk> \<Longrightarrow> P (IngressPort x)" by simp
    show "a = f" using 1 by(cases a; cases f)
        (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
        subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
  next
    have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Proto x\<rbrakk> \<Longrightarrow> P (IPv4Proto x)" by simp
    show "b = g" using 1 by(cases b; cases g)
        (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
        subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
  next
    have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Some x\<rbrakk> \<Longrightarrow> P (uncurry L4Src x)" by simp
    show "c = h" using 1 by(cases c; cases h)
        (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
        subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
  next
    have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Some x\<rbrakk> \<Longrightarrow> P (uncurry L4Dst x)" by simp
    show "d = i" using 1 by(cases d; cases i)
        (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
        subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
  qed
qed simp

lemma simple_match_to_of_match_generates_prereqs: "simple_match_valid m \<Longrightarrow> r \<in> set (simple_match_to_of_match m ifs) \<Longrightarrow> all_prerequisites r"
unfolding simple_match_to_of_match_def Let_def
proof(clarsimp, goal_cases)
  case (1 xiface xsrcp xdstp)
  note o = this
  show ?case unfolding simple_match_to_of_match_single_def all_prerequisites_def
    unfolding ball_Un
  proof((intro conjI; ((simp;fail)| - )), goal_cases)
    case 1
    have e: "(fst (sports m) = 0 \<and> snd (sports m) = - 1) \<or> proto m = Proto TCP \<or> proto m = Proto UDP \<or> proto m = Proto L4_Protocol.SCTP"
      using o(1)
      unfolding simple_match_valid_alt Let_def
      by(clarsimp split: if_splits)
    show ?case
      using o(3) e
      by(elim disjE; simp add: option2set_def split: if_splits prod.splits uncurry_splits)
  next
    case 2
    have e: "(fst (dports m) = 0 \<and> snd (dports m) = - 1) \<or> proto m = Proto TCP \<or> proto m = Proto UDP \<or> proto m = Proto L4_Protocol.SCTP"
      using o(1)
      unfolding simple_match_valid_alt Let_def
      by(clarsimp split: if_splits)
    show ?case
      using o(4) e
      by(elim disjE; simp add: option2set_def split: if_splits prod.splits uncurry_splits)
  qed
qed

lemma and_assoc: "a \<and> b \<and> c \<longleftrightarrow> (a \<and> b) \<and> c" by simp

lemmas custom_simpset = Let_def set_concat set_map map_map comp_def concat_map_maps set_maps UN_iff fun_app_def Set.image_iff

abbreviation "simple_fw_prefix_to_wordinterval \<equiv> prefix_to_wordinterval \<circ> uncurry PrefixMatch"

lemma simple_match_port_alt: "simple_match_port m p \<longleftrightarrow> p \<in> wordinterval_to_set (uncurry WordInterval m)" by(simp split: uncurry_splits)

lemma simple_match_src_alt: "simple_match_valid r \<Longrightarrow>
	simple_match_ip (src r) p \<longleftrightarrow> prefix_match_semantics (PrefixMatch (fst (src r)) (snd (src r))) p"
by(cases "(src r)") (simp add: prefix_match_semantics_ipset_from_netmask2 prefix_to_wordset_ipset_from_cidr simple_match_valid_def valid_prefix_fw_def)
lemma simple_match_dst_alt: "simple_match_valid r \<Longrightarrow>
	simple_match_ip (dst r) p \<longleftrightarrow> prefix_match_semantics (PrefixMatch (fst (dst r)) (snd (dst r))) p"
by(cases "(dst r)") (simp add: prefix_match_semantics_ipset_from_netmask2 prefix_to_wordset_ipset_from_cidr simple_match_valid_def valid_prefix_fw_def)

lemma "x \<in> set (wordinterval_CIDR_split_prefixmatch w) \<Longrightarrow> valid_prefix x"
using wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1] .

lemma simple_match_to_of_matchI:
	assumes mv: "simple_match_valid r"
	assumes mm: "simple_matches r p"
	assumes ii: "p_iiface p \<in> set ifs"
	assumes ippkt: "p_l2type p = 0x800"
	shows eq: "\<exists>gr \<in> set (simple_match_to_of_match r ifs). OF_match_fields gr p = Some True"
proof -
	let ?npm = "\<lambda>p. fst p = 0 \<and> snd p = - 1"
	let ?sb = "\<lambda>p r. (if ?npm p then None else Some r)"
	obtain si where si: "case si of Some ssi \<Rightarrow> p_sport p \<in> prefix_to_wordset ssi | None \<Rightarrow> True"
		"case si of None \<Rightarrow> True | Some ssi \<Rightarrow> ssi \<in> set (
		wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r)))"
		"si = None \<longleftrightarrow> ?npm (sports r)"
	proof(cases "?npm (sports r)", goal_cases)
		case 1 (* True *)
		hence "(case None of None \<Rightarrow> True | Some ssi \<Rightarrow> p_sport p \<in> prefix_to_wordset ssi) \<and>
            (case None of None \<Rightarrow> True
            | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r))))" by simp
        with 1 show ?thesis by blast
	next
		case 2 (* False *)
		from mm have "p_sport p \<in> wordinterval_to_set (uncurry WordInterval (sports r))"
			by(simp only: simple_matches.simps simple_match_port_alt)
		then obtain ssi where ssi:
			"ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r)))"
			"p_sport p \<in> prefix_to_wordset ssi"
			using wordinterval_CIDR_split_existential by fast
		hence "(case Some ssi of None \<Rightarrow> True | Some ssi \<Rightarrow> p_sport p \<in> prefix_to_wordset ssi) \<and>
            (case Some ssi of None \<Rightarrow> True
            | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r))))" by simp
        with 2 show ?thesis by blast
    qed
	obtain di where di: "case di of Some ddi \<Rightarrow> p_dport p \<in> prefix_to_wordset ddi | None \<Rightarrow> True"
		"case di of None \<Rightarrow> True | Some ddi \<Rightarrow> ddi \<in> set (
		wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r)))"
		"di = None \<longleftrightarrow> ?npm (dports r)"
	proof(cases "?npm (dports r)", goal_cases)
		case 1
		hence "(case None of None \<Rightarrow> True | Some ssi \<Rightarrow> p_dport p \<in> prefix_to_wordset ssi) \<and>
            (case None of None \<Rightarrow> True
            | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r))))" by simp
        with 1 show ?thesis by blast
	next
		case 2
		from mm have "p_dport p \<in> wordinterval_to_set (uncurry WordInterval (dports r))"
			by(simp only: simple_matches.simps simple_match_port_alt)
		then obtain ddi where ddi:
			"ddi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r)))"
			"p_dport p \<in> prefix_to_wordset ddi"
			using wordinterval_CIDR_split_existential by fast
		hence "(case Some ddi of None \<Rightarrow> True | Some ssi \<Rightarrow> p_dport p \<in> prefix_to_wordset ssi) \<and>
            (case Some ddi of None \<Rightarrow> True
            | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r))))" by simp
        with 2 show ?thesis by blast
    qed
    show ?thesis
	proof
		let ?mf = "map_option (apsnd (wordNOT \<circ> mask \<circ> (-) 16) \<circ> prefix_match_dtor)"
		let ?gr = "simple_match_to_of_match_single r
			(if iiface r = ifaceAny then None else Some (p_iiface p))
			(if proto r = ProtoAny then ProtoAny else Proto (p_proto p))
			(?mf si) (?mf di)"
		note mfu = simple_match_port.simps[of "fst (sports r)" "snd (sports r)", unfolded surjective_pairing[of "sports r",symmetric]]
				   simple_match_port.simps[of "fst (dports r)" "snd (dports r)", unfolded surjective_pairing[of "dports r",symmetric]]
		note u = mm[unfolded simple_matches.simps mfu ord_class.atLeastAtMost_iff simple_packet_unext_def simple_packet.simps]
		note of_safe_unsafe_match_eq[OF simple_match_to_of_match_generates_prereqs]
		from u have ple: "fst (sports r) \<le> snd (sports r)" "fst (dports r) \<le> snd (dports r)" by force+
		show eg: "?gr \<in> set (simple_match_to_of_match r ifs)"
			unfolding simple_match_to_of_match_def
			unfolding custom_simpset
			unfolding smtoms_eq_hlp
			proof(intro bexI, (intro conjI; ((rule refl)?)), goal_cases)
				case 2 thus ?case using ple(2) di
					apply(simp add: pfxm_mask_def prefix_match_dtor_def Set.image_iff
					           split: option.splits prod.splits uncurry_splits)
					apply(erule bexI[rotated])
					apply(simp split: prefix_match.splits)
				done
			next
				case 3 thus ?case using ple(1) si
					apply(simp add: pfxm_mask_def prefix_match_dtor_def Set.image_iff
					           split: option.splits prod.splits uncurry_splits)
					apply(erule bexI[rotated])
					apply(simp split: prefix_match.splits)
				done
			next
				case 4 thus ?case
				  using u ii by(clarsimp simp: set_maps split: if_splits)
			next
				case 1 thus ?case using ii u by simp_all (metis match_proto.elims(2))
			qed
		have dpm: "di = Some (PrefixMatch x1 x2) \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1" for x1 x2
    proof -
      have *: "di = Some (PrefixMatch x1 x2) \<Longrightarrow> prefix_match_semantics (the di) (p_dport p) \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1"
        by(clarsimp simp: prefix_match_semantics_def pfxm_mask_def word_bw_comms;fail)
      have **: "pfx \<in> set (wordinterval_CIDR_split_prefixmatch ra) \<Longrightarrow> prefix_match_semantics pfx a = (a \<in> prefix_to_wordset pfx)" for pfx ra and a :: "16 word"
        by (fact prefix_match_semantics_wordset[OF wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1]])
      have "\<lbrakk>di = Some (PrefixMatch x1 x2); p_dport p \<in> prefix_to_wordset (PrefixMatch x1 x2); PrefixMatch x1 x2 \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r)))\<rbrakk>
             \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1"
      using di(1,2)
        using * ** by auto
      thus "di = Some (PrefixMatch x1 x2) \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1"  using di(1,2) by auto
    qed
		have spm: "si = Some (PrefixMatch x1 x2) \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1" for x1 x2
    using si
    proof -
      have *: "si = Some (PrefixMatch x1 x2) \<Longrightarrow> prefix_match_semantics (the si) (p_sport p) \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1"
        by(clarsimp simp: prefix_match_semantics_def pfxm_mask_def word_bw_comms;fail)
      have **: "pfx \<in> set (wordinterval_CIDR_split_prefixmatch ra) \<Longrightarrow> prefix_match_semantics pfx a = (a \<in> prefix_to_wordset pfx)" for pfx ra and a :: "16 word"
        by (fact prefix_match_semantics_wordset[OF wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1]])
      have "\<lbrakk>si = Some (PrefixMatch x1 x2); p_sport p \<in> prefix_to_wordset (PrefixMatch x1 x2); PrefixMatch x1 x2 \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r)))\<rbrakk>
             \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1"
      using si(1,2)
        using * ** by auto
      thus "si = Some (PrefixMatch x1 x2) \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1"  using si(1,2) by auto
    qed
		show "OF_match_fields ?gr p = Some True"
		unfolding of_safe_unsafe_match_eq[OF simple_match_to_of_match_generates_prereqs[OF mv eg]]
		  by(cases si; cases di)
        (simp_all
					add: simple_match_to_of_match_single_def OF_match_fields_unsafe_def spm
					     option2set_def u ippkt prefix_match_dtor_def toprefixmatch_def dpm
					     simple_match_dst_alt[OF mv, symmetric] simple_match_src_alt[OF mv, symmetric]
					split: prefix_match.splits)
	qed
qed

lemma prefix_match_00[simp,intro!]: "prefix_match_semantics (PrefixMatch 0 0) p"
  by (simp add: valid_prefix_def zero_prefix_match_all)

lemma simple_match_to_of_matchD:
	assumes eg: "gr \<in> set (simple_match_to_of_match r ifs)"
	assumes mo: "OF_match_fields gr p = Some True"
	assumes me: "match_iface (oiface r) (p_oiface p)"
	assumes mv: "simple_match_valid r"
	shows "simple_matches r p"
proof -
	from mv have validpfx:
		"valid_prefix (uncurry PrefixMatch (src r))" "valid_prefix (uncurry PrefixMatch (dst r))"
		"\<And>pm. toprefixmatch (src r) = Some pm \<Longrightarrow> valid_prefix pm"
		"\<And>pm. toprefixmatch (dst r) = Some pm \<Longrightarrow> valid_prefix pm"
		unfolding simple_match_valid_def valid_prefix_fw_def toprefixmatch_def
		  by(simp_all split: uncurry_splits if_splits)
	from mo have mo: "OF_match_fields_unsafe gr p"
		unfolding of_safe_unsafe_match_eq[OF simple_match_to_of_match_generates_prereqs[OF mv eg]]
		by simp
	note this[unfolded OF_match_fields_unsafe_def]
	note eg[unfolded simple_match_to_of_match_def simple_match_to_of_match_single_def  custom_simpset option2set_def]
	then guess x ..	moreover from this(2) guess xa ..	moreover from this(2) guess xb ..
	note xx = calculation(1,3) this

  { fix a b xc xa
      fix pp :: "16 word"
	  have "\<lbrakk>pp && ~~ (pfxm_mask xc) = pfxm_prefix xc\<rbrakk>
              \<Longrightarrow> prefix_match_semantics xc (pp)" for xc
      by(simp add: prefix_match_semantics_def word_bw_comms;fail)
    moreover have "pp \<in> wordinterval_to_set (WordInterval a b) \<Longrightarrow> a \<le> pp \<and> pp \<le> b" by simp
    moreover have "xc \<in> set (wordinterval_CIDR_split_prefixmatch (WordInterval a b)) \<Longrightarrow> pp \<in> prefix_to_wordset xc  \<Longrightarrow> pp \<in> wordinterval_to_set (WordInterval a b)"
			by(subst wordinterval_CIDR_split_prefixmatch) blast
	  moreover have "\<lbrakk>xc \<in> set (wordinterval_CIDR_split_prefixmatch (WordInterval a b)); xa = Some (pfxm_prefix xc, ~~ (pfxm_mask xc)); prefix_match_semantics xc (pp)\<rbrakk> \<Longrightarrow> pp \<in> prefix_to_wordset xc"
			apply(subst(asm)(1) prefix_match_semantics_wordset)
			apply(erule wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1];fail)
			apply assumption
	  done
	  ultimately have "\<lbrakk>xc \<in> set (wordinterval_CIDR_split_prefixmatch (WordInterval a b)); xa = Some (pfxm_prefix xc, ~~ (pfxm_mask xc));
               pp && ~~ (pfxm_mask xc) = pfxm_prefix xc\<rbrakk>
              \<Longrightarrow> a \<le> pp \<and> pp \<le> b"
     by metis
	} note l4port_logic = this

	show ?thesis unfolding simple_matches.simps
	proof(unfold and_assoc, (rule)+)
		show "match_iface (iiface r) (p_iiface p)"
			apply(cases "iiface r = ifaceAny")
			 apply (simp add: match_ifaceAny)
			using xx(1) mo unfolding xx(4) OF_match_fields_unsafe_def
			apply(simp only: if_False set_maps UN_iff)
			apply(clarify)
			apply(rename_tac a; subgoal_tac "match_iface (iiface r) a")
			 apply(clarsimp simp add: option2set_def;fail)
			apply(rule ccontr,simp;fail)
		done
	next
		show "match_iface (oiface r) (p_oiface p)" using me .
	next
		show "simple_match_ip (src r) (p_src p)"
			using mo unfolding xx(4) OF_match_fields_unsafe_def toprefixmatch_def
			by(clarsimp
			  simp add: simple_packet_unext_def option2set_def validpfx simple_match_src_alt[OF mv] toprefixmatch_def
			  split: if_splits)
	next
		show "simple_match_ip (dst r) (p_dst p)"
			using mo unfolding xx(4) OF_match_fields_unsafe_def toprefixmatch_def
			by(clarsimp
			  simp add: simple_packet_unext_def option2set_def validpfx simple_match_dst_alt[OF mv] toprefixmatch_def
			  split: if_splits)
 	next
		show "match_proto (proto r) (p_proto p)"
			using mo unfolding xx(4) OF_match_fields_unsafe_def
			using xx(1) by(clarsimp
				simp add: singleton_iff simple_packet_unext_def option2set_def prefix_match_semantics_simple_match ball_Un
				split: if_splits protocol.splits)
	next
		show "simple_match_port (sports r) (p_sport p)"
			using mo xx(2) unfolding xx(4) OF_match_fields_unsafe_def
			by(cases "sports r") (clarsimp simp add: l4port_logic simple_packet_unext_def option2set_def prefix_match_semantics_simple_match split: if_splits)
	next
		show "simple_match_port (dports r) (p_dport p)"
		  using mo xx(3) unfolding xx(4) OF_match_fields_unsafe_def
			by(cases "dports r") (clarsimp simp add: l4port_logic simple_packet_unext_def option2set_def prefix_match_semantics_simple_match split: if_splits)
    qed
qed

primrec annotate_rlen where
"annotate_rlen [] = []" |
"annotate_rlen (a#as) = (length as, a) # annotate_rlen as"
lemma "annotate_rlen ''asdf'' = [(3, CHR ''a''), (2, CHR ''s''), (1, CHR ''d''), (0, CHR ''f'')]" by simp

lemma fst_annotate_rlen_le: "(k, a) \<in> set (annotate_rlen l) \<Longrightarrow> k < length l"
	by(induction l arbitrary: k; simp; force)

lemma distinct_fst_annotate_rlen: "distinct (map fst (annotate_rlen l))"
	using fst_annotate_rlen_le by(induction l) (simp, fastforce)
lemma distinct_annotate_rlen: "distinct (annotate_rlen l)"
	using distinct_fst_annotate_rlen unfolding distinct_map by blast
lemma in_annotate_rlen: "(a,x) \<in> set (annotate_rlen l) \<Longrightarrow> x \<in> set l"
  by(induction l) (simp_all, blast)
lemma map_snd_annotate_rlen: "map snd (annotate_rlen l) = l"
  by(induction l) simp_all
lemma "sorted_descending (map fst (annotate_rlen l))"
  by(induction l; clarsimp) (force dest: fst_annotate_rlen_le)
lemma "annotate_rlen l = zip (rev [0..<length l]) l"
  by(induction l; simp) (* It would probably have been better to just use the zip, but oh well\<dots> *)

primrec annotate_rlen_code where
"annotate_rlen_code [] = (0,[])" |
"annotate_rlen_code (a#as) = (case annotate_rlen_code as of (r,aas) \<Rightarrow> (Suc r, (r, a) # aas))"
lemma annotate_rlen_len: "fst (annotate_rlen_code r) = length r"
by(induction r) (clarsimp split: prod.splits)+
lemma annotate_rlen_code[code]: "annotate_rlen s = snd (annotate_rlen_code s)"
proof(induction s)
  case (Cons s ss) thus ?case using annotate_rlen_len[of ss] by(clarsimp split: prod.split)
qed simp

lemma suc2plus_inj_on: "inj_on (of_nat :: nat \<Rightarrow> ('l :: len) word) {0..unat (max_word :: 'l word)}"
proof(rule inj_onI)
   let ?mmw = "(max_word :: 'l word)"
   let ?mstp = "(of_nat :: nat \<Rightarrow> 'l word)"
   fix x y :: nat
   assume "x \<in> {0..unat ?mmw}" "y \<in> {0..unat ?mmw}"
   hence se: "x \<le> unat ?mmw" "y \<le> unat ?mmw" by simp_all
   assume eq: "?mstp x = ?mstp y"
   note f = le_unat_uoi[OF se(1)] le_unat_uoi[OF se(2)]
   show "x = y" using eq le_unat_uoi se by metis
qed

lemma distinct_of_nat_list: (* TODO: Move to CaesarWordLemmaBucket *)
	"distinct l \<Longrightarrow> \<forall>e \<in> set l. e \<le> unat (max_word :: ('l::len) word) \<Longrightarrow> distinct (map (of_nat :: nat \<Rightarrow> 'l word) l)"
proof(induction l)
	let ?mmw = "(max_word :: 'l word)"
	let ?mstp = "(of_nat :: nat \<Rightarrow> 'l word)"
	case (Cons a as)
	have "distinct as" "\<forall>e\<in>set as. e \<le> unat ?mmw" using Cons.prems by simp_all
	note mIH = Cons.IH[OF this]
	moreover have "?mstp a \<notin> ?mstp ` set as"
	proof
		have representable_set: "set as \<subseteq> {0..unat ?mmw}" using \<open>\<forall>e\<in>set (a # as). e \<le> unat max_word\<close> by fastforce
		have a_reprbl: "a \<in> {0..unat ?mmw}" using \<open>\<forall>e\<in>set (a # as). e \<le> unat max_word\<close> by simp
		assume "?mstp a \<in> ?mstp ` set as"
		with inj_on_image_mem_iff[OF suc2plus_inj_on a_reprbl representable_set]
		have "a \<in> set as" by simp
		with \<open>distinct (a # as)\<close> show False by simp
	qed
	ultimately show ?case by simp
qed simp

lemma annotate_first_le_hlp:
	"length l < unat (max_word :: ('l :: len) word) \<Longrightarrow> \<forall>e\<in>set (map fst (annotate_rlen l)). e \<le> unat (max_word :: 'l word)"
	by(clarsimp) (meson fst_annotate_rlen_le less_trans nat_less_le)
lemmas distinct_of_prio_hlp = distinct_of_nat_list[OF distinct_fst_annotate_rlen annotate_first_le_hlp]
(* don't need these right now, but maybe later? *)

lemma fst_annotate_rlen: "map fst (annotate_rlen l) = rev [0..<length l]"
by(induction l) (simp_all)

lemma sorted_word_upt:
  defines[simp]: "won \<equiv> (of_nat :: nat \<Rightarrow> ('l :: len) word)"
  assumes "length l \<le> unat (max_word :: 'l word)"
  shows "sorted_descending (map won (rev [0..<Suc (length l)]))"
using assms
  by(induction l rule: rev_induct;clarsimp)
    (metis (mono_tags, opaque_lifting) le_SucI le_unat_uoi of_nat_Suc order_refl word_le_nat_alt)
    (* This proof is kind of ugly. In case it breaks unfixably, go back to rev a9c4927 and get word_upto.
       The lemmas on word_upto can be used to shows this trivially. *)

lemma sorted_annotated:
	assumes "length l \<le> unat (max_word :: ('l :: len) word)"
	shows "sorted_descending (map fst (map (apfst (of_nat :: nat \<Rightarrow> 'l word)) (annotate_rlen l)))"
proof -
	let ?won = "(of_nat :: nat \<Rightarrow> 'l word)"
	have "sorted_descending (map ?won (rev [0..<Suc (length l)]))"
		using sorted_word_upt[OF assms] .
	hence "sorted_descending (map ?won (map fst (annotate_rlen l)))" by(simp add: fst_annotate_rlen)
	thus "sorted_descending (map fst (map (apfst ?won) (annotate_rlen l)))" by simp
qed

text\<open>l3 device to l2 forwarding\<close>
definition "lr_of_tran_s3 ifs ard = (
	[(p, b, case a of simple_action.Accept \<Rightarrow> [Forward c] | simple_action.Drop \<Rightarrow> []).
		(p,r,(c,a)) \<leftarrow> ard, b \<leftarrow> simple_match_to_of_match r ifs])"

definition "oif_ne_iif_p1 ifs \<equiv> [(simple_match_any\<lparr>oiface := Iface oif, iiface := Iface iif\<rparr>, simple_action.Accept). oif \<leftarrow> ifs, iif \<leftarrow> ifs, oif \<noteq> iif]"
definition "oif_ne_iif_p2 ifs = [(simple_match_any\<lparr>oiface := Iface i, iiface := Iface i\<rparr>, simple_action.Drop). i \<leftarrow> ifs]"
definition "oif_ne_iif ifs = oif_ne_iif_p2 ifs @ oif_ne_iif_p1 ifs" (* order irrelephant *)
(*value "oif_ne_iif [''a'', ''b'']"*)
(* I first tried something like "oif_ne_iif ifs \<equiv> [(simple_match_any\<lparr>oiface := Iface oi, iiface := Iface ii\<rparr>, if oi = ii then simple_action.Drop else simple_action.Accept). oi \<leftarrow> ifs, ii \<leftarrow> ifs]",
   but making the statement I wanted with that was really tricky. Much easier to have the second element constant and do it separately. *)
definition "lr_of_tran_s4 ard ifs \<equiv> generalized_fw_join ard (oif_ne_iif ifs)"

definition "lr_of_tran_s1 rt = [(route2match r, output_iface (routing_action r)). r \<leftarrow> rt]"

definition "lr_of_tran_fbs rt fw ifs \<equiv> let
	gfw = map simple_rule_dtor fw; \<comment> \<open>generalized simple fw, hopefully for FORWARD\<close>
	frt = lr_of_tran_s1 rt; \<comment> \<open>rt as fw\<close>
	prd = generalized_fw_join frt gfw
	in prd
"

definition "pack_OF_entries ifs ard \<equiv> (map (split3 OFEntry) (lr_of_tran_s3 ifs ard))"
definition "no_oif_match \<equiv> list_all (\<lambda>m. oiface (match_sel m) = ifaceAny)"

definition "lr_of_tran rt fw ifs \<equiv>
  if \<not> (no_oif_match fw \<and> has_default_policy fw \<and> simple_fw_valid fw	\<and> valid_prefixes rt \<and> has_default_route rt \<and> distinct ifs)
    then Inl ''Error in creating OpenFlow table: prerequisites not satisifed''
    else (
  let	nrd = lr_of_tran_fbs rt fw ifs;
	ard = map (apfst of_nat) (annotate_rlen nrd) \<comment> \<open>give them a priority\<close>
	in
	if length nrd < unat (- 1 :: 16 word)
	then Inr (pack_OF_entries ifs ard)
	else Inl ''Error in creating OpenFlow table: priority number space exhausted'')
"

definition "is_iface_name i \<equiv> i \<noteq> [] \<and> \<not>Iface.iface_name_is_wildcard i"
definition "is_iface_list ifs \<equiv> distinct ifs \<and> list_all is_iface_name ifs"

lemma max_16_word_max[simp]: "(a :: 16 word) \<le> 0xffff"
proof -
	have "0xFFFF = (- 1 :: 16 word)" by simp
	then show ?thesis by (simp only:) simp
qed

lemma replicate_FT_hlp: "x \<le> 16 \<and> y \<le> 16 \<Longrightarrow> replicate (16 - x) False @ replicate x True = replicate (16 - y) False @ replicate y True \<Longrightarrow> x = y"
proof -
	let ?ns = "{0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16}"
	assume "x \<le> 16 \<and> y \<le> 16"
	hence "x \<in> ?ns" "y \<in> ?ns" by(simp; presburger)+
	moreover assume "replicate (16 - x) False @ replicate x True = replicate (16 - y) False @ replicate y True"
	ultimately show "x = y" by simp (elim disjE; simp_all add: numeral_eq_Suc) (* that's only 289 subgoals after the elim *)
qed

lemma mask_inj_hlp1: "inj_on (mask :: nat \<Rightarrow> 16 word) {0..16}"
proof(intro inj_onI, goal_cases)
  case (1 x y)
  from 1(3)
  have oe: "of_bl (replicate (16 - x) False @ replicate x True) = (of_bl (replicate (16 - y) False @ replicate y True) :: 16 word)"
         unfolding mask_bl of_bl_rep_False .
  have "\<And>z. z \<le> 16 \<Longrightarrow> length (replicate (16 - z) False @ replicate z True) = 16" by auto
  with 1(1,2)
  have ps: "replicate (16 - x) False @ replicate x True \<in> {bl. length bl = LENGTH(16)}" " replicate (16 - y) False @ replicate y True \<in> {bl. length bl = LENGTH(16)}" by simp_all
  from inj_onD[OF word_bl.Abs_inj_on, OF oe ps]
  show ?case using 1(1,2) by(fastforce intro: replicate_FT_hlp)
qed

lemma distinct_simple_match_to_of_match_portlist_hlp:
  fixes ps :: "(16 word \<times> 16 word)"
  shows "distinct ifs \<Longrightarrow>
    distinct
     (if fst ps = 0 \<and> snd ps = max_word then [None]
      else if fst ps \<le> snd ps
           then map (Some \<circ> (\<lambda>pfx. (pfxm_prefix pfx, ~~ (pfxm_mask pfx))))
                 (wordinterval_CIDR_split_prefixmatch (WordInterval (fst ps) (snd ps)))
           else [])"
proof -
  assume di: "distinct ifs"
  { define wis where "wis = set (wordinterval_CIDR_split_prefixmatch (WordInterval (fst ps) (snd ps)))"
    fix x y :: "16 prefix_match"
    obtain xm xn ym yn where xyd[simp]: "x = PrefixMatch xm xn" "y = PrefixMatch ym yn" by(cases x; cases y)
    assume iw: "x \<in> wis" "y \<in> wis" and et: "(pfxm_prefix x, ~~ (pfxm_mask x)) = (pfxm_prefix y, ~~ (pfxm_mask y))"
    hence le16: "xn \<le> 16" "yn \<le> 16" unfolding wis_def using wordinterval_CIDR_split_prefixmatch_all_valid_Ball[unfolded Ball_def, THEN spec, THEN mp] by force+
    with et have "16 - xn = 16 - yn" unfolding pfxm_mask_def by(auto intro: mask_inj_hlp1[THEN inj_onD])
    hence "x = y" using et le16 using diff_diff_cancel by simp
  } note * = this
  show ?thesis
    apply(clarsimp simp add: smtoms_eq_hlp distinct_map wordinterval_CIDR_split_distinct)
    apply(subst comp_inj_on_iff[symmetric]; intro inj_onI)
  using * by simp_all
qed

lemma distinct_simple_match_to_of_match: "distinct ifs \<Longrightarrow> distinct (simple_match_to_of_match m ifs)"
  apply(unfold simple_match_to_of_match_def Let_def)
  apply(rule distinct_3lcomprI)
  subgoal by(induction ifs; clarsimp)
  subgoal by(fact distinct_simple_match_to_of_match_portlist_hlp)
  subgoal by(fact distinct_simple_match_to_of_match_portlist_hlp)
  subgoal by(simp_all add: smtoms_eq_hlp)
done

lemma inj_inj_on: "inj F \<Longrightarrow> inj_on F A" using subset_inj_on by auto (* TODO: include Word_Lib *)

lemma no_overlaps_lroft_hlp2: "distinct (map fst amr) \<Longrightarrow> (\<And>r. distinct (fm r)) \<Longrightarrow>
    distinct (concat (map (\<lambda>(p, r, c, a). map (\<lambda>b. (p, b, fs a c)) (fm r)) amr))"
  by(induction amr; force intro: injI inj_onI simp add: distinct_map split: prod.splits)

lemma distinct_lroft_s3: "\<lbrakk>distinct (map fst amr); distinct ifs\<rbrakk> \<Longrightarrow> distinct (lr_of_tran_s3 ifs amr)"
  unfolding lr_of_tran_s3_def
  by(erule no_overlaps_lroft_hlp2, simp add: distinct_simple_match_to_of_match)

lemma no_overlaps_lroft_hlp3: "distinct (map fst amr) \<Longrightarrow>
(aa, ab, ac) \<in> set (lr_of_tran_s3 ifs amr) \<Longrightarrow> (ba, bb, bc) \<in> set (lr_of_tran_s3 ifs amr) \<Longrightarrow>
ac \<noteq> bc \<Longrightarrow> aa \<noteq> ba"
  apply(unfold lr_of_tran_s3_def)
  apply(clarsimp)
  apply(clarsimp split: simple_action.splits)
    apply(metis map_of_eq_Some_iff old.prod.inject option.inject)
   apply(metis map_of_eq_Some_iff old.prod.inject option.inject simple_action.distinct(2))+
done

lemma no_overlaps_lroft_s3_hlp_hlp: (* I hlps *)
  "\<lbrakk>distinct (map fst amr); OF_match_fields_unsafe ab p; ab \<noteq> ad \<or> ba \<noteq> bb; OF_match_fields_unsafe ad p;
        (ac, ab, ba) \<in> set (lr_of_tran_s3 ifs amr); (ac, ad, bb) \<in> set (lr_of_tran_s3 ifs amr)\<rbrakk>
       \<Longrightarrow> False"
proof(elim disjE, goal_cases)
  case 1
  have 4: "\<lbrakk>distinct (map fst amr);  (ac, ab, x1, x2) \<in> set amr; (ac, bb, x4, x5) \<in> set amr; ab \<noteq> bb\<rbrakk>
       \<Longrightarrow> False" for ab x1 x2 bb x4 x5
       by (meson distinct_map_fstD old.prod.inject)
  have conjunctSomeProtoAnyD: "Some ProtoAny = simple_proto_conjunct a (Proto b) \<Longrightarrow> False" for a b
    using conjunctProtoD by force
  have 5:
       "\<lbrakk>OF_match_fields_unsafe am p; OF_match_fields_unsafe bm p; am \<noteq> bm;
        am \<in> set (simple_match_to_of_match ab ifs); bm \<in> set (simple_match_to_of_match bb ifs); \<not> ab \<noteq> bb\<rbrakk>
       \<Longrightarrow> False" for ab bb am bm
      by(clarify | unfold
         simple_match_to_of_match_def smtoms_eq_hlp Let_def set_concat set_map de_Morgan_conj not_False_eq_True)+
        (auto dest: conjunctSomeProtoAnyD cidrsplit_no_overlaps
	            simp add: OF_match_fields_unsafe_def simple_match_to_of_match_single_def option2set_def comp_def
	            split: if_splits
	            cong: smtoms_eq_hlp) (*1min*)
  from 1 show ?case
  using 4 5 by(clarsimp simp add: lr_of_tran_s3_def) blast
qed(metis no_overlaps_lroft_hlp3)

lemma no_overlaps_lroft_s3_hlp: "distinct (map fst amr) \<Longrightarrow> distinct ifs \<Longrightarrow>
no_overlaps OF_match_fields_unsafe (map (split3 OFEntry) (lr_of_tran_s3 ifs amr))"
  apply(rule no_overlapsI[rotated])
  apply(subst distinct_map, rule conjI)
  subgoal by(erule (1) distinct_lroft_s3)
  subgoal
    apply(rule inj_inj_on)
    apply(rule injI)
    apply(rename_tac x y, case_tac x, case_tac y)
    apply(simp add: split3_def;fail)
  done
  subgoal
    apply(unfold check_no_overlap_def)
    apply(clarify)
    apply(unfold set_map)
    apply(clarify)
    apply(unfold split3_def prod.simps flow_entry_match.simps flow_entry_match.sel de_Morgan_conj)
    apply(clarsimp simp only:)
    apply(erule (1) no_overlaps_lroft_s3_hlp_hlp)
       apply simp
      apply assumption
     apply assumption
    apply simp
  done
done

lemma lr_of_tran_no_overlaps: assumes "distinct ifs" shows "Inr t = (lr_of_tran rt fw ifs) \<Longrightarrow> no_overlaps OF_match_fields_unsafe t"
	apply(unfold lr_of_tran_def Let_def pack_OF_entries_def)
	apply(simp split: if_splits)
	apply(thin_tac "t = _")
	apply(drule distinct_of_prio_hlp)
	apply(rule no_overlaps_lroft_s3_hlp[rotated])
	subgoal by(simp add: assms)
	subgoal by(simp add: o_assoc)
done

lemma sorted_lr_of_tran_s3_hlp: "\<forall>x\<in>set f. fst x \<le> a \<Longrightarrow> b \<in> set (lr_of_tran_s3 s f) \<Longrightarrow> fst b \<le> a"
	by(auto simp add: lr_of_tran_s3_def)

lemma lr_of_tran_s3_Cons: "lr_of_tran_s3 ifs (a#ard) = (
	[(p, b, case a of simple_action.Accept \<Rightarrow> [Forward c] | simple_action.Drop \<Rightarrow> []).
		(p,r,(c,a)) \<leftarrow> [a], b \<leftarrow> simple_match_to_of_match r ifs]) @ lr_of_tran_s3 ifs ard"
	by(clarsimp simp: lr_of_tran_s3_def)

lemma sorted_lr_of_tran_s3: "sorted_descending (map fst f) \<Longrightarrow> sorted_descending (map fst (lr_of_tran_s3 s f))"
	apply(induction f)
	 subgoal by(simp add: lr_of_tran_s3_def)
	apply(clarsimp simp: lr_of_tran_s3_Cons map_concat comp_def)
	apply(unfold sorted_descending_append)
	apply(simp add: sorted_descending_alt rev_map sorted_lr_of_tran_s3_hlp sorted_const)
done

lemma sorted_lr_of_tran_hlp: "(ofe_prio \<circ> split3 OFEntry) = fst" by(simp add: fun_eq_iff comp_def split3_def)

lemma lr_of_tran_sorted_descending: "Inr r = lr_of_tran rt fw ifs \<Longrightarrow> sorted_descending (map ofe_prio r)"
	apply(unfold lr_of_tran_def Let_def)
	apply(simp split: if_splits)
	apply(thin_tac "r = _")
	apply(unfold sorted_lr_of_tran_hlp pack_OF_entries_def split3_def[abs_def] fun_app_def map_map comp_def prod.case_distrib)
	apply(simp add: fst_def[symmetric])
	apply(rule sorted_lr_of_tran_s3)
	apply(drule sorted_annotated[OF less_or_eq_imp_le, OF disjI1])
	apply(simp add: o_assoc)
done

lemma route2match_correct: "valid_prefix (routing_match a) \<Longrightarrow> prefix_match_semantics (routing_match a) (p_dst p) \<longleftrightarrow> simple_matches (route2match a) (p)"
by(simp add: route2match_def simple_matches.simps match_ifaceAny match_iface_refl ipset_from_cidr_0 prefix_match_semantics_ipset_from_netmask2)

lemma s1_correct: "valid_prefixes rt \<Longrightarrow> has_default_route (rt::('i::len) prefix_routing) \<Longrightarrow>
  \<exists>rm ra. generalized_sfw (lr_of_tran_s1 rt) p = Some (rm,ra) \<and> ra = output_iface (routing_table_semantics rt (p_dst p))"
	apply(induction rt)
	 apply(simp;fail)
	apply(drule valid_prefixes_split)
	apply(clarsimp)
	apply(erule disjE)
	subgoal for a rt
	 apply(case_tac a)
	 apply(rename_tac routing_m metric routing_action)
	 apply(case_tac routing_m)
	 apply(simp add: valid_prefix_def pfxm_mask_def prefix_match_semantics_def generalized_sfw_def
	       lr_of_tran_s1_def route2match_def simple_matches.simps match_ifaceAny match_iface_refl ipset_from_cidr_0
	       max_word_mask[where 'a = 'i, symmetric, simplified])
	done
	subgoal
    apply(rule conjI)
     apply(simp add: generalized_sfw_def lr_of_tran_s1_def route2match_correct;fail)
    apply(simp add: route2match_def simple_matches.simps prefix_match_semantics_ipset_from_netmask2
                    lr_of_tran_s1_split generalized_sfw_simps)
  done
done

definition "to_OF_action a \<equiv> (case a of (p,d) \<Rightarrow> (case d of simple_action.Accept \<Rightarrow> [Forward p] | simple_action.Drop \<Rightarrow> []))"
definition "from_OF_action a = (case a of [] \<Rightarrow> ('''',simple_action.Drop) | [Forward p] \<Rightarrow> (p, simple_action.Accept))"

lemma OF_match_linear_not_noD: "OF_match_linear \<gamma> oms p \<noteq> NoAction \<Longrightarrow> \<exists>ome. ome \<in> set oms \<and> \<gamma> (ofe_fields ome) p"
	apply(induction oms)
	 apply(simp)
	apply(simp split: if_splits)
	 apply blast+
done

lemma s3_noaction_hlp: "\<lbrakk>simple_match_valid ac; \<not>simple_matches ac p; match_iface (oiface ac) (p_oiface p)\<rbrakk> \<Longrightarrow>
OF_match_linear OF_match_fields_safe (map (\<lambda>x. split3 OFEntry (x1, x, case ba of simple_action.Accept \<Rightarrow> [Forward ad] | simple_action.Drop \<Rightarrow> [])) (simple_match_to_of_match ac ifs)) p = NoAction"
  apply(rule ccontr)
  apply(drule OF_match_linear_not_noD)
  apply(clarsimp)
  apply(rename_tac x)
  apply(subgoal_tac "all_prerequisites x")
   apply(drule simple_match_to_of_matchD)
      apply(simp add: split3_def)
      apply(subst(asm) of_match_fields_safe_eq2)
      apply(simp;fail)+
  using simple_match_to_of_match_generates_prereqs by blast

lemma aux:
  \<open>v = Some x \<Longrightarrow> the v = x\<close>
  by simp

lemma s3_correct:
	assumes vsfwm: "list_all simple_match_valid (map (fst \<circ> snd) ard)"
	assumes ippkt: "p_l2type p = 0x800"
	assumes iiifs: "p_iiface p \<in> set ifs"
	assumes oiifs: "list_all (\<lambda>m. oiface (fst (snd m)) = ifaceAny) ard"
	shows "OF_match_linear OF_match_fields_safe (pack_OF_entries ifs ard) p = Action ao \<longleftrightarrow> (\<exists>r af. generalized_sfw (map snd ard) p = (Some (r,af)) \<and> (if snd af = simple_action.Drop then ao = [] else ao = [Forward (fst af)]))"
unfolding pack_OF_entries_def lr_of_tran_s3_def fun_app_def
using vsfwm oiifs
  apply(induction ard)
   subgoal by(simp add: generalized_sfw_simps)
  apply simp
  apply(clarsimp simp add: generalized_sfw_simps split: prod.splits)
  apply(intro conjI) (* make two subgoals from one *)
   subgoal for ard x1 ac ad ba
    apply(clarsimp simp add: OF_match_linear_append split: prod.splits)
    apply(drule simple_match_to_of_matchI[rotated])
       apply(rule iiifs)
      apply(rule ippkt)
     apply blast
    apply(clarsimp simp add: comp_def)
    apply(drule
       OF_match_linear_match_allsameaction[where
         \<gamma>=OF_match_fields_safe and pri = x1 and
         oms = "simple_match_to_of_match ac ifs" and
         act = "case ba of simple_action.Accept \<Rightarrow> [Forward ad] | simple_action.Drop \<Rightarrow> []"])
     apply(unfold OF_match_fields_safe_def comp_def)
     apply(erule aux)
    apply(clarsimp)
    apply(intro iffI)
    subgoal
     apply(rule exI[where x = ac])
     apply(rule exI[where x = ad])
     apply(rule exI[where x = ba])
     apply(clarsimp simp: split3_def split: simple_action.splits flowtable_behavior.splits if_splits)
    done
    subgoal
     apply(clarsimp)
     apply(rename_tac b)
     apply(case_tac b)
     apply(simp_all)
   done
  done
  subgoal for ard x1 ac ad ba
   apply(simp add: OF_match_linear_append OF_match_fields_safe_def comp_def)
   apply(clarify)
   apply(subgoal_tac "OF_match_linear OF_match_fields_safe (map (\<lambda>x. split3 OFEntry (x1, x, case ba of simple_action.Accept \<Rightarrow> [Forward ad] | simple_action.Drop \<Rightarrow> [])) (simple_match_to_of_match ac ifs)) p = NoAction")
    apply(simp;fail)
   apply(erule (1) s3_noaction_hlp)
   apply(simp add: match_ifaceAny;fail)
  done
done

context
  notes valid_prefix_00[simp, intro!]
begin
  lemma lr_of_tran_s1_valid: "valid_prefixes rt \<Longrightarrow> gsfw_valid (lr_of_tran_s1 rt)"
    unfolding lr_of_tran_s1_def route2match_def gsfw_valid_def list_all_iff
    apply(clarsimp simp: simple_match_valid_def valid_prefix_fw_def)
    apply(intro conjI)
     apply force
    apply(simp add: valid_prefixes_alt_def)
  done
end

lemma simple_match_valid_fbs_rlen: "\<lbrakk>valid_prefixes rt; simple_fw_valid fw; (a, aa, ab, b) \<in> set (annotate_rlen (lr_of_tran_fbs rt fw ifs))\<rbrakk> \<Longrightarrow> simple_match_valid aa"
proof(goal_cases)
  case 1
  note 1[unfolded lr_of_tran_fbs_def Let_def]
  have "gsfw_valid (map simple_rule_dtor fw)" using gsfw_validI 1 by blast
  moreover have "gsfw_valid (lr_of_tran_s1 rt)" using 1 lr_of_tran_s1_valid by blast
  ultimately have "gsfw_valid (generalized_fw_join (lr_of_tran_s1 rt) (map simple_rule_dtor fw))" using gsfw_join_valid by blast
  moreover have "(aa, ab, b) \<in> set (lr_of_tran_fbs rt fw ifs)" using 1 using in_annotate_rlen by fast
  ultimately show ?thesis unfolding lr_of_tran_fbs_def Let_def gsfw_valid_def list_all_iff by fastforce
qed

lemma simple_match_valid_fbs: "\<lbrakk>valid_prefixes rt; simple_fw_valid fw\<rbrakk> \<Longrightarrow> list_all simple_match_valid (map fst (lr_of_tran_fbs rt fw ifs))"
proof(goal_cases)
  case 1
  note 1[unfolded lr_of_tran_fbs_def Let_def]
  have "gsfw_valid (map simple_rule_dtor fw)" using gsfw_validI 1 by blast
  moreover have "gsfw_valid (lr_of_tran_s1 rt)" using 1 lr_of_tran_s1_valid by blast
  ultimately have "gsfw_valid (generalized_fw_join (lr_of_tran_s1 rt) (map simple_rule_dtor fw))" using gsfw_join_valid by blast
  thus ?thesis unfolding lr_of_tran_fbs_def Let_def gsfw_valid_def list_all_iff by fastforce
qed

lemma lr_of_tran_prereqs: "valid_prefixes rt \<Longrightarrow> simple_fw_valid fw \<Longrightarrow> lr_of_tran rt fw ifs = Inr oft \<Longrightarrow>
list_all (all_prerequisites \<circ> ofe_fields) oft"
unfolding lr_of_tran_def pack_OF_entries_def lr_of_tran_s3_def Let_def
  apply(simp add: map_concat comp_def prod.case_distrib split3_def split: if_splits)
  apply(simp add: list_all_iff)
  apply(clarsimp)
  apply(drule simple_match_valid_fbs_rlen[rotated])
    apply(simp add: list_all_iff;fail)
   apply(simp add: list_all_iff;fail)
  apply(rule simple_match_to_of_match_generates_prereqs; assumption)
done

(* TODO: move. where? *)
lemma OF_unsafe_safe_match3_eq: "
  list_all (all_prerequisites \<circ> ofe_fields) oft \<Longrightarrow>
  OF_priority_match OF_match_fields_unsafe oft = OF_priority_match OF_match_fields_safe oft"
unfolding OF_priority_match_def[abs_def]
proof(goal_cases)
  case 1
  from 1 have "\<And>packet. [f\<leftarrow>oft . OF_match_fields_unsafe (ofe_fields f) packet] = [f\<leftarrow>oft . OF_match_fields_safe (ofe_fields f) packet]"
    apply(clarsimp simp add: list_all_iff of_match_fields_safe_eq)
  using of_match_fields_safe_eq by(metis (mono_tags, lifting) filter_cong)
  thus ?case by metis
qed

lemma OF_unsafe_safe_match_linear_eq: "
  list_all (all_prerequisites \<circ> ofe_fields) oft \<Longrightarrow>
  OF_match_linear OF_match_fields_unsafe oft = OF_match_linear OF_match_fields_safe oft"
unfolding fun_eq_iff
by(induction oft) (clarsimp simp add: list_all_iff of_match_fields_safe_eq)+

lemma simple_action_ne[simp]:
  "b \<noteq> simple_action.Accept \<longleftrightarrow> b = simple_action.Drop"
  "b \<noteq> simple_action.Drop \<longleftrightarrow> b = simple_action.Accept"
using simple_action.exhaust by blast+

lemma map_snd_apfst: "map snd (map (apfst x) l) = map snd l"
  unfolding map_map comp_def snd_apfst ..

lemma match_ifaceAny_eq: "oiface m = ifaceAny \<Longrightarrow> simple_matches m p = simple_matches m (p\<lparr>p_oiface := any\<rparr>)"
by(cases m) (simp add: simple_matches.simps match_ifaceAny)
lemma no_oif_matchD: "no_oif_match fw \<Longrightarrow> simple_fw fw p = simple_fw fw (p\<lparr>p_oiface := any\<rparr>)"
  by(induction fw)
    (auto simp add: no_oif_match_def simple_fw_alt dest: match_ifaceAny_eq)

lemma lr_of_tran_fbs_acceptD:
  assumes s1: "valid_prefixes rt" "has_default_route rt"
  assumes s2: "no_oif_match fw"
  shows "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Accept) \<Longrightarrow>
  simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>)"
proof(goal_cases)
  case 1
  note 1[unfolded lr_of_tran_fbs_def Let_def, THEN generalized_fw_joinD]
  then guess r1 .. then guess r2 .. note r12 = this
  note s1_correct[OF s1, of p]
  then guess rm .. then guess ra .. note rmra = this
  from r12 rmra have oifra: "oif = ra" by simp
  from r12 have sfw: "simple_fw fw p = Decision FinalAllow" using simple_fw_iff_generalized_fw_accept by blast
  note ifupdateirrel = no_oif_matchD[OF s2, where any = " output_iface (routing_table_semantics rt (p_dst p))" and p = p, symmetric]
  show ?case unfolding simple_linux_router_nol12_def by(simp add: Let_def ifupdateirrel sfw oifra rmra split: Option.bind_splits option.splits)
qed

lemma lr_of_tran_fbs_acceptI:
  assumes s1: "valid_prefixes rt" "has_default_route rt"
  assumes s2: "no_oif_match fw" "has_default_policy fw"
  shows "simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>) \<Longrightarrow>
  \<exists>r. generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Accept)"
proof(goal_cases)
  from s2 have nud: "\<And>p. simple_fw fw p \<noteq> Undecided" by (metis has_default_policy state.distinct(1))
  note ifupdateirrel = no_oif_matchD[OF s2(1), symmetric]
  case 1
  from 1 have "simple_fw fw p = Decision FinalAllow" by(simp add: simple_linux_router_nol12_def Let_def nud ifupdateirrel split: Option.bind_splits state.splits final_decision.splits)
  then obtain r where r: "generalized_sfw (map simple_rule_dtor fw) p = Some (r, simple_action.Accept)" using simple_fw_iff_generalized_fw_accept by blast
  have oif_def: "oif = output_iface (routing_table_semantics rt (p_dst p))" using 1 by(cases p) (simp add: simple_linux_router_nol12_def Let_def nud ifupdateirrel split: Option.bind_splits state.splits final_decision.splits)
  note s1_correct[OF s1, of p] then guess rm .. then guess ra .. note rmra = this
  show ?case unfolding lr_of_tran_fbs_def Let_def
    apply(rule exI)
    apply(rule generalized_fw_joinI)
    unfolding oif_def using rmra apply simp
    apply(rule r)
  done
qed

lemma lr_of_tran_fbs_dropD:
  assumes s1: "valid_prefixes rt" "has_default_route rt"
  assumes s2: "no_oif_match fw"
  shows "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop) \<Longrightarrow>
  simple_linux_router_nol12 rt fw p = None"
proof(goal_cases)
  note ifupdateirrel = no_oif_matchD[OF s2(1), symmetric]
  case 1
  from 1[unfolded lr_of_tran_fbs_def Let_def, THEN generalized_fw_joinD]
  obtain rr fr where "generalized_sfw (lr_of_tran_s1 rt) p = Some (rr, oif) \<and>
          generalized_sfw (map simple_rule_dtor fw) p = Some (fr, simple_action.Drop) \<and> Some r = simple_match_and rr fr" by presburger
  hence fd: "\<And>u. simple_fw fw (p\<lparr>p_oiface := u\<rparr>) = Decision FinalDeny" unfolding ifupdateirrel
  using simple_fw_iff_generalized_fw_drop by blast
  show ?thesis
    by(clarsimp simp: simple_linux_router_nol12_def Let_def fd split: Option.bind_splits)
qed

lemma lr_of_tran_fbs_dropI:
  assumes s1: "valid_prefixes rt" "has_default_route rt"
  assumes s2: "no_oif_match fw" "has_default_policy fw"
  shows "simple_linux_router_nol12 rt fw p = None \<Longrightarrow>
  \<exists>r oif. generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop)"
proof(goal_cases)
  from s2 have nud: "\<And>p. simple_fw fw p \<noteq> Undecided" by (metis has_default_policy state.distinct(1))
  note ifupdateirrel = no_oif_matchD[OF s2(1), symmetric]
  case 1
  from 1 have "simple_fw fw p = Decision FinalDeny" by(simp add: simple_linux_router_nol12_def Let_def nud ifupdateirrel split: Option.bind_splits state.splits final_decision.splits)
  then obtain r where r: "generalized_sfw (map simple_rule_dtor fw) p = Some (r, simple_action.Drop)" using simple_fw_iff_generalized_fw_drop by blast
  note s1_correct[OF s1, of p] then guess rm .. then guess ra .. note rmra = this
  show ?case unfolding lr_of_tran_fbs_def Let_def
    apply(rule exI)
    apply(rule exI[where x = ra])
    apply(rule generalized_fw_joinI)
    using rmra apply simp
    apply(rule r)
  done
qed

lemma no_oif_match_fbs:
 "no_oif_match fw \<Longrightarrow> list_all (\<lambda>m. oiface (fst (snd m)) = ifaceAny) (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))"
proof(goal_cases)
  case 1
  have c: "\<And>mr ar mf af f a. \<lbrakk>(mr, ar) \<in> set (lr_of_tran_s1 rt); (mf, af) \<in> simple_rule_dtor ` set fw; simple_match_and mr mf = Some a\<rbrakk> \<Longrightarrow> oiface a = ifaceAny"
  proof(goal_cases)
    case (1 mr ar mf af f a)
    have "oiface mr = ifaceAny" using 1(1) unfolding lr_of_tran_s1_def route2match_def by(clarsimp simp add: Set.image_iff)
    moreover have "oiface mf = ifaceAny" using 1(2) \<open>no_oif_match fw\<close> unfolding no_oif_match_def simple_rule_dtor_def[abs_def]
      by(clarsimp simp: list_all_iff split: simple_rule.splits) fastforce
    ultimately show ?case using 1(3) by(cases a; cases mr; cases mf) (simp add: iface_conjunct_ifaceAny split: option.splits)
  qed
  have la: "list_all (\<lambda>m. oiface (fst m) = ifaceAny) (lr_of_tran_fbs rt fw ifs)"
    unfolding lr_of_tran_fbs_def Let_def list_all_iff
    apply(clarify)
    apply(subst(asm) generalized_sfw_join_set)
    apply(clarsimp)
  using c by blast
  thus ?case
  proof(goal_cases)
    case 1
    have *: "(\<lambda>m. oiface (fst (snd m)) = ifaceAny) = (\<lambda>m. oiface (fst m) = ifaceAny) \<circ> snd" unfolding comp_def ..
    show ?case unfolding * list_all_map[symmetric] map_snd_apfst map_snd_annotate_rlen using la .
  qed
qed

lemma lr_of_tran_correct:
	fixes p :: "(32, 'a) simple_packet_ext_scheme"
assumes nerr: "lr_of_tran rt fw ifs = Inr oft"
	 and ippkt: "p_l2type p = 0x800"
	 and ifvld: "p_iiface p \<in> set ifs"
	shows "OF_priority_match OF_match_fields_safe oft p = Action [Forward oif] \<longleftrightarrow> simple_linux_router_nol12 rt fw p = (Some (p\<lparr>p_oiface := oif\<rparr>))"
	      "OF_priority_match OF_match_fields_safe oft p = Action [] \<longleftrightarrow> simple_linux_router_nol12 rt fw p = None"
	      (* fun stuff: *)
	      "OF_priority_match OF_match_fields_safe oft p \<noteq> NoAction" "OF_priority_match OF_match_fields_safe oft p \<noteq> Undefined"
	      "OF_priority_match OF_match_fields_safe oft p = Action ls \<longrightarrow> length ls \<le> 1"
	      "\<exists>ls. length ls \<le> 1 \<and> OF_priority_match OF_match_fields_safe oft p = Action ls"
proof -
	have s1: "valid_prefixes rt" "has_default_route rt"
   and s2: "has_default_policy fw" "simple_fw_valid fw" "no_oif_match fw"
   and difs: "distinct ifs"
	  using nerr unfolding lr_of_tran_def by(simp_all split: if_splits)
  have "no_oif_match fw" using nerr unfolding lr_of_tran_def by(simp split: if_splits)
  note s2 = s2 this
  have unsafe_safe_eq:
    "OF_priority_match OF_match_fields_unsafe oft = OF_priority_match OF_match_fields_safe oft"
    "OF_match_linear OF_match_fields_unsafe oft = OF_match_linear OF_match_fields_safe oft"
    apply(subst OF_unsafe_safe_match3_eq; (rule lr_of_tran_prereqs s1 s2 nerr refl)+)
    apply(subst OF_unsafe_safe_match_linear_eq; (rule lr_of_tran_prereqs s1 s2 nerr refl)+)
  done
  have lin: "OF_priority_match OF_match_fields_safe oft = OF_match_linear OF_match_fields_safe oft"
    using OF_eq[OF lr_of_tran_no_overlaps lr_of_tran_sorted_descending, OF difs nerr[symmetric] nerr[symmetric]] unfolding fun_eq_iff unsafe_safe_eq by metis
  let ?ard = "map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs))"
  have oft_def: "oft = pack_OF_entries ifs ?ard" using nerr unfolding lr_of_tran_def Let_def by(simp split: if_splits)
  have vld: "list_all simple_match_valid (map (fst \<circ> snd) ?ard)"
    unfolding fun_app_def map_map[symmetric] snd_apfst map_snd_apfst map_snd_annotate_rlen using simple_match_valid_fbs[OF s1(1) s2(2)] .
  have *: "list_all (\<lambda>m. oiface (fst (snd m)) = ifaceAny) ?ard" using no_oif_match_fbs[OF s2(3)] .
  have not_undec: "\<And>p. simple_fw fw p \<noteq> Undecided" by (metis has_default_policy s2(1) state.simps(3))
  have w1_1: "\<And>oif. OF_match_linear OF_match_fields_safe oft p = Action [Forward oif] \<Longrightarrow> simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>)
    \<and> oif = output_iface (routing_table_semantics rt (p_dst p))"
  proof(intro conjI, goal_cases)
    case (1 oif)
    note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD1, unfolded oft_def[symmetric], OF 1]
    hence "\<exists>r. generalized_sfw (map snd (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))) p = Some (r, (oif, simple_action.Accept))"
      by(clarsimp split: if_splits)
    then obtain r where "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, (oif, simple_action.Accept))"
      unfolding map_map comp_def snd_apfst map_snd_annotate_rlen by blast
    thus ?case using lr_of_tran_fbs_acceptD[OF s1 s2(3)] by metis
    thus "oif = output_iface (routing_table_semantics rt (p_dst p))"
      by(cases p) (clarsimp simp: simple_linux_router_nol12_def Let_def not_undec split: Option.bind_splits state.splits final_decision.splits)
  qed
  have w1_2: "\<And>oif. simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>) \<Longrightarrow> OF_match_linear OF_match_fields_safe oft p = Action [Forward oif]"
  proof(goal_cases)
    case (1 oif)
    note lr_of_tran_fbs_acceptI[OF s1 s2(3) s2(1) this, of ifs] then guess r .. note r = this
    hence "generalized_sfw (map snd (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))) p = Some (r, (oif, simple_action.Accept))"
    unfolding map_snd_apfst map_snd_annotate_rlen .
    moreover note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD2, unfolded oft_def[symmetric], of "[Forward oif]"]
    ultimately show ?case by simp
  qed
  show w1: "\<And>oif. (OF_priority_match OF_match_fields_safe oft p = Action [Forward oif]) = (simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>))"
    unfolding lin using w1_1 w1_2 by blast
  show w2: "(OF_priority_match OF_match_fields_safe oft p = Action []) = (simple_linux_router_nol12 rt fw p = None)"
  unfolding lin
  proof(rule iffI, goal_cases)
    case 1
    note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD1, unfolded oft_def[symmetric], OF 1]
    then obtain r oif where roif: "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop)"
      unfolding map_snd_apfst map_snd_annotate_rlen by(clarsimp split: if_splits)
    note lr_of_tran_fbs_dropD[OF s1 s2(3) this]
    thus ?case .
  next
    case 2
    note lr_of_tran_fbs_dropI[OF s1 s2(3) s2(1) this, of ifs] then
    obtain r oif where "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop)" by blast
    hence "generalized_sfw (map snd (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))) p = Some (r, oif, simple_action.Drop)"
      unfolding map_snd_apfst map_snd_annotate_rlen .
    moreover note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD2, unfolded oft_def[symmetric], of "[]"]
    ultimately show ?case by force
  qed
  have lr_determ: "\<And>a. simple_linux_router_nol12 rt fw p = Some a \<Longrightarrow> a = p\<lparr>p_oiface := output_iface (routing_table_semantics rt (p_dst p))\<rparr>"
    by(clarsimp simp: simple_linux_router_nol12_def Let_def not_undec split: Option.bind_splits state.splits final_decision.splits)
  show notno: "OF_priority_match OF_match_fields_safe oft p \<noteq> NoAction"
    apply(cases "simple_linux_router_nol12 rt fw p")
    using w2 apply(simp)
    using w1[of "output_iface (routing_table_semantics rt (p_dst p))"] apply(simp)
    apply(drule lr_determ)
    apply(simp)
  done
  show notub: "OF_priority_match OF_match_fields_safe oft p \<noteq> Undefined" unfolding lin using OF_match_linear_ne_Undefined .
  show notmult: "\<And>ls. OF_priority_match OF_match_fields_safe oft p = Action ls \<longrightarrow> length ls \<le> 1"
  apply(cases "simple_linux_router_nol12 rt fw p")
    using w2 apply(simp)
    using w1[of "output_iface (routing_table_semantics rt (p_dst p))"] apply(simp)
    apply(drule lr_determ)
    apply(clarsimp)
  done
  show "\<exists>ls. length ls \<le> 1 \<and> OF_priority_match OF_match_fields_safe oft p = Action ls"
    apply(cases "OF_priority_match OF_match_fields_safe oft p")
    using notmult apply blast
    using notno   apply blast
    using notub   apply blast
  done
qed

end