theory MapCompStudy
imports VDMToolkit
begin

(* { x+y \<mapsto> 10 | x \<in> {1,2,3}, y \<in> {4,5,6} } *)
lemma "(\<lambda> dummy . if (\<exists> x y . x \<in> {1,2,3::nat} \<and> y \<in> {4,5,6::nat} \<and> dummy = x + y) then Some 10 else None) =
  [5 \<mapsto> 10, 6 \<mapsto> 10, 7 \<mapsto> 10, 8 \<mapsto> 10, 9 \<mapsto> 10]"
  apply rule
  find_theorems "(if _ then _ else _) = _" -name:SMT
  apply (simp split:if_splits)
  apply rule+
        apply (elim exE conjE)
  apply simp
        apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
(*
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
  apply rule+
        apply (elim exE conjE)
  apply simp
  apply (smt (z3) add_Suc add_cancel_right_left eval_nat_numeral(3) numeral_1_eq_Suc_0 numeral_Bit0)
*)
  oops

(* { x+y \<mapsto> True | x \<in> {1,2,3}, y \<in> {4,5,6} } ; use true so that we can get past the if without the blowup ? *)
lemma "(\<lambda> dummy . if (\<exists> x y . x \<in> {1,2,3::nat} \<and> y \<in> {4,5,6::nat} \<and> dummy = x + y) then Some True else None) =
  [5 \<mapsto> True, 6 \<mapsto> True, 7 \<mapsto> True, 8 \<mapsto> True, 9 \<mapsto> True]"
  apply rule
  apply (cut_tac if_bool_eq_conj)
  apply simp
  oops

lemma "(\<lambda> dummy . if (\<exists> x y . x \<in> {1,2,3::nat} \<and> y \<in> {4,5,6::nat} \<and> dummy = x + y) then Some 10 else None) =
  [5 \<mapsto> 10, 6 \<mapsto> 10, 7 \<mapsto> 10, 8 \<mapsto> 10, 9 \<mapsto> 10]"
  apply rule
  find_theorems "(if _ then _ else _) = _" -name:SMT
  apply (simp split:if_splits)
  apply (intro conjI impI, elim exE conjE) oops

lemma "(\<lambda> dummy . if (\<exists> x y . x \<in> {1,2::nat} \<and> y \<in> {4,5::nat} \<and> dummy = x + y) then Some 10 else None) =
  [5 \<mapsto> 10, 6 \<mapsto> 10, 7 \<mapsto> 10]"
  apply rule
  find_theorems "(if _ then _ else _) = _" -name:SMT
  apply (simp split:if_splits)
  apply rule+
  apply (smt (z3) One_nat_def add_2_eq_Suc eval_nat_numeral(3) numeral_eq_iff plus_1_eq_Suc semiring_norm(89) semiring_norm(90))
  apply rule+
  apply (smt (z3) One_nat_def add_2_eq_Suc eval_nat_numeral(3) numeral_eq_iff plus_1_eq_Suc semiring_norm(89) semiring_norm(90))
     apply rule+
     apply (metis One_nat_def Suc_numeral plus_1_eq_Suc semiring_norm(5) semiring_norm(8))
  apply rule+
  apply (smt (z3) One_nat_def add_2_eq_Suc eval_nat_numeral(3) numeral_eq_iff plus_1_eq_Suc semiring_norm(89) semiring_norm(90))
      apply blast
      apply (metis add_2_eq_Suc eval_nat_numeral(2) eval_nat_numeral(3) semiring_norm(28))
  apply rule+
      apply (smt (z3) One_nat_def add_2_eq_Suc eval_nat_numeral(3) numeral_eq_iff plus_1_eq_Suc semiring_norm(89) semiring_norm(90))
  apply rule+
  apply (smt (z3) One_nat_def add_2_eq_Suc eval_nat_numeral(3) numeral_eq_iff plus_1_eq_Suc semiring_norm(89) semiring_norm(90))
    apply (smt (z3) One_nat_def add_2_eq_Suc eval_nat_numeral(3) numeral_eq_iff plus_1_eq_Suc semiring_norm(89) semiring_norm(90))
    apply rule+
     apply (metis One_nat_def eval_nat_numeral(2) plus_1_eq_Suc semiring_norm(28))
  apply rule+
  apply (smt (z3) One_nat_def add_2_eq_Suc eval_nat_numeral(3) numeral_eq_iff plus_1_eq_Suc semiring_norm(89) semiring_norm(90))
  apply rule+
  apply (smt (z3) One_nat_def add_2_eq_Suc eval_nat_numeral(3) numeral_eq_iff plus_1_eq_Suc semiring_norm(89) semiring_norm(90))
  apply rule+
  apply (smt (z3) One_nat_def add_2_eq_Suc eval_nat_numeral(3) numeral_eq_iff plus_1_eq_Suc semiring_norm(89) semiring_norm(90))
  apply rule+
  apply (smt (z3) One_nat_def add_2_eq_Suc eval_nat_numeral(3) numeral_eq_iff plus_1_eq_Suc semiring_norm(89) semiring_norm(90))
   apply rule+
      apply (metis add_2_eq_Suc eval_nat_numeral(2) eval_nat_numeral(3) semiring_norm(28))
  apply rule+
      apply (metis add_2_eq_Suc eval_nat_numeral(2) eval_nat_numeral(3) semiring_norm(28))
    apply (smt (z3) One_nat_def add_2_eq_Suc eval_nat_numeral(3) numeral_eq_iff plus_1_eq_Suc semiring_norm(89) semiring_norm(90))
      apply (metis add_2_eq_Suc eval_nat_numeral(2) eval_nat_numeral(3) semiring_norm(28))
  done

type_synonym  Map = "nat \<rightharpoonup> nat"

value "[1::nat \<mapsto> 2::nat, 1 \<mapsto> 3] 1"

(* { d |-> r | d in set {1,2::nat}, r in set {2,4::nat} & r = d*2 } *)
lemma "(\<lambda> dummy::nat . if (\<exists> d r . inv_VDMNat d \<and> inv_VDMNat r \<and> d \<in> {1,2::nat} \<and> r \<in> {2,4::nat} \<and> dummy = d \<and> r = d*2) then
              Some 10
          else undefined) =
  [1 \<mapsto> 10, 2 \<mapsto> 10, 3 \<mapsto> 10]"
    apply rule
  apply (simp split:if_splits)
  find_theorems "undefined"

  oops

(* { d |-> 10 | d in set {1,2::nat}, r in set {2,4::nat} & r = d*2 } *)
lemma "(\<lambda> dummy::nat . if (\<exists> d r . inv_VDMNat d \<and> inv_VDMNat r \<and> d \<in> {1,2::nat} \<and> r \<in> {2,4::nat} \<and> dummy = d \<and> r = d*2) then
              Some 10
          else None) =
  [1 \<mapsto> 10, 2 \<mapsto> 10]"
  unfolding inv_VDMNat_def
    apply rule
  by (simp split:if_splits)

(* { d |-> r | d in set {1,2::nat}, r in set {2,4::nat} & r = d*2 } *)
lemma "(\<lambda> dummy::nat . if (\<exists> d r . inv_VDMNat d \<and> inv_VDMNat r \<and> d \<in> {1,2::VDMNat} \<and> r \<in> {2,4::VDMNat} \<and> dummy = d \<and> r = d*2) then
              Some (THE r . (\<exists> d . inv_VDMNat d \<and> inv_VDMNat r \<and> d \<in> {1,2::VDMNat} \<and> r \<in> {2,4::VDMNat} \<and> dummy = d \<and> r = d*2))
          else None) =
  [1 \<mapsto> 2, 2 \<mapsto> 3, 3 \<mapsto> 6]" (* DUH! mistaken input set! *)
  unfolding inv_VDMNat_def
    apply rule
  apply (simp split:if_splits)
  apply (rule+, simp_all)
  apply rule+ (* THE is not quite right; SOME?! NOOOO 2\<mapsto> 4 dummy! *)
  oops

(* { d |-> r | d in set {1,2,3::nat}, r in set {2,4,6::nat} & r = d*2 } *)
lemma "(\<lambda> dummy::nat . if (\<exists> d r . inv_VDMNat d \<and> inv_VDMNat r \<and> d \<in> {1,2,3::VDMNat} \<and> r \<in> {2,4,6::VDMNat} \<and> dummy = d \<and> r = d*2) then
              Some (THE r . (\<exists> v . dummy = v \<and> r = v*2))
          else None) =
  [1 \<mapsto> 2, 2 \<mapsto> 4, 3 \<mapsto> 6]"
  unfolding inv_VDMNat_def
    apply rule
  by (simp split:if_splits)

(* { d |-> r | d in set {1,2,3::nat}, r in set {2,4,6::nat} & r = d*2 } *)
lemma mapComp1: "(\<lambda> dummy::VDMNat . if (\<exists> d \<in> {1,2,3::VDMNat} . \<exists> r \<in> {2,4,6::VDMNat} . inv_VDMNat d \<and> inv_VDMNat r \<and> dummy = d \<and> r = d*2) then
              Some (THE r . (\<exists> d \<in> {1,2,3::VDMNat} . inv_VDMNat d \<and> inv_VDMNat r \<and> dummy = d \<and> r \<in> {2,4,6::VDMNat} \<and> r = d*2))
          else None) =
  [1 \<mapsto> 2, 2 \<mapsto> 4, 3 \<mapsto> 6]"
  unfolding inv_VDMNat_def
  apply rule
  apply (simp split:if_splits)
  apply (rule+, simp_all)
  apply (rule+, simp_all)
  by auto

