(*  Title:      HOL/Auth/fifo_on_inis.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The fifo Protocol Case Study*}

theory fifo_on_inis imports fifo_on_ini
begin
lemma on_inis:
  assumes b1: "f \<in> (invariants N)" and b2: "ini \<in> {andList (allInitSpecs N)}" and b3: "formEval ini s"
  shows "formEval f s"
  proof -
  have c1: "(f=inv__1  )"
  apply (cut_tac b1, simp) done
    moreover {
      assume d1: "(f=inv__1  )"
      have "formEval f s"
      apply (rule iniImply_inv__1)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

  ultimately show "formEval f s"
  by satx
qed

end


theory Distributed_WebApp
imports "../TopoS_Impl"
begin

section\<open>Distributed Web Application Example\<close>

text\<open>
    The symbolic policy names are of type @{typ string}, e.g. @{term "''WebFrnt''"}
\<close>

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

text\<open>Sanity check\<close>
lemma "wf_list_graph policy" by eval
(*proof by eval means we have executable code to show the lemma. No need to show anything by hand*)

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

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

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

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

text\<open>The list of security invariants\<close>
definition "security_invariants = [Subnet_m, BLP_m, LogSink_m, DBACL_m]"

text\<open>All security invariants are fulfilled (obviously, the policy permits no flows).\<close>
lemma "all_security_requirements_fulfilled security_invariants policy" by eval

text\<open>Obviously, no policy rules violate the security invariants.\<close>
lemma "implc_get_offending_flows security_invariants policy = []" by eval

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

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

text\<open>
Visualizing the maximum policy
\<close>
ML\<open>
visualize_graph @{context} @{term "security_invariants"} @{term "max_policy"};
\<close>

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

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

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

section\<open>A stateful implementation\<close>
definition "stateful_policy = generate_valid_stateful_policy_IFSACS my_policy security_invariants"
value "stateful_policy"

text\<open>the stateful compliance criteria\<close>

text\<open>No information flow violations\<close>
  lemma "all_security_requirements_fulfilled (get_IFS security_invariants) (stateful_list_policy_to_list_graph stateful_policy)" by eval

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

  text\<open>In general, the calculated stateful policy complies with the security policy: @{thm generate_valid_stateful_policy_IFSACS_stateful_policy_compliance}\<close>

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

subsection\<open>Exporting to Network Security Mechanism Configurations\<close>

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

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

text\<open>firewall -- classical use case\<close>
ML_val\<open>

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

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

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

text\<open>firewall -- OpenVPN scenario\<close>
ML_val\<open>

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

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

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

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

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

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

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

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

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

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

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

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

(*dockermynet4*)

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

lemma "wf_list_graph dockermynet4policy" by eval

ML\<open>
visualize_graph @{context} @{term "security_invariants"} @{term "dockermynet4policy"};
\<close>

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

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

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

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

writeln ("COMMIT"^"\n");
\<close>

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

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

ML_val\<open>
writeln ("{"^"\n"^
         "\"container_to_container\": {"^"\n"^
         "\"rules\": ["^"\n"^
         "\n");

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

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

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

writeln ("]}}"^"\n");
\<close>

end


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

theory TailrecPre
imports
  "Word_Lib.WordSetup"
  "Lib.Lib"
begin

definition
  "tailrec_pre (f1 :: 'a \<Rightarrow> 'a) guard precondition (x::'a) \<equiv>
    (\<forall>k. (\<forall>m. m < k \<longrightarrow> guard ((f1 ^^ m) x)) \<longrightarrow> precondition ((f1 ^^ k) x)) \<and>
    (\<exists>n. \<not> guard ((f1 ^^ n) x))"

definition
  "short_tailrec_pre (f :: 'a \<Rightarrow> ('a + 'b) \<times> bool) \<equiv>
     tailrec_pre (theLeft o fst o f) (isLeft o fst o f) (snd o f)"

partial_function (tailrec)
  tailrec :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b"
where
 "tailrec f1 f2 g x = (if g x then tailrec f1 f2 g (f1 x) else f2 x)"

lemma tailrec_steps:
  "g x \<Longrightarrow> tailrec f1 f2 g x = tailrec f1 f2 g (f1 x)"
  "\<not> g x \<Longrightarrow> tailrec f1 f2 g x = f2 x"
  by (simp_all add: tailrec.simps cong: if_weak_cong split del: if_split)

definition
  "short_tailrec (f :: 'a \<Rightarrow> ('a + 'b) \<times> bool) \<equiv>
     tailrec (theLeft o fst o f) (theRight o fst o f) (isLeft o fst o f)"

definition
  "short_tailrec_pair stp v = (short_tailrec_pre stp v, short_tailrec stp v)"

lemma tailrec_pre_lemma:
  "!f1 g p x. tailrec_pre f1 g p (x::'a) = (p x \<and> (g x \<longrightarrow> tailrec_pre f1 g p (f1 x)))"
  apply (clarsimp simp add: tailrec_pre_def)
  apply (rule iffI)
   apply (rule conjI)
    apply auto[1]
   apply clarsimp
   apply (rule conjI[rotated])
    apply (case_tac n)
     apply simp
    apply (clarsimp simp: funpow_swap1)
    apply auto[1]
   apply clarsimp
   apply (drule_tac x="Suc n" for n in spec, simp add: funpow_swap1)
   apply (erule mp)
   apply clarsimp
   apply (case_tac m, simp_all add: funpow_swap1)[1]
  apply (case_tac "g x")
   apply clarsimp
   apply (rule conjI)
    apply clarsimp
    apply (case_tac k)
     apply auto[1]
    apply (simp_all add: funpow_swap1)[1]
    apply (erule allE, erule impE)
     prefer 2
     apply assumption
    apply (rule allI)
    apply (rule impI)
    apply (drule_tac x="Suc m" in spec, simp_all add: funpow_swap1)
   apply (rule_tac x="Suc n" in exI)
   apply (simp add: funpow_swap1)
  apply (rule conjI)
   prefer 2
   apply (rule_tac x="0" in exI)
   apply auto[1]
  apply (rule allI)
  apply (rule impI)
  apply (case_tac k)
  apply auto
  done

lemma tailrec_pre_lemmata:
  "g x \<Longrightarrow> tailrec_pre f1 g p (x::'a) = (p x \<and> tailrec_pre f1 g p (f1 x))"
  "\<not> g x \<Longrightarrow> tailrec_pre f1 g p (x::'a) = p x"
  by (metis tailrec_pre_lemma)+

theorem short_tailrec_thm:
  "\<forall>f x. short_tailrec f x = (if isLeft (fst (f x))
     then short_tailrec f (theLeft (fst (f x)))
     else theRight (fst (f x))) \<and>
   (short_tailrec_pre f x = (snd (f x)
     \<and> (isLeft (fst (f x)) \<longrightarrow> short_tailrec_pre f (theLeft (fst (f x))))))"
  apply (clarsimp simp add: short_tailrec_pre_def short_tailrec_def)
  apply (simp add: tailrec_pre_lemmata tailrec_steps)
  done

lemma short_tailrec_pair_single_step:
  "\<forall>v. \<not> isLeft (fst (f v))
    \<Longrightarrow> short_tailrec_pair f = (\<lambda>v. let (rv, b) = (f v) in (b, theRight rv))"
  apply (rule ext)
  apply (simp add: short_tailrec_pair_def split_def Let_def)
  apply (simp add: short_tailrec_thm cong: imp_cong[OF _ refl] if_weak_cong)
  done

lemma eq_true_imp:
  "(x ==  Trueprop True) ==> PROP x"
  apply auto
  done

lemma forall_true:
  "(!x. True) = True"
  apply auto
  done

lemmas split_thm = split_conv

definition
  line_number :: "word32 \<Rightarrow> bool"
where
  "line_number n \<equiv> True"

end


(*
 * Copyright (c) 2020, CleanQ Project - Systems Group, ETH Zurich
 * All rights reserved.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 *
 * See "LICENSE" for details.
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>CleanQ List Model to Ring Buffer Model refinement COMPLEX to SIMPLE\<close>

text \<open>
  The second refinement is from unbounded lists to bounded buffer rings for transferring
  ownership between two agents.
\<close>

theory CleanQ_ListRBRefinement
(*<*) imports
  "../Refinements"
  CleanQ_ListModel
  CleanQ_RBModel
  CleanQ_SetListRefinement (* Only for the pre condition of the lists*)
begin
(*>*)

(* ==================================================================================== *)
subsection \<open>RB Pre- and post- conditions\<close>
(* ==================================================================================== *)

definition CleanQ_RB_enq_x_pre :: "'a set \<Rightarrow> 'a \<Rightarrow> ('a CleanQ_RB_State, 'a CleanQ_RB_State) Semantic.xstate set"
  where "CleanQ_RB_enq_x_pre K b =  Semantic.Normal ` {rb. CleanQ_RB_Invariants K rb \<and> CleanQ_RB_enq_x_possible rb \<and> b \<in> rSX rb }"

definition CleanQ_RB_enq_y_pre :: "'a set \<Rightarrow> 'a \<Rightarrow> ('a CleanQ_RB_State, 'a CleanQ_RB_State) Semantic.xstate set"
  where "CleanQ_RB_enq_y_pre K b = Semantic.Normal ` {rb. CleanQ_RB_Invariants K rb \<and> CleanQ_RB_enq_y_possible rb \<and> b \<in> rSY rb}"

definition CleanQ_RB_deq_x_pre :: "'a set \<Rightarrow> 'a \<Rightarrow> ('a CleanQ_RB_State, 'a CleanQ_RB_State) Semantic.xstate set"
  where "CleanQ_RB_deq_x_pre K buf = Semantic.Normal ` {rb. CleanQ_RB_Invariants K rb \<and> CleanQ_RB_deq_x_possible rb \<and>
                                                        buf = rb_read_tail (rTYX rb)}"
definition CleanQ_RB_deq_y_pre :: "'a set \<Rightarrow> 'a \<Rightarrow> ('a CleanQ_RB_State, 'a CleanQ_RB_State) Semantic.xstate set"
  where "CleanQ_RB_deq_y_pre K buf = Semantic.Normal ` {rb. CleanQ_RB_Invariants K rb \<and> CleanQ_RB_deq_y_possible rb \<and>
                                                        buf = rb_read_tail (rTXY rb)}"

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Enqueue Refinement\<close>
(* ------------------------------------------------------------------------------------ *)

lemma
  CleanQ_listRBRefinement_enq_x:
  assumes precond: "Semantic.xstate.Normal sc \<in> CleanQ_RB_enq_x_pre K buf"
  shows
  "((\<Gamma>a, CleanQ_List_enq_x_pre K buf, Language.Basic (CleanQ_List_enq_x buf)),
                               (\<Gamma>c, CleanQ_RB_enq_x_pre K buf, Language.Basic (CleanQ_RB_enq_x buf)))
                               \<in> refinement_s (separable_lift CleanQ_RB2List CleanQ_RB2List)"
  apply(rule refinement_s_BasicI) (* Problem applying this after unfolding*)
  unfolding separable_lift_def
