theory Pip_Shared
imports Flow_Base FF "HOL-Library.Multiset"
begin

datatype fields = Fields "fields ref option" "int" "int" "int multiset"

definition "fields_y fs \<equiv> case fs of Fields y _ _ _ \<Rightarrow> y"
definition "fields_q fs \<equiv> case fs of Fields _ q _ _ \<Rightarrow> q"
definition "fields_q0 fs \<equiv> case fs of Fields _ _ q0 _ \<Rightarrow> q0"
definition "fields_qs fs \<equiv> case fs of Fields _ _ _ qs \<Rightarrow> qs"

definition "fields_y' fs y \<equiv> case fs of Fields _ q q0 qs \<Rightarrow> Fields y q q0 qs"
definition "fields_q' fs q \<equiv> case fs of Fields y _ q0 qs \<Rightarrow> Fields y q q0 qs"
definition "fields_q0' fs q0 \<equiv> case fs of Fields y q _ qs \<Rightarrow> Fields y q q0 qs"
definition "fields_qs' fs qs \<equiv> case fs of Fields y q q0 _ \<Rightarrow> Fields y q q0 qs"

instantiation multiset :: (countable) countable
begin
instance
proof (standard, goal_cases)
  case 1
  let ?multiset_to_list = "\<lambda>X. (SOME xs. mset xs = X)"

  obtain list_to_nat :: "'a list \<Rightarrow> nat"
    where "inj list_to_nat"
    by blast
  moreover have "inj ?multiset_to_list"
  proof (rule injI)
    fix X Y
    assume "(SOME xs. mset xs = X) = (SOME xs. mset xs = Y)"
    moreover have "mset (SOME xs. mset xs = X) = X" "mset (SOME xs. mset xs = Y) = Y"
      using some_eq_ex[symmetric, of "\<lambda>xs. mset xs = X"] ex_mset[of X]
            some_eq_ex[symmetric, of "\<lambda>xs. mset xs = Y"] ex_mset[of Y] by simp_all
    ultimately show "X = Y"
      by presburger
  qed
  ultimately have "inj (list_to_nat o ?multiset_to_list)"
    using inj_compose by blast
  then show ?case
    by blast
qed
end
instance multiset :: (heap) heap ..
instance fields :: countable by countable_datatype
instance fields :: heap ..

fun Max' :: "int set \<Rightarrow> int" where
"Max' X = (if X = {} then 0 else Max X)"

fun Max'_mset :: "int multiset \<Rightarrow> int" where
"Max'_mset X = Max' (set_mset X)"

fun \<gamma> :: "fields ref option \<Rightarrow> fields ref \<Rightarrow> fields \<Rightarrow> int multiset \<Rightarrow> bool" where
"\<gamma> \<eta> x (Fields y q q0 qs) m = (q0 \<ge> 0 \<and> (\<forall>q'\<in>set_mset qs. q' \<ge> 0) \<and>
                finite (set_mset qs) \<and>
                m = qs \<and> Max'_mset ({#q0#} + qs) = q \<and>
                \<eta> = y \<and> \<eta> \<noteq> Some x)"

definition \<phi> where
"\<phi> i \<equiv> i \<noteq> bot \<and> inf_fi i = (\<lambda>_. {#}) \<and> outf_fi i = (\<lambda>_. {#})"

fun edge :: "fields ref \<Rightarrow> fields \<Rightarrow> fields ref \<Rightarrow> (int multiset \<Rightarrow> int multiset)" where
"edge x (Fields y q q0 qs) z =
  (\<lambda>m. if Some z = y then {# Max_mset (m + {# q0 #}) #} else {#})"

lemma edge_refl_0[simp]:
  assumes "Some x \<noteq> fields_y fs"
  shows "edge x fs x = (\<lambda>_. {#})"
  using assms
  unfolding fields_y_def by (auto split: fields.splits)

lemma fg_singleton_valid_no_refl_edge[simp]:
  assumes "Some x \<noteq> fields_y fs"
  shows "fg {x} (\<lambda>_. edge x fs) fl \<noteq> bot"
proof -
  have X: "edge x fs x = (\<lambda>_. {#})" using assms by simp
  thus ?thesis by (rule def_fg_singleton')
qed

interpretation ff: FF \<gamma> \<phi> edge
proof (standard, goal_cases)
  case (1 x fs)
  then show ?case
    apply (cases fs)
    using fg_singleton_valid_no_refl_edge
    unfolding fields_y_def
    by auto
qed

definition "adjust_interface x y \<equiv> return ()"

lemma adjust_interface':
  assumes "ix + iy \<noteq> bot" "dom_fi ix = {x}" "dom_fi iy = {y}" "x \<noteq> y"
  shows "fi {x} (inf_fi ix) (\<lambda>n. if n = y then a else outf_fi ix n) +
    fi {y} (\<lambda>n. inf_fi (ix + iy) n + a) (outf_fi iy) = ix + iy"
proof -
  let ?ix' = "fi {x} (inf_fi ix) (\<lambda>n. if n = y then a else outf_fi ix n)"
  let ?iy' = "fi {y} (\<lambda>n. inf_fi (ix + iy) n + a) (outf_fi iy)"

  have *: "is_sum_fi ix iy (ix + iy)"
    using plus_fi_to_is_sum_fi[of ix iy "ix + iy"] assms by simp
  then have A: "\<forall>n \<in> dom_fi ix. inf_fi ix n = inf_fi (ix + iy) n + outf_fi iy n"
    using assms unfolding is_sum_fi_def by auto
  have **: "is_sum_fi ?ix' ?iy' (ix + iy)"
    using assms A
    unfolding is_sum_fi_def
    by simp
  show ?thesis
    by (fact is_sum_fi_to_plus_fi[OF **])
qed

text \<open>If the existence of an interface sum is assumed and the domain provides minus,
  then @{text adjust_interface} can be simplified.\<close>
lemma adjust_interface_mset':
  assumes "ix + iy \<noteq> bot" "dom_fi ix = {x}" "dom_fi iy = {y}" "x \<noteq> y"
  shows "fi {x} (inf_fi ix) (\<lambda>n. if n = y then a else outf_fi ix n) +
         fi {y} (\<lambda>n. inf_fi iy n - outf_fi ix n + a) (outf_fi iy) = ix + iy"
proof -
  let ?ix' = "fi {x} (inf_fi ix) (\<lambda>n. if n = y then a else outf_fi ix n)"
  let ?iy' = "fi {y} (\<lambda>n. inf_fi (ix + iy) n + a) (outf_fi iy)"

  have *: "is_sum_fi ix iy (ix + iy)"
    using plus_fi_to_is_sum_fi[of ix iy "ix + iy"] assms by simp
  then have A: "\<forall>n \<in> dom_fi ix. inf_fi ix n = inf_fi (ix + iy) n + outf_fi iy n"
    using assms unfolding is_sum_fi_def by auto
  have "\<forall>n \<in> dom_fi iy. inf_fi iy n = inf_fi (ix + iy) n + outf_fi ix n"
    using assms * unfolding is_sum_fi_def by simp
  then have B: "\<forall>n \<in> dom_fi iy. inf_fi (ix + iy) n = inf_fi iy n - outf_fi ix n"
    by simp
  have C: "fi {y} (\<lambda>n. inf_fi (ix + iy) n + a) (outf_fi iy) =
    fi {y} (\<lambda>n. inf_fi iy n - outf_fi ix n + a) (outf_fi iy)"
    by (rule fi_cong, auto simp: B assms)
  have **: "is_sum_fi ?ix' ?iy' (ix + iy)"
    using assms A
    unfolding is_sum_fi_def
    by simp
  show ?thesis
    using is_sum_fi_to_plus_fi[OF **] C by simp
qed

lemma adjust_interface_rule:
  assumes "ix + iy \<noteq> bot" "x \<noteq> y" "dom_fi ix = {x}" "dom_fi iy = {y}"
  shows "<ff.NI gx x fsx mx ix * ff.NI gy y fsy my iy>
    adjust_interface x y
    <\<lambda>_. ff.NI gx x fsx mx ix * ff.NI gy y fsy my iy * \<up>(ix + iy =
            fi {x} (inf_fi ix) (\<lambda>n. if n = y then a else outf_fi ix n) +
            fi {y} (\<lambda>n. inf_fi (ix + iy) n + a) (outf_fi iy))>"
  unfolding adjust_interface_def apply sep_auto
  using assms adjust_interface'[of ix iy x y] by simp

\<comment> \<open>We use Ref.change to simulate single field updates while storing all fields together,
    i.e. all unrelated fields are read to rewrite them together with the changed field.\<close>
abbreviation fields_change where
"fields_change setter x \<equiv> Ref.change (\<lambda>fs. setter fs x)"

abbreviation fields_lookup where
"fields_lookup getter fs \<equiv> do {
    fs' \<leftarrow> Ref.lookup fs;
    return (getter fs') }"

partial_function (heap) update :: "fields ref \<Rightarrow> int \<Rightarrow> int \<Rightarrow> unit Heap" where
"update n from to = do {
    ff.open_NI n;
    q0 \<leftarrow> fields_lookup fields_q0 n;
    qs \<leftarrow> fields_lookup fields_qs n;
    let qs' = qs - {# from #} + (if to \<ge> 0 then {# to #} else {#}) in do {
    fields_change fields_qs' qs' n;
    from \<leftarrow> fields_lookup fields_q n;
    fields_change fields_q' (Max_mset (qs' + {#q0#})) n;
    to \<leftarrow> fields_lookup fields_q n;
    y \<leftarrow> fields_lookup fields_y n;
    ff.close_NI n qs';

    if from \<noteq> to
      then (case y of
        Some y' \<Rightarrow> do {
            ff.unfold_GrI y';
            ff.fold_GrI n;
            update y' from to
          }
        | _ \<Rightarrow> do {
          ff.fold_GrI n
        })
      else ff.fold_GrI n
  }
}"

definition acquire :: "fields ref \<Rightarrow> fields ref \<Rightarrow> unit Heap" where
"acquire p r = do {
    ff.unfold_GrI p;
    ff.unfold_GrI r;
    ff.open_NI r;

    rqs \<leftarrow> fields_lookup fields_qs r;
    ry \<leftarrow> fields_lookup fields_y r;

    (if ry = None
      then do {
        fields_change fields_y' (Some p) r;
        rq \<leftarrow> fields_lookup fields_q r;
        ff.close_NI r rqs;
        ff.fold_GrI r;
        update p (-1) rq }
      else do {
        ff.close_NI r rqs;
        ff.open_NI p;
        fields_change fields_y' (Some r) p;
        pq \<leftarrow> fields_lookup fields_q p;
        pqs \<leftarrow> fields_lookup fields_qs p;
        ff.close_NI p pqs;
        ff.fold_GrI p;
        update r (-1) pq})
  }"

definition release :: "fields ref \<Rightarrow> fields ref \<Rightarrow> unit Heap" where
"release p r = do {
    ff.unfold_GrI p;
    ff.unfold_GrI r;
    ff.open_NI r;
    rq \<leftarrow> fields_lookup fields_q r;
    rqs \<leftarrow> fields_lookup fields_qs r;
    fields_change fields_y' None r;
    ff.close_NI r rqs;
    ff.fold_GrI r;
    update p rq (-1)
  }"

lemma ent_prod_cong:
  assumes "finite X" "\<And>x. x \<in> X \<Longrightarrow> P x \<Longrightarrow>\<^sub>A P' x"
  shows "(\<Prod>x \<in> X. P x) \<Longrightarrow>\<^sub>A (\<Prod>x \<in> X. P' x)"
  using assms
  apply (induction X rule: finite_induct)
   apply sep_auto
  apply (subst prod.insert, simp, simp)
  apply (subst prod.insert, simp, simp)
  by (rule ent_star_mono, simp, simp)

lemma finite_induct_reverse'_aux0: "a \<in> F \<Longrightarrow> insert a (F - F') = F - (F' - {a})"
  by blast

lemma finite_induct_reverse'_aux1: "finite X \<Longrightarrow> card X > 0 \<Longrightarrow> X \<noteq> {}"
  by auto

lemma finite_induct_reverse'_aux2:
  assumes "finite X" "x \<in> X" "card (X - {x}) = 0" shows "X = {x}"
proof -
  have "card (X - {x}) = 0" using assms by simp
  then have "card X = 1" using assms card_Suc_Diff1 by fastforce
  then show ?thesis using assms by (metis card_eq_0_iff finite_Diff insert_Diff)
qed

lemma finite_induct_reverse':
  assumes "finite F'" "F' \<subseteq> F" "\<And>a F. a \<in> F \<Longrightarrow> P a F"
    "\<And>x F'. F' \<subseteq> F \<Longrightarrow> x \<in> F \<Longrightarrow> (\<And>y. y \<in> F \<Longrightarrow> P y (insert x F')) \<Longrightarrow> P x F'" "a \<in> F'"
  shows "P a (F - F')"
  using assms
proof (induction "card (F' - {a})" arbitrary: a F')
  case 0
  have *: "insert a (F - {a}) = F" using \<open>a \<in> F'\<close> \<open>F' \<subseteq> F\<close> by blast
  have **: "F' = {a}"
    by (fact finite_induct_reverse'_aux2[OF \<open>finite F'\<close> \<open>a \<in> F'\<close> \<open>0 = card (F' - {a})\<close>[symmetric]])
  show ?case
    apply (rule "0"(5))
      apply blast
    using 0 apply blast
    apply (subst **, subst *, rule "0"(4), blast)
    done
