theory Total_Forward_Reasoning
imports Extended_Separation_Algebra
        Hoare_Sep_Tactics
        "~~/src/HOL/Library/Monad_Syntax"
begin

type_synonym heap = "nat \<Rightarrow> nat option"
type_synonym machine = "(heap \<times> bool)"

abbreviation "(heap :: machine \<Rightarrow> heap) \<equiv> fst"
abbreviation "(nf :: machine \<Rightarrow> bool) \<equiv> snd"

instantiation "prod" :: (cancellative_sep_algebra, cancellative_sep_algebra)
                         cancellative_sep_algebra
begin
  instance
 apply (intro_classes; clarsimp simp: sep_disj_prod_def plus_prod_def zero_prod_def)
 apply (simp add: sep_disj_positive)
 by (simp add: Extended_Separation_Algebra.cancellative_sep_algebra_class.sep_add_cancel)
end

instantiation "bool" :: cancellative_sep_algebra
begin
instance
 apply (intro_classes; (clarsimp simp: zero_bool_def plus_bool_def sep_disj_bool_def))
  by blast
end

definition maps_to:: "nat \<Rightarrow> nat \<Rightarrow> machine \<Rightarrow> bool" ("_ \<mapsto>u _" [56,51] 56)
  where "x \<mapsto>u y \<equiv> \<lambda>h. heap h = [x \<mapsto> y] \<and> nf h "

notation pred_ex  (binder "\<exists>" 10)

definition maps_to_ex :: "nat \<Rightarrow>  machine \<Rightarrow> bool" ("_ \<mapsto>u -" [56] 56)
  where "x \<mapsto>u - \<equiv> (\<lambda>s. \<exists>y. (x \<mapsto>u y) s)"

lemma maps_to_maps_to_ex [elim!]:
  "(p \<mapsto>u v) s \<Longrightarrow> (p \<mapsto>u -) s"
  by (auto simp: maps_to_ex_def)

lemma maps_to_ex_simp[simp]: " (p \<mapsto>u -) ([p \<mapsto> v], True)"
   by (clarsimp simp: maps_to_ex_def maps_to_def, fastforce)

