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

(*
  A simple example of strongest-post and weakest-pre reasoning in separation
  logic with wand and snake.
 *)

theory Simple_Separation_Example
imports
  "Extended_Separation_Algebra"
  "Hoare_Sep_Tactics"
  "Sep_SP"
begin

lemma sep_sp_coimpl[sep_sp]:
  "(\<And>R. \<lbrace>(P \<leadsto>* R)\<rbrace> f \<lbrace>\<lambda>rv. (Q rv \<and>* R)\<rbrace>) \<Longrightarrow>
   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv. (Q rv \<and>* (P -* R)) \<rbrace>"
  apply (rule hoare_chain, atomize, erule allE, assumption)
  apply (sep_forward, assumption)
  apply (assumption)
done

declare [[syntax_ambiguity_warning = false]]

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

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

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

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

lemma precise_maps_to: "precise (p \<mapsto> v)"
  apply (clarsimp simp: precise_def maps_to_def)
  done

lemma precise_maps_to_ex: "precise (p \<mapsto> -)"
  apply (clarsimp simp: precise_def maps_to_def maps_to_ex_def)
  apply (rule ext, clarsimp simp: sep_substate_def)
  apply (clarsimp simp: plus_fun_def plus_option_def)
  apply (drule fun_cong[where x=p], clarsimp split: option.splits)
  by (metis (full_types) fun_upd_same option.distinct(2) option.simps(5) sep_disj_fun_def sep_disj_option_def)

declare precise_maps_to[precise]
declare precise_maps_to_ex[precise]
declare maps_to_maps_to_ex[sep_cancel]

lemma precise_weaken_pre:
  "precise P \<Longrightarrow> \<lbrace>P \<leadsto>* R\<rbrace> f \<lbrace>\<lambda>_. Q \<and>* R\<rbrace>  \<Longrightarrow> \<lbrace>P \<and>* R\<rbrace> f \<lbrace>\<lambda>_. Q \<and>* R\<rbrace> "
  apply (rule hoare_weaken_pre, assumption)
  by (simp add: precise_conj_coimpl)

definition
  "delete_ptr p = do {
     x <- gets (\<lambda>s. s p);
     assert (x \<noteq> None);
     modify (\<lambda>s x.  if x = p then None else s x )
   }"

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

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

definition
  "new_ptr = do {
     s \<leftarrow> get;
     assert (\<exists>p. s p = None);
     p \<leftarrow> return (SOME p. s p = None);
     modify (\<lambda>s. s(p \<mapsto> 0));
     return p
   }"

declare K_def [simp] pred_conj_def [simp]

lemma None_disj[simp]: "None ## x \<and> x ## None"
  by (clarsimp simp: sep_disj_option_def split: option.splits)

lemma None_plus[simp]: "x + None = x \<and> None + x = x"
  by (simp add: plus_option_def split: option.splits)

lemma SOME_None[simp]:
  "s p = None \<Longrightarrow> s (SOME p. s p = None) = None"
  by (rule someI)

lemma new_ptr_sp[sp]: "\<lbrace>\<box> \<and>* R\<rbrace> new_ptr \<lbrace>\<lambda>rv. rv \<mapsto> - \<and>* R\<rbrace>"
  apply (clarsimp simp: new_ptr_def)
  apply Det_Monad.wp
  apply (rename_tac s)
  apply (simp add: Ball_def, intro allI impI)
  apply (clarsimp simp: sep_conj_def)
  apply (rule_tac x="[SOME p. s p = None \<mapsto> 0]" in exI)
  apply (rule_tac x=s in exI)
  by (auto simp: maps_to_ex_def maps_to_def plus_fun_def sep_disj_fun_def)

lemma delete_ptr_sp[sp]: "\<lbrace>p \<mapsto> - \<leadsto>* R\<rbrace> delete_ptr p \<lbrace>\<lambda>_. R\<rbrace>"
  apply (clarsimp simp: delete_ptr_def, Det_Monad.wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
  apply (rename_tac v)
  apply (erule_tac x="[p \<mapsto> v] :: heap" in allE)
  apply (drule mp)
   apply (clarsimp simp: maps_to_ex_def maps_to_def, fastforce)
  apply (erule_tac x="(\<lambda>ptr. if ptr = p then None else s ptr)" in allE)
  apply (drule mp)
   apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
  apply (drule mp)
   apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
  apply (assumption)
  done

lemma set_ptr_sp[sp]: "\<lbrace>p \<mapsto> - \<leadsto>* R\<rbrace> set_ptr p v  \<lbrace>\<lambda>_. p \<mapsto> v \<and>* R\<rbrace>"
  apply (clarsimp simp: set_ptr_def, Det_Monad.wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
  apply (rename_tac v')
  apply (erule_tac x="[p \<mapsto> v'] :: heap" in allE)
  apply (drule mp)
   apply (clarsimp simp: maps_to_ex_def maps_to_def, fastforce)
  apply (erule_tac x=" (\<lambda>ptr. if ptr = p then None else s ptr)" in allE)
  apply (drule mp)
   apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
  apply (drule mp)
   apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
  apply (rule_tac x="[p \<mapsto> v] :: heap" in exI)
  apply (rule_tac x=" (\<lambda>ptr. if ptr = p then None else s ptr)" in exI)
  apply (clarsimp, intro conjI)
    apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
   apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
  apply (clarsimp simp: maps_to_ex_def maps_to_def)
  done

lemma set_ptr_sp'[sp]: "\<lbrace>R\<rbrace> set_ptr p v \<lbrace>\<lambda>rv. p \<mapsto> v \<and>* (p \<mapsto> - -* R )\<rbrace>"
  by (sep_sp spec: set_ptr_sp)

lemma get_ptr_wp[wp']: "\<lbrace>EXS x. p \<mapsto> x \<and>* (p \<mapsto> x \<longrightarrow>* R x )\<rbrace> get_ptr p \<lbrace>R \<rbrace>"
  apply (clarsimp simp: get_ptr_def, Det_Monad.wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def sep_impl_def maps_to_def)
  apply (clarsimp simp: sep_disj_commute sep_add_commute)
  apply (subgoal_tac "x=y")
   apply (clarsimp)
  apply (clarsimp simp: plus_fun_def plus_option_def split: option.splits)
  done

lemma get_ptr_sp_weak: "\<lbrace>R\<rbrace> get_ptr p \<lbrace>\<lambda>rv. R and (ALLS x. (p \<mapsto> x \<leadsto>* (\<lambda>s. rv = x)))\<rbrace>"
  apply (clarsimp simp: get_ptr_def, Det_Monad.wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_conj_def)
  apply (clarsimp simp: sep_coimpl_def pred_neg_def sep_conj_def)
  apply (clarsimp simp: septraction_def plus_fun_def plus_option_def pred_neg_def sep_impl_def
                        maps_to_def sep_disj_fun_def sep_disj_option_def
                 split: option.splits if_split_asm)
  done

lemma get_ptr_sp[sp]: "\<lbrace>R\<rbrace> get_ptr p \<lbrace>\<lambda>rv. p \<mapsto> rv \<and>* (p \<mapsto> rv -* R)\<rbrace>"
  apply (clarsimp simp: get_ptr_def, Det_Monad.wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_conj_def)
  apply (rename_tac v)
  apply (rule_tac x="[p \<mapsto> v] :: heap" in exI)
  apply (rule_tac x=" (\<lambda>ptr. if ptr = p then None else s ptr)" in exI)
  apply (intro conjI)
     apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
    apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
   apply (clarsimp simp: maps_to_ex_def maps_to_def)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def sep_impl_def septraction_def)
  apply (rule_tac x="[p \<mapsto> v] :: heap" in exI)
  apply (clarsimp simp: maps_to_ex_def maps_to_def, rule conjI)
   apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def split: option.splits)
  apply (erule back_subst[where P=R])
  apply (rule ext, clarsimp simp: plus_fun_def plus_option_def split: option.splits)
  done

lemma get_ptr_sp': "\<lbrace>\<lambda>s. R (the (s p)) s\<rbrace> get_ptr p \<lbrace>\<lambda>rv. p \<mapsto> rv \<and>* (p \<mapsto> rv -* R rv)\<rbrace>"
  apply (clarsimp simp: get_ptr_def, Det_Monad.wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_conj_def)
  apply (rename_tac v)
  apply (rule_tac x="[p \<mapsto> v] :: heap" in exI)
  apply (rule_tac x=" (\<lambda>ptr. if ptr = p then None else s ptr)" in exI)
  apply (intro conjI)
     apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
    apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
   apply (clarsimp simp: maps_to_ex_def maps_to_def)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def sep_impl_def septraction_def)
  apply (rule_tac x="[p \<mapsto> v] :: heap" in exI)
  apply (clarsimp simp: maps_to_ex_def maps_to_def, rule conjI)
   apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def split: option.splits)
  apply (erule_tac P="R v" in back_subst)
  apply (rule ext, clarsimp simp: plus_fun_def plus_option_def split: option.splits)
  done

lemma extract_forall_septract:"(P -* (ALLS x. R x)) s \<Longrightarrow> \<forall>x. (P -* R x) s"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  apply (erule_tac x=x in allE)
  apply (fastforce)
  done

lemma septraction_snake_trivial_alls: "(P x -* (ALLS x. P x  \<leadsto>* R x)) s \<Longrightarrow> R x s"
  by (sep_invert, fastforce)

lemma get_ptr_valid: "\<lbrace>ALLS x. (p \<mapsto> x \<leadsto>* R x) \<rbrace> get_ptr p \<lbrace>\<lambda>rv. (p \<mapsto> rv \<and>* R rv) \<rbrace>"
  apply (sp, sep_invert, erule_tac x=rv in allE)
  apply (sep_forward)+
done

definition
  "copy_ptr p p' = do {
     x <- get_ptr p;
     set_ptr p' x
   }"

lemma septract_maps_to:"(p \<mapsto> v -* (p \<mapsto> v' \<and>* R)) s \<Longrightarrow> R s \<and> v = v'"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def maps_to_def sep_conj_def)
  apply (rule conjI)
   apply (erule back_subst[where P=R])
   apply (rule ext)
   apply (rename_tac x)
   apply (drule_tac x=x in fun_cong)
   apply (clarsimp simp: plus_fun_def plus_option_def sep_disj_fun_def sep_disj_option_def)
   apply (erule_tac x=x in allE)
   apply (erule_tac x=x in allE)
   apply (clarsimp split: option.splits if_split_asm)
  apply (drule_tac x=p in fun_cong)
  apply (clarsimp simp: plus_fun_def plus_option_def sep_disj_fun_def sep_disj_option_def)
  apply (erule_tac x=p in allE)
  apply (erule_tac x=p in allE)
  apply (clarsimp split: option.splits)
  done

lemma precise_conj_coimpl': "precise P \<Longrightarrow> (\<And>s R. (P \<and>* R) s \<Longrightarrow> (P \<leadsto>* R) s) "
  by (clarsimp simp: precise_conj_coimpl)

