header {*\isaheader{Map Interface}*}
theory Intf_Map
imports "../../../Refine_Monadic/Refine_Monadic"
begin

consts i_map :: "interface \<Rightarrow> interface \<Rightarrow> interface"

definition [simp]: "op_map_empty \<equiv> Map.empty"
definition op_map_lookup :: "'k \<Rightarrow> ('k\<rightharpoonup>'v) \<rightharpoonup> 'v"
  where [simp]: "op_map_lookup k m \<equiv> m k"
definition [simp]: "op_map_update k v m \<equiv> m(k\<mapsto>v)"
definition [simp]: "op_map_delete k m \<equiv> m |` (-{k})"
definition [simp]: "op_map_restrict P m \<equiv> m |` {k\<in>dom m. P (k, the (m k))}"
definition [simp]: "op_map_isEmpty x \<equiv> x=Map.empty"
definition [simp]: "op_map_isSng x \<equiv> \<exists>k v. x=[k\<mapsto>v]"
definition [simp]: "op_map_ball m P \<equiv> Ball (map_to_set m) P"
definition [simp]: "op_map_bex m P \<equiv> Bex (map_to_set m) P"
definition [simp]: "op_map_size m \<equiv> card (dom m)"
definition [simp]: "op_map_size_abort n m \<equiv> min n (card (dom m))"
definition [simp]: "op_map_sel m P \<equiv> SPEC (\<lambda>(k,v). m k = Some v \<and> P k v)"
definition [simp]: "op_map_pick m \<equiv> SPEC (\<lambda>(k,v). m k = Some v)"

