theory Lift_Snd
  imports "../Lifter"
begin
(*
 * snd
 *)

definition snd_l ::
  "('x, 'a, 'b2 :: Pord_Weak) lifting \<Rightarrow>
   ('x, 'a, ('b1 :: Pord_Weakb) * 'b2) lifting" where
"snd_l t =
      LMake (\<lambda> s a b . (case b of (b1, b2) \<Rightarrow> (b1, LUpd t s a b2)))
            (\<lambda> s x . (LOut t s (snd x)))
            (\<lambda> s . (\<bottom>, LBase t s))"

definition snd_l_S :: "('x, 'b2 :: Pord_Weak) valid_set \<Rightarrow> ('x, ('b1 :: Pord_Weakb * 'b2)) valid_set" where
"snd_l_S S s =
  { b . case b of (_, b2) \<Rightarrow> (b2 \<in> S s) }"

locale snd_l_valid_weak = lifting_valid_weak

sublocale snd_l_valid_weak \<subseteq> out : lifting_valid_weak "snd_l l" "snd_l_S S"
proof
  fix s a
  fix b :: "('e :: Pord_Weakb) * ('c :: Pord_Weak)"
  show "LOut (snd_l l) s (LUpd (snd_l l) s a b) = a"
    using put_get
    by(auto simp add: snd_l_def split:prod.splits)
next
  fix s
  fix b :: "('e :: Pord_Weakb) * ('c :: Pord_Weak)"
  assume  Hb : "b \<in> snd_l_S S s"
  thus "b <[ LUpd (snd_l l) s (LOut (snd_l l) s b) b"
    using get_put_weak
    by(auto simp add: snd_l_def prod_pleq leq_refl snd_l_S_def split:prod.splits)
next
  fix s a
  fix b :: "('e :: Pord_Weakb) * ('c :: Pord_Weak)"
  show "LUpd (snd_l l) s a b \<in> snd_l_S S s"
    using put_S
    by(auto simp add: snd_l_def prod_pleq leq_refl snd_l_S_def split:prod.splits)
qed

lemma (in snd_l_valid_weak) ax :
  shows "lifting_valid_weak (snd_l l) (snd_l_S S)"
  using out.lifting_valid_weak_axioms
  by auto

lemma (in snd_l_valid_weak) ax_g :
  assumes H : "\<And> x . S' x = snd_l_S S x"
  shows "lifting_valid_weak (snd_l l) S'"
proof-
  have "S' = snd_l_S S"
    using assms by auto
  then show ?thesis
    using out.lifting_valid_weak_axioms
    by auto
qed

locale snd_l_valid_ext = lifting_valid_ext

sublocale snd_l_valid_ext \<subseteq> out : lifting_valid_ext "snd_l l" "snd_l_S S"
proof
  fix s a
  fix b :: "('e :: Pord_Weakb) * ('c :: Pord_Weak)"
  (*assume  Hb : "b \<in> snd_l_S S s"*)
  show "b <[ LUpd (snd_l l) s a b"
    using get_put
    by(auto simp add: snd_l_def prod_pleq leq_refl snd_l_S_def split:prod.splits)
qed

lemma (in snd_l_valid_ext) ax :
  shows "lifting_valid_ext (snd_l l)"
  using out.lifting_valid_ext_axioms
  by auto

locale snd_l_valid_base_ext = lifting_valid_base_ext
sublocale snd_l_valid_base_ext \<subseteq> out : lifting_valid_base_ext "snd_l l" "snd_l_S S"
proof
  fix s
  show "LBase (snd_l l) s = \<bottom>" using base
    by(auto simp add: snd_l_def prod_bot)
qed

lemma (in snd_l_valid_base_ext) ax :
  shows "lifting_valid_base_ext (snd_l l)"
  using out.lifting_valid_base_ext_axioms
  by auto

locale snd_l_valid_ok_ext = lifting_valid_ok_ext
sublocale snd_l_valid_ok_ext \<subseteq> out : lifting_valid_ok_ext "snd_l l" "snd_l_S S"
proof
  fix s

  show "ok_S \<subseteq> snd_l_S S s" using ok_S_valid
    by(auto simp add: prod_ok_S snd_l_S_def)
next
  fix s a
  fix b :: "('d * 'c)"
  assume B: "b \<in> ok_S"
  then show "LUpd (snd_l l) s a b \<in> ok_S" using ok_S_put
    by(auto simp add: prod_ok_S snd_l_S_def snd_l_def)
qed

lemma (in snd_l_valid_ok_ext) ax :
  shows "lifting_valid_ok_ext (snd_l l) (snd_l_S S)"
  using out.lifting_valid_ok_ext_axioms
  by auto

lemma (in snd_l_valid_ok_ext) ax_g :
  assumes H: "\<And> x . S' x = snd_l_S S x"
  shows "lifting_valid_ok_ext (snd_l l) S'"
proof-
  have "S' = snd_l_S S"
    using assms by auto
  then show ?thesis
  using out.lifting_valid_ok_ext_axioms
  by auto
qed

locale snd_l_valid_pres_ext = lifting_valid_pres_ext
sublocale snd_l_valid_pres_ext \<subseteq> out : lifting_valid_pres_ext "snd_l l" "snd_l_S S"
proof
  fix v supr :: "('d * 'c)"
  fix V f s

  assume HV : "v \<in> V"
  assume HS : "V \<subseteq> snd_l_S S s"
  assume Hsupr : "is_sup V supr"
  assume Hsupr_S : "supr \<in> snd_l_S S s"
  show "is_sup (LMap (snd_l l) f s ` V) (LMap (snd_l l) f s supr)"
  proof(rule is_supI)

    fix x

    assume Xin : "x \<in> LMap (snd_l l) f s ` V"

    obtain x1 x2 where X: "x = (x1, x2)" by(cases x; auto)

    obtain xi xi1 xi2 where Xi : "xi = (xi1, xi2)" "xi \<in> V" "LMap (snd_l l) f s xi = x"
      using Xin
      by auto

    obtain supr1 supr2 where Supr : "supr = (supr1, supr2)" by(cases supr; auto)

    have "xi <[ supr" using is_supD1[OF Hsupr Xi(2)] by simp

    hence "xi1 <[ supr1" "xi2 <[ supr2"
      using Xi Supr
      by(auto simp add: prod_pleq split: prod.splits)

    have "x1 = xi1" using Xi X
      by(auto simp add: snd_l_def)

    have "x2 = LMap l f s xi2"
      using Xi X
      by(auto simp add: snd_l_def)

    have "LMap (snd_l l) f s supr = (supr1, LMap l f s supr2)"
      using Supr
      by(auto simp add: snd_l_def)

    have Xi1_in : "xi2 \<in> snd ` V"
      using imageI[OF `xi \<in> V`, of snd] Xi
      by(auto)

    have Fst_V_sub : "snd ` V \<subseteq> S s"
      using HS
      by(auto simp add: snd_l_S_def)

    have "supr2 \<in> S s"
      using Hsupr_S Supr
      by(auto simp add: snd_l_S_def)

    have Supr1_sup : "is_sup (snd ` V) supr2"
    proof(rule is_supI)
      fix w2
      assume "w2 \<in> snd ` V"

      then obtain w1 where "(w1, w2) \<in> V"
        by auto

      hence "(w1, w2) <[ supr" using is_supD1[OF Hsupr, of "(w1, w2)"] by auto

      thus "w2 <[ supr2" using Supr by(auto simp add: prod_pleq)
    next

      fix z2

      assume Hub : "is_ub (snd ` V) z2"

      have "is_ub V (supr1, z2)"
      proof(rule is_ubI)
        fix w
        assume "w \<in> V"

        obtain w1 w2 where W: "w = (w1, w2)" by(cases w; auto)

        have "w2 \<in> (snd ` V)"
          using imageI[OF `w \<in> V`, of snd] W by auto

        hence "w2 <[ z2" using is_ubE[OF Hub] by auto

        have "w1 <[ supr1" using is_supD1[OF Hsupr `w \<in> V`] Supr W
          by(auto simp add: prod_pleq)

        then show "w <[ (supr1, z2)" using W `w2 <[ z2`
          by(auto simp add: prod_pleq)
      qed

      show "supr2 <[ z2"
        using is_supD2[OF Hsupr `is_ub V (supr1, z2)`] Supr
        by(auto simp add: prod_pleq)
    qed

    have Supr1_map : "is_sup (LMap l f s ` snd ` V) (LMap l f s supr2)"
      using pres using pres[OF Xi1_in Fst_V_sub Supr1_sup `supr2 \<in> S s` , of f]
      by simp

    have X1_in : "x2 \<in> LMap l f s ` snd ` V"
      using X Xi imageI[OF `xi \<in> V`, of snd]
      by(auto simp add: snd_l_def)

    have "x2 <[ LMap l f s supr2"
      using is_supD1[OF Supr1_map X1_in]
      by simp

    have "x1 <[ supr1" using `x1 = xi1` `xi1 <[ supr1` by simp

    then show "x <[ LMap (snd_l l) f s supr"
      using X Supr `x2 <[ LMap l f s supr2`
      by(auto simp add: snd_l_def prod_pleq)
  next
    fix x

    assume Xub : "is_ub (LMap (snd_l l) f s ` V) x"

    obtain supr1 supr2 where Supr : "supr = (supr1, supr2)" by(cases supr; auto)

  (* TODO: copy-pasted from first case *)
    have "LMap (snd_l l) f s supr = (supr1, LMap l f s supr2)"
      using Supr
      by(auto simp add: snd_l_def)

    have Snd_V_sub : "snd ` V \<subseteq> S s"
      using HS
      by(auto simp add: snd_l_S_def)

    have "supr2 \<in> S s"
      using Hsupr_S Supr
      by(auto simp add: snd_l_S_def)

    have Supr2_sup : "is_sup (snd ` V) supr2"
    proof(rule is_supI)
      fix w2
      assume "w2 \<in> snd ` V"

      then obtain w1 where "(w1, w2) \<in> V"
        by auto

      hence "(w1, w2) <[ supr" using is_supD1[OF Hsupr, of "(w1, w2)"] by auto

      thus "w2 <[ supr2" using Supr by(auto simp add: prod_pleq)
    next

      fix z2

      assume Hub : "is_ub (snd ` V) z2"

      have "is_ub V (supr1, z2)"
      proof(rule is_ubI)
        fix w
        assume "w \<in> V"

        obtain w1 w2 where W: "w = (w1, w2)" by(cases w; auto)

        have "w2 \<in> (snd ` V)"
          using imageI[OF `w \<in> V`, of snd] W by auto

        hence "w2 <[ z2" using is_ubE[OF Hub] by auto

        have "w1 <[ supr1" using is_supD1[OF Hsupr `w \<in> V`] Supr W
          by(auto simp add: prod_pleq)

        then show "w <[ (supr1, z2)" using W `w2 <[ z2`
          by(auto simp add: prod_pleq)
      qed

      show "supr2 <[ z2"
        using is_supD2[OF Hsupr `is_ub V (supr1, z2)`] Supr
        by(auto simp add: prod_pleq)
    qed

    obtain v1 v2 where V : "v = (v1, v2)" "v2 \<in> snd ` V"
      using imageI[OF HV, of snd]
      by(cases v; auto)

    have Supr2_map : "is_sup (LMap l f s ` snd ` V) (LMap l f s supr2)"
      using pres[OF V(2) Snd_V_sub Supr2_sup `supr2 \<in> S s` ]
      by simp

    obtain x1 x2 where X: "x = (x1, x2)" by(cases x; auto)

    have X2_ub : "is_ub (LMap l f s ` snd ` V) x2"
    proof
      fix w2

      assume W2: "w2 \<in> LMap l f s ` snd ` V"

      then obtain wi wi1 wi2  where Wi : "wi \<in> V" "LMap l f s wi2 = w2" "wi = (wi1, wi2)"
        by(auto)

      have Wi_in : "LMap (snd_l l) f s wi \<in> LMap (snd_l l) f s ` V"
        using imageI[OF Wi(1), of "LMap (snd_l l) f s"] by simp

      have "LMap (snd_l l) f s wi <[ x"
        using is_ubE[OF Xub Wi_in]
        by simp

      then show "w2 <[ x2"
        using W2 Wi X
        by(auto simp add: prod_pleq snd_l_def)
    qed

    have "LMap l f s supr2 <[ x2"
      using is_supD2[OF Supr2_map X2_ub]
      by simp

    have "is_ub V (x1, supr2)"
    proof(rule is_ubI)
      fix w

      assume Win : "w \<in> V"

      obtain w1 w2 where W: "w = (w1, w2)" by(cases w; auto)

      have W2_in : "w2 \<in> snd ` V"
        using imageI[OF Win, of snd] W by simp

      have "w2 <[ supr2"
        using is_supD1[OF Supr2_sup W2_in] by simp

      have "LMap (snd_l l) f s w <[ x"
        using is_ubE[OF Xub imageI[OF Win]] by simp

      hence "w1 <[ x1" using W X
        by(auto simp add: snd_l_def prod_pleq)

      show "w <[ (x1, supr2)"
        using `w2 <[ supr2` `w1 <[ x1` W
        by(auto simp add: prod_pleq)
    qed

    have "supr1 <[ x1"
      using is_supD2[OF Hsupr `is_ub V (x1, supr2)`] Supr
      by(auto simp add: prod_pleq)

    show "LMap (snd_l l) f s supr <[ x"
      using `LMap l f s supr2 <[ x2` `supr1 <[ x1` X Supr
      by(auto simp add: snd_l_def prod_pleq)
  qed
qed

lemma (in snd_l_valid_pres_ext) ax :
  shows "lifting_valid_pres_ext (snd_l l) (snd_l_S S)"
  using out.lifting_valid_pres_ext_axioms
  by auto

lemma (in snd_l_valid_pres_ext) ax_g :
  assumes H : "\<And> x . S' x = snd_l_S S x"
  shows "lifting_valid_pres_ext (snd_l l) S'"
proof-
  have "S' = snd_l_S S"
    using assms by auto
  then show ?thesis
    using out.lifting_valid_pres_ext_axioms
  by auto
qed

locale snd_l_valid_base_pres_ext = snd_l_valid_pres_ext + snd_l_valid_base_ext + lifting_valid_base_pres_ext
sublocale snd_l_valid_base_pres_ext \<subseteq> out : lifting_valid_base_pres_ext "snd_l l" "snd_l_S S"
proof
  fix s
  show "\<bottom> \<notin> snd_l_S S s"
    using bot_bad[of s]
    by(auto simp add: snd_l_S_def prod_bot)
qed

lemma (in snd_l_valid_base_pres_ext) ax :
  shows "lifting_valid_base_pres_ext (snd_l l) (snd_l_S S)"
  using out.lifting_valid_base_pres_ext_axioms by auto

lemma (in snd_l_valid_base_pres_ext) ax_g :
  assumes H : "\<And> x . S' x = snd_l_S S x"
  shows "lifting_valid_base_pres_ext (snd_l l) S'"
proof-
  have "S' = snd_l_S S"
    using assms by auto
  then show ?thesis
    using out.lifting_valid_base_pres_ext_axioms by auto
qed

(* snd (copy-paste-change from fst) *)
locale snd_l_ortho = l_ortho

sublocale snd_l_ortho \<subseteq> out : l_ortho "snd_l l1" "snd_l_S S1" "snd_l l2" "snd_l_S S2"
proof
  fix s
  show "LBase (snd_l l1) s = LBase (snd_l l2) s"
    using eq_base
    by(auto simp add: snd_l_def)
next

  fix b :: "('e * 'c)"
  fix s
  fix a1 :: 'b
  fix a2 :: 'd

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  have Compat1 : "LUpd l1 s a1 (LUpd l2 s a2 b2) = LUpd l2 s a2 (LUpd l1 s a1 b2)"
    using compat[of s a1 a2 b2]
    by(auto)

  then show "LUpd (snd_l l1) s a1 (LUpd (snd_l l2) s a2 b) =
       LUpd (snd_l l2) s a2 (LUpd (snd_l l1) s a1 b)"
    using B
    by(auto simp add: snd_l_def)
next

  fix b :: "('e * 'c)"
  fix a1
  fix s

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  have Compat1 : "LOut l2 s (LUpd l1 s a1 b2) = LOut l2 s b2"
    using put1_get2
    by auto

  then show "LOut (snd_l l2) s (LUpd (snd_l l1) s a1 b) = LOut (snd_l l2) s b"
    using B
    by (auto simp add: snd_l_def)
next
  fix b :: "('e * 'c)"
  fix s a2

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  have Compat1 : "LOut l1 s (LUpd l2 s a2 b2) = LOut l1 s b2"
    using put2_get1
    by auto

  then show "LOut (snd_l l1) s
        (LUpd (snd_l l2) s a2 b) =
       LOut (snd_l l1) s b"
    using B
    by(auto simp add: snd_l_def)
next
  fix b :: "'e * 'c"
  fix s a1

  assume B_in : "b \<in> snd_l_S S2 s"

  then obtain b1 b2 where B : "b = (b1, b2)" "b2 \<in> S2 s"
    by(auto simp add: snd_l_S_def)

  have Compat1 : "LUpd l1 s a1 b2 \<in> S2 s"
    using put1_S2[OF B(2)] by auto

  then show "LUpd (snd_l l1) s a1 b \<in> snd_l_S S2 s"
    using B
    by(auto simp add: snd_l_def snd_l_S_def)
next
  fix b :: "'e * 'c"
  fix s a2

  assume B_in : "b \<in> snd_l_S S1 s"
  then obtain b1 b2 where B : "b = (b1, b2)" "b2 \<in> S1 s"
    by(auto simp add: snd_l_S_def)

  have Compat2 : "LUpd l2 s a2 b2 \<in> S1 s"
    using put2_S1[OF B(2)]
    by auto

  then show "LUpd (snd_l l2) s a2 b \<in> snd_l_S S1 s"
    using B
    by(auto simp add: snd_l_def snd_l_S_def)
qed

lemma (in snd_l_ortho) ax :
  shows "l_ortho (snd_l l1) (snd_l_S S1) (snd_l l2) (snd_l_S S2)"
  using out.l_ortho_axioms by auto

lemma (in snd_l_ortho) ax_g :
  assumes H1 : "\<And> x . S'1 x = snd_l_S S1 x"
  assumes H2 : "\<And> x . S'2 x = snd_l_S S2 x"
  shows "l_ortho (snd_l l1) S'1 (snd_l l2) S'2"
proof-
  have H1' : "S'1 = snd_l_S S1"
    using H1 by auto

  have H2' : "S'2 = snd_l_S S2"
    using H2 by auto

  show ?thesis using ax unfolding H1' H2'
    by auto
qed

locale snd_l_ortho_base_ext = l_ortho_base_ext

sublocale snd_l_ortho_base_ext \<subseteq> out : l_ortho_base_ext "snd_l l1" "snd_l l2"
proof
  fix s
  show "LBase (snd_l l1) s = \<bottom>"
    using compat_base1
    by(auto simp add: snd_l_def prod_bot)
next
  fix s
  show "LBase (snd_l l2) s = \<bottom>"
    using compat_base2
    by(auto simp add: snd_l_def prod_bot)
qed

lemma (in snd_l_ortho_base_ext) ax :
  shows "l_ortho_base_ext (snd_l l1) (snd_l l2)"
  using out.l_ortho_base_ext_axioms
  by auto

locale snd_l_ortho_ok_ext = l_ortho_ok_ext

sublocale snd_l_ortho_ok_ext \<subseteq> out : l_ortho_ok_ext "snd_l l1" "snd_l l2" .

(*
locale snd_l_ortho_pres = snd_l_ortho + l_ortho_pres

sublocale snd_l_ortho_pres \<subseteq> l_ortho_pres "snd_l l1" "snd_l_S S1" "snd_l l2" "snd_l_S S2"
proof
  fix a1 a2 s
  fix x :: "'e * 'c"
  obtain x1 x2 where X : "x = (x1, x2)"
    by(cases x; auto)

  have Sup :
    "is_sup {LUpd (l1) s a1 x2, LUpd (l2) s a2 x2}
        (LUpd (l1) s a1 (LUpd (l2) s a2 x2))"
    using compat_pres_sup
    by auto

  have Conc' :
    "is_sup ((\<lambda>w. (x1, w)) ` {LUpd l1 s a1 x2, LUpd l2 s a2 x2}) (x1, LUpd l1 s a1 (LUpd l2 s a2 x2))"
    using is_sup_snd[OF _ Sup]
    by auto

  then show "is_sup {LUpd (snd_l l1) s a1 x, LUpd (snd_l l2) s a2 x}
        (LUpd (snd_l l1) s a1 (LUpd (snd_l l2) s a2 x))"
    using X
    by(auto simp add: snd_l_def)
qed
*)

end


(*  Title:      HOL/HOLCF/IOA/Compositionality.thy
    Author:     Olaf Müller
*)

section \<open>Compositionality of I/O automata\<close>
theory Compositionality
imports CompoTraces
begin

lemma compatibility_consequence3: "eA \<longrightarrow> A \<Longrightarrow> eB \<and> \<not> eA \<longrightarrow> \<not> A \<Longrightarrow> (eA \<or> eB) \<longrightarrow> A = eA"
  by auto

lemma Filter_actAisFilter_extA:
  "compatible A B \<Longrightarrow> Forall (\<lambda>a. a \<in> ext A \<or> a \<in> ext B) tr \<Longrightarrow>
    Filter (\<lambda>a. a \<in> act A) \<cdot> tr = Filter (\<lambda>a. a \<in> ext A) \<cdot> tr"
  apply (rule ForallPFilterQR)
  text \<open>i.e.: \<open>(\<forall>x. P x \<longrightarrow> (Q x = R x)) \<Longrightarrow> Forall P tr \<Longrightarrow> Filter Q \<cdot> tr = Filter R \<cdot> tr\<close>\<close>
  prefer 2 apply assumption
  apply (rule compatibility_consequence3)
  apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
  done

text \<open>
  The next two theorems are only necessary, as there is no theorem
  \<open>ext (A \<parallel> B) = ext (B \<parallel> A)\<close>
\<close>

lemma compatibility_consequence4: "eA \<longrightarrow> A \<Longrightarrow> eB \<and> \<not> eA \<longrightarrow> \<not> A \<Longrightarrow> (eB \<or> eA) \<longrightarrow> A = eA"
  by auto

lemma Filter_actAisFilter_extA2:
  "compatible A B \<Longrightarrow> Forall (\<lambda>a. a \<in> ext B \<or> a \<in> ext A) tr \<Longrightarrow>
    Filter (\<lambda>a. a \<in> act A) \<cdot> tr = Filter (\<lambda>a. a \<in> ext A) \<cdot> tr"
  apply (rule ForallPFilterQR)
  prefer 2 apply (assumption)
  apply (rule compatibility_consequence4)
  apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
  done

subsection \<open>Main Compositionality Theorem\<close>

lemma compositionality:
  assumes "is_trans_of A1" and "is_trans_of A2"
    and "is_trans_of B1" and "is_trans_of B2"
    and "is_asig_of A1" and "is_asig_of A2"
    and "is_asig_of B1" and "is_asig_of B2"
    and "compatible A1 B1" and "compatible A2 B2"
    and "A1 =<| A2" and "B1 =<| B2"
  shows "(A1 \<parallel> B1) =<| (A2 \<parallel> B2)"
  apply (insert assms)
  apply (simp add: is_asig_of_def)
  apply (frule_tac A1 = "A1" in compat_commute [THEN iffD1])
  apply (frule_tac A1 = "A2" in compat_commute [THEN iffD1])
  apply (simp add: ioa_implements_def inputs_of_par outputs_of_par externals_of_par)
  apply auto
  apply (simp add: compositionality_tr)
  apply (subgoal_tac "ext A1 = ext A2 \<and> ext B1 = ext B2")
  prefer 2
  apply (simp add: externals_def)
  apply (erule conjE)+
  text \<open>rewrite with proven subgoal\<close>
  apply (simp add: externals_of_par)
  apply auto
  text \<open>2 goals, the 3rd has been solved automatically\<close>
  text \<open>1: \<open>Filter A2 x \<in> traces A2\<close>\<close>
  apply (drule_tac A = "traces A1" in subsetD)
  apply assumption
  apply (simp add: Filter_actAisFilter_extA)
  text \<open>2: \<open>Filter B2 x \<in> traces B2\<close>\<close>
  apply (drule_tac A = "traces B1" in subsetD)
  apply assumption
  apply (simp add: Filter_actAisFilter_extA2)
  done

end


section \<open>Static Standard Control Dependence\<close>

theory StandardControlDependence imports
  "../Basic/Postdomination"
  "../Basic/DynStandardControlDependence"
begin

context Postdomination begin

subsubsection \<open>Definition and some lemmas\<close>

definition standard_control_dependence :: "'node \<Rightarrow> 'node \<Rightarrow> bool"
  ("_ controls\<^sub>s _" [51,0])
where standard_control_dependences_eq:"n controls\<^sub>s n' \<equiv> \<exists>as. n controls\<^sub>s n' via as"

lemma standard_control_dependence_def:"n controls\<^sub>s n' =
    (\<exists>a a' as. (n' \<notin> set(sourcenodes (a#as))) \<and> (n -a#as\<rightarrow>* n') \<and>
                   (n' postdominates (targetnode a)) \<and>
                   (valid_edge a') \<and> (sourcenode a' = n) \<and>
                   (\<not> n' postdominates (targetnode a')))"
by(auto simp:standard_control_dependences_eq dyn_standard_control_dependence_def)

lemma Exit_not_standard_control_dependent:
  "n controls\<^sub>s (_Exit_) \<Longrightarrow> False"
by(auto simp:standard_control_dependences_eq
        intro:Exit_not_dyn_standard_control_dependent)

lemma standard_control_dependence_def_variant:
  "n controls\<^sub>s n' = (\<exists>as. (n -as\<rightarrow>* n') \<and> (n \<noteq> n') \<and>
    (\<not> n' postdominates n) \<and> (n' \<notin> set(sourcenodes as)) \<and>
  (\<forall>n'' \<in> set(targetnodes as). n' postdominates n''))"
by(auto simp:standard_control_dependences_eq
             dyn_standard_control_dependence_def_variant)

lemma inner_node_standard_control_dependence_predecessor:
  assumes "inner_node n" "(_Entry_) -as\<rightarrow>* n" "n -as'\<rightarrow>* (_Exit_)"
  obtains n' where "n' controls\<^sub>s n"
using assms
by(auto elim!:inner_node_dyn_standard_control_dependence_predecessor
        simp:standard_control_dependences_eq)

end

end


(*  Title:      JinjaDCI/Common/Decl.thy

    Author:     David von Oheimb, Susannah Mansky
    Copyright   1999 Technische Universitaet Muenchen, 2019-20 UIUC

    Based on the Jinja theory Common/Decl.thy by David von Oheimb
*)

section \<open> Class Declarations and Programs \<close>

theory Decl imports Type begin

type_synonym
  fdecl    = "vname \<times> staticb \<times> ty"        \<comment> \<open>field declaration\<close>
type_synonym
  'm mdecl = "mname \<times> staticb \<times> ty list \<times> ty \<times> 'm"     \<comment> \<open>method = name, static flag, arg.\ types, return type, body\<close>
type_synonym
  'm "class" = "cname \<times> fdecl list \<times> 'm mdecl list"       \<comment> \<open>class = superclass, fields, methods\<close>
type_synonym
  'm cdecl = "cname \<times> 'm class"  \<comment> \<open>class declaration\<close>
type_synonym
  'm prog  = "'m cdecl list"     \<comment> \<open>program\<close>

(* replaced all fname, mname, cname in below with `char list' so that
 pretty printing works   -SM *)
(*<*)
translations
  (type) "fdecl"   <= (type) "char list \<times> staticb \<times> ty"
  (type) "'c mdecl" <= (type) "char list \<times> staticb \<times> ty list \<times> ty \<times> 'c"
  (type) "'c class" <= (type) "char list \<times> fdecl list \<times> ('c mdecl) list"
  (type) "'c cdecl" <= (type) "char list \<times> ('c class)"
  (type) "'c prog" <= (type) "('c cdecl) list"
(*>*)

definition "class" :: "'m prog \<Rightarrow> cname \<rightharpoonup> 'm class"
where
  "class  \<equiv>  map_of"

(* Not difficult to prove, but useful for directing particular sequences of equality -SM *)
lemma class_cons: "\<lbrakk> C \<noteq> fst x \<rbrakk> \<Longrightarrow> class (x # P) C = class P C"
 by (simp add: class_def)

definition is_class :: "'m prog \<Rightarrow> cname \<Rightarrow> bool"
where
  "is_class P C  \<equiv>  class P C \<noteq> None"

lemma finite_is_class: "finite {C. is_class P C}"
(*<*)
proof -
  have "{C. is_class P C} = dom (map_of P)"
   by (simp add: is_class_def class_def dom_def)
  thus ?thesis by (simp add: finite_dom_map_of)
qed
(*>*)

definition is_type :: "'m prog \<Rightarrow> ty \<Rightarrow> bool"
where
  "is_type P T  \<equiv>
  (case T of Void \<Rightarrow> True | Boolean \<Rightarrow> True | Integer \<Rightarrow> True | NT \<Rightarrow> True
   | Class C \<Rightarrow> is_class P C)"

lemma is_type_simps [simp]:
  "is_type P Void \<and> is_type P Boolean \<and> is_type P Integer \<and>
  is_type P NT \<and> is_type P (Class C) = is_class P C"
(*<*)by(simp add:is_type_def)(*>*)

abbreviation
  "types P == Collect (is_type P)"

lemma class_exists_equiv:
 "(\<exists>x. fst x = cn \<and> x \<in> set P) = (class P cn \<noteq> None)"
proof(rule iffI)
 assume "\<exists>x. fst x = cn \<and> x \<in> set P" then show "class P cn \<noteq> None"
   by (metis class_def image_eqI map_of_eq_None_iff)
next
 assume "class P cn \<noteq> None" then show "\<exists>x. fst x = cn \<and> x \<in> set P"
   by (metis class_def fst_conv map_of_SomeD option.exhaust)
qed

lemma class_exists_equiv2:
 "(\<exists>x. fst x = cn \<and> x \<in> set (P1 @ P2)) = (class P1 cn \<noteq> None \<or> class P2 cn \<noteq> None)"
by (simp only: class_exists_equiv [where P = "P1@P2"], simp add: class_def)

end


(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory ValueSemantics
imports Cogent
begin

datatype ('f, 'a) vval = VPrim lit
                       | VProduct "('f, 'a) vval" "('f, 'a) vval"
                       | VSum name "('f, 'a) vval"
                       | VRecord "('f, 'a) vval list"
                       | VAbstract "'a"
                       | VFunction "'f expr" "type list"
                       | VAFunction "'f" "type list"
                       | VUnit

(* All polymorphic instantiations must have the _same_ value semantics. This means even if the C
implementations differ they must all refine the same specification *)
type_synonym ('f, 'a) vabsfuns = "'f \<Rightarrow> ('f, 'a) vval \<Rightarrow> ('f,'a) vval \<Rightarrow> bool"

definition eval_prim :: "prim_op \<Rightarrow> ('f, 'a) vval list \<Rightarrow> ('f, 'a) vval"
where
  "eval_prim pop xs = VPrim (eval_prim_op pop (map (\<lambda>vv. case vv of VPrim v \<Rightarrow> v | _ \<Rightarrow> LBool False) xs))"

(* NOTE: Termination is currently not provable with this approach. It's possible to show
   it for v_sem assuming all called functions are terminating, but proving
   this assumption would in turn require termination of v_sem.

   Fixing this problem is nontrivial, and will likely necessitate changes to the design.
*)

inductive v_sem :: "('f,'a) vabsfuns \<Rightarrow> ('f, 'a) vval env \<Rightarrow> 'f expr \<Rightarrow> ('f, 'a) vval \<Rightarrow> bool"
          ("_ , _ \<turnstile> _ \<Down> _" [30,0,0,20] 60)
and       v_sem_all  :: "('f,'a) vabsfuns \<Rightarrow> ('f, 'a) vval list \<Rightarrow> 'f expr list \<Rightarrow> ('f, 'a) vval list \<Rightarrow> bool"
          ("_ , _ \<turnstile>* _ \<Down> _" [30,0,0,20] 60)
where
  v_sem_var     : "\<xi> , \<gamma> \<turnstile> (Var i) \<Down> (\<gamma> ! i)"

| v_sem_lit     : "\<xi> , \<gamma> \<turnstile> (Lit l) \<Down> VPrim l"

| v_sem_prim    : "\<lbrakk> \<xi> , \<gamma> \<turnstile>* as \<Down> as'
                   \<rbrakk> \<Longrightarrow>  \<xi> , \<gamma> \<turnstile> (Prim p as) \<Down> eval_prim p as'"

| v_sem_fun     : "\<xi> , \<gamma> \<turnstile> Fun f ts \<Down> VFunction f ts"

| v_sem_afun     : "\<xi> , \<gamma> \<turnstile> AFun f ts \<Down> VAFunction f ts"

| v_sem_abs_app : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> VAFunction f ts
                   ; \<xi> , \<gamma> \<turnstile> y \<Down> a
                   ; \<xi> f a r
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> (App x y) \<Down> r"

| v_sem_cast    : "\<lbrakk> \<xi> , \<gamma> \<turnstile> e \<Down> VPrim l
                   ; cast_to \<tau> l = Some l'
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Cast \<tau> e \<Down> VPrim l'"

| v_sem_app     : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> VFunction e ts
                   ; \<xi> , \<gamma> \<turnstile> y \<Down> a
                   ; \<xi> , [ a ] \<turnstile> specialise ts e \<Down> r
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> (App x y) \<Down> r"

| v_sem_con     : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> x'
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> (Con _ t x) \<Down> VSum t x'"

| v_sem_promote : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> x'
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Promote t x \<Down> x'"

| v_sem_member  : "\<lbrakk> \<xi> , \<gamma> \<turnstile> e \<Down> VRecord fs
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Member e f \<Down> fs ! f"

| v_sem_unit    : "\<xi> , \<gamma> \<turnstile> Unit \<Down> VUnit"

| v_sem_tuple   : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> x'
                   ; \<xi> , \<gamma> \<turnstile> y \<Down> y'
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> (Tuple x y) \<Down> VProduct x' y'"

| v_sem_esac    : "\<lbrakk> \<xi> , \<gamma> \<turnstile> t \<Down> VSum ts v
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Esac t \<Down> v"

| v_sem_let     : "\<lbrakk> \<xi> , \<gamma> \<turnstile> a \<Down> a'
                   ; \<xi> , (a' # \<gamma>) \<turnstile> b \<Down> b'
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Let a b \<Down> b'"

| v_sem_letbang : "\<lbrakk> \<xi> , \<gamma> \<turnstile> a \<Down> a'
                   ; \<xi> , (a' # \<gamma>) \<turnstile> b \<Down> b'
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> LetBang vs a b \<Down> b'"

| v_sem_case_m  : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> VSum t v
                   ; \<xi> , (v # \<gamma>) \<turnstile> m \<Down> m'
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Case x t m n \<Down> m'"

| v_sem_case_nm : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> VSum t' v
                   ; t \<noteq> t'
                   ; \<xi> , (VSum t' v # \<gamma>) \<turnstile> n \<Down> n'
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Case x t m n \<Down> n'"

| v_sem_if      : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> VPrim (LBool b)
                   ; \<xi> , \<gamma> \<turnstile> if b then t else e \<Down> r
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> If x t e \<Down> r"

| v_sem_struct  : "\<lbrakk> \<xi> , \<gamma> \<turnstile>* xs \<Down> vs
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Struct ts xs \<Down> VRecord vs"

| v_sem_take    : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> VRecord fs
                   ; \<xi> , (fs ! f # VRecord fs # \<gamma>) \<turnstile> e \<Down> e'
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Take x f e \<Down> e'"

| v_sem_put     : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> VRecord fs
                   ; \<xi> , \<gamma> \<turnstile> e \<Down> e'
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Put x f e \<Down> VRecord (fs [ f := e' ])"

| v_sem_split   : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> VProduct a b
                   ; \<xi> , (a # b # \<gamma>) \<turnstile> e \<Down> e'
                   \<rbrakk> \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Split x e \<Down> e'"

| v_sem_all_empty : "\<xi> , \<gamma> \<turnstile>* [] \<Down> []"

| v_sem_all_cons  : "\<lbrakk> \<xi> , \<gamma> \<turnstile> x \<Down> v
                     ; \<xi> , \<gamma> \<turnstile>* xs \<Down> vs
                     \<rbrakk> \<Longrightarrow>  \<xi> , \<gamma> \<turnstile>* (x # xs) \<Down> (v # vs)"

inductive_cases v_sem_varE  [elim] : "\<xi> , \<gamma> \<turnstile> Var i \<Down> v"
inductive_cases v_sem_funE  [elim] : "\<xi> , \<gamma> \<turnstile> Fun f ts \<Down> v"
inductive_cases v_sem_afunE [elim] : "\<xi> , \<gamma> \<turnstile> AFun f ts \<Down> v"
inductive_cases v_sem_appE  [elim] : "\<xi> , \<gamma> \<turnstile> App a b \<Down> v"

locale value_sem =
  fixes abs_typing :: "'a \<Rightarrow> name \<Rightarrow> type list \<Rightarrow> bool"
  assumes abs_typing_bang : "abs_typing av n \<tau>s \<Longrightarrow> abs_typing av n (map bang \<tau>s)"

context value_sem begin

inductive vval_typing  :: "('f \<Rightarrow> poly_type) \<Rightarrow> ('f, 'a) vval \<Rightarrow> type \<Rightarrow> bool"
          ("_ \<turnstile> _ :v _" [30,0,20] 80)
and vval_typing_record :: "('f \<Rightarrow> poly_type) \<Rightarrow> ('f, 'a) vval list \<Rightarrow> (type \<times> bool) list \<Rightarrow> bool"
          ("_ \<turnstile>* _ :vr _" [30,0,20] 80) where

  v_t_prim     : "\<Xi> \<turnstile> VPrim l :v TPrim (lit_type l)"

| v_t_product  : "\<lbrakk> \<Xi> \<turnstile> a :v t
                  ; \<Xi> \<turnstile> b :v u
                  \<rbrakk> \<Longrightarrow> \<Xi> \<turnstile> VProduct a b :v TProduct t u"

| v_t_sum      : "\<lbrakk> \<Xi> \<turnstile> a :v t
                  ; (g, t) \<in> set ts
                  ; distinct (map fst ts)
                  ; [] \<turnstile>* map snd ts wellformed
                  \<rbrakk> \<Longrightarrow> \<Xi> \<turnstile> VSum g a :v TSum ts"

| v_t_record   : "\<lbrakk> \<Xi> \<turnstile>* fs :vr ts
                  \<rbrakk> \<Longrightarrow> \<Xi> \<turnstile> VRecord fs :v TRecord ts s"

| v_t_abstract : "\<lbrakk> abs_typing a n ts
                  ; [] \<turnstile>* ts wellformed
                  \<rbrakk> \<Longrightarrow> \<Xi> \<turnstile> VAbstract a :v TCon n ts s"

| v_t_afun     : "\<lbrakk> \<Xi> f = (ks, a, b)
                  ; list_all2 (kinding []) ts ks
                  ; ks \<turnstile> TFun a b wellformed
                  \<rbrakk> \<Longrightarrow> \<Xi> \<turnstile> VAFunction f ts :v TFun (instantiate ts a) (instantiate ts b)"

| v_t_function : "\<lbrakk> \<Xi> , K , [ Some t ] \<turnstile> f : u
                  ; K \<turnstile> t wellformed
                  ; list_all2 (kinding []) ts K
                  \<rbrakk> \<Longrightarrow> \<Xi> \<turnstile> VFunction f ts :v TFun (instantiate ts t) (instantiate ts u)"

| v_t_unit     : "\<Xi> \<turnstile> VUnit :v TUnit"

| v_t_r_empty  : "\<Xi> \<turnstile>* [] :vr []"

| v_t_r_cons1  : "\<lbrakk> \<Xi> \<turnstile> x :v t
                  ; \<Xi> \<turnstile>* xs :vr ts
                  \<rbrakk> \<Longrightarrow> \<Xi> \<turnstile>* (x # xs) :vr ((t, False) # ts)"

| v_t_r_cons2  : "\<lbrakk> \<Xi> \<turnstile>* xs :vr ts
                  ; [] \<turnstile> t wellformed
                  \<rbrakk> \<Longrightarrow> \<Xi> \<turnstile>* (x # xs) :vr ((t, True) # ts)"

lemma v_t_prim' [intro]:
assumes "lit_type l = \<tau>"
shows   "\<Xi> \<turnstile> VPrim l :v TPrim \<tau>"
using assms by (auto intro: v_t_prim)

inductive_cases v_t_funE      [elim]: "\<Xi> \<turnstile> VFunction f ts :v t"
inductive_cases v_t_afunE     [elim]: "\<Xi> \<turnstile> VAFunction f ts :v t"
inductive_cases v_t_recordE   [elim]: "\<Xi> \<turnstile> VRecord fs :v \<tau>"
inductive_cases v_t_productE  [elim]: "\<Xi> \<turnstile> VProduct a b :v \<tau>"
inductive_cases v_t_sumE'     [elim]: "\<Xi> \<turnstile> e :v TSum ts"
inductive_cases v_t_primE     [elim]: "\<Xi> \<turnstile> VPrim l :v TPrim (Num \<tau>)"

inductive_cases v_t_r_emptyE  [elim]: "\<Xi> \<turnstile>* [] :vr \<tau>s"
inductive_cases v_t_r_consE   [elim]: "\<Xi> \<turnstile>* (x # xs) :vr \<tau>s"

definition vval_typing_all :: "('f \<Rightarrow> poly_type) \<Rightarrow> ('f, 'a) vval list \<Rightarrow> type list \<Rightarrow> bool"
           ("_  \<turnstile>* _ :v _" [30,0,20] 80) where
   "(\<Xi> \<turnstile>* vs :v ts) \<equiv> list_all2 (vval_typing \<Xi>) vs ts"

definition matches :: "('f \<Rightarrow> poly_type) \<Rightarrow>  ('f, 'a) vval env \<Rightarrow> ctx \<Rightarrow> bool"
           ("_ \<turnstile> _ matches _" [30,0,20] 60) where
   "\<Xi> \<turnstile> \<gamma> matches \<Gamma> \<equiv> list_all2 (\<lambda> x m. \<forall> \<tau>. m = Some \<tau> \<longrightarrow> \<Xi> \<turnstile> x :v \<tau>) \<gamma> \<Gamma>"

definition proc_env_matches :: "('f \<Rightarrow> ('f, 'a) vval \<Rightarrow> ('f, 'a) vval \<Rightarrow> bool) \<Rightarrow> ('f \<Rightarrow> poly_type) \<Rightarrow> bool"
           ("_ matches _" [30,20] 60) where
  "\<xi> matches \<Xi> \<equiv> (\<forall> f. let (K, \<tau>i, \<tau>o) = \<Xi> f
                        in (\<forall> \<tau>s v v'. list_all2 (kinding []) \<tau>s K
                                  \<longrightarrow> (\<Xi> \<turnstile> v  :v instantiate \<tau>s \<tau>i)
                                  \<longrightarrow> \<xi> f v v'
                                  \<longrightarrow> (\<Xi> \<turnstile> v' :v instantiate \<tau>s \<tau>o)))"

section {* vval_typing lemmas *}

lemma vval_typing_to_kinding:
shows "\<Xi> \<turnstile> v :v \<tau>     \<Longrightarrow> [] \<turnstile> \<tau> wellformed"
and   "\<Xi> \<turnstile>* vs :vr fs \<Longrightarrow> [] \<turnstile>* map fst fs wellformed"
proof (induct rule: vval_typing_vval_typing_record.inducts)
     case v_t_function then show ?case by (force dest!: typing_to_kinding
                                                 intro: kinding_kinding_all_kinding_record.intros
                                                        substitutivity)
next case v_t_afun     then show ?case by (force dest: substitutivity)
qed (auto intro: kinding_kinding_all_kinding_record.intros supersumption kinding_all_record')

lemma vval_typing_bang:
shows  "\<Xi> \<turnstile> x :v \<tau> \<Longrightarrow> \<Xi> \<turnstile> x :v bang \<tau>"
and    "\<Xi> \<turnstile>* fs :vr \<tau>s \<Longrightarrow> \<Xi> \<turnstile>* fs :vr map (\<lambda> (x, y). (bang x, y)) \<tau>s"
proof (induct rule: vval_typing_vval_typing_record.inducts)
     case v_t_sum      then show ?case by (force intro: vval_typing_vval_typing_record.intros
                                                        bang_kind(2) [ where ts = "map snd ts" for ts
                                                                     , simplified])
next case v_t_abstract then show ?case by (force intro: vval_typing_vval_typing_record.intros
                                                        abs_typing_bang
                                                        bang_kind(2))
next case v_t_r_cons2  then show ?case by (force intro: vval_typing_vval_typing_record.intros
                                                        bang_kind)
qed (force intro: vval_typing_vval_typing_record.intros)+

subsection {* vval_typing_record *}

lemma vval_typing_record_length:
assumes "\<Xi> \<turnstile>* fs :vr \<tau>s"
shows   "length fs = length \<tau>s"
using assms proof (induct fs arbitrary: \<tau>s)
qed (auto)

lemma vval_typing_record_nth:
assumes "\<Xi> \<turnstile>* fs :vr \<tau>s"
and     "\<tau>s ! f = (\<tau>, False)"
and     "f < length \<tau>s"
shows   "\<Xi> \<turnstile> fs ! f :v \<tau>"
using assms proof (induct fs arbitrary: f \<tau>s)
     case Nil  then show ?case by (auto)
next case Cons then show ?case by (case_tac f, auto)
qed

lemma vval_typing_all_record:
assumes "\<Xi> \<turnstile>* vs :v ts"
shows "\<Xi> \<turnstile>* vs :vr zip ts (replicate (length ts) False)"
using assms[simplified vval_typing_all_def] proof (induct rule: list_all2_induct)
qed (auto intro: vval_typing_vval_typing_record.intros)

lemma vval_typing_record_take:
assumes "\<Xi> \<turnstile>* ts :vr \<tau>s"
and     "\<tau>s ! f = (t, False)"
and     "[] \<turnstile> t :\<kappa> k"
and     "S \<in> k \<or> taken"
shows   "\<Xi> \<turnstile>* ts :vr \<tau>s[ f := (t, taken) ]"
using assms proof (induct ts arbitrary: \<tau>s f)
     case Nil  then show ?case by ( force intro: vval_typing_vval_typing_record.intros)
next case Cons then show ?case by ( cases taken
                                  , (force split: nat.split
                                           intro: vval_typing_vval_typing_record.intros)+ )
qed

lemma vval_typing_record_put:
assumes "\<Xi> \<turnstile>* ts :vr \<tau>s"
and     "\<tau>s ! f = (t, taken)"
and     "[] \<turnstile> t :\<kappa> k"
and     "D \<in> k \<or> taken"
and     "\<Xi> \<turnstile> v :v t"
shows   "\<Xi> \<turnstile>* ts[ f := v ] :vr \<tau>s[ f := (t, False) ]"
using assms proof (induct ts arbitrary: \<tau>s f)
     case Nil  then show ?case by ( force intro: vval_typing_vval_typing_record.intros)
next case Cons then show ?case by ( cases taken
                                  , (fastforce split: nat.split
                                               intro: vval_typing_vval_typing_record.intros)+ )
qed

subsection {* Sums and subtyping *}

lemma width_subtyping:
assumes "set ts \<subseteq> set us"
and     "\<Xi> \<turnstile> v :v TSum ts"
and     "[] \<turnstile> TSum us wellformed"
shows   "\<Xi> \<turnstile> v :v TSum us"
using assms
by (force intro: vval_typing_vval_typing_record.intros)

lemma sum_downcast:
assumes "\<Xi> \<turnstile> VSum t v :v TSum ts"
and     "t \<noteq> t'"
shows   "\<Xi> \<turnstile> VSum t v :v TSum (filter (\<lambda> x. fst x \<noteq> t') ts)"
proof -
have 1: "(\<lambda> x. x \<noteq> t') \<circ> fst = (\<lambda> x. fst x \<noteq> t')" by (auto)
have 2: "map fst [ x \<leftarrow> ts. fst x \<noteq> t' ] = [ x \<leftarrow> map fst ts. x \<noteq> t' ]"by (simp add: 1 filter_map)
with assms show ?thesis by (fastforce intro: vval_typing_vval_typing_record.intros
                                             kinding_all_subset)
qed

subsection {* Introductions under instantiations *}

text {* An alternative introduction rule used for showing a value is a function under some type instantiation *}

lemma v_t_afun_instantiate:
assumes "list_all2 (kinding K') ts K"
and     "list_all2 (kinding []) \<delta> K'"
and     "K \<turnstile> t wellformed"
and     "K \<turnstile> u wellformed"
and     "\<Xi> f = (K, t, u)"
shows   "\<Xi> \<turnstile> VAFunction f (map (instantiate \<delta>) ts) :v TFun (instantiate \<delta> (instantiate ts t))
                                                           (instantiate \<delta> (instantiate ts u))"
proof -
from assms have "TFun (instantiate \<delta> (instantiate ts t))
                      (instantiate \<delta> (instantiate ts u))
               = TFun (instantiate (map (instantiate \<delta>) ts) t)
                      (instantiate (map (instantiate \<delta>) ts) u)"
           by (force intro: instantiate_instantiate dest: list_all2_lengthD)
with assms show ?thesis by (force intro: vval_typing_vval_typing_record.intros
                                         list_all2_substitutivity
                                         kinding_kinding_all_kinding_record.intros)
qed

lemma v_t_function_instantiate:
  assumes "\<Xi>, K, [Some t] \<turnstile> f : u"
  and     "K \<turnstile> t wellformed"
  and     "list_all2 (kinding []) \<delta> K'"
  assumes "list_all2 (kinding K') ts K"
  shows   "\<Xi> \<turnstile> VFunction f (map (instantiate \<delta>) ts) :v TFun (instantiate \<delta> (instantiate ts t))
                                                            (instantiate \<delta> (instantiate ts u))"
proof -
from assms have "TFun (instantiate \<delta> (instantiate ts t))
                      (instantiate \<delta> (instantiate ts u))
               = TFun (instantiate (map (instantiate \<delta>) ts) t)
                      (instantiate (map (instantiate \<delta>) ts) u)"
           by (force intro: instantiate_instantiate dest: list_all2_lengthD dest!: typing_to_kinding)
with assms show ?thesis by (force intro: vval_typing_vval_typing_record.intros
                                         list_all2_substitutivity
                                         kinding_kinding_all_kinding_record.intros)
qed

section {* matches lemmas *}

subsection {* matches + context manipulation *}
lemma matches_split':
assumes "[] \<turnstile> \<Gamma> \<leadsto> \<Gamma>1 | \<Gamma>2"
and     "\<Xi> \<turnstile> \<gamma> matches \<Gamma>"
shows   "\<Xi> \<turnstile> \<gamma> matches \<Gamma>1"
and     "\<Xi> \<turnstile> \<gamma> matches \<Gamma>2"
using assms proof (induct arbitrary: \<gamma> rule: split.induct)
     case split_empty
       case 1 then show ?case by simp
       case 2 then show ?case by simp
next case split_cons note prems = this
       case 1 with prems show ?case by (force simp:  matches_def
                                              iff:   list_all2_Cons2
                                              elim!: split_comp.cases)
       case 2 with prems show ?case by (force simp:  matches_def
                                              iff:   list_all2_Cons2
                                              elim!: split_comp.cases)
qed

lemma matches_split:
assumes "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>)"
and     "list_all2 (kinding []) \<tau>s K"
and     "K \<turnstile> \<Gamma> \<leadsto> \<Gamma>1 | \<Gamma>2"
shows   "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>1)"
and     "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>2)"
using assms by (auto intro: matches_split' instantiate_ctx_split)

lemma matches_split2:
assumes "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>)"
and     "list_all2 (kinding []) \<tau>s K"
and     "K \<turnstile> \<Gamma> \<leadsto> \<Gamma>1 | \<Gamma>2"
shows   "(\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>1)) \<and> (\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>2))"
using assms by (auto dest: matches_split)

lemma matches_splitE:
assumes "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>)"
and     "list_all2 (kinding []) \<tau>s K"
and     "K \<turnstile> \<Gamma> \<leadsto> \<Gamma>1 | \<Gamma>2"
and     "\<lbrakk> \<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>1) ; \<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>2) \<rbrakk> \<Longrightarrow> P"
shows   "P"
using assms by (auto dest: matches_split2)

lemma matches_split_bang':
assumes "split_bang [] vs \<Gamma> \<Gamma>1 \<Gamma>2"
and     "\<Xi> \<turnstile> \<gamma> matches \<Gamma>"
shows   "\<Xi> \<turnstile> \<gamma> matches \<Gamma>1"
and     "\<Xi> \<turnstile> \<gamma> matches \<Gamma>2"
using assms proof (induct arbitrary: \<gamma> rule: split_bang.induct)
     case split_bang_empty
       case 1 then show ?case by simp
       case 2 then show ?case by simp
next case split_bang_cons note prems = this
       case 1 with prems show ?case by (force simp:  matches_def
                                              iff:   list_all2_Cons2
                                              elim!: split_comp.cases)
       case 2 with prems show ?case by (force simp:  matches_def
                                              iff:   list_all2_Cons2
                                              elim!: split_comp.cases)
next case split_bang_bang note prems = this
       case 1 with prems show ?case by (force simp: matches_def
                                              iff:  list_all2_Cons2
                                              dest: vval_typing_bang)
       case 2 with prems show ?case by (force simp: matches_def
                                              iff:  list_all2_Cons2
                                              dest: vval_typing_bang)
qed

lemma matches_split_bang:
assumes "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>)"
and     "list_all2 (kinding []) \<tau>s K"
and     "split_bang K vs \<Gamma> \<Gamma>1 \<Gamma>2"
shows   "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>1)"
and     "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>2)"
using assms by (auto intro: matches_split_bang' instantiate_ctx_split_bang)

lemma matches_weakening':
assumes "\<Xi> \<turnstile> \<gamma> matches \<Gamma>"
and     "[] \<turnstile> \<Gamma> \<leadsto>w \<Gamma>'"
shows   "\<Xi> \<turnstile> \<gamma> matches \<Gamma>'"
using assms(2) [simplified weakening_def]
  and assms(1) proof(induct  arbitrary: \<gamma> rule: list_all2_induct)
     case Nil  then show ?case by simp
next case Cons then show ?case by (force simp:  matches_def
                                         iff:   list_all2_Cons2
                                         elim!: weakening_comp.cases)
qed

lemma matches_weakening:
assumes "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>)"
and     "list_all2 (kinding []) \<tau>s K"
and     "K \<turnstile> \<Gamma> \<leadsto>w \<Gamma>'"
shows   "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>')"
using assms by (auto dest: instantiate_ctx_weaken intro: matches_weakening')

lemma matches_cons':
assumes "\<Xi> \<turnstile> \<gamma> matches \<Gamma>"
and     "\<Xi> \<turnstile> x :v \<tau>"
shows   "\<Xi> \<turnstile> (x # \<gamma>) matches (Some \<tau> # \<Gamma>)"
using assms by (simp add: matches_def)

lemma matches_cons:
assumes "list_all2 (kinding []) \<tau>s K"
and     "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>)"
and     "\<Xi> \<turnstile> x :v instantiate \<tau>s \<tau>"
shows   "\<Xi> \<turnstile> (x # \<gamma>) matches (instantiate_ctx \<tau>s (Some \<tau> # \<Gamma>))"
using assms by (auto intro: matches_cons')

lemma matches_empty':
shows "\<Xi> \<turnstile> [] matches []"
by (simp add: matches_def)

lemma matches_empty:
shows "\<Xi> \<turnstile> [] matches instantiate_ctx \<tau>s []"
by (simp add: matches_empty' instantiate_ctx_def)

subsection {* other matches properties *}

lemma matches_length:
assumes "\<Xi> \<turnstile> \<gamma> matches \<Gamma>"
shows   "length \<gamma> = length \<Gamma>"
using assms by (simp add: matches_def list_all2_lengthD)

lemma matches_proj':
assumes "\<Xi> \<turnstile> \<gamma> matches \<Gamma>"
and     "i < length \<Gamma>"
and     "\<Gamma> ! i = Some \<tau>"
shows   "\<Xi> \<turnstile> (\<gamma> ! i) :v \<tau>"
using assms by (auto dest: list_all2_nthD2
                     simp: matches_def
                     intro: vval_typing_vval_typing_record.intros)

lemma matches_proj:
assumes "list_all2 (kinding []) \<tau>s K"
and     "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>)"
and     "i < length \<Gamma>"
and     "\<Gamma> ! i = Some \<tau>"
shows   "\<Xi> \<turnstile> (\<gamma> ! i) :v instantiate \<tau>s \<tau>"
using assms by (auto intro: matches_proj' simp: instantiate_ctx_def)

section {* procedure environment matches *}
lemma proc_env_matches_abstract:
assumes "\<xi> matches \<Xi>"
and     "\<Xi> f = (K, \<tau>i, \<tau>o)"
and     "list_all2 (kinding []) \<tau>s K"
and     "\<Xi> \<turnstile> v    :v instantiate \<tau>s \<tau>i"
and     "\<xi> f v v'"
shows   "\<Xi> \<turnstile> v' :v instantiate \<tau>s \<tau>o"
using assms by ( clarsimp simp: proc_env_matches_def
               , drule_tac x = f in spec
               , auto)

section {* Type Safety *}

theorem progress:
assumes "\<Xi>, K, \<Gamma> \<turnstile> e : \<tau>"
and     "\<xi> matches \<Xi>"
and     "list_all2 (kinding []) \<tau>s K"
and     "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>)"
shows   "\<exists>! v. \<xi>, \<gamma> \<turnstile> specialise \<tau>s e \<Down> v"
oops

lemma v_t_map_TPrimD:
  "\<Xi> \<turnstile>* vs :v map TPrim \<tau>s
    \<Longrightarrow> \<exists>lits. vs = map VPrim lits \<and> map lit_type lits = \<tau>s"
  unfolding vval_typing_all_def list_all2_map2
  apply (induct rule: list_all2_induct, simp_all)
  apply clarsimp
  apply (erule vval_typing.cases, simp_all)
  apply (rule exI[where x="x # xs" for x xs], simp)
  done

lemma eval_prim_preservation:
assumes "prim_op_type p = (\<tau>s, \<tau>)"
and     "\<Xi> \<turnstile>* vs :v map TPrim \<tau>s"
shows   "\<Xi> \<turnstile>  eval_prim p vs :v TPrim \<tau>"
using assms v_t_prim[where \<Xi>=\<Xi> and l="case eval_prim p vs of VPrim v \<Rightarrow> v"]
by (clarsimp simp add: eval_prim_def o_def eval_prim_op_lit_type dest!: v_t_map_TPrimD)

theorem preservation:
assumes "list_all2 (kinding []) \<tau>s K"
and     "proc_ctx_wellformed \<Xi>"
and     "\<Xi> \<turnstile> \<gamma> matches (instantiate_ctx \<tau>s \<Gamma>)"
and     "\<xi> matches \<Xi>"
shows   "\<lbrakk> \<xi>, \<gamma> \<turnstile>  specialise \<tau>s e \<Down> v  ; \<Xi>, K, \<Gamma> \<turnstile>  e  : \<tau>  \<rbrakk> \<Longrightarrow> \<Xi> \<turnstile>  v  :v instantiate \<tau>s \<tau>"
and     "\<lbrakk> \<xi>, \<gamma> \<turnstile>* map (specialise \<tau>s) es \<Down> vs ; \<Xi>, K, \<Gamma> \<turnstile>* es : \<tau>s' \<rbrakk> \<Longrightarrow> \<Xi> \<turnstile>* vs :v map (instantiate \<tau>s) \<tau>s'"
using assms proof (induct "specialise \<tau>s e"        v
                      and "map (specialise \<tau>s) es" vs
                      arbitrary: e  \<tau>s K \<tau>   \<Gamma>
                             and es \<tau>s K \<tau>s' \<Gamma>
                      rule: v_sem_v_sem_all.inducts)
     case v_sem_var     then show ?case by ( case_tac e, simp_all
                                           , fastforce dest:  matches_weakening
                                                       intro: matches_proj
                                                       simp:  empty_length empty_def)
next case v_sem_lit     then show ?case by ( case_tac e, simp_all
                                           , fastforce intro: vval_typing_vval_typing_record.intros)
next case v_sem_prim    then show ?case by ( case_tac e, simp_all
                                           , fastforce intro: eval_prim_preservation)
next case v_sem_cast    then show ?case by ( case_tac e, simp_all
                                           , fastforce elim!: upcast_valid_cast_to)
next case v_sem_afun    then show ?case by ( case_tac e, simp_all
                                           , fastforce intro: v_t_afun_instantiate)
next case v_sem_fun     then show ?case by ( case_tac e, simp_all
                                           , fastforce intro: v_t_function_instantiate)
next case v_sem_con     then show ?case by ( case_tac e, simp_all
                                           , fastforce intro: vval_typing_vval_typing_record.intros
                                                       dest:  substitutivity)
next case v_sem_promote then show ?case by ( case_tac e, simp_all
                                           , fastforce dest!: width_subtyping [OF set_subset_map ]
                                                       intro: kinding_kinding_all_kinding_record.intros
                                                              substitutivity(2) [ where ts = "map snd ts" for ts
                                                                                , simplified])
next case v_sem_member  then show ?case by ( case_tac e, simp_all
                                           , fastforce intro: vval_typing_record_nth)
next case v_sem_unit    then show ?case by ( case_tac e, simp_all
                                           , fastforce intro: vval_typing_vval_typing_record.intros)
next case v_sem_tuple   then show ?case by ( case_tac e, simp_all
                                           , fastforce intro: matches_split
                                                              vval_typing_vval_typing_record.intros)
next case v_sem_case_m  then show ?case by ( case_tac e, simp_all
                                           , fastforce intro: matches_split
                                                              matches_cons [simplified]
                                                       dest:  distinct_fst)
next case v_sem_case_nm then show ?case apply ( case_tac e, simp_all)
                                        apply ( clarsimp elim!: typing_caseE)
                                        apply ( rule v_sem_case_nm(5),simp+
                                              , (fastforce dest:  matches_split2
                                                           intro!: matches_cons [ where \<tau> = "TSum ts" for ts
                                                                                , simplified]
                                                                   sum_downcast
                                                           simp:   map_filter_fst [ where P = "\<lambda>x. x \<noteq> t" for t ])+ )
                                        done (* TODO proper automation *)
next case v_sem_esac    then show ?case by ( case_tac e, simp_all
                                           , fastforce)
next case v_sem_let     then show ?case by ( case_tac e, simp_all
                                           , fastforce dest:   matches_split
                                                       intro!: matches_cons [simplified])
next case v_sem_letbang then show ?case by ( case_tac e, simp_all
                                           , fastforce dest:   matches_split_bang
                                                       intro!: matches_cons [simplified])
next case v_sem_if      then show ?case by ( case_tac e, simp_all
                                           , fastforce intro:  matches_split
                                                       split:  split_if_asm)
next case v_sem_struct  then show ?case by ( case_tac e, simp_all
                                           , fastforce intro: vval_typing_vval_typing_record.intros
                                                              vval_typing_all_record [ where ts = "map f ts" for f ts
                                                                                , simplified])
next case v_sem_take    then show ?case apply (case_tac e, simp_all, clarsimp elim!: typing_takeE)
                                        apply (drule(2) matches_split2)
                                        apply (fastforce intro!: matches_cons
                                                                 vval_typing_vval_typing_record.intros
                                                                 vval_typing_record_take
                                                                 vval_typing_record_nth
                                                         simp:   map_update
                                                         intro:  substitutivity)
                                        done (* TODO automate properly *)
next case v_sem_put     then show ?case by ( case_tac e, simp_all
                                           , fastforce simp:  map_update
                                                       intro: vval_typing_vval_typing_record.intros
                                                              vval_typing_record_put
                                                              substitutivity
                                                              matches_split)
next case v_sem_split   then show ?case by ( case_tac e, simp_all
                                           , fastforce intro!: matches_cons
                                                       intro:  matches_split)
next case (v_sem_app \<xi> \<gamma> x ea ts y a r e \<tau>s K \<tau> \<Gamma>)
note IH1  = this(2)
and  IH2  = this(4)
and  IH3  = this(6)
and  rest = this(1,3,5,7-)
from rest show ?case
  apply (case_tac e, simp_all)
  apply (clarsimp)
  apply (fastforce elim!: typing_appE
                   dest!: IH1 [OF _ _ _ _ matches_split(1)]
                          IH2 [OF _ _ _ _ matches_split(2)]
                   intro: IH3
                   simp:  matches_def
                          instantiate_ctx_def).
next case v_sem_abs_app
note IH1  = this(2)
and  IH2  = this(4)
and  rest = this(1,3,5-)
from rest show ?case
  apply (case_tac e, simp_all)
  apply (clarsimp elim!: typing_appE)
  apply (frule(7) IH1 [OF _ _ _ _ matches_split(1)])
  apply (frule(7) IH2 [OF _ _ _ _ matches_split(2)])
  apply (fastforce intro: proc_env_matches_abstract).
next case v_sem_all_empty then show ?case by ( case_tac es, simp_all
                                             , fastforce simp: vval_typing_all_def)
next case v_sem_all_cons  then show ?case by ( case_tac es, simp_all
                                             , fastforce simp: vval_typing_all_def
                                                         dest: matches_split)
qed

(* TODO:
    - A-normal.
*)

lemma order_listsum: "x \<in> set es \<Longrightarrow> x < Suc (listsum es)"
  apply (simp add: set_conv_nth)
  apply (induct es)
  apply (clarsimp)
  apply (clarsimp)
  apply (case_tac i)
  apply (clarsimp)
  apply (clarsimp)
  apply (atomize)
  apply (drule mp)
  apply (force)
  apply (simp)
  done

function monoexpr :: "'f expr \<Rightarrow> ('f \<times> type list) expr" where
  "monoexpr (AFun f ts)       = AFun (f, ts) []"
| "monoexpr (Fun f ts)        = Fun (monoexpr (specialise ts f)) []"
| "monoexpr (Var i)           = Var i"
| "monoexpr (Prim p es)       = Prim p (map (monoexpr) es)"
| "monoexpr (App a b)         = App (monoexpr a) (monoexpr b)"
| "monoexpr (Con as t e)      = Con as t (monoexpr e)"
| "monoexpr (Promote as e)    = Promote as (monoexpr e)"
| "monoexpr (Struct ts vs)    = Struct ts (map (monoexpr) vs)"
| "monoexpr (Member v f)      = Member (monoexpr v) f"
| "monoexpr (Unit)            = Unit"
| "monoexpr (Cast t e)        = Cast t (monoexpr e)"
| "monoexpr (Lit v)           = Lit v"
| "monoexpr (Tuple a b)       = Tuple (monoexpr a) (monoexpr b)"
| "monoexpr (Put e f e')      = Put (monoexpr e) f (monoexpr e')"
| "monoexpr (Let e e')        = Let (monoexpr e) (monoexpr e')"
| "monoexpr (LetBang vs e e') = LetBang vs (monoexpr e) (monoexpr e')"
| "monoexpr (Case e t a b)    = Case (monoexpr e) t (monoexpr a) (monoexpr b)"
| "monoexpr (Esac e)          = Esac (monoexpr e)"
| "monoexpr (If c t e)        = If (monoexpr c) (monoexpr t) (monoexpr e)"
| "monoexpr (Take e f e')     = Take (monoexpr e) f (monoexpr e')"
| "monoexpr (Split v va)      = Split (monoexpr v) (monoexpr va)"
             by (case_tac x, auto)
 termination by (relation "measure expr_size", auto simp: order_listsum)

fun monoval :: "('f, 'a) vval \<Rightarrow> ('f \<times> type list, 'a) vval"
where "monoval (VPrim lit) = VPrim lit"
    | "monoval (VProduct t u) = VProduct (monoval t) (monoval u)"
    | "monoval (VSum name v) = VSum name (monoval v)"
    | "monoval (VRecord vs) = VRecord (map monoval vs)"
    | "monoval (VAbstract t) = VAbstract t"
    | "monoval (VAFunction f ts) = VAFunction (f, ts) []"
    | "monoval (VFunction f ts) = VFunction (monoexpr (specialise ts f)) []"
    | "monoval VUnit = VUnit"

definition monoprog :: "('f, 'a) vabsfuns \<Rightarrow> (('f \<times> type list), 'a) vabsfuns \<Rightarrow> bool"
where "monoprog \<xi> \<xi>' \<equiv> \<forall>f \<tau>s. (\<forall>v v'. \<xi> f v v' \<longleftrightarrow> \<xi>' (f, \<tau>s) (monoval v) (monoval v'))"

lemma member_nth_map: "f < length fs \<Longrightarrow> \<xi>', map monoval \<gamma> \<turnstile> Member (monoexpr e) f \<Down> monoval (fs ! f) =  \<xi>' , map monoval \<gamma> \<turnstile> Member (monoexpr e) f \<Down> (map monoval fs) ! f"
by (subst nth_map, simp_all)
thm v_sem_prim

lemma v_sem_prim': "\<xi> , \<gamma> \<turnstile>* as \<Down> as' \<Longrightarrow> eval_prim p as' = r \<Longrightarrow> \<xi> , \<gamma> \<turnstile> Prim p as \<Down> r"
by (force dest: sym intro: v_sem_prim)

lemma monoval_vprim [simp]: "monoval \<circ> VPrim = VPrim" by (rule ext, simp)

lemma eval_prim_type_change:
assumes "(eval_prim :: prim_op \<Rightarrow> ('f1, 'a1) vval list \<Rightarrow> ('f1, 'a1) vval) p (map VPrim lits) = VPrim l"
shows "(eval_prim :: prim_op \<Rightarrow> ('f2, 'a2) vval list \<Rightarrow> ('f2, 'a2) vval) p (map VPrim lits) = VPrim l"
proof -
have helper: "(\<lambda>vv. case vv of VPrim v \<Rightarrow> v | _ \<Rightarrow> LBool False) \<circ> VPrim = id" by (rule ext, simp)
then show ?thesis using assms by (simp add: eval_prim_def helper)
qed

lemma mono_correct:
assumes "\<xi> matches \<Xi>"
and     "proc_ctx_wellformed \<Xi>"
and     "\<Xi> \<turnstile> \<gamma> matches \<Gamma>"
and     "monoprog \<xi> \<xi>'"
shows   "\<xi>, \<gamma> \<turnstile> e \<Down> e' \<Longrightarrow>  \<Xi>, [], \<Gamma> \<turnstile> e : \<tau>    \<Longrightarrow> \<xi>', map monoval \<gamma> \<turnstile> monoexpr e \<Down> monoval e'"
and     "\<xi>, \<gamma> \<turnstile>* es \<Down> es' \<Longrightarrow> \<Xi>, [], \<Gamma> \<turnstile>* es : \<tau>s \<Longrightarrow> \<xi>', map monoval \<gamma> \<turnstile>* map monoexpr es \<Down> map monoval es'"
using assms proof (induct \<xi> \<gamma> e e'
                      and \<xi> \<gamma> es es'
               arbitrary: \<tau> \<Gamma>
                      and \<tau>s \<Gamma>
                    rule: v_sem_v_sem_all.inducts)
case v_sem_app
note IH1 = this(2)
and  IH2 = this(4)
and  IH3 = this(6)
and  rest = this(1,3,5,7-)
then show ?case
  apply (clarsimp)
  apply (erule typing_appE)
  apply (rule, erule(5) IH1 [OF _ _ _ matches_split'(1), simplified], erule(5) IH2 [OF _ _ _ matches_split'(2), simplified])
  apply (simp)
  apply (frule(5) preservation(1) [where \<tau>s = "[]" and K = "[]", OF _ _ matches_split'(1), simplified])
  apply (frule(5) preservation(1) [where \<tau>s = "[]" and K = "[]", OF _ _ matches_split'(2), simplified])
  apply (auto elim!: v_t_funE
              intro: IH3 [simplified] specialisation
              simp:  matches_def instantiate_ctx_def)
done
next case v_sem_abs_app
note IH1  = this(2)
and  IH2  = this(4)
and  rest = this(1,3,5-)
then show ?case
  apply (clarsimp)
  apply (erule typing_appE)
  apply (rule v_sem_v_sem_all.v_sem_abs_app, erule(5) IH1 [OF _ _ _ matches_split'(1), simplified], erule(5) IH2 [OF _ _ _ matches_split'(2), simplified])
  apply (simp add: monoprog_def)
done
next case v_sem_var then show ?case by (simp, metis matches_length nth_map typing_varE v_sem_v_sem_all.v_sem_var)
next case v_sem_lit then show ?case by (fastforce intro!: v_sem_v_sem_all.v_sem_lit)
next case v_sem_fun then show ?case by (fastforce intro!: v_sem_v_sem_all.v_sem_fun)
next case v_sem_afun then show ?case by (fastforce intro!: v_sem_v_sem_all.v_sem_afun)
next case v_sem_cast then show ?case by (fastforce intro!: v_sem_v_sem_all.v_sem_cast)
next case v_sem_con then show ?case by (fastforce intro!: v_sem_v_sem_all.v_sem_con)
next case v_sem_promote then show ?case by (fastforce intro!: v_sem_v_sem_all.v_sem_promote)
next case v_sem_unit then show ?case by (simp add: v_sem_v_sem_all.v_sem_unit)
next case v_sem_tuple then show ?case by (clarsimp elim!: typing_tupleE simp: matches_split' v_sem_v_sem_all.v_sem_tuple)
next case v_sem_esac then show ?case by (fastforce intro!: v_sem_v_sem_all.v_sem_esac)
next case v_sem_take
note IH1 = this(2)
and  IH2 = this(4)
and rest = this(1,3,5-)
from rest show ?case
  apply (clarsimp elim!: typing_takeE)
  apply (frule(1) matches_split'(1))
  apply (frule(1) matches_split'(2))
  apply (rule v_sem_v_sem_all.v_sem_take)
   apply (frule(5) IH1[simplified])
  apply (frule(4) preservation [where \<tau>s = "[]" and K = "[]", simplified, rotated -3])
  apply (erule v_t_recordE, simp)
  apply (frule(2) IH2[simplified])
    apply (rule matches_cons')
     apply (rule matches_cons')
      apply (simp)
     apply (frule(3) vval_typing_record_take)
     apply (rule)
     apply (simp)
    apply (frule(4) vval_typing_record_nth)
  apply (simp add: vval_typing_record_length)
done
next case v_sem_all_empty then show ?case by (simp add: v_sem_v_sem_all.v_sem_all_empty)
next case v_sem_all_cons then show ?case by (auto elim!: typing_all_consE dest: matches_split' intro!: v_sem_v_sem_all.intros)
next case v_sem_split
note IH1 = this(2)
and  IH2 = this(4)
and rest = this(1,3,5-)
from rest show ?case
  apply (clarsimp elim!: typing_splitE)
  apply (frule(1) matches_split'(1))
  apply (frule(1) matches_split'(2))
  apply (rule v_sem_v_sem_all.v_sem_split)
   apply (frule(5) IH1[simplified])
   apply (force dest: preservation [where \<tau>s = "[]" and K = "[]", simplified, rotated -3]
                      IH2
                simp: matches_def
                elim: v_t_productE)
done
next case v_sem_member then show ?case
  apply (clarsimp elim!: typing_memberE)
  apply (subst member_nth_map
        , (force dest:preservation [where \<tau>s = "[]" and K = "[]", simplified] elim!: v_t_recordE dest: vval_typing_record_length intro: v_sem_v_sem_all.intros)+
        )
done
next case v_sem_prim
note IH = this(2)
and rest = this(1,3-)
from rest show ?case
  apply (clarsimp elim!: typing_primE)
  apply (frule(4) preservation(2) [where \<tau>s = "[]" and K = "[]", simplified])
  apply (frule v_t_map_TPrimD)
  apply (clarsimp)
  apply (frule eval_prim_preservation)
  apply (simp)
  apply (erule vval_typing.cases, simp_all)
  apply (rule v_sem_prim')
  apply (clarsimp)
  apply (erule(4) IH)
  apply (force intro: eval_prim_type_change)
done
next case v_sem_struct then show ?case by (fastforce intro!: v_sem_v_sem_all.v_sem_struct)
next case v_sem_case_m then show ?case
  apply (clarsimp elim!: typing_caseE)
  apply (frule(1) matches_split'(1))
  apply (frule(1) matches_split'(2))
  apply (rule v_sem_v_sem_all.intros, fastforce)
  apply (frule(4) preservation [where \<tau>s = "[]" and K = "[]", simplified, rotated -3])
  apply (erule v_t_sumE', simp)
  apply (metis distinct_fst matches_cons')
done
next case v_sem_case_nm
note IH1 = this(2)
and  IH2 = this(5)
and rest = this(1,3-4,6-)
from rest show ?case
  apply (clarsimp elim!: typing_caseE)
  apply (frule(1) matches_split'(1))
  apply (frule(1) matches_split'(2))
  apply (rule v_sem_v_sem_all.intros, frule(6) IH1[simplified])
  apply (frule(3) IH2[OF _ _ _ matches_cons', simplified])
  apply (auto intro: sum_downcast dest:preservation [where \<tau>s = "[]" and K = "[]", simplified])
done
next case v_sem_let
note IH1 = this(2)
and  IH2 = this(4)
and rest = this(1,3,5-)
from rest show ?case
  apply (clarsimp elim!: typing_letE)
  apply (frule(1) matches_split'(1))
  apply (frule(1) matches_split'(2))
  apply (frule(4) preservation [where \<tau>s = "[]" and K = "[]", simplified])
  apply (erule(4) v_sem_v_sem_all.v_sem_let [OF IH1])
  apply (frule(5) IH2 [OF _ _ _ matches_cons', simplified])
  apply simp
done
next case v_sem_letbang
note IH1 = this(2)
and  IH2 = this(4)
and rest = this(1,3,5-)
from rest show ?case
  apply (clarsimp elim!: typing_letbE)
  apply (frule(1) matches_split_bang'(1))
  apply (frule(1) matches_split_bang'(2))
  apply (frule(4) preservation [where \<tau>s = "[]" and K = "[]", simplified])
  apply (erule(4) v_sem_v_sem_all.v_sem_letbang [OF IH1])
  apply (frule(5) IH2 [OF _ _ _ matches_cons', simplified])
  apply simp
done
next case v_sem_if then show ?case by (fastforce elim!: typing_ifE dest: matches_split' intro!: v_sem_v_sem_all.v_sem_if)
next case v_sem_put then show ?case
  apply (clarsimp elim!: typing_putE)
  apply (frule(1) matches_split'(1))
  apply (frule(1) matches_split'(2))
  apply (fastforce simp: map_update intro: v_sem_v_sem_all.v_sem_put)
done
qed

end

end