next
  case (Suc x)

  have F: "finite (F' - {a})"
    using \<open>finite F'\<close> finite_Diff by blast

  have "F' - {a} \<noteq> {}" using \<open>Suc x = card (F' - {a})\<close> finite_induct_reverse'_aux1[OF F] by simp
  with \<open>F' \<subseteq> F\<close> have "F - (F' - {a}) \<noteq> F" by blast
  then have "F - (F' - {a}) \<subset> F" by blast

  show ?case
    apply (rule Suc(6))
       apply blast
    using Suc apply blast
    subgoal for y
    apply (subst finite_induct_reverse'_aux0[of a F F'])
      using Suc apply blast
      apply (cases "y \<in> F' \<and> y \<noteq> a")
    apply (rule Suc(1)[of "F' - {a}" y])
    using \<open>Suc x = card (F' - {a})\<close> F apply simp
    using \<open>finite F'\<close> apply simp
    using Suc apply blast
    using Suc apply blast
    using Suc apply blast
     apply simp
  proof-
    assume "y \<in> F" "\<not> (y \<in> F' \<and> y \<noteq> a)"
    then have A: "y \<in> F - (F' - {a})" by simp
    show "P y (F - (F' - {a}))"
      by (fact Suc(5)[OF A])
  qed
  done
qed

lemma finite_induct_reverse [consumes 2, case_names base step]:
  assumes "finite F" "F' \<subseteq> F" "\<And>a F. a \<in> F \<Longrightarrow> P a F"
    "\<And>x F'. F' \<subseteq> F \<Longrightarrow> x \<in> F \<Longrightarrow> (\<And>y. y \<in> F \<Longrightarrow> P y (insert x F')) \<Longrightarrow> P x F'" "a \<in> F"
  shows "P a F'"
proof (cases "a \<in> F - F'")
  case True
  obtain F'' where *: "F' = F - F''" "F'' \<subseteq> F" "finite F''" using assms by auto
  have "P a (F - F'')"
    apply (rule finite_induct_reverse'[of F'' F P a])
    using * assms True by blast+
  then show ?thesis
    using * by simp
next
  case False
  show ?thesis
    apply (rule assms(3))
    using False assms by simp
qed

lemmas pip_simps = fields_q_def fields_qs_def fields_qs'_def fields_q'_def fields_q0_def
                   fields_y_def Ref.change_def
lemmas ll_simps = ff.open_NI_rule ff.close_NI_rule ff.sing_NI_GrI_rule ff.sing_GrI_NI_rule
                  ff.preserve_interface_rule[where P=emp and P'="\<lambda>_. emp"]
                  ff.diff_NI_rule ff.extends_rule ff.extends_rule ff.unfold_GrI_rule
                  ff.fold_GrI_rule

lemma Max_mset_add_remove:
  assumes "x \<in># X" "y < x" "Max_mset ((X - {# x #}) + {# y #}) \<noteq> Max_mset X"
  shows "Max_mset X = x"
proof (rule ccontr)
  assume A: "Max_mset X \<noteq> x"
  then have B: "Max_mset X > x" using \<open>x \<in># X\<close> using Max_ge le_neq_trans by auto
  moreover have C: "Max_mset X \<in># X" using Max_in assms by blast

  have D: "y < Max_mset X"
    using B assms by simp

  have "Max_mset (X - {#x#}) = Max_mset X" using B assms
    using A C by (metis Max_eqI Max_ge finite_set_mset in_diffD insert_DiffM insert_noteq_member)
  then have "Max_mset ((X - {#x#}) + {#y#}) = Max_mset X"
    using A C D assms by (metis Max_insert add_cancel_left_right add_mset_eq_singleton_iff
        finite_set_mset insert_DiffM less_imp_le max_def set_mset_add_mset_insert
        set_mset_eq_empty_iff union_mset_add_mset_right)
  then show False
    using assms by simp
qed

lemma Max_mset_add_remove_lt:
  assumes "x \<in># X" "y < x" "Max_mset ((X - {# x #}) + {# y #}) \<noteq> Max_mset X"
  shows "Max_mset ((X - {# x #}) + {# y #}) < Max_mset X"
proof -
  have "Max_mset X = x"
    using assms Max_mset_add_remove by auto
  show ?thesis
  proof (rule ccontr)
    assume "\<not> Max_mset (X - {#x#} + {#y#}) < Max_mset X"
    then have "Max_mset (X - {#x#} + {#y#}) \<ge> Max_mset X"
      using leI by blast
    then obtain z where "z \<in># X - {#x#} + {#y#}" "z \<ge> Max_mset X"
      by (metis Max_in empty_eq_union finite_set_mset multi_self_add_other_not_self
          set_mset_eq_empty_iff)
    then have *: "z \<ge> x" using assms by (simp add: \<open>Max_mset X = x\<close>)
    then have "z \<in># X" by (metis \<open>z \<in># X - {#x#} + {#y#}\<close> assms leD mset_contains_eq
          mset_right_cancel_elem union_iff)
    then have "Max_mset ((X - {# x #}) + {# y #}) = Max_mset X" using * assms
      by (metis (no_types, lifting) Max_ge Max_in \<open>Max_mset X = x\<close> \<open>z \<in># X - {#x#} + {#y#}\<close>
          empty_eq_union finite_set_mset leD more_than_one_mset_mset_diff mset_right_cancel_elem
          neq_iff set_mset_eq_empty_iff)
    then show False
      using assms by simp
  qed
qed

lemma Max_mset_add_remove_le:
  assumes "x \<in># X" "y < x"
  shows "Max_mset ((X - {# x #}) + {# y #}) \<le> Max_mset X"
proof -
  have "Max_mset ((X - {# x #}) + {# y #}) = Max_mset ((X + {# y #}) - {# x #})"
    using assms by simp
  also have "... \<le> Max_mset (X + {# y #})"
    by (metis assms Max_ge Max_in diff_union_single_conv2 empty_eq_union finite_set_mset in_diffD
        multi_self_add_other_not_self set_mset_eq_empty_iff)
  also have "... = Max_mset X"
    by (metis assms Max_ge Max_in add_right_imp_eq antisym diff_single_trivial zero_diff
        diff_union_single_conv2 finite_set_mset leD mset_right_cancel_elem multi_drop_mem_not_eq)
  finally show ?thesis .
qed

lemma dom_fg_plus_fg1:
  assumes nbot: "h1 + h2 \<noteq> bot"
  shows "dom_fg h1 = dom_fg (h1 + h2) - dom_fg h2"
  using plus_fg_dom_un[OF nbot] plus_fg_dom_disj[OF nbot] by auto

end


section "LTL integration"
theory PromelaLTL
imports
  Promela
  LTL.LTL
begin

text \<open>We have a semantic engine for Promela. But we need to have
an integration with LTL -- more specificly, we must know when a proposition
is true in a global state. This is achieved in this theory.\<close>

subsection \<open>LTL optimization\<close>

text \<open>For efficiency reasons, we do not store the whole @{typ expr} on the labels
of a system automaton, but @{typ nat} instead. This index then is used to look up the
corresponding @{typ expr}.\<close>

type_synonym APs = "expr iarray"

primrec ltlc_aps_list' :: "'a ltlc \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "ltlc_aps_list' True_ltlc l = l"
| "ltlc_aps_list' False_ltlc l = l"
| "ltlc_aps_list' (Prop_ltlc p) l = (if List.member l p then l else p#l)"
| "ltlc_aps_list' (Not_ltlc x) l = ltlc_aps_list' x l"
| "ltlc_aps_list' (Next_ltlc x) l = ltlc_aps_list' x l"
| "ltlc_aps_list' (Final_ltlc x) l = ltlc_aps_list' x l"
| "ltlc_aps_list' (Global_ltlc x) l = ltlc_aps_list' x l"
| "ltlc_aps_list' (And_ltlc x y) l = ltlc_aps_list' y (ltlc_aps_list' x l)"
| "ltlc_aps_list' (Or_ltlc x y) l = ltlc_aps_list' y (ltlc_aps_list' x l)"
| "ltlc_aps_list' (Implies_ltlc x y) l = ltlc_aps_list' y (ltlc_aps_list' x l)"
| "ltlc_aps_list' (Until_ltlc x y) l = ltlc_aps_list' y (ltlc_aps_list' x l)"
| "ltlc_aps_list' (Release_ltlc x y) l = ltlc_aps_list' y (ltlc_aps_list' x l)"
| "ltlc_aps_list' (WeakUntil_ltlc x y) l = ltlc_aps_list' y (ltlc_aps_list' x l)"
| "ltlc_aps_list' (StrongRelease_ltlc x y) l = ltlc_aps_list' y (ltlc_aps_list' x l)"

lemma ltlc_aps_list'_correct:
  "set (ltlc_aps_list' \<phi> l) = atoms_ltlc \<phi> \<union> set l"
  by (induct \<phi> arbitrary: l) (auto simp add: in_set_member)

lemma ltlc_aps_list'_distinct:
  "distinct l \<Longrightarrow> distinct (ltlc_aps_list' \<phi> l)"
  by (induct \<phi> arbitrary: l) (auto simp add: in_set_member)

definition ltlc_aps_list :: "'a ltlc \<Rightarrow> 'a list"
where
  "ltlc_aps_list \<phi> = ltlc_aps_list' \<phi> []"

lemma ltlc_aps_list_correct:
  "set (ltlc_aps_list \<phi>) = atoms_ltlc \<phi>"
  unfolding ltlc_aps_list_def
  by (force simp: ltlc_aps_list'_correct)

lemma ltlc_aps_list_distinct:
  "distinct (ltlc_aps_list \<phi>)"
  unfolding ltlc_aps_list_def
  by (auto intro: ltlc_aps_list'_distinct)

primrec idx' :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> nat option" where
  "idx' _ [] _ = None"
| "idx' ctr (x#xs) y = (if x = y then Some ctr else idx' (ctr+1) xs y)"

definition "idx = idx' 0"

lemma idx'_correct:
  assumes "distinct xs"
  shows "idx' ctr xs y = Some n \<longleftrightarrow> n \<ge> ctr \<and> n < length xs + ctr \<and> xs ! (n-ctr) = y"
using assms
proof (induction xs arbitrary: n ctr)
  case (Cons x xs)
  show ?case
  proof (cases "x=y")
    case True with Cons.prems have *: "y \<notin> set xs" by auto
    {
      assume A: "(y#xs)!(n-ctr) = y"
      and less: "ctr \<le> n"
      and length: "n < length (y#xs) + ctr"
      have "n = ctr"
      proof (rule ccontr)
        assume "n \<noteq> ctr" with less have "n-ctr > 0" by auto
        moreover from \<open>n\<noteq>ctr\<close> length have "n-ctr < length(y#xs)" by auto
        ultimately have "(y#xs)!(n-ctr) \<in> set xs" by simp
        with A * show False by auto
      qed
    }
    with True Cons show ?thesis by auto
  next
    case False
    from Cons have "distinct xs" by simp
    with Cons.IH False have "idx' (Suc ctr) xs y = Some n \<longleftrightarrow> Suc ctr \<le> n \<and> n < length xs + Suc ctr \<and> xs ! (n - Suc ctr) = y"
      by simp
    with False show ?thesis
      apply -
      apply (rule iffI)
      apply clarsimp_all
      done
  qed
qed simp

lemma idx_correct:
  assumes "distinct xs"
  shows "idx xs y = Some n \<longleftrightarrow> n < length xs \<and> xs ! n = y"
  using idx'_correct[OF assms]
  by (simp add: idx_def)

lemma idx_dom:
  assumes "distinct xs"
  shows "dom (idx xs) = set xs"
  by (auto simp add: idx_correct assms in_set_conv_nth)

lemma idx_image_self:
  assumes "distinct xs"
  shows "(the \<circ> idx xs) ` set xs = {..<length xs}"
proof (safe)
  fix x
  assume "x \<in> set xs" with in_set_conv_nth obtain n where n: "n < length xs" "xs ! n = x" by metis
  with idx_correct[OF assms] have "idx xs x = Some n" by simp
  hence "the (idx xs x) = n" by simp
  with n show "(the \<circ> idx xs) x < length xs" by simp
next
  fix n
  assume "n < length xs"
  moreover with nth_mem have "xs ! n \<in> set xs" by simp
  then obtain x where "xs ! n = x" "x \<in> set xs" by simp_all
  ultimately have "idx xs x = Some n" by (simp add: idx_correct[OF assms])
  hence "the (idx xs x) = n" by simp
  thus "n \<in> (the \<circ> idx xs) ` set xs"
    using \<open>x \<in> set xs\<close>
    by auto
qed

lemma idx_ran:
  assumes "distinct xs"
  shows "ran (idx xs) = {..<length xs}"
  using ran_is_image[where M="idx xs"]
  using idx_image_self[OF assms] idx_dom[OF assms]
  by simp

lemma idx_inj_on_dom:
  assumes "distinct xs"
  shows "inj_on (idx xs) (dom (idx xs))"
  by (fastforce simp add: idx_dom assms in_set_conv_nth idx_correct
                intro!: inj_onI)

definition ltl_convert :: "expr ltlc \<Rightarrow> APs \<times> nat ltlc" where
  "ltl_convert \<phi> = (
      let APs = ltlc_aps_list \<phi>;
          \<phi>\<^sub>i = map_ltlc (the \<circ> idx APs) \<phi>
      in (IArray APs, \<phi>\<^sub>i))"

  from assms have APs_def: "?APs = ltlc_aps_list \<phi>"
    unfolding ltl_convert_def by auto

  with ltlc_aps_list_correct show APs_set: ?P1 by metis

  from assms show ?P3
    unfolding ltl_convert_def
    by auto

  from assms have "atoms_ltlc \<phi>\<^sub>i = (the \<circ> idx ?APs) ` atoms_ltlc \<phi>"
    unfolding ltl_convert_def
    by (auto simp add: ltlc.set_map)
  moreover from APs_def ltlc_aps_list_distinct show "distinct ?APs" by simp
  note idx_image_self[OF this]
  moreover note APs_set
  ultimately show ?P2 by simp
qed

definition prepare
  :: "_ \<times> (program \<Rightarrow> unit) \<Rightarrow> ast \<Rightarrow> expr ltlc \<Rightarrow> (program \<times> APs \<times> gState) \<times> nat ltlc"
  where
  "prepare cfg ast \<phi> \<equiv>
      let
         (prog,g\<^sub>0) = Promela.setUp ast;
         (APs,\<phi>\<^sub>i) = PromelaLTL.ltl_convert \<phi>
      in
         ((prog, APs, g\<^sub>0), \<phi>\<^sub>i)"

lemma prepare_instrument[code]:
  "prepare cfg ast \<phi> \<equiv>
    let
         (_,printF) = cfg;
         _ = PromelaStatistics.start ();
         (prog,g\<^sub>0) = Promela.setUp ast;
         _ = printF prog;
         (APs,\<phi>\<^sub>i) = PromelaLTL.ltl_convert \<phi>;
         _ = PromelaStatistics.stop_timer ()
      in
         ((prog, APs, g\<^sub>0), \<phi>\<^sub>i)"
  by (simp add: prepare_def)

export_code prepare checking SML

subsection \<open>Language of a Promela program\<close>

definition propValid :: "APs \<Rightarrow> gState \<Rightarrow> nat \<Rightarrow> bool" where
  "propValid APs g i \<longleftrightarrow> i < IArray.length APs \<and> exprArith g emptyProc (APs!!i) \<noteq> 0"

definition promela_E :: "program \<Rightarrow> (gState \<times> gState) set"
  \<comment> \<open>Transition relation of a promela program\<close>
where
  "promela_E prog \<equiv> {(g,g'). g' \<in> ls.\<alpha> (nexts_code prog g)}"

definition promela_E_ltl :: "program \<times> APs \<Rightarrow> (gState \<times> gState) set" where
  "promela_E_ltl = promela_E \<circ> fst"

definition promela_is_run' :: "program \<times> gState \<Rightarrow> gState word \<Rightarrow> bool"
  \<comment> \<open>Predicate defining runs of promela programs\<close>
where
  "promela_is_run' progg r \<equiv>
      let (prog,g\<^sub>0)=progg in
           r 0 = g\<^sub>0
        \<and> (\<forall>i. r (Suc i) \<in> ls.\<alpha> (nexts_code prog (r i)))"

abbreviation "promela_is_run \<equiv> promela_is_run' \<circ> setUp"

definition promela_is_run_ltl :: "program \<times> APs \<times> gState \<Rightarrow> gState word \<Rightarrow> bool"
where
  "promela_is_run_ltl promg r \<equiv> let (prog,APs,g) = promg in promela_is_run' (prog,g) r"

definition promela_props :: "gState \<Rightarrow> expr set"
where
  "promela_props g = {e. exprArith g emptyProc e \<noteq> 0}"

definition promela_props_ltl :: "APs \<Rightarrow> gState \<Rightarrow> nat set"
where
  "promela_props_ltl APs g \<equiv> Collect (propValid APs g)"

definition promela_language :: "ast \<Rightarrow> expr set word set" where
  "promela_language ast \<equiv> {promela_props \<circ> r | r. promela_is_run ast r}"

definition promela_language_ltl :: "program \<times> APs \<times> gState \<Rightarrow> nat set word set" where
  "promela_language_ltl promg \<equiv> let (prog,APs,g) = promg in
                    {promela_props_ltl APs \<circ> r | r. promela_is_run_ltl promg r}"

lemma promela_props_ltl_map_aprops:
  assumes "ltl_convert \<phi> = (APs,\<phi>\<^sub>i)"
  shows "promela_props_ltl APs =
          map_props (idx (IArray.list_of APs)) \<circ> promela_props"
proof -
  let ?APs = "IArray.list_of APs"
  let ?idx = "idx ?APs"

  from ltl_convert_correct assms have D: "distinct ?APs" by simp

  show ?thesis
  proof (intro ext set_eqI iffI)
    fix g i
    assume "i \<in> promela_props_ltl APs g"
    hence "propValid APs g i" by (simp add: promela_props_ltl_def)
    hence l: "i < IArray.length APs" "exprArith g emptyProc (APs!!i) \<noteq> 0"
      by (simp_all add: propValid_def)
    hence "APs!!i \<in> promela_props g" by (simp add: promela_props_def)
    moreover from idx_correct l D have "?idx (APs!!i) = Some i" by fastforce
    ultimately show "i \<in> (map_props ?idx \<circ> promela_props) g"
      unfolding o_def map_props_def
      by blast
  next
    fix g i
    assume "i \<in> (map_props ?idx \<circ> promela_props) g"
    then obtain p where p_def: "p \<in> promela_props g" "?idx p = Some i"
      unfolding map_props_def o_def
      by auto
    hence expr: "exprArith g emptyProc p \<noteq> 0" by (simp add: promela_props_def)

    from D p_def have "i < IArray.length APs" "APs !! i = p"
      using idx_correct by fastforce+
    with expr have "propValid APs g i" by (simp add: propValid_def)
    thus "i \<in> promela_props_ltl APs g"
      by (simp add: promela_props_ltl_def)
  qed
qed

lemma promela_run_in_language_iff:
  assumes conv: "ltl_convert \<phi> = (APs,\<phi>\<^sub>i)"
  shows "promela_props \<circ> \<xi> \<in> language_ltlc \<phi>
          \<longleftrightarrow> promela_props_ltl APs \<circ> \<xi> \<in> language_ltlc \<phi>\<^sub>i" (is "?L \<longleftrightarrow> ?R")
proof -
  let ?APs = "IArray.list_of APs"

  from conv have D: "distinct ?APs"
    by (simp add: ltl_convert_correct)
  with conv have APs: "atoms_ltlc \<phi> \<subseteq> dom (idx ?APs)"
    by (simp add: idx_dom ltl_convert_correct)

  note map_semantics = map_semantics_ltlc[OF idx_inj_on_dom[OF D] APs]
                       promela_props_ltl_map_aprops[OF conv]
                       ltl_convert_correct[OF conv]

  have "?L \<longleftrightarrow> (promela_props \<circ> \<xi>) \<Turnstile>\<^sub>c \<phi>" by (simp add: language_ltlc_def)
  also have "... \<longleftrightarrow> (promela_props_ltl APs \<circ> \<xi>) \<Turnstile>\<^sub>c \<phi>\<^sub>i"
    using map_semantics
    by (simp add: o_assoc)
  also have "... \<longleftrightarrow> ?R"
    by (simp add: language_ltlc_def)
  finally show ?thesis .
qed

lemma promela_language_sub_iff:
  assumes conv: "ltl_convert \<phi> = (APs,\<phi>\<^sub>i)"
  and setUp: "setUp ast = (prog,g)"
  shows "promela_language_ltl (prog,APs,g) \<subseteq> language_ltlc \<phi>\<^sub>i \<longleftrightarrow> promela_language ast \<subseteq> language_ltlc \<phi>"
  using promela_run_in_language_iff[OF conv] setUp
  by (auto simp add: promela_language_ltl_def promela_language_def promela_is_run_ltl_def)

(* from PromelaDatastructures *)
hide_const (open) abort abortv
                  err errv
                  usc
                  warn the_warn with_warn

hide_const (open) idx idx'
end


subsection \<open>Formedness Properties\<close>

theory Form
imports
  Semantics.TreeToGraph
begin

definition wf_start where
  "wf_start g = (0 \<in> ids g \<and>
    is_StartNode (kind g 0))"

definition wf_closed where
  "wf_closed g =
    (\<forall> n \<in> ids g .
      inputs g n \<subseteq> ids g \<and>
      succ g n \<subseteq> ids g \<and>
      kind g n \<noteq> NoNode)"

definition wf_phis where
  "wf_phis g =
    (\<forall> n \<in> ids g.
      is_PhiNode (kind g n) \<longrightarrow>
      length (ir_values (kind g n))
       = length (ir_ends
           (kind g (ir_merge (kind g n)))))"

definition wf_ends where
  "wf_ends g =
    (\<forall> n \<in> ids g .
      is_AbstractEndNode (kind g n) \<longrightarrow>
      card (usages g n) > 0)"

fun wf_graph :: "IRGraph \<Rightarrow> bool" where
  "wf_graph g = (wf_start g \<and> wf_closed g \<and> wf_phis g \<and> wf_ends g)"

lemmas wf_folds =
  wf_graph.simps
  wf_start_def
  wf_closed_def
  wf_phis_def
  wf_ends_def

fun wf_stamps :: "IRGraph \<Rightarrow> bool" where
  "wf_stamps g = (\<forall> n \<in> ids g .
    (\<forall> v m p e . (g \<turnstile> n \<simeq> e) \<and> ([m, p] \<turnstile> e \<mapsto> v) \<longrightarrow> valid_value v (stamp_expr e)))"

fun wf_stamp :: "IRGraph \<Rightarrow> (ID \<Rightarrow> Stamp) \<Rightarrow> bool" where
  "wf_stamp g s = (\<forall> n \<in> ids g .
    (\<forall> v m p e . (g \<turnstile> n \<simeq> e) \<and> ([m, p] \<turnstile> e \<mapsto> v) \<longrightarrow> valid_value v (s n)))"

lemma wf_empty: "wf_graph start_end_graph"
  unfolding start_end_graph_def wf_folds by simp

lemma wf_eg2_sq: "wf_graph eg2_sq"
  unfolding eg2_sq_def wf_folds by simp

fun wf_logic_node_inputs :: "IRGraph \<Rightarrow> ID \<Rightarrow> bool" where
"wf_logic_node_inputs g n =
  (\<forall> inp \<in> set (inputs_of (kind g n)) . (\<forall> v m p . ([g, m, p] \<turnstile> inp \<mapsto> v) \<longrightarrow> wf_bool v))"

fun wf_values :: "IRGraph \<Rightarrow> bool" where
  "wf_values g = (\<forall> n \<in> ids g .
    (\<forall> v m p . ([g, m, p] \<turnstile> n \<mapsto> v) \<longrightarrow>
       (is_LogicNode (kind g n) \<longrightarrow>
        wf_bool v \<and> wf_logic_node_inputs g n)))"

