section \<open>Extended Finite State Machines\<close>

text\<open>This theory defines extended finite state machines as presented in \<^cite>\<open>"foster2018"\<close>. States
are indexed by natural numbers, however, since transition matrices are implemented by finite sets,
the number of reachable states in $S$ is necessarily finite. For ease of implementation, we
implicitly make the initial state zero for all EFSMs. This allows EFSMs to be represented purely by
their transition matrix which, in this implementation, is a finite set of tuples of the form
$((s_1, s_2), t)$ in which $s_1$ is the origin state, $s_2$ is the destination state, and $t$ is a
transition.\<close>

theory EFSM
  imports "HOL-Library.FSet" Transition FSet_Utils
begin

declare One_nat_def [simp del]

type_synonym cfstate = nat
type_synonym inputs = "value list"
type_synonym outputs = "value option list"

type_synonym action = "(label \<times> inputs)"
type_synonym execution = "action list"
type_synonym observation = "outputs list"
type_synonym transition_matrix = "((cfstate \<times> cfstate) \<times> transition) fset"

no_notation relcomp (infixr "O" 75) and comp (infixl "o" 55)

type_synonym event = "(label \<times> inputs \<times> value list)"
type_synonym trace = "event list"
type_synonym log = "trace list"

definition Str :: "string \<Rightarrow> value" where
  "Str s \<equiv> value.Str (String.implode s)"

lemma str_not_num: "Str s \<noteq> Num x1"
  by (simp add: Str_def)

definition S :: "transition_matrix \<Rightarrow> nat fset" where
  "S m = (fimage (\<lambda>((s, s'), t). s) m) |\<union>| fimage (\<lambda>((s, s'), t). s') m"

lemma S_ffUnion: "S e = ffUnion (fimage (\<lambda>((s, s'), _). {|s, s'|}) e)"
  unfolding S_def
  by(induct e, auto)

subsection\<open>Possible Steps\<close>
text\<open>From a given state, the possible steps for a given action are those transitions with labels
which correspond to the action label, arities which correspond to the number of inputs, and guards
which are satisfied by those inputs.\<close>

definition possible_steps :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> label \<Rightarrow> inputs \<Rightarrow> (cfstate \<times> transition) fset" where
  "possible_steps e s r l i = fimage (\<lambda>((origin, dest), t). (dest, t)) (ffilter (\<lambda>((origin, dest), t). origin = s \<and> (Label t) = l \<and> (length i) = (Arity t) \<and> apply_guards (Guards t) (join_ir i r)) e)"

lemma possible_steps_finsert:
"possible_steps (finsert ((s, s'), t) e) ss r l i = (
  if s = ss \<and> (Label t) = l \<and> (length i) = (Arity t) \<and> apply_guards (Guards t) (join_ir i r) then
    finsert (s', t) (possible_steps e s r l i)
  else
    possible_steps e ss r l i
)"
  by (simp add: possible_steps_def ffilter_finsert)

lemma split_origin:
"ffilter (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> can_take_transition t i r) e =
ffilter (\<lambda>((origin, dest), t). Label t = l \<and> can_take_transition t i r) (ffilter (\<lambda>((origin, dest), t). origin = s) e)"
  by auto

lemma split_label:
"ffilter (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> can_take_transition t i r) e =
ffilter (\<lambda>((origin, dest), t). origin = s \<and> can_take_transition t i r) (ffilter (\<lambda>((origin, dest), t). Label t = l) e)"
  by auto

lemma possible_steps_empty_guards_false:
  "\<forall>((s1, s2), t) |\<in>| ffilter (\<lambda>((origin, dest), t). Label t = l) e. \<not>can_take_transition t i r \<Longrightarrow>
  possible_steps e s r l i = {||}"
  apply (simp add: possible_steps_def can_take[symmetric] split_label)
  by (simp add: Abs_ffilter fBall_def Ball_def)

lemma fmember_possible_steps: "(s', t) |\<in>| possible_steps e s r l i = (((s, s'), t) \<in> {((origin, dest), t) \<in> fset e. origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)})"
  apply (simp add: possible_steps_def ffilter_def fimage_def fmember_def Abs_fset_inverse)
  by force

lemma possible_steps_alt_aux:
  "possible_steps e s r l i = {|(d, t)|} \<Longrightarrow>
       ffilter (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)) e = {|((s, d), t)|}"
proof(induct e)
  case empty
  then show ?case
    by (simp add: fempty_not_finsert possible_steps_def)
next
  case (insert x e)
  then show ?case
    apply (case_tac x)
    subgoal for a b
      apply (case_tac a)
      subgoal for aa _
        apply (simp add: possible_steps_def)
        apply (simp add: ffilter_finsert)
        apply (case_tac "aa = s \<and> Label b = l \<and> length i = Arity b \<and> apply_guards (Guards b) (join_ir i r)")
        by auto
      done
    done
qed

lemma possible_steps_alt: "(possible_steps e s r l i = {|(d, t)|}) = (ffilter
     (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r))
     e = {|((s, d), t)|})"
  apply standard
   apply (simp add: possible_steps_alt_aux)
  by (simp add: possible_steps_def)

lemma possible_steps_alt3: "(possible_steps e s r l i = {|(d, t)|}) = (ffilter
     (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> can_take_transition t i r)
     e = {|((s, d), t)|})"
  apply standard
   apply (simp add: possible_steps_alt_aux can_take)
  by (simp add: possible_steps_def can_take)

lemma possible_steps_alt_atom: "(possible_steps e s r l i = {|dt|}) = (ffilter
     (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> can_take_transition t i r)
     e = {|((s, fst dt), snd dt)|})"
  apply (cases dt)
  by (simp add: possible_steps_alt can_take_transition_def can_take_def)

lemma possible_steps_alt2: "(possible_steps e s r l i = {|(d, t)|}) = (
     (ffilter (\<lambda>((origin, dest), t). Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)) (ffilter (\<lambda>((origin, dest), t). origin = s) e) = {|((s, d), t)|}))"
  apply (simp add: possible_steps_alt)
  apply (simp only: filter_filter)
  apply (rule arg_cong [of "(\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r))"])
  by (rule ext, auto)

lemma possible_steps_single_out:
"ffilter (\<lambda>((origin, dest), t). origin = s) e = {|((s, d), t)|} \<Longrightarrow>
Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r) \<Longrightarrow>
possible_steps e s r l i = {|(d, t)|}"
  apply (simp add: possible_steps_alt2 Abs_ffilter)
  by blast

lemma possible_steps_singleton: "(possible_steps e s r l i = {|(d, t)|}) =
    ({((origin, dest), t) \<in> fset e. origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)} = {((s, d), t)})"
  apply (simp add: possible_steps_alt Abs_ffilter Set.filter_def)
  by fast

lemma possible_steps_apply_guards:
  "possible_steps e s r l i = {|(s', t)|} \<Longrightarrow>
   apply_guards (Guards t) (join_ir i r)"
  apply (simp add: possible_steps_singleton)
  by auto

lemma possible_steps_empty:
  "(possible_steps e s r l i = {||}) = (\<forall>((origin, dest), t) \<in> fset e. origin \<noteq> s \<or> Label t \<noteq> l \<or> \<not> can_take_transition t i r)"
  apply (simp add: can_take_transition_def can_take_def)
  apply (simp add: possible_steps_def Abs_ffilter Set.filter_def)
  by auto

lemma singleton_dest:
  assumes "fis_singleton (possible_steps e s r aa b)"
      and "fthe_elem (possible_steps e s r aa b) = (baa, aba)"
    shows "((s, baa), aba) |\<in>| e"
  using assms
  apply (simp add: fis_singleton_fthe_elem)
  using possible_steps_alt_aux by force

lemma ffilter_split: "ffilter (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)) e =
                      ffilter (\<lambda>((origin, dest), t). Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)) (ffilter (\<lambda>((origin, dest), t). origin = s) e)"
  by auto

subsection\<open>Choice\<close>
text\<open>Here we define the \texttt{choice} operator which determines whether or not two transitions are
nondeterministic.\<close>

definition choice :: "transition \<Rightarrow> transition \<Rightarrow> bool" where
  "choice t t' = (\<exists> i r. apply_guards (Guards t) (join_ir i r) \<and> apply_guards (Guards t') (join_ir i r))"

definition choice_alt :: "transition \<Rightarrow> transition \<Rightarrow> bool" where
  "choice_alt t t' = (\<exists> i r. apply_guards (Guards t@Guards t') (join_ir i r))"

lemma choice_alt: "choice t t' = choice_alt t t'"
  by (simp add: choice_def choice_alt_def apply_guards_append)

lemma choice_symmetry: "choice x y = choice y x"
  using choice_def by auto

definition deterministic :: "transition_matrix \<Rightarrow> bool" where
  "deterministic e = (\<forall>s r l i. size (possible_steps e s r l i) \<le> 1)"

