theory IMP_Minus_To_IMP_Minus_Minus_State_Translations_nat
  imports IMP_Minus_To_IMP_Minus_Minus_State_Translations Primitives Binary_Arithmetic_Nat
begin

fun dropWhile_char:: "nat \<Rightarrow> nat" where
  "dropWhile_char n =
    (if n = 0
     then 0
     else if hd_nat n = encode_char (CHR ''#'')
          then dropWhile_char (tl_nat n)
          else n
    )"

lemma subdropWhile_char: "dropWhile_char v = dropWhile_nat (\<lambda>i. i = encode_char (CHR ''#'')) v"
  by (induct v rule: dropWhile_char.induct) simp

fun takeWhile_char:: "nat \<Rightarrow> nat" where
  "takeWhile_char n =
    (if n = 0
     then 0
     else if hd_nat n = encode_char (CHR ''#'')
          then (hd_nat n) ## takeWhile_char (tl_nat n)
          else 0
    )"

lemma subtakeWhile_char: "takeWhile_char v =  takeWhile_nat (\<lambda>i. i = encode_char (CHR ''#'')) v"
  by ((induct v rule: takeWhile_char.induct), simp, metis)

fun takeWhile_char_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "takeWhile_char_acc acc n =
    (if n = 0
     then acc
     else if hd_nat n = encode_char (CHR ''#'')
          then takeWhile_char_acc ((hd_nat n) ## acc) (tl_nat n)
          else acc
    )"

lemma takeWhile_char_append:
  "takeWhile_char xs = xs \<Longrightarrow> takeWhile_char (append_nat xs ys) = append_nat xs (takeWhile_char ys)"
proof -
  assume "takeWhile_char xs = xs"
  moreover obtain xs' ys' where "xs = list_encode xs'"  "ys = list_encode ys'"
    by (metis list_decode_inverse)
  ultimately show ?thesis
    by (simp del: takeWhile_char.simps takeWhile_nat.simps add: subtakeWhile_char sub_takeWhile
        sub_append list_encode_eq)
qed

lemma append_nat_cons: "append_nat xs (a ## ys) = append_nat (append_nat xs (a ## 0)) ys"
proof -
  obtain xs' ys' where "xs = list_encode xs'"  "ys = list_encode ys'"
    by (metis list_decode_inverse)
  thus ?thesis by(simp del: list_encode.simps add: cons0 sub_cons sub_append)
qed

lemma takeWhile_char_extend:
  "takeWhile_char xs = xs \<Longrightarrow>
    takeWhile_char (append_nat xs ((encode_char CHR ''#'') ## 0))
      = append_nat xs ((encode_char CHR ''#'') ## 0)"
proof -
  assume "takeWhile_char xs = xs"
  moreover obtain xs' where "xs = list_encode xs'"
    by (metis list_decode_inverse)
  ultimately show ?thesis
    by(simp del: takeWhile_char.simps takeWhile_nat.simps list_encode.simps add: cons0
        subtakeWhile_char sub_takeWhile list_encode_eq sub_append)
qed

lemma takeWhile_char_induct:
  "takeWhile_char xs = xs \<Longrightarrow>
    takeWhile_char (append_nat xs ys)
      = reverse_nat (takeWhile_char_acc (reverse_nat (takeWhile_char xs)) ys)"
  apply (induct ys arbitrary:xs rule:length_nat.induct)
   apply (simp del: takeWhile_char_acc.simps takeWhile_char.simps add: append_nat_0)
   apply (simp add: rev_rev_nat)
  apply (simp only: takeWhile_char_append)
  apply (subst takeWhile_char.simps)
  apply (auto simp del: takeWhile_char_acc.simps takeWhile_char.simps)
  subgoal for v xs
    apply (subst append_nat_cons[of xs])
    apply (simp add: takeWhile_char_extend del: takeWhile_char_acc.simps
        takeWhile_char.simps)
    apply (subst (2) takeWhile_char_acc.simps)
    apply (simp add: reverse_append_nat reverse_singleton_nat append_singleton_nat
        del: takeWhile_char_acc.simps takeWhile_char.simps)
    done
  apply (subst takeWhile_char_acc.simps)
  apply (auto simp add:append_nat_0  rev_rev_nat simp del: takeWhile_char_acc.simps
      takeWhile_char.simps)
  done

definition takeWhile_char_tail:: "nat \<Rightarrow> nat" where
  "takeWhile_char_tail ys = reverse_nat (takeWhile_char_acc 0 ys)"

lemma subtail_takeWhile_char:
  "takeWhile_char_tail ys = takeWhile_char ys"
  using takeWhile_char_induct[of 0]
  by (simp add: reverse_nat_0 takeWhile_char_tail_def)

definition var_to_var_bit_nat:: "nat \<Rightarrow> nat" where
  "var_to_var_bit_nat v =
    (if length_nat v > 0
     then (if hd_nat v = encode_char (CHR ''#'')
           then (let t = dropWhile_char v;
                     l = length_nat (takeWhile_char v) - 1
                 in (if length_nat t > 0 \<and> hd_nat t = encode_char (CHR ''$'')
                     then some_nat (prod_encode(tl_nat t, l))
                     else 0))
           else 0)
     else 0
    )"

definition var_to_var_bit_tail:: "nat \<Rightarrow> nat" where
  "var_to_var_bit_tail v =
    (if length_nat v > 0
     then (if hd_nat v = encode_char (CHR ''#'')
           then (let t = dropWhile_char v;
                     l = length_nat (takeWhile_char_tail v) - 1
                 in (if length_nat t > 0 \<and> hd_nat t = encode_char (CHR ''$'')
                     then some_nat (prod_encode(tl_nat t, l))
                     else 0))
           else 0)
     else 0
    )"

lemma subtail_var_to_var_bit: "var_to_var_bit_tail v = var_to_var_bit_nat v"
  by (simp only: var_to_var_bit_tail_def var_to_var_bit_nat_def subtail_takeWhile_char)

fun vname_nat_encode:: "vname * nat \<Rightarrow> nat" where
  "vname_nat_encode (v, n) = prod_encode (vname_encode v, n)"

fun vname_nat_decode:: "nat \<Rightarrow> vname * nat" where
  "vname_nat_decode n = (let (v, x) = prod_decode n in (vname_decode v, x))"

lemma vne[simp]: "vname_nat_decode (vname_nat_encode x) = x"
  by (metis old.prod.case prod_encode_inverse vname_id vname_nat_decode.simps
      vname_nat_encode.elims)

fun vname_nat_option_encode:: "(vname * nat) option \<Rightarrow> nat" where
  "vname_nat_option_encode None = 0" |
  "vname_nat_option_encode (Some x) = some_nat (vname_nat_encode x)"

fun vname_nat_option_decode:: "nat \<Rightarrow> (vname * nat) option" where
  "vname_nat_option_decode 0 = None" |
  "vname_nat_option_decode (Suc n) = Some (vname_nat_decode n)"

lemma vname_nat_option_id[simp]: "vname_nat_option_decode (vname_nat_option_encode x) = x"
  by (metis option.exhaust vne some_nat_def vname_nat_option_decode.simps
      vname_nat_option_encode.simps)

lemma lambda_encode_char: "(\<lambda>i. i = encode_char x) \<circ> encode_char = (\<lambda>i. i = x)"
  by (auto simp add: idchar)

lemma sub_var_to_var_bit:
  "var_to_var_bit_nat (vname_encode v) = vname_nat_option_encode (var_to_var_bit v)"
  by (auto simp only: subtakeWhile_char subdropWhile_char var_to_var_bit_nat_def vname_encode_def
      sub_length sub_hd sub_dropWhile sub_takeWhile Let_def sub_tl var_to_var_bit_def
      sub_head_map sub_tail_map List.dropWhile_map List.takeWhile_map length_map idchar
      lambda_encode_char vname_nat_option_encode.simps vname_nat_encode.simps split:if_splits)

fun n_hashes_nat :: "nat \<Rightarrow> nat" where
  "n_hashes_nat 0 = 0" |
  "n_hashes_nat (Suc n) = cons (encode_char (CHR ''#'')) (n_hashes_nat n)"

lemma sub_n_hashes: "n_hashes_nat n = vname_encode (n_hashes n)"
  by (induct n) (auto simp :vname_encode_def sub_cons)

fun n_hashes_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "n_hashes_acc acc 0  = acc" |
  "n_hashes_acc acc (Suc n) = n_hashes_acc ((encode_char (CHR ''#'')) ## acc) n"

lemma n_hashes_dashes:
  "reverse_nat (n_hashes_nat (Suc m)) = (encode_char CHR ''#'') ## reverse_nat (n_hashes_nat m)"
  by (induction m)
    (simp add: sub_cons sub_reverse sub_n_hashes vname_encode_def list_encode_eq
      del: list_encode.simps)+

lemma n_hashes_induct:
  "n_hashes_nat (m + n) = reverse_nat (n_hashes_acc (reverse_nat (n_hashes_nat m)) n)"
proof(induct n arbitrary: m)
  case 0
  then show ?case by (simp add: rev_rev_nat)
next
  case (Suc n)
  then show ?case
    by (metis add_Suc_shift n_hashes_acc.simps(2) n_hashes_dashes)
qed

definition n_hashes_tail::"nat \<Rightarrow> nat" where
  "n_hashes_tail n = reverse_nat (n_hashes_acc 0 n)"

lemma subtail_n_hashes: "n_hashes_tail n = n_hashes_nat n"
  using n_hashes_induct[of 0 n]
  by (auto simp del: n_hashes_acc.simps simp add:reverse_nat_0 n_hashes_tail_def)

definition var_bit_to_var_nat:: "nat \<Rightarrow> nat" where
  "var_bit_to_var_nat vk =
  append_nat (append_nat (n_hashes_nat (snd_nat vk + 1)) (vname_encode ''$'')) (fst_nat vk)"

definition var_bit_to_var_tail:: "nat \<Rightarrow> nat" where
  "var_bit_to_var_tail vk =
  append_tail (append_tail (n_hashes_tail (snd_nat vk + 1)) (vname_encode ''$'')) (fst_nat vk)"

lemma subtail_var_bit_to_var:
  "var_bit_to_var_tail vk = var_bit_to_var_nat vk"
  by (simp only:subtail_append var_bit_to_var_nat_def var_bit_to_var_tail_def subtail_n_hashes)

lemma sub_var_bit_to_var:
  "var_bit_to_var_nat (vname_nat_encode vk) = vname_encode (var_bit_to_var vk)"
  by (cases vk) (auto simp only: var_bit_to_var_nat_def sub_snd vname_nat_encode.simps sub_n_hashes
      vname_encode_def sub_append sub_fst fst_def var_bit_to_var_def, simp)

lemma prod_encode_bounded[simp]:" 0 < snd_nat p \<Longrightarrow> prod_encode (fst_nat p, snd_nat p - Suc 0) < p"
proof -
  assume a:"0 < snd_nat p"
  obtain x y where  "prod_decode p = (x,y)"
    by fastforce
  hence xy_def: "p = prod_encode (x,y)"
    by (metis prod_decode_inverse)
  thus ?thesis
    using a
    by (simp add: sub_fst sub_snd xy_def)
      (smt Suc_pred a add.commute add.right_neutral add_Suc add_le_cancel_left
        cancel_comm_monoid_add_class.diff_cancel lessI less_eq_nat.simps(1) less_le_trans not_le
        prod_decode_aux.simps prod_encode_def prod_encode_prod_decode_aux split_conv)
qed

fun operand_bit_to_var_nat:: "nat \<Rightarrow> nat" where
  "operand_bit_to_var_nat p  =
    (if snd_nat p = 0
     then cons (fst_nat p) 0
     else cons (fst_nat p) (operand_bit_to_var_nat (prod_encode (fst_nat p, snd_nat p - 1)))
    )"

fun operand_bit_to_var_acc:: " nat \<Rightarrow> nat \<Rightarrow> nat" where
  "operand_bit_to_var_acc acc p  =
  (if snd_nat p = 0
   then acc
   else (operand_bit_to_var_acc ((fst_nat p) ## acc) (prod_encode (fst_nat p, snd_nat p - 1)))
  )"

lemma operand_bit_to_var_induct:
  "operand_bit_to_var_nat (prod_encode (c, n + m)) =
    operand_bit_to_var_acc (operand_bit_to_var_nat (prod_encode (c, n))) (prod_encode (c, m))"
proof(induct m arbitrary: n)
  case 0
  then show ?case
    by (simp add: sub_snd)
next
  case (Suc m)
  then show ?case
    by ((simp add: sub_fst sub_snd del: operand_bit_to_var_nat.simps operand_bit_to_var_acc.simps),
        (simp only: Suc_plus), (simp add: sub_fst sub_snd))
qed

definition operand_bit_to_var_tail:: "nat \<Rightarrow> nat" where
  "operand_bit_to_var_tail p = operand_bit_to_var_acc (cons (fst_nat p) 0) p"

lemma subtail_operand_bit_to_var:
  "operand_bit_to_var_tail p = operand_bit_to_var_nat p"
proof -
  obtain c m where "p = prod_encode (c,m)"
    by (metis operand_bit_to_var_acc.cases prod_decode_inverse)
  thus ?thesis using operand_bit_to_var_induct[of c 0 m]
    by(simp add: operand_bit_to_var_tail_def sub_fst sub_snd)
qed

fun char_nat_encode ::"char * nat \<Rightarrow> nat " where
  "char_nat_encode (x, n) = prod_encode (encode_char x, n)"

fun char_nat_decode ::" nat \<Rightarrow> (char * nat) " where
  "char_nat_decode p = (let (x, n) = prod_decode p in (decode_char x, n))"

lemma char_nat_decode_inverse[simp]: "char_nat_decode (char_nat_encode x) = x"
  by (simp add: idcharorg)
    (metis case_prod_beta char_nat_encode.simps comp_apply id_apply idcharorg prod.exhaust_sel
      prod.sel(1) prod_encode_inverse snd_conv)

lemma sub_operand_bit_to_var:
  "operand_bit_to_var_nat (char_nat_encode p) = vname_encode (operand_bit_to_var p)"
proof(cases p)
  case (Pair a b) thus ?thesis
    by (induct b arbitrary: p) (simp add: cons_def sub_fst sub_snd vname_encode_def)+
qed

definition var_to_operand_bit_nat:: "nat \<Rightarrow> nat" where
  "var_to_operand_bit_nat v =
  (if v \<noteq> 0 \<and> v = (operand_bit_to_var_nat (prod_encode (hd_nat v, length_nat v - 1)))
   then some_nat (prod_encode (hd_nat v, length_nat v - 1))
   else 0
  )"

definition var_to_operand_bit_tail:: "nat \<Rightarrow> nat" where
  "var_to_operand_bit_tail v =
  (if v \<noteq> 0 \<and> v = (operand_bit_to_var_tail (prod_encode (hd_nat v, length_nat v - 1)))
   then some_nat (prod_encode (hd_nat v, length_nat v - 1))
   else 0
  )"

lemma subtail_var_to_operand_bit: "var_to_operand_bit_tail v = var_to_operand_bit_nat v"
  by (simp only: var_to_operand_bit_tail_def var_to_operand_bit_nat_def subtail_operand_bit_to_var)

fun char_nat_option_encode:: "(char * nat) option \<Rightarrow> nat" where
  "char_nat_option_encode None = 0" |
  "char_nat_option_encode (Some x) = Suc (char_nat_encode x)"

fun char_nat_option_decode :: "nat \<Rightarrow> (char*nat) option" where
  "char_nat_option_decode 0 = None" |
  "char_nat_option_decode (Suc n) = Some (char_nat_decode n)"

lemma char_nat_option_id[simp]: "char_nat_option_decode (char_nat_option_encode x) = x"
  by (cases x) (auto simp add: decode_char_def encode_char_def)

lemma sub_head_enc_map: "vname_encode v \<noteq> 0 \<Longrightarrow> head (map encode_char v) = encode_char (hd v)"
  by (simp add: vname_encode_def list_encode_eq sub_head_map flip: list_encode.simps)

lemma list_encode_non_empty: "(list_encode xs = 0) = (xs = [])"
  using list_encode_eq by fastforce

lemma sub_var_to_operand_bit:
  "var_to_operand_bit_nat (vname_encode v) = char_nat_option_encode (var_to_operand_bit v)"
  by (simp only: var_to_operand_bit_nat_def vname_encode_def sub_hd sub_length length_map
      var_to_operand_bit_def sub_some) (smt char_nat_encode.simps char_nat_option_encode.simps
      option_encode.simps(2) vname_encode_def vname_id sub_operand_bit_to_var sub_head_enc_map
      list_encode_non_empty map_is_Nil_conv)

definition IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_list::
  "(vname,val) assignment list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> vname \<Rightarrow> bit option" where
  "IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_list s n a b v =
  (case var_to_var_bit v of
    Some (v', k) \<Rightarrow> if k < n then Some (nth_bit (fun_list_find s v') k) else None |
    None \<Rightarrow> (case var_to_operand_bit v of
              Some (CHR ''a'', k) \<Rightarrow> if k < n then Some (nth_bit a k) else None |
              Some (CHR ''b'', k) \<Rightarrow> if k < n then Some (nth_bit b k) else None |
    _ \<Rightarrow> (if v = ''carry'' then Some Zero else None))
  )"

lemma sublist_IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b:
  "IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_list s n a b v
    = IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b (fun_of s) n a b v"
  by (simp only: IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_list_def
      sub_fun_list_find IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def)

definition IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_nat::
  "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_nat s n a b v =
    (if var_to_var_bit_nat v \<noteq> 0
     then (let v' = fst_nat (var_to_var_bit_nat v - 1);
                k = snd_nat (var_to_var_bit_nat v - 1)
           in if k < n
              then some_nat (nth_bit_nat (fun_list_find_nat  s v') k)
              else 0)
     else (let v' = fst_nat (var_to_operand_bit_nat v - 1);
                k = snd_nat (var_to_operand_bit_nat v - 1)
             in if var_to_operand_bit_nat v \<noteq> 0 \<and> v' = encode_char (CHR ''a'')
                then if k < n
                     then Suc (nth_bit_nat a k)
                     else 0
                else if var_to_operand_bit_nat v \<noteq> 0 \<and> v' = encode_char (CHR ''b'')
                     then if k < n
                          then Suc (nth_bit_nat b k)
                          else 0
                     else if v = vname_encode (''carry'')
                           then Suc 0
                           else 0)
    )"

definition IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_tail::
  "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_tail s n a b v =
    (if var_to_var_bit_tail v \<noteq> 0
     then (let v' = fst_nat (var_to_var_bit_tail v - 1);
                k = snd_nat (var_to_var_bit_tail v - 1)
           in if k < n
              then some_nat (nth_bit_tail (fun_list_find_tail s v') k)
              else 0)
     else (let v' = fst_nat (var_to_operand_bit_tail v - 1);
                k = snd_nat (var_to_operand_bit_tail v - 1)
           in if var_to_operand_bit_tail v \<noteq> 0 \<and> v' = encode_char (CHR ''a'')
              then if k < n
                   then Suc (nth_bit_tail a k)
                   else 0
              else if var_to_operand_bit_tail v \<noteq> 0 \<and> v' = encode_char (CHR ''b'')
                   then if k < n
                        then Suc (nth_bit_tail b k)
                        else 0
                   else (if v = vname_encode (''carry'') then Suc 0 else 0))
    )"

lemma subtail_IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b:
  "IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_tail s n a b v
    = IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_nat s n a b v"
  by (simp only: IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_tail_def
      IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_nat_def subtail_var_to_operand_bit
      subtail_nth_bit subtail_var_to_var_bit subtail_fun_list_find)

lemma impm_assignment_simp: "impm_assignment_encode = prod_encode o (\<lambda>(x, y). (vname_encode x, y))"
  by fastforce

lemma vname_inj_simp: "(vname_encode x = vname_encode y) = (x = y)"
  using vname_inj by (auto simp add: inj_def)

lemma char_inj_simp: "(encode_char x = encode_char y) = (x=y)"
  using idchar by (auto simp add: inj_def)

lemma vname_nat_option_encode_0: "(vname_nat_option_encode x = 0) = (x = None)"
  by (cases x) auto

lemma bit_option_encode_0: "(bit_option_encode x = 0) = (x = None)"
  by (cases x) auto

lemma char_nat_option_encode_0: "(char_nat_option_encode x = 0) = (x = None)"
  by (cases x) auto

lemma subnat_IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b:
  "IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_nat
    (impm_assignment_list_encode s) n a b (vname_encode v)
      = bit_option_encode (IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_list s n a b v)"
  apply (cases "var_to_var_bit v")
   apply (cases "var_to_operand_bit v")
    apply (simp add: IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_list_def
      IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_nat_def sub_var_to_operand_bit
      sub_var_to_var_bit vname_inj_simp)
   apply (simp add: IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_nat_def )
   apply (auto simp only: vname_inj Let_def sub_nth_bit vname_nat_option_encode.simps
      vname_inj_simp sub_var_to_var_bit)[1]
    apply simp
   apply (simp add:sub_snd sub_fst bit_option_encode_0 char_inj_simp sub_var_to_operand_bit
      IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_list_def)
   apply (smt char.case char.exhaust)
  apply (simp add: IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_nat_def sub_var_to_var_bit)
  apply (auto simp only: vname_inj sub_snd  sub_fst fst_def sub_nth_bit vname_nat_encode.simps
      IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_list_def impm_assignment_list_encode_def
      impm_assignment_simp sub_fun_list_find_nat inj_fun_list_find simp flip: One_nat_def map_map,
      simp)[1]
  done

definition IMP_Minus_State_To_IMP_Minus_Minus_partial_list::
  "(vname, nat) assignment list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> vname \<Rightarrow> bit option" where
  "IMP_Minus_State_To_IMP_Minus_Minus_partial_list s n r v =
    (case var_to_var_bit v of
      Some (v', k) \<Rightarrow>
        if k \<ge> n
        then None
        else if k < r
              then map_list_find (map (\<lambda>(x, y). (x, nth_bit y k)) s) v'
              else Some Zero |
      None \<Rightarrow>
        (case var_to_operand_bit v of
          Some (CHR ''a'', k) \<Rightarrow>
            if k < n
            then Some Zero
            else None |
          Some (CHR ''b'', k) \<Rightarrow>
            if k < n
            then Some Zero
            else None |
          _ \<Rightarrow>
            if v = ''carry''
            then Some Zero
            else None
        )
    )"

lemma sub_lambda_partial:
  "((\<lambda>x. Some (nth_bit x k)) \<circ>\<^sub>m map_of s) v' = map_list_find (map (\<lambda>(x, y). (x, nth_bit y k)) s) v'"
  by (induct s) (auto simp add: map_comp_def)

lemma sublist_IMP_Minus_State_To_IMP_Minus_Minus_partial:
  "IMP_Minus_State_To_IMP_Minus_Minus_partial_list s n r v
    = IMP_Minus_State_To_IMP_Minus_Minus_partial (map_of s) n r v"
  by (simp only:IMP_Minus_State_To_IMP_Minus_Minus_partial_list_def sub_lambda_partial
      IMP_Minus_State_To_IMP_Minus_Minus_partial_def)

fun map_IMP_Minus_State_To_IMP_Minus_Minus_partial:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "map_IMP_Minus_State_To_IMP_Minus_Minus_partial k n =
    (if n = 0
     then 0
     else (prod_encode (fst_nat (hd_nat n), nth_bit_nat (snd_nat (hd_nat n)) k)) ##
           map_IMP_Minus_State_To_IMP_Minus_Minus_partial k (tl_nat n)
    )"

fun map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc acc k n =
    (if n = 0
     then acc
     else
      map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc
        ((prod_encode (fst_nat (hd_nat n), nth_bit_nat (snd_nat (hd_nat n)) k)) ## acc) k (tl_nat n)
    )"

lemma submap_IMP_Minus_State_To_IMP_Minus_Minus_partial:
  "map_IMP_Minus_State_To_IMP_Minus_Minus_partial k s
     = map_nat (\<lambda>n. prod_encode(fst_nat n, nth_bit_nat (snd_nat n) k)) s"
  by (induct k s rule: map_IMP_Minus_State_To_IMP_Minus_Minus_partial.induct) simp

lemma map_IMP_Minus_state_append:
  "map_IMP_Minus_State_To_IMP_Minus_Minus_partial k (append_nat xs ys)
    = append_nat (map_IMP_Minus_State_To_IMP_Minus_Minus_partial k xs)
                 (map_IMP_Minus_State_To_IMP_Minus_Minus_partial k ys)"
proof -
  obtain xs' ys' where  "xs = list_encode xs'" "ys = list_encode ys'"
    by (metis list_decode_inverse)
  thus ?thesis
    by (simp del:map_IMP_Minus_State_To_IMP_Minus_Minus_partial.simps map_nat.simps add: sub_map
        submap_IMP_Minus_State_To_IMP_Minus_Minus_partial sub_append)
qed

lemma map_IMP_Minus_State_To_IMP_Minus_Minus_partial_induct:
  "map_IMP_Minus_State_To_IMP_Minus_Minus_partial k (append_nat xs ys)
    = reverse_nat
        (map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc
          (reverse_nat (map_IMP_Minus_State_To_IMP_Minus_Minus_partial k xs)) k ys)"
  apply(induct ys arbitrary: xs rule: length_nat.induct)
   apply(simp add: append_nat_0  del: map_IMP_Minus_State_To_IMP_Minus_Minus_partial.simps
      map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc.simps)
   apply(subst map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc.simps)
   apply(simp add: rev_rev_nat append_nat_Suc
      del: map_IMP_Minus_State_To_IMP_Minus_Minus_partial.simps
      map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc.simps)+
  apply(subst (2) map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc.simps)
  apply(simp add:  map_IMP_Minus_state_append reverse_append_nat
      del: map_IMP_Minus_State_To_IMP_Minus_Minus_partial.simps
      map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc.simps)
  apply(subst map_IMP_Minus_State_To_IMP_Minus_Minus_partial.simps)
  apply(simp add: sub_hd cons0 sub_tl del: list_encode.simps
      map_IMP_Minus_State_To_IMP_Minus_Minus_partial.simps
      map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc.simps)
  apply(simp only: list_encode.simps)
  apply(simp add: reverse_singleton_nat append_singleton_nat)
  done

definition map_IMP_Minus_State_To_IMP_Minus_Minus_partial_tail:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "map_IMP_Minus_State_To_IMP_Minus_Minus_partial_tail k ys =
    reverse_nat (map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc 0 k ys)"

lemma subtail_map_IMP_Minus_State_To_IMP_Minus_Minus_partial:
  "map_IMP_Minus_State_To_IMP_Minus_Minus_partial_tail k ys
    = map_IMP_Minus_State_To_IMP_Minus_Minus_partial k ys"
  using map_IMP_Minus_State_To_IMP_Minus_Minus_partial_induct[of k 0 ys]
  by (simp add: reverse_nat_0 map_IMP_Minus_State_To_IMP_Minus_Minus_partial_tail_def)

definition IMP_Minus_State_To_IMP_Minus_Minus_partial_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "IMP_Minus_State_To_IMP_Minus_Minus_partial_nat s n r v =
    (let p = var_to_var_bit_nat v;
        v' = fst_nat (p - 1);
         k = snd_nat (p - 1)
     in if p \<noteq> 0
        then if k \<ge> n
             then 0
             else if k < r
                  then map_list_find_nat (map_IMP_Minus_State_To_IMP_Minus_Minus_partial k s) v'
                  else Suc 0
        else (let po = var_to_operand_bit_nat v;
                  vo = fst_nat (po-1);
                  ko = snd_nat (po-1)
              in if po \<noteq> 0 \<and> vo = encode_char CHR ''a''
                 then if ko < n
                      then Suc 0
                      else 0
                 else if po \<noteq> 0 \<and> vo = encode_char CHR ''b''
                      then if ko < n
                           then Suc 0
                           else 0
                      else if v = vname_encode ''carry''
                           then Suc 0
                           else 0)
    )"

definition IMP_Minus_State_To_IMP_Minus_Minus_partial_tail::
  "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "IMP_Minus_State_To_IMP_Minus_Minus_partial_tail s n r v =
    (let p = var_to_var_bit_tail v;
        v' = fst_nat (p - 1);
         k = snd_nat (p - 1)
     in if p \<noteq> 0
        then if k \<ge> n
             then 0
             else if k < r
                  then map_list_find_tail (map_IMP_Minus_State_To_IMP_Minus_Minus_partial_tail k s) v'
                  else Suc 0
        else (let po = var_to_operand_bit_tail v;
                  vo = fst_nat (po-1);
                  ko = snd_nat (po-1)
              in if po \<noteq> 0 \<and> vo = encode_char CHR ''a''
                 then if ko < n
                      then Suc 0
                      else 0
                 else if po \<noteq> 0 \<and> vo = encode_char CHR ''b''
                      then if ko < n
                           then Suc 0
                           else 0
                      else if v = vname_encode ''carry''
                           then Suc 0
                           else 0)
    )"

lemma subtail_IMP_Minus_State_To_IMP_Minus_Minus_partial:
  "IMP_Minus_State_To_IMP_Minus_Minus_partial_tail s n r v
    = IMP_Minus_State_To_IMP_Minus_Minus_partial_nat s n r v"
  by (simp only: IMP_Minus_State_To_IMP_Minus_Minus_partial_tail_def
      IMP_Minus_State_To_IMP_Minus_Minus_partial_nat_def
      subtail_map_list_find subtail_var_to_operand_bit subtail_var_to_var_bit
      subtail_map_IMP_Minus_State_To_IMP_Minus_Minus_partial)

lemma snd_nat_0: "snd_nat 0 = 0"
  by (simp add: snd_nat_def prod_decode_def prod_decode_aux.simps)

lemma fst_nat_0: "fst_nat 0 = 0"
  by (simp add: fst_nat_def prod_decode_def prod_decode_aux.simps)

lemma fst_impm: "fst_nat (impm_assignment_encode x) = vname_encode (fst x)"
  by (cases x) (simp add: sub_fst)

lemma snd_impm: "snd_nat (impm_assignment_encode x) = snd x"
  by (cases x) (simp add:sub_snd)

lemma subnat_IMP_Minus_State_To_IMP_Minus_Minus_partial:
  "IMP_Minus_State_To_IMP_Minus_Minus_partial_nat
    (impm_assignment_list_encode s) n r (vname_encode v)
      = bit_option_encode (IMP_Minus_State_To_IMP_Minus_Minus_partial_list s n r v)"
  apply (cases "var_to_var_bit v")
   apply (cases "var_to_operand_bit v")
    apply (auto simp add:IMP_Minus_State_To_IMP_Minus_Minus_partial_nat_def
      impm_assignment_list_encode_def vname_nat_option_encode_0)
       apply (auto simp only: submap_IMP_Minus_State_To_IMP_Minus_Minus_partial)
       apply (auto simp only: Let_def sub_map sub_var_to_var_bit sub_snd sub_fst vname_inj_simp
      vname_nat_option_encode.simps zero_diff)
       apply (auto simp only: snd_nat_0 fst_nat_0 sub_map_list_find_nat
      simp flip: comp_def [of prod_encode "\<lambda>n.(fst_nat n,nth_bit_nat (snd_nat n) _ )"] map_map)
       apply (auto simp only: map_map comp_def fst_impm snd_impm sub_nth_bit)
       apply (auto simp add: IMP_Minus_State_To_IMP_Minus_Minus_partial_list_def sub_fst fst_nat_0
      sub_var_to_operand_bit bit_option_encode_0 char_inj_simp sub_snd)
    apply (smt char.case char.exhaust)
   apply (smt char.case char.exhaust)
  apply (induct s)
   apply (auto simp add:vname_inj_simp)
  done

definition IMP_Minus_State_To_IMP_Minus_Minus_list::
  "(vname,nat) assignment list \<Rightarrow> nat \<Rightarrow> vname \<Rightarrow> bit option" where
  "IMP_Minus_State_To_IMP_Minus_Minus_list s n v =
    IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_list s n 0 0 v"

lemma sublist_IMP_Minus_State_To_IMP_Minus_Minus:
  "IMP_Minus_State_To_IMP_Minus_Minus_list s n v
    = IMP_Minus_State_To_IMP_Minus_Minus (fun_of s) n v"
  by (simp add: IMP_Minus_State_To_IMP_Minus_Minus_list_def IMP_Minus_State_To_IMP_Minus_Minus_def
      sublist_IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b)

definition IMP_Minus_State_To_IMP_Minus_Minus_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "IMP_Minus_State_To_IMP_Minus_Minus_nat s n v
    = IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_nat s n 0 0 v"

definition IMP_Minus_State_To_IMP_Minus_Minus_tail:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "IMP_Minus_State_To_IMP_Minus_Minus_tail s n v
   = IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_tail s n 0 0 v"

lemma subtail_IMP_Minus_State_To_IMP_Minus_Minus:
  "IMP_Minus_State_To_IMP_Minus_Minus_tail s n v
    = IMP_Minus_State_To_IMP_Minus_Minus_nat s n v"
  by (simp only: IMP_Minus_State_To_IMP_Minus_Minus_tail_def
      IMP_Minus_State_To_IMP_Minus_Minus_nat_def
      subtail_IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b)

lemma subnat_IMP_Minus_State_To_IMP_Minus_Minus:
  "IMP_Minus_State_To_IMP_Minus_Minus_nat (impm_assignment_list_encode s) n (vname_encode v)
    = bit_option_encode (IMP_Minus_State_To_IMP_Minus_Minus_list s n v)"
  by (simp add: IMP_Minus_State_To_IMP_Minus_Minus_nat_def
      IMP_Minus_State_To_IMP_Minus_Minus_list_def
      subnat_IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b)

end


(*  Title:      Jinja/Common/TypeRel.thy
    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

header {* \isaheader{Relations between Jinja Types} *}

theory TypeRel imports
  "~~/src/HOL/Library/Transitive_Closure_Table"
  Decl
begin

subsection{* The subclass relations *}

inductive_set
  subcls1 :: "'m prog \<Rightarrow> (cname \<times> cname) set"
  and subcls1' :: "'m prog \<Rightarrow> [cname, cname] \<Rightarrow> bool" ("_ \<turnstile> _ \<prec>\<^sup>1 _" [71,71,71] 70)
  for P :: "'m prog"
where
  "P \<turnstile> C  \<prec>\<^sup>1 D \<equiv> (C,D) \<in> subcls1 P"
| subcls1I: "\<lbrakk>class P C = Some (D,rest); C \<noteq> Object\<rbrakk> \<Longrightarrow> P \<turnstile> C \<prec>\<^sup>1 D"

abbreviation
  subcls  :: "'m prog \<Rightarrow> [cname, cname] \<Rightarrow> bool" ("_ \<turnstile> _ \<preceq>\<^sup>* _"  [71,71,71] 70)
  where "P \<turnstile> C  \<preceq>\<^sup>*  D \<equiv> (C,D) \<in> (subcls1 P)\<^sup>*"

lemma subcls1D: "P \<turnstile> C \<prec>\<^sup>1 D \<Longrightarrow> C \<noteq> Object \<and> (\<exists>fs ms. class P C = Some (D,fs,ms))"
(*<*)by(erule subcls1.induct)(fastforce simp add:is_class_def)(*>*)

lemma [iff]: "(P \<turnstile> Object \<preceq>\<^sup>* C) = (C = Object)"
(*<*)
apply(rule iffI)
 apply(erule converse_rtranclE)
  apply simp_all
done
(*>*)

lemma subcls1_def2:
  "subcls1 P =
     (SIGMA C:{C. is_class P C}. {D. C\<noteq>Object \<and> fst (the (class P C))=D})"
(*<*)
  by (fastforce simp:is_class_def dest: subcls1D elim: subcls1I)
(*>*)

lemma finite_subcls1: "finite (subcls1 P)"
(*<*)
apply (simp add: subcls1_def2)
apply(rule finite_SigmaI [OF finite_is_class])
apply(rule_tac B = "{fst (the (class P C))}" in finite_subset)
apply  auto
done
(*>*)
(*
lemma subcls_is_class: "(C,D) \<in> (subcls1 P)\<^sup>+ \<Longrightarrow> is_class P C"
apply (unfold is_class_def)
apply(erule trancl_trans_induct)
apply (auto dest!: subcls1D)
done

lemma subcls_is_class: "P \<turnstile> C \<preceq>\<^sup>* D \<Longrightarrow> is_class P D \<longrightarrow> is_class P C"
apply (unfold is_class_def)
apply (erule rtrancl_induct)
apply  (drule_tac [2] subcls1D)
apply  auto
done
*)

subsection{* The subtype relations *}

inductive
  widen   :: "'m prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ \<le> _"   [71,71,71] 70)
  for P :: "'m prog"
where
  widen_refl[iff]: "P \<turnstile> T \<le> T"
| widen_subcls: "P \<turnstile> C \<preceq>\<^sup>* D  \<Longrightarrow>  P \<turnstile> Class C \<le> Class D"
| widen_null[iff]: "P \<turnstile> NT \<le> Class C"

abbreviation (xsymbols)
  widens :: "'m prog \<Rightarrow> ty list \<Rightarrow> ty list \<Rightarrow> bool"
    ("_ \<turnstile> _ [\<le>] _" [71,71,71] 70) where
  "widens P Ts Ts' \<equiv> list_all2 (widen P) Ts Ts'"

lemma [iff]: "(P \<turnstile> T \<le> Void) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> T \<le> Boolean) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> T \<le> Integer) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Void \<le> T) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Boolean \<le> T) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Integer \<le> T) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma Class_widen: "P \<turnstile> Class C \<le> T  \<Longrightarrow>  \<exists>D. T = Class D"
(*<*)
apply (ind_cases "P \<turnstile> Class C \<le> T")
apply auto
done
(*>*)

lemma [iff]: "(P \<turnstile> T \<le> NT) = (T = NT)"
(*<*)
apply(cases T)
apply(auto dest:Class_widen)
done
(*>*)

lemma Class_widen_Class [iff]: "(P \<turnstile> Class C \<le> Class D) = (P \<turnstile> C \<preceq>\<^sup>* D)"
(*<*)
apply (rule iffI)
apply (ind_cases "P \<turnstile> Class C \<le> Class D")
apply (auto elim: widen_subcls)
done
(*>*)

lemma widen_Class: "(P \<turnstile> T \<le> Class C) = (T = NT \<or> (\<exists>D. T = Class D \<and> P \<turnstile> D \<preceq>\<^sup>* C))"
(*<*)by(induct T, auto)(*>*)

lemma widen_trans[trans]: "\<lbrakk>P \<turnstile> S \<le> U; P \<turnstile> U \<le> T\<rbrakk> \<Longrightarrow> P \<turnstile> S \<le> T"
(*<*)
proof -
  assume "P\<turnstile>S \<le> U" thus "\<And>T. P \<turnstile> U \<le> T \<Longrightarrow> P \<turnstile> S \<le> T"
  proof induct
    case (widen_refl T T') thus "P \<turnstile> T \<le> T'" .
  next
    case (widen_subcls C D T)
    then obtain E where "T = Class E" by (blast dest: Class_widen)
    with widen_subcls show "P \<turnstile> Class C \<le> T" by (auto elim: rtrancl_trans)
  next
    case (widen_null C RT)
    then obtain D where "RT = Class D" by (blast dest: Class_widen)
    thus "P \<turnstile> NT \<le> RT" by auto
  qed
qed
(*>*)

lemma widens_trans [trans]: "\<lbrakk>P \<turnstile> Ss [\<le>] Ts; P \<turnstile> Ts [\<le>] Us\<rbrakk> \<Longrightarrow> P \<turnstile> Ss [\<le>] Us"
(*<*)by (rule list_all2_trans, rule widen_trans)(*>*)

(*<*)
lemmas widens_refl [iff] = list_all2_refl [of "widen P", OF widen_refl] for P
lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P
(*>*)

subsection{* Method lookup *}

inductive
  Methods :: "['m prog, cname, mname \<rightharpoonup> (ty list \<times> ty \<times> 'm) \<times> cname] \<Rightarrow> bool"
                    ("_ \<turnstile> _ sees'_methods _" [51,51,51] 50)
  for P :: "'m prog"
where
  sees_methods_Object:
 "\<lbrakk> class P Object = Some(D,fs,ms); Mm = map_option (\<lambda>m. (m,Object)) \<circ> map_of ms \<rbrakk>
  \<Longrightarrow> P \<turnstile> Object sees_methods Mm"
| sees_methods_rec:
 "\<lbrakk> class P C = Some(D,fs,ms); C \<noteq> Object; P \<turnstile> D sees_methods Mm;
    Mm' = Mm ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms) \<rbrakk>
  \<Longrightarrow> P \<turnstile> C sees_methods Mm'";

lemma sees_methods_fun:
assumes 1: "P \<turnstile> C sees_methods Mm"
shows "\<And>Mm'. P \<turnstile> C sees_methods Mm' \<Longrightarrow> Mm' = Mm"
 (*<*)
using 1
proof induct
  case (sees_methods_rec C D fs ms Dres Cres Cres')
  have "class": "class P C = Some (D, fs, ms)"
   and notObj: "C \<noteq> Object" and Dmethods: "P \<turnstile> D sees_methods Dres"
   and IH: "\<And>Dres'. P \<turnstile> D sees_methods Dres' \<Longrightarrow> Dres' = Dres"
   and Cres: "Cres = Dres ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms)"
   and Cmethods': "P \<turnstile> C sees_methods Cres'" by fact+
  from Cmethods' notObj "class" obtain Dres'
    where Dmethods': "P \<turnstile> D sees_methods Dres'"
     and Cres': "Cres' = Dres' ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms)"
    by(auto elim: Methods.cases)
  from Cres Cres' IH[OF Dmethods'] show "Cres' = Cres" by simp
next
  case sees_methods_Object thus ?case by(auto elim: Methods.cases)
qed
(*>*)

lemma visible_methods_exist:
  "P \<turnstile> C sees_methods Mm \<Longrightarrow> Mm M = Some(m,D) \<Longrightarrow>
   (\<exists>D' fs ms. class P D = Some(D',fs,ms) \<and> map_of ms M = Some m)"
 (*<*)by(induct rule:Methods.induct) auto(*>*)

lemma sees_methods_decl_above:
assumes Csees: "P \<turnstile> C sees_methods Mm"
shows "Mm M = Some(m,D) \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
 (*<*)
using Csees
proof induct
  case sees_methods_Object thus ?case by auto
next
  case sees_methods_rec thus ?case
    by(fastforce simp:map_option_case split:option.splits
                elim:converse_rtrancl_into_rtrancl[OF subcls1I])
qed
(*>*)

lemma sees_methods_idemp:
assumes Cmethods: "P \<turnstile> C sees_methods Mm"
shows "\<And>m D. Mm M = Some(m,D) \<Longrightarrow>
              \<exists>Mm'. (P \<turnstile> D sees_methods Mm') \<and> Mm' M = Some(m,D)"
(*<*)
using Cmethods
proof induct
  case sees_methods_Object thus ?case
    by(fastforce dest: Methods.sees_methods_Object)
next
  case sees_methods_rec thus ?case
    by(fastforce split:option.splits dest: Methods.sees_methods_rec)
qed
(*>*)

(*FIXME something wrong with induct: need to attache [consumes 1]
directly to proof of thm, declare does not work. *)

lemma sees_methods_decl_mono:
assumes sub: "P \<turnstile> C' \<preceq>\<^sup>* C"
shows "P \<turnstile> C sees_methods Mm \<Longrightarrow>
       \<exists>Mm' Mm\<^sub>2. P \<turnstile> C' sees_methods Mm' \<and> Mm' = Mm ++ Mm\<^sub>2 \<and>
                 (\<forall>M m D. Mm\<^sub>2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C)"
(*<*)
      (is "_ \<Longrightarrow> \<exists>Mm' Mm2. ?Q C' C Mm' Mm2")
using sub
proof (induct rule:converse_rtrancl_induct)
  assume "P \<turnstile> C sees_methods Mm"
  hence "?Q C C Mm empty" by simp
  thus "\<exists>Mm' Mm2. ?Q C C Mm' Mm2" by blast
next
  fix C'' C'
  assume sub1: "P \<turnstile> C'' \<prec>\<^sup>1 C'" and sub: "P \<turnstile> C' \<preceq>\<^sup>* C"
  and IH: "P \<turnstile> C sees_methods Mm \<Longrightarrow>
           \<exists>Mm' Mm2. P \<turnstile> C' sees_methods Mm' \<and>
                Mm' = Mm ++ Mm2 \<and> (\<forall>M m D. Mm2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C)"
  and Csees: "P \<turnstile> C sees_methods Mm"
  from IH[OF Csees] obtain Mm' Mm2 where C'sees: "P \<turnstile> C' sees_methods Mm'"
    and Mm': "Mm' = Mm ++ Mm2"
    and subC:"\<forall>M m D. Mm2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C" by blast
  obtain fs ms where "class": "class P C'' = Some(C',fs,ms)" "C'' \<noteq> Object"
    using subcls1D[OF sub1] by blast
  let ?Mm3 = "map_option (\<lambda>m. (m,C'')) \<circ> map_of ms"
  have "P \<turnstile> C'' sees_methods (Mm ++ Mm2) ++ ?Mm3"
    using sees_methods_rec[OF "class" C'sees refl] Mm' by simp
  hence "?Q C'' C ((Mm ++ Mm2) ++ ?Mm3) (Mm2++?Mm3)"
    using converse_rtrancl_into_rtrancl[OF sub1 sub]
    by simp (simp add:map_add_def subC split:option.split)
  thus "\<exists>Mm' Mm2. ?Q C'' C Mm' Mm2" by blast
qed
(*>*)

definition Method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> 'm \<Rightarrow> cname \<Rightarrow> bool"
            ("_ \<turnstile> _ sees _: _\<rightarrow>_ = _ in _" [51,51,51,51,51,51,51] 50)
where
  "P \<turnstile> C sees M: Ts\<rightarrow>T = m in D  \<equiv>
  \<exists>Mm. P \<turnstile> C sees_methods Mm \<and> Mm M = Some((Ts,T,m),D)"

definition has_method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> bool" ("_ \<turnstile> _ has _" [51,0,51] 50)
where
  "P \<turnstile> C has M \<equiv> \<exists>Ts T m D. P \<turnstile> C sees M:Ts\<rightarrow>T = m in D"

lemma sees_method_fun:
  "\<lbrakk>P \<turnstile> C sees M:TS\<rightarrow>T = m in D; P \<turnstile> C sees M:TS'\<rightarrow>T' = m' in D' \<rbrakk>
   \<Longrightarrow> TS' = TS \<and> T' = T \<and> m' = m \<and> D' = D"
 (*<*)by(fastforce dest: sees_methods_fun simp:Method_def)(*>*)

lemma sees_method_decl_above:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
 (*<*)by(clarsimp simp:Method_def sees_methods_decl_above)(*>*)

lemma visible_method_exists:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow>
  \<exists>D' fs ms. class P D = Some(D',fs,ms) \<and> map_of ms M = Some(Ts,T,m)"
(*<*)by(fastforce simp:Method_def dest!: visible_methods_exist)(*>*)

lemma sees_method_idemp:
  "P \<turnstile> C sees M:Ts\<rightarrow>T=m in D \<Longrightarrow> P \<turnstile> D sees M:Ts\<rightarrow>T=m in D"
 (*<*)by(fastforce simp: Method_def intro:sees_methods_idemp)(*>*)

lemma sees_method_decl_mono:
  "\<lbrakk> P \<turnstile> C' \<preceq>\<^sup>* C; P \<turnstile> C sees M:Ts\<rightarrow>T = m in D;
     P \<turnstile> C' sees M:Ts'\<rightarrow>T' = m' in D' \<rbrakk> \<Longrightarrow> P \<turnstile> D' \<preceq>\<^sup>* D"
 (*<*)
apply(frule sees_method_decl_above)
apply(unfold Method_def)
apply clarsimp
apply(drule (1) sees_methods_decl_mono)
apply clarsimp
apply(drule (1) sees_methods_fun)
apply clarsimp
apply(blast intro:rtrancl_trans)
done
(*>*)

lemma sees_method_is_class:
  "\<lbrakk> P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<rbrakk> \<Longrightarrow> is_class P C"
(*<*)by (auto simp add: is_class_def Method_def elim: Methods.induct)(*>*)

subsection{* Field lookup *}

inductive
  Fields :: "['m prog, cname, ((vname \<times> cname) \<times> ty) list] \<Rightarrow> bool"
                  ("_ \<turnstile> _ has'_fields _" [51,51,51] 50)
  for P :: "'m prog"
where
  has_fields_rec:
  "\<lbrakk> class P C = Some(D,fs,ms); C \<noteq> Object; P \<turnstile> D has_fields FDTs;
     FDTs' = map (\<lambda>(F,T). ((F,C),T)) fs @ FDTs \<rbrakk>
   \<Longrightarrow> P \<turnstile> C has_fields FDTs'"
| has_fields_Object:
  "\<lbrakk> class P Object = Some(D,fs,ms); FDTs = map (\<lambda>(F,T). ((F,Object),T)) fs \<rbrakk>
   \<Longrightarrow> P \<turnstile> Object has_fields FDTs"

lemma has_fields_fun:
assumes 1: "P \<turnstile> C has_fields FDTs"
shows "\<And>FDTs'. P \<turnstile> C has_fields FDTs' \<Longrightarrow> FDTs' = FDTs"
 (*<*)
using 1
proof induct
  case (has_fields_rec C D fs ms Dres Cres Cres')
  have "class": "class P C = Some (D, fs, ms)"
   and notObj: "C \<noteq> Object" and DFields: "P \<turnstile> D has_fields Dres"
   and IH: "\<And>Dres'. P \<turnstile> D has_fields Dres' \<Longrightarrow> Dres' = Dres"
   and Cres: "Cres = map (\<lambda>(F,T). ((F,C),T)) fs @ Dres"
   and CFields': "P \<turnstile> C has_fields Cres'" by fact+
  from CFields' notObj "class" obtain Dres'
    where DFields': "P \<turnstile> D has_fields Dres'"
     and Cres': "Cres' = map (\<lambda>(F,T). ((F,C),T)) fs @ Dres'"
    by(auto elim: Fields.cases)
  from Cres Cres' IH[OF DFields'] show "Cres' = Cres" by simp
next
  case has_fields_Object thus ?case by(auto elim: Fields.cases)
qed
(*>*)

lemma all_fields_in_has_fields:
assumes sub: "P \<turnstile> C has_fields FDTs"
shows "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* D; class P D = Some(D',fs,ms); (F,T) \<in> set fs \<rbrakk>
       \<Longrightarrow> ((F,D),T) \<in> set FDTs"
(*<*)
using sub apply(induct)
 apply(simp add:image_def)
 apply(erule converse_rtranclE)
  apply(force)
 apply(drule subcls1D)
 apply fastforce
apply(force simp:image_def)
done
(*>*)

lemma has_fields_decl_above:
assumes fields: "P \<turnstile> C has_fields FDTs"
shows "((F,D),T) \<in> set FDTs \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
(*<*)
using fields apply(induct)
 prefer 2 apply fastforce
apply clarsimp
apply(erule disjE)
 apply(clarsimp simp add:image_def)
apply simp
apply(blast dest:subcls1I converse_rtrancl_into_rtrancl)
done
(*>*)

lemma subcls_notin_has_fields:
assumes fields: "P \<turnstile> C has_fields FDTs"
shows "((F,D),T) \<in> set FDTs \<Longrightarrow> (D,C) \<notin> (subcls1 P)\<^sup>+"
(*<*)
using fields apply(induct)
 prefer 2 apply(fastforce dest: tranclD)
apply clarsimp
apply(erule disjE)
 apply(clarsimp simp add:image_def)
 apply(drule tranclD)
 apply clarify
 apply(frule subcls1D)
 apply(fastforce dest:all_fields_in_has_fields)
apply simp
apply(blast dest:subcls1I trancl_into_trancl)
done
(*>*)

lemma has_fields_mono_lem:
assumes sub: "P \<turnstile> D \<preceq>\<^sup>* C"
shows "P \<turnstile> C has_fields FDTs
         \<Longrightarrow> \<exists>pre. P \<turnstile> D has_fields pre@FDTs \<and> dom(map_of pre) \<inter> dom(map_of FDTs) = {}"
(*<*)
using sub apply(induct rule:converse_rtrancl_induct)
 apply(rule_tac x = "[]" in exI)
 apply simp
apply clarsimp
apply(rename_tac D' D pre)
apply(subgoal_tac "(D',C) : (subcls1 P)^+")
 prefer 2 apply(erule (1) rtrancl_into_trancl2)
apply(drule subcls1D)
apply clarsimp
apply(rename_tac fs ms)
apply(drule (2) has_fields_rec)
 apply(rule refl)
apply(rule_tac x = "map (\<lambda>(F,T). ((F,D'),T)) fs @ pre" in exI)
apply simp
apply(simp add:Int_Un_distrib2)
apply(rule equals0I)
apply(auto dest: subcls_notin_has_fields simp:dom_map_of_conv_image_fst image_def)
done
(*>*)

(* FIXME why is Field not displayed correctly? TypeRel qualifier seems to confuse printer*)
definition has_field :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> cname \<Rightarrow> bool"
                   ("_ \<turnstile> _ has _:_ in _" [51,51,51,51,51] 50)
where
  "P \<turnstile> C has F:T in D  \<equiv>
  \<exists>FDTs. P \<turnstile> C has_fields FDTs \<and> map_of FDTs (F,D) = Some T"

lemma has_field_mono:
  "\<lbrakk> P \<turnstile> C has F:T in D; P \<turnstile> C' \<preceq>\<^sup>* C \<rbrakk> \<Longrightarrow> P \<turnstile> C' has F:T in D"
(*<*)
apply(clarsimp simp:has_field_def)
apply(drule (1) has_fields_mono_lem)
apply(fastforce simp: map_add_def split:option.splits)
done
(*>*)

definition sees_field :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> cname \<Rightarrow> bool"
                  ("_ \<turnstile> _ sees _:_ in _" [51,51,51,51,51] 50)
where
  "P \<turnstile> C sees F:T in D  \<equiv>
  \<exists>FDTs. P \<turnstile> C has_fields FDTs \<and>
            map_of (map (\<lambda>((F,D),T). (F,(D,T))) FDTs) F = Some(D,T)"

lemma map_of_remap_SomeD:
  "map_of (map (\<lambda>((k,k'),x). (k,(k',x))) t) k = Some (k',x) \<Longrightarrow> map_of t (k, k') = Some x"
(*<*)by (induct t) (auto simp:fun_upd_apply split: split_if_asm)(*>*)

lemma has_visible_field:
  "P \<turnstile> C sees F:T in D \<Longrightarrow> P \<turnstile> C has F:T in D"
(*<*)by(auto simp add:has_field_def sees_field_def map_of_remap_SomeD)(*>*)

lemma sees_field_fun:
  "\<lbrakk>P \<turnstile> C sees F:T in D; P \<turnstile> C sees F:T' in D'\<rbrakk> \<Longrightarrow> T' = T \<and> D' = D"
(*<*)by(fastforce simp:sees_field_def dest:has_fields_fun)(*>*)

lemma sees_field_decl_above:
  "P \<turnstile> C sees F:T in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
(*<*)
apply(auto simp:sees_field_def)
apply(blast  intro: has_fields_decl_above map_of_SomeD map_of_remap_SomeD)
done
(*>*)

(* FIXME ugly *)
lemma sees_field_idemp:
  "P \<turnstile> C sees F:T in D \<Longrightarrow> P \<turnstile> D sees F:T in D"
(*<*)
  apply (unfold sees_field_def)
  apply clarsimp
  apply (rule_tac P = "map_of ?xs F = ?y" in mp)
   prefer 2
   apply assumption
  apply (thin_tac "map_of ?xs F = ?y")
  apply (erule Fields.induct)
   apply clarsimp
   apply (frule map_of_SomeD)
   apply clarsimp
   apply (fastforce intro: has_fields_rec)
  apply clarsimp
  apply (frule map_of_SomeD)
  apply clarsimp
  apply (fastforce intro: has_fields_Object)
  done
(*>*)

subsection "Functional lookup"

definition method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> cname \<times> ty list \<times> ty \<times> 'm"
where
  "method P C M  \<equiv>  THE (D,Ts,T,m). P \<turnstile> C sees M:Ts \<rightarrow> T = m in D"

definition field  :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> cname \<times> ty"
where
  "field P C F  \<equiv>  THE (D,T). P \<turnstile> C sees F:T in D"

definition fields :: "'m prog \<Rightarrow> cname \<Rightarrow> ((vname \<times> cname) \<times> ty) list"
where
  "fields P C  \<equiv>  THE FDTs. P \<turnstile> C has_fields FDTs"

lemma fields_def2 [simp]: "P \<turnstile> C has_fields FDTs \<Longrightarrow> fields P C = FDTs"
(*<*)by (unfold fields_def) (auto dest: has_fields_fun)(*>*)

lemma field_def2 [simp]: "P \<turnstile> C sees F:T in D \<Longrightarrow> field P C F = (D,T)"
(*<*)by (unfold field_def) (auto dest: sees_field_fun)(*>*)

lemma method_def2 [simp]: "P \<turnstile> C sees M: Ts\<rightarrow>T = m in D \<Longrightarrow> method P C M = (D,Ts,T,m)"
(*<*)by (unfold method_def) (auto dest: sees_method_fun)(*>*)

subsection "Code generator setup"

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  subcls1p
.
declare subcls1_def [code_pred_def]

code_pred
  (modes: i \<Rightarrow> i \<times> o \<Rightarrow> bool, i \<Rightarrow> i \<times> i \<Rightarrow> bool)
  [inductify]
  subcls1
.
definition subcls' where "subcls' G = (subcls1p G)^**"
code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [inductify]
  subcls'
.

lemma subcls_conv_subcls' [code_unfold]:
  "(subcls1 G)^* = {(C, D). subcls' G C D}"
  by (simp add: subcls'_def subcls1_def rtrancl_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  widen
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Fields
.

lemma has_field_code [code_pred_intro]:
  "\<lbrakk> P \<turnstile> C has_fields FDTs; map_of FDTs (F, D) = \<lfloor>T\<rfloor> \<rbrakk>
  \<Longrightarrow> P \<turnstile> C has F:T in D"
by(auto simp add: has_field_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  has_field
by(auto simp add: has_field_def)

lemma sees_field_code [code_pred_intro]:
  "\<lbrakk> P \<turnstile> C has_fields FDTs; map_of (map (\<lambda>((F, D), T). (F, D, T)) FDTs) F = \<lfloor>(D, T)\<rfloor> \<rbrakk>
  \<Longrightarrow> P \<turnstile> C sees F:T in D"
by(auto simp add: sees_field_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
          i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  sees_field
by(auto simp add: sees_field_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Methods
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
          i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  Method
by(auto simp add: Method_def)

lemma eval_Method_i_i_i_o_o_o_o_conv:
  "Predicate.eval (Method_i_i_i_o_o_o_o P C M) = (\<lambda>(Ts, T, m, D). P \<turnstile> C sees M:Ts\<rightarrow>T=m in D)"
by(auto intro: Method_i_i_i_o_o_o_oI elim: Method_i_i_i_o_o_o_oE intro!: ext)

lemma method_code [code]:
  "method P C M =
  Predicate.the (Predicate.bind (Method_i_i_i_o_o_o_o P C M) (\<lambda>(Ts, T, m, D). Predicate.single (D, Ts, T, m)))"
apply (rule sym, rule the_eqI)
apply (simp add: method_def eval_Method_i_i_i_o_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: SUP_def Sup_fun_def Sup_bool_def fun_eq_iff)
done

lemma eval_Fields_conv:
  "Predicate.eval (Fields_i_i_o P C) = (\<lambda>FDTs. P \<turnstile> C has_fields FDTs)"
by(auto intro: Fields_i_i_oI elim: Fields_i_i_oE intro!: ext)

lemma fields_code [code]:
  "fields P C = Predicate.the (Fields_i_i_o P C)"
by(simp add: fields_def Predicate.the_def eval_Fields_conv)

lemma eval_sees_field_i_i_i_o_o_conv:
  "Predicate.eval (sees_field_i_i_i_o_o P C F) = (\<lambda>(T, D). P \<turnstile> C sees F:T in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_oI elim: sees_field_i_i_i_o_oE)

lemma eval_sees_field_i_i_i_o_i_conv:
  "Predicate.eval (sees_field_i_i_i_o_i P C F D) = (\<lambda>T. P \<turnstile> C sees F:T in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_iI elim: sees_field_i_i_i_o_iE)

lemma field_code [code]:
  "field P C F = Predicate.the (Predicate.bind (sees_field_i_i_i_o_o P C F) (\<lambda>(T, D). Predicate.single (D, T)))"
apply (rule sym, rule the_eqI)
apply (simp add: field_def eval_sees_field_i_i_i_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: SUP_def Sup_fun_def Sup_bool_def fun_eq_iff)
done

(*<*)
end
(*>*)


theory SINVAR_ACLcommunicateWith
imports "../TopoS_Helper"
begin
subsection \<open>SecurityInvariant ACLcommunicateWith\<close>
text\<open>An access control list strategy that says that hosts must only transitively access each other if allowed\<close>

text\<open>Warning: this transitive model has exponential computational complexity\<close>

definition default_node_properties :: "'v list"
  where  "default_node_properties \<equiv> []"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> 'v list) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> v \<in> nodes G. (\<forall>a \<in> (succ_tran G v). a \<in> set (nP v)))"

definition receiver_violation :: "bool" where
  "receiver_violation \<equiv> False"

(*Alternative definition*)
lemma ACLcommunicateWith_sinvar_alternative:
  "wf_graph G \<Longrightarrow> sinvar G nP = (\<forall> (e1,e2) \<in> (edges G)\<^sup>+. e2 \<in> set (nP e1))"
  proof(unfold sinvar.simps, rule iffI, goal_cases)
  case 1
      from 1(1) have e1_nodes: "(e1, e2) \<in> edges G \<Longrightarrow> e1 \<in> nodes G" for e1 e2
        by (simp add: wf_graph.E_wfD(1))
      from 1(2) have "\<forall>v\<in>nodes G. \<forall>a. (v, a) \<in> (edges G)\<^sup>+ \<longrightarrow> a \<in> set (nP v)"
        by(simp add: succ_tran_def)
      with e1_nodes have "(e1, e2)\<in>(edges G)\<^sup>+ \<Longrightarrow> e2 \<in> set (nP e1)" for e1 e2
        by (meson tranclD)
      thus ?case by blast
    next
    case 2
      from 2(1) have e1_nodes: "(v, a) \<in> edges G \<Longrightarrow> v \<in> nodes G" for v a
        by (simp add: wf_graph.E_wfD(1))
      with 2(2) show ?case by(auto simp add: succ_tran_def)
  qed

    from a3 have "v \<in> N \<Longrightarrow> \<forall>a\<in>(succ_tran \<lparr>nodes = N, edges = E\<rparr> v). a \<in> set (nP v)" for v by fastforce
    with a2 have g2: "v \<in> N \<Longrightarrow> (\<forall> a \<in> (succ_tran \<lparr>nodes = N, edges = E'\<rparr> v). a \<in> set (nP v))" for v
      using succ_tran_mono[OF a1] by blast
    thus "sinvar \<lparr>nodes = N, edges = E'\<rparr> nP" by simp
qed

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[4]
    apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops False_set succ_tran_empty)[1]
   apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

lemma unique_default_example: "succ_tran \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> vertex_2 = {}"
apply (simp add: succ_tran_def)
by (metis Domain.DomainI Domain_empty Domain_insert distinct_vertices12 singleton_iff trancl_domain)

interpretation ACLcommunicateWith: SecurityInvariant_ACS
where default_node_properties = SINVAR_ACLcommunicateWith.default_node_properties
and sinvar = SINVAR_ACLcommunicateWith.sinvar
  unfolding SINVAR_ACLcommunicateWith.default_node_properties_def
  apply unfold_locales

   apply simp
   apply(subst(asm) SecurityInvariant_withOffendingFlows.set_offending_flows_simp, simp)
   apply(clarsimp)
   apply (metis)

  apply(erule default_uniqueness_by_counterexample_ACS)
  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: prod.split_asm prod.split)
  apply(simp add: List.neq_Nil_conv)
  apply(erule exE)
  apply(rename_tac canAccessThis)
  apply(case_tac "canAccessThis = vertex_1")
   apply(rule_tac x="\<lparr> nodes={canAccessThis,vertex_2}, edges = {(vertex_2,canAccessThis)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(rule_tac x="(\<lambda> x. [])(vertex_1 := [], vertex_2 := [])" in exI, simp)
   apply(simp add: example_simps)
   apply(rule_tac x="{(vertex_2,vertex_1)}" in exI, simp)
   apply(simp add: example_simps)
   apply(fastforce)

  apply(rule_tac x="\<lparr> nodes={vertex_1,canAccessThis}, edges = {(vertex_1,canAccessThis)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: wf_graph_def)
  apply(rule_tac x="(\<lambda> x. [])(vertex_1 := [], canAccessThis := [])" in exI, simp)
  apply(simp add: example_simps)
  apply(rule_tac x="{(vertex_1,canAccessThis)}" in exI, simp)
  apply(simp add: example_simps)
  apply(fastforce)
 done

  lemma TopoS_ACLcommunicateWith: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_const (open) sinvar receiver_violation default_node_properties

end


section {*concrete\_supervisory\_control\_problem*}
theory concrete_supervisory_control_problem

imports
  PRJ_11__ENTRY

begin

definition epdaH_accessible_in_closed_loop :: "
  ('controller_state, 'event, 'controller_stack) epda
  \<Rightarrow> (('controller_state, 'plant_state) DT_tuple2, 'event, 'controller_stack) epda
  \<Rightarrow> bool"
  where
    "epdaH_accessible_in_closed_loop C CL \<equiv>
    (\<forall>e \<in> epda_delta C. \<exists>d' n' e' c'.
      epdaH.derivation_initial CL d'
      \<and> d' n' = Some (pair (Some e') c')
      \<and> edge_src e = sel_tuple2_1 (edge_src e')
      \<and> edge_event e = edge_event e'
      \<and> edge_pop e = edge_pop e'
      \<and> edge_push e = edge_push e'
      \<and> edge_trg e = sel_tuple2_1 (edge_trg e'))
  \<and> (\<forall>q \<in> epda_states C. \<exists>d n e c.
      epdaH.derivation_initial CL d
      \<and> d n = Some (pair e c)
      \<and> q = sel_tuple2_1 (epdaH_conf_state c))"

lemma epdaH_accessible__implies__epdaH_accessible_in_closed_loop__for__F_DPDA_DFA_PRODUCT__if__language_inclusion: "
  valid_dpda C
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> epdaH.unmarked_language C \<subseteq> epdaH.unmarked_language P
  \<Longrightarrow> epdaH_accessible C
  \<Longrightarrow> epdaH_accessible_in_closed_loop C (F_DPDA_DFA_PRODUCT C P)"
  apply(simp add: epdaH_accessible_in_closed_loop_def epdaH_accessible_def)
  apply(clarsimp)
  apply(rule conjI)
   apply(thin_tac "\<forall>q\<in>epda_states C.
       \<exists>d. ATS.derivation_initial epdaH_initial_configurations epdaH_step_relation C d \<and>
           (\<exists>n e c. d n = Some (pair e c) \<and> q = epdaH_conf_state c)")
   apply(clarsimp)
   apply(erule_tac x="e" in ballE)
    prefer 2
    apply(force)
   apply(clarsimp)
   apply(case_tac c)
   apply(rename_tac q1 h s)
   apply(clarsimp)
   apply(subgoal_tac "h \<in> epdaH.unmarked_language P")
    prefer 2
    apply(subgoal_tac "h \<in> epdaH.unmarked_language C")
     prefer 2
     apply(simp add: epdaH.unmarked_language_def epdaH_unmarked_effect_def epdaH.derivation_initial_def)
     apply(rule_tac x="d" in exI)
     apply(clarsimp)
     apply(force)
    apply(force)
   apply(thin_tac "epdaH.unmarked_language C \<subseteq> epdaH.unmarked_language P")
   apply(simp add: epdaH.unmarked_language_def epdaH_unmarked_effect_def)
   apply(clarsimp)
   apply(rename_tac e1 d1 n1 q1 s d2 n2 e2 c2)
   apply(case_tac c2)
   apply(clarsimp)
   apply(rename_tac e1 d1 n1 q1 s d2 n2 e2 q2 h s2)
   apply(subgoal_tac "s2 = [epda_box P]")
    prefer 2
    apply (metis DFA_stack_consists_only_of_box epdaH_conf.select_convs(3))
   apply(clarsimp)
   apply(subgoal_tac "n2 = length h")
    prefer 2
    apply (metis (mono_tags) DFA_one_symbol_per_step epdaH_conf.select_convs(2))
   apply(subgoal_tac "n1 \<ge> length h")
    prefer 2
    apply (metis epdaH_conf.select_convs(2) epda_at_most_one_symbol_per_step valid_dpda_def valid_pda_def)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac ints="n1-length h" in F_DPDA_DFA_PRODUCT__preserves__derivation_initial_strengthend)
            apply(force)
           apply(force)
          apply(force)
         apply (metis F_DPDA_DFA_PRODUCT__produces__PDA)
        apply(force)
       apply(force)
      prefer 2
      apply(force)
     prefer 2
     apply(force)
    apply(force)
   apply(clarsimp)
   apply(rule_tac x="dR" in exI)
   apply(clarsimp)
   apply(rule_tac x="n1" in exI)
   apply(clarsimp)
   apply(case_tac n1)
    apply(clarsimp)
    apply (metis epdaH.derivation_initial_is_derivation epdaH.initialNotEdgeSome_prime)
   apply(clarsimp)
   apply(rename_tac n1)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac d="dR" and n="n1" in get_labels__seperate_last)
    apply(force)
   apply(clarsimp)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac d="d1" and n="n1" in get_labels__seperate_last)
    apply(force)
   apply(case_tac eR)
    apply (metis epdaH.derivation_Always_PreEdge_prime epdaH.derivation_initial_is_derivation)
   apply(clarsimp)
   apply(rename_tac eR)
   apply(simp add: strip_plant_def)
  apply(thin_tac "\<forall>e\<in>epda_delta C.
       \<exists>d. ATS.derivation_initial epdaH_initial_configurations epdaH_step_relation C d \<and>
           (\<exists>n c. d n = Some (pair (Some e) c))")
  apply(clarsimp)
  apply(erule_tac x="q" in ballE)
   prefer 2
   apply(force)
  apply(clarsimp)
  apply(case_tac c)
  apply(rename_tac q1 h s)
  apply(clarsimp)
  apply(subgoal_tac "h \<in> epdaH.unmarked_language P")
   prefer 2
   apply(subgoal_tac "h \<in> epdaH.unmarked_language C")
    prefer 2
    apply(simp add: epdaH.unmarked_language_def epdaH_unmarked_effect_def epdaH.derivation_initial_def)
    apply(rule_tac x="d" in exI)
    apply(clarsimp)
    apply(force)
   apply(force)
  apply(thin_tac "epdaH.unmarked_language C \<subseteq> epdaH.unmarked_language P")
  apply(simp add: epdaH.unmarked_language_def epdaH_unmarked_effect_def)
  apply(clarsimp)
  apply(case_tac c)
  apply(rename_tac q2 h s2)
  apply(clarsimp)
  apply(rename_tac d1 n1 e1 q1 s1 d2 n2 e2 q2 h s2)
  apply(subgoal_tac "s2 = [epda_box P]")
   prefer 2
   apply (metis DFA_stack_consists_only_of_box epdaH_conf.select_convs(3))
  apply(clarsimp)
  apply(subgoal_tac "n2 = length h")
   prefer 2
   apply (metis (mono_tags) DFA_one_symbol_per_step epdaH_conf.select_convs(2))
  apply(subgoal_tac "n1 \<ge> length h")
   prefer 2
   apply (metis epdaH_conf.select_convs(2) epda_at_most_one_symbol_per_step valid_dpda_def valid_pda_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac ints="n1-length h" in F_DPDA_DFA_PRODUCT__preserves__derivation_initial_strengthend)
           apply(force)
          apply(force)
         apply(force)
        apply (metis F_DPDA_DFA_PRODUCT__produces__PDA)
       apply(force)
      apply(force)
     prefer 2
     apply(force)
    prefer 2
    apply(force)
   apply(force)
  apply(clarsimp)
  apply(rule_tac x="dR" in exI)
  apply(clarsimp)
  apply(rule_tac x="n1" in exI)
  apply(clarsimp)
  done

definition epdaH_specification_satisfaction :: "
  ('closed_loop_state, 'event, 'closed_loop_stack) epda
  \<Rightarrow> ('specification_state, 'event, 'specification_stack) epda
  \<Rightarrow> bool"
  where
    "epdaH_specification_satisfaction CL S \<equiv>
  \<forall>d1 n1 e1 c1.
    epdaH.derivation_initial CL d1
    \<longrightarrow> d1 n1 = Some (pair e1 c1)
    \<longrightarrow> (\<exists>d2 n2 e2 c2.
        epdaH.derivation_initial S d2
        \<and> d2 n2 = Some (pair e2 c2)
        \<and> epdaH_conf_history c1 = epdaH_conf_history c2
        \<and> (c1 \<in> epdaH_marking_configurations CL \<longrightarrow> c2 \<in> epdaH_marking_configurations S))"

lemma DES_specification_satisfied_to_epdaH_specification_satisfaction: "
  valid_dpda S
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> DES_specification_satisfied (epda_to_des S) (epda_to_des SOL)
  \<Longrightarrow> valid_dpda SOL
  \<Longrightarrow> inf (epda_to_des SOL) (epda_to_des P) = epda_to_des (F_DPDA_DFA_PRODUCT SOL P)
  \<Longrightarrow> inf (epda_to_des SOL) (epda_to_des P) \<in> SCP_Closed_Loop_Satisfactory_Direct (epda_to_des P) (inf (epda_to_des P) (epda_to_des S)) \<Sigma>UC
  \<Longrightarrow> epdaH_specification_satisfaction (F_DPDA_DFA_PRODUCT SOL P) S"
  apply(simp add: epdaH_specification_satisfaction_def SCP_Closed_Loop_Satisfactory_Direct_def)
  apply(simp add: DES_specification_satisfied_def)
  apply(clarsimp)
  apply(thin_tac "IsDES (epda_to_des (F_DPDA_DFA_PRODUCT SOL P))")
  apply(thin_tac "epda_to_des (F_DPDA_DFA_PRODUCT SOL P)
       \<le> epda_to_des P")
  apply(thin_tac "DES_controllability \<Sigma>UC (epda_to_des P)
        (epda_to_des (F_DPDA_DFA_PRODUCT SOL P))")
  apply(thin_tac "DES_nonblockingness
        (epda_to_des (F_DPDA_DFA_PRODUCT SOL P))")
  apply(simp add: epda_to_des_def des_langUM_def des_langM_def less_eq_DES_ext_def lesseqDES_def)
  apply(clarsimp)
  apply(case_tac "c1 \<in> epdaH_marking_configurations (F_DPDA_DFA_PRODUCT SOL P)")
   prefer 2
   apply(subgoal_tac "epdaH_conf_history c1 \<in> ATS_Language0.unmarked_language
            epdaH_initial_configurations epdaH_step_relation
            epdaH_unmarked_effect S")
    prefer 2
    apply(rule_tac A="ATS_Language0.unmarked_language
         epdaH_initial_configurations epdaH_step_relation
         epdaH_unmarked_effect (F_DPDA_DFA_PRODUCT SOL P)" in set_mp)
     apply(force)
    apply(simp add: epdaH.unmarked_language_def)
    apply(rule_tac x="d1" in exI)
    apply(clarsimp)
    apply(simp add: epdaH_unmarked_effect_def epdaH.derivation_initial_def)
    apply(force)
   apply(simp add: epdaH.unmarked_language_def)
   apply(clarsimp)
   apply(rule_tac x="d" in exI)
   apply(clarsimp)
   apply(simp add: epdaH_unmarked_effect_def epdaH.derivation_initial_def)
  apply(clarsimp)
  apply(subgoal_tac "epdaH_conf_history c1 \<in> epdaH.marked_language S")
   prefer 2
   apply(rule_tac A="epdaH.marked_language (F_DPDA_DFA_PRODUCT SOL P)" in set_mp)
    apply(force)
   apply(simp add: epdaH.marked_language_def)
   apply(rule_tac x="derivation_take d1 n1" in exI)
   apply(subgoal_tac "epdaH.derivation_initial (F_DPDA_DFA_PRODUCT SOL P) (derivation_take d1 n1)")
    prefer 2
    apply(rule epdaH.derivation_take_preserves_derivation_initial)
    apply(force)
   apply(clarsimp)
   apply(simp add: epdaH_marked_effect_def epdaH.derivation_initial_def epdaH_marking_condition_def)
   apply(rule context_conjI)
    prefer 2
    apply(blast)
   apply(rule_tac x="n1" in exI)
   apply(clarsimp)
   apply(subgoal_tac "derivation_take d1 n1 n1 = Some (pair e1 c1)")
    prefer 2
    apply(simp add: derivation_take_def)
   apply(clarsimp)
   apply(subgoal_tac "False")
    apply(force)
   apply (metis (no_types, hide_lams) antisym derivation_take_def less_imp_le_nat less_not_refl option.distinct(2))
  apply(simp add: epdaH_marked_effect_def epdaH.marked_language_def)
  apply(clarsimp)
  apply(rule_tac x="d" in exI)
  apply(clarsimp)
  apply(simp add: epdaH_marked_effect_def epdaH.derivation_initial_def)
  apply(clarsimp)
  apply(rule_tac x="i" in exI)
  apply(clarsimp)
  done

definition SCP_SATISFACTORY_CONTROLLER_DPDA :: "
  ('specification_state, 'event, 'specification_stack) epda
  \<Rightarrow> ('plant_state, 'event, nat) epda
  \<Rightarrow> 'event set
  \<Rightarrow> ('controller_state, 'event, 'controller_stack) epda set"
  where
    "SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC \<equiv>
  {C. valid_dpda C
    \<and> epda_operational_controllable C P \<Sigma>UC
    \<and> epdaH.Nonblockingness_branching (F_DPDA_DFA_PRODUCT C P)
    \<and> epdaH_specification_satisfaction (F_DPDA_DFA_PRODUCT C P) S
    \<and> epdaH_deadlock_freedom (F_DPDA_DFA_PRODUCT C P)
    \<and> epdaH_livelock_freedom (F_DPDA_DFA_PRODUCT C P)}"

definition SCP_SATISFACTORY_CLOSED_LOOP_DPDA :: "
  ('specification_state, 'event, 'specification_stack) epda
  \<Rightarrow> ('plant_state, 'event, nat) epda
  \<Rightarrow> 'event set
  \<Rightarrow> (('controller_state, 'plant_state) DT_tuple2, 'event, 'controller_stack) epda set"
  where
    "SCP_SATISFACTORY_CLOSED_LOOP_DPDA S P \<Sigma>UC \<equiv>
  {F_DPDA_DFA_PRODUCT C P | C. C \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC}"

definition SCP_DPDA_DFA_IS_SUPREMUM :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> ('state, 'event, 'stack) epda set
  \<Rightarrow> bool"
  where
    "SCP_DPDA_DFA_IS_SUPREMUM G GS \<equiv>
  Sup (epda_to_des ` GS) = epda_to_des G"

definition SCP_DPDA_DFA_LEAST_RESTRICTIVE_SATISFACTORY :: "
  ('specification_state, 'event, 'specification_stack) epda
  \<Rightarrow> ('plant_state, 'event, nat) epda
  \<Rightarrow> 'event set
  \<Rightarrow> ('controller_state, 'event, 'controller_stack) epda set"
  where
    "SCP_DPDA_DFA_LEAST_RESTRICTIVE_SATISFACTORY S P \<Sigma>UC \<equiv>
  {C.
  C \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC
  \<and> SCP_DPDA_DFA_IS_SUPREMUM (F_DPDA_DFA_PRODUCT C P) (SCP_SATISFACTORY_CLOSED_LOOP_DPDA S P \<Sigma>UC)
  \<and> epda_to_des (F_DPDA_DFA_PRODUCT C P) = Sup (SCP_Closed_Loop_Satisfactory (epda_to_des P) (epda_to_des S) \<Sigma>UC)
  \<and> F_DPDA_DFA_PRODUCT C P \<in> SCP_SATISFACTORY_CLOSED_LOOP_DPDA S P \<Sigma>UC}"

lemma SCP_SATISFACTORY_CONTROLLER_DPDA__TO__DES_nonblockingness:"
  C2 \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC
  \<Longrightarrow> inf (epda_to_des C2) (epda_to_des P) = epda_to_des (F_DPDA_DFA_PRODUCT C2 P)
  \<Longrightarrow> valid_dpda S
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> DES_nonblockingness (epda_to_des (F_DPDA_DFA_PRODUCT C2 P))"
  apply(subgoal_tac "valid_dpda C2")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(subgoal_tac "ATS_Language0.Nonblockingness_branching epdaH_configurations epdaH_initial_configurations epda_step_labels
     epdaH_step_relation epdaH_marking_condition (F_DPDA_DFA_PRODUCT C2 P)")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(simp add: DES_nonblockingness_def)
  apply(simp add: inf_DES_ext_def infDES_def less_eq_DES_ext_def lesseqDES_def des_langUM_def des_langM_def epda_to_des_def epdaH_specification_satisfaction_def)
  apply(subgoal_tac "valid_epda (F_DPDA_DFA_PRODUCT C2 P)")
   prefer 2
   apply (metis F_DPDA_DFA_PRODUCT__generates__DPDA valid_dpda_def valid_pda_def)
  apply(rule epdaH.AX_BF_Bra_OpLa)
   apply(force)
  apply(force)
  done

lemma SCP_SATISFACTORY_CONTROLLER_DPDA__TO__DES_specification_satisfied: "
  C2 \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC
  \<Longrightarrow> inf (epda_to_des C2) (epda_to_des P) = epda_to_des (F_DPDA_DFA_PRODUCT C2 P)
  \<Longrightarrow> valid_dpda S
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> DES_specification_satisfied (inf (epda_to_des P) (epda_to_des S)) (epda_to_des (F_DPDA_DFA_PRODUCT C2 P))"
  apply(simp add: DES_specification_satisfied_def)
  apply(rule conjI)
   apply (metis inf.commute inf_le1)
  apply(subgoal_tac "ATS_Language0.Nonblockingness_branching epdaH_configurations epdaH_initial_configurations epda_step_labels
     epdaH_step_relation epdaH_marking_condition (F_DPDA_DFA_PRODUCT C2 P)")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(subgoal_tac "valid_dpda C2")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(subgoal_tac "epdaH_specification_satisfaction (F_DPDA_DFA_PRODUCT C2 P) S")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(thin_tac "C2 \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC")
  apply(simp add: inf_DES_ext_def infDES_def less_eq_DES_ext_def lesseqDES_def des_langUM_def des_langM_def epda_to_des_def epdaH_specification_satisfaction_def)
  apply(clarsimp)
  apply(rule conjI)
   apply(thin_tac "ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect C2 \<inter>
    ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect P =
    ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect (F_DPDA_DFA_PRODUCT C2 P)")
   apply(clarsimp)
   apply(simp add: epdaH.unmarked_language_def epdaH_unmarked_effect_def)
   apply(clarsimp)
   apply(erule_tac x="d" in allE)
   apply(clarsimp)
   apply(erule_tac x="i" in allE)
   apply(clarsimp)
   apply(rule_tac x="d2" in exI)
   apply(clarsimp)
   apply(simp add: epdaH.derivation_initial_def)
   apply(force)
  apply(thin_tac "ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect C2 \<inter>
    ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect P =
    ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect (F_DPDA_DFA_PRODUCT C2 P)")
  apply(clarsimp)
  apply(simp add: epdaH.marked_language_def epdaH_marked_effect_def)
  apply(clarsimp)
  apply(erule_tac x="d" in allE)
  apply(clarsimp)
  apply(erule_tac x="i" and P="%n1. \<forall>e1 c1.
          d n1 = Some (pair e1 c1) \<longrightarrow>
          (\<exists>d2. ATS.derivation_initial epdaH_initial_configurations epdaH_step_relation S d2 \<and>
                (\<exists>n2 e2 c2.
                    d2 n2 = Some (pair e2 c2) \<and>
                    epdaH_conf_history c1 = epdaH_conf_history c2 \<and>
                    (c1 \<in> epdaH_marking_configurations (F_DPDA_DFA_PRODUCT C2 P) \<longrightarrow>
                     c2 \<in> epdaH_marking_configurations S))) " in allE)
  apply(clarsimp)
  apply(rule_tac x="derivation_take d2 n2" in exI)
  apply(subgoal_tac "epdaH.derivation_initial (S) (derivation_take d2 n2)")
   prefer 2
   apply(rule epdaH.derivation_take_preserves_derivation_initial)
   apply(force)
  apply(clarsimp)
  apply(simp add: epdaH_marked_effect_def epdaH.derivation_initial_def epdaH_marking_condition_def)
  apply(rule context_conjI)
   prefer 2
   apply(blast)
  apply(rule_tac x="n2" in exI)
  apply(clarsimp)
  apply(subgoal_tac "derivation_take d2 n2 n2 = Some (pair e2 c2)")
   prefer 2
   apply(simp add: derivation_take_def)
  apply(clarsimp)
  apply(subgoal_tac "False")
   apply(force)
  apply (metis (no_types, hide_lams) antisym derivation_take_def less_imp_le_nat less_not_refl option.distinct(2))
  done

lemma SCP_SATISFACTORY_CONTROLLER_DPDA__TO__DES_specification_satisfied2: "
  C2 \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC
  \<Longrightarrow> inf (epda_to_des C2) (epda_to_des P) = epda_to_des (F_DPDA_DFA_PRODUCT C2 P)
  \<Longrightarrow> valid_dpda S
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> DES_specification_satisfied (epda_to_des S) (epda_to_des (F_DPDA_DFA_PRODUCT C2 P))"
  apply(simp add: DES_specification_satisfied_def)
  apply(subgoal_tac "ATS_Language0.Nonblockingness_branching epdaH_configurations epdaH_initial_configurations epda_step_labels
     epdaH_step_relation epdaH_marking_condition (F_DPDA_DFA_PRODUCT C2 P)")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(subgoal_tac "valid_dpda C2")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(subgoal_tac "epdaH_specification_satisfaction (F_DPDA_DFA_PRODUCT C2 P) S")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(thin_tac "C2 \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC")
  apply(simp add: inf_DES_ext_def infDES_def less_eq_DES_ext_def lesseqDES_def des_langUM_def des_langM_def epda_to_des_def epdaH_specification_satisfaction_def)
  apply(clarsimp)
  apply(rule conjI)
   apply(thin_tac "ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect C2 \<inter>
    ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect P =
    ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect (F_DPDA_DFA_PRODUCT C2 P)")
   apply(clarsimp)
   apply(simp add: epdaH.unmarked_language_def epdaH_unmarked_effect_def)
   apply(clarsimp)
   apply(erule_tac x="d" in allE)
   apply(clarsimp)
   apply(erule_tac x="i" in allE)
   apply(clarsimp)
   apply(rule_tac x="d2" in exI)
   apply(clarsimp)
   apply(simp add: epdaH.derivation_initial_def)
   apply(force)
  apply(thin_tac "ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect C2 \<inter>
    ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect P =
    ATS_Language0.marked_language epdaH_initial_configurations epdaH_step_relation epdaH_marking_condition
     epdaH_marked_effect (F_DPDA_DFA_PRODUCT C2 P)")
  apply(clarsimp)
  apply(simp add: epdaH.marked_language_def epdaH_marked_effect_def)
  apply(clarsimp)
  apply(erule_tac x="d" in allE)
  apply(clarsimp)
  apply(erule_tac x="i" and P="%n1. \<forall>e1 c1.
          d n1 = Some (pair e1 c1) \<longrightarrow>
          (\<exists>d2. ATS.derivation_initial epdaH_initial_configurations epdaH_step_relation S d2 \<and>
                (\<exists>n2 e2 c2.
                    d2 n2 = Some (pair e2 c2) \<and>
                    epdaH_conf_history c1 = epdaH_conf_history c2 \<and>
                    (c1 \<in> epdaH_marking_configurations (F_DPDA_DFA_PRODUCT C2 P) \<longrightarrow>
                     c2 \<in> epdaH_marking_configurations S))) " in allE)
  apply(clarsimp)
  apply(rule_tac x="derivation_take d2 n2" in exI)
  apply(subgoal_tac "epdaH.derivation_initial (S) (derivation_take d2 n2)")
   prefer 2
   apply(rule epdaH.derivation_take_preserves_derivation_initial)
   apply(force)
  apply(clarsimp)
  apply(simp add: epdaH_marked_effect_def epdaH.derivation_initial_def epdaH_marking_condition_def)
  apply(rule context_conjI)
   prefer 2
   apply(blast)
  apply(rule_tac x="n2" in exI)
  apply(clarsimp)
  apply(subgoal_tac "derivation_take d2 n2 n2 = Some (pair e2 c2)")
   prefer 2
   apply(simp add: derivation_take_def)
  apply(clarsimp)
  apply(subgoal_tac "False")
   apply(force)
  apply (metis (no_types, hide_lams) antisym derivation_take_def less_imp_le_nat less_not_refl option.distinct(2))
  done

lemma SCP_SATISFACTORY_CONTROLLER_DPDA__TO_DES_controllability: "
  C2 \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC
  \<Longrightarrow> inf (epda_to_des C2) (epda_to_des P) = epda_to_des (F_DPDA_DFA_PRODUCT C2 P)
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> DES_controllability \<Sigma>UC (epda_to_des P) (epda_to_des (F_DPDA_DFA_PRODUCT C2 P))"
  apply(subgoal_tac "valid_dpda (F_DPDA_DFA_PRODUCT C2 P)")
   prefer  2
   apply (rule F_DPDA_DFA_PRODUCT__generates__DPDA)
     prefer 3
     apply(force)
    apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
   apply(force)
  apply(subgoal_tac "DES_controllability \<Sigma>UC (epda_to_des P) (epda_to_des (C2))")
   apply (metis DES_controllability_infimum inf_DES_ext_def)
  apply(subgoal_tac "epda_operational_controllable C2 P \<Sigma>UC")
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac G="C2" and SigmaUC="\<Sigma>UC" and P="P" in epda_epda_operational_controllable_to_Cont)
      apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
     apply(force)
    apply(force)
   apply(simp add: DES_controllability_def)
   apply(simp add: inf_DES_ext_def infDES_def less_eq_DES_ext_def lesseqDES_def des_langUM_def des_langM_def epda_to_des_def)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac A="(ATS_Language0.unmarked_language epdaH_initial_configurations epdaH_step_relation
             epdaH_unmarked_effect (C2))" and L="(ATS_Language0.unmarked_language epdaH_initial_configurations epdaH_step_relation
             epdaH_unmarked_effect P)" in Soundness_of_Controllable_Sublanguage)
   apply(force)
  apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  done

lemma inf_preserves_IsDES: "
  IsDES P
\<Longrightarrow> IsDES P2
\<Longrightarrow> IsDES (inf P P2)"
  apply (metis infDES_preserves_IsDES inf_DES_ext_def)
  done

lemma SCP_SATISFACTORY_CONTROLLER_DPDA__TO__SCP_Closed_Loop_Satisfactory_Direct_adapted_specification: "
  C \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC
  \<Longrightarrow> valid_dpda S
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> inf (epda_to_des C) (epda_to_des P) \<in> SCP_Closed_Loop_Satisfactory_Direct (epda_to_des P) (inf (epda_to_des P) (epda_to_des S)) \<Sigma>UC"
  apply(subgoal_tac "valid_dpda C")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(simp add: SCP_Closed_Loop_Satisfactory_Direct_def)
  apply(subgoal_tac "inf (epda_to_des C) (epda_to_des P) = epda_to_des (F_DPDA_DFA_PRODUCT C P)")
   prefer 2
   apply (metis F_DPDA_DFA_PRODUCT__epda_to_des)
  apply(rule conjI)
   apply(rule inf_preserves_IsDES)
    apply(rule epda_to_des_enforces_IsDES)
    apply (metis valid_dpda_def valid_pda_def)
   apply(rule epda_to_des_enforces_IsDES)
   apply (metis valid_dfa_def valid_dpda_def valid_pda_def)
  apply(clarsimp)
  apply(rule conjI)
   apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO_DES_controllability)
     apply(force)
    apply(force)
   apply(force)
  apply(rule conjI)
   apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO__DES_nonblockingness)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO__DES_specification_satisfied)
     apply(force)
    apply(force)
   apply(force)
  apply(force)
  done

lemma SCP_SATISFACTORY_CONTROLLER_DPDA__TO__SCP_Closed_Loop_Satisfactory_Direct: "
  C \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC
  \<Longrightarrow> valid_dpda S
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> inf (epda_to_des C) (epda_to_des P) \<in> SCP_Closed_Loop_Satisfactory_Direct (epda_to_des P) (epda_to_des S) \<Sigma>UC"
  apply(subgoal_tac "valid_dpda C")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(simp add: SCP_Closed_Loop_Satisfactory_Direct_def)
  apply(subgoal_tac "inf (epda_to_des C) (epda_to_des P) = epda_to_des (F_DPDA_DFA_PRODUCT C P)")
   prefer 2
   apply (metis F_DPDA_DFA_PRODUCT__epda_to_des)
  apply(rule conjI)
   apply(rule inf_preserves_IsDES)
    apply(rule epda_to_des_enforces_IsDES)
    apply (metis valid_dpda_def valid_pda_def)
   apply(rule epda_to_des_enforces_IsDES)
   apply (metis valid_dfa_def valid_dpda_def valid_pda_def)
  apply(clarsimp)
  apply(rule conjI)
   apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO_DES_controllability)
     apply(force)
    apply(force)
   apply(force)
  apply(rule conjI)
   apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO__DES_nonblockingness)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO__DES_specification_satisfied2)
     apply(force)
    apply(force)
   apply(force)
  apply(force)
  done

lemma epda_to_des__F_DPDA_DFA_PRODUCT: "
  valid_dpda C
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> epda_to_des (F_DPDA_DFA_PRODUCT C P) \<le> epda_to_des P"
  apply (metis F_DPDA_DFA_PRODUCT__epda_to_des inf_le2)
  done

lemma SCP_SATISFACTORY_CONTROLLER_DPDA__TO_DES_controllability2: "
  C \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> DES_controllability \<Sigma>UC (epda_to_des P) (epda_to_des C)"
  apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(clarsimp)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="C" and SigmaUC="\<Sigma>UC" and P="P" in epda_epda_operational_controllable_to_Cont)
     apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
    apply(force)
   apply(force)
  apply(simp add: DES_controllability_def)
  apply(simp add: inf_DES_ext_def infDES_def less_eq_DES_ext_def lesseqDES_def des_langUM_def des_langM_def epda_to_des_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac A="(ATS_Language0.unmarked_language epdaH_initial_configurations epdaH_step_relation
             epdaH_unmarked_effect (C))" and L="(ATS_Language0.unmarked_language epdaH_initial_configurations epdaH_step_relation
             epdaH_unmarked_effect P)" in Soundness_of_Controllable_Sublanguage)
  apply(force)
  done

theorem SCP_SATISFACTORY_CONTROLLER_DPDA__TO__SCP_Controller_Satisfactory: "
  C \<in> SCP_SATISFACTORY_CONTROLLER_DPDA S P \<Sigma>UC
  \<Longrightarrow> valid_dpda S
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> epda_to_des C \<in> SCP_Controller_Satisfactory (epda_to_des P) (epda_to_des S) \<Sigma>UC"
  apply(subgoal_tac "valid_dpda C")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(simp add: SCP_Controller_Satisfactory_def)
  apply(subgoal_tac "inf (epda_to_des C) (epda_to_des P) = epda_to_des (F_DPDA_DFA_PRODUCT C P)")
   prefer 2
   apply (metis F_DPDA_DFA_PRODUCT__epda_to_des)
  apply(rule conjI)
   apply(rule epda_to_des_enforces_IsDES)
   apply (metis valid_dpda_def valid_pda_def)
  apply(clarsimp)
  apply(rule conjI)
   apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO__DES_specification_satisfied2)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(rule conjI)
   apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO__DES_nonblockingness)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO_DES_controllability2)
   apply(force)
  apply(force)
  done

theorem SCP_SATISFACTORY_CLOSED_LOOP_DPDA__TO__SCP_Closed_Loop_Satisfactory: "
  CL \<in> SCP_SATISFACTORY_CLOSED_LOOP_DPDA S P \<Sigma>UC
  \<Longrightarrow> valid_dpda S
  \<Longrightarrow> valid_dfa P
  \<Longrightarrow> epda_to_des CL \<in> SCP_Closed_Loop_Satisfactory (epda_to_des P) (epda_to_des S) \<Sigma>UC"
  apply(simp add: SCP_Closed_Loop_Satisfactory_def)
  apply(simp add: SCP_SATISFACTORY_CLOSED_LOOP_DPDA_def)
  apply(clarsimp)
  apply(rule_tac x="epda_to_des C" in exI)
  apply(rule conjI)
   apply(simp add: SCP_SATISFACTORY_CLOSED_LOOP_DPDA_def SCP_SATISFACTORY_CONTROLLER_DPDA_def)
   apply(clarsimp)
   apply (metis F_DPDA_DFA_PRODUCT__epda_to_des inf.absorb2 inf.commute inf_le2)
  apply(simp add: SCP_Controller_Satisfactory_def)
  apply(rule conjI)
   apply(rule epda_to_des_enforces_IsDES)
   apply(simp add: SCP_SATISFACTORY_CONTROLLER_DPDA_def)
   apply (metis valid_dpda_def valid_pda_def)
  apply(subgoal_tac "valid_dpda C")
   prefer 2
   apply(simp add: SCP_SATISFACTORY_CLOSED_LOOP_DPDA_def SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(subgoal_tac "inf (epda_to_des C) (epda_to_des P) = epda_to_des (F_DPDA_DFA_PRODUCT C P)")
   prefer 2
   apply (metis F_DPDA_DFA_PRODUCT__epda_to_des)
  apply(clarsimp)
  apply(rule conjI)
   apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO__DES_specification_satisfied2)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(rule conjI)
   apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO__DES_nonblockingness)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO_DES_controllability2)
   apply(force)
  apply(force)
  done

lemma SCP_Closed_Loop_Satisfactory__vs__SCP_Closed_Loop_Satisfactory_Direct: "
  IsDES P
  \<Longrightarrow> IsDES S
  \<Longrightarrow> SCP_Closed_Loop_Satisfactory_Direct P S \<Sigma>UC = SCP_Closed_Loop_Satisfactory P S \<Sigma>UC"
  apply(rule antisym)
   apply(simp add: SCP_Closed_Loop_Satisfactory_Direct_def SCP_Closed_Loop_Satisfactory_def SCP_Controller_Satisfactory_def)
   apply(clarsimp)
   apply(rule_tac x="x" in exI)
   apply(clarsimp)
   apply(rule context_conjI)
    apply (metis le_iff_inf)
   apply(force)
  apply(simp add: SCP_Closed_Loop_Satisfactory_Direct_def SCP_Closed_Loop_Satisfactory_def SCP_Controller_Satisfactory_def)
  apply(clarsimp)
  apply(rule context_conjI)
   apply (metis inf_preserves_IsDES)
  apply (metis DES_controllability_infimum)
  done

lemma SCP_Controller_Least_Restrictive__vs__SCP_Controller_Least_Restrictive_Direct: "
  IsDES P
  \<Longrightarrow> IsDES S
  \<Longrightarrow> SCP_Controller_Least_Restrictive P S \<Sigma>UC = SCP_Controller_Least_Restrictive_Direct P S \<Sigma>UC"
  apply (metis SCP_Controller_Least_Restrictive_Simplified_is_equal_to_SCP_Controller_Least_Restrictive SCP_Controller_Least_Restrictive_Simplified_is_equal_to_SCP_Controller_Least_Restrictive_Direct)
  done

theorem SCP_DPDA_DFA_LEAST_RESTRICTIVE_SATISFACTORY__vs__SCP_Controller_Least_Restrictive_Direct: "
  valid_dfa P
  \<Longrightarrow> valid_dpda S
  \<Longrightarrow> C \<in> SCP_DPDA_DFA_LEAST_RESTRICTIVE_SATISFACTORY S P \<Sigma>UC
  \<Longrightarrow> P' = epda_to_des P
  \<Longrightarrow> S' = epda_to_des S
  \<Longrightarrow> C' = epda_to_des C
  \<Longrightarrow> C' \<in> SCP_Controller_Least_Restrictive P' S' \<Sigma>UC"
  apply(subgoal_tac "C' \<in> SCP_Controller_Least_Restrictive_Direct P' S' \<Sigma>UC")
   apply (metis SCP_Controller_Least_Restrictive_Simplified_is_equal_to_SCP_Controller_Least_Restrictive SCP_Controller_Least_Restrictive_Simplified_is_equal_to_SCP_Controller_Least_Restrictive_Direct epda_to_des_enforces_IsDES valid_dfa_def valid_dpda_def valid_pda_def)
  apply(clarsimp)
  apply(subgoal_tac "valid_dpda C")
   prefer 2
   apply(simp add: SCP_DPDA_DFA_LEAST_RESTRICTIVE_SATISFACTORY_def SCP_SATISFACTORY_CONTROLLER_DPDA_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule SCP_SATISFACTORY_CONTROLLER_DPDA__TO__SCP_Closed_Loop_Satisfactory_Direct_adapted_specification)
     apply(simp add: SCP_DPDA_DFA_LEAST_RESTRICTIVE_SATISFACTORY_def)
     apply(force)
    apply(force)
   apply(force)
  apply(simp add: SCP_Controller_Least_Restrictive_def SCP_Controller_Least_Restrictive_Direct_def)
  apply(rule context_conjI)
   apply(rule epda_to_des_enforces_IsDES)
   apply (metis valid_dpda_def valid_pda_def)
  apply(subgoal_tac "SCP_Closed_Loop_Satisfactory_Direct (epda_to_des P) (epda_to_des S) \<Sigma>UC = SCP_Closed_Loop_Satisfactory (epda_to_des P) (epda_to_des S) \<Sigma>UC")
   prefer 2
   apply(rule SCP_Closed_Loop_Satisfactory__vs__SCP_Closed_Loop_Satisfactory_Direct)
    apply (metis epda_to_des_enforces_IsDES valid_dfa_def valid_dpda_def valid_pda_def)
   apply (metis epda_to_des_enforces_IsDES valid_dpda_def valid_pda_def)
  apply(clarsimp)
  apply(simp add: SCP_DPDA_DFA_LEAST_RESTRICTIVE_SATISFACTORY_def SCP_SATISFACTORY_CLOSED_LOOP_DPDA_def SCP_DPDA_DFA_IS_SUPREMUM_def)
  apply(subgoal_tac "epda_to_des (F_DPDA_DFA_PRODUCT C P) = inf (epda_to_des C) (epda_to_des P)")
   prefer 2
   apply (metis F_DPDA_DFA_PRODUCT__epda_to_des)
  apply(clarsimp)
  done

end