definition [simp]: "op_map_pick_remove m \<equiv>
  SPEC (\<lambda>((k,v),m'). m k = Some v \<and> m' = m |` (-{k}))"

context begin interpretation autoref_syn .

  "m=Map.empty \<equiv> op_map_isEmpty$m"
  "Map.empty=m \<equiv> op_map_isEmpty$m"
  "dom m = {} \<equiv> op_map_isEmpty$m"
  "{} = dom m \<equiv> op_map_isEmpty$m"

  "\<exists>k v. m=[k\<mapsto>v] \<equiv> op_map_isSng$m"
  "\<exists>k v. [k\<mapsto>v]=m \<equiv> op_map_isSng$m"
  "\<exists>k. dom m={k} \<equiv> op_map_isSng$m"
  "\<exists>k. {k} = dom m \<equiv> op_map_isSng$m"
  "1 = card (dom m) \<equiv> op_map_isSng$m"

  "\<And>P. Ball (map_to_set m) P \<equiv> op_map_ball$m$P"
  "\<And>P. Bex (map_to_set m) P \<equiv> op_map_bex$m$P"

  "card (dom m) \<equiv> op_map_size$m"

  "min n (card (dom m)) \<equiv> op_map_size_abort$n$m"
  "min (card (dom m)) n \<equiv> op_map_size_abort$n$m"

  "\<And>P. SPEC (\<lambda>(k,v). m k=Some v \<and> P k v) \<equiv> op_map_sel$m$P"
  "\<And>P. SPEC (\<lambda>(k,v). P k v \<and> m k=Some v) \<equiv> op_map_sel$m$P"

  "\<And>P. SPEC (\<lambda>(k,v). m k = Some v) \<equiv> op_map_pick$m"
  "\<And>P. SPEC (\<lambda>(k,v). (k,v) \<in> map_to_set m) \<equiv> op_map_pick$m"
  by (auto
    intro!: eq_reflection ext
    simp: restrict_map_def dom_eq_singleton_conv card_Suc_eq map_to_set_def
    dest!: sym[of "Suc 0" "card (dom m)"] sym[of _ "dom m"]
  )

  lemma [autoref_op_pat]:
    "SPEC (\<lambda>((k,v),m'). m k = Some v \<and> m' = m |` (-{k}))
      \<equiv> op_map_pick_remove$m"
    by simp

  lemma op_map_pick_remove_alt: "
    do {((k,v),m) \<leftarrow> op_map_pick_remove m; f k v m}
      = (
    do {
      (k,v)\<leftarrow>SPEC (\<lambda>(k,v). m k = Some v);
       let m=m |` (-{k});
       f k v m
    })"
    unfolding op_map_pick_remove_def
    apply (auto simp: pw_eq_iff refine_pw_simps)
    done

  lemma [autoref_op_pat]:
    "do {
      (k,v)\<leftarrow>SPEC (\<lambda>(k,v). m k = Some v);
       let m=m |` (-{k});
       f k v m
    } \<equiv> do {((k,v),m) \<leftarrow> op_map_pick_remove m; f k v m}"
    unfolding op_map_pick_remove_alt .

end

lemma [autoref_itype]:
  "op_map_empty ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_lookup ::\<^sub>i Ik \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Iv\<rangle>\<^sub>ii_option"
  "op_map_update ::\<^sub>i Ik \<rightarrow>\<^sub>i Iv \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_delete ::\<^sub>i Ik \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_restrict
    ::\<^sub>i (\<langle>Ik,Iv\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_isEmpty ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_bool"
  "op_map_isSng ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_bool"
  "op_map_ball ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i (\<langle>Ik,Iv\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "op_map_bex ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i (\<langle>Ik,Iv\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "op_map_size ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_nat"
  "op_map_size_abort ::\<^sub>i i_nat \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_nat"
  "op ++ ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "map_of ::\<^sub>i \<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"

  "op_map_sel ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i (Ik \<rightarrow>\<^sub>i Iv \<rightarrow>\<^sub>i i_bool)
    \<rightarrow>\<^sub>i \<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  "op_map_pick ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  "op_map_pick_remove
    ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod,\<langle>Ik,Iv\<rangle>\<^sub>ii_map\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  by simp_all

lemma hom_map1[autoref_hom]:
  "CONSTRAINT Map.empty (\<langle>Rk,Rv\<rangle>Rm)"
  "CONSTRAINT map_of (\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>Rk,Rv\<rangle>Rm)"
  "CONSTRAINT op ++ (\<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>Rk,Rv\<rangle>Rm)"
  by simp_all

term op_map_restrict

  "CONSTRAINT op_map_sel (\<langle>Rk,Rv\<rangle>Rm\<rightarrow>(Rk \<rightarrow> Rv \<rightarrow> bool_rel)\<rightarrow>\<langle>Rk\<times>\<^sub>rRv\<rangle>nres_rel)"
  "CONSTRAINT op_map_pick (\<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>Rk\<times>\<^sub>rRv\<rangle>nres_rel)"
  "CONSTRAINT op_map_pick_remove (\<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>(Rk\<times>\<^sub>rRv)\<times>\<^sub>r\<langle>Rk,Rv\<rangle>Rm\<rangle>nres_rel)"
  by simp_all

definition "finite_map_rel R \<equiv> Range R \<subseteq> Collect (finite \<circ> dom)"
lemma finite_map_rel_trigger: "finite_map_rel R \<Longrightarrow> finite_map_rel R" .

declaration {* Tagged_Solver.add_triggers
  "Relators.relator_props_solver" @{thms finite_map_rel_trigger} *}

end


theory Defs
  imports "HOL-IMP.BExp" "HOL-IMP.Star"
begin

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;;/ _"  [60, 61] 60)
      | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
(* begin mod *)
      | Loop  com bexp
(* end mod *)

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
(* begin mod *)
LoopFalse: "\<lbrakk> (c,s) \<Rightarrow> t; \<not>bval b t \<rbrakk> \<Longrightarrow> (Loop c b,s) \<Rightarrow> t" |
LoopTrue: "\<lbrakk> (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  bval b s\<^sub>2; (Loop c b, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
  \<Longrightarrow> (Loop c b, s\<^sub>1) \<Rightarrow> s\<^sub>3"
(* end mod *)

text\<open> Proof automation: \<close>

declare big_step.intros [intro]

lemmas big_step_induct = big_step.induct[split_format(complete)]

subsection "Rule inversion"

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
inductive_cases WhileE[elim]: "(Loop c b,s) \<Rightarrow> t"

subsection "List setup"

text \<open>
  In the following, we use the length of lists as integers
  instead of natural numbers. Instead of converting @{typ nat}
  to @{typ int} explicitly, we tell Isabelle to coerce @{typ nat}
  automatically when necessary.
\<close>
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

text \<open>
  Similarly, we will want to access the ith element of a list,
  where @{term i} is an @{typ int}.
\<close>
fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"

text \<open>
  The only additional lemma we need about this function
  is indexing over append:
\<close>
lemma inth_append [simp]:
  "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induction xs arbitrary: i) (auto simp: algebra_simps)

text\<open> We hide coercion @{const int} applied to @{const length}: \<close>

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

datatype instr =
  LOADI int | LOAD vname | ADD | STORE vname |
  JMP int | JMPLESS int | JMPGE int

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
"iexec instr (i,s,stk) = (case instr of
  LOADI n \<Rightarrow> (i+1,s, n#stk) |
  LOAD x \<Rightarrow> (i+1,s, s x # stk) |
  ADD \<Rightarrow> (i+1,s, (hd2 stk + hd stk) # tl2 stk) |
  STORE x \<Rightarrow> (i+1,s(x := hd stk),tl stk) |
  JMP n \<Rightarrow>  (i+1+n,s,stk) |
  JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i+1+n else i+1,s,tl2 stk) |
  JMPGE n \<Rightarrow> (if hd2 stk >= hd stk then i+1+n else i+1,s,tl2 stk))"

definition
  exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
     ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)
where
  "P \<turnstile> c \<rightarrow> c' =
  (\<exists>i s stk. c = (i,s,stk) \<and> c' = iexec(P!!i) (i,s,stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P!!i) (i,s,stk) \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size P
  \<Longrightarrow> P \<turnstile> (i,s,stk) \<rightarrow> c'"
by (simp add: exec1_def)

abbreviation
  exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50)
where
  "exec P \<equiv> star (exec1 P)"

declare star.step[intro]

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

code_pred exec1 by (metis exec1_def)

values
  "{(i,map t [''x'',''y''],stk) | i t stk.
    [LOAD ''y'', STORE ''x''] \<turnstile>
    (0, <''x'' := 3, ''y'' := 4>, []) \<rightarrow>* (i,t,stk)}"

subsection\<open> Verification infrastructure \<close>

text\<open> Below we need to argue about the execution of code that is embedded in
larger programs. For this purpose we show that execution is preserved by
appending code to the left or right of a program. \<close>

lemma iexec_shift [simp]:
  "((n+i',s',stk') = iexec x (n+i,s,stk)) = ((i',s',stk') = iexec x (i,s,stk))"
by(auto split:instr.split)

lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
by (auto simp: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows
  "P \<turnstile> (i,s,stk) \<rightarrow> (i',s',stk') \<Longrightarrow>
   P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow> (size(P')+i',s',stk')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

lemma exec_appendL:
  fixes i i' :: int
  shows
 "P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')  \<Longrightarrow>
  P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow>* (size(P')+i',s',stk')"
  by (induction rule: exec_induct) (blast intro!: exec1_appendL)+

text\<open> Now we specialise the above lemmas to enable automatic proofs of
@{prop "P \<turnstile> c \<rightarrow>* c'"} where @{text P} is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by @{text "@"} and @{text "#"}. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it: \<close>

lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0,s,stk) \<rightarrow>* (j,t,stk') \<Longrightarrow>
  instr#P \<turnstile> (1,s,stk) \<rightarrow>* (1+j,t,stk')"
by (drule exec_appendL[where P'="[instr]"]) simp

lemma exec_appendL_if[intro]:
  fixes i i' j :: int
  shows
  "size P' <= i
   \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
   \<Longrightarrow> i' = size P' + j
   \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
by (drule exec_appendL[where P'=P']) simp

text\<open> Split the execution of a compound program up into the excution of its
parts: \<close>

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows
"P \<turnstile> (0,s,stk) \<rightarrow>* (i',s',stk') \<Longrightarrow>
 size P \<le> i' \<Longrightarrow>
 P' \<turnstile>  (i' - size P,s',stk') \<rightarrow>* (i'',s'',stk'') \<Longrightarrow>
 j'' = size P + i''
 \<Longrightarrow>
 P @ P' \<turnstile> (0,s,stk) \<rightarrow>* (j'',s'',stk'')"
by(metis star_trans[OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
"acomp (N n) = [LOADI n]" |
"acomp (V x) = [LOAD x]" |
"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
by (induction a arbitrary: stk) fastforce+

fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
"bcomp (Bc v) f n = (if v=f then [JMP n] else [])" |
"bcomp (Not b) f n = bcomp b (\<not>f) n" |
"bcomp (And b1 b2) f n =
 (let cb2 = bcomp b2 f n;
        m = (if f then size cb2 else (size cb2::int)+n);
      cb1 = bcomp b1 False m
  in cb1 @ cb2)" |
"bcomp (Less a1 a2) f n =
 acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
     False 3"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n"
                 "False"]
       And(2)[of n f] And(3)
  show ?case by fastforce
qed fastforce+

consts ccomp :: "com \<Rightarrow> instr list"

end


theory ReversePathFiltering
imports Routing_Table "../Simple_Firewall/Simple_Packet"
begin

text\<open>RFC3704 style RPF\<close>

text\<open>\begin{quote}The procedure is that the
   source address is looked up in the Forwarding Information Base (FIB)
   - and if the packet is received on the interface which would be used
   to forward the traffic to the source of the packet, it passes the
   check.\end{quote}\<close>
(* There's an iptables rpf in ./net/ipv4/netfilter/ipt_rpfilter.c:35
   More interesting is ./net/ipv4/fib_frontend.c:323 though
*)
definition "rpf_strict rtbl p \<equiv> output_iface (routing_table_semantics rtbl (p_src p)) = p_iiface p"

text\<open>\begin{quote}
   Feasible Path Reverse Path Forwarding (Feasible RPF) is an extension
   of Strict RPF.  The source address is still looked up in the FIB (or
   an equivalent, RPF-specific table) but instead of just inserting one
   best route there, the alternative paths (if any) have been added as
   well, and are valid for consideration.
\end{quote}\<close>
definition "rpf_feasible rtbl p \<equiv> \<exists>rr \<in> set rtbl.
  prefix_match_semantics (routing_match rr) (p_src p) \<and> routing_oiface rr = p_iiface p"
definition "rpf_loose rtbl p \<equiv> \<exists>rr \<in> set rtbl. prefix_match_semantics (routing_match rr) (p_src p)"
definition "rpf_loose_ign_default rtbl p \<equiv> \<exists>rr \<in> set rtbl.
  prefix_match_semantics (routing_match rr) (p_src p) \<and> routing_match rr \<noteq> PrefixMatch 0 0"
text\<open>Note that this clearly exposes a weakness of our models: The FIB we modelled really only considers the routing table. We have not taken care to avoid un-routable address spaces. As such, @{const rpf_loose} is not very useful:\<close>
lemma "valid_prefixes rtbl \<Longrightarrow> has_default_route rtbl \<Longrightarrow> \<forall>p. rpf_loose rtbl p"
  by(induction rtbl) (auto simp add: valid_prefixes_alt_def zero_prefix_match_all rpf_loose_def[abs_def])

text\<open>One might ask: What (nonstandard) formulations of reverse path filtering are possible? This is an example that fits into the hierarchy, between feasible and strict RPF:\<close>
definition "rpf_semifeasible    rtbl p \<equiv> \<exists>rr \<in> set rtbl.
  prefix_match_semantics (routing_match rr) (p_src p) \<and> routing_oiface rr = p_iiface p (* rule applies and routes to right interface *)
\<and> (\<forall>ra \<in> set rtbl. routing_prefix ra > routing_prefix rr \<longrightarrow>  \<not>prefix_match_semantics (routing_match ra) (p_src p)) (* no rules more specific than this one apply *)
"
text\<open>Unlinke feasible RPF, this only considers alternate routes if these routes have the same prefix length as the best route.\<close>
text\<open>The insight we are not going to prove here is: There is an infinite number of levels in this hierarchy.
(For example we might only allow alternate routes whose metric difference it at max @{term n}. However, there are more interesting formulations of RPF that we did not discuss.)\<close>

lemma "prefix_match_semantics (PrefixMatch 0 0) any" by (simp add: valid_prefix_00 zero_prefix_match_all)

text\<open>The hierarchy unfolds:\<close>
lemma
  assumes "valid_prefixes rtbl" "is_longest_prefix_routing rtbl" "has_default_route rtbl" "unambiguous_routing rtbl"
  shows "rpf_strict rtbl p \<Longrightarrow> rpf_semifeasible rtbl p"
unfolding rpf_semifeasible_def rpf_strict_def
(* meh, the thing is subtly different enough from existential_routing that we can't use that directly *)
proof goal_cases
  case 1
  then obtain act where *: "routing_table_semantics rtbl (p_src p) = act" by blast
  with existential_routing[OF assms]
  have ex: "(\<exists>rr\<in>set rtbl.
        prefix_match_semantics (routing_match rr) (p_src p) \<and>
        output_iface (routing_action rr) = output_iface 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) (p_src p)))" by auto
  from * 1 have act: "p_iiface p = output_iface act" by simp
  have **: "routing_prefix rr < routing_prefix ra \<Longrightarrow> routing_rule_sort_key ra < routing_rule_sort_key rr" for rr ra by(auto simp add: act routing_rule_sort_key_def linord_helper_less int_of_nat_def)
  from ex show ?case using ** by (simp add: act) blast
qed

lemma "rpf_semifeasible rtbl p \<Longrightarrow> rpf_feasible rtbl p"
unfolding rpf_semifeasible_def rpf_feasible_def by blast
lemma "rpf_feasible rtbl p \<Longrightarrow> rpf_loose rtbl p"
unfolding rpf_loose_def rpf_feasible_def by blast
lemma "rpf_loose_ign_default rtbl p \<Longrightarrow> rpf_loose rtbl p"
unfolding rpf_loose_def rpf_loose_ign_default_def by blast
text\<open>Unfortunately, nothing stronger can be said about @{const rpf_loose_ign_default}:\<close>
context begin
private definition "all_valid rtbl \<equiv> valid_prefixes rtbl \<and> is_longest_prefix_routing rtbl \<and> has_default_route rtbl \<and> unambiguous_routing rtbl"

lemma "\<exists>rtbl :: 'a :: len prefix_routing. all_valid rtbl \<and> (\<forall>p. \<not>rpf_loose_ign_default rtbl p) \<and> (\<exists>p :: 'a simple_packet. rpf_strict rtbl p)" (is "\<exists>x. ?t1 x")
text\<open>Read: There are routing tables where @{const rpf_loose_ign_default} is strongly stricter than @{const rpf_strict}.\<close>
proof text\<open>The catch here is that the routing table only containing the default rule will forbid all packets with @{term rpf_loose_ign_default}.\<close>
  have "rpf_strict [
    \<lparr>routing_match = PrefixMatch 0 0, metric = 418, routing_action = \<lparr>output_iface = ''e'', next_hop = Some 1\<rparr>\<rparr>]
    \<lparr> p_iiface = ''e'', p_oiface = '''', p_src = 0, p_dst = 0 :: 'a word, p_proto = TCP, p_sport = 0, p_dport = 0, p_tcp_flags = {}, p_payload = '''' \<rparr>"
  unfolding rpf_strict_def by(simp add: valid_prefix_00 zero_prefix_match_all)
  thus "?t1 [\<lparr>routing_match = PrefixMatch 0 0, metric = 418, routing_action = \<lparr>output_iface = ''e'', next_hop = Some 1\<rparr>\<rparr>]"
  unfolding rpf_loose_ign_default_def unfolding all_valid_def by (auto simp add: valid_prefixes_alt_def valid_prefix_00 is_longest_prefix_routing_def unambiguous_routing_code)
qed

lemma
  shows "\<exists>rtbl :: 32 prefix_routing. all_valid rtbl \<and> (\<forall>p. rpf_loose rtbl p \<longleftrightarrow> rpf_loose_ign_default rtbl p)" (is "\<exists>x. _ \<and> (\<forall>p. ?t2 x p)")
  text\<open>Read: There are routing tables where @{const rpf_loose_ign_default} is just as weak as @{const rpf_loose}. (Even though they contain a default route, mind you!)\<close>
  text\<open>And yes, this could be shown for a more general type, but I suspect that would be a lot more annoying.\<close>
proof (intro exI allI conjI) text\<open>The catch here is that the functionality of the default route can entirely be taken over by other routes.\<close>
    let ?c = "[\<lparr>routing_match = PrefixMatch 0 1, metric = 0, routing_action = \<lparr>output_iface = ''e'', next_hop = None\<rparr>\<rparr>,
        \<lparr>routing_match = PrefixMatch 2147483648 1, metric = 0, routing_action = \<lparr>output_iface = ''e'', next_hop = None\<rparr>\<rparr>,
        \<lparr>routing_match = PrefixMatch 0 0, metric = 0, routing_action = \<lparr>output_iface = ''e'', next_hop = None\<rparr>\<rparr>] :: 32 prefix_routing"
    show "all_valid ?c" by eval (* I'd like to make this part of the lemma, but\<dots> Isabelle bug? *)
    have l: "~~ mask 31 && p = 0 \<Longrightarrow> prefix_match_semantics (PrefixMatch 0 1) p" for p :: "32 word" unfolding prefix_match_semantics_def pfxm_prefix_def pfxm_mask_def by simp
    have m: "~~(mask 31 :: 32 word) = 0x80000000" by eval
    have s: "(1 << 31) && p \<noteq> 0 \<Longrightarrow> (1 << 31) && p = 1 << 31" for p :: "32 word"
      unfolding word_bw_comms word_and_1_shiftl by(simp split: if_splits)
    have u: "~~ mask 31 && p \<noteq> 0 \<Longrightarrow> prefix_match_semantics (PrefixMatch 0x80000000 1)  p" for p :: "32 word"
      unfolding prefix_match_semantics_def pfxm_prefix_def pfxm_mask_def using s by(simp add: m)
    show "?t2 ?c p" for p unfolding rpf_loose_def rpf_loose_ign_default_def
      by(cases "~~ mask 31 && p_src p = 0"; (drule l | drule u); simp)
qed
end

corollary rpf_strict_correct:
assumes vpfx: "valid_prefixes rtbl"
shows "rpf_strict rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (routing_ipassmt_wi rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
unfolding rpf_strict_def
  apply(intro iffI[rotated])
  apply(clarify)
  apply(auto dest: routing_ipassmt_wi_sound[OF vpfx])[1]
  apply(subst(asm) routing_ipassmt_wi[OF vpfx])
  apply blast
done

definition "rpf_semifeasible_round rtbl n space \<equiv>
let res = [(routing_oiface rr, wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space) . rr \<leftarrow> rtbl, routing_prefix rr = n] in (res,
wordinterval_setminus space (wordinterval_Union (map snd res)))"

primrec rpf_semifeasible_assignment_dups where
"rpf_semifeasible_assignment_dups _ _ 0 = []" |
"rpf_semifeasible_assignment_dups rtbl space (Suc n) = (let
  (res,rspace) = rpf_semifeasible_round rtbl n space in
  res @ rpf_semifeasible_assignment_dups rtbl rspace n)"

definition "rpf_semifeasible_wi (rtbl::'a :: len routing_rule list) \<equiv> reduce_range_destination
  (rpf_semifeasible_assignment_dups rtbl wordinterval_UNIV (Suc (fold max (map routing_prefix rtbl) 0)))"
text\<open>One might think that @{term "Suc (len_of TYPE ('a :: len))"} is the right length of prefix to start from.
Unfortunately, @{const valid_prefix} does not ensure that the prefix isn't longer than what the type permits,
and so you'd miss those broken prefixes. Nobody cares, except for the proofs.
\<close>

lemma rpf_semifeasible_round_fst: "(\<exists>rr \<in> set rtbl. routing_prefix rr = n \<and> rspace = wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space \<and> ifce = routing_oiface rr)
   \<longleftrightarrow> (\<exists>(p,spc) \<in> set (fst (rpf_semifeasible_round rtbl n space)). ifce = p \<and> rspace = spc)"
   unfolding rpf_semifeasible_round_def Let_def fst_conv by(simp; blast)

lemma rpf_semifeasible_round_snd: "rr \<in> set rtbl \<Longrightarrow> routing_prefix rr = n \<Longrightarrow> wordinterval_empty (wordinterval_intersection (snd (rpf_semifeasible_round rtbl n space)) (prefix_to_wordinterval (routing_match rr)))"
  unfolding rpf_semifeasible_round_def Let_def snd_conv by(auto simp add: wordinterval_Union)

lemma rpf_semifeasible_round_snd':
  assumes vpfx: "valid_prefixes rtbl"
  assumes nm: "\<forall>ra\<in>set rtbl. routing_prefix ra = n \<longrightarrow> \<not> prefix_match_semantics (routing_match ra) ip"
  assumes e: "ip \<in> wordinterval_to_set space"
  shows "ip \<in> wordinterval_to_set (snd (rpf_semifeasible_round rtbl n space))"
proof -
  have " \<forall>x\<in>set rtbl \<inter> {rr. pfxm_length (routing_match rr) = n}. ip \<notin> prefix_to_wordset (routing_match x)"
    using nm prefix_match_semantics_wordset valid_prefixes_alt_def vpfx by fastforce
  with e show ?thesis by(simp add:  rpf_semifeasible_round_def Let_def wordinterval_Union)
qed

lemma ex_prod_splitI: "\<exists>(a,b) \<in> S. P (a,b) \<Longrightarrow> \<exists>a \<in> S. P a" by simp

lemma rpf_semifeasible_assignment_subset: "(p, spc) \<in> set (rpf_semifeasible_assignment_dups rtbl space n) \<Longrightarrow> wordinterval_subset spc space"
proof(induction n arbitrary: space)
  case (Suc n)
  from Suc.prems[unfolded rpf_semifeasible_assignment_dups.simps Let_def case_prod_unfold set_append Set.Un_iff]
  have "(p, spc) \<in> set (fst (rpf_semifeasible_round rtbl n space)) \<or> (p, spc) \<in> set (rpf_semifeasible_assignment_dups rtbl (snd (rpf_semifeasible_round rtbl n space)) n)" .
  thus ?case proof(elim disjE, goal_cases)
    case 1 thus ?case unfolding rpf_semifeasible_round_def Let_def fst_conv by force
  next
    case 2 with Suc.IH have "wordinterval_subset spc (snd (rpf_semifeasible_round rtbl n space))" .
    thus ?case unfolding rpf_semifeasible_round_def Let_def snd_conv by force
  qed
qed simp

lemma rpf_semifeasible_assignment_dups_fst:
  assumes vpfx: "valid_prefixes rtbl"
  assumes space: "ip \<in> wordinterval_to_set space"
shows "
    (\<exists>rr \<in> set rtbl. routing_prefix rr < n \<and> prefix_match_semantics (routing_match rr) ip \<and> ifce = routing_oiface rr \<and>
    (\<forall>ra \<in> set rtbl.  routing_prefix ra < n \<longrightarrow> routing_prefix ra > routing_prefix rr \<longrightarrow>  \<not>prefix_match_semantics (routing_match ra) ip))
   \<longleftrightarrow> (\<exists>(p,spc) \<in> set (rpf_semifeasible_assignment_dups rtbl space n). ifce = p \<and> ip \<in> wordinterval_to_set spc)"
proof(rule iffI, goal_cases)
  case 1 show ?case proof(insert 1 space, elim bexE conjE, induction n arbitrary: space)
    case (Suc n rr)
    show ?case proof(cases "routing_prefix rr = n")
      case False
      with \<open>routing_prefix rr < Suc n\<close> have *: "routing_prefix rr < n" by linarith
      have **: "\<forall>ra\<in>set rtbl. routing_prefix ra < n \<longrightarrow> routing_prefix rr < routing_prefix ra \<longrightarrow> \<not> prefix_match_semantics (routing_match ra) ip"
        using Suc.prems(6) by simp
      have ***: "ip \<in> wordinterval_to_set (snd (rpf_semifeasible_round rtbl n space))"
        by (simp add: * Suc.prems(1) Suc.prems(6) rpf_semifeasible_round_snd' vpfx) (* it werks™ *)
      note Suc.IH[OF *** Suc.prems(2) * Suc.prems(4-5) **]
      thus ?thesis by(auto simp add: case_prod_unfold Let_def)
    next
      case True
      have "(\<exists>rra\<in>set rtbl.
      routing_prefix rra = n \<and>
      wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space =
      wordinterval_intersection (prefix_to_wordinterval (routing_match rra)) space \<and>
      ifce = routing_oiface rra)" by(intro bexI[where x=rr]; simp add: Suc.prems True)
      with rpf_semifeasible_round_fst obtain p spc where pspc:
        "(p, spc)\<in>set (fst (rpf_semifeasible_round rtbl n space))" "ifce = p"
        "spc = wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space" by fast
      have m: "ip \<in> prefix_to_wordset (routing_match rr)"
        using Suc.prems(2) Suc.prems(4) prefix_match_semantics_wordset valid_prefixes_alt_def vpfx by blast
      show ?thesis unfolding rpf_semifeasible_assignment_dups.simps Let_def case_prod_unfold fst_conv set_append bex_Un
        apply(intro disjI1)
        apply(rule ex_prod_splitI)
        apply(rule bexI[where x="(p,spc)",rotated])
        apply(fact pspc)
        apply(simp add: pspc m Suc.prems(1))
      done
    qed
  qed(subgoal_tac False; simp; fail)
next
  case 2
  then obtain p spc where
    "(p, spc)\<in>set (rpf_semifeasible_assignment_dups rtbl space n)" "ifce = p" "ip \<in> wordinterval_to_set spc" by blast
  with space show ?case proof(induction n arbitrary: space)
    case 0 thus ?case by simp
  next
    case (Suc n)
    from Suc.prems(2)[unfolded rpf_semifeasible_assignment_dups.simps Let_def case_prod_unfold fst_conv set_append Set.Un_iff]
    have *: "(p, spc) \<in> set (fst (rpf_semifeasible_round rtbl n space)) \<or> (p, spc) \<in> set (rpf_semifeasible_assignment_dups rtbl (snd (rpf_semifeasible_round rtbl n space)) n)" .
    show ?case proof(cases "\<exists>ra\<in>set rtbl. routing_prefix ra = n \<and> prefix_match_semantics (routing_match ra) ip")
      case True
      hence "\<not>(p, spc) \<in> set (rpf_semifeasible_assignment_dups rtbl (snd (rpf_semifeasible_round rtbl n space)) n)" (is "\<not>?f")
      proof(intro notI)
        from True guess ra .. note ra = this
        hence *: "ip \<in> prefix_to_wordset (routing_match ra)" using vpfx using prefix_match_semantics_wordset valid_prefixes_alt_def by blast
        with Suc.prems have "prefix_to_wordset (routing_match ra) \<inter> wordinterval_to_set spc \<noteq> {}" by blast
        from rpf_semifeasible_round_snd[OF ra(1) ra(2)[THEN conjunct1]]
        have **: "wordinterval_empty (wordinterval_intersection (snd (rpf_semifeasible_round rtbl n space)) (prefix_to_wordinterval (routing_match ra)))" .
        assume ?f
        with rpf_semifeasible_assignment_subset have ***: "wordinterval_subset spc (snd (rpf_semifeasible_round rtbl n space))" .
        show False using Suc.prems(4) * **  *** by fastforce
      qed
      hence True': "(p, spc) \<in> set (fst (rpf_semifeasible_round rtbl n space))" using * by blast
      note True' Suc.prems(1,3-) rpf_semifeasible_round_fst[of rtbl n spc space ifce]
      then obtain rr where rr: "rr\<in>set rtbl"
        "routing_prefix rr = n"
        "spc = wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space"
        "p = routing_oiface rr" by blast
      have a: "prefix_match_semantics (routing_match rr) ip"
        using Suc.prems(4) prefix_match_semantics_wordset rr(1) rr(3) valid_prefixes_alt_def vpfx by fastforce
      show ?thesis
        by(intro bexI[where x=rr]) (simp_all add: rr Suc a)
    next
      case False
      have "(p, spc) \<notin> set (fst (rpf_semifeasible_round rtbl n space))" (is "\<not>?f")
      proof(intro notI)
        assume ?f with rpf_semifeasible_round_fst[of rtbl n spc space ifce] Suc.prems(3)
        obtain rr where rr: "rr\<in>set rtbl"
        "routing_prefix rr = n" "spc = wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space" "ifce = routing_oiface rr"  by blast
        hence "prefix_match_semantics (routing_match rr) ip" using vpfx Suc.prems(4)
          using prefix_match_semantics_wordset valid_prefixes_alt_def Int_iff prefix_to_wordinterval_set_eq wordinterval_intersection_set_eq by auto
        with False rr show False by blast
      qed
      with * have *: "(p, spc) \<in> set (rpf_semifeasible_assignment_dups rtbl (snd (rpf_semifeasible_round rtbl n space)) n)" by clarify
      have **: "ip \<in> wordinterval_to_set (snd (rpf_semifeasible_round rtbl n space))" using Suc.prems(4) * rpf_semifeasible_assignment_subset by fastforce
      from Suc.IH[OF ** * Suc.prems(3,4)] obtain rr where rr:
        "rr\<in>set rtbl"
        "routing_prefix rr < n"
        "prefix_match_semantics (routing_match rr) ip"
        "ifce = routing_oiface rr"
        "(\<forall>ra\<in>set rtbl. routing_prefix ra < n \<longrightarrow> routing_prefix rr < routing_prefix ra \<longrightarrow> \<not> prefix_match_semantics (routing_match ra) ip)" by blast
      show ?thesis
        apply(intro bexI[where x=rr])
        apply(simp_all add: rr)
        apply(intro conjI)
        using rr(2) apply(simp;fail)
        using rr(5) False apply fastforce
      done
    qed
  qed
qed

lemma fold_max_append: "fold max l (a::nat) = max a (fold max l 0)"
proof(induction l arbitrary: a)
  case (Cons l ls)
  show ?case by(simp add: Cons[of "(max l a) "] Cons[of l])
qed simp

lemma fold_max: "(f :: nat) \<in> set l \<Longrightarrow> f < Suc (fold max l 0)"
by(induction l; simp) (metis (no_types, lifting) fold_max_append lessI max_less_iff_conj not_less_eq) (* It werks™ *)

corollary rpf_semifeasible_correct:
  assumes vpfx: "valid_prefixes rtbl"
  shows "rpf_semifeasible rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (rpf_semifeasible_wi rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
unfolding rpf_semifeasible_def rpf_semifeasible_wi_def
unfolding reduce_range_destination_def Let_def comp_def
proof(goal_cases)
  case 1
  let ?rs = "rpf_semifeasible_assignment_dups rtbl wordinterval_UNIV (Suc (fold max (map routing_prefix rtbl) 0))" (* rs wie rattenschwanz *)
  show ?case (is "?l = ?r") proof -
  have maxpfx: "\<forall>ra\<in>set rtbl. routing_prefix ra < Suc (fold max (map routing_prefix rtbl) 0)"
    using fold_max[where l="map routing_prefix rtbl"] by simp
  have "?l = (\<exists>rr\<in>set rtbl.
      routing_prefix rr < Suc (fold max (map routing_prefix rtbl) 0) \<and>
      prefix_match_semantics (routing_match rr) (p_src p) \<and>
      p_iiface p = routing_oiface rr \<and>
      (\<forall>ra\<in>set rtbl.
          routing_prefix ra < Suc (fold max (map routing_prefix rtbl) 0) \<longrightarrow>
          routing_prefix rr < routing_prefix ra \<longrightarrow> \<not> prefix_match_semantics (routing_match ra) (p_src p)))"
    using maxpfx by auto
  with rpf_semifeasible_assignment_dups_fst[OF vpfx, of "p_src p" wordinterval_UNIV "Suc (fold max (map routing_prefix rtbl) 0)" "p_iiface p",
      unfolded wordinterval_UNIV_set_eq, OF UNIV_I]
  have "?l = (\<exists>(pa, spc)\<in>set ?rs.
        p_iiface p = pa \<and> p_src p \<in> wordinterval_to_set spc)" by linarith
  moreover have "(\<exists>(pa, spc)\<in>set (rpf_semifeasible_assignment_dups rtbl wordinterval_UNIV (Suc (fold max (map routing_prefix rtbl) 0))).
        p_iiface p = pa \<and> p_src p \<in> wordinterval_to_set spc) = ?r" (is "?l1 = ?r")
  proof
    assume ?l1
    then obtain pa spc where paspc:
      "(pa, spc)\<in>set ?rs"
      "p_iiface p = pa" "p_src p \<in> wordinterval_to_set spc" by blast
    from this(1) have *: "pa \<in> set (remdups (map fst (?rs)))" by force
    let ?rss = "wordinterval_Union(map snd [x\<leftarrow>?rs. pa = fst x])"
    show ?r
      apply(intro bexI[where x="(pa, ?rss)"])
      subgoal
        apply(simp add: paspc(2))
        apply(unfold wordinterval_Union set_map set_filter UN_iff)
        apply(intro bexI[where x=spc])
        apply(simp add: paspc(3);fail)
        using paspc(1) apply force
      done
      subgoal
        using * by fastforce
    done
  next
    assume ?r
    then obtain k l where kl: "(k, l)\<in>set (map (\<lambda>p. (p, wordinterval_Union
                              (map snd [x\<leftarrow>rpf_semifeasible_assignment_dups rtbl wordinterval_UNIV (Suc (fold max (map routing_prefix rtbl) 0)) . p = fst x])))
                 (remdups (map fst (rpf_semifeasible_assignment_dups rtbl wordinterval_UNIV (Suc (fold max (map routing_prefix rtbl) 0))))))"
     "p_iiface p = k" " p_src p \<in> wordinterval_to_set l" by blast
    from kl have "k \<in> set (remdups (map fst ?rs))" by auto
    from kl have "l = wordinterval_Union (map snd [x\<leftarrow>?rs . k = fst x])" by fastforce
    with kl(3) obtain lo where lo: "p_src p \<in> wordinterval_to_set lo" "(k, lo) \<in>  set ?rs" by(auto simp add: wordinterval_Union)
    show ?l1 by(intro bexI[where x="(k,lo)"]) (simp add: lo kl, fact lo)
  qed
  ultimately show ?case by linarith
  qed
