theory Refine_Foreach
imports NREST.NREST NREST.RefineMonadicVCG SepLogic_Misc
begin

text \<open>
  A common pattern for loop usage is iteration over the elements of a set.
  This theory provides the \<open>FOREACH\<close>-combinator, that iterates over
  each element of a set.
\<close>

subsection \<open>Auxilliary Lemmas\<close>
text \<open>The following lemma is commonly used when reasoning about iterator
  invariants.
  It helps converting the set of elements that remain to be iterated over to
  the set of elements already iterated over.\<close>
lemma it_step_insert_iff:
  "it \<subseteq> S \<Longrightarrow> x\<in>it \<Longrightarrow> S-(it-{x}) = insert x (S-it)" by auto

subsection \<open>Definition\<close>

text \<open>
  Foreach-loops come in different versions, depending on whether they have an
  annotated invariant (I), a termination condition (C), and an order (O).

  Note that asserting that the set is finite is not necessary to guarantee
  termination. However, we currently provide only iteration over finite sets,
  as this also matches the ICF concept of iterators.
\<close>

definition "FOREACH_body f \<equiv> \<lambda>(xs, \<sigma>). do {
  x \<leftarrow> RETURNT( hd xs); \<sigma>'\<leftarrow>f x \<sigma>; RETURNT (tl xs,\<sigma>')
  }"

definition FOREACH_cond where "FOREACH_cond c \<equiv> (\<lambda>(xs,\<sigma>). xs\<noteq>[] \<and> c \<sigma>)"

text \<open>Foreach with continuation condition, order and annotated invariant:\<close>

definition FOREACHoci ("FOREACH\<^sub>O\<^sub>C\<^bsup>_,_\<^esup>") where "FOREACHoci R \<Phi> S c f \<sigma>0 inittime body_time \<equiv> do {
  ASSERT (finite S);
  xs \<leftarrow> SPECT (emb (\<lambda>xs. distinct xs \<and> S = set xs \<and> sorted_wrt R xs) inittime);
  (_,\<sigma>) \<leftarrow> whileIET
    (\<lambda>(it,\<sigma>). \<exists>xs'. xs = xs' @ it \<and> \<Phi> (set it) \<sigma>) (\<lambda>(it,_). length it * body_time)  (FOREACH_cond c) (FOREACH_body f) (xs,\<sigma>0);
  RETURNT \<sigma> }"

text \<open>Foreach with continuation condition and annotated invariant:\<close>
definition FOREACHci ("FOREACH\<^sub>C\<^bsup>_\<^esup>") where "FOREACHci \<equiv> FOREACHoci (\<lambda>_ _. True)"

subsection \<open>Proof Rules\<close>
thm vcg_rules
lemma FOREACHoci_rule:
  assumes IP:
    "\<And>x it \<sigma>. \<lbrakk> c \<sigma>; x\<in>it; it\<subseteq>S; I it \<sigma>; \<forall>y\<in>it - {x}. R x y;
                \<forall>y\<in>S - it. R y x \<rbrakk> \<Longrightarrow> f x \<sigma> \<le> SPECT (emb (I (it-{x})) (enat body_time))"
  assumes FIN: "finite S"
  assumes I0: "I S \<sigma>0"
  assumes II1: "\<And>\<sigma>. \<lbrakk>I {} \<sigma>\<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes II2: "\<And>it \<sigma>. \<lbrakk> it\<noteq>{}; it\<subseteq>S; I it \<sigma>; \<not>c \<sigma>;
                         \<forall>x\<in>it. \<forall>y\<in>S - it. R y x \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes time_ub: "inittime + enat ((card S) * body_time) \<le> enat overall_time"
  assumes progress_f[progress_rules]: "\<And>a b. progress (f a b)"
  shows "FOREACHoci R I S c f \<sigma>0 inittime body_time \<le> SPECT (emb P (enat overall_time))"
  unfolding FOREACHoci_def
  apply(rule T_specifies_I)
  unfolding FOREACH_body_def FOREACH_cond_def
  apply(vcg'\<open>-\<close> rules:  IP[THEN T_specifies_rev,THEN T_conseq4]  )

  prefer 5 apply auto []
  subgoal using I0 by blast
  subgoal by blast
  subgoal by simp
  subgoal by auto
  subgoal by (metis distinct_append hd_Cons_tl remove1_tl set_remove1_eq sorted_wrt.simps(2) sorted_wrt_append)
  subgoal by (metis DiffD1 DiffD2 UnE list.set_sel(1) set_append sorted_wrt_append)
  subgoal apply (auto simp: Some_le_mm3_Some_conv Some_le_emb'_conv Some_eq_emb'_conv)
      subgoal by (metis append.assoc append.simps(2) append_Nil hd_Cons_tl)
      subgoal by (metis remove1_tl set_remove1_eq)
      subgoal by (simp add: diff_mult_distrib)
      done
  subgoal using time_ub II1 apply (auto simp: Some_le_mm3_Some_conv Some_le_emb'_conv Some_eq_emb'_conv
               )
    subgoal by (simp add: distinct_card)
    subgoal by (metis DiffD1 DiffD2 II2 Un_iff Un_upper2 sorted_wrt_append)
    subgoal by (metis DiffD1 DiffD2 II2 Un_iff sorted_wrt_append sup_ge2)
    subgoal by (metis add_mono diff_le_self distinct_append distinct_card dual_order.trans enat_ord_simps(1) length_append order_mono_setup.refl set_append)
    done
  subgoal by (fact FIN)
  done

lemma FOREACHci_rule :
  assumes IP:
    "\<And>x it \<sigma>. \<lbrakk> x\<in>it; it\<subseteq>S; I it \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> \<le> SPECT (emb (I (it-{x})) (enat body_time))"
  assumes II1: "\<And>\<sigma>. \<lbrakk>I {} \<sigma>\<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes II2: "\<And>it \<sigma>. \<lbrakk> it\<noteq>{}; it\<subseteq>S; I it \<sigma>; \<not>c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes FIN: "finite S"
  assumes I0: "I S \<sigma>0"
  assumes progress_f: "\<And>a b. progress (f a b)"
  assumes "inittime + enat (card S * body_time) \<le> enat overall_time"
  shows "FOREACHci I S c f \<sigma>0 inittime body_time  \<le> SPECT (emb P (enat overall_time))"
  unfolding FOREACHci_def
  by (rule FOREACHoci_rule) (simp_all add: assms)

(* ... *)

text \<open>We define a relation between distinct lists and sets.\<close>
definition [to_relAPP]: "list_set_rel R \<equiv> \<langle>R\<rangle>list_rel O br set distinct"

(*lemma list_set_rel_finite: "(succl, succ) \<in> \<langle>Id\<rangle>list_set_rel \<Longrightarrow> finite succ"
  sorry *)

(* ... *)

subsection \<open>Nres-Fold with Interruption (nfoldli)\<close>
text \<open>
  A foreach-loop can be conveniently expressed as an operation that converts
  the set to a list, followed by folding over the list.

  This representation is handy for automatic refinement, as the complex
  foreach-operation is expressed by two relatively simple operations.
\<close>

text \<open>We first define a fold-function in the nrest-monad\<close>
definition nfoldli where
  "nfoldli l c f s = RECT (\<lambda>D (l,s). (case l of
    [] \<Rightarrow> RETURNT s
    | x#ls \<Rightarrow> if c s then do { s\<leftarrow>f x s; D (ls, s)} else RETURNT s
  )) (l, s)"

lemma nfoldli_simps[simp]:
  "nfoldli [] c f s = RETURNT s"
  "nfoldli (x#ls) c f s =
    (if c s then do { s\<leftarrow>f x s; nfoldli ls c f s} else RETURNT s)"
  unfolding nfoldli_def by (subst RECT_unfold, refine_mono, auto split: nat.split)+

lemma param_nfoldli[param]:
  shows "(nfoldli,nfoldli) \<in>
    \<langle>Ra\<rangle>list_rel \<rightarrow> (Rb\<rightarrow>Id) \<rightarrow> (Ra\<rightarrow>Rb\<rightarrow>\<langle>Rb\<rangle>nrest_rel) \<rightarrow> Rb \<rightarrow> \<langle>Rb\<rangle>nrest_rel"
  apply (intro fun_relI)
