theory Traces
imports Main
begin

find_consts "'a + 'b \<Rightarrow> bool"

term sum.isl

definition "traceDom \<equiv> {(f). \<forall> (i :: nat) j. j \<le> i \<longrightarrow> \<not>(sum.isl (f j)) \<longrightarrow> f i = f j}"

typedef ('state, 'sym) trace = "traceDom :: (nat \<Rightarrow> ('state + 'sym)) set"
  apply (rule_tac x="\<lambda>_. Inr undefined" in exI)
  apply (clarsimp simp: traceDom_def)
  done

setup_lifting type_definition_trace

lift_definition index :: " ('state, 'sym) trace \<Rightarrow> nat \<Rightarrow>  'state + 'sym" is "\<lambda>f n. f n" done

primrec iterate where
  "iterate x f 0       = x" |
  "iterate x f (Suc n) = f (iterate x f n)"

definition "finiteS f \<equiv> \<exists>n. \<not>isl (index f n)"

lift_definition pred :: "((nat \<Rightarrow>  'state + 'sym) \<Rightarrow> 'b) \<Rightarrow> ( ('state, 'sym) trace \<Rightarrow> 'b)" is "\<lambda>P f. P f"
  done

definition lengthS where "lengthS \<equiv> \<lambda>f. if finiteS f then Some (LEAST n. \<not>isl (index f n)) else None"

lift_definition liftF :: "(nat \<Rightarrow>  'state + 'sym) \<Rightarrow>  ('state, 'sym) trace " is
 "\<lambda>f. if f \<in> traceDom then f else (\<lambda>_. Inr undefined)"
  by (clarsimp simp: traceDom_def)

lemma traceDom_antimono: "g \<in> traceDom \<Longrightarrow> antimono P \<Longrightarrow> (\<And>n. P n \<longrightarrow> isl (f n)) \<Longrightarrow> (\<lambda>n. if P n then f n else g n ) \<in> traceDom"
  apply ( clarsimp simp: traceDom_def split: if_splits)
  by (metis monotoneD)

lemma traceDom_antimono': "\<not>(\<lambda>n. if P n then f n else g n ) \<in> traceDom \<Longrightarrow>  antimono P \<Longrightarrow> (\<And>n. P n \<Longrightarrow> isl (f n)) \<Longrightarrow> \<not>g \<in> traceDom "
  apply ( clarsimp simp: traceDom_def split: if_splits)
  by (metis monotoneD)

primrec coerce :: "'a + 'b \<Rightarrow> 'a + 'c"
  where
  "coerce (Inl a) = Inl a" |
  "coerce (Inr b) = Inr undefined"

definition "tail s = liftF (\<lambda>n. index s (n + 1))"

lemma tail_traceDom[simp]: "(\<lambda>n. index s (n + 1)) \<in> traceDom"
  by (clarsimp simp: traceDom_def, transfer, clarsimp simp: traceDom_def)

lemma lengthS_le: "(\<And>n.  isl (index s n) \<Longrightarrow> isl (index s' n)) ==>  finiteS s' \<Longrightarrow>   the ( lengthS s) \<le> the (lengthS s')"
  apply (transfer)
  apply (clarsimp simp: lengthS_def )
  apply (intro conjI impI; clarsimp?)
   apply (rule Least_le)
   apply (metis LeastI finiteS_def)
  by (simp add: finiteS_def)

definition "map_trace f t \<equiv> liftF (\<lambda>n. case_sum (Inl o f) (Inr) (index t n))"

lemma map_traceDom[simp]: "(\<lambda>n. case_sum (Inl o f o projl) (Inr) (index t n)) \<in> traceDom"
  apply (clarsimp simp: traceDom_def split: sum.splits)
  apply (intro conjI; clarsimp)
   apply (transfer, clarsimp simp: traceDom_def)
  apply (transfer, clarsimp simp: traceDom_def)
  done

lemma trace_eqI: "(\<And>n. index c n = index d n) \<Longrightarrow> c = d"
  by (transfer, intro ext, fastforce)

definition appendS :: " ('state, 'sym) trace \<Rightarrow>  ('state, 'sym) trace \<Rightarrow>  ('state, 'sym) trace"
  where "appendS s s' \<equiv>
   if finiteS s then
       liftF (\<lambda>n. if (n < the ( lengthS s)) then coerce (index s n) else index s' (n - (the (lengthS s))))
                        else
       liftF (coerce o index s)"

end


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

section\<open>Weak Safety Properties\<close>

theory Constrains
imports UNITY
begin

consts traces :: "[i, i] => i"
  (* Initial states and program => (final state, reversed trace to it)...
      the domain may also be state*list(state) *)
inductive
  domains
     "traces(init, acts)" <=
         "(init \<union> (\<Union>act\<in>acts. field(act)))*list(\<Union>act\<in>acts. field(act))"
  intros
         (*Initial trace is empty*)
    Init: "s: init ==> <s,[]> \<in> traces(init,acts)"

    Acts: "[| act:acts;  <s,evs> \<in> traces(init,acts);  <s,s'>: act |]
           ==> <s', Cons(s,evs)> \<in> traces(init, acts)"

  type_intros list.intros UnI1 UnI2 UN_I fieldI2 fieldI1

consts reachable :: "i=>i"
inductive
  domains
  "reachable(F)" \<subseteq> "Init(F) \<union> (\<Union>act\<in>Acts(F). field(act))"
  intros
    Init: "s:Init(F) ==> s:reachable(F)"

    Acts: "[| act: Acts(F);  s:reachable(F);  <s,s'>: act |]
           ==> s':reachable(F)"

  type_intros UnI1 UnI2 fieldI2 UN_I

definition
  Constrains :: "[i,i] => i"  (infixl "Co" 60)  where
  "A Co B == {F:program. F:(reachable(F) \<inter> A) co B}"

definition
  op_Unless  :: "[i, i] => i"  (infixl "Unless" 60)  where
  "A Unless B == (A-B) Co (A \<union> B)"

definition
  Stable     :: "i => i"  where
  "Stable(A) == A Co A"

definition
  (*Always is the weak form of "invariant"*)
  Always :: "i => i"  where
  "Always(A) == initially(A) \<inter> Stable(A)"

(*** traces and reachable ***)

lemma reachable_type: "reachable(F) \<subseteq> state"
apply (cut_tac F = F in Init_type)
apply (cut_tac F = F in Acts_type)
apply (cut_tac F = F in reachable.dom_subset, blast)
done

lemma st_set_reachable: "st_set(reachable(F))"
apply (unfold st_set_def)
apply (rule reachable_type)
done
declare st_set_reachable [iff]

lemma reachable_Int_state: "reachable(F) \<inter> state = reachable(F)"
by (cut_tac reachable_type, auto)
declare reachable_Int_state [iff]

lemma state_Int_reachable: "state \<inter> reachable(F) = reachable(F)"
by (cut_tac reachable_type, auto)
declare state_Int_reachable [iff]

lemma reachable_equiv_traces:
"F \<in> program ==> reachable(F)={s \<in> state. \<exists>evs. <s,evs>:traces(Init(F), Acts(F))}"
apply (rule equalityI, safe)
apply (blast dest: reachable_type [THEN subsetD])
apply (erule_tac [2] traces.induct)
apply (erule reachable.induct)
apply (blast intro: reachable.intros traces.intros)+
done

lemma Init_into_reachable: "Init(F) \<subseteq> reachable(F)"
by (blast intro: reachable.intros)

lemma stable_reachable: "[| F \<in> program; G \<in> program;
    Acts(G) \<subseteq> Acts(F)  |] ==> G \<in> stable(reachable(F))"
apply (blast intro: stableI constrainsI st_setI
             reachable_type [THEN subsetD] reachable.intros)
done

declare stable_reachable [intro!]
declare stable_reachable [simp]

(*The set of all reachable states is an invariant...*)
lemma invariant_reachable:
   "F \<in> program ==> F \<in> invariant(reachable(F))"
apply (unfold invariant_def initially_def)
apply (blast intro: reachable_type [THEN subsetD] reachable.intros)
done

(*...in fact the strongest invariant!*)
lemma invariant_includes_reachable: "F \<in> invariant(A) ==> reachable(F) \<subseteq> A"
apply (cut_tac F = F in Acts_type)
apply (cut_tac F = F in Init_type)
apply (cut_tac F = F in reachable_type)
apply (simp (no_asm_use) add: stable_def constrains_def invariant_def initially_def)
apply (rule subsetI)
apply (erule reachable.induct)
apply (blast intro: reachable.intros)+
done

(*** Co ***)

lemma constrains_reachable_Int: "F \<in> B co B'==>F:(reachable(F) \<inter> B) co (reachable(F) \<inter> B')"
apply (frule constrains_type [THEN subsetD])
apply (frule stable_reachable [OF _ _ subset_refl])
apply (simp_all add: stable_def constrains_Int)
done

(*Resembles the previous definition of Constrains*)
lemma Constrains_eq_constrains:
"A Co B = {F \<in> program. F:(reachable(F) \<inter> A) co (reachable(F)  \<inter>  B)}"
apply (unfold Constrains_def)
apply (blast dest: constrains_reachable_Int constrains_type [THEN subsetD]
             intro: constrains_weaken)
done

lemmas Constrains_def2 = Constrains_eq_constrains [THEN eq_reflection]

lemma constrains_imp_Constrains: "F \<in> A co A' ==> F \<in> A Co A'"
apply (unfold Constrains_def)
apply (blast intro: constrains_weaken_L dest: constrainsD2)
done

lemma ConstrainsI:
    "[|!!act s s'. [| act \<in> Acts(F); <s,s'>:act; s \<in> A |] ==> s':A';
       F \<in> program|]
     ==> F \<in> A Co A'"
apply (auto simp add: Constrains_def constrains_def st_set_def)
apply (blast dest: reachable_type [THEN subsetD])
done

lemma Constrains_type:
 "A Co B \<subseteq> program"
apply (unfold Constrains_def, blast)
done

lemma Constrains_empty: "F \<in> 0 Co B \<longleftrightarrow> F \<in> program"
by (auto dest: Constrains_type [THEN subsetD]
            intro: constrains_imp_Constrains)
declare Constrains_empty [iff]

lemma Constrains_state: "F \<in> A Co state \<longleftrightarrow> F \<in> program"
apply (unfold Constrains_def)
apply (auto dest: Constrains_type [THEN subsetD] intro: constrains_imp_Constrains)
done
declare Constrains_state [iff]

lemma Constrains_weaken_R:
        "[| F \<in> A Co A'; A'<=B' |] ==> F \<in> A Co B'"
apply (unfold Constrains_def2)
apply (blast intro: constrains_weaken_R)
done

lemma Constrains_weaken_L:
    "[| F \<in> A Co A'; B<=A |] ==> F \<in> B Co A'"
apply (unfold Constrains_def2)
apply (blast intro: constrains_weaken_L st_set_subset)
done

lemma Constrains_weaken:
   "[| F \<in> A Co A'; B<=A; A'<=B' |] ==> F \<in> B Co B'"
apply (unfold Constrains_def2)
apply (blast intro: constrains_weaken st_set_subset)
done

(** Union **)
lemma Constrains_Un:
    "[| F \<in> A Co A'; F \<in> B Co B' |] ==> F \<in> (A \<union> B) Co (A' \<union> B')"
apply (unfold Constrains_def2, auto)
apply (simp add: Int_Un_distrib)
apply (blast intro: constrains_Un)
done

