(*  Title:      HOL/MicroJava/BV/JVMType.thy
    Author:     Gerwin Klein
    Copyright   2000 TUM
*)

section {* The JVM Type System as Semilattice *}

theory JVMType
imports JType
begin

type_synonym locvars_type = "ty err list"
type_synonym opstack_type = "ty list"
type_synonym state_type = "opstack_type \<times> locvars_type"
type_synonym state = "state_type option err"    -- "for Kildall"
type_synonym method_type = "state_type option list"   -- "for BVSpec"
type_synonym class_type = "sig \<Rightarrow> method_type"
type_synonym prog_type = "cname \<Rightarrow> class_type"

definition stk_esl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty list esl" where
  "stk_esl S maxs == upto_esl maxs (JType.esl S)"

definition reg_sl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty err list sl" where
  "reg_sl S maxr == Listn.sl maxr (Err.sl (JType.esl S))"

definition sl :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> state sl" where
  "sl S maxs maxr ==
  Err.sl(Opt.esl(Product.esl (stk_esl S maxs) (Err.esl(reg_sl S maxr))))"

definition states :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> state set" where
  "states S maxs maxr == fst(sl S maxs maxr)"

definition le :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> state ord" where
  "le S maxs maxr == fst(snd(sl S maxs maxr))"

definition  sup :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> state binop" where
  "sup S maxs maxr == snd(snd(sl S maxs maxr))"

definition sup_ty_opt :: "['code prog,ty err,ty err] \<Rightarrow> bool"
                 ("_ |- _ <=o _" [71,71] 70) where
  "sup_ty_opt G == Err.le (subtype G)"

definition sup_loc :: "['code prog,locvars_type,locvars_type] \<Rightarrow> bool"
              ("_ |- _ <=l _"  [71,71] 70) where
  "sup_loc G == Listn.le (sup_ty_opt G)"

definition sup_state :: "['code prog,state_type,state_type] \<Rightarrow> bool"
               ("_ |- _ <=s _"  [71,71] 70) where
  "sup_state G == Product.le (Listn.le (subtype G)) (sup_loc G)"

definition sup_state_opt :: "['code prog,state_type option,state_type option] \<Rightarrow> bool"
                   ("_ |- _ <=' _"  [71,71] 70) where
  "sup_state_opt G == Opt.le (sup_state G)"

notation (xsymbols)
  sup_ty_opt  ("_ \<turnstile> _ <=o _" [71,71] 70) and
  sup_loc  ("_ \<turnstile> _ <=l _" [71,71] 70) and
  sup_state  ("_ \<turnstile> _ <=s _" [71,71] 70) and
  sup_state_opt  ("_ \<turnstile> _ <=' _" [71,71] 70)

lemma JVM_states_unfold:
  "states S maxs maxr == err(opt((Union {list n (types S) |n. n <= maxs}) <*>
                                  list maxr (err(types S))))"
  apply (unfold states_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def reg_sl_def Product.esl_def
         Listn.sl_def upto_esl_def JType.esl_def Err.esl_def)
  by simp

lemma JVM_le_unfold:
 "le S m n ==
  Err.le(Opt.le(Product.le(Listn.le(subtype S))(Listn.le(Err.le(subtype S)))))"
  apply (unfold le_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def reg_sl_def Product.esl_def
         Listn.sl_def upto_esl_def JType.esl_def Err.esl_def)
  by simp

lemma JVM_le_convert:
  "le G m n (OK t1) (OK t2) = G \<turnstile> t1 <=' t2"
  by (simp add: JVM_le_unfold Err.le_def lesub_def sup_state_opt_def
                sup_state_def sup_loc_def sup_ty_opt_def)

lemma JVM_le_Err_conv:
  "le G m n = Err.le (sup_state_opt G)"
  by (unfold sup_state_opt_def sup_state_def sup_loc_def
             sup_ty_opt_def JVM_le_unfold) simp

lemma zip_map [rule_format]:
  "\<forall>a. length a = length b \<longrightarrow>
  zip (map f a) (map g b) = map (\<lambda>(x,y). (f x, g y)) (zip a b)"
  apply (induct b)
   apply simp
  apply clarsimp
  apply (case_tac aa)
  apply simp_all
  done

lemma stk_convert:
  "Listn.le (subtype G) a b = G \<turnstile> map OK a <=l map OK b"
proof
  assume "Listn.le (subtype G) a b"

  hence le: "list_all2 (subtype G) a b"
    by (unfold Listn.le_def lesub_def)

  { fix x' y'
    assume "length a = length b"
           "(x',y') \<in> set (zip (map OK a) (map OK b))"
    then
    obtain x y where OK:
      "x' = OK x" "y' = OK y" "(x,y) \<in> set (zip a b)"
      by (auto simp add: zip_map)
    with le
    have "subtype G x y"
      by (simp add: list_all2_iff Ball_def)
    with OK
    have "G \<turnstile> x' <=o y'"
      by (simp add: sup_ty_opt_def)
  }

  with le
  show "G \<turnstile> map OK a <=l map OK b"
    by (unfold sup_loc_def Listn.le_def lesub_def list_all2_iff) auto
next
  assume "G \<turnstile> map OK a <=l map OK b"

  thus "Listn.le (subtype G) a b"
    apply (unfold sup_loc_def list_all2_iff Listn.le_def lesub_def)
    apply (clarsimp simp add: zip_map)
    apply (drule bspec, assumption)
    apply (auto simp add: sup_ty_opt_def subtype_def)
    done
qed

lemma sup_state_conv:
  "(G \<turnstile> s1 <=s s2) ==
  (G \<turnstile> map OK (fst s1) <=l map OK (fst s2)) \<and> (G \<turnstile> snd s1 <=l snd s2)"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def split_beta)

lemma subtype_refl [simp]:
  "subtype G t t"
  by (simp add: subtype_def)

theorem sup_ty_opt_refl [simp]:
  "G \<turnstile> t <=o t"
  by (simp add: sup_ty_opt_def Err.le_def lesub_def split: err.split)

lemma le_list_refl2 [simp]:
  "(\<And>xs. r xs xs) \<Longrightarrow> Listn.le r xs xs"
  by (induct xs, auto simp add: Listn.le_def lesub_def)

theorem sup_loc_refl [simp]:
  "G \<turnstile> t <=l t"
  by (simp add: sup_loc_def)

theorem sup_state_refl [simp]:
  "G \<turnstile> s <=s s"
  by (auto simp add: sup_state_def Product.le_def lesub_def)

theorem sup_state_opt_refl [simp]:
  "G \<turnstile> s <=' s"
  by (simp add: sup_state_opt_def Opt.le_def lesub_def split: option.split)

theorem anyConvErr [simp]:
  "(G \<turnstile> Err <=o any) = (any = Err)"
  by (simp add: sup_ty_opt_def Err.le_def split: err.split)

theorem OKanyConvOK [simp]:
  "(G \<turnstile> (OK ty') <=o (OK ty)) = (G \<turnstile> ty' \<preceq> ty)"
  by (simp add: sup_ty_opt_def Err.le_def lesub_def subtype_def)

