section\<open>Theory of Events for Security Protocols that use smartcards\<close>

theory EventSC
imports
  "../Message"
  "HOL-Library.Simps_Case_Conv"
begin

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

datatype card = Card agent

text\<open>Four new events express the traffic between an agent and his card\<close>
datatype
  event = Says  agent agent msg
        | Notes agent       msg
        | Gets  agent       msg
        | Inputs agent card msg (*Agent sends to card and\<dots>*)
        | C_Gets card       msg (*\<dots> card receives it*)
        | Outpts card agent msg (*Card sends to agent and\<dots>*)
        | A_Gets agent      msg (*agent receives it*)

consts
 bad     :: "agent set"  (*compromised agents*)
 stolen    :: "card set" (* stolen smart cards *)
 cloned  :: "card set"   (* cloned smart cards*)
 secureM :: "bool"(*assumption of secure means between agents and their cards*)

abbreviation
  insecureM :: bool where (*certain protocols make no assumption of secure means*)
  "insecureM == \<not>secureM"

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

specification (stolen)
  (*The server's card is secure by assumption\<dots>*)
  Card_Server_not_stolen [iff]: "Card Server \<notin> stolen"
  Card_Spy_not_stolen    [iff]: "Card Spy \<notin> stolen"
  apply blast done

specification (cloned)
  (*\<dots> the spy's card is secure because she already can use it freely*)
  Card_Server_not_cloned [iff]: "Card Server \<notin> cloned"
  Card_Spy_not_cloned    [iff]: "Card Spy \<notin> cloned"
  apply blast done

primrec (*This definition is extended over the new events, subject to the
          assumption of secure means*)
  knows   :: "agent => event list => msg set" (*agents' knowledge*) where
  knows_Nil:   "knows A [] = initState A" |
  knows_Cons:  "knows A (ev # evs) =
         (case ev of
            Says A' B X =>
                if (A=A' | A=Spy) then insert X (knows A evs) else knows A evs
          | Notes A' X  =>
                if (A=A' | (A=Spy & A'\<in>bad)) then insert X (knows A evs)
                                             else knows A evs
          | Gets A' X   =>
                if (A=A' & A \<noteq> Spy) then insert X (knows A evs)
                                     else knows A evs
          | Inputs A' C X =>
              if secureM then
                if A=A' then insert X (knows A evs) else knows A evs
              else
                if (A=A' | A=Spy) then insert X (knows A evs) else knows A evs
          | C_Gets C X   => knows A evs
          | Outpts C A' X =>
              if secureM then
                if A=A' then insert X (knows A evs) else knows A evs
              else
                if A=Spy then insert X (knows A evs) else knows A evs
          | A_Gets A' X   =>
                if (A=A' & A \<noteq> Spy) then insert X (knows A evs)
                                     else knows A evs)"

primrec
  (*The set of items that might be visible to someone is easily extended
    over the new events*)
  used :: "event list => msg set" where
  used_Nil:   "used []         = (UN B. parts (initState B))" |
  used_Cons:  "used (ev # evs) =
                 (case ev of
                    Says A B X => parts {X} \<union> (used evs)
                  | Notes A X  => parts {X} \<union> (used evs)
                  | Gets A X   => used evs
                  | Inputs A C X  => parts{X} \<union> (used evs)
                  | C_Gets C X   => used evs
                  | Outpts C A X  => parts{X} \<union> (used evs)
                  | A_Gets A X   => used evs)"
    \<comment> \<open>\<^term>\<open>Gets\<close> always follows \<^term>\<open>Says\<close> in real protocols.
       Likewise, \<^term>\<open>C_Gets\<close> will always have to follow \<^term>\<open>Inputs\<close>
       and \<^term>\<open>A_Gets\<close> will always have to follow \<^term>\<open>Outpts\<close>\<close>

lemma Notes_imp_used [rule_format]: "Notes A X \<in> set evs \<longrightarrow> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

lemma Says_imp_used [rule_format]: "Says A B X \<in> set evs \<longrightarrow> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

lemma MPair_used [rule_format]:
     "MPair X Y \<in> used evs \<longrightarrow> X \<in> used evs & Y \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

subsection\<open>Function \<^term>\<open>knows\<close>\<close>

(*Simplifying
 parts(insert X (knows Spy evs)) = parts{X} \<union> parts(knows Spy evs).
  This version won't loop with the simplifier.*)
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>\<open>A=Spy\<close> and whether \<^term>\<open>A\<in>bad\<close>\<close>
lemma knows_Spy_Notes [simp]:
     "knows Spy (Notes A X # evs) =
          (if A\<in>bad then insert X (knows Spy evs) else knows Spy evs)"
by simp

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

lemma knows_Spy_Inputs_secureM [simp]:
     "secureM \<Longrightarrow> knows Spy (Inputs A C X # evs) =
        (if A=Spy then insert X (knows Spy evs) else knows Spy evs)"
by simp

lemma knows_Spy_Inputs_insecureM [simp]:
     "insecureM \<Longrightarrow> knows Spy (Inputs A C X # evs) = insert X (knows Spy evs)"
by simp

lemma knows_Spy_C_Gets [simp]: "knows Spy (C_Gets C X # evs) = knows Spy evs"
by simp

lemma knows_Spy_Outpts_secureM [simp]:
      "secureM \<Longrightarrow> knows Spy (Outpts C A X # evs) =
         (if A=Spy then insert X (knows Spy evs) else knows Spy evs)"
by simp

lemma knows_Spy_Outpts_insecureM [simp]:
      "insecureM \<Longrightarrow> knows Spy (Outpts C A X # evs) = insert X (knows Spy evs)"
by simp

lemma knows_Spy_A_Gets [simp]: "knows Spy (A_Gets A X # evs) = knows Spy evs"
by simp

lemma knows_Spy_subset_knows_Spy_Says:
     "knows Spy evs \<subseteq> knows Spy (Says A B X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Notes:
     "knows Spy evs \<subseteq> knows Spy (Notes A X # evs)"
by force

lemma knows_Spy_subset_knows_Spy_Gets:
     "knows Spy evs \<subseteq> knows Spy (Gets A X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Inputs:
     "knows Spy evs \<subseteq> knows Spy (Inputs A C X # evs)"
by auto

lemma knows_Spy_equals_knows_Spy_Gets:
     "knows Spy evs = knows Spy (C_Gets C X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Outpts: "knows Spy evs \<subseteq> knows Spy (Outpts C A X # evs)"
by auto

lemma knows_Spy_subset_knows_Spy_A_Gets: "knows Spy evs \<subseteq> knows Spy (A_Gets A X # evs)"
by (simp add: subset_insertI)

text\<open>Spy sees what is sent on the traffic\<close>
lemma Says_imp_knows_Spy [rule_format]:
     "Says A B X \<in> set evs \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Notes_imp_knows_Spy [rule_format]:
     "Notes A X \<in> set evs \<longrightarrow> A\<in> bad \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*Nothing can be stated on a Gets event*)

lemma Inputs_imp_knows_Spy_secureM [rule_format (no_asm)]:
     "Inputs Spy C X \<in> set evs \<longrightarrow> secureM \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Inputs_imp_knows_Spy_insecureM [rule_format (no_asm)]:
     "Inputs A C X \<in> set evs \<longrightarrow> insecureM \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*Nothing can be stated on a C_Gets event*)

lemma Outpts_imp_knows_Spy_secureM [rule_format (no_asm)]:
     "Outpts C Spy X \<in> set evs \<longrightarrow> secureM \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Outpts_imp_knows_Spy_insecureM [rule_format (no_asm)]:
     "Outpts C A X \<in> set evs \<longrightarrow> insecureM \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*Nothing can be stated on an A_Gets event*)

text\<open>Elimination rules: derive contradictions from old Says events containing
  items known to be fresh\<close>
lemmas knows_Spy_partsEs =
     Says_imp_knows_Spy [THEN parts.Inj, elim_format]
     parts.Body [elim_format]

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

lemma knows_Inputs: "knows A (Inputs A C X # evs) = insert X (knows A evs)"
by simp

lemma knows_C_Gets: "knows A (C_Gets C X # evs) = knows A evs"
by simp

lemma knows_Outpts_secureM:
      "secureM \<longrightarrow> knows A (Outpts C A X # evs) = insert X (knows A evs)"
by simp

lemma knows_Outpts_insecureM:
      "insecureM \<longrightarrow> knows Spy (Outpts C A X # evs) = insert X (knows Spy evs)"
by simp
(*somewhat equivalent to knows_Spy_Outpts_insecureM*)

lemma knows_subset_knows_Says: "knows A evs \<subseteq> knows A (Says A' B X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Notes: "knows A evs \<subseteq> knows A (Notes A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Gets: "knows A evs \<subseteq> knows A (Gets A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Inputs: "knows A evs \<subseteq> knows A (Inputs A' C X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_C_Gets: "knows A evs \<subseteq> knows A (C_Gets C X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Outpts: "knows A evs \<subseteq> knows A (Outpts C A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_A_Gets: "knows A evs \<subseteq> knows A (A_Gets A' X # evs)"
by (simp add: subset_insertI)

text\<open>Agents know what they say\<close>
lemma Says_imp_knows [rule_format]: "Says A B X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

text\<open>Agents know what they note\<close>
lemma Notes_imp_knows [rule_format]: "Notes A X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

text\<open>Agents know what they receive\<close>
lemma Gets_imp_knows_agents [rule_format]:
     "A \<noteq> Spy \<longrightarrow> Gets A X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*Agents know what they input to their smart card*)
lemma Inputs_imp_knows_agents [rule_format (no_asm)]:
     "Inputs A (Card A) X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

(*Nothing to prove about C_Gets*)

(*Agents know what they obtain as output of their smart card,
  if the means is secure...*)
lemma Outpts_imp_knows_agents_secureM [rule_format (no_asm)]:
     "secureM \<longrightarrow> Outpts (Card A) A X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*otherwise only the spy knows the outputs*)
lemma Outpts_imp_knows_agents_insecureM [rule_format (no_asm)]:
      "insecureM \<longrightarrow> Outpts (Card A) A X \<in> set evs \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*end lemmas about agents' knowledge*)

lemma parts_knows_Spy_subset_used: "parts (knows Spy evs) \<subseteq> used evs"
apply (induct_tac "evs", force)
apply (simp add: parts_insert_knows_A add: event.split, blast)
done

lemmas usedI = parts_knows_Spy_subset_used [THEN subsetD, intro]

lemma initState_into_used: "X \<in> parts (initState B) \<Longrightarrow> X \<in> used evs"
apply (induct_tac "evs")
apply (simp_all add: parts_insert_knows_A split: event.split, blast)
done

simps_of_case used_Cons_simps[simp]: used_Cons

lemma used_nil_subset: "used [] \<subseteq> used evs"
apply simp
apply (blast intro: initState_into_used)
done

(*Novel lemmas*)
lemma Says_parts_used [rule_format (no_asm)]:
     "Says A B X \<in> set evs \<longrightarrow> (parts  {X}) \<subseteq> used evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

lemma Notes_parts_used [rule_format (no_asm)]:
     "Notes A X \<in> set evs \<longrightarrow> (parts  {X}) \<subseteq> used evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

lemma Outpts_parts_used [rule_format (no_asm)]:
     "Outpts C A X \<in> set evs \<longrightarrow> (parts  {X}) \<subseteq> used evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

lemma Inputs_parts_used [rule_format (no_asm)]:
     "Inputs A C X \<in> set evs \<longrightarrow> (parts  {X}) \<subseteq> used evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
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]

lemma knows_subset_knows_Cons: "knows A evs \<subseteq> knows A (e # evs)"
by (cases e, auto simp: knows_Cons)

lemma initState_subset_knows: "initState A \<subseteq> knows A evs"
apply (induct_tac evs, simp)
apply (blast intro: knows_subset_knows_Cons [THEN subsetD])
done

text\<open>For proving \<open>new_keys_not_used\<close>\<close>
lemma keysFor_parts_insert:
     "\<lbrakk> K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) \<rbrakk>
      \<Longrightarrow> K \<in> keysFor (parts (G \<union> H)) \<or> Key (invKey K) \<in> parts H"
by (force
    dest!: parts_insert_subset_Un [THEN keysFor_mono, THEN [2] rev_subsetD]
           analz_subset_parts [THEN keysFor_mono, THEN [2] rev_subsetD]
    intro: analz_subset_parts [THEN subsetD] parts_mono [THEN [2] rev_subsetD])

end


theory Small_Examples
imports Iptables_Semantics.Code_Interface
begin

section\<open>Small Examples\<close>
context
begin
  lemma "let fw = [''FORWARD'' \<mapsto> [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,0)) 8))) (Call ''foo'')],
                   ''foo'' \<mapsto> [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,128,0,0)) 9))) action.Return,
                               Rule (Match (Prot (Proto TCP))) action.Accept]
                   ] in
    let simplfw = to_simple_firewall
      (upper_closure (optimize_matches abstract_for_simple_firewall
        (upper_closure (packet_assume_new (unfold_ruleset_FORWARD action.Drop fw)))))
    in map simple_rule_ipv4_toString simplfw =
    [''ACCEPT     tcp  --  10.0.0.0/9            0.0.0.0/0    '',
     ''DROP     all  --  0.0.0.0/0            0.0.0.0/0    '']" by eval

  private definition "cool_example \<equiv> (let fw =
                [''FORWARD'' \<mapsto> [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,0)) 8))) (Call ''foo'')],
                 ''foo'' \<mapsto> [Rule (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,0)) 9)))) action.Drop,
                             Rule (Match (Prot (Proto TCP))) action.Accept]
                 ] in
    to_simple_firewall (upper_closure (optimize_matches abstract_for_simple_firewall
                          (upper_closure (packet_assume_new (unfold_ruleset_FORWARD action.Drop fw))))))"
  lemma " map simple_rule_ipv4_toString cool_example =
    [''DROP     all  --  10.128.0.0/9            0.0.0.0/0    '',
     ''ACCEPT     tcp  --  10.0.0.0/8            0.0.0.0/0    '',
     ''DROP     all  --  0.0.0.0/0            0.0.0.0/0    '']"
  by eval

  lemma "map ipv4addr_wordinterval_toString (getParts cool_example) =
    [''{10.128.0.0 .. 10.255.255.255}'',
     ''{10.0.0.0 .. 10.127.255.255}'',
     ''{0.0.0.0 .. 9.255.255.255} u {11.0.0.0 .. 255.255.255.255}'']" by eval

  lemma "map ipv4addr_wordinterval_toString (build_ip_partition parts_connection_ssh cool_example) =
    [''{0.0.0.0 .. 9.255.255.255} u {10.128.0.0 .. 255.255.255.255}'',
     ''{10.0.0.0 .. 10.127.255.255}'']" by eval

  (*it is not minimal if we allow to further compress the node definitions?
  the receiver nodes could be combined to UNIV
  But minimal for a symmetric matrix*)
  lemma "access_matrix_pretty_ipv4 parts_connection_ssh cool_example =
    ([(''0.0.0.0'', ''{0.0.0.0 .. 9.255.255.255} u {10.128.0.0 .. 255.255.255.255}''),
      (''10.0.0.0'', ''{10.0.0.0 .. 10.127.255.255}'')],
     [(''10.0.0.0'', ''0.0.0.0''),
      (''10.0.0.0'', ''10.0.0.0'')])" by eval
