theory Common_Primitive_Matcher_Generic
imports "../Semantics_Ternary/Semantics_Ternary"
        Common_Primitive_Syntax
        "../Semantics_Ternary/Unknown_Match_Tacs"
begin

subsection\<open>A Generic primitive matcher: Agnostic of IP Addresses\<close>

text\<open>Generalized Definition agnostic of IP Addresses fro IPv4 and IPv6\<close>

(*generic assumptions for a common matcher without information about IPs.
  used to add ipv6 integration without duplicating all proofs *)
locale primitive_matcher_generic =
  fixes \<beta> :: "('i::len common_primitive, ('i::len, 'a) tagged_packet_scheme) exact_match_tac"
  assumes IIface: "\<forall> p i. \<beta> (IIface i) p = bool_to_ternary (match_iface i (p_iiface p))"
      and OIface: "\<forall> p i. \<beta> (OIface i) p = bool_to_ternary (match_iface i (p_oiface p))"
        and Prot: "\<forall> p proto. \<beta> (Prot proto) p = bool_to_ternary (match_proto proto (p_proto p))"
   and Src_Ports: "\<forall> p proto ps. \<beta> (Src_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p \<and> p_sport p \<in> ports_to_set ps)"
   and Dst_Ports: "\<forall> p proto ps. \<beta> (Dst_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p \<and> p_dport p \<in> ports_to_set ps)"
   -- "-m multiport --ports matches source or destination port"
   and MultiportsPorts: "\<forall> p proto ps. \<beta> (MultiportPorts (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p \<and> (p_sport p \<in> ports_to_set ps \<or> p_dport p \<in> ports_to_set ps))"
    and L4_Flags: "\<forall> p flags. \<beta> (L4_Flags flags) p = bool_to_ternary (match_tcp_flags flags (p_tcp_flags p))"
    and CT_State: "\<forall> p S. \<beta> (CT_State S) p = bool_to_ternary (match_ctstate S (p_tag_ctstate p))"
        and Extra: "\<forall> p str. \<beta> (Extra str) p = TernaryUnknown"
begin
  lemma Iface_single:
    "matches (\<beta>, \<alpha>) (Match (IIface X)) a p \<longleftrightarrow> match_iface X (p_iiface p)"
    "matches (\<beta>, \<alpha>) (Match (OIface X)) a p \<longleftrightarrow> match_iface X (p_oiface p)"
     by(simp_all add: IIface OIface match_raw_ternary bool_to_ternary_simps
               split: ternaryvalue.split)
  text\<open>Since matching on the iface cannot be @{const TernaryUnknown}*, we can pull out negations.\<close>
  lemma Iface_single_not:
    "matches (\<beta>, \<alpha>) (MatchNot (Match (IIface X))) a p \<longleftrightarrow> \<not> match_iface X (p_iiface p)"
    "matches (\<beta>, \<alpha>) (MatchNot (Match (OIface X))) a p \<longleftrightarrow> \<not> match_iface X (p_oiface p)"
     by(simp_all add: IIface OIface matches_case_ternaryvalue_tuple bool_to_ternary_simps
          split: ternaryvalue.split)

  lemma Prot_single:
    "matches (\<beta>, \<alpha>) (Match (Prot X)) a p \<longleftrightarrow> match_proto X (p_proto p)"
     by(simp add: Prot match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split)
  lemma Prot_single_not:
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Prot X))) a p \<longleftrightarrow> \<not> match_proto X (p_proto p)"
     by(simp add: Prot matches_case_ternaryvalue_tuple bool_to_ternary_simps split: ternaryvalue.split)

  lemma Ports_single:
    "matches (\<beta>, \<alpha>) (Match (Src_Ports (L4Ports proto ps))) a p \<longleftrightarrow> proto = p_proto p \<and> p_sport p \<in> ports_to_set ps"
    "matches (\<beta>, \<alpha>) (Match (Dst_Ports (L4Ports proto ps))) a p \<longleftrightarrow> proto = p_proto p \<and> p_dport p \<in> ports_to_set ps"
     by(simp_all add: Src_Ports Dst_Ports match_raw_ternary bool_to_ternary_simps
               split: ternaryvalue.split)
  lemma Ports_single_not:
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Src_Ports (L4Ports proto ps)))) a p \<longleftrightarrow> proto \<noteq> p_proto p \<or> p_sport p \<notin> ports_to_set ps"
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Dst_Ports (L4Ports proto ps)))) a p \<longleftrightarrow> proto \<noteq> p_proto p \<or> p_dport p \<notin> ports_to_set ps"
     by(simp_all add: Src_Ports Dst_Ports matches_case_ternaryvalue_tuple bool_to_ternary_simps
               split: ternaryvalue.split)

  text\<open>Ports are dependent matches. They always match on the protocol too\<close>
  lemma Ports_single_rewrite_Prot:
    "matches (\<beta>, \<alpha>) (Match (Src_Ports (L4Ports proto ps))) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (Match (Prot (Proto proto))) a p \<and> p_sport p \<in> ports_to_set ps"
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Src_Ports (L4Ports proto ps)))) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (MatchNot (Match (Prot (Proto proto)))) a p \<or> p_sport p \<notin> ports_to_set ps"
    "matches (\<beta>, \<alpha>) (Match (Dst_Ports (L4Ports proto ps))) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (Match (Prot (Proto proto))) a p \<and> p_dport p \<in> ports_to_set ps"
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Dst_Ports (L4Ports proto ps)))) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (MatchNot (Match (Prot (Proto proto)))) a p \<or> p_dport p \<notin> ports_to_set ps"
  by(auto simp add: Ports_single_not Ports_single Prot_single_not Prot_single)

  lemma multiports_disjuction:
        "(\<exists>rg\<in>set spts. matches (\<beta>, \<alpha>) (Match (Src_Ports (L4Ports proto [rg]))) a p) \<longleftrightarrow> matches (\<beta>, \<alpha>) (Match (Src_Ports (L4Ports proto spts))) a p"
        "(\<exists>rg\<in>set dpts. matches (\<beta>, \<alpha>) (Match (Dst_Ports (L4Ports proto [rg]))) a p) \<longleftrightarrow> matches (\<beta>, \<alpha>) (Match (Dst_Ports (L4Ports proto dpts))) a p"
    by(auto simp add: Src_Ports Dst_Ports match_raw_ternary bool_to_ternary_simps ports_to_set
                   split: ternaryvalue.split)

  lemma MultiportPorts_single_rewrite:
    "matches (\<beta>, \<alpha>) (Match (MultiportPorts ports)) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (Match (Src_Ports ports)) a p \<or> matches (\<beta>, \<alpha>) (Match (Dst_Ports ports)) a p"
    apply(cases ports)
    apply(simp add: Ports_single)
    by(simp add: MultiportsPorts match_raw_ternary bool_to_ternary_simps
            split: ternaryvalue.split)
  lemma MultiportPorts_single_rewrite_MatchOr:
    "matches (\<beta>, \<alpha>) (Match (MultiportPorts ports)) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (MatchOr (Match (Src_Ports ports)) (Match (Dst_Ports ports))) a p"
    apply(cases ports)
    by(simp add: MatchOr MultiportPorts_single_rewrite)

  lemma MultiportPorts_single_not_rewrite_MatchAnd:
    "matches (\<beta>, \<alpha>) (MatchNot (Match (MultiportPorts ports))) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) (MatchAnd (MatchNot (Match (Src_Ports ports))) (MatchNot (Match (Dst_Ports ports)))) a p"
    apply(cases ports)
    apply(simp add: Ports_single_not bunch_of_lemmata_about_matches)
    by(simp add: MultiportsPorts matches_case_ternaryvalue_tuple bool_to_ternary_simps
            split: ternaryvalue.split)
  lemma MultiportPorts_single_not_rewrite:
    "matches (\<beta>, \<alpha>) (MatchNot (Match (MultiportPorts ports))) a p \<longleftrightarrow>
      \<not> matches (\<beta>, \<alpha>) (Match (Src_Ports ports)) a p \<and> \<not> matches (\<beta>, \<alpha>) (Match (Dst_Ports ports)) a p"
    apply(cases ports)
    by(simp add: MultiportPorts_single_not_rewrite_MatchAnd bunch_of_lemmata_about_matches
                 Ports_single_not Ports_single)

  lemma Extra_single:
    "matches (\<beta>, \<alpha>) (Match (Extra str)) a p \<longleftrightarrow> \<alpha> a p"
     by(simp add: Extra match_raw_ternary)
  lemma Extra_single_not:  --\<open>ternary logic, @{text "\<not> unknown = unknown"}\<close>
    "matches (\<beta>, \<alpha>) (MatchNot (Match (Extra str))) a p \<longleftrightarrow> \<alpha> a p"
     by(simp add: Extra matches_case_ternaryvalue_tuple)
