(* Author: Florian Haftmann, TU Muenchen *)

section \<open>A simple cookbook example how to eliminate choice in programs.\<close>

theory Execute_Choice
imports Main "HOL-Library.AList_Mapping"
begin

text \<open>
  A trivial example:
\<close>

definition valuesum :: "('a, 'b :: ab_group_add) mapping \<Rightarrow> 'b" where
  "valuesum m = (\<Sum>k \<in> Mapping.keys m. the (Mapping.lookup m k))"

text \<open>
  Not that instead of defining \<^term>\<open>valuesum\<close> with choice, we define it
  directly and derive a description involving choice afterwards:
\<close>

lemma valuesum_rec:
  assumes fin: "finite (dom (Mapping.lookup m))"
  shows "valuesum m = (if Mapping.is_empty m then 0 else
    let l = (SOME l. l \<in> Mapping.keys m) in the (Mapping.lookup m l) + valuesum (Mapping.delete l m))"
proof (cases "Mapping.is_empty m")
  case True then show ?thesis by (simp add: is_empty_def keys_def valuesum_def)
next
  case False
  then have l: "\<exists>l. l \<in> dom (Mapping.lookup m)" unfolding is_empty_def by transfer auto
  then have "(let l = SOME l. l \<in> dom (Mapping.lookup m) in
     the (Mapping.lookup m l) + (\<Sum>k \<in> dom (Mapping.lookup m) - {l}. the (Mapping.lookup m k))) =
       (\<Sum>k \<in> dom (Mapping.lookup m). the (Mapping.lookup m k))"
  proof (rule someI2_ex)
    fix l
    note fin
    moreover assume "l \<in> dom (Mapping.lookup m)"
    moreover obtain A where "A = dom (Mapping.lookup m) - {l}" by simp
    ultimately have "dom (Mapping.lookup m) = insert l A" and "finite A" and "l \<notin> A" by auto
    then show "(let l = l
        in the (Mapping.lookup m l) + (\<Sum>k \<in> dom (Mapping.lookup m) - {l}. the (Mapping.lookup m k))) =
        (\<Sum>k \<in> dom (Mapping.lookup m). the (Mapping.lookup m k))"
      by simp
   qed
  then show ?thesis unfolding is_empty_def valuesum_def by transfer simp
qed

text \<open>
  In the context of the else-branch we can show that the exact choice is
  irrelvant; in practice, finding this point where choice becomes irrelevant is the
  most difficult thing!
\<close>

lemma valuesum_choice:
  "finite (Mapping.keys M) \<Longrightarrow> x \<in> Mapping.keys M \<Longrightarrow> y \<in> Mapping.keys M \<Longrightarrow>
    the (Mapping.lookup M x) + valuesum (Mapping.delete x M) =
    the (Mapping.lookup M y) + valuesum (Mapping.delete y M)"
  unfolding valuesum_def  by transfer (simp add: sum_diff)

text \<open>
  Given \<open>valuesum_rec\<close> as initial description, we stepwise refine it to something executable;
  first, we formally insert the constructor \<^term>\<open>Mapping\<close> and split the one equation into two,
  where the second one provides the necessary context:
\<close>

lemma valuesum_rec_Mapping:
  shows [code]: "valuesum (Mapping []) = 0"
  and "valuesum (Mapping (x # xs)) = (let l = (SOME l. l \<in> Mapping.keys (Mapping (x # xs))) in
    the (Mapping.lookup (Mapping (x # xs)) l) + valuesum (Mapping.delete l (Mapping (x # xs))))"
  by (simp_all add: valuesum_rec finite_dom_map_of is_empty_Mapping null_def)

text \<open>
  As a side effect the precondition disappears (but note this has nothing to do with choice!).
  The first equation deals with the uncritical empty case and can already be used for code generation.

  Using \<open>valuesum_choice\<close>, we are able to prove an executable version of \<^term>\<open>valuesum\<close>:
\<close>

lemma valuesum_rec_exec [code]:
  "valuesum (Mapping (x # xs)) = (let l = fst (hd (x # xs)) in
    the (Mapping.lookup (Mapping (x # xs)) l) + valuesum (Mapping.delete l (Mapping (x # xs))))"
proof -
  let ?M = "Mapping (x # xs)"
  let ?l1 = "(SOME l. l \<in> Mapping.keys ?M)"
  let ?l2 = "fst (hd (x # xs))"
  have "finite (Mapping.keys ?M)" by (simp add: keys_Mapping)
  moreover have "?l1 \<in> Mapping.keys ?M"
    by (rule someI) (auto simp add: keys_Mapping)
  moreover have "?l2 \<in> Mapping.keys ?M"
    by (simp add: keys_Mapping)
  ultimately have "the (Mapping.lookup ?M ?l1) + valuesum (Mapping.delete ?l1 ?M) =
    the (Mapping.lookup ?M ?l2) + valuesum (Mapping.delete ?l2 ?M)"
    by (rule valuesum_choice)
  then show ?thesis by (simp add: valuesum_rec_Mapping)
qed

text \<open>
  See how it works:
\<close>

value "valuesum (Mapping [(''abc'', (42::int)), (''def'', 1705)])"

end


(*  Title:      ZF/UNITY/GenPrefix.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge

<xs,ys>:gen_prefix(r)
  if ys = xs' @ zs where length(xs) = length(xs')
  and corresponding elements of xs, xs' are pairwise related by r

Based on Lex/Prefix
*)

section{*Charpentier's Generalized Prefix Relation*}

theory GenPrefix
imports Main
begin

definition (*really belongs in ZF/Trancl*)
  part_order :: "[i, i] => o"  where
  "part_order(A, r) == refl(A,r) & trans[A](r) & antisym(r)"

consts
  gen_prefix :: "[i, i] => i"

inductive
  (* Parameter A is the domain of zs's elements *)

  domains "gen_prefix(A, r)" \<subseteq> "list(A)*list(A)"

  intros
    Nil:     "<[],[]>:gen_prefix(A, r)"

    prepend: "[| <xs,ys>:gen_prefix(A, r);  <x,y>:r; x \<in> A; y \<in> A |]
              ==> <Cons(x,xs), Cons(y,ys)>: gen_prefix(A, r)"

    append:  "[| <xs,ys>:gen_prefix(A, r); zs:list(A) |]
              ==> <xs, ys@zs>:gen_prefix(A, r)"
    type_intros app_type list.Nil list.Cons

definition
  prefix :: "i=>i"  where
  "prefix(A) == gen_prefix(A, id(A))"

definition
  strict_prefix :: "i=>i"  where
  "strict_prefix(A) == prefix(A) - id(list(A))"

(* less or equal and greater or equal over prefixes *)

abbreviation
  pfixLe :: "[i, i] => o"  (infixl "pfixLe" 50)  where
  "xs pfixLe ys == <xs, ys>:gen_prefix(nat, Le)"

abbreviation
  pfixGe :: "[i, i] => o"  (infixl "pfixGe" 50)  where
  "xs pfixGe ys == <xs, ys>:gen_prefix(nat, Ge)"

lemma reflD:
 "[| refl(A, r); x \<in> A |] ==> <x,x>:r"
apply (unfold refl_def, auto)
done

(*** preliminary lemmas ***)

lemma Nil_gen_prefix: "xs \<in> list(A) ==> <[], xs> \<in> gen_prefix(A, r)"
by (drule gen_prefix.append [OF gen_prefix.Nil], simp)
declare Nil_gen_prefix [simp]

lemma gen_prefix_length_le: "<xs,ys> \<in> gen_prefix(A, r) ==> length(xs) \<le> length(ys)"
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "ys \<in> list (A) ")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            intro: le_trans simp add: length_app)
done

lemma Cons_gen_prefix_aux:
  "[| <xs', ys'> \<in> gen_prefix(A, r) |]
   ==> (\<forall>x xs. x \<in> A \<longrightarrow> xs'= Cons(x,xs) \<longrightarrow>
       (\<exists>y ys. y \<in> A & ys' = Cons(y,ys) &
       <x,y>:r & <xs, ys> \<in> gen_prefix(A, r)))"
apply (erule gen_prefix.induct)
prefer 3 apply (force intro: gen_prefix.append, auto)
done

lemma Cons_gen_prefixE:
  "[| <Cons(x,xs), zs> \<in> gen_prefix(A, r);
    !!y ys. [|zs = Cons(y, ys); y \<in> A; x \<in> A; <x,y>:r;
      <xs,ys> \<in> gen_prefix(A, r) |] ==> P |] ==> P"
apply (frule gen_prefix.dom_subset [THEN subsetD], auto)
apply (blast dest: Cons_gen_prefix_aux)
done
declare Cons_gen_prefixE [elim!]

lemma Cons_gen_prefix_Cons:
"(<Cons(x,xs),Cons(y,ys)> \<in> gen_prefix(A, r))
  \<longleftrightarrow> (x \<in> A & y \<in> A & <x,y>:r & <xs,ys> \<in> gen_prefix(A, r))"
apply (auto intro: gen_prefix.prepend)
done
declare Cons_gen_prefix_Cons [iff]

(** Monotonicity of gen_prefix **)

lemma gen_prefix_mono2: "r<=s ==> gen_prefix(A, r) \<subseteq> gen_prefix(A, s)"
apply clarify
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (erule rev_mp)
apply (erule gen_prefix.induct)
apply (auto intro: gen_prefix.append)
done

lemma gen_prefix_mono1: "A<=B ==>gen_prefix(A, r) \<subseteq> gen_prefix(B, r)"
apply clarify
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (erule rev_mp)
apply (erule_tac P = "y \<in> list (A) " in rev_mp)
apply (erule_tac P = "xa \<in> list (A) " in rev_mp)
apply (erule gen_prefix.induct)
apply (simp (no_asm_simp))
apply clarify
apply (erule ConsE)+
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            intro: gen_prefix.append list_mono [THEN subsetD])
done

lemma gen_prefix_mono: "[| A \<subseteq> B; r \<subseteq> s |] ==> gen_prefix(A, r) \<subseteq> gen_prefix(B, s)"
apply (rule subset_trans)
apply (rule gen_prefix_mono1)
apply (rule_tac [2] gen_prefix_mono2, auto)
done

(*** gen_prefix order ***)

(* reflexivity *)
lemma refl_gen_prefix: "refl(A, r) ==> refl(list(A), gen_prefix(A, r))"
apply (unfold refl_def, auto)
apply (induct_tac "x", auto)
done
declare refl_gen_prefix [THEN reflD, simp]

(* Transitivity *)
(* A lemma for proving gen_prefix_trans_comp *)

lemma append_gen_prefix [rule_format (no_asm)]: "xs \<in> list(A) ==>
   \<forall>zs. <xs @ ys, zs> \<in> gen_prefix(A, r) \<longrightarrow> <xs, zs>: gen_prefix(A, r)"
apply (erule list.induct)
apply (auto dest: gen_prefix.dom_subset [THEN subsetD])
done

(* Lemma proving transitivity and more*)

lemma gen_prefix_trans_comp [rule_format (no_asm)]:
     "<x, y>: gen_prefix(A, r) ==>
   (\<forall>z \<in> list(A). <y,z> \<in> gen_prefix(A, s)\<longrightarrow><x, z> \<in> gen_prefix(A, s O r))"
apply (erule gen_prefix.induct)
apply (auto elim: ConsE simp add: Nil_gen_prefix)
apply (subgoal_tac "ys \<in> list (A) ")
prefer 2 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac xs = ys and r = s in append_gen_prefix, auto)
done

lemma trans_comp_subset: "trans(r) ==> r O r \<subseteq> r"
by (auto dest: transD)

lemma trans_gen_prefix: "trans(r) ==> trans(gen_prefix(A,r))"
apply (simp (no_asm) add: trans_def)
apply clarify
apply (rule trans_comp_subset [THEN gen_prefix_mono2, THEN subsetD], assumption)
apply (rule gen_prefix_trans_comp)
apply (auto dest: gen_prefix.dom_subset [THEN subsetD])
done

lemma trans_on_gen_prefix:
 "trans(r) ==> trans[list(A)](gen_prefix(A, r))"
apply (drule_tac A = A in trans_gen_prefix)
apply (unfold trans_def trans_on_def, blast)
done

lemma prefix_gen_prefix_trans:
    "[| <x,y> \<in> prefix(A); <y, z> \<in> gen_prefix(A, r); r<=A*A |]
      ==>  <x, z> \<in> gen_prefix(A, r)"
apply (unfold prefix_def)
apply (rule_tac P = "%r. <x,z> \<in> gen_prefix (A, r) " in right_comp_id [THEN subst])
apply (blast dest: gen_prefix_trans_comp gen_prefix.dom_subset [THEN subsetD])+
done

lemma gen_prefix_prefix_trans:
"[| <x,y> \<in> gen_prefix(A,r); <y, z> \<in> prefix(A); r<=A*A |]
  ==>  <x, z> \<in> gen_prefix(A, r)"
apply (unfold prefix_def)
apply (rule_tac P = "%r. <x,z> \<in> gen_prefix (A, r) " in left_comp_id [THEN subst])
apply (blast dest: gen_prefix_trans_comp gen_prefix.dom_subset [THEN subsetD])+
done

(** Antisymmetry **)

lemma nat_le_lemma [rule_format]: "n \<in> nat ==> \<forall>b \<in> nat. n #+ b \<le> n \<longrightarrow> b = 0"
by (induct_tac "n", auto)

lemma antisym_gen_prefix: "antisym(r) ==> antisym(gen_prefix(A, r))"
apply (simp (no_asm) add: antisym_def)
apply (rule impI [THEN allI, THEN allI])
apply (erule gen_prefix.induct, blast)
apply (simp add: antisym_def, blast)
txt{*append case is hardest*}
apply clarify
apply (subgoal_tac "length (zs) = 0")
apply (subgoal_tac "ys \<in> list (A) ")
prefer 2 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac psi = "<ys @ zs, xs> \<in> gen_prefix (A,r) " in asm_rl)
apply simp
apply (subgoal_tac "length (ys @ zs) = length (ys) #+ length (zs) &ys \<in> list (A) &xs \<in> list (A) ")
prefer 2 apply (blast intro: length_app dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule gen_prefix_length_le)+
apply clarify
apply simp
apply (drule_tac j = "length (xs) " in le_trans)
apply blast
apply (auto intro: nat_le_lemma)
done

(*** recursion equations ***)

lemma gen_prefix_Nil: "xs \<in> list(A) ==> <xs, []> \<in> gen_prefix(A,r) \<longleftrightarrow> (xs = [])"
by (induct_tac "xs", auto)
declare gen_prefix_Nil [simp]

lemma same_gen_prefix_gen_prefix:
 "[| refl(A, r);  xs \<in> list(A) |] ==>
    <xs@ys, xs@zs>: gen_prefix(A, r) \<longleftrightarrow> <ys,zs> \<in> gen_prefix(A, r)"
apply (unfold refl_def)
apply (induct_tac "xs")
apply (simp_all (no_asm_simp))
done
declare same_gen_prefix_gen_prefix [simp]

lemma gen_prefix_Cons: "[| xs \<in> list(A); ys \<in> list(A); y \<in> A |] ==>
    <xs, Cons(y,ys)> \<in> gen_prefix(A,r)  \<longleftrightarrow>
      (xs=[] | (\<exists>z zs. xs=Cons(z,zs) & z \<in> A & <z,y>:r & <zs,ys> \<in> gen_prefix(A,r)))"
apply (induct_tac "xs", auto)
done

lemma gen_prefix_take_append: "[| refl(A,r);  <xs,ys> \<in> gen_prefix(A, r); zs \<in> list(A) |]
      ==>  <xs@zs, take(length(xs), ys) @ zs> \<in> gen_prefix(A, r)"
apply (erule gen_prefix.induct)
apply (simp (no_asm_simp))
apply (frule_tac [!] gen_prefix.dom_subset [THEN subsetD], auto)
apply (frule gen_prefix_length_le)
apply (subgoal_tac "take (length (xs), ys) \<in> list (A) ")
apply (simp_all (no_asm_simp) add: diff_is_0_iff [THEN iffD2] take_type)
done

lemma gen_prefix_append_both: "[| refl(A, r);  <xs,ys> \<in> gen_prefix(A,r);
         length(xs) = length(ys); zs \<in> list(A) |]
      ==>  <xs@zs, ys @ zs> \<in> gen_prefix(A, r)"