end
context
begin
  (*now with a destination IP*)
  private definition "cool_example2 \<equiv> (let fw =
    [''FORWARD'' \<mapsto> [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,0)) 8))) (Call ''foo'')],
     ''foo'' \<mapsto> [Rule (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,0)) 9)))) action.Drop,
                 Rule (MatchAnd (Match (Prot (Proto TCP))) (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,42)) 32)))) action.Accept]
                ] in
    to_simple_firewall (upper_closure (optimize_matches abstract_for_simple_firewall
                          (upper_closure (packet_assume_new (unfold_ruleset_FORWARD action.Drop fw))))))"
  lemma "map simple_rule_ipv4_toString cool_example2 =
    [''DROP     all  --  10.128.0.0/9            0.0.0.0/0    '',
     ''ACCEPT     tcp  --  10.0.0.0/8            10.0.0.42/32    '',
     ''DROP     all  --  0.0.0.0/0            0.0.0.0/0    '']" by eval

  (*not minimal*)
  lemma "map ipv4addr_wordinterval_toString (getParts cool_example2) =
    [''{10.128.0.0 .. 10.255.255.255}'', ''10.0.0.42'',
     ''{10.0.0.0 .. 10.0.0.41} u {10.0.0.43 .. 10.127.255.255}'',
     ''{0.0.0.0 .. 9.255.255.255} u {11.0.0.0 .. 255.255.255.255}'']" by eval

  lemma "map ipv4addr_wordinterval_toString (build_ip_partition parts_connection_ssh cool_example2) =
    [''{0.0.0.0 .. 9.255.255.255} u {10.128.0.0 .. 255.255.255.255}'', ''10.0.0.42'',
     ''{10.0.0.0 .. 10.0.0.41} u {10.0.0.43 .. 10.127.255.255}'']" by eval

  lemma "access_matrix_pretty_ipv4 parts_connection_ssh cool_example2 =
    ([(''0.0.0.0'', ''{0.0.0.0 .. 9.255.255.255} u {10.128.0.0 .. 255.255.255.255}''),
      (''10.0.0.42'', ''10.0.0.42''),
      (''10.0.0.0'', ''{10.0.0.0 .. 10.0.0.41} u {10.0.0.43 .. 10.127.255.255}'')
     ],
     [(''10.0.0.42'', ''10.0.0.42''),
      (''10.0.0.0'', ''10.0.0.42'')
     ])" by eval
  end

end


(*  Title:      HOL/Quotient_Examples/Int_Pow.thy
    Author:     Ondrej Kuncar
    Author:     Lars Noschinski
*)

theory Int_Pow
imports MainRLT "HOL-Algebra.Group"
begin

(*
  This file demonstrates how to restore Lifting/Transfer enviromenent.

  We want to define int_pow (a power with an integer exponent) by directly accessing
  the representation type "nat * nat" that was used to define integers.
*)

context monoid
begin

(* first some additional lemmas that are missing in monoid *)

lemma Units_nat_pow_Units [intro, simp]:
  "a \<in> Units G \<Longrightarrow> a [^] (c :: nat) \<in> Units G" by (induct c) auto

lemma Units_r_cancel [simp]:
  "[| z \<in> Units G; x \<in> carrier G; y \<in> carrier G |] ==>
   (x \<otimes> z = y \<otimes> z) = (x = y)"
proof
  assume eq: "x \<otimes> z = y \<otimes> z"
    and G: "z \<in> Units G"  "x \<in> carrier G"  "y \<in> carrier G"
  then have "x \<otimes> (z \<otimes> inv z) = y \<otimes> (z \<otimes> inv z)"
    by (simp add: m_assoc[symmetric] Units_closed del: Units_r_inv)
  with G show "x = y" by simp
next
  assume eq: "x = y"
    and G: "z \<in> Units G"  "x \<in> carrier G"  "y \<in> carrier G"
  then show "x \<otimes> z = y \<otimes> z" by simp
qed

lemma inv_mult_units:
  "[| x \<in> Units G; y \<in> Units G |] ==> inv (x \<otimes> y) = inv y \<otimes> inv x"
proof -
  assume G: "x \<in> Units G"  "y \<in> Units G"
  then have "x \<in> carrier G"  "y \<in> carrier G" by auto
  with G have "inv (x \<otimes> y) \<otimes> (x \<otimes> y) = (inv y \<otimes> inv x) \<otimes> (x \<otimes> y)"
    by (simp add: m_assoc) (simp add: m_assoc [symmetric])
  with G show ?thesis by (simp del: Units_l_inv)
qed

lemma mult_same_comm:
  assumes [simp, intro]: "a \<in> Units G"
  shows "a [^] (m::nat) \<otimes> inv (a [^] (n::nat)) = inv (a [^] n) \<otimes> a [^] m"
proof (cases "m\<ge>n")
  have [simp]: "a \<in> carrier G" using \<open>a \<in> _\<close> by (rule Units_closed)
  case True
    then obtain k where *:"m = k + n" and **:"m = n + k" by (metis le_iff_add add.commute)
    have "a [^] (m::nat) \<otimes> inv (a [^] (n::nat)) = a [^] k"
      using * by (auto simp add: nat_pow_mult[symmetric] m_assoc)
    also have "\<dots> = inv (a [^] n) \<otimes> a [^] m"
      using ** by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric])
    finally show ?thesis .