end

subsection\<open>Basic optimisations\<close>

  (*this is currently not used.*)
  text\<open>Compress many @{const Extra} expressions to one expression.\<close>
  fun compress_extra :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
    "compress_extra (Match x) = Match x" |
    "compress_extra (MatchNot (Match (Extra e))) = Match (Extra (''NOT (''@e@'')''))" |
    "compress_extra (MatchNot m) = (MatchNot (compress_extra m))" |
    (*"compress_extra (MatchAnd (Match (Extra e1)) (Match (Extra e2))) = compress_extra (Match (Extra (e1@'' ''@e2)))" |*)
    (*"compress_extra (MatchAnd (Match (Extra e1)) MatchAny) = Match (Extra e1)" |*)
    "compress_extra (MatchAnd (Match (Extra e1)) m2) = (case compress_extra m2 of Match (Extra e2) \<Rightarrow> Match (Extra (e1@'' ''@e2)) | MatchAny \<Rightarrow> Match (Extra e1) | m2' \<Rightarrow> MatchAnd (Match (Extra e1)) m2')" |
    "compress_extra (MatchAnd m1 m2) = MatchAnd (compress_extra m1) (compress_extra m2)" |
    (*"compress_extra (MatchAnd m1 m2) = (case (compress_extra m1, compress_extra m2) of
          (Match (Extra e1), Match (Extra e2)) \<Rightarrow> Match (Extra (e1@'' ''@e2))
        | (Match (Extra e1), MatchAny) \<Rightarrow> Match (Extra e1)
        | (MatchAny, Match (Extra e2)) \<Rightarrow> Match (Extra e2)
        | (m1', m2') \<Rightarrow> MatchAnd m1' m2')" |*)
    "compress_extra MatchAny = MatchAny"

  thm compress_extra.simps

  value "compress_extra (MatchAnd (Match (Extra ''foo'')) (Match (Extra ''bar'')))"
  value "compress_extra (MatchAnd (Match (Extra ''foo'')) (MatchNot (Match (Extra ''bar''))))"
  value "compress_extra (MatchAnd (Match (Extra ''-m'')) (MatchAnd (Match (Extra ''addrtype'')) (MatchAnd (Match (Extra ''--dst-type'')) (MatchAnd (Match (Extra ''BROADCAST'')) MatchAny))))"

  lemma compress_extra_correct_matchexpr:
    fixes \<beta>::"('i::len common_primitive, ('i::len, 'a) tagged_packet_scheme) exact_match_tac"
    assumes generic: "primitive_matcher_generic \<beta>"
    shows "matches (\<beta>, \<alpha>) m = matches (\<beta>, \<alpha>) (compress_extra m)"
    proof(simp add: fun_eq_iff, clarify, rename_tac a p)
      fix a and p :: "('i, 'a) tagged_packet_scheme"
      from generic have "\<beta> (Extra e) p = TernaryUnknown" for e by(simp add: primitive_matcher_generic.Extra)
      hence "ternary_ternary_eval (map_match_tac \<beta> p m) = ternary_ternary_eval (map_match_tac \<beta> p (compress_extra m))"
        proof(induction m rule: compress_extra.induct)
        case 4 thus ?case
          by(simp_all split: match_expr.split match_expr.split_asm common_primitive.split)
        qed (simp_all)
      thus "matches (\<beta>, \<alpha>) m a p = matches (\<beta>, \<alpha>) (compress_extra m) a p"
        by(rule matches_iff_apply_f)
      qed

end


theory Hoare_Step imports Hoare Hoare_Indexed Hoare_Direct
 "../Lifter/Auto_Lifter_Proofs"
 "../Mergeable/Mergeable_Instances"
 "../Composition/Composition" "../Composition/Dominant"
 "../Language_Components/Seq/Seq_Hoare"
 "Hoare_Lift" "Hoare_Lift_Transform" "../Lifter/Toggle"
begin

(*
 * When dealing with single-step languages, we have an important special case - that is,
 * the case where the single-step language is _dominant_ (see Composition/Dominant.thy)
 * for one or more pieces of syntax. In such cases we can show that the
 * lifted version of the rule holds without side conditions.
 *)

(* TODO - decouple this from seq *)

(* However, we might be able to avoid reasoning about liftings at all in such cases (?)
 * by playing the same parametricity trick as with the control languages?
 *)

definition no_control_lifting :: "('a, 'b1, 'b2 :: {Bogus, Pord}) lifting \<Rightarrow>
  ('a, 'b1, ('x, 'b2) control) lifting" where
"no_control_lifting l =
  schem_lift NC (SP NX (SP NX (SINJ l NC)))"

