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
        "Pure-ex.Guess"
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. (\<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)
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: 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)
      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)
      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 (((=) 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


(*
 * 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 "../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 OR 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 "OR" 20)
where
  "f OR g \<equiv> \<lambda>s. (fst (f s) \<union> fst (g s), snd (f s) \<or> snd (g s))"

text \<open>Alternative notation for @{text OR}\<close>
notation (xsymbols)  alternative (infixl "\<sqinter>" 20)

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))"
  apply (simp add: gets_def return_def bind_def get_def)
  done

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')))"
  apply (rule eq_reflection)
  apply (auto simp add: bind_def split_def Let_def)
  done

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"
  apply (rule ext)
  apply (simp add: bind_def return_def split_def)
  done

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)"
  apply (unfold bind_def Let_def split_def)
  apply (rule ext)
  apply clarsimp
  apply (auto intro: rev_image_eqI)
  done

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
  "bindE f g \<equiv> bind 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"
  apply (unfold bindE_def returnOk_def)
  apply (clarsimp simp: lift_def)
  done

lemma lift_return [simp]:
  "lift (return \<circ> Inr) = return"
  by (rule ext)
     (simp add: 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)"
  apply (simp add: bindE_def bind_assoc)
  apply (rule arg_cong [where f="\<lambda>x. m >>= x"])
  apply (rule ext)
  apply (case_tac x, simp_all add: lift_def throwError_def)
  done

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_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 syntactically distinguish it in the syntax.
  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>
  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 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 "Hoare Logic"

subsection "Validity"

text \<open>This section defines a Hoare logic for partial correctness for
  the nondeterministic state monad as well as the exception monad.
  The logic talks only about the behaviour part of the monad and ignores
  the failure flag.

  The logic is defined semantically. Rules work directly on the
  validity predicate.

  In the nondeterministic state monad, validity is a triple of precondition,
  monad, and postcondition. The precondition is a function from state to
  bool (a state predicate), the postcondition is a function from return value
  to state to bool. A triple is valid if for all states that satisfy the
  precondition, all result values and result states that are returned by
  the monad satisfy the postcondition. Note that if the computation returns
  the empty set, the triple is trivially valid. This means @{term "assert P"}
  does not require us to prove that @{term P} holds, but rather allows us
  to assume @{term P}! Proving non-failure is done via separate predicate and
  calculus (see below).
\<close>
definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>")
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (\<forall>(r,s') \<in> fst (f s). Q r s')"

text \<open>
  We often reason about invariant predicates. The following provides shorthand syntax
  that avoids repeating potentially long predicates.
\<close>
abbreviation (input)
  invariant :: "('s,'a) nondet_monad \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool" ("_ \<lbrace>_\<rbrace>" [59,0] 60)
where
  "invariant f P \<equiv> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"

text \<open>
  Validity for the exception monad is similar and build on the standard
  validity above. Instead of one postcondition, we have two: one for
  normal and one for exceptional results.
\<close>
definition
  validE :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) nondet_monad \<Rightarrow>
             ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
("\<lbrace>_\<rbrace>/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>)")
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace> \<equiv> \<lbrace>P\<rbrace> f \<lbrace> \<lambda>v s. case v of Inr r \<Rightarrow> Q r s | Inl e \<Rightarrow> E e s \<rbrace>"

text \<open>
  The following two instantiations are convenient to separate reasoning
  for exceptional and normal case.
\<close>
definition
  validE_R :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'e + 'a) nondet_monad \<Rightarrow>
               ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
   ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>, -")
where
 "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,- \<equiv> validE P f Q (\<lambda>x y. True)"

definition
  validE_E :: "('s \<Rightarrow> bool) \<Rightarrow>  ('s, 'e + 'a) nondet_monad \<Rightarrow>
               ('e \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
   ("\<lbrace>_\<rbrace>/ _ /-, \<lbrace>_\<rbrace>")
where
 "\<lbrace>P\<rbrace> f -,\<lbrace>Q\<rbrace> \<equiv> validE P f (\<lambda>x y. True) Q"

text \<open>Abbreviations for trivial preconditions:\<close>
abbreviation(input)
  top :: "'a \<Rightarrow> bool" ("\<top>")
where
  "\<top> \<equiv> \<lambda>_. True"

abbreviation(input)
  bottom :: "'a \<Rightarrow> bool" ("\<bottom>")
where
  "\<bottom> \<equiv> \<lambda>_. False"

text \<open>Abbreviations for trivial postconditions (taking two arguments):\<close>
abbreviation(input)
  toptop :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<top>\<top>")
where
 "\<top>\<top> \<equiv> \<lambda>_ _. True"

abbreviation(input)
  botbot :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<bottom>\<bottom>")
where
 "\<bottom>\<bottom> \<equiv> \<lambda>_ _. False"

text \<open>
  Lifting @{text "\<and>"} and @{text "\<or>"} over two arguments.
  Lifting @{text "\<and>"} and @{text "\<or>"} over one argument is already
  defined (written @{text "and"} and @{text "or"}).
\<close>
definition
  bipred_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)"
  (infixl "And" 96)