theorem sup_ty_opt_OK:
  "G \<turnstile> a <=o (OK b) \<Longrightarrow> \<exists> x. a = OK x"
  by (clarsimp simp add: sup_ty_opt_def Err.le_def split: err.splits)

lemma widen_PrimT_conv1 [simp]:
  "\<lbrakk> G \<turnstile> S \<preceq> T; S = PrimT x\<rbrakk> \<Longrightarrow> T = PrimT x"
  by (auto elim: widen.cases)

theorem sup_PTS_eq:
  "(G \<turnstile> OK (PrimT p) <=o X) = (X=Err \<or> X = OK (PrimT p))"
  by (auto simp add: sup_ty_opt_def Err.le_def lesub_def subtype_def
              split: err.splits)

theorem sup_loc_Nil [iff]:
  "(G \<turnstile> [] <=l XT) = (XT=[])"
  by (simp add: sup_loc_def Listn.le_def)

theorem sup_loc_Cons [iff]:
  "(G \<turnstile> (Y#YT) <=l XT) = (\<exists>X XT'. XT=X#XT' \<and> (G \<turnstile> Y <=o X) \<and> (G \<turnstile> YT <=l XT'))"
  by (simp add: sup_loc_def Listn.le_def lesub_def list_all2_Cons1)

theorem sup_loc_Cons2:
  "(G \<turnstile> YT <=l (X#XT)) = (\<exists>Y YT'. YT=Y#YT' \<and> (G \<turnstile> Y <=o X) \<and> (G \<turnstile> YT' <=l XT))"
  by (simp add: sup_loc_def Listn.le_def lesub_def list_all2_Cons2)

lemma sup_state_Cons:
  "(G \<turnstile> (x#xt, a) <=s (y#yt, b)) =
   ((G \<turnstile> x \<preceq> y) \<and> (G \<turnstile> (xt,a) <=s (yt,b)))"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def)

theorem sup_loc_length:
  "G \<turnstile> a <=l b \<Longrightarrow> length a = length b"
proof -
  assume G: "G \<turnstile> a <=l b"
  have "\<forall>b. (G \<turnstile> a <=l b) \<longrightarrow> length a = length b"
    by (induct a, auto)
  with G
  show ?thesis by blast
qed

theorem sup_loc_nth:
  "\<lbrakk> G \<turnstile> a <=l b; n < length a \<rbrakk> \<Longrightarrow> G \<turnstile> (a!n) <=o (b!n)"
proof -
  assume a: "G \<turnstile> a <=l b" "n < length a"
  have "\<forall> n b. (G \<turnstile> a <=l b) \<longrightarrow> n < length a \<longrightarrow> (G \<turnstile> (a!n) <=o (b!n))"
    (is "?P a")
  proof (induct a)
    show "?P []" by simp

    fix x xs assume IH: "?P xs"

    show "?P (x#xs)"
    proof (intro strip)
      fix n b
      assume "G \<turnstile> (x # xs) <=l b" "n < length (x # xs)"
      with IH
      show "G \<turnstile> ((x # xs) ! n) <=o (b ! n)"
        by (cases n) auto
    qed
  qed
  with a
  show ?thesis by blast
qed

theorem all_nth_sup_loc:
  "\<forall>b. length a = length b \<longrightarrow> (\<forall> n. n < length a \<longrightarrow> (G \<turnstile> (a!n) <=o (b!n)))
  \<longrightarrow> (G \<turnstile> a <=l b)" (is "?P a")
proof (induct a)
  show "?P []" by simp

  fix l ls assume IH: "?P ls"

  show "?P (l#ls)"
  proof (intro strip)
    fix b
    assume f: "\<forall>n. n < length (l # ls) \<longrightarrow> (G \<turnstile> ((l # ls) ! n) <=o (b ! n))"
    assume l: "length (l#ls) = length b"

    then obtain b' bs where b: "b = b'#bs"
      by (cases b) (simp, simp add: neq_Nil_conv)

    with f
    have "\<forall>n. n < length ls \<longrightarrow> (G \<turnstile> (ls!n) <=o (bs!n))"
      by auto

    with f b l IH
    show "G \<turnstile> (l # ls) <=l b"
      by auto
  qed
qed

theorem sup_loc_append:
  "length a = length b \<Longrightarrow>
   (G \<turnstile> (a@x) <=l (b@y)) = ((G \<turnstile> a <=l b) \<and> (G \<turnstile> x <=l y))"
proof -
  assume l: "length a = length b"

  have "\<forall>b. length a = length b \<longrightarrow> (G \<turnstile> (a@x) <=l (b@y)) = ((G \<turnstile> a <=l b) \<and>
            (G \<turnstile> x <=l y))" (is "?P a")
  proof (induct a)
    show "?P []" by simp

    fix l ls assume IH: "?P ls"
    show "?P (l#ls)"
    proof (intro strip)
      fix b
      assume "length (l#ls) = length (b::ty err list)"
      with IH
      show "(G \<turnstile> ((l#ls)@x) <=l (b@y)) = ((G \<turnstile> (l#ls) <=l b) \<and> (G \<turnstile> x <=l y))"
        by (cases b) auto
    qed
  qed
  with l
  show ?thesis by blast
qed

theorem sup_loc_rev [simp]:
  "(G \<turnstile> (rev a) <=l rev b) = (G \<turnstile> a <=l b)"
proof -
  have "\<forall>b. (G \<turnstile> (rev a) <=l rev b) = (G \<turnstile> a <=l b)" (is "\<forall>b. ?Q a b" is "?P a")
  proof (induct a)
    show "?P []" by simp

    fix l ls assume IH: "?P ls"

    {
      fix b
      have "?Q (l#ls) b"
      proof (cases b)
        case Nil
        thus ?thesis by (auto dest: sup_loc_length)
      next
        case (Cons a list)
        show ?thesis
        proof
          assume "G \<turnstile> (l # ls) <=l b"
          thus "G \<turnstile> rev (l # ls) <=l rev b"
            by (clarsimp simp add: Cons IH sup_loc_length sup_loc_append)
        next
          assume "G \<turnstile> rev (l # ls) <=l rev b"
          hence G: "G \<turnstile> (rev ls @ [l]) <=l (rev list @ [a])"
            by (simp add: Cons)

          hence "length (rev ls) = length (rev list)"
            by (auto dest: sup_loc_length)

          from this G
          obtain "G \<turnstile> rev ls <=l rev list" "G \<turnstile> l <=o a"
            by (simp add: sup_loc_append)

          thus "G \<turnstile> (l # ls) <=l b"
            by (simp add: Cons IH)
        qed
      qed
    }
    thus "?P (l#ls)" by blast
  qed

  thus ?thesis by blast
qed

theorem sup_loc_update [rule_format]:
  "\<forall> n y. (G \<turnstile> a <=o b) \<longrightarrow> n < length y \<longrightarrow> (G \<turnstile> x <=l y) \<longrightarrow>
          (G \<turnstile> x[n := a] <=l y[n := b])" (is "?P x")