end


section \<open>Preprocessor and Code-Generator User Interface\<close>
theory LLVM_Codegen_Preproc
imports
  "../kernel/LLVM_Codegen"
  "Monadify"
  "../../lib/Definition_Utils"
  "../../lib/Named_Simpsets"
keywords "export_llvm" "llvm_deps" :: thy_decl
begin

  subsection \<open>Fixed-Point Unfolding Setup\<close>

  lemma llc_while_mono[partial_function_mono]:
    assumes "\<And>x. M_mono (\<lambda>f. b f x)"
    assumes "\<And>x. M_mono (\<lambda>f. c f x)"
    shows "M_mono (\<lambda>D. llc_while (b D) (c D) \<sigma>)"
    using assms unfolding llc_while_def by pf_mono_prover

  declaration \<open>fn _ => Definition_Utils.declare_extraction_group @{binding LLVM} #> snd\<close>
  declaration \<open>fn _ => Definition_Utils.declare_extraction_group @{binding LLVM_while} #> snd\<close>

  declaration \<open> fn _ =>
    Definition_Utils.add_extraction (@{extraction_group LLVM_while},\<^here>) {
      pattern = Logic.varify_global @{term "llc_while b body"},
      gen_thm = @{thm gen_code_thm_llc_while},
      gen_tac = K (K no_tac)
    }
  \<close>

  declaration \<open>fn _ =>
    Definition_Utils.add_extraction (@{extraction_group LLVM},\<^here>) {
      pattern = Logic.varify_global @{term "REC (B::('a \<Rightarrow> 'b llM) \<Rightarrow> 'a \<Rightarrow> 'b llM)"},
      gen_thm = @{thm REC_unfold},
      gen_tac = Partial_Function.mono_tac
    }
  \<close>