qed

definition "rpf_feasible_wi rtbl \<equiv> reduce_range_destination (map (\<lambda>rr. (routing_oiface rr, prefix_to_wordinterval (routing_match rr))) rtbl)"

lemma rpf_feasible_correct:
  assumes vpfx: "valid_prefixes rtbl"
  shows "rpf_feasible rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (rpf_feasible_wi rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
  using vpfx unfolding reduce_range_destination_def rpf_feasible_def rpf_feasible_wi_def
  by(force simp add: wordinterval_Union prefix_match_semantics_wordset valid_prefixes_alt_def)

definition "rpf_loose_wi ifs rtbl \<equiv> let routed_space = foldr (wordinterval_union \<circ> prefix_to_wordinterval \<circ> routing_match) rtbl Empty_WordInterval in [(iface,routed_space). iface \<leftarrow> ifs]"
lemma rpf_loose_correct:
  assumes vpfx: "valid_prefixes rtbl"
  assumes ifsane: "p_iiface p \<in> set ifs"
  shows "rpf_loose rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (rpf_loose_wi ifs rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
proof -
  from vpfx have *: "(\<exists>rr\<in>set rtbl. prefix_match_semantics (routing_match rr) (p )) =
        (p  \<in> wordinterval_to_set (foldr (wordinterval_union \<circ> prefix_to_wordinterval \<circ> routing_match) rtbl Empty_WordInterval))" for p
  proof(induction rtbl)
    case (Cons rr rtbl)
    have vpfx: "valid_prefix (routing_match rr)" using Cons.prems valid_prefixes_split by blast
    show ?case proof(cases "prefix_match_semantics (routing_match rr) p")
      case True thus ?thesis by(simp add: prefix_match_semantics_wordset[OF vpfx])
    next
      have vpfxs: "valid_prefixes rtbl" using Cons.prems valid_prefixes_split by blast
      case False
      with vpfx have ni: "p \<notin> prefix_to_wordset (routing_match rr)" using prefix_match_semantics_wordset by blast
      with False show ?thesis using Cons.IH[OF vpfxs] by simp
    qed
  qed simp
  thus ?thesis
  using vpfx ifsane
  unfolding rpf_loose_wi_def rpf_loose_def by simp