next
  have [simp]: "a \<in> carrier G" using \<open>a \<in> _\<close> by (rule Units_closed)
  case False
    then obtain k where *:"n = k + m" and **:"n = m + k"
      by (metis le_iff_add add.commute nat_le_linear)
    have "a [^] (m::nat) \<otimes> inv (a [^] (n::nat)) = inv(a [^] k)"
      using * by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric] inv_mult_units)
    also have "\<dots> = inv (a [^] n) \<otimes> a [^] m"
      using ** by (auto simp add: nat_pow_mult[symmetric] m_assoc inv_mult_units)
    finally show ?thesis .
qed

lemma mult_inv_same_comm:
  "a \<in> Units G \<Longrightarrow> inv (a [^] (m::nat)) \<otimes> inv (a [^] (n::nat)) = inv (a [^] n) \<otimes> inv (a [^] m)"
by (simp add: inv_mult_units[symmetric] nat_pow_mult ac_simps Units_closed)

context
includes int.lifting (* restores Lifting/Transfer for integers *)
begin

lemma int_pow_rsp:
  assumes eq: "(b::nat) + e = d + c"
  assumes a_in_G [simp, intro]: "a \<in> Units G"
  shows "a [^] b \<otimes> inv (a [^] c) = a [^] d \<otimes> inv (a [^] e)"
proof(cases "b\<ge>c")
  have [simp]: "a \<in> carrier G" using \<open>a \<in> _\<close> by (rule Units_closed)
  case True
    then obtain n where "b = n + c" by (metis le_iff_add add.commute)
    then have "d = n + e" using eq by arith
    from \<open>b = _\<close> have "a [^] b \<otimes> inv (a [^] c) = a [^] n"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc)
    also from \<open>d = _\<close>  have "\<dots> = a [^] d \<otimes> inv (a [^] e)"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc)
    finally show ?thesis .
next
  have [simp]: "a \<in> carrier G" using \<open>a \<in> _\<close> by (rule Units_closed)
  case False
    then obtain n where "c = n + b" by (metis le_iff_add add.commute nat_le_linear)
    then have "e = n + d" using eq by arith
    from \<open>c = _\<close> have "a [^] b \<otimes> inv (a [^] c) = inv (a [^] n)"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric] inv_mult_units)
    also from \<open>e = _\<close> have "\<dots> = a [^] d \<otimes> inv (a [^] e)"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric] inv_mult_units)
    finally show ?thesis .
qed

(*
  This definition is more convinient than the definition in HOL/Algebra/Group because
  it doesn't contain a test z < 0 when a [^] z is being defined.
*)

lift_definition int_pow :: "('a, 'm) monoid_scheme \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow> 'a" is
  "\<lambda>G a (n1, n2). if a \<in> Units G \<and> monoid G then (a [^]\<^bsub>G\<^esub> n1) \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> (a [^]\<^bsub>G\<^esub> n2)) else \<one>\<^bsub>G\<^esub>"
unfolding intrel_def by (auto intro: monoid.int_pow_rsp)

(*
  Thus, for example, the proof of distributivity of int_pow and addition
  doesn't require a substantial number of case distinctions.
*)

lemma int_pow_dist:
  assumes [simp]: "a \<in> Units G"
  shows "int_pow G a ((n::int) + m) = int_pow G a n \<otimes>\<^bsub>G\<^esub> int_pow G a m"
proof -
  {
    fix k l m :: nat
    have "a [^] l \<otimes> (inv (a [^] m) \<otimes> inv (a [^] k)) = (a [^] l \<otimes> inv (a [^] k)) \<otimes> inv (a [^] m)"
      (is "?lhs = _")
      by (simp add: mult_inv_same_comm m_assoc Units_closed)
    also have "\<dots> = (inv (a [^] k) \<otimes> a [^] l) \<otimes> inv (a [^] m)"
      by (simp add: mult_same_comm)
    also have "\<dots> = inv (a [^] k) \<otimes> (a [^] l \<otimes> inv (a [^] m))" (is "_ = ?rhs")
      by (simp add: m_assoc Units_closed)
    finally have "?lhs = ?rhs" .
  }
  then show ?thesis
    by (transfer fixing: G) (auto simp add: nat_pow_mult[symmetric] inv_mult_units m_assoc Units_closed)
qed

end

lifting_update int.lifting
lifting_forget int.lifting

end

end


theory Distributed_WebApp
imports "../TopoS_Impl"
begin

section{*Distributed Web Application Example*}

text{*
    The symbolic policy names are of type @{typ string}, e.g. @{term "''WebFrnt''"}
*}

text{*We start with the empty policy, only the entities are defined.*}
definition policy :: "string list_graph" where
    "policy \<equiv> \<lparr> nodesL = [''WebFrnt'', ''DB'', ''Log'', ''WebApp'', ''INET''],
                edgesL = [] \<rparr>"

text{*Sanity check*}
lemma "wf_list_graph policy" by eval
(*proof by eval means we have executable code to show the lemma. No need to show anything by hand*)

text{*Defining the security invariants*}
definition LogSink_m::"(string SecurityInvariant)" where
  "LogSink_m \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_Sink \<lparr>
          node_properties = [''Log'' \<mapsto> Sink]
          \<rparr> ''No information must leave the logging server''"

text{*
0 - unclassified
1 - confidential
*}
--"trusted: can access any security level, privacy-level 0: can reveal to anyone. I.e. can declassify"
definition BLP_m::"(string SecurityInvariant)" where
    "BLP_m \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_BLPtrusted \<lparr>
          node_properties = [''DB'' \<mapsto> \<lparr> security_level = 1, trusted = False \<rparr>,
                             ''Log'' \<mapsto> \<lparr> security_level = 1, trusted = False \<rparr>,
                             ''WebApp'' \<mapsto> \<lparr> security_level = 0, trusted = True \<rparr>
                             ]
          \<rparr> ''The database and the logging server have confidential information''"

definition Subnet_m::"(string SecurityInvariant)" where
    "Subnet_m \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_SubnetsInGW \<lparr>
          node_properties = [''DB'' \<mapsto> Member,
                             ''Log'' \<mapsto> Member,
                             ''WebApp'' \<mapsto> Member,
                             ''WebFrnt'' \<mapsto> InboundGateway (*DMZ*)
                             ]
          \<rparr> ''internal/DMZ structure''"

definition DBACL_m::"(string SecurityInvariant)" where
    "DBACL_m \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_CommunicationPartners \<lparr>
          node_properties = [''DB'' \<mapsto> Master [''WebApp''],
                             ''WebApp'' \<mapsto> Care
                             ]
          \<rparr> ''ACL of db''"

text{*The list of security invariants*}
definition "security_invariants = [Subnet_m, BLP_m, LogSink_m, DBACL_m]"

text{*All security invariants are fulfilled (obviously, the policy permits no flows).*}
lemma "all_security_requirements_fulfilled security_invariants policy" by eval

text{*Obviously, no policy rules violate the security invariants.*}
lemma "implc_get_offending_flows security_invariants policy = []" by eval

text{*We generate the maximum security policy.*}
definition "max_policy = generate_valid_topology security_invariants \<lparr>nodesL = nodesL policy, edgesL = List.product (nodesL policy) (nodesL policy) \<rparr>"

text{*Calculating the maximum policy (executing it).*}
value "max_policy"
lemma "max_policy =
   \<lparr>nodesL = [''WebFrnt'', ''DB'', ''Log'', ''WebApp'', ''INET''],
    edgesL = [(''WebFrnt'', ''WebFrnt''), (''WebFrnt'', ''Log''), (''WebFrnt'', ''WebApp''), (''WebFrnt'', ''INET''), (''DB'', ''DB''),
              (''DB'', ''Log''), (''DB'', ''WebApp''), (''Log'', ''Log''), (''WebApp'', ''WebFrnt''), (''WebApp'', ''DB''),
              (''WebApp'', ''Log''), (''WebApp'', ''WebApp''), (''WebApp'', ''INET''), (''INET'', ''WebFrnt''), (''INET'', ''INET'')]\<rparr>"
by eval (*proof by eval means it can be directly executed*)

text{*
Visualizing the maximum policy
*}
ML{*
visualize_graph @{context} @{term "security_invariants"} @{term "max_policy"};
*}

text{*The maximum policy also fulfills all security invariants. *}
lemma "all_security_requirements_fulfilled security_invariants max_policy" by eval
text{*This holds in general: @{thm generate_valid_topology_sound}.*}

text{*fine-tuning generated policy.*}
definition "my_policy = \<lparr>nodesL = [''WebFrnt'', ''DB'', ''Log'', ''WebApp'', ''INET''],
    edgesL = [(''WebFrnt'', ''WebFrnt''), (''WebFrnt'', ''Log''), (''WebFrnt'', ''WebApp''), (''DB'', ''DB''), (''DB'', ''Log''),
              (''DB'', ''WebApp''), (''Log'', ''Log''), (''WebApp'', ''WebFrnt''), (''WebApp'', ''DB''), (''WebApp'', ''Log''), (''WebApp'', ''WebApp''),
              (''WebApp'', ''INET''), (''INET'', ''WebFrnt''), (''INET'', ''INET'')]\<rparr>"
lemma "all_security_requirements_fulfilled security_invariants my_policy" by eval
lemma "set (edgesL my_policy) \<subset> set (edgesL max_policy)" by eval

text{*
The diff to the maximum policy.
*}
ML_val{*
visualize_edges @{context} @{term "edgesL my_policy"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#3399FF\", constraint=false]", @{term "[e \<leftarrow> edgesL max_policy. e \<notin> set (edgesL my_policy)]"})] "";
*}

section{*A stateful implementation*}
definition "stateful_policy = generate_valid_stateful_policy_IFSACS my_policy security_invariants"
value "stateful_policy"

text{*the stateful compliance criteria*}

text{*No information flow violations*}
  lemma "all_security_requirements_fulfilled (get_IFS security_invariants) (stateful_list_policy_to_list_graph stateful_policy)" by eval

  text{*No access control side effects*}
  lemma "\<forall> F \<in> set (implc_get_offending_flows (get_ACS security_invariants) (stateful_list_policy_to_list_graph stateful_policy)).
            set F \<subseteq> set (backlinks (flows_stateL stateful_policy)) - (set (flows_fixL stateful_policy))" by eval

  text{*In general, the calculated stateful policy complies with the security policy: @{thm generate_valid_stateful_policy_IFSACS_stateful_policy_compliance}*}

text{*Visualizing the stateful policy.*}
ML_val{*
visualize_edges @{context} @{term "flows_fixL stateful_policy"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "flows_stateL stateful_policy"})] "";
*}

subsection{*Exporting to Network Security Mechanism Configurations*}