definition
  mapComp1 :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "mapComp1 \<equiv> (\<lambda> dummy::VDMNat . if (\<exists> d \<in> {1,2,3::VDMNat} . \<exists> r \<in> {2,4,6::VDMNat} . inv_VDMNat d \<and> inv_VDMNat r \<and> dummy = d \<and> r = d*2) then
              Some (THE r . (\<exists> d \<in> {1,2::VDMNat} . inv_VDMNat d \<and> inv_VDMNat r \<and> r \<in> {2,4,6::VDMNat} \<and> dummy = d \<and> r = d*2))
          else None)"

lemma "x \<notin> {1,2,3::VDMNat} \<Longrightarrow>  mapComp1 x = None"
  by (simp add: mapComp1_def inv_VDMNat_def)

lemma "\<not> inv_VDMNat x  \<Longrightarrow> mapComp1  x = None"
  by (simp add: mapComp1_def inv_VDMNat_def)

lemma "x \<in> {1,2,3::VDMNat} \<Longrightarrow> v \<in> {2,4,6::VDMNat} \<Longrightarrow> mapComp1 x = Some v"
  apply (simp add: mapComp1_def inv_VDMNat_def)
  apply (safe, simp_all)
  find_theorems "(THE _ . _) = _"
          apply (rule the1_equality, simp_all)
  find_theorems "(\<exists>! _ . _)" intro
  apply (rule_tac a=2 in ex1I, safe, simp)
          apply (rule the1_equality, simp_all)
  apply (rule_tac a=2 in ex1I, safe, simp) defer
          apply (rule the1_equality, simp_all)
          apply (rule_tac a=2 in ex1I, safe, simp) defer
          apply (rule the1_equality, simp_all)
          apply (rule_tac a=4 in ex1I, safe, simp) defer
         apply (rule the1_equality) defer defer
          apply (rule the1_equality, simp_all)
  apply (rule_tac a=4 in ex1I, safe, simp)
          apply (rule the1_equality, simp_all)
  apply (rule_tac a=4 in ex1I, safe, simp) defer
          apply (rule the1_equality) defer defer
          apply (rule the1_equality)
   (* Ah! has to be THE on both domain and range? No: the mapping isn't direct of course! *)
  oops

definition
  mapComp2 :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "mapComp2 \<equiv> (\<lambda> dummy::VDMNat . if (\<exists> d \<in> {1,2,3::VDMNat} . \<exists> r \<in> {2,4,6::VDMNat} . inv_VDMNat d \<and> inv_VDMNat r \<and> dummy = d \<and> r = d*2) then
              Some (THE r . (\<exists> d \<in> {1,2, 3::VDMNat} . inv_VDMNat d \<and> inv_VDMNat r \<and> r \<in> {2,4,6::VDMNat} \<and> dummy = d \<and> r = d*2))
          else None)"

lemma "x \<notin> dom mapComp2  \<Longrightarrow>  mapComp2 x = None"
  by (simp add: domIff mapComp2_def)

lemma "dom mapComp2 = {1,2,3::VDMNat}"
  unfolding dom_def mapComp2_def inv_VDMNat_def
  by (simp split:if_splits, safe)

lemma "rng mapComp2 = {2,4,6::VDMNat}"
  unfolding ran_def rng_def mapComp2_def inv_VDMNat_def
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, simp_all)
   apply (elim exE conjE impE)
  (* this will be fiddly! *)
  oops

lemma "rng mapComp2 = {2,4,6::VDMNat}"
  unfolding ran_def rng_def mapComp2_def inv_VDMNat_def
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, simp_all)
   apply (elim exE conjE disjE, simp_all)
     apply fastforce
  apply fastforce
   apply fastforce
  by (smt (z3) semiring_norm(83) the_equality verit_eq_simplify(14) zero_le_numeral)

definition
  mapComp :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> \<bool>) \<Rightarrow> ('b \<Rightarrow> \<bool>) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)"
  where
  "mapComp S T inv_S inv_T domexpr rngexpr\<equiv>
        (\<lambda> dummy::'a .
            if (\<exists> d \<in> S . \<exists> r \<in> T . inv_S d \<and> inv_T r \<and> dummy = (domexpr d) \<and> r = (rngexpr d r)) then
                Some (THE r . (\<exists> d \<in> S . inv_S d \<and> r \<in> T \<and> inv_T r \<and> dummy = (domexpr d) \<and> r = (rngexpr d r)))
            else
                None
        )"

text \<open>Isabelle maps are similar to VDMs, but with some significant differences worth observing.

      If the filtering is not unique (i.e. result is not a function), then the @{term "THE x . P x"} expression
      might lead to (undefined) unexpected results. In Isabelle maps, repetitions is equivalent to overriding,
      so that @{lemma "[1::nat \<mapsto> 2, 1 \<mapsto> 3] 1 = Some 3" by simp}.

      In various VDMToolkit definitions, we default to @{term undefined} in case where the situation is out of hand,
      hence, proofs will fail, and users will know that @{term undefined} being reached means some earlier problem has
      occurred.
    \<close>

text \<open>Type bound map comprehension cannot filter for type invariants, hence won't have @{term undefined} results.
      This corresponds to the VDMSL expression
      %
      \begin{vdmssl}
        { domexpr(d) |-> rngexpr(d, r) | d:S, r: T & P(d, r) }
      \end{vdmsl}
      %
      where the maplet expression can be just variables or functions over the domain/range input(s).

      VDM also issues a proof obligation for type bound maps (i.e. avoid it please!) to ensure the resulting map is finite.
      Concretely, the example below generates the corresponding proof obligation:
      %
      \begin{vdmsl}
      	ex: () -> map nat to nat
	      ex() == { x+y |-> 10 | x: nat, y in set {4,5,6} & x < 10 };

        exists finmap1: map nat to (map (nat1) to (nat1)) &
            forall x:nat, y in set {4, 5, 6} & (x < 10) =>
              exists findex2 in set dom finmap1 &
                finmap1(findex2) = {(x + y) |-> 10}
      \end{vdmsl}
     \<close>
definition
  mapCompTypeBound :: "('a \<Rightarrow> \<bool>) \<Rightarrow> ('b \<Rightarrow> \<bool>) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> \<bool>) \<Rightarrow> ('a \<rightharpoonup> 'b)"
  where
  "mapCompTypeBound inv_S inv_T domexpr rngexpr pred \<equiv>
        (\<lambda> dummy::'a .
            if (\<exists> d r . inv_S d \<and> inv_T r \<and> dummy = domexpr d r \<and> r = rngexpr d r \<and> pred d r) then
                Some (THE r . inv_T r \<and> (\<exists> d . dummy = domexpr d r \<and> r = rngexpr d r))
              else
                None
        )"

text \<open>Set bound map comprehension can filter bound set for their elements invariants.
      This corresponds to the VDMSL expression
      %
      \begin{vdmssl}
        { domexpr(d) |-> rngexpr(d, r) | d in set S, r in set T & P(d, r) }
      \end{vdmsl}
      %
      If the filtering is not unique (i.e. result is not a function), then the @{term "THE x . P x"} expression
      might lead to (undefined) unexpected results. In Isabelle maps, repetitions is equivalent to overriding,
      so that @{lemma "[1::nat \<mapsto> 2, 1 \<mapsto> 3] 1 = Some 3" by simp}.
     \<close>
definition
  mapCompSetBind :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> \<bool>) \<Rightarrow> ('b \<Rightarrow> \<bool>) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> \<bool>) \<Rightarrow> ('a \<rightharpoonup> 'b)"
  where
  "mapCompSetBind S T inv_S inv_T domexpr rngexpr pred \<equiv>
        (\<lambda> dummy::'a .
            if inv_VDMSet' inv_S S \<and> inv_VDMSet' inv_T T then
              if (\<exists> d \<in> S . \<exists> r \<in> T . dummy = domexpr d r \<and> r = rngexpr d r \<and> pred d r) then
                Some (THE r . r \<in> T \<and> (\<exists> d \<in> S . dummy = domexpr d r \<and> r = rngexpr d r))
              else
                None
            else
              undefined
        )"

lemmas mapCompSetBind_defs = mapCompSetBind_def inv_VDMSet'_def inv_VDMSet_def
lemmas rng_defs = rng_def ran_def

text \<open>Identity functions to be used for the dom/rng expression functions for the case they are variables.\<close>
definition
  domid :: "'a \<Rightarrow> 'b \<Rightarrow> 'a"
  where
  "domid \<equiv> (\<lambda> d . (\<lambda> r . d))"

definition
  rngid :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
  where
  "rngid \<equiv> (\<lambda> d . id)"

lemma domidI[simp]: "domid d r = d"
  by (simp add: domid_def)

lemma rngidI[simp]: "rngid d r = r"
  by (simp add: rngid_def)

text \<open>Constant function to be used for the rng expression function for the case they are constants.\<close>
definition
  rngcnst :: "'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"
  where
  "rngcnst v \<equiv> (\<lambda> d . (\<lambda> r . v))"

lemma rngcnstI[simp]: "rngcnst v d r = v"
  by (simp add: rngcnst_def)

(*On the explicit (narrower/declared) type, add inv_VDMNat1
  v98: map nat to nat1 = { d \<mapsto> r | d in set {1,2,3}, r in set {2,4,6} & r = d*2 } *)
definition
  ex1 :: "VDMNat \<rightharpoonup> VDMNat1"
  where
  "ex1 \<equiv> mapCompSetBind {1,2,3::VDMNat} {2,4,6::VDMNat} inv_VDMNat inv_VDMNat1 domid rngid (\<lambda> d r . r = d*2)"

lemmas ex1_defs = ex1_def mapCompSetBind_defs inv_VDMNat1_def inv_VDMNat_def

(*On the implicit (wider/presumed) type, add inv_VDMNat
  v98 = { x+y |-> 10 | x in set {1,2,3}, y in set {4,5,6} } *)
definition
  ex2 :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "ex2 \<equiv> mapCompSetBind {1,2,3::VDMNat} {2,4,6::VDMNat} inv_VDMNat inv_VDMNat (\<lambda> d . (\<lambda> r . d+r)) (rngcnst 10) (\<lambda> d .(\<lambda>r . r = d*2))"

lemma "(rngcnst (10::nat)) x y = 10" by (simp add: rngcnst_def)

lemmas ex2_defs = ex2_def mapCompSetBind_defs inv_VDMNat1_def inv_VDMNat_def

lemma ex1_none: "x \<notin> dom ex1  \<Longrightarrow> ex1 x = None"
  by (simp add: domIff)

lemma ex1_dom: "dom ex1 = {1,2,3}"
  unfolding dom_def ex1_defs
  by (simp split:if_splits, safe)

lemma "mapComp2 = ex1"
  unfolding ex1_defs mapComp2_def
  apply simp

lemma ex1_rng:"rng ex1 = {2,4,6}"
  unfolding rng_defs ex1_defs
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, simp_all)
  (* apply (elim exE conjE impE)*)
  (* this will be fiddly! *)
  apply (elim exE conjE disjE, simp_all)
     apply fastforce
  apply fastforce
   apply fastforce
  by (smt (z3) semiring_norm(83) the_equality verit_eq_simplify(14) zero_le_numeral)