qed

definition "rpf_loose_ign_default_wi ifs \<equiv> rpf_loose_wi ifs \<circ> filter (\<lambda>rr. routing_match rr \<noteq> PrefixMatch 0 0)"
lemma rpf_loose_ign_default_correct:
  assumes vpfx: "valid_prefixes rtbl"
  assumes ifsane: "p_iiface p \<in> set ifs"
  shows "rpf_loose_ign_default rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (rpf_loose_ign_default_wi ifs rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
proof -
  let ?rtf = "filter (\<lambda>rr. routing_match rr \<noteq> PrefixMatch 0 0)"
  have f: "rpf_loose_ign_default rtbl p = rpf_loose (?rtf rtbl) p" unfolding rpf_loose_def rpf_loose_ign_default_def by auto
  from vpfx have fpfx: "valid_prefixes (?rtf rtbl)" unfolding valid_prefixes_alt_def by simp
  show ?thesis
    unfolding rpf_loose_ign_default_wi_def comp_def f
    using rpf_loose_correct[OF fpfx ifsane] .
qed

datatype rpf_type = RPF_Strict | RPF_Feasible | RPF_Loose | RPF_LooseIgnDef | RPF_Semifeasible
primrec rpf_def_lookup where
"rpf_def_lookup RPF_Strict = rpf_strict" |
"rpf_def_lookup RPF_Feasible = rpf_feasible" |
"rpf_def_lookup RPF_Loose = rpf_loose" |
"rpf_def_lookup RPF_LooseIgnDef = rpf_loose_ign_default" |
"rpf_def_lookup RPF_Semifeasible = rpf_semifeasible"
fun rpf_wi_lookup where
"rpf_wi_lookup RPF_Strict _ = routing_ipassmt_wi" |
"rpf_wi_lookup RPF_Feasible _ = rpf_feasible_wi" |
"rpf_wi_lookup RPF_Loose ifs = rpf_loose_wi ifs" |
"rpf_wi_lookup RPF_LooseIgnDef ifs = rpf_loose_ign_default_wi ifs" |
"rpf_wi_lookup RPF_Semifeasible _ = rpf_semifeasible_wi"

theorem
assumes vpfx: "valid_prefixes rtbl"
assumes ifsane: "rpf \<in> {RPF_Loose, RPF_LooseIgnDef} \<Longrightarrow> p_iiface p \<in> set ifs"
shows "rpf_def_lookup rpf rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (rpf_wi_lookup rpf ifs rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
using assms by(cases rpf; simp_all add: rpf_strict_correct rpf_semifeasible_correct rpf_feasible_correct rpf_loose_correct rpf_loose_ign_default_correct)

end


(* Author: Tobias Nipkow *)

subsection "Computable Abstract Interpretation"

theory Abs_Int1
imports Abs_State
begin

text\<open>Abstract interpretation over type \<open>st\<close> instead of functions.\<close>

context Gamma_semilattice
begin

fun aval' :: "aexp \<Rightarrow> 'av st \<Rightarrow> 'av" where
"aval' (N i) S = num' i" |
"aval' (V x) S = fun S x" |
"aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"

lemma aval'_correct: "s \<in> \<gamma>\<^sub>s S \<Longrightarrow> aval a s \<in> \<gamma>(aval' a S)"
by (induction a) (auto simp: gamma_num' gamma_plus' \<gamma>_st_def)

lemma gamma_Step_subcomm: fixes C1 C2 :: "'a::semilattice_sup acom"
  assumes "!!x e S. f1 x e (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (f2 x e S)"
          "!!b S. g1 b (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (g2 b S)"
  shows "Step f1 g1 (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (Step f2 g2 S C)"
proof(induction C arbitrary: S)
qed (auto simp: assms intro!: mono_gamma_o sup_ge1 sup_ge2)

lemma in_gamma_update: "\<lbrakk> s \<in> \<gamma>\<^sub>s S; i \<in> \<gamma> a \<rbrakk> \<Longrightarrow> s(x := i) \<in> \<gamma>\<^sub>s(update S x a)"
by(simp add: \<gamma>_st_def)

end

locale Abs_Int = Gamma_semilattice where \<gamma>=\<gamma>
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
begin