lemma Constrains_UN:
    "[|(!!i. i \<in> I==>F \<in> A(i) Co A'(i)); F \<in> program|]
     ==> F:(\<Union>i \<in> I. A(i)) Co (\<Union>i \<in> I. A'(i))"
by (auto intro: constrains_UN simp del: UN_simps
         simp add: Constrains_def2 Int_UN_distrib)

(** Intersection **)

lemma Constrains_Int:
    "[| F \<in> A Co A'; F \<in> B Co B'|]==> F:(A \<inter> B) Co (A' \<inter> B')"
apply (unfold Constrains_def)
apply (subgoal_tac "reachable (F) \<inter> (A \<inter> B) = (reachable (F) \<inter> A) \<inter> (reachable (F) \<inter> B) ")
apply (auto intro: constrains_Int)
done

lemma Constrains_INT:
    "[| (!!i. i \<in> I ==>F \<in> A(i) Co A'(i)); F \<in> program  |]
     ==> F:(\<Inter>i \<in> I. A(i)) Co (\<Inter>i \<in> I. A'(i))"
apply (simp (no_asm_simp) del: INT_simps add: Constrains_def INT_extend_simps)
apply (rule constrains_INT)
apply (auto simp add: Constrains_def)
done

lemma Constrains_imp_subset: "F \<in> A Co A' ==> reachable(F) \<inter> A \<subseteq> A'"
apply (unfold Constrains_def)
apply (blast dest: constrains_imp_subset)
done

lemma Constrains_trans:
 "[| F \<in> A Co B; F \<in> B Co C |] ==> F \<in> A Co C"
apply (unfold Constrains_def2)
apply (blast intro: constrains_trans constrains_weaken)
done

lemma Constrains_cancel:
"[| F \<in> A Co (A' \<union> B); F \<in> B Co B' |] ==> F \<in> A Co (A' \<union> B')"
apply (unfold Constrains_def2)
apply (simp (no_asm_use) add: Int_Un_distrib)
apply (blast intro: constrains_cancel)
done

(*** Stable ***)
(* Useful because there's no Stable_weaken.  [Tanja Vos] *)

lemma stable_imp_Stable:
"F \<in> stable(A) ==> F \<in> Stable(A)"

apply (unfold stable_def Stable_def)
apply (erule constrains_imp_Constrains)
done

lemma Stable_eq: "[| F \<in> Stable(A); A = B |] ==> F \<in> Stable(B)"
by blast

lemma Stable_eq_stable:
"F \<in> Stable(A) \<longleftrightarrow>  (F \<in> stable(reachable(F) \<inter> A))"
apply (auto dest: constrainsD2 simp add: Stable_def stable_def Constrains_def2)
done

lemma StableI: "F \<in> A Co A ==> F \<in> Stable(A)"
by (unfold Stable_def, assumption)

lemma StableD: "F \<in> Stable(A) ==> F \<in> A Co A"
by (unfold Stable_def, assumption)

lemma Stable_Un:
    "[| F \<in> Stable(A); F \<in> Stable(A') |] ==> F \<in> Stable(A \<union> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Un)
done

lemma Stable_Int:
    "[| F \<in> Stable(A); F \<in> Stable(A') |] ==> F \<in> Stable (A \<inter> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Int)
done

lemma Stable_Constrains_Un:
    "[| F \<in> Stable(C); F \<in> A Co (C \<union> A') |]
     ==> F \<in> (C \<union> A) Co (C \<union> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Un [THEN Constrains_weaken_R])
done

lemma Stable_Constrains_Int:
    "[| F \<in> Stable(C); F \<in> (C \<inter> A) Co A' |]
     ==> F \<in> (C \<inter> A) Co (C \<inter> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Int [THEN Constrains_weaken])
done

lemma Stable_UN:
    "[| (!!i. i \<in> I ==> F \<in> Stable(A(i))); F \<in> program |]
     ==> F \<in> Stable (\<Union>i \<in> I. A(i))"
apply (simp add: Stable_def)
apply (blast intro: Constrains_UN)
done

lemma Stable_INT:
    "[|(!!i. i \<in> I ==> F \<in> Stable(A(i))); F \<in> program |]
     ==> F \<in> Stable (\<Inter>i \<in> I. A(i))"
apply (simp add: Stable_def)
apply (blast intro: Constrains_INT)
done

lemma Stable_reachable: "F \<in> program ==>F \<in> Stable (reachable(F))"
apply (simp (no_asm_simp) add: Stable_eq_stable Int_absorb)
done

lemma Stable_type: "Stable(A) \<subseteq> program"
apply (unfold Stable_def)
apply (rule Constrains_type)
done

(*** The Elimination Theorem.  The "free" m has become universally quantified!
     Should the premise be !!m instead of \<forall>m ?  Would make it harder to use
     in forward proof. ***)

lemma Elimination:
    "[| \<forall>m \<in> M. F \<in> ({s \<in> A. x(s) = m}) Co (B(m)); F \<in> program |]
     ==> F \<in> ({s \<in> A. x(s):M}) Co (\<Union>m \<in> M. B(m))"
apply (unfold Constrains_def, auto)
apply (rule_tac A1 = "reachable (F) \<inter> A"
        in UNITY.elimination [THEN constrains_weaken_L])
apply (auto intro: constrains_weaken_L)
done

(* As above, but for the special case of A=state *)
lemma Elimination2:
 "[| \<forall>m \<in> M. F \<in> {s \<in> state. x(s) = m} Co B(m); F \<in> program |]
     ==> F \<in> {s \<in> state. x(s):M} Co (\<Union>m \<in> M. B(m))"
apply (blast intro: Elimination)
done

(** Unless **)

lemma Unless_type: "A Unless B <=program"
apply (unfold op_Unless_def)
apply (rule Constrains_type)
done

(*** Specialized laws for handling Always ***)

(** Natural deduction rules for "Always A" **)

lemma AlwaysI:
"[| Init(F)<=A;  F \<in> Stable(A) |] ==> F \<in> Always(A)"

apply (unfold Always_def initially_def)
apply (frule Stable_type [THEN subsetD], auto)
done

lemma AlwaysD: "F \<in> Always(A) ==> Init(F)<=A & F \<in> Stable(A)"
by (simp add: Always_def initially_def)

lemmas AlwaysE = AlwaysD [THEN conjE]
lemmas Always_imp_Stable = AlwaysD [THEN conjunct2]

(*The set of all reachable states is Always*)
lemma Always_includes_reachable: "F \<in> Always(A) ==> reachable(F) \<subseteq> A"
apply (simp (no_asm_use) add: Stable_def Constrains_def constrains_def Always_def initially_def)
apply (rule subsetI)
apply (erule reachable.induct)
apply (blast intro: reachable.intros)+
done

lemma invariant_imp_Always:
     "F \<in> invariant(A) ==> F \<in> Always(A)"
apply (unfold Always_def invariant_def Stable_def stable_def)
apply (blast intro: constrains_imp_Constrains)
done

lemmas Always_reachable = invariant_reachable [THEN invariant_imp_Always]

lemma Always_eq_invariant_reachable: "Always(A) = {F \<in> program. F \<in> invariant(reachable(F) \<inter> A)}"
apply (simp (no_asm) add: Always_def invariant_def Stable_def Constrains_def2 stable_def initially_def)
apply (rule equalityI, auto)
apply (blast intro: reachable.intros reachable_type)
done

(*the RHS is the traditional definition of the "always" operator*)
lemma Always_eq_includes_reachable: "Always(A) = {F \<in> program. reachable(F) \<subseteq> A}"
apply (rule equalityI, safe)
apply (auto dest: invariant_includes_reachable
   simp add: subset_Int_iff invariant_reachable Always_eq_invariant_reachable)
done

lemma Always_type: "Always(A) \<subseteq> program"
by (unfold Always_def initially_def, auto)

lemma Always_state_eq: "Always(state) = program"
apply (rule equalityI)
apply (auto dest: Always_type [THEN subsetD] reachable_type [THEN subsetD]
            simp add: Always_eq_includes_reachable)
done
declare Always_state_eq [simp]

lemma state_AlwaysI: "F \<in> program ==> F \<in> Always(state)"
by (auto dest: reachable_type [THEN subsetD]
            simp add: Always_eq_includes_reachable)

lemma Always_eq_UN_invariant: "st_set(A) ==> Always(A) = (\<Union>I \<in> Pow(A). invariant(I))"
apply (simp (no_asm) add: Always_eq_includes_reachable)
apply (rule equalityI, auto)
apply (blast intro: invariantI rev_subsetD [OF _ Init_into_reachable]
                    rev_subsetD [OF _ invariant_includes_reachable]
             dest: invariant_type [THEN subsetD])+
done

lemma Always_weaken: "[| F \<in> Always(A); A \<subseteq> B |] ==> F \<in> Always(B)"
by (auto simp add: Always_eq_includes_reachable)

(*** "Co" rules involving Always ***)
lemmas Int_absorb2 = subset_Int_iff [unfolded iff_def, THEN conjunct1, THEN mp]

lemma Always_Constrains_pre: "F \<in> Always(I) ==> (F:(I \<inter> A) Co A') \<longleftrightarrow> (F \<in> A Co A')"
apply (simp (no_asm_simp) add: Always_includes_reachable [THEN Int_absorb2] Constrains_def Int_assoc [symmetric])
done

lemma Always_Constrains_post: "F \<in> Always(I) ==> (F \<in> A Co (I \<inter> A')) \<longleftrightarrow>(F \<in> A Co A')"
apply (simp (no_asm_simp) add: Always_includes_reachable [THEN Int_absorb2] Constrains_eq_constrains Int_assoc [symmetric])
done

lemma Always_ConstrainsI: "[| F \<in> Always(I);  F \<in> (I \<inter> A) Co A' |] ==> F \<in> A Co A'"
by (blast intro: Always_Constrains_pre [THEN iffD1])

(* [| F \<in> Always(I);  F \<in> A Co A' |] ==> F \<in> A Co (I \<inter> A') *)
lemmas Always_ConstrainsD = Always_Constrains_post [THEN iffD2]

(*The analogous proof of Always_LeadsTo_weaken doesn't terminate*)
lemma Always_Constrains_weaken:
"[|F \<in> Always(C); F \<in> A Co A'; C \<inter> B<=A; C \<inter> A'<=B'|]==>F \<in> B Co B'"
apply (rule Always_ConstrainsI)
apply (drule_tac [2] Always_ConstrainsD, simp_all)
apply (blast intro: Constrains_weaken)
done

(** Conjoining Always properties **)
lemma Always_Int_distrib: "Always(A \<inter> B) = Always(A) \<inter> Always(B)"
by (auto simp add: Always_eq_includes_reachable)

(* the premise i \<in> I is need since \<Inter>is formally not defined for I=0 *)
lemma Always_INT_distrib: "i \<in> I==>Always(\<Inter>i \<in> I. A(i)) = (\<Inter>i \<in> I. Always(A(i)))"
apply (rule equalityI)
apply (auto simp add: Inter_iff Always_eq_includes_reachable)
done

lemma Always_Int_I: "[| F \<in> Always(A);  F \<in> Always(B) |] ==> F \<in> Always(A \<inter> B)"
apply (simp (no_asm_simp) add: Always_Int_distrib)
done

(*Allows a kind of "implication introduction"*)
lemma Always_Diff_Un_eq: "[| F \<in> Always(A) |] ==> (F \<in> Always(C-A \<union> B)) \<longleftrightarrow> (F \<in> Always(B))"
by (auto simp add: Always_eq_includes_reachable)

(*Delete the nearest invariance assumption (which will be the second one
  used by Always_Int_I) *)
lemmas Always_thin = thin_rl [of "F \<in> Always(A)"]

(*To allow expansion of the program's definition when appropriate*)
named_theorems program "program definitions"

ML
\<open>
(*Combines two invariance ASSUMPTIONS into one.  USEFUL??*)
fun Always_Int_tac ctxt =
  dresolve_tac ctxt @{thms Always_Int_I} THEN'
  assume_tac ctxt THEN'
  eresolve_tac ctxt @{thms Always_thin};

(*Combines a list of invariance THEOREMS into one.*)
val Always_Int_rule = foldr1 (fn (th1,th2) => [th1,th2] MRS @{thm Always_Int_I});

(*proves "co" properties when the program is specified*)

fun constrains_tac ctxt =
   SELECT_GOAL
      (EVERY [REPEAT (Always_Int_tac ctxt 1),
              REPEAT (eresolve_tac ctxt @{thms Always_ConstrainsI} 1
                      ORELSE
                      resolve_tac ctxt [@{thm StableI}, @{thm stableI},
                                   @{thm constrains_imp_Constrains}] 1),
              resolve_tac ctxt @{thms constrainsI} 1,
              (* Three subgoals *)
              rewrite_goal_tac ctxt [@{thm st_set_def}] 3,
              REPEAT (force_tac ctxt 2),
              full_simp_tac (ctxt addsimps (Named_Theorems.get ctxt @{named_theorems program})) 1,
              ALLGOALS (clarify_tac ctxt),
              REPEAT (FIRSTGOAL (eresolve_tac ctxt @{thms disjE})),
              ALLGOALS (clarify_tac ctxt),
              REPEAT (FIRSTGOAL (eresolve_tac ctxt @{thms disjE})),
              ALLGOALS (clarify_tac ctxt),
              ALLGOALS (asm_full_simp_tac ctxt),
              ALLGOALS (clarify_tac ctxt)]);

(*For proving invariants*)
fun always_tac ctxt i =
  resolve_tac ctxt @{thms AlwaysI} i THEN
  force_tac ctxt i
  THEN constrains_tac ctxt i;
\<close>

method_setup safety = \<open>
  Scan.succeed (SIMPLE_METHOD' o constrains_tac)\<close>
  "for proving safety properties"

method_setup always = \<open>
  Scan.succeed (SIMPLE_METHOD' o always_tac)\<close>
  "for proving invariants"

end


theory Defs
  imports "HOL-Library.Extended_Real"
begin

type_synonym val = "ereal option"

datatype bound = NegInf ("\<infinity>\<^sup>-") | PosInf ("\<infinity>\<^sup>+") | NaN | Real

lemma UNIV_bound: "UNIV = {\<infinity>\<^sup>-,\<infinity>\<^sup>+,NaN,Real}"
  by (smt (verit, best) UNIV_eq_I bound.exhaust insert_iff)

instantiation bound :: enum
begin

definition "enum_bound = [\<infinity>\<^sup>-,\<infinity>\<^sup>+,NaN,Real]"
definition "enum_all_bound P \<equiv> P \<infinity>\<^sup>- \<and> P \<infinity>\<^sup>+ \<and> P NaN \<and> P Real"
definition "enum_ex_bound P \<equiv> P \<infinity>\<^sup>- \<or> P \<infinity>\<^sup>+ \<or> P NaN \<or> P Real"

instance
  by standard (auto simp: enum_bound_def enum_all_bound_def enum_ex_bound_def UNIV_bound)

end

datatype bounds = B "bound set"

fun \<gamma>_bound :: "bound \<Rightarrow> val set" where
"\<gamma>_bound \<infinity>\<^sup>- = {Some (- \<infinity>)}" |
"\<gamma>_bound \<infinity>\<^sup>+ = {Some \<infinity>}" |
"\<gamma>_bound NaN = {None}" |
"\<gamma>_bound Real = {Some r|r. r\<in>\<real>}"

fun \<gamma>_bounds :: "bounds \<Rightarrow> val set" where
"\<gamma>_bounds (B bnds) = \<Union> (\<gamma>_bound ` bnds)"

fun num_bound :: "ereal \<Rightarrow> bound" where
  "num_bound PInfty = \<infinity>\<^sup>+" |
  "num_bound MInfty = \<infinity>\<^sup>-" |
  "num_bound (ereal r) = Real"

definition num_bounds :: "ereal \<Rightarrow> bounds" where
"num_bounds v = B {num_bound v}"

fun plus_bound :: "bound \<Rightarrow> bound \<Rightarrow> bound" where
"plus_bound NaN _ = NaN" |
"plus_bound _ NaN = NaN" |
"plus_bound \<infinity>\<^sup>- \<infinity>\<^sup>+ = NaN" |
"plus_bound \<infinity>\<^sup>+ \<infinity>\<^sup>- = NaN" |
"plus_bound \<infinity>\<^sup>- _ = \<infinity>\<^sup>-" |
"plus_bound _ \<infinity>\<^sup>- = \<infinity>\<^sup>-" |
"plus_bound _ \<infinity>\<^sup>+ = \<infinity>\<^sup>+" |
"plus_bound \<infinity>\<^sup>+ _ = \<infinity>\<^sup>+" |
"plus_bound Real Real = Real"

fun plus_bounds :: "bounds \<Rightarrow> bounds \<Rightarrow> bounds" where
  "plus_bounds (B X) (B Y) = B {plus_bound a b | a b. a \<in> X \<and> b \<in> Y}"

lemma minfty_bound[simp]: "Some (- \<infinity>) \<in> \<gamma>_bound bd \<longleftrightarrow> bd = \<infinity>\<^sup>-"
  by (cases bd; auto)

lemma pinfty_bound[simp]: "Some (\<infinity>) \<in> \<gamma>_bound bd \<longleftrightarrow> bd = \<infinity>\<^sup>+"
  by (cases bd; auto)

lemma NaN_bound[simp]: "None \<in> \<gamma>_bound bd \<longleftrightarrow> bd = NaN"
  by (cases bd; auto)

lemma Real_bound[simp]: "Some (ereal r) \<in> \<gamma>_bound bd \<longleftrightarrow> bd = Real"
  by (cases bd; auto simp: Reals_def)

consts inv_plus' :: "bounds \<Rightarrow> bounds \<Rightarrow> bounds \<Rightarrow> (bounds * bounds)"

consts inv_less' :: "bool option \<Rightarrow> bounds \<Rightarrow> bounds \<Rightarrow> (bounds * bounds)"

end


theory Ailamazyan_Code
  imports "HOL-Library.Code_Target_Nat" "Containers.Containers" Ailamazyan
begin

(* Convert database to fo_intp *)

definition insert_db :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b set) mapping \<Rightarrow> ('a, 'b set) mapping" where
  "insert_db k v m = (case Mapping.lookup m k of None \<Rightarrow>
    Mapping.update k ({v}) m
  | Some vs \<Rightarrow> Mapping.update k (({v} \<union> vs)) m)"

fun convert_db_rec :: "('a \<times> 'c list) list \<Rightarrow> (('a \<times> nat), 'c list set) mapping \<Rightarrow>
  (('a \<times> nat), 'c list set) mapping" where
  "convert_db_rec [] m = m"
| "convert_db_rec ((r, ts) # ktss) m = convert_db_rec ktss (insert_db (r, length ts) ts m)"

lemma convert_db_rec_mono: "Mapping.lookup m (r, n) = Some tss \<Longrightarrow>
  \<exists>tss'. Mapping.lookup (convert_db_rec ktss m) (r, n) = Some tss' \<and> tss \<subseteq> tss'"
  apply (induction ktss m arbitrary: tss rule: convert_db_rec.induct)
   apply (auto simp: insert_db_def fun_upd_def Mapping.lookup_update' split: option.splits if_splits)
   apply (metis option.discI)
  apply (smt option.inject order_trans subset_insertI)
  done

lemma convert_db_rec_sound: "(r, ts) \<in> set ktss \<Longrightarrow>
  \<exists>tss. Mapping.lookup (convert_db_rec ktss m) (r, length ts) = Some tss \<and> ts \<in> tss"
proof (induction ktss m rule: convert_db_rec.induct)
  case (2 r ts ktss m)
  obtain tss where
    "Mapping.lookup (convert_db_rec ktss (insert_db (r, length ts) ts m)) (r, length ts) = Some tss"
    "ts \<in> tss"
    using convert_db_rec_mono[of "insert_db (r, length ts) ts m" r "length ts" _ ktss]
    by atomize_elim (auto simp: insert_db_def Mapping.lookup_update' split: option.splits)+
  then show ?case
    using 2
    by auto
qed auto

lemma convert_db_rec_complete: "Mapping.lookup (convert_db_rec ktss m) (r, n) = Some tss' \<Longrightarrow>
  ts \<in> tss' \<Longrightarrow>
  (length ts = n \<and> (r, ts) \<in> set ktss) \<or> (\<exists>tss. Mapping.lookup m (r, n) = Some tss \<and> ts \<in> tss)"
  by (induction ktss m rule: convert_db_rec.induct)
     (auto simp: insert_db_def Mapping.lookup_update' split: option.splits if_splits)

definition convert_db :: "('a \<times> 'c list) list \<Rightarrow> ('c table, 'a) fo_intp" where
  "convert_db ktss = (let m = convert_db_rec ktss Mapping.empty in
    (\<lambda>x. case Mapping.lookup m x of None \<Rightarrow> {} | Some v \<Rightarrow> v))"

lemma convert_db_correct: "(ts \<in> convert_db ktss (r, n) \<longrightarrow> n = length ts) \<and>
  ((r, ts) \<in> set ktss \<longleftrightarrow> ts \<in> convert_db ktss (r, length ts))"
  by (auto simp: convert_db_def dest!: convert_db_rec_sound[of _ _ _ Mapping.empty]
      split: option.splits)
     (metis Mapping.lookup_empty convert_db_rec_complete option.distinct(1))+

(* Code setup *)

lemma Inl_vimage_set_code[code_unfold]: "Inl -` set as = set (List.map_filter (case_sum Some Map.empty) as)"
  by (induction as) (auto simp: List.map_filter_simps split: option.splits sum.splits)

lemma Inr_vimage_set_code[code_unfold]: "Inr -` set as = set (List.map_filter (case_sum Map.empty Some) as)"
  by (induction as) (auto simp: List.map_filter_simps split: option.splits sum.splits)

lemma Inl_vimage_code: "Inl -` as = projl ` {x \<in> as. isl x}"
  by (force simp: vimage_def)

lemmas ad_pred_code[code] = ad_terms.simps[unfolded Inl_vimage_code]
lemmas fo_wf_code[code] = fo_wf.simps[unfolded Inl_vimage_code]

(* Monomorphise *)

definition empty_J :: "((nat, nat) fo_t, String.literal) fo_intp" where
  "empty_J = (\<lambda>(_, n). eval_pred (map Var [0..<n]) {})"

definition eval_fin_nat :: "(nat, String.literal) fo_fmla \<Rightarrow> (nat table, String.literal) fo_intp \<Rightarrow> nat eval_res" where
  "eval_fin_nat \<phi> I = eval \<phi> I"

definition sat_fin_nat :: "(nat, String.literal) fo_fmla \<Rightarrow> (nat table, String.literal) fo_intp \<Rightarrow> nat val \<Rightarrow> bool" where
  "sat_fin_nat \<phi> I = sat \<phi> I"

definition convert_nat_db :: "(String.literal \<times> nat list) list \<Rightarrow>
  (nat table, String.literal) fo_intp" where
  "convert_nat_db = convert_db"

definition rbt_nat_fold :: "_ \<Rightarrow> nat set_rbt \<Rightarrow> _ \<Rightarrow> _" where
  "rbt_nat_fold = RBT_Set2.fold"

definition rbt_nat_list_fold :: "_ \<Rightarrow> (nat list) set_rbt \<Rightarrow> _ \<Rightarrow> _" where
  "rbt_nat_list_fold = RBT_Set2.fold"

definition rbt_sum_list_fold :: "_ \<Rightarrow> ((nat + nat) list) set_rbt \<Rightarrow> _ \<Rightarrow> _" where
  "rbt_sum_list_fold = RBT_Set2.fold"

export_code eval_fin_nat sat_fin_nat fv_fo_fmla_list convert_nat_db rbt_nat_fold rbt_nat_list_fold
  rbt_sum_list_fold Const Conj Inl Fin nat_of_integer integer_of_nat RBT_set
  in OCaml module_name Eval_FO file_prefix verified

(* Examples *)

definition \<phi> :: "(nat, String.literal) fo_fmla" where
  "\<phi> \<equiv> Exists 0 (Conj (FO.Eqa (Var 0) (Const 2)) (FO.Eqa (Var 0) (Var 1)))"

value "eval_fin_nat \<phi> (convert_nat_db [])"

value "sat_fin_nat \<phi> (convert_nat_db []) (\<lambda>_. 0)"
value "sat_fin_nat \<phi> (convert_nat_db []) (\<lambda>_. 2)"

definition \<psi> :: "(nat, String.literal) fo_fmla" where
  "\<psi> \<equiv> Forall 2 (Disj (FO.Eqa (Var 2) (Const 42))
       (Exists 1 (Conj (FO.Pred (String.implode ''P'') [Var 0, Var 1])
                 (Neg (FO.Pred (String.implode ''Q'') [Var 1, Var 2])))))"

value "eval_fin_nat \<psi> (convert_nat_db
   [(String.implode ''P'', [1, 20]),
    (String.implode ''P'', [9, 20]),
    (String.implode ''P'', [2, 30]),
    (String.implode ''P'', [3, 31]),
    (String.implode ''P'', [4, 32]),
    (String.implode ''P'', [5, 30]),
    (String.implode ''P'', [6, 30]),
    (String.implode ''P'', [7, 30]),
    (String.implode ''Q'', [20, 42]),
    (String.implode ''Q'', [30, 43])])"

end


theory Hnr_Recursion
  imports Hnr_Base Hnr_Frame Norm
begin

lemma [simp]: "fun_lub lub {} = (\<lambda>_. lub {})"
  by (simp add: fun_lub_def)

lemma admissible_fun:
    fixes le:: "'a \<Rightarrow> 'a \<Rightarrow> bool" and Q :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
    assumes adm: "\<And>x. ccpo.admissible lub le (Q x)"
    shows "ccpo.admissible  (fun_lub lub) (fun_ord le) (\<lambda>f. \<forall>x. Q x (f x))"
  proof (rule ccpo.admissibleI)
    fix A :: "('b \<Rightarrow> 'a) set"
    assume Q: "\<forall>f\<in>A. \<forall>x. Q x (f x)"
    assume ch: "Complete_Partial_Order.chain (fun_ord le) A"
    assume "A \<noteq> {}"
    hence non_empty: "\<And>a. {y. \<exists>f\<in>A. y = f a} \<noteq> {}" by auto
    show "\<forall>x. Q x (fun_lub lub A x)"
      unfolding fun_lub_def
      by (rule allI, rule ccpo.admissibleD[OF adm chain_fun[OF ch] non_empty])
        (auto simp: Q)
  qed

lemma admissible_flat: "ccpo.admissible (flat_lub b) (flat_ord b) (P)"
  apply (rule ccpo.admissibleI)
  by (metis all_not_in_conv flat_interpretation flat_lub_in_chain flat_ord_def partial_function_definitions.lub_upper)

lemma hnr_recursion':
  assumes
    mono_option: "\<And>x. mono_option (\<lambda>r. f r x)"
  and
    step: "\<And>r ri x xi F. (\<And>x' xi' F'. hnr (\<Gamma> F' x' xi') (ri xi') (\<Gamma>' F' x' xi') (r x'))
        \<Longrightarrow> hnr (\<Gamma> F x xi) (fi ri xi) (\<Gamma>' F x xi) (f r x)"
  and
    mono_heap: "\<And>x. mono_Heap (\<lambda>r. fi r x)"
  shows
    "hnr (\<Gamma> F x xi) (heap.fixp_fun fi xi) (\<Gamma>' F x xi) (option.fixp_fun f x)"
proof(induction arbitrary: x xi F rule: ccpo.fixp_induct[OF option.ccpo])
  case 1
  then show ?case
    apply(rule admissible_fun)
    by(rule admissible_flat)
next
  case 2
  then show ?case
    using mono_option
    by(simp add: monotone_def fun_ord_def)
next
  case 3
  then show ?case
    by simp
next
  case 4
  then show ?case
    apply(subst heap.mono_body_fixp[OF mono_heap])
    apply(rule step).
qed

lemma hnr_recursion:
  assumes
    mono_option: "\<And>x. mono_option (\<lambda>r. f r x)"
  and
    step: "\<And>r ri x xi F. (\<And>x' xi' F'. hnr (\<Gamma> F' x' xi') (ri xi') (\<Gamma>' F' x' xi') (r x'))
        \<Longrightarrow> hnr (\<Gamma> F x xi) (fi ri xi) (\<Gamma>'' F x xi) (f r x)"
  and
    norm: "\<And>F x xi r ri. Norm (\<Gamma>'' F x xi r ri) (\<Gamma>' F x xi r ri)"
  and
    mono_heap: "\<And>x. mono_Heap (\<lambda>r. fi r x)"
  shows
    "hnr (\<Gamma> F x xi) (heap.fixp_fun fi xi) (\<Gamma>' F x xi) (option.fixp_fun f x)"
  apply(rule hnr_recursion'[OF mono_option _ mono_heap])
  apply(rule hnr_post_cons)
  apply(rule step, assumption)
  by(rule norm[unfolded Norm_def])

lemma tuple_selector_refl: "fst (a, b) = fst (a, b)" "snd (a, b) = snd (a, b)"
  by simp_all

method hnr_recursion
  for \<Gamma>::"'F \<Rightarrow> 'x \<Rightarrow> 'xi \<Rightarrow> assn" and \<Gamma>'::"'F \<Rightarrow> 'x \<Rightarrow> 'xi \<Rightarrow> 'r \<Rightarrow> 'ri \<Rightarrow> assn"
  methods frame_match_atom =
  rule hnr_recursion[where \<Gamma>=\<Gamma> and \<Gamma>'=\<Gamma>', framed],
  ((subst tuple_selector_refl, simp only: fst_conv snd_conv)+)?,
  hnr_frame_inference frame_match_atom

method_setup partial_function_mono_setup =
  \<open>Scan.succeed (SIMPLE_METHOD' o Partial_Function.mono_tac)\<close>

method partial_function_mono = partial_function_mono_setup; fail

method hnr_solve_recursive_call methods frame_match_atom =
  rule hnr_frame[rotated], assumption, hnr_frame_inference frame_match_atom

end


theory EventSystemScheduler
  imports EventSystemWatchdog
begin

text \<open>This file contains verification of a simplified scheduler that
  does not allow switching between time tables.

  First, we verify the implementation of the scheduler, then combine
  with the implementation of the watchdog using the event system.
\<close>

subsection \<open>Abstract scheduler\<close>

record astate_scheduler =
  as_ttbl :: time_table
  window_id :: nat

definition next_partition :: "astate_scheduler \<Rightarrow> partition" where
  "next_partition st = fst (as_ttbl st ! ((window_id st + 1) mod length (as_ttbl st)))"

definition next_watchdog_pos :: "astate_scheduler \<Rightarrow> nat" where
  "next_watchdog_pos st = snd (as_ttbl st ! ((window_id st + 1) mod length (as_ttbl st)))"

definition spec_dispatch :: "astate_scheduler \<Rightarrow> astate_scheduler \<times> event list" where
  "spec_dispatch st =
    (\<lparr>as_ttbl = as_ttbl st,
      window_id = (window_id st + 1) mod length (as_ttbl st)\<rparr>,
     [PARTITION (next_partition st),
      WATCHDOG_ADD (0, next_watchdog_pos st)])"

subsection \<open>Concrete implementation of scheduler\<close>

record cstate_scheduler =
  cs_ttbl :: time_table
  window_time :: nat
  cur_window :: nat
  cur_frame_time :: nat

definition get_partition :: "nat \<Rightarrow> (cstate_scheduler, event, nat) event_monad" where
  "get_partition wid = get \<bind> (\<lambda>st. return (fst ((cs_ttbl st) ! wid)))"

definition get_duration :: "nat \<Rightarrow> (cstate_scheduler, event, nat) event_monad" where
  "get_duration wid = get \<bind> (\<lambda>st. return (snd ((cs_ttbl st) ! wid)))"

definition get_total_frame_time :: "(cstate_scheduler, event, nat) event_monad" where
  "get_total_frame_time = get \<bind> (\<lambda>st. return (frame_length (cs_ttbl st)))"

definition get_window_time :: "(cstate_scheduler, event, nat) event_monad" where
  "get_window_time = get \<bind> (\<lambda>st. return (window_time st))"

definition get_cur_window :: "(cstate_scheduler, event, nat) event_monad" where
  "get_cur_window = get \<bind> (\<lambda>st. return (cur_window st))"

definition get_cur_frame_time :: "(cstate_scheduler, event, nat) event_monad" where
  "get_cur_frame_time = get \<bind> (\<lambda>st. return (cur_frame_time st))"

definition set_window_time :: "nat \<Rightarrow> (cstate_scheduler, event, unit) event_monad" where
  "set_window_time t = modify (window_time_update (\<lambda>_. t))"

definition set_cur_window :: "nat \<Rightarrow> (cstate_scheduler, event, unit) event_monad" where
  "set_cur_window t = modify (cur_window_update (\<lambda>_. t))"

definition set_cur_frame_time :: "nat \<Rightarrow> (cstate_scheduler, event, unit) event_monad" where
  "set_cur_frame_time t = modify (cur_frame_time_update (\<lambda>_. t))"

lemma get_partition_rule [wp]:
  "\<lbrace> \<lambda>s. P (fst (cs_ttbl s ! wid)) s \<rbrace>
    get_partition wid
   \<lbrace> P \<rbrace>!"
  unfolding get_partition_def by wp

lemma get_duration_rule [wp]:
  "\<lbrace> \<lambda>s. P (snd (cs_ttbl s ! wid)) s \<rbrace>
    get_duration wid
   \<lbrace> P \<rbrace>!"
  unfolding get_duration_def by wp

lemma get_total_frame_time_rule [wp]:
  "\<lbrace> \<lambda>s. P (frame_length (cs_ttbl s)) s \<rbrace>
    get_total_frame_time
   \<lbrace> P \<rbrace>!"
  unfolding get_total_frame_time_def by wp

lemma get_window_time_rule [wp]:
  "\<lbrace> \<lambda>s. P (window_time s) s \<rbrace>
    get_window_time
   \<lbrace> P \<rbrace>!"
  unfolding get_window_time_def by wp

lemma get_cur_window_rule [wp]:
  "\<lbrace> \<lambda>s. P (cur_window s) s \<rbrace>
    get_cur_window
   \<lbrace> P \<rbrace>!"
  unfolding get_cur_window_def by wp

lemma get_cur_frame_time_rule [wp]:
  "\<lbrace> \<lambda>s. P (cur_frame_time s) s \<rbrace>
    get_cur_frame_time
   \<lbrace> P \<rbrace>!"
  unfolding get_cur_frame_time_def by wp

lemma set_window_time_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>window_time := wtime\<rparr>) \<rbrace>
     set_window_time wtime
   \<lbrace> \<lambda>_ s. P s \<rbrace>!"
  unfolding set_window_time_def by wp

lemma set_cur_window_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>cur_window := window\<rparr>) \<rbrace>
     set_cur_window window
   \<lbrace> \<lambda>_ s. P s \<rbrace>!"
  unfolding set_cur_window_def by wp

lemma set_cur_frame_time_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>cur_frame_time := ftime\<rparr>) \<rbrace>
     set_cur_frame_time ftime
   \<lbrace> \<lambda>_ s. P s \<rbrace>!"
  unfolding set_cur_frame_time_def by wp

definition update_cur_frame_time :: "(cstate_scheduler, event, unit) event_monad" where
  "update_cur_frame_time =
    get_window_time \<bind> (\<lambda>w_time.
    get_cur_frame_time \<bind> (\<lambda>f_time.
    set_cur_frame_time (f_time + w_time)))"

lemma update_cur_frame_time_rule [wp]:
  "\<lbrace> \<lambda>s. P (s\<lparr>cur_frame_time := cur_frame_time s + window_time s\<rparr>) \<rbrace>
     update_cur_frame_time
   \<lbrace> \<lambda>_ s. P s \<rbrace>!"
  unfolding update_cur_frame_time_def by wp

definition dispatch :: "(cstate_scheduler, event, unit) event_monad" where
  "dispatch =
     update_cur_frame_time \<bind> (\<lambda>_.
     get_cur_frame_time \<bind> (\<lambda>f_time.
     get_total_frame_time \<bind> (\<lambda>total_time.
     if f_time = total_time then
       get_partition 0 \<bind> (\<lambda>partition.
       get_duration 0 \<bind> (\<lambda>duration.
       set_window_time duration \<bind> (\<lambda>_.
       set_cur_frame_time 0 \<bind> (\<lambda>_.
       set_cur_window 0 \<bind> (\<lambda>_.
       signal (PARTITION partition) \<bind> (\<lambda>_.
       signal (WATCHDOG_ADD (0, duration))))))))
     else
       get_cur_window \<bind> (\<lambda>cur_window.
       get_partition (cur_window + 1) \<bind> (\<lambda>partition.
       get_duration (cur_window + 1) \<bind> (\<lambda>duration.
       set_window_time duration \<bind> (\<lambda>_.
       set_cur_window (cur_window + 1) \<bind> (\<lambda>_.
       signal (PARTITION partition) \<bind> (\<lambda>_.
       signal (WATCHDOG_ADD (0, duration)))))))))))"

subsection \<open>Refinement relation for scheduler\<close>

definition rel :: "astate_scheduler \<Rightarrow> cstate_scheduler \<Rightarrow> bool" where
  "rel as cs \<longleftrightarrow> as_ttbl as = cs_ttbl cs \<and>
                 window_id as = cur_window cs"

definition cinv :: "cstate_scheduler \<Rightarrow> bool" where
  "cinv cs \<longleftrightarrow> is_valid_time_table (cs_ttbl cs) \<and>
               cur_window cs < length (cs_ttbl cs) \<and>
               window_time cs = snd (cs_ttbl cs ! cur_window cs) \<and>
               cur_frame_time cs = frame_time_to_window (cs_ttbl cs) (cur_window cs)"

lemma dispatch_rule':
  "\<lbrace> \<lambda>cs es. rel as cs \<and> cinv cs \<and> es = [] \<rbrace>
     dispatch
   \<lbrace> \<lambda>_ cs es. rel (fst (spec_dispatch as)) cs \<and> cinv cs \<and> es = snd (spec_dispatch as) \<rbrace>!"
proof -
  have a: "Suc (cur_window cs) mod length (cs_ttbl cs) = 0"
    if "cinv cs" "cur_frame_time cs + window_time cs = frame_length (cs_ttbl cs)" for cs
  proof -
    have a1: "frame_time_to_window (cs_ttbl cs) (Suc (cur_window cs)) = frame_length (cs_ttbl cs)"
      using that(1,2) unfolding cinv_def
      by (simp add: frame_time_to_window_next)
    have a2: "cur_window cs < length (cs_ttbl cs)"
      using that(1) unfolding cinv_def by auto
    have a3: "Suc (cur_window cs) = length (cs_ttbl cs)"
      by (metis Suc_lessI a1 cinv_def frame_time_to_window_mono_strict frame_time_to_window_total less_not_refl that(1))
    show ?thesis
      by (simp add: a3)
  qed
  have b: "Suc (cur_window cs) < length (cs_ttbl cs)"
    if "cinv cs" "cur_frame_time cs + window_time cs \<noteq> frame_length (cs_ttbl cs)" for cs
    by (metis Suc_lessI cinv_def frame_time_to_window_next frame_time_to_window_total that)
  show ?thesis
    unfolding dispatch_def apply wp apply auto
    subgoal for cs
      apply (auto simp add: rel_def spec_dispatch_def)
      using a by auto
    subgoal for cs
      by (auto simp add: rel_def cinv_def)
    subgoal for cs
      apply (auto simp add: spec_dispatch_def next_partition_def next_watchdog_pos_def)
      using a by (auto simp add: rel_def)
    subgoal for cs
      apply (auto simp add: rel_def spec_dispatch_def)
      using b by auto
    subgoal for cs
      by (auto simp add: cinv_def b frame_time_to_window_next)
    subgoal for cs
      apply (auto simp add: spec_dispatch_def next_partition_def next_watchdog_pos_def)
      using b rel_def by auto
    done
qed

definition rel_scheduler :: "astate_scheduler \<Rightarrow> cstate_scheduler \<Rightarrow> bool" where
  "rel_scheduler as cs \<longleftrightarrow> rel as cs \<and> cinv cs"

lemma dispatch_rule:
  "\<lbrace> \<lambda>cs es. rel_scheduler as cs \<and> nil\<^sub>e es \<rbrace>
     dispatch
   \<lbrace> \<lambda>_ cs es. rel_scheduler (fst (spec_dispatch as)) cs \<and> es = snd (spec_dispatch as) \<rbrace>!"
  apply (rule validNF_weaken_pre)
  apply (rule validNF_strengthen_post)
  apply (rule dispatch_rule')
  by (auto simp add: rel_scheduler_def nil_event_def)

subsection \<open>Event system\<close>

fun system :: "(event, cstate_scheduler \<times> watchdog_chain) event_system" where
  "system (DISPATCH 0) = Some (apply_fst dispatch)"
| "system (WATCHDOG_ADD (ev, n)) = Some (apply_snd (watchdog_add_impl ev n))"
| "system WATCHDOG_TICK = Some (apply_snd watchdog_tick_impl)"
| "system _ = None"

lemma system_eval:
  "system (PARTITION n) = None"
  "system (DISPATCH 0) = Some (apply_fst dispatch)"
  "ev > 0 \<Longrightarrow> system (DISPATCH ev) = None"
  "system (WATCHDOG_ADD (ev, n)) = Some (apply_snd (watchdog_add_impl ev n))"
  "system WATCHDOG_TICK = Some (apply_snd watchdog_tick_impl)"
  unfolding system.simps apply auto
  apply (cases ev) by auto

fun rel_total :: "astate_scheduler \<times> astate_watchdog \<Rightarrow> cstate_scheduler \<times> watchdog_chain \<Rightarrow> bool" where
  "rel_total (as, aw) p \<longleftrightarrow> rel_scheduler as (fst p) \<and> rel_watchdog aw (snd p)"
declare rel_total.simps[simp del]

theorem sValidNF_watchdog_add:
  assumes "w0 ev = None"
    and "n > 0"
  shows
    "sValidNF system
      (\<lambda>p es. rel_total (s0, w0) p \<and> nil\<^sub>e es)
      (WATCHDOG_ADD (ev, n))
      (\<lambda>p es. rel_total (s0, w0(ev \<mapsto> n)) p \<and> nil\<^sub>e es)"
  apply (rule sValidNF_Some)
    apply (rule system_eval)
  apply (simp add: rel_total.simps)
   apply (rule validNF_apply_snd)
   apply (rule watchdog_add_rule)
    apply (rule assms(2)) apply (rule assms(1))
  unfolding nil_event_def apply auto
  apply (rule sValidNF_list_weaken_pre)
   prefer 2 apply (rule sValidNF_list_null)
  by (auto simp add: rel_total.simps)

theorem sValidNF_watchdog_add':
  assumes "w0 ev = None"
    and "n > 0"
  shows
    "sValidNF system
      (\<lambda>p es. rel_total (s0, w0) p \<and> Q es)
      (WATCHDOG_ADD (ev, n))
      (\<lambda>p es. rel_total (s0, w0(ev \<mapsto> n)) p \<and> Q es)"
  apply (rule sValidNF_frame_nil)
  apply (rule sValidNF_watchdog_add)
  using assms by auto

lemma next_watchdog_pos_positive:
  "is_valid_time_table (as_ttbl as) \<Longrightarrow> next_watchdog_pos as > 0"
  unfolding next_watchdog_pos_def
  apply auto
  using Suc_lessD mod_less_divisor window_time_pos' by blast

theorem sValidNF_dispatch':
  assumes "w0 0 = None"
  shows
    "sValidNF system
      (\<lambda>p es. is_valid_time_table (as_ttbl s0) \<and> rel_total (s0, w0) p \<and> nil\<^sub>e es)
      (DISPATCH 0)
      (\<lambda>p es. rel_total (fst (spec_dispatch s0), w0(0 \<mapsto> next_watchdog_pos s0)) p \<and>
              es = [PARTITION (next_partition s0)])"
proof -
  have snd_dispatch:
    "snd (spec_dispatch s0) = [PARTITION (next_partition s0), WATCHDOG_ADD (0, next_watchdog_pos s0)]"
    by (auto simp add: spec_dispatch_def)
  show ?thesis
    apply (subst sValidNF_conj_pre) apply auto
    apply (rule sValidNF_Some)
      apply (rule system_eval)
  apply (rule validNF_weaken_pre[where Q="\<lambda>p es. (rel_scheduler s0 (fst p) \<and> nil\<^sub>e es) \<and> rel_watchdog w0 (snd p)"])
    apply (rule validNF_apply_fst)
    apply (rule dispatch_rule)
   apply (auto simp add: rel_total.simps)[1]
  subgoal for p es
    apply (auto simp add: snd_dispatch)
    apply (rule sValidNF_list_cons)
     prefer 2
     apply (rule sValidNF_list_single)
     apply (rule sValidNF_watchdog_add')
      apply (rule assms(1)) apply (rule next_watchdog_pos_positive) apply auto[1]
    apply (rule sValidNF_weaken_pre)
     prefer 2 apply (rule sValidNF_None)
     apply (rule system_eval)
    by (auto simp add: nil_event_def rel_total.simps)
  done
qed

theorem sValidNF_dispatch:
  assumes "w0 0 = None"
  shows
    "sValidNF system
      (\<lambda>p es. rel_total (s0, w0) p \<and> nil\<^sub>e es)
      (DISPATCH 0)
      (\<lambda>p es. rel_total (fst (spec_dispatch s0), w0(0 \<mapsto> next_watchdog_pos s0)) p \<and>
              es = [PARTITION (next_partition s0)])"
  apply (rule sValidNF_weaken_pre)
   prefer 2 apply (rule sValidNF_dispatch')
  apply (rule assms) by (auto simp add: rel_total.simps rel_scheduler_def cinv_def rel_def)

fun spec_watchdog_tick_system ::
  "astate_scheduler \<times> astate_watchdog \<Rightarrow> (astate_scheduler \<times> astate_watchdog) \<times> event set" where
  "spec_watchdog_tick_system (s0, w0) =
   (if w0 0 = Some 1 then
      ((fst (spec_dispatch s0),
        (spec_watchdog_tick w0)(0 \<mapsto> next_watchdog_pos s0)),
       (DISPATCH ` spec_watchdog_tick_ev w0 - {DISPATCH 0} \<union> {PARTITION (next_partition s0)}))
    else
      ((s0, spec_watchdog_tick w0),
       DISPATCH ` spec_watchdog_tick_ev w0))"
declare spec_watchdog_tick_system.simps [simp del]

theorem sValidNF_watchdog_tick:
  "sValidNF system
    (\<lambda>p es. rel_total (s0, w0) p \<and> nil\<^sub>e es)
    WATCHDOG_TICK
    (\<lambda>p es. rel_total (fst (spec_watchdog_tick_system (s0, w0))) p \<and>
            distinct es \<and>
            set es = snd (spec_watchdog_tick_system (s0, w0)))"
proof -
  have pre1:
    "DISPATCH 0 \<notin> set es \<Longrightarrow>
     \<forall>e\<in>set es. \<exists>i. e = DISPATCH i \<Longrightarrow>
     sValidNF_list system (\<lambda>s' es'. P s' \<and> es' = es0) es (\<lambda>s' es'. P s' \<and> es' = es0 @ es)"
    for P es es0
    apply (rule sValidNF_list_weaken_pre)
    prefer 2 apply (rule sValidNF_list_all_None)
    apply (auto simp add: nil_event_def)
    apply (induction es) apply auto
    using system_eval(3) by fastforce
  have pre2:
    "DISPATCH 0 \<in> set es \<Longrightarrow>
     distinct es \<Longrightarrow>
     \<forall>e\<in>set es. \<exists>i. e = DISPATCH i \<Longrightarrow>
     w0 0 = None \<Longrightarrow>
     rel_scheduler s0 cs0 \<Longrightarrow>
     rel_watchdog w0 cw0 \<Longrightarrow>
     sValidNF_list system (\<lambda>s' es'. s' = (cs0, cw0) \<and> nil\<^sub>e es') es
       (\<lambda>s' es'. rel_total (fst (spec_dispatch s0), w0(0 \<mapsto> next_watchdog_pos s0)) s' \<and>
                 distinct es' \<and> set es' = set es - {DISPATCH 0} \<union> {PARTITION (next_partition s0)})"
    for cs0 cw0 s0 w0 es
  proof (induction es)
    case Nil
    then show ?case by auto
  next
    case (Cons e es)
    show ?case
    proof (cases "e = DISPATCH 0")
      case True
      have a1: "DISPATCH 0 \<notin> set es"
        using Cons(2,3) True by auto
      have a2: "\<forall>e\<in>set es. \<exists>i. e = DISPATCH i"
        using Cons(4) by auto
      let ?s0'="fst (spec_dispatch s0)"
      let ?w0'="w0(0 \<mapsto> next_watchdog_pos s0)"
      let ?es0="[PARTITION (next_partition s0)]"
      have a3: "sValidNF_list system (\<lambda>s' es'. rel_total (?s0', ?w0') s' \<and> es' = ?es0) es
                  (\<lambda>s' es'. rel_total (?s0', ?w0') s' \<and> es' = ?es0 @ es)"
        using pre1[OF a1 a2] by blast
      have a4: "distinct ([PARTITION (next_partition s0)] @ es)"
        using Cons(3) a2 by auto
      show ?thesis
        apply (subst True)
        apply (rule sValidNF_list_cons)
         apply (rule sValidNF_weaken_pre)
        prefer 2 apply (rule sValidNF_dispatch) apply (rule Cons(5))
          using Cons(6,7) apply (auto simp add: rel_total.simps)[1]
         apply (rule sValidNF_list_strengthen_post)
          prefer 2 apply (rule a3)
        using a1 a4 True by auto
    next
      case False
      have b1: "DISPATCH 0 \<in> set es"
        using Cons(2) False by auto
      have b2: "distinct es"
        using Cons(3) by auto
      have b3: "\<forall>e\<in>set es. \<exists>i. e = DISPATCH i"
        using Cons(4) by auto
      have b4: "system e = None"
        using False Cons.prems(3) system_eval(3) by force
      have b5: "sValidNF_list system
                 (\<lambda>s' es'. s' = (cs0, cw0) \<and> nil\<^sub>e es') es
                 (\<lambda>s' es'. rel_total (fst (spec_dispatch s0), w0(0 \<mapsto> next_watchdog_pos s0)) s' \<and>
                           distinct es' \<and>
                           set es' = set es - {DISPATCH 0} \<union> {PARTITION (next_partition s0)})"
        by (rule Cons(1)[OF b1 b2 b3 Cons(5,6,7)])
      have b6: "distinct t" "set t = set (e # es) - {DISPATCH 0} \<union> {PARTITION (next_partition s0)}"
        if assm_b6: "((\<lambda>t. t = [e]) ^\<^sub>e (\<lambda>es'. distinct es' \<and> set es' = set es - {DISPATCH 0} \<union> {PARTITION (next_partition s0)})) t" for t
      proof -
        obtain es' where c1: "distinct es'" "set es' = set es - {DISPATCH 0} \<union> {PARTITION (next_partition s0)}" "t = [e] @ es'"
          using assm_b6 unfolding chop_event_def by auto
        have c2: "set t = insert e (set es')"
          using c1(3) by auto
        show "distinct t"
          using Cons(3,4) c1 event.distinct(9) by auto
        show "set t = set (e # es) - {DISPATCH 0} \<union> {PARTITION (next_partition s0)}"
          using False c1(2) c2 by auto
      qed
      show ?thesis
        apply (rule sValidNF_list_cons)
        apply (rule sValidNF_None_sp)
         apply (rule b4)
        apply (rule sValidNF_list_strengthen_post)
         prefer 2 apply (rule sValidNF_list_frame)
         apply (rule b5)
        using b6 by blast
    qed
  qed
  have a: "sValidNF_list system
            (\<lambda>s' es'. s' = (cs0, cw0) \<and> nil\<^sub>e es')
             es
            (\<lambda>s' es'. rel_total (fst (spec_watchdog_tick_system (s0, w0))) s' \<and>
                      distinct es' \<and>
                      set es' = snd (spec_watchdog_tick_system (s0, w0)))"
    if "rel_scheduler s0 cs0"
       "rel_watchdog (spec_watchdog_tick w0) cw0"
       "distinct es"
       "set es = DISPATCH ` spec_watchdog_tick_ev w0" for cs0 cw0 es
  proof -
    have a1: "\<forall>e\<in>set es. \<exists>i. e = DISPATCH i"
      unfolding that spec_watchdog_tick_def by auto
    show ?thesis
    proof (cases "w0 0 = Some 1")
      case True
      have b1: "DISPATCH 0 \<in> set es"
        using True spec_watchdog_tick_ev_def that by auto
      have b2: "spec_watchdog_tick w0 0 = None"
        by (auto simp add: spec_watchdog_tick_def True)
      show ?thesis
        apply (auto simp add: True spec_watchdog_tick_system.simps)
        apply (rule sValidNF_list_strengthen_post)
         prefer 2 apply (rule pre2[OF b1 that(3) a1 b2 that(1) that(2)])
        using True that by auto
    next
      case False
      have c1: "DISPATCH 0 \<notin> set es"
        using False spec_watchdog_tick_ev_def that by auto
      show ?thesis
        unfolding nil_event_def
        apply (rule sValidNF_list_strengthen_post)
         prefer 2 apply (rule pre1[OF c1 a1])
        using False that by (auto simp add: rel_total.simps spec_watchdog_tick_system.simps)
    qed
  qed
  show ?thesis
    apply (rule sValidNF_Some)
      apply (rule system_eval)
    apply (simp add: rel_total.simps)
     apply (rule validNF_apply_snd)
     apply (rule watchdog_tick_rule)
    using a by auto
qed

subsection \<open>Refinement for the combined system\<close>

record astate =
  a_ttbl :: time_table
  frame_time :: nat
  wchain :: astate_watchdog

definition spec_atick :: "astate \<Rightarrow> astate" where
  "spec_atick a =
    \<lparr>a_ttbl = a_ttbl a,
    frame_time = (frame_time a + 1) mod frame_length (a_ttbl a),
    wchain = spec_watchdog_tick (wchain a)\<rparr>"

definition spec_atick_ev :: "astate \<Rightarrow> event set" where
  "spec_atick_ev a =
    (if at_window_boundary (a_ttbl a) (frame_time a) then
       DISPATCH ` spec_watchdog_tick_ev (wchain a) \<union>
       {PARTITION (partition_at_time (a_ttbl a) ((frame_time a + 1) mod frame_length (a_ttbl a)))}
     else DISPATCH ` spec_watchdog_tick_ev (wchain a))"

fun arel :: "astate \<Rightarrow> astate_scheduler \<times> astate_watchdog \<Rightarrow> bool" where
  "arel a (as, aw) \<longleftrightarrow>
   (case aw 0 of
      None \<Rightarrow> False
    | Some wpos \<Rightarrow>
        a_ttbl a = as_ttbl as \<and>
        frame_time a = frame_time_to_window (as_ttbl as) (window_id as + 1) - wpos) \<and>
        wchain a 0 = None \<and> (\<forall>i>0. wchain a i = aw i)"
declare arel.simps [simp del]

fun ainv :: "astate_scheduler \<times> astate_watchdog \<Rightarrow> bool" where
  "ainv (as, aw) \<longleftrightarrow>
    is_valid_time_table (as_ttbl as) \<and>
    window_id as < length (as_ttbl as) \<and>
    (case aw 0 of
       None \<Rightarrow> False
     | Some wpos \<Rightarrow> wpos > 0 \<and> wpos \<le> snd (as_ttbl as ! window_id as))"
declare ainv.simps [simp del]

theorem spec_atick_refines:
  assumes "arel a (as, aw)"
    and "ainv (as, aw)"
  shows "arel (spec_atick a) (fst (spec_watchdog_tick_system (as, aw)))"
proof -
  have g1: "length (as_ttbl as) > 0"
    using assms(2) ainv.simps by auto
  have g2: "frame_length (as_ttbl as) > 0"
    using assms(2) valid_time_table_frame_length ainv.simps by auto
  have g3: "Suc (frame_length (as_ttbl as) - 1) = frame_length (as_ttbl as)"
    using g2 by auto
  have g4: "window_id as < length (as_ttbl as)"
    using assms(2) ainv.simps by auto
  have a: "Suc (frame_time_to_window (as_ttbl as) (Suc (window_id as)) - 1) mod frame_length (as_ttbl as) =
           frame_time_to_window (as_ttbl as) ((Suc (window_id as) mod length (as_ttbl as)) + 1) -
           snd (as_ttbl as ! (Suc (window_id as) mod length (as_ttbl as)))"
    if "frame_time a = frame_time_to_window (as_ttbl as) (Suc (window_id as)) - 1"
       "a_ttbl a = as_ttbl as"
  proof (cases "window_id as = length (as_ttbl as) - 1")
    case True
    have a1: "Suc (window_id as) = length (as_ttbl as)"
      using g1 True by auto
    have a2: "Suc (window_id as) mod length (as_ttbl as) = 0"
      using a1 by auto
    show ?thesis
      unfolding a1 a2 g1 g2 g3 frame_time_to_window_total
      apply (cases "as_ttbl as") by auto
  next
    case False
    have a1: "window_id as < length (as_ttbl as) - 1"
      using g1 g4 False by auto
    have a2: "frame_time_to_window (as_ttbl as) (Suc (window_id as)) > 0"
      using ainv.simps assms(2) frame_time_to_window_next window_time_pos by auto
    have a3: "Suc (frame_time_to_window (as_ttbl as) (Suc (window_id as)) - 1) =
              frame_time_to_window (as_ttbl as) (Suc (window_id as))"
      using a2 by auto
    have a4: "Suc (window_id as) mod length (as_ttbl as) = Suc (window_id as)"
      using One_nat_def a1 by auto
    have a5: "frame_time_to_window (as_ttbl as) (Suc (window_id as)) < frame_length (as_ttbl as)"
      by (metis a4 ainv.simps assms(2) frame_time_to_window_mono_strict frame_time_to_window_total g1 nat_mod_lem)
    have a6: "frame_time_to_window (as_ttbl as) (Suc (window_id as)) mod frame_length (as_ttbl as) =
              frame_time_to_window (as_ttbl as) (Suc (window_id as))"
      using a5 by auto
    show ?thesis
      unfolding g1 g2 g3 a3 a4 a6
      using a4 frame_time_to_window_next g1 nat_mod_lem by auto
  qed
  show ?thesis
  proof (cases "aw 0")
    case None
    then show ?thesis using assms arel.simps by auto
  next
    case (Some wpos)
    have b1: "wpos > 0" "wpos \<le> snd (as_ttbl as ! window_id as)"
      using assms(2) Some ainv.simps by auto
    have b2: "a_ttbl a = as_ttbl as"
      using assms(1) Some arel.simps by auto
    show ?thesis
    proof (cases "wpos = 1")
      case True
      then show ?thesis
        using assms unfolding Some True spec_watchdog_tick_system.simps spec_atick_def spec_dispatch_def next_watchdog_pos_def
        using a arel.simps by (auto simp add: True Some spec_watchdog_tick_def)
    next
      case False
      have c1: "wpos > 1"
        using b1 False by auto
      have c2: "spec_watchdog_tick aw 0 = Some (wpos - 1)"
        unfolding spec_watchdog_tick_def using Some c1 by auto
      have c3: "fst (spec_watchdog_tick_system (as, aw)) = (as, spec_watchdog_tick aw)"
        unfolding spec_watchdog_tick_system.simps
        using False Some by auto
      have c4: "frame_time a = frame_time_to_window (as_ttbl as) (window_id as + 1) - wpos"
        using assms(1) Some arel.simps by auto
      have c5: "frame_time_to_window (as_ttbl as) (Suc (window_id as)) \<ge> wpos"
        apply (auto simp add: frame_time_to_window_next g4)
        using b1(2) by auto
      have c6: "Suc (frame_time_to_window (as_ttbl as) (Suc (window_id as)) - wpos) =
                Suc (frame_time_to_window (as_ttbl as) (Suc (window_id as))) - wpos"
        using c5 by auto
      have c7: "Suc (frame_time_to_window (as_ttbl as) (Suc (window_id as))) - wpos < frame_length (as_ttbl as)"
        by (smt Suc_lessI Suc_less_eq2 ainv.simps assms(2) b1(1) c1 c5 c6 diff_diff_cancel diff_less
                frame_time_to_window_mono_strict frame_time_to_window_total less_diff_conv
                less_imp_diff_less less_le_trans plus_1_eq_Suc)
      show ?thesis
        unfolding spec_atick_def fst_conv c3 spec_watchdog_tick_def arel.simps
        using c1 apply (auto simp add: Some b2)
        unfolding c4 apply auto unfolding c6 using c7 apply auto
        using assms(1) unfolding arel.simps by auto
    qed
  qed
qed

theorem spec_atick_ainv:
  assumes "arel a (as, aw)"
    and "ainv (as, aw)"
  shows "ainv (fst (spec_watchdog_tick_system (as, aw)))"
  using assms ainv.simps
  apply (auto simp: spec_dispatch_def next_watchdog_pos_def spec_watchdog_tick_def spec_watchdog_tick_system.simps)
  apply (metis mod_less_divisor neq0_conv not_less_zero)
  using Suc_lessD mod_less_divisor window_time_pos' apply blast
  apply (cases "aw 0") by auto

theorem spec_atick_output:
  assumes "arel a (as, aw)"
    and "ainv (as, aw)"
  shows "spec_atick_ev a = snd (spec_watchdog_tick_system (as, aw))"
proof (cases "aw 0")
  case None
  then show ?thesis using assms arel.simps by auto
next
  case (Some wpos)
  have b1: "wpos > 0" "wpos \<le> snd (as_ttbl as ! window_id as)"
    using assms(2) Some ainv.simps by auto
  have b2: "a_ttbl a = as_ttbl as"
    using assms(1) Some arel.simps by auto
  have b3: "frame_time a = frame_time_to_window (as_ttbl as) (window_id as + 1) - wpos"
    using assms(1) Some arel.simps by auto
  have b4: "at_window_boundary (a_ttbl a) (frame_time a) \<longleftrightarrow> wpos = 1"
    unfolding b2 b3 apply (rule at_window_boundary_wpos)
    using assms(2) b1 ainv.simps by auto
  show ?thesis
  proof (cases "wpos = 1")
    case True
    have c1: "frame_time_to_window (as_ttbl as) (window_id as + 1) - wpos + 1 =
              frame_time_to_window (as_ttbl as) (window_id as + 1)"
      apply simp unfolding frame_time_to_window_next
      using True assms(2) frame_time_to_window_next window_time_pos ainv.simps by auto
    have c2: "length (as_ttbl as) > 0"
      using assms(2) ainv.simps by fastforce
    have c3: "partition_at_time (a_ttbl a) ((frame_time a + 1) mod frame_length (a_ttbl a)) =
          next_partition as"
    proof (cases "window_id as = length (as_ttbl as) - 1")
      case True
      have d1: "(window_id as + 1) mod length (as_ttbl as) = 0"
        using True
        by (metis Suc_diff_1 Suc_eq_plus1 c2 mod_self)
      have d2: "frame_time_to_window (as_ttbl as) (window_id as + 1) = frame_length (as_ttbl as)"
        by (metis Suc_diff_1 Suc_eq_plus1 True c2 frame_time_to_window_total)
      show ?thesis
        unfolding next_partition_def b3 c1 d1
        unfolding d2 b2
        apply auto
        by (metis (no_types, hide_lams) One_nat_def Suc_eq_plus1 Suc_lessD ainv.simps
              assms(2) fst_conv is_valid_time_table.elims(2) list.size(3) not_less_zero
              nth_Cons_0 partition_at_time.elims snd_conv window_time_pos)
    next
      case False
      have d1: "window_id as + 1 < length (as_ttbl as)"
        using False assms(2) ainv.simps by auto
      have d2: "frame_time_to_window (as_ttbl as) (window_id as + 1) < frame_length (as_ttbl as)"
        by (metis d1 ainv.simps assms(2) frame_time_to_window_mono_strict frame_time_to_window_total)
      have d3: "(window_id as + 1) mod length (as_ttbl as) = window_id as + 1"
        using d1 by auto
      have d4: "frame_time_to_window (as_ttbl as) (window_id as + 1) mod frame_length (as_ttbl as) =
                frame_time_to_window (as_ttbl as) (window_id as + 1)"
        using d2 by auto
      show ?thesis
        unfolding next_partition_def b2 b3 c1 d3 d4
        apply (rule partition_at_time_frame_time_to_window)
        using assms d1 ainv.simps by auto
    qed
    then show ?thesis
      unfolding spec_atick_def spec_atick_ev_def spec_watchdog_tick_system.simps snd_conv
                Some True arel.simps
      using Some True b4 apply auto
      unfolding spec_watchdog_tick_ev_def using assms(1) unfolding arel.simps by auto
  next
    case False
    show ?thesis
      using Some False b4
      apply (auto simp add: spec_atick_def spec_atick_ev_def spec_watchdog_tick_system.simps)
      subgoal for x
        unfolding spec_watchdog_tick_ev_def using assms(1) apply (auto simp add: arel.simps)
        by (metis (mono_tags, lifting) image_eqI mem_Collect_eq neq0_conv option.distinct(1))
      subgoal for x
        unfolding spec_watchdog_tick_ev_def using assms(1) apply (auto simp add: arel.simps)
        by (metis (mono_tags, lifting) image_eqI mem_Collect_eq not_gr_zero option.inject)
      done
  qed
qed

fun arel_full :: "astate \<Rightarrow> cstate_scheduler \<times> watchdog_chain \<Rightarrow> bool" where
  "arel_full a p \<longleftrightarrow> (\<exists>as aw. arel a (as, aw) \<and> ainv (as, aw) \<and> rel_total (as, aw) p)"

theorem sValidNF_watchdog_tick_full:
  "sValidNF system
    (\<lambda>p es. arel_full a p \<and> nil\<^sub>e es)
      WATCHDOG_TICK
    (\<lambda>p es. arel_full (spec_atick a) p \<and> distinct es \<and> set es = spec_atick_ev a)"
  unfolding arel_full.simps
  apply (auto simp only: sValidNF_exists_pre)
  subgoal for as aw
    apply (auto simp add: sValidNF_conj_pre)
    apply (rule sValidNF_strengthen_post)
    prefer 2
     apply (rule sValidNF_watchdog_tick)
    subgoal for p es
      apply (intro conjI)
      subgoal
      apply (rule exI[where x="fst (fst (spec_watchdog_tick_system (as, aw)))"])
      apply (rule exI[where x="snd (fst (spec_watchdog_tick_system (as, aw)))"])
        by (auto simp add: spec_atick_refines spec_atick_ainv)
      using spec_atick_output by auto
    done
  done

end


(* Author: Gerwin Klein *)

theory Compiler2
imports Compiler
begin

text {*
The preservation of the source code semantics is already shown in the
parent theory @{theory Compiler}. This here shows the second direction.
*}

section {* Compiler Correctness, Reverse Direction *}

subsection {* Definitions *}

text {* Execution in @{term n} steps for simpler induction *}
primrec
  exec_n :: "instr list \<Rightarrow> config \<Rightarrow> nat \<Rightarrow> config \<Rightarrow> bool"
  ("_/ \<turnstile> (_ \<rightarrow>^_/ _)" [65,0,1000,55] 55)
where
  "P \<turnstile> c \<rightarrow>^0 c' = (c'=c)" |
  "P \<turnstile> c \<rightarrow>^(Suc n) c'' = (\<exists>c'. (P \<turnstile> c \<rightarrow> c') \<and> P \<turnstile> c' \<rightarrow>^n c'')"

text {* The possible successor PCs of an instruction at position @{term n} *}
text_raw{*\snip{isuccsdef}{0}{1}{% *}
definition isuccs :: "instr \<Rightarrow> int \<Rightarrow> int set" where
"isuccs i n = (case i of
  JMP j \<Rightarrow> {n + 1 + j} |
  JMPLESS j \<Rightarrow> {n + 1 + j, n + 1} |
  JMPGE j \<Rightarrow> {n + 1 + j, n + 1} |
  _ \<Rightarrow> {n +1})"
text_raw{*}%endsnip*}

text {* The possible successors PCs of an instruction list *}
definition succs :: "instr list \<Rightarrow> int \<Rightarrow> int set" where
"succs P n = {s. \<exists>i::int. 0 \<le> i \<and> i < size P \<and> s \<in> isuccs (P!!i) (n+i)}"

text {* Possible exit PCs of a program *}
definition exits :: "instr list \<Rightarrow> int set" where
"exits P = succs P 0 - {0..< size P}"

subsection {* Basic properties of @{term exec_n} *}

lemma exec_n_exec:
  "P \<turnstile> c \<rightarrow>^n c' \<Longrightarrow> P \<turnstile> c \<rightarrow>* c'"
  by (induct n arbitrary: c) (auto intro: star.step)

lemma exec_0 [intro!]: "P \<turnstile> c \<rightarrow>^0 c" by simp

lemma exec_Suc:
  "\<lbrakk> P \<turnstile> c \<rightarrow> c'; P \<turnstile> c' \<rightarrow>^n c'' \<rbrakk> \<Longrightarrow> P \<turnstile> c \<rightarrow>^(Suc n) c''"
  by (fastforce simp del: split_paired_Ex)

lemma exec_exec_n:
  "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> \<exists>n. P \<turnstile> c \<rightarrow>^n c'"
  by (induct rule: star.induct) (auto intro: exec_Suc)

lemma exec_eq_exec_n:
  "(P \<turnstile> c \<rightarrow>* c') = (\<exists>n. P \<turnstile> c \<rightarrow>^n c')"
  by (blast intro: exec_exec_n exec_n_exec)

lemma exec_n_Nil [simp]:
  "[] \<turnstile> c \<rightarrow>^k c' = (c' = c \<and> k = 0)"
  by (induct k) (auto simp: exec1_def)

lemma exec1_exec_n [intro!]:
  "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P \<turnstile> c \<rightarrow>^1 c'"
  by (cases c') simp

subsection {* Concrete symbolic execution steps *}

lemma exec_n_step:
  "n \<noteq> n' \<Longrightarrow>
  P \<turnstile> (n,stk,s) \<rightarrow>^k (n',stk',s') =
  (\<exists>c. P \<turnstile> (n,stk,s) \<rightarrow> c \<and> P \<turnstile> c \<rightarrow>^(k - 1) (n',stk',s') \<and> 0 < k)"
  by (cases k) auto

lemma exec1_end:
  "size P <= fst c \<Longrightarrow> \<not> P \<turnstile> c \<rightarrow> c'"
  by (auto simp: exec1_def)

lemma exec_n_end:
  "size P <= (n::int) \<Longrightarrow>
  P \<turnstile> (n,s,stk) \<rightarrow>^k (n',s',stk') = (n' = n \<and> stk'=stk \<and> s'=s \<and> k =0)"
  by (cases k) (auto simp: exec1_end)

lemmas exec_n_simps = exec_n_step exec_n_end

subsection {* Basic properties of @{term succs} *}

lemma succs_simps [simp]:
  "succs [ADD] n = {n + 1}"
  "succs [LOADI v] n = {n + 1}"
  "succs [LOAD x] n = {n + 1}"
  "succs [STORE x] n = {n + 1}"
  "succs [JMP i] n = {n + 1 + i}"
  "succs [JMPGE i] n = {n + 1 + i, n + 1}"
  "succs [JMPLESS i] n = {n + 1 + i, n + 1}"
  by (auto simp: succs_def isuccs_def)

lemma succs_empty [iff]: "succs [] n = {}"
  by (simp add: succs_def)

lemma succs_Cons:
  "succs (x#xs) n = isuccs x n \<union> succs xs (1+n)" (is "_ = ?x \<union> ?xs")
proof
  let ?isuccs = "\<lambda>p P n i::int. 0 \<le> i \<and> i < size P \<and> p \<in> isuccs (P!!i) (n+i)"
  { fix p assume "p \<in> succs (x#xs) n"
    then obtain i::int where isuccs: "?isuccs p (x#xs) n i"
      unfolding succs_def by auto
    have "p \<in> ?x \<union> ?xs"
    proof cases
      assume "i = 0" with isuccs show ?thesis by simp
    next
      assume "i \<noteq> 0"
      with isuccs
      have "?isuccs p xs (1+n) (i - 1)" by auto
      hence "p \<in> ?xs" unfolding succs_def by blast
      thus ?thesis ..
    qed
  }
  thus "succs (x#xs) n \<subseteq> ?x \<union> ?xs" ..

  { fix p assume "p \<in> ?x \<or> p \<in> ?xs"
    hence "p \<in> succs (x#xs) n"
    proof
      assume "p \<in> ?x" thus ?thesis by (fastforce simp: succs_def)
    next
      assume "p \<in> ?xs"
      then obtain i where "?isuccs p xs (1+n) i"
        unfolding succs_def by auto
      hence "?isuccs p (x#xs) n (1+i)"
        by (simp add: algebra_simps)
      thus ?thesis unfolding succs_def by blast
    qed
  }
  thus "?x \<union> ?xs \<subseteq> succs (x#xs) n" by blast
qed

lemma succs_iexec1:
  assumes "c' = iexec (P!!i) (i,s,stk)" "0 \<le> i" "i < size P"
  shows "fst c' \<in> succs P 0"
  using assms by (auto simp: succs_def isuccs_def split: instr.split)

lemma succs_shift:
  "(p - n \<in> succs P 0) = (p \<in> succs P n)"
  by (fastforce simp: succs_def isuccs_def split: instr.split)

lemma inj_op_plus [simp]:
  "inj (op + (i::int))"
  by (metis add_minus_cancel inj_on_inverseI)

lemma succs_set_shift [simp]:
  "op + i ` succs xs 0 = succs xs i"
  by (force simp: succs_shift [where n=i, symmetric] intro: set_eqI)

lemma succs_append [simp]:
  "succs (xs @ ys) n = succs xs n \<union> succs ys (n + size xs)"
  by (induct xs arbitrary: n) (auto simp: succs_Cons algebra_simps)

lemma exits_append [simp]:
  "exits (xs @ ys) = exits xs \<union> (op + (size xs)) ` exits ys -
                     {0..<size xs + size ys}"
  by (auto simp: exits_def image_set_diff)

lemma exits_single:
  "exits [x] = isuccs x 0 - {0}"
  by (auto simp: exits_def succs_def)

lemma exits_Cons:
  "exits (x # xs) = (isuccs x 0 - {0}) \<union> (op + 1) ` exits xs -
                     {0..<1 + size xs}"
  using exits_append [of "[x]" xs]
  by (simp add: exits_single)

lemma exits_empty [iff]: "exits [] = {}" by (simp add: exits_def)

lemma exits_simps [simp]:
  "exits [ADD] = {1}"
  "exits [LOADI v] = {1}"
  "exits [LOAD x] = {1}"
  "exits [STORE x] = {1}"
  "i \<noteq> -1 \<Longrightarrow> exits [JMP i] = {1 + i}"
  "i \<noteq> -1 \<Longrightarrow> exits [JMPGE i] = {1 + i, 1}"
  "i \<noteq> -1 \<Longrightarrow> exits [JMPLESS i] = {1 + i, 1}"
  by (auto simp: exits_def)

lemma acomp_succs [simp]:
  "succs (acomp a) n = {n + 1 .. n + size (acomp a)}"
  by (induct a arbitrary: n) auto

lemma acomp_size:
  "(1::int) \<le> size (acomp a)"
  by (induct a) auto

lemma acomp_exits [simp]:
  "exits (acomp a) = {size (acomp a)}"
  by (auto simp: exits_def acomp_size)

lemma bcomp_succs:
  "0 \<le> i \<Longrightarrow>
  succs (bcomp b f i) n \<subseteq> {n .. n + size (bcomp b f i)}
                           \<union> {n + i + size (bcomp b f i)}"
proof (induction b arbitrary: f i n)
  case (And b1 b2)
  from And.prems
  show ?case
    by (cases f)
       (auto dest: And.IH(1) [THEN subsetD, rotated]
                   And.IH(2) [THEN subsetD, rotated])
qed auto

lemmas bcomp_succsD [dest!] = bcomp_succs [THEN subsetD, rotated]

lemma bcomp_exits:
  fixes i :: int
  shows
  "0 \<le> i \<Longrightarrow>
  exits (bcomp b f i) \<subseteq> {size (bcomp b f i), i + size (bcomp b f i)}"
  by (auto simp: exits_def)

lemma bcomp_exitsD [dest!]:
  "p \<in> exits (bcomp b f i) \<Longrightarrow> 0 \<le> i \<Longrightarrow>
  p = size (bcomp b f i) \<or> p = i + size (bcomp b f i)"
  using bcomp_exits by auto

lemma ccomp_succs:
  "succs (ccomp c) n \<subseteq> {n..n + size (ccomp c)}"
proof (induction c arbitrary: n)
  case SKIP thus ?case by simp
next
  case Assign thus ?case by simp
next
  case (Seq c1 c2)
  from Seq.prems
  show ?case
    by (fastforce dest: Seq.IH [THEN subsetD])
next
  case (If b c1 c2)
  from If.prems
  show ?case
    by (auto dest!: If.IH [THEN subsetD] simp: isuccs_def succs_Cons)
next
  case (While b c)
  from While.prems
  show ?case by (auto dest!: While.IH [THEN subsetD])
qed

lemma ccomp_exits:
  "exits (ccomp c) \<subseteq> {size (ccomp c)}"
  using ccomp_succs [of c 0] by (auto simp: exits_def)

lemma ccomp_exitsD [dest!]:
  "p \<in> exits (ccomp c) \<Longrightarrow> p = size (ccomp c)"
  using ccomp_exits by auto

subsection {* Splitting up machine executions *}

lemma exec1_split:
  fixes i j :: int
  shows
  "P @ c @ P' \<turnstile> (size P + i, s) \<rightarrow> (j,s') \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size c \<Longrightarrow>
  c \<turnstile> (i,s) \<rightarrow> (j - size P, s')"
  by (auto split: instr.splits simp: exec1_def)

lemma exec_n_split:
  fixes i j :: int
  assumes "P @ c @ P' \<turnstile> (size P + i, s) \<rightarrow>^n (j, s')"
          "0 \<le> i" "i < size c"
          "j \<notin> {size P ..< size P + size c}"
  shows "\<exists>s'' (i'::int) k m.
                   c \<turnstile> (i, s) \<rightarrow>^k (i', s'') \<and>
                   i' \<in> exits c \<and>
                   P @ c @ P' \<turnstile> (size P + i', s'') \<rightarrow>^m (j, s') \<and>
                   n = k + m"
using assms proof (induction n arbitrary: i j s)
  case 0
  thus ?case by simp
next
  case (Suc n)
  have i: "0 \<le> i" "i < size c" by fact+
  from Suc.prems
  have j: "\<not> (size P \<le> j \<and> j < size P + size c)" by simp
  from Suc.prems
  obtain i0 s0 where
    step: "P @ c @ P' \<turnstile> (size P + i, s) \<rightarrow> (i0,s0)" and
    rest: "P @ c @ P' \<turnstile> (i0,s0) \<rightarrow>^n (j, s')"
    by clarsimp

  from step i
  have c: "c \<turnstile> (i,s) \<rightarrow> (i0 - size P, s0)" by (rule exec1_split)

  have "i0 = size P + (i0 - size P) " by simp
  then obtain j0::int where j0: "i0 = size P + j0"  ..

  note split_paired_Ex [simp del]

  { assume "j0 \<in> {0 ..< size c}"
    with j0 j rest c
    have ?case
      by (fastforce dest!: Suc.IH intro!: exec_Suc)
  } moreover {
    assume "j0 \<notin> {0 ..< size c}"
    moreover
    from c j0 have "j0 \<in> succs c 0"
      by (auto dest: succs_iexec1 simp: exec1_def simp del: iexec.simps)
    ultimately
    have "j0 \<in> exits c" by (simp add: exits_def)
    with c j0 rest
    have ?case by fastforce
  }
  ultimately
  show ?case by cases
qed

lemma exec_n_drop_right:
  fixes j :: int
  assumes "c @ P' \<turnstile> (0, s) \<rightarrow>^n (j, s')" "j \<notin> {0..<size c}"
  shows "\<exists>s'' i' k m.
          (if c = [] then s'' = s \<and> i' = 0 \<and> k = 0
           else c \<turnstile> (0, s) \<rightarrow>^k (i', s'') \<and>
           i' \<in> exits c) \<and>
           c @ P' \<turnstile> (i', s'') \<rightarrow>^m (j, s') \<and>
           n = k + m"
  using assms
  by (cases "c = []")
     (auto dest: exec_n_split [where P="[]", simplified])

text {*
  Dropping the left context of a potentially incomplete execution of @{term c}.
*}

lemma exec1_drop_left:
  fixes i n :: int
  assumes "P1 @ P2 \<turnstile> (i, s, stk) \<rightarrow> (n, s', stk')" and "size P1 \<le> i"
  shows "P2 \<turnstile> (i - size P1, s, stk) \<rightarrow> (n - size P1, s', stk')"
proof -
  have "i = size P1 + (i - size P1)" by simp
  then obtain i' :: int where "i = size P1 + i'" ..
  moreover
  have "n = size P1 + (n - size P1)" by simp
  then obtain n' :: int where "n = size P1 + n'" ..
  ultimately
  show ?thesis using assms
    by (clarsimp simp: exec1_def simp del: iexec.simps)
qed

lemma exec_n_drop_left:
  fixes i n :: int
  assumes "P @ P' \<turnstile> (i, s, stk) \<rightarrow>^k (n, s', stk')"
          "size P \<le> i" "exits P' \<subseteq> {0..}"
  shows "P' \<turnstile> (i - size P, s, stk) \<rightarrow>^k (n - size P, s', stk')"
using assms proof (induction k arbitrary: i s stk)
  case 0 thus ?case by simp
next
  case (Suc k)
  from Suc.prems
  obtain i' s'' stk'' where
    step: "P @ P' \<turnstile> (i, s, stk) \<rightarrow> (i', s'', stk'')" and
    rest: "P @ P' \<turnstile> (i', s'', stk'') \<rightarrow>^k (n, s', stk')"
    by auto
  from step `size P \<le> i`
  have *: "P' \<turnstile> (i - size P, s, stk) \<rightarrow> (i' - size P, s'', stk'')"
    by (rule exec1_drop_left)
  then have "i' - size P \<in> succs P' 0"
    by (fastforce dest!: succs_iexec1 simp: exec1_def simp del: iexec.simps)
  with `exits P' \<subseteq> {0..}`
  have "size P \<le> i'" by (auto simp: exits_def)
  from rest this `exits P' \<subseteq> {0..}`
  have "P' \<turnstile> (i' - size P, s'', stk'') \<rightarrow>^k (n - size P, s', stk')"
    by (rule Suc.IH)
  with * show ?case by auto
qed

lemmas exec_n_drop_Cons =
  exec_n_drop_left [where P="[instr]", simplified] for instr

definition
  "closed P \<longleftrightarrow> exits P \<subseteq> {size P}"

lemma ccomp_closed [simp, intro!]: "closed (ccomp c)"
  using ccomp_exits by (auto simp: closed_def)

lemma acomp_closed [simp, intro!]: "closed (acomp c)"
  by (simp add: closed_def)

lemma exec_n_split_full:
  fixes j :: int
  assumes exec: "P @ P' \<turnstile> (0,s,stk) \<rightarrow>^k (j, s', stk')"
  assumes P: "size P \<le> j"
  assumes closed: "closed P"
  assumes exits: "exits P' \<subseteq> {0..}"
  shows "\<exists>k1 k2 s'' stk''. P \<turnstile> (0,s,stk) \<rightarrow>^k1 (size P, s'', stk'') \<and>
                           P' \<turnstile> (0,s'',stk'') \<rightarrow>^k2 (j - size P, s', stk')"
proof (cases "P")
  case Nil with exec
  show ?thesis by fastforce
next
  case Cons
  hence "0 < size P" by simp
  with exec P closed
  obtain k1 k2 s'' stk'' where
    1: "P \<turnstile> (0,s,stk) \<rightarrow>^k1 (size P, s'', stk'')" and
    2: "P @ P' \<turnstile> (size P,s'',stk'') \<rightarrow>^k2 (j, s', stk')"
    by (auto dest!: exec_n_split [where P="[]" and i=0, simplified]
             simp: closed_def)
  moreover
  have "j = size P + (j - size P)" by simp
  then obtain j0 :: int where "j = size P + j0" ..
  ultimately
  show ?thesis using exits
    by (fastforce dest: exec_n_drop_left)
qed

subsection {* Correctness theorem *}

lemma acomp_neq_Nil [simp]:
  "acomp a \<noteq> []"
  by (induct a) auto

lemma acomp_exec_n [dest!]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>^n (size (acomp a),s',stk') \<Longrightarrow>
  s' = s \<and> stk' = aval a s#stk"
proof (induction a arbitrary: n s' stk stk')
  case (Plus a1 a2)
  let ?sz = "size (acomp a1) + (size (acomp a2) + 1)"
  from Plus.prems
  have "acomp a1 @ acomp a2 @ [ADD] \<turnstile> (0,s,stk) \<rightarrow>^n (?sz, s', stk')"
    by (simp add: algebra_simps)

  then obtain n1 s1 stk1 n2 s2 stk2 n3 where
    "acomp a1 \<turnstile> (0,s,stk) \<rightarrow>^n1 (size (acomp a1), s1, stk1)"
    "acomp a2 \<turnstile> (0,s1,stk1) \<rightarrow>^n2 (size (acomp a2), s2, stk2)"
       "[ADD] \<turnstile> (0,s2,stk2) \<rightarrow>^n3 (1, s', stk')"
    by (auto dest!: exec_n_split_full)

  thus ?case by (fastforce dest: Plus.IH simp: exec_n_simps exec1_def)
qed (auto simp: exec_n_simps exec1_def)

lemma bcomp_split:
  fixes i j :: int
  assumes "bcomp b f i @ P' \<turnstile> (0, s, stk) \<rightarrow>^n (j, s', stk')"
          "j \<notin> {0..<size (bcomp b f i)}" "0 \<le> i"
  shows "\<exists>s'' stk'' (i'::int) k m.
           bcomp b f i \<turnstile> (0, s, stk) \<rightarrow>^k (i', s'', stk'') \<and>
           (i' = size (bcomp b f i) \<or> i' = i + size (bcomp b f i)) \<and>
           bcomp b f i @ P' \<turnstile> (i', s'', stk'') \<rightarrow>^m (j, s', stk') \<and>
           n = k + m"
  using assms by (cases "bcomp b f i = []") (fastforce dest!: exec_n_drop_right)+

lemma bcomp_exec_n [dest]:
  fixes i j :: int
  assumes "bcomp b f j \<turnstile> (0, s, stk) \<rightarrow>^n (i, s', stk')"
          "size (bcomp b f j) \<le> i" "0 \<le> j"
  shows "i = size(bcomp b f j) + (if f = bval b s then j else 0) \<and>
         s' = s \<and> stk' = stk"
using assms proof (induction b arbitrary: f j i n s' stk')
  case Bc thus ?case
    by (simp split: if_split_asm add: exec_n_simps exec1_def)
next
  case (Not b)
  from Not.prems show ?case
    by (fastforce dest!: Not.IH)
next
  case (And b1 b2)

  let ?b2 = "bcomp b2 f j"
  let ?m  = "if f then size ?b2 else size ?b2 + j"
  let ?b1 = "bcomp b1 False ?m"

  have j: "size (bcomp (And b1 b2) f j) \<le> i" "0 \<le> j" by fact+

  from And.prems
  obtain s'' stk'' and i'::int and k m where
    b1: "?b1 \<turnstile> (0, s, stk) \<rightarrow>^k (i', s'', stk'')"
        "i' = size ?b1 \<or> i' = ?m + size ?b1" and
    b2: "?b2 \<turnstile> (i' - size ?b1, s'', stk'') \<rightarrow>^m (i - size ?b1, s', stk')"
    by (auto dest!: bcomp_split dest: exec_n_drop_left)
  from b1 j
  have "i' = size ?b1 + (if \<not>bval b1 s then ?m else 0) \<and> s'' = s \<and> stk'' = stk"
    by (auto dest!: And.IH)
  with b2 j
  show ?case
    by (fastforce dest!: And.IH simp: exec_n_end split: if_split_asm)
next
  case Less
  thus ?case by (auto dest!: exec_n_split_full simp: exec_n_simps exec1_def) (* takes time *)
qed

lemma ccomp_empty [elim!]:
  "ccomp c = [] \<Longrightarrow> (c,s) \<Rightarrow> s"
  by (induct c) auto

declare assign_simp [simp]

lemma ccomp_exec_n:
  "ccomp c \<turnstile> (0,s,stk) \<rightarrow>^n (size(ccomp c),t,stk')
  \<Longrightarrow> (c,s) \<Rightarrow> t \<and> stk'=stk"
proof (induction c arbitrary: s t stk stk' n)
  case SKIP
  thus ?case by auto
next
  case (Assign x a)
  thus ?case
    by simp (fastforce dest!: exec_n_split_full simp: exec_n_simps exec1_def)
next
  case (Seq c1 c2)
  thus ?case by (fastforce dest!: exec_n_split_full)
next
  case (If b c1 c2)
  note If.IH [dest!]

  let ?if = "IF b THEN c1 ELSE c2"
  let ?cs = "ccomp ?if"
  let ?bcomp = "bcomp b False (size (ccomp c1) + 1)"

  from `?cs \<turnstile> (0,s,stk) \<rightarrow>^n (size ?cs,t,stk')`
  obtain i' :: int and k m s'' stk'' where
    cs: "?cs \<turnstile> (i',s'',stk'') \<rightarrow>^m (size ?cs,t,stk')" and
        "?bcomp \<turnstile> (0,s,stk) \<rightarrow>^k (i', s'', stk'')"
        "i' = size ?bcomp \<or> i' = size ?bcomp + size (ccomp c1) + 1"
    by (auto dest!: bcomp_split)

  hence i':
    "s''=s" "stk'' = stk"
    "i' = (if bval b s then size ?bcomp else size ?bcomp+size(ccomp c1)+1)"
    by auto

  with cs have cs':
    "ccomp c1@JMP (size (ccomp c2))#ccomp c2 \<turnstile>
       (if bval b s then 0 else size (ccomp c1)+1, s, stk) \<rightarrow>^m
       (1 + size (ccomp c1) + size (ccomp c2), t, stk')"
    by (fastforce dest: exec_n_drop_left simp: exits_Cons isuccs_def algebra_simps)

  show ?case
  proof (cases "bval b s")
    case True with cs'
    show ?thesis
      by simp
         (fastforce dest: exec_n_drop_right
                   split: if_split_asm
                   simp: exec_n_simps exec1_def)
  next
    case False with cs'
    show ?thesis
      by (auto dest!: exec_n_drop_Cons exec_n_drop_left
               simp: exits_Cons isuccs_def)
  qed
next
  case (While b c)

  from While.prems
  show ?case
  proof (induction n arbitrary: s rule: nat_less_induct)
    case (1 n)

    { assume "\<not> bval b s"
      with "1.prems"
      have ?case
        by simp
           (fastforce dest!: bcomp_exec_n bcomp_split simp: exec_n_simps)
    } moreover {
      assume b: "bval b s"
      let ?c0 = "WHILE b DO c"
      let ?cs = "ccomp ?c0"
      let ?bs = "bcomp b False (size (ccomp c) + 1)"
      let ?jmp = "[JMP (-((size ?bs + size (ccomp c) + 1)))]"

      from "1.prems" b
      obtain k where
        cs: "?cs \<turnstile> (size ?bs, s, stk) \<rightarrow>^k (size ?cs, t, stk')" and
        k:  "k \<le> n"
        by (fastforce dest!: bcomp_split)

      have ?case
      proof cases
        assume "ccomp c = []"
        with cs k
        obtain m where
          "?cs \<turnstile> (0,s,stk) \<rightarrow>^m (size (ccomp ?c0), t, stk')"
          "m < n"
          by (auto simp: exec_n_step [where k=k] exec1_def)
        with "1.IH"
        show ?case by blast
      next
        assume "ccomp c \<noteq> []"
        with cs
        obtain m m' s'' stk'' where
          c: "ccomp c \<turnstile> (0, s, stk) \<rightarrow>^m' (size (ccomp c), s'', stk'')" and
          rest: "?cs \<turnstile> (size ?bs + size (ccomp c), s'', stk'') \<rightarrow>^m
                       (size ?cs, t, stk')" and
          m: "k = m + m'"
          by (auto dest: exec_n_split [where i=0, simplified])
        from c
        have "(c,s) \<Rightarrow> s''" and stk: "stk'' = stk"
          by (auto dest!: While.IH)
        moreover
        from rest m k stk
        obtain k' where
          "?cs \<turnstile> (0, s'', stk) \<rightarrow>^k' (size ?cs, t, stk')"
          "k' < n"
          by (auto simp: exec_n_step [where k=m] exec1_def)
        with "1.IH"
        have "(?c0, s'') \<Rightarrow> t \<and> stk' = stk" by blast
        ultimately
        show ?case using b by blast
      qed
    }
    ultimately show ?case by cases
  qed
qed

theorem ccomp_exec:
  "ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk') \<Longrightarrow> (c,s) \<Rightarrow> t"
  by (auto dest: exec_exec_n ccomp_exec_n)

corollary ccomp_sound:
  "ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)  \<longleftrightarrow>  (c,s) \<Rightarrow> t"
  by (blast intro!: ccomp_exec ccomp_bigstep)

end


theory GewirthArgument                              (* by David Fuenmayor and C. Benzmüller, 2019 *)
  imports ExtendedDDL
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3]

section \<open>Gewith's Ethical Theory\<close>

type_synonym p = "e\<Rightarrow>m" (**Type for properties (function from individuals to sentence meanings)*)

(**ActsOnPurpose is a relational constant. (ActsOnPurpose A E) reads as "A is acting on purpose E":*)
consts ActsOnPurpose::"e\<Rightarrow>m\<Rightarrow>m"
(**(NeedsForPurpose A P E) reads as "A needs to have property P in order to reach purpose E":*)
consts NeedsForPurpose::"e\<Rightarrow>p\<Rightarrow>m\<Rightarrow>m"

definition PPA:: "p" where "PPA a \<equiv> \<^bold>\<exists>E. ActsOnPurpose a E" (** Definition of PPA*)
axiomatization where essentialPPA: "\<lfloor>\<^bold>\<forall>a. PPA a \<^bold>\<rightarrow> \<^bold>\<box>\<^sup>D(PPA a)\<rfloor>\<^sup>D" (**PPA is an essential property*)
lemma recognizeOtherPPA: "\<forall>c d. \<lfloor>PPA (Agent d)\<rfloor>\<^sub>d \<longrightarrow> \<lfloor>PPA (Agent d)\<rfloor>\<^sub>c" using essentialPPA by blast

consts Good::"e\<Rightarrow>m\<Rightarrow>m"
axiomatization where explGoodness1: "\<lfloor>\<^bold>\<forall>a P. ActsOnPurpose a P \<^bold>\<rightarrow> Good a P\<rfloor>\<^sup>D"
axiomatization where explGoodness2: "\<lfloor>\<^bold>\<forall>P M a. Good a P \<^bold>\<and> NeedsForPurpose a M P \<^bold>\<rightarrow> Good a (M a)\<rfloor>\<^sup>D"
axiomatization where explGoodness3: "\<lfloor>\<^bold>\<forall>\<phi> a. \<^bold>\<diamond>\<^sub>p\<phi> \<^bold>\<rightarrow> \<^bold>O\<langle>\<phi> | \<^bold>\<box>\<^sup>DGood a \<phi>\<rangle>\<rfloor>\<^sup>D"

consts FWB::"p" (**Enjoying freedom and well-being (FWB) is a property (i.e.~has type @{text "e\<Rightarrow>m"})*)

axiomatization where
explicationFWB1: "\<lfloor>\<^bold>\<forall>P a. NeedsForPurpose a FWB P\<rfloor>\<^sup>D"
axiomatization where explicationFWB2: "\<lfloor>\<^bold>\<forall>a. \<^bold>\<diamond>\<^sub>p FWB a\<rfloor>\<^sup>D"
axiomatization where explicationFWB3: "\<lfloor>\<^bold>\<forall>a. \<^bold>\<diamond>\<^sub>p \<^bold>\<not>FWB a\<rfloor>\<^sup>D"

lemma "\<lfloor>\<^bold>O\<^sub>i\<phi> \<^bold>\<rightarrow> \<^bold>\<diamond>\<^sub>p\<phi>\<rfloor>" using sem_5ab by simp
axiomatization where OIOAC: "\<lfloor>\<^bold>O\<^sub>i\<phi> \<^bold>\<rightarrow> \<^bold>O\<^sub>i(\<^bold>\<diamond>\<^sub>a\<phi>)\<rfloor>\<^sup>D"

consts InterferesWith::"e\<Rightarrow>m\<Rightarrow>m"
axiomatization where explicationInterference: "\<lfloor>(\<^bold>\<exists>b. InterferesWith b \<phi>) \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<diamond>\<^sub>a\<phi>\<rfloor>"
lemma "\<lfloor>\<^bold>\<forall>a. (\<^bold>\<exists>b. InterferesWith b (FWB a)) \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<diamond>\<^sub>a(FWB a)\<rfloor>" using explicationInterference by blast
lemma InterferenceWithFWB: "\<lfloor>\<^bold>\<forall>a.  \<^bold>\<diamond>\<^sub>a(FWB a) \<^bold>\<leftrightarrow> (\<^bold>\<forall>b. \<^bold>\<not>InterferesWith b (FWB a))\<rfloor>" using explicationInterference by blast

definition RightTo::"e\<Rightarrow>(e\<Rightarrow>m)\<Rightarrow>m" where "RightTo a \<phi> \<equiv> \<^bold>O\<^sub>i(\<^bold>\<forall>b. \<^bold>\<not>InterferesWith b (\<phi> a))"

(**Axiom consistency checked: Nitpick finds a two-world model (card w=2)*)
lemma True nitpick[satisfy, card c = 1, card e = 1, card w = 2] oops

section \<open>Gewirth's Argument for the PGC\<close>

(**Following Beyleveld's summary, the main steps of the argument are (with original numbering): *)
(**(1) I act voluntarily for some (freely chosen) purpose E (equivalent --by definition-- to: I am a PPA).*)
(**(2) E is (subjectively) good (i.e.~I value E proactively).*)
(**(3) My freedom and well-being (FWB) are generically necessary conditions of my agency (i.e.~I need them to achieve any purpose whatsoever).*)
(**(4) My FWB are necessary goods (at least for me).*)
(**(5) I have (maybe nobody else does) a claim right to my FWB.*)
(**(13) Every PPA has a claim right to their FWB.*)

(**The following is a formalized proof for the main conclusion of Gewirth's argument, which
asserts that the following sentence is valid from every PPA's standpoint: "Every PPA has a
claim right to its freedom and well-being (FWB)" *)
theorem PGC: shows "\<lfloor>\<^bold>\<forall>x. PPA x \<^bold>\<rightarrow> (RightTo x FWB)\<rfloor>\<^sup>D"
proof -
 {fix C::c (**'C' is some arbitrarily chosen context (agent's perspective)*)
   {fix I::"e" (**'I' is some arbitrarily chosen individual (agent's perspective)*)
     {fix E::m (**'E' is some arbitrarily chosen purpose*)
      { assume P1: "\<lfloor>ActsOnPurpose I E\<rfloor>\<^sub>C" (**(1) I act voluntarily on purpose E:*)
           (**(1a) I am a PPA:*)
        from P1 have P1a: "\<lfloor>PPA I\<rfloor>\<^sub>C" using PPA_def by auto
           (**(2) purpose E is good for me:*)
        from P1 have C2: "\<lfloor>Good I E\<rfloor>\<^sub>C" using explGoodness1 essentialPPA by meson
           (**(3) I need FWB for any purpose whatsoever:*)
        from explicationFWB1 have C3: "\<lfloor>\<^bold>\<forall>P. NeedsForPurpose I FWB P\<rfloor>\<^sup>D" by simp
        hence "\<exists>P.\<lfloor>Good I P \<^bold>\<and> NeedsForPurpose I FWB P\<rfloor>\<^sup>D"
             using explicationFWB2 explGoodness3 sem_5ab by blast
           (**FWB is (a priori) good for me (in a kind of definitional sense):*)
        hence "\<lfloor>Good I (FWB I)\<rfloor>\<^sup>D" using explGoodness2 by blast
           (**(4) FWB is an (a priori) necessary good for me:*)
        hence C4: "\<lfloor>\<^bold>\<box>\<^sup>D(Good I (FWB I))\<rfloor>\<^sub>C" by simp
         (**I ought to pursue my FWB on the condition that I consider it a necessary good:*)
        have "\<lfloor>\<^bold>O\<langle>FWB I | \<^bold>\<box>\<^sup>D(Good I) (FWB I)\<rangle>\<rfloor>\<^sub>C" using explGoodness3 explicationFWB2 by blast
           (**There is an (other-directed) obligation to my FWB:*)
        hence "\<lfloor>\<^bold>O\<^sub>i(FWB I)\<rfloor>\<^sub>C" using explicationFWB2 explicationFWB3 C4 CJ_14p by fastforce
           (**It must therefore be the case that my FWB is possible:*)
        hence "\<lfloor>\<^bold>O\<^sub>i(\<^bold>\<diamond>\<^sub>a(FWB I))\<rfloor>\<^sub>C" using OIOAC by simp
           (**There is an obligation for others not to interfere with my FWB:*)
        hence "\<lfloor>\<^bold>O\<^sub>i(\<^bold>\<forall>a. \<^bold>\<not>InterferesWith a (FWB I))\<rfloor>\<^sub>C" using InterferenceWithFWB by simp
           (**(5) I have a claim right to my FWB:*)
        hence C5: "\<lfloor>RightTo I FWB\<rfloor>\<^sub>C" using RightTo_def by simp }
      (**I have a claim right to my FWB (since I act on some purpose E):*)
    hence "\<lfloor>ActsOnPurpose I E \<^bold>\<rightarrow> RightTo I FWB\<rfloor>\<^sub>C" by (rule impI) }
      (** "allI" is the logical generalization rule: all-quantifier introduction*)
    hence "\<lfloor>\<^bold>\<forall>P. ActsOnPurpose I P \<^bold>\<rightarrow> RightTo I FWB\<rfloor>\<^sub>C" by (rule allI)
      (**I have a claim right to my FWB since I am a PPA:*)
    hence "\<lfloor>PPA I \<^bold>\<rightarrow> RightTo I FWB\<rfloor>\<^sub>C" using PPA_def by simp }
    (**Every agent has a claim right to its FWB since it is a PPA:*)
  hence "\<forall>x. \<lfloor>PPA x \<^bold>\<rightarrow> RightTo x FWB\<rfloor>\<^sub>C" by simp }
    (**(13) For every perspective C: every agent has a claim right to its FWB:*)
  thus C13: "\<forall>C. \<lfloor>\<^bold>\<forall>x. PPA x \<^bold>\<rightarrow> (RightTo x FWB)\<rfloor>\<^sub>C" by (rule allI)
qed

(**The following is a weaker variant of PGC: the agent of some context claims rights to FWB if it holds itself as a PPA.*)
lemma PGC_weak: "\<forall>C. \<lfloor>PPA (Agent C) \<^bold>\<rightarrow> (RightTo (Agent C) FWB)\<rfloor>\<^sub>C" using PGC by simp

section \<open>An example\<close>

(**In the following, we illustrate how to draw some inferences building upon Gewirth's PGC.
Note that all theorems below can be proven using Isabelle's term rewriting engine.*)

consts X::c (**Context of use X (to which a certain speaker agent corresponds)*)
consts Y::c (**Context of use Y (to which another speaker agent corresponds)*)

(**The agent (of context) X holds itself as a PPA:*)
axiomatization where AgentX_X_PPA: "\<lfloor>PPA (Agent X)\<rfloor>\<^sub>X"

(**The agent (of another context) Y holds the agent (of context) X  as a PPA:*)
lemma AgentY_X_PPA: "\<lfloor>PPA (Agent X)\<rfloor>\<^sub>Y" using AgentX_X_PPA recognizeOtherPPA by simp

(**Now the agent (of context) Y holds itself as a PPA: *)
axiomatization where AgentY_Y_PPA: "\<lfloor>PPA (Agent Y)\<rfloor>\<^sub>Y"

(**The agent Y claims a right to FWB:*)
lemma AgentY_Y_FWB: "\<lfloor>RightTo (Agent Y) FWB\<rfloor>\<^sub>Y" using AgentY_Y_PPA PGC_weak by simp

(**The agent Y accepts X claiming a right to FWB:*)
lemma AgentY_X_FWB: "\<lfloor>RightTo (Agent X) FWB\<rfloor>\<^sub>Y" using AgentY_X_PPA PGC by simp

(**The agent Y accepts an (other-directed) obligation of non-interference with X's FWB:*)
lemma AgentY_NonInterference_X_FWB: "\<lfloor>\<^bold>O\<^sub>i(\<^bold>\<forall>z. \<^bold>\<not>InterferesWith z (FWB (Agent X)))\<rfloor>\<^sub>Y" using AgentY_X_FWB RightTo_def by simp

(**Axiom consistency checked: Nitpick finds a two-world model (card w=2).*)
lemma True nitpick[satisfy, card c = 1, card e = 1, card w = 2] oops

end


theory MDEAK_examples
imports Main MDEAK_Core_SE MDEAK_SE MDEAK_method
begin

lemma l1: "\<turnstile>d (A \<^sub>F)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (A \<^sub>F)\<^sub>S\<^sub>F\<^sub>M"
(*by (rule Id_fm)   *)
using [[simp_trace_new mode=full]]
by mdeak

lemma l2: "\<turnstile>d Y \<turnstile>\<^sub>F\<^sub>M ((A \<^sub>F) \<^sub>S\<^sub>F\<^sub>M) \<rightarrow>\<^sub>S ((A \<^sub>F) \<^sub>S\<^sub>F\<^sub>M)"
using [[simp_trace_new mode=full]]
(*by mdeak*)
by (simp only: W_2L l1)
(*by (simp only: derivable.intros)
by (simp only: derivable.simps)
by (simp only: derivable.cases)
by (simp only: derivable.induct)*)
(*by (simp only: IW_L I_2L_f Id_fm )*)
(*apply (rule IW_L)
apply (rule I_2L_f)
apply (rule Id)
done*)

lemma l3: "\<turnstile>d Y \<turnstile>\<^sub>F\<^sub>M ((A \<^sub>F) \<rightarrow>\<^sub>F (A \<^sub>F))\<^sub>S\<^sub>F\<^sub>M"
using [[simp_trace_new mode=full]]
apply(rule ImpR_R)
apply(rule l2)
done
(*using Bot_L IW_L I_2L_f ImpR_R by blast*)

lemma step1 : "\<turnstile>d (a)\<^sub>S\<^sub>A\<^sub>C \<turnstile>\<^sub>A\<^sub>C (a)\<^sub>S\<^sub>A\<^sub>C"
(*sledgehammer*)
by (metis Action.exhaust Bdiam3_L Bdiam3_R Fdiam3_L Fdiam3_R Id_ag Id_fa)

theorem AderivesA : "\<turnstile>d (A)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (A)\<^sub>S\<^sub>F\<^sub>M"
apply(induction A)
apply (simp add: l1)
apply (simp add: Top_L Top_R)
apply (simp add: Bot_L Bot_R)
apply (simp add: And_L And_R)
apply (simp add: Or_L Or_R)
apply (simp add: ImpR_L ImpR_R)
apply (simp add: ImpL_L ImpL_R)
apply (simp add: DimpR_L DimpR_R)
apply (simp add: DimpL_L DimpL_R)
apply (simp add: Fdiam0_L Fdiam0_R Id_fa)
apply (simp add: Fbox0_L Fbox0_R Id_fa)
apply (simp add: Fdiam1_L Fdiam1_R step1)
apply (simp add: Fbox1_L Fbox1_R step1)
apply (simp add: Fdiam2_L Fdiam2_R Id_ag)
apply (simp add: Fbox2_L Fbox2_R Id_ag)
apply (simp add: Bdiam0_L Bdiam0_R Id_fa)
apply (simp add: Bbox0_L Bbox0_R Id_fa)
apply (simp add: Bdiam1_L Bdiam1_R step1)
apply (simp add: Bbox1_L Bbox1_R step1)
apply (simp add: Bdiam2_L Bdiam2_R Id_ag)
by (simp add: Bbox2_L Bbox2_R Id_ag)
end