subsection \<open>Preprocessor\<close>
  text \<open>
    The actual code generator expects a set of monomorphic, well-shaped equations.
    The preprocessor processes user specified equations, monomorphizes them and
    brings them into the right shape.
  \<close>

  named_theorems llvm_code \<open>Isabelle-LLVM code theorems\<close>

  named_simpset llvm_inline = HOL_ss

  attribute_setup llvm_inline = \<open>
    Attrib.add_del
      (Named_Simpsets.add_attr @{named_simpset llvm_inline})
      (Named_Simpsets.del_attr @{named_simpset llvm_inline})
  \<close>

  lemma llvm_inline_bind_laws[llvm_inline]:
    "bind m return = m"
    "bind (bind m (\<lambda>x. f x)) g = bind m (\<lambda>x. bind (f x) g)"
    by auto

  lemma unit_meta_eq: "x \<equiv> ()" by simp

  lemma pull_lambda_case: "(case x of (a,b) \<Rightarrow> \<lambda>y. t a b y) = (\<lambda>y. case x of (a,b) \<Rightarrow> t a b y)"
    apply (rule ext) apply (cases x) by auto

  ML \<open> structure LLC_Preprocessor =
    struct
      open LLC_Lib

      val cfg_llvm_preproc_timing = Attrib.setup_config_bool @{binding llvm_preproc_timing} (K false)

      structure Monadify = Gen_Monadify_Cong (

        fun mk_return x = @{mk_term "return ?x ::_ llM"}
        fun mk_bind m f = @{mk_term "bind ?m ?f ::_ llM"}

        fun dest_return @{mpat "return ?x ::_ llM"} = SOME x | dest_return _ = NONE
        fun dest_bind @{mpat "bind ?m ?f ::_ llM"} = SOME (m,f) | dest_bind _ = NONE

        fun dest_monadT (Type (@{type_name M},[T,@{typ unit},@{typ llvm_memory},@{typ err}])) = SOME T | dest_monadT _ = NONE

        (*val strip_op = K strip_comb*)

        val bind_return_thm = @{lemma "bind m return = m" by simp}
        val return_bind_thm = @{lemma "bind (return x) f = f x" by simp}
        val bind_bind_thm = @{lemma "bind (bind m (\<lambda>x. f x)) g = bind m (\<lambda>x. bind (f x) g)" by simp}

      )

      (********* Normalization of code theorems *)

      fun cthm_inline ctxt thm = let
        val ctxt = Named_Simpsets.put @{named_simpset llvm_inline} ctxt
      in
        (* TODO: Simplifier.rewrite may introduce beta redexes.
          Currently we eliminate them right away. Or is it OK to have beta-redexes? *)
        Conv.fconv_rule (rhs_conv (Simplifier.rewrite ctxt) then_conv Thm.beta_conversion true) thm
      end

      val cthm_monadify = Conv.fconv_rule o (rhs_conv o Monadify.monadify_conv)

      val inline_iteration_limit =
        Config.int (Config.declare ("inline_iteration_limit", \<^here>) (fn _ => Config.Int ~1));

      fun monadify_inline_cthm ctxt thm = let
        fun rpt 0 thm' = raise THM ("inline_iteration_limit exceeded",~1,[thm,thm'])
          | rpt n thm = let
          val thm' = thm |> cthm_monadify ctxt |> cthm_inline ctxt
        in
          if Thm.eq_thm_prop (thm,thm') then thm
          else rpt (n-1) thm'
        end

        val it_limit = Config.get ctxt inline_iteration_limit
      in
        thm
        |> cthm_inline ctxt
        |> rpt it_limit
      end

      (*
        Bring code theorem into parseable format. To be applied after inlining,
          immediately before parsing.

        Applies eta-expansion, return-expansion, and converts \<equiv> to =.
        Finally, it will replace unit-binds by () constants and anonymous bind.

        May fail on non-well-formed theorems.
      *)
      fun cthm_format ctxt thm = let
        fun normalize_bind1 t = let
          val (f,args) = strip_comb t
          val _ = check_valid_head f

          val args_is_M = fastype_of f |> binder_types |> map (is_llM o body_type)

          val _ = length args_is_M = length args orelse raise TYPE ("cthm_format: All arguments must be explicit", [fastype_of f], [t])

          val args = map2 (fn isM => isM?(normalize o expand_eta_all)) args_is_M args

        in
          list_comb (f, args)
        end

        and normalize @{mpat "bind ?m ?f"} = let
            val m = normalize_bind1 m
            val f = (*ensure_abs f*) expand_eta_all f |> normalize
          in @{mk_term "bind ?m ?f"} end
        | normalize (Abs (x,T,t)) = Abs (x,T,normalize t)
        | normalize (t as @{mpat "return _"}) = t
        | normalize t = let val t = normalize_bind1 t in @{mk_term "bind ?t (\<lambda>x. return x)"} end

        fun normalize_eq @{mpat "Trueprop (?a = ?b)"} = let val b = normalize b in @{mk_term "Trueprop (?a = ?b)"} end
          | normalize_eq @{mpat "?a \<equiv> ?b"} = let val b = normalize b in @{mk_term "?a \<equiv> ?b"} end
          | normalize_eq t = raise TERM ("format_code_thm: normalize_eq", [t])

        fun norm_tac ctxt = ALLGOALS (simp_tac (put_simpset HOL_ss ctxt addsimps @{thms bind_laws}))

        fun cthm_norm_lambda ctxt thm = let
          val thm = Local_Defs.unfold ctxt @{thms pull_lambda_case} thm

          (*fun r thm = case Thm.concl_of thm of
            @{mpat "Trueprop (_ = (\<lambda>_. _))"} => r (thm RS @{thm fun_cong})
          | @{mpat "_ \<equiv> (\<lambda>_. _)"} => r (thm RS @{thm meta_fun_cong})
          | _ => thm
          *)

          fun r thm = case try (fn () => (thm RS @{thm fun_cong})) () of
            NONE => thm
          | SOME thm => r thm

        in
          r thm
        end

      in
        thm
        |> (simplify (put_simpset HOL_ss ctxt addsimps @{thms Monad.bind_laws atomize_eq}))
        |> cthm_norm_lambda ctxt
        |> (Conv.fconv_rule (Refine_Util.f_tac_conv ctxt normalize_eq (norm_tac ctxt)))
        |> (Conv.fconv_rule (Conv.top_sweep_conv (K (Conv.rewr_conv @{thm unit_meta_eq})) ctxt))
      end

      (********* Gathering of code equations *)
      (* TODO: Use net *)

      fun dep_prep_code_thm thm = let
        val c = head_of_eqn_thm thm
        val _ = check_valid_head c
      in
        (c,thm)
      end

      fun dep_try_instantiate_code_thm c (l,thm) = let
        val thy = Thm.theory_of_thm thm
      in
        case SOME (Pattern.match thy (l,c) (Vartab.empty,Vartab.empty)) handle Pattern.MATCH => NONE of
          NONE => NONE
        | SOME m => SOME (instantiate_uc m thm)
      end

      fun dep_find_code_thm pthms c =
        case get_first (dep_try_instantiate_code_thm c) pthms of
          SOME eqn => eqn
        | NONE => raise TERM ("No code equation",[c])

      val cmd_name_prefix = Long_Name.qualify (Long_Name.qualifier @{const_name ll_add}) "ll_"
      val comb_name_prefix = Long_Name.qualify (Long_Name.qualifier @{const_name llc_while}) "llc_"

      fun dep_is_ll_comb_name name =
               name = @{const_name bind}
        orelse name = @{const_name return}
        orelse String.isPrefix cmd_name_prefix name
        orelse String.isPrefix comb_name_prefix name

      fun dep_is_call_const t = case try dest_head t of
        NONE => false
      | SOME (name,T) =>
                  not (dep_is_ll_comb_name name) (* Not an internal name *)
          andalso is_llM (body_type T)           (* Yields a monadic result *)
          andalso not (exists (exists_subtype is_llM) (binder_types T)) (* No monadic parameters *)

      fun calls_of_cthm thm = Term.fold_aterms
        (fn t => dep_is_call_const t?cons t)
        (rhs_of_eqn (Thm.prop_of thm))
        []

      fun default_extractions ctxt =
          Definition_Utils.get_extraction_group ctxt @{extraction_group LLVM}
        |> (not (Config.get ctxt llc_compile_while) ?
              append (Definition_Utils.get_extraction_group ctxt @{extraction_group LLVM_while}))

      fun gather_code_thms roots lthy = let
        val thy = Proof_Context.theory_of lthy
        val pthms = Named_Theorems.get lthy @{named_theorems llvm_code}
          |> map dep_prep_code_thm
          |> Refine_Util.subsume_sort fst thy

        val tim = Config.get lthy cfg_llvm_preproc_timing

        fun trace msg = if tim then msg () |> tracing else ()

        fun process_root c (ctab, lthy) = let
          val _ = check_valid_head c
          val basename = name_of_head c |> Long_Name.base_name
        in
          case Termtab.lookup ctab c of
            SOME _ => (ctab, lthy)
          | NONE => let

              val _ = trace (fn () => "Processing " ^ basename)
              val startt = Time.now ()

              val _ = assert_monomorphic_const c
              (* Get code theorem and inline it *)
              val teqn = dep_find_code_thm pthms c |> monadify_inline_cthm lthy

              (* Extract recursion equations *)
              val exs = default_extractions lthy

              val ((teqn,add_eqns,_),lthy) = Definition_Utils.extract_recursion_eqs exs basename teqn lthy
              val teqns = teqn::add_eqns

              (* Inline and format again *)
              val teqns = map (monadify_inline_cthm lthy #> cthm_format lthy) teqns

              (* Update table *)
              val ctab = fold Termtab.update_new (map dep_prep_code_thm teqns) ctab

              (* Find calls *)
              val calls = map calls_of_cthm teqns |> flat

              val stopt = Time.now()
              val _ = trace (fn () => "Done " ^ basename ^ ": " ^ Time.toString (stopt - startt))

              (* Recurse *)
              val (ctab,lthy) = fold process_root calls (ctab,lthy)
            in
              (ctab, lthy)
            end
        end

        val (ctab,lthy) = fold process_root roots (Termtab.empty,lthy)
        val thms = Termtab.dest ctab |> map snd

      in
        (thms,lthy)
      end

    end
  \<close>

  declaration \<open>K (LLC_Preprocessor.Monadify.prepare_add_const_decl @{term "numeral a"})\<close>

subsection \<open>Code Generator Driver\<close>
  text \<open>
    The driver combines preeprocessing and code generation,
    and defines the user interface of the code generator, namely the commands
    @{command export_llvm} and @{command llvm_deps}.
  \<close>

  ML \<open> structure LLC_Driver
    = struct

      val cfg_llvm_debug = Attrib.setup_config_bool @{binding llvm_debug} (K false)
      val cfg_llvm_timing = Attrib.setup_config_bool @{binding llvm_timing} (K false)
      val cfg_llvm_gen_header = Attrib.setup_config_bool @{binding llvm_gen_header} (K true)

      fun pretty_cthms ctxt cthms = let
        val ctxt = Config.put Syntax_Trans.eta_contract false ctxt
      in Pretty.big_list "Code Theorems" (map (Thm.pretty_thm ctxt) cthms) end

      fun pretty_ftab_entry ctxt (t,n) = Pretty.block [
        Syntax.pretty_term ctxt t, Pretty.brk 1, Pretty.str ":: ", Syntax.pretty_typ ctxt (fastype_of t),
        Pretty.brk 1,Pretty.str "\<rightarrow>",Pretty.brk 1, Pretty.str n
      ]

      fun pretty_ftab ctxt ftab = Pretty.big_list "Symbol table:"
        (map (pretty_ftab_entry ctxt) (Termtab.dest ftab))

      fun consts_to_llvm hfname cns tydefs nt_ovr lthy = let
        val dbg = Config.get lthy cfg_llvm_debug
        val tim = Config.get lthy cfg_llvm_timing
        val gen_header = Config.get lthy cfg_llvm_gen_header
        fun trace s = if dbg then Pretty.string_of (s ()) |> tracing else ()

        fun trtimed msg f x = case (dbg,tim) of
          (_,true) => timeap_msg msg f x
        | (true,_) => (trace (fn () => Pretty.str msg); f x)
        | _ => f x

        val (cthms,lthy) = trtimed "Gathering code theorems" (LLC_Preprocessor.gather_code_thms (map fst cns)) lthy
        val _ = trace (fn () => pretty_cthms lthy cthms)

        fun cmp_symtab cthms = let

          fun fx (_,NONE) = NONE
            | fx (cn, SOME csig) = SOME (cn,C_Interface.name_of_sig csig)

          val fixes = map_filter fx cns
          val ftab = LLC_Compiler.compute_fun_names fixes cthms
        in ftab end

        val ftab = trtimed "Computing symbol table" cmp_symtab cthms
        val _ = trace (fn () => pretty_ftab lthy ftab)

        val (tys,eqns) = trtimed "Translating code theorems to IL" (LLC_Compiler.parse_cthms ftab nt_ovr cthms) lthy
        val _ = trace (fn () => LLC_Intermediate.pretty_llc (tys,eqns))

        val _ = trace (fn () => Pretty.str "Writing LLVM")
        val res = trtimed "Writing LLVM" (LLC_Backend.compile_to_llvm lthy) (tys,eqns)

        val hdres = if gen_header then let
            fun mk_hd eqns = let
              val sigspecs = map_filter snd cns
              fun dest_sig sg = (C_Interface.name_of_sig sg, sg)

              val sigtab = Symtab.make (map dest_sig sigspecs)

              fun match_eqn (eqn as LLC_Intermediate.EQN (_,name,_,_)) = case Symtab.lookup sigtab name of
                NONE => NONE
              | SOME sg => SOME (eqn,sg)

              val eqnsxsigs = map_filter match_eqn eqns

              val hdres = LLC_HeaderGen.make_header hfname tydefs tys eqnsxsigs
            in hdres end

            val hdres = trtimed "Preparing Header" mk_hd eqns
          in hdres end
          else NONE

      in
        ((cthms,res,hdres), lthy)
      end

      local
        val using_master_directory =
          File.full_path o Resources.master_directory o Proof_Context.theory_of;

        fun prepare_path ctxt (s,pos) = let
          val _ = Position.report pos (Markup.language_path false);
          val path = Path.explode s;
          val _ = Position.report pos (Markup.path (Path.implode_symbolic path));
          val path = using_master_directory ctxt path
        in path end

        fun remove_ext ext p = let val (p',ext') = Path.split_ext p in if ext=ext' then p' else p end
        fun remove_all_ext p = case Path.split_ext p of (p,"") => p | (p,_) => remove_all_ext p

        fun prepare_hpath _ NONE = ("HEADER_NAME",NONE)
          | prepare_hpath ctxt (SOME spos) = let
              val path = prepare_path ctxt spos
                |> remove_ext "ll"
                |> Path.ext "h"
              val hfname = remove_all_ext (Path.base path) |> Path.implode
            in
              (hfname,SOME path)
            end

        fun write_out NONE s = writeln s
          | write_out (SOME path) s = File.write path s

        (*
        (*
          Contains a name (used as name for generated LLVM function) and
          an optional signature (used for header file generation).

          Note that this information is redundant, the name in the signature must match
          the LLVM-name. This redundancy, however, reflects the split of LLVM code
          generator and Header file generator.
        *)
        datatype siginfo = SIGI of string * LLC_HeaderGen.raw_sig option

        fun sigi_of_sig (rsg as (LLC_HeaderGen.RSIG (_,name,_))) = SIGI (name,SOME rsg)
        fun sigi_of_name name = SIGI (name,NONE)

        fun sigi_name (SIGI (name,_)) = name
        fun sigi_has_sig (SIGI (_,NONE)) = false
          | sigi_has_sig (SIGI (_,SOME _)) = true

        fun sigi_the_sig (SIGI (_,SOME sg)) = sg
          | sigi_the_sig _ = raise Match

        val parse_sigi =
             (Parse.short_ident || Parse.string) >> sigi_of_name
          || xxx, string needs inner parser!

        *)

      in
        fun export_llvm cns tydefs nt_ovr path (hfname,hfpath) lthy = let
          val lthy = Config.put Syntax_Trans.eta_contract false lthy
          val ((cthms,llvm_code,hcode),lthy) = consts_to_llvm hfname cns tydefs nt_ovr lthy
          val _ = write_out path llvm_code
          val _ = case hcode of SOME c => write_out hfpath c | NONE => ()
        in
          (cthms,lthy)
        end

        val parse_ty_overrides = Scan.repeat1 (Parse.typ --| @{keyword "="} -- Parse.name)

        val export_llvm_cmd = (
          (Args.mode "debug"
          -- Args.mode "timing"
          -- Args.mode "no_while"
          -- Args.mode "no_header"
          -- Parse_Spec.opt_thm_name ":"
          -- Scan.repeat1 (Parse.term -- Scan.option (@{keyword "is"} |-- LLC_HeaderGen.parse_raw_sig ))
          -- Scan.option (@{keyword "defines"} |-- LLC_HeaderGen.parse_raw_tydefs)
          -- Scan.optional (@{keyword "rewrites"} |-- parse_ty_overrides) []
          -- Scan.option ((@{keyword "file"} |-- Parse.position Parse.path))
          )

            >> (fn (((((((((dbg,timing),nowhile),no_header),bnd),cns),tydefs),nt_ovr),path_spos)) => fn lthy => let

              local
                val lthy = (timing?Config.put cfg_llvm_timing true) lthy
                val lthy = (dbg?Config.put cfg_llvm_debug true) lthy
                val lthy = (nowhile?Config.put LLC_Lib.llc_compile_while false) lthy
                val lthy = (no_header?Config.put cfg_llvm_gen_header false) lthy
              in
                val cns = map (apfst (Syntax.read_term lthy)) cns
                val cns = map (apsnd (map_option (LLC_HeaderGen.check_raw_sig lthy))) cns
                val tydefs = the_default [] (map_option (LLC_HeaderGen.check_raw_tydefs lthy) tydefs)

                val nt_ovr = map (apfst (Syntax.read_typ lthy)) nt_ovr

                val path = Option.map (prepare_path lthy) path_spos
                val hfnpath = prepare_hpath lthy path_spos

                val (cthms,lthy) = export_llvm cns tydefs nt_ovr path hfnpath lthy
              end

              val (_,lthy) = Local_Theory.note (bnd,cthms) lthy

            in lthy end))

        val llvm_deps_cmd = Parse_Spec.opt_thm_name ":" -- Scan.repeat1 Parse.term
          >> (fn (bnd,cns) => fn lthy => let
              val cns = map (Syntax.read_term lthy) cns
              val _ = writeln "Gathering code theorems"

              val (cthms,lthy) = LLC_Preprocessor.gather_code_thms cns lthy
              val (_,lthy) = Local_Theory.note (bnd,cthms) lthy

              val _ = writeln "Done"

              val _ = pretty_cthms lthy cthms |> Pretty.string_of |> writeln

             in lthy end
          )

      end

      val _ = Outer_Syntax.local_theory @{command_keyword export_llvm} "generate LLVM code for constants" export_llvm_cmd
      val _ = Outer_Syntax.local_theory @{command_keyword llvm_deps} "Print LLVM code theorems for constants" llvm_deps_cmd
    end
  \<close>

  subsection \<open>Setup for Product Type\<close>
  text \<open>We prepare a setup to compile product types to anonymous 2-element structures\<close>

  lemma to_val_prod[ll_to_val]: "to_val x = llvm_struct [to_val (fst x), to_val (snd x)]"
    by (cases x; simp)

  definition prod_insert_fst :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'a \<Rightarrow> _"
    where [llvm_inline]: "prod_insert_fst p x \<equiv> ll_insert_value p x 0"
  definition prod_insert_snd :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'b \<Rightarrow> _"
    where [llvm_inline]: "prod_insert_snd p x \<equiv> ll_insert_value p x 1"
  definition prod_extract_fst :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'a llM"
    where [llvm_inline]: "prod_extract_fst p \<equiv> ll_extract_value p 0"
  definition prod_extract_snd :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'b llM"
    where [llvm_inline]: "prod_extract_snd p \<equiv> ll_extract_value p 1"
  definition prod_gep_fst :: "('a::llvm_rep \<times> 'b::llvm_rep) ptr \<Rightarrow> 'a ptr llM"
    where [llvm_inline]: "prod_gep_fst p \<equiv> ll_gep_struct p 0"
  definition prod_gep_snd :: "('a::llvm_rep \<times> 'b::llvm_rep) ptr \<Rightarrow> 'b ptr llM"
    where [llvm_inline]: "prod_gep_snd p \<equiv> ll_gep_struct p 1"

  lemma prod_ops_simp:
    "prod_insert_fst = (\<lambda>(_,b) a. return (a,b))"
    "prod_insert_snd = (\<lambda>(a,_) b. return (a,b))"
    "prod_extract_fst = (\<lambda>(a,b). return a)"
    "prod_extract_snd = (\<lambda>(a,b). return b)"
    unfolding
      prod_insert_fst_def prod_insert_snd_def ll_insert_value_def
      prod_extract_fst_def prod_extract_snd_def ll_extract_value_def
    apply (all \<open>intro ext\<close>  )
    apply (auto
      simp: to_val_prod_def from_val_prod_def checked_from_val_def
      split: prod.splits
      )
    done

  subsection \<open>Ad-Hoc Regression Tests\<close>

experiment begin

  definition exp :: "64 word \<Rightarrow> 64 word llM" where [llvm_code]: "exp i \<equiv> doM {
    s \<leftarrow> prod_insert_fst init 1;
    s \<leftarrow> prod_insert_snd s i;
    s \<leftarrow> llc_while
      (\<lambda>s. doM {
        i \<leftarrow> prod_extract_snd s;
        ll_icmp_ne i 0
      })
      (\<lambda>s. doM {
        c \<leftarrow> prod_extract_fst s;
        i \<leftarrow> prod_extract_snd s;

        c \<leftarrow> ll_mul c 2;
        i \<leftarrow> ll_sub i 1;

        s \<leftarrow> prod_insert_fst init c;
        s \<leftarrow> prod_insert_snd s i;

        return s
      })
      s;

    prod_extract_fst s
  }"

  definition streq :: "8 word ptr \<Rightarrow> 8 word ptr \<Rightarrow> 1 word llM" where [llvm_code]: "streq s\<^sub>1 s\<^sub>2 = doM {
      x \<leftarrow> ll_load s\<^sub>1;
      ll_load s\<^sub>2 \<bind> ll_icmp_eq x
    }"

  export_llvm streq

  definition [llvm_code]: "test2 (n::32 word) \<equiv> doM {
    n \<leftarrow> ll_add n 42;
    p \<leftarrow> ll_malloc TYPE(16 word) n;
    p \<leftarrow> ll_ofs_ptr p (5::32 word);
    ll_store 42 p;
    r \<leftarrow> ll_load p;
    return r
  }"

  definition [llvm_code]: "add_add (a::_ word) \<equiv> doM {
    x \<leftarrow> ll_add a a;
    x \<leftarrow> ll_add x x;
    return x
  }"

  definition [llvm_code]: "add_add_driver (a::32 word) (b::64 word) \<equiv> doM {
    a \<leftarrow> add_add a;
    b \<leftarrow> add_add b;
    a \<leftarrow> ll_zext a TYPE(64 word);
    b \<leftarrow> ll_add a b;
    return b
  }"

  export_llvm (debug) add_add_driver

  definition [llvm_code]: "main (argc::32 word) (argv::8 word ptr ptr) \<equiv> doM {
    r \<leftarrow> test2 argc;
    r \<leftarrow> ll_zext r TYPE(32 word);
    return r
  }"

  definition [llvm_code]: "main_exp (argc::32 word) (argv::8 word ptr ptr) \<equiv> doM {
    argc \<leftarrow> ll_zext argc TYPE(64 word);
    r \<leftarrow> exp argc;
    r \<leftarrow> ll_trunc r TYPE(32 word);
    return r
  }"