text{*Space-separated policy dump*}
ML_val{*
iterate_edges_ML @{context} @{term "flows_fixL stateful_policy"}
  (fn (v1,v2) => writeln (""^v1^" "^v2) )
  (fn _ => () )
  (fn _ => () );

writeln "# stateful answers";
iterate_edges_ML @{context} @{term "flows_stateL stateful_policy"}
  (fn (v1,v2) => writeln (v2^" "^v1) )
  (fn _ => () )
  (fn _ => () )
*}

text{*firewall -- classical use case*}
ML_val{*

(*header*)
writeln ("echo 1 > /proc/sys/net/ipv4/ip_forward"^"\n"^
         "# flush all rules"^"\n"^
         "iptables -F"^"\n"^
         "#default policy for FORWARD chain:"^"\n"^
         "iptables -P FORWARD DROP");

iterate_edges_ML @{context}  @{term "flows_fixL stateful_policy"}
  (fn (v1,v2) => writeln ("iptables -A FORWARD -i $"^v1^"_iface -s $"^v1^"_ipv4 -o $"^v2^"_iface -d $"^v2^"_ipv4 -j ACCEPT"^" # "^v1^" -> "^v2) )
  (fn _ => () )
  (fn _ => () );

iterate_edges_ML @{context} @{term "flows_stateL stateful_policy"}
  (fn (v1,v2) => writeln ("iptables -I FORWARD -m state --state ESTABLISHED -i $"^v2^"_iface -s $"^v2^"_ipv4 -o $"^v1^"_iface -d $"^v1^"_ipv4 -j ACCEPT # "^v2^" -> "^v1^" (answer)") )
  (fn _ => () )
  (fn _ => () )
*}

text{*firewall -- OpenVPN scenario*}
ML_val{*

(*header*)
writeln ("echo 1 > /proc/sys/net/ipv4/ip_forward"^"\n"^
         "# flush all rules"^"\n"^
         "iptables -F"^"\n"^
         "#default policy for FORWARD chain:"^"\n"^
         "iptables -P FORWARD DROP");

fun iface (s: string): string =
  if s = "INET" then "eth0" else "tun0";

iterate_edges_ML @{context} @{term "[(s,r) \<leftarrow> flows_fixL stateful_policy. s \<noteq> r]"}
  (fn (v1,v2) => writeln ("iptables -A FORWARD -i "^iface v1^" -s $"^v1^"_ipv4 -o "^iface v2^" -d $"^v2^"_ipv4 -j ACCEPT") )
  (fn _ => () )
  (fn _ => () );

iterate_edges_ML @{context} @{term "flows_stateL stateful_policy"}
  (fn (v1,v2) => writeln ("iptables -I FORWARD -m state --state ESTABLISHED -i "^iface v2^" -s $"^v2^"_ipv4 -o "^iface v1^" -d $"^v1^"_ipv4 -j ACCEPT") )
  (fn _ => () )
  (fn _ => () )
*}

lemma "set (flows_stateL stateful_policy) \<subseteq> set (flows_fixL stateful_policy)" by eval

definition stateful_flows :: "(string \<times> string) list" where
  "stateful_flows \<equiv> [(src, dst) \<leftarrow> flows_stateL stateful_policy. src \<noteq> dst]"
value "stateful_flows"

definition stateless_flows :: "(string \<times> string) list" where
  "stateless_flows \<equiv> [(src, dst) \<leftarrow> flows_fixL stateful_policy. src \<noteq> dst \<and> (src, dst) \<notin> set stateful_flows]"
value "stateless_flows"

text{*OpenFlow Flow table Rules*}
ML_val{*
fun ARP (src: string) (dst: string): string =
  "# ARP Request\n"^
  "in_port=${port_"^src^"} dl_src=${mac_"^src^"} dl_dst=ff:ff:ff:ff:ff:ff arp arp_sha=${mac_"^src^"} "^
  "arp_spa=${ip4_"^src^"} arp_tpa=${ip4_"^dst^"} priority=40000 action=mod_dl_dst:${mac_"^dst^"},output:${port_"^dst^"}"^"\n"^
  "# ARP Reply\n"^
  "dl_src=${mac_"^dst^"} dl_dst=${mac_"^src^"} arp arp_sha=${mac_"^dst^"} "^
  "arp_spa=${ip4_"^dst^"} arp_tpa=${ip4_"^src^"} priority=40000 action=output:${port_"^src^"}";

local
  fun IPv4_helper (priority: int) (nw_src_wildcard: bool) (nw_dst_wildcard: bool) (src: string) (dst: string): string =
    let
      val nw_src = (if nw_src_wildcard then "*" else "${ip4_"^src^"}");
      val nw_dst = (if nw_dst_wildcard then "*" else "${ip4_"^dst^"}");
    in
      "in_port=${port_"^src^"} dl_src=${mac_"^src^"} ip nw_src="^nw_src^" "^
      "nw_dst="^nw_dst^" priority="^(Int.toString priority)^" action=mod_dl_dst:${mac_"^dst^"},output:${port_"^dst^"}"
    end;
in
  fun IPv4 (src: string) (dst: string): string =
    if dst = "INET" then
      IPv4_helper 30000 false true src dst
    else if src = "INET" then
      IPv4_helper 30000 true false src dst
    else
      IPv4_helper 40000 false false src dst
      ;
end;

iterate_edges_ML @{context} @{term "stateful_flows"}
  (fn (v1,v2) => writeln ((ARP v1 v2) ^ "\n" ^ (ARP v2 v1) ^ "\n" ^ (IPv4 v1 v2) ^ "\n" ^ (IPv4 v2 v1) ^"\n"))
  (fn _ => () )
  (fn _ => () );

iterate_edges_ML @{context} @{term "stateless_flows"}
  (fn (v1,v2) =>  writeln ((ARP v1 v2) ^ "\n" ^ (IPv4 v1 v2) ^ "\n"))
  (fn _ => () )
  (fn _ => () )
*}

text{*Finally, all the functions demonstrated here can be exported to several programming languages
     to obtain a stand-alone tool.*}
export_code
  security_invariants
  policy
  all_security_requirements_fulfilled
  implc_get_offending_flows
  max_policy
  my_policy
  generate_valid_stateful_policy_IFSACS
  stateful_policy
  stateful_flows
  stateless_flows
in Scala

(*dockermynet4*)

definition dockermynet4policy :: "string list_graph" where
    "dockermynet4policy \<equiv> \<lparr> nodesL = [''WebFrnt'', ''DB'', ''Log'', ''WebApp'', ''INET''],
                edgesL = [(''INET'',''INET''),
                          (''INET'',''WebFrnt''),
                          (''WebApp'',''INET''),
                          (''WebApp'',''WebApp''),
                          (''WebApp'',''DB''),
                          (''WebApp'',''Log''),
                          (''WebApp'',''WebFrnt''),
                          (''DB'',''WebApp''),
                          (''DB'',''DB''),
                          (''DB'',''Log''),
                          (''Log'',''Log''),
                          (''Log'',''WebFrnt''),
                          (''WebFrnt'',''WebApp''),
                          (''WebFrnt'',''Log''),
                          (''WebFrnt'',''WebFrnt'')] \<rparr>"

lemma "wf_list_graph dockermynet4policy" by eval

ML{*
visualize_graph @{context} @{term "security_invariants"} @{term "dockermynet4policy"};
*}

ML_val{*
writeln ("*filter"^"\n"^
         ":INPUT ACCEPT [0:0]"^"\n"^
         ":FORWARD DROP [0:0]"^"\n"^
         ":OUTPUT ACCEPT [0:0]"^"\n");

fun mkiface s = if s = "INET" then "INET_iface" else "br-b74b417b331f";

iterate_edges_ML @{context}  @{term "flows_fixL (generate_valid_stateful_policy_IFSACS max_policy security_invariants)"}
  (fn (v1,v2) => writeln ("-A FORWARD -i "^mkiface v1^" -s $"^v1^"_ipv4 -o "^mkiface v2^" -d $"^v2^"_ipv4 -j ACCEPT") )
  (fn _ => () )
  (fn _ => () );

iterate_edges_ML @{context} @{term "flows_stateL (generate_valid_stateful_policy_IFSACS max_policy security_invariants)"}
  (fn (v1,v2) => writeln ("-I FORWARD -m state --state ESTABLISHED -i "^mkiface v2^" -s $"^v2^"_ipv4 -o "^mkiface v1^" -d $"^v1^"_ipv4 -j ACCEPT") )
  (fn _ => () )
  (fn _ => () );

writeln ("COMMIT"^"\n");
*}

ML_val{*
visualize_edges @{context} @{term "flows_fixL (generate_valid_stateful_policy_IFSACS max_policy security_invariants)"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "flows_stateL (generate_valid_stateful_policy_IFSACS max_policy security_invariants)"})] "";
*}