definition "step' = Step
  (\<lambda>x e S. case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(update S x (aval' e S)))
  (\<lambda>b S. S)"

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI c = pfp (step' \<top>) (bot c)"

lemma strip_step'[simp]: "strip(step' S C) = strip C"
by(simp add: step'_def)

text\<open>Correctness:\<close>

lemma step_step': "step (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' S C)"
unfolding step_def step'_def
by(rule gamma_Step_subcomm)
  (auto simp: intro!: aval'_correct in_gamma_update split: option.splits)

lemma AI_correct: "AI c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
proof(simp add: CS_def AI_def)
  assume 1: "pfp (step' \<top>) (bot c) = Some C"
  have pfp': "step' \<top> C \<le> C" by(rule pfp_pfp[OF 1])
  have 2: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"  \<comment> \<open>transfer the pfp'\<close>
  proof(rule order_trans)
    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' \<top> C)" by(rule step_step')
    show "... \<le> \<gamma>\<^sub>c C" by (metis mono_gamma_c[OF pfp'])
  qed
  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp[OF _ 1] step'_def)
  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 2])
  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
qed

end

subsubsection "Monotonicity"

locale Abs_Int_mono = Abs_Int +
assumes mono_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> plus' a1 a2 \<le> plus' b1 b2"
begin

lemma mono_aval': "S1 \<le> S2 \<Longrightarrow> aval' e S1 \<le> aval' e S2"
by(induction e) (auto simp: mono_plus' mono_fun)

theorem mono_step': "S1 \<le> S2 \<Longrightarrow> C1 \<le> C2 \<Longrightarrow> step' S1 C1 \<le> step' S2 C2"
unfolding step'_def
by(rule mono2_Step) (auto simp: mono_aval' split: option.split)

lemma mono_step'_top: "C \<le> C' \<Longrightarrow> step' \<top> C \<le> step' \<top> C'"
by (metis mono_step' order_refl)

lemma AI_least_pfp: assumes "AI c = Some C" "step' \<top> C' \<le> C'" "strip C' = c"
shows "C \<le> C'"
by(rule pfp_bot_least[OF _ _ assms(2,3) assms(1)[unfolded AI_def]])
  (simp_all add: mono_step'_top)

end

subsubsection "Termination"

locale Measure1 =
fixes m :: "'av::order_top \<Rightarrow> nat"
fixes h :: "nat"
assumes h: "m x \<le> h"
begin

definition m_s :: "'av st \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>s") where
"m_s S X = (\<Sum> x \<in> X. m(fun S x))"

lemma m_s_h: "finite X \<Longrightarrow> m_s S X \<le> h * card X"
by(simp add: m_s_def) (metis mult.commute of_nat_id sum_bounded_above[OF h])

definition m_o :: "'av st option \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>o") where
"m_o opt X = (case opt of None \<Rightarrow> h * card X + 1 | Some S \<Rightarrow> m_s S X)"

lemma m_o_h: "finite X \<Longrightarrow> m_o opt X \<le> (h*card X + 1)"
by(auto simp add: m_o_def m_s_h le_SucI split: option.split dest:m_s_h)

definition m_c :: "'av st option acom \<Rightarrow> nat" ("m\<^sub>c") where
"m_c C = sum_list (map (\<lambda>a. m_o a (vars C)) (annos C))"

text\<open>Upper complexity bound:\<close>
lemma m_c_h: "m_c C \<le> size(annos C) * (h * card(vars C) + 1)"
proof-
  let ?X = "vars C" let ?n = "card ?X" let ?a = "size(annos C)"
  have "m_c C = (\<Sum>i<?a. m_o (annos C ! i) ?X)"
    by(simp add: m_c_def sum_list_sum_nth atLeast0LessThan)
  also have "\<dots> \<le> (\<Sum>i<?a. h * ?n + 1)"
    apply(rule sum_mono) using m_o_h[OF finite_Cvars] by simp
  also have "\<dots> = ?a * (h * ?n + 1)" by simp
  finally show ?thesis .
qed

end

fun top_on_st :: "'a::order_top st \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>s") where
"top_on_st S X = (\<forall>x\<in>X. fun S x = \<top>)"

fun top_on_opt :: "'a::order_top st option \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>o") where
"top_on_opt (Some S)  X = top_on_st S X" |
"top_on_opt None X = True"

definition top_on_acom :: "'a::order_top st option acom \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>c") where
"top_on_acom C X = (\<forall>a \<in> set(annos C). top_on_opt a X)"

lemma top_on_top: "top_on_opt (\<top>::_ st option) X"
by(auto simp: top_option_def fun_top)

lemma top_on_bot: "top_on_acom (bot c) X"
by(auto simp add: top_on_acom_def bot_def)

lemma top_on_post: "top_on_acom C X \<Longrightarrow> top_on_opt (post C) X"
by(simp add: top_on_acom_def post_in_annos)

lemma top_on_acom_simps:
  "top_on_acom (SKIP {Q}) X = top_on_opt Q X"
  "top_on_acom (x ::= e {Q}) X = top_on_opt Q X"
  "top_on_acom (C1;;C2) X = (top_on_acom C1 X \<and> top_on_acom C2 X)"
  "top_on_acom (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) X =
   (top_on_opt P1 X \<and> top_on_acom C1 X \<and> top_on_opt P2 X \<and> top_on_acom C2 X \<and> top_on_opt Q X)"
  "top_on_acom ({I} WHILE b DO {P} C {Q}) X =
   (top_on_opt I X \<and> top_on_acom C X \<and> top_on_opt P X \<and> top_on_opt Q X)"
by(auto simp add: top_on_acom_def)

lemma top_on_sup:
  "top_on_opt o1 X \<Longrightarrow> top_on_opt o2 X \<Longrightarrow> top_on_opt (o1 \<squnion> o2 :: _ st option) X"
apply(induction o1 o2 rule: sup_option.induct)
apply(auto)
by transfer simp

lemma top_on_Step: fixes C :: "('a::semilattice_sup_top)st option acom"
assumes "!!x e S. \<lbrakk>top_on_opt S X; x \<notin> X; vars e \<subseteq> -X\<rbrakk> \<Longrightarrow> top_on_opt (f x e S) X"
        "!!b S. top_on_opt S X \<Longrightarrow> vars b \<subseteq> -X \<Longrightarrow> top_on_opt (g b S) X"
shows "\<lbrakk> vars C \<subseteq> -X; top_on_opt S X; top_on_acom C X \<rbrakk> \<Longrightarrow> top_on_acom (Step f g S C) X"
proof(induction C arbitrary: S)
qed (auto simp: top_on_acom_simps vars_acom_def top_on_post top_on_sup assms)

locale Measure = Measure1 +
assumes m2: "x < y \<Longrightarrow> m x > m y"
begin

lemma m1: "x \<le> y \<Longrightarrow> m x \<ge> m y"
by(auto simp: le_less m2)

lemma m_s2_rep: assumes "finite(X)" and "S1 = S2 on -X" and "\<forall>x. S1 x \<le> S2 x" and "S1 \<noteq> S2"
shows "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))"
proof-
  from assms(3) have 1: "\<forall>x\<in>X. m(S1 x) \<ge> m(S2 x)" by (simp add: m1)
  from assms(2,3,4) have "\<exists>x\<in>X. S1 x < S2 x"
    by(simp add: fun_eq_iff) (metis Compl_iff le_neq_trans)
  hence 2: "\<exists>x\<in>X. m(S1 x) > m(S2 x)" by (metis m2)
  from sum_strict_mono_ex1[OF \<open>finite X\<close> 1 2]
  show "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))" .
qed

lemma m_s2: "finite(X) \<Longrightarrow> fun S1 = fun S2 on -X
  \<Longrightarrow> S1 < S2 \<Longrightarrow> m_s S1 X > m_s S2 X"
apply(auto simp add: less_st_def m_s_def)
apply (transfer fixing: m)
apply(simp add: less_eq_st_rep_iff eq_st_def m_s2_rep)
done

lemma m_o2: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 < o2 \<Longrightarrow> m_o o1 X > m_o o2 X"
proof(induction o1 o2 rule: less_eq_option.induct)
  case 1 thus ?case by (auto simp: m_o_def m_s2 less_option_def)
next
  case 2 thus ?case by(auto simp: m_o_def less_option_def le_imp_less_Suc m_s_h)
next
  case 3 thus ?case by (auto simp: less_option_def)
qed

lemma m_o1: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 \<le> o2 \<Longrightarrow> m_o o1 X \<ge> m_o o2 X"
by(auto simp: le_less m_o2)

lemma m_c2: "top_on_acom C1 (-vars C1) \<Longrightarrow> top_on_acom C2 (-vars C2) \<Longrightarrow>
  C1 < C2 \<Longrightarrow> m_c C1 > m_c C2"
proof(auto simp add: le_iff_le_annos size_annos_same[of C1 C2] vars_acom_def less_acom_def)
  let ?X = "vars(strip C2)"
  assume top: "top_on_acom C1 (- vars(strip C2))"  "top_on_acom C2 (- vars(strip C2))"
  and strip_eq: "strip C1 = strip C2"
  and 0: "\<forall>i<size(annos C2). annos C1 ! i \<le> annos C2 ! i"
  hence 1: "\<forall>i<size(annos C2). m_o (annos C1 ! i) ?X \<ge> m_o (annos C2 ! i) ?X"
    apply (auto simp: all_set_conv_all_nth vars_acom_def top_on_acom_def)
    by (metis finite_cvars m_o1 size_annos_same2)
  fix i assume i: "i < size(annos C2)" "\<not> annos C2 ! i \<le> annos C1 ! i"
  have topo1: "top_on_opt (annos C1 ! i) (- ?X)"
    using i(1) top(1) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
  have topo2: "top_on_opt (annos C2 ! i) (- ?X)"
    using i(1) top(2) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
  from i have "m_o (annos C1 ! i) ?X > m_o (annos C2 ! i) ?X" (is "?P i")
    by (metis 0 less_option_def m_o2[OF finite_cvars topo1] topo2)
  hence 2: "\<exists>i < size(annos C2). ?P i" using \<open>i < size(annos C2)\<close> by blast
  have "(\<Sum>i<size(annos C2). m_o (annos C2 ! i) ?X)
         < (\<Sum>i<size(annos C2). m_o (annos C1 ! i) ?X)"
    apply(rule sum_strict_mono_ex1) using 1 2 by (auto)
  thus ?thesis
    by(simp add: m_c_def vars_acom_def strip_eq sum_list_sum_nth atLeast0LessThan size_annos_same[OF strip_eq])
qed

end

locale Abs_Int_measure =
  Abs_Int_mono where \<gamma>=\<gamma> + Measure where m=m
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set" and m :: "'av \<Rightarrow> nat"
begin

lemma top_on_step': "\<lbrakk> top_on_acom C (-vars C) \<rbrakk> \<Longrightarrow> top_on_acom (step' \<top> C) (-vars C)"
unfolding step'_def
by(rule top_on_Step)
  (auto simp add: top_option_def fun_top split: option.splits)

lemma AI_Some_measure: "\<exists>C. AI c = Some C"
unfolding AI_def
apply(rule pfp_termination[where I = "\<lambda>C. top_on_acom C (- vars C)" and m="m_c"])
apply(simp_all add: m_c2 mono_step'_top bot_least top_on_bot)
using top_on_step' apply(auto simp add: vars_acom_def)
done

end

end


theory IHT_Skew_Heap
  imports
    IHT_Tree
    Amortized_Complexity.Skew_Heap_Analysis
    "../Asymptotics/Asymptotics_1D"
begin

section \<open>Operations\<close>

partial_function (heap_time) merge_impl :: "'a::{heap,linorder} ptree \<Rightarrow> 'a ptree \<Rightarrow> 'a ptree Heap" where
  "merge_impl a b = (case a of
    None \<Rightarrow> return b
  | Some p \<Rightarrow> (case b of
      None \<Rightarrow> return a
    | Some q \<Rightarrow> do {
        ta \<leftarrow> !p;
        tb \<leftarrow> !q;
        (if val ta \<le> val tb then do {
           q' \<leftarrow> merge_impl (Some q) (rsub ta);
           p := Node q' (val ta) (lsub ta);
           return (Some p) }
         else do {
           p' \<leftarrow> merge_impl (Some p) (rsub tb);
           q := Node p' (val tb) (lsub tb);
           return (Some q) })}))"

setup \<open>fold add_rewrite_rule @{thms Skew_Heap.merge.simps}\<close>

definition merge_time :: "'a::linorder tree \<Rightarrow> 'a tree \<Rightarrow> nat" where
  "merge_time t1 t2 = 4 * T_merge t1 t2"

lemma merge_time_simps [rewrite]:
  "merge_time Leaf h = 4"
  "merge_time h Leaf = 4"
  "merge_time \<langle>l1, a1, r1\<rangle> \<langle>l2, a2, r2\<rangle> =
     (if a1 \<le> a2 then merge_time \<langle>l2, a2, r2\<rangle> r1 else merge_time \<langle>l1, a1, r1\<rangle> r2) + 4"
  by (simp add: merge_time_def)+

lemma skew_heap_merge_correct [hoare_triple]:
  "<btree t1 a * btree t2 b * $(merge_time t1 t2)>
   merge_impl a b
   <btree (Skew_Heap.merge t1 t2)>\<^sub>t"
@proof @fun_induct "Skew_Heap.merge t1 t2" arbitrary a b @with
  @subgoal "(t1 = t1, t2 = Leaf)" @case "t1 = Leaf" @endgoal @end
@qed

definition "skew_heap_constr v = tree_constr v"

lemma skew_heap_constr_to_fun [hoare_triple]:
  "<$2> skew_heap_constr v <btree \<langle>Leaf, v, Leaf\<rangle>>\<^sub>t" by auto2

definition insert_impl :: "'a::{heap,linorder} \<Rightarrow> 'a ptree \<Rightarrow> 'a ptree Heap" where
  "insert_impl x t = do {
     s \<leftarrow> skew_heap_constr x;
     merge_impl s t
   }"