lemma septraction_precise_conj: "precise P \<Longrightarrow> (P -* (P \<and>* R)) s \<Longrightarrow> R s "
  apply (drule septraction_impl2)
   apply (erule (1) precise_conj_coimpl')
  by (erule septraction_snake_trivial)

lemma septract_lift_pure[simp]: "(P -* (\<lambda>s. p \<and> Q s)) s \<longleftrightarrow> (P -* Q) s \<and> p"
  apply (rule iffI, rule conjI)
  using septraction_impl2 apply blast
   apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  done

lemma copy_ptr_wp:
  "\<lbrace>EXS x. p \<mapsto> x \<and>* (p \<mapsto> x \<longrightarrow>* p' \<mapsto> - \<and>* (p' \<mapsto> x \<longrightarrow>* R))\<rbrace> copy_ptr p p' \<lbrace>\<lambda>rv. R\<rbrace>"
  apply (clarsimp simp: copy_ptr_def)
  apply (rule bind_wp)
   apply (rule hoare_strengthen_post, rule precise_weaken_pre[OF precise_maps_to_ex], rule set_ptr_sp)
   apply (sep_erule (direct) sep_mp)
  apply (rule get_ptr_wp)
  done

lemma sep_All_mp:"(P x \<and>* (ALLS v. P v \<longrightarrow>* R v)) s \<Longrightarrow> R x s"
  apply (clarsimp simp: sep_conj_def sep_impl_def)
  apply (erule_tac x=x in allE, erule_tac x=xa in allE)
  by (simp add: sep_add_commute sep_disj_commuteI)

(* new_rules can be run in both directions *)

lemma copy_ptr_wp':
  "\<lbrace>ALLS x. (p \<mapsto> x \<leadsto>* (ALLS x. (p \<mapsto> x \<longrightarrow>* (p' \<mapsto> - \<leadsto>* p' \<mapsto> x \<longrightarrow>* R)) ))  \<rbrace>
   copy_ptr p p'  \<lbrace>\<lambda>rv. R\<rbrace>"
  apply (clarsimp simp: copy_ptr_def)
  apply (sp, sep_invert)
  apply (erule_tac x=x in allE)
  apply (sep_forward)
  apply (fastforce)
done

lemma copy_ptr_sp[sp]:
  "\<lbrace>R\<rbrace> copy_ptr p p' \<lbrace>\<lambda>rv. EXS x. p' \<mapsto> x \<and>* (p' \<mapsto> - -*  (p \<mapsto> x \<and>* (p \<mapsto> x -* R)))\<rbrace>"
  apply (clarsimp simp: copy_ptr_def)
  apply (sp)
  apply (rule_tac x=x in exI, clarsimp)
  done

lemma copy_ptr_valid: "\<lbrace>p \<mapsto> x \<and>* p' \<mapsto> - \<and>* R\<rbrace> copy_ptr p p'  \<lbrace>\<lambda>_. p \<mapsto> x \<and>* p' \<mapsto> x \<and>* R\<rbrace>"
  apply (Det_Monad.wp wp: copy_ptr_wp)
  apply (rule_tac x=x in exI)
  apply (sep_solve)
  done

lemma copy_ptr_valid': "\<lbrace>p \<mapsto> x \<and>* p' \<mapsto> - \<and>* R\<rbrace> copy_ptr p p'  \<lbrace>\<lambda>_. p \<mapsto> x \<and>* p' \<mapsto> x \<and>* R\<rbrace>"
  by (rule copy_ptr_valid)

definition
  "swap_ptr p p' = do {
     np <- new_ptr;
     copy_ptr p np;
     copy_ptr p' p;
     copy_ptr np p';
     delete_ptr np
  }"

lemma delete_ptr_sp'[sp]: "\<lbrace>R\<rbrace> delete_ptr p \<lbrace>\<lambda>_. p \<mapsto> - -* R\<rbrace>"
  apply (rule hoare_weaken_pre[OF delete_ptr_sp])
  apply (erule (1) sep_snake_septraction)
  done

lemma extract_exs_septraction_simp[simp]: "(P -* (EXS v. R v)) = (EXS v. (P -* R v) )"
  apply (rule ext, rule iffI)
   apply (fastforce simp: septraction_def sep_impl_def pred_neg_def)
  apply (fastforce simp: septraction_def sep_impl_def pred_neg_def)
  done

lemma extract_exs_septraction_simp'[simp]: "((EXS v. R v) -* P ) = (EXS v. (R v -* P) )"
  apply (rule ext, rule iffI; fastforce simp: septraction_def sep_impl_def pred_neg_def)
  done

lemma new_ptr_wp: "\<lbrace>ALLS p. p \<mapsto> - \<longrightarrow>* R p\<rbrace> new_ptr \<lbrace>R\<rbrace>"
  apply (rule hoare_chain, rule new_ptr_sp[simplified], assumption)
  using sep_conj_commuteI sep_conj_sep_impl2 by blast

