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