setup \<open>add_rewrite_rule @{thm skew_heap.insert.simps}\<close>

partial_function (heap_time) del_min_impl :: "'a::{heap,linorder} ptree \<Rightarrow> 'a ptree Heap" where
  "del_min_impl a = (case a of
     None \<Rightarrow> return None
   | Some a \<Rightarrow> do {
      t \<leftarrow> !a;
      merge_impl (lsub t) (rsub t)
    })"

setup \<open>fold add_rewrite_rule @{thms skew_heap.del_min.simps}\<close>

fun del_min_time :: "'a::linorder tree \<Rightarrow> nat" where
  "del_min_time Leaf = 4"
| "del_min_time (tree.Node l v r) = merge_time l r + 4"
setup \<open>fold add_rewrite_rule @{thms del_min_time.simps}\<close>

lemma skew_heap_del_min_correct [hoare_triple]:
  "<btree t a * $(del_min_time t)>
    del_min_impl a
   <btree (skew_heap.del_min t)>\<^sub>t"
@proof @case "t = Leaf" @qed

section \<open>Amortized analysis\<close>

definition skew_heap_P :: "'a tree \<Rightarrow> nat" where [rewrite]:
  "skew_heap_P t = 4 * nat (\<Phi> t)"

definition skew_heap :: "'a::heap tree \<Rightarrow> 'a ptree \<Rightarrow> assn" where [rewrite_ent]:
  "skew_heap t a = btree t a * $(skew_heap_P t)"

definition merge_atime :: "nat \<Rightarrow> nat \<Rightarrow> nat" where [rewrite]:
  "merge_atime n1 n2 = 4 * nat (\<lceil>3 * log 2 (n1 + n2)\<rceil> + 1)"

lemma merge_P_rule [resolve]:
  "merge_time t1 t2 + skew_heap_P (Skew_Heap.merge t1 t2) \<le>
   skew_heap_P t1 + skew_heap_P t2 + merge_atime (size1 t1) (size1 t2)"
proof -
  have a_merge':
    "T_merge t1 t2 + nat (\<Phi> (Skew_Heap.merge t1 t2)) \<le>
     nat (\<Phi> t1) + nat (\<Phi> t2) + nat (\<lceil>3 * log 2 (real (size1 t1 + size1 t2))\<rceil> + 1)" (is "?lhs \<le> ?rhs")
  proof -
    have a_merge'': "real ?lhs \<le> real ?rhs"
    proof -
      have rhs_ge_zero: "\<lceil>3 * log 2 (size1 t1 + size1 t2)\<rceil> + 1 \<ge> 0"
        by (smt Glog ceiling_mono ceiling_zero of_nat_0_le_iff of_nat_add zero_le_log_cancel_iff)
      have a_merge''': "real_of_int (int (T_merge t1 t2) + \<Phi> (Skew_Heap.merge t1 t2) - \<Phi> t1 - \<Phi> t2) \<le>
                        \<lceil>3 * log 2 (real (size1 t1 + size1 t2))\<rceil> + 1"
        using a_merge by (smt le_of_int_ceiling of_int_1 of_int_diff)
      show ?thesis
      apply (simp add: \<Phi>_nneg)
      apply (subst of_nat_nat)
        using rhs_ge_zero apply auto
        using a_merge''' by simp
    qed
    show ?thesis using a_merge'' of_nat_le_iff by blast
  qed
  show ?thesis
  apply (simp only: merge_time_def skew_heap_P_def merge_atime_def)
  using a_merge' by auto
qed

lemma skew_heap_merge_amor [hoare_triple]:
  "<skew_heap t1 a * skew_heap t2 b * $(merge_atime (size1 t1) (size1 t2))>
   merge_impl a b
   <skew_heap (Skew_Heap.merge t1 t2)>\<^sub>t"
@proof
  @have "skew_heap_P t1 + skew_heap_P t2 + merge_atime (size1 t1) (size1 t2) \<ge>\<^sub>t
         merge_time t1 t2 + skew_heap_P (Skew_Heap.merge t1 t2)"
@qed

lemma skew_heap_empty_P [rewrite]: "skew_heap_P Leaf = 0"
  by (simp add: skew_heap_P_def)

lemma skew_heap_constr_P [rewrite]: "skew_heap_P \<langle>Leaf, x, Leaf\<rangle> = 0"
  by (simp add: skew_heap_P_def rh_def)

definition "skew_heap_empty = tree_empty"

lemma skew_heap_empty_to_fun' [hoare_triple]:
  "<$1> skew_heap_empty <skew_heap Leaf>\<^sub>t"
@proof @have "1 \<ge>\<^sub>t 1 + skew_heap_P Leaf" @qed

lemma skew_heap_constr_to_fun' [hoare_triple]:
  "<$2> skew_heap_constr v <skew_heap \<langle>Leaf, v, Leaf\<rangle>>\<^sub>t"
@proof @have "2 \<ge>\<^sub>t 2 + skew_heap_P (tree.Node Leaf v Leaf)" @qed

definition del_min_atime :: "nat \<Rightarrow> nat" where
  "del_min_atime n = 4 * nat (\<lceil>3 * log 2 (n + 2)\<rceil> + 2)"

lemma del_min_time_rule:
  "del_min_time t = 4 * nat (T_del_min t)"
  by (induct t) (simp_all add: T_del_min_def merge_time_def)

lemma del_min_P_rule [resolve]:
  "del_min_time t + skew_heap_P (skew_heap.del_min t) \<le> skew_heap_P t + del_min_atime (size1 t)"
proof -
  have a_del_min':
    "nat (T_del_min t) + nat (\<Phi> (skew_heap.del_min t)) \<le>
     nat (\<Phi> t) + nat (\<lceil>3 * log 2 (real (size1 t + 2)) + 2\<rceil>)" (is "?lhs \<le> ?rhs")
  proof -
    have a_del_min'': "real ?lhs \<le> real ?rhs"
    proof -
      have rhs_ge_zero: "\<lceil>3 * log 2 (real (size1 t))\<rceil> + 2 \<ge> 0"
        by (smt Glog ceiling_mono ceiling_zero of_nat_0_le_iff)
      have a_del_min''': "real_of_int (T_del_min t + \<Phi> (skew_heap.del_min t) - \<Phi> t) \<le>
                          \<lceil>3 * log 2 (real (size1 t + 2))\<rceil> + 2"
        using a_del_min
        by (smt ceiling_diff_of_int le_of_int_ceiling of_int_1 of_int_minus)
      show ?thesis
        apply (simp add: \<Phi>_nneg)
        apply (subst of_nat_nat)
        using rhs_ge_zero T_del_min_def [of t] apply auto
        using a_del_min''' by simp
    qed
    show ?thesis using a_del_min'' of_nat_le_iff by blast
  qed
  show ?thesis
  apply (simp only: del_min_time_rule skew_heap_P_def del_min_atime_def)
    using a_del_min' by auto
qed

lemma skew_heap_del_min_to_fun' [hoare_triple]:
  "<skew_heap t a * $(del_min_atime (size1 t))>
    del_min_impl a
   <skew_heap (skew_heap.del_min t)>\<^sub>t"
@proof
  @have "skew_heap_P t + del_min_atime (size1 t) \<ge>\<^sub>t del_min_time t + skew_heap_P (skew_heap.del_min t)"
@qed

lemma del_min_atime_alt: "del_min_atime n = 8 + 4 * real (nat (\<lceil>3 * log 2 (2 + real n)\<rceil>))"
  apply (auto simp: del_min_atime_def) apply (subst nat_add_distrib)
  apply auto apply (rule less_le_trans[of _ 0]) using log2_gt_zero by auto

lemma del_min_atime_asym [asym_bound]:
  "(\<lambda>n. del_min_atime n) \<in> \<Theta>(\<lambda>n. ln (real n))"
  unfolding del_min_atime_alt
  using abcd_lnx[of 8 4 3 2] by auto

setup \<open>del_prfstep_thm @{thm skew_heap_def}\<close>

definition insert_atime :: "nat \<Rightarrow> nat" where [rewrite]:
  "insert_atime n = merge_atime 2 n + 2"

lemma skew_heap_constr_size [rewrite]: "size1 \<langle>Leaf, x, Leaf\<rangle> = 2" by simp

lemma skew_heap_insert_to_fun' [hoare_triple]:
  "<skew_heap t a * $(insert_atime (size1 t))>
   insert_impl x a
   <skew_heap (skew_heap.insert x t)>\<^sub>t"
@proof
  @have "insert_atime (size1 t) \<ge>\<^sub>t merge_atime (size1 \<langle>Leaf, x, Leaf\<rangle>) (size1 t) + 2"
@qed

lemma insert_atime_alt: "insert_atime n = 6 + 4 * real (nat (\<lceil>3 * log 2 (real (2 + n))\<rceil>))"
  apply (auto simp: insert_atime_def merge_atime_def) apply(subst nat_add_distrib)
  apply auto apply(rule less_le_trans[of _ 0] ) using log2_gt_zero by auto

lemma insert_atime_asym [asym_bound]:
  "(\<lambda>n. insert_atime n) \<in> \<Theta>(\<lambda>x. ln (real x))"  (is "?f \<in> \<Theta>(?g)")
  unfolding insert_atime_alt by (rule abcd_lnx) auto

section \<open>Abstract assertion\<close>

definition skew_heap_mset :: "'a::{heap,linorder} multiset \<Rightarrow> 'a ptree \<Rightarrow> assn" where [rewrite_ent]:
  "skew_heap_mset S a = (\<exists>\<^sub>At. skew_heap t a * \<up>(heap t) * \<up>(mset_tree t = S))"