apply (drule_tac zs = zs in gen_prefix_take_append, assumption+)
apply (subgoal_tac "take (length (xs), ys) =ys")
apply (auto intro!: take_all dest: gen_prefix.dom_subset [THEN subsetD])
done

(*NOT suitable for rewriting since [y] has the form y#ys*)
lemma append_cons_conv: "xs \<in> list(A) ==> xs @ Cons(y, ys) = (xs @ [y]) @ ys"
by (auto simp add: app_assoc)

lemma append_one_gen_prefix_lemma [rule_format]:
     "[| <xs,ys> \<in> gen_prefix(A, r);  refl(A, r) |]
      ==> length(xs) < length(ys) \<longrightarrow>
          <xs @ [nth(length(xs), ys)], ys> \<in> gen_prefix(A, r)"
apply (erule gen_prefix.induct, blast)
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (simp_all add: length_type)
(* Append case is hardest *)
apply (frule gen_prefix_length_le [THEN le_iff [THEN iffD1]])
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (subgoal_tac "length (xs) :nat&length (ys) :nat &length (zs) :nat")
prefer 2 apply (blast intro: length_type, clarify)
apply (simp_all add: nth_append length_type length_app)
apply (rule conjI)
apply (blast intro: gen_prefix.append)
apply (erule_tac V = "length (xs) < length (ys) \<longrightarrow>?u" in thin_rl)
apply (erule_tac a = zs in list.cases, auto)
apply (rule_tac P1 = "%x. <?u (x), ?v>:?w" in nat_diff_split [THEN iffD2])
apply auto
apply (simplesubst append_cons_conv)
apply (rule_tac [2] gen_prefix.append)
apply (auto elim: ConsE simp add: gen_prefix_append_both)
done

lemma append_one_gen_prefix: "[| <xs,ys>: gen_prefix(A, r);  length(xs) < length(ys);  refl(A, r) |]
      ==> <xs @ [nth(length(xs), ys)], ys> \<in> gen_prefix(A, r)"
apply (blast intro: append_one_gen_prefix_lemma)
done

(** Proving the equivalence with Charpentier's definition **)

lemma gen_prefix_imp_nth_lemma [rule_format]: "xs \<in> list(A) ==>
  \<forall>ys \<in> list(A). \<forall>i \<in> nat. i < length(xs)
          \<longrightarrow> <xs, ys>: gen_prefix(A, r) \<longrightarrow> <nth(i, xs), nth(i, ys)>:r"
apply (induct_tac "xs", simp, clarify)
apply simp
apply (erule natE, auto)
done

lemma gen_prefix_imp_nth: "[| <xs,ys> \<in> gen_prefix(A,r); i < length(xs)|]
      ==> <nth(i, xs), nth(i, ys)>:r"
apply (cut_tac A = A in gen_prefix.dom_subset)
apply (rule gen_prefix_imp_nth_lemma)
apply (auto simp add: lt_nat_in_nat)
done

lemma nth_imp_gen_prefix [rule_format]: "xs \<in> list(A) ==>
  \<forall>ys \<in> list(A). length(xs) \<le> length(ys)
      \<longrightarrow> (\<forall>i. i < length(xs) \<longrightarrow> <nth(i, xs), nth(i,ys)>:r)
      \<longrightarrow> <xs, ys> \<in> gen_prefix(A, r)"
apply (induct_tac "xs")
apply (simp_all (no_asm_simp))
apply clarify
apply (erule_tac a = ys in list.cases, simp)
apply (force intro!: nat_0_le simp add: lt_nat_in_nat)
done

lemma gen_prefix_iff_nth: "(<xs,ys> \<in> gen_prefix(A,r)) \<longleftrightarrow>
      (xs \<in> list(A) & ys \<in> list(A) & length(xs) \<le> length(ys) &
      (\<forall>i. i < length(xs) \<longrightarrow> <nth(i,xs), nth(i, ys)>: r))"
apply (rule iffI)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (frule gen_prefix_length_le, auto)
apply (rule_tac [2] nth_imp_gen_prefix)
apply (drule gen_prefix_imp_nth)
apply (auto simp add: lt_nat_in_nat)
done

(** prefix is a partial order: **)

lemma refl_prefix: "refl(list(A), prefix(A))"
apply (unfold prefix_def)
apply (rule refl_gen_prefix)
apply (auto simp add: refl_def)
done
declare refl_prefix [THEN reflD, simp]

lemma trans_prefix: "trans(prefix(A))"
apply (unfold prefix_def)
apply (rule trans_gen_prefix)
apply (auto simp add: trans_def)
done

lemmas prefix_trans = trans_prefix [THEN transD]

lemma trans_on_prefix: "trans[list(A)](prefix(A))"
apply (unfold prefix_def)
apply (rule trans_on_gen_prefix)
apply (auto simp add: trans_def)
done

lemmas prefix_trans_on = trans_on_prefix [THEN trans_onD]

(* Monotonicity of "set" operator WRT prefix *)

lemma set_of_list_prefix_mono:
"<xs,ys> \<in> prefix(A) ==> set_of_list(xs) \<subseteq> set_of_list(ys)"

apply (unfold prefix_def)
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "xs \<in> list (A) &ys \<in> list (A) ")
prefer 4 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (auto simp add: set_of_list_append)
done

(** recursion equations **)

lemma Nil_prefix: "xs \<in> list(A) ==> <[],xs> \<in> prefix(A)"

apply (unfold prefix_def)
apply (simp (no_asm_simp) add: Nil_gen_prefix)
done
declare Nil_prefix [simp]

lemma prefix_Nil: "<xs, []> \<in> prefix(A) \<longleftrightarrow> (xs = [])"

apply (unfold prefix_def, auto)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac psi = "<xs, []> \<in> gen_prefix (A, id (A))" in asm_rl)
apply (simp add: gen_prefix_Nil)
done
declare prefix_Nil [iff]