end


theory ValueOntologyNew     (*Benzmüller, Fuenmayor & Lomfeld, 2020*)
  imports PreferenceLogicBasics
begin (*** Lomfeld's value ontology is encoded ***)

(*two legal parties (there can be more in principle)*)
datatype c = p | d (*parties/contenders: plaintiff, defendant*)
fun other::"c\<Rightarrow>c" ("_\<inverse>") where "p\<inverse> = d" | "d\<inverse>= p"

consts For::"c\<Rightarrow>\<sigma>"    (*decision: find/rule for party*)
axiomatization where ForAx: "\<lfloor>For x \<^bold>\<leftrightarrow> (\<^bold>\<not>For x\<inverse>)\<rfloor>"

datatype (*ethico-legal upper values (wrt. party)*)
 't VAL = LIBERTY 't | UTILITY 't | SECURITY 't | EQUALITY 't
type_synonym v = "(c)VAL\<Rightarrow>bool" (*principles: sets of upper values*)

abbreviation vset1 ("\<lbrace>_\<rbrace>") where "\<lbrace>\<phi>\<rbrace> \<equiv> \<lambda>x::(c)VAL. x=\<phi>"
abbreviation vset2 ("\<lbrace>_,_\<rbrace>")   where "\<lbrace>\<alpha>,\<beta>\<rbrace> \<equiv> \<lambda>x::(c)VAL. x=\<alpha> \<or> x=\<beta>"

abbreviation util::"c\<Rightarrow>v" ("UTIL\<^sup>_") where "UTIL\<^sup>x \<equiv> \<lbrace>UTILITY  x\<rbrace>"
abbreviation secu::"c\<Rightarrow>v" ("SECU\<^sup>_") where "SECU\<^sup>x \<equiv> \<lbrace>SECURITY x\<rbrace>"
abbreviation equa::"c\<Rightarrow>v" ("EQUA\<^sup>_") where "EQUA\<^sup>x \<equiv> \<lbrace>EQUALITY x\<rbrace>"
abbreviation libe::"c\<Rightarrow>v" ("LIBE\<^sup>_") where "LIBE\<^sup>x \<equiv> \<lbrace>LIBERTY  x\<rbrace>"
abbreviation stab::"c\<Rightarrow>v" ("STAB\<^sup>_") where "STAB\<^sup>x \<equiv> \<lbrace>SECURITY x, UTILITY  x\<rbrace>"
abbreviation effi::"c\<Rightarrow>v" ("EFFI\<^sup>_") where "EFFI\<^sup>x \<equiv> \<lbrace>UTILITY  x, SECURITY x\<rbrace>"
abbreviation gain::"c\<Rightarrow>v" ("GAIN\<^sup>_") where "GAIN\<^sup>x \<equiv> \<lbrace>UTILITY  x, LIBERTY  x\<rbrace>"
abbreviation will::"c\<Rightarrow>v" ("WILL\<^sup>_") where "WILL\<^sup>x \<equiv> \<lbrace>LIBERTY  x, UTILITY  x\<rbrace>"
abbreviation resp::"c\<Rightarrow>v" ("RESP\<^sup>_") where "RESP\<^sup>x \<equiv> \<lbrace>LIBERTY  x, EQUALITY x\<rbrace>"
abbreviation fair::"c\<Rightarrow>v" ("FAIR\<^sup>_") where "FAIR\<^sup>x \<equiv> \<lbrace>EQUALITY x, LIBERTY  x\<rbrace>"
abbreviation equi::"c\<Rightarrow>v" ("EQUI\<^sup>_") where "EQUI\<^sup>x \<equiv> \<lbrace>EQUALITY x, SECURITY x\<rbrace>"
abbreviation reli::"c\<Rightarrow>v" ("RELI\<^sup>_") where "RELI\<^sup>x \<equiv> \<lbrace>SECURITY x, EQUALITY x\<rbrace>"

consts Vrel::"(c)VAL\<Rightarrow>i\<Rightarrow>bool" ("\<I>") (*incidence relation (between values and worlds) *)

(*derivation operators (forming a Galois connection, cf. tests) *)
abbreviation Vint::"\<sigma>\<Rightarrow>v" ("_\<up>") where "W\<up> \<equiv> \<lambda>v. \<forall>x. W x \<longrightarrow> \<I> v x"
abbreviation Vext::"v\<Rightarrow>\<sigma>" ("_\<down>") where "V\<down> \<equiv> \<lambda>w. \<forall>x. V x \<longrightarrow> \<I> x w"
abbreviation clExt::"\<sigma>\<Rightarrow>\<sigma>" ("_\<^sup>o") where "X\<^sup>o \<equiv> X\<up>\<down>"
abbreviation clInt::"v\<Rightarrow>v" ("_\<^sup>v") where "X\<^sup>v \<equiv> X\<down>\<up>"
abbreviation concept::"\<sigma>\<Rightarrow>v\<Rightarrow>bool" ("\<BB>") where "\<BB> A B \<equiv> (A\<up> = B) \<and> (B\<down> = A)"

abbreviation Vagg (infixr "\<^bold>\<oplus>"80) where "v\<^sub>1\<^bold>\<oplus>v\<^sub>2 \<equiv> v\<^sub>1 \<^bold>\<sqinter> v\<^sub>2"
lemma "v\<^sub>1\<down> \<^bold>\<or> v\<^sub>2\<down> \<^bold>\<sqsubseteq> (v\<^sub>1\<^bold>\<oplus>v\<^sub>2)\<down>" by simp
lemma "(v\<^sub>1\<^bold>\<oplus>v\<^sub>2)\<down> \<^bold>\<sqsubseteq> v\<^sub>1\<down> \<^bold>\<or> v\<^sub>2\<down>" nitpick oops
lemma "(v\<^sub>1\<^bold>\<oplus>v\<^sub>2)\<down> \<equiv> (v\<^sub>1\<down> \<^bold>\<or> v\<^sub>2\<down>)\<up>\<down>" nitpick oops

(*useful(???) shorthand notation for aggregated values*)
abbreviation Vagg1 ("[_]") where "[v] \<equiv> v\<down>"
abbreviation Vagg2 ("[_\<oplus>_]") where "[v\<^sub>1\<oplus>v\<^sub>2] \<equiv> (v\<^sub>1 \<^bold>\<oplus> v\<^sub>2)\<down>"
abbreviation Vagg3 ("[_\<oplus>_\<oplus>_]") where "[v\<^sub>1\<oplus>v\<^sub>2\<oplus>v\<^sub>3] \<equiv> (v\<^sub>1 \<^bold>\<oplus> v\<^sub>2 \<^bold>\<oplus> v\<^sub>3)\<down>"
abbreviation Vagg4 ("[_\<oplus>_\<oplus>_\<oplus>_]") where "[v\<^sub>1\<oplus>v\<^sub>2\<oplus>v\<^sub>3\<oplus>v\<^sub>4] \<equiv> (v\<^sub>1 \<^bold>\<oplus> v\<^sub>2 \<^bold>\<oplus> v\<^sub>3 \<^bold>\<oplus> v\<^sub>4)\<down>"

 (* abbreviation relPref::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("_\<^bold>\<prec>_") where "\<phi> \<^bold>\<prec> \<psi> \<equiv> \<phi> \<prec>\<^sub>A\<^sub>E \<psi> "  *)
 (* abbreviation relPrefv::"v\<Rightarrow>v\<Rightarrow>\<sigma>" ("_\<^bold>\<prec>\<^sub>v_") where "\<phi> \<^bold>\<prec>\<^sub>v \<psi> \<equiv> \<phi>\<down> \<prec>\<^sub>A\<^sub>E \<psi>\<down> "  *)
 abbreviation relPref::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>"  ("_\<^bold>\<prec>_") where "\<phi> \<^bold>\<prec> \<psi> \<equiv> \<psi> \<^bold>\<succ>\<^sub>E\<^sub>A \<phi>"
 abbreviation relPrefv::"v\<Rightarrow>v\<Rightarrow>\<sigma>" ("_\<^bold>\<prec>\<^sub>v_") where "\<phi> \<^bold>\<prec>\<^sub>v \<psi> \<equiv> \<psi>\<down> \<^bold>\<succ>\<^sub>E\<^sub>A \<phi>\<down>"

abbreviation indiff ("INDIFF\<^sup>_") where "INDIFF\<^sup>x \<equiv> (\<^bold>\<not>SECU\<^sup>x\<down>) \<^bold>\<and> (\<^bold>\<not>EQUA\<^sup>x\<down>) \<^bold>\<and> (\<^bold>\<not>LIBE\<^sup>x\<down>) \<^bold>\<and> (\<^bold>\<not>UTIL\<^sup>x\<down>)"
abbreviation incnst1 ("INCONS\<^sup>_") where "INCONS\<^sup>x \<equiv> (SECU\<^sup>x \<^bold>\<squnion> EQUA\<^sup>x \<^bold>\<squnion> LIBE\<^sup>x \<^bold>\<squnion> UTIL\<^sup>x)\<down>"
abbreviation incnst2 ("INCONS2\<^sup>_") where "INCONS2\<^sup>x \<equiv> SECU\<^sup>x\<down> \<^bold>\<and> EQUA\<^sup>x\<down> \<^bold>\<and> LIBE\<^sup>x\<down> \<^bold>\<and> UTIL\<^sup>x\<down>"

lemma "\<lfloor>INCONS\<^sup>x \<^bold>\<rightarrow> INCONS2\<^sup>x\<rfloor>" by simp (*both are equivalent: choose the most performant*)
lemma "\<lfloor>INCONS2\<^sup>x \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" by blast

lemma "True" nitpick[satisfy] oops

end


(* Title:      Kleene algebra with tests
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

header {* Transformation Theorem for while Loops *}

theory FolkTheorem
  imports Conway KAT DRAT
begin

text {*
  We prove Kozen's transformation theorem for while loops \cite{Kozen97} in a weak setting that unifies
  previous proofs in Kleene algebra with tests, demonic refinement algebras and a variant of probabilistic
  Kleene algebra.
*}

context pre_conway
begin

abbreviation preservation :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "preserves" 60) where
  "x preserves p \<equiv> test p \<and> p\<cdot>x\<cdot>p = p\<cdot>x \<and> !p\<cdot>x\<cdot>!p = !p\<cdot>x"

lemma preserves_test_closed: "\<lbrakk>test p; x preserves q\<rbrakk> \<Longrightarrow> p\<cdot>x preserves q"
  apply (auto, metis mult.assoc test_mult_comm_var)
  by (metis mult.assoc test_comp_closed_var test_mult_comm_var)

lemma conditional_helper1:
  assumes  "test r1"
          "x1 preserves q" "y1 preserves q"
          "x2 preserves q" "y2 preserves q"
  shows "p\<cdot>q\<cdot>x1\<cdot>(q\<cdot>r1\<cdot>y1 + !q\<cdot>r2\<cdot>y2)\<^sup>\<dagger>\<cdot>(q\<cdot>!r1 + !q\<cdot>!r2) = p\<cdot>q\<cdot>x1\<cdot>(r1\<cdot>y1)\<^sup>\<dagger>\<cdot>!r1"
proof -
  let ?B = "q\<cdot>!r1 + !q\<cdot>!r2"
  have pres: "q\<cdot>(r1\<cdot>y1) = q \<cdot> (r1\<cdot>y1) \<cdot>q"
    by (metis assms preserves_test_closed)
  hence "q\<cdot>(q\<cdot>r1\<cdot>y1 + !q\<cdot>r2\<cdot>y2)\<^sup>\<dagger> = (q\<cdot>r1\<cdot>y1)\<^sup>\<dagger>\<cdot>q"
    by (metis assms(2-) test_preserve1 dagger_slide mult.assoc)
  hence "p\<cdot>q\<cdot>x1\<cdot>(q\<cdot>r1\<cdot>y1 + !q\<cdot>r2\<cdot>y2)\<^sup>\<dagger>\<cdot>?B = p\<cdot>q\<cdot>x1\<cdot>(q\<cdot>r1\<cdot>y1)\<^sup>\<dagger>\<cdot>q\<cdot>?B"
    by (metis assms(2) mult.assoc)
  also have "... = p\<cdot>q\<cdot>x1\<cdot>(q\<cdot>r1\<cdot>y1)\<^sup>\<dagger>\<cdot>q\<cdot>!r1"
    by (metis assms(5) mult.assoc weak_distrib_left_var test_comp_mult annil add_zeror test_mult_idem_var)
  also have "... = p\<cdot>q\<cdot>x1\<cdot>(r1\<cdot>y1)\<^sup>\<dagger>\<cdot>!r1"
    by (metis pres assms(2) mult.assoc test_preserve)
  finally show ?thesis .
qed

lemma conditional_helper2:
  assumes  "test r2"
          "x1 preserves q" "y1 preserves q"
          "x2 preserves q" "y2 preserves q"
  shows "p\<cdot>!q\<cdot>x2\<cdot>(q\<cdot>r1\<cdot>y1 + !q\<cdot>r2\<cdot>y2)\<^sup>\<dagger>\<cdot>(q\<cdot>!r1 + !q\<cdot>!r2) = p\<cdot>!q\<cdot>x2\<cdot>(r2\<cdot>y2)\<^sup>\<dagger>\<cdot>!r2"
proof -
   let ?B = "q\<cdot>!r1 + !q\<cdot>!r2"
  have pres: "!q\<cdot>(r2\<cdot>y2) = !q \<cdot> (r2\<cdot>y2) \<cdot>!q"
    by (metis assms preserves_test_closed)
  hence "!q\<cdot>(q\<cdot>r1\<cdot>y1 + !q\<cdot>r2\<cdot>y2)\<^sup>\<dagger> = (!q\<cdot>r2\<cdot>y2)\<^sup>\<dagger>\<cdot>!q"
    by (metis assms(2-) test_preserve1[of "!q" "r2\<cdot>y2" "r1\<cdot>y1"] add.commute mult.assoc test_comp_closed_var test_double_comp_var)
  hence "p\<cdot>!q\<cdot>x2\<cdot>(q\<cdot>r1\<cdot>y1 + !q\<cdot>r2\<cdot>y2)\<^sup>\<dagger>\<cdot>?B = p\<cdot>!q\<cdot>x2\<cdot>(!q\<cdot>r2\<cdot>y2)\<^sup>\<dagger>\<cdot>!q\<cdot>?B"
    by (metis assms(4) mult.assoc)
  also have "... = p\<cdot>!q\<cdot>x2\<cdot>(!q\<cdot>r2\<cdot>y2)\<^sup>\<dagger>\<cdot>!q\<cdot>!r2"
    by (metis assms(5) mult.assoc test_comp_closed_var weak_distrib_left_var test_comp_mult2 test_mult_idem_var add_zerol annil)
  also have "... = p\<cdot>!q\<cdot>x2\<cdot>(r2\<cdot>y2)\<^sup>\<dagger>\<cdot>!r2"
    by (metis assms(4) mult.assoc pres test_comp_closed_var test_preserve)
  finally show ?thesis .
qed

theorem conditional:
  assumes "test p" "test r1" "test r2"
          "x1 preserves q" "y1 preserves q"
          "x2 preserves q" "y2 preserves q"
  shows "(p\<cdot>q + !p\<cdot>!q)\<cdot>(p\<cdot>x1\<cdot>(r1\<cdot>y1)\<^sup>\<dagger>\<cdot>!r1 + !p\<cdot>x2\<cdot>(r2\<cdot>y2)\<^sup>\<dagger>\<cdot>!r2) =
      (p\<cdot>q + !p\<cdot>!q)\<cdot>(q\<cdot>x1 + !q\<cdot>x2)\<cdot>((q\<cdot>r1 + !q\<cdot>r2)\<cdot>(q\<cdot>y1 + !q\<cdot>y2))\<^sup>\<dagger>\<cdot>!(q\<cdot>r1 + !q\<cdot>r2)"
proof -
  have "p\<cdot>q\<cdot>(x1\<cdot>(r1\<cdot>y1)\<^sup>\<dagger>\<cdot>!r1) = p\<cdot>q\<cdot>x1\<cdot>(q\<cdot>r1\<cdot>y1 + !q\<cdot>r2\<cdot>y2)\<^sup>\<dagger>\<cdot>(q\<cdot>!r1 + !q\<cdot>!r2)" and "!p\<cdot>!q\<cdot>(x2\<cdot>(r2\<cdot>y2)\<^sup>\<dagger>\<cdot>!r2) = !p\<cdot>!q\<cdot>x2\<cdot>(q\<cdot>r1\<cdot>y1 + !q\<cdot>r2\<cdot>y2)\<^sup>\<dagger>\<cdot>(q\<cdot>!r1 + !q\<cdot>!r2)"
    apply (metis assms(2,4-) conditional_helper1[of r1 q x1 y1 x2 y2 p] mult.assoc)
    by (metis assms(3-) conditional_helper2[of r2 q x1 y1 x2 y2 "!p"] mult.assoc)
  moreover have "(p\<cdot>q + !p\<cdot>!q)\<cdot>(p\<cdot>x1\<cdot>(r1\<cdot>y1)\<^sup>\<dagger>\<cdot>!r1 + !p\<cdot>x2\<cdot>(r2\<cdot>y2)\<^sup>\<dagger>\<cdot>!r2) = p\<cdot>q\<cdot>(x1\<cdot>(r1\<cdot>y1)\<^sup>\<dagger>\<cdot>!r1) + !p\<cdot>!q\<cdot>(x2\<cdot>(r2\<cdot>y2)\<^sup>\<dagger>\<cdot>!r2)"
    by (metis assms(1,4-) cond_distr mult.assoc test_def)
  moreover have "... = (p\<cdot>q\<cdot>x1 + !p\<cdot>!q\<cdot>x2)\<cdot>(q\<cdot>r1\<cdot>y1 + !q\<cdot>r2\<cdot>y2)\<^sup>\<dagger>\<cdot>(q\<cdot>!r1 + !q\<cdot>!r2)"
    by (metis calculation(1) calculation(2) distrib_right')
  moreover have "... = (q\<cdot>p\<cdot>x1 + !q\<cdot>!p\<cdot>x2)\<cdot>(q\<cdot>r1\<cdot>y1 + !q\<cdot>r2\<cdot>y2)\<^sup>\<dagger>\<cdot>(q\<cdot>!r1 + !q\<cdot>!r2)"
    by (metis assms(1) assms(5) test_comp_closed_var test_mult_comm_var)
  moreover have "... = (q\<cdot>p + !q\<cdot>!p)\<cdot>(q\<cdot>x1 + !q\<cdot>x2)\<cdot>((q\<cdot>r1 + !q\<cdot>r2)\<cdot>(q\<cdot>y1 + !q\<cdot>y2))\<^sup>\<dagger>\<cdot>!(q\<cdot>r1 + !q\<cdot>r2)"
    by (metis assms(1-3,5) cond_distr de_morgan_var2 test_comp_closed_var)
  ultimately show ?thesis
    by (metis assms(1,5) test_comp_closed_var test_mult_comm_var)
qed

theorem nested_loops:
  assumes "test p" "test q"
  shows "(p\<cdot>x\<cdot>(q\<cdot>y)\<^sup>\<dagger>\<cdot>!q)\<^sup>\<dagger>\<cdot>!p = p\<cdot>x\<cdot>((p + q)\<cdot>(q\<cdot>y + !q\<cdot>x))\<^sup>\<dagger>\<cdot>!(p + q) + !p"
proof -
  have "p\<cdot>x\<cdot>((p + q)\<cdot>(q\<cdot>y + !q\<cdot>x))\<^sup>\<dagger>\<cdot>!(p + q) + !p = p\<cdot>x\<cdot>(q\<cdot>y)\<^sup>\<dagger>\<cdot>(!q\<cdot>p\<cdot>x\<cdot>(q\<cdot>y)\<^sup>\<dagger>)\<^sup>\<dagger>\<cdot>!p\<cdot>!q + !p"
    by (metis assms test_distrib mult.assoc de_morgan2 dagger_denest2)
  thus ?thesis
    by (metis assms mult.assoc test_comp_closed_var test_mult_comm_var add.commute dagger_slide dagger_unfoldl_distr)
qed

lemma postcomputation:
  assumes "y preserves p"
  shows "(p\<cdot>x)\<^sup>\<dagger>\<cdot>!p\<cdot>y = !p\<cdot>y + p\<cdot>(p\<cdot>x\<cdot>(!p\<cdot>y + p))\<^sup>\<dagger>\<cdot>!p"
proof -
  have "p\<cdot>(p\<cdot>x\<cdot>(!p\<cdot>y + p))\<^sup>\<dagger>\<cdot>!p = p\<cdot>(1 + p\<cdot>x\<cdot>((!p\<cdot>y + p)\<cdot>p\<cdot>x)\<^sup>\<dagger>\<cdot>(!p\<cdot>y + p))\<cdot>!p"
    by (metis dagger_prod_unfold mult.assoc)
  also have "... = (p + p\<cdot>p\<cdot>x\<cdot>((!p\<cdot>y + p)\<cdot>p\<cdot>x)\<^sup>\<dagger>\<cdot>(!p\<cdot>y + p))\<cdot>!p"
    by (metis assms mult.assoc weak_distrib_left_var distrib_right' mult_1_left)
  also have "... = p\<cdot>!p + p\<cdot>x\<cdot>(!p\<cdot>y\<cdot>p\<cdot>x + p\<cdot>p\<cdot>x)\<^sup>\<dagger>\<cdot>(!p\<cdot>y + p)\<cdot>!p"
    by (metis assms mult.assoc distrib_right' test_mult_idem_var)
  also have "... = p\<cdot>!p + p\<cdot>x\<cdot>(!p\<cdot>y\<cdot>p\<cdot>x + p\<cdot>p\<cdot>x)\<^sup>\<dagger>\<cdot>(!p\<cdot>y\<cdot>!p + p\<cdot>!p)"
    by (metis distrib_right' mult.assoc)
  also have "... = p\<cdot>x\<cdot>(!p\<cdot>y\<cdot>!p\<cdot>p\<cdot>x + p\<cdot>x)\<^sup>\<dagger>\<cdot>(!p\<cdot>y)"
    by (metis assms test_comp_mult test_mult_idem_var add_zerol add_zeror)
  also have "... = p\<cdot>x\<cdot>(!p\<cdot>y\<cdot>0 + p\<cdot>x)\<^sup>\<dagger>\<cdot>!p\<cdot>y"
    by (metis assms mult.assoc test_double_comp_var test_mult_comp annil)
  moreover have "... = p \<cdot>x \<cdot>(p \<cdot>x)\<^sup>\<dagger>\<cdot>(!p \<cdot> y \<cdot> 0 \<cdot>(p \<cdot>x)\<^sup>\<dagger>)\<^sup>\<dagger>\<cdot>!p \<cdot> y"
    by (metis mult.assoc add.commute dagger_denest2)
  moreover have "... = p \<cdot>x \<cdot>(p \<cdot>x)\<^sup>\<dagger>\<cdot>!p \<cdot> y \<cdot> (0\<cdot>!p \<cdot> y)\<^sup>\<dagger>"
    by (metis annil dagger_slide mult.assoc)
  ultimately have "p\<cdot>(p\<cdot>x\<cdot>(!p\<cdot>y + p))\<^sup>\<dagger>\<cdot>!p = p \<cdot>x \<cdot>(p \<cdot>x)\<^sup>\<dagger>\<cdot>!p \<cdot> y"
    by (metis zero_dagger annil mult_1_right)
  thus "(p\<cdot>x)\<^sup>\<dagger>\<cdot>!p\<cdot>y = !p\<cdot>y + p\<cdot>(p\<cdot>x\<cdot>(!p\<cdot>y + p))\<^sup>\<dagger>\<cdot>!p"
    by (metis dagger_unfoldl_distr mult.assoc)
qed

lemma composition_helper:
  assumes "test g" "test h" "g\<cdot>y = y\<cdot>g"
  shows "g\<cdot>(h\<cdot>y)\<^sup>\<dagger>\<cdot>!h\<cdot>g = g\<cdot>(h\<cdot>y)\<^sup>\<dagger>\<cdot>!h"
  apply (subgoal_tac "g\<cdot>(h\<cdot>y)\<^sup>\<dagger>\<cdot>!h \<le> (h\<cdot>y)\<^sup>\<dagger>\<cdot>!h\<cdot>g")
  apply (metis assms(1) test_eq3 mult.assoc)
  by (metis assms mult.assoc test_mult_comm_var order_refl dagger_simr mult_isor test_comp_closed_var)

theorem composition:
  assumes "test g" "test h" "g\<cdot>y = y\<cdot>g" "!g\<cdot>y = y\<cdot>!g"
  shows "(g\<cdot>x)\<^sup>\<dagger>\<cdot>!g\<cdot>(h\<cdot>y)\<^sup>\<dagger>\<cdot>!h = !g\<cdot>(h\<cdot>y)\<^sup>\<dagger>\<cdot>!h + g\<cdot>(g\<cdot>x\<cdot>(!g\<cdot>(h\<cdot>y)\<^sup>\<dagger>\<cdot>!h + g))\<^sup>\<dagger>\<cdot>!g"
  apply (subgoal_tac "(h\<cdot>y)\<^sup>\<dagger>\<cdot>!h preserves g")
  by (metis postcomputation mult.assoc, metis assms composition_helper test_comp_closed_var mult.assoc)

end

text {*
  Kleene algebras with tests form pre-Conway algebras, therefore the transformation theorem is valid for KAT as well.
*}
sublocale  kat \<subseteq> pre_conway star
  apply (default, simp_all only: star_prod_unfold star_sim2)
  by (metis star_denest_var star_slide)

text {*
  Demonic refinement algebras form pre-Conway algebras, therefore the transformation theorem is valid for DRA as well.
*}
sublocale  dra_tests \<subseteq> pre_conway strong_iteration
  apply (default, metis iteration_denest iteration_slide)
  by (metis iteration_prod_unfold, metis iteration_sim)

text {*
  We do not currently consider an expansion of probabilistic Kleene algebra.
*}
end


(*<*)
theory Slicing
  imports Abstract_Monitor MFOTL
begin
(*>*)

section \<open>Slicing framework\<close>

text \<open>This section formalizes the abstract slicing framework and the joint data slicer
  presented in the article~\cite[Sections 4.2 and~4.3]{SchneiderBBKT-STTT20}.\<close>

subsection \<open>Abstract slicing\<close>

subsubsection \<open>Definition 1\<close>

text \<open>Corresponds to locale @{locale monitor} defined in theory
  @{theory MFOTL_Monitor_Devel.Abstract_Monitor}.\<close>

subsubsection \<open>Definition 2\<close>

locale slicer = monitor +
  fixes submonitor :: "'k :: finite \<Rightarrow> 'a prefix \<Rightarrow> (nat \<times> 'b option list) set"
  and   splitter :: "'a prefix \<Rightarrow> 'k \<Rightarrow> 'a prefix"
  and   joiner :: "('k \<Rightarrow> (nat \<times> 'b option list) set) \<Rightarrow> (nat \<times> 'b option list) set"
assumes mono_splitter: "\<pi> \<le> \<pi>' \<Longrightarrow> splitter \<pi> k \<le> splitter \<pi>' k"
  and   correct_slicer: "joiner (\<lambda>k. submonitor k (splitter \<pi> k)) = M \<pi>"
begin

lemmas sound_slicer = equalityD1[OF correct_slicer]
lemmas complete_slicer = equalityD2[OF correct_slicer]

end

locale self_slicer = slicer nfv fv sat M "\<lambda>_. M" splitter joiner for nfv fv sat M splitter joiner

subsubsection \<open>Definition 3\<close>

locale event_separable_splitter =
  fixes event_splitter :: "'a \<Rightarrow> 'k :: finite set"
begin

lift_definition splitter :: "'a prefix \<Rightarrow> 'k \<Rightarrow> 'a prefix" is
  "\<lambda>\<pi> k. map (\<lambda>(D, t). ({e \<in> D. k \<in> event_splitter e}, t)) \<pi>"
  by (auto simp: o_def split_beta)

subsubsection \<open>Lemma 1\<close>

lemma mono_splitter: "\<pi> \<le> \<pi>' \<Longrightarrow> splitter \<pi> k \<le> splitter \<pi>' k"
  by transfer auto

end

subsection \<open>Joint data slicer\<close>

abbreviation (input) "ok \<phi> v \<equiv> wf_tuple (MFOTL.nfv \<phi>) (MFOTL.fv \<phi>) v"

locale splitting_strategy =
  fixes \<phi> :: "'a MFOTL.formula"
  and strategy :: "'a option list \<Rightarrow> 'k :: finite set"
  assumes strategy_nonempty: "ok \<phi> v \<Longrightarrow> strategy v \<noteq> {}"
begin

abbreviation slice_set where
  "slice_set k \<equiv> {v. \<exists>v'. map the v' = v \<and> ok \<phi> v' \<and> k \<in> strategy v'}"

end

subsubsection \<open>Definition 4\<close>

locale MFOTL_monitor =
  monitor "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>" M for \<phi> M

locale joint_data_slicer = MFOTL_monitor \<phi> M + splitting_strategy \<phi> strategy
  for \<phi> M strategy
begin

definition event_splitter where
  "event_splitter e = (\<Union>(strategy ` {v. ok \<phi> v \<and> MFOTL.matches (map the v) \<phi> e}))"

sublocale event_separable_splitter where event_splitter = event_splitter .

definition joiner where
  "joiner = (\<lambda>s. \<Union>k. s k \<inter> (UNIV :: nat set) \<times> {v. k \<in> strategy v})"

lemma splitter_pslice: "splitter \<pi> k = MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>"
  by transfer (auto simp: event_splitter_def)

subsubsection \<open>Lemma 2\<close>

text \<open>Corresponds to the following theorem @{thm[source] sat_slice_strong} proved in theory
   @{theory MFOTL_Monitor_Devel.Abstract_Monitor}:

   @{thm sat_slice_strong[no_vars]}\<close>

subsubsection \<open>Theorem 1\<close>

sublocale joint_monitor: MFOTL_monitor \<phi> "\<lambda>\<pi>. joiner (\<lambda>k. M (splitter \<pi> k))"
proof (unfold_locales, goal_cases mono wf sound complete)
  case (mono \<pi> \<pi>')
  show ?case
    using mono_monitor[OF mono_splitter, OF mono]
    by (auto simp: joiner_def)
next
  case (wf i v \<pi>)
  then obtain k where in_M: "(i, v) \<in> M (splitter \<pi> k)"  and k: "k \<in> strategy v"
    unfolding joiner_def by (auto split: if_splits)
  then show ?case
    using wf_monitor[OF in_M] by auto
next
  case (sound i v \<pi> \<sigma>)
  then obtain k where in_M: "(i, v) \<in> M (splitter \<pi> k)"  and k: "k \<in> strategy v"
    unfolding joiner_def by (auto split: if_splits)
  have wf: "ok \<phi> v" and sat: "\<And>\<sigma>. prefix_of (splitter \<pi> k) \<sigma> \<Longrightarrow> MFOTL.sat \<sigma> (map the v) i \<phi>"
    using sound_monitor[OF in_M] wf_monitor[OF in_M] by auto
  then have "MFOTL.sat \<sigma> (map the v) i \<phi>" if "prefix_of \<pi> \<sigma>" for \<sigma>
    using that k
    by (intro iffD2[OF sat_slice_iff[of "map the v" "slice_set k" \<sigma> i \<phi>]])
      (auto simp: wf_tuple_def fvi_less_nfv splitter_pslice intro!: exI[of _ v] prefix_of_pmap_\<Gamma>)
  then show ?case using sound(2) by blast
next
  case (complete \<pi> \<sigma> v i)
  with strategy_nonempty obtain k where k: "k \<in> strategy v" by blast
  have "MFOTL.sat \<sigma>' (map the v) i \<phi>" if "prefix_of (MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>) \<sigma>'" for \<sigma>'
  proof -
    have "MFOTL.sat \<sigma>' (map the v) i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>') (map the v) i \<phi>"
      using complete(2) k by (auto intro!: sat_slice_iff)
    also have "\<dots> = MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) (replace_prefix \<pi> \<sigma>')) (map the v) i \<phi>"
      using that complete k by (subst slice_replace_prefix[symmetric]; simp)
    also have "\<dots> = MFOTL.sat (replace_prefix \<pi> \<sigma>') (map the v) i \<phi>"
      using complete(2) k by (auto intro!: sat_slice_iff[symmetric])
    also have "\<dots>"
      by (rule complete(3)[rule_format], rule prefix_of_replace_prefix[OF that])
    finally show ?thesis .
  qed
  with complete(1-3) obtain \<pi>' where \<pi>':
    "prefix_of \<pi>' (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>)" "(i, v) \<in> M \<pi>'"
    by (atomize_elim, intro complete_monitor[where \<pi>="MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>"])
      (auto simp: splitter_pslice intro!: prefix_of_pmap_\<Gamma>)
  from \<pi>'(1) obtain \<pi>'' where "\<pi>' = MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>''" "prefix_of \<pi>'' \<sigma>"
    by (atomize_elim, rule prefix_of_map_\<Gamma>_D)
  with \<pi>' k show ?case
    by (intro exI[of _ \<pi>'']) (auto simp: joiner_def splitter_pslice intro!: exI[of _ k])
qed

subsubsection \<open>Corollary 1\<close>

sublocale joint_slicer: slicer "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>"
  "\<lambda>\<pi>. joiner (\<lambda>k. M (splitter \<pi> k))" "\<lambda>_. M" splitter joiner
  by standard (auto simp: mono_splitter)

end

subsubsection \<open>Definition 5\<close>

text \<open>Corresponds to locale @{locale sliceable_monitor} defined in theory
  @{theory MFOTL_Monitor_Devel.Abstract_Monitor}.\<close>

locale slicable_joint_data_slicer =
  sliceable_monitor "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" "relevant_events \<phi>" "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>" M +
  joint_data_slicer \<phi> M strategy for \<phi> M strategy
begin

lemma monitor_split: "ok \<phi> v \<Longrightarrow> k \<in> strategy v \<Longrightarrow> (i, v) \<in> M (splitter \<pi> k) \<longleftrightarrow> (i, v) \<in> M \<pi>"
  unfolding splitter_pslice
  by (rule sliceable_M)
    (auto simp: wf_tuple_def fvi_less_nfv intro!: mem_restrI[rotated 2, where y="map the v"])

subsubsection \<open>Theorem 2\<close>

sublocale self_slicer "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>" M splitter joiner
proof (standard, erule mono_splitter, safe, goal_cases sound complete)
  case (sound \<pi> i v)
  have "ok \<phi> v" using joint_monitor.wf_monitor[OF sound] by auto
  from sound obtain k where "(i, v) \<in> M (splitter \<pi> k)" "k \<in> strategy v"
    unfolding joiner_def by blast
  with \<open>ok \<phi> v\<close> show ?case by (simp add: monitor_split)
next
  case (complete \<pi> i v)
  have "ok \<phi> v" using wf_monitor[OF complete] by auto
  with complete strategy_nonempty obtain k where k: "k \<in> strategy v" by blast
  then have "(i, v) \<in> M (splitter \<pi> k)" using complete \<open>ok \<phi> v\<close> by (simp add: monitor_split)
  with k show ?case unfolding joiner_def by blast
qed

end

subsubsection \<open>Towards Theorem 3\<close>

fun names :: "'a MFOTL.formula \<Rightarrow> MFOTL.name set" where
  "names (MFOTL.Pred e _) = {e}"
| "names (MFOTL.Eq _ _) = {}"
| "names (MFOTL.Neg \<psi>) = names \<psi>"
| "names (MFOTL.Or \<alpha> \<beta>) = names \<alpha> \<union> names \<beta>"
| "names (MFOTL.Exists \<psi>) = names \<psi>"
| "names (MFOTL.Prev I \<psi>) = names \<psi>"
| "names (MFOTL.Next I \<psi>) = names \<psi>"
| "names (MFOTL.Since \<alpha> I \<beta>) = names \<alpha> \<union> names \<beta>"
| "names (MFOTL.Until \<alpha> I \<beta>) = names \<alpha> \<union> names \<beta>"

fun gen_unique :: "'a MFOTL.formula \<Rightarrow> bool" where
  "gen_unique (MFOTL.Pred _ _) = True"
| "gen_unique (MFOTL.Eq (MFOTL.Var _) (MFOTL.Const _)) = False"
| "gen_unique (MFOTL.Eq (MFOTL.Const _) (MFOTL.Var _)) = False"
| "gen_unique (MFOTL.Eq _ _) = True"
| "gen_unique (MFOTL.Neg \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Or \<alpha> \<beta>) = (gen_unique \<alpha> \<and> gen_unique \<beta> \<and> names \<alpha> \<inter> names \<beta> = {})"
| "gen_unique (MFOTL.Exists \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Prev I \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Next I \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Since \<alpha> I \<beta>) = (gen_unique \<alpha> \<and> gen_unique \<beta> \<and> names \<alpha> \<inter> names \<beta> = {})"
| "gen_unique (MFOTL.Until \<alpha> I \<beta>) = (gen_unique \<alpha> \<and> gen_unique \<beta> \<and> names \<alpha> \<inter> names \<beta> = {})"

lemma sat_inter_names_cong: "(\<And>e. e \<in> names \<phi> \<Longrightarrow> {xs. (e, xs) \<in> E} = {xs. (e, xs) \<in> F}) \<Longrightarrow>
  MFOTL.sat (map_\<Gamma> (\<lambda>D. D \<inter> E) \<sigma>) v i \<phi> \<longleftrightarrow> MFOTL.sat (map_\<Gamma> (\<lambda>D. D \<inter> F) \<sigma>) v i \<phi>"
  by (induction \<phi> arbitrary: v i) (auto split: nat.splits)

lemma matches_in_names: "MFOTL.matches v \<phi> x \<Longrightarrow> fst x \<in> names \<phi>"
  by (induction \<phi> arbitrary: v) (auto)

lemma unique_names_matches_absorb: "fst x \<in> names \<alpha> \<Longrightarrow> names \<alpha> \<inter> names \<beta> = {} \<Longrightarrow>
    MFOTL.matches v \<alpha> x \<or> MFOTL.matches v \<beta> x \<longleftrightarrow> MFOTL.matches v \<alpha> x"
  "fst x \<in> names \<beta> \<Longrightarrow> names \<alpha> \<inter> names \<beta> = {} \<Longrightarrow>
    MFOTL.matches v \<alpha> x \<or> MFOTL.matches v \<beta> x \<longleftrightarrow> MFOTL.matches v \<beta> x"
  by (auto dest: matches_in_names)

definition mergeable_envs where
  "mergeable_envs n S \<longleftrightarrow> (\<forall>v1\<in>S. \<forall>v2\<in>S. (\<forall>A B f.
    (\<forall>x\<in>A. x < n \<and> v1 ! x = f x) \<and> (\<forall>x\<in>B. x < n \<and> v2 ! x = f x) \<longrightarrow>
    (\<exists>v\<in>S. \<forall>x\<in>A \<union> B. v ! x = f x)))"

lemma mergeable_envsI:
  assumes "\<And>v1 v2 v. v1 \<in> S \<Longrightarrow> v2 \<in> S \<Longrightarrow> length v = n \<Longrightarrow> \<forall>x < n. v ! x = v1 ! x \<or> v ! x = v2 ! x \<Longrightarrow> v \<in> S"
  shows "mergeable_envs n S"
  unfolding mergeable_envs_def
proof (safe, goal_cases mergeable)
  case [simp]: (mergeable v1 v2 A B f)
  let ?v = "tabulate (\<lambda>x. if x \<in> A \<union> B then f x else v1 ! x) 0 n"
  from assms[of v1 v2 ?v, simplified] show ?case
    by (auto intro!: bexI[of _ ?v])
qed

lemma in_listset_nth: "x \<in> listset As \<Longrightarrow> i < length As \<Longrightarrow> x ! i \<in> As ! i"
  by (induction As arbitrary: x i) (auto simp: set_Cons_def nth_Cons split: nat.split)

lemma all_nth_in_listset: "length x = length As \<Longrightarrow> (\<And>i. i < length As \<Longrightarrow> x ! i \<in> As ! i) \<Longrightarrow> x \<in> listset As"
  by (induction x As rule: list_induct2) (fastforce simp: set_Cons_def nth_Cons)+

lemma mergeable_envs_listset: "mergeable_envs (length As) (listset As)"
  by (rule mergeable_envsI) (auto intro!: all_nth_in_listset elim!: in_listset_nth)

lemma mergeable_envs_Ex: "mergeable_envs n S \<Longrightarrow> MFOTL.nfv \<alpha> \<le> n \<Longrightarrow> MFOTL.nfv \<beta> \<le> n \<Longrightarrow>
  (\<exists>v'\<in>S. \<forall>x\<in>fv \<alpha>. v' ! x = v ! x) \<Longrightarrow> (\<exists>v'\<in>S. \<forall>x\<in>fv \<beta>. v' ! x = v ! x) \<Longrightarrow>
  (\<exists>v'\<in>S. \<forall>x\<in>fv \<alpha> \<union> fv \<beta>. v' ! x = v ! x)"
proof (clarify, goal_cases mergeable)
  case (mergeable v1 v2)
  then show ?case
    by (auto intro: order.strict_trans2[OF fvi_less_nfv[rule_format]]
      elim!: mergeable_envs_def[THEN iffD1, rule_format, of _ _ v1 v2])
qed

lemma in_set_ConsE: "xs \<in> set_Cons A As \<Longrightarrow> (\<And>y ys. xs = y # ys \<Longrightarrow> y \<in> A \<Longrightarrow> ys \<in> As \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding set_Cons_def by blast

lemma mergeable_envs_set_Cons: "mergeable_envs n S \<Longrightarrow> mergeable_envs (Suc n) (set_Cons UNIV S)"
  unfolding mergeable_envs_def
proof (clarify, elim in_set_ConsE, goal_cases mergeable)
  case (mergeable v1 v2 A B f y1 ys1 y2 ys2)
  let ?A = "(\<lambda>x. x - 1) ` (A - {0})"
  let ?B = "(\<lambda>x. x - 1) ` (B - {0})"
  from mergeable(4-9) have "\<exists>v \<in> S. \<forall>x\<in>?A \<union> ?B. v ! x = f (Suc x)"
    by (auto dest!: mergeable(2,3)[rule_format] intro!: mergeable(1)[rule_format, of ys1 ys2])
  then obtain v where "v \<in> S" "\<forall>x\<in>?A \<union> ?B. v ! x = f (Suc x)" by blast
  then show ?case
    by (intro bexI[of _ "f 0 # v"]) (auto simp: nth_Cons' set_Cons_def)
qed

lemma slice_Exists: "MFOTL_slicer.slice (MFOTL.Exists \<phi>) S \<sigma> = MFOTL_slicer.slice \<phi> (set_Cons UNIV S) \<sigma>"
  by (auto simp: set_Cons_def intro: map_\<Gamma>_cong)

lemma image_Suc_fvi: "Suc ` MFOTL.fvi (Suc b) \<phi> = MFOTL.fvi b \<phi> - {0}"
  by (auto simp: image_def Bex_def MFOTL.fvi_Suc dest: gr0_implies_Suc)

lemma nfv_Exists: "MFOTL.nfv (MFOTL.Exists \<phi>) = MFOTL.nfv \<phi> - 1"
  unfolding MFOTL.nfv_def
  by (cases "fv \<phi> = {}") (auto simp add: image_Suc_fvi mono_Max_commute[symmetric] mono_def)

lemma set_Cons_empty_iff[simp]: "set_Cons A Xs = {} \<longleftrightarrow> A = {} \<or> Xs = {}"
  unfolding set_Cons_def by auto

lemma unique_sat_slice_mem: "safe_formula \<phi> \<Longrightarrow> gen_unique \<phi> \<Longrightarrow> S \<noteq> {} \<Longrightarrow>
  mergeable_envs n S \<Longrightarrow> MFOTL.nfv \<phi> \<le> n \<Longrightarrow>
  MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi> \<Longrightarrow> \<exists>v'\<in>S. \<forall>x\<in>fv \<phi>. v' ! x = v ! x"
proof (induction arbitrary: v i S n rule: safe_formula_induct)
  case (1 t1 t2)
  then show ?case by (cases "t2") (auto simp: MFOTL.is_Const_def)
next
  case (2 t1 t2)
  then show ?case by (cases "t1") (auto simp: MFOTL.is_Const_def)
next
  case (3 x y)
  then show ?case by auto
next
  case (4 x y)
  then show ?case by simp
next
  case (5 e ts)
  then obtain v' where "v' \<in> S" and eq: "\<forall>t\<in>set ts. MFOTL.eval_trm v' t = MFOTL.eval_trm v t"
    by auto
  have "\<forall>t\<in>set ts. \<forall>x\<in>fv_trm t. v' ! x = v ! x" proof
    fix t assume "t \<in> set ts"
    with eq have "MFOTL.eval_trm v' t = MFOTL.eval_trm v t" ..
    then show "\<forall>x\<in>fv_trm t. v' ! x = v ! x" by (cases t) (simp_all)
  qed
  with \<open>v' \<in> S\<close> show ?case by auto
next
  case (6 \<phi> \<psi>)
  from \<open>gen_unique (MFOTL.And \<phi> \<psi>)\<close>
  have
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.And \<phi> \<psi>) S \<sigma>) v i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.And \<phi> \<psi>) S \<sigma>) v i \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v i \<psi>"
    unfolding MFOTL.And_def
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)+
  with 6(1,4-) 6(2,3)[where S=S] show ?case
    unfolding MFOTL.And_def
    by (auto intro!: mergeable_envs_Ex)