lemma delete_ptr_valid: "\<lbrace>p \<mapsto> - \<and>* R\<rbrace> delete_ptr p \<lbrace>\<lambda>_. R\<rbrace>"
  apply (rule hoare_weaken_pre[OF delete_ptr_sp])
  by (erule precise_conj_coimpl'[OF precise_maps_to_ex])

lemma swap_ptr_valid:
  "\<lbrace>(p \<mapsto> v \<and>* p' \<mapsto> v' \<and>* R)\<rbrace> swap_ptr p p' \<lbrace>\<lambda>_. (p \<mapsto> v' \<and>* p' \<mapsto> v \<and>* R)\<rbrace>"
  apply (clarsimp simp: swap_ptr_def)
  apply (Det_Monad.wp wp: delete_ptr_valid)
      apply (wp copy_ptr_wp new_ptr_wp)+
  apply (clarsimp simp: sep_conj_exists)
  apply (sep_cancel)
  apply (rule_tac x=v in exI)
  apply (sep_cancel)+
  apply (rule_tac x=v' in exI)
  apply (sep_cancel add: maps_to_maps_to_ex)+
  apply (rule exI)
  by (sep_solve add: maps_to_maps_to_ex)

lemma septraction_lens: "((P -* Q) \<and>* R) s \<Longrightarrow> (\<And>s. Q' s = Q s) \<Longrightarrow> ((P -* Q') \<and>* R) s"
  apply (sep_cancel) using septract_cancel by blast

lemmas septraction_lens' = septraction_lens[where R=\<box>, simplified]

ML{*
  fun septraction_drule thms ctxt =
     let val lens  = dresolve0_tac  [@{thm septraction_lens}]
         val r = rotator' ctxt
      in sep_drule_tac (dresolve0_tac thms |> r lens) ctxt
   end;

fun septraction_drule_method  thms ctxt = SIMPLE_METHOD' (septraction_drule  thms ctxt)

 fun septraction_drule' thms ctxt =
     let val lens  = dresolve0_tac  [@{thm septraction_lens'}]
         val r = rotator' ctxt
      in (dresolve0_tac thms |> r lens)
   end;

fun septraction_drule_method'  thms ctxt = SIMPLE_METHOD' (septraction_drule'  thms ctxt)

*}

method_setup septract_drule = {*
  Attrib.thms >>  septraction_drule_method
*}

method_setup septract_drule' = {*
  Attrib.thms >>  septraction_drule_method'
*}

lemma septract_maps_to1:"((p \<mapsto> v -* (p \<mapsto> v' \<and>* R)) \<and>* Q) s \<Longrightarrow> ((R \<and>* Q) and K(v = v')) s"
  by (sep_drule septract_maps_to) clarsimp

lemma septract_maps_to2: "((p \<mapsto> v -* (p \<mapsto> - \<and>* R)) \<and>* Q) s \<Longrightarrow> (R \<and>* Q) s"
  apply (sep_cancel)
  using precise_maps_to_ex septraction_impl1 septraction_precise_conj by fastforce

lemma septract_maps_to3: "((p \<mapsto> - -* (p \<mapsto> v' \<and>* R)) \<and>* Q) s \<Longrightarrow> (R \<and>* Q) s "
  apply (sep_cancel)
  by (smt maps_to_maps_to_ex precise_conj_coimpl precise_maps_to_ex sep_rule sep_septraction_snake)

lemma septract_maps_to4: "((p \<mapsto> - -* (p \<mapsto> - \<and>* R)) \<and>* Q) s \<Longrightarrow> (R \<and>* Q) s"
  apply (sep_cancel)
  using precise_maps_to_ex septraction_precise_conj by blast

lemmas septract_maps_to_set = septract_maps_to1 septract_maps_to2 septract_maps_to3 septract_maps_to4

lemmas septract_maps_to_set' = septract_maps_to_set[where Q=sep_empty, simplified]

lemma septraction_extract_pure[simp]: "(P -* (\<lambda>s. R s \<and> r)) = ((P -* R) and K r)"
  by (rule ext, rule iffI; fastforce simp: septraction_def sep_impl_def pred_neg_def)

(*
method septract_cancel =
  ((septract_drule septract_maps_to_set | septract_drule' septract_maps_to_set') |
   ((sep_drule septraction_impl2 | drule septraction_impl2), septract_cancel, assumption))
*)

(* now forwards *)

declare precise_maps_to[precise]
declare precise_maps_to_ex[precise]
declare maps_to_maps_to_ex[sep_cancel]

lemma maps_to_pointer[precise]: "pointer (maps_to p)"
 apply (clarsimp simp:  pointer_def maps_to_def
  sep_conj_def sep_coimpl_def pred_neg_def)
  apply (subgoal_tac "x=y", simp)
  apply (metis sep_add_cancelD sep_add_commute sep_disj_commuteI)
  apply (drule_tac x=p in fun_cong)
 apply (clarsimp simp: plus_fun_def plus_option_def split: option.splits)
  apply (clarsimp simp: sep_disj_fun_def)
  apply (erule_tac x=p in allE)
  apply (erule_tac x=p in allE)
apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
done

lemma swap_ptr_valid': "\<lbrace>p \<mapsto> v \<and>* p' \<mapsto> v' \<and>* R\<rbrace> swap_ptr p p' \<lbrace>\<lambda>_. p \<mapsto> v' \<and>* p' \<mapsto> v \<and>* R\<rbrace>"
  unfolding swap_ptr_def
  apply (sp sp: new_ptr_sp[simplified])
  apply (clarsimp simp: sep_conj_exists2)
  apply (sep_invert; sep_forward+)
  apply (simp, sep_solve)
  done

primrec
  list :: "nat \<Rightarrow> nat list \<Rightarrow> heap \<Rightarrow> bool"
where
  "list i [] = (\<langle>i=0\<rangle> and \<box>)"
| "list i (x#xs) = (\<langle>i=x \<and> i\<noteq>0\<rangle> and (EXS j. i \<mapsto> j ** list j xs))"

lemma list_empty [simp]:
  shows "list 0 xs = (\<lambda>s. xs = [] \<and> \<box> s)"
  by (cases xs) auto

lemma list_nonempty:
  "0 < i \<Longrightarrow> list i xs = (EXS h t. \<langle>i= (h) \<and> i\<noteq>0 \<and> xs = h#t \<rangle> and (EXS j. i \<mapsto> j ** list j (t)))"
  by (cases xs) auto

lemma set_ptr_list_valid:
  "\<lbrace>(p \<mapsto> - and (\<lambda>s. p \<noteq>0)) \<and>* list q qs\<rbrace>
     set_ptr p q
   \<lbrace>\<lambda>_. list p (p#qs)\<rbrace>"
  apply (sp)
  apply clarsimp
  apply (sep_invert)
  apply (clarsimp)
  apply (sep_forward, sep_forward)
  apply (rule_tac x=q in exI, sep_solve)
  done

lemma set_ptr_wp[wp']: "\<lbrace>p \<mapsto> - \<and>* (p \<mapsto> v \<longrightarrow>* R)\<rbrace> set_ptr p v \<lbrace>\<lambda>_. R\<rbrace>"
  apply (sp)
  apply (sep_invert, sep_forward, assumption)
  done

definition "NULL \<equiv> 0::nat"

declare NULL_def[simp]

definition list_rev where
  "list_rev p = do {
     (hd_ptr, rev)  <- whileLoop  (\<lambda>(hd_ptr, rev). hd_ptr \<noteq> NULL)
                                  (\<lambda>(hd_ptr, rev). do {
                                     next_ptr <- get_ptr hd_ptr;
                                     set_ptr hd_ptr rev;
                                     return (next_ptr, hd_ptr)
                                   })
                                  (p, NULL) ;
     return rev
   }"

definition
  "reverse_inv xs list' rev' \<equiv>
     EXS ys zs. (list list' ys \<and>* list rev' zs) and (\<lambda>s. rev xs = rev ys @ zs)"

method guess_spec = (rule exI)+, (intro conjI; (fastforce)?)

lemma list_rev_valid_wp: "\<lbrace>list p ps\<rbrace> list_rev p \<lbrace>\<lambda>rv. list rv (rev ps)\<rbrace>"
  apply (clarsimp simp: list_rev_def)
  apply (subst whileLoop_add_inv [where
                  I="\<lambda>(list', rev'). EXS ys zs. (list list' ys \<and>* list rev' zs) and
                                                (\<lambda>s. rev ps = rev ys @ zs)"])
  apply (Det_Monad.wp; clarsimp)+
  apply (case_tac x; clarsimp simp: sep_conj_exists)
  apply (rule exI)
  apply (sep_cancel add: maps_to_maps_to_ex)+
  apply (guess_spec)
  apply (clarsimp simp: sep_conj_exists)
  apply (rule exI, sep_solve)
done

lemma septract_extra_pure1[simp]: "(P -* (\<lambda>s. Q s \<and> q)) = ((P -* Q) and (\<lambda>s. q))"
  by (rule ext, rule iffI; fastforce simp: septraction_def sep_impl_def pred_neg_def)
lemma septract_extra_pure2[simp]: "(P -* (\<lambda>s. q \<and> Q s)) = ((P -* Q) and (\<lambda>s. q))"
  by (rule ext, rule iffI; fastforce simp: septraction_def sep_impl_def pred_neg_def)

lemma septract_false[simp] :"(P -* (sep_false)) = sep_false"
  using sep_septraction_snake by blast

lemma whileLoop_sp_inv[sp]:
  "\<lbrakk> \<And>r. \<lbrace>\<lambda>s. I r s \<and> C r\<rbrace> B r \<lbrace>I\<rbrace>; \<And>s. P s \<Longrightarrow> I r s \<rbrakk>
      \<Longrightarrow> \<lbrace>P\<rbrace> whileLoop_inv C B I r \<lbrace>\<lambda>rv s. I rv s \<and> \<not> C rv\<rbrace>"
  unfolding whileLoop_inv_def
  by (Det_Monad.wp wp: whileLoop_wp [where I=I]; fastforce)

lemma sep_conj_coimpl_mp:"(P \<and>* R) s \<Longrightarrow> (P \<leadsto>* Q) s \<Longrightarrow> (P \<and>* (Q and R)) s"
  by (drule (2) sep_coimpl_mp_gen, clarsimp simp: conj_commute)

lemma trivial_spec: "P xa ya \<Longrightarrow> \<exists>x y. Q xa ya = Q x y \<and> P x y"
 by (fastforce)

declare sep_conj_exists[simp]

lemma list_nonemptyI:"(list b as \<and>* a \<mapsto> b) s \<Longrightarrow> 0 < a
       \<Longrightarrow> list a (a # as) s"
   apply (clarsimp, rule exI, sep_cancel)
done

lemma sep_pred_conj_sep_conj: "P s \<Longrightarrow> Q s \<Longrightarrow> (P \<and>* (Q -* (P and Q))) s"
  by (metis disjoint_zero_sym pred_conj_def pred_neg_def sep_add_zero_sym sep_conjI
            sep_conj_commuteI sep_mp septraction_def)

method sep_forward_simp = (sep_invert; sep_forward+)

lemma list_rev_valid_sp:
  "\<lbrace>list p ps \<and>* R\<rbrace> list_rev p \<lbrace>\<lambda>rv. list rv (rev ps) \<and>* R\<rbrace>"
  apply (clarsimp simp: list_rev_def)
  apply (subst whileLoop_add_inv [where I="\<lambda>(list', rev'). reverse_inv ps list' rev' \<and>* R",
                                  unfolded reverse_inv_def])
  apply (sp; clarsimp)
   apply (rename_tac list' rev')
   apply (case_tac list'; clarsimp simp: sep_conj_assoc)
   apply (sep_forward_simp, rule trivial_spec, clarsimp, rule exI, sep_solve)
  apply (rule hoare_post, sp, clarsimp)
  done

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>\<open>SemiCAT\<close>\<close>
theory CZH_ECAT_SemiCAT
  imports
    CZH_Foundations.CZH_SMC_SemiCAT
    CZH_ECAT_Small_Category
    CZH_ECAT_Simple
begin

subsection\<open>Background\<close>

text\<open>
The methodology for the exposition of \<open>SemiCAT\<close> as a category
is analogous to the one used in \<^cite>\<open>"milehins_category_2021"\<close>
for the exposition of \<open>SemiCAT\<close> as a semicategory.
\<close>

named_theorems cat_SemiCAT_simps
named_theorems cat_SemiCAT_intros

subsection\<open>Definition and elementary properties\<close>

definition cat_SemiCAT :: "V \<Rightarrow> V"
  where "cat_SemiCAT \<alpha> =
    [
      set {\<CC>. semicategory \<alpha> \<CC>},
      all_smcfs \<alpha>,
      (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomDom\<rparr>),
      (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomCod\<rparr>),
      (\<lambda>\<GG>\<FF>\<in>\<^sub>\<circ>composable_arrs (dg_SemiCAT \<alpha>). \<GG>\<FF>\<lparr>0\<rparr> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG>\<FF>\<lparr>1\<^sub>\<nat>\<rparr>),
      (\<lambda>\<CC>\<in>\<^sub>\<circ>set {\<CC>. semicategory \<alpha> \<CC>}. smcf_id \<CC>)
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma cat_SemiCAT_components:
  shows "cat_SemiCAT \<alpha>\<lparr>Obj\<rparr> = set {\<CC>. semicategory \<alpha> \<CC>}"
    and "cat_SemiCAT \<alpha>\<lparr>Arr\<rparr> = all_smcfs \<alpha>"
    and "cat_SemiCAT \<alpha>\<lparr>Dom\<rparr> = (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomDom\<rparr>)"
    and "cat_SemiCAT \<alpha>\<lparr>Cod\<rparr> = (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomCod\<rparr>)"
    and "cat_SemiCAT \<alpha>\<lparr>Comp\<rparr> =
      (\<lambda>\<GG>\<FF>\<in>\<^sub>\<circ>composable_arrs (dg_SemiCAT \<alpha>). \<GG>\<FF>\<lparr>0\<rparr> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG>\<FF>\<lparr>1\<^sub>\<nat>\<rparr>)"
    and "cat_SemiCAT \<alpha>\<lparr>CId\<rparr> = (\<lambda>\<CC>\<in>\<^sub>\<circ>set {\<CC>. semicategory \<alpha> \<CC>}. smcf_id \<CC>)"
  unfolding cat_SemiCAT_def dg_field_simps
  by (simp_all add: nat_omega_simps)

text\<open>Slicing.\<close>

lemma cat_smc_SemiCAT: "cat_smc (cat_SemiCAT \<alpha>) = smc_SemiCAT \<alpha>"
proof(rule vsv_eqI)
  have dom_lhs: "\<D>\<^sub>\<circ> (cat_smc (cat_SemiCAT \<alpha>)) = 5\<^sub>\<nat>"
    unfolding cat_smc_def by (simp add: nat_omega_simps)
  have dom_rhs: "\<D>\<^sub>\<circ> (smc_SemiCAT \<alpha>) = 5\<^sub>\<nat>"
    unfolding smc_SemiCAT_def by (simp add: nat_omega_simps)
  show "\<D>\<^sub>\<circ> (cat_smc (cat_SemiCAT \<alpha>)) = \<D>\<^sub>\<circ> (smc_SemiCAT \<alpha>)"
    unfolding dom_lhs dom_rhs by simp
  show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (cat_smc (cat_SemiCAT \<alpha>)) \<Longrightarrow>
    cat_smc (cat_SemiCAT \<alpha>)\<lparr>a\<rparr> = smc_SemiCAT \<alpha>\<lparr>a\<rparr>"
    for a
    by
      (
        unfold dom_lhs,
        elim_in_numeral,
        unfold cat_smc_def dg_field_simps cat_SemiCAT_def smc_SemiCAT_def
      )
      (auto simp: nat_omega_simps)
qed (auto simp: cat_smc_def smc_SemiCAT_def)

lemmas_with [folded cat_smc_SemiCAT, unfolded slicing_simps]:
  \<comment>\<open>Digraph\<close>
  cat_SemiCAT_ObjI = smc_SemiCAT_ObjI
  and cat_SemiCAT_ObjD = smc_SemiCAT_ObjD
  and cat_SemiCAT_ObjE = smc_SemiCAT_ObjE
  and cat_SemiCAT_Obj_iff[cat_SemiCAT_simps] = smc_SemiCAT_Obj_iff
  and cat_SemiCAT_Dom_app[cat_SemiCAT_simps] = smc_SemiCAT_Dom_app
  and cat_SemiCAT_Cod_app[cat_SemiCAT_simps] = smc_SemiCAT_Cod_app
  and cat_SemiCAT_is_arrI = smc_SemiCAT_is_arrI
  and cat_SemiCAT_is_arrD = smc_SemiCAT_is_arrD
  and cat_SemiCAT_is_arrE = smc_SemiCAT_is_arrE
  and cat_SemiCAT_is_arr_iff[cat_SemiCAT_simps] = smc_SemiCAT_is_arr_iff

lemmas_with [
    folded cat_smc_SemiCAT, unfolded slicing_simps, unfolded cat_smc_SemiCAT
    ]:
  \<comment>\<open>Semicategory\<close>
  cat_SemiCAT_Comp_vdomain = smc_SemiCAT_Comp_vdomain
  and cat_SemiCAT_composable_arrs_dg_SemiCAT =
    smc_SemiCAT_composable_arrs_dg_SemiCAT
  and cat_SemiCAT_Comp = smc_SemiCAT_Comp
  and cat_SemiCAT_Comp_app[cat_SemiCAT_simps] = smc_SemiCAT_Comp_app
  and cat_SemiCAT_Comp_vrange = smc_SemiCAT_Comp_vrange

lemmas_with (in \<Z>) [folded cat_smc_SemiCAT, unfolded slicing_simps]:
  \<comment>\<open>Semicategory\<close>
  cat_SemiCAT_obj_initialI = smc_SemiCAT_obj_initialI
  and cat_SemiCAT_obj_initialD = smc_SemiCAT_obj_initialD
  and cat_SemiCAT_obj_initialE = smc_SemiCAT_obj_initialE
  and cat_SemiCAT_obj_initial_iff[cat_SemiCAT_simps] =
    smc_SemiCAT_obj_initial_iff
  and cat_SemiCAT_obj_terminalI = smc_SemiCAT_obj_terminalI
  and cat_SemiCAT_obj_terminalE = smc_SemiCAT_obj_terminalE

subsection\<open>Identity\<close>

lemma cat_SemiCAT_CId_app[cat_SemiCAT_simps]:
  assumes "semicategory \<alpha> \<CC>"
  shows "cat_SemiCAT \<alpha>\<lparr>CId\<rparr>\<lparr>\<CC>\<rparr> = smcf_id \<CC>"
  using assms unfolding cat_SemiCAT_components by simp

lemma cat_SemiCAT_CId_vdomain[cat_SemiCAT_simps]:
  "\<D>\<^sub>\<circ> (cat_SemiCAT \<alpha>\<lparr>CId\<rparr>) = set {\<CC>. semicategory \<alpha> \<CC>}"
  unfolding cat_SemiCAT_components by auto

lemma cat_SemiCAT_CId_vrange: "\<R>\<^sub>\<circ> (cat_SemiCAT \<alpha>\<lparr>CId\<rparr>) \<subseteq>\<^sub>\<circ> all_smcfs \<alpha>"
proof(rule vsubsetI)
  fix \<HH> assume "\<HH> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (cat_SemiCAT \<alpha>\<lparr>CId\<rparr>)"
  then obtain \<AA>
    where \<HH>_def: "\<HH> = cat_SemiCAT \<alpha>\<lparr>CId\<rparr>\<lparr>\<AA>\<rparr>"
      and \<AA>: "\<AA> \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (cat_SemiCAT \<alpha>\<lparr>CId\<rparr>)"
    unfolding cat_SemiCAT_components by auto
  from \<AA> have \<HH>_def': "\<HH> = smcf_id \<AA>"
    unfolding \<HH>_def cat_SemiCAT_CId_vdomain by (auto simp: cat_SemiCAT_CId_app)
  from \<AA> semicategory.smc_smcf_id_is_semifunctor show "\<HH> \<in>\<^sub>\<circ> all_smcfs \<alpha>"
    unfolding \<HH>_def' cat_SemiCAT_CId_vdomain by force
qed

subsection\<open>\<open>SemiCAT\<close> is a category\<close>

lemma (in \<Z>) tiny_category_cat_SemiCAT:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "tiny_category \<beta> (cat_SemiCAT \<alpha>)"
proof(intro tiny_categoryI)
  interpret \<beta>: \<Z> \<beta> by (rule assms(1))
  show "vfsequence (cat_SemiCAT \<alpha>)" unfolding cat_SemiCAT_def by simp
  show "vcard (cat_SemiCAT \<alpha>) = 6\<^sub>\<nat>"
    unfolding cat_SemiCAT_def by (simp add: nat_omega_simps)
  show "cat_SemiCAT \<alpha>\<lparr>CId\<rparr>\<lparr>\<BB>\<rparr> \<circ>\<^sub>A\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<FF> = \<FF>"
    if "\<FF> : \<AA> \<mapsto>\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>" for \<FF> \<AA> \<BB>
    using that
    unfolding cat_SemiCAT_is_arr_iff
    by (cs_concl cs_simp: smc_cs_simps cat_SemiCAT_simps cs_intro: smc_cs_intros)
  show "\<FF> \<circ>\<^sub>A\<^bsub>cat_SemiCAT \<alpha>\<^esub> cat_SemiCAT \<alpha>\<lparr>CId\<rparr>\<lparr>\<BB>\<rparr> = \<FF>"
    if "\<FF> : \<BB> \<mapsto>\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<CC>" for \<FF> \<BB> \<CC>
    using that
    unfolding cat_SemiCAT_is_arr_iff
    by (cs_concl cs_simp: smc_cs_simps cat_SemiCAT_simps cs_intro: smc_cs_intros)
qed
  (
    simp_all add:
      assms
      cat_smc_SemiCAT
      cat_SemiCAT_components
      cat_SemiCAT_is_arr_iff
      tiny_semicategory_smc_SemiCAT
      semicategory.smc_smcf_id_is_semifunctor
  )

subsection\<open>Isomorphism\<close>

lemma cat_SemiCAT_is_iso_arrI:
  assumes "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<FF> : \<AA> \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>"
proof(intro is_iso_arrI is_inverseI)
  interpret is_iso_semifunctor \<alpha> \<AA> \<BB> \<FF> by (rule assms)
  from assms show \<FF>: "\<FF> : \<AA> \<mapsto>\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>"
    unfolding cat_SemiCAT_is_arr_iff by auto
  note iso_thms = is_iso_semifunctor_is_iso_arr[OF assms]
  from iso_thms(1) show inv_\<FF>: "inv_smcf \<FF> : \<BB> \<mapsto>\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<AA>"
    unfolding cat_SemiCAT_is_arr_iff by auto
  from assms show "\<FF> : \<AA> \<mapsto>\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>"
    unfolding cat_SemiCAT_is_arr_iff by auto
  from assms have \<AA>: "semicategory \<alpha> \<AA>" and \<BB>: "semicategory \<alpha> \<BB>" by auto
  show "inv_smcf \<FF> \<circ>\<^sub>A\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<FF> = cat_SemiCAT \<alpha>\<lparr>CId\<rparr>\<lparr>\<AA>\<rparr>"
    unfolding cat_SemiCAT_CId_app[OF \<AA>] cat_SemiCAT_Comp_app[OF inv_\<FF> \<FF>]
    by (rule iso_thms(2))
  show "\<FF> \<circ>\<^sub>A\<^bsub>cat_SemiCAT \<alpha>\<^esub> inv_smcf \<FF> = cat_SemiCAT \<alpha>\<lparr>CId\<rparr>\<lparr>\<BB>\<rparr>"
    unfolding cat_SemiCAT_CId_app[OF \<BB>] cat_SemiCAT_Comp_app[OF \<FF> inv_\<FF>]
    by (rule iso_thms(3))
qed

lemma cat_SemiCAT_is_iso_arrD:
  assumes "\<FF> : \<AA> \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>"
  shows "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> \<BB>"
proof-
  from is_iso_arrD[OF assms] have \<FF>: "\<FF> : \<AA> \<mapsto>\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>"
    and "(\<exists>\<GG>. is_inverse (cat_SemiCAT \<alpha>) \<GG> \<FF>)"
    by simp_all
  then obtain \<GG> where \<GG>\<FF>: "is_inverse (cat_SemiCAT \<alpha>) \<GG> \<FF>" by clarsimp
  then obtain \<AA>' \<BB>' where \<GG>': "\<GG> : \<BB>' \<mapsto>\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<AA>'"
    and \<FF>': "\<FF> : \<AA>' \<mapsto>\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>'"
    and \<GG>\<FF>: "\<GG> \<circ>\<^sub>A\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<FF> = cat_SemiCAT \<alpha>\<lparr>CId\<rparr>\<lparr>\<AA>'\<rparr>"
    and \<FF>\<GG>: "\<FF> \<circ>\<^sub>A\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<GG> = cat_SemiCAT \<alpha>\<lparr>CId\<rparr>\<lparr>\<BB>'\<rparr>"
    by auto
  from \<FF> \<FF>' have \<AA>': "\<AA>' = \<AA>" and \<BB>': "\<BB>' = \<BB>" by auto
  from \<FF> have \<FF>: "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" unfolding cat_SemiCAT_is_arr_iff by simp
  interpret is_semifunctor \<alpha> \<AA> \<BB> \<FF> by (rule \<FF>)
  have \<AA>: "semicategory \<alpha> \<AA>" and \<BB>: "semicategory \<alpha> \<BB>"
    by (cs_concl cs_intro: smc_cs_intros)+
  from \<GG>' have \<GG>: "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
    unfolding \<AA>' \<BB>' cat_SemiCAT_is_arr_iff by simp
  moreover from \<GG>\<FF> have "\<GG> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<FF> = smcf_id \<AA>"
    unfolding \<AA>' cat_SemiCAT_Comp_app[OF \<GG>' \<FF>'] cat_SemiCAT_CId_app[OF \<AA>]
    by simp
  moreover from \<FF>\<GG> have "\<FF> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG> = smcf_id \<BB>"
    unfolding \<BB>' cat_SemiCAT_Comp_app[OF \<FF>' \<GG>'] cat_SemiCAT_CId_app[OF \<BB>]
    by simp
  ultimately show ?thesis
    using \<FF> by (elim is_iso_arr_is_iso_semifunctor)
qed

lemma cat_SemiCAT_is_iso_arrE:
  assumes "\<FF> : \<AA> \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>"
  obtains "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> \<BB>"
  using assms by (auto dest: cat_SemiCAT_is_iso_arrD)

lemma cat_SemiCAT_is_iso_arr_iff[cat_SemiCAT_simps]:
  "\<FF> : \<AA> \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB> \<longleftrightarrow> \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> \<BB>"
  using cat_SemiCAT_is_iso_arrI cat_SemiCAT_is_iso_arrD by auto

subsection\<open>Isomorphic objects\<close>

lemma cat_SemiCAT_obj_isoI:
  assumes "\<AA> \<approx>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<AA> \<approx>\<^sub>o\<^sub>b\<^sub>j\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>"
proof-
  from iso_semicategoryD[OF assms] obtain \<FF> where "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> \<BB>"
    by clarsimp
  from cat_SemiCAT_is_iso_arrI[OF this] show ?thesis by (rule obj_isoI)
qed

lemma cat_SemiCAT_obj_isoD:
  assumes "\<AA> \<approx>\<^sub>o\<^sub>b\<^sub>j\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>"
  shows "\<AA> \<approx>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
proof-
  from obj_isoD[OF assms] obtain \<FF> where "\<FF> : \<AA> \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>"
    by clarsimp
  from cat_SemiCAT_is_iso_arrD[OF this] show ?thesis
    by (rule iso_semicategoryI)
qed

lemma cat_SemiCAT_obj_isoE:
  assumes "\<AA> \<approx>\<^sub>o\<^sub>b\<^sub>j\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB>"
  obtains "\<AA> \<approx>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  using assms by (auto simp: cat_SemiCAT_obj_isoD)

lemma cat_SemiCAT_obj_iso_iff[cat_SemiCAT_simps]:
  "\<AA> \<approx>\<^sub>o\<^sub>b\<^sub>j\<^bsub>cat_SemiCAT \<alpha>\<^esub> \<BB> \<longleftrightarrow> \<AA> \<approx>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  using cat_SemiCAT_obj_isoI cat_SemiCAT_obj_isoD by (intro iffI) auto

text\<open>\newpage\<close>

end


section \<open>Explicit Nondeterministic Büchi Automata\<close>

theory NBA_Explicit
imports NBA_Algorithms
begin

  datatype ('label, 'state) nbae = nbae
    (alphabete: "'label set")
    (initiale: "'state set")
    (transitione: "('state \<times> 'label \<times> 'state) set")
    (acceptinge: "'state set")

  definition nbae_rel where
    [to_relAPP]: "nbae_rel L S \<equiv> {(A\<^sub>1, A\<^sub>2).
      (alphabete A\<^sub>1, alphabete A\<^sub>2) \<in> \<langle>L\<rangle> set_rel \<and>
      (initiale A\<^sub>1, initiale A\<^sub>2) \<in> \<langle>S\<rangle> set_rel \<and>
      (transitione A\<^sub>1, transitione A\<^sub>2) \<in> \<langle>S \<times>\<^sub>r L \<times>\<^sub>r S\<rangle> set_rel \<and>
      (acceptinge A\<^sub>1, acceptinge A\<^sub>2) \<in> \<langle>S\<rangle> set_rel}"

  lemma nbae_param[param, autoref_rules]:
    "(nbae, nbae) \<in> \<langle>L\<rangle> set_rel \<rightarrow> \<langle>S\<rangle> set_rel \<rightarrow> \<langle>S \<times>\<^sub>r L \<times>\<^sub>r S\<rangle> set_rel \<rightarrow>
      \<langle>S\<rangle> set_rel \<rightarrow> \<langle>L, S\<rangle> nbae_rel"
    "(alphabete, alphabete) \<in> \<langle>L, S\<rangle> nbae_rel \<rightarrow> \<langle>L\<rangle> set_rel"
    "(initiale, initiale) \<in> \<langle>L, S\<rangle> nbae_rel \<rightarrow> \<langle>S\<rangle> set_rel"
    "(transitione, transitione) \<in> \<langle>L, S\<rangle> nbae_rel \<rightarrow> \<langle>S \<times>\<^sub>r L \<times>\<^sub>r S\<rangle> set_rel"
    "(acceptinge, acceptinge) \<in> \<langle>L, S\<rangle> nbae_rel \<rightarrow> \<langle>S\<rangle> set_rel"
    unfolding nbae_rel_def by auto

  lemma nbae_rel_id[simp]: "\<langle>Id, Id\<rangle> nbae_rel = Id" unfolding nbae_rel_def using nbae.expand by auto
  lemma nbae_rel_comp[simp]: "\<langle>L\<^sub>1 O L\<^sub>2, S\<^sub>1 O S\<^sub>2\<rangle> nbae_rel = \<langle>L\<^sub>1, S\<^sub>1\<rangle> nbae_rel O \<langle>L\<^sub>2, S\<^sub>2\<rangle> nbae_rel"
  proof safe
    fix A B
    assume 1: "(A, B) \<in> \<langle>L\<^sub>1 O L\<^sub>2, S\<^sub>1 O S\<^sub>2\<rangle> nbae_rel"
    obtain a b c d where 2:
      "(alphabete A, a) \<in> \<langle>L\<^sub>1\<rangle> set_rel" "(a, alphabete B) \<in> \<langle>L\<^sub>2\<rangle> set_rel"
      "(initiale A, b) \<in> \<langle>S\<^sub>1\<rangle> set_rel" "(b, initiale B) \<in> \<langle>S\<^sub>2\<rangle> set_rel"
      "(transitione A, c) \<in> \<langle>S\<^sub>1 \<times>\<^sub>r L\<^sub>1 \<times>\<^sub>r S\<^sub>1\<rangle> set_rel" "(c, transitione B) \<in> \<langle>S\<^sub>2 \<times>\<^sub>r L\<^sub>2 \<times>\<^sub>r S\<^sub>2\<rangle> set_rel"
      "(acceptinge A, d) \<in> \<langle>S\<^sub>1\<rangle> set_rel" "(d, acceptinge B) \<in> \<langle>S\<^sub>2\<rangle> set_rel"
      using 1 unfolding nbae_rel_def prod_rel_compp set_rel_compp by auto
    show "(A, B) \<in> \<langle>L\<^sub>1, S\<^sub>1\<rangle> nbae_rel O \<langle>L\<^sub>2, S\<^sub>2\<rangle> nbae_rel"
    proof
      show "(A, nbae a b c d) \<in> \<langle>L\<^sub>1, S\<^sub>1\<rangle> nbae_rel" using 2 unfolding nbae_rel_def by auto
      show "(nbae a b c d, B) \<in> \<langle>L\<^sub>2, S\<^sub>2\<rangle> nbae_rel" using 2 unfolding nbae_rel_def by auto
    qed
  next
    show "(A, C) \<in> \<langle>L\<^sub>1 O L\<^sub>2, S\<^sub>1 O S\<^sub>2\<rangle> nbae_rel"
      if "(A, B) \<in> \<langle>L\<^sub>1, S\<^sub>1\<rangle> nbae_rel" "(B, C) \<in> \<langle>L\<^sub>2, S\<^sub>2\<rangle> nbae_rel" for A B C
      using that unfolding nbae_rel_def prod_rel_compp set_rel_compp by auto
  qed

  (* TODO: why do we need all this setup? can't i_of_rel do the trick? *)
  consts i_nbae_scheme :: "interface \<Rightarrow> interface \<Rightarrow> interface"

  context
  begin

    interpretation autoref_syn by this

    lemma nbae_scheme_itype[autoref_itype]:
      "nbae ::\<^sub>i \<langle>L\<rangle>\<^sub>i i_set \<rightarrow>\<^sub>i \<langle>S\<rangle>\<^sub>i i_set \<rightarrow>\<^sub>i \<langle>\<langle>S, \<langle>L, S\<rangle>\<^sub>i i_prod\<rangle>\<^sub>i i_prod\<rangle>\<^sub>i i_set \<rightarrow>\<^sub>i \<langle>S\<rangle>\<^sub>i i_set \<rightarrow>\<^sub>i
        \<langle>L, S\<rangle>\<^sub>i i_nbae_scheme"
      "alphabete ::\<^sub>i \<langle>L, S\<rangle>\<^sub>i i_nbae_scheme \<rightarrow>\<^sub>i \<langle>L\<rangle>\<^sub>i i_set"
      "initiale ::\<^sub>i \<langle>L, S\<rangle>\<^sub>i i_nbae_scheme \<rightarrow>\<^sub>i \<langle>S\<rangle>\<^sub>i i_set"
      "transitione ::\<^sub>i \<langle>L, S\<rangle>\<^sub>i i_nbae_scheme \<rightarrow>\<^sub>i \<langle>\<langle>S, \<langle>L, S\<rangle>\<^sub>i i_prod\<rangle>\<^sub>i i_prod\<rangle>\<^sub>i i_set"
      "acceptinge ::\<^sub>i \<langle>L, S\<rangle>\<^sub>i i_nbae_scheme \<rightarrow>\<^sub>i \<langle>S\<rangle>\<^sub>i i_set"
      by auto

  end

  datatype ('label, 'state) nbaei = nbaei
    (alphabetei: "'label list")
    (initialei: "'state list")
    (transitionei: "('state \<times> 'label \<times> 'state) list")
    (acceptingei: "'state list")

  definition nbaei_rel where
    [to_relAPP]: "nbaei_rel L S \<equiv> {(A\<^sub>1, A\<^sub>2).
      (alphabetei A\<^sub>1, alphabetei A\<^sub>2) \<in> \<langle>L\<rangle> list_rel \<and>
      (initialei A\<^sub>1, initialei A\<^sub>2) \<in> \<langle>S\<rangle> list_rel \<and>
      (transitionei A\<^sub>1, transitionei A\<^sub>2) \<in> \<langle>S \<times>\<^sub>r L \<times>\<^sub>r S\<rangle> list_rel \<and>
      (acceptingei A\<^sub>1, acceptingei A\<^sub>2) \<in> \<langle>S\<rangle> list_rel}"

  lemma nbaei_param[param, autoref_rules]:
    "(nbaei, nbaei) \<in> \<langle>L\<rangle> list_rel \<rightarrow> \<langle>S\<rangle> list_rel \<rightarrow> \<langle>S \<times>\<^sub>r L \<times>\<^sub>r S\<rangle> list_rel \<rightarrow>
      \<langle>S\<rangle> list_rel \<rightarrow> \<langle>L, S\<rangle> nbaei_rel"
    "(alphabetei, alphabetei) \<in> \<langle>L, S\<rangle> nbaei_rel \<rightarrow> \<langle>L\<rangle> list_rel"
    "(initialei, initialei) \<in> \<langle>L, S\<rangle> nbaei_rel \<rightarrow> \<langle>S\<rangle> list_rel"
    "(transitionei, transitionei) \<in> \<langle>L, S\<rangle> nbaei_rel \<rightarrow> \<langle>S \<times>\<^sub>r L \<times>\<^sub>r S\<rangle> list_rel"
    "(acceptingei, acceptingei) \<in> \<langle>L, S\<rangle> nbaei_rel \<rightarrow> \<langle>S\<rangle> list_rel"
    unfolding nbaei_rel_def by auto

  definition nbaei_nbae_rel where
    [to_relAPP]: "nbaei_nbae_rel L S \<equiv> {(A\<^sub>1, A\<^sub>2).
      (alphabetei A\<^sub>1, alphabete A\<^sub>2) \<in> \<langle>L\<rangle> list_set_rel \<and>
      (initialei A\<^sub>1, initiale A\<^sub>2) \<in> \<langle>S\<rangle> list_set_rel \<and>
      (transitionei A\<^sub>1, transitione A\<^sub>2) \<in> \<langle>S \<times>\<^sub>r L \<times>\<^sub>r S\<rangle> list_set_rel \<and>
      (acceptingei A\<^sub>1, acceptinge A\<^sub>2) \<in> \<langle>S\<rangle> list_set_rel}"

  lemmas [autoref_rel_intf] = REL_INTFI[of nbaei_nbae_rel i_nbae_scheme]

  lemma nbaei_nbae_param[param, autoref_rules]:
    "(nbaei, nbae) \<in> \<langle>L\<rangle> list_set_rel \<rightarrow> \<langle>S\<rangle> list_set_rel \<rightarrow> \<langle>S \<times>\<^sub>r L \<times>\<^sub>r S\<rangle> list_set_rel \<rightarrow>
      \<langle>S\<rangle> list_set_rel \<rightarrow> \<langle>L, S\<rangle> nbaei_nbae_rel"
    "(alphabetei, alphabete) \<in> \<langle>L, S\<rangle> nbaei_nbae_rel \<rightarrow> \<langle>L\<rangle> list_set_rel"
    "(initialei, initiale) \<in> \<langle>L, S\<rangle> nbaei_nbae_rel \<rightarrow> \<langle>S\<rangle> list_set_rel"
    "(transitionei, transitione) \<in> \<langle>L, S\<rangle> nbaei_nbae_rel \<rightarrow> \<langle>S \<times>\<^sub>r L \<times>\<^sub>r S\<rangle> list_set_rel"
    "(acceptingei, acceptinge) \<in> \<langle>L, S\<rangle> nbaei_nbae_rel \<rightarrow> \<langle>S\<rangle> list_set_rel"
    unfolding nbaei_nbae_rel_def by auto

  definition nbaei_nbae where
    "nbaei_nbae A \<equiv> nbae (set (alphabetei A)) (set (initialei A))
      (set (transitionei A)) (set (acceptingei A))"

  lemma nbaei_nbae_id_param[param]: "(nbaei_nbae, id) \<in> \<langle>L, S\<rangle> nbaei_nbae_rel \<rightarrow> \<langle>L, S\<rangle> nbae_rel"
  proof
    fix Ai A
    assume 1: "(Ai, A) \<in> \<langle>L, S\<rangle> nbaei_nbae_rel"
    have 2: "nbaei_nbae Ai = nbae (set (alphabetei Ai)) (set (initialei Ai))
      (set (transitionei Ai)) (set (acceptingei Ai))" unfolding nbaei_nbae_def by rule
    have 3: "id A = nbae (id (alphabete A)) (id (initiale A))
      (id (transitione A)) (id (acceptinge A))" by simp
    show "(nbaei_nbae Ai, id A) \<in> \<langle>L, S\<rangle> nbae_rel" unfolding 2 3 using 1 by parametricity
  qed

  abbreviation "transitions L S s \<equiv> \<Union> a \<in> L. \<Union> p \<in> S. {p} \<times> {a} \<times> s a p"
  abbreviation "succs T a p \<equiv> (T `` {p}) `` {a}"

  definition nba_nbae where "nba_nbae A \<equiv> nbae (alphabet A) (initial A)
    (transitions (alphabet A) (nodes A) (transition A)) (Set.filter (accepting A) (nodes A))"
  definition nbae_nba where "nbae_nba A \<equiv> nba (alphabete A) (initiale A)
    (succs (transitione A)) (\<lambda> p. p \<in> acceptinge A)"

  lemma nba_nbae_param[param]: "(nba_nbae, nba_nbae) \<in> \<langle>L, S\<rangle> nba_rel \<rightarrow> \<langle>L, S\<rangle> nbae_rel"
    unfolding nba_nbae_def by parametricity
  lemma nbae_nba_param[param]:
    assumes "bijective L" "bijective S"
    shows "(nbae_nba, nbae_nba) \<in> \<langle>L, S\<rangle> nbae_rel \<rightarrow> \<langle>L, S\<rangle> nba_rel"
    using assms assms(2)[unfolded bijective_alt] unfolding nbae_nba_def by parametricity auto

  lemma nbae_nba_nba_nbae_param[param]:
    "((nbae_nba \<circ> nba_nbae) A, id A) \<in> \<langle>Id_on (alphabet A), Id_on (nodes A)\<rangle> nba_rel"
  proof -
    have "(nbae_nba \<circ> nba_nbae) A = nba (alphabet A) (initial A)
      (succs (transitions (alphabet A) (nodes A) (transition A))) (\<lambda> p. p \<in> Set.filter (accepting A) (nodes A))"
      unfolding nbae_nba_def nba_nbae_def by simp
    also have "(\<dots>, nba (alphabet A) (initial A) (transition A) (accepting A)) \<in>
      \<langle>Id_on (alphabet A), Id_on (nodes A)\<rangle> nba_rel"
      using nba_rel_eq by parametricity auto
    also have  "nba (alphabet A) (initial A) (transition A) (accepting A) = id A" by simp
    finally show ?thesis by this
  qed

  definition nbaei_nba_rel where
    [to_relAPP]: "nbaei_nba_rel L S \<equiv> {(Ae, A). (nbae_nba (nbaei_nbae Ae), A) \<in> \<langle>L, S\<rangle> nba_rel}"
  lemma nbaei_nba_id[param]: "(nbae_nba \<circ> nbaei_nbae, id) \<in> \<langle>L, S\<rangle> nbaei_nba_rel \<rightarrow> \<langle>L, S\<rangle> nba_rel"
    unfolding nbaei_nba_rel_def by auto

  schematic_goal nbae_nba_impl:
    assumes [autoref_rules]: "(leq, HOL.eq) \<in> L \<rightarrow> L \<rightarrow> bool_rel"
    assumes [autoref_rules]: "(seq, HOL.eq) \<in> S \<rightarrow> S \<rightarrow> bool_rel"
    shows "(?f, nbae_nba) \<in> \<langle>L, S\<rangle> nbaei_nbae_rel \<rightarrow> \<langle>L, S\<rangle> nbai_nba_rel"
    unfolding nbae_nba_def by autoref
  concrete_definition nbae_nba_impl uses nbae_nba_impl
  lemma nbae_nba_impl_refine[autoref_rules]:
    assumes "GEN_OP leq HOL.eq (L \<rightarrow> L \<rightarrow> bool_rel)"
    assumes "GEN_OP seq HOL.eq (S \<rightarrow> S \<rightarrow> bool_rel)"
    shows "(nbae_nba_impl leq seq, nbae_nba) \<in> \<langle>L, S\<rangle> nbaei_nbae_rel \<rightarrow> \<langle>L, S\<rangle> nbai_nba_rel"
    using nbae_nba_impl.refine assms unfolding autoref_tag_defs by this

end


theory PermEnvEq
  imports PermEnv
begin

    (*
      ####################################
        P1. main equality lemmas
      ####################################
    *)

    (* - add / rem lemmas *)

lemma ignore_add_use_env: "\<lbrakk> r = r_s x \<rbrakk> \<Longrightarrow> r_s = add_use_env r_s x r"
  apply (simp add: add_use_env_def)
  apply (auto)
  done

lemma self_add_use_env: "add_use_env r_s x (r_s x) = r_s"
  apply (case_tac "\<forall> x'. add_use_env r_s x (r_s x) x' = r_s x'")
   apply (auto)
  apply (simp add: add_use_env_def)
  apply (auto)
  done

lemma almost_comm_add_use_env: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> add_use_env (add_use_env r_s x r) y r' = add_use_env (add_use_env r_s y r') x r"
  apply (simp add: add_use_env_def)
  apply (auto)
  done

lemma ignore_rem_use_env: "\<lbrakk> r_s x = NoPerm \<rbrakk> \<Longrightarrow> r_s = rem_use_env r_s x"
  apply (case_tac "\<forall> x'. r_s x' = rem_use_env r_s x x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (auto)
  done

lemma almost_comm_rem_add_use_env: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> rem_use_env (add_use_env r_s x r) y = add_use_env (rem_use_env r_s y) x r"
  apply (case_tac "\<forall> x'. rem_use_env (add_use_env r_s x r) y x' = add_use_env (rem_use_env r_s y) x r x'")
   apply (auto)
  apply (simp add: add_use_env_def)
  apply (simp add: rem_use_env_def)
  apply (case_tac "y = x'")
   apply (auto)
   apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  done

lemma partial_add_rem_use_env: "add_use_env r_s x r = add_use_env (rem_use_env r_s x) x r"
  apply (case_tac "\<forall> x'. add_use_env r_s x r x' = add_use_env (rem_use_env r_s x) x r x'")
   apply (auto)
  apply (simp add: add_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  done

lemma partial_rem_add_use_env: "rem_use_env r_s x = rem_use_env (add_use_env r_s x r) x"
  apply (case_tac "\<forall> x'. rem_use_env r_s x x' = rem_use_env (add_use_env r_s x r) x x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  apply (simp add: add_use_env_def)
  done

lemma cancel_rem_add_use_env: "\<lbrakk> r_s x = NoPerm \<rbrakk> \<Longrightarrow> r_s = rem_use_env (add_use_env r_s x r) x"
  apply (case_tac "\<forall> x'. r_s x' = rem_use_env (add_use_env r_s x r) x x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  apply (simp add: add_use_env_def)
  done

lemma cancel_add_rem_use_env: "\<lbrakk> r_s x = r \<rbrakk> \<Longrightarrow> r_s = add_use_env (rem_use_env r_s x) x r"
  apply (case_tac "\<forall> x'. r_s x' = add_use_env (rem_use_env r_s x) x r x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (simp add: add_use_env_def)
   apply (auto)
  done

    (* - diff lemmas *)

lemma double_diff_use_env: "diff_use_env r_s r_x = diff_use_env (diff_use_env r_s r_x) r_x"
  apply (case_tac "\<forall> x. diff_use_env r_s r_x x = diff_use_env (diff_use_env r_s r_x) r_x x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma cancel_diff_use_env2: "\<lbrakk> leq_use_env r_x r_c \<rbrakk> \<Longrightarrow> diff_use_env r_s r_c = diff_use_env (diff_use_env r_s r_c) r_x"
  apply (case_tac "\<forall> x. diff_use_env r_s r_c x = diff_use_env (diff_use_env r_s r_c) r_x x")
   apply (auto)
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  apply (case_tac "r_c x")
    apply (auto)
  done

lemma cancel_diff_use_env: "\<lbrakk> leq_use_env r_x r_c \<rbrakk> \<Longrightarrow> diff_use_env r_s r_c = diff_use_env (diff_use_env r_s r_x) r_c"
  apply (case_tac "\<forall> x. diff_use_env r_s r_c x = diff_use_env (diff_use_env r_s r_x) r_c x")
   apply (auto)
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  apply (case_tac "r_c x")
    apply (auto)
  done

lemma weak_diff_use_env: "\<lbrakk> weak_use_env r_x \<rbrakk> \<Longrightarrow> diff_use_env r_s r_x = r_s"
  apply (case_tac "\<forall> x. diff_use_env r_s r_x x = r_s x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: weak_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma dist_sq_diff_use_env: "diff_use_env (diff_use_env r_s r_x) r_ex = diff_use_env (diff_use_env r_s r_ex) (diff_use_env r_x r_ex)"
  apply (case_tac "\<forall> x. diff_use_env (diff_use_env r_s r_x) r_ex x = diff_use_env (diff_use_env r_s r_ex) (diff_use_env r_x r_ex) x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (case_tac "r_ex x")
    apply (auto)
  done

lemma inv_diff_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> diff_use_env r_ex r_x = diff_use_env r_ex (diff_use_env r_s (diff_use_env r_s r_x))"
  apply (case_tac "\<forall> x. diff_use_env r_ex r_x x = diff_use_env r_ex (diff_use_env r_s (diff_use_env r_s r_x)) x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
    apply (case_tac "r_s x")
      apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

    (* - diff / add / rem lemmas *)

lemma diff_rem_use_env: "rem_use_env r_s x = diff_use_env r_s (one_use_env x OwnPerm)"
  apply (case_tac "\<forall> x'. rem_use_env r_s x x' = diff_use_env r_s (one_use_env x OwnPerm) x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: one_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma diff_add_rem_use_env: "add_use_env (diff_use_env r_s r_x) x r = diff_use_env (add_use_env r_s x r) (rem_use_env r_x x)"
  apply (case_tac "\<forall> x'. add_use_env (diff_use_env r_s r_x) x r x' = diff_use_env (add_use_env r_s x r) (rem_use_env r_x x) x'")
   apply (auto)
  apply (simp add: add_use_env_def)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
   apply (simp add: diff_use_env_def)
  apply (simp add: diff_use_env_def)
  done

lemma comm_diff_rem_use_env: "rem_use_env (diff_use_env r_s r_x) x = diff_use_env (rem_use_env r_s x) r_x"
  apply (case_tac "\<forall> x'. rem_use_env (diff_use_env r_s r_x) x x' = diff_use_env (rem_use_env r_s x) r_x x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (simp add: diff_use_env_def)
  done

lemma dist_diff_rem_use_env: "rem_use_env (diff_use_env r_s r_x) x = diff_use_env (rem_use_env r_s x) (rem_use_env r_x x)"
  apply (case_tac "\<forall> x'. rem_use_env (diff_use_env r_s r_x) x x' = diff_use_env (rem_use_env r_s x) (rem_use_env r_x x) x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
   apply (simp add: diff_use_env_def)
  apply (simp add: diff_use_env_def)
  done

    (* - comp lemmas *)

lemma comm_comp_use_env: "comp_use_env r_s r_x = comp_use_env r_x r_s"
  apply (case_tac "\<forall> x. comp_use_env r_s r_x x = comp_use_env r_x r_s x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r_x x")
    apply (auto)
    apply (case_tac "r_s x")
      apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma cancel_comp_use_env1: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> comp_use_env r_x r_s = r_s"
  apply (case_tac "\<forall> x. comp_use_env r_x r_s x = r_s x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_s x")
    apply (auto)
    apply (case_tac "r_x x")
      apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma cancel_comp_use_env2: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> comp_use_env r_s r_x = r_s"
  apply (cut_tac r_s="r_s" and r_x="r_x" in comm_comp_use_env)
  apply (simp)
  apply (rule_tac cancel_comp_use_env1)
  apply (simp)
  done

lemma double_comp_use_env: "comp_use_env (comp_use_env r_s r_x) r_s = comp_use_env r_s r_x"
  apply (case_tac "\<forall> x. comp_use_env (comp_use_env r_s r_x) r_s x = comp_use_env r_s r_x x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma assoc_comp_use_env: "comp_use_env r_ex (comp_use_env r_s r_x) = comp_use_env (comp_use_env r_ex r_s) r_x"
  apply (case_tac "\<forall> x. comp_use_env r_ex (comp_use_env r_s r_x) x = comp_use_env (comp_use_env r_ex r_s) r_x x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r_ex x")
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
    apply (case_tac "r_x x")
      apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma shuffle_comp_use_env: "comp_use_env (comp_use_env r_s r_x) r_ex = comp_use_env (comp_use_env r_s r_ex) r_x"
  apply (case_tac "\<forall> x. comp_use_env (comp_use_env r_s r_x) r_ex x = comp_use_env (comp_use_env r_s r_ex) r_x x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
     apply (case_tac "r_ex x")
       apply (auto)
    apply (case_tac "r_ex x")
      apply (auto)
   apply (case_tac "r_ex x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
    apply (case_tac "r_ex x")
      apply (auto)
   apply (case_tac "r_ex x")
     apply (auto)
  apply (case_tac "r_ex x")
    apply (auto)
  done

lemma dist_sq_comp_use_env: "comp_use_env r_ex (comp_use_env r_s r_x) = comp_use_env (comp_use_env r_ex r_s) (comp_use_env r_ex r_x)"
  apply (case_tac "\<forall> x. comp_use_env r_ex (comp_use_env r_s r_x) x = comp_use_env (comp_use_env r_ex r_s) (comp_use_env r_ex r_x) x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r_ex x")
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma dist_sq_comp_use_env2: "comp_use_env (comp_use_env r_s r_x) r_ex = comp_use_env (comp_use_env r_s r_ex) (comp_use_env r_x r_ex)"
  apply (cut_tac r_s="comp_use_env r_s r_x" and r_x="r_ex" in comm_comp_use_env)
  apply (cut_tac r_s="r_s" and r_x="r_ex" in comm_comp_use_env)
  apply (cut_tac r_s="r_x" and r_x="r_ex" in comm_comp_use_env)
  apply (auto)
  apply (rule_tac dist_sq_comp_use_env)
  done

lemma dist_foil_comp_use_env: "comp_use_env (comp_use_env r_xa r_xb) (comp_use_env r_sa r_sb) = comp_use_env (comp_use_env r_xa r_sa) (comp_use_env r_xb r_sb)"
  apply (cut_tac r_ex="comp_use_env r_xa r_xb" and r_s="r_sa" and r_x="r_sb" in dist_sq_comp_use_env)
  apply (simp)
  apply (cut_tac r_s="r_xa" and r_x="r_xb" and r_ex="r_sa" in shuffle_comp_use_env)
  apply (simp)
  apply (rule_tac t="comp_use_env (comp_use_env r_xa r_xb) r_sb" and s="comp_use_env r_xa (comp_use_env r_xb r_sb)" in subst)
   apply (rule_tac assoc_comp_use_env)
  apply (cut_tac r_s="comp_use_env r_xa r_sa" and r_x="r_xb" and r_ex="comp_use_env r_xa (comp_use_env r_xb r_sb)" in shuffle_comp_use_env)
  apply (simp)
  apply (cut_tac r_ex="comp_use_env r_xa r_sa" and r_s="r_xa" and r_x="comp_use_env r_xb r_sb" in assoc_comp_use_env)
  apply (simp)
  apply (rule_tac t="comp_use_env (comp_use_env (comp_use_env (comp_use_env r_xa r_sa) r_xa) (comp_use_env r_xb r_sb)) r_xb" and
      s="comp_use_env (comp_use_env (comp_use_env r_xa r_sa) r_xa) (comp_use_env (comp_use_env r_xb r_sb) r_xb)" in subst)
   apply (rule_tac assoc_comp_use_env)
  apply (cut_tac r_s="r_xa" and r_x="r_sa" in double_comp_use_env)
  apply (cut_tac r_s="r_xb" and r_x="r_sb" in double_comp_use_env)
  apply (simp)
  done

    (* - comp / add / rem lemmas *)

lemma add_comp_use_env: "\<lbrakk> leq_perm (r_s x) r \<rbrakk> \<Longrightarrow> add_use_env r_s x r = comp_use_env r_s (one_use_env x r)"
  apply (case_tac "\<forall> x'. add_use_env r_s x r x' = comp_use_env r_s (one_use_env x r) x'")
   apply (auto)
  apply (simp add: add_use_env_def)
  apply (simp add: comp_use_env_def)
  apply (simp add: one_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
     apply (case_tac r)
       apply (auto)
    apply (case_tac r)
      apply (auto)
   apply (case_tac r)
     apply (auto)
  apply (case_tac "r_s x'")
    apply (auto)
  done

lemma dist_add_comp_use_env: "comp_use_env (add_use_env r_ex x r) (add_use_env r_s x r) = add_use_env (comp_use_env r_ex r_s) x r"
  apply (case_tac "\<forall> xa. comp_use_env (add_use_env r_ex x r) (add_use_env r_s x r) xa = add_use_env (comp_use_env r_ex r_s) x r xa")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac "x = xa")
   apply (auto)
  apply (case_tac r)
    apply (auto)
  done

lemma dist_rem_comp_use_env: "rem_use_env (comp_use_env r_s r_x) x = comp_use_env (rem_use_env r_s x) (rem_use_env r_x x)"
  apply (case_tac "\<forall> x'. rem_use_env (comp_use_env r_s r_x) x x' = comp_use_env (rem_use_env r_s x) (rem_use_env r_x x) x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
   apply (simp add: comp_use_env_def)
  apply (simp add: comp_use_env_def)
  done

lemma rem_add_comp_use_env: "comp_use_env (rem_use_env r_ex x) (add_use_env r_s x r) = add_use_env (comp_use_env r_ex r_s) x r"
  apply (case_tac "\<forall> xa. comp_use_env (rem_use_env r_ex x) (add_use_env r_s x r) xa = add_use_env (comp_use_env r_ex r_s) x r xa")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: add_use_env_def)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = xa")
   apply (auto)
  apply (case_tac "r")
    apply (auto)
  done

    (* - comp / diff lemmas *)

lemma diff_comp_use_env: "diff_use_env (diff_use_env r_s r_x) r_ex = diff_use_env r_s (comp_use_env r_x r_ex)"
  apply (case_tac "\<forall> x. diff_use_env (diff_use_env r_s r_x) r_ex x = diff_use_env r_s (comp_use_env r_x r_ex) x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r_x x")
    apply (auto)
    apply (case_tac "r_ex x")
      apply (auto)
   apply (case_tac "r_ex x")
     apply (auto)
  apply (case_tac "r_ex x")
    apply (auto)
  done

lemma sum_comp_diff_use_env: "comp_use_env (diff_use_env r_ex r_x) r_x = comp_use_env r_ex r_x"
  apply (case_tac "\<forall> x. comp_use_env (diff_use_env r_ex r_x) r_x x = comp_use_env r_ex r_x x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r_x x")
    apply (auto)
  apply (case_tac "r_ex x")
    apply (auto)
  done

lemma dist_diff_comp_use_env: "comp_use_env (diff_use_env r_s r_ex) (diff_use_env r_x r_ex) = diff_use_env (comp_use_env r_s r_x) r_ex"
  apply (case_tac "\<forall> x. comp_use_env (diff_use_env r_s r_ex) (diff_use_env r_x r_ex) x = diff_use_env (comp_use_env r_s r_x) r_ex x")
   apply (auto)
   apply (simp add: diff_use_env_def)
   apply (simp add: comp_use_env_def)
  apply (case_tac "r_ex x")
    apply (auto)
  done

lemma msum_diff_comp_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> comp_use_env r_x (diff_use_env r_s r_x) = r_s"
  apply (case_tac "\<forall> x. comp_use_env r_x (diff_use_env r_s r_x) x = r_s x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: comp_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_s x")
    apply (auto)
    apply (case_tac "r_x x")
      apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

    (* - empty lemmas *)

lemma diff_empty_use_env1: "diff_use_env empty_use_env r_s = empty_use_env"
  apply (case_tac "\<forall> x. diff_use_env empty_use_env r_s x = empty_use_env x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: empty_use_env_def)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma diff_empty_use_env2: "diff_use_env r_s empty_use_env = r_s"
  apply (case_tac "\<forall> x. diff_use_env r_s empty_use_env x = r_s x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: empty_use_env_def)
  done

lemma comp_empty_use_env1: "comp_use_env empty_use_env r = r"
  apply (case_tac "\<forall> x. comp_use_env empty_use_env r x = r x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: empty_use_env_def)
  apply (case_tac "r x")
    apply (auto)
  done

lemma comp_empty_use_env2: "comp_use_env r empty_use_env = r"
  apply (case_tac "\<forall> x. comp_use_env r empty_use_env x = r x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: empty_use_env_def)
  apply (case_tac "r x")
    apply (auto)
  done

lemma comp_empty_use_env: "empty_use_env = comp_use_env empty_use_env empty_use_env"
  apply (case_tac "\<forall> x. empty_use_env x = comp_use_env empty_use_env empty_use_env x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: empty_use_env_def)
  done

end


theory Chisholm imports SDL                             (* Christoph Benzmüller, 2018 *)

begin (* Chisholm Example *)
 consts go::\<sigma> tell::\<sigma> kill::\<sigma>
 axiomatization where
  D1: "\<lfloor>\<^bold>O\<^bold>\<langle>go\<^bold>\<rangle>\<rfloor>" (*It ought to be that Jones goes to assist his neighbors.*) and
  D2: "\<lfloor>\<^bold>O\<^bold>\<langle>go \<^bold>\<rightarrow> tell\<^bold>\<rangle>\<rfloor>"  (*It ought to be that if Jones goes, then he tells them he is coming.*) and
  D3: "\<lfloor>\<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>\<^bold>\<not>tell\<^bold>\<rangle>\<rfloor>" (*If Jones doesn't go, then he ought not tell them he is coming.*) and
  D4: "\<lfloor>\<^bold>\<not>go\<rfloor>\<^sub>c\<^sub>w" (*Jones doesn't go. (This is encoded as a locally valid statement.)*)

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

 lemma True  nitpick [satisfy] oops  (*Consistency-check: Is there a model?*)
 lemma False sledgehammer      oops  (*Inconsistency-check: Can Falsum be derived?*)

 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>\<^bold>\<not>tell\<^bold>\<rangle>\<rfloor>" sledgehammer  nitpick oops   (*Should James not tell?*)
 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>tell\<^bold>\<rangle>\<rfloor>"  sledgehammer  nitpick oops   (*Should James tell?*)
 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>kill\<^bold>\<rangle>\<rfloor>"  sledgehammer  nitpick oops   (*Should James kill?*)
end


section \<open>Fixpoint of Converging Program Transformations\<close>

theory Fixpoint
  imports Compiler
begin

context
  fixes
    m :: "'a \<Rightarrow> nat" and
    f :: "'a \<Rightarrow> 'a option"
begin

function fixpoint :: "'a \<Rightarrow> 'a option" where
  "fixpoint x = (
    case f x of
      None \<Rightarrow> None |
      Some x' \<Rightarrow> if m x' < m x then fixpoint x' else Some x'
  )"
by pat_completeness auto
termination
proof (relation "measure m")
  show "wf (measure m)" by auto
next
  fix x x'
  assume "f x = Some x'" and "m x' < m x"
  thus "(x', x) \<in> measure m" by simp
qed

end

lemma fixpoint_to_comp_pow:
  "fixpoint m f x = y \<Longrightarrow> \<exists>n. option_comp_pow f n x = y"
proof (induction x arbitrary: y rule: fixpoint.induct[where f = f and m = m])
  case (1 x)
  show ?case
  proof (cases "f x")
    case None
    then show ?thesis
      using "1.prems"
      by (metis (no_types, lifting) fixpoint.simps option.case_eq_if option_comp_pow.simps(1))
  next
    case (Some a)
    show ?thesis
    proof (cases "m a < m x")
      case True
      hence "fixpoint m f a = y"
        using "1.prems" Some by simp
      then show ?thesis
        using "1.IH"[OF Some True]
        by (metis Some bind.simps(2) old.nat.exhaust option_comp_def option_comp_pow.simps(1,3))
    next
      case False
      then show ?thesis
        using "1.prems" Some
        apply simp
        by (metis option_comp_pow.simps(2))
    qed
  qed
qed

lemma fixpoint_eq_comp_pow:
  "\<exists>n. fixpoint m f x = option_comp_pow f n x"
  by (metis fixpoint_to_comp_pow)

lemma compiler_composition_fixpoint:
  assumes
    "compiler step step final final load load order match compile"
  shows "compiler step step final final load load
    (lexp order\<^sup>+\<^sup>+) (rel_comp_pow match) (fixpoint m compile)"
proof (rule compiler.intro)
  show "compiler_axioms load load (rel_comp_pow match) (fixpoint m compile)"
  proof unfold_locales
    fix p1 p2 s1
    assume "fixpoint m compile p1 = Some p2" and "load p1 = Some s1"
    obtain n where "fixpoint m compile p1 = option_comp_pow compile n p1"
      using fixpoint_eq_comp_pow by metis

    thus "\<exists>s2 i. load p2 = Some s2 \<and> rel_comp_pow match i s1 s2"
      using \<open>fixpoint m compile p1 = Some p2\<close> assms compiler.compile_load compiler_composition_pow
      using \<open>load p1 = Some s1\<close> by fastforce
  qed
qed (auto intro: assms compiler.axioms backward_simulation_pow)

end


(*

Copyright (c) 2017, ETH Zurich
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this
   list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

(*<*)
theory interrupt
  imports Main Set "HOL-Library.Nat_Bijection"  "../model/Model" "../model/Syntax"
begin
(*>*)

(* ------------------------------------------------------------------------- *)
subsection "Datatype definitions"
(* ------------------------------------------------------------------------- *)

type_synonym PORT = nat
type_synonym VECTOR = nat
type_synonym DATA = nat
type_synonym CONTROLLER_NAME = nat

datatype FORMAT = FINVALID | FEMPTY | FVECTOR "nat" | FMEMWRITE "nat" "nat"

record IRQ =
  format :: FORMAT
  port :: PORT

record CONTROLLER_CLASS =
  in_port_num :: nat
  out_port_num :: nat
  map_valid :: "(IRQ \<Rightarrow> IRQ set) set"

(* Configuration of a controller *)
record CONTROLLER =
  map      :: "IRQ \<Rightarrow> IRQ set"

(* Interconnect of the system + each controller with a class *)
record SYSTEM =
  controller :: "CONTROLLER_NAME \<Rightarrow> (CONTROLLER \<times> CONTROLLER_CLASS)"
  net :: "CONTROLLER_NAME \<Rightarrow> nat \<Rightarrow> (CONTROLLER_NAME \<times> nat) set"

(* ------------------------------------------------------------------------- *)
subsection "IRQ / IRQ Format definitions"
(* ------------------------------------------------------------------------- *)
definition irq_is_empty :: "IRQ \<Rightarrow> bool"
  where "irq_is_empty x = (case format x of FEMPTY \<Rightarrow> True | _ \<Rightarrow> False)"

definition irq_is_vector :: "IRQ \<Rightarrow> bool"
  where "irq_is_vector x = (case format x of FVECTOR _ \<Rightarrow> True | _ \<Rightarrow> False)"

definition irq_is_memwrite :: "IRQ \<Rightarrow> bool"
  where "irq_is_memwrite x = (case format x of FMEMWRITE a b \<Rightarrow> True | _ \<Rightarrow> False)"

definition irq_format_valid :: "FORMAT \<Rightarrow> bool"
  where "irq_format_valid x = (case x of FINVALID \<Rightarrow> False | _ \<Rightarrow> True)"

definition NULL_IRQ :: IRQ
  where "NULL_IRQ = \<lparr>format = FINVALID, port=0\<rparr>"

(* IRQ valid *)
definition irq_valid :: "IRQ \<Rightarrow> bool"
  where "irq_valid x = irq_format_valid (format x)"

(* ------------------------------------------------------------------------- *)
subsection "IRQ / IRQ Format nat encoding and proof of bijection"
(* ------------------------------------------------------------------------- *)
(* define port+formatr to natural bijection *)
definition irq_format_nat_encode :: "FORMAT \<Rightarrow> nat" where
  "irq_format_nat_encode x = (case x of
    FINVALID \<Rightarrow> 0 |
    FEMPTY \<Rightarrow> 1 |
    FVECTOR a  \<Rightarrow> 2 + prod_encode (0,a) |
    FMEMWRITE a b \<Rightarrow> 2 + prod_encode (1+a, b)
    )"

definition irq_format_nat_decode :: "nat \<Rightarrow> FORMAT" where
  "irq_format_nat_decode x = (
        if x = 0 then FINVALID
   else if x = 1 then FEMPTY
   else if fst (prod_decode (x-2)) = 0 then (FVECTOR (snd (prod_decode (x-2))))
   else FMEMWRITE ((fst (prod_decode (x-2)))-1) (snd (prod_decode (x-2)))
   )"

definition irq_nat_encode :: "IRQ \<Rightarrow> nat" where
  "irq_nat_encode i = prod_encode ((irq_format_nat_encode (format i)), port i)"

definition irq_nat_decode :: "nat \<Rightarrow> IRQ" where
  "irq_nat_decode n = \<lparr>format = irq_format_nat_decode (fst (prod_decode n)),
     port = (snd (prod_decode n)) \<rparr>"

lemma format_enc_inv[simp]: "irq_format_nat_decode(irq_format_nat_encode x) = x"
  by(case_tac x, simp_all add:irq_format_nat_encode_def irq_format_nat_decode_def)

lemma format_dec_inv_0:
  assumes e1: "x=0"
  shows "irq_format_nat_encode(irq_format_nat_decode x) = x"
  by(simp add:e1 irq_format_nat_encode_def irq_format_nat_decode_def)

lemma format_dec_inv_1:
  assumes e1: "x=1"
  shows "irq_format_nat_encode(irq_format_nat_decode x) = x"
  by(simp add:e1 irq_format_nat_encode_def irq_format_nat_decode_def)

lemma format_dec_inv_2:
  assumes e1: "x=2"
  shows "irq_format_nat_encode(irq_format_nat_decode x) = x"
    apply(simp add:irq_format_nat_encode_def irq_format_nat_decode_def e1)
    by(metis prod.collapse prod_decode_inverse)

lemma format_dec_inv_rest:
  assumes e1: "(x :: nat) > 2"
  shows "irq_format_nat_encode(irq_format_nat_decode x) = x"

proof -
  from e1 have "Suc (Suc (x - 2)) = x"
    by(simp)

  thus ?thesis
    apply(simp add:irq_format_nat_encode_def irq_format_nat_decode_def)
    by(metis prod.collapse prod_decode_inverse)
qed

lemma format_dec_inv[simp]:
  shows "irq_format_nat_encode(irq_format_nat_decode x) = x"
proof cases
  assume "x=0"
  thus ?thesis
    by(simp add:format_dec_inv_0)
next
  assume nc0: "(x :: nat) \<noteq>0"
  thus ?thesis
  proof cases
    assume "(x :: nat) =1"
    thus ?thesis by(simp add:nc0 format_dec_inv_1)
  next
    assume nc1: "(x :: nat) \<noteq>1"
    thus ?thesis
    proof cases
      assume "(x :: nat) =2"
      thus ?thesis by(simp add:format_dec_inv_2)
    next
      assume nc2: "(x :: nat) \<noteq>2"
      thus ?thesis
      proof -
        have R1: "(x :: nat) > 2"
          using nc0 nc1 nc2 by linarith
        thus ?thesis by(simp add:format_dec_inv_rest)
      qed
    qed
  qed
qed

lemma irq_enc_inv[simp]: "irq_nat_decode(irq_nat_encode x) = x"
  by(simp add:irq_nat_encode_def irq_nat_decode_def)

lemma irq_dec_inv[simp]: "irq_nat_encode(irq_nat_decode x) = x"
  by(simp add:irq_nat_encode_def irq_nat_decode_def)

lemma inj_irq_nat_encode: "inj_on irq_nat_encode A"
  by (rule inj_on_inverseI) (rule irq_enc_inv)

lemma inj_irq_nat_decode: "inj_on irq_nat_decode A"
  by (rule inj_on_inverseI) (rule irq_dec_inv)

lemma surj_irq_nat_encode: "surj irq_nat_encode"
  by (rule surjI) (rule irq_dec_inv)

lemma surj_irq_nat_decode: "surj irq_nat_decode"
  by (rule surjI) (rule irq_enc_inv)

lemma bij_irq_nat_encode: "bij irq_nat_encode"
  by (rule bijI [OF inj_irq_nat_encode surj_irq_nat_encode])

lemma bij_irq_nat_decode: "bij irq_nat_decode"
  by (rule bijI [OF inj_irq_nat_decode surj_irq_nat_decode])

lemma irq_nat_encode_eq: "irq_nat_encode x = irq_nat_encode y \<longleftrightarrow> x = y"
  by (rule inj_irq_nat_encode [THEN inj_eq])

lemma irq_nat_decode_eq: "irq_nat_decode x = irq_nat_decode y \<longleftrightarrow> x = y"
  by (rule inj_irq_nat_decode [THEN inj_eq])

(* ------------------------------------------------------------------------- *)
subsection "Incremental configuration change of controllers"
(* ------------------------------------------------------------------------- *)

definition replace_map :: "CONTROLLER \<Rightarrow> IRQ \<Rightarrow> IRQ set \<Rightarrow> CONTROLLER"
  where "replace_map orig new_inp new_out = orig \<lparr> map :=
    (\<lambda>i. (if i = new_inp then new_out else (map orig) i))
   \<rparr>"

definition replace_map_ctrl :: "(CONTROLLER \<times> CONTROLLER_CLASS) \<Rightarrow> IRQ \<Rightarrow> IRQ set \<Rightarrow>
          (CONTROLLER \<times> CONTROLLER_CLASS)"
  where "replace_map_ctrl orig new_inp new_out = (replace_map (fst orig) new_inp new_out, snd orig)"

(* An identity mapped no broadcasting net *)
definition ident_net :: "CONTROLLER_NAME \<Rightarrow> nat \<Rightarrow> (CONTROLLER_NAME \<times> nat) set"
  where "ident_net cn inp = {(cn, inp)}"

(* In system at controller name, replace its mapping from new_inp to new_outp *)
definition replace_system :: "SYSTEM \<Rightarrow> CONTROLLER_NAME \<Rightarrow> IRQ \<Rightarrow> IRQ set \<Rightarrow> SYSTEM"
  where "replace_system orig name new_inp new_out = orig \<lparr>
      controller := (controller orig)(name := replace_map_ctrl ((controller orig)name) new_inp new_out)
    \<rparr>"

(* Arguments that do not produce an empty set, see dom *)
definition doms :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a set" where
  "doms m = {a. m a \<noteq> {}}"

(* Get  the actual configuration of a controller name *)
definition sys_ctrl_act_conf :: "SYSTEM \<Rightarrow> CONTROLLER_NAME \<Rightarrow> (IRQ \<Rightarrow> IRQ set)"
  where "sys_ctrl_act_conf s cn = map (fst ((controller s) cn))"

(* Get the set valid configuration of a controller name *)
definition sys_ctrl_valid_conf :: "SYSTEM \<Rightarrow> CONTROLLER_NAME \<Rightarrow> ((IRQ \<Rightarrow> IRQ set) set)"
  where "sys_ctrl_valid_conf s cn = (map_valid (snd ((controller s) cn)))"

(* Check if c has a valid config in s *)
definition sys_ctrl_valid :: "SYSTEM \<Rightarrow> CONTROLLER_NAME \<Rightarrow> bool"
  where "sys_ctrl_valid s cn = ((sys_ctrl_act_conf s cn) \<in> (sys_ctrl_valid_conf s cn))"

(* Check if a system is in a valid state *)
definition sys_valid :: "SYSTEM \<Rightarrow> bool"
  where "sys_valid s = (\<forall> c. sys_ctrl_valid s c)"

(* ------------------------------------------------------------------------- *)
subsection "From IRQ system to decoding net definitions"
(* ------------------------------------------------------------------------- *)
(* iis is an output set at c,  perform net lookup to give back input interrupts at controllers (as set)*)
definition net_set_translate :: "SYSTEM \<Rightarrow> CONTROLLER_NAME \<Rightarrow> IRQ set \<Rightarrow> (CONTROLLER_NAME \<times> IRQ) set"
  where "net_set_translate s c iis = \<Union> { {(fst y, \<lparr> format = (format x), port = (snd y)\<rparr>) |
     y. y \<in> ((net s) c (port x))} | x. x \<in> iis }"

(* A set of input interrupts translated to a a name set *)
definition irq_set_to_name_set :: "(CONTROLLER_NAME \<times> IRQ) set \<Rightarrow> name set"
  where "irq_set_to_name_set is = { (fst a, (irq_nat_encode (snd a), {})) | a. a \<in> is}"

(* Apply net translation, then translate to names *)
definition conf_to_translate_mod_conf :: "SYSTEM \<Rightarrow> CONTROLLER_NAME \<Rightarrow> (IRQ \<Rightarrow> IRQ set) \<Rightarrow> IRQ \<Rightarrow> name set"
  where "conf_to_translate_mod_conf s cn conf i = irq_set_to_name_set (net_set_translate s cn (conf i))"

definition conf_to_translate_mod :: "SYSTEM \<Rightarrow> CONTROLLER_NAME \<Rightarrow> IRQ \<Rightarrow> name set"
  where "conf_to_translate_mod s cn ini =
            irq_set_to_name_set (net_set_translate s cn ((sys_ctrl_act_conf s cn) ini))"

definition conf_to_translate :: "SYSTEM \<Rightarrow> CONTROLLER_NAME \<Rightarrow> (addr \<Rightarrow> name set)"
  where "conf_to_translate s cn =
            (\<lambda>addr. conf_to_translate_mod s cn (irq_nat_decode (fst addr)))
         "

definition mk_node :: "SYSTEM \<Rightarrow> CONTROLLER_NAME \<Rightarrow> node"
  where "mk_node s cn = \<lparr>accept = {}, translate = conf_to_translate s cn \<rparr>"

definition mk_net :: "SYSTEM \<Rightarrow> net"
  where "mk_net s = (\<lambda>nodeid. mk_node s nodeid)"

(* modify node such that addr will now map to name set *)
definition replace_node :: "node \<Rightarrow> nat \<Rightarrow> name set \<Rightarrow> node" where
  "replace_node n inp out = n \<lparr> translate := (\<lambda> a. if (fst a)=inp then out else translate n a) \<rparr>"

(* ------------------------------------------------------------------------- *)
subsection "Lifting Result"
(* ------------------------------------------------------------------------- *)

(* TODO: move this into the proof of the lifting lemma *)
lemma lifts_inner : "({(a, (irq_nat_encode b, {})) |a b.
              \<exists>x. (
                \<exists>xa. x = {(ctrl, \<lparr>format = format xa, port = port xa\<rparr>)} \<and>
                xa \<in> (if irq_nat_decode (fst addr) = inirq then {outirq}
                      else CONTROLLER.map (fst (controller sys ctrl)) (irq_nat_decode (fst addr))))
                      \<and> (a, b) \<in> x}) =
    (if (fst addr) = irq_nat_encode inirq then {(ctrl, (irq_nat_encode outirq, {}))}
          else {(aa, (irq_nat_encode b, {})) |aa b. \<exists>x.
          (\<exists>xa. x = {(ctrl, \<lparr>format = format xa, port = port xa\<rparr>)} \<and>
          xa \<in> CONTROLLER.map (fst (controller sys ctrl)) (irq_nat_decode (fst addr)))
          \<and> (aa, b) \<in> x})"
  by(auto, simp add:irq_nat_encode_def)

lemma lifts:
  (* Assume an identity net function *)
  assumes ident_net: "net sys = ident_net"
  (* Assume that inirq \<rightarrow> outirq is in mapvalid? *)
  shows "mk_node (replace_system sys ctrl inirq {outirq}) ctrl =
       replace_node (mk_node sys ctrl) (irq_nat_encode inirq) {(ctrl, (irq_nat_encode outirq, {}))}"
proof -
  (* Simplify both side until we apply lemma lifts_inner *)

  (* left side *)
  have L1: "mk_node (replace_system sys ctrl inirq {outirq}) ctrl =
 \<lparr>accept = {}, translate = conf_to_translate (replace_system sys ctrl inirq {outirq}) ctrl\<rparr> "
    by(simp add:mk_node_def)

  have L2: "conf_to_translate (replace_system sys ctrl inirq {outirq}) ctrl =
        (\<lambda>addr. conf_to_translate_mod (replace_system sys ctrl inirq {outirq}) ctrl (irq_nat_decode (fst addr)))"
    by(simp add:conf_to_translate_def)

  (* continue only with translate function *)
  have L3: "(\<lambda>addr. conf_to_translate_mod (replace_system sys ctrl inirq {outirq}) ctrl (irq_nat_decode (fst addr))) =
    (\<lambda>addr. {(a, (irq_nat_encode b, {})) |a b.
              \<exists>x. (\<exists>xa. x = {(ctrl, \<lparr>format = format xa, port = port xa\<rparr>)} \<and> xa \<in>
              (if irq_nat_decode (fst addr) = inirq then {outirq} else
              CONTROLLER.map (fst (controller sys ctrl)) (irq_nat_decode (fst addr)))) \<and> (a, b) \<in> x})"
    apply(simp add:conf_to_translate_mod_def)
    apply(simp add:irq_set_to_name_set_def)
    apply(simp add:sys_ctrl_act_conf_def)
    apply(simp add:replace_system_def)
    apply(simp add:replace_map_ctrl_def)
    apply(simp add:replace_map_def)
    apply(simp add:net_set_translate_def)
    apply(simp add:ident_net add:ident_net_def)
    done

  (* right side *)
  have R1: "replace_node (interrupt.mk_node sys ctrl) (irq_nat_encode inirq)
            {(ctrl, (irq_nat_encode outirq, {}))} = \<lparr>accept = {}, translate =
            \<lambda>a. if (fst a) = irq_nat_encode inirq then {(ctrl, (irq_nat_encode outirq, {}))}
             else translate \<lparr>accept = {}, translate = conf_to_translate sys ctrl\<rparr> a\<rparr>"
    by(simp add:replace_node_def mk_node_def)

  have R21: "translate \<lparr>accept = {}, translate = conf_to_translate sys ctrl\<rparr> =
      (\<lambda>addr. {(a, (irq_nat_encode b, {}))
         |a b. \<exists>x. (\<exists>xa. x = {(ctrl, \<lparr>format = format xa, port = port xa\<rparr>)} \<and>
         xa \<in> CONTROLLER.map (fst (controller sys ctrl)) (irq_nat_decode (fst addr))) \<and> (a, b) \<in> x})"
    by(simp add:conf_to_translate_def conf_to_translate_mod_def irq_set_to_name_set_def
                  net_set_translate_def ident_net ident_net_def sys_ctrl_act_conf_def)

  show ?thesis
    by(simp only:R1, simp only:R21, simp add:L1 L2 L3 lifts_inner)
qed

end