proof goal_cases
  case (1 l l' c c' f f' s s')
  thus ?case
    apply (induct arbitrary: s s')
    apply (simp only: nfoldli_simps True_implies_equals)
    apply parametricity
    apply (simp only: nfoldli_simps True_implies_equals)
    apply (parametricity)
    done
qed

lemma nfoldli_no_ctd[simp]: "\<not>ctd s \<Longrightarrow> nfoldli l ctd f s = RETURNT s"
  by (cases l) auto

lemma nfoldli_append: "nfoldli (l1@l2) ctd f s = nfoldli l1 ctd f s \<bind> nfoldli l2 ctd f"
  by (induction l1 arbitrary: s) simp_all

lemma nfoldli_assert:
  assumes "set l \<subseteq> S"
  shows "nfoldli l c (\<lambda> x s. ASSERT (x \<in> S) \<then> f x s) s = nfoldli l c f s"
  using assms by (induction l arbitrary: s) (auto simp: pw_eq_iff refine_pw_simps)

lemmas nfoldli_assert' = nfoldli_assert[OF order.refl]

definition nfoldliIE :: "('d list \<Rightarrow> 'd list \<Rightarrow> 'a \<Rightarrow>  bool) \<Rightarrow> nat \<Rightarrow> 'd list \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('d \<Rightarrow> 'a \<Rightarrow> 'a nrest) \<Rightarrow> 'a \<Rightarrow> 'a nrest" where
  "nfoldliIE I E l c f s = nfoldli l c f s"

lemma nfoldliIE_rule':
  assumes IS: "\<And>x l1 l2 \<sigma>. \<lbrakk> l0=l1@x#l2; I l1 (x#l2) \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> \<le> SPECT (emb (I (l1@[x]) l2) (enat body_time))"
  assumes FNC: "\<And>l1 l2 \<sigma>. \<lbrakk> l0=l1@l2; I l1 l2 \<sigma>; \<not>c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes FC: "\<And>\<sigma>. \<lbrakk> I l0 [] \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "lr@l = l0 \<Longrightarrow> I lr l \<sigma> \<Longrightarrow> nfoldliIE I body_time l c f \<sigma> \<le> SPECT (emb P (body_time * length l))"
proof (induct l arbitrary: lr \<sigma>)
  case Nil
  then show ?case by (auto simp: nfoldliIE_def RETURNT_def le_fun_def  Some_le_emb'_conv dest!: FC)
next
  case (Cons a l)
  show ?case
    apply (auto simp add: nfoldliIE_def)
    subgoal
      apply(rule T_specifies_I)
      apply (vcg'\<open>-\<close> rules: IS[THEN T_specifies_rev  , THEN T_conseq4]
                            Cons(1)[unfolded nfoldliIE_def, THEN T_specifies_rev  , THEN T_conseq4])
      unfolding Some_eq_emb'_conv Some_le_emb'_conv
      using Cons(2,3) by auto
    subgoal
      apply(simp add: RETURNT_def le_fun_def Some_le_emb'_conv)
      apply(rule FNC) using Cons(2,3) by auto
    done
qed

lemma nfoldliIE_rule:
  assumes I0: "I [] l0 \<sigma>0"
  assumes IS: "\<And>x l1 l2 \<sigma>. \<lbrakk> l0=l1@x#l2; I l1 (x#l2) \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> \<le> SPECT (emb (I (l1@[x]) l2) (enat body_time))"
  assumes FNC: "\<And>l1 l2 \<sigma>. \<lbrakk> l0=l1@l2; I l1 l2 \<sigma>; \<not>c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes FC: "\<And>\<sigma>. \<lbrakk> I l0 [] \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes T: "(body_time * length l0) \<le> t"
  shows "nfoldliIE I body_time l0 c f \<sigma>0 \<le> SPECT (emb P t)"
proof -
  have "nfoldliIE I body_time l0 c f \<sigma>0 \<le> SPECT (emb P (body_time * length l0))"
     apply(rule nfoldliIE_rule'[where lr="[]"]) using assms by auto
  also have "\<dots> \<le> SPECT (emb P t)"
    apply(rule SPECT_ub) using T by (auto simp: le_fun_def)
  finally show ?thesis .
qed

lemma nfoldli_refine[refine]:
  assumes "(li, l) \<in> \<langle>S\<rangle>list_rel"
    and "(si, s) \<in> R"
    and CR: "(ci, c) \<in> R \<rightarrow> bool_rel"
    and [refine]: "\<And>xi x si s. \<lbrakk> (xi,x)\<in>S; (si,s)\<in>R; c s \<rbrakk> \<Longrightarrow> fi xi si \<le> \<Down>R (f x s)"
  shows "nfoldli li ci fi si \<le> \<Down> R (nfoldli l c f s)"
  using assms(1,2)
proof (induction arbitrary: si s rule: list_rel_induct)
  case Nil thus ?case by (simp add: RETURNT_refine)
next
  case (Cons xi x li l)
  note [refine] = Cons

  show ?case
    apply (simp add: RETURNT_refine  split del: if_split)
    apply refine_rcg
    using CR Cons.prems by (auto simp: RETURNT_refine  dest: fun_relD)
qed

thm nfoldliIE_rule[THEN T_specifies_rev, THEN T_conseq4,no_vars]

definition "nfoldliIE' I bt l0 f s0 = nfoldliIE I bt l0 (\<lambda>_. True) f s0"

lemma nfoldliIE'_rule:
  assumes
"\<And>x l1 l2 \<sigma>.
    l0 = l1 @ x # l2 \<Longrightarrow>
    I l1 (x # l2) \<sigma> \<Longrightarrow> Some 0 \<le> lst (f x \<sigma>) (emb (I (l1 @ [x]) l2) (enat body_time))"
"I [] l0 \<sigma>0"
"(\<And>\<sigma>. I l0 [] \<sigma> \<Longrightarrow> Some (t + enat (body_time * length l0)) \<le> Q \<sigma>)"
shows "Some t \<le> lst (nfoldliIE' I body_time l0 f \<sigma>0) Q"
  unfolding nfoldliIE'_def
  apply(rule nfoldliIE_rule[where P="I l0 []" and c="\<lambda>_. True" and t="body_time * length l0", THEN T_specifies_rev, THEN T_conseq4])
       apply fact
  subgoal
    apply(rule T_specifies_I) using  assms(1) by auto
  subgoal by auto
    apply simp
   apply simp
  subgoal
    unfolding Some_eq_emb'_conv
    using assms(3) by auto
  done

text \<open>We relate our fold-function to the while-loop that we used in
  the original definition of the foreach-loop\<close>
lemma nfoldli_while: "nfoldli l c f \<sigma>
          \<le>
         (whileIET I E
           (FOREACH_cond c) (FOREACH_body f) (l, \<sigma>) \<bind>
          (\<lambda>(_, \<sigma>). RETURNT \<sigma>))"
proof (induct l arbitrary: \<sigma>)
  case Nil thus ?case
    unfolding whileIET_def
     apply (subst whileT_unfold) by (auto simp: FOREACH_cond_def)
next
  case (Cons x ls)
  show ?case
  proof (cases "c \<sigma>")
    case False thus ?thesis
    unfolding whileIET_def
     apply (subst whileT_unfold)
      unfolding FOREACH_cond_def
      by simp
  next
    case [simp]: True
    from Cons show ?thesis
    unfolding whileIET_def
     apply (subst whileT_unfold)
      unfolding FOREACH_cond_def FOREACH_body_def
      apply clarsimp
      apply (rule  bindT_mono)
      apply simp_all
      done
  qed
qed

lemma rr: "l0 = l1 @ a \<Longrightarrow> a \<noteq> [] \<Longrightarrow> l0 = l1 @ hd a # tl a" by auto

lemma nfoldli_rule:
  assumes I0: "I [] l0 \<sigma>0"
  assumes IS: "\<And>x l1 l2 \<sigma>. \<lbrakk> l0=l1@x#l2; I l1 (x#l2) \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> \<le> SPECT (emb (I (l1@[x]) l2) (enat body_time))"
  assumes FNC: "\<And>l1 l2 \<sigma>. \<lbrakk> l0=l1@l2; I l1 l2 \<sigma>; \<not>c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes FC: "\<And>\<sigma>. \<lbrakk> I l0 [] \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes progressf: "\<And>x y. progress (f x y)"
  shows "nfoldli l0 c f \<sigma>0 \<le> SPECT (emb P (body_time * length l0))"
  apply (rule order_trans[OF nfoldli_while[
          where I="\<lambda>(l2,\<sigma>). \<exists>l1. l0=l1@l2 \<and> I l1 l2 \<sigma>" and E="\<lambda>(l2,\<sigma>). (length l2) * body_time"]])
  unfolding FOREACH_cond_def FOREACH_body_def
  apply(rule T_specifies_I)
  apply(vcg'_step \<open>clarsimp\<close>)
  subgoal  using I0 by auto
  subgoal
    apply(vcg'_step \<open>clarsimp\<close>)
    apply (elim exE conjE)
    subgoal for a b l1
      apply(vcg'_step \<open>clarsimp\<close> rules: IS[THEN T_specifies_rev , THEN T_conseq4 ])
         apply(rule rr) apply simp_all
      apply(auto simp add: Some_le_mm3_Some_conv emb_eq_Some_conv left_diff_distrib')
      apply(rule exI[where x="l1@[hd a]"]) by simp
    done
  subgoal (* progress *)
    supply progressf [progress_rules] by (progress \<open>clarsimp\<close>)
  subgoal
    apply(vcg' \<open>clarsimp\<close>)
    subgoal for a \<sigma>
      apply(cases "c \<sigma>")
      using FC  FNC  by(auto simp add: Some_le_emb'_conv  mult.commute)
    done
  done

definition "LIST_FOREACH' tsl c f \<sigma> \<equiv> do {xs \<leftarrow> tsl; nfoldli xs c f \<sigma>}"

text \<open>This constant is a placeholder to be converted to
  custom operations by pattern rules\<close>
definition "it_to_sorted_list R s to_sorted_list_time
  \<equiv> SPECT (emb (\<lambda>l. distinct l \<and> s = set l \<and> sorted_wrt R l) to_sorted_list_time)"

definition "LIST_FOREACH \<Phi> tsl c f \<sigma>0 bodytime \<equiv> do {
  xs \<leftarrow> tsl;
  (_,\<sigma>) \<leftarrow> whileIET (\<lambda>(it, \<sigma>). \<exists>xs'. xs = xs' @ it \<and> \<Phi> (set it) \<sigma>) (\<lambda>(it, \<sigma>). length it * bodytime)
    (FOREACH_cond c) (FOREACH_body f) (xs, \<sigma>0);
    RETURNT \<sigma>}"

lemma FOREACHoci_by_LIST_FOREACH:
  "FOREACHoci R \<Phi> S c f \<sigma>0 to_sorted_list_time bodytime = do {
    ASSERT (finite S);
    LIST_FOREACH \<Phi> (it_to_sorted_list R S to_sorted_list_time) c f \<sigma>0 bodytime
  }"
  unfolding OP_def FOREACHoci_def LIST_FOREACH_def it_to_sorted_list_def
  by simp
(*

lemma LFO_pre_refine: (* TODO: Generalize! *)
  assumes "(li,l)\<in>\<langle>A\<rangle>list_set_rel"
  assumes "(ci,c)\<in>R \<rightarrow> bool_rel"
  assumes "(fi,f)\<in>A\<rightarrow>R\<rightarrow>\<langle>R\<rangle>nrest_rel"
  assumes "(s0i,s0)\<in>R"
  shows "LIST_FOREACH' (RETURNT li) ci fi s0i \<le> \<Down>R (FOREACHci I l c f s0 0 body_time)"
proof -
  from assms(1) have [simp]: "finite l" by (auto simp: list_set_rel_def br_def)
  show ?thesis
    unfolding   FOREACHci_def unfolding FOREACHoci_by_LIST_FOREACH
    apply simp
    apply (rule LIST_FOREACH_autoref[param_fo, THEN nres_relD])
    using assms
    apply auto
    apply (auto simp: it_to_sorted_list_def nres_rel_def pw_le_iff refine_pw_simps
      list_set_rel_def br_def)
    done
qed
    *)

(*
lemma LFOci_refine: (* TODO: Generalize! *)
  assumes "(li,l)\<in>\<langle>A\<rangle>list_set_rel"
  assumes "\<And>s si. (si,s)\<in>R \<Longrightarrow> ci si \<longleftrightarrow> c s"
  assumes "\<And>x xi s si. \<lbrakk>(xi,x)\<in>A; (si,s)\<in>R\<rbrakk> \<Longrightarrow> fi xi si \<le> \<Down>R (f x s)"
  assumes "(s0i,s0)\<in>R"
  shows "nfoldli li ci fi s0i \<le> \<Down>R (FOREACHci I l c f s0 init_time body_time)"
(*
proof -
  from assms LFO_pre_refine[of li l A ci c R fi f s0i s0] show ?thesis
    unfolding fun_rel_def nres_rel_def LIST_FOREACH'_def
    apply (simp add: pw_le_iff refine_pw_simps)
    apply blast+
    done
qed
*)sorry
*)

end


(*  Title:      Sequents/S43.thy
    Author:     Martin Coen
    Copyright   1991  University of Cambridge

This implements Rajeev Gore's sequent calculus for S43.
*)

theory S43
imports Modal0
begin

consts
  S43pi :: "[seq'\<Rightarrow>seq', seq'\<Rightarrow>seq', seq'\<Rightarrow>seq',
             seq'\<Rightarrow>seq', seq'\<Rightarrow>seq', seq'\<Rightarrow>seq'] \<Rightarrow> prop"
syntax
  "_S43pi" :: "[seq, seq, seq, seq, seq, seq] \<Rightarrow> prop"
                         ("S43pi((_);(_);(_);(_);(_);(_))" [] 5)

parse_translation \<open>
  let
    val tr  = seq_tr;
    fun s43pi_tr [s1, s2, s3, s4, s5, s6] =
      Const (\<^const_syntax>\<open>S43pi\<close>, dummyT) $ tr s1 $ tr s2 $ tr s3 $ tr s4 $ tr s5 $ tr s6;
  in [(\<^syntax_const>\<open>_S43pi\<close>, K s43pi_tr)] end
\<close>

print_translation \<open>
let
  val tr' = seq_tr';
  fun s43pi_tr' [s1, s2, s3, s4, s5, s6] =
    Const(\<^syntax_const>\<open>_S43pi\<close>, dummyT) $ tr' s1 $ tr' s2 $ tr' s3 $ tr' s4 $ tr' s5 $ tr' s6;
in [(\<^const_syntax>\<open>S43pi\<close>, K s43pi_tr')] end
\<close>

axiomatization where
(* Definition of the star operation using a set of Horn clauses  *)
(* For system S43: gamma * == {[]P | []P : gamma}                *)
(*                 delta * == {<>P | <>P : delta}                *)

  lstar0:         "|L>" and
  lstar1:         "$G |L> $H \<Longrightarrow> []P, $G |L> []P, $H" and
  lstar2:         "$G |L> $H \<Longrightarrow>   P, $G |L>      $H" and
  rstar0:         "|R>" and
  rstar1:         "$G |R> $H \<Longrightarrow> <>P, $G |R> <>P, $H" and
  rstar2:         "$G |R> $H \<Longrightarrow>   P, $G |R>      $H" and

(* Set of Horn clauses to generate the antecedents for the S43 pi rule       *)
(* ie                                                                        *)
(*           S1...Sk,Sk+1...Sk+m                                             *)
(*     ----------------------------------                                    *)
(*     <>P1...<>Pk, $G \<turnstile> $H, []Q1...[]Qm                                    *)
(*                                                                           *)
(*  where Si == <>P1...<>Pi-1,<>Pi+1,..<>Pk,Pi, $G * \<turnstile> $H *, []Q1...[]Qm    *)
(*    and Sj == <>P1...<>Pk, $G * \<turnstile> $H *, []Q1...[]Qj-1,[]Qj+1...[]Qm,Qj    *)
(*    and 1<=i<=k and k<j<=k+m                                               *)

  S43pi0:         "S43pi $L;; $R;; $Lbox; $Rdia" and
  S43pi1:
   "\<lbrakk>(S43pi <>P,$L';     $L;; $R; $Lbox;$Rdia);   $L',P,$L,$Lbox \<turnstile> $R,$Rdia\<rbrakk> \<Longrightarrow>
       S43pi     $L'; <>P,$L;; $R; $Lbox;$Rdia" and
  S43pi2:
   "\<lbrakk>(S43pi $L';; []P,$R';     $R; $Lbox;$Rdia);  $L',$Lbox \<turnstile> $R',P,$R,$Rdia\<rbrakk> \<Longrightarrow>
       S43pi $L';;     $R'; []P,$R; $Lbox;$Rdia" and

(* Rules for [] and <> for S43 *)

  boxL:           "$E, P, $F, []P \<turnstile> $G \<Longrightarrow> $E, []P, $F \<turnstile> $G" and
  diaR:           "$E \<turnstile> $F, P, $G, <>P \<Longrightarrow> $E \<turnstile> $F, <>P, $G" and
  pi1:
   "\<lbrakk>$L1,<>P,$L2 |L> $Lbox;  $L1,<>P,$L2 |R> $Ldia;  $R |L> $Rbox;  $R |R> $Rdia;
      S43pi ; $Ldia;; $Rbox; $Lbox; $Rdia\<rbrakk> \<Longrightarrow>
   $L1, <>P, $L2 \<turnstile> $R" and
  pi2:
   "\<lbrakk>$L |L> $Lbox;  $L |R> $Ldia;  $R1,[]P,$R2 |L> $Rbox;  $R1,[]P,$R2 |R> $Rdia;
      S43pi ; $Ldia;; $Rbox; $Lbox; $Rdia\<rbrakk> \<Longrightarrow>
   $L \<turnstile> $R1, []P, $R2"

ML \<open>
structure S43_Prover = Modal_ProverFun
(
  val rewrite_rls = @{thms rewrite_rls}
  val safe_rls = @{thms safe_rls}
  val unsafe_rls = @{thms unsafe_rls} @ [@{thm pi1}, @{thm pi2}]
  val bound_rls = @{thms bound_rls} @ [@{thm boxL}, @{thm diaR}]
  val aside_rls = [@{thm lstar0}, @{thm lstar1}, @{thm lstar2}, @{thm rstar0},
    @{thm rstar1}, @{thm rstar2}, @{thm S43pi0}, @{thm S43pi1}, @{thm S43pi2}]
)
\<close>

method_setup S43_solve = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD
    (S43_Prover.solve_tac ctxt 2 ORELSE S43_Prover.solve_tac ctxt 3))
\<close>

(* Theorems of system T from Hughes and Cresswell and Hailpern, LNCS 129 *)

lemma "\<turnstile> []P \<longrightarrow> P" by S43_solve
lemma "\<turnstile> [](P \<longrightarrow> Q) \<longrightarrow> ([]P \<longrightarrow> []Q)" by S43_solve   (* normality*)
lemma "\<turnstile> (P--<Q) \<longrightarrow> []P \<longrightarrow> []Q" by S43_solve
lemma "\<turnstile> P \<longrightarrow> <>P" by S43_solve

lemma "\<turnstile>  [](P \<and> Q) \<longleftrightarrow> []P \<and> []Q" by S43_solve
lemma "\<turnstile>  <>(P \<or> Q) \<longleftrightarrow> <>P \<or> <>Q" by S43_solve
lemma "\<turnstile>  [](P \<longleftrightarrow> Q) \<longleftrightarrow> (P>-<Q)" by S43_solve
lemma "\<turnstile>  <>(P \<longrightarrow> Q) \<longleftrightarrow> ([]P \<longrightarrow> <>Q)" by S43_solve
lemma "\<turnstile>        []P \<longleftrightarrow> \<not> <>(\<not> P)" by S43_solve
lemma "\<turnstile>     [](\<not>P) \<longleftrightarrow> \<not> <>P" by S43_solve
lemma "\<turnstile>       \<not> []P \<longleftrightarrow> <>(\<not> P)" by S43_solve
lemma "\<turnstile>      [][]P \<longleftrightarrow> \<not> <><>(\<not> P)" by S43_solve
lemma "\<turnstile> \<not> <>(P \<or> Q) \<longleftrightarrow> \<not> <>P \<and> \<not> <>Q" by S43_solve

lemma "\<turnstile> []P \<or> []Q \<longrightarrow> [](P \<or> Q)" by S43_solve
lemma "\<turnstile> <>(P \<and> Q) \<longrightarrow> <>P \<and> <>Q" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> []P \<or> <>Q" by S43_solve
lemma "\<turnstile> <>P \<and> []Q \<longrightarrow> <>(P \<and> Q)" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> <>P \<or> []Q" by S43_solve
lemma "\<turnstile> <>(P \<longrightarrow> (Q \<and> R)) \<longrightarrow> ([]P \<longrightarrow> <>Q) \<and> ([]P \<longrightarrow> <>R)" by S43_solve
lemma "\<turnstile> (P --< Q) \<and> (Q --<R ) \<longrightarrow> (P --< R)" by S43_solve
lemma "\<turnstile> []P \<longrightarrow> <>Q \<longrightarrow> <>(P \<and> Q)" by S43_solve

(* Theorems of system S4 from Hughes and Cresswell, p.46 *)

lemma "\<turnstile> []A \<longrightarrow> A" by S43_solve             (* refexivity *)
lemma "\<turnstile> []A \<longrightarrow> [][]A" by S43_solve         (* transitivity *)
lemma "\<turnstile> []A \<longrightarrow> <>A" by S43_solve           (* seriality *)
lemma "\<turnstile> <>[](<>A \<longrightarrow> []<>A)" by S43_solve
lemma "\<turnstile> <>[](<>[]A \<longrightarrow> []A)" by S43_solve
lemma "\<turnstile> []P \<longleftrightarrow> [][]P" by S43_solve
lemma "\<turnstile> <>P \<longleftrightarrow> <><>P" by S43_solve
lemma "\<turnstile> <>[]<>P \<longrightarrow> <>P" by S43_solve
lemma "\<turnstile> []<>P \<longleftrightarrow> []<>[]<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longleftrightarrow> <>[]<>[]P" by S43_solve

(* Theorems for system S4 from Hughes and Cresswell, p.60 *)

lemma "\<turnstile> []P \<or> []Q \<longleftrightarrow> []([]P \<or> []Q)" by S43_solve
lemma "\<turnstile> ((P >-< Q) --< R) \<longrightarrow> ((P >-< Q) --< []R)" by S43_solve

(* These are from Hailpern, LNCS 129 *)

lemma "\<turnstile> [](P \<and> Q) \<longleftrightarrow> []P \<and> []Q" by S43_solve
lemma "\<turnstile> <>(P \<or> Q) \<longleftrightarrow> <>P \<or> <>Q" by S43_solve
lemma "\<turnstile> <>(P \<longrightarrow> Q) \<longleftrightarrow> ([]P \<longrightarrow> <>Q)" by S43_solve

lemma "\<turnstile> [](P \<longrightarrow> Q) \<longrightarrow> (<>P \<longrightarrow> <>Q)" by S43_solve
lemma "\<turnstile> []P \<longrightarrow> []<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longrightarrow> <>P" by S43_solve

lemma "\<turnstile> []P \<or> []Q \<longrightarrow> [](P \<or> Q)" by S43_solve
lemma "\<turnstile> <>(P \<and> Q) \<longrightarrow> <>P \<and> <>Q" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> []P \<or> <>Q" by S43_solve
lemma "\<turnstile> <>P \<and> []Q \<longrightarrow> <>(P \<and> Q)" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> <>P \<or> []Q" by S43_solve

(* Theorems of system S43 *)

lemma "\<turnstile> <>[]P \<longrightarrow> []<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longrightarrow> [][]<>P" by S43_solve
lemma "\<turnstile> [](<>P \<or> <>Q) \<longrightarrow> []<>P \<or> []<>Q" by S43_solve
lemma "\<turnstile> <>[]P \<and> <>[]Q \<longrightarrow> <>([]P \<and> []Q)" by S43_solve
lemma "\<turnstile> []([]P \<longrightarrow> []Q) \<or> []([]Q \<longrightarrow> []P)" by S43_solve
lemma "\<turnstile> [](<>P \<longrightarrow> <>Q) \<or> [](<>Q \<longrightarrow> <>P)" by S43_solve
lemma "\<turnstile> []([]P \<longrightarrow> Q) \<or> []([]Q \<longrightarrow> P)" by S43_solve
lemma "\<turnstile> [](P \<longrightarrow> <>Q) \<or> [](Q \<longrightarrow> <>P)" by S43_solve
lemma "\<turnstile> [](P \<longrightarrow> []Q \<longrightarrow> R) \<or> [](P \<or> ([]R \<longrightarrow> Q))" by S43_solve
lemma "\<turnstile> [](P \<or> (Q \<longrightarrow> <>C)) \<or> [](P \<longrightarrow> C \<longrightarrow> <>Q)" by S43_solve
lemma "\<turnstile> []([]P \<or> Q) \<and> [](P \<or> []Q) \<longrightarrow> []P \<or> []Q" by S43_solve
lemma "\<turnstile> <>P \<and> <>Q \<longrightarrow> <>(<>P \<and> Q) \<or> <>(P \<and> <>Q)" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<and> []([]P \<or> Q) \<and> [](P \<or> []Q) \<longrightarrow> []P \<or> []Q" by S43_solve
lemma "\<turnstile> <>P \<and> <>Q \<longrightarrow> <>(P \<and> Q) \<or> <>(<>P \<and> Q) \<or> <>(P \<and> <>Q)" by S43_solve
lemma "\<turnstile> <>[]<>P \<longleftrightarrow> []<>P" by S43_solve
lemma "\<turnstile> []<>[]P \<longleftrightarrow> <>[]P" by S43_solve

(* These are from Hailpern, LNCS 129 *)

lemma "\<turnstile> [](P \<and> Q) \<longleftrightarrow> []P \<and> []Q" by S43_solve
lemma "\<turnstile> <>(P \<or> Q) \<longleftrightarrow> <>P \<or> <>Q" by S43_solve
lemma "\<turnstile> <>(P \<longrightarrow> Q) \<longleftrightarrow> []P \<longrightarrow> <>Q" by S43_solve

lemma "\<turnstile> [](P \<longrightarrow> Q) \<longrightarrow> <>P \<longrightarrow> <>Q" by S43_solve
lemma "\<turnstile> []P \<longrightarrow> []<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longrightarrow> <>P" by S43_solve
lemma "\<turnstile> []<>[]P \<longrightarrow> []<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longrightarrow> <>[]<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longrightarrow> []<>P" by S43_solve
lemma "\<turnstile> []<>[]P \<longleftrightarrow> <>[]P" by S43_solve
lemma "\<turnstile> <>[]<>P \<longleftrightarrow> []<>P" by S43_solve

lemma "\<turnstile> []P \<or> []Q \<longrightarrow> [](P \<or> Q)" by S43_solve
lemma "\<turnstile> <>(P \<and> Q) \<longrightarrow> <>P \<and> <>Q" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> []P \<or> <>Q" by S43_solve
lemma "\<turnstile> <>P \<and> []Q \<longrightarrow> <>(P \<and> Q)" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> <>P \<or> []Q" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> []<>P \<or> []<>Q" by S43_solve
lemma "\<turnstile> <>[]P \<and> <>[]Q \<longrightarrow> <>(P \<and> Q)" by S43_solve
lemma "\<turnstile> <>[](P \<and> Q) \<longleftrightarrow> <>[]P \<and> <>[]Q" by S43_solve
lemma "\<turnstile> []<>(P \<or> Q) \<longleftrightarrow> []<>P \<or> []<>Q" by S43_solve

end


section "Linux Router"
theory Linux_Router
imports
	Routing_Table
	"../Simple_Firewall/SimpleFw_Semantics"
	"../Simple_Firewall/Simple_Packet"
	"~~/src/HOL/Library/Monad_Syntax"
begin

definition "fromMaybe a m = (case m of Some a \<Rightarrow> a | None \<Rightarrow> a)" (* mehr Haskell wagen *)

text\<open>Here, we present a heavily simplified model of a linux router.
(i.e., a linux-based device with \texttt{net.ipv4.ip\_forward})
It covers the following steps in packet processing:
\begin{itemize}
 \item Packet arrives (destination port is empty, destination mac address is own address).
 \item Destination address is extracted and used for a routing table lookup.
 \item Packet is updated with output interface of routing decision.
 \item The FORWARD chain of iptables is considered.
 \item Next hop is extracted from the routing decision, fallback to destination address if directly attached.
 \item MAC address of next hop is looked up (using the mac lookup function mlf)
 \item L2 destination address of packet is updated.
\end{itemize}
This is stripped down to model only the most important and widely used aspects of packet processing.
Here are a few examples of what was abstracted away:
\begin{itemize}
 \item No local traffic.
 \item Only the \texttt{filter} table of iptables is considered, \texttt{raw} and \texttt{nat} are not.
 \item Only one routing table is considered. (Linux can have other tables than the \texttt{default} one.)
 \item No source MAC modification.
 \item \ldots
\end{itemize}
\<close>

record interface =
	iface_name :: string
	iface_mac :: "48 word"
	(*iface_ips :: "(ipv4addr \<times> 32 prefix_match) set" (* there is a set of IP addresses and the reachable subnets for them *), but we don't use that right now, so it is commented out.
	Also, part of that information is already in the routing table, so careful here... *)

definition iface_packet_check ::  "interface list \<Rightarrow>('i::len,'b) simple_packet_ext_scheme \<Rightarrow> interface option"
where "iface_packet_check ifs p \<equiv> find (\<lambda>i. iface_name i = p_iiface p \<and> iface_mac i = p_l2dst p) ifs"
term simple_fw
definition simple_linux_router ::
  "'i routing_rule list \<Rightarrow> 'i simple_rule list \<Rightarrow> (('i::len) word \<Rightarrow> 48 word option) \<Rightarrow>
         interface list \<Rightarrow> 'i simple_packet_ext \<Rightarrow> 'i simple_packet_ext option" where
"simple_linux_router rt fw mlf ifl p \<equiv> do {
	_ \<leftarrow> iface_packet_check ifl p;
	let rd (* routing decision *) = routing_table_semantics rt (p_dst p);
	let p = p\<lparr>p_oiface := output_iface rd\<rparr>;
	let fd (* firewall decision *) = simple_fw fw p;
	_ \<leftarrow> (case fd of Decision FinalAllow \<Rightarrow> Some () | Decision FinalDeny \<Rightarrow> None);
	let nh = fromMaybe (p_dst p) (next_hop rd);
	ma \<leftarrow> mlf nh;
	Some (p\<lparr>p_l2dst := ma\<rparr>)
}"
(* Can I find something that looks a bit more semantic. Maybe the option monad can reduce a bit of the foo? *)
(* TODO: What happens in linux, if I send a packet to an interface with the mac of another interface? Hopefully, that is going to be dropped? *)

text\<open>However, the above model is still too powerful for some use-cases.
Especially, the next hop look-up cannot be done without either a pre-distributed table of all MAC addresses,
or the usual mechanic of sending out an ARP request and caching the answer.
Doing ARP requests in the restricted environment of, e.g., an OpenFlow ruleset seems impossible.
Therefore, we present this model:\<close>
definition simple_linux_router_nol12 ::
    "'i routing_rule list \<Rightarrow> 'i simple_rule list \<Rightarrow> ('i,'a) simple_packet_scheme \<Rightarrow> ('i::len,'a) simple_packet_scheme option" where
"simple_linux_router_nol12 rt fw p \<equiv> do {
	let rd = routing_table_semantics rt (p_dst p);
	let p = p\<lparr>p_oiface := output_iface rd\<rparr>;
	let fd = simple_fw fw p;
	_ \<leftarrow> (case fd of Decision FinalAllow \<Rightarrow> Some () | Decision FinalDeny \<Rightarrow> None);
	Some p
}"
text\<open>The differences to @{const simple_linux_router} are illustrated by the lemmata below.\<close>
(* an alternative formulation would maybe be "if the routing decision for the source is the same as for the destination, don't forward it."
   This might be advantageous in $cases, however, this formulation is clearly easier to translate to openflow. *)

lemma rtr_nomac_e1:
  fixes pi
	assumes "simple_linux_router rt fw mlf ifl pi = Some po"
	assumes "simple_linux_router_nol12 rt fw pi = Some po'"
	shows "\<exists>x. po = po'\<lparr>p_l2dst := x\<rparr>"
using assms
unfolding simple_linux_router_nol12_def simple_linux_router_def
by(simp add: Let_def split: option.splits state.splits final_decision.splits Option.bind_splits if_splits) blast+

lemma rtr_nomac_e2:
  fixes pi
	assumes "simple_linux_router rt fw mlf ifl pi = Some po"
	shows "\<exists>po'. simple_linux_router_nol12 rt fw pi = Some po'"
using assms
unfolding simple_linux_router_nol12_def simple_linux_router_def
by(clarsimp simp add: Let_def split: option.splits state.splits final_decision.splits Option.bind_splits if_splits)

lemma rtr_nomac_e3:
  fixes pi
	assumes "simple_linux_router_nol12 rt fw pi = Some po"
	assumes "iface_packet_check ifl pi = Some i(*don'tcare*)"
	assumes "mlf (fromMaybe (p_dst pi) (next_hop (routing_table_semantics rt (p_dst pi)))) = Some i2"
	shows "\<exists>po'. simple_linux_router rt fw mlf ifl pi = Some po'"
using assms
unfolding simple_linux_router_nol12_def simple_linux_router_def
by(clarsimp simp add: Let_def split: option.splits state.splits final_decision.splits Option.bind_splits if_splits)

lemma rtr_nomac_eq:
  fixes pi
	assumes "iface_packet_check ifl pi \<noteq> None"
	assumes "mlf (fromMaybe (p_dst pi) (next_hop (routing_table_semantics rt (p_dst pi)))) \<noteq> None"
	shows "\<exists>x. map_option (\<lambda>p. p\<lparr>p_l2dst := x\<rparr>) (simple_linux_router_nol12 rt fw pi) = simple_linux_router rt fw mlf ifl pi"
proof(cases "simple_linux_router_nol12 rt fw pi"; cases "simple_linux_router rt fw mlf ifl pi")
	fix a b
	assume as: "simple_linux_router rt fw mlf ifl pi = Some b" "simple_linux_router_nol12 rt fw pi = Some a"
	note rtr_nomac_e1[OF this]
	with as show ?thesis by auto
next
	fix a assume as: "simple_linux_router_nol12 rt fw pi = None" "simple_linux_router rt fw mlf ifl pi = Some a"
	note rtr_nomac_e2[OF as(2)]
	with as(1) have False by simp
	thus ?thesis ..
next
	fix a assume as: "simple_linux_router_nol12 rt fw pi = Some a" "simple_linux_router rt fw mlf ifl pi = None"
	from \<open>iface_packet_check ifl pi \<noteq> None\<close> obtain i3 where "iface_packet_check ifl pi = Some i3" by blast
	note rtr_nomac_e3[OF as(1) this] assms(2)
	with as(2) have False by force
	thus ?thesis ..
qed simp

end


theory Functions_FiniteSeq_E1
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"Ax1\", \"Ax2\", \"Ax3\", \"Ax4\", \"Ax5\", \"Ax6\", \"Ax7\",
     \"Ax8\", \"Ax9\", \"Ax10\", \"Ax11\", \"Ax12\", \"Ax13\", \"Ax14\",
     \"Ax15\", \"Ax1_1\", \"Ax2_1\", \"Ax3_1\"]"

typedecl ('a1) Seq

consts
X_all :: "(nat => 'S partial) => ('S => bool) => bool" ("all''/'(_,/ _')" [3,3] 999)
X_concat :: "(nat => 'S partial) * (nat => 'S partial) => nat => 'S partial"
X_empty :: "(nat => 'S partial) => bool" ("empty''/'(_')" [3] 999)
X_filter :: "(nat => 'S partial) => ('S => bool) => nat => 'S partial"
X_finite :: "(nat => 'S partial) => bool" ("finite''/'(_')" [3] 999)
X_head :: "(nat => 'S partial) => 'S partial" ("head/'(_')" [3] 999)
X_length :: "(nat => 'S partial) => nat partial" ("length''/'(_')" [3] 999)
X_max :: "nat => nat => nat" ("max''/'(_,/ _')" [3,3] 999)
X_minX1 :: "nat => nat => nat" ("min''/'(_,/ _')" [3,3] 999)
X_minX2 :: "(nat => bool) => nat partial" ("min''''/'(_')" [3] 999)
X_nfh :: "(nat => 'S partial) => 'S partial" ("nfh/'(_')" [3] 999)
X_start :: "(nat => 'S partial) => nat partial" ("start/'(_')" [3] 999)
nf :: "(nat => 'S partial) => nat => 'S partial"
nft :: "(nat => 'S partial) => nat => 'S partial"
tail :: "(nat => 'S partial) => nat => 'S partial"

axioms
Ax1 [rule_format] : "ALL Q. defOp (min''(Q)) --> (EX m. Q m)"

Ax2 [rule_format] :
"ALL Q.
 (EX m. Q m) -->
 min''(Q) =
 (if Q 0 then makePartial 0 else min''(% m. Q (m + 1)))"

Ax3 [rule_format] : "ALL s. start(s) = min''(% m. defOp (s m))"

Ax4 [rule_format] : "ALL s. head(s) = s 0"

Ax5 [rule_format] : "ALL s. tail s = (% x. s (x + 1))"

Ax6 [rule_format] : "ALL s. head(nf s) = nfh(s)"

Ax7 [rule_format] : "ALL s. tail (nf s) = nf (nft s)"

Ax8 [rule_format] :
"ALL P.
 ALL s.
 head(X_filter s P) =
 (resOp
  (head(s),
   bool2partial (defOp (head(s)) & P (makeTotal (head(s))))))"

Ax9 [rule_format] :
"ALL P. ALL s. tail (X_filter s P) = X_filter (tail s) P"
(*
Ax10 [rule_format] :
"ALL s.
 nfh(s) = lift2partial s (start(s))

Ax11 [rule_format] :
"ALL s.
 nft s =
 (% k.  lift2partial s (mapPartial (X__XPlus__X (k + 1)) (start(s))))

Ax12 [rule_format] :
"ALL s. finite'(s) = (EX X_n. ALL m. m > X_n --> ~ defOp (s m))"

Ax13 [rule_format] : "ALL s. empty'(s) = (ALL m. ~ defOp (s m))"

Ax14 [rule_format] :
"ALL s.
 ALL t.
 head(X_concat (s, t)) = (if ~ empty'(s) then head(s) else head(t))"

Ax15 [rule_format] :
"ALL s.
 ALL t.
 tail (X_concat (s, t)) =
 (if ~ empty'(s) then X_concat (tail s, t) else tail t)"
*)

declare Ax6 [simp]

theorem restrict1 : "restrictOp (restrictOp a (defOp b)) c = restrictOp (restrictOp a c) (defOp (restrictOp b c))"
apply (case_tac c)
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem restrict_trivial_rule[simp]: "b ==> restrictOp t b = t"
apply (simp add: restrictOp_def)
done

theorem restrict_trivial [simp]: "restrictOp t True = t"
apply (simp)
done

theorem restrict_assoc[simp] : "restrictOp a (defOp (restrictOp b c)) = restrictOp (restrictOp a (defOp b)) c"
apply (case_tac c)
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def noneOp_def defOp.simps)
sorry

theorem restrict_out[simp] : "restrictOp (t b) b = restrictOp (t True) b"
apply (case_tac "b")
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem mkpartial_cancel [simp]: "makeTotal(makePartial x) = x"
apply (simp add: makeTotal_def makePartial_def)
done

theorem mkpartial_cancel2 [simp]: "defOp(x) ==> makePartial(makeTotal x) = x"
apply (simp add: makeTotal_def makePartial_def)
apply (case_tac x)
apply (simp)
apply (simp)
done

theorem mkpartial_cancel3 [simp] : "((makePartial x) = (makePartial y)) = (x = y)"
apply (simp add: makePartial_def)
done

theorem defOp_trivial [simp]: "defOp(makePartial x) = True"
apply (simp add: makePartial_def makeTotal_def)
done

(* Some more stuff about removing extraneous restrictions *)

theorem total_restrict2 [simp]:
"(c ==> b) ==> restrictOp (t (makeTotal  (restrictOp a b))) c =
	   restrictOp (t (makeTotal a)) c"
apply (simp add: makeTotal_def restrictOp_def defOp.simps undefinedOp_def)
done

theorem def_restrict [simp]:
"defOp (restrictOp a b) = (defOp a & b)"
apply (simp add:  restrictOp_def defOp.simps undefinedOp_def split: split_if)
done

theorem total_restrict [simp]:
"restrictOp (t (makeTotal  (restrictOp a b))) (defOp (restrictOp a b)) =
	   restrictOp (t (makeTotal a)) (defOp a & b)"
apply simp
done

lemma restrictOp_cong [cong]:
  "b = b' ==> (b' ==> a = a') ==> restrictOp a b = restrictOp a' b'"
  apply (simp add: restrictOp_def defOp.simps undefinedOp_def)
done

lemma double_defop: "defOp(head(X_filter (X_filter a P) P)) = defOp(head(X_filter a P))"
apply (simp add: Ax8 resOp_def bool2partial_def)
apply (auto)
done

theorem defop_filter2: "((defOp (head(a))) & (P (makeTotal (head(a))))) = defOp(head(X_filter a P))"
apply (simp add: Ax8 bool2partial_def resOp_def lift2bool_def)
done

lemma double_filter_head[simp]: "head(X_filter (X_filter a P) P) = head(X_filter a P)"
(*apply (case_tac "defOp(a 0) & P(makeTotal (a 0))")*)
apply (simp add: Ax8 resOp_def bool2partial_def)
apply (simp add: defop_filter2 cong: conj_cong)
done

theorem coinduct: "[|R u v ==> (head(u)=head(v) & (R (tail u) (tail v)));  R u v|] ==> u=v"
apply (rule ext)
apply (induct_tac x)
sorry

theorem Ax2_1 :
"ALL P. ALL s. X_filter s P=X_filter (X_filter s P) P"
apply (auto)
apply (rule_tac R="(%x y. EX a. (x=X_filter a P) & y=(X_filter (X_filter a P) P))" in coinduct)
apply (auto)
apply (rule_tac x="tail a" in exI)
apply (simp add: Ax9)
done

theorem Ax1_1 :
"ALL P. ALL s. nf (X_filter s P) = X_filter (nf s) P"
by (auto)

ML "Header.record \"Ax1_1\""

ML "Header.record \"Ax2_1\""

theorem Ax3_1 : "ALL s. defOp (nfh(s)) = (~ empty'(s))"
by (auto)

ML "Header.record \"Ax3_1\""

end


theory Kaiserslautern
imports Main Smart_Isabelle.Smart_Isabelle
begin

primrec rev1::"'a list \<Rightarrow> 'a list" where
  "rev1  []      = []"
| "rev1 (x # xs) = rev1 xs @ [x]"

fun rev2::"'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "rev2  []      ys = ys"
| "rev2 (x # xs) ys = rev2 xs (x # ys)"

 theorem "rev2 xs ys = rev1 xs @ ys"
  apply(induct xs arbitrary: ys)
  apply auto done

strategy CDInd = Thens [Conjecture, Fastforce, Quickcheck,
                        Dynamic (Induct), Auto, IsSolved]

lemma assumes "True = True"
  shows "rev2 xs [] = rev1 xs"
  oops

end


(*  Title:      Code_Target_Bits_Int.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter {* Implementation of bit operations on int by target language operations *}

theory Code_Target_Bits_Int
imports
  "Bits_Integer"
  "~~/src/HOL/Library/Code_Target_Int"
begin

declare [[code drop:
  "bitAND :: int \<Rightarrow> _" "bitOR :: int \<Rightarrow> _" "bitXOR :: int \<Rightarrow> _" "bitNOT :: int \<Rightarrow> _"
  "lsb :: int \<Rightarrow> _" "set_bit :: int \<Rightarrow> _" "test_bit :: int \<Rightarrow> _"
  "shiftl :: int \<Rightarrow> _" "shiftr :: int \<Rightarrow> _"
  bin_last bin_rest bin_nth Bit
  int_of_integer_symbolic
  ]]

context
includes integer.lifting
begin

lemma bitAND_int_code [code]:
  "int_of_integer i AND int_of_integer j = int_of_integer (i AND j)"
by transfer simp

lemma bitOR_int_code [code]:
  "int_of_integer i OR int_of_integer j = int_of_integer (i OR j)"
by transfer simp

lemma bitXOR_int_code [code]:
  "int_of_integer i XOR int_of_integer j = int_of_integer (i XOR j)"
by transfer simp

lemma bitNOT_int_code [code]:
  "NOT (int_of_integer i) = int_of_integer (NOT i)"
by transfer simp

declare bin_last_conv_AND [code]

lemma bin_rest_code [code]:
   "bin_rest (int_of_integer i) = int_of_integer (bin_rest_integer i)"
by transfer simp

declare bitval_bin_last [code_unfold]

declare bin_nth_conv_AND [code]

lemma Bit_code [code]: "int_of_integer i BIT b = int_of_integer (Bit_integer i b)"
by transfer simp

lemma test_bit_int_code [code]: "int_of_integer x !! n = x !! n"
by transfer simp

lemma lsb_int_code [code]: "lsb (int_of_integer x) = lsb x"
by transfer simp

lemma set_bit_int_code [code]: "set_bit (int_of_integer x) n b = int_of_integer (set_bit x n b)"
by transfer simp

lemma shiftl_int_code [code]: "int_of_integer x << n = int_of_integer (x << n)"
by transfer simp

lemma shiftr_int_code [code]: "int_of_integer x >> n = int_of_integer (x >> n)"
by transfer simp

lemma int_of_integer_symbolic_code [code]:
  "int_of_integer_symbolic = int_of_integer"
by(simp add: int_of_integer_symbolic_def)

end

code_identifier code_module Code_Target_Bits_Int \<rightharpoonup>
  (SML) Bit_Int and (OCaml) Bit_Int and (Haskell) Bit_Int and (Scala) Bit_Int

end


theory PreferenceLogicCeterisParibus      (*** Benzmüller & Fuenmayor, 2020 ***)
  imports PreferenceLogicBasics
begin (** Ceteris Paribus reasoning by van Benthem, Girard and Roy, JPL 2009 **)

(*Section 5: Equality-based Ceteris Paribus Preference Logic*)
abbreviation a1::"\<sigma>\<Rightarrow>\<pi>\<Rightarrow>bool" ("_\<^bold>\<in>_") where "\<phi> \<^bold>\<in> \<Gamma> \<equiv> \<Gamma> \<phi>"
abbreviation a2 ("_\<^bold>\<subseteq>_") where "\<Gamma> \<^bold>\<subseteq> \<Gamma>' \<equiv> \<forall>\<phi>. \<phi> \<^bold>\<in> \<Gamma> \<longrightarrow> \<phi> \<^bold>\<in> \<Gamma>'"
abbreviation a3 ("_\<^bold>\<union>_") where "\<Gamma> \<^bold>\<union> \<Gamma>' \<equiv> \<lambda>\<phi>. \<phi> \<^bold>\<in> \<Gamma> \<or> \<phi> \<^bold>\<in> \<Gamma>'"
abbreviation a4 ("_\<^bold>\<inter>_") where "\<Gamma> \<^bold>\<inter> \<Gamma>' \<equiv> \<lambda>\<phi>. \<phi> \<^bold>\<in> \<Gamma> \<and> \<phi> \<^bold>\<in> \<Gamma>'"
abbreviation a5 ("\<^bold>{_\<^bold>}") where "\<^bold>{\<phi>\<^bold>} \<equiv> \<lambda>x::\<sigma>. x=\<phi>"
abbreviation a6 ("\<^bold>{_,_\<^bold>}")   where "\<^bold>{\<alpha>,\<beta>\<^bold>} \<equiv> \<lambda>x::\<sigma>. x=\<alpha> \<or> x=\<beta>"
abbreviation a7 ("\<^bold>{_,_,_\<^bold>}") where "\<^bold>{\<alpha>,\<beta>,\<gamma>\<^bold>} \<equiv> \<lambda>x::\<sigma>. x=\<alpha> \<or> x=\<beta> \<or> x=\<gamma>"
abbreviation a8 ("\<^bold>\<emptyset>")   where "\<^bold>\<emptyset> \<equiv> (\<lambda>\<psi>::\<sigma>. False)"
abbreviation a9 ("\<^bold>\<U>")   where "\<^bold>\<U> \<equiv> (\<lambda>\<psi>::\<sigma>. True)"

abbreviation c14 ("_\<^bold>\<equiv>\<^sub>__") where "w \<^bold>\<equiv>\<^sub>\<Gamma> v \<equiv> \<forall>\<phi>. \<phi> \<^bold>\<in> \<Gamma> \<longrightarrow> (\<phi> w \<longleftrightarrow> \<phi> v)"
abbreviation c15 ("_\<^bold>\<unlhd>\<^sub>__") where "w \<^bold>\<unlhd>\<^sub>\<Gamma> v \<equiv> w \<preceq> v \<and> w \<^bold>\<equiv>\<^sub>\<Gamma> v"
abbreviation c16 ("_\<^bold>\<lhd>\<^sub>__") where "w \<^bold>\<lhd>\<^sub>\<Gamma> v \<equiv> w \<prec> v \<and> w \<^bold>\<equiv>\<^sub>\<Gamma> v"
abbreviation c17 ("\<^bold>\<langle>_\<^bold>\<rangle>\<^sup>\<preceq>_") where "\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi> \<equiv> \<lambda>w.\<exists>v. w \<^bold>\<unlhd>\<^sub>\<Gamma> v \<and> \<phi> v"
abbreviation c18 ("[_]\<^sup>\<preceq>_") where "[\<Gamma>]\<^sup>\<preceq>\<phi> \<equiv> \<lambda>w.\<forall>v. w \<^bold>\<unlhd>\<^sub>\<Gamma> v \<longrightarrow> \<phi> v"
abbreviation c19 ("\<^bold>\<langle>_\<^bold>\<rangle>\<^sup>\<prec>_") where "\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi> \<equiv> \<lambda>w.\<exists>v. w \<^bold>\<lhd>\<^sub>\<Gamma> v \<and> \<phi> v"
abbreviation c20 ("[_]\<^sup>\<prec>_") where "[\<Gamma>]\<^sup>\<prec>\<phi> \<equiv> \<lambda>w.\<forall>v. w \<^bold>\<lhd>\<^sub>\<Gamma> v \<longrightarrow> \<phi> v"
abbreviation c21 ("\<^bold>\<langle>_\<^bold>\<rangle>_")  where "\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi> \<equiv> \<lambda>w.\<exists>v. w \<^bold>\<equiv>\<^sub>\<Gamma> v \<and> \<phi> v"
abbreviation c22 ("[_]_")  where "[\<Gamma>]\<phi> \<equiv> \<lambda>w.\<forall>v. w \<^bold>\<equiv>\<^sub>\<Gamma> v \<longrightarrow> \<phi> v"

(*Section 6: Ceteris Paribus Counterparts of Binary Pref. Statements*)
(*operators below are not defined in paper; existence is tacitly suggested.
  AA-variant draws upon von Wright's. AE-variant draws upon Halpern's.*)
abbreviation C23 ("_\<prec>\<^sub>A\<^sub>A\<^sup>__") where "(\<phi> \<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<equiv> \<forall>s.\<forall>t. \<phi> s \<and> \<psi> t \<longrightarrow> s \<^bold>\<lhd>\<^sub>\<Gamma> t"
abbreviation c24 ("_\<preceq>\<^sub>A\<^sub>A\<^sup>__") where "(\<phi> \<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<equiv> \<forall>s.\<forall>t. \<phi> s \<and> \<psi> t \<longrightarrow> s \<^bold>\<unlhd>\<^sub>\<Gamma> t"
abbreviation c25 ("_\<prec>\<^sub>A\<^sub>E\<^sup>__") where "(\<phi> \<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u \<equiv> \<forall>s.\<exists>t. \<phi> s \<longrightarrow> \<psi> t \<and> s \<^bold>\<lhd>\<^sub>\<Gamma> t"
abbreviation c26 ("_\<preceq>\<^sub>A\<^sub>E\<^sup>__") where "(\<phi> \<preceq>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u \<equiv> \<forall>s.\<exists>t. \<phi> s \<longrightarrow> \<psi> t \<and> s \<^bold>\<unlhd>\<^sub>\<Gamma> t"
abbreviation c27 ("_\<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>__") where "\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi> \<equiv> \<^bold>A(\<psi> \<^bold>\<rightarrow> [\<Gamma>]\<^sup>\<preceq>\<^bold>\<not>\<phi>)"
abbreviation c28 ("_\<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>__") where "\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi> \<equiv> \<^bold>A(\<psi> \<^bold>\<rightarrow> [\<Gamma>]\<^sup>\<prec>\<^bold>\<not>\<phi>)"
abbreviation c29 ("_\<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>__") where "\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi> \<equiv> \<^bold>A(\<phi> \<^bold>\<rightarrow> \<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<psi>)"
abbreviation c30 ("_\<^bold>\<preceq>\<^sub>A\<^sub>E\<^sup>__") where "\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi> \<equiv> \<^bold>A(\<phi> \<^bold>\<rightarrow> \<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<psi>)"

(*Consistency confirmed (trivial: essentially only abbreviations are introduced*)
lemma True nitpick[satisfy,user_axioms] oops
end

(*Lines 80--92: Except for $<^\Gamma$, the operators defined here are not
explicitly defined in the paper, but their existence is tacitly suggested.
$<^\Gamma$ aims at modelling von Wright's notion of ceteris paribus (``all
other things being equal'') preferences wrt. a set of formulas $\Gamma$
and it corresponds to $<_{AA}^\Sigma$ below, where $\Sigma=cp(\Gamma)$,
i.e., $\Sigma$ are the propositional atoms independent from (not occurring
in)  $\Gamma$, they are to be elicited by extra-logical means. Our variants
below can thus be understood as "these (given) things being equal"-preferences.*)


(*  Title:      SimpleMultiASP.thy
    Author:     Vincenzo Mastandrea Ludovic Henrio and Florian Kammuller
                2015

    Note:       Multi-active object formalisation
                1) One class
                2) No class filds and parameters
                3) Alowed passing future
*)

(*Conventions:
  x,y=varname
  locs = local variables
  Stl = statement list
  EContext is an execution context, ie a thread
  EcL = EContext list*)

header {* Syntax and Semantics *}

theory SimpleMultiASP imports Main AuxiliaryFunctions begin

subsection {* Syntax *}
type_synonym ItfName = string
type_synonym VarName =  string
type_synonym Variable = VarName
type_synonym ClassName = string
type_synonym MethodName = string

type_synonym ActName = nat
type_synonym FutName = nat

datatype Signature = Method ItfName MethodName  "(ItfName * VarName) list"
  (* signature = Method returnType MethodName (list of parameters)*)

datatype Value = null | ASPInt nat | ASPBool bool (* static values *)
                | ActRef ActName (* runtime values *)
                | FutRef FutName

(*
type_synonym  Object = "(VarName~=>Value) * ClassName"
abbreviation GetObject:: "Object \<Rightarrow>VarName=>Value option" ("_.[_]")
  where "GetObject ob x \<equiv> (fst ob) x"
abbreviation SetObject:: "Object \<Rightarrow>VarName=>Value\<Rightarrow>Object" ("_.[_]:=_")
  where "SetObject ob x v\<equiv> ((fst ob)(x\<mapsto>v),snd ob)"
*)

datatype Expression = Val Value
             | Var Variable
             | Plus Expression Expression ("_+\<^sub>A_" [120,120] 200)
             | And Expression Expression ("_&\<^sub>A_" [100,100] 300)
             | Test Expression Expression ("_==\<^sub>A_" [100,100] 300)

datatype Rhs = Expr Expression
             | Call Expression MethodName "Expression list" ("_.\<^sub>A_'(_')" [440,0,50] 500) (*e.m(e list) *)
             | Hole (* runtime term *)

datatype Statement =  Assign VarName Rhs  (infix "=\<^sub>A"  400) (*x=z*)
| NewActive VarName ("_ =\<^sub>A newActive'(')" [300] 300)
| Return Expression ("return _" [300] 300)(*return E *)
| If Expression "Statement list" "Statement list" ("IF _ THEN _ ELSE _ " [300,0,0] 300)(*if E then s else s *)
(* skip |  NB: skip and seq are not necessary thanks to the use of statement list
| Seq Statement Statement (infix ";;"  100)*)

abbreviation MakeStatementList:: "Statement \<Rightarrow>Statement list\<Rightarrow>Statement list" (infix ";;" 100)
  where "MakeStatementList s Stl\<equiv> s#Stl"
abbreviation MakeStatementList2:: "Statement \<Rightarrow>Statement\<Rightarrow>Statement list" (infix ";;;" 80)
  where "MakeStatementList2 s s'\<equiv> s#[s']"

record Method =
MethSignature:: Signature
LocalVariables::"(ItfName * VarName) list"
Body::"Statement list"
(*MethDefinition methodname (local variables) body*)

abbreviation MName:: "Method \<Rightarrow> MethodName"
where "MName m \<equiv> case (MethSignature m) of
        (Method returnType MethName listparameters) \<Rightarrow>MethName"

abbreviation MRType:: "Method \<Rightarrow> ItfName"
where "MRType m \<equiv> case (MethSignature m) of
        (Method returnType MethName listparameters) \<Rightarrow>returnType"

abbreviation MParams:: "Method \<Rightarrow>(ItfName * VarName) list"
where "MParams m \<equiv> case (MethSignature m) of
        (Method returnType MethName listparameters) \<Rightarrow>listparameters"

record Class =
 Name::ClassName
 Methods::"(Method list)"
             (*ASPclass (listofmethodbodies) *)

datatype Program = Prog Class "(ItfName * VarName) list" "Statement list"

type_synonym EContext = "(VarName~=>Value) * (Statement list)"
                         (*{l|s} execution context = location of this, local variables, and statements *)

type_synonym Request = "FutName * MethodName * (Value list)" (*q ::= (f,m,\<^bold>v) *)

abbreviation EC_locs:: "EContext \<Rightarrow>(VarName~=>Value)"
where "EC_locs Ec \<equiv> fst Ec"

abbreviation EC_Stl:: "EContext \<Rightarrow>Statement list"
where "EC_Stl Ec \<equiv> snd Ec"
(*datatype Process = Proc Request "Context list" *)

datatype ActiveObject = AO "Request~=>EContext" "Request list"
    (* active object location , store, task list, request queue*)

datatype FutValue = Undefined | FutVal Value

datatype Configuration = Cn "ActName~=>ActiveObject" "FutName~=>FutValue"

subsection {*finite configuration *}
definition finite_Processes :: "(Request~=>EContext) \<Rightarrow> bool"
  where
    "finite_Processes (processMap) \<equiv> finite (dom (processMap)) \<and>
       (\<forall> cont\<in>ran(processMap). finite (dom(EC_locs(cont))))"

primrec finite_Configuration :: "Configuration => bool"
  where
 " finite_Configuration (Cn AOs Futures) =
      (finite (dom AOs) \<and> finite (dom Futures) \<and>
      (\<forall> ao\<in>(ran AOs). \<forall> P Q. ao = AO P Q \<longrightarrow> finite_Processes P))"

declare SimpleMultiASP.finite_Configuration.simps[simp del]

text{* Binding and fetching elements *}
definition fetchClass
where
"fetchClass P \<equiv>
case P of (Prog C Vars Stl) \<Rightarrow> C
"

definition fetchMethodInClass
where
"fetchMethodInClass class m \<equiv>
Option.bind
(List.find (\<lambda>method. (MName method = m)) (Methods class))
(\<lambda>method. Some (map snd (MParams method), map snd (LocalVariables method), Body method))
"

abbreviation DefinedClassNames
where "DefinedClassNames prog \<equiv> (case prog of Prog C vl xtl \<Rightarrow>Name C)"

definition Bind::"Program\<Rightarrow>MethodName\<Rightarrow>Value list\<Rightarrow> EContext option"
where
 "Bind P m value_list\<equiv>
(case  fetchMethodInClass (fetchClass P) m  of
       Some (param_list,locs,b) \<Rightarrow>
         if length param_list = length value_list then
           ( let locales=  (map_of (zip locs (replicate (length locs) null)))
                    ++ (map_of (zip param_list value_list)) in
                Some (locales,b))
           else None
       | None \<Rightarrow> None)
"

(* semantics parameterized by compatibility and binder function*)
axiomatization
  Compatible :: "(Request * Request) set"
where
  symmetric_compatible: "sym Compatible"

lemma COMP[rule_format]: "\<forall>x y. (x,y)\<in>Compatible\<longrightarrow>(y,x)\<in>Compatible"
apply (fold sym_def)
apply (rule symmetric_compatible)
done

section{*SOS*}

inductive_set EvalValue:: "(Value \<times> Value) set"
where
  Valnull[simp,intro]: "(null, null)\<in>EvalValue"              |
  Valint[simp,intro]:  "(ASPInt i, (ASPInt i) )\<in>EvalValue"   |
  valbool[simp,intro]: "(ASPBool b, (ASPBool b) )\<in>EvalValue" |
  valact[simp,intro]:  "(ActRef \<alpha>, (ActRef \<alpha>) )\<in>EvalValue"   |
  valfut[simp,intro]:  "(FutRef f, (FutRef f) )\<in>EvalValue"

lemma EvalValue_is_deterministic[rule_format,intro]: "(e,v)\<in>EvalValue \<longrightarrow>(e,v')\<in>EvalValue \<longrightarrow>v=v'"
apply (rule impI)
apply auto
apply (erule EvalValue.cases,simp+)+
done

inductive_set EvalExpr:: "(Expression \<times> (VarName~=>Value) \<times> Value) set"
(* (e1,locs,v) is true if e1 EVALUATES to v  in a setting where local variables are locs*)
 where
   exprval [simp,intro]:  "(v,ev)\<in>EvalValue \<Longrightarrow>(Val v, locs, ev)\<in>EvalExpr"                   |
   exprlocs[simp,intro]:  "\<lbrakk>locs(x)=Some v;(v,ev)\<in>EvalValue\<rbrakk> \<Longrightarrow>(Var (x), locs, ev)\<in>EvalExpr" |
   expradd [simp,intro]:  "\<lbrakk>(e,locs,ASPInt i)\<in>EvalExpr;(e',locs, ASPInt i')\<in>EvalExpr\<rbrakk>
                      \<Longrightarrow>(e +\<^sub>A e', locs, ASPInt (i+i'))\<in>EvalExpr"                             |
   exprand [simp,intro]:  "\<lbrakk>(e,locs,ASPBool b)\<in>EvalExpr;(e',locs,ASPBool b')\<in>EvalExpr\<rbrakk>
                      \<Longrightarrow>(e &\<^sub>A e', locs, ASPBool (b\<and>b'))\<in>EvalExpr"                            |
   exprtest[simp,intro]:  "\<lbrakk>(e,locs,ASPInt i)\<in>EvalExpr;(e',locs,ASPInt i')\<in>EvalExpr\<rbrakk>
                      \<Longrightarrow>(e ==\<^sub>A e', locs, ASPBool (i=i'))\<in>EvalExpr"

lemma EvalExpr_is_deterministic[rule_format]:
      " (e,locs,v)\<in>EvalExpr \<longrightarrow> (\<forall> v'. (e,locs,v')\<in>EvalExpr \<longrightarrow>v=v')"
apply (rule impI)
apply (erule EvalExpr.induct)
apply (auto)
apply (erule EvalExpr.cases)
apply (auto)
apply (erule EvalExpr.cases)
apply (auto)
apply (erule_tac ?a1.0="e+\<^sub>Ae'"  in EvalExpr.cases,auto)
apply (erule_tac ?a1.0="e&\<^sub>Ae'"  in EvalExpr.cases,auto)
apply (erule_tac ?a1.0="e==\<^sub>Ae'" in EvalExpr.cases,auto)
done

abbreviation Ready:: "Request\<Rightarrow>(Request~=>EContext)\<Rightarrow>(Request list)\<Rightarrow>bool"
 (*Ready q,p,Rq returns true if q is ready to be served*)
where
 "Ready R tasks Rq \<equiv>(\<forall> Q\<in>dom(tasks). (R,Q)\<in>Compatible)
                     \<and> (\<forall> Q\<in>set Rq. (R,Q)\<in>Compatible)"

inductive reduction :: "Program\<Rightarrow>[Configuration, Configuration] => bool"  ("_\<turnstile>_\<leadsto>_" 50)
  where
    Serve [simp, intro!]:
      "\<lbrakk>(Activities \<alpha>) = Some (AO tasks (Rq@R#Rq')) ; R=(f,m,vl);
        Ready R tasks Rq;
        Bind P m vl = Some EC\<rbrakk>
          \<Longrightarrow> P\<turnstile>Cn Activities Futures
                \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO (tasks(R\<mapsto>EC))) (Rq@Rq'))) Futures" |

    AssignLocal  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO tasks Rq);
       tasks Q = Some ((locs,(x=\<^sub>AExpr e);;Stl));
       x\<in>dom locs ; (e,locs, v)\<in>EvalExpr
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO (tasks(Q\<mapsto>(locs(x\<mapsto>v),Stl))) Rq)))  Futures" |

     NewActive  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO tasks Rq);
       tasks Q = Some (locs,x =\<^sub>A newActive();;Stl);
       \<gamma>\<notin>dom Activities
      \<rbrakk>
        \<Longrightarrow> P\<turnstile>Cn Activities Futures
             \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO (tasks(Q\<mapsto>(locs,x=\<^sub>AExpr (Val (ActRef \<gamma>));;Stl))) Rq))
                             (\<gamma>\<mapsto> (AO empty [])))  Futures" |

   InvkActive  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO tasks Rq);
       Activities \<beta> = Some (AO tasks\<^sub>\<beta> Rq\<^sub>\<beta>);
       tasks Q = Some (locs,x=\<^sub>A(e.\<^sub>Am(el));;Stl);
       \<alpha>\<noteq>\<beta>;
       (e,locs,ActRef \<beta>)\<in>EvalExpr;
       f\<notin>dom Futures;
       length value_list = length el;
       \<forall> i<length value_list . ((el!i,locs,value_list!i)\<in>EvalExpr)
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO (tasks(Q\<mapsto>(locs,x=\<^sub>AExpr (Val (FutRef f));;Stl))) Rq)
                          (\<beta>\<mapsto> AO tasks\<^sub>\<beta> (Rq\<^sub>\<beta>@[(f,m,value_list)]) ))
               (Futures(f\<mapsto>Undefined))" |

   InvkActive_Self  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO tasks Rq);
       tasks Q = Some (locs,x=\<^sub>A(e.\<^sub>Am(el));;Stl);
       (e,locs,ActRef \<alpha>)\<in>EvalExpr;
       f\<notin>dom Futures;
       length value_list = length el;
       \<forall> i<length value_list . ((el!i,locs,value_list!i)\<in>EvalExpr)
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO (tasks(Q\<mapsto>(locs,x=\<^sub>AExpr (Val (FutRef f));;Stl))) (Rq@[(f,m,value_list)])))
               (Futures(f\<mapsto>Undefined))" |

   ReturnRequest [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO tasks Rq);
       tasks Q = Some (locs,return e;;Stl);   Q=(f,m,vl);
       (e,locs,v)\<in>EvalExpr
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO (tasks|``Q) Rq) ) (Futures(f\<mapsto>FutVal v ))" |

    UpdateFuture [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO tasks Rq);
       tasks Q = Some (locs,Stl);   Q=(f,m,vl);
       locs x = Some (FutRef f);
       Futures f = Some (FutVal v )
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO (tasks(Q\<mapsto>(locs(x\<mapsto>v),Stl))) Rq)) Futures"   |

    IfThenElseTrue [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO tasks Rq);
       tasks Q = Some (locs,(IF e THEN s\<^sub>t ELSE s\<^sub>e);;Stl);
       (e,locs,ASPBool True)\<in>EvalExpr
   \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO (tasks(Q\<mapsto>(locs,s\<^sub>t@Stl))) Rq))) Futures"  |

    IfThenElseFalse [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO tasks Rq);
       tasks Q = Some (locs,(IF e THEN s\<^sub>t ELSE s\<^sub>e);;Stl);
       (e,locs,ASPBool False)\<in>EvalExpr
   \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO (tasks(Q\<mapsto>(locs,s\<^sub>e@Stl))) Rq))) Futures"

