subsection \<open>A Comparator-Interface to Red-Black-Trees\<close>

theory RBT_Comparator_Impl
imports
  "~~/src/HOL/Library/RBT_Impl"
  Comparator
begin

text \<open>For all of the main algorithms of red-black trees, we
  provide alternatives which are completely based on comparators,
  and which are provable equivalent. At the time of writing,
  this interface is used in the Container AFP-entry.

  It does not rely on the modifications of code-equations as in
  the previous subsection.\<close>

context
  fixes c :: "'a comparator"
begin

primrec rbt_comp_lookup :: "('a, 'b) rbt \<Rightarrow> 'a \<rightharpoonup> 'b"
where
  "rbt_comp_lookup RBT_Impl.Empty k = None"
| "rbt_comp_lookup (Branch _ l x y r) k =
   (case c k x of Lt \<Rightarrow> rbt_comp_lookup l k
     | Gt \<Rightarrow> rbt_comp_lookup r k
     | Eq \<Rightarrow> Some y)"

fun
  rbt_comp_ins :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
  "rbt_comp_ins f k v RBT_Impl.Empty = Branch RBT_Impl.R RBT_Impl.Empty k v  RBT_Impl.Empty" |
  "rbt_comp_ins f k v (Branch RBT_Impl.B l x y r) = (case c k x of
      Lt \<Rightarrow> balance (rbt_comp_ins f k v l) x y r
    | Gt \<Rightarrow> balance l x y (rbt_comp_ins f k v r)
    | Eq \<Rightarrow> Branch RBT_Impl.B l x (f k y v) r)" |
  "rbt_comp_ins f k v (Branch RBT_Impl.R l x y r) = (case c k x of
      Lt \<Rightarrow> Branch RBT_Impl.R (rbt_comp_ins f k v l) x y r
    | Gt \<Rightarrow> Branch RBT_Impl.R l x y (rbt_comp_ins f k v r)
    | Eq \<Rightarrow> Branch RBT_Impl.R l x (f k y v) r)"

definition rbt_comp_insert_with_key :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where "rbt_comp_insert_with_key f k v t = paint RBT_Impl.B (rbt_comp_ins f k v t)"

definition rbt_comp_insert :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where
  "rbt_comp_insert = rbt_comp_insert_with_key (\<lambda>_ _ nv. nv)"

fun
  rbt_comp_del_from_left :: "'a \<Rightarrow> ('a,'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt" and
  rbt_comp_del_from_right :: "'a \<Rightarrow> ('a,'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt" and
  rbt_comp_del :: "'a\<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
  "rbt_comp_del x RBT_Impl.Empty = RBT_Impl.Empty" |
  "rbt_comp_del x (Branch _ a y s b) =
   (case c x y of
        Lt \<Rightarrow> rbt_comp_del_from_left x a y s b
      | Gt \<Rightarrow> rbt_comp_del_from_right x a y s b
      | Eq \<Rightarrow> combine a b)" |
  "rbt_comp_del_from_left x (Branch RBT_Impl.B lt z v rt) y s b = balance_left (rbt_comp_del x (Branch RBT_Impl.B lt z v rt)) y s b" |
  "rbt_comp_del_from_left x a y s b = Branch RBT_Impl.R (rbt_comp_del x a) y s b" |
  "rbt_comp_del_from_right x a y s (Branch RBT_Impl.B lt z v rt) = balance_right a y s (rbt_comp_del x (Branch RBT_Impl.B lt z v rt))" |
  "rbt_comp_del_from_right x a y s b = Branch RBT_Impl.R a y s (rbt_comp_del x b)"

definition "rbt_comp_delete k t = paint RBT_Impl.B (rbt_comp_del k t)"

definition "rbt_comp_bulkload xs = foldr (\<lambda>(k, v). rbt_comp_insert k v) xs RBT_Impl.Empty"

primrec
  rbt_comp_map_entry :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
where
  "rbt_comp_map_entry k f RBT_Impl.Empty = RBT_Impl.Empty"
| "rbt_comp_map_entry k f (Branch cc lt x v rt) =
    (case c k x of
        Lt \<Rightarrow> Branch cc (rbt_comp_map_entry k f lt) x v rt
      | Gt \<Rightarrow> Branch cc lt x v (rbt_comp_map_entry k f rt)
      | Eq \<Rightarrow> Branch cc lt x (f v) rt)"