proof -
   show "\<And>sc. Semantic.xstate.Normal sc \<in> CleanQ_RB_enq_x_pre K buf \<Longrightarrow> CleanQ_RB2List (CleanQ_RB_enq_x buf sc) = CleanQ_List_enq_x buf (CleanQ_RB2List sc)"
     using precond CleanQ_RB_enq_x_equal
     using CleanQ_RB_enq_x_pre_def by fastforce
 next
   have core_g2: "Semantic.xstate.Normal (CleanQ_RB2List sc) \<in> CleanQ_List_enq_x_pre K buf" using precond
   proof -
     fix b
     have b_in_sx: "b \<in> (rSX sc) \<Longrightarrow> b \<in> lSX (CleanQ_RB2List sc)"
       by (simp add: CleanQ_RB2List_def)
     have b_notin_txy: "b \<in> (rSX sc) \<Longrightarrow> b \<notin> set (lTXY (CleanQ_RB2List sc))"
       using precond
       unfolding CleanQ_RB_enq_x_pre_def CleanQ_RB2List_def
       using CleanQ_RB_Invariants_def I2_rb_img_def by fastforce

     have final: "Semantic.xstate.Normal sc \<in> CleanQ_RB_enq_x_pre K buf \<Longrightarrow> Semantic.xstate.Normal (CleanQ_RB2List sc) \<in> CleanQ_List_enq_x_pre K buf"
       using b_in_sx b_notin_txy precond unfolding CleanQ_RB2List_def CleanQ_RB_enq_x_pre_def CleanQ_List_enq_x_pre_def
       by (smt CleanQ_List_State.select_convs(1) CleanQ_List_State.select_convs(3) CleanQ_RB2List_def
           CleanQ_RB_Invariants_List_Invariants CleanQ_RB_Invariants_def CollectD CollectI I2_rb_img_def
           Semantic.xstate.inject(1) Set.set_insert disjoint_insert(1) imageE imageI)

     show ?thesis using final precond
       by blast
   qed
   show "Semantic.xstate.case_xstate (\<lambda>sc. Semantic.xstate.Normal (CleanQ_RB2List sc)) (\<lambda>sc. Abrupt (CleanQ_RB2List sc)) (\<lambda>fc. Semantic.xstate.Fault (CleanQ_RB2List fc))
     Semantic.xstate.Stuck ` CleanQ_RB_enq_x_pre K buf \<subseteq> CleanQ_List_enq_x_pre K buf"
     using core_g2 CleanQ_RB_Invariants_List_Invariants unfolding CleanQ_RB_enq_x_pre_def CleanQ_List_enq_x_pre_def
     by (smt CleanQ_List_State.select_convs(1) CleanQ_List_State.select_convs(3) CleanQ_RB2List_def CleanQ_RB_Invariants_def
         CollectI I2_rb_img_def Semantic.xstate.simps(16) disjoint_iff_not_equal image_Collect_subsetI image_def image_image)

qed

lemma
  CleanQ_listRBRefinement_enq_y:
  assumes precond: "Semantic.xstate.Normal sc \<in> CleanQ_RB_enq_y_pre K buf"
  shows
  "((\<Gamma>a, CleanQ_List_enq_y_pre K buf, Language.Basic (CleanQ_List_enq_y buf)),
                               (\<Gamma>c, CleanQ_RB_enq_y_pre K buf, Language.Basic (CleanQ_RB_enq_y buf)))
                               \<in> refinement_s (separable_lift CleanQ_RB2List CleanQ_RB2List)"
  apply(rule refinement_s_BasicI) (* Problem applying this after unfolding*)
  unfolding separable_lift_def
proof -
   show "\<And>sc. Semantic.xstate.Normal sc \<in> CleanQ_RB_enq_y_pre K buf \<Longrightarrow> CleanQ_RB2List (CleanQ_RB_enq_y buf sc) = CleanQ_List_enq_y buf (CleanQ_RB2List sc)"
     using precond CleanQ_RB_enq_y_equal
     using CleanQ_RB_enq_y_pre_def by fastforce
 next
   have core_g2: "Semantic.xstate.Normal (CleanQ_RB2List sc) \<in> CleanQ_List_enq_y_pre K buf" using precond
   proof -
     fix b
     have b_in_sx: "b \<in> (rSY sc) \<Longrightarrow> b \<in> lSY (CleanQ_RB2List sc)"
       by (simp add: CleanQ_RB2List_def)
     have b_notin_tyx: "b \<in> (rSY sc) \<Longrightarrow> b \<notin> set (lTYX (CleanQ_RB2List sc))"
       using precond
       unfolding CleanQ_RB_enq_y_pre_def CleanQ_RB2List_def
       using CleanQ_RB_Invariants_def I2_rb_img_def by fastforce

     have final: "Semantic.xstate.Normal sc \<in> CleanQ_RB_enq_y_pre K buf \<Longrightarrow> Semantic.xstate.Normal (CleanQ_RB2List sc) \<in> CleanQ_List_enq_y_pre K buf"
       using b_in_sx b_notin_tyx precond unfolding CleanQ_RB2List_def CleanQ_RB_enq_y_pre_def CleanQ_List_enq_y_pre_def
       by (smt CleanQ_List_State.select_convs(2) CleanQ_List_State.select_convs(4) CleanQ_RB2List_def
           CleanQ_RB_Invariants_List_Invariants CleanQ_RB_Invariants_def CollectD CollectI I2_rb_img_def
           Semantic.xstate.inject(1) Set.set_insert disjoint_insert(1) imageE imageI)

     show ?thesis using final precond
       by simp
   qed
   show "Semantic.xstate.case_xstate (\<lambda>sc. Semantic.xstate.Normal (CleanQ_RB2List sc)) (\<lambda>sc. Abrupt (CleanQ_RB2List sc)) (\<lambda>fc. Semantic.xstate.Fault (CleanQ_RB2List fc))
     Semantic.xstate.Stuck ` CleanQ_RB_enq_y_pre K buf \<subseteq> CleanQ_List_enq_y_pre K buf"
     using core_g2 CleanQ_RB_Invariants_List_Invariants unfolding CleanQ_RB_enq_y_pre_def CleanQ_List_enq_y_pre_def
     by (smt CleanQ_List_State.select_convs(2) CleanQ_List_State.select_convs(4) CleanQ_RB2List_def
         CleanQ_RB_Invariants_def CollectD CollectI I2_rb_img_def Semantic.xstate.simps(16)
         disjoint_iff_not_equal image_iff image_subsetI)

qed

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Dequeue Refinement\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  We first show some helper lemmas that connect the two preconditions on the Ring buffer
  model and the List model.
\<close>

lemma
  refine_hd_list_tl_ring_tyx:
  fixes buf sc
  assumes precond: "Semantic.xstate.Normal sc \<in> CleanQ_RB_deq_x_pre K buf"
  shows "buf = the (ring (rTYX sc) (tail (rTYX sc))) \<Longrightarrow> buf = hd (lTYX (CleanQ_RB2List sc))"
  using precond unfolding CleanQ_RB2List_def
  apply auto
  by (metis (mono_tags, lifting) CleanQ_RB_Invariants_def CleanQ_RB_deq_x_possible_def CleanQ_RB_deq_x_pre_def
      CollectD I4_rb_valid_def imageE prod.sel(1) rb_deq_def rb_deq_list_was_head state_simps(1))

lemma
  refine_hd_list_tl_ring_txy:
  fixes buf sc
  assumes precond: "Semantic.xstate.Normal sc \<in> CleanQ_RB_deq_y_pre K buf"
  shows "buf = the (ring (rTXY sc) (tail (rTXY sc))) \<Longrightarrow> buf = hd (lTXY (CleanQ_RB2List sc))"
  using precond unfolding CleanQ_RB2List_def CleanQ_RB_deq_y_pre_def
  apply auto
  by (metis (no_types) CleanQ_RB_Invariants_def CleanQ_RB_deq_y_possible_def I4_rb_valid_def prod.sel(1)
      rb_deq_def rb_deq_list_was_head)

lemma
  deq_x_rb_pre_implies_list_pre:
  assumes precond: "Semantic.xstate.Normal sc \<in> CleanQ_RB_deq_x_pre K buf"
  shows "CleanQ_RB_Invariants K sc \<and> buf = the (ring (rTYX sc) (tail (rTYX sc))) \<and> \<not> rb_empty (rTYX sc)
         \<Longrightarrow> CleanQ_List_Invariants K (CleanQ_RB2List sc) \<and> buf = hd (lTYX (CleanQ_RB2List sc)) \<and> lTYX (CleanQ_RB2List sc) \<noteq> []"
proof -
   have precond_buf: " buf = hd (lTYX (CleanQ_RB2List sc)) \<longleftrightarrow> buf = the (ring (rTYX sc) (tail (rTYX sc)))"
       using refine_hd_list_tl_ring_tyx precond
       by (smt CleanQ_RB_deq_x_pre_def CollectD Semantic.xstate.inject(1) imageE rb_read_tail_def)

   have non_empty: "CleanQ_RB_deq_x_possible sc \<Longrightarrow> lTYX (CleanQ_RB2List sc) \<noteq> []"
     using precond unfolding CleanQ_RB_deq_x_possible_def CleanQ_RB2List_def CleanQ_RB_deq_x_pre_def
     using CleanQ_RB_Invariants_def I4_rb_valid_def rb_deq_not_empty by fastforce

   show ?thesis  using non_empty precond_buf CleanQ_RB_Invariants_List_Invariants
     using precond non_empty refine_hd_list_tl_ring_tyx precond_buf
     unfolding CleanQ_RB2List_def CleanQ_RB_deq_x_pre_def CleanQ_List_deq_x_pre_def
     by (smt CollectD imageE rb_read_tail_def state_simps(1))
 qed

lemma
  deq_y_rb_pre_implies_list_pre:
  assumes precond: "Semantic.xstate.Normal sc \<in> CleanQ_RB_deq_y_pre K buf"
  shows "CleanQ_RB_Invariants K sc \<and> buf = the (ring (rTXY sc) (tail (rTXY sc))) \<and> \<not> rb_empty (rTXY sc)
         \<Longrightarrow> CleanQ_List_Invariants K (CleanQ_RB2List sc) \<and> buf = hd (lTXY (CleanQ_RB2List sc)) \<and> lTXY (CleanQ_RB2List sc) \<noteq> []"
proof -
   have precond_buf: " buf = hd (lTXY (CleanQ_RB2List sc)) \<longleftrightarrow> buf = the (ring (rTXY sc) (tail (rTXY sc)))"
     using refine_hd_list_tl_ring_txy precond unfolding CleanQ_RB_deq_y_pre_def
     by (smt CollectD imageE precond rb_read_tail_def refine_hd_list_tl_ring_txy state_simps(1))

   have non_empty: "CleanQ_RB_deq_y_possible sc \<Longrightarrow> lTXY (CleanQ_RB2List sc) \<noteq> []"
     using precond unfolding CleanQ_RB_deq_y_possible_def
     by (smt CleanQ_List_State.select_convs(3) CleanQ_RB2List_def CleanQ_RB_Invariants_def
         CleanQ_RB_deq_y_pre_def CollectD I4_rb_valid_def image_def rb_deq_not_empty state_simps(1))

   show ?thesis  using non_empty precond_buf CleanQ_RB_Invariants_List_Invariants
     using precond non_empty refine_hd_list_tl_ring_txy precond_buf
     unfolding CleanQ_RB2List_def CleanQ_RB_deq_y_pre_def CleanQ_List_deq_y_pre_def
     by (smt CollectD imageE rb_read_tail_def state_simps(1))
 qed

text \<open>
  Finally the proofs for the Dequeue refinement.
\<close>

lemma
  CleanQ_listRBRefinement_deq_x:
  assumes precond: "Semantic.xstate.Normal sc \<in> CleanQ_RB_deq_x_pre K buf"
  shows
  "((\<Gamma>a, CleanQ_List_deq_x_pre K buf, Language.Basic (CleanQ_List_deq_x)),
    (\<Gamma>c, CleanQ_RB_deq_x_pre K buf, Language.Basic (CleanQ_RB_deq_x)))
                               \<in> refinement_s (separable_lift CleanQ_RB2List CleanQ_RB2List)"
  apply(rule refinement_s_BasicI) (* Problem applying this after unfolding*)
  unfolding separable_lift_def
proof auto
    show "\<And>sc. Semantic.xstate.Normal sc \<in> CleanQ_RB_deq_x_pre K buf \<Longrightarrow> CleanQ_RB2List (CleanQ_RB_deq_x sc) = CleanQ_List_deq_x (CleanQ_RB2List sc)"
    using CleanQ_RB_deq_x_equal
    by (smt CleanQ_RB_deq_x_pre_def CollectD image_def state_simps(1))
next
   have core: "\<And>x. Semantic.xstate.Normal x \<in> CleanQ_RB_deq_x_pre K buf \<Longrightarrow> Semantic.xstate.Normal (CleanQ_RB2List x)
         \<in> CleanQ_List_deq_x_pre K buf"
       using deq_x_rb_pre_implies_list_pre precond CleanQ_RB_Invariants_List_Invariants
       unfolding CleanQ_RB_deq_x_pre_def CleanQ_List_deq_x_pre_def CleanQ_RB_deq_x_possible_def
                 rb_can_deq_def rb_read_tail_def
       by (smt CleanQ_RB_deq_x_pre_def CollectD CollectI imageE image_eqI rb_can_deq_def rb_read_tail_def state_simps(1))

   show "\<And>xa. xa \<in> CleanQ_RB_deq_x_pre K buf \<Longrightarrow>
          (case xa of Semantic.xstate.Normal sc \<Rightarrow> Semantic.xstate.Normal (CleanQ_RB2List sc) | Abrupt sc \<Rightarrow> Abrupt (CleanQ_RB2List sc) | Semantic.xstate.Fault fc \<Rightarrow> Semantic.xstate.Fault (CleanQ_RB2List fc)
           | Semantic.xstate.Stuck \<Rightarrow> Semantic.xstate.Stuck)
          \<in> CleanQ_List_deq_x_pre K buf"
     unfolding CleanQ_RB_deq_x_pre_def CleanQ_List_deq_x_pre_def
     apply (auto)
     using core precond unfolding CleanQ_RB_deq_x_pre_def CleanQ_List_deq_x_pre_def
     by auto
 qed