definition [llvm_code]: "testx (a::64 word) \<equiv> llc_while (\<lambda>a. ll_icmp_ult 0 a) (\<lambda>a. ll_sub a 1) a"
export_llvm (debug) testx
export_llvm (debug) exp_thms1: exp
export_llvm (debug) (no_while) exp_thms2: exp
export_llvm (debug) (no_while) exp_thms3: exp

thm exp_thms1
thm exp_thms2
thm exp_thms3

export_llvm (debug) foobar: main_exp is main
export_llvm (debug) main is main

definition [llvm_code]:
  "test_if_names (n::32 word) \<equiv> doM {
    tmp \<leftarrow> ll_icmp_eq n 0;
    a \<leftarrow> llc_if tmp (return null) (doM {
                                     x \<leftarrow> ll_malloc TYPE(8 word) n;
                                     return x
                                   });
    p \<leftarrow> ll_ofs_ptr a (1::32 word);
    ll_store 0x2A p;
    ll_free a;
    return ()
  }"

export_llvm test_if_names

definition fib :: "64 word \<Rightarrow> 64 word llM"
  where [llvm_code]: "fib n \<equiv> REC (\<lambda>fib n. doM {
    t\<leftarrow>ll_icmp_ule n 1;
    llc_if t
      (return n)
      (doM {
        n\<^sub>1 \<leftarrow> ll_sub n 1;
        a\<leftarrow>fib n\<^sub>1;
        n\<^sub>2 \<leftarrow> ll_sub n 2;
        b\<leftarrow>fib n\<^sub>2;
        c\<leftarrow>ll_add a b;
        return c })} ) n"

export_llvm fib is fib