(*dfwfw (docker firewall) rules: https://github.com/irsl/dfwfw*)

ML_val{*
writeln ("{"^"\n"^
         "\"container_to_container\": {"^"\n"^
         "\"rules\": ["^"\n"^
         "\n");

fun mkdfwfwrule filter v1 v2 = "{"^"\n"^
             "  \"network\": \"mynet\","^"\n"^
             "  \"src_container\": \"Name =~ ^"^ String.map Char.toLower v1 ^"-?\\\\d*$\","^"\n"^
             "  \"dst_container\": \"Name =~ ^"^ String.map Char.toLower v2 ^"-?\\\\d*$\","^"\n"^
             "  \"filter\": \""^filter^"\","^"\n"^
             "  \"action\": \"ACCEPT\""^"\n"^
          "},";

iterate_edges_ML @{context}  @{term "flows_fixL (generate_valid_stateful_policy_IFSACS max_policy security_invariants)"}
  (fn (v1,v2) => writeln (mkdfwfwrule "" v1 v2) )
  (fn _ => () )
  (fn _ => () );

iterate_edges_ML @{context} @{term "flows_stateL (generate_valid_stateful_policy_IFSACS max_policy security_invariants)"}
  (fn (v1,v2) => writeln (mkdfwfwrule "-m state --state ESTABLISHED" v2 v1))
  (fn _ => () )
  (fn _ => () );

writeln ("]}}"^"\n");
*}

end


section\<open>Routing Table\<close>
theory Routing_Table
imports "../IP_Addresses/Prefix_Match"
        "../IP_Addresses/IPv4" "../IP_Addresses/IPv6"
        "Linorder_Helper"
        "../IP_Addresses/Prefix_Match_toString"
begin

text\<open>This section makes the necessary definitions to work with a routing table using longest prefix matching.\<close>
subsection\<open>Definition\<close>

record(overloaded) 'i routing_action =
  output_iface :: string
  next_hop :: "'i word option" (* no next hop iff locally attached *)

(* Routing rule matching ip route unicast type *)
record(overloaded) 'i routing_rule =
  routing_match :: "('i::len) prefix_match" (* done on the dst *)
  metric :: nat
  routing_action :: "'i routing_action"

text\<open>This definition is engineered to model routing tables on packet forwarding devices.
It eludes, e.g., the source address hint, which is only relevant for packets originating from the device itself.\<close>
(* See also: http://linux-ip.net/html/routing-saddr-selection.html *)

context
begin

definition "default_metric = 0"

type_synonym 'i prefix_routing = "('i routing_rule) list"

abbreviation "routing_oiface a \<equiv> output_iface (routing_action a)" (* I needed this a lot... *)
abbreviation "routing_prefix r \<equiv> pfxm_length (routing_match r)"

definition valid_prefixes where
  "valid_prefixes r = foldr conj (map (\<lambda>rr. valid_prefix (routing_match rr)) r) True"
lemma valid_prefixes_split: "valid_prefixes (r#rs) \<Longrightarrow> valid_prefix (routing_match r) \<and> valid_prefixes rs"
  using valid_prefixes_def by force

lemma foldr_True_set: "foldr (\<lambda>x. op \<and> (f x)) l True = (\<forall>x \<in> set l. f x)"
  by (induction l) simp_all
lemma valid_prefixes_alt_def: "valid_prefixes r = (\<forall>e \<in> set r. valid_prefix (routing_match e))"
  unfolding valid_prefixes_def
  unfolding foldr_map
  unfolding comp_def
  unfolding foldr_True_set
  ..

fun has_default_route :: "('i::len) prefix_routing \<Rightarrow> bool" where
"has_default_route (r#rs) = (((pfxm_length (routing_match r)) = 0) \<or> has_default_route rs)" |
"has_default_route Nil = False"

lemma has_default_route_alt: "has_default_route rt \<longleftrightarrow> (\<exists>r \<in> set rt. pfxm_length (routing_match r) = 0)" by(induction rt) simp_all

subsection\<open>Single Packet Semantics\<close>

fun routing_table_semantics :: "('i::len) prefix_routing \<Rightarrow> 'i word \<Rightarrow> 'i routing_action" where
"routing_table_semantics [] _ = routing_action (undefined::'i routing_rule)" |
"routing_table_semantics (r#rs) p = (if prefix_match_semantics (routing_match r) p then routing_action r else routing_table_semantics rs p)"
lemma routing_table_semantics_ports_from_table: "valid_prefixes rtbl \<Longrightarrow> has_default_route rtbl \<Longrightarrow>
  routing_table_semantics rtbl packet = r \<Longrightarrow> r \<in> routing_action ` set rtbl"
proof(induction rtbl)
  case (Cons r rs)
  note v_pfxs = valid_prefixes_split[OF Cons.prems(1)]
  show ?case
  proof(cases "pfxm_length (routing_match r) = 0")
    case True
    note zero_prefix_match_all[OF conjunct1[OF v_pfxs] True] Cons.prems(3)
    then show ?thesis by simp
  next
    case False
    hence "has_default_route rs" using Cons.prems(2) by simp
    from Cons.IH[OF conjunct2[OF v_pfxs] this] Cons.prems(3) show ?thesis by force
  qed
qed simp

subsection\<open>Longest Prefix Match\<close>

text\<open>We can abuse @{const LinordHelper} to sort.\<close>
definition "routing_rule_sort_key \<equiv> \<lambda>r. LinordHelper (0 - (of_nat :: nat \<Rightarrow> int) (pfxm_length (routing_match r))) (metric r)"
text\<open>There is actually a slight design choice here. We can choose to sort based on @{thm less_eq_prefix_match_def} (thus including the address) or only the prefix length (excluding it).
  Which is taken does not matter gravely, since the bits of the prefix can't matter. They're either eqal or the rules don't overlap and the metric decides. (It does matter for the resulting list though.)
  Ignoring the prefix and taking only its length is slightly easier.\<close>

(*example: get longest prefix match by sorting by pfxm_length*)
definition "rr_ctor m l a nh me \<equiv> \<lparr> routing_match = PrefixMatch (ipv4addr_of_dotdecimal m) l, metric = me, routing_action =\<lparr>output_iface = a, next_hop = (map_option ipv4addr_of_dotdecimal nh)\<rparr> \<rparr>"
value "sort_key routing_rule_sort_key [
  rr_ctor (0,0,0,1) 3 '''' None 0,
  rr_ctor (0,0,0,2) 8 [] None 0,
  rr_ctor (0,0,0,3) 4 [] None 13,
  rr_ctor (0,0,0,3) 4 [] None 42]"

definition "is_longest_prefix_routing \<equiv> sorted \<circ> map routing_rule_sort_key"

definition correct_routing :: "('i::len) prefix_routing \<Rightarrow> bool" where
  "correct_routing r \<equiv> is_longest_prefix_routing r \<and> valid_prefixes r"
text\<open>Many proofs and functions around routing require at least parts of @{const correct_routing} as an assumption.
Obviously, @{const correct_routing} is not given for arbitrary routing tables. Therefore,
@{const correct_routing} is made to be executable and should be checked for any routing table after parsing.
Note: @{const correct_routing} used to also require @{const has_default_route},
but none of the proofs require it anymore and it is not given for any routing table.\<close>

lemma is_longest_prefix_routing_rule_exclusion:
  assumes "is_longest_prefix_routing (r1 # rn # rss)"
  shows "is_longest_prefix_routing (r1 # rss)"
using assms by(case_tac rss) (auto simp add: is_longest_prefix_routing_def)

lemma is_longest_prefix_routing_sorted_by_length:
  assumes "is_longest_prefix_routing r"
     and "r = r1 # rs @ r2 # rss"
  shows "(pfxm_length (routing_match r1) \<ge> pfxm_length (routing_match r2))"
using assms
proof(induction rs arbitrary: r)
  case (Cons rn rs)
  let ?ro = "r1 # rs @ r2 # rss"
  have "is_longest_prefix_routing ?ro" using Cons.prems is_longest_prefix_routing_rule_exclusion[of r1 rn "rs @ r2 # rss"] by simp
  from Cons.IH[OF this] show ?case by simp
next
  case Nil thus ?case by(auto simp add: is_longest_prefix_routing_def routing_rule_sort_key_def linord_helper_less_eq1_def less_eq_linord_helper_def int_of_nat_def)
qed

definition "sort_rtbl :: ('i::len) routing_rule list \<Rightarrow> 'i routing_rule list \<equiv> sort_key routing_rule_sort_key"

lemma is_longest_prefix_routing_sort: "is_longest_prefix_routing (sort_rtbl r)" unfolding sort_rtbl_def is_longest_prefix_routing_def by simp

definition "unambiguous_routing rtbl \<equiv> (\<forall>rt1 rt2 rr ra. rtbl = rt1 @ rr # rt2 \<longrightarrow> ra \<in> set (rt1 @ rt2) \<longrightarrow> routing_match rr = routing_match ra \<longrightarrow> routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra)"
lemma unambiguous_routing_Cons: "unambiguous_routing (r # rtbl) \<Longrightarrow> unambiguous_routing rtbl"
  unfolding unambiguous_routing_def by(clarsimp) (metis append_Cons in_set_conv_decomp)
lemma "unambiguous_routing (rr # rtbl) \<Longrightarrow> is_longest_prefix_routing (rr # rtbl) \<Longrightarrow> ra \<in> set rtbl \<Longrightarrow> routing_match rr = routing_match ra \<Longrightarrow> routing_rule_sort_key rr < routing_rule_sort_key ra"
  unfolding is_longest_prefix_routing_def unambiguous_routing_def by(fastforce simp add: sorted_Cons)
primrec unambiguous_routing_code where
"unambiguous_routing_code [] = True" |
"unambiguous_routing_code (rr#rtbl) = (list_all (\<lambda>ra. routing_match rr \<noteq> routing_match ra \<or> routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra) rtbl \<and> unambiguous_routing_code rtbl)"
lemma unambiguous_routing_code[code_unfold]: "unambiguous_routing rtbl \<longleftrightarrow> unambiguous_routing_code rtbl"
proof(induction rtbl)
  case (Cons rr rtbl) show ?case (is "?l \<longleftrightarrow> ?r") proof
    assume l: ?l
    with unambiguous_routing_Cons Cons.IH have "unambiguous_routing_code rtbl" by blast
    moreover have "list_all (\<lambda>ra. routing_match rr \<noteq> routing_match ra \<or> routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra) rtbl"
      using l unfolding unambiguous_routing_def by(fastforce simp add: list_all_iff)
    ultimately show ?r by simp
  next
    assume r: ?r
    with Cons.IH have "unambiguous_routing rtbl" by simp
    from r have *: "list_all (\<lambda>ra. routing_match rr \<noteq> routing_match ra \<or>  routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra) rtbl" by simp
    have False if "rr # rtbl = rt1 @ rra # rt2" "ra \<in> set (rt1 @ rt2)" "routing_rule_sort_key rra = routing_rule_sort_key ra \<and> routing_match rra = routing_match ra" for rt1 rt2 rra ra
    proof(cases "rt1 = []")
      case True thus ?thesis using that * by(fastforce simp add: list_all_iff)
    next
      case False
      with that(1) have rtbl: "rtbl = tl rt1 @ rra # rt2" by (metis list.sel(3) tl_append2)
      show ?thesis proof(cases "ra = hd rt1") (* meh case split\<dots> *)
        case False hence "ra \<in> set (tl rt1 @ rt2)" using that by(cases rt1; simp)
        with \<open>unambiguous_routing rtbl\<close> show ?thesis  using that(3) rtbl unfolding unambiguous_routing_def by fast
      next
        case True hence "rr = ra" using that \<open>rt1 \<noteq> []\<close> by(cases rt1; simp)
        thus ?thesis using that * unfolding rtbl by(fastforce simp add: list_all_iff)
      qed
    qed
    thus ?l unfolding unambiguous_routing_def by blast
  qed
qed(simp add: unambiguous_routing_def)

lemma unambigous_prefix_routing_weak_mono:
  assumes lpfx: "is_longest_prefix_routing (rr#rtbl)"
  assumes e:"rr' \<in> set rtbl"
  shows "routing_rule_sort_key rr' \<ge> routing_rule_sort_key rr"
using assms  by(simp add: linorder_class.sorted_Cons is_longest_prefix_routing_def)
lemma unambigous_prefix_routing_strong_mono:
  assumes lpfx: "is_longest_prefix_routing (rr#rtbl)"
  assumes uam: "unambiguous_routing (rr#rtbl)"
  assumes e:"rr' \<in> set rtbl"
  assumes ne: "routing_match rr' = routing_match rr"
  shows "routing_rule_sort_key rr' > routing_rule_sort_key rr"
proof -
  from uam e ne have "routing_rule_sort_key rr \<noteq> routing_rule_sort_key rr'" by(fastforce simp add: unambiguous_routing_def)
  moreover from unambigous_prefix_routing_weak_mono lpfx e have "routing_rule_sort_key rr \<le> routing_rule_sort_key rr'" .
  ultimately show ?thesis by simp
qed

lemma "routing_rule_sort_key (rr_ctor (0,0,0,0) 8 [] None 0) > routing_rule_sort_key (rr_ctor (0,0,0,0) 24 [] None 0)" by eval
(* get the inequality right\<dots> bigger means lower priority *)
text\<open>In case you don't like that formulation of @{const is_longest_prefix_routing} over sorting, this is your lemma.\<close>
theorem existential_routing: "valid_prefixes rtbl \<Longrightarrow> is_longest_prefix_routing rtbl \<Longrightarrow> has_default_route rtbl \<Longrightarrow> unambiguous_routing rtbl \<Longrightarrow>
routing_table_semantics rtbl addr = act \<longleftrightarrow> (\<exists>rr \<in> set rtbl. prefix_match_semantics (routing_match rr) addr \<and> routing_action rr = act \<and>
  (\<forall>ra \<in> set rtbl. routing_rule_sort_key ra < routing_rule_sort_key rr \<longrightarrow> \<not>prefix_match_semantics (routing_match ra) addr))"
proof(induction rtbl)
  case Nil thus ?case by simp
next
  case (Cons rr rtbl)
  show ?case proof(cases "prefix_match_semantics (routing_match rr) addr")
    case False
    hence [simp]: "routing_table_semantics (rr # rtbl) addr = routing_table_semantics (rr # rtbl) addr" by simp
    show ?thesis proof(cases "routing_prefix rr = 0")
      case True text\<open>Need special treatment, rtbl won't have a default route, so the IH is not usable.\<close>
      have "valid_prefix (routing_match rr)" using Cons.prems valid_prefixes_split by blast
      with True False have False using zero_prefix_match_all by blast
      thus ?thesis ..
    next
      case False
      with Cons.prems have mprems: "valid_prefixes rtbl" "is_longest_prefix_routing rtbl" "has_default_route rtbl" "unambiguous_routing rtbl"
        by(simp_all add: valid_prefixes_split unambiguous_routing_Cons is_longest_prefix_routing_def sorted_Cons)
      show ?thesis using Cons.IH[OF mprems] False \<open>\<not> prefix_match_semantics (routing_match rr) addr\<close> by simp
    qed
  next
    case True
    from True have [simp]: "routing_table_semantics (rr # rtbl) addr = routing_action rr" by simp
    show ?thesis (is "?l \<longleftrightarrow> ?r") proof
      assume ?l
      hence [simp]: "act = routing_action rr" by(simp add: True)
      have *: "(\<forall>ra\<in>set (rr # rtbl). routing_rule_sort_key rr \<le> routing_rule_sort_key ra)"
        using \<open>is_longest_prefix_routing (rr # rtbl)\<close>  by(clarsimp simp: is_longest_prefix_routing_def sorted_Cons)
      thus ?r by(fastforce simp add: True)
    next
      assume ?r
      then guess rr' .. note rr' = this
      have "rr' = rr" proof(rule ccontr)
        assume C: "rr' \<noteq> rr"
        from C have e: "rr' \<in> set rtbl" using rr' by simp
        show False proof cases
          assume eq: "routing_match rr' = routing_match rr"
          with e have "routing_rule_sort_key rr < routing_rule_sort_key rr'" using unambigous_prefix_routing_strong_mono[OF Cons.prems(2,4) _ eq] by simp
          with True rr' show False by simp
        next
          assume ne: "routing_match rr' \<noteq> routing_match rr"
          from rr' Cons.prems have "valid_prefix (routing_match rr)" "valid_prefix (routing_match rr')" "prefix_match_semantics (routing_match rr') addr" by(auto simp add: valid_prefixes_alt_def)
          note same_length_prefixes_distinct[OF this(1,2) ne[symmetric] _ True this(3)]
          moreover have "routing_prefix rr = routing_prefix rr'" (is ?pe) proof -
            have "routing_rule_sort_key rr < routing_rule_sort_key rr' \<longrightarrow> \<not> prefix_match_semantics (routing_match rr) addr" using rr' by simp
            with unambigous_prefix_routing_weak_mono[OF Cons.prems(2) e] True have "routing_rule_sort_key rr = routing_rule_sort_key rr'" by simp
            thus ?pe by(simp add: routing_rule_sort_key_def int_of_nat_def)
          qed
          ultimately show False .
        qed
      qed
      thus ?l using rr' by simp
    qed
  qed
qed

subsection\<open>Printing\<close>

definition "routing_rule_32_toString (rr::32 routing_rule) \<equiv>
  prefix_match_32_toString (routing_match rr)
@ (case next_hop (routing_action rr) of Some nh \<Rightarrow> '' via '' @ ipv4addr_toString nh | _ \<Rightarrow> [])
@ '' dev '' @ routing_oiface rr
@ '' metric '' @ string_of_nat (metric rr)"

definition "routing_rule_128_toString (rr::128 routing_rule) \<equiv>
  prefix_match_128_toString (routing_match rr)
@ (case next_hop (routing_action rr) of Some nh \<Rightarrow> '' via '' @ ipv6addr_toString nh | _ \<Rightarrow> [])
@ '' dev '' @ routing_oiface rr
@ '' metric '' @ string_of_nat (metric rr)"

lemma "map routing_rule_32_toString
[rr_ctor (42,0,0,0) 7 ''eth0'' None 808,
 rr_ctor (0,0,0,0) 0 ''eth1'' (Some (222,173,190,239)) 707] =
[''42.0.0.0/7 dev eth0 metric 808'',
 ''0.0.0.0/0 via 222.173.190.239 dev eth1 metric 707'']" by eval

section\<open>Routing table to Relation\<close>

text\<open>Walking through a routing table splits the (remaining) IP space when traversing a routing table into a pair of sets:
 the pair contains the IPs concerned by the current rule and those left alone.\<close>
private definition ipset_prefix_match where
  "ipset_prefix_match pfx rg = (let pfxrg = prefix_to_wordset pfx in (rg \<inter> pfxrg, rg - pfxrg))"
private lemma ipset_prefix_match_m[simp]:  "fst (ipset_prefix_match pfx rg) = rg \<inter> (prefix_to_wordset pfx)" by(simp only: Let_def ipset_prefix_match_def, simp)
private lemma ipset_prefix_match_nm[simp]: "snd (ipset_prefix_match pfx rg) = rg - (prefix_to_wordset pfx)" by(simp only: Let_def ipset_prefix_match_def, simp)
private lemma ipset_prefix_match_distinct: "rpm = ipset_prefix_match pfx rg \<Longrightarrow>
  (fst rpm) \<inter> (snd rpm) = {}" by force
private lemma ipset_prefix_match_complete: "rpm = ipset_prefix_match pfx rg \<Longrightarrow>
  (fst rpm) \<union> (snd rpm) = rg" by force
private

subsection\<open>Wordintervals for Ports by Routing\<close>
text\<open>This split, although rather trivial,
can be used to construct the sets (or rather: the intervals)
of IPs that are actually matched by an entry in a routing table.\<close>

private fun routing_port_ranges :: "'i prefix_routing \<Rightarrow> 'i wordinterval \<Rightarrow> (string \<times> ('i::len) wordinterval) list" where
"routing_port_ranges [] lo = (if wordinterval_empty lo then [] else [(routing_oiface (undefined::'i routing_rule),lo)])" | (* insert default route to nirvana. has to match what routing_table_semantics does. *)
"routing_port_ranges (a#as) lo = (
	let rpm = range_prefix_match (routing_match a) lo; m = fst rpm; nm = snd rpm in (
	(routing_oiface a,m) # routing_port_ranges as nm))"

private lemma routing_port_ranges_subsets:
"(a1, b1) \<in> set (routing_port_ranges tbl s) \<Longrightarrow> wordinterval_to_set b1 \<subseteq> wordinterval_to_set s"
  by(induction tbl arbitrary: s; fastforce simp add: Let_def split: if_splits)

private lemma routing_port_ranges_sound: "e \<in> set (routing_port_ranges tbl s) \<Longrightarrow> k \<in> wordinterval_to_set (snd e) \<Longrightarrow> valid_prefixes tbl \<Longrightarrow>
	fst e = output_iface (routing_table_semantics tbl k)"
proof(induction tbl arbitrary: s)
	case (Cons a as)
	note s = Cons.prems(1)[unfolded routing_port_ranges.simps Let_def list.set]
	note vpfx = valid_prefixes_split[OF Cons.prems(3)]
	show ?case (is ?kees) proof(cases "e = (routing_oiface a, fst (range_prefix_match (routing_match a) s))")
		case False
		hence es: "e \<in> set (routing_port_ranges as (snd (range_prefix_match (routing_match a) s)))" using s by blast
		note eq = Cons.IH[OF this Cons.prems(2) conjunct2[OF vpfx]]
		have "\<not>prefix_match_semantics (routing_match a) k" (is ?nom)
		proof -
		  from routing_port_ranges_subsets[of "fst e" "snd e", unfolded prod.collapse, OF es]
		  have *: "wordinterval_to_set (snd e) \<subseteq> wordinterval_to_set (snd (range_prefix_match (routing_match a) s))" .
			show ?nom unfolding prefix_match_semantics_wordset[OF conjunct1[OF vpfx]]
			  using * Cons.prems(2)	unfolding wordinterval_subset_set_eq
				by(auto simp add: range_prefix_match_def Let_def)
		qed
		thus ?kees using eq by simp
	next
		case True
		hence fe: "fst e = routing_oiface a" by simp
		from True have "k \<in> wordinterval_to_set (fst (range_prefix_match (routing_match a) s))"
			using Cons.prems(2) by(simp)
		hence "prefix_match_semantics (routing_match a) k"
			unfolding prefix_match_semantics_wordset[OF conjunct1, OF vpfx]
			unfolding range_prefix_match_def Let_def
			by simp
		thus ?kees by(simp add: fe)
	qed
qed (simp split: if_splits)

private lemma routing_port_ranges_disjoined:
assumes vpfx: "valid_prefixes tbl"
  and ins:  "(a1, b1) \<in> set (routing_port_ranges tbl s)" "(a2, b2) \<in> set (routing_port_ranges tbl s)"
  and nemp: "wordinterval_to_set b1 \<noteq> {}"
shows "b1 \<noteq> b2 \<longleftrightarrow> wordinterval_to_set b1 \<inter> wordinterval_to_set b2 = {}"
using assms
proof(induction tbl arbitrary: s)
  case (Cons r rs)
  have vpfx: "valid_prefix (routing_match r)" "valid_prefixes rs" using Cons.prems(1) using valid_prefixes_split by blast+
  { (* In case that one of b1 b2 stems from r and one does not, we assume it is b1 WLOG. *)
    fix a1 b1 a2 b2
    assume one: "b1 = fst (range_prefix_match (routing_match r) s)"
    assume two: "(a2, b2) \<in> set (routing_port_ranges rs (snd (range_prefix_match (routing_match r) s)))"
    have dc: "wordinterval_to_set (snd (range_prefix_match (routing_match r) s)) \<inter>
          wordinterval_to_set (fst (range_prefix_match (routing_match r) s)) = {}" by force
    hence "wordinterval_to_set b1 \<inter> wordinterval_to_set b2 = {}"
    unfolding one using two[THEN routing_port_ranges_subsets] by fast
  } note * = this
  show ?case
  using \<open>(a1, b1) \<in> set (routing_port_ranges (r # rs) s)\<close> \<open>(a2, b2) \<in> set (routing_port_ranges (r # rs) s)\<close> nemp
    Cons.IH[OF vpfx(2)] *
    by(fastforce simp add: Let_def)
qed (simp split: if_splits)

private lemma routing_port_rangesI:
"valid_prefixes tbl \<Longrightarrow>
 output_iface (routing_table_semantics tbl k) = output_port \<Longrightarrow>
 k \<in> wordinterval_to_set wi \<Longrightarrow>
 (\<exists>ip_range. (output_port, ip_range) \<in> set (routing_port_ranges tbl wi) \<and> k \<in> wordinterval_to_set ip_range)"
proof(induction tbl arbitrary: wi)
  case Nil thus ?case by simp blast
next
  case (Cons r rs)
  from Cons.prems(1) have vpfx: "valid_prefix (routing_match r)" and vpfxs: "valid_prefixes rs"
    by(simp_all add: valid_prefixes_split)
  show ?case
  proof(cases "prefix_match_semantics (routing_match r) k")
    case True
    thus ?thesis
      using Cons.prems(2) using vpfx \<open>k \<in> wordinterval_to_set wi\<close>
      by (intro exI[where x =  "fst (range_prefix_match (routing_match r) wi)"])
         (simp add: prefix_match_semantics_wordset Let_def)
  next
    case False
    with \<open>k \<in> wordinterval_to_set wi\<close> have ksnd: "k \<in> wordinterval_to_set (snd (range_prefix_match (routing_match r) wi))"
      by (simp add: prefix_match_semantics_wordset vpfx)
    have mpr: "output_iface (routing_table_semantics rs k) = output_port" using Cons.prems False by simp
    note Cons.IH[OF vpfxs mpr ksnd]
    thus ?thesis by(fastforce simp: Let_def)
  qed
qed

subsection\<open>Reduction\<close>
text\<open>So far, one entry in the list would be generated for each routing table entry.
This next step reduces it to one for each port.
The resulting list will represent a function from port to IP wordinterval.
(It can also be understood as a function from IP (interval) to port (where the intervals don't overlap).\<close>

definition "reduce_range_destination l \<equiv>
let ps = remdups (map fst l) in
let c = \<lambda>s. (wordinterval_Union \<circ> map snd \<circ> filter ((op = s) \<circ> fst)) l in
[(p, c p). p \<leftarrow> ps]
"

definition "routing_ipassmt_wi tbl \<equiv> reduce_range_destination (routing_port_ranges tbl wordinterval_UNIV)"

lemma routing_ipassmt_wi_distinct: "distinct (map fst (routing_ipassmt_wi tbl))"
  unfolding routing_ipassmt_wi_def reduce_range_destination_def
  by(simp add: comp_def)

private lemma routing_port_ranges_superseted:
"(a1,b1) \<in> set (routing_port_ranges tbl wordinterval_UNIV) \<Longrightarrow>
  \<exists>b2. (a1,b2) \<in> set (routing_ipassmt_wi tbl) \<and> wordinterval_to_set b1 \<subseteq> wordinterval_to_set b2"
  unfolding routing_ipassmt_wi_def reduce_range_destination_def
  by(force simp add: Set.image_iff wordinterval_Union)

private lemma routing_ipassmt_wi_subsetted:
"(a1,b1) \<in> set (routing_ipassmt_wi tbl) \<Longrightarrow>
 (a1,b2) \<in> set (routing_port_ranges tbl wordinterval_UNIV) \<Longrightarrow>  wordinterval_to_set b2 \<subseteq> wordinterval_to_set b1"
  unfolding routing_ipassmt_wi_def reduce_range_destination_def
  by(fastforce simp add: Set.image_iff wordinterval_Union comp_def)

text\<open>This lemma should hold without the @{const valid_prefixes} assumption, but that would break the semantic argument and make the proof a lot harder.\<close>
lemma routing_ipassmt_wi_disjoint:
assumes vpfx: "valid_prefixes (tbl::('i::len) prefix_routing)"
  and dif: "a1 \<noteq> a2"
  and ins:  "(a1, b1) \<in> set (routing_ipassmt_wi tbl)" "(a2, b2) \<in> set (routing_ipassmt_wi tbl)"
shows "wordinterval_to_set b1 \<inter> wordinterval_to_set b2 = {}"
proof(rule ccontr)
  note iuf = ins[unfolded routing_ipassmt_wi_def reduce_range_destination_def Let_def, simplified, unfolded Set.image_iff comp_def, simplified]
  assume "(wordinterval_to_set b1 \<inter> wordinterval_to_set b2 \<noteq> {})"
  hence "wordinterval_to_set b1 \<inter> wordinterval_to_set b2 \<noteq> {}" by simp
  text\<open>If the intervals are not disjoint, there exists a witness of that.\<close>
  then obtain x where x[simp]: "x \<in> wordinterval_to_set b1" "x \<in> wordinterval_to_set b2" by blast
  text\<open>This witness has to have come from some entry in the result of @{const routing_port_ranges}, for both of @{term b1} and @{term b2}.\<close>
  hence "\<exists>b1g. x \<in> wordinterval_to_set b1g \<and> wordinterval_to_set b1g \<subseteq> wordinterval_to_set b1 \<and> (a1, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)"
    using iuf(1) by(fastforce simp add: wordinterval_Union) (* strangely, this doesn't work with obtain *)
  then obtain b1g where b1g: "x \<in> wordinterval_to_set b1g" "wordinterval_to_set b1g \<subseteq> wordinterval_to_set b1" "(a1, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)" by clarsimp
  from x have "\<exists>b2g. x \<in> wordinterval_to_set b2g \<and> wordinterval_to_set b2g \<subseteq> wordinterval_to_set b2 \<and> (a2, b2g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)"
    using iuf(2) by(fastforce simp add: wordinterval_Union)
  then obtain b2g where b2g: "x \<in> wordinterval_to_set b2g" "wordinterval_to_set b2g \<subseteq> wordinterval_to_set b2" "(a2, b2g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)" by clarsimp
  text\<open>Soudness tells us that the both @{term a1} and @{term a2} have to be the result of routing @{term x}.\<close>
  note routing_port_ranges_sound[OF b1g(3), unfolded fst_conv snd_conv, OF b1g(1) vpfx] routing_port_ranges_sound[OF b2g(3), unfolded fst_conv snd_conv, OF b2g(1) vpfx]
  text\<open>A contradiction follows from @{thm dif}.\<close>
  with dif show False by simp
qed

lemma routing_ipassmt_wi_sound:
  assumes vpfx: "valid_prefixes tbl"
  and ins: "(ea,eb) \<in> set (routing_ipassmt_wi tbl)"
  and x: "k \<in> wordinterval_to_set eb"
  shows "ea = output_iface (routing_table_semantics tbl k)"
proof -
  note iuf = ins[unfolded routing_ipassmt_wi_def reduce_range_destination_def Let_def, simplified, unfolded Set.image_iff comp_def, simplified]
  from x have "\<exists>b1g. k \<in> wordinterval_to_set b1g \<and> wordinterval_to_set b1g \<subseteq> wordinterval_to_set eb \<and> (ea, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)"
    using iuf(1) by(fastforce simp add: wordinterval_Union)
  then obtain b1g where b1g: "k \<in> wordinterval_to_set b1g" "wordinterval_to_set b1g \<subseteq> wordinterval_to_set eb" "(ea, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)" by clarsimp
  note routing_port_ranges_sound[OF b1g(3), unfolded fst_conv snd_conv, OF b1g(1) vpfx]
  thus ?thesis .
qed

theorem routing_ipassmt_wi:
assumes vpfx: "valid_prefixes tbl"
  shows
  "output_iface (routing_table_semantics tbl k) = output_port \<longleftrightarrow>
    (\<exists>ip_range. k \<in> wordinterval_to_set ip_range \<and> (output_port, ip_range) \<in> set (routing_ipassmt_wi tbl))"
proof (intro iffI, goal_cases)
  case 2 with vpfx routing_ipassmt_wi_sound show ?case by blast
next
  case 1
  then obtain ip_range where "(output_port, ip_range) \<in> set (routing_port_ranges tbl wordinterval_UNIV) \<and> k \<in> wordinterval_to_set ip_range"
    using routing_port_rangesI[where wi = wordinterval_UNIV, OF vpfx] by auto
  thus ?case
    unfolding routing_ipassmt_wi_def reduce_range_destination_def
    unfolding Let_def comp_def
    by(force simp add: Set.image_iff wordinterval_Union)
qed

(* this was not given for the old reduced_range_destination *)
lemma routing_ipassmt_wi_has_all_interfaces:
  assumes in_tbl: "r \<in> set tbl"
  shows "\<exists>s. (routing_oiface r,s) \<in> set (routing_ipassmt_wi tbl)"
proof -
  from in_tbl have "\<exists>s. (routing_oiface r,s) \<in> set (routing_port_ranges tbl S)" for S
  proof(induction tbl arbitrary: S)
    case (Cons l ls)
    show ?case
    proof(cases "r = l")
      case True thus ?thesis using Cons.prems by(auto simp: Let_def)
    next
      case False with Cons.prems have "r \<in> set ls" by simp
      from Cons.IH[OF this] show ?thesis by(simp add: Let_def) blast
    qed
  qed simp
  thus ?thesis
    unfolding routing_ipassmt_wi_def reduce_range_destination_def
    by(force simp add: Set.image_iff)
qed

end

end


section \<open>Vardi Systems\<close>

(*<*)
theory Vardi
imports
  Probabilistic_Hierarchy
begin
(*>*)

context notes [[bnf_internals]]
begin
  datatype ('a, 'b, 'k) var0 = PMF "('a \<times> 'b) pmf" | BPS "('a \<times> 'b) set['k]"
end

inductive var_eq :: "('a, 'b, 'k) var0 \<Rightarrow> ('a, 'b, 'k) var0 \<Rightarrow> bool" (infixl "\<sim>" 65) where
  var_eq_reflp[intro]: "x \<sim> x"
| [intro]: "PMF (return_pmf (a, x)) \<sim> BPS (bsingleton (a, x))"
| [intro]: "BPS (bsingleton (a, x)) \<sim> PMF (return_pmf (a, x))"

lemma var_eq_symp: "x \<sim> y \<Longrightarrow> y \<sim> x"
  by (auto elim: var_eq.cases)

lemma var_eq_transp: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"
  by (auto elim!: var_eq.cases)

quotient_type ('a, 'b, 'k) var = "('a, 'b, 'k) var0" / "(\<sim>)"
  by (auto intro: equivpI reflpI sympI transpI  var_eq_symp var_eq_transp)

lift_definition map_var  :: "('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a, 'b, 'k) var \<Rightarrow> ('c, 'd, 'k) var"
  is map_var0
  by (auto elim!: var_eq.cases simp: map_bset_bsingleton)

lift_definition set1_var  :: "('a, 'b, 'k) var \<Rightarrow> 'a set"
  is set1_var0
  by (auto elim!: var_eq.cases)

lift_definition set2_var  :: "('a, 'b, 'k) var \<Rightarrow> 'b set"
  is set2_var0
  by (auto elim!: var_eq.cases)

inductive rel_var :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a, 'b, 'k) var \<Rightarrow> ('c, 'd, 'k) var \<Rightarrow> bool" for R S where
  "set1_var x \<subseteq> {(x, y). R x y} \<Longrightarrow> set2_var x \<subseteq> {(x, y). S x y} \<Longrightarrow>
    rel_var R S (map_var fst fst x) (map_var snd snd x)"

abbreviation (input) "var0_of_gen_emb \<equiv> case_option (BPS bempty) PMF"
abbreviation (input) "var0_of_lts_emb \<equiv> BPS"

lift_definition var_of_gen_emb :: "('a \<times> 'b) pmf option \<Rightarrow> ('a, 'b, 'k) var" is var0_of_gen_emb .
lift_definition var_of_lts_emb :: "('a \<times> 'b) set['k] \<Rightarrow> ('a, 'b, 'k) var" is var0_of_lts_emb .

abbreviation "bisimilar_var \<equiv> bisimilar (\<lambda>R. rel_var (=) R)"

lemma map_var0_eq_BPS_iff[simp]:
  "map_var0 f g z = BPS X \<longleftrightarrow> (\<exists>Y. z = BPS Y \<and> map_bset (map_prod f g) Y = X)"
  by (cases z) auto

lemma map_var0_eq_PMF_iff[simp]:
  "map_var0 f g z = PMF p \<longleftrightarrow> (\<exists>q. z = PMF q \<and> map_pmf (map_prod f g) q = p)"
  by (cases z) auto

lemma "bisimilar_lts s1 s2 x y \<longleftrightarrow> bisimilar_var (var_of_lts_emb o s1) (var_of_lts_emb o s2) x y"
  (is "_ \<longleftrightarrow> bisimilar_var (?emb1 o _) (?emb2 o _) _ _")
unfolding bisimilar_def o_apply proof safe
  fix R assume "R x y" and
    bis: "\<forall>x y. R x y \<longrightarrow> rel_bset (rel_prod (=) R) (s1 x) (s2 y)"
  from \<open>R x y\<close> show "\<exists>R. R x y \<and> (\<forall>x y. R x y \<longrightarrow> rel_var (=) R (?emb1 (s1 x)) (?emb2 (s2 y)))"
  proof (intro exI[of _ R], safe)
    fix x y
    assume "R x y"
    with bis have *: "rel_bset (rel_prod (=) R) (s1 x) (s2 y)" by blast
    then obtain z where
      "set_bset z \<subseteq> {(x, y). rel_prod (=) R x y}" "map_bset fst z = s1 x" "map_bset snd z = s2 y"
      by (auto simp: bset.in_rel)
    then show "rel_var (=) R (?emb1 (s1 x)) (?emb2 (s2 y))"
      unfolding rel_var.simps by (transfer fixing: z)
        (force simp: bset.map_comp o_def split_beta prod_set_simps
        intro: exI[of _ "BPS (map_bset (\<lambda>((a,b),(c,d)). ((a,c),(b,d))) z)"])
  qed
next
  fix R assume "R x y" and
    bis: "\<forall>x y. R x y \<longrightarrow> rel_var (=) R (?emb1 (s1 x)) (?emb2 (s2 y))"
  from \<open>R x y\<close> show "\<exists>R. R x y \<and> (\<forall>x y. R x y \<longrightarrow> rel_bset (rel_prod (=) R) (s1 x) (s2 y))"
  proof (intro exI[of _ R], safe)
    fix x y
    assume "R x y"
    with bis have "rel_var (=) R (?emb1 (s1 x)) (?emb2 (s2 y))" by blast
    then obtain z where *:
      "set1_var z \<subseteq> {(x, y). x = y}" "set2_var z \<subseteq> {(x, y). R x y}"
      "?emb1 (s1 x) = map_var fst fst z" "?emb2 (s2 y) = map_var snd snd z"
      by (auto simp: rel_var.simps)
    then show "rel_bset (rel_prod (=) R) (s1 x) (s2 y)"
      by (transfer fixing: s1 s2) (fastforce simp: bset.in_rel bset.map_comp o_def map_pmf_eq_return_pmf_iff
        split_beta[abs_def] map_prod_def subset_eq split_beta prod_set_defs elim!: var_eq.cases
        intro: exI[of _ "map_bset (\<lambda>((a,b),(c,d)). ((a,c),(b,d))) z" for z]
          exI[of _ "bsingleton ((a,c),(b,d))" for a b c d])
  qed
qed

lemma "bisimilar_gen s1 s2 x y \<longleftrightarrow> bisimilar_var (var_of_gen_emb o s1) (var_of_gen_emb o s2) x y"
  (is "_ \<longleftrightarrow> bisimilar_var (?emb1 o _) (?emb2 o _) _ _")
unfolding bisimilar_def o_apply proof safe
  fix R assume "R x y" and
    bis: "\<forall>x y. R x y \<longrightarrow> rel_option (rel_pmf (rel_prod (=) R)) (s1 x) (s2 y)"
  from \<open>R x y\<close> show "\<exists>R. R x y \<and> (\<forall>x y. R x y \<longrightarrow> rel_var (=) R (?emb1 (s1 x)) (?emb2 (s2 y)))"
  proof (intro exI[of _ R], safe)
    fix x y
    assume "R x y"
    with bis have *: "rel_option (rel_pmf (rel_prod (=) R)) (s1 x) (s2 y)" by blast
    then show "rel_var (=) R (?emb1 (s1 x)) (?emb2 (s2 y))"
    proof (cases "s1 x" "s2 y" rule: option.exhaust[case_product option.exhaust])
      case None_None then show ?thesis unfolding rel_var.simps
        by (transfer fixing: s1 s2) (auto simp: bempty.rep_eq intro!: exI[of _ "BPS bempty"])
    next
      case (Some_Some p q)
      with * obtain z where
        "set_pmf z \<subseteq> {(x, y). rel_prod (=) R x y}" "map_pmf fst z = p" "map_pmf snd z = q"
        by (auto simp: pmf.in_rel)
      with Some_Some show ?thesis unfolding rel_var.simps
        by (transfer fixing: s1 s2 z) (force simp: pmf.map_comp o_def split_beta prod_set_simps
          intro: exI[of _ "PMF (map_pmf (\<lambda>((a,b),(c,d)). ((a,c),(b,d))) z)"])
    qed auto
  qed
next
  fix R assume "R x y" and
    bis: "\<forall>x y. R x y \<longrightarrow> rel_var (=) R (?emb1 (s1 x)) (?emb2 (s2 y))"
  from \<open>R x y\<close> show "\<exists>R. R x y \<and> (\<forall>x y. R x y \<longrightarrow>
     rel_option (rel_pmf (rel_prod (=) R)) (s1 x) (s2 y))"
  proof (intro exI[of _ R], safe)
    fix x y
    assume "R x y"
    with bis have "rel_var (=) R (?emb1 (s1 x)) (?emb2 (s2 y))" by blast
    then obtain z where *:
        "set1_var z \<subseteq> {(x, y). x = y}" "set2_var z \<subseteq> {(x, y). R x y}"
        "?emb1 (s1 x) = map_var fst fst z" "?emb2 (s2 y) = map_var snd snd z"
        by (auto simp: rel_var.simps)
    then show "rel_option (rel_pmf (rel_prod (=) R)) (s1 x) (s2 y)"
    proof (cases "s1 x" "s2 y" rule: option.exhaust[case_product option.exhaust])
      case Some_None
      with * show ?thesis by transfer (auto simp: bempty.rep_eq elim!: var_eq.cases)
    next
      case None_Some
      with * show ?thesis by transfer (auto elim!: var_eq.cases)
    next
      case (Some_Some p q)
      with * show ?thesis
        by transfer (fastforce simp: subset_eq split_beta prod_set_defs
          elim!: var_eq.cases intro!: rel_pmf_reflI)
    qed simp
  qed
qed

(*<*)
end
(*>*)