lemma deterministic_alt_aux: "size (possible_steps e s r l i) \<le> 1 =(
        possible_steps e s r l i = {||} \<or>
        (\<exists>s' t.
            ffilter
             (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)) e =
            {|((s, s'), t)|}))"
  apply (case_tac "size (possible_steps e s r l i) = 0")
   apply (simp add: fset_equiv)
  apply (case_tac "possible_steps e s r l i = {||}")
   apply simp
  apply (simp only: possible_steps_alt[symmetric])
  by (metis le_neq_implies_less le_numeral_extra(4) less_one prod.collapse size_fsingleton)

lemma size_le_1: "size f \<le> 1 = (f = {||} \<or> (\<exists>e. f = {|e|}))"
  apply standard
   apply (metis bot.not_eq_extremum gr_implies_not0 le_neq_implies_less less_one size_fsingleton size_fsubset)
  by auto

lemma ffilter_empty_if: "\<forall>x |\<in>| xs. \<not> P x \<Longrightarrow> ffilter P xs = {||}"
  by auto

lemma empty_ffilter: "ffilter P xs = {||} = (\<forall>x |\<in>| xs. \<not> P x)"
  by auto

lemma all_states_deterministic:
"(\<forall>s l i r.
  ffilter (\<lambda>((origin, dest), t). origin = s \<and> (Label t) = l \<and> can_take_transition t i r) e = {||} \<or>
  (\<exists>x. ffilter (\<lambda>((origin, dest), t). origin = s \<and> (Label t) = l \<and> can_take_transition t i r) e = {|x|})
) \<Longrightarrow> deterministic e"
  unfolding deterministic_def
  apply clarify
  subgoal for s r l i
    apply (erule_tac x=s in allE)
    apply (erule_tac x=l in allE)
    apply (erule_tac x=i in allE)
    apply (erule_tac x=r in allE)
    apply (simp only: size_le_1)
    apply (erule disjE)
     apply (rule_tac disjI1)
     apply (simp add: possible_steps_def can_take_transition_def can_take_def)
    apply (erule exE)
    subgoal for x
      apply (case_tac x)
      subgoal for a b
        apply (case_tac a)
        apply simp
        apply (induct e)
         apply auto[1]
        subgoal for _ _ _ ba
          apply (rule disjI2)
          apply (rule_tac x=ba in exI)
          apply (rule_tac x=b in exI)
          by (simp add: possible_steps_def can_take_transition_def[symmetric] can_take_def[symmetric])
        done
      done
    done
  done

lemma deterministic_finsert:
"\<forall>i r l.
\<forall>((a, b), t) |\<in>| ffilter (\<lambda>((origin, dest), t). origin = s) (finsert ((s, s'), t') e).
Label t = l \<and> can_take_transition t i r \<longrightarrow> \<not> can_take_transition t' i r \<Longrightarrow>
deterministic e \<Longrightarrow>
deterministic (finsert ((s, s'), t') e)"
  apply (simp add: deterministic_def possible_steps_finsert can_take del: size_fset_overloaded_simps)
  apply clarify
  subgoal for r i
    apply (erule_tac x=s in allE)
    apply (erule_tac x=r in allE)
    apply (erule_tac x="Label t'" in allE)
    apply (erule_tac x=i in allE)
    apply (erule_tac x=r in allE)
    apply (erule_tac x=i in allE)
    apply (erule_tac x="Label t'" in allE)
    by auto
  done

lemma ffilter_fBall: "(\<forall>x |\<in>| xs. P x) = (ffilter P xs = xs)"
  by auto

lemma fsubset_if: "\<forall>x. x |\<in>| f1 \<longrightarrow> x |\<in>| f2 \<Longrightarrow> f1 |\<subseteq>| f2"
  by auto

lemma in_possible_steps: "(((s, s'), t)|\<in>|e \<and> Label t = l \<and> can_take_transition t i r) = ((s', t) |\<in>| possible_steps e s r l i)"
  apply (simp add: fmember_possible_steps)
  by (simp add: can_take_def can_take_transition_def fmember_iff_member_fset)

lemma possible_steps_can_take_transition:
  "(s2, t1) |\<in>| possible_steps e1 s1 r l i \<Longrightarrow> can_take_transition t1 i r"
  using in_possible_steps by blast

lemma not_deterministic:
  "\<exists>s l i r.
    \<exists>d1 d2 t1 t2.
      d1 \<noteq> d2 \<and> t1 \<noteq> t2 \<and>
      ((s, d1), t1) |\<in>| e \<and>
      ((s, d2), t2) |\<in>| e \<and>
      Label t1 = Label t2 \<and>
      can_take_transition t1 i r \<and>
      can_take_transition t2 i r \<Longrightarrow>
  \<not>deterministic e"
  apply (simp add: deterministic_def not_le del: size_fset_overloaded_simps)
  apply clarify
  subgoal for s i r d1 d2 t1 t2
    apply (rule_tac x=s in exI)
    apply (rule_tac x=r in exI)
    apply (rule_tac x="Label t1" in exI)
    apply (rule_tac x=i in exI)
    apply (case_tac "(d1, t1) |\<in>| possible_steps e s r (Label t1) i")
     defer using in_possible_steps apply blast
    apply (case_tac "(d2, t2) |\<in>| possible_steps e s r (Label t1) i")
     apply (metis fempty_iff fsingleton_iff not_le_imp_less prod.inject size_le_1)
    using in_possible_steps by force
  done

lemma not_deterministic_conv:
  "\<not>deterministic e \<Longrightarrow>
  \<exists>s l i r.
    \<exists>d1 d2 t1 t2.
      (d1 \<noteq> d2 \<or> t1 \<noteq> t2) \<and>
      ((s, d1), t1) |\<in>| e \<and>
      ((s, d2), t2) |\<in>| e \<and>
      Label t1 = Label t2 \<and>
      can_take_transition t1 i r \<and>
      can_take_transition t2 i r"
  apply (simp add: deterministic_def not_le del: size_fset_overloaded_simps)
  apply clarify
  subgoal for s r l i
    apply (case_tac "\<exists>e1 e2 f'. e1 \<noteq> e2 \<and> possible_steps e s r l i = finsert e1 (finsert e2 f')")
     defer using size_gt_1 apply blast
    apply (erule exE)+
    subgoal for e1 e2 f'
      apply (case_tac e1, case_tac e2)
      subgoal for a b aa ba
        apply (simp del: size_fset_overloaded_simps)
        apply (rule_tac x=s in exI)
        apply (rule_tac x=i in exI)
        apply (rule_tac x=r in exI)
        apply (rule_tac x=a in exI)
        apply (rule_tac x=aa in exI)
        apply (rule_tac x=b in exI)
        apply (rule_tac x=ba in exI)
        by (metis finsertI1 finsert_commute in_possible_steps)
      done
    done
  done

lemma deterministic_if:
"\<nexists>s l i r.
  \<exists>d1 d2 t1 t2.
    (d1 \<noteq> d2 \<or> t1 \<noteq> t2) \<and>
    ((s, d1), t1) |\<in>| e \<and>
    ((s, d2), t2) |\<in>| e \<and>
    Label t1 = Label t2 \<and>
    can_take_transition t1 i r \<and>
    can_take_transition t2 i r \<Longrightarrow>
  deterministic e"
  using not_deterministic_conv by blast

lemma "\<forall>l i r.
  (\<forall>((s, s'), t) |\<in>| e. Label t = l \<and> can_take_transition t i r \<and>
  (\<nexists>t' s''. ((s, s''), t') |\<in>| e \<and> (s' \<noteq> s'' \<or> t' \<noteq> t) \<and> Label t' = l \<and> can_take_transition t' i r))
 \<Longrightarrow> deterministic e"
  apply (simp add: deterministic_def del: size_fset_overloaded_simps)
  apply (rule allI)+
  apply (simp only: size_le_1 possible_steps_empty)
  apply (case_tac "\<exists>t s'. ((s, s'), t)|\<in>|e \<and> Label t = l \<and> can_take_transition t i r")
   defer using notin_fset apply fastforce
  apply (rule disjI2)
  apply clarify
  apply (rule_tac x="(s', t)" in exI)
  apply standard
   defer apply (meson fempty_fsubsetI finsert_fsubset in_possible_steps)
  apply standard
  apply (case_tac x)
  apply (simp add: in_possible_steps[symmetric])
  apply (erule_tac x="Label t" in allE)
  apply (erule_tac x=i in allE)
  apply (erule_tac x=r in allE)
  apply (erule_tac x="((s, s'), t)" in fBallE)
   defer apply simp
  apply simp
  apply (erule_tac x=b in allE)
  apply simp
  apply (erule_tac x=a in allE)
  by simp

definition "outgoing_transitions e s = ffilter (\<lambda>((o, _), _). o = s) e"

lemma in_outgoing: "((s1, s2), t) |\<in>| outgoing_transitions e s = (((s1, s2), t) |\<in>| e \<and> s1 = s)"
  by (simp add: outgoing_transitions_def)

lemma outgoing_transitions_deterministic:
  "\<forall>s.
    \<forall>((s1, s2), t) |\<in>| outgoing_transitions e s.
      \<forall>((s1', s2'), t') |\<in>| outgoing_transitions e s.
        s2 \<noteq> s2' \<or> t \<noteq> t' \<longrightarrow> Label t = Label t' \<longrightarrow> \<not> choice t t' \<Longrightarrow> deterministic e"
  apply (rule deterministic_if)
  apply simp
  apply (rule allI)
  subgoal for s
    apply (erule_tac x=s in allE)
    apply (simp add: fBall_def Ball_def)
    apply (rule allI)+
    subgoal for i r d1 d2 t1
      apply (erule_tac x=s in allE)
      apply (erule_tac x=d1 in allE)
      apply (erule_tac x=t1 in allE)
      apply (rule impI, rule allI)
      subgoal for t2
        apply (case_tac "((s, d1), t1) \<in> fset (outgoing_transitions e s)")
         apply simp
         apply (erule_tac x=s in allE)
         apply (erule_tac x=d2 in allE)
         apply (erule_tac x=t2 in allE)
         apply (simp add: outgoing_transitions_def choice_def can_take)
         apply (meson fmember_implies_member)
        apply (simp add: outgoing_transitions_def)
        by (meson fmember_implies_member)
      done
    done
  done

lemma outgoing_transitions_deterministic2: "(\<And>s a b ba aa bb bc.
       ((a, b), ba) |\<in>| outgoing_transitions e s \<Longrightarrow>
       ((aa, bb), bc) |\<in>| (outgoing_transitions e s) - {|((a, b), ba)|} \<Longrightarrow> b \<noteq> bb \<or> ba \<noteq> bc \<Longrightarrow> \<not>choice ba bc)
        \<Longrightarrow> deterministic e"
  apply (rule outgoing_transitions_deterministic)
  by blast

lemma outgoing_transitions_fprod_deterministic:
"(\<And>s b ba bb bc.
(((s, b), ba), ((s, bb), bc)) \<in> fset (outgoing_transitions e s) \<times> fset (outgoing_transitions e s)
\<Longrightarrow> b \<noteq> bb \<or> ba \<noteq> bc \<Longrightarrow> Label ba = Label bc \<Longrightarrow> \<not>choice ba bc)
\<Longrightarrow> deterministic e"
  apply (rule outgoing_transitions_deterministic)
  apply clarify
  by (metis SigmaI fmember_implies_member in_outgoing)

text\<open>The \texttt{random\_member} function returns a random member from a finite set, or
\texttt{None}, if the set is empty.\<close>
definition random_member :: "'a fset \<Rightarrow> 'a option" where
  "random_member f = (if f = {||} then None else Some (Eps (\<lambda>x. x |\<in>| f)))"

lemma random_member_nonempty: "s \<noteq> {||} = (random_member s \<noteq> None)"
  by (simp add: random_member_def)

lemma random_member_is_member:
  "random_member ss = Some s \<Longrightarrow> s |\<in>| ss"
  apply (simp add: random_member_def)
  by (metis equalsffemptyI option.distinct(1) option.inject verit_sko_ex_indirect)

lemma random_member_None[simp]: "random_member ss = None = (ss = {||})"
  by (simp add: random_member_def)

lemma random_member_empty[simp]: "random_member {||} = None"
  by simp

definition step :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> label \<Rightarrow> inputs \<Rightarrow> (transition \<times> cfstate \<times> outputs \<times> registers) option" where
  "step e s r l i = (case random_member (possible_steps e s r l i) of
      None \<Rightarrow> None |
      Some (s', t) \<Rightarrow>  Some (t, s', evaluate_outputs t i r, evaluate_updates t i r)
  )"

lemma possible_steps_not_empty_iff:
  "step e s r a b \<noteq> None \<Longrightarrow>
   \<exists>aa ba. (aa, ba) |\<in>| possible_steps e s r a b"
  apply (simp add: step_def)
  apply (case_tac "possible_steps e s r a b")
   apply (simp add: random_member_def)
  by auto

lemma step_member: "step e s r l i = Some (t, s', p, r') \<Longrightarrow> (s', t) |\<in>| possible_steps e s r l i"
  apply (simp add: step_def)
  apply (case_tac "random_member (possible_steps e s r l i)")
   apply simp
  subgoal for a by (case_tac a, simp add: random_member_is_member)
  done

lemma step_outputs: "step e s r l i = Some (t, s', p, r') \<Longrightarrow> evaluate_outputs t i r = p"
  apply (simp add: step_def)
  apply (case_tac "random_member (possible_steps e s r l i)")
  by auto

lemma step:
  "possibilities = (possible_steps e s r l i) \<Longrightarrow>
   random_member possibilities = Some (s', t) \<Longrightarrow>
   evaluate_outputs t i r = p \<Longrightarrow>
   evaluate_updates t i r = r' \<Longrightarrow>
   step e s r l i = Some (t, s', p, r')"
  by (simp add: step_def)

lemma step_None: "step e s r l i = None = (possible_steps e s r l i = {||})"
  by (simp add: step_def prod.case_eq_if random_member_def)

lemma step_Some: "step e s r l i = Some (t, s', p, r') =
  (
    random_member (possible_steps e s r l i) = Some (s', t) \<and>
    evaluate_outputs t i r = p \<and>
    evaluate_updates t i r = r'
  )"
  apply (simp add: step_def)
  apply (case_tac "random_member (possible_steps e s r l i)")
   apply simp
  subgoal for a by (case_tac a, auto)
  done

lemma no_possible_steps_1:
  "possible_steps e s r l i = {||} \<Longrightarrow> step e s r l i = None"
  by (simp add: step_def random_member_def)

subsection\<open>Execution Observation\<close>
text\<open>One of the key features of this formalisation of EFSMs is their ability to produce
\emph{outputs}, which represent function return values. When action sequences are executed in an
EFSM, they produce a corresponding \emph{observation}.\<close>

text_raw\<open>\snip{observe}{1}{2}{%\<close>
fun observe_execution :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> outputs list" where
  "observe_execution _ _ _ [] = []" |
  "observe_execution e s r ((l, i)#as)  = (
    let viable = possible_steps e s r l i in
    if viable = {||} then
      []
    else
      let (s', t) = Eps (\<lambda>x. x |\<in>| viable) in
      (evaluate_outputs t i r)#(observe_execution e s' (evaluate_updates t i r) as)
    )"
text_raw\<open>}%endsnip\<close>

lemma observe_execution_step_def: "observe_execution e s r ((l, i)#as)  = (
    case step e s r l i of
      None \<Rightarrow> []|
      Some (t, s', p, r') \<Rightarrow> p#(observe_execution e s' r' as)
    )"
  apply (simp add: step_def)
  apply (case_tac "possible_steps e s r l i")
   apply simp
  subgoal for x S'
    apply (simp add: random_member_def)
    apply (case_tac "SOME xa. xa = x \<or> xa |\<in>| S'")
    by simp
  done

lemma observe_execution_first_outputs_equiv:
  "observe_execution e1 s1 r1 ((l, i) # ts) = observe_execution e2 s2 r2 ((l, i) # ts) \<Longrightarrow>
   step e1 s1 r1 l i = Some (t, s', p, r') \<Longrightarrow>
   \<exists>(s2', t2)|\<in>|possible_steps e2 s2 r2 l i. evaluate_outputs t2 i r2 = p"
  apply (simp only: observe_execution_step_def)
  apply (case_tac "step e2 s2 r2 l i")
   apply simp
  subgoal for a
    apply simp
    apply (case_tac a)
    apply clarsimp
    by (meson step_member case_prodI rev_fBexI step_outputs)
  done

lemma observe_execution_step:
  "step e s r (fst h) (snd h) = Some (t, s', p, r') \<Longrightarrow>
   observe_execution e s' r' es = obs \<Longrightarrow>
   observe_execution e s r (h#es) = p#obs"
  apply (cases h, simp add: step_def)
  apply (case_tac "possible_steps e s r a b = {||}")
   apply simp
  subgoal for a b
    apply (case_tac "SOME x. x |\<in>| possible_steps e s r a b")
    by (simp add: random_member_def)
  done

lemma observe_execution_possible_step:
  "possible_steps e s r (fst h) (snd h) = {|(s', t)|} \<Longrightarrow>
   apply_outputs (Outputs t) (join_ir (snd h) r) = p \<Longrightarrow>
   apply_updates (Updates t) (join_ir (snd h) r) r = r' \<Longrightarrow>
   observe_execution e s' r' es = obs \<Longrightarrow>
   observe_execution e s r (h#es) = p#obs"
  by (simp add: observe_execution_step step)

lemma observe_execution_no_possible_step:
  "possible_steps e s r (fst h) (snd h) = {||} \<Longrightarrow>
   observe_execution e s r (h#es) = []"
  by (cases h, simp)

lemma observe_execution_no_possible_steps:
  "possible_steps e1 s1 r1 (fst h) (snd h) = {||} \<Longrightarrow>
   possible_steps e2 s2 r2 (fst h) (snd h) = {||} \<Longrightarrow>
   (observe_execution e1 s1 r1 (h#t)) = (observe_execution e2 s2 r2 (h#t))"
  by (simp add: observe_execution_no_possible_step)

lemma observe_execution_one_possible_step:
  "possible_steps e1 s1 r (fst h) (snd h) = {|(s1', t1)|} \<Longrightarrow>
   possible_steps e2 s2 r (fst h) (snd h) = {|(s2', t2)|} \<Longrightarrow>
   apply_outputs (Outputs t1) (join_ir (snd h) r) = apply_outputs (Outputs t2) (join_ir (snd h) r) \<Longrightarrow>

   apply_updates (Updates t1) (join_ir (snd h) r) r = r' \<Longrightarrow>
   apply_updates (Updates t2) (join_ir (snd h) r) r = r' \<Longrightarrow>
   (observe_execution e1 s1' r' t) = (observe_execution e2 s2' r' t) \<Longrightarrow>
   (observe_execution e1 s1 r (h#t)) = (observe_execution e2 s2 r (h#t))"
  by (simp add: observe_execution_possible_step)

subsubsection\<open>Utilities\<close>
text\<open>Here we define some utility functions to access the various key properties of a given EFSM.\<close>

definition max_reg :: "transition_matrix \<Rightarrow> nat option" where
  "max_reg e = (let maxes = (fimage (\<lambda>(_, t). Transition.max_reg t) e) in if maxes = {||} then None else fMax maxes)"

definition enumerate_ints :: "transition_matrix \<Rightarrow> int set" where
  "enumerate_ints e = \<Union> (image (\<lambda>(_, t). Transition.enumerate_ints t) (fset e))"

definition max_int :: "transition_matrix \<Rightarrow> int" where
  "max_int e = Max (insert 0 (enumerate_ints e))"

definition max_output :: "transition_matrix \<Rightarrow> nat" where
  "max_output e = fMax (fimage (\<lambda>(_, t). length (Outputs t)) e)"

definition all_regs :: "transition_matrix \<Rightarrow> nat set" where
  "all_regs e = \<Union> (image (\<lambda>(_, t). enumerate_regs t) (fset e))"

text_raw\<open>\snip{finiteRegs}{1}{2}{%\<close>
lemma finite_all_regs: "finite (all_regs e)"
text_raw\<open>}%endsnip\<close>
  apply (simp add: all_regs_def enumerate_regs_def)
  apply clarify
  apply standard
   apply (rule finite_UnI)+
  using GExp.finite_enumerate_regs apply blast
  using AExp.finite_enumerate_regs apply blast
   apply (simp add: AExp.finite_enumerate_regs prod.case_eq_if)
  by auto

definition max_input :: "transition_matrix \<Rightarrow> nat option" where
  "max_input e = fMax (fimage (\<lambda>(_, t). Transition.max_input t) e)"

fun maxS :: "transition_matrix \<Rightarrow> nat" where
  "maxS t = (if t = {||} then 0 else fMax ((fimage (\<lambda>((origin, dest), t). origin) t) |\<union>| (fimage (\<lambda>((origin, dest), t). dest) t)))"

subsection\<open>Execution Recognition\<close>
text\<open>The \texttt{recognises} function returns true if the given EFSM recognises a given execution.
That is, the EFSM is able to respond to each event in sequence. There is no restriction on the
outputs produced. When a recognised execution is observed, it produces an accepted trace of the
EFSM.\<close>

text_raw\<open>\snip{recognises}{1}{2}{%\<close>
inductive recognises_execution :: "transition_matrix \<Rightarrow> nat \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
  base [simp]: "recognises_execution e s r []" |
  step: "\<exists>(s', T) |\<in>| possible_steps e s r l i.
         recognises_execution e s' (evaluate_updates T i r) t \<Longrightarrow>
         recognises_execution e s r ((l, i)#t)"
text_raw\<open>}%endsnip\<close>

abbreviation "recognises e t \<equiv> recognises_execution e 0 <> t"

definition "E e = {x. recognises e x}"

lemma no_possible_steps_rejects:
  "possible_steps e s r l i = {||} \<Longrightarrow> \<not> recognises_execution e s r ((l, i)#t)"
  apply clarify
  by (rule recognises_execution.cases, auto)

lemma recognises_step_equiv: "recognises_execution e s r ((l, i)#t) =
   (\<exists>(s', T) |\<in>| possible_steps e s r l i. recognises_execution e s' (evaluate_updates T i r) t)"
  apply standard
   apply (rule recognises_execution.cases)
  by (auto simp: recognises_execution.step)

fun recognises_prim :: "transition_matrix \<Rightarrow> nat \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
  "recognises_prim e s r [] = True" |
  "recognises_prim e s r ((l, i)#t) = (
    let poss_steps = possible_steps e s r l i in
    (\<exists>(s', T) |\<in>| poss_steps. recognises_prim e s' (evaluate_updates T i r) t)
  )"

lemma recognises_prim [code]: "recognises_execution e s r t = recognises_prim e s r t"
proof(induct t arbitrary: r s)
  case Nil
  then show ?case
    by simp
next
  case (Cons h t)
  then show ?case
    apply (cases h)
    apply simp
    apply standard
     apply (rule recognises_execution.cases, simp)
      apply simp
     apply auto[1]
    using recognises_execution.step by blast
qed

lemma recognises_single_possible_step:
  assumes "possible_steps e s r l i = {|(s', t)|}"
      and "recognises_execution e s' (evaluate_updates t i r) trace"
    shows "recognises_execution e s r ((l, i)#trace)"
  apply (rule recognises_execution.step)
  using assms by auto

lemma recognises_single_possible_step_atomic:
  assumes "possible_steps e s r (fst h) (snd h) = {|(s', t)|}"
      and "recognises_execution e s' (apply_updates (Updates t) (join_ir (snd h) r) r) trace"
    shows "recognises_execution e s r (h#trace)"
  by (metis assms prod.collapse recognises_single_possible_step)

lemma recognises_must_be_possible_step:
  "recognises_execution e s r (h # t) \<Longrightarrow>
   \<exists>aa ba. (aa, ba) |\<in>| possible_steps e s r (fst h) (snd h)"
  using recognises_step_equiv by fastforce

lemma recognises_possible_steps_not_empty:
  "recognises_execution e s r (h#t) \<Longrightarrow> possible_steps e s r (fst h) (snd h) \<noteq> {||}"
  apply (rule recognises_execution.cases)
  by auto

lemma recognises_must_be_step:
  "recognises_execution e s r (h#ts) \<Longrightarrow>
   \<exists>t s' p d'. step e s r (fst h) (snd h) = Some (t, s', p, d')"
  apply (cases h)
  subgoal for a b
    apply (simp add: recognises_step_equiv step_def)
    apply clarify
    apply (case_tac "(possible_steps e s r a b)")
     apply (simp add: random_member_def)
    apply (simp add: random_member_def)
    subgoal for _ _ x S' apply (case_tac "SOME xa. xa = x \<or> xa |\<in>| S'")
      by simp
    done
  done

lemma recognises_cons_step:
  "recognises_execution e s r (h # t) \<Longrightarrow> step e s r (fst h) (snd h) \<noteq>  None"
  by (simp add: recognises_must_be_step)

lemma no_step_none:
  "step e s r aa ba = None \<Longrightarrow> \<not> recognises_execution e s r ((aa, ba) # p)"
  using recognises_cons_step by fastforce

lemma step_none_rejects:
  "step e s r (fst h) (snd h) = None \<Longrightarrow> \<not> recognises_execution e s r (h#t)"
  using no_step_none surjective_pairing by fastforce

lemma trace_reject:
  "(\<not> recognises_execution e s r ((l, i)#t)) = (possible_steps e s r l i = {||} \<or> (\<forall>(s', T) |\<in>| possible_steps e s r l i. \<not> recognises_execution e s' (evaluate_updates T i r) t))"
  using recognises_prim by fastforce

lemma trace_reject_no_possible_steps_atomic:
  "possible_steps e s r (fst a) (snd a) = {||} \<Longrightarrow> \<not> recognises_execution e s r (a#t)"
  using recognises_possible_steps_not_empty by auto

lemma trace_reject_later:
  "\<forall>(s', T) |\<in>| possible_steps e s r l i. \<not> recognises_execution e s' (evaluate_updates T i r) t \<Longrightarrow>
   \<not> recognises_execution e s r ((l, i)#t)"
  using trace_reject by auto

lemma recognition_prefix_closure: "recognises_execution e s r (t@t') \<Longrightarrow> recognises_execution e s r t"
proof(induct t arbitrary: s r)
  case (Cons a t)
  then show ?case
    apply (cases a, clarsimp)
    apply (rule recognises_execution.cases)
      apply simp
     apply simp
    by (rule recognises_execution.step, auto)
qed auto

lemma rejects_prefix: "\<not> recognises_execution e s r t \<Longrightarrow> \<not> recognises_execution e s r (t @ t')"
  using recognition_prefix_closure by blast

lemma recognises_head: "recognises_execution e s r (h#t) \<Longrightarrow> recognises_execution e s r [h]"
  by (simp add: recognition_prefix_closure)

subsubsection\<open>Trace Acceptance\<close>
text\<open>The \texttt{accepts} function returns true if the given EFSM accepts a given trace. That is,
the EFSM is able to respond to each event in sequence \emph{and} is able to produce the expected
output. Accepted traces represent valid runs of an EFSM.\<close>

text_raw\<open>\snip{accepts}{1}{2}{%\<close>
inductive accepts_trace :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> trace \<Rightarrow> bool" where
  base [simp]: "accepts_trace e s r []" |
  step: "\<exists>(s', T) |\<in>| possible_steps e s r l i.
         evaluate_outputs T i r = map Some p \<and> accepts_trace e s' (evaluate_updates T i r) t \<Longrightarrow>
         accepts_trace e s r ((l, i, p)#t)"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{T}{1}{2}{%\<close>
definition T :: "transition_matrix \<Rightarrow> trace set" where
  "T e = {t. accepts_trace e 0 <> t}"
text_raw\<open>}%endsnip\<close>

abbreviation "rejects_trace e s r t \<equiv> \<not> accepts_trace e s r t"

lemma accepts_trace_step:
  "accepts_trace e s r ((l, i, p)#t) = (\<exists>(s', T) |\<in>| possible_steps e s r l i.
         evaluate_outputs T i r = map Some p \<and>
         accepts_trace e s' (evaluate_updates T i r) t)"
  apply standard
  by (rule accepts_trace.cases, auto simp: accepts_trace.step)

lemma accepts_trace_exists_possible_step:
  "accepts_trace e1 s1 r1 ((aa, b, c) # t) \<Longrightarrow>
       \<exists>(s1', t1)|\<in>|possible_steps e1 s1 r1 aa b.
          evaluate_outputs t1 b r1 = map Some c"
  using accepts_trace_step by auto

lemma rejects_trace_step:
"rejects_trace e s r ((l, i, p)#t) = (
  (\<forall>(s', T) |\<in>| possible_steps e s r l i.  evaluate_outputs T i r \<noteq> map Some p \<or> rejects_trace e s' (evaluate_updates T i r) t)
)"
  apply (simp add: accepts_trace_step)
  by auto

definition accepts_log :: "trace set \<Rightarrow> transition_matrix \<Rightarrow> bool" where
  "accepts_log l e = (\<forall>t \<in> l. accepts_trace e 0 <> t)"

text_raw\<open>\snip{prefixClosure}{1}{2}{%\<close>
lemma prefix_closure: "accepts_trace e s r (t@t') \<Longrightarrow> accepts_trace e s r t"
text_raw\<open>}%endsnip\<close>
proof(induct t arbitrary: s r)
next
  case (Cons a t)
  then show ?case
    apply (cases a, clarsimp)
    apply (simp add: accepts_trace_step)
    by auto
qed auto

text\<open>For code generation, it is much more efficient to re-implement the \texttt{accepts\_trace}
function primitively than to use the code generator's default setup for inductive definitions.\<close>
fun accepts_trace_prim :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> trace \<Rightarrow> bool" where
  "accepts_trace_prim _ _ _ [] = True" |
  "accepts_trace_prim e s r ((l, i, p)#t) = (
    let poss_steps = possible_steps e s r l i in
    if fis_singleton poss_steps then
      let (s', T) = fthe_elem poss_steps in
      if evaluate_outputs T i r = map Some p then
        accepts_trace_prim e s' (evaluate_updates T i r) t
      else False
    else
      (\<exists>(s', T) |\<in>| poss_steps.
         evaluate_outputs T i r = (map Some p) \<and>
         accepts_trace_prim e s' (evaluate_updates T i r) t))"

lemma accepts_trace_prim [code]: "accepts_trace e s r l = accepts_trace_prim e s r l"
proof(induct l arbitrary: s r)
  case (Cons a l)
  then show ?case
    apply (cases a)
    apply (simp add: accepts_trace_step Let_def fis_singleton_alt)
    by auto
qed auto

subsection\<open>EFSM Comparison\<close>
text\<open>Here, we define some different metrics of EFSM equality.\<close>

subsubsection\<open>State Isomporphism\<close>
text\<open>Two EFSMs are isomorphic with respect to states if there exists a bijective function between
the state names of the two EFSMs, i.e. the only difference between the two models is the way the
states are indexed.\<close>

definition isomorphic :: "transition_matrix \<Rightarrow> transition_matrix \<Rightarrow> bool" where
  "isomorphic e1 e2 = (\<exists>f. bij f \<and> (\<forall>((s1, s2), t) |\<in>| e1. ((f s1, f s2), t) |\<in>| e2))"

subsubsection\<open>Register Isomporphism\<close>
text\<open>Two EFSMs are isomorphic with respect to registers if there exists a bijective function between
the indices of the registers in the two EFSMs, i.e. the only difference between the two models is
the way the registers are indexed.\<close>
definition rename_regs :: "(nat \<Rightarrow> nat) \<Rightarrow> transition_matrix \<Rightarrow> transition_matrix" where
  "rename_regs f e = fimage (\<lambda>(tf, t). (tf, Transition.rename_regs f t)) e"

definition eq_upto_rename_strong :: "transition_matrix \<Rightarrow> transition_matrix \<Rightarrow> bool" where
  "eq_upto_rename_strong e1 e2 = (\<exists>f. bij f \<and> rename_regs f e1 = e2)"

subsubsection\<open>Trace Simulation\<close>
text\<open>An EFSM, $e_1$ simulates another EFSM $e_2$ if there is a function between the states of the
states of $e_1$ and $e_1$ such that in each state, if $e_1$ can respond to the event and produce
the correct output, so can $e_2$.\<close>

text_raw\<open>\snip{traceSim}{1}{2}{%\<close>
inductive trace_simulation :: "(cfstate \<Rightarrow> cfstate) \<Rightarrow> transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow>
transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> trace \<Rightarrow> bool" where
  base: "s2 = f s1 \<Longrightarrow> trace_simulation f e1 s1 r1 e2 s2 r2 []" |
  step: "s2 = f s1 \<Longrightarrow>
         \<forall>(s1', t1) |\<in>| ffilter (\<lambda>(s1', t1). evaluate_outputs t1 i r1 = map Some o) (possible_steps e1 s1 r1 l i).
           \<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i. evaluate_outputs t2 i r2 = map Some o \<and>
            trace_simulation f e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es \<Longrightarrow>
         trace_simulation f e1 s1 r1 e2 s2 r2 ((l, i, o)#es)"
text_raw\<open>}%endsnip\<close>

lemma trace_simulation_step:
"trace_simulation f e1 s1 r1 e2 s2 r2 ((l, i, o)#es) = (
  (s2 = f s1) \<and> (\<forall>(s1', t1) |\<in>| ffilter (\<lambda>(s1', t1). evaluate_outputs t1 i r1 = map Some o) (possible_steps e1 s1 r1 l i).
         (\<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i. evaluate_outputs t2 i r2 = map Some o \<and>
         trace_simulation f e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es))
)"
  apply standard
   apply (rule trace_simulation.cases, simp+)
  apply (rule trace_simulation.step)
   apply simp
  by blast

lemma trace_simulation_step_none:
  "s2 = f s1 \<Longrightarrow>
   \<nexists>(s1', t1) |\<in>| possible_steps e1 s1 r1 l i. evaluate_outputs t1 i r1 = map Some o \<Longrightarrow>
   trace_simulation f e1 s1 r1 e2 s2 r2 ((l, i, o)#es)"
  apply (rule trace_simulation.step)
   apply simp
  apply (case_tac "ffilter (\<lambda>(s1', t1). evaluate_outputs t1 i r1 = map Some o) (possible_steps e1 s1 r1 l i)")
   apply simp
  by fastforce

definition "trace_simulates e1 e2 = (\<exists>f. \<forall>t. trace_simulation f e1 0 <> e2 0 <> t)"

lemma rejects_trace_simulation:
  "rejects_trace e2 s2 r2 t \<Longrightarrow>
   accepts_trace e1 s1 r1 t \<Longrightarrow>
   \<not>trace_simulation f e1 s1 r1 e2 s2 r2 t"
proof(induct t arbitrary: s1 r1 s2 r2)
  case Nil
  then show ?case
    using accepts_trace.base by blast
next
  case (Cons a t)
  then show ?case
    apply (cases a)
    apply (simp add: rejects_trace_step)
    apply (simp add: accepts_trace_step)
    apply clarify
    apply (rule trace_simulation.cases)
      apply simp
     apply simp
    apply clarsimp
    subgoal for l o _ _ i
      apply (case_tac "ffilter (\<lambda>(s1', t1). evaluate_outputs t1 i r1 = map Some o) (possible_steps e1 s1 r1 l i) = {||}")
       apply auto[1]
      by fastforce
    done
qed

lemma accepts_trace_simulation:
  "accepts_trace e1 s1 r1 t \<Longrightarrow>
   trace_simulation f e1 s1 r1 e2 s2 r2 t \<Longrightarrow>
   accepts_trace e2 s2 r2 t"
  using rejects_trace_simulation by blast

lemma simulates_trace_subset: "trace_simulates e1 e2 \<Longrightarrow> T e1 \<subseteq> T e2"
  using T_def accepts_trace_simulation trace_simulates_def by fastforce

subsubsection\<open>Trace Equivalence\<close>
text\<open>Two EFSMs are trace equivalent if they accept the same traces. This is the intuitive definition
of ``observable equivalence'' between the behaviours of the two models. If two EFSMs are trace
equivalent, there is no trace which can distinguish the two.\<close>

text_raw\<open>\snip{traceEquiv}{1}{2}{%\<close>
definition "trace_equivalent e1 e2 = (T e1 = T e2)"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{simEquiv}{1}{2}{%\<close>
lemma simulation_implies_trace_equivalent:
  "trace_simulates e1 e2 \<Longrightarrow> trace_simulates e2 e1 \<Longrightarrow> trace_equivalent e1 e2"
text_raw\<open>}%endsnip\<close>
  using simulates_trace_subset trace_equivalent_def by auto

lemma trace_equivalent_reflexive: "trace_equivalent e1 e1"
  by (simp add: trace_equivalent_def)

lemma trace_equivalent_symmetric:
  "trace_equivalent e1 e2 = trace_equivalent e2 e1"
  using trace_equivalent_def by auto

lemma trace_equivalent_transitive:
  "trace_equivalent e1 e2 \<Longrightarrow>
   trace_equivalent e2 e3 \<Longrightarrow>
   trace_equivalent e1 e3"
  by (simp add: trace_equivalent_def)

text\<open>Two EFSMs are trace equivalent if they accept the same traces.\<close>
lemma trace_equivalent:
  "\<forall>t. accepts_trace e1 0 <> t = accepts_trace e2 0 <> t \<Longrightarrow> trace_equivalent e1 e2"
  by (simp add: T_def trace_equivalent_def)

lemma accepts_trace_step_2: "(s2', t2) |\<in>| possible_steps e2 s2 r2 l i \<Longrightarrow>
       accepts_trace e2 s2' (evaluate_updates t2 i r2) t \<Longrightarrow>
       evaluate_outputs t2 i r2 = map Some p \<Longrightarrow>
       accepts_trace e2 s2 r2 ((l, i, p)#t)"
  by (rule accepts_trace.step, auto)

subsubsection\<open>Execution Simulation\<close>
text\<open>Execution simulation is similar to trace simulation but for executions rather than traces.
Execution simulation has no notion of ``expected'' output. It simply requires that the simulating
EFSM must be able to produce equivalent output for each action.\<close>

text_raw\<open>\snip{execSim}{1}{2}{%\<close>
inductive execution_simulation :: "(cfstate \<Rightarrow> cfstate) \<Rightarrow> transition_matrix \<Rightarrow> cfstate \<Rightarrow>
registers \<Rightarrow> transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
  base: "s2 = f s1 \<Longrightarrow> execution_simulation f e1 s1 r1 e2 s2 r2 []" |
  step: "s2 = f s1 \<Longrightarrow>
         \<forall>(s1', t1) |\<in>| (possible_steps e1 s1 r1 l i).
           \<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i.
            evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
            execution_simulation f e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es \<Longrightarrow>
         execution_simulation f e1 s1 r1 e2 s2 r2 ((l, i)#es)"
text_raw\<open>}%endsnip\<close>

definition "execution_simulates e1 e2 = (\<exists>f. \<forall>t. execution_simulation f e1 0 <> e2 0 <> t)"

lemma execution_simulation_step:
"execution_simulation f e1 s1 r1 e2 s2 r2 ((l, i)#es) =
 (s2 = f s1 \<and>
 (\<forall>(s1', t1) |\<in>| (possible_steps e1 s1 r1 l i).
         (\<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i. evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
         execution_simulation f e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es))
)"
  apply standard
   apply (rule execution_simulation.cases)
     apply simp
    apply simp
   apply simp
  apply (rule execution_simulation.step)
   apply simp
  by blast

text_raw\<open>\snip{execTraceSim}{1}{2}{%\<close>
lemma execution_simulation_trace_simulation:
  "execution_simulation f e1 s1 r1 e2 s2 r2 (map (\<lambda>(l, i, o). (l, i)) t) \<Longrightarrow>
   trace_simulation f e1 s1 r1 e2 s2 r2 t"
text_raw\<open>}%endsnip\<close>
proof(induct t arbitrary: s1 s2 r1 r2)
case Nil
  then show ?case
    apply (rule execution_simulation.cases)
     apply (simp add: trace_simulation.base)
    by simp
next
  case (Cons a t)
  then show ?case
    apply (cases a, clarsimp)
    apply (rule execution_simulation.cases)
      apply simp
     apply simp
    apply (rule trace_simulation.step)
     apply simp
    apply clarsimp
    subgoal for _ _ _ aa ba
      apply (erule_tac x="(aa, ba)" in fBallE)
       apply clarsimp
       apply blast
      by simp
    done
qed

lemma execution_simulates_trace_simulates:
  "execution_simulates e1 e2 \<Longrightarrow> trace_simulates e1 e2"
  apply (simp add: execution_simulates_def trace_simulates_def)
  using execution_simulation_trace_simulation by blast

subsubsection\<open>Executional Equivalence\<close>
text\<open>Two EFSMs are executionally equivalent if there is no execution which can distinguish between
the two. That is, for every execution, they must produce equivalent outputs.\<close>

text_raw\<open>\snip{execEquiv}{1}{2}{%\<close>
inductive executionally_equivalent :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow>
transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
  base [simp]: "executionally_equivalent e1 s1 r1 e2 s2 r2 []" |
  step: "\<forall>(s1', t1) |\<in>| possible_steps e1 s1 r1 l i.
           \<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i.
             evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
             executionally_equivalent e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es \<Longrightarrow>
         \<forall>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i.
           \<exists>(s1', t1) |\<in>| possible_steps e1 s1 r1 l i.
             evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
             executionally_equivalent e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es \<Longrightarrow>
         executionally_equivalent e1 s1 r1 e2 s2 r2 ((l, i)#es)"
text_raw\<open>}%endsnip\<close>

lemma executionally_equivalent_step:
"executionally_equivalent e1 s1 r1 e2 s2 r2 ((l, i)#es) = (
  (\<forall>(s1', t1) |\<in>| (possible_steps e1 s1 r1 l i). (\<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i. evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
   executionally_equivalent e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es)) \<and>
  (\<forall>(s2', t2) |\<in>| (possible_steps e2 s2 r2 l i). (\<exists>(s1', t1) |\<in>| possible_steps e1 s1 r1 l i. evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
   executionally_equivalent e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es)))"
  apply standard
   apply (rule executionally_equivalent.cases)
     apply simp
    apply simp
   apply simp
  by (rule executionally_equivalent.step, auto)

lemma execution_end:
  "possible_steps e1 s1 r1 l i = {||} \<Longrightarrow>
   possible_steps e2 s2 r2 l i = {||} \<Longrightarrow>
  executionally_equivalent e1 s1 r1 e2 s2 r2 ((l, i)#es)"
  by (simp add: executionally_equivalent_step)

lemma possible_steps_disparity:
  "possible_steps e1 s1 r1 l i \<noteq> {||} \<Longrightarrow>
   possible_steps e2 s2 r2 l i = {||} \<Longrightarrow>
   \<not>executionally_equivalent e1 s1 r1 e2 s2 r2 ((l, i)#es)"
  by (simp add: executionally_equivalent_step, auto)

lemma executionally_equivalent_acceptance_map:
  "executionally_equivalent e1 s1 r1 e2 s2 r2 (map (\<lambda>(l, i, o). (l, i)) t) \<Longrightarrow>
   accepts_trace e2 s2 r2 t = accepts_trace e1 s1 r1 t"
proof(induct t arbitrary: s1 s2 r1 r2)
  case (Cons a t)
  then show ?case
    apply (cases a, simp)
    apply (rule executionally_equivalent.cases)
      apply simp
     apply simp
    apply clarsimp
    apply standard
    subgoal for i p l
      apply (rule accepts_trace.cases)
        apply simp
       apply simp
      apply clarsimp
      subgoal for aa b
        apply (rule accepts_trace.step)
        apply (erule_tac x="(aa, b)" in fBallE[of "possible_steps e2 s2 r2 l i"])
         defer apply simp
        apply simp
        by blast
      done
    apply (rule accepts_trace.cases)
      apply simp
     apply simp
    apply clarsimp
    subgoal for _ _ _ aa b
      apply (rule accepts_trace.step)
      apply (erule_tac x="(aa, b)" in fBallE)
       defer apply simp
      apply simp
      by fastforce
    done
qed auto

lemma executionally_equivalent_acceptance:
  "\<forall>x. executionally_equivalent e1 s1 r1 e2 s2 r2 x \<Longrightarrow> accepts_trace e1 s1 r1  t \<Longrightarrow> accepts_trace e2 s2 r2 t"
  using executionally_equivalent_acceptance_map by blast

lemma executionally_equivalent_trace_equivalent:
  "\<forall>x. executionally_equivalent e1 0 <> e2 0 <> x \<Longrightarrow> trace_equivalent e1 e2"
  apply (rule trace_equivalent)
  apply clarify
  subgoal for t apply (erule_tac x="map (\<lambda>(l, i, o). (l, i)) t" in allE)
    by (simp add: executionally_equivalent_acceptance_map)
  done

lemma executionally_equivalent_symmetry:
  "executionally_equivalent e1 s1 r1 e2 s2 r2 x \<Longrightarrow>
   executionally_equivalent e2 s2 r2 e1 s1 r1 x"
proof(induct x arbitrary: s1 s2 r1 r2)
  case (Cons a x)
  then show ?case
    apply (cases a, clarsimp)
    apply (simp add: executionally_equivalent_step)
    apply standard
     apply (rule fBallI)
     apply clarsimp
    subgoal for aa b aaa ba
      apply (erule_tac x="(aaa, ba)" in fBallE[of "possible_steps e2 s2 r2 aa b"])
      by (force, simp)
    apply (rule fBallI)
    apply clarsimp
    subgoal for aa b aaa ba
      apply (erule_tac x="(aaa, ba)" in fBallE)
      by (force, simp)
    done
qed auto

lemma executionally_equivalent_transitivity:
  "executionally_equivalent e1 s1 r1 e2 s2 r2 x \<Longrightarrow>
   executionally_equivalent e2 s2 r2 e3 s3 r3 x \<Longrightarrow>
   executionally_equivalent e1 s1 r1 e3 s3 r3 x"
proof(induct x arbitrary: s1 s2 s3 r1 r2 r3)
  case (Cons a x)
  then show ?case
    apply (cases a, clarsimp)
    apply (simp add: executionally_equivalent_step)
    apply clarsimp
    apply standard
     apply (rule fBallI)
     apply clarsimp
    subgoal for aa b ab ba
      apply (erule_tac x="(ab, ba)" in fBallE[of "possible_steps e1 s1 r1 aa b"])
       prefer 2 apply simp
      apply simp
      apply (erule fBexE)
      subgoal for x apply (case_tac x)
        apply simp
        by blast
      done
    apply (rule fBallI)
    apply clarsimp
    subgoal for aa b ab ba
      apply (erule_tac x="(ab, ba)" in fBallE[of "possible_steps e3 s3 r3 aa b"])
       prefer 2 apply simp
      apply simp
      apply (erule fBexE)
      subgoal for x apply (case_tac x)
        apply clarsimp
        subgoal for aaa baa
          apply (erule_tac x="(aaa, baa)" in fBallE[of "possible_steps e2 s2 r2 aa b"])
           prefer 2 apply simp
          apply simp
          by blast
        done
      done
    done
qed auto

subsection\<open>Reachability\<close>
text\<open>Here, we define the function \texttt{visits} which returns true if the given execution
leaves the given EFSM in the given state.\<close>

text_raw\<open>\snip{reachable}{1}{2}{%\<close>
inductive visits :: "cfstate \<Rightarrow> transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
  base [simp]: "visits s e s r []" |
  step: "\<exists>(s', T) |\<in>| possible_steps e s r l i. visits target e s' (evaluate_updates T i r) t \<Longrightarrow>
         visits target e s r ((l, i)#t)"

definition "reachable s e = (\<exists>t. visits s e 0 <> t)"
text_raw\<open>}%endsnip\<close>

lemma no_further_steps:
  "s \<noteq> s' \<Longrightarrow> \<not> visits s e s' r []"
  apply safe
  apply (rule visits.cases)
  by auto

lemma visits_base: "visits target e s r [] = (s = target)"
  by (metis visits.base no_further_steps)

lemma visits_step:
  "visits target e s r (h#t) = (\<exists>(s', T) |\<in>| possible_steps e s r (fst h) (snd h). visits target e s' (evaluate_updates T (snd h) r) t)"
  apply standard
   apply (rule visits.cases)
     apply simp+
  apply (cases h)
  using visits.step by auto

lemma reachable_initial: "reachable 0 e"
  apply (simp add: reachable_def)
  apply (rule_tac x="[]" in exI)
  by simp

lemma visits_finsert:
  "visits s e s' r t \<Longrightarrow> visits s (finsert ((aa, ba), b) e) s' r t"
proof(induct t arbitrary: s' r)
  case Nil
  then show ?case
    by (simp add: visits_base)
next
  case (Cons a t)
  then show ?case
    apply (simp add: visits_step)
    apply (erule fBexE)
    apply (rule_tac x=x in fBexI)
     apply auto[1]
    by (simp add: possible_steps_finsert)
qed

lemma reachable_finsert:
  "reachable s e \<Longrightarrow> reachable s (finsert ((aa, ba), b) e)"
  apply (simp add: reachable_def)
  by (meson visits_finsert)

lemma reachable_finsert_contra:
  "\<not> reachable s (finsert ((aa, ba), b) e) \<Longrightarrow> \<not>reachable s e"
  using reachable_finsert by blast

lemma visits_empty: "visits s e s' r [] = (s = s')"
  apply standard
  by (rule visits.cases, auto)

definition "remove_state s e = ffilter (\<lambda>((from, to), t). from \<noteq> s \<and> to \<noteq> s) e"

text_raw\<open>\snip{obtainable}{1}{2}{%\<close>
inductive "obtains" :: "cfstate \<Rightarrow> registers \<Rightarrow> transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
  base [simp]: "obtains s r e s r []" |
  step: "\<exists>(s'', T) |\<in>| possible_steps e s' r' l i. obtains s r e s'' (evaluate_updates T i r') t \<Longrightarrow>
         obtains s r e s' r' ((l, i)#t)"

definition "obtainable s r e = (\<exists>t. obtains s r e 0 <> t)"
text_raw\<open>}%endsnip\<close>

lemma obtains_obtainable:
  "obtains s r e 0 <> t \<Longrightarrow> obtainable s r e"
  apply (simp add: obtainable_def)
  by auto

lemma obtains_step: "obtains s r e s' r' ((l, i)#t) = (\<exists>(s'', T) |\<in>| possible_steps e s' r' l i. obtains s r e s'' (evaluate_updates T i r') t)"
  apply standard
  by (rule obtains.cases, auto simp add: obtains.step)

lemma obtains_recognises:
  "obtains s c e s' r t \<Longrightarrow> recognises_execution e s' r t"
proof(induct t arbitrary: s' r)
  case Nil
  then show ?case
    by (simp add: obtains_base)
next
  case (Cons a t)
  then show ?case
    apply (cases a)
    apply simp
    apply (rule obtains.cases)
      apply simp
     apply simp
    apply clarsimp
    using recognises_execution.step by fastforce
qed

lemma ex_comm4:
  "(\<exists>c1 s a b. (a, b) \<in> fset (possible_steps e s' r l i) \<and> obtains s c1 e a (evaluate_updates b i r) t) =
   (\<exists>a b s c1. (a, b) \<in> fset (possible_steps e s' r l i) \<and> obtains s c1 e a (evaluate_updates b i r) t)"
  by auto

lemma recognises_execution_obtains:
  "recognises_execution e s' r t \<Longrightarrow> \<exists>c1 s. obtains s c1 e s' r t"
proof(induct t arbitrary: s' r)
  case Nil
  then show ?case
    by (simp add: obtains_base)
next
  case (Cons a t)
  then show ?case
    apply (cases a)
    apply (simp add: obtains_step)
    apply (rule recognises_execution.cases)
      apply simp
     apply simp
    apply clarsimp
    apply (simp add: fBex_def Bex_def ex_comm4)
    subgoal for _ _ aa ba
      apply (rule_tac x=aa in exI)
      apply (rule_tac x=ba in exI)
      apply (simp add: fmember_implies_member)
      by blast
    done
qed

lemma obtainable_empty_efsm:
  "obtainable s c {||} = (s=0 \<and> c = <>)"
  apply (simp add: obtainable_def)
  apply standard
  apply (metis ffilter_empty no_outgoing_transitions no_step_none obtains.cases obtains_recognises step_None)
  using obtains_base by blast

lemma obtains_visits: "obtains s r e s' r' t \<Longrightarrow> visits s e s' r' t"
proof(induct t arbitrary: s' r')
  case Nil
  then show ?case
    by (simp add: obtains_base)
next
  case (Cons a t)
  then show ?case
    apply (cases a)
    apply (rule obtains.cases)
      apply simp
     apply simp
    apply clarsimp
    apply (rule visits.step)
    by auto
qed

lemma unobtainable_if: "\<not> visits s e s' r' t \<Longrightarrow> \<not> obtains s r e s' r' t"
  using obtains_visits by blast

lemma obtainable_if_unreachable: "\<not>reachable s e \<Longrightarrow> \<not>obtainable s r e"
  by (simp add: reachable_def obtainable_def unobtainable_if)

lemma obtains_step_append:
  "obtains s r e s' r' t \<Longrightarrow>
  (s'', ta) |\<in>| possible_steps e s r l i \<Longrightarrow>
  obtains s'' (evaluate_updates ta i r) e s' r' (t @ [(l, i)])"
proof(induct t arbitrary: s' r')
  case Nil
  then show ?case
    apply (simp add: obtains_base)
    apply (rule obtains.step)
    apply (rule_tac x="(s'', ta)" in fBexI)
    by auto
next
  case (Cons a t)
  then show ?case
    apply simp
    apply (rule obtains.cases)
      apply simp
     apply simp
    apply clarsimp
    apply (rule obtains.step)
    by auto
qed

lemma reachable_if_obtainable_step:
  "obtainable s r e \<Longrightarrow> \<exists>l i t. (s', t) |\<in>| possible_steps e s r l i \<Longrightarrow> reachable s' e"
  apply (simp add: reachable_def obtainable_def)
  apply clarify
  subgoal for t l i
    apply (rule_tac x="t@[(l, i)]" in exI)
    using obtains_step_append unobtainable_if by blast
  done

lemma possible_steps_remove_unreachable:
  "obtainable s r e \<Longrightarrow>
  \<not> reachable s' e \<Longrightarrow>
  possible_steps (remove_state s' e) s r l i = possible_steps e s r l i"
  apply standard
  apply (simp add: fsubset_eq)
   apply (rule fBallI)
   apply clarsimp
   apply (metis ffmember_filter in_possible_steps remove_state_def)
  apply (simp add: fsubset_eq)
   apply (rule fBallI)
  apply clarsimp
  subgoal for a b
    apply (case_tac "a = s'")
    using reachable_if_obtainable_step apply blast
    apply (simp add: remove_state_def)
    by (metis (mono_tags, lifting) ffmember_filter in_possible_steps obtainable_if_unreachable old.prod.case)
  done

text_raw\<open>\snip{removeUnreachableArb}{1}{2}{%\<close>
lemma executionally_equivalent_remove_unreachable_state_arbitrary:
  "obtainable s r e \<Longrightarrow> \<not> reachable s' e \<Longrightarrow> executionally_equivalent e s r (remove_state s' e) s r x"
text_raw\<open>}%endsnip\<close>
proof(induct x arbitrary: s r)
  case (Cons a x)
  then show ?case
    apply (cases a, simp)
    apply (rule executionally_equivalent.step)
    apply (simp add: possible_steps_remove_unreachable)
    apply standard
     apply clarsimp
    subgoal for aa b ab ba
      apply (rule_tac x="(ab, ba)" in fBexI)
       apply (metis (mono_tags, lifting) obtainable_def obtains_step_append case_prodI)
      apply simp
      done
    apply (rule fBallI)
    apply clarsimp
    apply (rule_tac x="(ab, ba)" in fBexI)
     apply simp
     apply (metis obtainable_def obtains_step_append possible_steps_remove_unreachable)
    by (simp add: possible_steps_remove_unreachable)
qed auto

text_raw\<open>\snip{removeUnreachable}{1}{2}{%\<close>
lemma executionally_equivalent_remove_unreachable_state:
  "\<not> reachable s' e \<Longrightarrow> executionally_equivalent e 0 <> (remove_state s' e) 0 <> x"
text_raw\<open>}%endsnip\<close>
  by (meson executionally_equivalent_remove_unreachable_state_arbitrary
      obtains.simps obtains_obtainable)

subsection\<open>Transition Replacement\<close>
text\<open>Here, we define the function \texttt{replace} to replace one transition with another, and prove
some of its properties.\<close>

definition "replace e1 old new = fimage (\<lambda>x. if x = old then new else x) e1"

lemma replace_finsert:
  "replace (finsert ((aaa, baa), b) e1) old new = (if ((aaa, baa), b) = old then (finsert new (replace e1 old new)) else (finsert ((aaa, baa), b) (replace e1 old new)))"
  by (simp add: replace_def)

lemma possible_steps_replace_unchanged:
  "((s, aa), ba) \<noteq> ((s1, s2), t1) \<Longrightarrow>
  (aa, ba) |\<in>| possible_steps e1 s r l i \<Longrightarrow>
  (aa, ba) |\<in>| possible_steps (replace e1 ((s1, s2), t1) ((s1, s2), t2)) s r l i"
  apply (simp add: in_possible_steps[symmetric] replace_def)
  by fastforce

end


theory SINVAR_Tainting
imports "../TopoS_Helper"
begin

subsection \<open>SecurityInvariant Tainting for IFS\<close>

context
begin

  qualified type_synonym taints = "string set"

  text\<open>Warning: an infinite set has cardinality 0\<close>
  lemma "card (UNIV::taints) = 0" by (simp add: infinite_UNIV_listI)

  qualified definition default_node_properties :: "taints"
    where  "default_node_properties \<equiv> {}"

  (*The definition we want to present*)
  text\<open>For all nodes @{term n} in the graph, for all nodes @{term r} which are reachable from @{term n},
        node @{term n} needs the appropriate tainting fields which are set by @{term r}\<close>
  definition sinvar_tainting :: "'v graph \<Rightarrow> ('v \<Rightarrow> taints) \<Rightarrow> bool" where
    "sinvar_tainting G nP \<equiv> \<forall> n \<in> (nodes G). \<forall>r \<in> (succ_tran G n). nP n \<subseteq> nP r"

  private lemma sinvar_tainting_edges_def: "wf_graph G \<Longrightarrow>
    sinvar_tainting G nP \<longleftrightarrow> (\<forall> (v1,v2) \<in> edges G. \<forall>r \<in> (succ_tran G v1). nP v1 \<subseteq> nP r)"
    unfolding sinvar_tainting_def
    proof
      assume a1: "wf_graph G"
        and  a2: "\<forall>n\<in>nodes G. \<forall>r\<in>succ_tran G n. nP n \<subseteq> nP r"
        from a1[simplified wf_graph_def] have f1: "fst ` edges G \<subseteq> nodes G" by simp
        from f1 a2 have "\<forall>v \<in> (fst ` edges G). \<forall>r\<in>succ_tran G v. nP v \<subseteq> nP r" by auto
        thus "\<forall>(v1, _)\<in>edges G. \<forall>r\<in>succ_tran G v1. nP v1 \<subseteq> nP r" by fastforce
      next
      assume a1: "wf_graph G"
        and  a2: "\<forall>(v1, v2)\<in>edges G. \<forall>r\<in>succ_tran G v1. nP v1 \<subseteq> nP r"
        from a2 have g1: "\<forall> v \<in> (fst ` edges G). \<forall>r\<in>succ_tran G v. nP v \<subseteq> nP r" by fastforce
        from FiniteGraph.succ_tran_empty[OF a1]
        have g2: "\<forall> v. v \<notin> (fst ` edges G) \<longrightarrow> (\<forall>r\<in>succ_tran G v. nP v \<subseteq> nP r)" by blast
        from g1 g2 show "\<forall>n\<in>nodes G. \<forall>r\<in>succ_tran G n. nP n \<subseteq> nP r" by metis
    qed

  text\<open>Alternative definition of the @{const sinvar_tainting}\<close>

  qualified definition sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> taints) \<Rightarrow> bool" where
    "sinvar G nP \<equiv> \<forall> (v1,v2) \<in> edges G. nP v1 \<subseteq> nP v2"

  qualified lemma sinvar_preferred_def:
    "wf_graph G \<Longrightarrow> sinvar_tainting G nP = sinvar G nP"
    proof(unfold sinvar_tainting_edges_def sinvar_def, rule iffI, goal_cases)
    case 2
        have "(v, v') \<in> (edges G)\<^sup>+ \<Longrightarrow> nP v \<subseteq> nP v'" for v v'
          proof(induction rule: trancl_induct)
          case base thus ?case using 2(2) by fastforce
          next
          case step thus ?case using 2(2) by fastforce
          qed
        thus ?case
        by(simp add: succ_tran_def)
      next
      case 1
        from 1(1)[simplified wf_graph_def] have f1: "fst ` edges G \<subseteq> nodes G" by simp
        from f1 1(2) have "\<forall>v \<in> (fst ` edges G). \<forall>v'\<in>succ_tran G v. nP v \<subseteq> nP v'" by fastforce
        thus ?case unfolding succ_tran_def by fastforce
    qed

  text\<open>Information Flow Security\<close>
  qualified definition receiver_violation :: "bool" where "receiver_violation \<equiv> True"

  private

end

end


theory SeparationLogic
imports Semantics
begin

datatype expr =
  ConstE val
| VarE var
| Base expr
| Ende expr
| UnOpE unop expr
| BinOpE binop expr expr

abbreviation e_add :: "expr \<Rightarrow> expr \<Rightarrow> expr" where
  "e_add e1 e2 \<equiv> BinOpE plus e1 e2"

declare [[coercion VarE, coercion ConstE, coercion_enabled = true]]

fun e_size :: "expr \<Rightarrow> nat" where
  "e_size (ConstE k) = length k"
| "e_size (VarE v) = size v"
| "e_size (Base _) = loc_N_B"
| "e_size (Ende _) = loc_N_B"
| "e_size (UnOpE _ e) = e_size e"
| "e_size (BinOpE _ e _) = e_size e"

fun expr_semantics :: "stack \<Rightarrow> blocks \<Rightarrow> expr \<Rightarrow> val" where
  "expr_semantics S B (ConstE k) = k"
| "expr_semantics S B (VarE x) = lookup S x"
| "expr_semantics S B (Base e) = loc64_ops.to_val (base B (loc64_ops.from_val (expr_semantics S B e)))"
| "expr_semantics S B (Ende e)= loc64_ops.to_val (ende B (loc64_ops.from_val (expr_semantics S B e)))"
| "expr_semantics S B (UnOpE op e) = apply_unop op (expr_semantics S B e)"
| "expr_semantics S B (BinOpE op e1 e2) = apply_binop op (expr_semantics S B e1) (expr_semantics S B e2)"

datatype form =
  PointsTo expr expr (infix "\<mapsto>\<^sub>s" 60)
| PointsToK expr byte expr ("_\<mapsto>\<^sub>_[_]")
| PointsToTop expr expr ("_\<mapsto>\<top>[_]")
| SepConj form form (infixr "\<^emph>" 50)
| Disj form form (infixl "\<or>\<^sub>s" 55)
| LinkedList expr expr
| DoublyLinkedList expr expr expr expr
| Emp
| TrueF
| Atom condition expr expr
| Exists var form

abbreviation f_eq :: "expr \<Rightarrow> expr \<Rightarrow> form" where
  "f_eq e1 e2 \<equiv> Atom Eq e1 e2"

fun symbolic_heap :: "form \<Rightarrow> bool" where
  "symbolic_heap (SepConj f1 f2) = (symbolic_heap f1 \<and> symbolic_heap f2)"
| "symbolic_heap (Disj _ _) = False"
| "symbolic_heap (Exists _ f) = symbolic_heap f"
| "symbolic_heap _ = True"

fun quantifier_free :: "form \<Rightarrow> bool" where
  "quantifier_free (SepConj f1 f2) = (quantifier_free f1 \<and> quantifier_free f2)"
| "quantifier_free (Disj f1 f2) = (quantifier_free f1 \<and> quantifier_free f2)"
| "quantifier_free (Exists _ f) = False"
| "quantifier_free _ = True"

abbreviation quantifree_symb_heap :: "form \<Rightarrow> bool" where
  "quantifree_symb_heap P \<equiv> quantifier_free P \<and> symbolic_heap P"

fun pure :: "form \<Rightarrow> bool" where
  "pure (SepConj f1 f2) = (pure f1 \<and> pure f2)"
| "pure (Atom _ _ _) = True"
| "pure _ = False"

class frees =
  fixes free_vars :: "'a \<Rightarrow> var set"

instantiation expr :: frees begin
fun free_vars_expr :: "expr \<Rightarrow> var set" where
  "free_vars_expr (ConstE _) = {}"
| "free_vars_expr (VarE v) = {v}"
| "free_vars_expr (Base e) = free_vars_expr e"
| "free_vars_expr (Ende e) = free_vars_expr e"
| "free_vars_expr (UnOpE _ e) = free_vars_expr e"
| "free_vars_expr (BinOpE _ e1 e2) = free_vars_expr e1 \<union> free_vars_expr e2"
instance .. end

instantiation form :: frees begin
fun free_vars_form :: "form \<Rightarrow> var set" where
 "free_vars_form (PointsTo e1 e2) = free_vars e1 \<union> free_vars e2"
| "free_vars_form (PointsToK e1 _ e2) = free_vars e1 \<union> free_vars e2"
| "free_vars_form (PointsToTop e1 e2) = free_vars e1 \<union> free_vars e2"
| "free_vars_form (SepConj f1 f2) = free_vars_form f1 \<union> free_vars_form f2"
| "free_vars_form (Disj f1 f2) = free_vars_form f1 \<union> free_vars_form f2"
| "free_vars_form (LinkedList e1 e2) = free_vars e1 \<union> free_vars e2"
| "free_vars_form (DoublyLinkedList e1 e2 e3 e4) = free_vars e1 \<union> free_vars e2 \<union> free_vars e3
  \<union> free_vars e4"
| "free_vars_form Emp = {}"
| "free_vars_form TrueF = {}"
| "free_vars_form (Atom _ e1 e2) = free_vars e1 \<union> free_vars e2"
| "free_vars_form (Exists v f) = free_vars_form f - {v}"
instance .. end

fun rename_vars_expr :: "expr \<Rightarrow> var set \<Rightarrow> (var\<Rightarrow>expr) \<Rightarrow> (expr\<times>(var\<Rightarrow>expr))" where
  "rename_vars_expr (ConstE val) _ vs = (ConstE val, vs)"
| "rename_vars_expr (VarE var) in_use vs =
  (case vs var of VarE v \<Rightarrow> (if v \<in> in_use then (let fresh_v = fresh in_use in
  (VarE fresh_v, vs(var:=fresh_v))) else (VarE v, vs)) | e \<Rightarrow> (e, vs))"
| "rename_vars_expr (Base expr) in_use vs = (let (e',vs') = rename_vars_expr expr in_use vs in
  (Base e', vs'))"
| "rename_vars_expr (Ende expr) in_use vs = (let (e',vs') = rename_vars_expr expr in_use vs in
  (Ende e', vs'))"
| "rename_vars_expr (UnOpE op expr) in_use vs = (let (e',vs') = rename_vars_expr expr in_use vs in
  (UnOpE op e', vs'))"
| "rename_vars_expr (BinOpE op e1 e2) in_use vs =
  (let (e1',vs1) = rename_vars_expr e1 in_use vs in
  (let (e2',vs2) = rename_vars_expr e2 in_use vs1 in
  (BinOpE op e1' e2', vs2)))"

fun rename_vars :: "form \<Rightarrow> var set \<Rightarrow> (var\<Rightarrow>expr) \<Rightarrow> (form\<times>(var\<Rightarrow>expr))" where
  "rename_vars (e1 \<mapsto>\<^sub>s e2) in_use vs =
  (let (e1',vs1) = rename_vars_expr e1 in_use vs in
  (let (e2',vs2) = rename_vars_expr e2 in_use vs1 in
  (e1' \<mapsto>\<^sub>s e2', vs2)))"
| "rename_vars (e1 \<mapsto>\<^sub>b[e2]) in_use vs =
  (let (e1',vs1) = rename_vars_expr e1 in_use vs in
  (let (e2',vs2) = rename_vars_expr e2 in_use vs1 in
  (e1' \<mapsto>\<^sub>b [e2'], vs2)))"
| "rename_vars (e1 \<mapsto>\<top>[e2]) in_use vs =
  (let (e1',vs1) = rename_vars_expr e1 in_use vs in
  (let (e2',vs2) = rename_vars_expr e2 in_use vs1 in
  (e1'\<mapsto>\<top>[e2'], vs2)))"
| "rename_vars (f1\<^emph>f2) in_use vs =
  (let (f1',vs1) = rename_vars f1 in_use vs in
  (let (f2',vs2) = rename_vars f2 in_use vs1 in
  (f1' \<^emph> f2', vs2)))"
| "rename_vars (f1\<or>\<^sub>sf2) in_use vs =
  (let (f1',vs1) = rename_vars f1 in_use vs in
  (let (f2',vs2) = rename_vars f2 in_use vs1 in
  (f1' \<or>\<^sub>s f2', vs2)))"
| "rename_vars (LinkedList e1 e2) in_use vs =
  (let (e1',vs1) = rename_vars_expr e1 in_use vs in
  (let (e2',vs2) = rename_vars_expr e2 in_use vs1 in
  (LinkedList e1' e2', vs2)))"
| "rename_vars (DoublyLinkedList e1 e2 e3 e4) in_use vs =
  (let (e1',vs1) = rename_vars_expr e1 in_use vs in
  (let (e2',vs2) = rename_vars_expr e2 in_use vs1 in
  (let (e3',vs3) = rename_vars_expr e3 in_use vs2 in
  (let (e4',vs4) = rename_vars_expr e4 in_use vs3 in
  (DoublyLinkedList e1' e2' e3' e4', vs4)))))"
| "rename_vars Emp _ vs = (Emp,vs)"
| "rename_vars TrueF _ vs = (TrueF,vs)"
| "rename_vars (Atom condition e1 e2) in_use vs =
  (let (e1',vs1) = rename_vars_expr e1 in_use vs in
  (let (e2',vs2) = rename_vars_expr e2 in_use vs1 in
  (Atom condition e1' e2', vs2)))"
| "rename_vars (Exists v f) in_use vs =
  \<comment> \<open>vs must not map v to any expr. Bound variables can only be renamed but not substituted.\<close>
  (if v \<in> in_use then (let v' = fresh in_use in (let (f',vs') = rename_vars f in_use (vs(v:=v')) in
    (Exists v' f', vs'))) else (let (f',vs') = rename_vars f in_use vs in (Exists v f', vs')))"

abbreviation rename_vars_option :: "form \<Rightarrow> var set \<Rightarrow> (var\<rightharpoonup>expr) \<Rightarrow> (form\<times>(var\<Rightarrow>expr))" where
  "rename_vars_option f in_use vs_map \<equiv> rename_vars f in_use (\<lambda>x. case vs_map x of Some y \<Rightarrow> y | _ \<Rightarrow> x)"

abbreviation pointsto_sem :: "expr \<Rightarrow> expr \<Rightarrow> pre_config \<Rightarrow> bool" where
  "pointsto_sem e1 e2 c \<equiv> case c of (S,B,M) \<Rightarrow>
    (dom M = {x. loc64_ops.from_val (expr_semantics S B e1) \<le> x \<and>
    x < offset (loc64_ops.from_val (expr_semantics S B e1)) (e_size e2)} \<and>
    access M (loc64_ops.from_val (expr_semantics S B e1)) (e_size e2) = Some (expr_semantics S B e2))"

text \<open>We need form to be deeply embedded so that we can talk about symbolic heaps and
  quantifier free formulae. We also need \<Lambda> to return a form so that we can restrict it
  to symbolic heaps in prenex form. But because \<Lambda> can potentially make the logic's semantics
  non-terminating, we can't define them over a completely deeply embedded form with \<Lambda>.\<close>

locale separation_logic =
  fixes \<Lambda> :: "(expr \<Rightarrow> expr \<Rightarrow> form) \<times> (expr \<Rightarrow> expr \<Rightarrow> pre_config \<Rightarrow> bool)"
    and d\<Lambda> :: "(expr \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> form) \<times> (expr \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> pre_config \<Rightarrow> bool)"
begin

inductive list_semantics :: "pre_config \<Rightarrow> form \<Rightarrow> bool" where
  \<comment> \<open>Either the list is empty...\<close>
  "\<lbrakk>M = Map.empty; eval_cond Eq (expr_semantics S B e1) (expr_semantics S B e2)\<rbrakk>
  \<Longrightarrow> list_semantics (S,B,M) (LinkedList e1 e2)"
  \<comment> \<open>... or we can take one segment and get its semantics from \<Lambda>.\<close>
| "\<lbrakk>eval_cond Neq (expr_semantics S B e1) (expr_semantics S B e2);
    \<comment> \<open>For this get new variable and location denoting the second element and split of a heap for \<Lambda>\<close>
    u \<notin> free_vars e1 \<union> free_vars e2; dom M1 \<inter> dom M2 = {}; M = M1 ++ M2;
    snd \<Lambda> e1 (VarE u) (update_stack S u (loc64_ops.to_val l),B,M1);
    list_semantics (update_stack S u (loc64_ops.to_val l),B,M2) (LinkedList (VarE u) e2)\<rbrakk>
   \<Longrightarrow> list_semantics (S,B,M) (LinkedList e1 e2)"
  \<comment> \<open>And the same for doubly-linked lists.\<close>
| "\<lbrakk>M = Map.empty; eval_cond Eq (expr_semantics S B e1) (expr_semantics S B e1');
    eval_cond Eq (expr_semantics S B e2) (expr_semantics S B e2')\<rbrakk>
  \<Longrightarrow> list_semantics (S,B,M) (DoublyLinkedList e1 e2 e1' e2')"
| "\<lbrakk>eval_cond Neq (expr_semantics S B e1) (expr_semantics S B e1');
    eval_cond Neq (expr_semantics S B e2) (expr_semantics S B e2');
    u \<notin> free_vars e1 \<union> free_vars e2; om M1 \<inter> dom M2 = {}; M = M1 ++ M2;
    snd d\<Lambda> e1 (VarE u) e2 (update_stack S u (loc64_ops.to_val l),B,M1);
    list_semantics (update_stack S u (loc64_ops.to_val l),B,M2) (DoublyLinkedList (VarE u) e1 e1' e2')\<rbrakk>
  \<Longrightarrow> list_semantics (S,B,M) (DoublyLinkedList e1 e2 e1' e2')"

fun form_semantics :: "pre_config \<Rightarrow> form \<Rightarrow> bool" (infix "\<turnstile>" 80)
  where
  "(S,B,M) \<turnstile> (e1 \<mapsto>\<^sub>s e2) = pointsto_sem e1 e2 (S,B,M)"
| "(S,B,M) \<turnstile> (e1 \<mapsto>\<^sub>k[e2]) = (dom M = {x. loc64_ops.from_val (expr_semantics S B e1) \<le> x \<and>
    x < offset (loc64_ops.from_val (expr_semantics S B e1)) (e_size e2)} \<and> ran M = {k})"
| "(S,B,M) \<turnstile> (e1 \<mapsto>\<top>[e2]) = (dom M = {x. loc64_ops.from_val (expr_semantics S B e1) \<le> x \<and>
    x < offset (loc64_ops.from_val (expr_semantics S B e1)) (e_size e2)})"
| "(S,B,M) \<turnstile> (\<phi>1\<^emph>\<phi>2) = (\<exists>M1 M2. dom M1 \<inter> dom M2 = {} \<and> M = M1 ++ M2 \<and> (S,B,M1)\<turnstile>\<phi>1 \<and> (S,B,M2)\<turnstile>\<phi>2)"
| "(S,B,M) \<turnstile>  (\<phi>1 \<or>\<^sub>s \<phi>2) = ((S,B,M) \<turnstile> \<phi>1 \<or> (S,B,M) \<turnstile> \<phi>2)"
| "(S,B,M) \<turnstile> Emp = (M = Map.empty)"
| "(S,B,M) \<turnstile> TrueF = True"
| "(S,B,M) \<turnstile> (Atom cond e1 e2) = (M = Map.empty \<and> eval_cond cond (expr_semantics S B e1) (expr_semantics S B e2))"
| "(S,B,M) \<turnstile> (Exists x f) = (\<exists>v. (update_stack S x v,B,M) \<turnstile> f)"
| "c \<turnstile> l = list_semantics c l"
end

locale sound_separation_logic = separation_logic \<Lambda> d\<Lambda> for \<Lambda> d\<Lambda>
  + assumes sound_lambda: "\<forall>c e1 e2. c \<turnstile> (fst \<Lambda> e1 e2) \<longleftrightarrow> snd \<Lambda> e1 e2 c"
    and sound_dlambda: "\<forall>c e1 e2 e3. c \<turnstile> (fst d\<Lambda> e1 e2 e3) \<longleftrightarrow> snd d\<Lambda> e1 e2 e3 c"

locale program_logic = sound_separation_logic
  + fixes fs :: prog
  assumes "\<forall>n \<in> dom fs. \<forall>cfg. fs n = Some cfg \<longrightarrow> fst (fst cfg) = n"

interpretation standard_sl:
  sound_separation_logic "((\<lambda>x y. x \<mapsto>\<^sub>s y), pointsto_sem)"
    "((\<lambda>x y z. (x\<mapsto>\<^sub>sz) \<^emph> ((BinOpE plus x (ConstE [8]))\<mapsto>\<^sub>sy)),
      (\<lambda>x y z (S,B,M). \<exists>M1 M2. dom M1 \<inter> dom M2 = {} \<and> M = M1 ++ M2 \<and>
      pointsto_sem x z (S,B,M1) \<and> pointsto_sem (BinOpE plus x (ConstE [8])) y (S,B,M2)))"
  by standard (auto simp: separation_logic.form_semantics.simps(1,4))

context sound_separation_logic begin
definition satisfiable :: "form \<Rightarrow> bool" where
  "satisfiable P \<equiv> \<exists>S B M. (S,B,M) \<turnstile> P"

definition entails :: "form \<Rightarrow> form \<Rightarrow> bool" where
  "entails P Q \<equiv> \<forall>S B M. (S,B,M) \<turnstile> P \<longrightarrow> (S,B,M) \<turnstile> Q"
end

context separation_logic begin
definition FalseF :: form where
  "FalseF \<equiv> Atom Neq (ConstE []) (ConstE [])"

lemma false_is_false: "\<nexists>S B M. (S,B,M) \<turnstile> FalseF"
  by (auto simp: FalseF_def)

lemma false_conj_unit: "((S,B,M) \<turnstile> (P \<or>\<^sub>s FalseF)) = (S,B,M) \<turnstile> P"
  using false_is_false by (auto)
end
end


theory HealthyOrIll
  imports Main

begin

lemma hoi: "(healthy \<or> ill) \<and> (healthy \<longrightarrow> travel) \<and> \<not>ill \<longrightarrow> travel"
  apply (rule impI)
  apply (erule conjE)
  apply (erule conjE)
  apply (erule impE)
   apply (erule disjE)
    apply assumption
   apply (erule notE)
   apply assumption
  apply (erule disjE)
   apply assumption
  apply assumption
  done
end


theory Kindcheck
imports Type "../Utilities/Vector"
begin

inductive kinding :: "kind list \<Rightarrow> type \<Rightarrow> kind \<Rightarrow> bool" (infix "\<turnstile>\<^sub>k _ :" 60) where
  k_var [simp]: "lookup \<Delta> x = Some k \<Longrightarrow> \<Delta> \<turnstile>\<^sub>k TyVar x : k"
| k_arrow [simp]: "\<Delta> \<turnstile>\<^sub>k t\<^sub>1 : Star \<Longrightarrow> \<Delta> \<turnstile>\<^sub>k t\<^sub>2 : Star \<Longrightarrow> \<Delta> \<turnstile>\<^sub>k Arrow t\<^sub>1 t\<^sub>2 : Star"
| k_record [simp]: "(\<forall>t \<in> set ts. \<Delta> \<turnstile>\<^sub>k t : Star) \<Longrightarrow> \<Delta> \<turnstile>\<^sub>k Record ts : Star"
| k_variant [simp]: "(\<forall>t \<in> set ts. \<Delta> \<turnstile>\<^sub>k t : Star) \<Longrightarrow> \<Delta> \<turnstile>\<^sub>k Variant ts : Star"
| k_inductive [simp]: "insert_at 0 k \<Delta> \<turnstile>\<^sub>k t : Star \<Longrightarrow> \<Delta> \<turnstile>\<^sub>k Inductive k t : Star"
| k_forall [simp]: "insert_at 0 k \<Delta> \<turnstile>\<^sub>k t : Star \<Longrightarrow> \<Delta> \<turnstile>\<^sub>k Forall k t : Star"

inductive_cases [elim]: "\<Delta> \<turnstile>\<^sub>k TyVar x : k"
inductive_cases [elim]: "\<Delta> \<turnstile>\<^sub>k Arrow t\<^sub>1 t\<^sub>2 : k"
inductive_cases [elim]: "\<Delta> \<turnstile>\<^sub>k Record ts : k"
inductive_cases [elim]: "\<Delta> \<turnstile>\<^sub>k Variant ts : k"
inductive_cases [elim]: "\<Delta> \<turnstile>\<^sub>k Inductive k' t : k"
inductive_cases [elim]: "\<Delta> \<turnstile>\<^sub>k Forall k' t : k"

lemma [simp]: "insert_at x k' \<Delta> \<turnstile>\<^sub>k t : k \<Longrightarrow> \<Delta> \<turnstile>\<^sub>k t' : k' \<Longrightarrow> x \<le> length \<Delta> \<Longrightarrow>
    \<Delta> \<turnstile>\<^sub>k subst\<^sub>t\<^sub>t x t' t : k"
  proof (induction "insert_at x k' \<Delta>" t k arbitrary: \<Delta> x t' rule: kinding.induct)
  case (k_var y k)
    thus ?case by (induction y) auto
  qed simp_all

end


theory weird_nat_add3_assoc1
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S y2) z = S (add3 Z y2 z)"
| "add3 (S x2) y z = S (add3 x2 y z)"

(*hipster add3 *)

theorem x0 :
  "!! (x1 :: Nat) (x2 :: Nat) (x3 :: Nat) (x4 :: Nat) (x5 :: Nat) .
     (add3 (add3 x1 x2 x3) x4 x5) = (add3 x1 x2 (add3 x3 x4 x5))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(* Copyright 2021 (C) Mihails Milehins *)

chapter\<open>Digraphs\<close>

section\<open>Introduction\<close>
theory CZH_DG_Introduction
  imports
    "HOL-Library.Rewrite"
    CZH_Sets_NOP
    CZH_Sets_VNHS
begin

subsection\<open>Background\<close>

text\<open>
Many concepts that are normally associated with category theory can be
generalized to directed graphs. It is the goal of
this chapter to expose these generalized concepts and provide the
relevant foundations for the development of the notion of a semicategory
in the next chapter.
It is important to note, however, that it is not the goal of this chapter
to present a comprehensive canonical theory of directed graphs.
Nonetheless, there is little that could prevent one from extending this
body of work by providing canonical results from the theory of directed
graphs.
\<close>

subsection\<open>Preliminaries\<close>

declare One_nat_def[simp del]

named_theorems slicing_simps
named_theorems slicing_commute
named_theorems slicing_intros

named_theorems dg_op_simps
named_theorems dg_op_intros

named_theorems dg_cs_simps
named_theorems dg_cs_intros

named_theorems dg_shared_cs_simps
named_theorems dg_shared_cs_intros

subsection\<open>CS setup for foundations\<close>

named_theorems V_cs_simps
named_theorems V_cs_intros

named_theorems Ord_cs_simps
named_theorems Ord_cs_intros

subsubsection\<open>Basic \<open>HOL\<close>\<close>

lemma (in semilattice_sup) sup_commute':
  shows "b' = b \<Longrightarrow> a' = a \<Longrightarrow> a \<squnion> b = b' \<squnion> a'"
    and "b' = b \<Longrightarrow> a' = a \<Longrightarrow> a \<squnion> b' = b \<squnion> a'"
    and "b' = b \<Longrightarrow> a' = a \<Longrightarrow> a' \<squnion> b = b' \<squnion> a"
    and "b' = b \<Longrightarrow> a' = a \<Longrightarrow> a \<squnion> b' = b \<squnion> a'"
    and "b' = b \<Longrightarrow> a' = a \<Longrightarrow> a' \<squnion> b' = b \<squnion> a"
  by (auto simp: sup.commute)

lemma (in semilattice_inf) inf_commute':
  shows "b' = b \<Longrightarrow> a' = a \<Longrightarrow> a \<sqinter> b = b' \<sqinter> a'"
    and "b' = b \<Longrightarrow> a' = a \<Longrightarrow> a \<sqinter> b' = b \<sqinter> a'"
    and "b' = b \<Longrightarrow> a' = a \<Longrightarrow> a' \<sqinter> b = b' \<sqinter> a"
    and "b' = b \<Longrightarrow> a' = a \<Longrightarrow> a \<sqinter> b' = b \<sqinter> a'"
    and "b' = b \<Longrightarrow> a' = a \<Longrightarrow> a' \<sqinter> b' = b \<sqinter> a"
  by (auto simp: inf.commute)

lemmas [V_cs_simps] =
  if_P
  if_not_P
  inf.absorb1
  inf.absorb2
  sup.absorb1
  sup.absorb2
  add_0_right
  add_0

lemmas [V_cs_intros] =
  conjI
  sup_commute'
  inf_commute'
  sup.commute
  inf.commute

subsubsection\<open>Lists for \<open>HOL\<close>\<close>

lemma list_all_singleton: "list_all P [x] = P x" by simp

lemma replicate_one: "replicate 1 x = [x]"
  by (simp add: One_nat_def)

lemma list_all_mono:
  assumes "list_all P xs" and "P \<le> Q"
  shows "list_all Q xs"
  using assms by (metis list.pred_mono_strong rev_predicate1D)

lemma pred_in_set_mono:
  assumes "S \<subseteq> T"
  shows "(\<lambda>x. x \<in> S) \<le> (\<lambda>x. x \<in> T)"
  using assms by auto

lemma elts_subset_mono:
  assumes "S \<subseteq>\<^sub>\<circ> T"
  shows "elts S \<subseteq> elts T"
  using assms by auto

lemma list_all_replicate:
  assumes "P x"
  shows "list_all P (replicate n x)"
  using assms by (metis Ball_set in_set_replicate)

lemma list_all_set:
  assumes "list_all P xs" and "x \<in> list.set xs"
  shows "P x"
  using assms by (induct xs) auto

lemma list_map_id:
  assumes "list_all (\<lambda>x. f x = x) xs"
  shows "map f xs = xs"
  using assms by (induct xs) auto

lemmas [V_cs_simps] =
  List.append.append_Nil
  List.append_Nil2
  List.append.append_Cons
  List.rev.simps(1)
  list.map(1,2)
  rev.simps(2)
  List.map_append
  list_all_append
  replicate.replicate_0
  rev_replicate
  semiring_1_class.of_nat_0
  group_add_class.minus_zero
  group_add_class.minus_minus
  replicate.replicate_Suc
  replicate_one
  list_all_singleton

lemmas [V_cs_intros] =
  exI
  pred_in_set_mono
  elts_subset_mono
  list_all_replicate

subsubsection\<open>Foundations\<close>

abbreviation (input) if3 :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "if3 a b c \<equiv>
    (
      \<lambda>i. if i = 0 \<Rightarrow> a
           | i = 1\<^sub>\<nat> \<Rightarrow> b
           | otherwise \<Rightarrow> c
    )"
lemma if3_0[V_cs_simps]: "if3 a b c 0 = a" by auto
lemma if3_1[V_cs_simps]: "if3 a b c (1\<^sub>\<nat>) = b" by auto
lemma if3_2[V_cs_simps]: "if3 a b c (2\<^sub>\<nat>) = c" by auto

lemma vinsertI1':
  assumes "x' = x"
  shows "x \<in>\<^sub>\<circ> vinsert x' A"
  unfolding assms by (rule vinsertI1)

lemma in_vsingleton[V_cs_intros]:
  assumes "f = a"
  shows "f \<in>\<^sub>\<circ> set {a}"
  unfolding assms by simp

lemma a_in_succ_a: "a \<in>\<^sub>\<circ> succ a" by simp

lemma a_in_succ_xI:
  assumes "a \<in>\<^sub>\<circ> x"
  shows "a \<in>\<^sub>\<circ> succ x"
  using assms by simp

lemma vone_ne[V_cs_intros]: "1\<^sub>\<nat> \<noteq> 0" by clarsimp

lemmas [V_cs_simps] =
  vinsert_set_insert_eq
  beta
  set_empty
  vcard_0

lemmas [V_cs_intros] =
  mem_not_refl
  succ_notin_self
  vset_neq_1
  vset_neq_2
  nin_vinsertI
  vinsertI1'
  vinsertI2
  vfinite_vinsert
  vfinite_vsingleton
  vdisjnt_nin_right
  vdisjnt_nin_left
  vunionI1
  vunionI2
  vunion_in_VsetI
  vintersection_in_VsetI
  vsubset_reflexive
  vsingletonI
  small_insert small_empty
  Limit_vtimes_in_VsetI
  Limit_VPow_in_VsetI
  a_in_succ_a
  vsubset_vempty

subsubsection\<open>Binary relations\<close>

lemma vtimesI'[V_cs_intros]:
  assumes "ab = \<langle>a, b\<rangle>" and "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> B"
  shows "ab \<in>\<^sub>\<circ> A \<times>\<^sub>\<circ> B"
  using assms by simp

lemma vrange_vcomp_vsubset[V_cs_intros]:
  assumes "\<R>\<^sub>\<circ> r \<subseteq>\<^sub>\<circ> B"
  shows "\<R>\<^sub>\<circ> (r \<circ>\<^sub>\<circ> s) \<subseteq>\<^sub>\<circ> B"
  using assms by auto

lemma vrange_vconst_on_vsubset[V_cs_intros]:
  assumes "a \<in>\<^sub>\<circ> R"
  shows "\<R>\<^sub>\<circ> (vconst_on A a) \<subseteq>\<^sub>\<circ> R"
  using assms by auto

lemma vrange_vcomp_eq_vrange[V_cs_simps]:
  assumes "\<D>\<^sub>\<circ> r = \<R>\<^sub>\<circ> s"
  shows "\<R>\<^sub>\<circ> (r \<circ>\<^sub>\<circ> s) = \<R>\<^sub>\<circ> r"
  using assms by (metis vimage_vdomain vrange_vcomp)

lemmas [V_cs_simps] =
  vdomain_vsingleton
  vdomain_vlrestriction
  vdomain_vlrestriction_vsubset
  vdomain_vcomp_vsubset
  vdomain_vconverse
  vrange_vconverse
  vdomain_vconst_on
  vconverse_vtimes
  vdomain_VLambda

lemmas [V_cs_intros] = vcpower_vsubset_mono

subsubsection\<open>Single-valued functions\<close>

lemmas (in vsv) [V_cs_intros] = vsv_axioms

lemma vpair_app:
  assumes "j = a"
  shows "set {\<langle>a, b\<rangle>}\<lparr>j\<rparr> = b"
  unfolding assms by simp

lemmas [V_cs_simps] =
  vpair_app
  vsv.vlrestriction_app
  vsv_vcomp_at
  vid_on_atI

lemmas (in vsv) [V_cs_intros] = vsv_vimageI2'

lemmas [V_cs_intros] =
  vsv_vsingleton
  vsv.vsv_vimageI2'
  vsv_vcomp

subsubsection\<open>Injective single-valued functions\<close>

lemmas (in v11) [V_cs_intros] = v11_axioms

lemma (in v11) v11_vconverse_app_in_vdomain':
  assumes "y \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> r" and "A = \<D>\<^sub>\<circ> r"
  shows "r\<inverse>\<^sub>\<circ>\<lparr>y\<rparr> \<in>\<^sub>\<circ> A"
  using assms(1) unfolding assms(2) by (rule v11_vconverse_app_in_vdomain)

lemmas (in v11) [V_cs_intros] = v11_vconverse_app_in_vdomain'
lemmas [V_cs_intros] = v11.v11_vconverse_app_in_vdomain'

lemmas (in v11) [V_cs_simps] = (*only in the context of v11*)
  v11_app_if_vconverse_app[rotated -2]
  v11_app_vconverse_app
  v11_vconverse_app_app

lemmas [V_cs_simps] =
  v11.v11_vconverse_app[rotated -1]
  v11.v11_app_vconverse_app
  v11.v11_vconverse_app_app

lemmas [V_cs_intros] =
  v11D(1)
  v11.v11_vconverse
  v11_vcomp

subsubsection\<open>Operations on indexed families of sets\<close>

lemmas [V_cs_simps] =
  vprojection_app
  vprojection_vdomain

lemmas [V_cs_intros] = vprojection_vsv

subsubsection\<open>Finite sequences\<close>

lemmas (in vfsequence) [V_cs_intros] = vfsequence_axioms

lemmas (in vfsequence) [V_cs_simps] = vfsequence_vdomain
lemmas [V_cs_simps] = vfsequence.vfsequence_vdomain

lemmas [V_cs_intros] =
  vfsequence.vfsequence_vcons
  vfsequence_vempty

lemmas [V_cs_simps] =
  vfinite_0_left
  vfinite_0_right

subsubsection\<open>Binary relation as a finite sequence\<close>

lemmas [V_cs_simps] =
  fconverse_vunion
  fconverse_ftimes
  vdomain_fflip

lemmas [V_cs_intros] =
  ftimesI2
  vcpower_two_ftimesI

subsubsection\<open>Ordinals\<close>

lemmas [Ord_cs_intros] =
  Limit_right_Limit_mult
  Limit_left_Limit_mult
  Ord_succ_mono
  Limit_plus_omega_vsubset_Limit
  Limit_plus_nat_in_Limit

subsubsection\<open>von Neumann hierarchy\<close>

lemma (in \<Z>) omega_in_any[V_cs_intros]:
  assumes "\<alpha> \<subseteq>\<^sub>\<circ> \<beta>"
  shows "\<omega> \<in>\<^sub>\<circ> \<beta>"
  using assms by auto

lemma Ord_vsubset_succ[V_cs_intros]:
  assumes "Ord \<alpha>" and "Ord \<beta>" and "\<alpha> \<subseteq>\<^sub>\<circ> \<beta>"
  shows "\<alpha> \<subseteq>\<^sub>\<circ> succ \<beta>"
  by (metis Ord_linear_le Ord_succ assms(1) assms(2) assms(3) leD succ_le_iff)

lemma Ord_in_Vset_succ[V_cs_intros]:
  assumes "Ord \<alpha>" and "a \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "a \<in>\<^sub>\<circ> Vset (succ \<alpha>)"
  using assms by (auto simp: Ord_Vset_in_Vset_succI)

lemma Ord_vsubset_Vset_succ[V_cs_intros]:
  assumes "Ord \<alpha>" and "B \<subseteq>\<^sub>\<circ> Vset \<alpha>"
  shows "B \<subseteq>\<^sub>\<circ> Vset (succ \<alpha>)"
  by (intro vsubsetI)
    (auto simp: assms Vset_trans Ord_vsubset_in_Vset_succI)

lemmas (in \<Z>) [V_cs_intros] =
  omega_in_\<alpha>
  Ord_\<alpha>
  Limit_\<alpha>

lemmas [V_cs_intros] =
  vempty_in_Vset_succ
  \<Z>.ord_of_nat_in_Vset
  Vset_in_mono
  Limit_vpair_in_VsetI
  Vset_vsubset_mono
  Ord_succ
  Limit_vempty_in_VsetI
  Limit_insert_in_VsetI
  vfsequence.vfsequence_Limit_vcons_in_VsetI
  vfsequence.vfsequence_Ord_vcons_in_Vset_succI
  Limit_vdoubleton_in_VsetI
  Limit_omega_in_VsetI
  Limit_ftimes_in_VsetI

subsubsection\<open>\<open>n\<close>-ary operations\<close>

lemmas [V_cs_simps] =
  fflip_app
  vdomain_fflip

subsubsection\<open>Countable ordinals as a set\<close>

named_theorems omega_of_set
named_theorems nat_omega_simps_extra

lemmas [nat_omega_simps_extra] =
  add_num_simps
  Suc_numeral
  Suc_1
  le_num_simps
  less_numeral_simps(1,2)
  less_num_simps
  less_one
  nat_omega_simps

lemmas [omega_of_set] = nat_omega_simps_extra

lemma set_insert_succ[omega_of_set]:
  assumes [simp]: "small b" and "set b = a\<^sub>\<nat>"
  shows "set (insert (a\<^sub>\<nat>) b) = succ (a\<^sub>\<nat>)"
  unfolding assms(2)[symmetric] by auto

lemma set_0[omega_of_set]: "set {0} = succ 0" by auto

subsubsection\<open>Sequences\<close>

named_theorems vfsequence_simps
named_theorems vfsequence_intros

lemmas [vfsequence_simps] =
  vfsequence.vfsequence_at_last[rotated]
  vfsequence.vfsequence_vcard_vcons[rotated]
  vfsequence.vfsequence_at_not_last[rotated]

lemmas [vfsequence_intros] =
  vfsequence.vfsequence_vcons
  vfsequence_vempty

subsubsection\<open>Further numerals\<close>

named_theorems nat_omega_intros

lemma [nat_omega_intros]:
  assumes "a < b"
  shows "a\<^sub>\<nat> \<in>\<^sub>\<circ> b\<^sub>\<nat>"
  using assms by simp

lemma [nat_omega_intros]:
  assumes "0 < b"
  shows "0 \<in>\<^sub>\<circ> b\<^sub>\<nat>"
  using assms by auto

lemma [nat_omega_intros]:
  assumes "a = numeral b"
  shows "(0::nat) < a"
  using assms by auto

lemma nat_le_if_in[nat_omega_intros]:
  assumes "x\<^sub>\<nat> \<in>\<^sub>\<circ> y\<^sub>\<nat>"
  shows "x\<^sub>\<nat> \<le> y\<^sub>\<nat>"
  using assms by auto

lemma vempty_le_nat[nat_omega_intros]: "0 \<le> y\<^sub>\<nat>" by auto

lemmas [nat_omega_intros] =
  preorder_class.order_refl
  preorder_class.eq_refl

subsubsection\<open>Generally available foundational results\<close>

lemma (in \<Z>) \<Z>_\<beta>:
  assumes "\<beta> = \<alpha>"
  shows "\<Z> \<beta>"
  unfolding assms by auto

lemmas (in \<Z>) [dg_cs_intros] = \<Z>_\<beta>

text\<open>\newpage\<close>

end


section \<open>Sums in monoids\<close>

theory MonoidSums

imports Main
  "HOL-Algebra.Module"
  RingModuleFacts
  FunctionLemmas
begin

text \<open>We build on the finite product simplifications in FiniteProduct.thy and the analogous ones
for finite sums (see "lemmas" in Ring.thy).\<close>

text \<open>Use as an intro rule\<close>
lemma (in comm_monoid) factors_equal:
  "\<lbrakk>a=b; c=d\<rbrakk> \<Longrightarrow> a\<otimes>\<^bsub>G\<^esub>c =  b\<otimes>\<^bsub>G\<^esub>d"
  by simp

lemma (in comm_monoid) extend_prod:
  fixes a A S
  assumes fin: "finite S" and subset: "A\<subseteq>S" and a: "a\<in>A\<rightarrow>carrier G"
  shows "(\<Otimes>\<^bsub>G\<^esub> x\<in>S. (if x\<in>A then a x else \<one>\<^bsub>G\<^esub>)) = (\<Otimes>\<^bsub>G\<^esub> x\<in>A. a x)"
  (is "(\<Otimes>\<^bsub>G\<^esub> x\<in>S. ?b x) = (\<Otimes>\<^bsub>G\<^esub> x\<in>A. a x)")
proof -
  from subset have uni:"S = A \<union> (S-A)" by auto
  from assms subset show ?thesis
    apply (subst uni)
    apply (subst finprod_Un_disjoint, auto)
    by (auto cong: finprod_cong if_cong elim: finite_subset simp add:Pi_def finite_subset)
(*Pi_def is key for automation here*)
qed

text \<open>Scalar multiplication distributes over scalar multiplication (on left).\<close>(*Add to module.*)
lemma (in module) finsum_smult:
  "[| c\<in> carrier R; g \<in> A \<rightarrow> carrier M |] ==>
   (c \<odot>\<^bsub>M\<^esub> finsum M g A) = finsum M (%x. c \<odot>\<^bsub>M\<^esub> g x) A "
proof (induct A rule: infinite_finite_induct)
  case (insert a A)
  from insert.hyps insert.prems have 1: "finsum M g (insert a A) = g a \<oplus>\<^bsub>M\<^esub> finsum M g A"
    by (intro finsum_insert, auto)
  from insert.hyps insert.prems have 2: "(\<Oplus>\<^bsub>M\<^esub>x\<in>insert a A. c \<odot>\<^bsub>M\<^esub> g x) = c \<odot>\<^bsub>M\<^esub> g a \<oplus>\<^bsub>M\<^esub>(\<Oplus>\<^bsub>M\<^esub>x\<in>A. c \<odot>\<^bsub>M\<^esub> g x)"
    by (intro finsum_insert, auto)
  from insert.hyps insert.prems show ?case
    by (auto simp add:1 2 smult_r_distr)
qed auto

text \<open>Scalar multiplication distributes over scalar multiplication (on right).\<close>(*Add to module.*)
lemma (in module) finsum_smult_r:
  "[| v\<in> carrier M; f \<in> A \<rightarrow> carrier R |] ==>
   (finsum R f A \<odot>\<^bsub>M\<^esub> v) = finsum M (%x. f x \<odot>\<^bsub>M\<^esub> v) A "
proof (induct A rule: infinite_finite_induct)
  case (insert a A)
  from insert.hyps insert.prems have 1: "finsum R f (insert a A) = f a \<oplus>\<^bsub>R\<^esub> finsum R f A"
    by (intro R.finsum_insert, auto)
  from insert.hyps insert.prems have 2: "(\<Oplus>\<^bsub>M\<^esub>x\<in>insert a A. f x \<odot>\<^bsub>M\<^esub> v) = f a \<odot>\<^bsub>M\<^esub> v \<oplus>\<^bsub>M\<^esub>(\<Oplus>\<^bsub>M\<^esub>x\<in>A. f x \<odot>\<^bsub>M\<^esub> v)"
    by (intro finsum_insert, auto)
  from insert.hyps insert.prems show ?case
    by (auto simp add:1 2 smult_l_distr)
qed auto

text \<open>A sequence of lemmas that shows that the product does not depend on the ambient group.
Note I had to dig back into the definitions of foldSet to show this.\<close>
(*Add the following 2 lemmas to Group.*)

lemma foldD_not_depend:
  fixes D E B f e A
  assumes h1: "LCD B D f" and h2: "LCD B E f" and h3: "D\<subseteq>E" and h4: "e\<in>D" and h5: "A\<subseteq>B" and h6: "finite B"
  shows "foldD D f e A = foldD E f e A"
proof -
  from assms have 1: "\<exists>y. (A,y)\<in>foldSetD D f e"
    apply (intro finite_imp_foldSetD, auto)
     apply (metis finite_subset)
    by (unfold LCD_def, auto)
  from 1 obtain y where 2: "(A,y)\<in>foldSetD D f e" by auto
  from assms 2 have 3: "foldD D f e A = y" by (intro LCD.foldD_equality[of B], auto)
  from h3 have 4: "foldSetD D f e \<subseteq> foldSetD E f e" by (rule foldSet_not_depend)
  from 2 4 have 5: "(A,y)\<in>foldSetD E f e" by auto
  from assms 5 have 6: "foldD E f e A = y" by (intro LCD.foldD_equality[of B], auto)
(*(A,y)\<in>f*)
  from 3 6 show ?thesis by auto
qed

lemma (in comm_monoid) finprod_all1[simp]:
  assumes all1:" \<And>a. a\<in>A\<Longrightarrow>f a = \<one>\<^bsub>G\<^esub>"
  shows "(\<Otimes>\<^bsub>G\<^esub> a\<in>A. f a) = \<one>\<^bsub>G\<^esub>"
(*  "[| \<And>a. a\<in>A\<Longrightarrow>f a = \<one>\<^bsub>G\<^esub> |] ==> (\<Otimes>\<^bsub>G\<^esub> a\<in>A. f a) = \<one>\<^bsub>G\<^esub>" won't work with proof - *)
proof -
  from assms show ?thesis
    by (simp cong: finprod_cong)
qed

context abelian_monoid
begin
lemmas summands_equal = add.factors_equal
lemmas extend_sum = add.extend_prod
lemmas finsum_all0 = add.finprod_all1
end

end