lemma Cons_prefix_Cons:
"<Cons(x,xs), Cons(y,ys)> \<in> prefix(A) \<longleftrightarrow> (x=y & <xs,ys> \<in> prefix(A) & y \<in> A)"
apply (unfold prefix_def, auto)
done
declare Cons_prefix_Cons [iff]

lemma same_prefix_prefix:
"xs \<in> list(A)==> <xs@ys,xs@zs> \<in> prefix(A) \<longleftrightarrow> (<ys,zs> \<in> prefix(A))"
apply (unfold prefix_def)
apply (subgoal_tac "refl (A,id (A))")
apply (simp (no_asm_simp))
apply (auto simp add: refl_def)
done
declare same_prefix_prefix [simp]

lemma same_prefix_prefix_Nil: "xs \<in> list(A) ==> <xs@ys,xs> \<in> prefix(A) \<longleftrightarrow> (<ys,[]> \<in> prefix(A))"
apply (rule_tac P = "%x. <?u, x>:?v \<longleftrightarrow> ?w (x) " in app_right_Nil [THEN subst])
apply (rule_tac [2] same_prefix_prefix, auto)
done
declare same_prefix_prefix_Nil [simp]

lemma prefix_appendI:
"[| <xs,ys> \<in> prefix(A); zs \<in> list(A) |] ==> <xs,ys@zs> \<in> prefix(A)"
apply (unfold prefix_def)
apply (erule gen_prefix.append, assumption)
done
declare prefix_appendI [simp]

lemma prefix_Cons:
"[| xs \<in> list(A); ys \<in> list(A); y \<in> A |] ==>
  <xs,Cons(y,ys)> \<in> prefix(A) \<longleftrightarrow>
  (xs=[] | (\<exists>zs. xs=Cons(y,zs) & <zs,ys> \<in> prefix(A)))"
apply (unfold prefix_def)
apply (auto simp add: gen_prefix_Cons)
done

lemma append_one_prefix:
  "[| <xs,ys> \<in> prefix(A); length(xs) < length(ys) |]
  ==> <xs @ [nth(length(xs),ys)], ys> \<in> prefix(A)"
apply (unfold prefix_def)
apply (subgoal_tac "refl (A, id (A))")
apply (simp (no_asm_simp) add: append_one_gen_prefix)
apply (auto simp add: refl_def)
done

lemma prefix_length_le:
"<xs,ys> \<in> prefix(A) ==> length(xs) \<le> length(ys)"
apply (unfold prefix_def)
apply (blast dest: gen_prefix_length_le)
done

lemma prefix_type: "prefix(A)<=list(A)*list(A)"
apply (unfold prefix_def)
apply (blast intro!: gen_prefix.dom_subset)
done

lemma strict_prefix_type:
"strict_prefix(A) \<subseteq> list(A)*list(A)"
apply (unfold strict_prefix_def)
apply (blast intro!: prefix_type [THEN subsetD])
done

lemma strict_prefix_length_lt_aux:
     "<xs,ys> \<in> prefix(A) ==> xs\<noteq>ys \<longrightarrow> length(xs) < length(ys)"
apply (unfold prefix_def)
apply (erule gen_prefix.induct, clarify)
apply (subgoal_tac [!] "ys \<in> list(A) & xs \<in> list(A)")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            simp add: length_type)
apply (subgoal_tac "length (zs) =0")
apply (drule_tac [2] not_lt_imp_le)
apply (rule_tac [5] j = "length (ys) " in lt_trans2)
apply auto
done

lemma strict_prefix_length_lt:
     "<xs,ys>:strict_prefix(A) ==> length(xs) < length(ys)"
apply (unfold strict_prefix_def)
apply (rule strict_prefix_length_lt_aux [THEN mp])
apply (auto dest: prefix_type [THEN subsetD])
done

(*Equivalence to the definition used in Lex/Prefix.thy*)
lemma prefix_iff:
    "<xs,zs> \<in> prefix(A) \<longleftrightarrow> (\<exists>ys \<in> list(A). zs = xs@ys) & xs \<in> list(A)"
apply (unfold prefix_def)
apply (auto simp add: gen_prefix_iff_nth lt_nat_in_nat nth_append nth_type app_type length_app)
apply (subgoal_tac "drop (length (xs), zs) \<in> list (A) ")
apply (rule_tac x = "drop (length (xs), zs) " in bexI)
apply safe
 prefer 2 apply (simp add: length_type drop_type)
apply (rule nth_equalityI)
apply (simp_all (no_asm_simp) add: nth_append app_type drop_type length_app length_drop)
apply (rule nat_diff_split [THEN iffD2], simp_all, clarify)
apply (drule_tac i = "length (zs) " in leI)
apply (force simp add: le_subset_iff, safe)
apply (subgoal_tac "length (xs) #+ (i #- length (xs)) = i")
apply (subst nth_drop)
apply (simp_all (no_asm_simp) add: leI split add: nat_diff_split)
done

lemma prefix_snoc:
"[|xs \<in> list(A); ys \<in> list(A); y \<in> A |] ==>
   <xs, ys@[y]> \<in> prefix(A) \<longleftrightarrow> (xs = ys@[y] | <xs,ys> \<in> prefix(A))"
apply (simp (no_asm) add: prefix_iff)
apply (rule iffI, clarify)
apply (erule_tac xs = ysa in rev_list_elim, simp)
apply (simp add: app_type app_assoc [symmetric])
apply (auto simp add: app_assoc app_type)
done
declare prefix_snoc [simp]

lemma prefix_append_iff [rule_format]: "zs \<in> list(A) ==> \<forall>xs \<in> list(A). \<forall>ys \<in> list(A).
   (<xs, ys@zs> \<in> prefix(A)) \<longleftrightarrow>
  (<xs,ys> \<in> prefix(A) | (\<exists>us. xs = ys@us & <us,zs> \<in> prefix(A)))"
apply (erule list_append_induct, force, clarify)
apply (rule iffI)
apply (simp add: add: app_assoc [symmetric])
apply (erule disjE)
apply (rule disjI2)
apply (rule_tac x = "y @ [x]" in exI)
apply (simp add: add: app_assoc [symmetric], force+)
done

(*Although the prefix ordering is not linear, the prefixes of a list
  are linearly ordered.*)
lemma common_prefix_linear_lemma [rule_format]: "[| zs \<in> list(A); xs \<in> list(A); ys \<in> list(A) |]
   ==> <xs, zs> \<in> prefix(A) \<longrightarrow> <ys,zs> \<in> prefix(A)
  \<longrightarrow><xs,ys> \<in> prefix(A) | <ys,xs> \<in> prefix(A)"
apply (erule list_append_induct, auto)
done

lemma common_prefix_linear: "[|<xs, zs> \<in> prefix(A); <ys,zs> \<in> prefix(A) |]
      ==> <xs,ys> \<in> prefix(A) | <ys,xs> \<in> prefix(A)"
apply (cut_tac prefix_type)
apply (blast del: disjCI intro: common_prefix_linear_lemma)
done

(*** pfixLe, pfixGe \<in> properties inherited from the translations ***)

(** pfixLe **)

lemma refl_Le: "refl(nat,Le)"

apply (unfold refl_def, auto)
done
declare refl_Le [simp]

lemma antisym_Le: "antisym(Le)"
apply (unfold antisym_def)
apply (auto intro: le_anti_sym)
done
declare antisym_Le [simp]

lemma trans_on_Le: "trans[nat](Le)"
apply (unfold trans_on_def, auto)
apply (blast intro: le_trans)
done
declare trans_on_Le [simp]

lemma trans_Le: "trans(Le)"
apply (unfold trans_def, auto)
apply (blast intro: le_trans)
done
declare trans_Le [simp]

lemma part_order_Le: "part_order(nat,Le)"
by (unfold part_order_def, auto)
declare part_order_Le [simp]

lemma pfixLe_refl: "x \<in> list(nat) ==> x pfixLe x"
by (blast intro: refl_gen_prefix [THEN reflD] refl_Le)
declare pfixLe_refl [simp]

lemma pfixLe_trans: "[| x pfixLe y; y pfixLe z |] ==> x pfixLe z"
by (blast intro: trans_gen_prefix [THEN transD] trans_Le)

lemma pfixLe_antisym: "[| x pfixLe y; y pfixLe x |] ==> x = y"
by (blast intro: antisym_gen_prefix [THEN antisymE] antisym_Le)

lemma prefix_imp_pfixLe:
"<xs,ys>:prefix(nat)==> xs pfixLe ys"

apply (unfold prefix_def)
apply (rule gen_prefix_mono [THEN subsetD], auto)
done

lemma refl_Ge: "refl(nat, Ge)"
by (unfold refl_def Ge_def, auto)
declare refl_Ge [iff]

lemma antisym_Ge: "antisym(Ge)"
apply (unfold antisym_def Ge_def)
apply (auto intro: le_anti_sym)
done
declare antisym_Ge [iff]

lemma trans_Ge: "trans(Ge)"
apply (unfold trans_def Ge_def)
apply (auto intro: le_trans)
done
declare trans_Ge [iff]

lemma pfixGe_refl: "x \<in> list(nat) ==> x pfixGe x"
by (blast intro: refl_gen_prefix [THEN reflD])
declare pfixGe_refl [simp]

lemma pfixGe_trans: "[| x pfixGe y; y pfixGe z |] ==> x pfixGe z"
by (blast intro: trans_gen_prefix [THEN transD])

lemma pfixGe_antisym: "[| x pfixGe y; y pfixGe x |] ==> x = y"
by (blast intro: antisym_gen_prefix [THEN antisymE])

lemma prefix_imp_pfixGe:
  "<xs,ys>:prefix(nat) ==> xs pfixGe ys"
apply (unfold prefix_def Ge_def)
apply (rule gen_prefix_mono [THEN subsetD], auto)
done
(* Added by Sidi \<in> prefix and take *)

lemma prefix_imp_take:
"<xs, ys> \<in> prefix(A) ==> xs = take(length(xs), ys)"

apply (unfold prefix_def)
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "length (xs) :nat")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD] simp add: length_type)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (frule gen_prefix_length_le)
apply (auto simp add: take_append)
apply (subgoal_tac "length (xs) #- length (ys) =0")
apply (simp_all (no_asm_simp) add: diff_is_0_iff)
done

lemma prefix_length_equal: "[|<xs,ys> \<in> prefix(A); length(xs)=length(ys)|] ==> xs = ys"
apply (cut_tac A = A in prefix_type)
apply (drule subsetD, auto)
apply (drule prefix_imp_take)
apply (erule trans, simp)
done

lemma prefix_length_le_equal: "[|<xs,ys> \<in> prefix(A); length(ys) \<le> length(xs)|] ==> xs = ys"
by (blast intro: prefix_length_equal le_anti_sym prefix_length_le)