proof (induct x)
  show "?P []" by simp

  fix l ls assume IH: "?P ls"
  show "?P (l#ls)"
  proof (intro strip)
    fix n y
    assume "G \<turnstile>a <=o b" "G \<turnstile> (l # ls) <=l y" "n < length y"
    with IH
    show "G \<turnstile> (l # ls)[n := a] <=l y[n := b]"
      by (cases n) (auto simp add: sup_loc_Cons2 list_all2_Cons1)
  qed
qed

theorem sup_state_length [simp]:
  "G \<turnstile> s2 <=s s1 \<Longrightarrow>
   length (fst s2) = length (fst s1) \<and> length (snd s2) = length (snd s1)"
  by (auto dest: sup_loc_length simp add: sup_state_def stk_convert lesub_def Product.le_def)

theorem sup_state_append_snd:
  "length a = length b \<Longrightarrow>
  (G \<turnstile> (i,a@x) <=s (j,b@y)) = ((G \<turnstile> (i,a) <=s (j,b)) \<and> (G \<turnstile> (i,x) <=s (j,y)))"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_append)

theorem sup_state_append_fst:
  "length a = length b \<Longrightarrow>
  (G \<turnstile> (a@x,i) <=s (b@y,j)) = ((G \<turnstile> (a,i) <=s (b,j)) \<and> (G \<turnstile> (x,i) <=s (y,j)))"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_append)