definition triple_sum :: "(64 word \<times> 64 word \<times> 64 word) ptr \<Rightarrow> 64 word llM" where [llvm_code]:
  "triple_sum abc \<equiv> doM {
    abc \<leftarrow> ll_load abc;
    a \<leftarrow> ll_extract_value abc 0;
    bc::64 word \<times> 64 word \<leftarrow> ll_extract_value abc 1;
    b \<leftarrow> ll_extract_value bc 0;
    c \<leftarrow> ll_extract_value bc 1;
    r \<leftarrow> ll_add a b;
    r \<leftarrow> ll_add r c;
    return r
   }"

export_llvm triple_sum is \<open>_ triple_sum(triple*)\<close>
  defines \<open>typedef struct {int64_t a; struct {int64_t b; int64_t c;};} triple;\<close>

end

end


(*
    Author:      Salomon Sickert
    License:     BSD
*)

section \<open>LTL Code Equations\<close>

theory LTL_Impl
  imports Main
    "../LTL_FGXU"
    Boolean_Expression_Checkers.Boolean_Expression_Checkers
    Boolean_Expression_Checkers.Boolean_Expression_Checkers_AList_Mapping
begin

subsection \<open>Subformulae\<close>

fun G_list :: "'a ltl \<Rightarrow>'a ltl list"
where
  "G_list (\<phi> and \<psi>) = List.union (G_list \<phi>) (G_list \<psi>)"
| "G_list (\<phi> or \<psi>) = List.union (G_list \<phi>) (G_list \<psi>)"
| "G_list (F \<phi>) = G_list \<phi>"
| "G_list (G \<phi>) = List.insert (G \<phi>) (G_list \<phi>)"
| "G_list (X \<phi>) = G_list \<phi>"
| "G_list (\<phi> U \<psi>) = List.union (G_list \<phi>) (G_list \<psi>)"
| "G_list \<phi> = []"

lemma G_eq_G_list:
  "\<^bold>G \<phi> = set (G_list \<phi>)"
  by (induction \<phi>) auto

lemma G_list_distinct:
  "distinct (G_list \<phi>)"
  by (induction \<phi>) auto

subsection \<open>Propositional Equivalence\<close>

fun ifex_of_ltl :: "'a ltl \<Rightarrow> 'a ltl ifex"
where
  "ifex_of_ltl true = Trueif"
| "ifex_of_ltl false = Falseif"
| "ifex_of_ltl (\<phi> and \<psi>) = normif Mapping.empty (ifex_of_ltl \<phi>) (ifex_of_ltl \<psi>) Falseif"
| "ifex_of_ltl (\<phi> or \<psi>) = normif Mapping.empty (ifex_of_ltl \<phi>) Trueif (ifex_of_ltl \<psi>)"
| "ifex_of_ltl \<phi> = IF \<phi> Trueif Falseif"

lemma val_ifex:
  "val_ifex (ifex_of_ltl b) s = (\<Turnstile>\<^sub>P) {x. s x} b"
  by (induction b) (simp add: agree_Nil val_normif)+

lemma reduced_ifex:
  "reduced (ifex_of_ltl b) {}"
  by (induction b) (simp; metis keys_empty reduced_normif)+

lemma ifex_of_ltl_reduced_bdt_checker:
  "reduced_bdt_checkers ifex_of_ltl (\<lambda>y s. {x. s x} \<Turnstile>\<^sub>P y)"
  by (unfold reduced_bdt_checkers_def; insert val_ifex reduced_ifex; blast)

lemma [code]:
  "(\<phi> \<longrightarrow>\<^sub>P \<psi>) = impl_test ifex_of_ltl \<phi> \<psi>"
  by (simp add: ltl_prop_implies_def reduced_bdt_checkers.impl_test[OF ifex_of_ltl_reduced_bdt_checker]; force)

\<comment> \<open>Check Code Export\<close>
export_code "(\<equiv>\<^sub>P)" "(\<longrightarrow>\<^sub>P)" checking

subsection \<open>Remove Constants\<close>

fun remove_constants\<^sub>P :: "'a ltl \<Rightarrow> 'a ltl"
where
  "remove_constants\<^sub>P (\<phi> and \<psi>) = (
    case (remove_constants\<^sub>P \<phi>) of
        false \<Rightarrow> false
      | true \<Rightarrow> remove_constants\<^sub>P \<psi>
      | \<phi>' \<Rightarrow> (case remove_constants\<^sub>P \<psi> of
          false \<Rightarrow> false
        | true \<Rightarrow> \<phi>'
        | \<psi>' \<Rightarrow> \<phi>' and \<psi>'))"
| "remove_constants\<^sub>P (\<phi> or \<psi>) = (
    case (remove_constants\<^sub>P \<phi>) of
        true \<Rightarrow> true
      | false \<Rightarrow> remove_constants\<^sub>P \<psi>
      | \<phi>' \<Rightarrow> (case remove_constants\<^sub>P \<psi> of
          true \<Rightarrow> true
        | false \<Rightarrow> \<phi>'
        | \<psi>' \<Rightarrow> \<phi>' or \<psi>'))"
| "remove_constants\<^sub>P \<phi> = \<phi>"

lemma remove_constants_correct:
  "S \<Turnstile>\<^sub>P \<phi> \<longleftrightarrow> S \<Turnstile>\<^sub>P remove_constants\<^sub>P \<phi>"
  by (induction \<phi> arbitrary: S) (auto split: ltl.split)

subsection \<open>And/Or Constructors\<close>

fun in_and
where
  "in_and x (y and z) = (in_and x y \<or> in_and x z)"
| "in_and x y = (x = y)"

fun in_or
where
  "in_or x (y or z) = (in_or x y \<or> in_or x z)"
| "in_or x y = (x = y)"

lemma in_entailment:
  "in_and x y \<Longrightarrow> S \<Turnstile>\<^sub>P y \<Longrightarrow> S \<Turnstile>\<^sub>P x"
  "in_or x y \<Longrightarrow> S \<Turnstile>\<^sub>P x \<Longrightarrow> S \<Turnstile>\<^sub>P y"
  by (induction y) auto

definition mk_and
where
  "mk_and f x y = (case f x of false \<Rightarrow> false | true \<Rightarrow> f y
    | x' \<Rightarrow> (case f y of false \<Rightarrow> false | true \<Rightarrow> x'
    | y' \<Rightarrow> if in_and x' y' then y' else if in_and y' x' then x' else x' and y'))"

definition mk_and'
where
  "mk_and' x y \<equiv> case y of false \<Rightarrow> false | true \<Rightarrow> x | _ \<Rightarrow> x and y"

definition mk_or
where
  "mk_or f x y = (case f x of true \<Rightarrow> true | false \<Rightarrow> f y
    | x' \<Rightarrow> (case f y of true \<Rightarrow> true | false \<Rightarrow> x'
    | y' \<Rightarrow> if in_or x' y' then y' else if in_or y' x' then x' else x' or y'))"

definition mk_or'
where
  "mk_or' x y \<equiv> case y of true \<Rightarrow> true | false \<Rightarrow> x | _ \<Rightarrow> x or y"

lemma mk_and_correct:
  "S \<Turnstile>\<^sub>P mk_and f x y \<longleftrightarrow> S \<Turnstile>\<^sub>P f x and f y"
proof -
  have X: "\<And>x' y'. S \<Turnstile>\<^sub>P (if in_and x' y' then y' else if in_and y' x' then x' else x' and y')
    \<longleftrightarrow> S \<Turnstile>\<^sub>P x' and y'"
    using in_entailment by auto
  show ?thesis
    unfolding mk_and_def ltl.split X by (cases "f x"; cases "f y"; simp)
qed

lemma mk_and'_correct:
  "S \<Turnstile>\<^sub>P mk_and' x y \<longleftrightarrow> S \<Turnstile>\<^sub>P x and y"
  unfolding mk_and'_def by (cases y; simp)

lemma mk_or_correct:
  "S \<Turnstile>\<^sub>P mk_or f x y \<longleftrightarrow> S \<Turnstile>\<^sub>P f x or f y"
proof -
  have X: "\<And>x' y'. S \<Turnstile>\<^sub>P (if in_or x' y' then y' else if in_or y' x' then x' else x' or y')
    \<longleftrightarrow> S \<Turnstile>\<^sub>P x' or y'"
    using in_entailment by auto
  show ?thesis
    unfolding mk_or_def ltl.split X by (cases "f x"; cases "f y"; simp)
qed

lemma mk_or'_correct:
  "S \<Turnstile>\<^sub>P mk_or' x y \<longleftrightarrow> S \<Turnstile>\<^sub>P x or y"
  unfolding mk_or'_def by (cases y; simp)

end


theory Tut07
  imports "HOL-IMP.Small_Step" "HOL-IMP.Def_Init" "HOL-IMP.Sec_Typing"
begin

inductive sec_type2' :: "com \<Rightarrow> level \<Rightarrow> bool" ("(\<turnstile>'' _ : _)" [0,0] 50) where
Skip2': "\<turnstile>' SKIP : l" |
Assign2': "sec x \<ge> sec a \<Longrightarrow> \<turnstile>' x ::= a : sec x" |
Seq2': "\<lbrakk> \<turnstile>' c\<^sub>1 : l;  \<turnstile>' c\<^sub>2 : l \<rbrakk> \<Longrightarrow> \<turnstile>' c\<^sub>1 ;; c\<^sub>2 : l" |
If2': "\<lbrakk> sec b \<le> l;  \<turnstile>' c\<^sub>1 : l;  \<turnstile>' c\<^sub>2 : l \<rbrakk> \<Longrightarrow> \<turnstile>' IF b THEN c\<^sub>1 ELSE c\<^sub>2 : l" |
While2': "\<lbrakk> sec b \<le> l;  \<turnstile>' c : l \<rbrakk> \<Longrightarrow> \<turnstile>' WHILE b DO c : l" |
Subsumption2': "\<lbrakk> \<turnstile>' c : l; l' \<le> l \<rbrakk> \<Longrightarrow> \<turnstile>' c : l'"

lemma "\<turnstile> c : l \<Longrightarrow> \<turnstile>' c : l"
proof(induction rule: sec_type2.induct)
  case (Seq2 c\<^sub>1 l\<^sub>1 c\<^sub>2 l\<^sub>2)
  then show ?case using Seq2' Subsumption2' by simp
next
  case (If2 b l\<^sub>1 l\<^sub>2 c\<^sub>1 c\<^sub>2)
  then show ?case by (auto intro: sec_type2'.intros simp: Subsumption2')