lemma take_prefix [rule_format]: "xs \<in> list(A) ==> \<forall>n \<in> nat. <take(n, xs), xs> \<in> prefix(A)"
apply (unfold prefix_def)
apply (erule list.induct, simp, clarify)
apply (erule natE, auto)
done

lemma prefix_take_iff: "<xs,ys> \<in> prefix(A) \<longleftrightarrow> (xs=take(length(xs), ys) & xs \<in> list(A) & ys \<in> list(A))"
apply (rule iffI)
apply (frule prefix_type [THEN subsetD])
apply (blast intro: prefix_imp_take, clarify)
apply (erule ssubst)
apply (blast intro: take_prefix length_type)
done

lemma prefix_imp_nth: "[| <xs,ys> \<in> prefix(A); i < length(xs)|] ==> nth(i,xs) = nth(i,ys)"
by (auto dest!: gen_prefix_imp_nth simp add: prefix_def)

lemma nth_imp_prefix:
     "[|xs \<in> list(A); ys \<in> list(A); length(xs) \<le> length(ys);
        !!i. i < length(xs) ==> nth(i, xs) = nth(i,ys)|]
      ==> <xs,ys> \<in> prefix(A)"
apply (auto simp add: prefix_def nth_imp_gen_prefix)
apply (auto intro!: nth_imp_gen_prefix simp add: prefix_def)
apply (blast intro: nth_type lt_trans2)
done

lemma length_le_prefix_imp_prefix: "[|length(xs) \<le> length(ys);
        <xs,zs> \<in> prefix(A); <ys,zs> \<in> prefix(A)|] ==> <xs,ys> \<in> prefix(A)"
apply (cut_tac A = A in prefix_type)
apply (rule nth_imp_prefix, blast, blast)
 apply assumption
apply (rule_tac b = "nth (i,zs)" in trans)
 apply (blast intro: prefix_imp_nth)
apply (blast intro: sym prefix_imp_nth prefix_length_le lt_trans2)
done

end


subsection \<open>Relation between the Hoare logics in big-O style\<close>
theory DiscussionO
imports SepLogK_Hoare QuantK_Hoare Nielson_Hoare
begin