definition sept (infix "-&" 50) where
"sept P Q \<equiv> (\<lambda>s. \<exists>h h'. P h \<and> Q h'  \<and>
            (if (nf h \<and> nf s) then
                 (h + s = h' \<and> h ## s)
                 else (nf h' \<longrightarrow> ((nf h  \<longrightarrow> h ## h') \<and> (nf s \<longrightarrow> s ## h')))))   "

 definition sep_con (infix "\<and>&" 50) where
  "sep_con P Q \<equiv> (\<lambda>s. \<exists>h h'. P h \<and>  Q h' \<and>  (if (nf h \<and> nf h') then ( h' + h = s \<and> h ## h')
                      else (nf s \<longrightarrow>((nf h \<longrightarrow> h ## s) \<and> (nf h' \<longrightarrow>  s ## h'))))) "

lemma "(p \<mapsto>u v -& p \<mapsto>u v) s \<Longrightarrow> \<box> s"
   apply (clarsimp simp: sept_def  maps_to_def zero_prod_def sep_empty_def split: if_splits)
    apply (drule mp)
    apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def  sep_disj_option_def split: if_splits option.splits)
   apply (metis )
   apply (clarsimp)
  by (metis Extended_Separation_Algebra.cancellative_sep_algebra_class.sep_add_cancelD disjoint_zero_sym sep_add_commute sep_add_zero_sym sep_disj_commuteI zero_prod_def)

lemma sep_con_commute: "sep_con P Q s \<Longrightarrow> sep_con Q P s"
   apply (clarsimp simp: sep_con_def)
   apply (rule_tac x="aa" in exI)
   apply (rule_tac x="ba" in exI)
    apply (intro conjI)
   apply (clarsimp)
   apply (rule_tac x="a" in exI)
   apply (rule_tac x="b" in exI)
    apply (intro conjI)
     apply (clarsimp, intro conjI impI)
     using sep_add_commute apply fastforce
   apply (clarsimp simp: sep_disj_commute sep_add_commute)+
  using sep_disj_commuteI by fastforce

definition sep_imp (infix "\<longrightarrow>&" 50) where "sep_imp P Q \<equiv> (not (sept P (not Q)))"

definition sep_snake where "sep_snake P Q \<equiv> (not ( sep_con P (not Q)))"

lemma sep_mp: "sep_con P (sep_imp P R) s \<Longrightarrow> R s"
  apply (clarsimp simp: sep_con_def sep_imp_def pred_neg_def sept_def )
  apply (erule_tac x=a in allE, erule_tac x=b in allE, simp)
  apply (erule_tac x="fst s" in allE, erule_tac x="snd s" in allE, simp)
  apply (elim disjE; clarsimp?)
  apply (erule notE)
 by (metis prod.collapse sep_add_commute sep_disj_commute)

lemma sep_curry: "R s \<Longrightarrow> sep_imp P (sep_con P R) s"
  apply (clarsimp simp: sep_con_def sep_imp_def pred_neg_def sept_def)
   apply (intro conjI; clarsimp)
   apply (erule_tac x=a in allE, erule_tac x=b in allE, simp)
   apply (erule_tac x="fst s" in allE, erule_tac x="snd s" in allE, simp)
   apply (clarsimp simp: sep_add_commute sep_disj_commute)+
  apply (metis (mono_tags, lifting) prod.collapse sep_disj_commuteI)
  apply (rule_tac x=a in exI, rule_tac x=b in exI, clarsimp)
  apply (rule_tac x="fst s" in exI, rule_tac x="snd s" in exI, simp)
  apply (metis (mono_tags, lifting) prod.collapse sep_disj_commuteI)
done

lemma sep_adjoint: "(\<forall>s. sep_con P (sep_imp P R) s \<longrightarrow> R s) \<longleftrightarrow>
                      (\<forall>s. R s \<longrightarrow> sep_imp P (sep_con P R) s)"
 using Total_Forward_Reasoning.sep_curry Total_Forward_Reasoning.sep_mp by blast

lemma sep_con_collapse:"sep_con (p \<mapsto>u v) (R and nf) s \<Longrightarrow> (p \<mapsto>u v \<and>* R) s"
     apply (clarsimp simp: sep_con_def)
     apply (clarsimp simp: sep_conj_def maps_to_def pred_conj_def)
 by (metis sep_add_commute)

no_notation NonDetMonad.bind (infixl ">>=" 60)
hide_const NonDetMonad.bind return get put modify gets fail assert state_assert

translations
  "CONST bind_do" == "CONST bind"

no_notation valid ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>")
no_notation validNF ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!")
hide_const valid validNF

type_synonym ('s,'a) det_monad = "'s \<Rightarrow> 'a \<times> 's \<times> bool"

definition
  bind :: "('s,'a) det_monad \<Rightarrow> ('a \<Rightarrow> ('s,'b) det_monad) \<Rightarrow> ('s,'b) det_monad"
where
  "bind f g \<equiv> \<lambda>s. let (r', s', c) = f s;
                       (r'', s'', c') = g r' s'
                   in (r'', s'', c \<and> c')"

(* use do syntax for this state monad *)
adhoc_overloading
  Monad_Syntax.bind bind

definition
  "return x \<equiv> \<lambda>s. (x, s, True)"

definition
  "get \<equiv> \<lambda>s. (s, s, True)"

definition
  "put s \<equiv> \<lambda>s'. ((), s, True)"

definition
  "fail \<equiv> \<lambda>s. ((), s, False)"

definition
  "modify f \<equiv> get >>= (\<lambda>x. put (f x))"

definition
  "gets f \<equiv> get >>= (\<lambda>x. return (f x))"

definition
  "assert P \<equiv> if P then return () else fail"

definition
  "state_assert P \<equiv> do { s \<leftarrow> get; assert (P s) }"

definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) det_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>v")
where
  "\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace>v \<equiv> \<forall>s. P s \<longrightarrow> (let (r',s', c) = m s in c \<longrightarrow> Q r' s')"

definition
  validNF :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) det_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!")
where
  "\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace>! \<equiv> \<forall>s. P s \<longrightarrow> (let (r',s', c) = m s in Q r' s' \<and> c)"

definition
  validU :: "(('s \<times> bool)  \<Rightarrow> bool) \<Rightarrow> ('s,'a) det_monad \<Rightarrow> ('a \<Rightarrow> ('s \<times> bool) \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>u")
where
  "\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace>u \<equiv> \<forall>s c. P (s, c) \<longrightarrow> (let (r',s',c') = m s in Q r' (s', c \<and> c'))"

lemma bind_wp[wp]:
  "(\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>v) \<Longrightarrow> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>v \<Longrightarrow> \<lbrace>A\<rbrace> f >>= g \<lbrace>C\<rbrace>v"
  unfolding valid_def Let_def bind_def by (fastforce split: prod.splits)

lemma bind_wp_nf:
  "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>! \<Longrightarrow> (\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>!) \<Longrightarrow> \<lbrace>A\<rbrace> f >>= g \<lbrace>C\<rbrace>!"
  unfolding validNF_def Let_def bind_def by fastforce

lemma hoare_seq_ext:
  "\<lbrace>A\<rbrace> f \<lbrace>B \<rbrace>u \<Longrightarrow> (\<And>x.\<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>u)  \<Longrightarrow> \<lbrace>A\<rbrace> f >>= g \<lbrace>C\<rbrace>u"
  unfolding validU_def Let_def bind_def by fastforce

lemma bind_wpU[wp]:
  "(\<And>x.\<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>u) \<Longrightarrow> \<lbrace>A\<rbrace> f \<lbrace>B \<rbrace>u \<Longrightarrow> \<lbrace>A\<rbrace> f >>= g \<lbrace>C\<rbrace>u"
  by (rule hoare_seq_ext)

lemma hoare_chain:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>v;
    \<And>s. R s \<Longrightarrow> P s;
    \<And>r s. Q r s \<Longrightarrow> S r s \<rbrakk> \<Longrightarrow>
   \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace>v"
  by (fastforce simp: valid_def)

lemma hoare_pre[wp_pre]:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>v;
    \<And>s. R s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow>
   \<lbrace>R\<rbrace> f \<lbrace>Q\<rbrace>v"
  by (rule hoare_chain) blast

lemma hoare_chainU:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>u;
    \<And>s. R s \<Longrightarrow> P s;
    \<And>r s. Q r s \<Longrightarrow> S r s \<rbrakk> \<Longrightarrow>
   \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace>u"
  by (fastforce simp: validU_def)

lemma hoare_preU[wp_pre]:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>u;
    \<And>s. R s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow>
   \<lbrace>R\<rbrace> f \<lbrace>Q\<rbrace>u"
  by (fastforce simp: validU_def)

lemma get_wp[wp]: "\<lbrace>\<lambda>s. P s s\<rbrace> get \<lbrace>P\<rbrace>v"
  by (clarsimp simp: get_def valid_def)

lemma put_wp[wp]: "\<lbrace>\<lambda>s'. P () s\<rbrace> put s \<lbrace>P\<rbrace>v"
  by (clarsimp simp: put_def valid_def)

lemma fail_wp[wp]: "\<lbrace>\<lambda>s. True\<rbrace> fail \<lbrace>P\<rbrace>v"
  by (simp add: fail_def valid_def)

lemma return_wp[wp]: "\<lbrace>P x\<rbrace> return x \<lbrace>P\<rbrace>v"
  by (simp add: valid_def return_def)

lemma if_wp[wp]:
  "\<lbrakk> Q \<Longrightarrow> \<lbrace>A\<rbrace> f \<lbrace>P\<rbrace>v; \<not>Q \<Longrightarrow> \<lbrace>B\<rbrace> g \<lbrace>P\<rbrace>v\<rbrakk> \<Longrightarrow>
  \<lbrace>\<lambda>s. (Q \<longrightarrow> A s) \<and> (\<not>Q \<longrightarrow> B s)\<rbrace> if Q then f else g \<lbrace>P\<rbrace>v"
  by auto

(* partial ignores asserts *)
lemma assert_wp[wp]:
  "\<lbrace>\<lambda>s. Q \<longrightarrow> P () s\<rbrace> assert Q \<lbrace>P\<rbrace>v"
  unfolding assert_def by wp auto

lemma state_assert_wp[wp]:
  "\<lbrace>\<lambda>s. Q s \<longrightarrow> P () s\<rbrace> state_assert Q \<lbrace>P\<rbrace>v"
  unfolding state_assert_def by wp

lemma modify_wp[wp]:
  "\<lbrace>\<lambda>s. P () (f s)\<rbrace> modify f \<lbrace>P\<rbrace>v"
  unfolding modify_def by wpsimp

lemma get_wpU[wp]: "\<lbrace>\<lambda>s. P (fst s) s \<rbrace> get \<lbrace> P \<rbrace>u"
  by (clarsimp simp: get_def validU_def)

lemma put_wpU[wp]: "\<lbrace>\<lambda>s'. P () (s, snd s') \<rbrace> put s \<lbrace> P \<rbrace>u"
  by (clarsimp simp: put_def validU_def)

lemma fail_wpU[wp]: "\<lbrace>\<lambda>s. P () (fst s, False) \<rbrace> fail \<lbrace> P \<rbrace>u"
  by (simp add: fail_def validU_def)

lemma return_wpU[wp]: "\<lbrace>P x\<rbrace> return x \<lbrace>P\<rbrace>u"
  by (simp add: validU_def return_def)

lemma if_wpU[wp]:
  "\<lbrakk> Q \<Longrightarrow> \<lbrace>A\<rbrace> f \<lbrace>P\<rbrace>u; \<not>Q \<Longrightarrow> \<lbrace>B\<rbrace> g \<lbrace>P\<rbrace>u\<rbrakk> \<Longrightarrow>
  \<lbrace>\<lambda>s. (Q \<longrightarrow> A s) \<and> (\<not>Q \<longrightarrow> B s)\<rbrace> if Q then f else g \<lbrace>P\<rbrace>u"
  by auto

lemma assert_wpU[wp]:
  "\<lbrace>\<lambda>s. P () (fst s, Q \<and> snd s) \<rbrace> assert Q \<lbrace> P \<rbrace>u"
  unfolding assert_def by wp auto

lemma state_assert_wpU[wp]:
  "\<lbrace>\<lambda>s.  P () (fst s, Q (fst s) \<and> snd s) \<rbrace> state_assert Q \<lbrace> P \<rbrace>u"
  unfolding state_assert_def by wpsimp

lemma modify_wpU[wp]:
  "\<lbrace>\<lambda>s. P ()  (f (fst s), snd s)\<rbrace> modify f \<lbrace>P\<rbrace>u"
  unfolding modify_def by wpsimp

definition
  "delete_ptr p = do {
    state_assert (\<lambda>s.  s p \<noteq> None);
    modify (\<lambda>s. (\<lambda>p'. if p = p' then None else s p'))
  }"

lemma delete_ptr_sp:"\<lbrace>R\<rbrace> delete_ptr p  \<lbrace>\<lambda>_. (sept (p \<mapsto>u -) R) \<rbrace>u"
 apply (clarsimp simp: delete_ptr_def)
 apply (rule hoare_seq_ext[rotated])
 apply (rule modify_wpU)
 apply (rule hoare_chainU[OF state_assert_wpU, rotated])
 apply (assumption)
 apply (clarsimp)
 apply (case_tac "a p = 0"; clarsimp simp: zero_option_def sept_def)
 apply (rule_tac x=" [p \<mapsto> undefined]" in exI)
 apply (rule_tac x=" True" in exI)
 apply (intro conjI, fastforce)
 apply (rule_tac x=a in exI, rule_tac x=b in exI)
 apply (clarsimp)
 apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
 apply (case_tac "b"; clarsimp)
  apply (rule_tac x="[p \<mapsto> y]" in exI)
  apply (rule_tac x="True" in exI)
 apply (intro conjI, fastforce)
 apply (clarsimp)
apply (rule_tac x=a in exI, rule_tac x=True in exI)
apply (clarsimp, intro conjI)
apply (clarsimp simp: plus_prod_def, intro conjI)
apply (rule ext)
apply (clarsimp simp: plus_fun_def plus_option_def)
apply (clarsimp simp: plus_bool_def)
 apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
   apply (rule_tac x="[p \<mapsto> y]" in exI)
   apply (rule_tac x="True" in exI)
apply (intro conjI, fastforce)
 by blast

definition "the_f v d = (if (v = None) then d else (the v))"

lemma gets_wpU: "\<lbrace>\<lambda>s.  P (f (fst s)) s \<rbrace> gets f \<lbrace> P \<rbrace>u"
   by (clarsimp simp: gets_def get_def bind_def validU_def return_def)

definition
  "get_ptr p = do {
     v <- gets (\<lambda>s. s p);
     assert (v \<noteq> None);
     return (the_f v (0))
   }"

lemma get_ptr_sp: "\<lbrace>R\<rbrace> get_ptr p \<lbrace>\<lambda>rv. (p \<mapsto>u rv \<and>& (p \<mapsto>u rv -& R))\<rbrace>u"
  apply (clarsimp simp: get_ptr_def, (rule hoare_seq_ext[rotated])+)
  apply (rule return_wpU assert_wpU)+
  apply (rule hoare_chainU[OF gets_wpU, rotated])
  apply (assumption)
  apply (clarsimp simp: gets_def validU_def)
  apply (case_tac "(\<exists>y. a p = Some y)"; clarsimp simp: the_f_def  zero_option_def)
  apply (clarsimp simp: sep_con_def)
  apply (rule_tac x="(\<lambda>ptr. if ptr = p then None else  a ptr)" in exI)
  apply (rule_tac x="b" in exI)
  apply (clarsimp, intro conjI impI)
  apply (clarsimp simp: sept_def)
  apply (rule_tac x=a in exI, rule_tac x=b in exI, clarsimp, intro conjI)
  apply (clarsimp simp: plus_prod_def plus_bool_def)
  apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
  apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
  apply (clarsimp simp: plus_prod_def plus_bool_def)
  apply (rule ext, clarsimp simp: plus_fun_def plus_option_def split: option.splits)
  apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
  apply (clarsimp simp: sept_def)
  apply (blast)
  apply (clarsimp simp: sep_con_def)
  apply (rule_tac x="(\<lambda>ptr. if ptr = p then None else  a ptr)" in exI, rule_tac x= False in exI)
  apply (clarsimp)
  apply (clarsimp simp: sept_def)
  apply (rule_tac x=a in exI)
  apply (rule_tac x=b in exI)
  apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
done

definition
  "set_ptr p v = do {
     x <- gets (\<lambda>s. s p);
     assert (x \<noteq> None);
     modify (\<lambda>s. s(p \<mapsto> v))
   }"

lemma set_ptr_sp: "\<lbrace>R\<rbrace> set_ptr p v \<lbrace>\<lambda>_. (p \<mapsto>u v \<and>& (p \<mapsto>u - -& R))\<rbrace>u"
  apply (clarsimp simp: set_ptr_def, (rule hoare_seq_ext[rotated])+)
  apply (rule return_wpU assert_wpU modify_wpU)+
  apply (rule hoare_chainU[OF gets_wpU, rotated])
  apply (assumption)
  apply (clarsimp simp: gets_def validU_def)
  apply (case_tac "(\<exists>y. a p = Some y)"; clarsimp simp: the_f_def maps_to_ex_def zero_option_def)
  apply (clarsimp simp: sep_con_def)
  apply (rule_tac x="(\<lambda>ptr. if ptr = p then None else  a ptr)" in exI)
  apply (rule_tac x="b" in exI)
  apply (clarsimp, intro conjI impI)
  apply (clarsimp simp: sept_def)
  apply (rule_tac x="[p \<mapsto> y]" in exI, intro conjI, fastforce)
  apply (rule_tac x=b in exI, clarsimp)
  apply (rule exI, rule exI, intro conjI, fastforce)
  apply (clarsimp simp: plus_prod_def plus_bool_def)
  apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
  apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
  apply (clarsimp simp: plus_prod_def plus_bool_def)
  apply (rule ext, clarsimp simp: plus_fun_def plus_option_def split: option.splits)
  apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
  apply (clarsimp simp: sept_def)
  apply (blast)
  apply (clarsimp simp: sep_con_def)
  apply (rule_tac x="(\<lambda>ptr. if ptr = p then Some v else  a ptr)" in exI, rule_tac x= False in exI)
  apply (clarsimp)
  apply (clarsimp simp: sept_def)
  apply (rule_tac x="[p \<mapsto> undefined]" in exI)
apply (rule conjI)
apply (fastforce)
  apply (rule_tac x=True in exI)
  apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
apply (blast)
done

definition "move_ptr p p' = get_ptr p >>= set_ptr p'"

lemma sep_con_impl2: "(p \<and>& q) s \<Longrightarrow> (\<And>s. q s \<Longrightarrow> q' s) \<Longrightarrow> (p \<and>& q') s"
  apply (clarsimp simp: sep_con_def)
  apply (rule_tac x=a in exI, rule_tac x=b in exI)
  apply (clarsimp)
  apply (rule_tac x=aa in exI, rule_tac x=ba in exI, clarsimp)
  by auto

lemma sept_impl2: "(p -& q) s \<Longrightarrow> (\<And>s. q s \<Longrightarrow> q' s) \<Longrightarrow> (p -& q') s"
  apply (clarsimp simp: sept_def)
  apply (fastforce)
done

lemma sept_success:"( p \<mapsto>u v -& (p \<mapsto>u v' \<and>* (R and nf))) s \<Longrightarrow> (R and (\<lambda>s. nf s \<and> v = v')) s"
  apply (clarsimp simp: sept_def sep_conj_def maps_to_ex_def split: if_splits)
  apply (erule disjE, clarsimp simp: pred_conj_def)
  apply (subgoal_tac "v = v'", clarsimp)
  apply (metis Extended_Separation_Algebra.cancellative_sep_algebra_class.sep_add_cancelD sep_add_commute sep_disj_commuteI)
  apply (clarsimp simp: plus_prod_def)
apply (drule fun_cong[where x=p], clarsimp simp: plus_fun_def plus_option_def split: option.splits)
apply (clarsimp simp: sep_disj_fun_def sep_disj_prod_def sep_disj_option_def split: if_splits, fastforce)
apply (clarsimp simp: pred_conj_def plus_prod_def)
apply (clarsimp simp: plus_fun_def plus_option_def sep_disj_fun_def sep_disj_prod_def sep_disj_option_def plus_bool_def sep_disj_bool_def split: if_splits)
apply (fastforce)
done

lemma sept_success_ex:"( p \<mapsto>u - -& (p \<mapsto>u - \<and>* (R and nf))) s \<Longrightarrow> (R and (nf)) s"
apply (clarsimp simp: sept_def sep_conj_def maps_to_ex_def split: if_splits)
  apply (erule disjE, clarsimp simp: pred_conj_def)
  apply (subgoal_tac "y = ya", clarsimp)
  apply (metis Extended_Separation_Algebra.cancellative_sep_algebra_class.sep_add_cancelD sep_add_commute sep_disj_commuteI)
  apply (clarsimp simp: plus_prod_def)
apply (drule fun_cong[where x=p], clarsimp simp: plus_fun_def plus_option_def split: option.splits)
apply (clarsimp simp: plus_fun_def plus_option_def sep_disj_fun_def sep_disj_prod_def sep_disj_option_def plus_bool_def sep_disj_bool_def split: if_splits)
apply (fastforce)
apply (clarsimp simp: plus_fun_def plus_prod_def plus_option_def sep_disj_fun_def sep_disj_prod_def sep_disj_option_def plus_bool_def sep_disj_bool_def split: if_splits)
apply (fastforce)
done

lemma sep_maps_to_success: "(p \<mapsto>u v \<and>* R) s \<Longrightarrow> (\<And>s. R s \<Longrightarrow> nf s) \<Longrightarrow> ((p \<mapsto>u v \<and>* R) and nf) s"
  apply (clarsimp simp: sep_conj_def pred_conj_def)
  by (simp add: plus_prod_def plus_bool_def)

lemma maps_to_nf: "(p \<mapsto>u v) s \<Longrightarrow> ((p \<mapsto>u v) and nf) s"
by (clarsimp simp: pred_conj_def maps_to_def)

lemma maps_to_ex_nf: "(p \<mapsto>u -) s \<Longrightarrow> ((p \<mapsto>u -) and nf) s"
by (clarsimp simp: pred_conj_def maps_to_ex_def maps_to_def)

lemma move_ptr_validU:"\<lbrace>(p \<mapsto>u v \<and>* p' \<mapsto>u -)\<rbrace> move_ptr p p' \<lbrace>\<lambda>_. (p \<mapsto>u v \<and>* p' \<mapsto>u v)\<rbrace>u"
  apply (clarsimp simp: move_ptr_def, rule hoare_seq_ext)
apply (rule hoare_chainU, rule get_ptr_sp, assumption, assumption)
  apply (rule hoare_chainU[OF set_ptr_sp])
 apply (assumption)
   apply (subgoal_tac "x=v", clarsimp)
  apply (drule sep_con_impl2)
  apply (drule sept_impl2)
  apply (drule sep_con_impl2)
    apply (drule sept_impl2)
    apply (sep_drule maps_to_ex_nf[where p=p'])
    apply (sep_select_asm 2, assumption)
 apply (drule sept_success, assumption+)
 apply (drule sep_con_impl2)
 apply (drule sept_impl2)
apply (rule sep_con_collapse[where p=p and R="p' \<mapsto>u -"])
 apply (erule sep_con_impl2)
 apply (clarsimp simp: pred_conj_def)
 apply (drule sept_impl2)
apply (sep_drule maps_to_nf)
 apply (sep_select_asm 2, assumption)
apply (drule sept_success_ex, assumption)
apply (drule sep_con_collapse, sep_solve)
  apply (drule sep_con_impl2)
  apply (drule sept_impl2)
  apply (drule sep_con_impl2)
    apply (drule sept_impl2)
    apply (sep_drule maps_to_ex_nf[where p=p'])
    apply (sep_select_asm 2, assumption)
 apply (drule sept_success, assumption+)
apply (clarsimp simp: pred_conj_def sep_con_def sept_def)
done

lemma "\<exists>s. (nf -& nf) s \<and> \<not>nf s"
 apply (rule_tac x="(undefined,False)" in exI)
 apply (clarsimp simp: sept_def)
 apply (rule_tac x="[p \<mapsto> v]" in exI)
 apply (rule_tac x=True in exI)
 apply (clarsimp)
apply (rule_tac x=0 in exI)
 apply (rule_tac x= True in exI)
 apply (clarsimp)
apply (clarsimp simp: sep_disj_prod_def sep_disj_bool_def)
done

abbreviation "NULL \<equiv> (0 :: nat)"

definition
  "new_ptr = do {
     s <- get;
     p <- return (if (\<exists>x. s x = 0) then (SOME x. s x = 0) else NULL );
     _ <- if (p = NULL) then (return ()) else modify (\<lambda>s. s(p \<mapsto> undefined));
     return (p)
   }"

lemma new_ptr_sp: "\<lbrace>R\<rbrace> new_ptr \<lbrace>\<lambda>rv s. if (rv = NULL) then R s else (rv \<mapsto>u - \<and>* R) s\<rbrace>u"
  apply (clarsimp simp: new_ptr_def)
  apply (wp)
  apply (clarsimp)
  apply (clarsimp simp: sep_conj_def)
  apply (rule_tac x="[(SOME x. a x = 0) \<mapsto> undefined]" in exI)
  apply (rule_tac x=True in exI)
  apply (rule_tac x=a in exI)
  apply (rule_tac x=b in exI)
  apply (clarsimp, intro conjI)
  apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def zero_fun_def zero_option_def)
  apply (safe)
  apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def zero_fun_def sep_disj_option_def zero_option_def)
  apply (meson tfl_some)
 apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def zero_fun_def sep_disj_option_def zero_option_def)
 apply (clarsimp simp: sep_disj_bool_def)
apply (clarsimp simp: plus_prod_def plus_bool_def)
  apply (rule ext)
  apply (clarsimp)
  apply (safe)
  apply (clarsimp simp: plus_fun_def plus_option_def zero_option_def)
  using case_option_over_if(2) tfl_some apply auto[1]
apply (clarsimp simp: plus_fun_def plus_option_def)
done

end


section \<open>Examples\<close>

theory RG_Examples
imports RG_Syntax
begin

lemmas definitions [simp]= stable_def Pre_def Rely_def Guar_def Post_def Com_def

subsection \<open>Set Elements of an Array to Zero\<close>

lemma le_less_trans2: "\<lbrakk>(j::nat)<k; i\<le> j\<rbrakk> \<Longrightarrow> i<k"
by simp

lemma add_le_less_mono: "\<lbrakk> (a::nat) < c; b\<le>d \<rbrakk> \<Longrightarrow> a + b < c + d"
by simp

record Example1 =
  A :: "nat list"

lemma Example1:
 "\<turnstile> COBEGIN
      SCHEME [0 \<le> i < n]
     (\<acute>A := \<acute>A [i := 0],
     \<lbrace> n < length \<acute>A \<rbrace>,
     \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> \<ordmasculine>A ! i = \<ordfeminine>A ! i \<rbrace>,
     \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> (\<forall>j<n. i \<noteq> j \<longrightarrow> \<ordmasculine>A ! j = \<ordfeminine>A ! j) \<rbrace>,
     \<lbrace> \<acute>A ! i = 0 \<rbrace>)
    COEND
 SAT [\<lbrace> n < length \<acute>A \<rbrace>, \<lbrace> \<ordmasculine>A = \<ordfeminine>A \<rbrace>, \<lbrace> True \<rbrace>, \<lbrace> \<forall>i < n. \<acute>A ! i = 0 \<rbrace>]"
apply(rule Parallel)
apply (auto intro!: Basic)
done

lemma Example1_parameterized:
"k < t \<Longrightarrow>
  \<turnstile> COBEGIN
    SCHEME [k*n\<le>i<(Suc k)*n] (\<acute>A:=\<acute>A[i:=0],
   \<lbrace>t*n < length \<acute>A\<rbrace>,
   \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> \<ordmasculine>A!i = \<ordfeminine>A!i\<rbrace>,
   \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>j<length \<ordmasculine>A . i\<noteq>j \<longrightarrow> \<ordmasculine>A!j = \<ordfeminine>A!j)\<rbrace>,
   \<lbrace>\<acute>A!i=0\<rbrace>)
   COEND
 SAT [\<lbrace>t*n < length \<acute>A\<rbrace>,
      \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>i<n. \<ordmasculine>A!(k*n+i)=\<ordfeminine>A!(k*n+i))\<rbrace>,
      \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and>
      (\<forall>i<length \<ordmasculine>A . (i<k*n \<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i) \<and> ((Suc k)*n \<le> i\<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i))\<rbrace>,
      \<lbrace>\<forall>i<n. \<acute>A!(k*n+i) = 0\<rbrace>]"
apply(rule Parallel)
    apply auto
  apply(erule_tac x="k*n +i" in allE)
  apply(subgoal_tac "k*n+i <length (A b)")
   apply force
  apply(erule le_less_trans2)
  apply(case_tac t,simp+)
  apply (simp add:add.commute)
  apply(simp add: add_le_mono)
apply(rule Basic)
   apply simp
   apply clarify
   apply (subgoal_tac "k*n+i< length (A x)")
    apply simp
   apply(erule le_less_trans2)
   apply(case_tac t,simp+)
   apply (simp add:add.commute)
   apply(rule add_le_mono, auto)
done

subsection \<open>Increment a Variable in Parallel\<close>

subsubsection \<open>Two components\<close>

record Example2 =
  x  :: nat
  c_0 :: nat
  c_1 :: nat

lemma Example2:
 "\<turnstile>  COBEGIN
    (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_0:=\<acute>c_0 + 1 \<rangle>,
     \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1  \<and> \<acute>c_0=0\<rbrace>,
     \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
        (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
        \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
     \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
         (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
         \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
     \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_0=1 \<rbrace>)
  \<parallel>
      (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_1:=\<acute>c_1+1 \<rangle>,
     \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=0 \<rbrace>,
     \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
        (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
        \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
     \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
         (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
        \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
     \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=1\<rbrace>)
 COEND
 SAT [\<lbrace>\<acute>x=0 \<and> \<acute>c_0=0 \<and> \<acute>c_1=0\<rbrace>,
      \<lbrace>\<ordmasculine>x=\<ordfeminine>x \<and>  \<ordmasculine>c_0= \<ordfeminine>c_0 \<and> \<ordmasculine>c_1=\<ordfeminine>c_1\<rbrace>,
      \<lbrace>True\<rbrace>,
      \<lbrace>\<acute>x=2\<rbrace>]"
apply(rule Parallel)
   apply simp_all
   apply clarify
   apply(case_tac i)
    apply simp
    apply(rule conjI)
     apply clarify
     apply simp
    apply clarify
    apply simp
   apply simp
   apply(rule conjI)
    apply clarify
    apply simp
   apply clarify
   apply simp
   apply(subgoal_tac "xa=0")
    apply simp
   apply arith
  apply clarify
  apply(case_tac xaa, simp, simp)
 apply clarify
 apply simp
 apply(erule_tac x=0 in all_dupE)
 apply(erule_tac x=1 in allE,simp)
apply clarify
apply(case_tac i,simp)
 apply(rule Await)
  apply simp_all
 apply(clarify)
 apply(rule Seq)
  prefer 2
  apply(rule Basic)
   apply simp_all
  apply(rule subset_refl)
 apply(rule Basic)
 apply simp_all
 apply clarify
 apply simp
apply(rule Await)
 apply simp_all
apply(clarify)
apply(rule Seq)
 prefer 2
 apply(rule Basic)
  apply simp_all
 apply(rule subset_refl)
apply(auto intro!: Basic)
done

subsubsection \<open>Parameterized\<close>

lemma Example2_lemma2_aux: "j<n \<Longrightarrow>
 (\<Sum>i=0..<n. (b i::nat)) =
 (\<Sum>i=0..<j. b i) + b j + (\<Sum>i=0..<n-(Suc j) . b (Suc j + i))"
apply(induct n)
 apply simp_all
apply(simp add:less_Suc_eq)
 apply(auto)
apply(subgoal_tac "n - j = Suc(n- Suc j)")
  apply simp
apply arith
done

lemma Example2_lemma2_aux2:
  "j\<le> s \<Longrightarrow> (\<Sum>i::nat=0..<j. (b (s:=t)) i) = (\<Sum>i=0..<j. b i)"
  by (induct j) simp_all

lemma Example2_lemma2:
 "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow> Suc (\<Sum>i::nat=0..<n. b i)=(\<Sum>i=0..<n. (b (j := Suc 0)) i)"
apply(frule_tac b="(b (j:=(Suc 0)))" in Example2_lemma2_aux)
apply(erule_tac  t="sum (b(j := (Suc 0))) {0..<n}" in ssubst)
apply(frule_tac b=b in Example2_lemma2_aux)
apply(erule_tac  t="sum b {0..<n}" in ssubst)
apply(subgoal_tac "Suc (sum b {0..<j} + b j + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))=(sum b {0..<j} + Suc (b j) + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))")
apply(rotate_tac -1)
apply(erule ssubst)
apply(subgoal_tac "j\<le>j")
 apply(drule_tac b="b" and t="(Suc 0)" in Example2_lemma2_aux2)
apply(rotate_tac -1)
apply(erule ssubst)
apply simp_all
done

lemma Example2_lemma2_Suc0: "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow>
 Suc (\<Sum>i::nat=0..< n. b i)=(\<Sum>i=0..< n. (b (j:=Suc 0)) i)"
by(simp add:Example2_lemma2)

record Example2_parameterized =
  C :: "nat \<Rightarrow> nat"
  y  :: nat

lemma Example2_parameterized: "0<n \<Longrightarrow>
  \<turnstile> COBEGIN SCHEME  [0\<le>i<n]
     (\<langle> \<acute>y:=\<acute>y+1;; \<acute>C:=\<acute>C (i:=1) \<rangle>,
     \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=0\<rbrace>,
     \<lbrace>\<ordmasculine>C i = \<ordfeminine>C i \<and>
      (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
     \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>C j = \<ordfeminine>C j) \<and>
       (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
     \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=1\<rbrace>)
    COEND
 SAT [\<lbrace>\<acute>y=0 \<and> (\<Sum>i=0..<n. \<acute>C i)=0 \<rbrace>, \<lbrace>\<ordmasculine>C=\<ordfeminine>C \<and> \<ordmasculine>y=\<ordfeminine>y\<rbrace>, \<lbrace>True\<rbrace>, \<lbrace>\<acute>y=n\<rbrace>]"
apply(rule Parallel)
apply force
apply force
apply(force)
apply clarify
apply simp
apply simp
apply clarify
apply simp
apply(rule Await)
apply simp_all
apply clarify
apply(rule Seq)
prefer 2
apply(rule Basic)
apply(rule subset_refl)
apply simp+
apply(rule Basic)
apply simp
apply clarify
apply simp
apply(simp add:Example2_lemma2_Suc0 cong:if_cong)
apply simp_all
done

subsection \<open>Find Least Element\<close>

text \<open>A previous lemma:\<close>

lemma mod_aux :"\<lbrakk>i < (n::nat); a mod n = i;  j < a + n; j mod n = i; a < j\<rbrakk> \<Longrightarrow> False"
apply(subgoal_tac "a=a div n*n + a mod n" )
 prefer 2 apply (simp (no_asm_use))
apply(subgoal_tac "j=j div n*n + j mod n")
 prefer 2 apply (simp (no_asm_use))
apply simp
apply(subgoal_tac "a div n*n < j div n*n")
prefer 2 apply arith
apply(subgoal_tac "j div n*n < (a div n + 1)*n")
prefer 2 apply simp
apply (simp only:mult_less_cancel2)
apply arith
done

record Example3 =
  X :: "nat \<Rightarrow> nat"
  Y :: "nat \<Rightarrow> nat"

lemma Example3: "m mod n=0 \<Longrightarrow>
 \<turnstile> COBEGIN
 SCHEME [0\<le>i<n]
 (WHILE (\<forall>j<n. \<acute>X i < \<acute>Y j)  DO
   IF P(B!(\<acute>X i)) THEN \<acute>Y:=\<acute>Y (i:=\<acute>X i)
   ELSE \<acute>X:= \<acute>X (i:=(\<acute>X i)+ n) FI
  OD,
 \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i)\<rbrace>,
 \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y j \<le> \<ordmasculine>Y j) \<and> \<ordmasculine>X i = \<ordfeminine>X i \<and>
   \<ordmasculine>Y i = \<ordfeminine>Y i\<rbrace>,
 \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X j = \<ordfeminine>X j \<and> \<ordmasculine>Y j = \<ordfeminine>Y j) \<and>
   \<ordfeminine>Y i \<le> \<ordmasculine>Y i\<rbrace>,
 \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i) \<rbrace>)
 COEND
 SAT [\<lbrace> \<forall>i<n. \<acute>X i=i \<and> \<acute>Y i=m+i \<rbrace>,\<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,\<lbrace>True\<rbrace>,
  \<lbrace>\<forall>i<n. (\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
    (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i)\<rbrace>]"
apply(rule Parallel)
\<comment> \<open>5 subgoals left\<close>
apply force+
apply clarify
apply simp
apply(rule While)
    apply force
   apply force
    apply force
  apply (erule dvdE)
 apply(rule_tac pre'="\<lbrace> \<acute>X i mod n = i \<and> (\<forall>j. j<\<acute>X i \<longrightarrow> j mod n = i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i < n * k \<longrightarrow> P (B!(\<acute>Y i))) \<and> \<acute>X i<\<acute>Y i\<rbrace>" in Conseq)
     apply force
    apply(rule subset_refl)+
 apply(rule Cond)
    apply force
   apply(rule Basic)
      apply force
     apply fastforce
    apply force
   apply force
  apply(rule Basic)
     apply simp
     apply clarify
     apply simp
     apply (case_tac "X x (j mod n) \<le> j")
     apply (drule le_imp_less_or_eq)
     apply (erule disjE)
     apply (drule_tac j=j and n=n and i="j mod n" and a="X x (j mod n)" in mod_aux)
     apply auto
done

text \<open>Same but with a list as auxiliary variable:\<close>

record Example3_list =
  X :: "nat list"
  Y :: "nat list"

lemma Example3_list: "m mod n=0 \<Longrightarrow> \<turnstile> (COBEGIN SCHEME [0\<le>i<n]
 (WHILE (\<forall>j<n. \<acute>X!i < \<acute>Y!j)  DO
     IF P(B!(\<acute>X!i)) THEN \<acute>Y:=\<acute>Y[i:=\<acute>X!i] ELSE \<acute>X:= \<acute>X[i:=(\<acute>X!i)+ n] FI
  OD,
 \<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i)\<rbrace>,
 \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y!j \<le> \<ordmasculine>Y!j) \<and> \<ordmasculine>X!i = \<ordfeminine>X!i \<and>
   \<ordmasculine>Y!i = \<ordfeminine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
 \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X!j = \<ordfeminine>X!j \<and> \<ordmasculine>Y!j = \<ordfeminine>Y!j) \<and>
   \<ordfeminine>Y!i \<le> \<ordmasculine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
 \<lbrace>(\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i) \<rbrace>) COEND)
 SAT [\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<forall>i<n. \<acute>X!i=i \<and> \<acute>Y!i=m+i) \<rbrace>,
      \<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,
      \<lbrace>True\<rbrace>,
      \<lbrace>\<forall>i<n. (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
        (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i)\<rbrace>]"
  apply (rule Parallel)