theorem sup_state_Cons1:
  "(G \<turnstile> (x#xt, a) <=s (yt, b)) =
   (\<exists>y yt'. yt=y#yt' \<and> (G \<turnstile> x \<preceq> y) \<and> (G \<turnstile> (xt,a) <=s (yt',b)))"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def)

theorem sup_state_Cons2:
  "(G \<turnstile> (xt, a) <=s (y#yt, b)) =
   (\<exists>x xt'. xt=x#xt' \<and> (G \<turnstile> x \<preceq> y) \<and> (G \<turnstile> (xt',a) <=s (yt,b)))"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_Cons2)

theorem sup_state_ignore_fst:
  "G \<turnstile> (a, x) <=s (b, y) \<Longrightarrow> G \<turnstile> (c, x) <=s (c, y)"
  by (simp add: sup_state_def lesub_def Product.le_def)

theorem sup_state_rev_fst:
  "(G \<turnstile> (rev a, x) <=s (rev b, y)) = (G \<turnstile> (a, x) <=s (b, y))"
proof -
  have m: "\<And>f x. map f (rev x) = rev (map f x)" by (simp add: rev_map)
  show ?thesis by (simp add: m sup_state_def stk_convert lesub_def Product.le_def)
qed

lemma sup_state_opt_None_any [iff]:
  "(G \<turnstile> None <=' any) = True"
  by (simp add: sup_state_opt_def Opt.le_def split: option.split)

lemma sup_state_opt_any_None [iff]:
  "(G \<turnstile> any <=' None) = (any = None)"
  by (simp add: sup_state_opt_def Opt.le_def split: option.split)

lemma sup_state_opt_Some_Some [iff]:
  "(G \<turnstile> (Some a) <=' (Some b)) = (G \<turnstile> a <=s b)"
  by (simp add: sup_state_opt_def Opt.le_def lesub_def del: split_paired_Ex)

lemma sup_state_opt_any_Some [iff]:
  "(G \<turnstile> (Some a) <=' any) = (\<exists>b. any = Some b \<and> G \<turnstile> a <=s b)"
  by (simp add: sup_state_opt_def Opt.le_def lesub_def split: option.split)

lemma sup_state_opt_Some_any:
  "(G \<turnstile> any <=' (Some b)) = (any = None \<or> (\<exists>a. any = Some a \<and> G \<turnstile> a <=s b))"
  by (simp add: sup_state_opt_def Opt.le_def lesub_def split: option.split)

theorem sup_ty_opt_trans [trans]:
  "\<lbrakk>G \<turnstile> a <=o b; G \<turnstile> b <=o c\<rbrakk> \<Longrightarrow> G \<turnstile> a <=o c"
  by (auto intro: widen_trans
           simp add: sup_ty_opt_def Err.le_def lesub_def subtype_def
           split: err.splits)

theorem sup_loc_trans [trans]:
  "\<lbrakk>G \<turnstile> a <=l b; G \<turnstile> b <=l c\<rbrakk> \<Longrightarrow> G \<turnstile> a <=l c"
proof -
  assume G: "G \<turnstile> a <=l b" "G \<turnstile> b <=l c"

  hence "\<forall> n. n < length a \<longrightarrow> (G \<turnstile> (a!n) <=o (c!n))"
  proof (intro strip)
    fix n
    assume n: "n < length a"
    with G(1)
    have "G \<turnstile> (a!n) <=o (b!n)"
      by (rule sup_loc_nth)
    also
    from n G
    have "G \<turnstile> \<dots> <=o (c!n)"
      by - (rule sup_loc_nth, auto dest: sup_loc_length)
    finally
    show "G \<turnstile> (a!n) <=o (c!n)" .
  qed

  with G
  show ?thesis
    by (auto intro!: all_nth_sup_loc [rule_format] dest!: sup_loc_length)
qed

theorem sup_state_trans [trans]:
  "\<lbrakk>G \<turnstile> a <=s b; G \<turnstile> b <=s c\<rbrakk> \<Longrightarrow> G \<turnstile> a <=s c"
  by (auto intro: sup_loc_trans simp add: sup_state_def stk_convert Product.le_def lesub_def)

theorem sup_state_opt_trans [trans]:
  "\<lbrakk>G \<turnstile> a <=' b; G \<turnstile> b <=' c\<rbrakk> \<Longrightarrow> G \<turnstile> a <=' c"
  by (auto intro: sup_state_trans
           simp add: sup_state_opt_def Opt.le_def lesub_def
           split: option.splits)

end


(*
    File:        SubOcc.thy
    Time-stamp:  <2015-12-23T12:46:41Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory SubOcc imports OccTools begin

definition Occ_Subtree :: "[i, i] => i" where
"Occ_Subtree(m, X) == {z. y: X, EX l T. z = <l, T> & y = <m@l, T>}"

definition Term_cons_inj_cond :: "[i, i, i=>i, [i,i]=>i]=>o" where
  "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)
        == ALL T: Tag. ALL U: Tag. ALL l: list(Terms). ALL m: list(Terms).
              Term_cons(T, l): Terms -->
           (Term_cons(T, l) = Term_cons(U, m) <-> T = U &
                 (ALL z: Arity(T). nth(z, l) = nth(z, m)))"

(** Occ_Subtree **)
lemma Occ_SubtreeI:
  "[| m: list(A); <m@l, T>: X |] ==> <l, T>: Occ_Subtree(m, X)"
apply (unfold Occ_Subtree_def)
apply (rule ReplaceI)
prefer 2 apply assumption
apply (rule refl conjI exI)+
apply (elim conjE exE)
apply simp
done

lemma Occ_SubtreeD:
  "<l, T>: Occ_Subtree(m, X) ==> <m@l, T>: X"
apply (unfold Occ_Subtree_def)
apply blast
done

lemma Occ_SubtreeE:
  "[| x: Occ_Subtree(m, X);
      !!l T. [| x = <l, T>; <m@l, T>: X |] ==> R |]==> R"
apply (unfold Occ_Subtree_def)
apply blast
done

lemma Occ_SubtreeE2:
  "[| <l, T>: Occ_Subtree(m, X);
      <m@l, T>: X ==> R |] ==> R"
apply (unfold Occ_Subtree_def)
apply blast
done

lemma Occ_Subtree_0:
  "Occ_Subtree(m, 0) = 0"
apply (unfold Occ_Subtree_def)
apply blast
done

lemma Occ_Subtree_Nil:
  "X <= A * B ==> Occ_Subtree([], X) = X"
apply (unfold Occ_Subtree_def)
apply simp
apply blast
done

lemma Occ_Subtree_Cons:
  "l: list(A) ==>
      Occ_Subtree(Cons(a, l), X) = Occ_Subtree(l, Occ_subtree(a, X))"
apply (unfold Occ_Subtree_def)
apply simp
apply (rule equalityI)
apply (safe elim!: Occ_subtreeE)
apply (rule ReplaceI)
apply (erule_tac [2] Occ_subtreeI)
apply (rule_tac [3] ReplaceI)
prefer 4 apply assumption
prefer 3
apply (assumption | rule refl exI conjI)+
apply (elim exE conjE)
apply simp
apply (elim exE conjE)
apply simp
done

lemma Occ_Subtree_app:
  assumes prem1: "l: list(A)"
  and prem2: "m: list(A)"
  and prem3: "X <= list(C) * D"
  shows "Occ_Subtree(l@m, X) = Occ_Subtree(m, Occ_Subtree(l, X))"
apply (rule prem3 [THEN rev_mp])
apply (rule_tac x="X" in spec)
apply (insert prem2)
apply (rule prem1 [THEN list.induct])
apply (simp_all add: Occ_Subtree_Nil Occ_Subtree_Cons)
apply (intro impI allI)
apply (drule Occ_subtree_preserves_domain)
apply (drule spec)
apply (drule mp, assumption)
apply assumption
done

lemma Occ_Subtree_in_Occ_range:
  assumes major: "<l, T>: X"
  and prem: "X: Occ_range(Tag, Arity)"
  shows "Occ_Subtree(l, X): Occ_range(Tag, Arity)"
apply (rule prem [THEN rev_mp])
apply (rule major [THEN rev_mp])
apply (rule_tac x="X" in spec)
apply (rule list.induct
    [OF major [THEN prem
       [THEN Occ_range_domain_lemma, THEN subsetD, THEN SigmaD1]]])
apply (intro impI allI)
apply (frule Occ_range_domain_lemma)
apply (simp add: Occ_Subtree_Nil)
apply (intro impI allI)
apply (frule Occ_range_domain_lemma)
apply (simp add: Occ_Subtree_Cons)
apply (erule spec [THEN mp, THEN mp])
apply (erule Occ_subtreeI)
apply (rule Occ_subtree_in_Occ_range)
apply assumption+
done

(** Term_cons_inj_cond **)
lemma Term_cons_inj_condI:
  assumes
  "!! T U l m.
    [| T: Tag; U: Tag; l: list(Terms); m: list(Terms);
      Term_cons(T, l): Terms
    |] ==> Term_cons(T, l) = Term_cons(U, m) <->
          T = U & (ALL z: Arity(T). nth(z, l) = nth(z, m))"
  shows "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
apply (unfold Term_cons_inj_cond_def)
apply (assumption | rule assms ballI impI)+
done

lemma Term_cons_inj_condD:
  "[| Term_cons_inj_cond(Terms, Tag, Arity, Term_cons);
      T: Tag; U: Tag; l: list(Terms); m: list(Terms);
      Term_cons(T, l): Terms
   |] ==> Term_cons(T, l) = Term_cons(U, m) <->
           T = U & (ALL z: Arity(T). nth(z, l) = nth(z, m))"
apply (unfold Term_cons_inj_cond_def)
apply blast
done

lemma Term_cons_inj_condD1:
  "[| Term_cons_inj_cond(Terms, Tag, Arity, Term_cons);
      Term_cons(T, l) = Term_cons(U, m);
      T: Tag; U: Tag; l: list(Terms); m: list(Terms);
      Term_cons(T, l): Terms
   |] ==> T = U & (ALL z: Arity(T). nth(z, l) = nth(z, m))"
apply (unfold Term_cons_inj_cond_def)
apply blast
done

lemma Occ_ind_cond_Term_cons_lemma:
  "[| Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons);
      M: Terms |] ==> EX T: Tag. EX l: list(Terms).
          M = Term_cons(T, l) & Arity(T) = length(l)"
apply (erule Occ_ind_condD)
apply (assumption | rule refl bexI conjI)+
done

lemma Term_cons_inj_cond_induct_lemma:
  assumes hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and major: "M: Terms"
  and indstep:
     "!! l T. [| T: Tag; l: list(Terms);
            Term_cons(T, l): Terms;
            Arity(T) = length(l);
            Occ(Term_cons(T, l)) = Occ_cons(T, map(Occ, l));
            ALL z: length(l). ALL U: Tag. ALL m: list(Terms).
               nth(z, l) = Term_cons(U, m) & Arity(U) = length(m)
               --> P(nth(z, l), U, m)
      |]  ==> P(Term_cons(T, l), T, l)"
  shows
    "ALL T. ALL l. M = Term_cons(T, l) & Arity(T) = length(l) &
          T: Tag & l: list(Terms) --> P(M, T, l)"
apply (rule Occ_ind_condD [OF hind major])
apply (intro impI allI)
apply (elim conjE)
apply (drule hinj [THEN Term_cons_inj_condD1])
apply assumption+
apply (erule conjE)
apply hypsubst
apply (rename_tac m)
apply (subgoal_tac "l = m")
prefer 2
apply (rule nth_inj)
apply simp
apply simp
apply assumption+
apply hypsubst
apply (rule indstep)
apply assumption+
apply (intro ballI impI)
apply (erule conjE)
apply (drule bspec)
apply assumption
apply (drule spec [THEN spec, THEN mp])
apply (assumption | rule conjI)+
done

lemma Term_cons_inj_cond_induct:
  assumes hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and major: "Term_cons(T, l): Terms"
  and t_tag: "T: Tag"
  and l_list: "l: list(Terms)"
  and lencond: "Arity(T) = length(l)"
  and indstep:
     "!! l T. [| T: Tag; l: list(Terms);
          Term_cons(T, l): Terms;
          Arity(T) = length(l);
          Occ(Term_cons(T, l)) = Occ_cons(T, map(Occ, l));
          ALL z: length(l). ALL U: Tag. ALL m: list(Terms).
             nth(z, l) = Term_cons(U, m) & Arity(U) = length(m)
               --> P(U, m)
      |]  ==> P(T, l)"
  shows "P(T, l)"
apply (rule Term_cons_inj_cond_induct_lemma [OF hind hinj major,
         THEN spec, THEN spec, THEN mp])
prefer 2
apply (assumption | rule refl t_tag l_list lencond conjI)+
apply (rule indstep)
apply assumption+
done