next
  case (7 \<phi> \<psi>)
  from \<open>gen_unique (MFOTL.And_Not \<phi> \<psi>)\<close>
  have "MFOTL.sat (MFOTL_slicer.slice (MFOTL.And_Not \<phi> \<psi>) S \<sigma>) v i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    unfolding MFOTL.And_Not_def
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  with 7(1,2,5-) 7(3)[where S=S] have "\<exists>v'\<in>S. \<forall>x\<in>fv \<phi>. v' ! x = v ! x"
    unfolding MFOTL.And_Not_def by auto
  with \<open>fv \<psi> \<subseteq> fv \<phi>\<close> show ?case by (auto simp: MFOTL.fvi_And_Not)
next
  case (8 \<phi> \<psi>)
  from \<open>gen_unique (MFOTL.Or \<phi> \<psi>)\<close>
  have
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Or \<phi> \<psi>) S \<sigma>) v i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Or \<phi> \<psi>) S \<sigma>) v i \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v i \<psi>"
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)+
  with 8(1,4-) 8(2,3)[where S=S] have "\<exists>v'\<in>S. \<forall>x\<in>fv \<phi>. v' ! x = v ! x"
    by (auto simp: \<open>fv \<psi> = fv \<phi>\<close>)
  then show ?case by (auto simp: \<open>fv \<psi> = fv \<phi>\<close>)