where
  "bipred_conj P Q \<equiv> \<lambda>x y. P x y \<and> Q x y"

definition
  bipred_disj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)"
  (infixl "Or" 91)
where
  "bipred_disj P Q \<equiv> \<lambda>x y. P x y \<or> Q x y"

subsection "Determinism"

text \<open>A monad of type @{text nondet_monad} is deterministic iff it
returns exactly one state and result and does not fail\<close>
definition
  det :: "('a,'s) nondet_monad \<Rightarrow> bool"
where
  "det f \<equiv> \<forall>s. \<exists>r. f s = ({r},False)"

text \<open>A deterministic @{text nondet_monad} can be turned
  into a normal state monad:\<close>
definition
  the_run_state :: "('s,'a) nondet_monad \<Rightarrow> 's \<Rightarrow> 'a \<times> 's"
where
  "the_run_state M \<equiv> \<lambda>s. THE s'. fst (M s) = {s'}"

subsection "Non-Failure"

text \<open>
  With the failure flag, we can formulate non-failure separately
  from validity. A monad @{text m} does not fail under precondition
  @{text P}, if for no start state in that precondition it sets
  the failure flag.
\<close>
definition
  no_fail :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> bool"
where
  "no_fail P m \<equiv> \<forall>s. P s \<longrightarrow> \<not> (snd (m s))"

text \<open>
  It is often desired to prove non-failure and a Hoare triple
  simultaneously, as the reasoning is often similar. The following
  definitions allow such reasoning to take place.
\<close>

definition
  validNF ::"('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
      ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!")
where
  "validNF P f Q \<equiv> valid P f Q \<and> no_fail P f"

definition
  validE_NF :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) nondet_monad \<Rightarrow>
             ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>!)")
where
  "validE_NF P f Q E \<equiv> validE P f Q E \<and> no_fail P f"

lemma validE_NF_alt_def:
  "\<lbrace> P \<rbrace> B \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>! = \<lbrace> P \<rbrace> B \<lbrace> \<lambda>v s. case v of Inl e \<Rightarrow> E e s | Inr r \<Rightarrow> Q r s \<rbrace>!"
  by (clarsimp simp: validE_NF_def validE_def validNF_def)

text \<open>
  Usually, well-formed monads constructed from the primitives
  above will have the following property: if they return an
  empty set of results, they will have the failure flag set.
\<close>
definition
  empty_fail :: "('s,'a) nondet_monad \<Rightarrow> bool"
where
  "empty_fail m \<equiv> \<forall>s. fst (m s) = {} \<longrightarrow> snd (m s)"

text \<open>
  Useful in forcing otherwise unknown executions to have
  the @{const empty_fail} property.
\<close>
definition
  mk_ef :: "'a set \<times> bool \<Rightarrow> 'a set \<times> bool"
where
  "mk_ef S \<equiv> (fst S, fst S = {} \<or> snd S)"

section "Basic exception reasoning"

text \<open>
  The following predicates @{text no_throw} and @{text no_return} allow
  reasoning that functions in the exception monad either do
  no throw an exception or never return normally.
\<close>

definition "no_throw P A \<equiv> \<lbrace> P \<rbrace> A \<lbrace> \<lambda>_ _. True \<rbrace>,\<lbrace> \<lambda>_ _. False \<rbrace>"

definition "no_return P A \<equiv> \<lbrace> P \<rbrace> A \<lbrace>\<lambda>_ _. False\<rbrace>,\<lbrace>\<lambda>_ _. True \<rbrace>"

end


theory prop_44
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype ('a, 'b) Pair2 = Pair "'a" "'b"
  fun zip :: "'a list => 'b list => (('a, 'b) Pair2) list" where
  "zip (Nil2) y = Nil2"
  | "zip (Cons2 z x2) (Nil2) = Nil2"
  | "zip (Cons2 z x2) (Cons2 x3 x4) = Cons2 (Pair z x3) (zip x2 x4)"
  fun zipConcat :: "'a => 'a list => 'b list =>
                    (('a, 'b) Pair2) list" where
  "zipConcat x y (Nil2) = Nil2"
  | "zipConcat x y (Cons2 y2 ys) = Cons2 (Pair x y2) (zip y ys)"
  (*hipster zip zipConcat *)
  theorem x0 :
    "(zip (Cons2 x xs) ys) = (zipConcat x xs ys)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end