lemma
  CleanQ_listRBRefinement_deq_y:
  assumes precond: "Semantic.xstate.Normal sc \<in> CleanQ_RB_deq_y_pre K buf"
  shows
  "((\<Gamma>a, CleanQ_List_deq_y_pre K buf, Language.Basic (CleanQ_List_deq_y)),
    (\<Gamma>c, CleanQ_RB_deq_y_pre K buf, Language.Basic (CleanQ_RB_deq_y)))
                               \<in> refinement_s (separable_lift CleanQ_RB2List CleanQ_RB2List)"
  apply(rule refinement_s_BasicI) (* Problem applying this after unfolding*)
  unfolding separable_lift_def
proof auto
    show "\<And>sc. Semantic.xstate.Normal sc \<in> CleanQ_RB_deq_y_pre K buf \<Longrightarrow> CleanQ_RB2List (CleanQ_RB_deq_y sc) = CleanQ_List_deq_y (CleanQ_RB2List sc)"
    using CleanQ_RB_deq_y_equal
    by (smt CleanQ_RB_deq_y_pre_def CollectD image_def state_simps(1))
next
   have core: "\<And>x. Semantic.xstate.Normal x \<in> CleanQ_RB_deq_y_pre K buf \<Longrightarrow> Semantic.xstate.Normal (CleanQ_RB2List x)
         \<in> CleanQ_List_deq_y_pre K buf"
       using deq_y_rb_pre_implies_list_pre precond CleanQ_RB_Invariants_List_Invariants
       unfolding CleanQ_RB_deq_y_pre_def CleanQ_List_deq_y_pre_def CleanQ_RB_deq_y_possible_def
                 rb_can_deq_def rb_read_tail_def
       by (smt CleanQ_RB_deq_y_pre_def CollectD CollectI imageE image_eqI rb_can_deq_def rb_read_tail_def state_simps(1))

   show "\<And>xa. xa \<in> CleanQ_RB_deq_y_pre K buf \<Longrightarrow>
          (case xa of Semantic.xstate.Normal sc \<Rightarrow> Semantic.xstate.Normal (CleanQ_RB2List sc) | Abrupt sc \<Rightarrow> Abrupt (CleanQ_RB2List sc) | Semantic.xstate.Fault fc \<Rightarrow> Semantic.xstate.Fault (CleanQ_RB2List fc)
           | Semantic.xstate.Stuck \<Rightarrow> Semantic.xstate.Stuck)
          \<in> CleanQ_List_deq_y_pre K buf"
     unfolding CleanQ_RB_deq_y_pre_def CleanQ_List_deq_x_pre_def
     apply (auto)
     using core precond unfolding CleanQ_RB_deq_y_pre_def CleanQ_List_deq_y_pre_def
     by auto
qed

end


theory ext_BigStepContinuous
  imports ext_BigStepSimple
begin

subsection \<open>Hoare rules for ODE\<close>

text \<open>Weakest precondition form\<close>
theorem Valid_ode:
  "Valid
    (\<lambda>(a,s) tr. (\<not>b s \<longrightarrow> Q (a,s) tr) \<and>
            (\<forall>d p. 0 < d \<longrightarrow> ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow> (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow> \<not>b (p d) \<longrightarrow>
                   Q (a,p d) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})])))
    (Cont ode b)
    Q"
  unfolding Valid_def
  apply (auto elim!: contE)
  done

subsection \<open>Hoare rules for interrupt\<close>

text \<open>Weakest precondition form\<close>
theorem Valid_interrupt:
  assumes "\<And>i. i < length cs \<Longrightarrow>
    case cs ! i of
      (ch[!]e, p2) \<Rightarrow>
        (\<exists>Q. \<Turnstile> {Q} p2 {R} \<and>
             (P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. Q (a,s) (tr @ [OutBlock ch (e (a,s))]))) \<and>
             (P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
                        (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
                        Q (a,p d) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs),
                                       OutBlock ch (e (a,p d))]))))
    | (ch[?]var, p2) \<Rightarrow>
        (\<exists>Q. \<Turnstile> {Q} p2 {R} \<and>
             (P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>v. Q (a,s(var := v)) (tr @ [InBlock ch v]))) \<and>
             (P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>d>0. \<forall>p v. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
                        (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
                        Q (a,(p d)(var := v)) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs),
                                                   InBlock ch v]))))"
    and "P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<not>b s \<longrightarrow> R (a,s) tr)"
    and "P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. (\<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
                   (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow> \<not>b (p d) \<longrightarrow>
                   R (a,p d) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs)])))"
  shows "\<Turnstile> {P} Interrupt ode b cs {R}"
proof -
  have a: "R s2 (tr1 @ OutBlock ch (e s1) # tr2)"
    if *: "P s1 tr1"
          "i < length cs"
          "cs ! i = (ch[!]e, p2)"
          "big_step p2 s1 tr2 s2" for s1 tr1 s2 i ch e p2 tr2
  proof -
    from assms obtain Q where 1:
      "\<Turnstile> {Q} p2 {R}"
      "P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. Q (a,s) (tr @ [OutBlock ch (e (a,s))]))"
      using *(2,3) by fastforce
    have 2: "Q s1 (tr1 @ [OutBlock ch (e s1)])"
      using 1(2) *(1) unfolding entails_def
      by blast
    then show ?thesis
      using *(4) 1(1) unfolding Valid_def by fastforce
  qed
  have b: "R s2 (tr1 @ WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs) # OutBlock ch (e (a,p d)) # tr2)"
    if *: "P (a,p 0) tr1"
          "0 < d"
          "ODEsol ode p d"
          "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)"
          "i < length cs"
          "cs ! i = (ch[!]e, p2)"
          "big_step p2 (a,p d) tr2 s2" for a tr1 s2 d p i ch e p2 tr2
  proof -
    from assms obtain Q where 1:
      "\<Turnstile> {Q} p2 {R}"
      "P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
                 (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
                 Q (a,p d) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs),
                                OutBlock ch (e (a,p d))]))"
      using *(5,6) by fastforce
    have "Q (a,p d) (tr1 @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs),
                          OutBlock ch (e (a,p d))])"
      using 1(2) *(1-4) unfolding entails_def by auto
    then show ?thesis
      using *(7) 1(1) unfolding Valid_def by fastforce
  qed
  have c: "R s2 (tr1 @ InBlock ch v # tr2)"
    if *: "P (a1,s1) tr1"
          "i < length cs"
          "cs ! i = (ch[?]var, p2)"
          "big_step p2 (a1,s1(var := v)) tr2 s2" for a1 s1 tr1 s2 i ch var p2 v tr2
  proof -
    from assms obtain Q where 1:
      "\<Turnstile> {Q} p2 {R}"
      "P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>v. Q (a,s(var := v)) (tr @ [InBlock ch v]))"
      using *(2,3) by fastforce
    have 2: "Q (a1,s1(var := v)) (tr1 @ [InBlock ch v])"
      using 1(2) *(1) unfolding entails_def by auto
    then show ?thesis
      using *(4) 1(1) unfolding Valid_def by fastforce
  qed
  have d: "R s2 (tr1 @ WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs) # InBlock ch v # tr2a)"
    if *: "P (a,p 0) tr1"
          "0 < d"
          "ODEsol ode p d"
          "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)"
          "i < length cs"
          "cs ! i = (ch[?]var, p2)"
          "big_step p2 (a,(p d)(var := v)) tr2a s2" for a tr1 s2 d p i ch var p2 v tr2a
  proof -
    from assms obtain Q where 1:
      "\<Turnstile> {Q} p2 {R}"
      "P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>d>0. \<forall>p v. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
                 (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
                 Q (a,(p d)(var := v)) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs),
                                            InBlock ch v]))"
      using *(5,6) by fastforce
    have "Q (a,(p d)(var := v)) (tr1 @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs), InBlock ch v])"
      using 1(2) *(1-4) unfolding entails_def by auto
    then show ?thesis
      using *(7) 1(1) unfolding Valid_def by fastforce
  qed
  show ?thesis
    unfolding Valid_def
    apply (auto elim!: interruptE)
    using a b c d assms(2-3) unfolding entails_def by auto
qed

text \<open>Simpler versions with one input/output\<close>

theorem Valid_interrupt_In:
  assumes "\<Turnstile> {Q} p {R}"
  shows "\<Turnstile>
    {\<lambda>(a,s) tr. (\<forall>v. Q (a,s(var := v)) (tr @ [InBlock ch v])) \<and>
            (\<forall>d>0. \<forall>p v. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
                (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
                Q (a,(p d)(var := v)) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {ch}),
                                           InBlock ch v])) \<and>
            (\<not>b s \<longrightarrow> R (a,s) tr) \<and>
            (\<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
                (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow> \<not>b (p d) \<longrightarrow>
                R (a,p d) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {ch})]))}
      Interrupt ode b [(ch[?]var, p)]
    {R}"
  apply (rule Valid_interrupt)
  apply auto apply (rule exI[where x=Q])
  by (auto simp add: assms entails_def)

theorem Valid_interrupt_Out:
  assumes "\<Turnstile> {Q} p {R}"
  shows "\<Turnstile>
    {\<lambda>(a,s) tr. (Q (a,s) (tr @ [OutBlock ch (e (a,s))])) \<and>
            (\<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
                (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
                Q (a,p d) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({ch}, {}),
                               OutBlock ch (e (a,p d))])) \<and>
            (\<not>b s \<longrightarrow> R (a,s) tr) \<and>
            (\<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
                (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow> \<not>b (p d) \<longrightarrow>
                R (a,p d) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({ch}, {})]))}
      Interrupt ode b [(ch[!]e, p)]
    {R}"
  apply (rule Valid_interrupt)
  apply auto apply (rule exI[where x=Q])
  by (auto simp add: assms entails_def)

subsection \<open>Assertions for ODEs\<close>

text \<open>ODE without interrupt\<close>
inductive ode_assn :: "'a ext_state \<Rightarrow> ODE \<Rightarrow> fform \<Rightarrow> 'a ext_state \<Rightarrow> 'a tassn" ("ODE\<^sub>t") where
  "\<not>b s \<Longrightarrow> ODE\<^sub>t (a,s) ode b (a,s) []"
| "0 < d \<Longrightarrow> ODEsol ode p d \<Longrightarrow> p 0 = s \<Longrightarrow> (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<Longrightarrow> \<not>b (p d) \<Longrightarrow>
     ODE\<^sub>t (a,s) ode b (a,p d) [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})]"
thm ode_assn.induct
lemmas ode_assn_induct = ode_assn.induct[split_format(complete)]
lemma ode_assn_ext_con:
"ODE\<^sub>t (a, s) ode b (a', s') tr \<Longrightarrow> a' = a"
  apply(induct rule:ode_assn_induct)
  by auto

text \<open>ODE interrupted by communication\<close>
inductive ode_in_assn :: "'a ext_state \<Rightarrow> ODE \<Rightarrow> fform \<Rightarrow> 'a ext_state \<Rightarrow> cname \<Rightarrow> var \<Rightarrow> rdy_info \<Rightarrow> 'a tassn" ("ODEin\<^sub>t") where
  "ODEin\<^sub>t (a,s) ode b (a,s(var := v)) ch var rdy [InBlock ch v]"
| "0 < d \<Longrightarrow> ODEsol ode p d \<Longrightarrow> p 0 = s \<Longrightarrow>
    \<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t) \<Longrightarrow>
    ODEin\<^sub>t (a,s) ode b (a,(p d)(var := v)) ch var rdy
      [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) rdy, InBlock ch v]"
lemmas ode_in_assn_induct = ode_in_assn.induct[split_format(complete)]

inductive ode_out_assn :: "'a ext_state \<Rightarrow> ODE \<Rightarrow> fform \<Rightarrow> 'a ext_state \<Rightarrow> cname \<Rightarrow> 'a ext_exp \<Rightarrow> rdy_info \<Rightarrow> 'a tassn" ("ODEout\<^sub>t") where
  "ODEout\<^sub>t (a,s) ode b (a,s) ch e rdy [OutBlock ch (e (a,s))]"