function comp_sunion_with :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list"
where
  "comp_sunion_with f ((k, v) # as) ((k', v') # bs) =
   (case c k' k of
        Lt \<Rightarrow> (k', v') # comp_sunion_with f ((k, v) # as) bs
      | Gt \<Rightarrow> (k, v) # comp_sunion_with f as ((k', v') # bs)
      | Eq \<Rightarrow> (k, f k v v') # comp_sunion_with f as bs)"
| "comp_sunion_with f [] bs = bs"
| "comp_sunion_with f as [] = as"
by pat_completeness auto
termination by lexicographic_order

function comp_sinter_with :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list"
where
  "comp_sinter_with f ((k, v) # as) ((k', v') # bs) =
  (case c k' k of
      Lt \<Rightarrow> comp_sinter_with f ((k, v) # as) bs
    | Gt \<Rightarrow> comp_sinter_with f as ((k', v') # bs)
    | Eq \<Rightarrow> (k, f k v v') # comp_sinter_with f as bs)"
| "comp_sinter_with f [] _ = []"
| "comp_sinter_with f _ [] = []"
by pat_completeness auto
termination by lexicographic_order

definition rbt_comp_union_with_key :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
where
  "rbt_comp_union_with_key f t1 t2 =
  (case RBT_Impl.compare_height t1 t1 t2 t2
   of compare.EQ \<Rightarrow> rbtreeify (comp_sunion_with f (RBT_Impl.entries t1) (RBT_Impl.entries t2))
    | compare.LT \<Rightarrow> RBT_Impl.fold (rbt_comp_insert_with_key (\<lambda>k v w. f k w v)) t1 t2
    | compare.GT \<Rightarrow> RBT_Impl.fold (rbt_comp_insert_with_key f) t2 t1)"

definition rbt_comp_inter_with_key :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
where
  "rbt_comp_inter_with_key f t1 t2 =
  (case RBT_Impl.compare_height t1 t1 t2 t2
   of compare.EQ \<Rightarrow> rbtreeify (comp_sinter_with f (RBT_Impl.entries t1) (RBT_Impl.entries t2))
    | compare.LT \<Rightarrow> rbtreeify (List.map_filter (\<lambda>(k, v). map_option (\<lambda>w. (k, f k v w)) (rbt_comp_lookup t2 k)) (RBT_Impl.entries t1))
    | compare.GT \<Rightarrow> rbtreeify (List.map_filter (\<lambda>(k, v). map_option (\<lambda>w. (k, f k w v)) (rbt_comp_lookup t1 k)) (RBT_Impl.entries t2)))"

context
  assumes c: "comparator c"
begin

lemma rbt_comp_lookup: "rbt_comp_lookup = ord.rbt_lookup (lt_of_comp c)"
proof (intro ext)
  fix k and t :: "('a,'b)rbt"
  show "rbt_comp_lookup t k = ord.rbt_lookup (lt_of_comp c) t k"
    by (induct t, unfold rbt_comp_lookup.simps ord.rbt_lookup.simps
      comparator.two_comparisons_into_case_order[OF c])
      (auto split: order.splits)
qed

lemma rbt_comp_ins: "rbt_comp_ins = ord.rbt_ins (lt_of_comp c)"
proof (intro ext)
  fix f k v and t :: "('a,'b)rbt"
  show "rbt_comp_ins f k v t = ord.rbt_ins (lt_of_comp c) f k v t"
    by (induct f k v t rule: rbt_comp_ins.induct, unfold rbt_comp_ins.simps ord.rbt_ins.simps
      comparator.two_comparisons_into_case_order[OF c])
      (auto split: order.splits)
qed

lemma rbt_comp_insert_with_key: "rbt_comp_insert_with_key = ord.rbt_insert_with_key (lt_of_comp c)"
  unfolding rbt_comp_insert_with_key_def[abs_def] ord.rbt_insert_with_key_def[abs_def]
  unfolding rbt_comp_ins ..

lemma rbt_comp_insert: "rbt_comp_insert = ord.rbt_insert (lt_of_comp c)"
  unfolding rbt_comp_insert_def[abs_def] ord.rbt_insert_def[abs_def]
  unfolding rbt_comp_insert_with_key ..

lemma rbt_comp_del: "rbt_comp_del = ord.rbt_del (lt_of_comp c)"
proof - {
  fix k a b and s t :: "('a,'b)rbt"
  have
    "rbt_comp_del_from_left k t a b s = ord.rbt_del_from_left (lt_of_comp c) k t a b s"
    "rbt_comp_del_from_right k t a b s = ord.rbt_del_from_right (lt_of_comp c) k t a b s"
    "rbt_comp_del k t = ord.rbt_del (lt_of_comp c) k t"
  by (induct k t a b s and k t a b s and k t rule: rbt_comp_del_from_left_rbt_comp_del_from_right_rbt_comp_del.induct,
    unfold
      rbt_comp_del.simps ord.rbt_del.simps
      rbt_comp_del_from_left.simps ord.rbt_del_from_left.simps
      rbt_comp_del_from_right.simps ord.rbt_del_from_right.simps
      comparator.two_comparisons_into_case_order[OF c],
    auto split: order.split)
  }
  thus ?thesis by (intro ext)
qed

lemma rbt_comp_delete: "rbt_comp_delete = ord.rbt_delete (lt_of_comp c)"
  unfolding rbt_comp_delete_def[abs_def] ord.rbt_delete_def[abs_def]
  unfolding rbt_comp_del ..

lemma rbt_comp_bulkload: "rbt_comp_bulkload = ord.rbt_bulkload (lt_of_comp c)"
  unfolding rbt_comp_bulkload_def[abs_def] ord.rbt_bulkload_def[abs_def]
  unfolding rbt_comp_insert ..

lemma rbt_comp_map_entry: "rbt_comp_map_entry = ord.rbt_map_entry (lt_of_comp c)"
proof (intro ext)
  fix f k and t :: "('a,'b)rbt"
  show "rbt_comp_map_entry f k t = ord.rbt_map_entry (lt_of_comp c) f k t"
    by (induct t, unfold rbt_comp_map_entry.simps ord.rbt_map_entry.simps
      comparator.two_comparisons_into_case_order[OF c])
      (auto split: order.splits)
qed

lemma comp_sunion_with: "comp_sunion_with = ord.sunion_with (lt_of_comp c)"
proof (intro ext)
  fix f and as bs :: "('a \<times> 'b)list"
  show "comp_sunion_with f as bs = ord.sunion_with (lt_of_comp c) f as bs"
    by (induct f as bs rule: comp_sunion_with.induct,
      unfold comp_sunion_with.simps ord.sunion_with.simps
      comparator.two_comparisons_into_case_order[OF c])
      (auto split: order.splits)
qed

lemma comp_sinter_with: "comp_sinter_with = ord.sinter_with (lt_of_comp c)"
proof (intro ext)
  fix f and as bs :: "('a \<times> 'b)list"
  show "comp_sinter_with f as bs = ord.sinter_with (lt_of_comp c) f as bs"
    by (induct f as bs rule: comp_sinter_with.induct,
      unfold comp_sinter_with.simps ord.sinter_with.simps
      comparator.two_comparisons_into_case_order[OF c])
      (auto split: order.splits)
qed

lemma rbt_comp_union_with_key: "rbt_comp_union_with_key = ord.rbt_union_with_key (lt_of_comp c)"
  unfolding rbt_comp_union_with_key_def[abs_def] ord.rbt_union_with_key_def[abs_def]
  unfolding rbt_comp_insert_with_key comp_sunion_with ..

lemma rbt_comp_inter_with_key: "rbt_comp_inter_with_key = ord.rbt_inter_with_key (lt_of_comp c)"
  unfolding rbt_comp_inter_with_key_def[abs_def] ord.rbt_inter_with_key_def[abs_def]
  unfolding rbt_comp_insert_with_key comp_sinter_with rbt_comp_lookup ..

lemmas rbt_comp_simps =
  rbt_comp_insert
  rbt_comp_lookup
  rbt_comp_delete
  rbt_comp_bulkload
  rbt_comp_map_entry
  rbt_comp_union_with_key
  rbt_comp_inter_with_key
end
end

end


theory GasAnalysis_16012023_033635
imports "Z_Machines.Z_Machine"
begin

subsection \<open> Introduction \<close>

text \<open> This theory file is to model the GasAnalysis state machine in Z Machine notations.\<close>

notation undefined ("???")

subsection \<open> type definition \<close>

datatype ('s, 'e) tag =
  State (ofState: 's) | Event (ofEvent: 'e)

abbreviation "is_Event x \<equiv> \<not> is_State x"

type_synonym ('s, 'e) rctrace = "('s, 'e) tag list"

definition wf_rcstore :: "('s, 'e) rctrace \<Rightarrow> 's \<Rightarrow> 's option \<Rightarrow> bool" where
[z_defs]: "wf_rcstore tr st final = (
     length(tr) > 0
   \<and> tr ! ((length tr) -1) = State st
   \<and> (final \<noteq> None \<longrightarrow> (\<forall>i<length tr. tr ! i = State (the final) \<longrightarrow> i= (length tr) -1))
   \<and> (filter is_State tr) ! (length (filter is_State tr) -1) = State  st)"

enumtype St = initial | GasDetected | final | Reading | Analysis | NoGas
definition [z_defs]: "St = {initial, GasDetected, final, Reading, Analysis, NoGas}"

enumtype Evt = gas | resume | turn | stop
definition "Evt = {gas, resume, turn, stop}"

enumtype Status = noGas | gasD

definition "Status = {noGas, gasD}"
enumtype Angle = Left | Right | Back | Front

definition "Angle = {Left, Right, Back, Front}"
type_synonym Chem= "nat"
type_synonym Intensity= "nat"
record GasSensor =
  c :: Chem
  i :: Intensity
record_default GasSensor
consts thr :: "Intensity"
consts SeqGs :: "((GasSensor) list) set"

text \<open> function definition \<close>

consts goreq :: " Intensity \<times> Intensity \<Rightarrow>bool"
consts angle :: " nat \<Rightarrow> Angle"
consts intensity :: " GasSensor list \<Rightarrow> Intensity"
consts analysis :: " GasSensor list \<Rightarrow> Status"
consts location :: " GasSensor list \<Rightarrow> Angle"

subsection \<open> State Space \<close>

zstore GasAnalysis =
  sts :: "Status"
  gs :: "GasSensor list"
  ins :: "Intensity"
  anl :: "Angle"

  st::"St"
  tr :: "(St, Evt) tag list"
  triggers:: "Evt set"
  where inv:
    "wf_rcstore tr st (Some final)"

subsection \<open> Operations \<close>

zoperation InitialToReading =
  over GasAnalysis
  pre "st= initial"
  update "[st\<Zprime>= Reading
         ,gs\<Zprime> = []
         ,anl\<Zprime> = Front
         ,tr\<Zprime> =tr  @ [State Reading]
         ,triggers\<Zprime> = {gas}
         ]"

zoperation AnalysisToNoGas =
  over GasAnalysis
  pre "st= Analysis \<and> sts= (noGas)"
  update "[st\<Zprime>= NoGas
         ,tr\<Zprime> =tr @ [Event resume] @ [State NoGas]
         ,triggers\<Zprime> = {}
         ]"

zoperation AnalysisToGasDetected =
  over GasAnalysis
  pre "st= Analysis \<and> sts= (gasD)"
  update "[st\<Zprime>= GasDetected
         ,ins\<Zprime> =intensity(gs)
         ,tr\<Zprime> =tr  @ [State GasDetected]
         ,triggers\<Zprime> = {}
         ]"

zoperation GasDetectedToFinal =
  over GasAnalysis
  pre "st= GasDetected \<and> goreq(ins, thr)"
  update "[st\<Zprime>= final
         ,tr\<Zprime> =tr @ [Event stop] @ [State final]
         ,triggers\<Zprime> = {}
         ]"

zoperation GasDetectedToReading =
  over GasAnalysis
  pre "st= GasDetected \<and> \<not>goreq(ins, thr)"
  update "[st\<Zprime>= Reading
         ,anl\<Zprime> = location(gs)
         ,tr\<Zprime> =tr @ [Event turn] @ [State Reading]
         ,triggers\<Zprime> = {gas}
         ]"