(* here we compare quantitative Hoare logic with constant with Nielson's Hoare logic *)

subsubsection \<open>Relation Nielson to quantHoare\<close>

definition emN :: "qassn \<Rightarrow> Nielson_Hoare.assn2"  where "emN P = (\<lambda>l s. P s < \<infinity>)"

(* quanthoare can be simulated by Nielson  *)
lemma assumes s: "\<Turnstile>\<^sub>1 { emN P'} c {  %s. (THE e. enat e = P' s - Q' (THE t. (\<exists>n. (c, s) \<Rightarrow> n \<Down> t ) )) \<Down> emN Q' }" (is "\<Turnstile>\<^sub>1 { ?P } c { ?e \<Down> ?Q }")
  shows quantNielson: "\<Turnstile>\<^sub>2\<^sub>' { P' } c { Q' }"
proof -
  from s obtain k where k: "k>0" and qd: "\<And>l s. emN P' l s \<Longrightarrow> (\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> p \<le> k * ?e s \<and> emN Q' l t)"
    unfolding hoare1_valid_def by blast

  show ?thesis unfolding QuantK_Hoare.hoare2o_valid_def
    apply(rule exI[where x=k])
    apply safe apply fact
  proof -
    fix s
    assume P': "P' s < \<infinity>"
    then have "(emN P') (\<lambda>_. 0) s" unfolding  emN_def by auto
    with qd obtain p t where i: "(c, s) \<Rightarrow> p \<Down> t" and p: "p \<le> k * ?e s" and e: "emN Q' (\<lambda>_. 0) t"
      by blast
    have t: "\<down>\<^sub>s (c, s) = t" using bigstepT_the_state[OF i] by auto

    from P' obtain pre where pre: "P' s = enat pre" by fastforce
    from e have "Q' t < \<infinity>" unfolding emN_def by auto
    then obtain post where post: "Q' t = enat post" by fastforce

    have "p > 0" using i bigstep_progress by auto

    thm enat.inject idiff_enat_enat the_equality
    have k: "(THE e. enat e = P' s - Q' (THE t. \<exists>n. (c, s) \<Rightarrow> n \<Down> t)) = pre - post"
      unfolding t pre post apply(rule the_equality)
       using idiff_enat_enat by auto
    with p have ieq: "p \<le> k * (pre - post)" by auto
    then have "p + k * post \<le> k * pre" using \<open>p>0\<close>
      using diff_mult_distrib2 by auto
       then
    have ii: "enat p + k * Q' t \<le> k * P' s" unfolding post pre by simp
    from i ii show "(\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> enat p + k * Q' t \<le> k * P' s)" by auto
  qed
qed

(* Nielson can be simulated by quanthoare *)
lemma assumes s: "\<Turnstile>\<^sub>2\<^sub>' { %s . emb (\<forall>l. P l s) + enat (e s) } c { %s. emb (\<forall>l. Q l s) }" (is "\<Turnstile>\<^sub>2\<^sub>' { ?P } c { ?Q }")
    and sP: "\<And>l t. P l t \<Longrightarrow> \<forall>l. P l t" (* "support P = {}" *)
    and sQ: "\<And>l t. Q l t \<Longrightarrow> \<forall>l. Q l t" (* "support Q = {}" *)
  shows  NielsonQuant: "\<Turnstile>\<^sub>1 { P } c { e \<Down> Q }"
proof -
  from s obtain k where k: "k>0" and qd: "\<And>s. ?P s < \<infinity> \<longrightarrow> (\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> enat p + enat k * ?Q t \<le> enat k * ?P s)"
    unfolding QuantK_Hoare.hoare2o_valid_def by blast

  show ?thesis unfolding hoare1_valid_def
    apply(rule exI[where x=k])
    apply safe apply fact
  proof -
    fix l s
    assume P': "P l s"
    then have aP: "\<forall>l. P l s" using sP  by auto
    then have P: "?P s < \<infinity>" by auto
    with qd obtain p t where i: "(c, s) \<Rightarrow> p \<Down> t" and p: "enat p + enat k * ?Q t \<le> enat k * ?P s"
      by blast
    have t: "\<down>\<^sub>s (c, s) = t" using bigstepT_the_state[OF i] by auto

    from P have Q: "Q l t" using p k
      apply auto
      by (metis (full_types) emb.simps(1) enat_ord_simps(2) imult_is_infinity infinity_ileE not_less_zero plus_enat_simps(3))
    with sQ have "\<forall>l. Q l t" by auto
    then have "?Q t = 0" by auto
    with p have "enat p \<le> enat k * ?P s" by auto
    with aP have p': "p \<le> k * e s" by auto

    from i Q p' show "\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> p \<le> k * e s \<and> Q l t" by blast
  qed
qed

subsubsection \<open>Relation SepLogic to quantHoare\<close>

definition em :: "qassn \<Rightarrow> (pstate_t \<Rightarrow> bool)" where
  "em P = (%(ps,n). (\<forall>ex. P (Partial_Evaluation.emb ps ex) \<le> enat n) )"  (* with equality next lemma also works *)

lemma assumes s: "\<Turnstile>\<^sub>3\<^sub>' { em P} c { em Q }"
shows  "\<Turnstile>\<^sub>2\<^sub>' { P } c { Q }"
proof -
  from s obtain k where k: "0<k" and s': "\<And>ps n. em P (ps, n) \<Longrightarrow> (\<exists>ps' ps'' m e e'. (c, ps) \<Rightarrow>\<^sub>A m \<Down> ps'+ ps'' \<and> ps' ## ps'' \<and> k * n = k * e + e' + m \<and> em Q (ps', e))" unfolding hoare3o_valid_def  by auto
  {
    fix s
    assume P: "P s < \<infinity>"
    then obtain n where n: "P s = enat n"
      by fastforce
    with P have "em P (part s, n)" unfolding em_def by auto
    with s' obtain ps' ps'' m e e' where c: "(c, part s) \<Rightarrow>\<^sub>A m \<Down> ps' + ps''" and orth: "ps' ## ps''"
              and m: "k * n = k * e + e' + m" and Q: "em Q (ps', e)" by blast

    from Q have q: "Q (Partial_Evaluation.emb ps' (Partial_Evaluation.emb ps'' (\<lambda>_. 0))) \<le> enat (e)" unfolding em_def by auto

    have z: "(Partial_Evaluation.emb ps' (Partial_Evaluation.emb ps'' (\<lambda>_. 0))) = (Partial_Evaluation.emb (ps'+ps'') (\<lambda>_. 0))"
      unfolding Partial_Evaluation.emb_def  apply (auto simp: plus_fun_def)
      apply (rule ext) subgoal for v apply (cases "ps' v") apply auto using orth    by (auto simp: sep_disj_fun_def domain_conv) done

    from q z have q:  "enat k * Q (Partial_Evaluation.emb (ps'+ps'') (\<lambda>_. 0)) \<le> enat k * enat e" using k
      by (metis i0_lb mult_left_mono)

    have i: "(c, s) \<Rightarrow> m \<Down> (Partial_Evaluation.emb (ps'+ps'') (\<lambda>_. 0))" using  part_to_full'[OF c] by simp

    have ii: "enat m + enat k * Q (Partial_Evaluation.emb (ps'+ps'') (\<lambda>_. 0)) \<le> enat k * P s" unfolding  n using q m
      using enat_ile by fastforce

    from i ii have "(\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> enat p + enat k * Q t \<le> enat k * P s)" by auto
  } note B=this
  show ?thesis unfolding QuantK_Hoare.hoare2o_valid_def
    apply(rule exI[where x=k], safe) apply fact
    apply (fact B) done
qed

definition embe :: "(pstate_t \<Rightarrow> bool) \<Rightarrow> qassn" where
    "embe P = (%s. Inf {enat n|n. P (part s, n)} )"

lemma assumes s: "\<Turnstile>\<^sub>2\<^sub>' { embe P } c { embe Q }" and full: "\<And>ps n. P (ps,n) \<Longrightarrow> dom ps = UNIV"
  shows  "\<Turnstile>\<^sub>3\<^sub>' {  P} c { Q }"
proof -
  from s obtain k where k: "k>0" and s: "\<And>s. embe P s < \<infinity> \<longrightarrow> (\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> enat p + enat k * embe Q t \<le> enat k * embe P s)"
    unfolding QuantK_Hoare.hoare2o_valid_def by auto

  { fix ps n
    let ?s =" (Partial_Evaluation.emb ps (\<lambda>_. 0))"
    assume P: "P (ps, n)"
    with full have "dom ps = UNIV" by auto
    then have ps: "part ?s = ps" by simp
    from P have l': "({enat n |n. P (ps, n)} = {}) =  False " by auto
    have t: "embe P ?s < \<infinity>" unfolding embe_def Inf_enat_def ps l'
      apply(rule ccontr) using l' apply auto
      by (metis (mono_tags, lifting) Least_le infinity_ileE)
    with s obtain t p where c: "(c, ?s) \<Rightarrow> p \<Down> t" and ineq: "enat p + enat k * embe Q t \<le> enat k * embe P ?s" by blast
    from t obtain z where z: "embe P ?s = enat z"
      using less_infinityE by blast
    with ineq obtain y where y: "embe Q t = enat y"
      using k by fastforce
    then have l: "embe Q t < \<infinity>" by auto
    then have zz: "({enat n|n. Q (part t, n)} = {}) = False" unfolding embe_def Inf_enat_def apply safe by simp
    from y have "Q (part t, y)"  unfolding embe_def zz Inf_enat_def apply auto
       using zz apply auto   by (smt Collect_empty_eq LeastI enat.inject)

    from full_to_part[OF c] ps have c': "(c, ps) \<Rightarrow>\<^sub>A p \<Down> part t" by auto

    have "\<And>P n. P (n::nat) \<Longrightarrow> (LEAST n. P n) \<le> n" apply(rule Least_le) by auto

    from z P have zn: "z \<le> n" unfolding embe_def ps unfolding embe_def Inf_enat_def l'
      apply auto
      by (metis (mono_tags, lifting) Least_le enat_ord_simps(1))

    from ineq z y have "enat p + enat k * y \<le> enat k * z" by auto
    then have "p + k * y \<le> k * z" by auto
    also have "\<dots> \<le> k * n"   using zn k by simp
    finally obtain e' where "k * n = k * y + e' + p" using k  by (metis add.assoc add.commute le_iff_add)

    have "\<exists>ps' ps'' m e e'. (c, ps) \<Rightarrow>\<^sub>A m \<Down> ps' + ps'' \<and> ps' ## ps'' \<and> k * n = k * e + e' + m \<and> Q (ps', e)"
      apply(rule exI[where x="part t"])
      apply(rule exI[where x="0"])
      apply(rule exI[where x="p"])
      apply(rule exI[where x="y"])
      apply(rule exI[where x="e'"]) apply auto by fact+
  }

  show ?thesis unfolding hoare3o_valid_def apply(rule exI[where x=k], safe)
    apply fact by fact
qed

subsection \<open>A General Validity Predicate with Time\<close>

definition valid  where
  "valid P c Q n = (\<forall>s. P s \<longrightarrow> (\<exists>s' m. (c, s) \<Rightarrow> m \<Down> s' \<and> m \<le> n \<and> Q s'))"

definition validk  where
  "validk P c Q n = (\<exists>k>0. (\<forall>s. P s \<longrightarrow> (\<exists>s' m. (c, s) \<Rightarrow> m \<Down> s' \<and> m \<le> k * n \<and> Q s')))"

lemma "validk P c Q n = (\<exists>k>0. valid P c Q (k*n))"
  unfolding valid_def validk_def by simp

subsubsection \<open>Relation between valid predicate and Quantitative Hoare Logic\<close>

lemma "\<Turnstile>\<^sub>2\<^sub>' {%s.  emb (P s)  + enat n} c { \<lambda>s.  emb (Q s)  } \<Longrightarrow> \<exists>k>0. valid P c Q (k*n)"
proof -
  assume valid: "\<Turnstile>\<^sub>2\<^sub>' {\<lambda>s. \<up> (P s) + enat n} c {\<lambda>s. \<up> (Q s)}"
  then obtain k where val: "\<And>s. \<up> (P s) + enat n < \<infinity> \<Longrightarrow> (\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> enat p + enat k * \<up> (Q t) \<le> enat k * (\<up> (P s) + enat n))"
    and k: "k>0" unfolding QuantK_Hoare.hoare2o_valid_def by blast
  {
    fix s
    assume Ps: "P s"
    then have " \<up> (P s) + enat n < \<infinity>" by auto
    with val obtain  t m where
        c: "(c, s) \<Rightarrow> m \<Down> t" and "enat m + k * \<up> (Q t) \<le> k * (\<up> (P s) + enat n)" by blast

    then have "m \<le> k * n \<and> Q t" using k
      using Ps add.commute add.right_neutral emb.simps(1) emb.simps(2) enat_ord_simps(1) infinity_ileE plus_enat_simps(3)
      by (metis (full_types) mult_zero_right not_gr_zero times_enat_simps(1) times_enat_simps(4))

    with     c
    have "(\<exists>s' m. (c, s) \<Rightarrow> m \<Down> s' \<and> m \<le>  k * n \<and> Q s')" by blast
  } note bla=this
  show "\<exists>k>0. valid P c Q (k*n)" unfolding valid_def apply(rule exI[where x=k]) using bla k by auto
qed

lemma valid_quantHoare: "\<exists>k>0. valid P c Q (k*n) \<Longrightarrow> \<Turnstile>\<^sub>2\<^sub>' {%s. emb (P s)  + enat n} c { \<lambda>s. emb (Q s)  }"
proof -
  assume  "\<exists>k>0. valid P c Q (k*n)"
  then obtain k where valid: "valid P c Q (k*n)" and k: "k>0" by blast
  {
    fix s
    assume "(%s. emb (P s)  + enat n) s < \<infinity>"
    then have Ps: "P s" apply auto
      by (metis emb.elims enat.distinct(2) enat.simps(5) enat_defs(4))
    with valid[unfolded valid_def] obtain t m where
        c: "(c, s) \<Rightarrow> m \<Down> t" and "m \<le> k * n" "Q t" by blast
    then have "enat m +  k * \<up> (Q t) \<le>  k * (\<up> (P s) + enat n)" using Ps by simp
    with     c
    have "(\<exists>s' m. (c, s) \<Rightarrow> m \<Down> s' \<and> enat m + enat k * \<up> (Q s') \<le> enat k * (\<up> (P s) + enat n))" by blast
  } note funk=this
  show "\<Turnstile>\<^sub>2\<^sub>' {%s.  emb (P s)  + enat n} c { \<lambda>s. emb (Q s)  }" unfolding QuantK_Hoare.hoare2o_valid_def
    apply(rule exI[where x=k]) using funk k by auto
qed

subsubsection \<open>Relation between valid predicate and Hoare Logic based on Separation Logic\<close>

definition "embP2 P = (%(ps,n). \<forall>s.  P (Partial_Evaluation.emb ps s) \<and> n = 0)"
definition "embP3 P = (%(ps,n). dom ps = UNIV \<and> (\<forall>s.  P (Partial_Evaluation.emb ps s)) \<and> n = 0)"

lemma emp: "a + Map.empty = a"
  by (simp add: plus_fun_conv)

lemma oneway: "\<Turnstile>\<^sub>3\<^sub>' {embP3 P ** $n} c {embP2 Q} \<Longrightarrow> validk P c Q n"
proof -
  assume partial_true: "\<Turnstile>\<^sub>3\<^sub>' {embP3 P ** $n} c {embP2 Q}"
  from partial_true[unfolded hoare3o_valid_def] obtain k where k: "k>0" and
   q : "\<forall>ps na. (embP3 P \<and>* $ n) (ps, na) \<longrightarrow>
                (\<exists>ps' ps'' m e e'. (c, ps) \<Rightarrow>\<^sub>A m \<Down> ps' + ps'' \<and> ps' ## ps'' \<and> k * na = k * e + e' + m \<and> embP2 Q (ps', e)) " by blast
  { fix s
    assume "P s"
    then have g: " (embP3 P \<and>* $ n) (part s, n)"
      unfolding embP3_def dollar_def sep_conj_def by auto
    from q  g
    obtain ps' ps'' m e e' where pbig: "(c, part s) \<Rightarrow>\<^sub>A m \<Down> ps' + ps''" and orth: "ps' ## ps''"
        and ii: "k * n = k * e + e' + m" and erg: "embP2 Q (ps', e)" by blast

    have ii': "m \<le> k * n" using ii by auto

    from part_to_full'[OF pbig] have i: "(c, s ) \<Rightarrow> m \<Down> Partial_Evaluation.emb (ps' + ps'') s" by simp

    from erg have z2: "\<And>s. Q (Partial_Evaluation.emb ps' s)" unfolding embP2_def by auto
    have "Partial_Evaluation.emb (ps' + ps'') s = Partial_Evaluation.emb (ps'' + ps') s"
      using orth  by (simp add: sep_add_commute)
    also have "Partial_Evaluation.emb (ps'' + ps') s = Partial_Evaluation.emb (ps') (Partial_Evaluation.emb (ps'') s)"
      apply rule
      unfolding emb_def plus_fun_conv map_add_def
      by (metis option.case_eq_if option.simps(5))
    finally have z: "Partial_Evaluation.emb (ps' + ps'') s = Partial_Evaluation.emb (ps') (Partial_Evaluation.emb (ps'') s)" .
    have iii: "Q (Partial_Evaluation.emb (ps' + ps'') s)" unfolding z apply (fact) .

    from i ii' iii
      have "\<exists>s' m. (c, s) \<Rightarrow> m \<Down> s' \<and> m \<le> k * n \<and> Q s'" by auto
    }
    with k show "validk P c Q n" unfolding validk_def by blast
qed

lemma theother: "validk P c Q n \<Longrightarrow> \<Turnstile>\<^sub>3\<^sub>' {embP3 P ** $n} c {embP2 Q }"
proof -
  assume valid: "validk P c Q n"
  then obtain k where k : "k>0" and v: "(\<forall>s. P s \<longrightarrow> (\<exists>s' m. (c, s) \<Rightarrow> m \<Down> s' \<and> m \<le> k * n \<and> Q s'))"
   unfolding validk_def by blast

  { fix ps na
    assume an: "(embP3 P \<and>* $ n) (ps, na)"
    have dom: "dom ps = UNIV" and Pps: "\<And>s. P (Partial_Evaluation.emb ps s)" and nan: "na = n" using an unfolding sep_conj_def
        by (auto simp: embP3_def dollar_def)

    from v Pps
      obtain s' m where big: "(c, (Partial_Evaluation.emb ps (%_. 0))) \<Rightarrow> m \<Down> s'" and ii: "m \<le> k * n" and erg: "Q s'" by blast

    have "part (Partial_Evaluation.emb ps (\<lambda>_. 0)) = ps " using dom by simp
    with full_to_part[OF big] have i: "(c, ps) \<Rightarrow>\<^sub>A m \<Down> part s'" by auto

    have iii: "embP2 Q (part s', 0)"
      unfolding embP2_def apply auto by fact

    have "k * na = k * n - m + m" using ii k nan by simp

    have "(\<exists>ps' ps'' m e e'. (c, ps) \<Rightarrow>\<^sub>A m \<Down> ps' + ps'' \<and> ps' ## ps'' \<and> k * na = k * e + e' + m \<and> embP2 Q (ps', e))"
      apply(rule exI[where x="part s'"])
      apply(rule exI[where x="0"])
      apply(rule exI[where x="m"])
      apply(rule exI[where x="0"])
      apply(rule exI[where x="k * n - m"]) apply auto
      by fact+
    }
    with k show "\<Turnstile>\<^sub>3\<^sub>' {embP3 P ** $n} c {embP2 Q }" unfolding hoare3o_valid_def by blast
qed

lemma "validk P c Q n \<longleftrightarrow> \<Turnstile>\<^sub>3\<^sub>' {embP3 P ** $n} c {embP2 Q }"
using oneway and theother by metis

end


            (*-------------------------------------------*
            |                                           |
            |       LW-CSP-Prover on Isabelle2021       |
            |                                           |
            *-------------------------------------------*)

theory CSP_trace
imports Main
begin

(*************************************************************

         1. Event type
         2. Functions on event-lists
         3.
         4.

 *************************************************************)

(***********************************************************
                    Definition of traces
 ***********************************************************)

datatype 'a event = Ev 'a | Tau
type_synonym 'a ev_list = "'a event list"           (* synonym *)

(***********************************************************
                       functions
 ***********************************************************)

(* remove Tau *)

primrec
  obs :: "'a event => 'a list"
  where
    "obs (Ev a) = [a]"
  | "obs (Tau) = []"

fun
  rem_tau :: "'a ev_list => 'a list"
  where
    "rem_tau [] = []"
  |"rem_tau (Tau#s) = rem_tau s"
  |"rem_tau (Ev a#s) = a#rem_tau s"

(* ----------------------------------------- *
 |                    lemmas                 |
 * ----------------------------------------- *)

lemma map_list_test:
  "map Ev [1,2,3] = [Ev 1, Ev 2, Ev 3]"
  apply (simp)
  done

lemma eq_rem_tau:
  "rem_tau(map Ev s) = s"
  apply (induct_tac s)
  apply (simp)
  apply (simp)
  done

lemma ev_or_tau:
  "ALL e. (EX a. e = Ev a) | e = Tau"
  apply (rule allI)
  apply (induct_tac e)
  apply (simp_all)
  done

lemma rem_tau_append_ALL:
  "ALL s1 s2. rem_tau(s1 @ s2) = rem_tau(s1) @ rem_tau(s2)"
  apply (rule allI)
  apply (induct_tac s1)
    (* nil *)
  apply (simp)

(* step *)
  apply (insert ev_or_tau)
  apply (drule_tac x="a" in spec)
  apply (elim disjE exE conjE)
  apply (simp_all)
  done

lemma rem_tau_append:
  "rem_tau(s1 @ s2) = rem_tau(s1) @ rem_tau(s2)"
  apply (simp add: rem_tau_append_ALL)
  done

lemma rem_tau_obs:
  "rem_tau([e]) = obs e"
  apply (induct_tac e)
  apply (simp)
  apply (simp)
  done

lemma rem_tau_cons:
  "rem_tau(e#s) = (obs e) @ rem_tau(s)"
  apply (insert rem_tau_append[of "[e]" s])
  apply (simp)
  apply (simp add: rem_tau_obs)
  done

lemma rem_tau_ev_only_if:
  "(rem_tau t = [a])
   --> (EX s1 s2. t = s1@(Ev a #s2) & rem_tau s1 = [] & rem_tau s2 = [])"
  apply (induct_tac t)
  apply (simp)

  apply (intro impI)
  apply (insert ev_or_tau)
  apply (drule_tac x="aa" in spec)
  apply (elim disjE exE conjE)

  apply (simp)
  apply (rule_tac x="[]" in exI)
  apply (rule_tac x="list" in exI)
  apply (simp)

  apply (simp)
  apply (elim exE conjE)
  apply (simp)
  apply (rule_tac x="Tau # s1" in exI)
  apply (simp)
  done

lemma rem_tau_ev:
  "(rem_tau t = [a])
   = (EX s1 s2. t = s1@(Ev a # s2) & rem_tau s1 = [] & rem_tau s2 = [])"
  apply (rule iffI)
  apply (simp add: rem_tau_ev_only_if)
  apply (elim exE conjE)
  apply (simp)
  apply (simp add: rem_tau_append)
  done

lemma rem_asmE:
  "A ==> R ==> R"
  by simp

end


(*  Title:      HOL/ex/Intuitionistic.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge

Taken from FOL/ex/int.ML
*)

section \<open>Higher-Order Logic: Intuitionistic predicate calculus problems\<close>

theory Intuitionistic imports Main begin

(*Metatheorem (for PROPOSITIONAL formulae...):
  P is classically provable iff ~~P is intuitionistically provable.
  Therefore ~P is classically provable iff it is intuitionistically provable.

Proof: Let Q be the conjuction of the propositions A|~A, one for each atom A
in P.  Now ~~Q is intuitionistically provable because ~~(A|~A) is and because
~~ distributes over &.  If P is provable classically, then clearly Q-->P is
provable intuitionistically, so ~~(Q-->P) is also provable intuitionistically.
The latter is intuitionistically equivalent to ~~Q-->~~P, hence to ~~P, since
~~Q is intuitionistically provable.  Finally, if P is a negation then ~~P is
intuitionstically equivalent to P.  [Andy Pitts] *)

lemma "(~~(P&Q)) = ((~~P) & (~~Q))"
  by iprover

lemma "~~ ((~P --> Q) --> (~P --> ~Q) --> P)"
  by iprover

(* ~~ does NOT distribute over | *)

lemma "(~~(P-->Q))  = (~~P --> ~~Q)"
  by iprover

lemma "(~~~P) = (~P)"
  by iprover

lemma "~~((P --> Q | R)  -->  (P-->Q) | (P-->R))"
  by iprover

lemma "(P=Q) = (Q=P)"
  by iprover

lemma "((P --> (Q | (Q-->R))) --> R) --> R"
  by iprover

lemma "(((G-->A) --> J) --> D --> E) --> (((H-->B)-->I)-->C-->J)
      --> (A-->H) --> F --> G --> (((C-->B)-->I)-->D)-->(A-->C)
      --> (((F-->A)-->B) --> I) --> E"
  by iprover

(* Lemmas for the propositional double-negation translation *)

lemma "P --> ~~P"
  by iprover

lemma "~~(~~P --> P)"
  by iprover

lemma "~~P & ~~(P --> Q) --> ~~Q"
  by iprover

(* de Bruijn formulae *)

(*de Bruijn formula with three predicates*)
lemma "((P=Q) --> P&Q&R) &
       ((Q=R) --> P&Q&R) &
       ((R=P) --> P&Q&R) --> P&Q&R"
  by iprover

(*de Bruijn formula with five predicates*)
lemma "((P=Q) --> P&Q&R&S&T) &
       ((Q=R) --> P&Q&R&S&T) &
       ((R=S) --> P&Q&R&S&T) &
       ((S=T) --> P&Q&R&S&T) &
       ((T=P) --> P&Q&R&S&T) --> P&Q&R&S&T"
  by iprover

(*** Problems from Sahlin, Franzen and Haridi,
     An Intuitionistic Predicate Logic Theorem Prover.
     J. Logic and Comp. 2 (5), October 1992, 619-656.
***)

(*Problem 1.1*)
lemma "(\<forall>x. \<exists>y. \<forall>z. p(x) \<and> q(y) \<and> r(z)) =
       (\<forall>z. \<exists>y. \<forall>x. p(x) \<and> q(y) \<and> r(z))"
  by (iprover del: allE elim 2: allE')

(*Problem 3.1*)
lemma "\<not> (\<exists>x. \<forall>y. p y x = (\<not> p x x))"
  by iprover

(* Intuitionistic FOL: propositional problems based on Pelletier. *)

(* Problem ~~1 *)
lemma "~~((P-->Q)  =  (~Q --> ~P))"
  by iprover

(* Problem ~~2 *)
lemma "~~(~~P  =  P)"
  by iprover

(* Problem 3 *)
lemma "~(P-->Q) --> (Q-->P)"
  by iprover

(* Problem ~~4 *)
lemma "~~((~P-->Q)  =  (~Q --> P))"
  by iprover

(* Problem ~~5 *)
lemma "~~((P|Q-->P|R) --> P|(Q-->R))"
  by iprover

(* Problem ~~6 *)
lemma "~~(P | ~P)"
  by iprover

(* Problem ~~7 *)
lemma "~~(P | ~~~P)"
  by iprover

(* Problem ~~8.  Peirce's law *)
lemma "~~(((P-->Q) --> P)  -->  P)"
  by iprover

(* Problem 9 *)
lemma "((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)"
  by iprover

(* Problem 10 *)
lemma "(Q-->R) --> (R-->P&Q) --> (P-->(Q|R)) --> (P=Q)"
  by iprover

(* 11.  Proved in each direction (incorrectly, says Pelletier!!) *)
lemma "P=P"
  by iprover

(* Problem ~~12.  Dijkstra's law *)
lemma "~~(((P = Q) = R)  =  (P = (Q = R)))"
  by iprover

lemma "((P = Q) = R)  -->  ~~(P = (Q = R))"
  by iprover

(* Problem 13.  Distributive law *)
lemma "(P | (Q & R))  = ((P | Q) & (P | R))"
  by iprover

(* Problem ~~14 *)
lemma "~~((P = Q) = ((Q | ~P) & (~Q|P)))"
  by iprover

(* Problem ~~15 *)
lemma "~~((P --> Q) = (~P | Q))"
  by iprover

(* Problem ~~16 *)
lemma "~~((P-->Q) | (Q-->P))"
by iprover

(* Problem ~~17 *)
lemma "~~(((P & (Q-->R))-->S) = ((~P | Q | S) & (~P | ~R | S)))"
  oops

(*Dijkstra's "Golden Rule"*)
lemma "(P&Q) = (P = (Q = (P|Q)))"
  by iprover

(****Examples with quantifiers****)

(* The converse is classical in the following implications... *)

lemma "(\<exists>x. P(x)\<longrightarrow>Q)  \<longrightarrow>  (\<forall>x. P(x)) \<longrightarrow> Q"
  by iprover

lemma "((\<forall>x. P(x))\<longrightarrow>Q) \<longrightarrow> \<not> (\<forall>x. P(x) \<and> \<not>Q)"
  by iprover

lemma "((\<forall>x. \<not>P(x))\<longrightarrow>Q)  \<longrightarrow>  \<not> (\<forall>x. \<not> (P(x)\<or>Q))"
  by iprover

lemma "(\<forall>x. P(x)) \<or> Q  \<longrightarrow>  (\<forall>x. P(x) \<or> Q)"
  by iprover

lemma "(\<exists>x. P \<longrightarrow> Q(x)) \<longrightarrow> (P \<longrightarrow> (\<exists>x. Q(x)))"
  by iprover

(* Hard examples with quantifiers *)

(*The ones that have not been proved are not known to be valid!
  Some will require quantifier duplication -- not currently available*)

(* Problem ~~19 *)
lemma "\<not>\<not>(\<exists>x. \<forall>y z. (P(y)\<longrightarrow>Q(z)) \<longrightarrow> (P(x)\<longrightarrow>Q(x)))"
  by iprover

(* Problem 20 *)
lemma "(\<forall>x y. \<exists>z. \<forall>w. (P(x)\<and>Q(y)\<longrightarrow>R(z)\<and>S(w)))
    \<longrightarrow> (\<exists>x y. P(x) \<and> Q(y)) \<longrightarrow> (\<exists>z. R(z))"
  by iprover

(* Problem 21 *)
lemma "(\<exists>x. P\<longrightarrow>Q(x)) \<and> (\<exists>x. Q(x)\<longrightarrow>P) \<longrightarrow> \<not>\<not>(\<exists>x. P=Q(x))"
  by iprover

(* Problem 22 *)
lemma "(\<forall>x. P = Q(x))  \<longrightarrow>  (P = (\<forall>x. Q(x)))"
  by iprover

(* Problem ~~23 *)
lemma "\<not>\<not> ((\<forall>x. P \<or> Q(x))  =  (P \<or> (\<forall>x. Q(x))))"
  by iprover

(* Problem 25 *)
lemma "(\<exists>x. P(x)) \<and>
       (\<forall>x. L(x) \<longrightarrow> \<not> (M(x) \<and> R(x))) \<and>
       (\<forall>x. P(x) \<longrightarrow> (M(x) \<and> L(x))) \<and>
       ((\<forall>x. P(x)\<longrightarrow>Q(x)) \<or> (\<exists>x. P(x)\<and>R(x)))
   \<longrightarrow> (\<exists>x. Q(x)\<and>P(x))"
  by iprover

(* Problem 27 *)
lemma "(\<exists>x. P(x) \<and> \<not>Q(x)) \<and>
             (\<forall>x. P(x) \<longrightarrow> R(x)) \<and>
             (\<forall>x. M(x) \<and> L(x) \<longrightarrow> P(x)) \<and>
             ((\<exists>x. R(x) \<and> \<not> Q(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> \<not> R(x)))
         \<longrightarrow> (\<forall>x. M(x) \<longrightarrow> \<not>L(x))"
  by iprover

(* Problem ~~28.  AMENDED *)
lemma "(\<forall>x. P(x) \<longrightarrow> (\<forall>x. Q(x))) \<and>
       (\<not>\<not>(\<forall>x. Q(x)\<or>R(x)) \<longrightarrow> (\<exists>x. Q(x)&S(x))) \<and>
       (\<not>\<not>(\<exists>x. S(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> M(x)))
   \<longrightarrow> (\<forall>x. P(x) \<and> L(x) \<longrightarrow> M(x))"
  by iprover

(* Problem 29.  Essentially the same as Principia Mathematica *11.71 *)
lemma "(((\<exists>x. P(x)) \<and> (\<exists>y. Q(y))) \<longrightarrow>
   (((\<forall>x. (P(x) \<longrightarrow> R(x))) \<and> (\<forall>y. (Q(y) \<longrightarrow> S(y)))) =
    (\<forall>x y. ((P(x) \<and> Q(y)) \<longrightarrow> (R(x) \<and> S(y))))))"
  by iprover

(* Problem ~~30 *)
lemma "(\<forall>x. (P(x) \<or> Q(x)) \<longrightarrow> \<not> R(x)) \<and>
       (\<forall>x. (Q(x) \<longrightarrow> \<not> S(x)) \<longrightarrow> P(x) \<and> R(x))
   \<longrightarrow> (\<forall>x. \<not>\<not>S(x))"
  by iprover

(* Problem 31 *)
lemma "\<not>(\<exists>x. P(x) \<and> (Q(x) \<or> R(x))) \<and>
        (\<exists>x. L(x) \<and> P(x)) \<and>
        (\<forall>x. \<not> R(x) \<longrightarrow> M(x))
    \<longrightarrow> (\<exists>x. L(x) \<and> M(x))"
  by iprover

(* Problem 32 *)
lemma "(\<forall>x. P(x) \<and> (Q(x)|R(x))\<longrightarrow>S(x)) \<and>
       (\<forall>x. S(x) \<and> R(x) \<longrightarrow> L(x)) \<and>
       (\<forall>x. M(x) \<longrightarrow> R(x))
   \<longrightarrow> (\<forall>x. P(x) \<and> M(x) \<longrightarrow> L(x))"
  by iprover

(* Problem ~~33 *)
lemma "(\<forall>x. \<not>\<not>(P(a) \<and> (P(x)\<longrightarrow>P(b))\<longrightarrow>P(c)))  =
       (\<forall>x. \<not>\<not>((\<not>P(a) \<or> P(x) \<or> P(c)) \<and> (\<not>P(a) \<or> \<not>P(b) \<or> P(c))))"
  oops

(* Problem 36 *)
lemma
     "(\<forall>x. \<exists>y. J x y) \<and>
      (\<forall>x. \<exists>y. G x y) \<and>
      (\<forall>x y. J x y \<or> G x y \<longrightarrow> (\<forall>z. J y z \<or> G y z \<longrightarrow> H x z))
  \<longrightarrow> (\<forall>x. \<exists>y. H x y)"
  by iprover

(* Problem 39 *)
lemma "\<not> (\<exists>x. \<forall>y. F y x = (\<not>F y y))"
  by iprover

(* Problem 40.  AMENDED *)
lemma "(\<exists>y. \<forall>x. F x y = F x x) \<longrightarrow>
             \<not>(\<forall>x. \<exists>y. \<forall>z. F z y = (\<not> F z x))"
  by iprover

(* Problem 44 *)
lemma "(\<forall>x. f(x) \<longrightarrow>
             (\<exists>y. g(y) \<and> h x y \<and> (\<exists>y. g(y) \<and> ~ h x y)))  \<and>
             (\<exists>x. j(x) \<and> (\<forall>y. g(y) \<longrightarrow> h x y))
             \<longrightarrow> (\<exists>x. j(x) \<and> \<not>f(x))"
  by iprover

(* Problem 48 *)
lemma "(a=b \<or> c=d) \<and> (a=c \<or> b=d) \<longrightarrow> a=d \<or> b=c"
  by iprover

(* Problem 51 *)
lemma "((\<exists>z w. (\<forall>x y. (P x y = ((x = z) \<and> (y = w))))) \<longrightarrow>
  (\<exists>z. (\<forall>x. (\<exists>w. ((\<forall>y. (P x y = (y = w))) = (x = z))))))"
  by iprover

(* Problem 52 *)
(*Almost the same as 51. *)
lemma "((\<exists>z w. (\<forall>x y. (P x y = ((x = z) \<and> (y = w))))) \<longrightarrow>
   (\<exists>w. (\<forall>y. (\<exists>z. ((\<forall>x. (P x y = (x = z))) = (y = w))))))"
  by iprover

(* Problem 56 *)
lemma "(\<forall>x. (\<exists>y. P(y) \<and> x=f(y)) \<longrightarrow> P(x)) = (\<forall>x. P(x) \<longrightarrow> P(f(x)))"
  by iprover

(* Problem 57 *)
lemma "P (f a b) (f b c) & P (f b c) (f a c) \<and>
     (\<forall>x y z. P x y \<and> P y z \<longrightarrow> P x z) \<longrightarrow> P (f a b) (f a c)"
  by iprover

(* Problem 60 *)
lemma "\<forall>x. P x (f x) = (\<exists>y. (\<forall>z. P z y \<longrightarrow> P z (f x)) \<and> P x y)"
  by iprover

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
   A general calculus of refinement in Isabelle.
*)

chapter "Refinement"

theory Simulation
imports Main
begin

text \<open>
  A data type is a collection of three functions on three basic types.
  The three basic types are the private state space @{typ 'a}, the observable
  state space @{typ 'b} and the operations @{typ 'j}.

  The three functions are the initialisation @{term "Init"} which (potentially
  nondeterministically) produces a private state space from an observable one,
  the finalisation @{term Fin} which projects the observable part of
  the state space out of the private one, and finally @{term Step} that gives
  the (potentially nondeterministic) transition relation on the private state
  space for each operation in @{typ 'j}.

  In the simple case, the private state space is something like a
  tuple @{typ "'a \<times> 'b"} fully containing the observable part such
  that @{term Fin} just becomes the projection @{term snd}, and @{term
  "Init s"} constructs an additional private part, e.g. just
  @{term "{(f x, x)}"}.

  Hoare triples on the system and refinement are defined over the observable
  part of the state.
\<close>

record ('a,'b,'j) data_type =
  Init :: "'b \<Rightarrow> 'a set"
  Fin :: "'a \<Rightarrow> 'b"
  Step :: "'j \<Rightarrow> ('a \<times> 'a) set"

text \<open>
  A sequence of operations over a transition relation @{term \<delta>} is executed
  by applying the relation repeatedly.
\<close>
definition
  steps :: "('j \<Rightarrow> ('a \<times> 'a) set) \<Rightarrow> 'a set \<Rightarrow> 'j list \<Rightarrow> 'a set" where
  "steps \<delta> \<equiv> foldl (\<lambda>S j. \<delta> j `` S)"

text \<open>
  The sequence of operations in the data type is then executed
  in an initial state by initialising the private state, executing
  the transition relation over this private state, and finally
  projecting back out the set of final, observable states.
\<close>
definition
   execution :: "('a,'b,'j) data_type \<Rightarrow> 'b \<Rightarrow> 'j list \<Rightarrow> 'b set" where
  "execution A s js \<equiv> Fin A ` steps (Step A) (Init A s) js"

text \<open>
  A Hoare triple over a list of operations in the data type is
  the usual: given a state in the pre-condition, all resulting states
  of the execution must be in the post-condition:
\<close>
definition
  hoare_triple :: "('a,'b,'j) data_type \<Rightarrow> 'b set \<Rightarrow> 'j list \<Rightarrow> 'b set \<Rightarrow> bool"
where
  "hoare_triple A P js Q \<equiv> \<forall>s \<in> P. execution A s js \<subseteq> Q"

text \<open>
  Refinement is defined by saying that all concrete behaviours are contained in
  their corresponding abstract ones. Only the private state spaces of the
  data type may differ.
\<close>
definition
  refines :: "('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool" (infix "\<sqsubseteq>" 60)
where
  "C \<sqsubseteq> A \<equiv> \<forall>js s. execution C s js \<subseteq> execution A s js"

text \<open>
  Alternatively, one may say that all Hoare triples proved on the abstract data
  type are true for the concrete one.
\<close>
lemma hoare_triple_refinement:
  "C \<sqsubseteq> A = (\<forall>P Q js. hoare_triple A P js Q \<longrightarrow> hoare_triple C P js Q)"
  by (simp add: refines_def hoare_triple_def) blast

\<comment> \<open>composing two relations\<close>
definition
  rel_semi :: "('a \<times> 'b) set \<Rightarrow> ('b \<times> 'c) set \<Rightarrow> ('a \<times> 'c) set" (infixl ";;;" 65)
where
  "A ;;; B \<equiv> A O B"

text \<open>
  Refinement is a global property over all executions and/or all
  hoare triples. As this is hard to show, we define the weaker concept
  of forward simulation.
\<close>
definition
  fw_sim :: "('a \<times> 'c) set \<Rightarrow> ('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool"
where
  "fw_sim R C A \<equiv> (\<forall>s. Init C s \<subseteq> R `` Init A s) \<and>
                  (\<forall>j. R ;;; Step C j \<subseteq> Step A j ;;; R) \<and>
                  (\<forall>s s'. (s,s') \<in> R \<longrightarrow> Fin C s' = Fin A s)"

definition
  fw_simulates :: "('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool" (infixl "\<sqsubseteq>\<^sub>F" 50)
where
  "C \<sqsubseteq>\<^sub>F A \<equiv> \<exists>R. fw_sim R C A"

lemma fw_sim_steps:
  assumes steps: "t' \<in> steps (Step C) S' js" "S' \<subseteq> R `` S"
  assumes sim: "fw_sim R C A"
  shows "\<exists>t \<in> steps (Step A) S js. (t,t') \<in> R" using steps
proof (induct js arbitrary: S' S)
  case Nil
  thus ?case by (simp add: steps_def) blast
next
  case (Cons j js)
  hence "t' \<in> steps (Step C) (Step C j `` S') js"
    by (clarsimp simp: steps_def)
  moreover {
    from Cons.prems
    have "S' \<subseteq> R `` S" by simp
    moreover
    from sim
    have "R ;;; Step C j \<subseteq> Step A j ;;; R" by (simp add: fw_sim_def)
    ultimately
    have "Step C j `` S' \<subseteq> R `` (Step A j `` S)"
      by (simp add: rel_semi_def) blast
  }
  ultimately
  show ?case using Cons.hyps
    by (auto simp: steps_def)
qed

lemma sim_imp_refines:
  "C \<sqsubseteq>\<^sub>F A \<Longrightarrow> C \<sqsubseteq> A"
  apply (clarsimp simp: refines_def execution_def fw_simulates_def)
  apply (rename_tac t)
  apply (drule fw_sim_steps)
    prefer 2
    apply assumption
   apply (simp add: fw_sim_def)
   apply blast
  apply clarsimp
  apply (erule rev_image_eqI)
  apply (simp add: fw_sim_def)
  done

text \<open>
  To further aid proofs, we define (private) invariants on data types.
  Private invariants are properties that are true throughout execution
  on the private state space of the state type. The purpose is to exploit
  these properties while showing forward simulation.
\<close>
definition
  invariant_holds :: "('a,'b,'j) data_type \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<Turnstile>" 60)
where
  "D \<Turnstile> I \<equiv> (\<forall>s. Init D s \<subseteq> I) \<and> (\<forall>j. Step D j `` I \<subseteq> I)"

lemma invariant_T [iff]: "D \<Turnstile> UNIV"
  by (simp add: invariant_holds_def)

lemma invariantI:
  "\<lbrakk> \<forall>s. Init D s \<subseteq> I; \<forall>j. Step D j `` I \<subseteq> I \<rbrakk> \<Longrightarrow> D \<Turnstile> I"
  by (simp add: invariant_holds_def)

lemma invariant_CollectI [intro?]:
  assumes init: "\<And>s a. s \<in> Init D a \<Longrightarrow> I s"
  assumes step: "\<And>j s s'. \<lbrakk> I s; (s,s') \<in> Step D j \<rbrakk> \<Longrightarrow> I s'"
  shows "D \<Turnstile> Collect I"
proof (rule invariantI)
  show "\<forall>a. Init D a \<subseteq> Collect I" by (fast intro: init)
next
  show "\<forall>j. Step D j `` Collect I \<subseteq> Collect I"
    by (auto simp add: Image_def intro: step)
qed

lemma invariant_conjI:
  "D \<Turnstile> P \<Longrightarrow> D \<Turnstile> Q  \<Longrightarrow> D \<Turnstile> P \<inter> Q"
  by (simp add: invariant_holds_def) blast

lemma invariant_conjI2:
  "\<lbrakk> D \<Turnstile> I; \<And>s. Init D s \<subseteq> I \<Longrightarrow> Init D s \<subseteq> J;
    \<forall>j. Step D j `` (I \<inter> J) \<subseteq> J \<rbrakk> \<Longrightarrow> D \<Turnstile> I \<inter> J"
  by (simp add: invariant_holds_def) blast

text \<open>
  We can now define forward simulation with an invariant. The proof
  obligation for the step and final case in the correspondence proof
  can now assume that the invariant holds. The invariant itself can be
  shown separately.
\<close>
definition
  LI :: "('a,'b,'j) data_type \<Rightarrow> ('c,'b,'j) data_type \<Rightarrow> ('a \<times> 'c) set \<Rightarrow> ('a \<times> 'c) set \<Rightarrow> bool"
where
  "LI A C R I \<equiv> (\<forall>s. Init C s \<subseteq> R `` Init A s) \<and>
                (\<forall>j. (R \<inter> I) ;;; Step C j \<subseteq> Step A j ;;; R) \<and>
                (\<forall>s s'. (s,s') \<in> R \<inter> I \<longrightarrow> Fin C s' = Fin A s)"

lemma LI_fw_sim:
  assumes  ia: "A \<Turnstile> I\<^sub>a" and ic: "C \<Turnstile> I\<^sub>c" and li: "LI A C r (I\<^sub>a \<times> I\<^sub>c)"
  shows "fw_sim (r \<inter> I\<^sub>a \<times> I\<^sub>c) C A"
proof -
  from li have
    init: "\<forall>s. Init C s \<subseteq> r `` Init A s" and
    step: "\<forall>j. (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) ;;; Step C j \<subseteq> Step A j ;;; r" and
    fin: "(\<forall>s s'. (s,s') \<in> r \<inter> (I\<^sub>a \<times> I\<^sub>c) \<longrightarrow> Fin C s' = Fin A s)"
    by (auto simp: LI_def)
  from ia have  "\<forall>s. (r \<inter> (UNIV \<times> I\<^sub>c) ) `` Init A s = (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) `` Init A s"
    by (simp add: invariant_holds_def, blast)
  moreover from init ic have "\<forall>s. Init C s \<subseteq> (r \<inter> (UNIV \<times> I\<^sub>c)) `` Init A s"
    by (simp add: invariant_holds_def, blast)
  ultimately have initI: "\<forall>s. Init C s \<subseteq> (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) `` Init A s" by simp
  moreover {
    fix j
    from step have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) ;;; Step C j \<subseteq> Step A j ;;; r"..
    also
    have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) = ((UNIV \<times> I\<^sub>a) \<inter> Id) ;;; r ;;; ((I\<^sub>c \<times> UNIV) \<inter> Id)"
      (is "_ = ?I\<^sub>a ;;; r ;;; ?I\<^sub>c")
      by (simp add: rel_semi_def, blast)
    finally
    have "?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j \<subseteq> ?I\<^sub>a ;;; Step A j ;;; r"
      by (simp add: rel_semi_def, blast)
    also
    from ia have "\<dots> \<subseteq> Step A j ;;; ?I\<^sub>a ;;; r"
      by (simp add: invariant_holds_def rel_semi_def, blast)
    finally
    have "?I\<^sub>a ;;;  r ;;; ?I\<^sub>c ;;; Step C j;;; ?I\<^sub>c \<subseteq>  Step A j ;;; ?I\<^sub>a ;;; r ;;; ?I\<^sub>c"
      by (simp add: rel_semi_def, blast)
    also
    from ic
    have "?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j;;; ?I\<^sub>c =  ?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j"
      by (simp add: invariant_holds_def rel_semi_def, blast)
    finally
    have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) ;;; Step C j \<subseteq> Step A j ;;; r \<inter> (I\<^sub>a \<times> I\<^sub>c)"
      by (simp add: rel_semi_def, blast)
  }
  ultimately show "fw_sim (r \<inter> I\<^sub>a \<times> I\<^sub>c) C A" using fin
    by (simp add: fw_sim_def)
qed

lemma weaken_LI:
  assumes LI: "LI A C R I'" and weaker: "I \<subseteq> I'" shows "LI A C R I"
proof -
  from weaker have step: "\<And>j. R \<inter> I ;;; Step C j \<subseteq> R \<inter> I' ;;; Step C j"
    by (fastforce simp: rel_semi_def relcomp_def)
  from weaker have fin: "\<And>S. S \<in> R \<inter> I \<Longrightarrow> S \<in> R \<inter> I'" by fastforce
  from subset_trans[OF step] fin LI show ?thesis  by (clarsimp simp: LI_def)
qed

lemma fw_sim_eq_LI: "fw_sim r C A = LI A C r UNIV"
  by (simp add: fw_sim_def LI_def)

lemma fw_sim_LI: "fw_sim r C A \<Longrightarrow> LI A C r I"
  by (simp add: fw_sim_eq_LI weaken_LI[where I'=UNIV])

lemma L_invariantI:
  assumes  "A \<Turnstile> I\<^sub>a" and "C \<Turnstile> I\<^sub>c" and "LI A C r (I\<^sub>a \<times> I\<^sub>c)"
  shows "C \<sqsubseteq>\<^sub>F A"
  using assms
  by (simp add: fw_simulates_def, rule_tac x="r \<inter> I\<^sub>a \<times> I\<^sub>c" in exI,
      simp add: LI_fw_sim)

lemma refinement_refl[simp]:
  "A \<sqsubseteq> A"
  by (simp add: refines_def)

lemma refinement_trans [trans]:
  "\<lbrakk>C \<sqsubseteq> B; B \<sqsubseteq> A\<rbrakk> \<Longrightarrow> C \<sqsubseteq> A"
  by (simp add: refines_def) blast

lemma fw_inv_transport:
  "\<lbrakk> A \<Turnstile> I\<^sub>a; C \<Turnstile> I\<^sub>c; LI A C R (I\<^sub>a \<times> I\<^sub>c) \<rbrakk> \<Longrightarrow> C \<Turnstile> {s'. \<exists>s. (s,s') \<in> R \<and> s \<in> I\<^sub>a \<and> s' \<in> I\<^sub>c}"
  apply (clarsimp simp: LI_def invariant_holds_def)
  apply (rule conjI)
   apply (rule allI)
   apply clarsimp
   apply (subgoal_tac "x \<in> (R `` Init A s)")
    prefer 2
    apply fastforce
   apply blast
  apply clarsimp
  apply (erule_tac x=j in allE)+
  apply (clarsimp simp: rel_semi_def)
  apply (subgoal_tac "(s,x) \<in> Step A j O R")
   prefer 2
   apply blast
  apply blast
  done

lemma fw_sim_refl:
  "fw_sim Id A A"
  apply (simp add: fw_sim_def rel_semi_def)
  done

lemma fw_simulates_refl[simp]:
  "A \<sqsubseteq>\<^sub>F A"
  apply (simp add: fw_simulates_def fw_sim_refl exI[where x="Id"])
  done

lemma fw_sim_trans:
  "\<lbrakk>fw_sim Q C B; fw_sim R B A\<rbrakk> \<Longrightarrow> fw_sim (R O Q) C A"
  by (auto simp: fw_sim_def rel_semi_def; blast)

lemma fw_simulates_trans:
  "\<lbrakk>C \<sqsubseteq>\<^sub>F B; B \<sqsubseteq>\<^sub>F A\<rbrakk> \<Longrightarrow> C \<sqsubseteq>\<^sub>F A"
  apply (auto simp: fw_simulates_def dest: fw_sim_trans)
  done

end