lemma invar_empty: "heap Leaf"
  using skew_heap.PQM.invar_empty Heaps.Heap.empty_def by auto
setup \<open>add_resolve_prfstep @{thm invar_empty}\<close>
setup \<open>fold add_rewrite_rule @{thms mset_tree.simps}\<close>

lemma size1_mset_tree [rewrite]:
  "size (mset_tree t) + 1 = size1 t" by (simp add: size1_size)

lemma skew_heap_empty_rule'' [hoare_triple]:
  "<$1> skew_heap_empty <skew_heap_mset {#}>\<^sub>t"
  by auto2

thm skew_heap.PQM.invar_insert
setup \<open>add_forward_prfstep @{thm Skew_Heap.heap_merge}\<close>
setup \<open>add_rewrite_rule @{thm Skew_Heap.mset_merge}\<close>
setup \<open>add_forward_prfstep_cond @{thm skew_heap.PQM.invar_insert} [with_term "skew_heap.insert ?x ?q"]\<close>
setup \<open>add_rewrite_rule @{thm skew_heap.PQM.mset_insert}\<close>
setup \<open>add_forward_prfstep @{thm skew_heap.PQM.invar_del_min}\<close>
setup \<open>add_rewrite_rule @{thm skew_heap.PQM.mset_del_min}\<close>

setup \<open>register_wellform_data ("value h", ["h \<noteq> Leaf"])\<close>
setup \<open>add_prfstep_check_req ("value h", "h \<noteq> Leaf")\<close>

setup \<open>add_rewrite_rule @{thm skew_heap.PQM.mset_get_min}\<close>

lemma skew_heap_merge_rule [hoare_triple]:
  "<skew_heap_mset S a * skew_heap_mset T b * $(merge_atime (size S + 1) (size T + 1))>
    merge_impl a b
   <skew_heap_mset (S + T)>\<^sub>t" by auto2