| "0 < d \<Longrightarrow> ODEsol ode p d \<Longrightarrow> p 0 = s \<Longrightarrow>
    \<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t) \<Longrightarrow>
    ODEout\<^sub>t (a,s) ode b (a,p d) ch e rdy
      [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) rdy, OutBlock ch (e (a,p d))]"
lemmas ode_out_assn_induct = ode_out_assn.induct[split_format(complete)]

text \<open>ODE with interrupt, but reached boundary\<close>
inductive ode_rdy_assn :: "'a ext_state \<Rightarrow> ODE \<Rightarrow> fform \<Rightarrow> 'a ext_state \<Rightarrow> rdy_info \<Rightarrow> 'a tassn" ("ODErdy\<^sub>t") where
  "\<not>b s \<Longrightarrow> ODErdy\<^sub>t (a,s) ode b (a,s) rdy []"
| "0 < d \<Longrightarrow> ODEsol ode p d \<Longrightarrow> p 0 = s \<Longrightarrow>
    \<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t) \<Longrightarrow> \<not>b (p d) \<Longrightarrow>
    ODErdy\<^sub>t (a,s) ode b (a,p d) rdy
      [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) rdy]"

subsection \<open>Simpler rules for ODE\<close>

theorem Valid_ode':
  "\<Turnstile> {\<lambda>(a,s) tr. \<forall>s'. (ODE\<^sub>t (a,s) ode b (a,s') @- Q (a,s')) tr}
       Cont ode b
      {Q}"
proof -
  have 1: "Q (a,s) tr"
    if "\<forall>s'. (ODE\<^sub>t (a,s) ode b (a,s') @- Q (a,s')) tr" "\<not> b s" for a s tr
  proof -
    have "(ODE\<^sub>t (a,s) ode b (a,s) @- Q (a,s)) tr"
      using that(1) by auto
    moreover have "ODE\<^sub>t (a,s) ode b (a,s) []"
      using that(2) by (auto intro: ode_assn.intros)
    ultimately show ?thesis
      by (auto simp add: magic_wand_assn_def)
  qed
  have 2: "Q (a,p d) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})])"
    if "\<forall>s'. (ODE\<^sub>t (a,p 0) ode b (a,s') @- Q (a,s')) tr"
       "0 < d" "ODEsol ode p d" "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)" "\<not> b (p d)" for a p d tr
  proof -
    have "(ODE\<^sub>t (a,p 0) ode b (a,p d) @- Q (a,p d)) tr"
      using that(1) by auto
    moreover have "ODE\<^sub>t (a,p 0) ode b (a,p d) [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})]"
      apply (rule ode_assn.intros)
      using that by auto
    ultimately show ?thesis
      by (auto simp add: magic_wand_assn_def)
  qed
  show ?thesis
    apply (rule Valid_weaken_pre)
     prefer 2 apply (rule Valid_ode)
    unfolding entails_def using 1 2 by auto
qed

text \<open>Strongest postcondition rule for ODE\<close>
theorem Valid_ode_sp:
  "\<Turnstile> {\<lambda>s t. P s t}
        Cont ode b
      {\<lambda>s t. \<exists>s'. (P s' @\<^sub>t ODE\<^sub>t s' ode b s) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_ode')
  by (auto simp add: entails_def magic_wand_assn_def join_assn_def)

theorem Valid_ode_sp':
  "\<Turnstile> {\<lambda>(a,s) t. P (a,s) t}
        Cont ode b
      {\<lambda>(a,s) t. \<exists>s'. (P (a,s') @\<^sub>t ODE\<^sub>t (a,s') ode b (a,s)) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_ode')
  by (auto simp add: entails_def magic_wand_assn_def join_assn_def)