definition emptyObjClass  where
"emptyObjClass \<equiv>
\<lparr> Name = ''EmptyObjectClass'',
  Methods=[]
\<rparr>"

definition BuildInitialConfigurationfromVarsStl:: "(VarName list) \<Rightarrow>Statement list\<Rightarrow> Configuration"
where
  "BuildInitialConfigurationfromVarsStl vl stl \<equiv> Cn (empty(0\<mapsto>(AO
                  (empty((0,''m'',[])\<mapsto>((map_of (zip vl (replicate (length vl) null))),stl))) [])))
                  (empty(0\<mapsto>Undefined))"

definition InitialConfiguration:: "Program \<Rightarrow>Configuration"
where
" InitialConfiguration prog \<equiv> case prog of (Prog C Vars Stl) \<Rightarrow> BuildInitialConfigurationfromVarsStl (map snd Vars) Stl"

end


theory Ex_CFG
imports "../lib/Monad"
begin
  text \<open>
    Small demonstrator for CFG semantics by "writing" an interpreter
    in a nontermination-error monad.

    Includes syntactic well-formedness check and proof that well-formed programs
    do not go wrong.
  \<close>

  datatype err = STATIC_ERROR

  type_synonym state = "string \<Rightarrow> int"
  type_synonym label = string
  type_synonym proc_name = string
  type_synonym val = "int"

  datatype nt_instr = I_BASIC "state \<Rightarrow> state" | I_CALL proc_name

  datatype t_instr = TI_RETURN | TI_BR label | TI_CBR "state\<Rightarrow>bool" label label

  datatype bblock = BBLOCK (nt_instrs: "nt_instr list") (t_instr: "t_instr")

  type_synonym proc_body = "label \<rightharpoonup> bblock"
  type_synonym prog = "proc_name \<rightharpoonup> proc_body"

  context
    fixes \<pi> :: prog
  begin

    context
      fixes execute :: "proc_body \<times> label \<Rightarrow> (unit,unit,state,err) M"
    begin

      definition "exec_nt_instr ins \<equiv> case ins of
        I_BASIC f \<Rightarrow> doM { s\<leftarrow>Monad.get; Monad.set (f s)}
      | I_CALL p \<Rightarrow> doM {
          \<beta> \<leftarrow> lookup STATIC_ERROR \<pi> p;
          handle (doM {execute (\<beta>,''__start''); fail STATIC_ERROR}) (\<lambda>_. return ());
          return ()
        }"

      fun exec_t_instr where
        "exec_t_instr (TI_RETURN) = doM {
          raise ()
        }"
      | "exec_t_instr (TI_BR l) = return l"
      | "exec_t_instr (TI_CBR c l1 l2) = doM {
          s\<leftarrow>Monad.get;
          if c s then return l1 else return l2
      }"

      definition "execute_body \<equiv> \<lambda>(\<beta>,l). doM {
        bb \<leftarrow> lookup STATIC_ERROR \<beta> l;
        mfold' exec_nt_instr (nt_instrs bb);
        l \<leftarrow> exec_t_instr (t_instr bb);
        execute (\<beta>,l)
      }"
    end

    definition "execute \<equiv> REC execute_body"

    lemma mono_mfold[partial_function_mono]:
      "\<lbrakk>\<And>x s. M.mono_body (\<lambda>f. F f x s)\<rbrakk> \<Longrightarrow> M.mono_body (\<lambda>f. mfold (F f) xs s)"
      apply (induction xs arbitrary: s)
      apply simp_all
      apply pf_mono_prover
      apply pf_mono_prover
      apply simp_all
      done

    lemma mono_exec_ntinstr[partial_function_mono]: "M.mono_body (\<lambda>f. local.exec_nt_instr f ins)"
      by (cases ins; simp add: exec_nt_instr_def; pf_mono_prover)

    lemma mono_execute_body[partial_function_mono]: "\<And>x. M.mono_body (\<lambda>fa. local.execute_body fa x)"
      unfolding execute_body_def
      by pf_mono_prover

  end

  lemmas
        execute_unfold[code] = REC_unfold[OF execute_def, discharge_monos]
    and execute_partial = lrmwpe_REC_partial[OF execute_def, discharge_monos, consumes 1, case_names nonterm step]
    and execute_total = lrmwpe_REC_total[OF execute_def, discharge_monos, consumes 1, case_names wf step]
    and execute_sim[sim_rules] = sim_REC[OF execute_def execute_def, discharge_monos]

  term execute

  thm sim_rules

  lemma execute_sm_sim[sim_rules]:
    assumes "\<pi> \<subseteq>\<^sub>m \<pi>'"
    shows "sim (execute \<pi> \<beta>l) (execute \<pi>' \<beta>l)"
    using assms
    by (auto intro!: sim_rules split!: nt_instr.split simp: execute_body_def exec_nt_instr_def)

  fun wf_nt_instr where
    "wf_nt_instr \<pi> (I_BASIC f) \<longleftrightarrow> True"
  | "wf_nt_instr \<pi> (I_CALL p) \<longleftrightarrow> p\<in>dom \<pi>"

  fun wf_t_instr where
    "wf_t_instr \<pi> \<beta> (TI_RETURN) \<longleftrightarrow> True"
  | "wf_t_instr \<pi> \<beta> (TI_BR l) \<longleftrightarrow> l\<in>dom \<beta>"
  | "wf_t_instr \<pi> \<beta> (TI_CBR c l1 l2) \<longleftrightarrow> l1\<in>dom \<beta> \<and> l2\<in>dom \<beta>"

  fun wf_basic_block where
    "wf_basic_block \<pi> \<beta> (BBLOCK ntis ti) \<longleftrightarrow> (\<forall>nti\<in>List.set ntis. wf_nt_instr \<pi> nti) \<and> wf_t_instr \<pi> \<beta> ti"

  definition "wf_proc_body \<pi> b \<equiv> ''__start''\<in>dom b \<and> (\<forall>bb\<in>ran b. wf_basic_block \<pi> b bb)"

  definition "wf_prog \<pi> \<equiv> \<forall>b\<in>ran \<pi>. wf_proc_body \<pi> b"

  definition "wf_pos \<pi> \<equiv> \<lambda>(\<beta>,l). \<beta> \<in> ran \<pi> \<and> l\<in>dom \<beta>"

  lemma
    assumes "run (execute \<pi> \<beta>l) s = r"
    assumes "wf_pos \<pi> \<beta>l"
    assumes "wf_prog \<pi>"
    shows "mwp r True bot top bot"
    using assms(1,2)
  proof (induction rule: execute_partial)
    case (nonterm x s)
    then show ?case by simp
  next
    case (step f x s r)

    note step.IH[OF refl, THEN mwp_cons, intro!]

    obtain \<beta> l where [simp]: "x = (\<beta>,l)" by (cases x)
    with \<open>wf_pos \<pi> x\<close> obtain ntis ti where [simp]: "\<beta> l = Some (BBLOCK ntis ti)" and "\<beta>\<in>ran \<pi>"
      apply (auto simp: wf_pos_def)
      using bblock.exhaust by blast

    have [THEN mwp_cons, intro!]:
      "mwp (run (exec_nt_instr \<pi> f i) s) top bot bot top" if "wf_nt_instr \<pi> i" for i s
      using that
      apply (auto simp: run_simps exec_nt_instr_def split: nt_instr.splits option.split)
      using assms(3)
      by (auto simp: wf_pos_def ranI wf_prog_def wf_proc_body_def)

    from \<open>wf_prog \<pi>\<close> \<open>\<beta>\<in>ran \<pi>\<close> have "wf_basic_block \<pi> \<beta> (BBLOCK ntis ti)"
      unfolding wf_prog_def wf_proc_body_def apply (auto)
      apply (meson \<open>\<beta> l = Some (BBLOCK ntis ti)\<close> ranI wf_basic_block.simps)
      apply (meson \<open>\<beta> l = Some (BBLOCK ntis ti)\<close> ranI wf_basic_block.simps)
      done
    hence WF_NTI: "(\<forall>nti\<in>List.set ntis. wf_nt_instr \<pi> nti)"
      and WF_TI: "wf_t_instr \<pi> \<beta> ti" by simp_all

    from WF_NTI have [THEN mwp_cons, intro!]:
      "mwp (run (mfold' (exec_nt_instr \<pi> f) ntis) s) top bot bot top"
      apply (induction ntis arbitrary: s)
      by (auto simp: run_simps)

    from WF_TI have [THEN mwp_cons, intro!]: "mwp (run (exec_t_instr ti) s) top bot top (\<lambda>l _. l\<in>dom \<beta>)" for s
      apply (cases ti)
      apply (auto simp: run_simps)
      done

    from step.hyps step.prems show ?case
      by (auto simp: execute_body_def run_simps wf_pos_def split: prod.splits option.splits)

  qed