next
  case (9 \<phi>)
  then obtain z where sat_\<phi>: "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Exists \<phi>) S \<sigma>) (z # v) i \<phi>"
    by auto
  from "9.prems" sat_\<phi> have "\<exists>v'\<in>set_Cons UNIV S. \<forall>x\<in>fv \<phi>. v' ! x = (z # v) ! x"
    unfolding slice_Exists
    by (intro "9.IH") (auto simp: nfv_Exists intro!: mergeable_envs_set_Cons)
  then show ?case
    by (auto simp: set_Cons_def fvi_Suc Ball_def nth_Cons split: nat.splits)
next
  case (10 I \<phi>)
  then obtain j where "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v j \<phi>"
    by (auto split: nat.splits)
  with 10 show ?case by simp
next
  case (11 I \<phi>)
  then obtain j where "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v j \<phi>"
    by (auto split: nat.splits)
  with 11 show ?case by simp
next
  case (12 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Since \<phi> I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since \<phi> I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 12 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since \<phi> I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 12 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv \<phi> \<subseteq> fv \<psi>\<close> show ?case by auto
next
  case (13 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Since (MFOTL.Neg \<phi>) I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 13 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 13 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv (MFOTL.Neg \<phi>) \<subseteq> fv \<psi>\<close> show ?case by auto
next
  case (14 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Until \<phi> I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until \<phi> I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 14 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until \<phi> I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 14 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv \<phi> \<subseteq> fv \<psi>\<close> show ?case by auto
next
  case (15 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Until (MFOTL.Neg \<phi>) I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 15 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 15 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv (MFOTL.Neg \<phi>) \<subseteq> fv \<psi>\<close> show ?case by auto
qed

lemma unique_sat_slice:
  assumes formula: "safe_formula \<phi>" "gen_unique \<phi>"
      and restr: "S \<noteq> {}" "mergeable_envs (MFOTL.nfv \<phi>) S"
      and sat_slice: "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    shows "MFOTL.sat \<sigma> v i \<phi>"
proof -
  obtain v' where "v' \<in> S" and fv_eq: "\<forall>x\<in>fv \<phi>. v' ! x = v ! x"
    using unique_sat_slice_mem[OF formula restr order_refl sat_slice] ..
  with sat_slice have "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v' i \<phi>"
    by (auto iff: sat_fvi_cong)
  then have "MFOTL.sat \<sigma> v' i \<phi>"
    unfolding sat_slice_iff[OF \<open>v' \<in> S\<close>, symmetric] .
  with fv_eq show ?thesis by (auto iff: sat_fvi_cong)
qed

subsubsection \<open>Lemma 3\<close>

lemma (in splitting_strategy) unique_sat_strategy:
  "safe_formula \<phi> \<Longrightarrow> gen_unique \<phi> \<Longrightarrow> slice_set k \<noteq> {} \<Longrightarrow>
  mergeable_envs (MFOTL.nfv \<phi>) (slice_set k) \<Longrightarrow>
  MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>) (map the v) i \<phi> \<Longrightarrow>
  ok \<phi> v \<Longrightarrow> k \<in> strategy v"
  by (drule (3) unique_sat_slice_mem) (auto dest: wf_tuple_cong)

locale skip_inter = joint_data_slicer +
  assumes nonempty: "slice_set k \<noteq> {}"
  and mergeable: "mergeable_envs (MFOTL.nfv \<phi>) (slice_set k)"
begin

subsubsection \<open>Definition of J'\<close>

definition "skip_joiner = (\<lambda>s. \<Union>k. s k)"

subsubsection \<open>Theorem 3\<close>

lemma skip_joiner:
  assumes "safe_formula \<phi>" "gen_unique \<phi>"
  shows "joiner (\<lambda>k. M (splitter \<pi> k)) = skip_joiner (\<lambda>k. M (splitter \<pi> k))"
  (is "?L = ?R")
proof safe
  fix i v
  assume "(i, v) \<in> ?R"
  then obtain k where in_M: "(i, v) \<in> M (splitter \<pi> k)"
  unfolding skip_joiner_def by blast
  from ex_prefix_of obtain \<sigma> where "prefix_of \<pi> \<sigma>" by blast
  with wf_monitor[OF in_M] sound_monitor[OF in_M] have
    "MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>) (map the v) i \<phi>" "ok \<phi> v"
    by (auto simp: splitter_pslice intro!: prefix_of_pmap_\<Gamma>)
  note unique_sat_strategy[OF assms nonempty mergeable this]
  with in_M show "(i, v) \<in> ?L" unfolding joiner_def by blast
qed (auto simp: joiner_def skip_joiner_def)

sublocale skip_joint_monitor: MFOTL_monitor \<phi>
  "\<lambda>\<pi>. (if safe_formula \<phi> \<and> gen_unique \<phi> then skip_joiner else joiner) (\<lambda>k. M (splitter \<pi> k))"
  using joint_monitor.mono_monitor joint_monitor.wf_monitor joint_monitor.sound_monitor joint_monitor.complete_monitor
  by unfold_locales (auto simp: skip_joiner[symmetric] split: if_splits)

end

(*<*)
end
(*>*)