text \<open>Strongest postcondition rule for ODE with fixed initial state\<close>
theorem Valid_ode_sp_st:
  "\<Turnstile> {\<lambda>s t. s = (a0,s0) \<and> Q s t}
        Cont ode b
      {\<lambda>s t. (Q (a0,s0) @\<^sub>t ODE\<^sub>t (a0,s0) ode b s) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_ode')
  apply (auto simp add: entails_def)
  using entails_mp by (auto simp add: entails_tassn_def)

theorem Valid_ode_sp_st':
  "\<Turnstile> {\<lambda>(a,s) t. s = s0 \<and> Q (a,s) t}
        Cont ode b
      {\<lambda>(a,s) t. (Q (a,s0) @\<^sub>t ODE\<^sub>t (a,s0) ode b (a,s)) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_ode')
  apply (auto simp add: entails_def)
  using entails_mp by (auto simp add: entails_tassn_def)

text \<open>Auxiliary lemma, converting ODE assertion to Wait assertion
  when the ODE can be solved exactly.
\<close>
theorem Valid_ode_unique_solution_aux:
  assumes
    "d > 0" "ODEsol ode p d" "\<forall>t. t \<ge> 0 \<and> t < d \<longrightarrow> b (p t)"
    "\<not> b (p d)" "p 0 = st"
    "local_lipschitz {- 1<..} UNIV (\<lambda>(t::real) v. ODE2Vec ode (vec2state v))"
    "ODE\<^sub>t (a,st) ode b (a,st') tr"
  shows
    "st' = p d \<and> Wait\<^sub>t d (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {}) tr"
proof -
  have "b st"
    using assms(1,3,5) by auto
  have main: "d2 = d \<and> p d = p2 d2 \<and> (\<lambda>\<tau>\<in>{0..d}. EState (a,p \<tau>)) = (\<lambda>\<tau>\<in>{0..d2}. EState (a,p2 \<tau>)) \<and>
              Wait\<^sub>t d (\<lambda>s. EState (a,p s)) ({}, {}) [WaitBlk d2 (\<lambda>\<tau>. EState (a,p2 \<tau>)) ({}, {})]"
    if cond: "0 < d2"
       "ODEsol ode p2 d2"
       "(\<forall>t. 0 \<le> t \<and> t < d2 \<longrightarrow> b (p2 t))"
       "\<not> b (p2 d2)"
       "p2 0 = st" for p2 d2
  proof -
    interpret loc:ll_on_open_it "{-1<..}"
      "\<lambda>t v. ODE2Vec ode (vec2state v)" UNIV 0
      apply standard
      using assms(6) by auto
    have s1: "((\<lambda>t. state2vec (p t)) solves_ode ((\<lambda>t v. ODE2Vec ode (vec2state v)))) {0..d} UNIV"
      using assms(2) using ODEsol_old[OF assms(2)] unfolding ODEsol_def solves_ode_def by auto
    have s2: "(loc.flow 0 (state2vec st)) t = (\<lambda>t. state2vec (p t)) t" if "t \<in> {0..d}" for t
      apply (rule loc.maximal_existence_flow(2)[OF s1])
      using that by (auto simp add: state2vec_def assms(1,5))
    have s3: "((\<lambda>t. state2vec(p2 t)) solves_ode ((\<lambda>t v. ODE2Vec ode (vec2state v)))) {0..d2} UNIV"
      using cond(2) using ODEsol_old[OF cond(2)] unfolding ODEsol_def solves_ode_def by auto
    have s4: "loc.flow 0 (state2vec st) t = state2vec (p2 t)" if "t\<in>{0..d2}" for t
      apply (rule loc.maximal_existence_flow(2)[OF s3])
      using cond(1,5) that by auto
    have s5: "d \<le> d2"
    proof (rule ccontr)
      assume 0: "\<not>(d \<le> d2)"
      from 0 have 1: "(\<lambda>t. state2vec (p t)) d2 = (\<lambda>t. state2vec (p2 t)) d2"
        using s2[of d2] s4[of d2] cond(1) by auto
      from 1 have "p d2 = p2 d2"
        by (auto simp add: state2vec_def)
      show False
        using "0" \<open>p d2 = p2 d2\<close> assms(3) that(1) that(4)
        using less_eq_real_def by auto
    qed
    have s6: "d2 \<le> d"
    proof (rule ccontr)
      assume 0: "\<not>(d2 \<le> d)"
      from 0 have 1: "(\<lambda>t. state2vec (p t)) d = (\<lambda>t. state2vec (p2 t)) d"
        using s2[of d] s4[of d] assms(1) by auto
      from 1 have "p d = p2 d"
        by (auto simp add: state2vec_def)
      show False
        using "0" \<open>p d = p2 d\<close> assms(1) assms(4) that(3) by auto
    qed
    have s7: "d = d2" using s5 s6 by auto
    have s8: "t\<in>{0..d} \<Longrightarrow> p2 t = p t" for t
      using s2 s4 s7 by (metis vec_state_map1)
    have s10: "p d = p2 d"
      using s8 by (simp add: assms(1) less_eq_real_def)
    have s11: "WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {}) = WaitBlk d2 (\<lambda>\<tau>. EState (a,p2 \<tau>)) ({}, {})"
      apply (rule WaitBlk_ext_real) using s7 s8 by auto
    have s12: "Wait\<^sub>t d (\<lambda>s. EState (a,p s)) ({}, {}) [WaitBlk d2 (\<lambda>\<tau>. EState (a,p2 \<tau>)) ({}, {})]"
      unfolding s11[symmetric]
      apply (rule wait_assn.intros)
      using assms(1) by auto
    show ?thesis using s7 s8 s10 s12 by auto
  qed
  show ?thesis
    using assms(7) apply (auto simp add: ode_assn.simps)
    subgoal using \<open>b st\<close> by auto
    subgoal using \<open>b st\<close> by auto
    subgoal for d1 p1
      using main[of d1 p1] by auto
    subgoal for d1 p1
      using main[of d1 p1] by auto
    done
qed

text \<open>Strongest postcondition rule for ODE when the ODE can be solved exactly\<close>
theorem Valid_ode_unique_solution_sp:
  assumes "\<And>s. b s \<Longrightarrow> d s > 0 \<and> ODEsol ode (p s) (d s) \<and>
                (\<forall>t. t \<ge> 0 \<and> t < d s \<longrightarrow> b (p s t)) \<and>
                \<not>b (p s (d s)) \<and> p s 0 = s"
    and "local_lipschitz {- 1<..} UNIV (\<lambda>(t::real) v. ODE2Vec ode (vec2state v))"
  shows "\<Turnstile>
    {\<lambda>(a,s) t. P (a,s) t}
      Cont ode b
    {\<lambda>(a,s) t. \<exists>s'. if b s' then (\<up>(s = p s' (d s')) \<and>\<^sub>t P (a,s') @\<^sub>t Wait\<^sub>t (d s') (\<lambda>\<tau>. EState (a,p s' \<tau>)) ({}, {})) t
                else (\<up>(s = s') \<and>\<^sub>t P (a,s')) t}"
proof -
  have a: "s' = p s (d s) \<and> Wait\<^sub>t (d s) (\<lambda>\<tau>. EState (a,p s \<tau>)) ({}, {}) tr2"
    if "ODE\<^sub>t (a,s) ode b (a,s') tr2" "b s" for a s s' tr2
  proof -
    have a1: "d s > 0" "ODEsol ode (p s) (d s)" "\<forall>t. 0 \<le> t \<and> t < d s \<longrightarrow> b (p s t)"
             "\<not>b (p s (d s))" "p s 0 = s"
      using assms(1) that(2) by auto
    show ?thesis
      using Valid_ode_unique_solution_aux[OF a1(1-2) _ a1(4-5) assms(2) that(1)] a1(3)
      by auto
  qed
  have b: "ODE\<^sub>t (a,s) ode b (a,s') tr2 \<Longrightarrow> \<not>b s \<Longrightarrow> s = s' \<and> tr2 = []" for a s s' tr2
    apply (induct rule: ode_assn_induct) by auto
  show ?thesis
    apply (rule Valid_weaken_pre)
     prefer 2 apply (rule Valid_ode')
    apply (auto simp add: entails_def magic_wand_assn_def)
    subgoal for a s tr1 s' tr2
      apply (rule exI[where x=s])
      apply (auto simp add: join_assn_def conj_assn_def pure_assn_def)
      apply (auto simp add: a)
      using b apply metis
      using b by fastforce
    done
qed

text \<open>Strongest postcondition rule for ODE when the ODE can be solved exactly,
  for fixed initial state.
\<close>
theorem Valid_ode_unique_solution_st:
  assumes
    "d > 0" "ODEsol ode p d" "\<forall>t. t \<ge> 0 \<and> t < d \<longrightarrow> b (p t)"
    "\<not> b (p d)" "p 0 = st"
    "local_lipschitz {- 1<..} UNIV (\<lambda>(t::real) v. ODE2Vec ode (vec2state v))"
  shows "\<Turnstile>
    {\<lambda>s tr. s = (a,st) \<and> Q s tr}
      Cont ode b
    {\<lambda>s tr. s = (a,p d) \<and> (Q (a,st) @\<^sub>t Wait\<^sub>t d (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})) tr}"
proof -
  have "b st"
    using assms(1,3,5) by auto
  have *: "ODE\<^sub>t (a,st) ode b (a,s) tr2 \<Longrightarrow> s = p d \<and> Wait\<^sub>t d (\<lambda>s. EState (a,p s)) ({}, {}) tr2" for  s tr2
    using Valid_ode_unique_solution_aux[OF assms(1-6)] by metis
  show ?thesis
    apply (rule Valid_strengthen_post)
     prefer 2 apply (rule Valid_ode_sp_st)
    apply (auto simp add: \<open>b st\<close> entails_def join_assn_def * ode_assn_ext_con)
    subgoal for a' s' tr1 tr2
      using * ode_assn_ext_con by metis
    using * ode_assn_ext_con by metis
qed

text \<open>Case where the initial state does not satisfy domain\<close>
theorem Valid_ode_exit_st:
  assumes "\<not> b st"
  shows "\<Turnstile>
    {\<lambda>s tr. s = (a,st) \<and> Q tr}
      Cont ode b
    {\<lambda>s tr. s = (a,st) \<and> Q tr}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_ode)
  using assms by (auto simp add: entails_def)

subsection \<open>Simpler rules for interrupt\<close>

theorem Valid_interrupt':
  assumes "\<And>i. i < length cs \<Longrightarrow>
    case cs ! i of
      (ch[!]e, p2) \<Rightarrow>
        (\<exists>Q. \<Turnstile> {Q} p2 {R} \<and>
             (P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>s'. (ODEout\<^sub>t (a,s) ode b (a,s') ch e (rdy_of_echoice cs) @- Q (a,s')) tr)))
    | (ch[?]var, p2) \<Rightarrow>
        (\<exists>Q. \<Turnstile> {Q} p2 {R} \<and>
             (P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>s'. (ODEin\<^sub>t (a,s) ode b (a,s') ch var (rdy_of_echoice cs) @- Q (a,s')) tr)))"
    and "P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>s'. (ODErdy\<^sub>t (a,s) ode b (a,s') (rdy_of_echoice cs) @- R (a,s')) tr)"
  shows "\<Turnstile> {P} Interrupt ode b cs {R}"
proof -
  have 1: "\<exists>Q. \<Turnstile> {Q} p {R} \<and>
           (P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. Q (a,s) (tr @ [OutBlock ch (e (a,s))]))) \<and>
           (P \<Longrightarrow>\<^sub>A
            (\<lambda>(a,s) tr.
                \<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow>
                          p 0 = s \<longrightarrow>
                          (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
                          Q (a,p d) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs), OutBlock ch (e (a,p d))])))"
    if *: "i < length cs" "cs ! i = (ch[!]e, p)" for i ch e p
  proof -
    from assms(1) obtain Q where
      Q: "\<Turnstile> {Q} p {R} \<and> (P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>s'. (ODEout\<^sub>t (a,s) ode b (a,s') ch e (rdy_of_echoice cs) @- Q (a,s')) tr))"
      using * by fastforce
    show ?thesis
      apply (rule exI[where x=Q])
      using Q ode_out_assn.intros apply (auto simp add: entails_def magic_wand_assn_def)
       apply (simp add: ode_out_assn.intros(1))
      apply (simp add: ode_out_assn.intros(2))
      done
  qed
  have 2: "\<exists>Q. \<Turnstile> {Q} p {R} \<and>
           (P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>v. Q (a,s(var := v)) (tr @ [InBlock ch v]))) \<and>
           (P \<Longrightarrow>\<^sub>A
            (\<lambda>(a,s) tr.
                \<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow>
                          p 0 = s \<longrightarrow>
                          (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
                          (\<forall>v. Q (a,(p d)(var := v)) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs), InBlock ch v]))))"
    if *: "i < length cs" "cs ! i = (ch[?]var, p)" for i ch var p
  proof -
    from assms(1) obtain Q where
      Q: "\<Turnstile> {Q} p {R} \<and> (P \<Longrightarrow>\<^sub>A (\<lambda>(a,s) tr. \<forall>s'. (ODEin\<^sub>t (a,s) ode b (a,s') ch var (rdy_of_echoice cs) @- Q (a,s')) tr))"
      using * by fastforce
    show ?thesis
      apply (rule exI[where x=Q])
      using Q ode_in_assn.intros apply (auto simp add: entails_def magic_wand_assn_def)
       apply (simp add: ode_in_assn.intros(1))
      apply (simp add: ode_in_assn.intros(2))
      done
  qed
  have 3: "R (a,s) tr"
    if "\<forall>s'. (ODErdy\<^sub>t (a,s) ode b (a,s') (rdy_of_echoice cs) @- R (a,s')) tr" "\<not> b s" for a s tr
  proof -
    have "(ODErdy\<^sub>t (a,s) ode b (a,s) (rdy_of_echoice cs) @- R (a,s)) tr"
      using that(1) by auto
    moreover have "ODErdy\<^sub>t (a,s) ode b (a,s) (rdy_of_echoice cs) []"
      using that(2) by (auto intro: ode_rdy_assn.intros)
    ultimately show ?thesis
      by (auto simp add: magic_wand_assn_def)
  qed
  have 4: "R (a,p d) (tr @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs)])"
    if "\<forall>s'. (ODErdy\<^sub>t (a,p 0) ode b (a,s') (rdy_of_echoice cs) @- R (a,s')) tr"
       "0 < d" "ODEsol ode p d"
       "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)" "\<not> b (p d)" for a p d tr
  proof -
    have "(ODErdy\<^sub>t (a,p 0) ode b (a,p d) (rdy_of_echoice cs) @- R (a,p d)) tr"
      using that(1) by auto
    moreover have "ODErdy\<^sub>t (a,p 0) ode b (a,p d) (rdy_of_echoice cs) [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) (rdy_of_echoice cs)]"
      apply (rule ode_rdy_assn.intros)
      using that by auto
    ultimately show ?thesis
      by (auto simp add: magic_wand_assn_def)
  qed
  show ?thesis
    apply (rule Valid_interrupt)
    subgoal for i apply (cases "cs ! i")
      subgoal for ch p apply (cases ch)
        using 1 2 by auto
      done
    subgoal apply (rule entails_trans[OF assms(2)])
      by (auto simp add: entails_def 3)
    subgoal apply (rule entails_trans[OF assms(2)])
      by(auto simp add: 4 entails_def)
    done
qed

theorem Valid_interrupt_In':
  assumes "\<Turnstile> {Q} p {R}"
  shows "\<Turnstile>
    {\<lambda>(a,s) tr. (\<forall>s'. (ODEin\<^sub>t (a,s) ode b (a,s') ch var ({}, {ch}) @- Q (a,s')) tr) \<and>
            (\<forall>s'. (ODErdy\<^sub>t (a,s) ode b (a,s') ({}, {ch}) @- R (a,s')) tr)}
      Interrupt ode b [(ch[?]var, p)]
    {R}"
  apply (rule Valid_interrupt')
  using assms by (auto simp add: entails_def)

theorem Valid_interrupt_In'':
  assumes "\<Turnstile> {Q} p {R}"
  shows "\<Turnstile>
    {\<lambda>s tr. (\<forall>s'. (ODEin\<^sub>t s ode b s' ch var ({}, {ch}) @- Q s') tr) \<and>
            (\<forall>s'. (ODErdy\<^sub>t s ode b s' ({}, {ch}) @- R s') tr)}
      Interrupt ode b [(ch[?]var, p)]
    {R}"
  apply (rule Valid_interrupt')
  using assms by (auto simp add: entails_def)

theorem Valid_interrupt_Out':
  assumes "\<Turnstile> {Q} p {R}"
  shows "\<Turnstile>
    {\<lambda>(a,s) tr. (\<forall>s'. (ODEout\<^sub>t (a,s) ode b (a,s') ch e ({ch}, {}) @- Q (a,s')) tr) \<and>
            (\<forall>s'. (ODErdy\<^sub>t (a,s) ode b (a,s') ({ch}, {}) @- R (a,s')) tr)}
      Interrupt ode b [(ch[!]e, p)]
    {R}"
  apply (rule Valid_interrupt')
  using assms by (auto simp add: entails_def)

theorem Valid_interrupt_Out'':
  assumes "\<Turnstile> {Q} p {R}"
  shows "\<Turnstile>
    {\<lambda>s tr. (\<forall>s'. (ODEout\<^sub>t s ode b s' ch e ({ch}, {}) @- Q s') tr) \<and>
            (\<forall>s'. (ODErdy\<^sub>t s ode b s' ({ch}, {}) @- R s') tr)}
      Interrupt ode b [(ch[!]e, p)]
    {R}"
  apply (rule Valid_interrupt')
  using assms by (auto simp add: entails_def)

theorem Valid_interrupt_sp:
  assumes "\<And>i. i < length cs \<Longrightarrow>
    case cs ! i of
      (ch[!]e, p2) \<Rightarrow>
        \<Turnstile> {\<lambda>s tr. (P st @\<^sub>t ODEout\<^sub>t st ode b s ch e (rdy_of_echoice cs)) tr} p2 {Q}
    | (ch[?]var, p2) \<Rightarrow>
        \<Turnstile> {\<lambda>s tr. (P st @\<^sub>t ODEin\<^sub>t st ode b s ch var (rdy_of_echoice cs)) tr} p2 {Q}"
  assumes "(\<lambda>s tr. (P st @\<^sub>t (ODErdy\<^sub>t st ode b s (rdy_of_echoice cs))) tr) \<Longrightarrow>\<^sub>A Q"
  shows "\<Turnstile>
    {\<lambda>s tr. s = st \<and> P s tr}
      Interrupt ode b cs
    {Q}"
  apply (rule Valid_interrupt')
  subgoal for i
    apply (cases "cs ! i") apply auto
    subgoal for comm p2
      apply (cases comm)
      subgoal for ch e
        apply auto
        apply (rule exI[where x="\<lambda>s tr. (P st @\<^sub>t ODEout\<^sub>t st ode b s ch e (rdy_of_echoice cs)) tr"])
        using assms(1)[of i]
        by (auto simp add: entails_def magic_wand_assn_def join_assn_def)
      subgoal for ch var
        apply auto
        apply (rule exI[where x="\<lambda>s tr. (P st @\<^sub>t ODEin\<^sub>t st ode b s ch var (rdy_of_echoice cs)) tr"])
        using assms(1)[of i]
        by (auto simp add: entails_def magic_wand_assn_def join_assn_def)
      done
    done
  using assms(2) apply (auto simp add: entails_def magic_wand_assn_def)
  using join_assn_def by metis

theorem Valid_interrupt_sp':
  assumes "\<And>i. i < length cs \<Longrightarrow>
    case cs ! i of
      (ch[!]e, p2) \<Rightarrow>
        \<Turnstile> {\<lambda>(a,s) tr. (P (a,st) @\<^sub>t ODEout\<^sub>t (a,st) ode b (a,s) ch e (rdy_of_echoice cs)) tr} p2 {Q}
    | (ch[?]var, p2) \<Rightarrow>
        \<Turnstile> {\<lambda>(a,s) tr. (P (a,st) @\<^sub>t ODEin\<^sub>t (a,st) ode b (a,s) ch var (rdy_of_echoice cs)) tr} p2 {Q}"
  assumes "(\<lambda>(a,s) tr. (P (a,st) @\<^sub>t (ODErdy\<^sub>t (a,st) ode b (a,s) (rdy_of_echoice cs))) tr) \<Longrightarrow>\<^sub>A Q"
  shows "\<Turnstile>
    {\<lambda>(a,s) tr. s = st \<and> P (a,s) tr}
      Interrupt ode b cs
    {Q}"
  apply (rule Valid_interrupt')
  subgoal for i
    apply (cases "cs ! i") apply auto
    subgoal for comm p2
      apply (cases comm)
      subgoal for ch e
        apply auto
        apply (rule exI[where x="\<lambda>(a,s) tr. (P (a,st) @\<^sub>t ODEout\<^sub>t (a,st) ode b (a,s) ch e (rdy_of_echoice cs)) tr"])
        using assms(1)[of i]
        by (auto simp add: entails_def magic_wand_assn_def join_assn_def)
      subgoal for ch var
        apply auto
        apply (rule exI[where x="\<lambda>(a,s)tr. (P (a,st) @\<^sub>t ODEin\<^sub>t (a,st) ode b (a,s) ch var (rdy_of_echoice cs)) tr"])
        using assms(1)[of i]
        by (auto simp add: entails_def magic_wand_assn_def join_assn_def)
      done
    done
  using assms(2) apply (auto simp add: entails_def magic_wand_assn_def)
  using join_assn_def by metis

theorem Valid_interrupt_In_sp:
  assumes "\<Turnstile> {\<lambda>s tr. (P st @\<^sub>t ODEin\<^sub>t st ode b s ch var ({}, {ch})) tr} p {Q}"
  shows "\<Turnstile>
    {\<lambda>s tr. s = st \<and> P s tr}
      Interrupt ode b [(ch[?]var, p)]
    {\<lambda>s tr. Q s tr \<or> (P st @\<^sub>t (ODErdy\<^sub>t st ode b s ({}, {ch}))) tr}"
  apply (rule Valid_interrupt_sp)
  using assms by (auto simp add: Valid_def entails_def)

theorem Valid_interrupt_In_sp':
  assumes "\<Turnstile> {\<lambda>(a,s) tr. (P (a,st) @\<^sub>t ODEin\<^sub>t (a,st) ode b (a,s) ch var ({}, {ch})) tr} p {Q}"
  shows "\<Turnstile>
    {\<lambda>(a,s) tr. s = st \<and> P (a,s) tr}
      Interrupt ode b [(ch[?]var, p)]
    {\<lambda>(a,s) tr. Q (a,s) tr \<or> (P (a,st) @\<^sub>t (ODErdy\<^sub>t (a,st) ode b (a,s) ({}, {ch}))) tr}"
  apply (rule Valid_interrupt_sp')
  using assms by (auto simp add: Valid_def entails_def)

theorem Valid_interrupt_Out_sp:
  assumes "\<Turnstile> {\<lambda>s tr. (P st @\<^sub>t ODEout\<^sub>t st ode b s ch e ({ch}, {})) tr} p {Q}"
  shows "\<Turnstile>
    {\<lambda>s tr. s = st \<and> P s tr}
      Interrupt ode b [(ch[!]e, p)]
    {\<lambda>s tr. Q s tr \<or> (P st @\<^sub>t (ODErdy\<^sub>t st ode b s ({ch}, {}))) tr}"
  apply (rule Valid_interrupt_sp)
  using assms by (auto simp add: Valid_def entails_def)

theorem Valid_interrupt_Out_sp':
  assumes "\<Turnstile> {\<lambda>(a,s) tr. (P (a,st) @\<^sub>t ODEout\<^sub>t (a,st) ode b (a,s) ch e ({ch}, {})) tr} p {Q}"
  shows "\<Turnstile>
    {\<lambda>(a,s) tr. s = st \<and> P (a,s) tr}
      Interrupt ode b [(ch[!]e, p)]
    {\<lambda>(a,s) tr. Q (a,s) tr \<or> (P (a,st) @\<^sub>t (ODErdy\<^sub>t (a,st) ode b (a,s) ({ch}, {}))) tr}"
  apply (rule Valid_interrupt_sp')
  using assms by (auto simp add: Valid_def entails_def)

lemma ODErdy_false:
  "ODErdy\<^sub>t st ode b s rdy tr \<Longrightarrow> b = (\<lambda>_. True) \<Longrightarrow> False"
  apply (induct rule: ode_rdy_assn.induct) by auto

definition supp :: "state \<Rightarrow> var set" where
  "supp s = {v. s v \<noteq> 0}"

fun ode_supp :: "ODE \<Rightarrow> var set" where
  "ode_supp (ODE ode) = {v. ode v \<noteq> (\<lambda>_. 0)}"

theorem Valid_interrupt_Out_sp2:
  assumes "\<Turnstile> {\<lambda>(a,s) tr. \<exists>st'. s = st' \<and> supp st' \<subseteq> VS \<and>
                (P (a,st) @\<^sub>t ODEout\<^sub>t (a,st) (ODE ode) (\<lambda>_. True) (a,st') ch e ({ch}, {})) tr} p {Q}"
    and "ode_supp (ODE ode) \<subseteq> VS"
    and "supp st \<subseteq> VS"
  shows "\<Turnstile>
    {\<lambda>(a,s) tr. s = st \<and> P (a,s) tr}
      Interrupt (ODE ode) (\<lambda>_. True) [(ch[!]e, p)]
    {Q}"
  apply (rule Valid_strengthen_post)
   prefer 2
   apply (rule Valid_interrupt_Out_sp')
   apply (rule Valid_weaken_pre)
    prefer 2 apply (rule assms)
  apply (auto simp add: entails_def)
   apply (auto simp add: Valid_def entails_def join_assn_def)
  subgoal for a s x tr1 tr2
    subgoal premises pre
    proof(rule ccontr)
      assume cond:"x \<notin> VS"
    have 1:"ODEout\<^sub>t (a,st) (ODE ode) (\<lambda>_. True) (a,s) ch e ({ch}, {}) tr2 \<Longrightarrow> tr2 =  [OutBlock ch (e (a,s))] \<Longrightarrow> st = s"
      apply (induct rule: ode_out_assn_induct) by auto
    have 2:"ODEout\<^sub>t (a,st) (ODE ode) (\<lambda>_. True) (a,s) ch e ({ch}, {}) tr2 \<Longrightarrow> tr2 =  [OutBlock ch (e (a,s))] \<Longrightarrow> False"
      using 1 pre cond assms(3) unfolding supp_def by auto
    have 3:"ODEout\<^sub>t (a,st) (ODE ode) (\<lambda>_. True) (a,s) ch e ({ch}, {}) tr2 \<Longrightarrow> tr2 \<noteq>  [OutBlock ch (e (a,s))] \<Longrightarrow>
\<exists> p d. (0 < (d::real) \<and>  ODEsol (ODE ode) p d \<and> p 0 = st \<and>
    s = p d \<and> tr2 = [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({ch}, {}), OutBlock ch (e (a,p d))])"
      apply (induct rule: ode_out_assn_induct) by auto
    have 4:"ODEout\<^sub>t (a,st) (ODE ode) (\<lambda>_. True) (a,s) ch e ({ch}, {}) tr2 \<Longrightarrow> tr2 \<noteq>  [OutBlock ch (e (a,s))] \<Longrightarrow>False"
      subgoal premises pre1
      proof-
        obtain p and d where condd:"0 < (d::real)"" ODEsol (ODE ode) p d""p 0 = st"" s = p d "
          using pre1 3 by auto
        have a1:"p 0 x = 0" using pre condd cond assms(3) unfolding supp_def by auto
        have a2:"ode x = (\<lambda>_. 0)"
          using assms(2) cond by auto
        have a3:"((\<lambda>t. p t x) has_vderiv_on (\<lambda>t. 0)) {0 .. d}"
          using ODEsol_old[OF condd(2)]
          using has_vderiv_on_proj[of "(\<lambda>t. state2vec (p t))" "(\<lambda>t. ODE2Vec (ODE ode) (p t))"  "{0 .. d}" x]
          apply auto
          unfolding state2vec_def apply auto
          using a2 by auto
        then have 4:"p 0 x = p d x"
          unfolding has_vderiv_on_def has_vector_derivative_def
          using mvt_real_eq[of d "(\<lambda>t. p t x)" "\<lambda>t. (\<lambda>x. x *\<^sub>R 0)" d]
          using condd by auto
        then show ?thesis using a1 cond pre condd unfolding supp_def by auto
      qed
      done
    show False using 2 4 pre by auto
  qed
  done
  using ODErdy_false by blast

inductive wait_in_assn :: "real \<Rightarrow> 'a \<Rightarrow> (real \<Rightarrow> state) \<Rightarrow> cname \<Rightarrow> real \<Rightarrow> rdy_info \<Rightarrow> 'a tassn" ("WaitIn\<^sub>t") where
  "WaitIn\<^sub>t 0 a p ch v rdy [InBlock ch v]"
| "d > 0 \<Longrightarrow> WaitIn\<^sub>t d a p ch v rdy [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) rdy, InBlock ch v]"

inductive wait_out_assn :: "real \<Rightarrow> 'a \<Rightarrow> (real \<Rightarrow> state) \<Rightarrow> cname \<Rightarrow> 'a ext_exp \<Rightarrow> rdy_info \<Rightarrow> 'a tassn" ("WaitOut\<^sub>t") where
  "WaitOut\<^sub>t 0 a p ch e rdy [OutBlock ch (e (a,p 0))]"
| "d > 0 \<Longrightarrow> WaitOut\<^sub>t d a p ch e rdy [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) rdy, OutBlock ch (e (a,p d))]"

theorem Valid_ode_out_unique_solution_aux:
  assumes
    "ODEsolInf ode p" "\<forall>t\<ge>0. b (p t)" "p 0 = st"
    "local_lipschitz {- 1<..} UNIV (\<lambda>(t::real) v. ODE2Vec ode (vec2state v))"
    "ODEout\<^sub>t (a,st) ode b (a,st') ch e rdy tr"
  shows
    "\<exists>d. st' = p d \<and> WaitOut\<^sub>t d a p ch e rdy tr"
proof -
  have main: "p2 d = p d \<and> (\<forall>\<tau>\<in>{0..d}. EState (a,p2 \<tau>) = EState (a,p \<tau>))"
    if cond: "0 < d"
       "ODEsol ode p2 d"
       "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p2 t)"
       "p2 0 = st" for d p2
  proof -
    interpret loc:ll_on_open_it "{-1<..}"
      "\<lambda>t v. ODE2Vec ode (vec2state v)" UNIV 0
      apply standard
      using assms(4) by auto
    have s1: "((\<lambda>t. state2vec (p t)) solves_ode ((\<lambda>t v. ODE2Vec ode (vec2state v)))) {0..} UNIV"
      using assms(1) using ODEsolInf_old[OF assms(1)] unfolding ODEsolInf_def solves_ode_def by auto
    have s2: "(loc.flow 0 (state2vec st)) t = (\<lambda>t. state2vec (p t)) t" if "t \<in> {0..d}" for t
      apply (rule loc.maximal_existence_flow(2)[OF s1])
      using that by (auto simp add: state2vec_def assms(3))
    have s3: "((\<lambda>t. state2vec(p2 t)) solves_ode ((\<lambda>t v. ODE2Vec ode (vec2state v)))) {0..d} UNIV"
      using cond(2) using ODEsol_old[OF cond(2)]unfolding ODEsol_def solves_ode_def by auto
    have s4: "loc.flow 0 (state2vec st) t = state2vec (p2 t)" if "t\<in>{0..d}" for t
      apply (rule loc.maximal_existence_flow(2)[OF s3])
      using cond that by auto
    have s8: "t\<in>{0..d} \<Longrightarrow> p2 t = p t" for t
      using s2 s4 by (metis vec_state_map1)
    have s10: "p d = p2 d"
      using s8 that(1) by auto
    show ?thesis using s8 s10 by auto
  qed
  show ?thesis
    using assms(5) apply (elim ode_out_assn.cases)
     apply auto
     apply (rule exI[where x=0])
    subgoal for rdy1 rdy2
      by (auto simp add: assms(3) wait_out_assn.simps)
    subgoal for d p2 rdy1 rdy2
      apply (rule exI[where x=d])
      apply (auto simp add: wait_out_assn.simps)
      using main[of d p2] apply (auto simp: WaitBlk.simps)
      done
    done
qed

theorem Valid_ode_rdy_unique_solution_aux:
  assumes
    "ODEsolInf ode p" "\<forall>t\<ge>0. b (p t)" "p 0 = st"
    "local_lipschitz {- 1<..} UNIV (\<lambda>(t::real) v. ODE2Vec ode (vec2state v))"
    "ODErdy\<^sub>t (a,st) ode b (a,st') rdy tr"
  shows
    "False"
proof -
  have "b st"
    using assms(2,3) by auto
  have main: "False"
    if cond: "0 < d1"
       "ODEsol ode p1 d1"
       "st = p1 0"
       "\<forall>t. 0 \<le> t \<and> t < d1 \<longrightarrow> b (p1 t)"
       "\<not> b (p1 d1)" for d1 p1
  proof -
    interpret loc:ll_on_open_it "{-1<..}"
      "\<lambda>t v. ODE2Vec ode (vec2state v)" UNIV 0
      apply standard
      using assms(4) by auto
    have s1: "((\<lambda>t. state2vec (p t)) solves_ode ((\<lambda>t v. ODE2Vec ode (vec2state v)))) {0..} UNIV"
      using assms(1) using ODEsolInf_old[OF assms(1)] unfolding ODEsolInf_def solves_ode_def by auto
    have s2: "(loc.flow 0 (state2vec st)) t = (\<lambda>t. state2vec (p t)) t" if "t \<in> {0..d1}" for t
      apply (rule loc.maximal_existence_flow(2)[OF s1])
      using that by (auto simp add: state2vec_def assms(3))
    have s3: "((\<lambda>t. state2vec(p1 t)) solves_ode ((\<lambda>t v. ODE2Vec ode (vec2state v)))) {0..d1} UNIV"
      using cond(2) using ODEsol_old[OF cond(2)] unfolding ODEsol_def solves_ode_def by auto
    have s4: "loc.flow 0 (state2vec st) t = state2vec (p1 t)" if "t\<in>{0..d1}" for t
      apply (rule loc.maximal_existence_flow(2)[OF s3])
      using cond that by auto
    have s8: "t\<in>{0..d1} \<Longrightarrow> p1 t = p t" for t
      using s2 s4 by (metis vec_state_map1)
    have s10: "p d1 = p1 d1"
      using s8 that(1) by auto
    show ?thesis using assms(2) cond(1,5) s10
      using less_eq_real_def by auto
  qed
  show ?thesis
    using assms(5) apply (auto simp add: ode_rdy_assn.simps)
    subgoal using \<open>b st\<close> by auto
    subgoal for d1 p1
      using main by auto
    done
qed

theorem Valid_ode_out_unique_solution:
  assumes
    "ODEsolInf ode p" "\<forall>t\<ge>0. b (p t)" "p 0 = st"
    "local_lipschitz {- 1<..} UNIV (\<lambda>(t::real) v. ODE2Vec ode (vec2state v))"
    "\<Turnstile> {\<lambda>(a,s) tr. \<exists>d. s = p d \<and> (P (a,st) @\<^sub>t WaitOut\<^sub>t d a p ch e ({ch}, {})) tr} p2 {Q}"
  shows "\<Turnstile>
    {\<lambda>(a,s) tr. s = st \<and> P (a,s) tr}
      Interrupt ode b [(ch[!]e, p2)]
    {Q}"
proof -
  have *: "ODEout\<^sub>t (a,st) ode b (a,s) ch e ({ch}, {}) tr2 \<Longrightarrow>
           \<exists>d. s = p d \<and> WaitOut\<^sub>t d a p ch e ({ch}, {}) tr2" for a s tr2
    using Valid_ode_out_unique_solution_aux[OF assms(1-4)] by auto
  have **: "ODErdy\<^sub>t (a,st) ode b (a,s) ({ch}, {}) tr2 \<Longrightarrow> False" for a s tr2
    using Valid_ode_rdy_unique_solution_aux[OF assms(1-4)] by auto
  show ?thesis
    apply (rule Valid_strengthen_post)
     prefer 2 apply (rule Valid_interrupt_Out_sp'[where Q=Q])
    subgoal
      apply (auto simp add: Valid_def join_assn_def)
      apply (drule *)
      using assms(5) apply (auto simp add: Valid_def join_assn_def join_assoc)
      by fastforce
    apply (auto simp add: entails_def join_assn_def)
    using ** by metis
qed

end


(* The value setup for paper confidentiality *)
theory Decision_Value_Setup2
imports Decision_Value_Setup
begin

section\<open>Preliminaries\<close>

(* two papers equal everywhere but w.r.t. the tail of the decision: *)
fun eqExcD2 :: "paper \<Rightarrow> paper \<Rightarrow> bool" where
"eqExcD2 (Paper title abstract ct reviews dis decs )
         (Paper title1 abstract1 ct1 reviews1 dis1 decs1) =
 (title = title1 \<and> abstract = abstract1 \<and> ct = ct1 \<and> reviews = reviews1 \<and> dis = dis1 \<and>
 hd decs = hd decs1)"

lemma eqExcD2:
"eqExcD2 pap pap1 =
 (titlePaper pap = titlePaper pap1 \<and> abstractPaper pap = abstractPaper pap1 \<and>
  contentPaper pap = contentPaper pap1 \<and>
  reviewsPaper pap = reviewsPaper pap1 \<and> disPaper pap = disPaper pap1 \<and>
  hd (decsPaper pap) = hd (decsPaper pap1)
 )"
by(cases pap, cases pap1, auto)

lemma eqExcD2_eq[simp,intro!]: "eqExcD2 pap pap"
by(cases pap) auto

lemma eqExcD2_sym:
assumes "eqExcD2 pap pap1"
shows "eqExcD2 pap1 pap"
apply(cases pap, cases pap1)
using assms by auto

lemma eqExcD2_trans:
assumes "eqExcD2 pap pap1" and "eqExcD2 pap1 pap2"
shows "eqExcD2 pap pap2"
apply(cases pap, cases pap1, cases pap2)
using assms by auto

(* Auxiliary notion:  *)
definition eeqExcPID2 where
"eeqExcPID2 paps paps1 \<equiv>
 \<forall> pid. if pid = PID then eqExcD2 (paps pid) (paps1 pid) else paps pid = paps1 pid"

lemma eeqExcPID2_eeq[simp,intro!]: "eeqExcPID2 s s"
unfolding eeqExcPID2_def by auto

lemma eeqExcPID2_sym:
assumes "eeqExcPID2 s s1" shows "eeqExcPID2 s1 s"
using assms eqExcD2_sym unfolding eeqExcPID2_def by auto

lemma eeqExcPID2_trans:
assumes "eeqExcPID2 s s1" and "eeqExcPID2 s1 s2" shows "eeqExcPID2 s s2"
using assms eqExcD2_trans unfolding eeqExcPID2_def by simp blast

lemma eeqExcPID2_imp:
"eeqExcPID2 paps paps1 \<Longrightarrow> eqExcD2 (paps PID) (paps1 PID)"
"\<lbrakk>eeqExcPID2 paps paps1; pid \<noteq> PID\<rbrakk> \<Longrightarrow> paps pid = paps1 pid"
unfolding eeqExcPID2_def by auto

lemma eeqExcPID2_cong:
assumes "eeqExcPID2 paps paps1"
and "pid = PID \<Longrightarrow> eqExcD2 uu uu1"
and "pid \<noteq> PID \<Longrightarrow> uu = uu1"
shows "eeqExcPID2 (paps (pid := uu)) (paps1(pid := uu1))"
using assms unfolding eeqExcPID2_def by auto

lemma eeqExcPID2_RDD:
"eeqExcPID2 paps paps1 \<Longrightarrow>
 titlePaper (paps PID) = titlePaper (paps1 PID) \<and>
 abstractPaper (paps PID) = abstractPaper (paps1 PID) \<and>
 contentPaper (paps PID) = contentPaper (paps1 PID) \<and>
 reviewsPaper (paps PID) = reviewsPaper (paps1 PID) \<and>
 disPaper (paps PID) = disPaper (paps1 PID) \<and>
 hd (decsPaper (paps PID)) = hd (decsPaper (paps PID))"
using eeqExcPID2_def unfolding eqExcD2 by auto

(* The notion of two states being equal everywhere but on the tail of the decision of
   the paper associated to a given PID *)
definition eqExcPID2 :: "state \<Rightarrow> state \<Rightarrow> bool" where
"eqExcPID2 s s1 \<equiv>
 confIDs s = confIDs s1 \<and> conf s = conf s1 \<and>
 userIDs s = userIDs s1 \<and> pass s = pass s1 \<and> user s = user s1 \<and> roles s = roles s1 \<and>
 paperIDs s = paperIDs s1
 \<and>
 eeqExcPID2 (paper s) (paper s1)
 \<and>
 pref s = pref s1 \<and>
 voronkov s = voronkov s1 \<and>
 news s = news s1 \<and> phase s = phase s1"

lemma eqExcPID2_eq[simp,intro!]: "eqExcPID2 s s"
unfolding eqExcPID2_def by auto

lemma eqExcPID2_sym:
assumes "eqExcPID2 s s1" shows "eqExcPID2 s1 s"
using assms eeqExcPID2_sym unfolding eqExcPID2_def by auto

lemma eqExcPID2_trans:
assumes "eqExcPID2 s s1" and "eqExcPID2 s1 s2" shows "eqExcPID2 s s2"
using assms eeqExcPID2_trans unfolding eqExcPID2_def by auto

(* Implications from eqExcPID2, including w.r.t. auxiliary operations: *)
lemma eqExcPID2_imp:
"eqExcPID2 s s1 \<Longrightarrow>
 confIDs s = confIDs s1 \<and> conf s = conf s1 \<and>
 userIDs s = userIDs s1 \<and> pass s = pass s1 \<and> user s = user s1 \<and> roles s = roles s1 \<and>
 paperIDs s = paperIDs s1
 \<and>
 eeqExcPID2 (paper s) (paper s1)
 \<and>
 pref s = pref s1 \<and>
 voronkov s = voronkov s1 \<and>
 news s = news s1 \<and> phase s = phase s1 \<and>

 getAllPaperIDs s = getAllPaperIDs s1 \<and>
 isRev s cid uid pid = isRev s1 cid uid pid \<and>
 getReviewIndex s cid uid pid = getReviewIndex s1 cid uid pid \<and>
 getRevRole s cid uid pid = getRevRole s1 cid uid pid"
unfolding eqExcPID2_def getAllPaperIDs_def
unfolding isRev_def getReviewIndex_def getRevRole_def by auto

lemma eqExcPID2_imp1:
"eqExcPID2 s s1 \<Longrightarrow> eqExcD2 (paper s pid) (paper s1 pid)"
"eqExcPID2 s s1 \<Longrightarrow> pid \<noteq> PID \<or> PID \<noteq> pid \<Longrightarrow>
    paper s pid = paper s1 pid \<and>
    getNthReview s pid n = getNthReview s1 pid n"
unfolding eqExcPID2_def getNthReview_def eeqExcPID2_def
apply auto
by (metis eqExcD2_eq)

lemma eqExcPID2_imp2:
assumes "eqExcPID2 s s1" and "pid \<noteq> PID \<or> PID \<noteq> pid"
shows "getReviewersReviews s cid pid = getReviewersReviews s1 cid pid"
proof-
  have
  "(\<lambda>uID. if isRev s cid uID pid then [(uID, getNthReview s pid (getReviewIndex s cid uID pid))] else []) =
   (\<lambda>uID. if isRev s1 cid uID pid then [(uID, getNthReview s1 pid (getReviewIndex s1 cid uID pid))] else [])"
  apply(rule ext)
  using assms by (auto simp: eqExcPID2_imp eqExcPID2_imp1)
  thus ?thesis unfolding getReviewersReviews_def using assms by (simp add: eqExcPID2_imp)
qed

lemma eqExcPID2_RDD:
"eqExcPID2 s s1 \<Longrightarrow>
 titlePaper (paper s PID) = titlePaper (paper s1 PID) \<and>
 abstractPaper (paper s PID) = abstractPaper (paper s1 PID) \<and>
 contentPaper (paper s PID) = contentPaper (paper s1 PID) \<and>
 reviewsPaper (paper s PID) = reviewsPaper (paper s1 PID) \<and>
 disPaper (paper s PID) = disPaper (paper s1 PID)"
using eqExcPID2_imp eeqExcPID2_RDD by auto

lemma eqExcPID2_cong[simp, intro]:
"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>confIDs := uu1\<rparr>) (s1 \<lparr>confIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>conf := uu1\<rparr>) (s1 \<lparr>conf := uu2\<rparr>)"

"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>userIDs := uu1\<rparr>) (s1 \<lparr>userIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>pass := uu1\<rparr>) (s1 \<lparr>pass := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>user := uu1\<rparr>) (s1 \<lparr>user := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>roles := uu1\<rparr>) (s1 \<lparr>roles := uu2\<rparr>)"

"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>paperIDs := uu1\<rparr>) (s1 \<lparr>paperIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> eeqExcPID2 uu1 uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>paper := uu1\<rparr>) (s1 \<lparr>paper := uu2\<rparr>)"

"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>pref := uu1\<rparr>) (s1 \<lparr>pref := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>voronkov := uu1\<rparr>) (s1 \<lparr>voronkov := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>news := uu1\<rparr>) (s1 \<lparr>news := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID2 (s \<lparr>phase := uu1\<rparr>) (s1 \<lparr>phase := uu2\<rparr>)"
unfolding eqExcPID2_def by auto

lemma eqExcPID2_Paper:
assumes s's1': "eqExcPID2 s s1"
and "paper s pid = Paper title abstract content reviews dis decs"
and "paper s1 pid = Paper title1 abstract1 content1 reviews1 dis1 decs1"
shows "title = title1 \<and> abstract = abstract1 \<and> content = content1 \<and> reviews = reviews1 \<and>
    dis = dis1"
using assms unfolding eqExcPID2_def apply (auto simp: eqExcD2 eeqExcPID2_def)
  by (metis titlePaper.simps abstractPaper.simps contentPaper.simps reviewsPaper.simps
disPaper.simps)+

section\<open>Value Setup\<close>

(* These hold for eeqExcPID, but not for eeqExcPID2:
lemma UUact_uuDec_step_eqExcPID2:
assumes a: "a = UUact (uuDec cid uid p PID dec)"
and "step s a = (ou,s')"
shows "eqExcPID2 s s'"
using assms unfolding eqExcPID2_def eeqExcPID2_def by (auto simp: uu_defs)

lemma \<phi>_step_eqExcPID2:
assumes \<phi>: "\<phi> (Trans s a ou s')"
and s: "step s a = (ou,s')"
shows "eqExcPID2 s s'"
using \<phi> UUact_uuDec_step_eqExcPID2[OF _ s] unfolding \<phi>_def2 by blast
*)

(* major *) lemma eqExcPID2_step:
assumes s's1': "eqExcPID2 s s1"
and step: "step s a = (ou,s')"
and step1: "step s1 a = (ou1,s1')"
shows "eqExcPID2 s' s1'"
proof -
  note eqs = eqExcPID2_imp[OF s's1']
  note eqs' = eqExcPID2_imp1[OF s's1']

  note simps[simp] = c_defs u_defs uu_defs r_defs l_defs Paper_dest_conv eqExcPID2_def eeqExcPID2_def eqExcD2

  show ?thesis
    using s's1' step step1 eqs eqs'
    apply(cases a, simp_all only:)
      subgoal for x1 apply(cases x1)
        apply auto[] apply auto[] apply auto[] apply auto[]
        apply auto[] apply auto[] apply auto[] apply auto[] .
      subgoal for x2 apply(cases x2)
        apply auto[] apply auto[] apply auto[] apply auto[]
        apply auto[] apply auto[] apply auto[] .
      subgoal for x3 apply(cases x3)
        apply auto[] apply auto[] apply auto[] apply auto[] .
      apply auto
  done
qed

lemma eqExcPID2_step_\<phi>_imp:
assumes s's1': "eqExcPID2 s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and \<phi>: "\<phi> (Trans s a ou s')"
shows "\<phi> (Trans s1 a ou1 s1')"
using assms unfolding \<phi>_def2 by (auto simp add: uu_defs eqExcPID2_imp)

lemma eqExcPID2_step_\<phi>:
assumes s's1': "eqExcPID2 s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
shows "\<phi> (Trans s a ou s') = \<phi> (Trans s1 a ou1 s1')"
by (metis eqExcPID2_step_\<phi>_imp eqExcPID2_sym assms)

end


section \<open>Final Instantiation of Algorithms Related to Complementation\<close>

theory Complementation_Final
imports
  "Complementation_Implement"
  "Formula"
  "Transition_Systems_and_Automata.NBA_Translate"
  "Transition_Systems_and_Automata.NGBA_Algorithms"
  "HOL-Library.Multiset"
begin

  subsection \<open>Syntax\<close>

  (* TODO: this syntax has unnecessarily high inner binding strength, requiring extra parentheses
    the regular let syntax correctly uses inner binding strength 0: ("(2_ =/ _)" 10) *)
  no_syntax "_do_let" :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2let _ =/ _)" [1000, 13] 13)
  syntax "_do_let" :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2let _ =/ _)" 13)

  subsection \<open>Hashcodes on Complement States\<close>

  definition "hci k \<equiv> uint32_of_nat k * 1103515245 + 12345"
  definition "hc \<equiv> \<lambda> (p, q, b). hci p + hci q * 31 + (if b then 1 else 0)"
  definition "list_hash xs \<equiv> fold ((XOR) \<circ> hc) xs 0"

  lemma list_hash_eq:
    assumes "distinct xs" "distinct ys" "set xs = set ys"
    shows "list_hash xs = list_hash ys"
  proof -
    have "mset (remdups xs) = mset (remdups ys)" using assms(3)
      using set_eq_iff_mset_remdups_eq by blast
    then have "mset xs = mset ys" using assms(1, 2) by (simp add: distinct_remdups_id)
    have "fold ((XOR) \<circ> hc) xs = fold ((XOR) \<circ> hc) ys"
      apply (rule fold_multiset_equiv)
       apply (simp_all add: fun_eq_iff ac_simps)
      using \<open>mset xs = mset ys\<close> .
    then show ?thesis unfolding list_hash_def by simp
  qed

  definition state_hash :: "nat \<Rightarrow> Complementation_Implement.state \<Rightarrow> nat" where
    "state_hash n p \<equiv> nat_of_hashcode (list_hash p) mod n"

  lemma state_hash_bounded_hashcode[autoref_ga_rules]: "is_bounded_hashcode state_rel
    (gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
    (prod_eq (=) (\<longleftrightarrow>))) state_hash"
  proof
    show [param]: "(gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
      (prod_eq (=) (\<longleftrightarrow>)), (=)) \<in> state_rel \<rightarrow> state_rel \<rightarrow> bool_rel" by autoref
    show "state_hash n xs = state_hash n ys" if "xs \<in> Domain state_rel" "ys \<in> Domain state_rel"
      "gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list))
      (list_map_lookup (=)) (prod_eq (=) (=)) xs ys" for xs ys n
    proof -
      have 1: "distinct (map fst xs)" "distinct (map fst ys)"
        using that(1, 2) unfolding list_map_rel_def list_map_invar_def by (auto simp: in_br_conv)
      have 2: "distinct xs" "distinct ys" using 1 by (auto intro: distinct_mapI)
      have 3: "(xs, map_of xs) \<in> state_rel" "(ys, map_of ys) \<in> state_rel"
        using 1 unfolding list_map_rel_def list_map_invar_def by (auto simp: in_br_conv)
      have 4: "(gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
        (prod_eq (=) (\<longleftrightarrow>)) xs ys, map_of xs = map_of ys) \<in> bool_rel" using 3 by parametricity
      have 5: "map_to_set (map_of xs) = map_to_set (map_of ys)" using that(3) 4 by simp
      have 6: "set xs = set ys" using map_to_set_map_of 1 5 by blast
      show "state_hash n xs = state_hash n ys" unfolding state_hash_def using list_hash_eq 2 6 by metis
    qed
    show "state_hash n x < n" if "1 < n" for n x using that unfolding state_hash_def by simp
  qed

  subsection \<open>Complementation\<close>

  schematic_goal complement_impl:
    assumes [simp]: "finite (NBA.nodes A)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, op_translate (complement_4 A)) \<in> ?R"
    by (autoref_monadic (plain))
  concrete_definition complement_impl uses complement_impl

  theorem complement_impl_correct:
    assumes "finite (NBA.nodes A)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "NBA.language (nbae_nba (nbaei_nbae (complement_impl Ai))) =
      streams (nba.alphabet A) - NBA.language A"
    using op_translate_language[OF complement_impl.refine[OF assms]]
    using complement_4_correct[OF assms(1)]
    by simp

  subsection \<open>Language Subset\<close>

  definition [simp]: "op_language_subset A B \<equiv> NBA.language A \<subseteq> NBA.language B"

  lemmas [autoref_op_pat] = op_language_subset_def[symmetric]

  schematic_goal language_subset_impl:
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, do {
      let AB' = intersect' A (complement_4 B);
      ASSERT (finite (NGBA.nodes AB'));
      RETURN (NGBA.language AB' = {})
    }) \<in> ?R"
		by (autoref_monadic (plain))
  concrete_definition language_subset_impl uses language_subset_impl
  lemma language_subset_impl_refine[autoref_rules]:
    assumes "SIDE_PRECOND (finite (NBA.nodes A))"
    assumes "SIDE_PRECOND (finite (NBA.nodes B))"
    assumes "SIDE_PRECOND (nba.alphabet A \<subseteq> nba.alphabet B)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(language_subset_impl Ai Bi, (OP op_language_subset :::
      \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> bool_rel) $ A $ B) \<in> bool_rel"
  proof -
    have "(RETURN (language_subset_impl Ai Bi), do {
      let AB' = intersect' A (complement_4 B);
      ASSERT (finite (NGBA.nodes AB'));
      RETURN (NGBA.language AB' = {})
    }) \<in> \<langle>bool_rel\<rangle> nres_rel"
      using language_subset_impl.refine assms(2, 4, 5) unfolding autoref_tag_defs by this
    also have "(do {
      let AB' = intersect' A (complement_4 B);
      ASSERT (finite (NGBA.nodes AB'));
      RETURN (NGBA.language AB' = {})
    }, RETURN (NBA.language A \<subseteq> NBA.language B)) \<in> \<langle>bool_rel\<rangle> nres_rel"
    proof refine_vcg
      show "finite (NGBA.nodes (intersect' A (complement_4 B)))" using assms(1, 2) by auto
      have 1: "NBA.language A \<subseteq> streams (nba.alphabet B)"
        using nba.language_alphabet streams_mono2 assms(3) unfolding autoref_tag_defs by blast
      have 2: "NBA.language (complement_4 B) = streams (nba.alphabet B) - NBA.language B"
        using complement_4_correct assms(2) by auto
      show "(NGBA.language (intersect' A (complement_4 B)) = {},
        NBA.language A \<subseteq> NBA.language B) \<in> bool_rel" using 1 2 by auto
    qed
    finally show ?thesis using RETURN_nres_relD unfolding nres_rel_comp by force
  qed

  subsection \<open>Language Equality\<close>

  definition [simp]: "op_language_equal A B \<equiv> NBA.language A = NBA.language B"

  lemmas [autoref_op_pat] = op_language_equal_def[symmetric]

  schematic_goal language_equal_impl:
    assumes [simp]: "finite (NBA.nodes A)"
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [simp]: "nba.alphabet A = nba.alphabet B"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, NBA.language A \<subseteq> NBA.language B \<and> NBA.language B \<subseteq> NBA.language A) \<in> ?R"
    by autoref
  concrete_definition language_equal_impl uses language_equal_impl
  lemma language_equal_impl_refine[autoref_rules]:
    assumes "SIDE_PRECOND (finite (NBA.nodes A))"
    assumes "SIDE_PRECOND (finite (NBA.nodes B))"
    assumes "SIDE_PRECOND (nba.alphabet A = nba.alphabet B)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(language_equal_impl Ai Bi, (OP op_language_equal :::
      \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> bool_rel) $ A $ B) \<in> bool_rel"
    using language_equal_impl.refine[OF assms[unfolded autoref_tag_defs]] by auto

  schematic_goal product_impl:
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, do {
      let AB' = intersect A (complement_4 B);
      ASSERT (finite (NBA.nodes AB'));
      op_translate AB'
    }) \<in> ?R"
		by (autoref_monadic (plain))
  concrete_definition product_impl uses product_impl

  (* TODO: possible optimizations:
    - introduce op_map_map operation for maps instead of manually iterating via FOREACH
    - consolidate various binds and maps in expand_map_get_7 *)
  export_code
    Set.empty Set.insert Set.member
    "Inf :: 'a set set \<Rightarrow> 'a set" "Sup :: 'a set set \<Rightarrow> 'a set" image Pow set
    nat_of_integer integer_of_nat
    Variable Negation Conjunction Disjunction satisfies map_formula
    nbaei alphabetei initialei transitionei acceptingei
    nbae_nba_impl complement_impl language_equal_impl product_impl
    in SML module_name Complementation file_prefix Complementation

end