lemma Occ_Term_cons:
  assumes hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and major: "Term_cons(T, l): Terms"
  and t_tag: "T: Tag"
  and l_list: "l: list(Terms)"
  and lencond: "Arity(T) = length(l)"
  shows "Occ(Term_cons(T, l)) = Occ_cons(T, map(Occ, l))"
apply (rule Term_cons_inj_cond_induct [OF hind hinj major t_tag l_list lencond])
apply assumption
done

lemma def_Sub_type:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsub: "!!M. Sub(M) == {<l, Occinv(Occ_Subtree(l, Occ(M)))>. <l, T>: Occ(M)}"
  and major: "M: Terms"
  shows "Sub(M) <= list(nat)*Terms"
apply (unfold hsub)
apply safe
apply (frule Occ_ind_cond_Occ_domain [OF hind major, THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply simp
apply (insert major)
apply (blast intro: def_Occinv_type [OF hcons hind hinv]
               Occ_Subtree_in_Occ_range
               hind [THEN Occ_ind_cond_Occ_in_Occ_range])
done

lemma def_Sub_rec:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsub: "!!M. Sub(M) == {<l, Occinv(Occ_Subtree(l, Occ(M)))>. <l, T>: Occ(M)}"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and major: "Term_cons(T, l): Terms"
  and t_tag: "T: Tag"
  and l_list: "l: list(Terms)"
  and lencond: "Arity(T) = length(l)"
  shows "Sub(Term_cons(T, l)) = Occ_cons(Term_cons(T, l), map(Sub, l))"
apply (unfold hsub)
apply (rule Term_cons_inj_cond_induct [OF hind hinj major t_tag l_list lencond])
apply (rule equalityI)
apply safe
apply (frule hind [THEN Occ_ind_cond_Occ_domain])
apply (frule subsetD)
apply assumption
apply (erule SigmaE)
apply hypsubst
apply simp
apply (rename_tac v y)
apply (rule_tac a="v" in list.cases)
apply assumption
apply hypsubst
apply (drule_tac a="Occ(Term_cons(T, l))" in sym)
apply (simp add: def_Occinv_Occ [OF hcons hind hinv]
         Occ_Subtree_Nil)
apply (rule Occ_consI1)
apply simp
apply (erule Occ_cons_ConsE)
apply (subgoal_tac "map(Occ, l): list(Pow(list(nat) * Tag))")
apply (simp add: Occ_subtree_Occ_cons Occ_Subtree_Cons)
apply (rule Occ_consI2)
apply simp
apply (simp add: nth_map)
apply (unfold hsub)
apply (rule RepFun_eqI)
prefer 2 apply assumption
apply simp
apply (erule map_type)
apply (erule hind [THEN Occ_ind_cond_Occ_domain, THEN PowI])

apply (erule Occ_consE)
apply hypsubst
apply (rule RepFun_eqI)
prefer 2
apply simp
apply (rule Occ_consI1)
apply (frule hind [THEN Occ_ind_cond_Occ_domain])
apply (drule_tac a="Occ(Term_cons(T, l))" in sym)
apply (simp add: def_Occinv_Occ [OF hcons hind hinv]
              Occ_Subtree_Nil)
apply hypsubst
apply (simp add: nth_map)
apply (erule bexE)
apply (subgoal_tac "nth(a, l): Terms")
apply (frule_tac M="nth(a, l)" in hind [THEN Occ_ind_cond_Occ_domain])
apply (drule subsetD, assumption)
apply (erule SigmaE)
apply hypsubst
apply simp
apply (rename_tac n y)
apply (rule_tac x="<Cons(a, n), y>" in bexI)
apply (rule_tac [2] Occ_consI2)
apply (subgoal_tac "a: nat" "map(Occ, l): list(Pow(list(nat) * Tag))")
apply (simp add: nth_map Occ_subtree_Occ_cons Occ_Subtree_Cons)
apply (erule map_type)
apply (erule hind [THEN Occ_ind_cond_Occ_domain, THEN PowI])
apply (erule mem_nat_in_nat)
apply (erule length_type)
apply simp
apply (simp add: nth_map)
apply (rule nth_type2)
apply assumption
apply (erule ltI)
apply (erule length_type [THEN nat_into_Ord])
done

lemma def_Sub_functional:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsub: "!!M. Sub(M) == {<l, Occinv(Occ_Subtree(l, Occ(M)))>. <l, T>: Occ(M)}"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and major: "M: Terms"
  shows "functional(Sub(M))"
apply (rule Occ_ind_condD [OF hind major])
apply (simp add: def_Sub_rec [OF hcons hind hinv hsub hinj])
apply (rule functionalI)
apply (elim Occ_consE)
apply (simp_all add: nth_map)
apply clarify
apply (drule bspec)
apply (erule_tac [2] functionalD)
apply assumption+
done

lemma def_subterm_Nil:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsub: "!!M. Sub(M) == {<l, Occinv(Occ_Subtree(l, Occ(M)))>. <l, T>: Occ(M)}"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and hsubterm: "!!M l. subterm(M, l) == THE N. <l, N>: Sub(M)"
  and major: "M: Terms"
  shows "subterm(M, []) = M"
apply (unfold hsubterm)
apply (subgoal_tac "<[], M>: Sub(M)")
apply (rule the_equality)
apply assumption
apply (rule def_Sub_functional [OF hcons hind hinv hsub hinj major,
                                THEN functionalD])
apply assumption+
apply (rule Occ_ind_condD [OF hind major])
apply (simp add: def_Sub_rec [OF hcons hind hinv hsub hinj])
apply (rule Occ_consI1)
done

lemma def_subterm_Cons:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsub: "!!M. Sub(M) == {<l, Occinv(Occ_Subtree(l, Occ(M)))>. <l, T>: Occ(M)}"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and hsubterm: "!!M l. subterm(M, l) == THE N. <l, N>: Sub(M)"
  and major: "Term_cons(T, l): Terms"
  and t_tag: "T: Tag"
  and l_list: "l: list(Terms)"
  and hlen: "Arity(T) = length(l)"
  and prem1: "m: list(nat)"
  and prem2: "a: length(l)"
  shows "subterm(Term_cons(T, l), Cons(a, m)) = subterm(nth(a, l), m)"
apply (unfold hsubterm)
apply (insert major t_tag l_list hlen prem1 prem2)
apply (simp add: def_Sub_rec [OF hcons hind hinv hsub hinj])
apply (subgoal_tac "nth(a, l): Terms")
prefer 2
apply (rule nth_type2, assumption)
apply (erule ltI)
apply (erule length_type [THEN nat_into_Ord])
apply (case_tac "EX X. <m, X>: Sub(nth(a, l))")
prefer 2
apply (rule the_0 [THEN sym, THEN [2] trans])
prefer 2
apply (rule notI)
apply (erule notE)
apply blast
apply (rule the_0)
apply (rule notI)
apply (erule notE)
apply (erule ex1E)
apply (erule Occ_cons_ConsE)
apply (rule exI)
apply (simp add: nth_map)
apply (rule the_equality)
apply (rule_tac [2] the_equality [THEN sym])
apply (erule_tac [3] Occ_cons_ConsE)
apply (erule_tac [2] Occ_cons_ConsE)
apply (rule Occ_consI2)
apply (simp_all add: nth_map)
prefer 2
apply (rule def_Sub_functional [OF hcons hind hinv hsub hinj,
                                THEN functionalD])
prefer 2 apply assumption
prefer 2 apply assumption
apply simp
apply (rule theI)
apply (erule exE)
apply (rule ex1I)
apply assumption
apply (rule def_Sub_functional [OF hcons hind hinv hsub hinj,
                                THEN functionalD])
prefer 2 apply assumption
apply simp
apply assumption
done

end


(*  Title:      HOL/NanoJava/Decl.thy
    Author:     David von Oheimb
    Copyright   2001 Technische Universitaet Muenchen
*)

section "Types, class Declarations, and whole programs"

theory Decl imports Term begin

datatype ty
  = NT           --{* null type  *}
  | Class cname  --{* class type *}

text{* Field declaration *}
type_synonym fdecl
        = "fname \<times> ty"

record  methd
        = par :: ty
          res :: ty
          lcl ::"(vname \<times> ty) list"
          bdy :: stmt

text{* Method declaration *}
type_synonym mdecl
        = "mname \<times> methd"

record  "class"
        = super   :: cname
          flds    ::"fdecl list"
          methods ::"mdecl list"

text{* Class declaration *}
type_synonym cdecl
        = "cname \<times> class"

type_synonym prog
        = "cdecl list"

translations
  (type) "fdecl" \<leftharpoondown> (type) "fname \<times> ty"
  (type) "mdecl" \<leftharpoondown> (type) "mname \<times> ty \<times> ty \<times> stmt"
  (type) "class" \<leftharpoondown> (type) "cname \<times> fdecl list \<times> mdecl list"
  (type) "cdecl" \<leftharpoondown> (type) "cname \<times> class"
  (type) "prog " \<leftharpoondown> (type) "cdecl list"

axiomatization
  Prog    :: prog       --{* program as a global value *}
and
  Object  :: cname      --{* name of root class *}

definition "class" :: "cname \<rightharpoonup> class" where
 "class      \<equiv> map_of Prog"

definition is_class   :: "cname => bool" where
 "is_class C \<equiv> class C \<noteq> None"

lemma finite_is_class: "finite {C. is_class C}"
apply (unfold is_class_def class_def)
apply (fold dom_def)
apply (rule finite_dom_map_of)
done

end


theory Con_Set

imports VCG_Check

begin

definition
  con_set :: "vaddr set \<Rightarrow> p_state \<Rightarrow> bool"
where
  "con_set V s \<equiv>  \<forall>va\<in>V. va \<notin> incon_set s"

lemma [simp]:
  "con_set V (s\<lparr>heap := hp, incon_set := iset \<rparr>) = con_set V (s\<lparr>incon_set := iset\<rparr>)"
 by (clarsimp simp: con_set_def)

end


header "LTL integration"
theory PromelaLTL
imports
  "Promela"
  "../LTL_to_GBA/LTL"
begin

text {* 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. *}

subsection {* Proposition types and conversion *}

text {* LTL formulae and propositions are also generated by an SML parser.
Hence we have the same setup as for Promela itself: Mirror the data structures and
(sometimes) map them to new ones. *}

datatype binOp = Eq | Le | LEq | Gr | GEq

datatype ident = Ident "String.literal" "integer option"

datatype propc = CProp ident
               | BProp binOp ident ident
               | BExpProp binOp ident integer

fun identConv :: "ident \<Rightarrow> varRef" where
  "identConv (Ident name None) = VarRef True name None"
| "identConv (Ident name (Some i)) = VarRef True name (Some (ExprConst i))"

definition ident2expr :: "ident \<Rightarrow> expr" where
  "ident2expr = ExprVarRef \<circ> identConv"

primrec binOpConv :: "binOp \<Rightarrow> PromelaDatastructures.binOp" where
  "binOpConv Eq = BinOpEq"
| "binOpConv Le = BinOpLe"
| "binOpConv LEq = BinOpLEq"
| "binOpConv Gr = BinOpGr"
| "binOpConv GEq = BinOpGEq"

primrec propConv :: "propc \<Rightarrow> expr" where
  "propConv (CProp ident) =
     ExprBinOp BinOpEq (ident2expr ident) (ExprConst 1)"
| "propConv (BProp bop il ir) =
     ExprBinOp (binOpConv bop) (ident2expr il) (ident2expr ir)"
| "propConv (BExpProp bop il ir) =
     ExprBinOp (binOpConv bop) (ident2expr il) (ExprConst ir)"

definition evalProp :: "gState \<Rightarrow> propc \<Rightarrow> bool" where
  "evalProp g p \<longleftrightarrow> exprArith g emptyProc (propConv p) \<noteq> 0"

definition printProp
  :: "(integer \<Rightarrow> char list) \<Rightarrow> propc \<Rightarrow> char list"
where
  "printProp f p = printExpr f (propConv p)"

text {* Find all propositions in an LTL formula and give each a unique ID. *}
primrec ltlPropcs' :: "propc ltlc \<Rightarrow> propc list \<Rightarrow> propc list"
where
  "ltlPropcs' LTLcTrue l = l"
| "ltlPropcs' LTLcFalse l = l"
| "ltlPropcs' (LTLcProp p) l = p#l"
| "ltlPropcs' (LTLcNeg x) l = ltlPropcs' x l"
| "ltlPropcs' (LTLcNext x) l = ltlPropcs' x l"
| "ltlPropcs' (LTLcFinal x) l = ltlPropcs' x l"
| "ltlPropcs' (LTLcGlobal x) l = ltlPropcs' x l"
| "ltlPropcs' (LTLcAnd x y) l = ltlPropcs' y (ltlPropcs' x l)"
| "ltlPropcs' (LTLcOr x y) l = ltlPropcs' y (ltlPropcs' x l)"
| "ltlPropcs' (LTLcImplies x y) l = ltlPropcs' y (ltlPropcs' x l)"
| "ltlPropcs' (LTLcIff x y) l = ltlPropcs' y (ltlPropcs' x l)"
| "ltlPropcs' (LTLcUntil x y) l = ltlPropcs' y (ltlPropcs' x l)"
| "ltlPropcs' (LTLcRelease x y) l = ltlPropcs' y (ltlPropcs' x l)"

definition ltlPropcs :: "propc ltlc \<Rightarrow> (expr,nat) lm" where
  "ltlPropcs p = (let ps = remdups (map propConv (ltlPropcs' p [])) in
                  lm.to_map (zip ps [0..<length ps]))"

definition "propcs_inv m = finite (ran (lm.\<alpha> m))"

lemma ltlPropcs_propcs_inv:
  "propcs_inv (ltlPropcs p)"
unfolding ltlPropcs_def propcs_inv_def
by (simp add: lm.correct ran_distinct)

text {* Then map the formula to talk about those IDs instead of the propositions. *}
primrec ltlConv :: "(expr, nat) lm \<Rightarrow> propc ltlc \<Rightarrow> nat ltlc"
where
  "ltlConv _ LTLcTrue = LTLcTrue"
| "ltlConv _ LTLcFalse = LTLcFalse"
| "ltlConv P (LTLcProp p) = LTLcProp (the (lm.lookup (propConv p) P))"
| "ltlConv P (LTLcNeg x) = LTLcNeg (ltlConv P x)"
| "ltlConv P (LTLcNext x) = LTLcNext (ltlConv P x)"
| "ltlConv P (LTLcFinal x) = LTLcFinal (ltlConv P x)"
| "ltlConv P (LTLcGlobal x) = LTLcGlobal (ltlConv P x)"
| "ltlConv P (LTLcAnd x y) = LTLcAnd (ltlConv P x) (ltlConv P y)"
| "ltlConv P (LTLcOr x y) = LTLcOr (ltlConv P x) (ltlConv P y)"
| "ltlConv P (LTLcImplies x y) = LTLcImplies (ltlConv P x) (ltlConv P y)"
| "ltlConv P (LTLcIff x y) = LTLcIff (ltlConv P x) (ltlConv P y)"
| "ltlConv P (LTLcUntil x y) = LTLcUntil (ltlConv P x) (ltlConv P y)"
| "ltlConv P (LTLcRelease x y) = LTLcRelease (ltlConv P x) (ltlConv P y)"

subsection {* Promela integration *}

type_synonym config = "bitset \<times> gState"
type_synonym promela = "program \<times> (expr, nat) lm"

definition lm_filter where
  "lm_filter P m =
     lm.iterate m (\<lambda>(k,v) \<sigma>.
                     if P k then bs_insert v \<sigma> else \<sigma>
                  ) (bs_empty())"

lemma lm_filter_correct:
  "bs_\<alpha> (lm_filter P m) = {v. \<exists>k. P k \<and> lm.\<alpha> m k = Some v}"
  unfolding lm_filter_def
  by (rule lm.iterate_rule_insert_P[where
           I="\<lambda>S \<sigma>. bs_\<alpha> \<sigma> = {v | k v. (k,v) \<in> S \<and> P k}"])
     (auto simp add: lm.correct map_to_set_def)

definition validPropcs :: "gState \<Rightarrow> (expr, nat) lm \<Rightarrow> bitset" where
  "validPropcs g P = lm_filter (\<lambda>e. exprArith g emptyProc e \<noteq> 0) P"

lemma validPropcs_correct:
  "bs_\<alpha> (validPropcs g P) =
     {v. \<exists>k. exprArith g emptyProc k \<noteq> 0 \<and> lm.\<alpha> P k = Some v}"
unfolding validPropcs_def
by (metis lm_filter_correct)

lemma validPropcs_ran:
  "bs_\<alpha> (validPropcs g P) \<subseteq> ran (lm.\<alpha> P)"
unfolding validPropcs_correct ran_def
by auto

text {* Now lift the successor function of Promela proper (@{const Promela.nexts}). *}

definition nexts :: "promela \<Rightarrow> config \<Rightarrow> config ls nres" where
  "nexts prom c = (
           let (prog, P) = prom in
           Promela.nexts prog (\<lambda>g. (validPropcs g P,g)) (snd c))"