qed (auto intro: sec_type2'.intros)

lemma "\<turnstile>' c : l \<Longrightarrow> \<exists>l' \<ge> l. \<turnstile> c : l'"
proof(induction rule: sec_type2'.induct)
  case (Seq2' c\<^sub>1 l c\<^sub>2)
  then obtain l\<^sub>1 l\<^sub>2 where ldef: "l\<^sub>1 \<ge> l" "\<turnstile> c\<^sub>1 : l\<^sub>1" "l\<^sub>2 \<ge> l" "\<turnstile> c\<^sub>2 : l\<^sub>2"
    by auto
  moreover from ldef have "l \<le> min l\<^sub>1 l\<^sub>2"
    by auto
  ultimately show ?case using Seq2[of c\<^sub>1 l\<^sub>1 c\<^sub>2 l\<^sub>2] by blast
next
  case (If2' b l c\<^sub>1 c\<^sub>2)
  then show ?case sorry
next
  case (While2' b l c)
  then show ?case using While2 by auto
next
  case (Subsumption2' c l l')
  then show ?case using le_trans by blast
qed (auto intro: sec_type2.intros)

fun AA :: "com \<Rightarrow> (vname \<times> aexp) set \<Rightarrow> (vname \<times> aexp) set" where
  "AA SKIP A = A"
| "AA (x ::= a) A = (if x \<notin> vars a then {(x, a)} else {})
    \<union> {(x', a'). (x', a') \<in> A \<and> x \<notin> {x'} \<union> vars a'}"
| "AA (c\<^sub>1;; c\<^sub>2) A = (AA c\<^sub>2 \<circ> AA c\<^sub>1) A"
| "AA (IF b THEN c\<^sub>1 ELSE c\<^sub>2) A = AA c\<^sub>1 A \<inter> AA c\<^sub>2 A"
| "AA (WHILE b DO c) A = A \<inter> AA c A"

lemma AA_idem: "AA c (AA c A) = AA c A"
  sorry

lemma AA_sound_gen:
  "(c, s) \<Rightarrow> t \<Longrightarrow> \<forall>(x, a) \<in> A. s x = aval a s \<Longrightarrow> \<forall>(x, a) \<in> AA c A. t x = aval a t"
proof(induction arbitrary: A rule: big_step_induct)
  case (Skip s)
  then show ?case by simp
next
  case (Assign x a s)
  then show ?case by auto
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  from WhileTrue have
    "\<forall>(x, a) \<in> AA c A. s\<^sub>2 x = aval a s\<^sub>2"
    by simp
  from WhileTrue have
    "\<forall>(x, a) \<in> AA (WHILE b DO c) (AA c A). s\<^sub>3 x = aval a s\<^sub>3"
    by presburger
  moreover have "AA (WHILE b DO c) (AA c A) = AA c A"
    by (simp add: AA_idem)
  ultimately show ?case
    by simp
qed (fastforce split: prod.splits)+

theorem AA_sound:
  "(c, s) \<Rightarrow> t \<Longrightarrow> \<forall>(x, a) \<in> AA c {}. t x = aval a t"
  using AA_sound_gen by blast

fun gen :: "com \<Rightarrow> (vname \<times> aexp) set" and kill :: "com \<Rightarrow> (vname \<times> aexp) set"  where
  "gen _ = undefined"

lemma "gen (''x''::=N 5;; ''x''::= N 6) = {(''x'',N 6)}"
  by simp

lemma "(''x'', N 6) \<notin> kill (''x''::=N 5;; ''x''::= N 6)"
  by simp

lemma AA_gen_kill: "AA c A = (A \<union> gen c) - kill c"
  sorry

end


(*  Title:       A theory of Featherweight Java in Isabelle/HOL
    Author:      Nate Foster <jnfoster at cis.upenn.edu>,
                 Dimitrios Vytiniotis <dimitriv at cis.upenn.edu>, 2006
    Maintainer:  Nate Foster <jnfoster at cis.upenn.edu>,
                 Dimitrios Vytiniotis <dimitriv at cis.upenn.edu>
    License:     LGPL

  Auxiliary lemmas
*)

header {* {\tt FJAux}: Auxiliary Lemmas *}

theory FJAux imports FJDefs
begin

subsection{* Non-FJ Lemmas *}

subsubsection{* Lists *}
lemma mem_ith:
  assumes "ei \<in> set es"
  shows "\<exists> el er. es = el@ei#er"
  using assms
proof(induct es)
  case Nil thus ?case by auto
next
  case (Cons esh est)
  { assume "esh = ei"
    with Cons have ?case by blast
  } moreover {
    assume "esh \<noteq> ei"
    with Cons have "ei \<in> set est" by auto
    with Cons obtain el er where "esh # est = (esh#el) @ (ei#er)" by auto
    hence ?case by blast }
  ultimately show ?case by blast
qed

lemma ith_mem: "\<And>i. \<lbrakk> i < length es \<rbrakk> \<Longrightarrow> es!i \<in> set es"
proof(induct es)
  case Nil thus ?case by auto
next
  case (Cons h t) thus ?case by(cases "i", auto)
qed

subsubsection{* Maps *}

lemma map_shuffle:
  assumes "length xs = length ys"
  shows "[xs[\<mapsto>]ys,x\<mapsto>y] = [(xs@[x])[\<mapsto>](ys@[y])]"
  using assms
by (induct "xs" "ys" rule:list_induct2) (auto simp add:map_upds_append1)

lemma map_upds_index:
  assumes "length xs = length As"
  and "[xs[\<mapsto>]As]x = Some Ai"
  shows "\<exists>i.(As!i = Ai)
         \<and> (i < length As)
         \<and> (\<forall>(Bs::'c list).((length Bs = length As)
                            \<longrightarrow> ([xs[\<mapsto>]Bs] x = Some (Bs !i))))"
  (is "\<exists>i. ?P i xs As"
   is "\<exists>i.(?P1 i As) \<and> (?P2 i As) \<and> (\<forall>Bs::('c list).(?P3 i xs As Bs))")
  using assms
proof(induct "xs" "As" rule:list_induct2)
  assume "[[][\<mapsto>][]] x = Some Ai"
  moreover have "\<not>[[][\<mapsto>][]] x = Some Ai" by auto
  ultimately show "\<exists>i. ?P i [] []" by contradiction
next
  fix xa xs y ys
  assume length_xs_ys: "length xs = length ys"
    and IH: "[xs [\<mapsto>] ys] x = Some Ai \<Longrightarrow> \<exists>i. ?P i xs ys"
    and map_eq_Some: "[xa # xs [\<mapsto>] y # ys] x = Some Ai"
  then have map_decomp: "[xa#xs [\<mapsto>] y#ys] = [xa\<mapsto>y] ++ [xs[\<mapsto>]ys]" by fastforce
  show "\<exists>i. ?P i (xa#xs) (y # ys)"
  proof(cases "[xs[\<mapsto>]ys]x")
    case(Some Ai')
    hence "([xa \<mapsto>y] ++ [xs[\<mapsto>]ys]) x = Some Ai'" by(rule map_add_find_right)
    hence P: "[xs[\<mapsto>]ys] x = Some Ai" using map_eq_Some Some by simp
    from IH[OF P] obtain i where
      R1: "ys ! i = Ai"
      and R2: "i < length ys"
      and pre_r3: "\<forall>(Bs::'c list). ?P3 i xs ys Bs" by fastforce
    { fix Bs::"'c list"
      assume length_Bs: "length Bs = length (y#ys)"
      then obtain n where "length (y#ys) = Suc n" by auto
      with length_Bs obtain b bs where Bs_def: "Bs = b#bs" by (auto simp add:length_Suc_conv)
      with length_Bs have "length ys = length bs" by simp
      with pre_r3 have "([xa\<mapsto>b] ++ [xs[\<mapsto>]bs]) x = Some (bs!i)" by(auto simp only:map_add_find_right)
      with pre_r3 Bs_def length_Bs have "?P3 (i+1) (xa#xs) (y#ys) Bs" by simp }
    with R1 R2 have "?P (i+1) (xa#xs) (y#ys)" by auto
    thus ?thesis ..
  next
    case None
    with map_decomp map_eq_Some have "[xa\<mapsto>y] x = Some Ai" by (auto simp only:map_add_SomeD)
    hence ai_def: "y = Ai" and x_eq_xa:"x=xa" by (auto simp only:map_upd_Some_unfold)
    { fix Bs::"'c list"
      assume length_Bs: "length Bs = length (y#ys)"
      then obtain n where "length (y#ys) = Suc n" by auto
      with length_Bs obtain b bs where Bs_def: "Bs = b#bs" by (auto simp add:length_Suc_conv)
      with length_Bs have "length ys = length bs" by simp
      hence "dom([xs[\<mapsto>]ys]) = dom([xs[\<mapsto>]bs])" by auto
      with None have "[xs[\<mapsto>]bs] x = None" by (auto simp only:domIff)
      moreover from x_eq_xa have sing_map: "[xa\<mapsto>b] x = Some b" by (auto simp only:map_upd_Some_unfold)
      ultimately have "([xa\<mapsto>b] ++ [xs[\<mapsto>]bs]) x = Some b" by (auto simp only:map_add_Some_iff)
      with Bs_def have "?P3 0 (xa#xs) (y#ys) Bs" by simp }
    with ai_def have "?P 0 (xa#xs) (y#ys)" by auto
    thus ?thesis ..
  qed
qed

subsection{* FJ Lemmas *}

subsubsection{* Substitution *}

lemma subst_list1_eq_map_substs :
  "\<forall>\<sigma>. subst_list1 \<sigma> l = map (substs \<sigma>) l"
   by (induct l, simp_all)

lemma subst_list2_eq_map_substs :
  "\<forall>\<sigma>. subst_list2 \<sigma> l = map (substs \<sigma>) l"
   by (induct l, simp_all)

subsubsection{* Lookup *}

lemma lookup_functional:
  assumes "lookup l f = o1"
  and "lookup l f = o2"
  shows "o1 = o2"
using assms by (induct l) auto

lemma lookup_true:
  "lookup l f = Some r \<Longrightarrow> f r"
proof(induct l)
  case Nil thus ?case by simp
next
  case(Cons h t) thus ?case by(cases "f h") (auto simp add:lookup.simps)
qed

lemma lookup_hd:
  "\<lbrakk> length l > 0; f (l!0) \<rbrakk> \<Longrightarrow> lookup l f = Some (l!0)"
by (induct l) auto

lemma lookup_split: "lookup l f = None \<or> (\<exists>h. lookup l f = Some h)"
by (induct l) simp_all

lemma lookup_index:
  assumes "lookup l1 f = Some e"
  shows " \<And>l2. \<exists>i < (length l1). e = l1!i \<and> ((length l1 = length l2) \<longrightarrow> lookup2 l1 l2 f = Some (l2!i))"
  using assms
proof(induct l1)
  case Nil thus ?case by auto
next
  case (Cons h1 t1)
  { assume asm:"f h1"
    hence "0<length (h1 # t1) \<and> e = (h1 # t1) ! 0"
      using Cons by (auto simp add:lookup.simps)
    moreover {
      assume "length (h1 # t1) = length l2"
      hence "length l2 = Suc (length t1)" by auto
      then obtain h2 t2 where l2_def:"l2 = h2#t2" by (auto simp add: length_Suc_conv)
      hence "lookup2 (h1 # t1) l2 f = Some (l2 ! 0)" using asm by(auto simp add: lookup2.simps)
    }
    ultimately have ?case by auto
  } moreover {
    assume asm:"\<not> (f h1)"
    hence "lookup t1 f = Some e"
      using Cons by (auto simp add:lookup.simps)
    then obtain i where
      "i<length t1"
      and "e = t1 ! i"
      and  ih:"(length t1 = length (tl l2) \<longrightarrow> lookup2 t1 (tl l2) f = Some ((tl l2) ! i))"
      using Cons by blast
    hence "Suc i < length (h1#t1) \<and> e = (h1#t1)!(Suc i)" using Cons by auto
    moreover {
      assume "length (h1 # t1) = length l2"
      hence lens:"length l2 = Suc (length t1)" by auto
      then obtain h2 t2 where l2_def:"l2 = h2#t2" by (auto simp add: length_Suc_conv)
      hence "lookup2 t1 t2 f = Some (t2 ! i)" using ih l2_def lens by auto
      hence "lookup2 (h1 # t1) l2 f = Some (l2!(Suc i))"
        using asm l2_def by(auto simp add: lookup2.simps)
    }
    ultimately have ?case by auto
  }
  ultimately show ?case by auto
qed

lemma lookup2_index:
  "\<And>l2. \<lbrakk> lookup2 l1 l2 f = Some e;
  length l1 = length l2 \<rbrakk> \<Longrightarrow> \<exists>i < (length l2). e = (l2!i) \<and> lookup l1 f = Some (l1!i)"
proof(induct l1)
  case Nil thus ?case by auto
next
  case (Cons h1 t1)
  hence "length l2 = Suc (length t1)" by auto
  then obtain h2 t2 where l2_def:"l2 = h2#t2" by (auto simp add: length_Suc_conv)
  { assume asm:"f h1"
    hence "e = h2" using Cons l2_def by (auto simp add:lookup2.simps)
    hence "0<length (h2#t2) \<and> e = (h2#t2) ! 0 \<and> lookup (h1 # t1) f = Some ((h1 # t1) ! 0)"
      using asm by (auto simp add:lookup.simps)
    hence ?case using l2_def by auto
  } moreover {
    assume asm:"\<not> (f h1)"
    hence "\<exists>i<length t2. e = t2 ! i \<and> lookup t1 f = Some (t1 ! i)" using Cons l2_def by auto
    then obtain i where "i<length t2 \<and>  e = t2 ! i \<and> lookup t1 f = Some (t1 ! i)" by auto
    hence "(Suc i) < length(h2#t2) \<and> e = ((h2#t2) ! (Suc i)) \<and> lookup (h1#t1) f = Some ((h1#t1) ! (Suc i))"
      using asm by (force simp add: lookup.simps)
    hence ?case using l2_def by auto
  }
  ultimately show ?case by auto
qed

lemma lookup_append:
  assumes "lookup l f = Some r"
  shows "lookup (l@l') f = Some r"
  using assms by(induct l) auto

lemma method_typings_lookup:
  assumes lookup_eq_Some: "lookup M f = Some mDef"
  and M_ok: "CT \<turnstile>+ M OK IN C"
  shows "CT \<turnstile> mDef OK IN C"
  using lookup_eq_Some M_ok
proof(induct M)
  case Nil thus ?case by fastforce
next
  case (Cons h t) thus ?case by(cases "f h", auto elim:method_typings.cases simp add:lookup.simps)
qed

subsubsection{* Functional *}

text {* These lemmas prove that several relations are actually functions *}

lemma mtype_functional:
  assumes "mtype(CT,m,C) = Cs \<rightarrow> C0"
  and     "mtype(CT,m,C) = Ds \<rightarrow> D0"
  shows "Ds=Cs \<and> D0=C0"
using assms by induct (auto elim:mtype.cases)

lemma mbody_functional:
  assumes mb1: "mbody(CT,m,C) = xs . e0"
  and     mb2: "mbody(CT,m,C) = ys . d0"
  shows "xs = ys \<and> e0 = d0"
using assms by induct (auto elim:mbody.cases)

lemma fields_functional:
  assumes "fields(CT,C) = Cf"
  and "CT OK"
  shows "\<And>Cf'. \<lbrakk> fields(CT,C) = Cf'\<rbrakk> \<Longrightarrow> Cf = Cf'"
using assms
proof induct
  case (f_obj CT)
  hence "CT(Object) = None" by (auto elim: ct_typing.cases)
  thus ?case using f_obj by (auto elim: fields.cases)
next
  case (f_class CT C CDef D Cf Dg DgCf DgCf')
  hence f_class_inv:
    "(CT C = Some CDef) \<and> (cSuper CDef = D) \<and> (cFields CDef = Cf)"
    and "CT OK" by fastforce+
  hence c_not_obj:"C \<noteq> Object" by (force elim:ct_typing.cases)
  from f_class have flds:"fields(CT,C) = DgCf'" by fastforce
  then obtain Dg' where
    "fields(CT,D) = Dg'"
    and "DgCf' = Dg' @ Cf"
    using f_class_inv c_not_obj by (auto elim:fields.cases)
  hence "Dg' = Dg" using f_class by auto
  thus ?case using `DgCf = Dg @ Cf` and `DgCf' = Dg' @ Cf` by force
qed

subsubsection{* Subtyping and Typing *}

lemma typings_lengths: assumes "CT;\<Gamma> \<turnstile>+ es:Cs" shows "length es = length Cs"
  using assms by(induct "es" "Cs") (auto elim:typings.cases)

lemma typings_index:
  assumes "CT;\<Gamma> \<turnstile>+ es:Cs"
  shows "\<And>i. \<lbrakk> i < length es \<rbrakk> \<Longrightarrow> CT;\<Gamma> \<turnstile> (es!i) : (Cs!i)"
proof -
  have "length es = length Cs" using assms by (auto simp: typings_lengths)
  thus "\<And>i. \<lbrakk> i < length es \<rbrakk> \<Longrightarrow> CT;\<Gamma> \<turnstile> (es!i) : (Cs!i)"
    using assms
  proof(induct es Cs rule:list_induct2)
    case Nil thus ?case by auto
  next
    case (Cons esh est hCs tCs i)
    thus ?case by(cases i) (auto elim:typings.cases)
  qed
qed

lemma subtypings_index:
  assumes "CT \<turnstile>+ Cs <: Ds"
  shows "\<And>i. \<lbrakk> i < length Cs \<rbrakk> \<Longrightarrow> CT \<turnstile> (Cs!i) <: (Ds!i)"
  using assms
proof induct
  case ss_nil thus ?case by auto
next
  case (ss_cons hCs CT tCs hDs tDs i)
  thus ?case by(cases "i", auto)
qed

lemma typings_append:
  assumes "CT;\<Gamma> \<turnstile>+ es : Cs"
  and "CT;\<Gamma> \<turnstile> e : C"
  shows "CT;\<Gamma> \<turnstile>+ (es@[e]) : (Cs@[C])"
proof -
  have "length es = length Cs" using assms by(simp_all add:typings_lengths)
  thus "CT;\<Gamma> \<turnstile>+ (es@[e]) : (Cs@[C])" using assms
  proof(induct "es" "Cs" rule:list_induct2)
    have "CT;\<Gamma> \<turnstile>+ []:[]" by(simp add:typings_typing.ts_nil)
    moreover from assms have "CT;\<Gamma> \<turnstile> e : C" by simp
    ultimately show "CT;\<Gamma> \<turnstile>+ ([]@[e]) : ([]@[C])" by (auto simp add:typings_typing.ts_cons)
  next
    fix x xs y ys
    assume "length xs = length ys"
      and IH: "\<lbrakk>CT;\<Gamma> \<turnstile>+ xs : ys; CT;\<Gamma> \<turnstile> e : C\<rbrakk> \<Longrightarrow> CT;\<Gamma> \<turnstile>+ (xs @ [e]) : (ys @ [C])"
      and x_xs_typs: "CT;\<Gamma> \<turnstile>+ (x # xs) : (y # ys)"
      and e_typ: "CT;\<Gamma> \<turnstile> e : C"
    from x_xs_typs have x_typ: "CT;\<Gamma> \<turnstile> x : y" and "CT;\<Gamma> \<turnstile>+ xs : ys" by(auto elim:typings.cases)
    with IH e_typ have "CT;\<Gamma> \<turnstile>+ (xs@[e]) : (ys@[C])" by simp
    with x_typ have "CT;\<Gamma> \<turnstile>+ ((x#xs)@[e]) : ((y#ys)@[C])" by (auto simp add:typings_typing.ts_cons)
    thus "CT;\<Gamma> \<turnstile>+ ((x # xs) @ [e]) : ((y # ys) @ [C])" by(auto simp add:typings_typing.ts_cons)
  qed
qed

lemma ith_typing: "\<And>Cs. \<lbrakk> CT;\<Gamma> \<turnstile>+ (es@(h#t)) : Cs \<rbrakk> \<Longrightarrow> CT;\<Gamma> \<turnstile> h : (Cs!(length es))"
proof(induct "es", auto elim:typings.cases)
qed

lemma ith_subtyping: "\<And>Ds. \<lbrakk> CT \<turnstile>+ (Cs@(h#t)) <: Ds \<rbrakk> \<Longrightarrow> CT \<turnstile> h <: (Ds!(length Cs))"
proof(induct "Cs", auto elim:subtypings.cases)
qed

lemma subtypings_refl: "CT \<turnstile>+ Cs <: Cs"
by(induct "Cs", auto simp add: subtyping.s_refl subtypings.intros)

lemma subtypings_trans: "\<And>Ds Es. \<lbrakk> CT \<turnstile>+ Cs <: Ds;  CT \<turnstile>+ Ds <: Es \<rbrakk> \<Longrightarrow> CT \<turnstile>+ Cs <: Es"
proof(induct "Cs")
  case Nil thus ?case
    by (auto elim:subtypings.cases simp add:subtypings.ss_nil)
next
  case (Cons hCs tCs)
  then obtain hDs tDs
    where h1:"CT \<turnstile> hCs <: hDs" and t1:"CT \<turnstile>+ tCs <: tDs" and "Ds = hDs#tDs"
    by (auto elim:subtypings.cases)
  then obtain hEs tEs
    where h2:"CT \<turnstile> hDs <: hEs" and t2:"CT \<turnstile>+ tDs <: tEs" and "Es = hEs#tEs"
    using Cons by (auto elim:subtypings.cases)
  moreover from subtyping.s_trans[OF h1 h2] have "CT \<turnstile> hCs <: hEs" by fastforce
  moreover with t1 t2 have "CT \<turnstile>+ tCs <: tEs" using Cons by simp_all
  ultimately show ?case by (auto simp add:subtypings.intros)
qed

lemma ith_typing_sub:
  "\<And>Cs. \<lbrakk> CT;\<Gamma> \<turnstile>+ (es@(h#t)) : Cs;
     CT;\<Gamma> \<turnstile> h' : Ci';
     CT \<turnstile> Ci' <: (Cs!(length es)) \<rbrakk>
  \<Longrightarrow> \<exists>Cs'. (CT;\<Gamma> \<turnstile>+ (es@(h'#t)) : Cs' \<and> CT \<turnstile>+ Cs' <: Cs)"
proof(induct es)
case Nil
 then obtain hCs tCs
   where ts: "CT;\<Gamma> \<turnstile>+ t : tCs"
   and Cs_def: "Cs = hCs # tCs" by(auto elim:typings.cases)
 from Cs_def Nil have "CT \<turnstile> Ci' <: hCs" by auto
 with Cs_def have "CT \<turnstile>+ (Ci'#tCs) <: Cs" by(auto simp add:subtypings.ss_cons subtypings_refl)
 moreover from ts Nil have "CT;\<Gamma> \<turnstile>+ (h'#t) : (Ci'#tCs)" by(auto simp add:typings_typing.ts_cons)
 ultimately show ?case by auto
next
case (Cons eh et)
then obtain hCs tCs
  where "CT;\<Gamma> \<turnstile> eh : hCs"
  and "CT;\<Gamma> \<turnstile>+ (et@(h#t)) : tCs"
  and Cs_def: "Cs = hCs # tCs"
  by(auto elim:typings.cases)
moreover with Cons obtain tCs'
  where "CT;\<Gamma> \<turnstile>+ (et@(h'#t)) : tCs'"
  and "CT \<turnstile>+ tCs' <: tCs"
  by auto
ultimately have
  "CT;\<Gamma> \<turnstile>+ (eh#(et@(h'#t))) : (hCs#tCs')"
  and "CT \<turnstile>+ (hCs#tCs') <: Cs"
  by(auto simp add:typings_typing.ts_cons subtypings.ss_cons subtyping.s_refl)
thus ?case by auto
qed

lemma mem_typings:
  "\<And>Cs. \<lbrakk> CT;\<Gamma> \<turnstile>+ es:Cs; ei \<in> set es\<rbrakk> \<Longrightarrow> \<exists>Ci. CT;\<Gamma> \<turnstile> ei:Ci"
proof(induct es)
  case Nil thus ?case by auto
next
  case (Cons eh et) thus ?case
    by(cases "ei=eh", auto elim:typings.cases)
qed

lemma typings_proj:
  assumes "CT;\<Gamma> \<turnstile>+ ds : As"
      and "CT \<turnstile>+ As <: Bs"
      and "length ds = length As"
      and "length ds = length Bs"
      and "i < length ds"
    shows "CT;\<Gamma> \<turnstile> ds!i : As!i" and "CT \<turnstile> As!i <: Bs!i"
  using assms by (auto simp add:typings_index subtypings_index)

lemma subtypings_length:
  "CT \<turnstile>+ As <: Bs \<Longrightarrow> length As = length Bs"
  by(induct rule:subtypings.induct) simp_all

lemma not_subtypes_aux:
  assumes "CT \<turnstile> C <: Da"
  and "C \<noteq> Da"
  and "CT C = Some CDef"
  and "cSuper CDef = D"
  shows "CT \<turnstile> D <: Da"
  using assms
by (induct rule:subtyping.induct) (auto intro:subtyping.intros)

lemma not_subtypes:
  assumes "CT \<turnstile> A <: C"
  shows "\<And>D. \<lbrakk> CT \<turnstile> D \<not><: C;  CT \<turnstile> C \<not><: D\<rbrakk> \<Longrightarrow> CT \<turnstile> A \<not><: D"
  using assms
proof(induct rule:subtyping.induct)
  case s_refl thus ?case by auto
next
  case (s_trans CT C D E Da)
  have da_nsub_d:"CT \<turnstile> Da \<not><: D"
  proof(rule ccontr)
    assume "\<not> CT \<turnstile> Da \<not><: D"
    hence da_sub_d:"CT \<turnstile> Da <: D" by auto
    have d_sub_e:"CT \<turnstile> D <: E" using s_trans by fastforce
    thus "False" using s_trans by (force simp add:subtyping.s_trans[OF da_sub_d d_sub_e])
  qed
  have d_nsub_da:"CT \<turnstile> D \<not><: Da" using s_trans by auto
  from da_nsub_d d_nsub_da s_trans show "CT \<turnstile> C \<not><: Da" by auto
next
  case (s_super CT C CDef D Da)
  have "C \<noteq> Da" proof(rule ccontr)
    assume "\<not> C \<noteq> Da"
    hence "C = Da" by auto
    hence "CT \<turnstile> Da <: D" using s_super by(auto simp add: subtyping.s_super)
    thus "False" using s_super by auto
  qed
  thus ?case using s_super by (auto simp add: not_subtypes_aux)
qed

subsubsection{* Sub-Expressions *}

lemma isubexpr_typing:
  assumes "e1 \<in> isubexprs(e0)"
  shows "\<And>C. \<lbrakk> CT;empty \<turnstile> e0 : C \<rbrakk> \<Longrightarrow> \<exists>D. CT;empty \<turnstile> e1 : D"
using assms
  by (induct rule:isubexprs.induct) (auto elim:typing.cases simp add:mem_typings)

lemma subexpr_typing:
  assumes "e1 \<in> subexprs(e0)"
  shows "\<And>C. \<lbrakk> CT;empty \<turnstile> e0 : C \<rbrakk> \<Longrightarrow> \<exists>D. CT;empty \<turnstile> e1 : D"
using assms
  by (induct rule:rtrancl.induct) (auto, force simp add:isubexpr_typing)

lemma isubexpr_reduct:
  assumes "d1 \<in> isubexprs(e1)"
  shows "\<And>d2. \<lbrakk> CT \<turnstile> d1 \<rightarrow> d2 \<rbrakk> \<Longrightarrow> \<exists>e2. CT \<turnstile> e1 \<rightarrow> e2"
using assms mem_ith
  by induct
    (auto elim:isubexprs.cases intro:reduction.intros,
      force intro:reduction.intros,
      force intro:reduction.intros)

lemma subexpr_reduct:
  assumes "d1 \<in> subexprs(e1)"
  shows "\<And>d2. \<lbrakk> CT \<turnstile> d1 \<rightarrow> d2 \<rbrakk> \<Longrightarrow> \<exists>e2. CT \<turnstile> e1 \<rightarrow> e2"
using assms
  by (induct rule:rtrancl.induct) (auto, force simp add: isubexpr_reduct)

end