end


(*
 * Copyright 2014, NICTA
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "32-Bit Machine Word Setup"

theory Machine_Word_32
  imports Machine_Word_32_Basics More_Word Bit_Shifts_Infix_Syntax Rsplit
begin

context
  includes bit_operations_syntax
begin

type_synonym machine_word = \<open>machine_word_len word\<close>

lemma word_bits_len_of:
  \<open>LENGTH(machine_word_len) = word_bits\<close>
  by (simp add: word_bits_conv)

lemma word_bits_size:
  "size (w :: machine_word) = word_bits"
  by (simp add: word_bits_def word_size)

lemma word_bits_word_size_conv:
  \<open>word_bits = word_size * 8\<close>
  by (simp add: word_bits_def word_size_def)

lemma word_size_word_size_bits:
  \<open>word_size = (2 :: 'a :: semiring_1) ^ word_size_bits\<close>
  by (simp add: word_size_def word_size_bits_def)

lemma lt_word_bits_lt_pow:
  "sz < word_bits \<Longrightarrow> sz < 2 ^ word_bits"
  by (simp add: word_bits_conv)

lemma if_then_1_else_0:
  "((if P then 1 else 0) = (0 :: machine_word)) = (\<not> P)"
  by simp

lemma if_then_0_else_1:
  "((if P then 0 else 1) = (0 :: machine_word)) = (P)"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma bool_mask [simp]:
  \<open>0 < x AND 1 \<longleftrightarrow> x AND 1 = 1\<close> for x :: machine_word
  by (rule bool_mask') auto

lemma in_16_range:
  "0 \<in> S \<Longrightarrow> r \<in> (\<lambda>x. r + x * (16 :: machine_word)) ` S"
  "n - 1 \<in> S \<Longrightarrow> (r + (16 * n - 16)) \<in> (\<lambda>x :: machine_word. r + x * 16) ` S"
  by (clarsimp simp: image_def elim!: bexI[rotated])+

lemma le_step_down_word_3:
  fixes x :: machine_word
  shows "\<lbrakk>x \<le> y; x \<noteq> y\<rbrakk> \<Longrightarrow> x \<le> y - 1"
  by (fact le_step_down_word_2)

lemma shiftr_1:
  "(x::machine_word) >> 1 = 0 \<Longrightarrow> x < 2"
  apply transfer
  apply (simp add: take_bit_drop_bit)
  apply (simp add: drop_bit_Suc)
  done

lemma Suc_unat_mask_div:
  "Suc (unat (mask sz div word_size :: machine_word)) = 2 ^ (min sz word_bits - word_size_bits)"
  by (simp add: word_size_word_size_bits unat_drop_bit_eq unat_mask_eq drop_bit_mask_eq Suc_mask_eq_exp
    flip: drop_bit_eq_div word_bits_conv)

lemma ucast_not_helper:
  fixes a::"8 word"
  assumes a: "a \<noteq> 0xFF"
  shows "ucast a \<noteq> (0xFF::machine_word)"
proof
  assume "ucast a = (0xFF::machine_word)"
  also
  have "(0xFF::machine_word) = ucast (0xFF::8 word)" by simp
  finally
  show False using a
    apply -
    apply (drule up_ucast_inj, simp)
    apply simp
    done
qed

lemma unat_less_2p_word_bits:
  "unat (x :: machine_word) < 2 ^ word_bits"
  apply (simp only: word_bits_def)
  apply (rule unat_lt2p)
  done

lemma unat_less_word_bits:
  fixes y :: machine_word
  shows "x < unat y \<Longrightarrow> x < 2 ^ word_bits"
  unfolding word_bits_def
  by (rule order_less_trans [OF _ unat_lt2p])

lemma unat_mask_2_less_4:
  "unat (p AND mask 2 :: machine_word) < 4"
  by (rule unat_less_helper) (simp only: take_bit_eq_mod word_mod_less_divisor flip: take_bit_eq_mask, simp add: word_mod_less_divisor)

lemma unat_mult_simple:
  \<open>unat (x * y) = unat x * unat y\<close>
    if \<open>unat x * unat y < 2 ^ LENGTH(machine_word_len)\<close>
    for x y :: machine_word
  using that by (simp flip: unat_mult_lem)

lemma upto_2_helper:
  "{0..<2 :: machine_word} = {0, 1}"
  by (safe; simp) unat_arith

lemma word_ge_min:
  \<open>- (2 ^ (word_bits - 1)) \<le> sint x\<close> for x :: machine_word
  using sint_ge [of x] by (simp add: word_bits_def)

(* We want the rhs unfolded here for later matching *)
lemma word_rsplit_0:
  "word_rsplit (0::machine_word) = [0, 0, 0, (0::8 word)]"
  by (simp add: word_rsplit_def bin_rsplit_def word_bits_def word_size_def Cons_replicate_eq)

lemma x_less_2_0_1:
  fixes x :: machine_word
  shows "x < 2 \<Longrightarrow> x = 0 \<or> x = 1"
  by (rule x_less_2_0_1') auto

lemma less_4_cases:
  "(x::machine_word) < 4 \<Longrightarrow> x=0 \<or> x=1 \<or> x=2 \<or> x=3"
  apply clarsimp
  apply (drule word_less_cases, erule disjE, simp, simp)+
  done

end

end