lemma nexts_SPEC:
  assumes "gState_inv prog g"
  and "program_inv prog"
  shows "nexts (prog,P) (ps,g)
  \<le> SPEC (\<lambda>gs. \<forall>(ps',g') \<in> ls.\<alpha> gs.
                 (g,g') \<in> gState_progress_rel prog
               \<and> bs_\<alpha> ps' \<subseteq> ran (lm.\<alpha> P))"
using assms
unfolding nexts_def
apply (refine_rcg refine_vcg)
  apply (rule order_trans[OF Promela.nexts_SPEC[where
           I="\<lambda>(ps,g) (ps',g').
                  (g,g') \<in> gState_progress_rel prog
                \<and> ps = validPropcs g P
                \<and> bs_\<alpha> ps' \<subseteq> ran (lm.\<alpha> P)"]])
  apply (auto simp add: validPropcs_ran)
 done

subsubsection {* Handle non-termination *}

text {*
  A Promela model may include non-terminating parts. Therefore we cannot guarantee, that @{const nexts} will actually terminate.
  To avoid having to deal with this in the model checker, we fail in case of non-termination.
*}

(* TODO: Integrate such a concept into refine_transfer! *)
definition SUCCEED_abort where
  "SUCCEED_abort msg dm m = (
     case m of
       RES X \<Rightarrow> if X={} then Code.abort msg (\<lambda>_. dm) else RES X
     | _ \<Rightarrow> m)"

definition dSUCCEED_abort where
  "dSUCCEED_abort msg dm m = (
     case m of
       dSUCCEEDi \<Rightarrow> Code.abort msg (\<lambda>_. dm)
     | _ \<Rightarrow> m)"

definition ref_succeed where
  "ref_succeed m m' \<longleftrightarrow> m \<le> m' \<and> (m=SUCCEED \<longrightarrow> m'=SUCCEED)"

lemma dSUCCEED_abort_SUCCEED_abort:
   "\<lbrakk> RETURN dm' \<le> dm; ref_succeed (nres_of m') m \<rbrakk>
       \<Longrightarrow> nres_of (dSUCCEED_abort msg (dRETURN dm') (m'))
           \<le> SUCCEED_abort msg dm m"
unfolding dSUCCEED_abort_def SUCCEED_abort_def ref_succeed_def
by (auto split: dres.splits nres.splits)

schematic_lemma nexts_code_aux:
  "nres_of (?nexts prog g) \<le> nexts prog g"
  unfolding nexts_def
  by (refine_transfer Promela.nexts_code.refine the_resI)

concrete_definition nexts_code_aux for prog g uses nexts_code_aux

text {* The final successor function now incorporates:
  \begin{enumerate}
    \item @{const Promela.nexts}
    \item handling of the LTL propositions (cf. @{const PromelaLTL.nexts})
    \item handling of non-termination
  \end{enumerate} *}
definition nexts_code where
  "nexts_code prog g =
     the_res (dSUCCEED_abort (STR ''The Universe is broken!'')
                             (dRETURN (ls.sng g))
                             (nexts_code_aux prog g))"

lemma nexts_code_SPEC:
  assumes "gState_inv prog g"
  and "program_inv prog"
  and "bs_\<alpha> ps \<subseteq> ran (lm.\<alpha> P)"
  shows "(ps',g') \<in> ls.\<alpha> (nexts_code (prog,P) (ps,g))
         \<Longrightarrow> (g,g') \<in> gState_progress_rel prog \<and> bs_\<alpha> ps' \<subseteq> ran (lm.\<alpha> P)"
unfolding nexts_code_def
unfolding dSUCCEED_abort_def
using assms
using order_trans[OF nexts_code_aux.refine nexts_SPEC[OF assms(1,2)], of P ps]
by (auto split: dres.splits simp: ls.correct)

subsection {* Finiteness of the state space *}

inductive_set reachable_configs
  for P :: promela
  and c\<^sub>s :: config -- "start configuration"
where
"c\<^sub>s \<in> reachable_configs P c\<^sub>s" |
"c \<in> reachable_configs P c\<^sub>s \<Longrightarrow> x \<in> ls.\<alpha> (nexts_code P c)
                               \<Longrightarrow> x \<in> reachable_configs P c\<^sub>s"

lemmas reachable_configs_induct[case_names init step] =
  reachable_configs.induct[split_format (complete)]

definition promela_inv where
  "promela_inv prom = (case prom of (prog,P) \<Rightarrow> program_inv prog \<and> propcs_inv P)"
definition config_inv where
  "config_inv prom c = (
     case c of (ps,g) \<Rightarrow> case prom of (prog, P) \<Rightarrow>
       gState_inv prog g \<and> bs_\<alpha> ps \<subseteq> ran (lm.\<alpha> P))"

lemma reachable_configs_finite:
  assumes "promela_inv prom"
  and "config_inv prom c"
  shows "finite (reachable_configs prom c)"
proof (rule finite_subset)
  obtain prog P where [simp, intro!]: "prom = (prog,P)" by (metis prod.exhaust)
  obtain g ps where [simp, intro!]: "c = (ps,g)" by (metis prod.exhaust)

  from assms have I: "program_inv prog" "propcs_inv P"
                     "gState_inv prog g" "bs_\<alpha> ps \<subseteq> ran (lm.\<alpha> P)"
    by (simp_all add: promela_inv_def config_inv_def)

  def INV \<equiv> "\<lambda>(ps',g').  bs_\<alpha> ps' \<subseteq> ran (lm.\<alpha> P)
                       \<and> g' \<in> (gState_progress_rel prog)\<^sup>* `` {g}
                       \<and> gState_inv prog g'"

  {
    fix ps' g'
    have "(ps',g') \<in> reachable_configs (prog,P) (ps,g) \<Longrightarrow> INV (ps',g')"
    proof (induct rule: reachable_configs_induct)
      case init with I show ?case by (simp add: INV_def)
    next
      case (step ps g ps' g')
      from step(2,3) have
        "(g, g') \<in> gState_progress_rel prog \<and> bs_\<alpha> ps' \<subseteq> ran (lm.\<alpha> P)"
        using nexts_code_SPEC[OF _ `program_inv prog`, of g ps P ps' g']
        unfolding INV_def by auto
      thus ?case using step(2) unfolding INV_def by auto
    qed
   }

  thus "reachable_configs prom c \<subseteq>
        {bs. bs_\<alpha> bs \<subseteq> ran (lm.\<alpha> (snd prom))}
      \<times> (gState_progress_rel (fst prom))\<^sup>* `` {snd c}"
    unfolding INV_def by auto

  note gStates_finite[of prog g]
  moreover have "finite {bs. bs_\<alpha> bs \<subseteq> ran (lm.\<alpha> P)}"
    using [[simproc finite_Collect]]
    apply auto
    apply (intro finite_vimageI)
      apply (simp add: I[unfolded propcs_inv_def])
    apply (metis bs_eq_correct bs_eq_def injI)
    done
  ultimately
  show "finite ({bs. bs_\<alpha> bs \<subseteq> ran (lm.\<alpha> (snd prom))}
                \<times> (gState_progress_rel (fst prom))\<^sup>* `` {snd c})"
    by simp
qed

definition promela_E :: "promela \<Rightarrow> (config \<times> config) set"
  -- "Transition relation of a promela program"
where
  "promela_E prom \<equiv> {(c,c'). c' \<in> ls.\<alpha> (nexts_code prom c)}"

definition promela_is_run :: "promela \<times> config \<Rightarrow> config word \<Rightarrow> bool"
  -- "Predicate defining runs of promela programs"
where
  "promela_is_run promc r \<equiv>
      let (prom,c)=promc in
           r 0 = c
        \<and> (\<forall>i. r (Suc i) \<in> ls.\<alpha> (nexts_code prom (r i)))"

definition promela_props :: "config \<Rightarrow> nat set"
where
  [code_unfold]: "promela_props = bs_\<alpha> \<circ> fst"

definition promela_language :: "promela \<times> config \<Rightarrow> nat set word set" where
  "promela_language promc \<equiv> {promela_props \<circ> r | r. promela_is_run promc r}"

text {*
Prepare the AST for the Promela interpreter.

This takes as arguments:
  \begin{itemize}
   \item Function to return the ltl formula $\phi$. This function gets passed a lookup onto the LTLs defined in the code.
   \item AST of the promela code
  \end{itemize}

Returns:
  \begin{itemize}
   \item Program representation (@{typ promela})
   \item Initial configuration  (@{typ config})
   \item LTL representation to use (@{typ "nat ltlc"})
  \end{itemize}
*}

definition prepare
  :: "((String.literal \<Rightarrow> String.literal option) \<Rightarrow> propc ltlc)
      \<Rightarrow> AST.module list
      \<Rightarrow> (promela \<times> config) \<times> nat ltlc"
where
  "prepare ltlChoose ast = (
      let
         _ = PromelaStatistics.start();
         eAst = preprocess ast;
         (ltls,g\<^sub>0,prog) = Promela.setUp eAst;
         \<phi> = ltlChoose (\<lambda>l. lm.lookup l ltls);
         P = ltlPropcs \<phi>;
         \<phi>\<^sub>c = ltlConv P \<phi>;
         ps\<^sub>0 = validPropcs g\<^sub>0 P;
         _ = PromelaStatistics.stop_timer()
      in
      (((prog, P), (ps\<^sub>0, g\<^sub>0)), \<phi>\<^sub>c))"

lemma prepare_correct':
  assumes "prepare ltlChoose ast = (((prog,P), (ps\<^sub>0, g\<^sub>0)), \<phi>\<^sub>c)"
  shows "program_inv prog"
    and "propcs_inv P"
    and "bs_\<alpha> ps\<^sub>0 \<subseteq> ran (lm.\<alpha> P)"
    and "gState_inv prog g\<^sub>0"
using assms setUp_program_inv setUp_gState_inv
      ltlPropcs_propcs_inv validPropcs_ran[of g\<^sub>0 P]
unfolding prepare_def
by (auto split: prod.splits)

lemma prepare_connect:
  assumes "prepare ltlChoose ast = ((prom, c\<^sub>0), \<phi>\<^sub>c)"
  shows "promela_inv prom" and "config_inv prom c\<^sub>0"
using prepare_correct'[of ltlChoose ast] assms
  apply (force simp add: promela_inv_def split: prod.splits)
using  prepare_correct'[of ltlChoose ast] assms
  apply (force simp add: config_inv_def split: prod.splits)
  done

definition printConfig
  :: "(integer \<Rightarrow> string) \<Rightarrow> promela \<Rightarrow> config option \<Rightarrow> config \<Rightarrow> string"
where
  "printConfig f prom c\<^sub>0 c\<^sub>1 = Promela.printConfig f (fst prom) (map_option snd c\<^sub>0) (snd c\<^sub>1)"

export_code nexts_code printConfig prepare checking SML

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