definition no_control_lifting_S ::"
('a, 'b1, 'b2 :: {Bogus, Pord}) lifting \<Rightarrow>
  ('a \<Rightarrow> 'b2 set) \<Rightarrow>
  ('a \<Rightarrow> ('x, 'b2) control set)" where
"no_control_lifting_S l S =
  schem_lift_S NC (SP NX (SP NX (SINJS l S NC)))"

(* something is weird with the pord constraint here. *)
definition no_control_l :: "
('a, 'b1, 'b2 :: {Bogus, Pord, Okay}) lifting \<Rightarrow>
('a \<Rightarrow> 'b1 \<Rightarrow> 'b1 :: {Bogus, Pord, Okay}) \<Rightarrow>
('a \<Rightarrow> ('x, 'b2 :: {Bogus, Pord, Okay}) control \<Rightarrow> ('x, 'b2 ) control)" where
"no_control_l l f =
  lift_map_s id (no_control_lifting l) f"

lemma no_control_l_valid :
  assumes H : "lifting_valid_ok l S"
  shows "lifting_valid_ok (no_control_lifting l) (no_control_lifting_S l S)"
  using H
  unfolding no_control_lifting_def no_control_lifting_S_def schem_lift_defs schem_lift_S_defs
  by(fastforce intro: lifting_valid_fast lifting_ortho_fast
  dest: lifting_valid_locale_axioms
)
  (*
lemma HTS_imp_HT' :
  fixes fs :: "('b \<Rightarrow> ('b, 'c) control \<Rightarrow> ('b, 'c :: {Bogus, Mergeableb, Okay}) control) list"
  assumes H: "f % {{P1}} c {{P2}}"
  assumes Valid : "lifting_valid_ok l S"
  assumes Hf' : "f' = no_control_l l f"
  assumes H0 : "gs = pcomps fs"
  (* was payload ` ok_S *)
(*
  assumes Hpres : "sups_pres (set fs) (\<lambda> _ . (ok_S :: ('b, 'c) control set))"

*)
  assumes Hpres : "sups_pres (set fs) (\<lambda> _ . (ok_S :: ('b, 'c) control set))"
  assumes Hseq : "seq_sem_l_gen lfts \<in> set fs"
  assumes Skip : "lfts c = Sskip"
  assumes Cin : "c \<in> X"
  assumes Hnemp : "g \<in> (set fs - {seq_sem_l_gen lfts})"
  assumes Hdom : "(f' \<downharpoonleft> (set fs - {seq_sem_l_gen lfts}) X)"
  shows "|gs| {~ (lift_pred_valid_ok_s id l c P1) ~} [G c z] {~ (lift_pred_valid_ok_s id l c P2) ~}"
proof(rule HT'I)
  fix npost

  interpret V: lifting_valid_ok l S
    using Valid .

  have "|#gs#| {#-lift_pred_valid_ok_s id l c
                     P1, (0 +
                          npost)-#} [G c z] {#-lift_pred_valid_ok_s id l c
       P2, npost-#}"
    unfolding add_0
  proof
    fix c'

    assume Guard : "|#gs#| {#lift_pred_valid_ok_s id l c P2, npost#} c'"
    show "|#gs#| {#lift_pred_valid_ok_s id l c P1, npost#} ([G c z] @ c')"
    proof
      fix m :: "('b, 'c) control"
      assume Ok : "m \<in> ok_S"
      assume Hpay : "lift_pred_valid_ok_s id l c P1 (payload m)"
      assume Hcont : "cont m = Inl ([G c z] @ c') "

      have Hpay1 : "P1 (LOut l c (payload m))" and Hpay2 : "payload m \<in> S c" and Hpay3 : "payload m \<in> ok_S"
        using Hpay
        using V.ok_S_valid
        unfolding lift_pred_valid_ok_s_def
        unfolding lift_pred_noS_s_def lift_pred_s_def
        by auto

      have Hpay' : "P2 (f c (LOut l c (payload m)))"
        using HTSE[OF H Hpay1]
        by simp

      show "safe_for gs m npost"
      proof(cases "(sem_step gs m)")
        case (Inr bad)

        then have False using Hcont H0
          by(auto simp add: sem_step_def)

        then show ?thesis by auto
      next
        case (Inl m')

        have Huh : "set fs - {seq_sem_l_gen lfts} \<subseteq> set fs" "finite (set fs)"
          by auto
        have Pres' : "sups_pres (set fs - {seq_sem_l_gen lfts}) (\<lambda> _ . ok_S)"
          (*using sups_pres_subset[OF Hpres, of "set fs - {seq_sem_l_gen lfts}"] Hnemp by auto*)
          using sups_pres_subset[OF Hpres Huh(2) Huh(1) Hnemp]
          by(auto)

        obtain fs_sub where Fs_sub : "set fs_sub = set fs - {seq_sem_l_gen lfts}"
          using finite_list[of "set fs - {seq_sem_l_gen lfts}"]
          by auto

(* ok, so the idea now is:
- we know full step (op + control flow) leads to m'
- dominance over everything but the seq means we can treat it as
  "op (dominant thing) then seq"
- we can then unfold these things in order and everything should be ok.
*)

(* this does not hold in general now - need to use some information about the input. *)
(* gs c m specifically is all we need *)

        have Assoc :
             "pcomps (fs_sub @ [seq_sem_l_gen lfts]) c m =
              pcomps [pcomps fs_sub, pcomps [seq_sem_l_gen lfts]] c m"
        proof(rule pcomps_assoc[where S = "\<lambda> _ . ok_S"])

          have "set fs - {seq_sem_l_gen lfts} \<union> set [seq_sem_l_gen lfts] = set fs"
            using Hseq
            by(simp; blast)

          then show "\<And> s x . sups_pres (set fs_sub \<union> set [seq_sem_l_gen lfts]) (\<lambda> _ . ok_S)"
            unfolding Fs_sub
            using Hpres
            by auto
        next

          have "set fs_sub \<noteq> {}" using Hnemp unfolding Fs_sub by auto

          then show "fs_sub \<noteq> []" by auto
        next

          show "[seq_sem_l_gen lfts] \<noteq> []" by simp
        next
          show "m \<in> ok_S"
            using Ok .
        qed

        have Set_alt : "set (fs_sub @ [seq_sem_l_gen lfts]) = set fs"
          unfolding set_append Fs_sub
          using Un_Diff_cancel2 Hseq
          by auto

        have Gs_alt : "gs c m = pcomps (fs_sub @ [seq_sem_l_gen lfts]) c m"
          using pcomps_set_eq[OF Hpres Hseq _ Set_alt Ok, of fs] H0
          by auto

(* TODO: find a better solution than this awful type annotation hack *)
        have Seq_pres :
          "sups_pres {(seq_sem_l_gen lfts  :: ('b \<Rightarrow> 'b gensyn list md_triv option md_prio \<times>
            String.literal md_triv option md_prio \<times> 'c
            \<Rightarrow> 'b gensyn list md_triv option md_prio \<times>
               String.literal md_triv option md_prio \<times>
               'c))} (\<lambda> _ . ok_S)"
          using sups_pres_subset[OF Hpres, of "{seq_sem_l_gen lfts}"] Hseq
          by(auto)

        have Gs_alt' : "gs c m = pcomps [pcomps fs_sub, seq_sem_l_gen lfts] c m"
          using Gs_alt pcomps_singleton[OF Seq_pres _ Ok, of "[seq_sem_l_gen lfts]"]
          unfolding Assoc
          unfolding append.simps H0
          by auto

        have Hdom' :  "f' \<downharpoonleft> (set fs_sub) X"
          using Fs_sub Hdom by auto

        have Dominate1 : "pcomps fs_sub c m = f' c m"
          using dominant_pcomps[OF Pres'[folded Fs_sub] _ Hdom' Cin Ok] Pres' Hnemp Fs_sub
          by auto

(* almost have this. the missing ingredient is using the fact that
 * information content will increase (for a strong-valid lifting) *)

(* TODO: declare a lemmas with all the definitions of liftings... *)
        obtain pri1 pri2 rest where Msplit :
          "m = (mdp pri1 (Some (mdt (G c z # c'))), mdp pri2 (Some (mdt (STR ''''))), rest)"
          and Rest : "rest \<in> ok_S"
          using (*Gs_alt'*) Dominate1 Skip Hpay Hcont Hf'
          unfolding lift_pred_valid_ok_s_def lift_pred_noS_s_def

          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def
            lift_pred_s_def lift_pred_valid_ok_s_def lift_pred_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm if_splits)

(* need m' \<in> ok_S *)
        have Rest' : "rest \<in> ok_S"
          using Rest by auto

        hence Rest'' : "rest \<in> S c"
          using V.ok_S_valid
          by auto

        have LUpd_rest1 :
          "rest <[ LUpd l c (f c (LOut l c rest)) rest"
          using V.get_put
          by auto

        have LUpd_rest2 : "[^ LUpd l c (f c (LOut l c rest)) rest, rest ^] = LUpd l c (f c (LOut l c rest)) rest"
          using bsup_base_leq2[OF LUpd_rest1]
          by simp

        then have LOut_m : "LOut (no_control_lifting l) c (gs c m) = LOut (no_control_lifting l) c (f' c m)"
          using Gs_alt' Dominate1 Skip Hpay Hcont Hf' Msplit
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def  lift_map_s_def
            lift_pred_valid_ok_s_def lift_pred_s_def lift_pred_noS_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm if_splits)

(* key sub-result. *)
        have Pay_final : "payload m' = LUpd l c (f c (LOut l c (payload m))) (payload m)"
          using Gs_alt' Dominate1 Skip Hpay Hcont Hf' Msplit Inl LUpd_rest2
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            seq_sem_lifting_gen_def  lift_map_s_def lift_pred_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm)

(* key sub-result. idea here is that no_control_l means we won't overwrite. *)
        have Cont_final : "cont m' = cont (seq_sem_l_gen lfts c m)"
          using Hcont Msplit Skip Inl Gs_alt' Dominate1 Hf'
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            seq_sem_lifting_gen_def  lift_map_s_def lift_pred_s_def lift_pred_noS_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup triv_bsup no_control_l_def prio_bsup option_bsup leq_refl
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm if_splits)

        hence Cont_final' : "cont m' = Inl c'"
          using Hcont Msplit Skip
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            seq_sem_lifting_gen_def  lift_map_s_def lift_pred_s_def lift_pred_noS_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup triv_bsup no_control_l_def prio_bsup option_bsup leq_refl
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm if_splits)

        have Rest'_ok : "LUpd l c (f c (LOut l c rest)) rest \<in> ok_S"
          using V.ok_S_put[OF Rest']
          by auto

(* the priority being unchanged when updating the control data seems off. *)
        then have Ok' : "m' \<in> ok_S"
          using Gs_alt' Dominate1 Skip Hpay Hcont Hf' Msplit Inl LUpd_rest2 Rest' Ok
          apply(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            seq_sem_lifting_gen_def  lift_map_s_def lift_pred_s_def lift_pred_noS_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup triv_bsup no_control_l_def prio_bsup option_bsup leq_refl
            prod_ok_S option_ok_S triv_ok_S prio_ok_S
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm if_splits)
(* this sucks. *)
          apply(rule_tac x =  "mdp (Suc pri1) (Some (mdt c'))" in exI)
          apply(rule_tac x = "mdp pri2 (Some (mdt (STR '''')))" in exI)
          apply(rule_tac x = "LUpd l c (f c (LOut l c rest)) rest" in exI)
          by(auto)

        have Conc' : "safe_for gs m' npost"
          using guardediD[OF Guard Ok'] Hpay' Cont_final' Rest'_ok Ok' Hpay3
          unfolding Pay_final Cont_final' lift_pred_s_def lift_pred_noS_s_def lift_pred_valid_ok_s_def lift_pred_s_def
          using V.put_get[ of c "f c (LOut l c (payload m))" "payload m"] V.ok_S_put
          by(cases m; auto)

        have Inl_alt : "sem_step_p gs m m'"
          using Inl unfolding sem_step_p_eq by simp

        show  "safe_for gs m npost"
          using safe_for_weaken[OF safe_for_extend[OF Conc' Excp_1[OF Inl_alt]], of npost]
          by simp
      qed
    qed
  qed

  thus "\<exists>npre.
          |#gs#| {#-lift_pred_valid_ok_s id l c
                     P1, (npre + npost)-#} [G c z] {#-lift_pred_valid_ok_s id l c P2, npost-#}"
    by blast
qed
*)

lemma HTS_imp_HT'' :
  fixes fs :: "('b \<Rightarrow> ('b, 'c) control \<Rightarrow> ('b, 'c :: {Bogus, Mergeableb, Okay}) control) list"
(*
  fixes f :: "'syn0 \<Rightarrow> 'st0 \<Rightarrow> 'st0"
  fixes x :: "'syn1"
  fixes l' :: "('syn1 \<Rightarrow> 'syn0)"
*)
  assumes H: "f % {{P'}} (l' x) {{Q'}}"
  (* TODO: can we weaken this to lifting_valid_weak_ok *)
  assumes Valid : "lifting_valid_ok l S"
  assumes Hf' : "f' = lift_map_t_s l' (no_control_lifting  l) tg f"
  assumes H0 : "gs = pcomps fs"
  assumes Hpres : "sups_pres (set fs) (\<lambda> _ . ok_S)"
  assumes Hseq : "seq_sem_l_gen lfts \<in> set fs"
  assumes Skip : "lfts x = Sskip"
  assumes Active : "tg x = True"
  assumes Xin : "x \<in> X"
  assumes Hnemp : "g \<in> (set fs - {seq_sem_l_gen lfts})"
  assumes Hdom : "(f' \<downharpoonleft> (set fs - {seq_sem_l_gen lfts}) X)"
  assumes HP : "\<And> st . P st \<Longrightarrow> P' (LOut l (l' x) st)"

  shows "|gs| {~ (\<lambda> st . P st) ~} [G x z]
    {~ (\<lambda> st . \<exists> old_big small_new . P old_big \<and> Q' small_new \<and> st = LUpd l (l' x) small_new old_big) ~}"
  (*shows "\<And> P1 . |gs| {~ P1 ~} [G c z] {~ (liftt_conc id l c P2 P1) ~}"*)
proof(rule HT'I)
  fix npost

  interpret V : lifting_valid_ok l S
    using Valid .

  have "|#gs#| {#-(\<lambda>st. P st), (0 + npost)-#} [G x z] {#-(\<lambda>st. \<exists>old_big small_new.
            P old_big \<and>
            Q' small_new \<and>
            st = LUpd l (l' x)  small_new old_big), npost-#}"
    unfolding add_0
  proof
    fix c'

    assume Guard : " |#gs#| {#(\<lambda>st. \<exists>old_big small_new.
                            P old_big \<and>
                            Q' small_new \<and>
                            st =
                            LUpd l (l' x) small_new
                             old_big), npost#} c'"
    show "|#gs#| {#P, npost#} ([G x z] @ c')"
    proof
      fix m :: "('b, 'c) control"
      assume Ok : "m \<in> ok_S"
      assume Hpay0 : "P (payload m)" and Hcont : "cont m = Inl ([G x z] @ c') "

      show "safe_for gs m npost"
      proof(cases "(sem_step gs m)")
        case (Inr bad)

        then have False using Hcont H0
          by(auto simp add: sem_step_def)

        then show ?thesis by auto
      next
        case (Inl m')

        have Pres' : "sups_pres (set fs - {seq_sem_l_gen lfts}) (\<lambda> _ . ok_S)"
          using sups_pres_subset[OF Hpres, of "set fs - {seq_sem_l_gen lfts}"] by auto

        obtain fs_sub where Fs_sub : "set fs_sub = set fs - {seq_sem_l_gen lfts}"
          using finite_list[of "set fs - {seq_sem_l_gen lfts}"]
          by auto

(* ok, so the idea now is:
- we know full step (op + control flow) leads to m'
- dominance over everything but the seq means we can treat it as
  "op (dominant thing) then seq"
- we can then unfold these things in order and everything should be ok.
*)

        have Assoc :
             "pcomps (fs_sub @ [seq_sem_l_gen lfts]) x m =
              pcomps [pcomps fs_sub, pcomps [seq_sem_l_gen lfts]] x m"
        proof(rule pcomps_assoc)

          have "set fs - {seq_sem_l_gen lfts} \<union> set [seq_sem_l_gen lfts] = set fs"
            using Hseq
            by(simp; blast)

          then show "sups_pres (set fs_sub \<union> set [seq_sem_l_gen lfts]) (\<lambda> _ . ok_S)"
            unfolding Fs_sub
            using Hpres
            by auto
        next

          have "set fs_sub \<noteq> {}" using Hnemp unfolding Fs_sub by auto

          then show "fs_sub \<noteq> []" by auto
        next

          show "[seq_sem_l_gen lfts] \<noteq> []" by simp
        next
          show "m \<in> ok_S"
            using Ok .
        qed

        have Set_alt : "set (fs_sub @ [seq_sem_l_gen lfts]) = set fs"
          unfolding set_append Fs_sub
          using Un_Diff_cancel2 Hseq
          by auto

        have Gs_alt : "gs x m = pcomps (fs_sub @ [seq_sem_l_gen lfts]) x m"
          using pcomps_set_eq[OF Hpres Hseq _ Set_alt Ok, of fs] H0
          by auto

        have Hpay : "P (payload m)"
          using Hpay0
          by auto

        then have Hpay_S : "payload m \<in> ok_S"
          using Ok by(cases m; auto simp add: prod_ok_S)

        have Hpay1' : "LOut l (l' x) (payload m) = LOut l (l' x) (payload m) \<and> P (payload m)"
          using Hpay
          by simp

      have Hpay' : "Q' (f (l' x) (LOut l (l' x) (payload m)))"
        using HTSE[OF H ] HP[OF Hpay]
        by auto

  (*
        then have Hpay1 : "\<exists>full. LOut l (id c) full = LOut l c (payload m) \<and> P1 full" using Hpay_S
          by auto

        have Hpay' : " P2 (\<lambda>st. \<exists>full. LOut l (id c) full = st \<and> P1 full) (f c (LOut l c (payload m)))"
          using HTSE[OF H ] Hpay1
          by auto
*)
(* TODO: find a better solution than this awful type annotation hack *)

        have Seq_pres :
          "sups_pres {(seq_sem_l_gen lfts  ::('b \<Rightarrow> 'b gensyn list md_triv option md_prio \<times>
            String.literal option md_triv option md_prio \<times> 'c
            \<Rightarrow> 'b gensyn list md_triv option md_prio \<times>
               String.literal option md_triv option md_prio \<times>
               'c))} (\<lambda> _ . ok_S)"
          using sups_pres_subset[OF Hpres, of "{(seq_sem_l_gen lfts )}"] Hseq
          by(auto)

        have Gs_alt' : "gs x m = pcomps [pcomps fs_sub, seq_sem_l_gen lfts] x m"
          using Gs_alt pcomps_singleton[OF Seq_pres _ Ok, of "[seq_sem_l_gen lfts]"]
          unfolding Assoc
          unfolding append.simps H0
          by auto

        have Hdom' :  "f' \<downharpoonleft> (set fs_sub) X"
          using Fs_sub Hdom by auto

        have Dominate1 : "pcomps fs_sub x m = f' x m"
          using dominant_pcomps[OF Pres'[unfolded sym[OF Fs_sub]] Hnemp[unfolded sym[OF Fs_sub]] Hdom' Xin Ok]
          by auto
        obtain pri1 pri2 rest where Msplit :
          "m = (mdp pri1 (Some (mdt (G x z # c'))), mdp pri2 (Some (mdt None)), rest)" and Rest : "rest \<in> ok_S"
          using Gs_alt' Dominate1 (*Dominate1_weak*) Skip Hpay Hcont Hf' Hpay_S
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def
            lift_pred_valid_ok_s_def lift_pred_noS_s_def lift_pred_s_def lift_map_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm if_splits)

        have Rest' : "rest \<in> S (l' x)"
          using V.ok_S_valid Rest by auto

        have LUpd_rest1 :
          "rest <[ LUpd l (l' x) (f (l' x) (LOut l (l' x) rest)) rest"
          using
            V.get_put
          by auto

        have LUpd_rest2 : "[^ LUpd l (l' x) (f (l' x) (LOut l (l' x) rest)) rest, rest ^] = LUpd l (l' x) (f (l' x) (LOut l (l' x) rest)) rest"
          using bsup_base_leq2[OF LUpd_rest1]
          by simp

(*
        then have LOut_m :
          "LOut (l_synt l' (no_control_lifting l)) x (gs x m) = LOut (l_synt l' (no_control_lifting l)) x (f' x m)"
          using Gs_alt' Dominate1 Skip Hpay Hcont Hf' Msplit
          unfolding l_synt_def
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def
            lift_pred_valid_s_def lift_pred_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm)
*)

(* key sub-result. *)

(* key sub-result. idea here is that no_control_l means we won't overwrite. *)
        have Cont_final : "cont m' = cont (seq_sem_l_gen lfts x m)"
          using Hcont Msplit Skip Inl Gs_alt' Dominate1 Hf' Msplit
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            lift_pred_s_def lift_map_s_def lift_map_t_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def prio_bsup option_bsup leq_refl triv_bsup split: md_prio.splits if_splits md_triv.splits option.splits)
(*
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm)
*)
        hence Cont_final' : "cont m' = Inl c'"
          using Hcont Msplit Skip
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            lift_map_s_def lift_pred_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm)

        have Pay_final : "payload m' = LUpd l (l' x) (f (l' x) (LOut l (l' x) (payload m))) (payload m)"
          using Gs_alt' Dominate1 Skip Hpay Hcont Hf' Msplit Inl LUpd_rest2 Active
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            lift_map_s_def lift_map_t_s_def lift_pred_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm)

        have "(P (payload m)) \<and> Q' ((f (l' x) (LOut l (l' x) (payload m)))) \<and>
              payload m' = LUpd l (l' x) (f (l' x) (LOut l (l' x) (payload m)))(payload m)"
          using Hpay' Pay_final Hpay_S Hpay
          by(auto)

        then have Guard_Hyp : "\<exists>old_big small_new.
             P old_big \<and>
             Q' small_new \<and>
             payload m' = LUpd l (l' x) small_new old_big"
          by auto

        have M'_ok : "m' \<in> ok_S"
          using Hcont Msplit Skip Inl Gs_alt' Dominate1 Hf' Msplit Cont_final' Pay_final
            V.ok_S_put[OF Rest]
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            lift_pred_s_def lift_map_s_def lift_map_t_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def prio_bsup option_bsup leq_refl triv_bsup
            prod_ok_S triv_ok_S prio_ok_S option_ok_S
            split: md_prio.splits if_splits md_triv.splits option.splits)

        have Conc' : "safe_for gs m' npost"
          using guardediD[OF Guard, of "m'"]  Cont_final' Guard_Hyp
          using M'_ok
          unfolding Pay_final Cont_final' lift_pred_s_def lift_pred_s_def lift_pred_valid_ok_s_def
            liftt_conc_def

          (*using lifting_validDO[OF Valid'] lifting_validDP[OF Valid'] lifting_validxDP'[OF Valid ]*)
          by(cases m; auto)

        have Inl_alt : "sem_step_p gs m m'"
          using Inl unfolding sem_step_p_eq by simp

        show  "safe_for gs m npost"
          using safe_for_weaken[OF safe_for_extend[OF Conc' Excp_1[OF Inl_alt]], of npost]
          by simp
      qed
    qed
  qed

  thus "\<exists>npre.
          |#gs#| {#-P, (npre +
                        npost)-#} [G x
  z] {#-(\<lambda>st. \<exists>old_big small_new.
                  P old_big \<and>
                  Q' small_new \<and>
                  st = LUpd l (l' x) small_new old_big), npost-#}"
    by blast
qed

lemma HTS_imp_HT''' :
  fixes fs :: "('b \<Rightarrow> ('b, 'c) control \<Rightarrow> ('b, 'c :: {Bogus, Mergeableb, Okay}) control) list"
  assumes H: "f % {{P'}} (l' x) {{Q'}}"
  (* TODO: can we weaken this to lifting_valid_weak_ok *)
  assumes Valid : "lifting_valid_ok l S"
  assumes Hf' : "f' = lift_map_t_s l' (no_control_lifting  l) tg f"
  assumes H0 : "gs = pcomps fs"
  assumes Hpres : "sups_pres (set fs) (\<lambda> _ . ok_S)"
  assumes Hseq : "seq_sem_l_gen lfts \<in> set fs"
  assumes Skip : "lfts x = Sskip"
  assumes Active : "tg x = True"
  assumes Xin : "x \<in> X"
  assumes Hnemp : "g \<in> (set fs - {seq_sem_l_gen lfts})"
  assumes Hdom : "(f' \<downharpoonleft> (set fs - {seq_sem_l_gen lfts}) X)"
  assumes HP : "\<And> st . P st \<Longrightarrow> P' (LOut l (l' x) st)"

  shows "|gs| {~ (\<lambda> st . P st) ~} [G x z]
    {~ (\<lambda> st . \<exists> old_big . P old_big \<and>
        P' (LOut l (l' x) old_big) \<and>
        Q' (LOut l (l' x) st) \<and>
        st = LUpd l (l' x) (f (l' x) (LOut l (l' x) old_big)) old_big)
         ~}"
(*
{~ (\<lambda> st . \<exists> old_big small_new . P old_big \<and> (case small_new of
                                  (c1, c2, x) \<Rightarrow> x = c1 + c2 \<and>
(\<exists>old. P' (c1, c2, old) \<and> LOut calc_lift' Cadd old_big = (c1, c2, old))) \<and>
                                 st = LUpd calc_lift' Cadd small_new old_big) ~}
*)
  (*shows "\<And> P1 . |gs| {~ P1 ~} [G c z] {~ (liftt_conc id l c P2 P1) ~}"*)
proof(rule HT'I)
  fix npost

  interpret V : lifting_valid_ok l S
    using Valid .

  have "|#gs#| {#-(\<lambda>st. P st), (0 + npost)-#} [G x z] {#-(\<lambda>st. \<exists>old_big.
                 P old_big \<and>
                 P' (LOut l (l' x) old_big) \<and>
                 Q' ((LOut l (l' x) st)) \<and>
                 st = LUpd l (l' x) (f (l' x) (LOut l (l' x) old_big)) old_big), npost-#}"
    unfolding add_0
  proof
    fix c'

    assume Guard : " |#gs#| {#(\<lambda>st. \<exists>old_big.
                 P old_big \<and>
                 P' (LOut l (l' x) old_big) \<and>
                 Q' ((LOut l (l' x) st)) \<and>
                 st = LUpd l (l' x) (f (l' x) (LOut l (l' x) old_big)) old_big), npost#} c'"
    show "|#gs#| {#P, npost#} ([G x z] @ c')"
    proof
      fix m :: "('b, 'c) control"
      assume Ok : "m \<in> ok_S"
      assume Hpay0 : "P (payload m)" and Hcont : "cont m = Inl ([G x z] @ c') "

      show "safe_for gs m npost"
      proof(cases "(sem_step gs m)")
        case (Inr bad)

        then have False using Hcont H0
          by(auto simp add: sem_step_def)

        then show ?thesis by auto
      next
        case (Inl m')

        have Pres' : "sups_pres (set fs - {seq_sem_l_gen lfts}) (\<lambda> _ . ok_S)"
          using sups_pres_subset[OF Hpres, of "set fs - {seq_sem_l_gen lfts}"] by auto

        obtain fs_sub where Fs_sub : "set fs_sub = set fs - {seq_sem_l_gen lfts}"
          using finite_list[of "set fs - {seq_sem_l_gen lfts}"]
          by auto

(* ok, so the idea now is:
- we know full step (op + control flow) leads to m'
- dominance over everything but the seq means we can treat it as
  "op (dominant thing) then seq"
- we can then unfold these things in order and everything should be ok.
*)

        have Assoc :
             "pcomps (fs_sub @ [seq_sem_l_gen lfts]) x m =
              pcomps [pcomps fs_sub, pcomps [seq_sem_l_gen lfts]] x m"
        proof(rule pcomps_assoc)

          have "set fs - {seq_sem_l_gen lfts} \<union> set [seq_sem_l_gen lfts] = set fs"
            using Hseq
            by(simp; blast)

          then show "sups_pres (set fs_sub \<union> set [seq_sem_l_gen lfts]) (\<lambda> _ . ok_S)"
            unfolding Fs_sub
            using Hpres
            by auto
        next

          have "set fs_sub \<noteq> {}" using Hnemp unfolding Fs_sub by auto

          then show "fs_sub \<noteq> []" by auto
        next

          show "[seq_sem_l_gen lfts] \<noteq> []" by simp
        next
          show "m \<in> ok_S"
            using Ok .
        qed

        have Set_alt : "set (fs_sub @ [seq_sem_l_gen lfts]) = set fs"
          unfolding set_append Fs_sub
          using Un_Diff_cancel2 Hseq
          by auto

        have Gs_alt : "gs x m = pcomps (fs_sub @ [seq_sem_l_gen lfts]) x m"
          using pcomps_set_eq[OF Hpres Hseq _ Set_alt Ok, of fs] H0
          by auto

        have Hpay : "P (payload m)"
          using Hpay0
          by auto

        then have Hpay_S : "payload m \<in> ok_S"
          using Ok by(cases m; auto simp add: prod_ok_S)

        have Hpay1' : "LOut l (l' x) (payload m) = LOut l (l' x) (payload m) \<and> P (payload m)"
          using Hpay
          by simp

      have Hpay' : "Q' (f (l' x) (LOut l (l' x) (payload m)))"
        using HTSE[OF H ] HP[OF Hpay]
        by auto

  (*
        then have Hpay1 : "\<exists>full. LOut l (id c) full = LOut l c (payload m) \<and> P1 full" using Hpay_S
          by auto

        have Hpay' : " P2 (\<lambda>st. \<exists>full. LOut l (id c) full = st \<and> P1 full) (f c (LOut l c (payload m)))"
          using HTSE[OF H ] Hpay1
          by auto
*)
(* TODO: find a better solution than this awful type annotation hack *)

        have Seq_pres :
          "sups_pres {(seq_sem_l_gen lfts  ::('b \<Rightarrow> 'b gensyn list md_triv option md_prio \<times>
            String.literal option md_triv option md_prio \<times> 'c
            \<Rightarrow> 'b gensyn list md_triv option md_prio \<times>
               String.literal option md_triv option md_prio \<times>
               'c))} (\<lambda> _ . ok_S)"
          using sups_pres_subset[OF Hpres, of "{(seq_sem_l_gen lfts )}"] Hseq
          by(auto)

        have Gs_alt' : "gs x m = pcomps [pcomps fs_sub, seq_sem_l_gen lfts] x m"
          using Gs_alt pcomps_singleton[OF Seq_pres _ Ok, of "[seq_sem_l_gen lfts]"]
          unfolding Assoc
          unfolding append.simps H0
          by auto

        have Hdom' :  "f' \<downharpoonleft> (set fs_sub) X"
          using Fs_sub Hdom by auto

        have Dominate1 : "pcomps fs_sub x m = f' x m"
          using dominant_pcomps[OF Pres'[unfolded sym[OF Fs_sub]] Hnemp[unfolded sym[OF Fs_sub]] Hdom' Xin Ok]
          by auto
        obtain pri1 pri2 rest where Msplit :
          "m = (mdp pri1 (Some (mdt (G x z # c'))), mdp pri2 (Some (mdt None)), rest)" and Rest : "rest \<in> ok_S"
          using Gs_alt' Dominate1 (*Dominate1_weak*) Skip Hpay Hcont Hf' Hpay_S
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def
            lift_pred_valid_ok_s_def lift_pred_noS_s_def lift_pred_s_def lift_map_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm if_splits)

        have Rest' : "rest \<in> S (l' x)"
          using V.ok_S_valid Rest by auto

        have LUpd_rest1 :
          "rest <[ LUpd l (l' x) (f (l' x) (LOut l (l' x) rest)) rest"
          using
            V.get_put
          by auto

        have LUpd_rest2 : "[^ LUpd l (l' x) (f (l' x) (LOut l (l' x) rest)) rest, rest ^] = LUpd l (l' x) (f (l' x) (LOut l (l' x) rest)) rest"
          using bsup_base_leq2[OF LUpd_rest1]
          by simp

(*
        then have LOut_m :
          "LOut (l_synt l' (no_control_lifting l)) x (gs x m) = LOut (l_synt l' (no_control_lifting l)) x (f' x m)"
          using Gs_alt' Dominate1 Skip Hpay Hcont Hf' Msplit
          unfolding l_synt_def
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def
            lift_pred_valid_s_def lift_pred_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm)
*)

(* key sub-result. *)

(* key sub-result. idea here is that no_control_l means we won't overwrite. *)
        have Cont_final : "cont m' = cont (seq_sem_l_gen lfts x m)"
          using Hcont Msplit Skip Inl Gs_alt' Dominate1 Hf' Msplit
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            lift_pred_s_def lift_map_s_def lift_map_t_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def prio_bsup option_bsup leq_refl triv_bsup split: md_prio.splits if_splits md_triv.splits option.splits)
(*
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm)
*)
        hence Cont_final' : "cont m' = Inl c'"
          using Hcont Msplit Skip
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            lift_map_s_def lift_pred_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm)

        have Pay_final : "payload m' = LUpd l (l' x) (f (l' x) (LOut l (l' x) (payload m))) (payload m)"
          using Gs_alt' Dominate1 Skip Hpay Hcont Hf' Msplit Inl LUpd_rest2 Active
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            lift_map_s_def lift_map_t_s_def lift_pred_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def
            split: md_prio.splits prod.splits md_triv.splits option.splits list.split_asm)

        have "(P (payload m)) \<and> Q' ((f (l' x) (LOut l (l' x) (payload m)))) \<and>
              payload m' = LUpd l (l' x) (f (l' x) (LOut l (l' x) (payload m)))(payload m)"
          using Hpay' Pay_final Hpay_S Hpay
          by(auto)

        then have Guard_Hyp : "\<exists>old_big.
           P old_big \<and>
           P' (LOut l (l' x) old_big) \<and>
           Q' (LOut l (l' x) (payload m')) \<and>
           payload m' = LUpd l (l' x) (f (l' x) (LOut l (l' x) old_big)) old_big"
          apply(rule_tac x = "(payload m)" in exI)
          by(cases m; cases m'; auto simp add: V.put_get HP)

        have M'_ok : "m' \<in> ok_S"
          using Hcont Msplit Skip Inl Gs_alt' Dominate1 Hf' Msplit Cont_final' Pay_final
            V.ok_S_put[OF Rest]
          by(auto simp add: seq_sem_l_gen_def seq_sem_lifting_gen_def sem_step_def
            lift_pred_s_def lift_map_s_def lift_map_t_s_def
            no_control_lifting_def cont_def
            schem_lift_defs fst_l_def snd_l_def prio_l_def triv_l_def option_l_def seq_sem_def
            prod_bsup no_control_l_def prio_bsup option_bsup leq_refl triv_bsup
            prod_ok_S triv_ok_S prio_ok_S option_ok_S
            split: md_prio.splits if_splits md_triv.splits option.splits)

        have Conc' : "safe_for gs m' npost"
          using guardediD[OF Guard, of "m'"]  Cont_final' Guard_Hyp
          using M'_ok
          unfolding Pay_final Cont_final' lift_pred_s_def lift_pred_s_def lift_pred_valid_ok_s_def
            liftt_conc_def

          (*using lifting_validDO[OF Valid'] lifting_validDP[OF Valid'] lifting_validxDP'[OF Valid ]*)
          by(cases m; auto)

        have Inl_alt : "sem_step_p gs m m'"
          using Inl unfolding sem_step_p_eq by simp

        show  "safe_for gs m npost"
          using safe_for_weaken[OF safe_for_extend[OF Conc' Excp_1[OF Inl_alt]], of npost]
          by simp
      qed
    qed
  qed

  thus "\<exists>npre.
          |#gs#| {#-P, (npre +
                        npost)-#} [G x z] {#-(\<lambda>st.
            \<exists>old_big.
               P old_big \<and>
               P' (LOut l (l' x) old_big) \<and>
               Q' (LOut l (l' x) st) \<and>
               st =
               LUpd l (l' x) (f (l' x) (LOut l (l' x) old_big))
                old_big), npost-#}"
    by blast
qed

end


(*  Title:      HOL/HOLCF/IOA/meta_theory/Traces.thy
    Author:     Olaf Müller
*)

section {* Executions and Traces of I/O automata in HOLCF *}

theory Traces
imports Sequence Automata
begin

default_sort type

type_synonym
   ('a,'s)pairs            =    "('a * 's) Seq"

type_synonym
   ('a,'s)execution        =    "'s * ('a,'s)pairs"

type_synonym
   'a trace                =    "'a Seq"

type_synonym
   ('a,'s)execution_module = "('a,'s)execution set * 'a signature"

type_synonym
   'a schedule_module      = "'a trace set * 'a signature"

type_synonym
   'a trace_module         = "'a trace set * 'a signature"

consts

   (* Executions *)

  is_exec_fragC ::"('a,'s)ioa => ('a,'s)pairs -> 's => tr"
  is_exec_frag  ::"[('a,'s)ioa, ('a,'s)execution] => bool"
  has_execution ::"[('a,'s)ioa, ('a,'s)execution] => bool"
  executions    :: "('a,'s)ioa => ('a,'s)execution set"

  (* Schedules and traces *)
  filter_act    ::"('a,'s)pairs -> 'a trace"
  has_schedule  :: "[('a,'s)ioa, 'a trace] => bool"
  has_trace     :: "[('a,'s)ioa, 'a trace] => bool"
  schedules     :: "('a,'s)ioa => 'a trace set"
  traces        :: "('a,'s)ioa => 'a trace set"
  mk_trace      :: "('a,'s)ioa => ('a,'s)pairs -> 'a trace"

  laststate    ::"('a,'s)execution => 's"

  (* A predicate holds infinitely (finitely) often in a sequence *)

  inf_often      ::"('a => bool) => 'a Seq => bool"
  fin_often      ::"('a => bool) => 'a Seq => bool"

  (* fairness of executions *)

  wfair_ex       ::"('a,'s)ioa => ('a,'s)execution => bool"
  sfair_ex       ::"('a,'s)ioa => ('a,'s)execution => bool"
  is_wfair       ::"('a,'s)ioa => 'a set => ('a,'s)execution => bool"
  is_sfair       ::"('a,'s)ioa => 'a set => ('a,'s)execution => bool"
  fair_ex        ::"('a,'s)ioa => ('a,'s)execution => bool"

  (* fair behavior sets *)

  fairexecutions ::"('a,'s)ioa => ('a,'s)execution set"
  fairtraces     ::"('a,'s)ioa => 'a trace set"

  (* Notions of implementation *)
  ioa_implements :: "[('a,'s1)ioa, ('a,'s2)ioa] => bool"   (infixr "=<|" 12)
  fair_implements  :: "('a,'s1)ioa => ('a,'s2)ioa => bool"

  (* Execution, schedule and trace modules *)
  Execs         ::  "('a,'s)ioa => ('a,'s)execution_module"
  Scheds        ::  "('a,'s)ioa => 'a schedule_module"
  Traces        ::  "('a,'s)ioa => 'a trace_module"

defs

(*  ------------------- Executions ------------------------------ *)

is_exec_frag_def:
  "is_exec_frag A ex ==  ((is_exec_fragC A$(snd ex)) (fst ex) ~= FF)"

is_exec_fragC_def:
  "is_exec_fragC A ==(fix$(LAM h ex. (%s. case ex of
      nil => TT
    | x##xs => (flift1
            (%p. Def ((s,p):trans_of A) andalso (h$xs) (snd p))
             $x)
   )))"

executions_def:
  "executions ioa == {e. ((fst e) : starts_of(ioa)) &
                         is_exec_frag ioa e}"

(*  ------------------- Schedules ------------------------------ *)

filter_act_def:
  "filter_act == Map fst"

has_schedule_def:
  "has_schedule ioa sch ==
     (? ex:executions ioa. sch = filter_act$(snd ex))"

schedules_def:
  "schedules ioa == {sch. has_schedule ioa sch}"

(*  ------------------- Traces ------------------------------ *)

has_trace_def:
  "has_trace ioa tr ==
     (? sch:schedules ioa. tr = Filter (%a. a:ext(ioa))$sch)"

traces_def:
  "traces ioa == {tr. has_trace ioa tr}"

mk_trace_def:
  "mk_trace ioa == LAM tr.
     Filter (%a. a:ext(ioa))$(filter_act$tr)"

(*  ------------------- Fair Traces ------------------------------ *)

laststate_def:
  "laststate ex == case Last$(snd ex) of
                      UU  => fst ex
                    | Def at => snd at"

inf_often_def:
  "inf_often P s == Infinite (Filter P$s)"

(*  filtering P yields a finite or partial sequence *)
fin_often_def:
  "fin_often P s == ~inf_often P s"

(* Note that partial execs cannot be wfair as the inf_often predicate in the
   else branch prohibits it. However they can be sfair in the case when all W
   are only finitely often enabled: Is this the right model?
   See LiveIOA for solution conforming with the literature and superseding this one *)
wfair_ex_def:
  "wfair_ex A ex == ! W : wfair_of A.
                      if   Finite (snd ex)
                      then ~Enabled A W (laststate ex)
                      else is_wfair A W ex"

is_wfair_def:
  "is_wfair A W ex == (inf_often (%x. fst x:W) (snd ex)
                     | inf_often (%x.~Enabled A W (snd x)) (snd ex))"

sfair_ex_def:
  "sfair_ex A ex == ! W : sfair_of A.
                      if   Finite (snd ex)
                      then ~Enabled A W (laststate ex)
                      else is_sfair A W ex"

is_sfair_def:
  "is_sfair A W ex ==  (inf_often (%x. fst x:W) (snd ex)
                      | fin_often (%x. Enabled A W (snd x)) (snd ex))"

fair_ex_def:
  "fair_ex A ex == wfair_ex A ex & sfair_ex A ex"

fairexecutions_def:
  "fairexecutions A == {ex. ex:executions A & fair_ex A ex}"

fairtraces_def:
  "fairtraces A == {mk_trace A$(snd ex) | ex. ex:fairexecutions A}"

(*  ------------------- Implementation ------------------------------ *)

ioa_implements_def:
  "ioa1 =<| ioa2 ==
    (((inputs(asig_of(ioa1)) = inputs(asig_of(ioa2))) &
     (outputs(asig_of(ioa1)) = outputs(asig_of(ioa2)))) &
      traces(ioa1) <= traces(ioa2))"

fair_implements_def:
  "fair_implements C A == inp(C) = inp(A) &  out(C)=out(A) &
                          fairtraces(C) <= fairtraces(A)"

(*  ------------------- Modules ------------------------------ *)

Execs_def:
  "Execs A  == (executions A, asig_of A)"

Scheds_def:
  "Scheds A == (schedules A, asig_of A)"

Traces_def:
  "Traces A == (traces A,asig_of A)"

lemmas [simp del] = HOL.ex_simps HOL.all_simps split_paired_Ex
declare Let_def [simp]
setup {* map_theory_claset (fn ctxt => ctxt delSWrapper "split_all_tac") *}

lemmas exec_rws = executions_def is_exec_frag_def

subsection "recursive equations of operators"

(* ---------------------------------------------------------------- *)
(*                               filter_act                         *)
(* ---------------------------------------------------------------- *)

lemma filter_act_UU: "filter_act$UU = UU"
apply (simp add: filter_act_def)
done

lemma filter_act_nil: "filter_act$nil = nil"
apply (simp add: filter_act_def)
done

lemma filter_act_cons: "filter_act$(x>>xs) = (fst x) >> filter_act$xs"
apply (simp add: filter_act_def)
done

declare filter_act_UU [simp] filter_act_nil [simp] filter_act_cons [simp]

(* ---------------------------------------------------------------- *)
(*                             mk_trace                             *)
(* ---------------------------------------------------------------- *)

lemma mk_trace_UU: "mk_trace A$UU=UU"
apply (simp add: mk_trace_def)
done

lemma mk_trace_nil: "mk_trace A$nil=nil"
apply (simp add: mk_trace_def)
done

lemma mk_trace_cons: "mk_trace A$(at >> xs) =
             (if ((fst at):ext A)
                  then (fst at) >> (mk_trace A$xs)
                  else mk_trace A$xs)"

apply (simp add: mk_trace_def)
done

declare mk_trace_UU [simp] mk_trace_nil [simp] mk_trace_cons [simp]

(* ---------------------------------------------------------------- *)
(*                             is_exec_fragC                             *)
(* ---------------------------------------------------------------- *)

lemma is_exec_fragC_unfold: "is_exec_fragC A = (LAM ex. (%s. case ex of
       nil => TT
     | x##xs => (flift1
             (%p. Def ((s,p):trans_of A) andalso (is_exec_fragC A$xs) (snd p))
              $x)
    ))"
apply (rule trans)
apply (rule fix_eq2)
apply (rule is_exec_fragC_def)
apply (rule beta_cfun)
apply (simp add: flift1_def)
done

lemma is_exec_fragC_UU: "(is_exec_fragC A$UU) s=UU"
apply (subst is_exec_fragC_unfold)
apply simp
done

lemma is_exec_fragC_nil: "(is_exec_fragC A$nil) s = TT"
apply (subst is_exec_fragC_unfold)
apply simp
done

lemma is_exec_fragC_cons: "(is_exec_fragC A$(pr>>xs)) s =
                         (Def ((s,pr):trans_of A)
                 andalso (is_exec_fragC A$xs)(snd pr))"
apply (rule trans)
apply (subst is_exec_fragC_unfold)
apply (simp add: Consq_def flift1_def)
apply simp
done

declare is_exec_fragC_UU [simp] is_exec_fragC_nil [simp] is_exec_fragC_cons [simp]

(* ---------------------------------------------------------------- *)
(*                        is_exec_frag                              *)
(* ---------------------------------------------------------------- *)

lemma is_exec_frag_UU: "is_exec_frag A (s, UU)"
apply (simp add: is_exec_frag_def)
done

lemma is_exec_frag_nil: "is_exec_frag A (s, nil)"
apply (simp add: is_exec_frag_def)
done

lemma is_exec_frag_cons: "is_exec_frag A (s, (a,t)>>ex) =
                                (((s,a,t):trans_of A) &
                                is_exec_frag A (t, ex))"
apply (simp add: is_exec_frag_def)
done

(* Delsimps [is_exec_fragC_UU,is_exec_fragC_nil,is_exec_fragC_cons]; *)
declare is_exec_frag_UU [simp] is_exec_frag_nil [simp] is_exec_frag_cons [simp]

(* ---------------------------------------------------------------------------- *)
                           section "laststate"
(* ---------------------------------------------------------------------------- *)

lemma laststate_UU: "laststate (s,UU) = s"
apply (simp add: laststate_def)
done

lemma laststate_nil: "laststate (s,nil) = s"
apply (simp add: laststate_def)
done

lemma laststate_cons: "!! ex. Finite ex ==> laststate (s,at>>ex) = laststate (snd at,ex)"
apply (simp (no_asm) add: laststate_def)
apply (case_tac "ex=nil")
apply (simp (no_asm_simp))
apply (simp (no_asm_simp))
apply (drule Finite_Last1 [THEN mp])
apply assumption
apply defined
done

declare laststate_UU [simp] laststate_nil [simp] laststate_cons [simp]

lemma exists_laststate: "!!ex. Finite ex ==> (! s. ? u. laststate (s,ex)=u)"
apply (tactic "Seq_Finite_induct_tac @{context} 1")
done

subsection "has_trace, mk_trace"

(* alternative definition of has_trace tailored for the refinement proof, as it does not
   take the detour of schedules *)

lemma has_trace_def2:
"has_trace A b = (? ex:executions A. b = mk_trace A$(snd ex))"
apply (unfold executions_def mk_trace_def has_trace_def schedules_def has_schedule_def)
apply auto
done

subsection "signatures and executions, schedules"

(* All executions of A have only actions of A. This is only true because of the
   predicate state_trans (part of the predicate IOA): We have no dependent types.
   For executions of parallel automata this assumption is not needed, as in par_def
   this condition is included once more. (see Lemmas 1.1.1c in CompoExecs for example) *)

lemma execfrag_in_sig:
  "!! A. is_trans_of A ==>
  ! s. is_exec_frag A (s,xs) --> Forall (%a. a:act A) (filter_act$xs)"
apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def},
  @{thm Forall_def}, @{thm sforall_def}] 1 *})
(* main case *)
apply (auto simp add: is_trans_of_def)
done

lemma exec_in_sig:
  "!! A.[|  is_trans_of A; x:executions A |] ==>
  Forall (%a. a:act A) (filter_act$(snd x))"
apply (simp add: executions_def)
apply (tactic {* pair_tac @{context} "x" 1 *})
apply (rule execfrag_in_sig [THEN spec, THEN mp])
apply auto
done

lemma scheds_in_sig:
  "!! A.[|  is_trans_of A; x:schedules A |] ==>
    Forall (%a. a:act A) x"
apply (unfold schedules_def has_schedule_def)
apply (fast intro!: exec_in_sig)
done

subsection "executions are prefix closed"

(* only admissible in y, not if done in x !! *)
lemma execfrag_prefixclosed: "!x s. is_exec_frag A (s,x) & y<<x  --> is_exec_frag A (s,y)"
apply (tactic {* pair_induct_tac @{context} "y" [@{thm is_exec_frag_def}] 1 *})
apply (intro strip)
apply (tactic {* Seq_case_simp_tac @{context} "xa" 1 *})
apply (tactic {* pair_tac @{context} "a" 1 *})
apply auto
done

lemmas exec_prefixclosed =
  conjI [THEN execfrag_prefixclosed [THEN spec, THEN spec, THEN mp]]

(* second prefix notion for Finite x *)

lemma exec_prefix2closed [rule_format]:
  "! y s. is_exec_frag A (s,x@@y) --> is_exec_frag A (s,x)"
apply (tactic {* pair_induct_tac @{context} "x" [@{thm is_exec_frag_def}] 1 *})
apply (intro strip)
apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
apply (tactic {* pair_tac @{context} "a" 1 *})
apply auto
done

end


(*
    File:        AllLambda.thy
    Time-stamp:  <2016-01-06T17:58:00Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory AllLambda
imports dB dBeta SndLAlpha SndLBeta Length FNumber FinBndEx
begin

lemma LAlpha3_iff_LAlpha2:
  assumes infv: "Infinite(LVariable)"
  shows "LAlpha3(M, N) <-> <M, N>: LAlpha2"
apply (rule iff_trans [OF LAlpha3_iff_LAlpha
        infv [THEN LAlpha2_iff_LAlpha, THEN iff_sym]])
done

end