theory TS_To_TC_Aux
  imports Main "../Three_Sat_To_Set_Cover"
begin

subsection \<open>Order over Litarals of a CNF clause\<close>

fun extract_value :: "'a lit \<Rightarrow> 'a" where
  "extract_value (Pos a) = a"
| "extract_value (Neg a) = a"

fun is_Pos :: "'a lit \<Rightarrow> bool" where
  "is_Pos (Pos _) = True"
| "is_Pos _ = False"

instantiation lit :: (linorder) linorder
begin

definition less_eq_lit where [simp]: "x \<le> y \<equiv>
  extract_value x < extract_value y \<or> (extract_value x = extract_value
y \<and> is_Pos x \<le> is_Pos y)"

definition less_lit where [simp]: "(x:: 'a lit) < y \<equiv> (x\<le>y \<and> x\<noteq>y)"

instance
  by standard (fastforce elim!: is_Pos.elims(3) extract_value.elims)+

end

(* Ordered by Pos/Neg then by order over a' type *)
datatype 'a lit' = Pos' 'a | Neg' 'a

instantiation lit' :: (linorder) linorder
begin

fun less_eq_lit' :: "'a lit' \<Rightarrow> 'a lit' \<Rightarrow> bool" where
  "less_eq_lit' (Neg' x) (Neg' y) = (x \<le> y)"
| "less_eq_lit' (Neg' _) (Pos' _) = True"
| "less_eq_lit' (Pos' _) (Neg' _) = False"
| "less_eq_lit' (Pos' x) (Pos' y) = (x \<le> y)"

definition less_lit' where [simp]: "(x:: 'a lit') < y \<longleftrightarrow> (x\<le>y \<and> x\<noteq>y)"

instance
  apply standard
  apply (auto elim!: less_eq_lit'.elims)
  using less_eq_lit'.elims(3) by fastforce
end

subsection \<open>CNF Aux for TS_To_TC\<close>

lemma cnf_remove_clause: "F \<in> three_cnf_sat \<Longrightarrow> F = F' @ [a] \<Longrightarrow> F' \<in> three_cnf_sat"
proof -
  assume asm1: "F\<in> three_cnf_sat"
  assume asm2: "F = F' @ [a]"
  from asm1 obtain \<sigma> where obt1:"\<sigma> \<Turnstile> F " unfolding three_cnf_sat_def sat_def by auto
  from asm2 have "(set F') \<subseteq> (set F)" by auto
  from this obt1 have "\<sigma> \<Turnstile> F'" unfolding models_def
    by blast
  from asm1 asm2 this show ?thesis
  unfolding three_cnf_sat_def sat_def
  by auto
qed

lemma cnf_clause: "F \<in> three_cnf_sat \<Longrightarrow> F = F' @ [a] \<Longrightarrow> [a] \<in> three_cnf_sat"
proof -
  assume asm1: "F\<in> three_cnf_sat"
  assume asm2: "F = F' @ [a]"
  from asm1 obtain \<sigma> where obt1:"\<sigma> \<Turnstile> F " unfolding three_cnf_sat_def sat_def by auto
  from asm2 have "(set [a]) \<subseteq> (set F)" by auto
  from this obt1 have "\<sigma> \<Turnstile> [a]" unfolding models_def
    by blast
  from asm1 asm2 this show ?thesis
  unfolding three_cnf_sat_def sat_def
  by auto
qed

subsection \<open>Graph Aux for TS_To_TC\<close>

fun var :: "'a lit \<Rightarrow> 'a "  where
   "var (Pos v) = v"
 | "var (Neg v) = v"

fun tolit :: "'a lit \<Rightarrow> 'a \<Rightarrow> 'a lit "  where
   "tolit (Pos v) = Pos"
 | "tolit (Neg v) = Neg"

fun isPos :: "'a lit \<Rightarrow> bool " where
   "isPos (Pos v) = True"
 | "isPos (Neg v) = False"

lemma i_split:"i< length (F@[c]) \<longleftrightarrow> (i < length F) \<or> (i = length F)"
  by auto

lemma and_distrLit2:"
  \<And>l1 l2 l3 i . ((
  (i < length (F)  \<and> {l1,l2,l3} = (F@[c]) ! i ) \<or>
  (i = length F  \<and> {l1,l2,l3} = (F@[c]) ! i )) \<and>
  sorted_list_of_set ((F@[c])  !i) = [l1,l2,l3])
  \<longleftrightarrow>
  (i < length (F)  \<and> {l1,l2,l3} = (F@[c]) ! i \<and> (sorted_list_of_set ((F@[c])  !i) = [l1,l2,l3]) ) \<or>
  ((i = length F  \<and> {l1,l2,l3} = (F@[c]) ! i ) \<and> (sorted_list_of_set ((F@[c])  !i) = [l1,l2,l3]))"
  by auto

lemma i_less_lengthF:
      "(i < length (F)  \<and> {l1,l2,l3} = (F@[c]) ! i \<and> (sorted_list_of_set ((F@[c])  !i) = [l1,l2,l3]) ) =
       (i < length (F)  \<and> {l1,l2,l3} = (F) ! i \<and> (sorted_list_of_set ((F)  !i) = [l1,l2,l3]) )"
  by (simp add: nth_append)

lemma i_eq_lengthF:
      "(i = length (F)  \<and> {l1,l2,l3} = (F@[c]) ! i \<and> (sorted_list_of_set ((F@[c])  !i) = [l1,l2,l3]) ) =
       (i = length (F)  \<and> {l1,l2,l3} = c \<and> (sorted_list_of_set (c) = [l1,l2,l3]) )"
  by fastforce

lemma orToUnion:"
  \<Union>{{{(1::nat,tolit l1 = Pos,var l1,0::nat),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}} |l1 l2 l3 i.
                    (i < length F  \<and> {l1,l2,l3} = F ! i \<and> sorted_list_of_set (F!i) = [l1,l2,l3]) \<or>
                    (i = length F  \<and> {l1,l2,l3} = c  \<and> sorted_list_of_set (c) = [l1,l2,l3])} =
  \<Union>{{{(1,tolit l1 = Pos,var l1,0),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}} |l1 l2 l3 i.
      (i < length F  \<and> {l1,l2,l3} = F ! i \<and> sorted_list_of_set (F!i) = [l1,l2,l3])} \<union>
  \<Union>{{{(1,tolit l1 = Pos,var l1,0),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}} |l1 l2 l3 i.
      (i = length F  \<and> {l1,l2,l3} = c  \<and> sorted_list_of_set (c) = [l1,l2,l3])}"
  by auto blast +

(* To run in Isabelle2022: restore old syntax *)
abbreviation "strict_sorted \<equiv> sorted_wrt (<)"

lemma sorted_to_strict_sorted:"card c = 3 \<Longrightarrow> c= {l1,l2,l3} \<Longrightarrow> sorted [l1,l2,l3] \<Longrightarrow>
                              strict_sorted [l1,l2,l3]"
proof -
  assume asms: "card c = 3" "c= {l1,l2,l3}" "sorted [l1,l2,l3]"
  from this have "card {l1,l2,l3} = 3"
    by simp
  from this have "l1 \<noteq> l2 \<and> l2 \<noteq> l3 \<and> l1 \<noteq> l3"
    by (metis card_2_iff doubleton_eq_iff insert_absorb2 is_singletonI is_singleton_altdef
 not_numeral_less_one numeral_eq_iff numeral_less_iff semiring_norm(77) semiring_norm(89))
  from this asms show ?thesis
    by auto
qed

lemma sorted_strictsorted_lits2_2 :"c = {la,lb,lc} \<Longrightarrow> (la::nat lit) < lb \<Longrightarrow> lb < lc  \<Longrightarrow>
      sorted_list_of_set c = [la,lb,lc]"
proof -
  assume asms:"c = {la,lb,lc}" "(la::nat lit) < lb" "lb < lc"
  from this have "la < lc"
    using less_trans by blast
  from this asms have " strict_sorted [la,lb,lc]"
    by simp
  from this asms(1) show "sorted_list_of_set c = [la,lb,lc]"
    by simp
qed

lemma sorted_strictsorted_lits4:"c = {l1,l2,l3} \<Longrightarrow> card c = 3 \<Longrightarrow>
        sorted [(l1::nat lit),l2,l3] \<Longrightarrow>
        sorted_list_of_set c = [l1,l2,l3]"
proof -
  assume asms:  "c = {l1,l2,l3}" "card c = 3" "sorted [(l1::nat lit),l2,l3]"
  from this have strict:"strict_sorted [l1, l2, l3]" using sorted_to_strict_sorted
    by blast
  from this have l1l2less:"l1< l2"
    by simp
  from strict have l2l3less:"l2 < l3"
    by simp
  from this asms(1) l1l2less show "sorted_list_of_set c = [l1,l2,l3]"
    using sorted_strictsorted_lits2_2[where c = c and la = l1 and lb = l2 and lc = l3]
    by blast
qed

lemma union_split:"\<Union>{{{(1::nat,tolit l1 = Pos,var l1,0::nat),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . i < length (F@[c]) \<and> {l1,l2,l3} = (F@[c]) ! i \<and> sorted_list_of_set ((F@[c])  !i) = [l1,l2,l3]}
      =
      \<Union>{{{(1,tolit l1 = Pos,var l1,0),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . i < length (F) \<and> {l1,l2,l3} = (F) ! i \<and> sorted_list_of_set ((F)  !i) = [l1,l2,l3]} \<union>
      \<Union>{{{(1,tolit l1 = Pos,var l1,0),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . i = length F \<and> {l1,l2,l3} = c \<and> sorted_list_of_set c = [l1,l2,l3]}"
proof -
  define A where A_def:"A=
    \<Union>{{{(1::nat,tolit l1 = Pos,var l1,0::nat),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . i < length (F@[c]) \<and> {l1,l2,l3} = (F@[c]) ! i \<and>
      sorted_list_of_set ((F@[c])  !i) = [l1,l2,l3]}"

  define B where B_def:"B=
    \<Union>{{{(1::nat,tolit l1 = Pos,var l1,0::nat),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . (i < length (F) \<or> i = length F) \<and> {l1,l2,l3} = (F@[c]) ! i \<and>
      sorted_list_of_set ((F@[c])  !i) = [l1,l2,l3]}"

  define C where C_def:"C=
    \<Union>{{{(1::nat,tolit l1 = Pos,var l1,0::nat),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i .
      ((i < length (F)  \<and> {l1,l2,l3} = (F@[c]) ! i ) \<or>
      (i = length F  \<and> {l1,l2,l3} = (F@[c]) ! i )) \<and>
      sorted_list_of_set ((F@[c])  !i) = [l1,l2,l3]}"

  define D where D_def:"D=
    \<Union>{{{(1::nat,tolit l1 = Pos,var l1,0::nat),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . (
      (i < length F  \<and> {l1,l2,l3} = F ! i \<and> sorted_list_of_set (F!i) = [l1,l2,l3]) \<or>
      (i = length F  \<and> {l1,l2,l3} = c  \<and> sorted_list_of_set (c) = [l1,l2,l3]) )}"

  define E where E_def:"E=
      \<Union>{{{(1::nat,tolit l1 = Pos,var l1,0::nat),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i .
      (i < length F  \<and> {l1,l2,l3} = F ! i \<and> sorted_list_of_set (F!i) = [l1,l2,l3])} \<union>
      \<Union>{{{(1,tolit l1 = Pos,var l1,0),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i .
      (i = length F  \<and> {l1,l2,l3} = c  \<and> sorted_list_of_set (c) = [l1,l2,l3])}"

  have step1:"A = B"
    using i_split[where F = F and c = c]
    unfolding A_def B_def
    by simp
  have step2:"B = C"
    unfolding B_def C_def
    by meson
  have step3: "C = D"
    unfolding C_def D_def
    using and_distrLit2[where F= F and c= c]
          i_less_lengthF[where F= F and c = c]
          i_eq_lengthF[where F= F and c = c]
    by presburger
  have "D = E"
    unfolding D_def E_def
    using orToUnion[where F=F and c= c]
    by fast
  from this step1 step2 step3 have "A=E"
    by simp
  from this A_def E_def show ?thesis
    by simp
qed

lemma clauseToEdges:"card c = 3 \<Longrightarrow> c = {lita,litb,litc} \<Longrightarrow> sorted [lita,litb,litc] \<Longrightarrow>
      \<Union>{{{(1,tolit l1 = Pos,var l1,0),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . i = length F \<and> {l1,l2,l3} = c \<and> sorted_list_of_set c = [l1,l2,l3]}
      =
      {{(1::nat,tolit lita = Pos,var lita,0::nat),(2,False,length F,0)},
      {(1::nat,tolit litb = Pos,var litb,0::nat),(2,False,length F,1)},
      {(1::nat,tolit litc = Pos,var litc,0::nat),(2,False,length F,2)}}"
proof -
  assume asms:"card c = 3" "c = {lita,litb,litc}" "sorted [lita,litb,litc]"
  from asms have lit_sorted:"sorted_list_of_set {lita,litb,litc} = [lita,litb,litc]"
    using sorted_strictsorted_lits4
    by blast
  from this asms(2) show ?thesis
    by simp
qed

lemma clause_split_union:"c = {lita, litb, litc} \<Longrightarrow> sorted [lita, litb, litc] \<Longrightarrow>  card c = 3  \<Longrightarrow>
      \<Union>{{{(1::nat,tolit l1 = Pos,var l1,0::nat),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . i < length (F@[c]) \<and> {l1,l2,l3} = (F@[c]) ! i \<and> sorted_list_of_set ((F@[c])  !i) = [l1,l2,l3]}
      =
      \<Union>{{{(1,tolit l1 = Pos,var l1,0),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . i < length (F) \<and> {l1,l2,l3} = (F) ! i \<and> sorted_list_of_set ((F)  !i) = [l1,l2,l3]} \<union>
      {{(1,tolit lita = Pos,var lita,0),(2,False,length F,0)},
      {(1,tolit litb = Pos,var litb,0),(2,False,length F,1)},
      {(1,tolit litc = Pos,var litc,0),(2,False,length F,2)}}"
proof -
  assume asms: "c = {lita, litb, litc}" "sorted [lita, litb, litc]" "card c = 3"
  define A where A_def:"A =
    \<Union>{{{(1::nat,tolit l1 = Pos,var l1,0::nat),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . i < length (F@[c]) \<and> {l1,l2,l3} = (F@[c]) ! i \<and> sorted_list_of_set ((F@[c])  !i) = [l1,l2,l3]}"
  define B where B_def:"B =
    \<Union>{{{(1::nat,tolit l1 = Pos,var l1,0::nat),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . i < length (F) \<and> {l1,l2,l3} = (F) ! i \<and> sorted_list_of_set ((F)  !i) = [l1,l2,l3]} \<union>
      \<Union>{{{(1,tolit l1 = Pos,var l1,0),(2,False,i,0)},
      {(1,tolit l2 = Pos,var l2,0),(2,False,i,1)},
      {(1,tolit l3 = Pos,var l3,0),(2,False,i,2)}}|
      l1 l2 l3 i . i = length F \<and> {l1,l2,l3} = c \<and> sorted_list_of_set c = [l1,l2,l3]}"
  define C where C_def: "C =
      \<Union> {{{(1::nat, tolit l1 = Pos, var l1, 0::nat), (2, False, i, 0)},
          {(1, tolit l2 = Pos, var l2, 0), (2, False, i, 1)},
          {(1, tolit l3 = Pos, var l3, 0), (2, False, i, 2)}} |
          l1 l2 l3 i. i < length F \<and> {l1, l2, l3} = F ! i \<and>
          sorted_list_of_set (F ! i) = [l1, l2, l3]} \<union>
      {{(1,tolit lita = Pos,var lita,0),(2,False,length F,0)},
      {(1,tolit litb = Pos,var litb,0),(2,False,length F,1)},
      {(1,tolit litc = Pos,var litc,0),(2,False,length F,2)}}"
  have step1:"A = B"
    unfolding A_def B_def
    using union_split
    by presburger
  from asms have "B= C"
    unfolding B_def C_def
    using clauseToEdges[where c = c and F = F and lita = lita and litb = litb and litc = litc]
    by presburger
  from this step1 have "A = C"
    by simp
  from this show ?thesis
    unfolding A_def C_def
    by fast
qed

subsection "finite Aux"

lemma finite1:
"F\<in> three_cnf_sat \<Longrightarrow>
finite {{(0, False, 0, 2), (Suc 0, True, var l, 0)} |j l. l \<in>  \<Union> (set F)} "
proof -
  assume "F\<in> three_cnf_sat"
  from this have "finite (\<Union> (set F))" unfolding three_cnf_sat_def sat_def models_def
    using finite_Union by fastforce
  from this have fin1:"finite (var`(\<Union> (set F)))" by auto
  let ?S = "({0}\<times>{True,False} \<times> (var`(\<Union> (set F)))\<times> {2})\<times>({1}\<times>{True,False} \<times> (var`(\<Union> (set F)))\<times> {0})"
  from fin1 show ?thesis by (fastforce intro: finite_surj[where A = "?S"])
qed

lemma finite2:
"F\<in> three_cnf_sat \<Longrightarrow>
finite {{(0, False, 0, 2), (Suc 0, False, var l, 0)} |j l. l \<in>  \<Union> (set F)} "
proof -
  assume "F\<in> three_cnf_sat"
  from this have "finite (\<Union> (set F))" unfolding three_cnf_sat_def sat_def models_def
    using finite_Union by fastforce
  from this have fin1:"finite (var`(\<Union> (set F)))" by auto
  let ?S = "({1}\<times>{True,False} \<times> {0}\<times> {0})\<times>({1}\<times>{True,False} \<times> (var`(\<Union> (set F)))\<times> {0})"
  from fin1 show ?thesis by (fastforce intro: finite_surj[where A = "?S"])
qed

lemma finite3:
"F\<in> three_cnf_sat \<Longrightarrow>
finite {{(Suc 0, False, var l, 0), (Suc 0, True, var l, 0)} |l. \<exists>x\<in>set F. l \<in> x}"
proof -
  assume "F\<in> three_cnf_sat"
  from this have "finite (\<Union> (set F))" unfolding three_cnf_sat_def sat_def models_def
    using finite_Union by fastforce
  from this have fin1:"finite (var`(\<Union> (set F)))" by auto
  let ?S = "({1}\<times>{True,False} \<times> (var`(\<Union> (set F)))\<times> {0})\<times>({1}\<times>{True,False} \<times> (var`(\<Union> (set F)))\<times> {0})"
  from fin1 show ?thesis by (fastforce intro: finite_surj[where A = "?S"])
qed

lemma finite4:
"F\<in> three_cnf_sat \<Longrightarrow>
finite
     (\<Union> {{{(Suc 0, tolit l1 = Pos, var l1, 0), (2, False, i, 0)},
           {(Suc 0, tolit l2 = Pos, var l2, 0), (2, False, i, Suc 0)},
           {(Suc 0, tolit l3 = Pos, var l3, 0), (2, False, i, 2)}} |
          l1 l2 l3 i. i < length F \<and> {l1, l2, l3} = F ! i \<and> sorted_list_of_set ((F)  !i) = [l1,l2,l3]})"
proof -
  assume "F\<in> three_cnf_sat"
  from this have "finite (\<Union> (set F))" unfolding three_cnf_sat_def sat_def models_def
    using finite_Union by fastforce
  from this have fin1:"finite (var`(\<Union> (set F)))" by auto
  let ?S = "({1}\<times>{True,False} \<times> (var`(\<Union> (set F)))\<times> {0})\<times>({2}\<times>{True,False} \<times> {0..<length F}\<times> {0,1,2})"
  from fin1 show ?thesis by (fastforce intro: finite_surj[where A = "?S"])
qed

end


theory DDL imports Main             (* Christoph Benzmüller & Xavier Parent & Ali Farjami, 2018  *)

begin (* DDL: Dyadic Deontic Logic by Carmo and Jones *)
 typedecl i (*type for possible worlds*)   type_synonym \<sigma> = "(i\<Rightarrow>bool)"
 consts av::"i\<Rightarrow>\<sigma>" pv::"i\<Rightarrow>\<sigma>" ob::"\<sigma>\<Rightarrow>(\<sigma>\<Rightarrow>bool)" (*accessibility relations*) cw::i (*current world*)

 axiomatization where
  ax_3a: "\<exists>x. av(w)(x)" and ax_4a: "\<forall>x. av(w)(x) \<longrightarrow> pv(w)(x)" and ax_4b: "pv(w)(w)" and
  ax_5a: "\<not>ob(X)(\<lambda>x. False)" and
  ax_5b: "(\<forall>w. ((Y(w) \<and> X(w)) \<longleftrightarrow> (Z(w) \<and> X(w)))) \<longrightarrow> (ob(X)(Y) \<longleftrightarrow> ob(X)(Z))" and
  ax_5c: "((\<forall>Z. \<beta>(Z) \<longrightarrow> ob(X)(Z)) \<and> (\<exists>Z. \<beta>(Z))) \<longrightarrow>
      (((\<exists>y. ((\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))(y) \<and> X(y))) \<longrightarrow> ob(X)(\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))))" and
  ax_5d: "((\<forall>w. Y(w) \<longrightarrow> X(w)) \<and> ob(X)(Y) \<and> (\<forall>w. X(w) \<longrightarrow> Z(w)))
                   \<longrightarrow> ob(Z)(\<lambda>w. (Z(w) \<and> \<not>X(w)) \<or> Y(w))" and
  ax_5e: "((\<forall>w. Y(w) \<longrightarrow> X(w)) \<and> ob(X)(Z) \<and> (\<exists>w. Y(w) \<and> Z(w))) \<longrightarrow> ob(Y)(Z)"

 abbreviation ddlneg ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>A \<equiv> \<lambda>w. \<not>A(w)"
 abbreviation ddland (infixr"\<^bold>\<and>"51) where "A\<^bold>\<and>B \<equiv> \<lambda>w. A(w)\<and>B(w)"
 abbreviation ddlor (infixr"\<^bold>\<or>"50) where "A\<^bold>\<or>B \<equiv> \<lambda>w. A(w)\<or>B(w)"
 abbreviation ddlimp (infixr"\<^bold>\<rightarrow>"49) where "A\<^bold>\<rightarrow>B \<equiv> \<lambda>w. A(w)\<longrightarrow>B(w)"
 abbreviation ddlequiv (infixr"\<^bold>\<leftrightarrow>"48) where "A\<^bold>\<leftrightarrow>B \<equiv> \<lambda>w. A(w)\<longleftrightarrow>B(w)"
 abbreviation ddlbox ("\<^bold>\<box>") where "\<^bold>\<box>A \<equiv> \<lambda>w.\<forall>v. A(v)"  (*A = (\<lambda>w. True)*)
 abbreviation ddlboxa ("\<^bold>\<box>\<^sub>a") where "\<^bold>\<box>\<^sub>aA \<equiv> \<lambda>w. (\<forall>x. av(w)(x) \<longrightarrow> A(x))"  (*in all actual worlds*)
 abbreviation ddlboxp ("\<^bold>\<box>\<^sub>p") where "\<^bold>\<box>\<^sub>pA \<equiv> \<lambda>w. (\<forall>x. pv(w)(x) \<longrightarrow> A(x))" (*in all potential worlds*)
 abbreviation ddldia ("\<^bold>\<diamond>") where "\<^bold>\<diamond>A \<equiv> \<^bold>\<not>\<^bold>\<box>(\<^bold>\<not>A)"
 abbreviation ddldiaa ("\<^bold>\<diamond>\<^sub>a") where "\<^bold>\<diamond>\<^sub>aA \<equiv> \<^bold>\<not>\<^bold>\<box>\<^sub>a(\<^bold>\<not>A)"
 abbreviation ddldiap ("\<^bold>\<diamond>\<^sub>p") where "\<^bold>\<diamond>\<^sub>pA \<equiv> \<^bold>\<not>\<^bold>\<box>\<^sub>p(\<^bold>\<not>A)"
 abbreviation ddlo ("\<^bold>O\<^bold>\<langle>_\<^bold>|_\<^bold>\<rangle>"[52]53) where "\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<equiv> \<lambda>w. ob(A)(B)"  (*it ought to be \<psi>, given \<phi> *)
 abbreviation ddloa ("\<^bold>O\<^sub>a") where "\<^bold>O\<^sub>aA \<equiv> \<lambda>w. ob(av(w))(A) \<and> (\<exists>x. av(w)(x) \<and> \<not>A(x))" (*actual obligation*)
 abbreviation ddlop ("\<^bold>O\<^sub>p") where "\<^bold>O\<^sub>pA \<equiv> \<lambda>w. ob(pv(w))(A) \<and> (\<exists>x. pv(w)(x) \<and> \<not>A(x))"  (*primary obligation*)
 abbreviation ddltop ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
 abbreviation ddlbot ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"

 abbreviation ddlvalid::"\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>"[7]105) where "\<lfloor>A\<rfloor> \<equiv> \<forall>w. A w"   (*Global validity*)
 abbreviation ddlvalidcw::"\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>\<^sub>c\<^sub>w"[7]105) where "\<lfloor>A\<rfloor>\<^sub>c\<^sub>w \<equiv> A cw" (*Local validity (in cw)*)

(* A is obliagtory *)
 abbreviation obligatoryDDL::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>O\<^bold>\<langle>_\<^bold>\<rangle>")   where "\<^bold>O\<^bold>\<langle>A\<^bold>\<rangle>  \<equiv>  \<^bold>O\<^bold>\<langle>A\<^bold>|\<^bold>\<top>\<^bold>\<rangle>"

(* Consistency *)
  lemma True nitpick [satisfy] oops

(* Unimportant *)
  sledgehammer_params [max_facts=20,timeout=20] (* Sets parameters for theorem provers *)
  nitpick_params [user_axioms,expect=genuine,show_all,format=2] (* ... and model finder. *)

end


theory PureLogic
imports
  Execution
  FirstOccOrd
begin

section{* Knowledge Event Traces *}

datatype knevent = "Knows" "execmsg"   ("\<star>_" [900] 900)
                 | "Event" "execevent" ("\<Delta>_" [900] 900)

types knev_trace = "knevent list"

fun injectKn :: "wt_subst \<Rightarrow> trace \<Rightarrow> knev_trace"
where
  "injectKn s []     = []"
| "injectKn s (FromIK0 m) =
     \<Delta>(FromIK0 m) # \<star>(m) # injectKn s es"
| "injectKn s (MkStep tid (Send lbl msg)#es) =
     \<Delta>(MkStep tid (Send lbl msg)) #
     \<star>(subst s (spec2exec msg tid)) #
     injectKn s es"
| "injectKn s (MkStep tid (Recv lbl msg) # es) =
     \<Delta>(MkStep tid (Recv lbl msg)) # injectKn s es"
| "injectKn s (MkTup x y # es) =
     \<Delta>(MkTup x y) # \<star>(Tup x y)  # injectKn s es"
| "injectKn s (MkUnt x y # es) =
     \<Delta>(MkUnt x y) # \<star>(x) # \<star>(y) # injectKn s es"
| "injectKn s (MkEncr m k # es) =
     \<Delta>(MkEncr m k) # \<star>(Enc m k) # injectKn s es"
| "injectKn s (MkDecr m k # es) =
     \<Delta>(MkDecr m k) # \<star>(m) # injectKn s es"
| "injectKn s (MkHash m # es) =
     \<Delta>(MkHash m) # \<star>(Hash m) # injectKn s es"

definition stateOrd :: "knevent \<Rightarrow> state \<Rightarrow> knevent \<Rightarrow> bool" ("_ \<prec>\<^bsub>_\<^esub>/ _" [100, 100, 100] 100)
where "stateOrd ke q ke' = (case q of (t,r,s) \<Rightarrow>
                             (ke' \<notin> { \<star>m | m. m \<in> IK0}) \<and>
                             (ke  \<in> { \<star>m | m. m \<in> IK0} \<and> ke' \<in> set (injectKn s t) \<or>
                              (ke,ke') \<in> firstOccOrd (injectKn s t))
                           )"

definition stateKnEvs :: "state \<Rightarrow> knevent set"
where "stateKnEvs q = (case q of (t,r,s) \<Rightarrow> { \<star>m | m. m \<in> IK0} \<union> set (injectKn s t))"

lemma stateOrd_trans: "\<lbrakk> ke \<prec>\<^bsub>q\<^esub> ke'; ke' \<prec>\<^bsub>q\<^esub> ke'' \<rbrakk> \<Longrightarrow> ke \<prec>\<^bsub>q\<^esub> ke''"
  by(auto simp: stateOrd_def dest: in_set_firstOccOrd1 in_set_firstOccOrd2 intro: firstOccOrd_trans)

(* MISSSING: previous event must only be present, if later event is present
    \<Longrightarrow> sacrifices irreflexivity
*)

lemma stateOrd_irr: "\<not>( ke \<prec>\<^bsub>q\<^esub> ke )"
  by(auto simp: stateOrd_def intro: firstOccOrd_irr)

section{* Secrecy and Authentication Logic *}

text{*
  This version tries to be more complete with respect to
  the operator definitions.
*}

subsection{* Abstract Events *}

fun substEv :: "wt_subst \<Rightarrow> execevent \<Rightarrow> execevent"
where
  "substEv s (MkStep tid step) = MkStep tid step"
| "substEv s (MkHash m)        = MkHash (subst s m)"
| "substEv s (MkTup x y)       = MkTup  (subst s x) (subst s y)"
| "substEv s (MkUnt x y)       = MkUnt  (subst s x) (subst s y)"
| "substEv s (MkEncr m k)      = MkEncr (subst s m) (subst s k)"
| "substEv s (MkDecr m k)      = MkDecr (subst s m) (subst s k)"

subsection{* Predicates *}

definition kn :: "state \<Rightarrow> execmsg \<Rightarrow> bool"
where "kn q m = (case q of (t,r,s) \<Rightarrow> subst s m \<in> knows s t)"

definition ev :: "state \<Rightarrow> execevent \<Rightarrow> bool"
where "ev q e \<equiv> (case q of (t,r,s) \<Rightarrow> substEv s e \<in> set t)"

definition evBev :: "execevent \<Rightarrow> state \<Rightarrow> execevent \<Rightarrow> bool" ("_/ \<triangleleft>[_]\<triangleleft>/ _" [100,100,100] 100)
where "e' \<triangleleft>[q]\<triangleleft> e = (case q of (t,r,s) \<Rightarrow>
                      substEv s e \<in> set t \<longrightarrow>
                      (substEv s e', substEv s e) \<in> firstOccOrd t)"

definition knBev :: "execmsg \<Rightarrow> state \<Rightarrow> execevent \<Rightarrow> bool" ("_/ \<star>[_]\<triangleleft>/ _" [100,100,100] 100)
where "m \<star>[q]\<triangleleft> e = (case q of (t,r,s) \<Rightarrow>
                      subst s m \<in> IK0 \<or>
                      (substEv s e \<in> set t \<longrightarrow>
                        (\<exists> e' \<in> set t. (e', substEv s e) \<in> firstOccOrd t \<and>
                                       subst s m \<in> eout s e'
                        )
                      )
                    )"

definition evBkn :: "execevent \<Rightarrow> state \<Rightarrow> execmsg \<Rightarrow> bool" ("_/ \<triangleleft>[_]\<star>/ _" [100,100,100] 100)
where "e \<triangleleft>[q]\<star> m = (case q of (t,r,s) \<Rightarrow>
                      subst s m \<notin> IK0 \<and>
                      (\<forall> e' \<in> set t. subst s m \<in> eout s e' \<longrightarrow>
                                    (substEv s e, e') \<in> firstOccOrd t
                      )
                    )"

definition knBkn :: "execmsg \<Rightarrow> state \<Rightarrow> execmsg \<Rightarrow> bool" ("_/ \<star>[_]\<star>/ _" [100,100,100] 100)
where "m' \<star>[q]\<star> m = (case q of (t,r,s) \<Rightarrow>
                       subst s m \<notin> IK0 \<and>
                       (\<forall> e \<in> set t. subst s m \<in> eout s e \<longrightarrow>
                          (\<exists> e' \<in> set t. subst s m' \<in> eout s e' \<and>
                                         (e', e) \<in> firstOccOrd t
                          )
                       )
                     )"

lemma knBkn_trans [trans]: "\<lbrakk> m \<star>[q]\<star> m'; m' \<star>[q]\<star> m'' \<rbrakk> \<Longrightarrow> m \<star>[q]\<star> m''"
  by(force simp: knBkn_def intro: firstOccOrd_trans)

lemma evBev_trans [trans]: "\<lbrakk> e \<triangleleft>[q]\<triangleleft> e'; e' \<triangleleft>[q]\<triangleleft> e'' \<rbrakk> \<Longrightarrow> e \<triangleleft>[q]\<triangleleft> e''"
  by(auto simp: evBev_def intro: firstOccOrd_trans
          dest: in_set_firstOccOrd1 in_set_firstOccOrd2)

lemma knBev_evBkn_trans: "\<lbrakk>

lemma test: "x \<or> y \<longrightarrow> z"
  apply(rule impI)

lemma test: "f e \<triangleleft>[q]\<triangleleft> g e \<and> P"

definition learn :: "state \<Rightarrow> execevent \<Rightarrow> execmsg \<Rightarrow> bool"
where "learn q e m \<equiv> (case q of (t,r,s) \<Rightarrow>
                       substEv s e \<in> set t \<and>
                       subst s m \<in> eout s (substEv s e) \<and>
                       subst s m \<notin> IK0 \<and>
                       (\<forall> e' \<in> set t. (e',substEv s e) \<in> firstOccOrd t \<longrightarrow>
                                       subst s m \<notin> eout s e')
                     )"

\<star>[q]\<star>

\<triangleleft>[q]\<star>

\<triangleleft>[q]\<triangleleft>

\<star>[q]\<triangleleft>

definition evbefore :: "state \<Rightarrow> execevent \<Rightarrow> execevent \<Rightarrow> bool"
where "evbefore q e e' \<equiv> (case q of (t,r,s) \<Rightarrow>
                           (substEv s e, substEv s e') \<in> firstOccOrd t)"

definition knbefore :: "state \<Rightarrow> execmsg \<Rightarrow> execevent \<Rightarrow> bool"
where "knbefore q m e \<equiv> (case q of (t,r,s) \<Rightarrow>
                          substEv s e \<in> set t \<and>
                          (subst s m \<in> IK0 \<or>
                           (\<exists> e' \<in> set t. (e',substEv s e) \<in> firstOccOrd t \<and>
                                          subst s m \<in> eout s e')
                          )
                        )"

definition runs :: "state \<Rightarrow> tid \<Rightarrow> role \<Rightarrow> bool"
where "runs q tid R \<equiv> (case q of (t,r,s) \<Rightarrow>
                        (case r tid of
                          Some (todo,done) \<Rightarrow> Rep_role R = rev done @ todo
                        | None             \<Rightarrow> False))"

subsection{* Rules *}

subsubsection{* Simplification *}

lemma kn_simps [simp]:
  "kn q (Lit (EConst c))"
  "kn q (Lit (EHonest a))"
  "kn q (Lit (EveNonce n))"
  "kn q (SK (Lit Eve))"
  "kn q (PK (Lit (EHonest a)))"
  "kn q (K (Lit (EHonest a)) (Lit Eve))"
  "kn q (K (Lit Eve) (Lit (EHonest a)))"
  by(cases q, simp add: IK0_def kn_def knows_conv_eout image_def)+

lemma knbefore_simps:
  "ev q e \<Longrightarrow> knbefore q (Lit (EConst c)) e"
  "ev q e \<Longrightarrow> knbefore q (Lit (EHonest a)) e"
  "ev q e \<Longrightarrow> knbefore q (Lit (EveNonce n)) e"
  "ev q e \<Longrightarrow> knbefore q (SK (Lit Eve)) e"
  "ev q e \<Longrightarrow> knbefore q (PK (Lit (EHonest a))) e"
  "ev q e \<Longrightarrow> knbefore q (K (Lit (EHonest a)) (Lit Eve)) e"
  "ev q e \<Longrightarrow> knbefore q (K (Lit Eve) (Lit (EHonest a))) e"
  by(cases q, simp add: IK0_def knbefore_def image_def ev_def)+

subsubsection{* Purely Execal *}

lemma evbeforeD1: "evbefore q e1 e2 \<Longrightarrow> ev q e1"
  by(auto dest: in_set_firstOccOrd1 simp: evbefore_def ev_def)

lemma evbeforeD2: "evbefore q e1 e2 \<Longrightarrow> ev q e2"
  by(auto dest: in_set_firstOccOrd2 simp: evbefore_def ev_def)

lemma knbeforeD1: "knbefore q m e \<Longrightarrow> kn q m"
  by(auto simp: knbefore_def knows_conv_eout kn_def)

lemma knbeforeD2: "knbefore q m e \<Longrightarrow> ev q e"
  by(auto simp: knbefore_def  ev_def)

lemma learnD1: "learn q e m \<Longrightarrow> ev q e"
  by(auto simp: learn_def ev_def)

lemma learnD2: "learn q e m \<Longrightarrow> kn q m"
  by(auto simp add: learn_def knows_conv_eout kn_def)

lemma ebefore_irr: "\<not>evbefore q e e"
  by(auto simp: evbefore_def)

lemma ebefore_trans: "\<lbrakk> evbefore q e1 e2; evbefore q e2 e3 \<rbrakk> \<Longrightarrow> evbefore q e1 e3"
  by(auto simp: evbefore_def intro: firstOccOrd_trans)

lemma learn_fun:
  "\<lbrakk> learn q e1 m; learn q e2 m \<rbrakk>
  \<Longrightarrow> substEv (sts q) e1 = substEv (sts q) e2"
  apply(clarsimp simp: learn_def)
  by(auto dest: firstOccOrd_cases in_set_firstOccOrd1 in_set_firstOccOrd2)

lemma learn_knbefore_evbefore:
  "\<lbrakk> learn q e m; knbefore q m e' \<rbrakk> \<Longrightarrow> evbefore q e e'"
  by(auto dest: firstOccOrd_cases intro: firstOccOrd_trans
          simp: learn_def knbefore_def evbefore_def)

lemma runs_fun: "\<lbrakk> runs q tid R; runs q tid R' \<rbrakk> \<Longrightarrow> R = R'"
  by(auto simp: runs_def Rep_role_inject[symmetric] split: option.splits )