zoperation ReadingToAnalysis =
  over GasAnalysis
  params gs_input \<in> "SeqGs"
  pre "st= Reading"
  update "[st\<Zprime>= Analysis
         ,gs\<Zprime> =gs_input
         ,sts\<Zprime> =analysis(gs_input)
         ,tr\<Zprime> =tr @ [Event gas] @ [State Analysis]
         ,triggers\<Zprime> = {}
         ]"

zoperation NoGasToReading =
  over GasAnalysis
  pre "st= NoGas"
  update "[st\<Zprime>= Reading
         ,tr\<Zprime> =tr  @ [State Reading]
         ,triggers\<Zprime> = {gas}
         ]"

definition Init :: "GasAnalysis subst" where
  [z_defs]:
  "Init =
  [st\<leadsto> ,
   tr\<leadsto> ,
   triggers\<leadsto> ,
   ]"
(*To be filled in by user*)

zmachine GasAnalysisMachine =
  init Init
  invariant GasAnalysis_inv
  operations  InitialToReading AnalysisToNoGas AnalysisToGasDetected GasDetectedToFinal GasDetectedToReading ReadingToAnalysis NoGasToReading

subsection \<open> Structural Invariants \<close>

lemma Init_inv [hoare_lemmas]: "Init establishes GasAnalysis_inv"
  by zpog_full

lemma InitialToReading_inv [hoare_lemmas]: "InitialToReading() preserves GasAnalysis_inv"
  by (zpog_full; auto)

lemma AnalysisToNoGas_inv [hoare_lemmas]: "AnalysisToNoGas() preserves GasAnalysis_inv"
  by (zpog_full; auto)

lemma AnalysisToGasDetected_inv [hoare_lemmas]: "AnalysisToGasDetected() preserves GasAnalysis_inv"
  by (zpog_full; auto)

lemma GasDetectedToFinal_inv [hoare_lemmas]: "GasDetectedToFinal() preserves GasAnalysis_inv"
  by (zpog_full; auto)

lemma GasDetectedToReading_inv [hoare_lemmas]: "GasDetectedToReading() preserves GasAnalysis_inv"
  by (zpog_full; auto)

lemma ReadingToAnalysis_inv [hoare_lemmas]: "ReadingToAnalysis (gs) preserves GasAnalysis_inv"
  by (zpog_full; auto)

lemma NoGasToReading_inv [hoare_lemmas]: "NoGasToReading() preserves GasAnalysis_inv"
  by (zpog_full; auto)

subsection \<open> Safety Requirements \<close>

zexpr R1 is ""

lemma  "Init establishes R1"
  by zpog_full

lemma "InitialToReading() preserves R1 under GasAnalysis_inv"
  by (zpog_full; auto)

lemma "AnalysisToNoGas() preserves R1 under GasAnalysis_inv"
  by (zpog_full; auto)

lemma "AnalysisToGasDetected() preserves R1 under GasAnalysis_inv"
  by (zpog_full; auto)

lemma "GasDetectedToFinal() preserves R1 under GasAnalysis_inv"
  by (zpog_full; auto)

lemma "GasDetectedToReading() preserves R1 under GasAnalysis_inv"
  by (zpog_full; auto)

lemma "ReadingToAnalysis (gs) preserves R1 under GasAnalysis_inv"
  by (zpog_full; auto)

lemma "NoGasToReading() preserves R1 under GasAnalysis_inv"
  by (zpog_full; auto)

definition [z_defs]: "GasAnalysis_axioms = ()"

lemma GasAnalysis_deadlock_free: "GasAnalysis_axioms  \<Longrightarrow> deadlock_free GasAnalysisMachine"
  unfolding GasAnalysisMachine_def
  by deadlock_free
end


theory Pierson imports GeneralKnowledge (*** Benzmüller, Fuenmayor & Lomfeld, 2021 ***)
begin (*** Pierson v. Post "wild animal" case **)
 (*unimportant*) nitpick_params[user_axioms,expect=genuine,show_all,format=3]
 (*case-specific 'world-vocabulary'*)
