src/HOL/MicroJava/J/Example.thy

Adapted to new inductive definition package.

(*  Title:      HOL/MicroJava/J/Example.thy
    ID:         $Id$
    Author:     David von Oheimb
    Copyright   1999 Technische Universitaet Muenchen
*)

header {* \isaheader{Example MicroJava Program} *}

theory Example imports SystemClasses Eval begin

text {* 
The following example MicroJava program includes:
 class declarations with inheritance, hiding of fields, and overriding of
  methods (with refined result type), 
 instance creation, local assignment, sequential composition,
 method call with dynamic binding, literal values,
 expression statement, local access, type cast, field assignment (in part), 
 skip.

\begin{verbatim}
class Base {
  boolean vee;
  Base foo(Base x) {return x;}
}

class Ext extends Base {
  int vee;
  Ext foo(Base x) {((Ext)x).vee=1; return null;}
}

class Example {
  public static void main (String args[]) {
    Base e=new Ext();
    e.foo(null);
  }
}
\end{verbatim}
*}

datatype cnam_ = Base_ | Ext_
datatype vnam_ = vee_ | x_ | e_

consts
  cnam_ :: "cnam_ => cname"
  vnam_ :: "vnam_ => vnam"

-- "@{text cnam_} and @{text vnam_} are intended to be isomorphic 
    to @{text cnam} and @{text vnam}"
axioms 
  inj_cnam_:  "(cnam_ x = cnam_ y) = (x = y)"
  inj_vnam_:  "(vnam_ x = vnam_ y) = (x = y)"

  surj_cnam_: "\<exists>m. n = cnam_ m"
  surj_vnam_: "\<exists>m. n = vnam_ m"

declare inj_cnam_ [simp] inj_vnam_ [simp]

syntax
  Base :: cname
  Ext  :: cname
  vee  :: vname
  x    :: vname
  e    :: vname

translations
  "Base" == "cnam_ Base_"
  "Ext"  == "cnam_ Ext_"
  "vee"  == "VName (vnam_ vee_)"
  "x"  == "VName (vnam_ x_)"
  "e"  == "VName (vnam_ e_)"

axioms
  Base_not_Object: "Base \<noteq> Object"
  Ext_not_Object:  "Ext  \<noteq> Object"
  Base_not_Xcpt:   "Base \<noteq> Xcpt z"
  Ext_not_Xcpt:    "Ext  \<noteq> Xcpt z"
  e_not_This:      "e \<noteq> This"  

declare Base_not_Object [simp] Ext_not_Object [simp]
declare Base_not_Xcpt [simp] Ext_not_Xcpt [simp]
declare e_not_This [simp]
declare Base_not_Object [symmetric, simp]
declare Ext_not_Object  [symmetric, simp]
declare Base_not_Xcpt [symmetric, simp]
declare Ext_not_Xcpt  [symmetric, simp]

consts
  foo_Base::  java_mb
  foo_Ext ::  java_mb
  BaseC   :: "java_mb cdecl"
  ExtC    :: "java_mb cdecl"
  test    ::  stmt
  foo   ::  mname
  a   ::  loc
  b       ::  loc

defs
  foo_Base_def:"foo_Base == ([x],[],Skip,LAcc x)"
  BaseC_def:"BaseC == (Base, (Object, 
           [(vee, PrimT Boolean)], 
           [((foo,[Class Base]),Class Base,foo_Base)]))"
  foo_Ext_def:"foo_Ext == ([x],[],Expr( {Ext}Cast Ext
               (LAcc x)..vee:=Lit (Intg Numeral1)),
           Lit Null)"
  ExtC_def: "ExtC  == (Ext,  (Base  , 
           [(vee, PrimT Integer)], 
           [((foo,[Class Base]),Class Ext,foo_Ext)]))"

  test_def:"test == Expr(e::=NewC Ext);; 
                    Expr({Base}LAcc e..foo({[Class Base]}[Lit Null]))"


abbreviation
  NP  :: xcpt where
  "NP == NullPointer"

abbreviation
  tprg  ::"java_mb prog" where
  "tprg == [ObjectC, BaseC, ExtC, ClassCastC, NullPointerC, OutOfMemoryC]"

abbreviation
  obj1  :: obj where
  "obj1 == (Ext, empty((vee, Base)\<mapsto>Bool False) ((vee, Ext )\<mapsto>Intg 0))"