apply (auto cong del: image_cong_simp)
apply force
apply (rule While)
    apply force
   apply force
  apply force
  apply (erule dvdE)
 apply(rule_tac pre'="\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> \<acute>X ! i mod n = i \<and> (\<forall>j. j < \<acute>X ! i \<longrightarrow> j mod n = i \<longrightarrow> \<not> P (B ! j)) \<and> (\<acute>Y ! i < n * k \<longrightarrow> P (B ! (\<acute>Y ! i))) \<and> \<acute>X!i<\<acute>Y!i\<rbrace>" in Conseq)
     apply force
    apply(rule subset_refl)+
 apply(rule Cond)
    apply force
   apply(rule Basic)
      apply force
     apply force
    apply force
   apply force
  apply(rule Basic)
     apply simp
     apply clarify
     apply simp
     apply(rule allI)
     apply(rule impI)+
     apply(case_tac "X x ! i\<le> j")
      apply(drule le_imp_less_or_eq)
      apply(erule disjE)
       apply(drule_tac j=j and n=n and i=i and a="X x ! i" in mod_aux)
     apply auto
done

end


theory regexp_PlusCommutative
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype A = X | Y

datatype R
  = Nil2 | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   case x of
     | other =>
         case y of
           | other =>
               case x of
                 | other =>
                     case y of
                       | other => Seq x y
                       | Eps => x
                     end
                 | Eps => y
               end
           | Nil2 => y
         end
     | Nil2 => x
   end"

fun plus :: "R => R => R" where
"plus x y =
   case x of
     | other =>
         case y of
           | other => Plus x y
           | Nil2 => x
         end
     | Nil2 => y
   end"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun eqA :: "A => A => bool" where
"eqA (X) y = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun eps :: "R => bool" where
"eps x =
   case x of
     | other => False
     | Eps => True
     | Plus p q => or2 (eps p) (eps q)
     | Seq p2 q2 => and2 (eps p2) (eps q2)
     | Star y => True
   end"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil2)"

fun step :: "R => A => R" where
"step x y =
   case x of
     | other => Nil2
     | Atom a => (if eqA a y then Eps else Nil2)
     | Plus p q => plus (step p y) (step q y)
     | Seq p2 q2 =>
         plus (seq (step p2 y) q2) (seq (epsR p2) (step q2 y))
     | Star p3 => seq (step p3 y) x
   end"

fun recognise :: "R => A list => bool" where
"recognise x (Nil2) = eps x"
| "recognise x (Cons2 z xs) = recognise (step x z) xs"

(*hipster seq plus or2 eqA and2 eps epsR step recognise *)

theorem x0 :
  "!! (p :: R) (q :: R) (s :: A list) .
     (recognise (Plus p q) s) = (recognise (Plus q p) s)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Typing
  imports Syntax Defs Lemmas
begin

no_notation Set.member  ("(_/ : _)" [51, 51] 50)

inductive Ax :: "\<Delta> \<Rightarrow> bool" ("\<turnstile> _")
  and Ctx :: "\<Delta> \<Rightarrow> \<Gamma> \<Rightarrow> bool" ("_ \<turnstile> _")
  and Ty :: "\<Gamma> \<Rightarrow> \<Delta> \<Rightarrow> \<tau> \<Rightarrow> \<kappa> \<Rightarrow> bool" ("_ , _ \<turnstile>\<^sub>t\<^sub>y _ : _") where

  Ax_Empty: "\<turnstile> []"

| Ax_Data: "\<lbrakk> \<turnstile> \<Delta> ; \<nexists>k. AxData T k \<in> set \<Delta> \<rbrakk> \<Longrightarrow> \<turnstile> AxData T \<kappa> # \<Delta>"

| Ax_Ctor: "\<lbrakk> [] , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : \<star> ; ctor_type \<tau> = Some T ; \<nexists>t. AxCtor D t \<in> set \<Delta> \<rbrakk> \<Longrightarrow> \<turnstile> AxCtor D \<tau> # \<Delta>"

(* ------------------------------ *)

| Ctx_Empty: "\<turnstile> \<Delta> \<Longrightarrow> \<Delta> \<turnstile> []"

| Ctx_TyVar: "\<lbrakk> \<Delta> \<turnstile> \<Gamma> ; atom a \<sharp> \<Gamma> \<rbrakk> \<Longrightarrow> \<Delta> \<turnstile> BTyVar a k # \<Gamma>"

| Ctx_Var: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : \<star> ; atom x \<sharp> \<Gamma> \<rbrakk> \<Longrightarrow> \<Delta> \<turnstile> BVar x \<tau> # \<Gamma>"

(* ------------------------------ *)

| Ty_Var: "\<lbrakk> \<Delta> \<turnstile> \<Gamma> ; BTyVar a k \<in> \<Gamma> \<rbrakk> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y TyVar a : k"

| Ty_App: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau>1 : \<kappa>1 \<rightarrow> \<kappa>2 ; \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau>2 : \<kappa>1 \<rbrakk> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y TyApp \<tau>1 \<tau>2 : \<kappa>2"

| Ty_Data: "\<lbrakk> \<Delta> \<turnstile> \<Gamma> ; AxData T k \<in> set \<Delta> \<rbrakk> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y TyData T : k"

| Ty_Arrow: "\<Delta> \<turnstile> \<Gamma> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y TyArrow : \<star> \<rightarrow> \<star> \<rightarrow> \<star>"

| Ty_Forall: "\<lbrakk> BTyVar a k # \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<sigma> : \<star> \<rbrakk> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y (\<forall>a : k. \<sigma>) : \<star>"

equivariance Ax

inductive Tm :: "\<Gamma> \<Rightarrow> \<Delta> \<Rightarrow> term \<Rightarrow> \<tau> \<Rightarrow> bool" ("_ , _ \<turnstile> _ : _" 50) where
  Tm_Var: "\<lbrakk> \<Delta> \<turnstile> \<Gamma> ; BVar x \<tau> \<in> \<Gamma> \<rbrakk> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile> (Var x) : \<tau>"

| Tm_Abs: "BVar x \<tau>1 # \<Gamma> , \<Delta> \<turnstile> e : \<tau>2 \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile> (\<lambda> x : \<tau>1 . e) : (\<tau>1 \<rightarrow> \<tau>2)"

| Tm_App: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile> e1 : (\<tau>1 \<rightarrow> \<tau>2) ; \<Gamma> , \<Delta> \<turnstile> e2 : \<tau>1 \<rbrakk> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile> App e1 e2 : \<tau>2"

| Tm_TAbs: "BTyVar a k # \<Gamma> , \<Delta> \<turnstile> e : \<sigma> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile> (\<Lambda> a : k . e) : (\<forall> a : k . \<sigma>)"

| Tm_TApp: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile> e : \<forall> a:k. \<sigma> ; \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k \<rbrakk> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile> TApp e \<tau> : \<sigma>[\<tau>/a]"

| Tm_Ctor: "\<lbrakk> \<Delta> \<turnstile> \<Gamma> ; AxCtor D \<tau> \<in> set \<Delta> \<rbrakk> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile> Ctor D : \<tau>"

| Tm_Let: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile> e1 : \<tau>1 ; BVar x \<tau>1 # \<Gamma> , \<Delta> \<turnstile> e2 : \<tau>2 \<rbrakk> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile> Let x \<tau>1 e1 e2 : \<tau>2"

equivariance Tm

lemmas Ax_intros = Ax_Ctx_Ty.intros(1-3)
lemmas Ctx_intros = Ax_Ctx_Ty.intros(4-6)
lemmas Ty_intros = Ax_Ctx_Ty.intros(7-11)

inductive_cases AxE[elim]:
  "\<turnstile> AxData T k # \<Delta>"
  "\<turnstile> AxCtor D \<tau> # \<Delta>"

inductive_cases CtxE[elim]:
  "\<Delta> \<turnstile> BTyVar a k # \<Gamma>"
  "\<Delta> \<turnstile> BVar x \<tau> # \<Gamma>"

inductive_cases TyE[elim!]:
  "\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y TyVar a : k"
  "\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y TyApp \<tau>1 \<tau>2 : \<kappa>2"
  "\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y TyData D : k"
  "\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y TyArrow : k"

inductive_cases TmE[elim!]:
  "\<Gamma> , \<Delta> \<turnstile> Var x : \<tau>"
  "\<Gamma> , \<Delta> \<turnstile> App e1 e2 : \<tau>2"
  "\<Gamma> , \<Delta> \<turnstile> TApp e \<tau> : \<tau>2"
  "\<Gamma> , \<Delta> \<turnstile> Ctor D : \<tau>"

(* Split induction principles *)
lemma Ty_induct[consumes 1, case_names Var App Data Arrow Forall]:
  fixes P::"\<Gamma> \<Rightarrow> \<Delta> \<Rightarrow> \<tau> \<Rightarrow> \<kappa> \<Rightarrow> bool"
  assumes "\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : \<kappa>"
  and Var: "\<And>\<Gamma> \<Delta> a k. \<lbrakk> \<Delta> \<turnstile> \<Gamma> ; BTyVar a k \<in> \<Gamma> \<rbrakk> \<Longrightarrow> P \<Gamma> \<Delta> (TyVar a) k"
  and App: "\<And>\<Gamma> \<Delta> \<tau>1 \<tau>2 \<kappa>1 \<kappa>2. \<lbrakk> \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau>1 : \<kappa>1 \<rightarrow> \<kappa>2 ; P \<Gamma> \<Delta> \<tau>1 (KArrow \<kappa>1 \<kappa>2) ; \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau>2 : \<kappa>1 ; P \<Gamma> \<Delta> \<tau>2 \<kappa>1 \<rbrakk> \<Longrightarrow> P \<Gamma> \<Delta> (TyApp \<tau>1 \<tau>2) \<kappa>2"
  and Data: "\<And>\<Delta> \<Gamma> T k. \<lbrakk> \<Delta> \<turnstile> \<Gamma> ; AxData T k \<in> set \<Delta> \<rbrakk> \<Longrightarrow> P \<Gamma> \<Delta> (TyData T) k"
  and Arrow: "\<And>\<Gamma> \<Delta>. \<Delta> \<turnstile> \<Gamma> \<Longrightarrow> P \<Gamma> \<Delta> TyArrow (\<star> \<rightarrow> \<star> \<rightarrow> \<star>)"
  and Forall: "\<And>\<Gamma> \<Delta> a k \<sigma>. \<lbrakk> BTyVar a k # \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<sigma> : \<star> ; P (BTyVar a k # \<Gamma>) \<Delta> \<sigma> \<star> \<rbrakk> \<Longrightarrow> P \<Gamma> \<Delta> (\<forall> a:k. \<sigma>) \<star>"
shows "P \<Gamma> \<Delta> \<tau> \<kappa>"
  using Ax_Ctx_Ty.inducts(3)[OF assms(1), of "\<lambda>a. True" P "\<lambda>a b. True"] assms(2-6) by simp

(* axiom validity *)
lemma axioms_valid_aux:
  shows "\<Delta> \<turnstile> \<Gamma> \<longrightarrow> \<turnstile> \<Delta>"
  and "\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k \<longrightarrow> \<turnstile> \<Delta>"
proof -
  have "(\<turnstile> \<Delta> \<longrightarrow> \<turnstile> \<Delta>) \<and> (\<Delta> \<turnstile> \<Gamma> \<longrightarrow> \<turnstile> \<Delta>) \<and> (\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k \<longrightarrow> \<turnstile> \<Delta>)"
    by (induction rule: Ax_Ctx_Ty.induct) (auto intro: Ax_intros)
  then show "\<Delta> \<turnstile> \<Gamma> \<longrightarrow> \<turnstile> \<Delta>" and "\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k \<longrightarrow> \<turnstile> \<Delta>" by simp_all
qed
lemma axioms_valid_context: "\<Delta> \<turnstile> \<Gamma> \<Longrightarrow> \<turnstile> \<Delta>"
  using axioms_valid_aux by simp
lemma axioms_valid_ty: "\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k \<Longrightarrow> \<turnstile> \<Delta>"
  using axioms_valid_aux by simp
lemma axioms_valid_tm: "\<Gamma> , \<Delta> \<turnstile> e : \<tau> \<Longrightarrow> \<turnstile> \<Delta>"
  by (induction \<Gamma> \<Delta> e \<tau> rule: Tm.induct) (auto simp: axioms_valid_context axioms_valid_ty)
lemmas axioms_valid = axioms_valid_context axioms_valid_ty axioms_valid_tm

lemma Ctx_Ty_induct_split[case_names Ctx_Empty Ctx_TyVar Ctx_Var Ty_Var Ty_App Ty_Data Ty_Arrow Ty_Forall]:
  fixes P::"\<Delta> \<Rightarrow> \<Gamma> \<Rightarrow> bool" and Q::"\<Gamma> \<Rightarrow> \<Delta> \<Rightarrow> \<tau> \<Rightarrow> \<kappa> \<Rightarrow> bool"
  assumes "\<Delta> \<turnstile> \<Gamma> \<Longrightarrow> P \<Delta> []"
  and "\<And>\<Gamma>' b k2. \<lbrakk> \<Delta> \<turnstile> \<Gamma>' @ \<Gamma> ; P \<Delta> \<Gamma>' ; atom b \<sharp> (\<Gamma>' @  \<Gamma>) \<rbrakk> \<Longrightarrow> P \<Delta> (BTyVar b k2 # \<Gamma>')"
  and "\<And>\<Gamma>' \<tau> x. \<lbrakk> \<Gamma>' @ \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : \<star> ; Q \<Gamma>' \<Delta> \<tau> \<star> ; atom x \<sharp> (\<Gamma>' @  \<Gamma>) \<rbrakk> \<Longrightarrow> P \<Delta> (BVar x \<tau> # \<Gamma>')"
  and "\<And>\<Gamma>' b k2. \<lbrakk> \<Delta> \<turnstile> \<Gamma>' @ \<Gamma> ; P \<Delta> \<Gamma>' ; BTyVar b k2 \<in> (\<Gamma>' @  \<Gamma>) \<rbrakk> \<Longrightarrow> Q \<Gamma>' \<Delta> (TyVar b) k2"
  and "\<And>\<Gamma>' \<tau>1 \<kappa>1 \<kappa>2 \<tau>2. \<lbrakk> \<Gamma>' @ \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau>1 : \<kappa>1 \<rightarrow> \<kappa>2 ; Q \<Gamma>' \<Delta> \<tau>1 (\<kappa>1 \<rightarrow> \<kappa>2) ; \<Gamma>' @ \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau>2 : \<kappa>1 ; Q \<Gamma>' \<Delta> \<tau>2 \<kappa>1 \<rbrakk> \<Longrightarrow> Q \<Gamma>' \<Delta> (TyApp \<tau>1 \<tau>2) \<kappa>2"
  and "\<And>\<Gamma>' T k. \<lbrakk> \<Delta> \<turnstile> \<Gamma>' @ \<Gamma> ; P \<Delta> \<Gamma>' ; AxData T k \<in> set \<Delta> \<rbrakk> \<Longrightarrow> Q \<Gamma>' \<Delta> (TyData T) k"
  and "\<And>\<Gamma>'. \<lbrakk> \<Delta> \<turnstile> (\<Gamma>' @ \<Gamma>) ; P \<Delta> \<Gamma>' \<rbrakk> \<Longrightarrow> Q \<Gamma>' \<Delta> TyArrow (\<star> \<rightarrow> \<star> \<rightarrow> \<star>)"
  and "\<And>\<Gamma>' b k2 \<sigma>. \<lbrakk> BTyVar b k2 # \<Gamma>' @ \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<sigma> : \<star> ; Q (BTyVar b k2 # \<Gamma>') \<Delta> \<sigma> \<star> \<rbrakk> \<Longrightarrow> Q \<Gamma>' \<Delta> (\<forall> b : k2 . \<sigma>) \<star>"
shows "\<Delta> \<turnstile> \<Gamma>' @ \<Gamma> \<longrightarrow> P \<Delta> \<Gamma>'"
  and "\<Gamma>' @ \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k2 \<longrightarrow> Q \<Gamma>' \<Delta> \<tau> k2"
proof -
  let ?\<Gamma> = "\<Gamma>' @ \<Gamma>"
  let ?P = "\<lambda>\<Delta>2 x. \<forall>\<Gamma>2. (x = \<Gamma>2 @ \<Gamma> \<and> \<Delta>2 = \<Delta>) \<longrightarrow> (P \<Delta> \<Gamma>2)"
  let ?Q = "\<lambda>x \<Delta>2 y z. \<forall>\<Gamma>2. (x = \<Gamma>2 @ \<Gamma> \<and> \<Delta>2 = \<Delta>) \<longrightarrow> (Q \<Gamma>2 \<Delta> y z)"

  have "(\<turnstile> \<Delta> \<longrightarrow> True) \<and> (\<Delta> \<turnstile> ?\<Gamma> \<longrightarrow> ?P \<Delta> ?\<Gamma>) \<and> (?\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k2 \<longrightarrow> ?Q ?\<Gamma> \<Delta> \<tau> k2)"
  proof (cases rule: Ax_Ctx_Ty.induct[of "\<lambda>x. True" "?Q" "?P"])
    case (Ctx_Empty \<Delta>)
    then show ?case
    proof (auto, goal_cases)
      case 1
      then show ?case using assms(1) Ax_Ctx_Ty.Ctx_Empty[OF Ctx_Empty(1)] by simp
    qed
  next
    case (Ctx_TyVar \<Delta>2 \<Gamma>' a k)
    then show ?case
    proof (auto, goal_cases)
      case (1 \<Gamma>2)
      then show ?case
      proof (cases "\<Gamma>2 = []")
        case True
        then have "\<Delta> \<turnstile> \<Gamma>" using Ax_Ctx_Ty.Ctx_TyVar[OF Ctx_TyVar(1,3)] 1 by auto
        then show ?thesis using assms(1) True by simp
      next
        case False
        then obtain G where "\<Gamma>' = G @ \<Gamma>" by (meson Cons_eq_append_conv 1)
        then show ?thesis using assms(2) Ctx_TyVar 1 by auto
      qed
    qed
  next
    case (Ctx_Var \<Gamma>' \<Delta>2 \<tau> x)
    then show ?case
    proof (auto, goal_cases)
      case (1 \<Gamma>2)
      then show ?case
      proof (cases "\<Gamma>2 = []")
        case True
        then have "\<Delta> \<turnstile> \<Gamma>" using Ax_Ctx_Ty.Ctx_Var[OF Ctx_Var(1,3)] 1 by simp
        then show ?thesis using True assms(1) by simp
      next
        case False
        then obtain G where "\<Gamma>' = G @ \<Gamma>" by (meson Cons_eq_append_conv 1)
        then show ?thesis using assms(3) Ctx_Var 1 by auto
      qed
    qed
  qed (auto simp: assms(1,4-8))

  then show "\<Delta> \<turnstile> \<Gamma>' @ \<Gamma> \<longrightarrow> P \<Delta> \<Gamma>'" and "\<Gamma>' @ \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k2 \<longrightarrow> Q \<Gamma>' \<Delta> \<tau> k2" by simp_all
qed

(* context validity *)
lemma context_valid_ty: "\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : \<kappa> \<Longrightarrow> \<Delta> \<turnstile> \<Gamma>"
  by (induction \<Gamma> \<Delta> \<tau> \<kappa> rule: Ty_induct) auto
lemma context_valid_tm: "\<Gamma> , \<Delta> \<turnstile> e : \<tau> \<Longrightarrow> \<Delta> \<turnstile> \<Gamma>"
  by (induction \<Gamma> \<Delta> e \<tau> rule: Tm.induct) (auto simp: context_valid_ty)
lemmas context_valid = context_valid_ty context_valid_tm

(* \<lbrakk> \<Gamma> \<turnstile> e : t ; atom x \<sharp> \<Gamma> \<rbrakk> \<Longrightarrow> atom x \<sharp> e *)
lemma fresh_in_context_ty: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k ; atom (a::tyvar) \<sharp> \<Gamma> \<rbrakk> \<Longrightarrow> atom a \<sharp> \<tau>"
proof (induction \<Gamma> \<Delta> \<tau> k rule: Ty_induct)
  case (Var \<Gamma> \<Delta> a k)
  then show ?case using fresh_at_base(2) fresh_not_isin_tyvar by fastforce
qed (auto simp: fresh_Cons)

lemma fresh_in_context_term_var: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile> e : \<tau> ; atom (x::var) \<sharp> \<Gamma> \<rbrakk> \<Longrightarrow> atom x \<sharp> e"
proof (induction \<Gamma> \<Delta> e \<tau> rule: Tm.induct)
case (Tm_Var \<Gamma> \<Delta> x \<tau>)
  then show ?case using fresh_ineq_at_base fresh_not_isin_var by force
qed (auto simp: fresh_Cons)

lemma fresh_in_context_term_tyvar: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile> e : \<tau> ; atom (a::tyvar) \<sharp> \<Gamma> \<rbrakk> \<Longrightarrow> atom a \<sharp> e"
proof (induction \<Gamma> \<Delta> e \<tau> rule: Tm.induct)
  case (Tm_Abs x \<tau>1 \<Gamma> \<Delta> e \<tau>2)
  then have "atom a \<sharp> \<tau>1" by (meson CtxE(2) context_valid_tm fresh_in_context_ty)
  then show ?case by (simp add: Tm_Abs fresh_Cons)
next
  case (Tm_Let \<Gamma> e1 e2 \<tau>1 \<tau>2 x)
  then show ?case
    by (metis (mono_tags, lifting) CtxE(2) binder.fresh(1) context_valid_tm fresh_Cons fresh_in_context_ty fresh_ineq_at_base list.set_intros(1) term.fresh(7))
qed (auto simp: fresh_Cons fresh_in_context_ty)
lemmas fresh_in_context = fresh_in_context_ty fresh_in_context_term_var fresh_in_context_term_tyvar

lemma fresh_in_axioms: "\<turnstile> \<Delta> \<Longrightarrow> atom (a::tyvar) \<sharp> \<Delta>"
proof -
  fix \<Gamma> \<tau> k
  assume a: "\<turnstile> \<Delta>"
  let ?Q = "\<lambda>b c d e. atom a \<sharp> c"
  let ?W = "\<lambda>b c. atom a \<sharp> b"

  have "(\<turnstile> \<Delta> \<longrightarrow> atom a \<sharp> \<Delta>) \<and> (\<Delta> \<turnstile> \<Gamma> \<longrightarrow> ?W \<Delta> \<Gamma>) \<and> (\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k \<longrightarrow> ?Q \<Gamma> \<Delta> \<tau> k)"
  proof (induction rule: Ax_Ctx_Ty.induct[of "\<lambda>x. atom a \<sharp> x" ?Q ?W])
    case (Ax_Ctor \<Delta> \<tau> D)
    then show ?case using fresh_in_context(1)[OF Ax_Ctor(1) fresh_Nil] fresh_Cons fresh_Nil by fastforce
  qed (auto simp: fresh_Nil fresh_Cons)

  then show ?thesis using a by simp
qed

lemma perm_axioms_tyvars[simp]: "\<turnstile> \<Delta> \<Longrightarrow> ((a::tyvar) \<leftrightarrow> b) \<bullet> \<Delta> = \<Delta>"
  using flip_fresh_fresh fresh_in_axioms by blast

nominal_inductive Ax avoids
  Ty_Forall: a
proof goal_cases
  case (1 a k \<Gamma> \<Delta> \<sigma>)
  then have "\<Delta> \<turnstile> BTyVar a k # \<Gamma>" by (rule context_valid(1))
  then have 2: "atom a \<sharp> \<Gamma>" by blast
  have 3: "atom a \<sharp> \<Delta>" by (rule fresh_in_axioms[OF axioms_valid(2)[OF 1]])
  obtain c \<sigma>' where 4: "(\<forall> a:k. \<sigma>) = (\<forall> c:k. \<sigma>') \<and> atom a \<sharp> (\<forall> c:k. \<sigma>')" using Abs_fresh_var by auto
  then have "atom a \<sharp> (\<Gamma>, \<Delta>, \<forall> c:k. \<sigma>', \<star>)" using 2 3 fresh_Pair by simp
  then show ?case using 2 fresh_star_def by fastforce
qed auto

nominal_inductive Tm avoids
  Tm_Abs: x
  | Tm_TAbs: a
  | Tm_Let: x
proof goal_cases
  case (1 x \<tau>1 \<Gamma> \<Delta> e \<tau>2)
  then have "\<Delta> \<turnstile> BVar x \<tau>1 # \<Gamma>" by (rule context_valid)
  then have 2: "atom x \<sharp> \<Gamma>" by blast
  obtain y e' where 4: "(\<lambda> x:\<tau>1. e) = (\<lambda> y:\<tau>1. e') \<and> atom x \<sharp> (\<lambda> y:\<tau>1. e')" using Abs_fresh_var by auto
  then have "atom x \<sharp> (\<Gamma>, \<Delta>, \<lambda> y:\<tau>1. e', \<tau>1 \<rightarrow> \<tau>2)" using 2 fresh_Pair by simp
  then show ?case using 4 fresh_star_def by fastforce
next
  case (3 a k \<Gamma> \<Delta> e \<sigma>)
  then have "\<Delta> \<turnstile> BTyVar a k # \<Gamma>" by (rule context_valid)
  then have 1: "atom a \<sharp> \<Gamma>" by blast
  have 2: "atom a \<sharp> \<Delta>" by (rule fresh_in_axioms[OF axioms_valid(3)[OF 3]])
  obtain y e' where 3: "(\<Lambda> a:k. e) = (\<Lambda> y:k. e') \<and> atom a \<sharp> (\<Lambda> y:k. e')" using Abs_fresh_var by auto
  obtain y2 \<sigma>' where 4: "(\<forall> a:k. \<sigma>) = (\<forall> y2:k. \<sigma>') \<and> atom a \<sharp> (\<forall> y2:k. \<sigma>')" using Abs_fresh_var by auto
  then have "atom a \<sharp> (\<Gamma>, \<Delta>, \<Lambda> y:k. e', \<forall> y2:k. \<sigma>')" using 1 2 3 by auto
  then show ?case using 3 4 fresh_star_def by force
next
  case (5 \<Gamma> \<Delta> e1 \<tau>1 x e2 \<tau>2)
  from 5(2) have "\<Delta> \<turnstile> BVar x \<tau>1 # \<Gamma>" by (rule context_valid)
  then have 1: "atom x \<sharp> \<Gamma>" by blast
  then have "atom x \<sharp> e1" using 5(1) fresh_in_context(2) by blast
  then obtain y e2' where 2: "Let x \<tau>1 e1 e2 = Let y \<tau>1 e1 e2' \<and> atom x \<sharp> Let y \<tau>1 e1 e2'" using Abs_fresh_var by auto
  then have "atom x \<sharp> (\<Gamma>, \<Delta>, Let y \<tau>1 e1 e2', \<tau>2)" using 1 fresh_Pair by simp
  then show ?case using 2 fresh_star_def by fastforce
qed auto

end


section "Splay Tree"

subsection "Basics"

theory Splay_Tree_Analysis_Base
imports
  Lemmas_log
  Splay_Tree.Splay_Tree
begin

declare size1_size[simp]

abbreviation "\<phi> t == log 2 (size1 t)"

fun \<Phi> :: "'a tree \<Rightarrow> real" where
"\<Phi> Leaf = 0" |
"\<Phi> (Node l a r) = \<Phi> l + \<Phi> r + \<phi> (Node l a r)"

fun t_splay :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
"t_splay x Leaf = 1" |
"t_splay x (Node AB b CD) =
  (case cmp x b of
   EQ \<Rightarrow> 1 |
   LT \<Rightarrow> (case AB of
          Leaf \<Rightarrow> 1 |
          Node A a B \<Rightarrow>
            (case cmp x a of EQ \<Rightarrow> 1 |
             LT \<Rightarrow> if A = Leaf then 1 else t_splay x A + 1 |
             GT \<Rightarrow> if B = Leaf then 1 else t_splay x B + 1)) |
   GT \<Rightarrow> (case CD of
          Leaf \<Rightarrow> 1 |
          Node C c D \<Rightarrow>
            (case cmp x c of EQ \<Rightarrow> 1 |
             LT \<Rightarrow> if C = Leaf then 1 else t_splay x C + 1 |
             GT \<Rightarrow> if D = Leaf then 1 else t_splay x D + 1)))"

lemma t_splay_simps[simp]:
  "t_splay a (Node l a r) = 1"
  "a<b \<Longrightarrow> t_splay a (Node Leaf b r) = 1"
  "a<b \<Longrightarrow> t_splay a (Node (Node ll a lr) b r) = 1"
  "a<b \<Longrightarrow> a<c \<Longrightarrow> t_splay a (Node (Node ll c lr) b r) =
   (if ll = Leaf then 1 else t_splay a ll + 1)"
  "a<b \<Longrightarrow> c<a \<Longrightarrow> t_splay a (Node (Node ll c lr) b r) =
   (if lr = Leaf then 1 else t_splay a lr + 1)"
  "b<a \<Longrightarrow> t_splay a (Node l b Leaf) = 1"
  "b<a \<Longrightarrow> t_splay a (Node l b (Node rl a rr)) = 1"
  "b<a \<Longrightarrow> a<c \<Longrightarrow> t_splay a (Node l b (Node rl c rr)) =
  (if rl=Leaf then 1 else t_splay a rl + 1)"
  "b<a \<Longrightarrow> c<a \<Longrightarrow> t_splay a (Node l b (Node rl c rr)) =
  (if rr=Leaf then 1 else t_splay a rr + 1)"
by auto

declare t_splay.simps(2)[simp del]

fun t_splay_max :: "'a::linorder tree \<Rightarrow> nat" where
"t_splay_max Leaf = 1" |
"t_splay_max (Node l b Leaf) = 1" |
"t_splay_max (Node l b (Node rl c rr)) = (if rr=Leaf then 1 else t_splay_max rr + 1)"

definition t_delete :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
"t_delete a t = (if t = Leaf then 0 else t_splay a t + (case splay a t of
  Node l x r \<Rightarrow>
    if x=a then case l of Leaf \<Rightarrow> 0 | _ \<Rightarrow> t_splay_max l
    else 0))"

lemma ex_in_set_tree: "t \<noteq> Leaf \<Longrightarrow> bst t \<Longrightarrow>
  \<exists>a' \<in> set_tree t. splay a' t = splay a t \<and> t_splay a' t = t_splay a t"
proof(induction a t rule: splay.induct)
  case (6 a b c ll)
  hence "splay a ll \<noteq> Leaf" by simp
  then obtain lll u llr where [simp]: "splay a ll = Node lll u llr"
    by (metis tree.exhaust)
  have "b < c" "bst ll" using "6.prems" by auto
  from "6.IH"[OF \<open>ll \<noteq> Leaf\<close> \<open>bst ll\<close>]
  obtain e where "e \<in> set_tree ll" "splay e ll = splay a ll" "t_splay e ll = t_splay a ll"
    by blast
  moreover hence "e<b" using "6.prems"(2) by auto
  ultimately show ?case using \<open>a<c\<close> \<open>a<b\<close> \<open>b<c\<close> \<open>bst ll\<close> by force
next
  case (8 b a c lr)
  hence "splay a lr \<noteq> Leaf" by simp
  then obtain lrl u lrr where [simp]: "splay a lr = Node lrl u lrr"
    by (metis tree.exhaust)
  have "b < c" "bst lr" using "8.prems" by auto
  from "8.IH"[OF \<open>lr \<noteq> Leaf\<close> \<open>bst lr\<close>]
  obtain e where "e \<in> set_tree lr" "splay e lr = splay a lr" "t_splay e lr = t_splay a lr"
    by blast
  moreover hence "b<e & e<c" using "8.prems"(2) by simp
  ultimately show ?case using \<open>a<c\<close> \<open>b<a\<close> \<open>b<c\<close> \<open>bst lr\<close> by force
next
  case (11 c a b rl)
  hence "splay a rl \<noteq> Leaf" by simp
  then obtain rll u rlr where [simp]: "splay a rl = Node rll u rlr"
    by (metis tree.exhaust)
  have "c < b" "bst rl" using "11.prems" by auto
  from "11.IH"[OF \<open>rl \<noteq> Leaf\<close> \<open>bst rl\<close>]
  obtain e where "e \<in> set_tree rl" "splay e rl = splay a rl" "t_splay e rl = t_splay a rl"
    by blast
  moreover hence "c<e & e<b" using "11.prems" by simp
  ultimately show ?case using \<open>c<a\<close> \<open>a<b\<close> \<open>c<b\<close> \<open>bst rl\<close> by force
next
  case (14 c a b rr)
  hence "splay a rr \<noteq> Leaf" by simp
  then obtain rrl u rrr where [simp]: "splay a rr = Node rrl u rrr"
    by (metis tree.exhaust)
  have "c < b" "bst rr" using "14.prems" by auto
  from "14.IH"[OF \<open>rr \<noteq> Leaf\<close> \<open>bst rr\<close>]
  obtain e where "e \<in> set_tree rr" "splay e rr = splay a rr" "t_splay e rr = t_splay a rr"
    by blast
  moreover hence "b<e" using "14.prems"(2) by simp
  ultimately show ?case using \<open>c<a\<close> \<open>b<a\<close> \<open>c<b\<close> \<open>bst rr\<close> by force
qed (auto simp: le_less)

datatype 'a op = Empty | Splay 'a | Insert 'a | Delete 'a

fun arity :: "'a::linorder op \<Rightarrow> nat" where
"arity Empty = 0" |
"arity (Splay a) = 1" |
"arity (Insert a) = 1" |
"arity (Delete a) = 1"

fun exec :: "'a::linorder op \<Rightarrow> 'a tree list \<Rightarrow> 'a tree" where
"exec Empty [] = Leaf" |
"exec (Splay a) [t] = splay a t" |
"exec (Insert a) [t] = Splay_Tree.insert a t" |
"exec (Delete a) [t] = Splay_Tree.delete a t"

fun cost :: "'a::linorder op \<Rightarrow> 'a tree list \<Rightarrow> nat" where
"cost Empty [] = 1" |
"cost (Splay a) [t] = t_splay a t" |
"cost (Insert a) [t] = t_splay a t" |
"cost (Delete a) [t] = t_delete a t"

end


theory sse_operation_negative_quantification
  imports sse_operation_negative sse_boolean_algebra_quantification
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

subsection \<open>Definitions and interrelations (infinitary case)\<close>

text\<open>\noindent{We define and interrelate infinitary variants for some previously introduced ('negative') conditions
on operations. We show how they relate to quantifiers as previously defined.}\<close>

text\<open>\noindent{iDM: infinitary De Morgan laws.}\<close>
abbreviation riDM1 ("iDM1\<^sup>_ _") where "iDM1\<^sup>S \<eta> \<equiv> \<eta>(\<^bold>\<Or>S) \<^bold>\<preceq> \<^bold>\<And>Ra[\<eta>|S]"
abbreviation riDM2 ("iDM2\<^sup>_ _") where "iDM2\<^sup>S \<eta> \<equiv> \<^bold>\<Or>Ra[\<eta>|S] \<^bold>\<preceq> \<eta>(\<^bold>\<And>S)"
abbreviation riDM3 ("iDM3\<^sup>_ _") where "iDM3\<^sup>S \<eta> \<equiv> \<eta>(\<^bold>\<And>S) \<^bold>\<preceq> \<^bold>\<Or>Ra[\<eta>|S]"
abbreviation riDM4 ("iDM4\<^sup>_ _") where "iDM4\<^sup>S \<eta> \<equiv> \<^bold>\<And>Ra[\<eta>|S] \<^bold>\<preceq> \<eta>(\<^bold>\<Or>S)"
definition "iDM1 \<eta> \<equiv> \<forall>S. iDM1\<^sup>S \<eta>"
definition "iDM2 \<eta> \<equiv> \<forall>S. iDM2\<^sup>S \<eta>"
definition "iDM3 \<eta> \<equiv> \<forall>S. iDM3\<^sup>S \<eta>"
definition "iDM4 \<eta> \<equiv> \<forall>S. iDM4\<^sup>S \<eta>"
declare iDM1_def[Defs] iDM2_def[Defs] iDM3_def[Defs] iDM4_def[Defs]

lemma CoPw_iDM1: "CoPw \<eta> \<Longrightarrow> iDM1 \<eta>" unfolding Defs by (smt Ra_restr_all sup_char)
lemma CoPw_iDM2: "CoPw \<eta> \<Longrightarrow> iDM2 \<eta>" unfolding Defs by (smt Ra_restr_ex inf_char)
lemma CoP2_iDM3: "CoP2 \<eta> \<Longrightarrow> iDM3 \<eta>" by (smt CoP2_def Ra_restr_ex iDM3_def inf_char)
lemma CoP1_iDM4: "CoP1 \<eta> \<Longrightarrow> iDM4 \<eta>" by (smt CoP1_def Ra_restr_all iDM4_def sup_char)
lemma "XCoP \<eta> \<Longrightarrow> iDM3 \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> iDM4 \<eta>" nitpick oops

text\<open>\noindent{DM1, DM2, iDM1, iDM2 and CoPw are equivalent.}\<close>
lemma iDM1_rel: "iDM1 \<eta> \<Longrightarrow> DM1 \<eta>" proof -
  assume idm1: "iDM1 \<eta>"
   { fix a::"\<sigma>" and b::"\<sigma>"
     let ?S="\<lambda>Z. Z=a \<or> Z=b"
     have "\<^bold>\<And>Ra[\<eta>|?S] = \<^bold>\<forall>\<^sup>R\<lparr>?S\<rparr> \<eta>" using Ra_restr_all by blast
     moreover have "\<^bold>\<forall>\<^sup>R\<lparr>?S\<rparr> \<eta> = (\<eta> a) \<^bold>\<and> (\<eta> b)" using meet_def by auto
     ultimately have "\<^bold>\<And>Ra[\<eta>|?S] = (\<eta> a) \<^bold>\<and> (\<eta> b)" by simp
     moreover have "\<^bold>\<Or>?S = a \<^bold>\<or> b" using supremum_def join_def by auto
     moreover from idm1 have "\<eta>(\<^bold>\<Or>?S) \<^bold>\<preceq> \<^bold>\<And>Ra[\<eta>|?S]" by (simp add: iDM1_def)
     ultimately have "\<eta>(a \<^bold>\<or> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<and> (\<eta> b)" by simp
   } thus ?thesis by (simp add: DM1_def)
 qed
lemma iDM2_rel: "iDM2 \<eta> \<Longrightarrow> DM2 \<eta>" proof -
  assume idm2: "iDM2 \<eta>"
   { fix a::"\<sigma>" and b::"\<sigma>"
     let ?S="\<lambda>Z. Z=a \<or> Z=b"
     have "\<^bold>\<Or>Ra[\<eta>|?S] = \<^bold>\<exists>\<^sup>R\<lparr>?S\<rparr> \<eta>" using Ra_restr_ex by blast
     moreover have "\<^bold>\<exists>\<^sup>R\<lparr>?S\<rparr> \<eta> = (\<eta> a) \<^bold>\<or> (\<eta> b)" using join_def by auto
     ultimately have "\<^bold>\<Or>Ra[\<eta>|?S] = (\<eta> a) \<^bold>\<or> (\<eta> b)" by simp
     moreover have "\<^bold>\<And>?S = a \<^bold>\<and> b" using infimum_def meet_def by auto
     moreover from idm2 have "\<^bold>\<Or>Ra[\<eta>|?S] \<^bold>\<preceq> \<eta>(\<^bold>\<And>?S)" by (simp add: iDM2_def)
     ultimately have "(\<eta> a) \<^bold>\<or> (\<eta> b) \<^bold>\<preceq> \<eta>(a \<^bold>\<and> b)" by auto
   } thus ?thesis by (simp add: DM2_def)
qed
lemma "DM1 \<eta> = iDM1 \<eta>" using CoPw_iDM1 DM1_CoPw iDM1_rel by blast
lemma "DM2 \<eta> = iDM2 \<eta>" using CoPw_iDM2 DM2_CoPw iDM2_rel by blast
lemma "iDM1 \<eta> = iDM2 \<eta>" using CoPw_iDM1 CoPw_iDM2 DM1_CoPw DM2_CoPw iDM1_rel iDM2_rel by blast

text\<open>\noindent{iDM3/4 entail their finitary variants but not the other way round.}\<close>
lemma iDM3_rel: "iDM3 \<eta> \<Longrightarrow> DM3 \<eta>" proof -
  assume idm3: "iDM3 \<eta>"
   { fix a::"\<sigma>" and b::"\<sigma>"
     let ?S="\<lambda>Z. Z=a \<or> Z=b"
     have "\<^bold>\<Or>Ra[\<eta>|?S] = \<^bold>\<exists>\<^sup>R\<lparr>?S\<rparr> \<eta>" using Ra_restr_ex by blast
     moreover have "\<^bold>\<exists>\<^sup>R\<lparr>?S\<rparr> \<eta> = (\<eta> a) \<^bold>\<or> (\<eta> b)" using join_def by auto
     ultimately have "\<^bold>\<Or>Ra[\<eta>|?S] = (\<eta> a) \<^bold>\<or> (\<eta> b)" by simp
     moreover have "\<^bold>\<And>?S = a \<^bold>\<and> b" using infimum_def meet_def by auto
     moreover from idm3 have "\<eta>(\<^bold>\<And>?S) \<^bold>\<preceq> \<^bold>\<Or>Ra[\<eta>|?S]" by (simp add: iDM3_def)
     ultimately have "\<eta>(a \<^bold>\<and> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)" by auto
   } thus ?thesis by (simp add: DM3_def)
qed
lemma iDM4_rel: "iDM4 \<eta> \<Longrightarrow> DM4 \<eta>" proof -
  assume idm4: "iDM4 \<eta>"
   { fix a::"\<sigma>" and b::"\<sigma>"
     let ?S="\<lambda>Z. Z=a \<or> Z=b"
     have "\<^bold>\<And>Ra[\<eta>|?S] = \<^bold>\<forall>\<^sup>R\<lparr>?S\<rparr> \<eta>" using Ra_restr_all by blast
     moreover have "\<^bold>\<forall>\<^sup>R\<lparr>?S\<rparr> \<eta> = (\<eta> a) \<^bold>\<and> (\<eta> b)" using meet_def by auto
     ultimately have "\<^bold>\<And>Ra[\<eta>|?S] = (\<eta> a) \<^bold>\<and> (\<eta> b)" by simp
     moreover have "\<^bold>\<Or>?S = a \<^bold>\<or> b" using supremum_def join_def by auto
     moreover from idm4 have "\<^bold>\<And>Ra[\<eta>|?S] \<^bold>\<preceq> \<eta>(\<^bold>\<Or>?S)" by (simp add: iDM4_def)
     ultimately have "(\<eta> a) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> \<eta>(a \<^bold>\<or> b)" by simp
   } thus ?thesis by (simp add: DM4_def)
 qed
lemma "DM3 \<eta> \<Longrightarrow> iDM3 \<eta>" nitpick oops
lemma "DM4 \<eta> \<Longrightarrow> iDM4 \<eta>" nitpick oops

text\<open>\noindent{Indeed the previous characterization of the infinitary De Morgan laws is fairly general and entails
the traditional version employing quantifiers (though not the other way round).}\<close>
text\<open>\noindent{The first two variants DM1/2 follow easily from DM1/2, iDM1/2 or CoPw (all of them equivalent).}\<close>
lemma iDM1_trad: "iDM1 \<eta> \<Longrightarrow> \<forall>\<pi>. \<eta>(\<^bold>\<exists>x. \<pi> x)  \<^bold>\<preceq>  (\<^bold>\<forall>x. \<eta>(\<pi> x))" by (metis (mono_tags, lifting) CoPw_def DM1_CoPw iDM1_rel)
lemma iDM2_trad: "iDM2 \<eta> \<Longrightarrow> \<forall>\<pi>. (\<^bold>\<exists>x. \<eta>(\<pi> x)) \<^bold>\<preceq> \<eta>(\<^bold>\<forall>x. \<pi> x)" by (metis (mono_tags, lifting) CoPw_def DM2_CoPw iDM2_rel)

text\<open>\noindent{An analogous relationship holds for variants DM3/4, though the proof is less trivial.
To see how let us first consider an intermediate version of the De Morgan laws, obtained as a
particular case of the general variant above, with S as the range of a propositional function.}\<close>
abbreviation "piDM1 \<pi> \<eta> \<equiv> \<eta>(\<^bold>\<Or>Ra(\<pi>)) \<^bold>\<preceq> \<^bold>\<And>Ra[\<eta>|Ra(\<pi>)]"
abbreviation "piDM2 \<pi> \<eta> \<equiv> \<^bold>\<Or>Ra[\<eta>|Ra(\<pi>)] \<^bold>\<preceq> \<eta>(\<^bold>\<And>Ra(\<pi>))"
abbreviation "piDM3 \<pi> \<eta> \<equiv> \<eta>(\<^bold>\<And>Ra(\<pi>)) \<^bold>\<preceq> \<^bold>\<Or>Ra[\<eta>|Ra(\<pi>)]"
abbreviation "piDM4 \<pi> \<eta> \<equiv> \<^bold>\<And>Ra[\<eta>|Ra(\<pi>)] \<^bold>\<preceq> \<eta>(\<^bold>\<Or>Ra(\<pi>))"

text\<open>\noindent{They are entailed (unidirectionally) by the general De Morgan laws.}\<close>
lemma "iDM1 \<eta> \<Longrightarrow> \<forall>\<pi>. piDM1 \<pi> \<eta>" by (simp add: iDM1_def)
lemma "iDM2 \<eta> \<Longrightarrow> \<forall>\<pi>. piDM2 \<pi> \<eta>" by (simp add: iDM2_def)
lemma "iDM3 \<eta> \<Longrightarrow> \<forall>\<pi>. piDM3 \<pi> \<eta>" by (simp add: iDM3_def)
lemma "iDM4 \<eta> \<Longrightarrow> \<forall>\<pi>. piDM4 \<pi> \<eta>" by (simp add: iDM4_def)

text\<open>\noindent{Drawing upon the relationships shown previously we can rewrite the latter two as:}\<close>
lemma iDM3_aux: "piDM3 \<pi> \<eta> \<equiv> \<eta>(\<^bold>\<forall>\<pi>) \<^bold>\<preceq> \<^bold>\<exists>[\<eta>|\<lparr>Ra \<pi>\<rparr>]\<^sup>N" unfolding Ra_all Ra_ex_restr by simp
lemma iDM4_aux: "piDM4 \<pi> \<eta> \<equiv> \<^bold>\<forall>[\<eta>|\<lparr>Ra \<pi>\<rparr>]\<^sup>P \<^bold>\<preceq> \<eta>(\<^bold>\<exists>\<pi>)" unfolding Ra_ex Ra_all_restr by simp

text\<open>\noindent{and thus finally obtain the desired formulas.}\<close>
lemma iDM3_trad: "iDM3 \<eta> \<Longrightarrow> \<forall>\<pi>. \<eta>(\<^bold>\<forall>x. \<pi> x)  \<^bold>\<preceq>  (\<^bold>\<exists>x. \<eta>(\<pi> x))" by (metis Ra_ex_comp2 iDM3_def iDM3_aux comp_apply)
lemma iDM4_trad: "iDM4 \<eta> \<Longrightarrow> \<forall>\<pi>. (\<^bold>\<forall>x. \<eta>(\<pi> x)) \<^bold>\<preceq> \<eta>(\<^bold>\<exists>x. \<pi> x)" by (metis Ra_all_comp1 iDM4_def iDM4_aux comp_apply)

end


theory Nat_Language
  imports "../Isabelle/WP_Typed_Rely_Guarantee"
begin

datatype ('Addr) aexp =
  Load "'Addr"
  | Nat "nat"
  | UExp "nat \<Rightarrow> nat" "'Addr aexp"
  | BExp "'Addr aexp" "nat \<Rightarrow> nat \<Rightarrow> nat" "'Addr aexp"

datatype 'Addr bexp =
  true
  | false
  | Conj "'Addr bexp" "'Addr bexp"
  | Disj "'Addr bexp" "'Addr bexp"
  | Not  "'Addr bexp"
  | UCmp "nat \<Rightarrow> bool" "'Addr aexp"
  | BCmp "'Addr aexp" "nat \<Rightarrow> nat \<Rightarrow> bool" "'Addr aexp"

fun
  eval\<^sub>A :: "('Addr,nat) Mem \<Rightarrow> 'Addr aexp \<Rightarrow> nat"
where
  "eval\<^sub>A mem (Load v) = mem v" |
  "eval\<^sub>A mem (Nat c) = c" |
  "eval\<^sub>A mem (UExp f a) = f (eval\<^sub>A mem a)" |
  "eval\<^sub>A mem (BExp a f b) = f (eval\<^sub>A mem a) (eval\<^sub>A mem b)"

fun
  eval\<^sub>B :: "('Addr,nat) Mem \<Rightarrow> 'Addr bexp \<Rightarrow> bool"
where
  "eval\<^sub>B mem (Conj P Q) = (eval\<^sub>B mem P \<and> eval\<^sub>B mem Q)" |
  "eval\<^sub>B mem (Disj P Q) = (eval\<^sub>B mem P \<or> eval\<^sub>B mem Q)" |
  "eval\<^sub>B mem (Not P) = (\<not> eval\<^sub>B mem P)" |
  "eval\<^sub>B mem (UCmp f a) = f (eval\<^sub>A mem a)" |
  "eval\<^sub>B mem (BCmp a f b) = f (eval\<^sub>A mem a) (eval\<^sub>A mem b)" |
  "eval\<^sub>B mem (true) = True" |
  "eval\<^sub>B mem (false) = False"

fun
  lift\<^sub>A :: "'Addr aexp \<Rightarrow> ('Addr,nat) exp"
where
  "lift\<^sub>A (Load v) = Var v" |
  "lift\<^sub>A (Nat n) = Const n" |
  "lift\<^sub>A (UExp f a) = Op (\<lambda>x y. f x) (lift\<^sub>A a) (Const 0)" |
  "lift\<^sub>A (BExp e\<^sub>1 f e\<^sub>2) = Op (f) (lift\<^sub>A e\<^sub>1) (lift\<^sub>A e\<^sub>2)"

fun
  lift\<^sub>B :: "'Addr bexp \<Rightarrow> ('Addr,nat) pred"
where
  "lift\<^sub>B (Conj P Q) = (lift\<^sub>B P \<and>\<^sub>p lift\<^sub>B Q)" |
  "lift\<^sub>B (Disj P Q) = (lift\<^sub>B P \<or>\<^sub>p lift\<^sub>B Q)" |
  "lift\<^sub>B (Not P) = (PNeg (lift\<^sub>B P))" |
  "lift\<^sub>B (UCmp f a) = (PCmp (\<lambda>x y. f x) (lift\<^sub>A a) (Const 0))" |
  "lift\<^sub>B (BCmp a f b) = (PCmp f (lift\<^sub>A a) (lift\<^sub>A b))" |
  "lift\<^sub>B (true) = (Pb True)" |
  "lift\<^sub>B (false) = (Pb False)"

fun
  vars\<^sub>A :: "'Addr aexp \<Rightarrow> 'Addr list"
where
  "vars\<^sub>A (Load v) = [v]" |
  "vars\<^sub>A (Nat n) = []" |
  "vars\<^sub>A (UExp f a) = (vars\<^sub>A a)" |
  "vars\<^sub>A (BExp a f b) = (vars\<^sub>A a @ vars\<^sub>A b)"

fun
  vars\<^sub>B :: "'Addr bexp \<Rightarrow> 'Addr list"
where
  "vars\<^sub>B (Conj P Q) = (vars\<^sub>B P @ vars\<^sub>B Q)" |
  "vars\<^sub>B (Disj P Q) = (vars\<^sub>B P @ vars\<^sub>B Q)" |
  "vars\<^sub>B (Not P) = (vars\<^sub>B P)" |
  "vars\<^sub>B (UCmp f a) = (vars\<^sub>A a)" |
  "vars\<^sub>B (BCmp a f b) = (vars\<^sub>A a @ vars\<^sub>A b)" |
  "vars\<^sub>B _ = []"

(* Common operations *)
abbreviation inc :: "'Addr \<Rightarrow> ('Addr, nat) rpred" where
  "inc y \<equiv> (PCmp (\<le>) (Var y\<^sup>o) (Var y`))"

definition const :: "'Addr \<Rightarrow> ('Addr, nat) rpred" where
  "const y \<equiv> (PCmp (=) (Var (Orig y)) (Var (Prime y))) \<and>\<^sub>p (Low (Orig y) \<longrightarrow>\<^sub>p Low (Prime y))"

definition invar :: "('Addr, nat) pred \<Rightarrow> ('Addr, nat) rpred" where
  "invar P \<equiv> orig P \<longrightarrow>\<^sub>p Primed_Typed_Predicate_Language.prime P"

locale nat_language =
  fixes all_vars :: "'Addr list"
  and locals :: "'Addr list"
  assumes all: "UNIV = set all_vars"

context nat_language
begin

named_theorems nat_language_simp

lemma nl_eval\<^sub>A [nat_language_simp]:
  "eval mem (lift\<^sub>A e) = eval\<^sub>A mem e"
  by (induct e, auto)

lemma nl_eval\<^sub>B [nat_language_simp]:
  "test mem \<Gamma> (lift\<^sub>B e) = eval\<^sub>B mem e"
  by (induct e, auto simp: nl_eval\<^sub>A)

lemma nl_vars\<^sub>A [nat_language_simp]:
  "set (vars\<^sub>A e) = vars\<^sub>e (lift\<^sub>A e)"
  by (induct e, auto)

lemma nl_vars\<^sub>B [nat_language_simp]:
  "set (vars\<^sub>B e) = vars\<^sub>p (lift\<^sub>B e)"
  by (induct e, auto simp: nl_vars\<^sub>A)

end

sublocale nat_language \<subseteq> type_rg_if_impl all_vars eval\<^sub>A eval\<^sub>B lift\<^sub>A lift\<^sub>B vars\<^sub>A vars\<^sub>B Not locals
  by unfold_locales (auto simp: all nat_language_simp)

method allvars_tac = (intro UNIV_eq_I; case_tac xa; simp)

context nat_language
begin

method try_refl = (insert context_order_refl; assumption)?

lemma prepare[intro]:
  assumes "\<forall>m \<Gamma>. test m \<Gamma> (P \<longrightarrow>\<^sub>p Q)"
  shows "P \<turnstile>\<^sub>p Q"
  using assms unfolding entail_def by auto

named_theorems RGSpec

named_theorems RGSimp
declare step_def [RGSimp]
declare str_env_def [RGSimp]
declare invar_def [RGSimp]
declare const_def [RGSimp]
declare Primed_Typed_Predicate_Language.prime_def [RGSimp]
declare type_ord_def [RGSimp]

method wf_solve =
  (match conclusion in "transitive R" for R \<Rightarrow> \<open>simp add: transitive_def; intro impI allI; normalization; clarsimp\<close>) |
  (match conclusion in "reflexive G" for G \<Rightarrow> \<open>simp add: reflexive_def; intro impI allI; normalization; clarsimp\<close>) |
  (match conclusion in "wf\<^sub>\<L> L" for L \<Rightarrow> \<open>simp add: wf\<^sub>\<L>_def, intro allI, case_tac x, simp_all\<close>) |
  (match conclusion in "str_env (step G)" for G \<Rightarrow> \<open>simp add: RGSimp\<close>) |
  (match conclusion in "onlyGlobals R" for R \<Rightarrow> \<open>normalization; simp add: RGSimp\<close>)

method wf_spec = (solves \<open>insert RGSpec, simp\<close> | wf_solve)

method stable = ((unfold asn_def)?, intro allI impI, normalization, clarsimp, argo?)

method solve =
  (match conclusion in "P \<turnstile>\<^sub>p Q" for P Q \<Rightarrow> \<open>intro prepare allI\<close>; normalization; clarsimp?) |
  (match conclusion in "\<forall>m \<Gamma> m' \<Gamma>' mh \<Gamma>h. test (m \<Oplus> mh) (\<Gamma> \<Oplus> \<Gamma>h) P \<and> test (m \<mapsto> m') (\<Gamma> \<mapsto> \<Gamma>') R \<longrightarrow> test (m' \<Oplus> mh) (\<Gamma>' \<Oplus> \<Gamma>h) P" for P R \<Rightarrow> \<open>stable\<close>)

method act_intro = (rule actWP_rewrite)

method step =
  (match conclusion in "valid R G \<L> P (c\<^sub>2 ; c\<^sub>1) Q" for R G P c\<^sub>1 c\<^sub>2 \<L> Q \<Rightarrow> \<open>rule seqWP\<close>) |
  (match conclusion in "valid R G \<L> P (Act \<alpha>) Q" for R G P \<alpha> \<L> Q \<Rightarrow> \<open>act_intro\<close>, try_refl) |
  (match conclusion in "valid R G \<L> P (Skip) Q" for R G P \<L> Q  \<Rightarrow> \<open>rule skipWP_rewrite\<close>, try_refl) |
  (match conclusion in "valid R G \<L> P (DoWhile c I g) Q" for R G P \<L> c I g Q  \<Rightarrow> \<open>rule doWhileWP\<close>, try_refl) |
  (match conclusion in "valid R G \<L> P (While c I g) Q" for R G P \<L> c I g Q  \<Rightarrow> \<open>rule whileWP_rewrite\<close>, try_refl) |
  (match conclusion in "valid R G \<L> P (If c I g) Q" for R G P \<L> c I g Q  \<Rightarrow> \<open>rule ifWP_rewrite\<close>, try_refl)

method pre = (rule if_secureI, wf_spec, wf_spec, wf_spec, wf_spec, wf_spec, wf_spec, wf_spec)
method stepall = (find_goal \<open>step\<close>)+
method vcg = (pre, stepall)
method solveall = (solve+)
method vcgsolve = (vcg, solveall, (intro conjI impI)?)

end

end