lemma skew_heap_insert_rule [hoare_triple]:
  "<skew_heap_mset S a * $(insert_atime (size S + 1))>
    insert_impl x a
   <skew_heap_mset ({#x#} + S)>\<^sub>t" by auto2

lemma skew_heap_del_min_rule [hoare_triple]:
  "S \<noteq> {#} \<Longrightarrow>
   <skew_heap_mset S a * $(del_min_atime (size S + 1))>
    del_min_impl a
   <skew_heap_mset (S - {# Min_mset S #})>\<^sub>t" by auto2

end


theory DerivedCombinators
imports BananasBigStepDynamics
begin

(* derived types *)

abbreviation Bool :: type where
  "Bool \<equiv> \<one> \<oplus> \<one>"

abbreviation TrueV :: val where
  "TrueV \<equiv> InlV UnitV"

abbreviation FalseV :: val where
  "FalseV \<equiv> InrV UnitV"

(* derived combinators *)

abbreviation tuple_pair :: "expr \<Rightarrow> expr \<Rightarrow> expr" (infix "\<triangle>" 80) where
  "e\<^sub>1 \<triangle> e\<^sub>2 \<equiv> e\<^sub>1 \<parallel> e\<^sub>2 \<cdot> \<Theta>"

abbreviation case_strip :: "expr \<Rightarrow> expr \<Rightarrow> expr" (infix "\<nabla>" 80) where
  "e\<^sub>l \<nabla> e\<^sub>r \<equiv> \<Xi> \<cdot> e\<^sub>l \<bar> e\<^sub>r"

abbreviation predicate :: "expr \<Rightarrow> expr" ("_?") where
  "p? \<equiv> \<pi>\<^sub>2 \<bar> \<pi>\<^sub>2 \<cdot> \<rhd> \<cdot> p \<parallel> \<epsilon> \<cdot> \<Theta>"

abbreviation swap :: expr ("\<bowtie>") where
  "\<bowtie> \<equiv> \<pi>\<^sub>2 \<triangle> \<pi>\<^sub>1"

abbreviation distribute_right :: expr ("\<lhd>") where
  "\<lhd> \<equiv> \<bowtie> \<bar> \<bowtie> \<cdot> \<rhd> \<cdot> \<bowtie>"

abbreviation if_expr :: "expr \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr" ("IF _ THEN _ ELSE _ FI") where
  "IF p THEN e\<^sub>t ELSE e\<^sub>f FI \<equiv> e\<^sub>t \<nabla> e\<^sub>f \<cdot> (p?)"

abbreviation not_expr :: expr ("not") where
  "not \<equiv> IF \<epsilon> THEN \<kappa> FalseV ELSE \<kappa> TrueV FI"

lemma [simp]: "\<Gamma> \<turnstile> f\<^sub>l : t\<^sub>1 \<rightarrow> t\<^sub>3 \<Longrightarrow> \<Gamma> \<turnstile> f\<^sub>r : t\<^sub>2 \<rightarrow> t\<^sub>3 \<Longrightarrow> \<Gamma> \<turnstile> f\<^sub>l \<nabla> f\<^sub>r : t\<^sub>1 \<oplus> t\<^sub>2 \<rightarrow> t\<^sub>3"
  proof -
    assume "\<Gamma> \<turnstile> f\<^sub>l : t\<^sub>1 \<rightarrow> t\<^sub>3"
       and "\<Gamma> \<turnstile> f\<^sub>r : t\<^sub>2 \<rightarrow> t\<^sub>3"
    hence "\<Gamma> \<turnstile> f\<^sub>l \<bar> f\<^sub>r : t\<^sub>1 \<oplus> t\<^sub>2 \<rightarrow> t\<^sub>3 \<oplus> t\<^sub>3" by simp
    moreover have "\<Gamma> \<turnstile> \<Xi> : t\<^sub>3 \<oplus> t\<^sub>3 \<rightarrow> t\<^sub>3" by simp
    ultimately show "\<Gamma> \<turnstile> \<Xi> \<cdot> f\<^sub>l \<bar> f\<^sub>r : t\<^sub>1 \<oplus> t\<^sub>2 \<rightarrow> t\<^sub>3" by (metis tc_comp)
  qed

lemma [simp]: "\<Gamma> \<turnstile> p : t \<rightarrow> Bool \<Longrightarrow> \<Gamma> \<turnstile> p? : t \<rightarrow> t \<oplus> t"
  proof -
    assume "\<Gamma> \<turnstile> p : t \<rightarrow> Bool"
    hence "\<Gamma> \<turnstile> p \<parallel> \<epsilon> : t \<otimes> t \<rightarrow> Bool \<otimes> t" by simp
    moreover have "\<Gamma> \<turnstile> \<Theta> : t \<rightarrow> t \<otimes> t" by simp
    moreover have "\<Gamma> \<turnstile> \<rhd> : Bool \<otimes> t \<rightarrow> \<one> \<otimes> t \<oplus> \<one> \<otimes> t" by simp
    ultimately have "\<Gamma> \<turnstile> \<rhd> \<cdot> p \<parallel> \<epsilon> \<cdot> \<Theta> : t \<rightarrow> \<one> \<otimes> t \<oplus> \<one> \<otimes> t" by (metis tc_comp)
    moreover have "\<Gamma> \<turnstile> \<pi>\<^sub>2 \<bar> \<pi>\<^sub>2 : \<one> \<otimes> t \<oplus> \<one> \<otimes> t \<rightarrow> t \<oplus> t" by simp
    ultimately show "\<Gamma> \<turnstile> \<pi>\<^sub>2 \<bar> \<pi>\<^sub>2 \<cdot> \<rhd> \<cdot> p \<parallel> \<epsilon> \<cdot> \<Theta> : t \<rightarrow> t \<oplus> t" by (metis tc_comp)
  qed

lemma [simp]: "\<Gamma> \<turnstile> \<bowtie> : t\<^sub>1 \<otimes> t\<^sub>2 \<rightarrow> t\<^sub>2 \<otimes> t\<^sub>1"
  by simp

lemma [simp]: "\<Gamma> \<turnstile> \<lhd> : t\<^sub>3 \<otimes> (t\<^sub>1 \<oplus> t\<^sub>2) \<rightarrow> t\<^sub>3 \<otimes> t\<^sub>1 \<oplus> t\<^sub>3 \<otimes> t\<^sub>2"
  proof -
    have "\<Gamma> \<turnstile> \<rhd> : (t\<^sub>1 \<oplus> t\<^sub>2) \<otimes> t\<^sub>3 \<rightarrow> t\<^sub>1 \<otimes> t\<^sub>3 \<oplus> t\<^sub>2 \<otimes> t\<^sub>3" by simp
    moreover have "\<Gamma> \<turnstile> \<bowtie> : t\<^sub>3 \<otimes> (t\<^sub>1 \<oplus> t\<^sub>2) \<rightarrow> (t\<^sub>1 \<oplus> t\<^sub>2) \<otimes> t\<^sub>3" by simp
    ultimately have "\<Gamma> \<turnstile> \<rhd> \<cdot> \<bowtie> : t\<^sub>3 \<otimes> (t\<^sub>1 \<oplus> t\<^sub>2) \<rightarrow> t\<^sub>1 \<otimes> t\<^sub>3 \<oplus> t\<^sub>2 \<otimes> t\<^sub>3" by (metis tc_comp)
    moreover have "\<Gamma> \<turnstile> \<bowtie> \<bar> \<bowtie> : t\<^sub>1 \<otimes> t\<^sub>3 \<oplus> t\<^sub>2 \<otimes> t\<^sub>3 \<rightarrow> t\<^sub>3 \<otimes> t\<^sub>1 \<oplus> t\<^sub>3 \<otimes> t\<^sub>2" by simp
    ultimately show "\<Gamma> \<turnstile> \<bowtie> \<bar> \<bowtie> \<cdot> \<rhd> \<cdot> \<bowtie> : t\<^sub>3 \<otimes> (t\<^sub>1 \<oplus> t\<^sub>2) \<rightarrow> t\<^sub>3 \<otimes> t\<^sub>1 \<oplus> t\<^sub>3 \<otimes> t\<^sub>2" by (metis tc_comp)
  qed

lemma [simp]: "\<Gamma> \<turnstile> p : t\<^sub>1 \<rightarrow> Bool \<Longrightarrow> \<Gamma> \<turnstile> e\<^sub>t : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> e\<^sub>f : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow>
    \<Gamma> \<turnstile> IF p THEN e\<^sub>t ELSE e\<^sub>f FI : t\<^sub>1 \<rightarrow> t\<^sub>2"
  proof -
    assume "\<Gamma> \<turnstile> e\<^sub>t : t\<^sub>1 \<rightarrow> t\<^sub>2"
       and "\<Gamma> \<turnstile> e\<^sub>f : t\<^sub>1 \<rightarrow> t\<^sub>2"
    hence "\<Gamma> \<turnstile> e\<^sub>t \<nabla> e\<^sub>f : t\<^sub>1 \<oplus> t\<^sub>1 \<rightarrow> t\<^sub>2" by simp
    moreover assume "\<Gamma> \<turnstile> p : t\<^sub>1 \<rightarrow> Bool"
    ultimately show "\<Gamma> \<turnstile> IF p THEN e\<^sub>t ELSE e\<^sub>f FI : t\<^sub>1 \<rightarrow> t\<^sub>2" by simp
  qed

lemma [simp]: "\<Gamma> \<turnstile> not : Bool \<rightarrow> Bool"
  by simp

lemma [simp]: "\<Lambda> \<turnstile> f\<^sub>1 \<cdot> v \<Down> v\<^sub>1 \<Longrightarrow> \<Lambda> \<turnstile> f\<^sub>2 \<cdot> v \<Down> v\<^sub>2 \<Longrightarrow> \<Lambda> \<turnstile> f\<^sub>1 \<triangle> f\<^sub>2 \<cdot> v \<Down> PairV v\<^sub>1 v\<^sub>2"
  proof -
    assume "\<Lambda> \<turnstile> f\<^sub>1 \<cdot> v \<Down> v\<^sub>1"
       and "\<Lambda> \<turnstile> f\<^sub>2 \<cdot> v \<Down> v\<^sub>2"
    moreover have "\<Lambda> \<turnstile> \<Theta> \<cdot> v \<Down> PairV v v" by simp
    ultimately show "\<Lambda> \<turnstile> (f\<^sub>1 \<parallel> f\<^sub>2 \<cdot> \<Theta>) \<cdot> v \<Down> PairV v\<^sub>1 v\<^sub>2" by fastforce
  qed

lemma [simp]: "\<Lambda> \<turnstile> f\<^sub>l \<cdot> v \<Down> v' \<Longrightarrow> \<Lambda> \<turnstile> f\<^sub>l \<nabla> f\<^sub>r \<cdot> InlV v \<Down> v'"
  proof -
    assume "\<Lambda> \<turnstile> f\<^sub>l \<cdot> v \<Down> v'"
    hence "\<Lambda> \<turnstile> f\<^sub>l \<bar> f\<^sub>r \<cdot> InlV v \<Down> InlV v'" by simp
    thus "\<Lambda> \<turnstile> (\<Xi> \<cdot> f\<^sub>l \<bar> f\<^sub>r) \<cdot> InlV v \<Down> v'" by fastforce
  qed

lemma [simp]: "\<Lambda> \<turnstile> f\<^sub>r \<cdot> v \<Down> v' \<Longrightarrow> \<Lambda> \<turnstile> f\<^sub>l \<nabla> f\<^sub>r \<cdot> InrV v \<Down> v'"
  proof -
    assume "\<Lambda> \<turnstile> f\<^sub>r \<cdot> v \<Down> v'"
    hence "\<Lambda> \<turnstile> f\<^sub>l \<bar> f\<^sub>r \<cdot> InrV v \<Down> InrV v'" by simp
    thus "\<Lambda> \<turnstile> (\<Xi> \<cdot> f\<^sub>l \<bar> f\<^sub>r) \<cdot> InrV v \<Down> v'" by fastforce
  qed

lemma [simp]: "\<Lambda> \<turnstile> p \<cdot> v \<Down> TrueV \<Longrightarrow> \<Lambda> \<turnstile> p? \<cdot> v \<Down> InlV v"
  proof -
    have "\<Lambda> \<turnstile> \<Theta> \<cdot> v \<Down> PairV v v" by simp
    moreover assume "\<Lambda> \<turnstile> p \<cdot> v \<Down> TrueV"
    moreover hence "\<Lambda> \<turnstile> (p \<parallel> \<epsilon>) \<cdot> PairV v v \<Down> PairV TrueV v" by simp
    ultimately have "\<Lambda> \<turnstile> (p \<parallel> \<epsilon> \<cdot> \<Theta>) \<cdot> v \<Down> PairV TrueV v" by fastforce
    moreover have "\<Lambda> \<turnstile> \<rhd> \<cdot> PairV TrueV v \<Down> InlV (PairV UnitV v)" by simp
    ultimately have "\<Lambda> \<turnstile> (\<rhd> \<cdot> p \<parallel> \<epsilon> \<cdot> \<Theta>) \<cdot> v \<Down> InlV (PairV UnitV v)" by fastforce
    moreover have "\<Lambda> \<turnstile> (\<pi>\<^sub>2 \<bar> \<pi>\<^sub>2) \<cdot> InlV (PairV UnitV v) \<Down> InlV v" by simp
    ultimately show "\<Lambda> \<turnstile> (\<pi>\<^sub>2 \<bar> \<pi>\<^sub>2 \<cdot> \<rhd> \<cdot> p \<parallel> \<epsilon> \<cdot> \<Theta>) \<cdot> v \<Down> InlV v" by fastforce
  qed

lemma [simp]: "\<Lambda> \<turnstile> p \<cdot> v \<Down> FalseV \<Longrightarrow> \<Lambda> \<turnstile> p? \<cdot> v \<Down> InrV v"
  proof -
    have "\<Lambda> \<turnstile> \<Theta> \<cdot> v \<Down> PairV v v" by simp
    moreover assume "\<Lambda> \<turnstile> p \<cdot> v \<Down> FalseV"
    moreover hence "\<Lambda> \<turnstile> (p \<parallel> \<epsilon>) \<cdot> PairV v v \<Down> PairV FalseV v" by simp
    ultimately have "\<Lambda> \<turnstile> (p \<parallel> \<epsilon> \<cdot> \<Theta>) \<cdot> v \<Down> PairV FalseV v" by fastforce
    moreover have "\<Lambda> \<turnstile> \<rhd> \<cdot> PairV FalseV v \<Down> InrV (PairV UnitV v)" by simp
    ultimately have "\<Lambda> \<turnstile> (\<rhd> \<cdot> p \<parallel> \<epsilon> \<cdot> \<Theta>) \<cdot> v \<Down> InrV (PairV UnitV v)" by fastforce
    moreover have "\<Lambda> \<turnstile> (\<pi>\<^sub>2 \<bar> \<pi>\<^sub>2) \<cdot> InrV (PairV UnitV v) \<Down> InrV v" by simp
    ultimately show "\<Lambda> \<turnstile> (\<pi>\<^sub>2 \<bar> \<pi>\<^sub>2 \<cdot> \<rhd> \<cdot> p \<parallel> \<epsilon> \<cdot> \<Theta>) \<cdot> v \<Down> InrV v" by fastforce
  qed

lemma [simp]: "\<Lambda> \<turnstile> \<bowtie> \<cdot> PairV v\<^sub>1 v\<^sub>2 \<Down> PairV v\<^sub>2 v\<^sub>1"
  by simp

lemma [simp]: "\<Lambda> \<turnstile> \<lhd> \<cdot> PairV v\<^sub>1 (InlV v\<^sub>2) \<Down> InlV (PairV v\<^sub>1 v\<^sub>2)"
  proof -
    have "\<Lambda> \<turnstile> \<bowtie> \<cdot> PairV v\<^sub>1 (InlV v\<^sub>2) \<Down> PairV (InlV v\<^sub>2) v\<^sub>1" by simp
    moreover have "\<Lambda> \<turnstile> \<rhd> \<cdot> PairV (InlV v\<^sub>2) v\<^sub>1 \<Down> InlV (PairV v\<^sub>2 v\<^sub>1)" by simp
    ultimately have "\<Lambda> \<turnstile> (\<rhd> \<cdot> \<bowtie>) \<cdot> PairV v\<^sub>1 (InlV v\<^sub>2) \<Down> InlV (PairV v\<^sub>2 v\<^sub>1)" by fastforce
    moreover have "\<Lambda> \<turnstile> \<bowtie> \<bar> \<bowtie> \<cdot> InlV (PairV v\<^sub>2 v\<^sub>1) \<Down> InlV (PairV v\<^sub>1 v\<^sub>2)" by simp
    ultimately show "\<Lambda> \<turnstile> (\<bowtie> \<bar> \<bowtie> \<cdot> \<rhd> \<cdot> \<bowtie>) \<cdot> PairV v\<^sub>1 (InlV v\<^sub>2) \<Down> InlV (PairV v\<^sub>1 v\<^sub>2)" by fastforce
  qed

lemma [simp]: "\<Lambda> \<turnstile> \<lhd> \<cdot> PairV v\<^sub>1 (InrV v\<^sub>2) \<Down> InrV (PairV v\<^sub>1 v\<^sub>2)"
  proof -
    have "\<Lambda> \<turnstile> \<bowtie> \<cdot> PairV v\<^sub>1 (InrV v\<^sub>2) \<Down> PairV (InrV v\<^sub>2) v\<^sub>1" by simp
    moreover have "\<Lambda> \<turnstile> \<rhd> \<cdot> PairV (InrV v\<^sub>2) v\<^sub>1 \<Down> InrV (PairV v\<^sub>2 v\<^sub>1)" by simp
    ultimately have "\<Lambda> \<turnstile> (\<rhd> \<cdot> \<bowtie>) \<cdot> PairV v\<^sub>1 (InrV v\<^sub>2) \<Down> InrV (PairV v\<^sub>2 v\<^sub>1)" by fastforce
    moreover have "\<Lambda> \<turnstile> \<bowtie> \<bar> \<bowtie> \<cdot> InrV (PairV v\<^sub>2 v\<^sub>1) \<Down> InrV (PairV v\<^sub>1 v\<^sub>2)" by simp
    ultimately show "\<Lambda> \<turnstile> (\<bowtie> \<bar> \<bowtie> \<cdot> \<rhd> \<cdot> \<bowtie>) \<cdot> PairV v\<^sub>1 (InrV v\<^sub>2) \<Down> InrV (PairV v\<^sub>1 v\<^sub>2)" by fastforce
  qed

lemma [simp]: "\<Lambda> \<turnstile> p \<cdot> v \<Down> TrueV \<Longrightarrow> \<Lambda> \<turnstile> e\<^sub>t \<cdot> v \<Down> v' \<Longrightarrow> \<Lambda> \<turnstile> IF p THEN e\<^sub>t ELSE e\<^sub>f FI \<cdot> v \<Down> v'"
  proof -
    assume "\<Lambda> \<turnstile> p \<cdot> v \<Down> TrueV"
    hence X: "\<Lambda> \<turnstile> p? \<cdot> v \<Down> InlV v" by simp
    assume "\<Lambda> \<turnstile> e\<^sub>t \<cdot> v \<Down> v'"
    hence "\<Lambda> \<turnstile> e\<^sub>t \<nabla> e\<^sub>f \<cdot> InlV v \<Down> v'" by simp
    with X show "\<Lambda> \<turnstile> IF p THEN e\<^sub>t ELSE e\<^sub>f FI \<cdot> v \<Down> v'" by fastforce
  qed

lemma [simp]: "\<Lambda> \<turnstile> p \<cdot> v \<Down> FalseV \<Longrightarrow> \<Lambda> \<turnstile> e\<^sub>f \<cdot> v \<Down> v' \<Longrightarrow> \<Lambda> \<turnstile> IF p THEN e\<^sub>t ELSE e\<^sub>f FI \<cdot> v \<Down> v'"
  proof -
    assume "\<Lambda> \<turnstile> p \<cdot> v \<Down> FalseV"
    hence X: "\<Lambda> \<turnstile> p? \<cdot> v \<Down> InrV v" by simp
    assume "\<Lambda> \<turnstile> e\<^sub>f \<cdot> v \<Down> v'"
    hence "\<Lambda> \<turnstile> e\<^sub>t \<nabla> e\<^sub>f \<cdot> InrV v \<Down> v'" by simp
    with X show "\<Lambda> \<turnstile> IF p THEN e\<^sub>t ELSE e\<^sub>f FI \<cdot> v \<Down> v'" by fastforce
  qed

lemma [simp]: "\<Lambda> \<turnstile> not \<cdot> TrueV \<Down> FalseV"
  by simp

lemma [simp]: "\<Lambda> \<turnstile> not \<cdot> FalseV \<Down> TrueV"
  by simp

end