consts \<alpha>::"e" (*appropriated animal (fox in this case) *)
consts Pursue::"c\<Rightarrow>e\<Rightarrow>\<sigma>" Capture::"c\<Rightarrow>e\<Rightarrow>\<sigma>"
(************** pro-defendant (Pierson) argument **************)
 (*defendant's theory*)
abbreviation "dT1 \<equiv> \<lfloor>(\<^bold>\<exists>c. Capture c \<alpha> \<^bold>\<and> \<^bold>\<not>Domestic \<alpha>) \<^bold>\<rightarrow> appWildAnimal\<rfloor>"
abbreviation "dT2 \<equiv> \<lfloor>\<^bold>\<forall>c. Pursue c \<alpha> \<^bold>\<rightarrow> Intent c\<rfloor>"
abbreviation "dT3 \<equiv> \<lfloor>\<^bold>\<forall>c. Capture c \<alpha> \<^bold>\<rightarrow> Poss c\<rfloor>"
abbreviation "d_theory \<equiv> dT1 \<and> dT2 \<and> dT3"
 (*defendant's facts*)
abbreviation "dF1 w \<equiv> Fox \<alpha> w"
abbreviation "dF2 w \<equiv> FreeRoaming \<alpha> w"
abbreviation "dF3 w \<equiv> \<^bold>\<not>Pet \<alpha> w"
abbreviation "dF4 w \<equiv> Pursue p \<alpha> w"
abbreviation "dF5 w \<equiv> Capture d \<alpha> w"
abbreviation "d_facts \<equiv> dF1 \<^bold>\<and> dF2 \<^bold>\<and> dF3 \<^bold>\<and> dF4 \<^bold>\<and> dF5"
 (*decision for defendant (Pierson) can be proven automatically*)
theorem Pierson: "d_theory \<longrightarrow> \<lfloor>d_facts \<^bold>\<rightarrow> \<^bold>\<box>\<^sup>\<prec>For d\<rfloor>"
  by (smt F1 F3 ForAx R2 W5 W7 other.simps tSBR)
 (*we reconstruct the reasoning process leading to the decision for the defendant*)
theorem Pierson': assumes d_theory and "d_facts w" shows "\<^bold>\<box>\<^sup>\<prec>For d w"
proof -
  have 1: "appWildAnimal w"    using W5 W7 assms by blast
  have 2: "\<lfloor>[WILL\<^sup>p]\<^bold>\<prec>[STAB\<^sup>d]\<rfloor>"  using 1 R2 assms by fastforce
  have 3: "\<lfloor>(\<^bold>\<diamond>\<^sup>\<prec>[WILL\<^sup>p]) \<^bold>\<rightarrow> \<^bold>\<diamond>\<^sup>\<prec>[STAB\<^sup>d]\<rfloor>" using 2 tSBR by smt
  have 4: "\<^bold>\<box>\<^sup>\<prec>(For p \<^bold>\<leftrightarrow> \<^bold>\<diamond>\<^sup>\<prec>[WILL\<^sup>p]) w" using F1 assms by meson
  have 5: "\<^bold>\<box>\<^sup>\<prec>(For d \<^bold>\<leftrightarrow> \<^bold>\<diamond>\<^sup>\<prec>[STAB\<^sup>d]) w" using F3 assms by meson
  have 6: "\<^bold>\<box>\<^sup>\<prec>((\<^bold>\<diamond>\<^sup>\<prec>[WILL\<^sup>p]) \<^bold>\<or> (\<^bold>\<diamond>\<^sup>\<prec>[STAB\<^sup>d])) w" using 4 5 ForAx by (smt other.simps)
  have 7: "\<^bold>\<box>\<^sup>\<prec>(\<^bold>\<diamond>\<^sup>\<prec>[STAB\<^sup>d]) w" using 3 6 by blast
  have 8: "\<^bold>\<box>\<^sup>\<prec>(For d) w" using 5 7 by simp
  then show ?thesis by simp
qed
(************** Further checks (using model finder) ****************)
 (*defendant's theory and facts are logically consistent*)
lemma "d_theory \<and> \<lfloor>d_facts\<rfloor>" nitpick[satisfy,card \<iota>=3] oops (*(non-trivial) model found*)
 (*decision for defendant is compatible with premises and lacks value conflicts*)
lemma "\<lfloor>\<^bold>\<not>Conflict\<^sup>p\<rfloor> \<and> \<lfloor>\<^bold>\<not>Conflict\<^sup>d\<rfloor> \<and> d_theory \<and> \<lfloor>d_facts \<^bold>\<and> For d\<rfloor>"
  nitpick[satisfy,card \<iota>=3] oops (* (non-trivial) model found*)
 (*situations where decision holds for plaintiff are compatible too*)
lemma "\<lfloor>\<^bold>\<not>Conflict\<^sup>p\<rfloor> \<and> \<lfloor>\<^bold>\<not>Conflict\<^sup>d\<rfloor> \<and> d_theory \<and> \<lfloor>d_facts \<^bold>\<and> For p\<rfloor>"
  nitpick[satisfy,card \<iota>=3] oops (* (non-trivial) model found*)
end


theory "Woo_Lam_Pi_3_cert_auto"
imports
  "ESPLogic"
begin

(* section:  Woo and Lam Pi 3  *)

(* text:
  Modelled after SPORE.

  Notable differences:
    1. We use explicit global constants instead of implicit typing to discern
       the different messages.

    2. We prove non-injective synchronization, which is stronger than the
       authenticatino requirement stated in the description.

    3. We added the identity B to the plaintext of the fourth message, as the
       server must know it for looking up the key k(B,S).

 *)

role A
where "A =
  [ Send ''1'' ( sAV ''A'' )
  , Recv ''2'' ( sMV ''Nb'' )
  , Send ''3'' ( PEnc <| sC ''3'', sMV ''Nb'' |> ( sK ''A'' ''S'' ) )
  ]"

role B
where "B =
  [ Recv ''1'' ( sMV ''A'' )
  , Send ''2'' ( sN ''Nb'' )
  , Recv ''3'' ( sMV ''Ticket'' )
  , Send ''4'' <| sAV ''B'',
                  PEnc <| sC ''4'', sMV ''A'', sMV ''Ticket'' |> ( sK ''B'' ''S'' )
               |>
  , Recv ''5'' ( PEnc <| sC ''5'', sMV ''A'', sN ''Nb'' |>
                      ( sK ''B'' ''S'' )
               )
  ]"

role S
where "S =
  [ Recv ''4'' <| sMV ''B'',
                  PEnc <| sC ''4'', sMV ''A'',
                          PEnc <| sC ''3'', sMV ''Nb'' |> ( PSymK ( sMV ''A'' ) ( sAV ''S'' ) )
                       |>
                       ( PSymK ( sMV ''B'' ) ( sAV ''S'' ) )
               |>
  , Send ''5'' ( PEnc <| sC ''5'', sMV ''A'', sMV ''Nb'' |>
                      ( PSymK ( sMV ''B'' ) ( sAV ''S'' ) )
               )
  ]"

protocol WooLamPi
where "WooLamPi = { A, B, S }"

locale restricted_WooLamPi_state = WooLamPi_state

type_invariant WooLamPi_msc_typing for WooLamPi
where "WooLamPi_msc_typing = mk_typing
  [ ((B, ''A''), (KnownT B_1))
  , ((S, ''A''), (SumT (KnownT S_4) AgentT))
  , ((S, ''B''), (KnownT S_4))
  , ((A, ''Nb''), (KnownT A_2))
  , ((S, ''Nb''), (SumT (KnownT S_4) (NonceT B ''Nb'')))
  , ((B, ''Ticket''), (KnownT B_3))
  ]"

sublocale WooLamPi_state < WooLamPi_msc_typing_state
proof -
  have "(t,r,s) : approx WooLamPi_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF WooLamPi_msc_typing.monoTyp, completeness_cases_rule])
    case (S_4_A t r s tid0)
    then interpret state: WooLamPi_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_4_A
    thus ?case
    proof(sources! "
        Enc {| LC ''4'', s(MV ''A'' tid0),
               Enc {| LC ''3'', s(MV ''Nb'' tid0) |}
                   ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) )
            |}
            ( K ( s(MV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_4_B t r s tid0)
    then interpret state: WooLamPi_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_4_B
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_4_Nb t r s tid0)
    then interpret state: WooLamPi_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_4_Nb
    thus ?case
    proof(sources! "
        Enc {| LC ''4'', s(MV ''A'' tid0),
               Enc {| LC ''3'', s(MV ''Nb'' tid0) |}
                   ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) )
            |}
            ( K ( s(MV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''3'', s(MV ''Nb'' tid0) |}
                           ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
      qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
    next
      case (B_4_enc tid1) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''3'', s(MV ''Nb'' tid0) |}
                           ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
      qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed
  thus "WooLamPi_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context WooLamPi_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* subsection:  Security Properties  *)

lemma (in restricted_WooLamPi_state) B_noninjective_agreement:
  assumes facts:
    "roleMap r tid2 = Some B"
    "RLKR(s(AV ''B'' tid2)) ~: reveals t"
    "RLKR(s(AV ''S'' tid2)) ~: reveals t"
    "RLKR(s(MV ''A'' tid2)) ~: reveals t"
    "( tid2, B_5 ) : steps t"
  shows
    "(?  tid1.
        roleMap r tid1 = Some A &
        s(AV ''A'' tid1) = s(MV ''A'' tid2) &
        s(AV ''S'' tid1) = s(AV ''S'' tid2) &
        s(MV ''Nb'' tid1) = LN ''Nb'' tid2)"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''5'', s(MV ''A'' tid2), LN ''Nb'' tid2 |}
                       ( K ( s(AV ''B'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc tid3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''4'', s(MV ''A'' tid2),
                            Enc {| LC ''3'', LN ''Nb'' tid2 |}
                                ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) )
                         |}
                         ( K ( s(AV ''B'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    next
      case (B_4_enc tid4) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''3'', LN ''Nb'' tid2 |}
                           ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (auto dest!: ltk_secrecy)
      next
        case (A_3_enc tid5) note_unified facts = this facts
        thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end


section \<open> Overloaded Expression Constructs \<close>

theory utp_expr_ovld
  imports "Z_Toolkit.Relation_Toolkit" utp
begin recall_syntax

hide_const (open) Map.dom
hide_const (open) Map.ran

subsection \<open> Overloadable Constants \<close>

text \<open> For convenience, we often want to utilise the same expression syntax for multiple constructs.
  This can be achieved using ad-hoc overloading. We create a number of polymorphic constants and then
  overload their definitions using appropriate implementations. In order for this to work,
  each collection must have its own unique type. Thus we do not use the HOL map type directly,
  but rather our own partial function type, for example. \<close>

\<comment> \<open> Empty elements, for example empty set, nil list, 0... \<close>
abbreviation (input) "uempty \<equiv> 0"

class ovrd = plus
begin

definition [upred_defs]: "ovrd = plus"

end

consts
  \<comment> \<open> Function application, map application, list application... \<close>
  uapply     :: "'f \<Rightarrow> 'k \<Rightarrow> 'v"
  \<comment> \<open> Function update, map update, list update... \<close>
  uupd       :: "'f \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> 'f"
  \<comment> \<open> Collection summation \<close>
  usums      :: "'f \<Rightarrow> 'a"
  \<comment> \<open> Construct a collection from a list of entries \<close>
  uentries   :: "'k set \<Rightarrow> ('k \<Rightarrow> 'v) \<Rightarrow> 'f"

text \<open> We need a function corresponding to function application in order to overload. \<close>

definition fun_apply :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"
where "fun_apply f x = f x"

declare fun_apply_def [simp]

text \<open> We then set up the overloading for a number of useful constructs for various collections. \<close>

definition [upred_defs]: "list_apply = nth"
definition [upred_defs]: "list_upd = list_augment"
definition [upred_defs]: "list_card = length"
definition [upred_defs]: "list_ran = set"

adhoc_overloading
  uapply rel_apply and uapply fun_apply and uapply list_apply and
  uapply pfun_app and uapply ffun_app and
  uupd rel_update and uupd pfun_upd and uupd ffun_upd and uupd list_upd and
(*  udom Domain and udom pdom and udom fdom and udom seq_dom and *)
(*  uran Range and uran pran and uran fran and uran list_ran and *)
  usums list_sum and usums Sum and usums pfun_sum and
  uentries pfun_entries and uentries ffun_entries

subsection \<open> Syntax Translations \<close>

syntax
  "_uundef"     :: "logic" ("\<bottom>\<^sub>u")
  "_umap_empty" :: "logic" ("[]\<^sub>u")
  "_uapply"     :: "('a \<Rightarrow> 'b, '\<alpha>) uexpr \<Rightarrow> utuple_args \<Rightarrow> ('b, '\<alpha>) uexpr" ("_'(_')\<^sub>a" [999,0] 999)
  "_uovrd"      :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<oplus>" 65)
  "_umaplet"    :: "[logic, logic] => umaplet" ("_ /\<mapsto>/ _")
  ""            :: "umaplet => umaplets"             ("_")
  "_UMaplets"   :: "[umaplet, umaplets] => umaplets" ("_,/ _")
  "_UMapUpd"    :: "[logic, umaplets] => logic" ("_/'(_')\<^sub>u" [900,0] 900)
  "_UMap"       :: "umaplets => logic" ("(1[_]\<^sub>u)")
  "_udom"       :: "logic \<Rightarrow> logic" ("dom\<^sub>u'(_')")
  "_uran"       :: "logic \<Rightarrow> logic" ("ran\<^sub>u'(_')")
  "_usum"       :: "logic \<Rightarrow> logic" ("sum\<^sub>u'(_')")
  "_uentries"   :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("entr\<^sub>u'(_,_')")

translations
  \<comment> \<open> Pretty printing for adhoc-overloaded constructs \<close>
  "f(x)\<^sub>a"    <= "CONST uapply f x"
  "dom\<^sub>u(f)" <= "CONST dom f"
  "ran\<^sub>u(f)" <= "CONST ran f"

  "f(k \<mapsto> v)\<^sub>u" <= "CONST uupd f k v"

  \<comment> \<open> Overloaded construct translations \<close>
  "f(x,y,z,u)\<^sub>a" == "CONST bop CONST uapply f (x,y,z,u)\<^sub>u"
  "f(x,y,z)\<^sub>a" == "CONST bop CONST uapply f (x,y,z)\<^sub>u"
  "f(x,y)\<^sub>a"  == "CONST bop CONST uapply f (x,y)\<^sub>u"
  "f(x)\<^sub>a"    == "CONST bop CONST uapply f x"
  "sum\<^sub>u(A)" == "CONST uop CONST usums A"
  "dom\<^sub>u(f)" == "CONST uop CONST Relation_Toolkit.dom f"
  "ran\<^sub>u(f)" == "CONST uop CONST Relation_Toolkit.ran f"
  "[]\<^sub>u"     => "\<guillemotleft>CONST uempty\<guillemotright>"
  "\<bottom>\<^sub>u"     == "\<guillemotleft>CONST undefined\<guillemotright>"
  "entr\<^sub>u(d,f)" == "CONST bop CONST uentries d \<guillemotleft>f\<guillemotright>"
  "_UMapUpd m (_UMaplets xy ms)" == "_UMapUpd (_UMapUpd m xy) ms"
  "_UMapUpd m (_umaplet  x y)"   == "CONST trop CONST uupd m x y"
  "_UMap ms"                      == "_UMapUpd []\<^sub>u ms"
  "_UMap (_UMaplets ms1 ms2)"     <= "_UMapUpd (_UMap ms1) ms2"
  "_UMaplets ms1 (_UMaplets ms2 ms3)" <= "_UMaplets (_UMaplets ms1 ms2) ms3"

subsection \<open> Simplifications \<close>

lemma ufun_apply_lit [simp]:
  "\<guillemotleft>f\<guillemotright>(\<guillemotleft>x\<guillemotright>)\<^sub>a = \<guillemotleft>f(x)\<guillemotright>"
  by (transfer, simp)

lemma lit_plus_appl [lit_norm]: "\<guillemotleft>(+)\<guillemotright>(x)\<^sub>a(y)\<^sub>a = x + y" by (simp add: uexpr_defs, transfer, simp)
lemma lit_minus_appl [lit_norm]: "\<guillemotleft>(-)\<guillemotright>(x)\<^sub>a(y)\<^sub>a = x - y" by (simp add: uexpr_defs, transfer, simp)
lemma lit_mult_appl [lit_norm]: "\<guillemotleft>times\<guillemotright>(x)\<^sub>a(y)\<^sub>a = x * y" by (simp add: uexpr_defs, transfer, simp)
lemma lit_divide_apply [lit_norm]: "\<guillemotleft>(/)\<guillemotright>(x)\<^sub>a(y)\<^sub>a = x / y" by (simp add: uexpr_defs, transfer, simp)

(*
lemma pfun_entries_apply [simp]:
  "(entr\<^sub>u(d,P,f) :: (('k, 'v) pfun, '\<alpha>) uexpr)(i)\<^sub>a = ((\<guillemotleft>f\<guillemotright>(i)\<^sub>a) \<triangleleft> i \<in>\<^sub>u d \<and> P(i)\<^sub>a \<triangleright> \<bottom>\<^sub>u)"
  by (pred_auto)
*)

lemma udom_uupdate_pfun [simp]:
  fixes m :: "(('k, 'v) pfun, '\<alpha>) uexpr"
  shows "dom\<^sub>u(m(k \<mapsto> v)\<^sub>u) = {k}\<^sub>u \<union>\<^sub>u dom\<^sub>u(m)"
  by (rel_auto)

lemma uapply_uupdate_pfun [simp]:
  fixes m :: "(('k, 'v) pfun, '\<alpha>) uexpr"
  shows "(m(k \<mapsto> v)\<^sub>u)(i)\<^sub>a = v \<triangleleft> i =\<^sub>u k \<triangleright> m(i)\<^sub>a"
  by (rel_auto)

subsection \<open> Indexed Assignment \<close>

syntax
  \<comment> \<open> Indexed assignment \<close>
  "_assignment_upd" :: "svid \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(_[_] :=/ _)" [63, 0, 0] 62)

translations
  \<comment> \<open> Indexed assignment uses the overloaded collection update function \emph{uupd}. \<close>
  "_assignment_upd x k v" => "x := &x(k \<mapsto> v)\<^sub>u"

end


section{* Example Verifications with KAD *}

theory VC_KAD_Examples
imports VC_KAD GCD Binomial "$ISABELLE_HOME/src/HOL/Eisbach/Eisbach"

begin

lemma [simp]: "p2r P; p2r Q = p2r (P \<sqinter> Q)"
  by (simp add: p2r_conj_hom_var)

lemma [intro!]:  "P \<le> Q \<Longrightarrow> \<lceil>P\<rceil> \<subseteq> \<lceil>Q\<rceil>"
  by (auto simp: p2r_def)

lemma [simp]: "rdom \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (simp add: d_p2r)

lemma euclid:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  by (rule rel_antidomain_kleene_algebra.fbox_whilei) (auto simp: gcd_non_0_nat)

lemma euclid_diff:
   "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y \<and> x > 0 \<and> y > 0)
    (WHILE (\<lambda>s. s ''x''\<noteq> s ''y'') INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
     DO
        (IF (\<lambda>s. s ''x'' >  s ''y'')
         THEN (''x'' ::= (\<lambda>s. s ''x'' - s ''y''))
         ELSE (''y'' ::= (\<lambda>s. s ''y'' - s ''x''))
         FI)
    OD)
    POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule rel_antidomain_kleene_algebra.fbox_whilei, simp_all)
  apply (simp_all add: p2r_def rel_ad_def)
  apply auto[2]
  by (safe, metis gcd_commute_nat gcd_diff1_nat le_cases nat_less_le)

lemma varible_swap:
  "PRE (\<lambda>s. s ''x'' = a \<and> s ''y'' = b)
    (''z'' ::= (\<lambda>s. s ''x''));
    (''x'' ::= (\<lambda>s. s ''y''));
    (''y'' ::= (\<lambda>s. s ''z''))
   POST (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  by (simp, clarsimp simp: p2r_def)

lemma maximum:
  "PRE (\<lambda>s:: nat store. True)
   (IF (\<lambda>s. s ''x'' \<ge> s ''y'')
    THEN (''z'' ::= (\<lambda>s. s ''x''))
    ELSE (''z'' ::= (\<lambda>s. s ''y''))
    FI)
   POST (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))"
  by (simp, simp add: p2r_def rel_ad_def, fastforce)

lemma integer_division:
  "PRE (\<lambda>s::nat store. x \<ge> 0)
    (''q'' ::= (\<lambda>s. 0));
    (''r'' ::= (\<lambda>s. x));
    (WHILE (\<lambda>s. y \<le> s ''r'') INV (\<lambda>s. x = s ''q'' * y + s ''r'' \<and> s ''r'' \<ge> 0)
     DO
      (''q'' ::= (\<lambda>s. s ''q'' + 1));
      (''r'' ::= (\<lambda>s. s ''r'' - y))
      OD)
   POST (\<lambda>s. x = s ''q'' * y + s ''r'' \<and> s ''r'' \<ge> 0 \<and> s ''r'' < y)"
  by (rule rel_antidomain_kleene_algebra.fbox_whilei_break, simp_all, auto simp: p2r_def)

lemma factorial:
  "PRE (\<lambda>s::nat store. True)
   (''x'' ::= (\<lambda>s. 0));
   (''y'' ::= (\<lambda>s. 1));
   (WHILE (\<lambda>s. s ''x'' \<noteq> x0) INV (\<lambda>s. s ''y'' = fact (s ''x''))
   DO
     (''x'' ::= (\<lambda>s. s ''x'' + 1));
     (''y'' ::= (\<lambda>s. s ''y'' \<cdot> s ''x''))
   OD)
   POST (\<lambda>s. s ''y'' = fact x0)"
  by (rule rel_antidomain_kleene_algebra.fbox_whilei_break, simp_all, auto simp: p2r_def)

lemma my_power:
  "PRE (\<lambda>s::nat store. True)
   (''i'' ::= (\<lambda>s. 0));
   (''y'' ::= (\<lambda>s. 1));
   (WHILE (\<lambda>s. s ''i'' < n) INV (\<lambda>s. s ''y'' = x ^ (s ''i'') \<and> s ''i'' \<le> n)
     DO
       (''y'' ::= (\<lambda>s. (s ''y'') * x));
       (''i'' ::= (\<lambda>s. s ''i'' + 1))
     OD)
   POST (\<lambda>s. s ''y'' = x ^ n)"
  by (rule rel_antidomain_kleene_algebra.fbox_whilei_break, simp_all, auto simp add: p2r_def)

lemma imp_reverse:
  "PRE (\<lambda>s:: 'a list store. s ''x'' = X)
   (''y'' ::= (\<lambda>s. []));
   (WHILE (\<lambda>s. s ''x'' \<noteq> []) INV (\<lambda>s. rev (s ''x'') @ s ''y'' = rev X)
    DO
     (''y'' ::= (\<lambda>s. hd (s ''x'') # s ''y''));
     (''x'' ::= (\<lambda>s. tl (s ''x'')))
    OD)
   POST (\<lambda>s. s ''y''= rev X )"
  apply (rule rel_antidomain_kleene_algebra.fbox_whilei_break, simp_all, simp_all add: p2r_def)
  apply auto[1]
  by (safe, metis append.simps append_assoc hd_Cons_tl rev.simps(2))

(* using a tactic *)

named_theorems ht

declare rel_antidomain_kleene_algebra.fbox_whilei [ht]
  rel_antidomain_kleene_algebra.fbox_seq_var [ht]
  subset_refl[ht]

method hoare = (rule ht; hoare?)

lemma euclid2:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
apply hoare
using gcd_red_nat by auto

lemma euclid_diff2:
   "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y \<and> x > 0 \<and> y > 0)
    (WHILE (\<lambda>s. s ''x''\<noteq> s ''y'') INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
     DO
        (IF (\<lambda>s. s ''x'' >  s ''y'')
         THEN (''x'' ::= (\<lambda>s. s ''x'' - s ''y''))
         ELSE (''y'' ::= (\<lambda>s. s ''y'' - s ''x''))
         FI)
    OD)
    POST (\<lambda>s. s ''x'' = gcd x y)"
  apply hoare
  apply auto
  apply (metis gcd_commute_nat gcd_diff1_nat le_cases nat_less_le)+
done

lemma varible_swap2:
  "PRE (\<lambda>s. s ''x'' = a \<and> s ''y'' = b)
    (''z'' ::= (\<lambda>s. s ''x''));
    (''x'' ::= (\<lambda>s. s ''y''));
    (''y'' ::= (\<lambda>s. s ''z''))
   POST (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  by clarsimp

lemma maximum2:
  "PRE (\<lambda>s:: nat store. True)
   (IF (\<lambda>s. s ''x'' \<ge> s ''y'')
    THEN (''z'' ::= (\<lambda>s. s ''x''))
    ELSE (''z'' ::= (\<lambda>s. s ''y''))
    FI)
   POST (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))"
   by auto

lemma my_power2:
  "PRE (\<lambda>s::nat store. True)
   (''i'' ::= (\<lambda>s. 0));
   (''y'' ::= (\<lambda>s. 1));
   (WHILE (\<lambda>s. s ''i'' < n) INV (\<lambda>s. s ''y'' = x ^ (s ''i'') \<and> s ''i'' \<le> n)
     DO
       (''y'' ::= (\<lambda>s. (s ''y'') * x));
       (''i'' ::= (\<lambda>s. s ''i'' + 1))
     OD)
   POST (\<lambda>s. s ''y'' = x ^ n)"
  by hoare auto

lemma imp_reverse2:
  "PRE (\<lambda>s:: 'a list store. s ''x'' = X)
   (''y'' ::= (\<lambda>s. []));
   (WHILE (\<lambda>s. s ''x'' \<noteq> []) INV (\<lambda>s. rev (s ''x'') @ s ''y'' = rev X)
    DO
     (''y'' ::= (\<lambda>s. hd (s ''x'') # s ''y''));
     (''x'' ::= (\<lambda>s. tl (s ''x'')))
    OD)
   POST (\<lambda>s. s ''y''= rev X )"
  apply hoare
  apply auto
  apply (metis append.simps append_assoc hd_Cons_tl rev.simps(2))
done

end


theory PreferenceLogicTests2                (*Benzmüller & Fuenmayor, 2020*)
   imports PreferenceLogicCeterisParibus
begin (*** Tests for the SSE of van Benthem, Girard and Roy, JPL 2009 ***)
(**** Section 5: Equality-based Ceteris Paribus Preference Logic ****)
(*Some tests: dualities*)
lemma "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>) \<^bold>\<leftrightarrow> \<^bold>\<not>([\<Gamma>]\<^sup>\<preceq>\<^bold>\<not>\<phi>)\<rfloor>"  by auto
lemma "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi>) \<^bold>\<leftrightarrow> \<^bold>\<not>([\<Gamma>]\<^sup>\<prec>\<^bold>\<not>\<phi>)\<rfloor>"  by auto
lemma "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi>)  \<^bold>\<leftrightarrow> \<^bold>\<not>([\<Gamma>]\<^bold>\<not>\<phi>)\<rfloor>"    by auto
(*Lemma 2*)
lemma lemma2_1: "(\<^bold>\<diamond>\<^sup>\<preceq>\<phi>) w \<longleftrightarrow> (\<^bold>\<langle>\<^bold>\<emptyset>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>) w" by auto
lemma lemma2_2: "(\<^bold>\<diamond>\<^sup>\<prec>\<phi>) w \<longleftrightarrow> (\<^bold>\<langle>\<^bold>\<emptyset>\<^bold>\<rangle>\<^sup>\<prec>\<phi>) w" by auto
lemma lemma2_3: "((\<^bold>E\<phi>) w \<longleftrightarrow> (\<^bold>\<langle>\<^bold>\<emptyset>\<^bold>\<rangle>\<phi>) w) \<and> ((\<^bold>A\<phi>) w \<longleftrightarrow> ([\<^bold>\<emptyset>]\<phi>) w)" by auto
(**Axiomatization:**)
(*inclusion and interaction axioms *)
lemma Inc1: "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)\<rfloor>" by auto
lemma Inc2: "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi>)\<rfloor>"  by auto
lemma Int3: "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)) \<^bold>\<rightarrow>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)\<rfloor>"  by (meson tBR)
lemma Int4: "\<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)) \<^bold>\<rightarrow>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi>)\<rfloor>"  by (metis tBR)
lemma Int5: "\<lfloor>(\<psi>\<^bold>\<and>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)) \<^bold>\<rightarrow> ((\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi>)\<^bold>\<or>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>(\<phi>\<^bold>\<and>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>))))\<rfloor>" by (metis rBR)
(*ceteris paribus reflexivity*)
lemma CetPar6: "\<phi> \<^bold>\<in> \<Gamma> \<longrightarrow> \<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi>) \<^bold>\<rightarrow> \<phi>\<rfloor>"    by blast
lemma CetPar7: "\<phi> \<^bold>\<in> \<Gamma> \<longrightarrow> \<lfloor>(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^bold>\<not>\<phi>) \<^bold>\<rightarrow> \<^bold>\<not>\<phi>\<rfloor>" by blast
(*monotonicity*)
lemma CetPar8:  "\<Gamma> \<^bold>\<subseteq> \<Gamma>' \<longrightarrow> \<lfloor>(\<^bold>\<langle>\<Gamma>'\<^bold>\<rangle>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi>)\<rfloor>"   by auto
lemma CetPar9:  "\<Gamma> \<^bold>\<subseteq> \<Gamma>' \<longrightarrow> \<lfloor>(\<^bold>\<langle>\<Gamma>'\<^bold>\<rangle>\<^sup>\<preceq>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>)\<rfloor>" by auto
lemma CetPar10: "\<Gamma> \<^bold>\<subseteq> \<Gamma>' \<longrightarrow> \<lfloor>(\<^bold>\<langle>\<Gamma>'\<^bold>\<rangle>\<^sup>\<prec>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi>)\<rfloor>" by auto
(*increase (decrease) of ceteris paribus sets*)
lemma CetPar11a: "\<lfloor>(\<phi> \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>(\<alpha> \<^bold>\<and> \<phi>) )) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<alpha>)\<rfloor>"       by auto
lemma CetPar11b: "\<lfloor>((\<^bold>\<not>\<phi>) \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>(\<alpha> \<^bold>\<and> \<^bold>\<not>\<phi>))) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<alpha>)\<rfloor>"   by auto
lemma CetPar12a: "\<lfloor>(\<phi> \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>(\<alpha> \<^bold>\<and> \<phi>) )) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<^sup>\<preceq>\<alpha>)\<rfloor>"     by auto
lemma CetPar12b: "\<lfloor>((\<^bold>\<not>\<phi>) \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>(\<alpha> \<^bold>\<and> \<^bold>\<not>\<phi>))) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<^sup>\<preceq>\<alpha>)\<rfloor>" by auto
lemma CetPar13a: "\<lfloor>(\<phi> \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>(\<alpha> \<^bold>\<and> \<phi>) )) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<^sup>\<prec>\<alpha>)\<rfloor>"     by auto
lemma CetPar13b: "\<lfloor>((\<^bold>\<not>\<phi>) \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>(\<alpha> \<^bold>\<and> \<^bold>\<not>\<phi>))) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<^sup>\<prec>\<alpha>)\<rfloor>" by auto
(*Example 1, Lemma 4, Corollary 1 and Lemma5*)
lemma Ex1:    "\<lfloor>(([\<Gamma>]\<^sup>\<preceq>\<phi>) \<^bold>\<and> (\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<alpha>)) \<^bold>\<rightarrow> (\<^bold>\<langle>\<Gamma>\<^bold>\<union>\<^bold>{\<phi>\<^bold>}\<^bold>\<rangle>\<^sup>\<preceq>\<alpha>)\<rfloor>" using rBR by auto
lemma Lemma4: "(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi>) w \<longrightarrow> (\<exists>v. (w \<^bold>\<unlhd>\<^sub>\<Gamma> v) \<and> (\<phi> v))"  by simp
lemma Cor1:   "(\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi>)  w \<longrightarrow> (\<exists>v. (w \<^bold>\<equiv>\<^sub>\<Gamma> v) \<and> (\<phi> v))"  by simp
lemma Lemma5: "(w \<^bold>\<unlhd>\<^sub>\<Gamma> v) \<longleftrightarrow> ((w \<preceq> v) \<and> (w \<^bold>\<equiv>\<^sub>\<Gamma> v))"    by auto
(**** Section 6: Ceteris Paribus Counterparts ****)
(*AA-variant (drawing upon von Wright's)*)
lemma lAA_cp_pr:     "(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u" nitpick oops (*Ctm*)
lemma lAA_cp_pr_lr:  "(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u" nitpick oops (*Ctm*)
lemma lAA_cp_pr_rl:  "(\<phi> \<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longrightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u" by auto
lemma lAA_cp_pr:  "is_total SBR \<longrightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u"  by smt
lemma lqAA_cp_pr:    "(\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u  \<longleftrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u" nitpick oops (*Ctm*)
lemma lqAA_cp_pr_lr: "(\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u"  nitpick oops (*Ctm*)
lemma lqAA_cp_pr_rl: "(\<phi> \<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longrightarrow> (\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u"  by auto
lemma lqAA_cp_pr: "is_total SBR \<longrightarrow> (\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<longleftrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u"  by smt
(*AE-variant*)
lemma leAE_cp_pref: "(\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u \<longleftrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u" by auto
lemma leqAE_cp_pref: "(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u" by auto
(*miscelaneous tests*)
lemma "let \<Gamma> = \<^bold>\<emptyset> in \<lfloor>(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A \<psi>)\<rfloor>"    by simp
lemma "let \<Gamma> = \<^bold>{\<^bold>\<bottom>\<^bold>} in \<lfloor>(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A \<psi>)\<rfloor>" by simp
lemma "let \<Gamma> = \<^bold>{\<^bold>\<bottom>,A\<^bold>} in \<lfloor>(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A \<psi>)\<rfloor>"     nitpick oops (*Ctm*)
lemma "let \<Gamma> = \<^bold>{A\<^bold>} in \<lfloor>(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A \<psi>))\<rfloor>" nitpick oops (*Ctm*)
lemma "let \<Gamma> = \<^bold>{A\<^bold>} in \<lfloor>(A \<^bold>\<rightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A \<psi>)) \<^bold>\<rightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>)\<rfloor>" nitpick oops (*Ctm*)
lemma "let \<Gamma> = \<^bold>\<emptyset> in \<lfloor>(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E \<psi>)\<rfloor>"    by simp
lemma "let \<Gamma> = \<^bold>{\<^bold>\<bottom>\<^bold>} in \<lfloor>(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E \<psi>)\<rfloor>" by simp
lemma "let \<Gamma> = \<^bold>{\<^bold>\<bottom>,A\<^bold>} in \<lfloor>(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E \<psi>)\<rfloor>"     nitpick oops (*Ctm*)
lemma "let \<Gamma> = \<^bold>{A\<^bold>} in \<lfloor>(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E \<psi>))\<rfloor>"         by auto
lemma "let \<Gamma> = \<^bold>{A,B\<^bold>} in \<lfloor>(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) \<^bold>\<rightarrow> ((A \<^bold>\<and> B) \<^bold>\<rightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E \<psi>))\<rfloor>" by auto
lemma "let \<Gamma> = \<^bold>{A\<^bold>} in \<lfloor>(A \<^bold>\<rightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E \<psi>)) \<^bold>\<rightarrow> (\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>)\<rfloor>" nitpick oops (*Ctm*)
end