abbreviation "s0 == Norm    (empty, empty)"
abbreviation "s1 == Norm    (empty(a\<mapsto>obj1),empty(e\<mapsto>Addr a))"
abbreviation "s2 == Norm    (empty(a\<mapsto>obj1),empty(x\<mapsto>Null)(This\<mapsto>Addr a))"
abbreviation "s3 == (Some NP, empty(a\<mapsto>obj1),empty(e\<mapsto>Addr a))"

ML {* bind_thm ("map_of_Cons", hd (tl (thms "map_of.simps"))) *}
lemma map_of_Cons1 [simp]: "map_of ((aa,bb)#ps) aa = Some bb"
apply (simp (no_asm))
done
lemma map_of_Cons2 [simp]: "aa\<noteq>k ==> map_of ((k,bb)#ps) aa = map_of ps aa"
apply (simp (no_asm_simp))
done
declare map_of_Cons [simp del] -- "sic!"

lemma class_tprg_Object [simp]: "class tprg Object = Some (arbitrary, [], [])"
apply (unfold ObjectC_def class_def)
apply (simp (no_asm))
done

lemma class_tprg_NP [simp]: "class tprg (Xcpt NP) = Some (Object, [], [])"
apply (unfold ObjectC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def BaseC_def ExtC_def class_def)
apply (simp (no_asm))
done

lemma class_tprg_OM [simp]: "class tprg (Xcpt OutOfMemory) = Some (Object, [], [])"
apply (unfold ObjectC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def BaseC_def ExtC_def class_def)
apply (simp (no_asm))
done

lemma class_tprg_CC [simp]: "class tprg (Xcpt ClassCast) = Some (Object, [], [])"
apply (unfold ObjectC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def BaseC_def ExtC_def class_def)
apply (simp (no_asm))
done

lemma class_tprg_Base [simp]: 
"class tprg Base = Some (Object,  
    [(vee, PrimT Boolean)],  
          [((foo, [Class Base]), Class Base, foo_Base)])"
apply (unfold ObjectC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def BaseC_def ExtC_def class_def)
apply (simp (no_asm))
done

lemma class_tprg_Ext [simp]: 
"class tprg Ext = Some (Base,  
    [(vee, PrimT Integer)],  
          [((foo, [Class Base]), Class Ext, foo_Ext)])"
apply (unfold ObjectC_def BaseC_def ExtC_def class_def)
apply (simp (no_asm))
done

lemma not_Object_subcls [elim!]: "(subcls1 tprg)^++ Object C ==> R"
apply (auto dest!: tranclD' subcls1D)
done

lemma subcls_ObjectD [dest!]: "tprg\<turnstile>Object\<preceq>C C ==> C = Object"
apply (erule rtrancl_induct')
apply  auto
apply (drule subcls1D)
apply auto
done

lemma not_Base_subcls_Ext [elim!]: "(subcls1 tprg)^++ Base Ext ==> R"
apply (auto dest!: tranclD' subcls1D)
done

lemma class_tprgD: 
"class tprg C = Some z ==> C=Object \<or> C=Base \<or> C=Ext \<or> C=Xcpt NP \<or> C=Xcpt ClassCast \<or> C=Xcpt OutOfMemory"
apply (unfold ObjectC_def ClassCastC_def NullPointerC_def OutOfMemoryC_def BaseC_def ExtC_def class_def)
apply (auto split add: split_if_asm simp add: map_of_Cons)
done

lemma not_class_subcls_class [elim!]: "(subcls1 tprg)^++ C C ==> R"
apply (auto dest!: tranclD' subcls1D)
apply (frule class_tprgD)
apply (auto dest!:)
apply (drule rtranclD')
apply auto
done

lemma unique_classes: "unique tprg"
apply (simp (no_asm) add: ObjectC_def BaseC_def ExtC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def)
done

lemmas subcls_direct = subcls1I [THEN r_into_rtrancl' [where r="subcls1 G"], standard]

lemma Ext_subcls_Base [simp]: "tprg\<turnstile>Ext\<preceq>C Base"
apply (rule subcls_direct)
apply auto
done

lemma Ext_widen_Base [simp]: "tprg\<turnstile>Class Ext\<preceq> Class Base"
apply (rule widen.subcls)
apply (simp (no_asm))
done

declare ty_expr_ty_exprs_wt_stmt.intros [intro!]

lemma acyclic_subcls1_: "acyclicP (subcls1 tprg)"
apply (rule acyclicI [to_pred])
apply safe
done

lemmas wf_subcls1_ = acyclic_subcls1_ [THEN finite_subcls1 [THEN finite_acyclic_wf_converse [to_pred]]]

lemmas fields_rec_ = wf_subcls1_ [THEN [2] fields_rec_lemma]

lemma fields_Object [simp]: "fields (tprg, Object) = []"
apply (subst fields_rec_)
apply   auto
done

declare is_class_def [simp]

lemma fields_Base [simp]: "fields (tprg,Base) = [((vee, Base), PrimT Boolean)]"
apply (subst fields_rec_)
apply   auto
done

lemma fields_Ext [simp]: 
  "fields (tprg, Ext)  = [((vee, Ext ), PrimT Integer)] @ fields (tprg, Base)"
apply (rule trans)
apply  (rule fields_rec_)
apply   auto
done

lemmas method_rec_ = wf_subcls1_ [THEN [2] method_rec_lemma]

lemma method_Object [simp]: "method (tprg,Object) = map_of []"
apply (subst method_rec_)
apply  auto
done

lemma method_Base [simp]: "method (tprg, Base) = map_of  
  [((foo, [Class Base]), Base, (Class Base, foo_Base))]"
apply (rule trans)
apply  (rule method_rec_)
apply  auto
done

lemma method_Ext [simp]: "method (tprg, Ext) = (method (tprg, Base) ++ map_of  
  [((foo, [Class Base]), Ext , (Class Ext, foo_Ext))])"
apply (rule trans)
apply  (rule method_rec_)
apply  auto
done

lemma wf_foo_Base: 
"wf_mdecl wf_java_mdecl tprg Base ((foo, [Class Base]), (Class Base, foo_Base))"
apply (unfold wf_mdecl_def wf_mhead_def wf_java_mdecl_def foo_Base_def)
apply auto
done

lemma wf_foo_Ext: 
"wf_mdecl wf_java_mdecl tprg Ext ((foo, [Class Base]), (Class Ext, foo_Ext))"
apply (unfold wf_mdecl_def wf_mhead_def wf_java_mdecl_def foo_Ext_def)
apply auto
apply  (rule ty_expr_ty_exprs_wt_stmt.Cast)
prefer 2
apply   (simp)
apply   (rule_tac [2] cast.subcls)
apply   (unfold field_def)
apply   auto
done

lemma wf_ObjectC: 
"ws_cdecl tprg ObjectC \<and> 
  wf_cdecl_mdecl wf_java_mdecl tprg ObjectC \<and> wf_mrT tprg ObjectC"
apply (unfold ws_cdecl_def wf_cdecl_mdecl_def 
  wf_mrT_def wf_fdecl_def ObjectC_def)
apply (simp (no_asm))
done

lemma wf_NP:
"ws_cdecl tprg NullPointerC \<and>
  wf_cdecl_mdecl wf_java_mdecl tprg NullPointerC \<and> wf_mrT tprg NullPointerC"
apply (unfold ws_cdecl_def wf_cdecl_mdecl_def 
  wf_mrT_def wf_fdecl_def NullPointerC_def)
apply (simp add: class_def)
apply (fold NullPointerC_def class_def)
apply auto
done

lemma wf_OM:
"ws_cdecl tprg OutOfMemoryC \<and>
  wf_cdecl_mdecl wf_java_mdecl tprg OutOfMemoryC \<and> wf_mrT tprg OutOfMemoryC"
apply (unfold ws_cdecl_def wf_cdecl_mdecl_def 
  wf_mrT_def wf_fdecl_def OutOfMemoryC_def)
apply (simp add: class_def)
apply (fold OutOfMemoryC_def class_def)
apply auto
done

lemma wf_CC:
"ws_cdecl tprg ClassCastC \<and>
  wf_cdecl_mdecl wf_java_mdecl tprg ClassCastC \<and> wf_mrT tprg ClassCastC"
apply (unfold ws_cdecl_def wf_cdecl_mdecl_def 
  wf_mrT_def wf_fdecl_def ClassCastC_def)
apply (simp add: class_def)
apply (fold ClassCastC_def class_def)
apply auto
done

lemma wf_BaseC: 
"ws_cdecl tprg BaseC \<and>
  wf_cdecl_mdecl wf_java_mdecl tprg BaseC \<and> wf_mrT tprg BaseC"
apply (unfold ws_cdecl_def wf_cdecl_mdecl_def
  wf_mrT_def wf_fdecl_def BaseC_def)
apply (simp (no_asm))
apply (fold BaseC_def)
apply (rule mp) defer apply (rule wf_foo_Base)
apply (auto simp add: wf_mdecl_def)
done


lemma wf_ExtC: 
"ws_cdecl tprg ExtC \<and>
  wf_cdecl_mdecl wf_java_mdecl tprg ExtC \<and> wf_mrT tprg ExtC"
apply (unfold ws_cdecl_def wf_cdecl_mdecl_def
  wf_mrT_def wf_fdecl_def ExtC_def)
apply (simp (no_asm))
apply (fold ExtC_def)
apply (rule mp) defer apply (rule wf_foo_Ext)
apply (auto simp add: wf_mdecl_def)
apply (drule rtranclD')
apply auto
done


lemma [simp]: "fst ObjectC = Object" by (simp add: ObjectC_def)

lemma wf_tprg: 
"wf_prog wf_java_mdecl tprg"
apply (unfold wf_prog_def ws_prog_def Let_def)
apply (simp add: wf_ObjectC wf_BaseC wf_ExtC wf_NP wf_OM wf_CC unique_classes)
apply (rule wf_syscls)
apply (simp add: SystemClasses_def)
done

lemma appl_methds_foo_Base: 
"appl_methds tprg Base (foo, [NT]) =  
  {((Class Base, Class Base), [Class Base])}"
apply (unfold appl_methds_def)
apply (simp (no_asm))
done

lemma max_spec_foo_Base: "max_spec tprg Base (foo, [NT]) =  
  {((Class Base, Class Base), [Class Base])}"
apply (unfold max_spec_def)
apply (auto simp add: appl_methds_foo_Base)
done

ML {* fun t thm = resolve_tac (thms "ty_expr_ty_exprs_wt_stmt.intros") 1 thm *}
lemma wt_test: "(tprg, empty(e\<mapsto>Class Base))\<turnstile>  
  Expr(e::=NewC Ext);; Expr({Base}LAcc e..foo({?pTs'}[Lit Null]))\<surd>"
apply (tactic t) -- ";;"
apply  (tactic t) -- "Expr"
apply  (tactic t) -- "LAss"
apply    simp -- {* @{text "e \<noteq> This"} *}
apply    (tactic t) -- "LAcc"
apply     (simp (no_asm))
apply    (simp (no_asm))
apply   (tactic t) -- "NewC"
apply   (simp (no_asm))
apply  (simp (no_asm))
apply (tactic t) -- "Expr"
apply (tactic t) -- "Call"
apply   (tactic t) -- "LAcc"
apply    (simp (no_asm))
apply   (simp (no_asm))
apply  (tactic t) -- "Cons"
apply   (tactic t) -- "Lit"
apply   (simp (no_asm))
apply  (tactic t) -- "Nil"
apply (simp (no_asm))
apply (rule max_spec_foo_Base)
done

ML {* fun e t = resolve_tac (thm "NewCI"::thms "eval_evals_exec.intros") 1 t *}

declare split_if [split del]
declare init_vars_def [simp] c_hupd_def [simp] cast_ok_def [simp]
lemma exec_test: 
" [|new_Addr (heap (snd s0)) = (a, None)|] ==>  
  tprg\<turnstile>s0 -test-> ?s"
apply (unfold test_def)
-- "?s = s3 "
apply (tactic e) -- ";;"
apply  (tactic e) -- "Expr"
apply  (tactic e) -- "LAss"
apply   (tactic e) -- "NewC"
apply    force
apply   force
apply  (simp (no_asm))
apply (erule thin_rl)
apply (tactic e) -- "Expr"
apply (tactic e) -- "Call"
apply       (tactic e) -- "LAcc"
apply      force
apply     (tactic e) -- "Cons"
apply      (tactic e) -- "Lit"
apply     (tactic e) -- "Nil"
apply    (simp (no_asm))
apply   (force simp add: foo_Ext_def)
apply  (simp (no_asm))
apply  (tactic e) -- "Expr"
apply  (tactic e) -- "FAss"
apply       (tactic e) -- "Cast"
apply        (tactic e) -- "LAcc"
apply       (simp (no_asm))
apply      (simp (no_asm))
apply     (simp (no_asm))
apply     (tactic e) -- "XcptE"
apply    (simp (no_asm))
apply   (rule surjective_pairing [THEN sym, THEN[2]trans], subst Pair_eq, force)
apply  (simp (no_asm))
apply (simp (no_asm))
apply (tactic e) -- "XcptE"
done

end