(*
    File:        LBeta.thy
    Time-stamp:  <2016-01-02T15:01:15Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory LBeta imports LAlpha begin

definition LBeta1 :: "[i, i]=>o" where
"LBeta1(M, N) == M: LTerm &
    (EX u: LSub(M). EX l x A B. u = <l, LApp(LLam(x, A), B)> &
        LFreeForIn(B, x, A) &
        N = LOccinv(Occ_Graft1(LOcc(M), l, LOcc(Lsubst(A, x, B)))))"

definition LBV :: "i=>i" where
"LBV(M) == {x: LVariable. EX l. <l, TLLam(x)>: LOcc(M)}"

(** LBeta1 **)
lemma LBeta1_type1:
  "LBeta1(M, N) ==> M: LTerm"
apply (unfold LBeta1_def)
apply (erule conjunct1)
done

lemma LBeta1_type2:
  "LBeta1(M, N) ==> N: LTerm"
apply (unfold LBeta1_def)
apply safe
apply (rule LTerm_def_Occinv_type)
apply (rule Occ_Graft1_in_Occ_range)
apply (erule_tac [2] LFreeForInE)
apply (assumption | rule LOcc_in_Occ_range Lsubst_type)+
apply (unfold LSub_def)
apply (erule RepFunE)
apply (frule LOcc_domain [THEN subsetD])
apply assumption
apply (erule SigmaE)
apply hypsubst
apply simp
apply (erule domainI)
done

lemmas LTerm_def_Sub_rec = def_Sub_rec [OF
  LTerm_Occ_cons_cond LTerm_Occ_ind_cond LOccinv_def
  LSub_def LTerm_Term_cons_inj_cond]

lemmas LTerm_def_Occinv_Occ = def_Occinv_Occ [OF
  LTerm_Occ_cons_cond LTerm_Occ_ind_cond LOccinv_def]

lemma LBeta1_baseI:
  assumes major: "LFreeForIn(B, x, A)"
  shows "LBeta1(LApp(LLam(x, A), B), Lsubst(A, x, B))"
apply (unfold LBeta1_def)
apply (rule major [THEN LFreeForInE])
apply (assumption | rule conjI bexI exI refl major LTerm.intros)+
prefer 2
apply (simp add: LTerm_def_Sub_rec LTerm_cons_eqns_sym)
apply (rule Occ_consI1)
apply (simp add: Occ_Graft1_Nil LTerm_def_Occinv_Occ)
done

lemmas LTerm_def_Sub_type = def_Sub_type [OF
  LTerm_Occ_cons_cond LTerm_Occ_ind_cond LOccinv_def
  LSub_def]

lemmas LTerm_def_Occinv2 = def_Occinv2 [OF
  LTerm_Occ_cons_cond LTerm_Occ_ind_cond LOccinv_def]

lemma LBeta1_LLamI:
  "[| LBeta1(M, M');  x: LVariable |] ==> LBeta1(LLam(x, M), LLam(x, M'))"
apply (unfold LBeta1_def)
apply safe
apply (assumption | rule bexI conjI refl exI LTerm.intros)+
prefer 2
apply (simp add: LTerm_def_Sub_rec LTerm_cons_eqns_sym)
apply (rule_tac a="0" in Occ_consI2)
apply simp
apply (simp add: LTerm_cons_eqns)
apply (subgoal_tac "A: LTerm" "B: LTerm" "xa: LVariable" "l: list(nat)"
        "Occ_Graft1(LOcc(LLam(x, M)), Cons(0, l), LOcc(Lsubst(A, xa, B)))
                  : Occ_range(LTag, LArity)")
defer 1
apply (rule Occ_Graft1_in_Occ_range)
apply (assumption | rule LOcc_in_Occ_range Lsubst_type LTerm.intros)+
apply (simp add: LTerm_Occ_Term_cons LTerm_cons_eqns_sym)
apply (simp only: LSub_def)
apply (erule RepFunE)
apply (frule LOcc_domain [THEN subsetD])
apply assumption
apply (erule SigmaE)
apply hypsubst
apply simp
apply (rule Occ_consI2 [THEN domainI])
apply simp
apply simp
apply (erule LTerm_def_Sub_type [THEN subsetD, THEN SigmaD1])
apply assumption
apply (erule LFreeForInE, assumption)+
apply (simp add: LTerm_Occ_Term_cons LTerm_cons_eqns_sym)
apply (rule Occ_Graft1_Occ_cons_Cons [THEN ssubst])
apply (simp_all add: LTerm_cons_eqns_sym)
apply (rule LTerm_def_Occinv2 [THEN trans, THEN sym])
apply (rule_tac P="%x. x: Occ_range(LTag, LArity)" in subst)
prefer 2 apply assumption
apply (rule Occ_Graft1_Occ_cons_Cons [THEN ssubst])
apply (simp_all add: LTerm_def_Occinv_Occ)
apply (assumption | rule Occ_Graft1_domain LOcc_domain Lsubst_type
        PowI list.intros LTag.intros)+
done

lemma LBeta1_LAppI1:
  "[| LBeta1(A, A');  B: LTerm |] ==> LBeta1(LApp(A, B), LApp(A', B))"
apply (unfold LBeta1_def)
apply safe
apply (assumption | rule bexI conjI refl exI LTerm.intros)+
prefer 2
apply (simp add: LTerm_def_Sub_rec LTerm_cons_eqns_sym)
apply (rule_tac a="0" in Occ_consI2)
apply simp
apply simp
apply (subgoal_tac "Aa: LTerm" "Ba: LTerm" "x: LVariable" "l: list(nat)"
         "Occ_Graft1(LOcc(LApp(A, B)), Cons(0, l), LOcc(Lsubst(Aa, x, Ba)))
                 : Occ_range(LTag, LArity)")
defer 1
apply (rule Occ_Graft1_in_Occ_range)
apply (assumption | rule LOcc_in_Occ_range Lsubst_type LTerm.intros)+
apply (simp add: LTerm_Occ_Term_cons LTerm_cons_eqns_sym)
apply (simp only: LSub_def)
apply (erule RepFunE)
apply (rule LOcc_domain [THEN subsetD, THEN SigmaE])
prefer 2 apply assumption
apply assumption
apply hypsubst
apply simp
apply (rule Occ_consI2 [THEN domainI])
apply simp
apply simp
apply (rule LTerm_def_Sub_type [THEN subsetD, THEN SigmaD1])
prefer 2 apply assumption
apply assumption
apply (erule LFreeForInE, assumption)+
apply (simp add: LTerm_Occ_Term_cons LTerm_cons_eqns_sym)
apply (rule Occ_Graft1_Occ_cons_Cons [THEN ssubst])
apply (simp_all add: LTerm_cons_eqns_sym)
apply (rule LTerm_def_Occinv2 [THEN trans, THEN sym])
apply (rule_tac P="%x. x: Occ_range(LTag, LArity)" in subst)
prefer 2 apply assumption
apply (rule Occ_Graft1_Occ_cons_Cons [THEN ssubst])
apply (simp_all add: LTerm_def_Occinv_Occ)
apply (assumption | rule conjI Occ_Graft1_domain LOcc_domain Lsubst_type
         PowI list.intros LTag.intros)+
done

lemma LBeta1_LAppI2:
  "[| LBeta1(B, B');  A: LTerm |] ==> LBeta1(LApp(A, B), LApp(A, B'))"
apply (unfold LBeta1_def)
apply safe
apply (assumption | rule bexI conjI refl exI LTerm.intros)+
prefer 2
apply (simp add: LTerm_def_Sub_rec LTerm_cons_eqns_sym)
apply (rule_tac a="1" in Occ_consI2)
apply simp
apply simp
apply (subgoal_tac "Aa: LTerm" "Ba: LTerm" "x: LVariable" "l: list(nat)"
         "Occ_Graft1(LOcc(LApp(A, B)), Cons(1, l), LOcc(Lsubst(Aa, x, Ba)))
                 : Occ_range(LTag, LArity)")
defer 1
apply (rule Occ_Graft1_in_Occ_range)
apply (assumption | rule LOcc_in_Occ_range Lsubst_type LTerm.intros)+
apply (simp add: LTerm_Occ_Term_cons LTerm_cons_eqns_sym)
apply (simp only: LSub_def)
apply (erule RepFunE)
apply (rule LOcc_domain [THEN subsetD, THEN SigmaE])
prefer 2 apply assumption
apply assumption
apply hypsubst
apply simp
apply (rule Occ_consI2 [THEN domainI])
apply simp
apply simp
apply (rule LTerm_def_Sub_type [THEN subsetD, THEN SigmaD1])
prefer 2 apply assumption
apply assumption
apply (erule LFreeForInE, assumption)+
apply (simp add: LTerm_Occ_Term_cons LTerm_cons_eqns_sym)
apply (rule Occ_Graft1_Occ_cons_Cons [THEN ssubst])
apply (simp_all add: LTerm_cons_eqns_sym)
apply (rule LTerm_def_Occinv2 [THEN trans, THEN sym])
apply (rule_tac P="%x. x: Occ_range(LTag, LArity)" in subst)
prefer 2 apply assumption
apply (rule Occ_Graft1_Occ_cons_Cons [THEN ssubst])
apply (simp_all add: LTerm_def_Occinv_Occ)
apply (assumption | rule conjI Occ_Graft1_domain LOcc_domain Lsubst_type
         PowI list.intros LTag.intros)+
done

lemma LBeta1_LVarE:
  "LBeta1(LVar(x), N) ==> R"
apply (unfold LBeta1_def)
apply (safe elim!: LTerm_typeEs)
apply (rotate_tac 2)
apply (simp add: LTerm_def_Sub_rec LTerm_cons_eqns_sym)
apply (simp only: LTerm_cons_eqns)
apply (erule Occ_consE2)
prefer 3 apply simp
apply (safe elim!: LTerm.free_elims)
done

lemma LBeta1_LLamE:
  assumes major: "LBeta1(LLam(x, M), N)"
  and prem:
   "!!N'. [| N = LLam(x, N'); LBeta1(M, N'); x: LVariable |] ==> R"
  shows "R"
apply (insert major)
apply (unfold LBeta1_def)
apply (erule_tac conjE bexE exE LTerm_typeEs)+
apply (rotate_tac 4)
apply hypsubst
apply (simp add: LTerm_def_Sub_rec LTerm_Occ_Term_cons
        LTerm_cons_eqns_sym)
apply (simp only: LTerm_cons_eqns)
apply (erule Occ_consE)
apply (blast elim!: LTerm.free_elims)
apply simp
apply (erule succE)
apply (erule_tac [2] emptyE)
apply (erule conjE)
apply hypsubst
apply simp

apply (rule prem [unfolded LBeta1_def])
apply (erule trans)
defer 1
apply (assumption | rule conjI refl bexI exI)+
apply (rule Occ_Graft1_Occ_cons_Cons [THEN ssubst])
apply simp_all
apply (rule LTerm_def_Sub_type [THEN subsetD, THEN SigmaD1])
prefer 2 apply assumption
apply assumption
apply (subgoal_tac "A: LTerm" "xa: LVariable" "B: LTerm"
         "Occ_Graft1(LOcc(M), m, LOcc(Lsubst(A, xa, B))):
             Occ_range(LTag, LArity)"
         "LOccinv(Occ_Graft1(LOcc(M), m, LOcc(Lsubst(A, xa, B)))):
                  LTerm")
defer 1
apply (rule_tac [2] Occ_Graft1_in_Occ_range)
apply (assumption | rule LOcc_in_Occ_range Lsubst_type
         LTerm_def_Occinv_type LTerm.intros)+
apply (simp only: LSub_def)
apply (erule RepFunE)
apply (rule LOcc_domain [THEN subsetD, THEN SigmaE])
prefer 2
apply assumption
prefer 2
apply hypsubst
apply simp
apply (erule domainI)
apply assumption
apply (erule LFreeForInE, assumption)+
apply (rule trans)
apply (rule_tac [2] LTerm_def_Occinv_Occ)
apply (rule_tac f="LOccinv" in function_apply_eq)
apply (simp_all add: LTerm_Occ_Term_cons LTerm_def_Occ_Occinv
         LTerm_cons_eqns_sym)
done

lemma LBeta1_LAppE:
  assumes major: "LBeta1(LApp(A, B), N)"
  and prem1:
     "!!x N'. [| A = LLam(x, N'); N = Lsubst(N', x, B);
              LFreeForIn(B, x, N') |] ==> R"
  and prem2:
     "!!A'. [| N = LApp(A',B); LBeta1(A, A'); B: LTerm |] ==> R"
  and prem3:
     "!!B'. [| N = LApp(A, B'); LBeta1(B, B'); A: LTerm |] ==> R"
  shows "R"
apply (insert major)
apply (unfold LBeta1_def)
apply (erule conjE bexE exE LTerm_typeEs)+
apply (rotate_tac 4)
apply hypsubst
apply (simp add: LTerm_def_Sub_rec LTerm_Occ_Term_cons
         LTerm_cons_eqns_sym)
apply (simp only: LTerm_cons_eqns)
apply (erule Occ_consE)
prefer 2
apply simp
defer 1
apply (erule_tac [2] succE)
apply (erule_tac [3] succE)
apply (rule_tac [3] prem2)
apply (rule_tac [2] prem3)
apply (rule_tac [1] prem1)
apply (unfold LBeta1_def)
apply (safe elim!: LTerm.free_elims LTerm_typeEs)
apply (rule refl)
apply (rule Occ_Graft1_Nil [THEN ssubst])
apply (rule Occ_cons_type)
apply (rule LTag.intros)
apply (assumption | rule Occ_cons_type LOcc_domain PowI
        Lsubst_type list.intros LTerm.intros)+
apply (simp add: LTerm_def_Occinv_Occ)
apply assumption
apply simp_all
prefer 2 apply (assumption | rule bexI exI conjI refl)+
prefer 3 apply (assumption | rule bexI exI conjI refl)+
apply (rule_tac [2] Occ_Graft1_Occ_cons_Cons [THEN ssubst])
apply (rule_tac [1] Occ_Graft1_Occ_cons_Cons [THEN ssubst])
apply simp_all
apply (rule LTerm_def_Sub_type [THEN subsetD, THEN SigmaD1])
prefer 2 apply assumption
apply assumption
apply (rule_tac [2] LTerm_def_Sub_type [THEN subsetD, THEN SigmaD1])
prefer 3 apply assumption
prefer 2 apply assumption

apply (subgoal_tac [2] "Aa: LTerm" "x: LVariable" "Ba: LTerm"
         "Occ_Graft1(LOcc(A), m, LOcc(Lsubst(Aa, x, Ba))):
             Occ_range(LTag, LArity)"
         "LOccinv(Occ_Graft1(LOcc(A), m, LOcc(Lsubst(Aa, x, Ba)))):
              LTerm")
apply (subgoal_tac [1] "Aa: LTerm" "x: LVariable" "Ba: LTerm"
         "Occ_Graft1(LOcc(B), m, LOcc(Lsubst(Aa, x, Ba))):
             Occ_range(LTag, LArity)"
         "LOccinv(Occ_Graft1(LOcc(B), m, LOcc(Lsubst(Aa, x, Ba)))):
              LTerm")
defer 1
apply (rule_tac [2] Occ_Graft1_in_Occ_range)
apply (assumption | rule LOcc_in_Occ_range Lsubst_type
         LTerm_def_Occinv_type LTerm.intros)+
apply (simp only: LSub_def)
apply (erule RepFunE)
apply (rule LOcc_domain [THEN subsetD, THEN SigmaE])
prefer 2 apply assumption
apply assumption
apply hypsubst
apply simp
apply (erule domainI)
apply (erule LFreeForInE, assumption)+
defer 1
apply (rule_tac [2] Occ_Graft1_in_Occ_range)
apply (assumption | rule LOcc_in_Occ_range Lsubst_type
         LTerm_def_Occinv_type LTerm.intros)+
apply (simp only: LSub_def)
apply (erule RepFunE)
apply (rule LOcc_domain [THEN subsetD, THEN SigmaE])
prefer 2 apply assumption
apply assumption
apply hypsubst
apply simp
apply (erule domainI)
apply (erule LFreeForInE, assumption)+
apply (rule_tac [2] trans)
apply (rule_tac [3] LTerm_def_Occinv_Occ)
apply (rule_tac [2] f="LOccinv" in function_apply_eq)
apply (rule trans)
apply (rule_tac [2] LTerm_def_Occinv_Occ)
apply (rule_tac f="LOccinv" in function_apply_eq)
apply (simp_all add: LTerm_Occ_Term_cons LTerm_def_Occ_Occinv
         LTerm_cons_eqns_sym)
done

lemmas LBeta1_LTermEs = LBeta1_LVarE LBeta1_LLamE LBeta1_LAppE

lemma LBeta1_redex_lemma:
  assumes infv: "Infinite(LVariable)"
  and major: "M: LTerm"
  and prem: "<l, LApp(LLam(x, A),B)>: LSub(M)"
  shows "EX N A'. LAlpha(M, N) & <l, LApp(LLam(x, A'), B)>: LSub(N) &
              LFreeForIn(B, x, A')"
apply (rule prem [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule major [THEN LTerm.induct])
apply (simp_all add: LTerm_def_Sub_rec LTerm_cons_eqns_sym)
apply (simp_all only: LTerm_cons_eqns)
apply (rule_tac [3] impI [THEN allI], erule_tac [3] Occ_consE2)
apply (rule_tac [2] impI [THEN allI], erule_tac [2] Occ_consE2)
apply (rule_tac [1] impI [THEN allI], erule_tac [1] Occ_consE2)
prefer 4
prefer 7
apply (assumption | rule LTerm_def_Sub_type [THEN PowI]
        list.intros)+
apply (simp_all add: le_succ_iff)
apply (safe elim!: LTerm.free_elims LTerm_typeEs)
apply simp_all
apply (rule_tac [2] infv [THEN Infinite_LVariable_LAlpha_lemma, THEN bexE])
apply (erule_tac [5] conjE)
apply (rule_tac [5] exI)
apply (rule_tac [5] conjI)
apply (rule_tac [6] exI)
apply (rule_tac [6] conjI)
prefer 7 apply assumption
apply (rule_tac [5] LAlpha_LAppI)
apply (rule_tac [5] LAlpha_LLamI1)
prefer 5 apply assumption
apply (erule_tac [2] asm_rl | rule_tac [2] LAlpha_refl)+
prefer 2 apply (simp add: LTerm_def_Sub_rec LTerm_cons_eqns_sym)
apply (rule Occ_consI1)

apply (drule_tac [3] spec [THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [2] spec [THEN mp], erule_tac [2] asm_rl)
apply (drule_tac [1] spec [THEN mp], erule_tac [1] asm_rl)
apply safe

prefer 3
apply (intro exI conjI)
apply (assumption | rule LAlpha_LLamI1 LAlpha_LAppI LAlpha_refl)+
prefer 2 apply assumption
apply (frule LAlphaD1 [THEN LSkeltonEqD2])
apply (simp add: LTerm_def_Sub_rec LTerm_cons_eqns_sym)
apply (rule Occ_consI2)
apply simp
apply simp

prefer 2
apply (intro exI conjI)
apply (assumption | rule LAlpha_LLamI1 LAlpha_LAppI LAlpha_refl)+
prefer 2 apply assumption
apply (frule LAlphaD1 [THEN LSkeltonEqD2])
apply (simp add: LTerm_def_Sub_rec LTerm_cons_eqns_sym)
apply (rule Occ_consI2)
apply simp
apply simp

apply (intro exI conjI)
apply (assumption | rule LAlpha_LLamI1 LAlpha_LAppI LAlpha_refl)+
prefer 2 apply assumption
apply (frule LAlphaD1 [THEN LSkeltonEqD2])
apply (simp add: LTerm_def_Sub_rec LTerm_cons_eqns_sym)
apply (rule Occ_consI2)
apply simp
apply simp
done

lemma LFreeForIn_left_LsubstD1:
  assumes major: "LFreeForIn(Lsubst(A, x, B), y, M)"
  and prem1: "LFreeForIn(LVar(x), y, M)"
  and prem2: "LFreeForIn(B, x, A)"
  shows "LFreeForIn(A, y, M)"
apply (insert prem1 [THEN LFreeForInD1] prem1 [THEN LFreeForInD2]
              prem1 [THEN LFreeForInD3] prem2 [THEN LFreeForInD1]
              prem2 [THEN LFreeForInD2] prem2 [THEN LFreeForInD3])
apply (erule LTerm_typeEs)
apply (insert prem2)
apply (rule LFreeForInI)
apply (erule_tac [4] LFV_E)
apply (case_tac [4] "x = z")
prefer 4 apply hypsubst
defer 1
apply (rule_tac [4] major [THEN LFreeForInE])
apply (rule_tac [5] prem1 [THEN LFreeForInE])
apply (erule_tac [5] spec [THEN spec, THEN spec, THEN mp])
apply (erule_tac [4] spec [THEN spec, THEN spec, THEN mp])
apply safe
prefer 5 apply simp
apply (erule_tac [2] asm_rl)+
apply (rule LFV_I)
apply (rule LFreeIn_LsubstI1)
apply assumption+
done

lemma LFreeForIn_right_LsubstD:
  assumes major: "LFreeForIn(A, x, Lsubst(M, y, B))"
  and prem1: "LFreeForIn(B, y, M)"
  and prem2: "x: LFV(B)"
  shows "LFreeForIn(A, y, M)"
apply (insert major [THEN LFreeForInD1] major [THEN LFreeForInD2]
              major [THEN LFreeForInD3] prem1 [THEN LFreeForInD1]
              prem1 [THEN LFreeForInD2] prem1 [THEN LFreeForInD3])
apply (rule prem2 [THEN LFV_E])
apply (case_tac "y: LFV(M)")
prefer 2
apply (rule LFreeForInI)
apply (erule_tac [4] notE, erule_tac [4] LFV_I)
apply (rule_tac [4] LFreeForInI)
apply assumption+
apply (erule LFV_E)+
apply (rule major [THEN LFreeForInE])
apply (erule spec [THEN spec, THEN spec, THEN mp])
apply safe
apply (erule LFV_I)
apply (rule_tac [2] LOcc_LsubstI1)
prefer 3 apply assumption
prefer 2 apply (blast elim!: LFO_E LTag.free_elims)
apply (rule LFreeIn_LsubstI2)
apply (assumption | rule prem1 LFO_I)+
apply (erule initseg_appI3)
apply (erule LFreeInE2, erule LOcc_typeD1, assumption)
done

lemma LFreeIn_TLVar_leaf:
  assumes prem1: "LFreeIn(<l, T>, M)"
  and prem2: "<l @ m, U>: LOcc(M)"
  shows "m = [] & T = U"
apply (rule prem1 [THEN LFreeInE])
apply (frule prem2 [THEN [2] TLVar_leaf])
apply safe
apply (rule initseg_appI1)
apply (erule_tac [3] app_Nil_eqD1)
apply (frule_tac [2] prem2 [THEN LOcc_typeD1])
apply (erule_tac [2] app_typeD)
apply (assumption | erule LOcc_typeD1)+
done

lemma LFreeForIn_right_LsubstI1:
  assumes prem1: "LFreeForIn(N, x, A)"
  and prem2: "B: LTerm"
  and prem3: "x ~: LFV(B)"
  shows "LFreeForIn(N, x, Lsubst(A, y, B))"
apply (insert prem1 [THEN LFreeForInD1] prem1 [THEN LFreeForInD2]
              prem1 [THEN LFreeForInD3])
apply (insert prem2)
apply (assumption | rule Lsubst_type LFreeForInI)+
apply (safe elim!: LFreeIn_LsubstE initseg_right_appE
          initseg_left_appE LOcc_LsubstE LFV_E LFO_E2
          dest!: sym [THEN app_Nil_eqD1])
prefer 2
prefer 4
prefer 6
prefer 8
prefer 9
apply (erule LFreeInE2, erule LOcc_typeD1, assumption)+
prefer 2
prefer 3
prefer 4
prefer 6
apply (erule LFV_I [THEN prem3 [THEN notE]])+
apply (frule_tac [2] LFreeIn_TLVar_leaf, erule_tac [2] LFreeInE2,
       erule_tac [2] asm_rl)
prefer 2 apply (blast elim!: LTag.free_elims)
apply (rule prem1 [THEN LFreeForInE])
apply (erule spec [THEN spec, THEN spec, THEN mp])
apply (assumption | rule LFV_I conjI initseg_appI1)+
done

lemma LFreeForIn_left_LsubstI:
  assumes prem1: "LFreeForIn(A, x, M)"
  and prem2: "LFreeForIn(B, x, M)"
  shows "LFreeForIn(Lsubst(A, y, B), x, M)"
apply (insert prem1 [THEN LFreeForInD1] prem1 [THEN LFreeForInD2]
              prem1 [THEN LFreeForInD3] prem2 [THEN LFreeForInD1]
              prem2 [THEN LFreeForInD2] prem2 [THEN LFreeForInD3])
apply (assumption | rule Lsubst_type LFreeForInI)+
apply (safe elim!: LFreeIn_LsubstE LFV_E)
apply (rule prem1 [THEN LFreeForInE])
apply (erule spec [THEN spec, THEN spec, THEN mp])
apply (assumption | rule LFV_I conjI initseg_appI1)+
apply (rule prem2 [THEN LFreeForInE])
apply (erule spec [THEN spec, THEN spec, THEN mp])
apply (assumption | rule LFV_I conjI initseg_appI1)+
done

lemma LBeta1_LsubstI:
  assumes major: "LBeta1(M, M')"
  and prem1: "LFreeForIn(N, x, M)"
  and prem2: "LFreeForIn(N, x, M')"
  shows "LBeta1(Lsubst(M, x, N), Lsubst(M', x, N))"
apply (rule prem2 [THEN rev_mp])
apply (rule prem1 [THEN rev_mp])
apply (rule major [THEN rev_mp])
apply (rule major [THEN LBeta1_type2, THEN [2] bspec])
apply (rule major [THEN LBeta1_type1, THEN LTerm.induct])
apply (safe elim!: LBeta1_LTermEs LFreeForIn_LTermEs)
apply (subgoal_tac [8] "xaa ~= x")
prefer 9 apply blast
apply (simp_all add: Lsubst_lemma Lsubst_lemma4
        LFreeForInD1 LFreeForInD3)
apply (rule_tac [10] LBeta1_LAppI2)
apply (rule_tac [9] LBeta1_LAppI1)
apply (rule_tac [8] LBeta1_LLamI LBeta1_baseI)
apply (rule_tac [7] LBeta1_LLamI LBeta1_baseI)
apply (rule_tac [6] LBeta1_LLamI LBeta1_baseI)
apply (rule_tac [5] LBeta1_LLamI LBeta1_baseI)
apply (rule_tac [4] LBeta1_LLamI LBeta1_baseI)
apply (rule_tac [3] LBeta1_LLamI LBeta1_baseI)
apply (rule_tac [2] LBeta1_LLamI LBeta1_baseI)
apply (rule_tac [1] LBeta1_LLamI LBeta1_baseI)
prefer 1
prefer 2
prefer 4
prefer 6
prefer 8
prefer 9
prefer 10
prefer 15
prefer 17
apply (assumption | rule Lsubst_type
       | erule LTerm_typeEs | erule LFreeForInD1)+
apply (simp_all add: LFreeForInD1 LFreeForInD3)
apply (drule_tac [2] bspec [THEN mp, THEN mp, THEN mp])
prefer 3 apply assumption
apply (erule_tac [2] LFreeForInD3)
apply (rule_tac [2] LFreeForInI)
apply (erule_tac [5] notE, erule_tac [5] LFV_I)
apply (erule_tac [2] asm_rl LFreeForInD1)+
apply (drule bspec [THEN mp, THEN mp])
prefer 2 apply assumption
apply (erule LBeta1_type2)
apply (rule LFreeForInI)
apply (erule_tac [4] notE, erule_tac [4] LFV_I)
apply (erule_tac [3] LBeta1_type2)
apply (erule_tac [1] LFreeForInD1)
apply assumption
apply (simp add: LBeta1_type2)
apply (rule_tac [2] LFreeForIn_right_LsubstI1)
apply (erule_tac [3] LFreeForInD1)
prefer 3 apply assumption
apply (case_tac [3] "x: LFV(Na)")
apply (case_tac [2] "x: LFV(Na)")
apply (case_tac [1] "x: LFV(Na)")
apply (simp_all add: LFreeForInD1)
apply (safe dest!: LFreeForIn_right_LsubstD)
apply (assumption | rule LFreeForIn_left_LsubstI)+
done

(** LBV **)
lemma LBV_I:
  "[| <l, TLLam(x)>: LOcc(M); M: LTerm |] ==> x: LBV(M)"
apply (unfold LBV_def)
apply (frule LOcc_typeD2)
apply assumption
apply (erule LTag_typeEs)
apply blast
done

lemma LBV_E:
  "[| x: LBV(M);
      !!l. [| <l, TLLam(x)>: LOcc(M); x: LVariable |] ==> R
   |] ==> R"
apply (unfold LBV_def)
apply blast
done

lemma LBV_LVar:
  "x: LVariable ==> LBV(LVar(x)) = 0"
apply (rule equalityI)
apply (blast elim!: LBV_E LOcc_LTermEs LTag.free_elims
           intro: LBV_I intro!: LOcc_LTermIs)+
done

lemma LBV_LLam:
  "[| x: LVariable; M: LTerm |] ==> LBV(LLam(x, M)) = cons(x, LBV(M))"
apply (rule equalityI)
apply (blast elim!: LBV_E LOcc_LTermEs LTag.free_elims
           intro: LBV_I intro!: LOcc_LTermIs)+
done

lemma LBV_LApp:
  "[| M: LTerm; N: LTerm |] ==> LBV(LApp(M, N)) = LBV(M) Un LBV(N)"
apply (rule equalityI)
apply (blast elim!: LBV_E LOcc_LTermEs LTag.free_elims
           intro: LBV_I intro!: LOcc_LTermIs)+
done

lemmas LBV_eqns = LBV_LVar LBV_LLam LBV_LApp

lemma LAV_eq_LFV_LBV:
  "M: LTerm ==> LAV(M) = LFV(M) Un LBV(M)"
apply (erule LTerm.induct)
apply (simp_all add: LBV_eqns)
apply (rule equalityI, blast, blast)+
done

lemma LBV_Lsubst1:
  assumes major: "M: LTerm"
  and prem1: "N: LTerm"
  and prem2: "x: LFV(M)"
  shows "LBV(Lsubst(M, x, N)) = LBV(M) Un LBV(N)"
apply (insert prem1)
apply (rule prem2 [THEN rev_mp])
apply (rule major [THEN LTerm.induct])
apply (case_tac [3] "x: LFV(M)")
apply (case_tac [3] "x: LFV(Na)")
apply (simp_all add: LBV_eqns)
apply blast+
done

lemma LBV_Lsubst2:
  "[| M: LTerm; N: LTerm |] ==> LBV(Lsubst(M, x, N)) <= LBV(M) Un LBV(N)"
apply (case_tac "x: LFV(M)")
apply (simp_all add: LBV_Lsubst1)
apply (rule Un_upper1)
done

lemma disjoint_LBV_LFV_imp_LFreeForIn:
  "[| LBV(M) Int LFV(N) = 0; M: LTerm; N: LTerm; x: LVariable |]
       ==> LFreeForIn(N, x, M)"
apply (assumption | rule LFreeForInI)+
apply (erule disjointE)
apply (assumption | rule LBV_I)+
done

lemma LFV_Fin:
  "M: LTerm ==> LFV(M): Fin(LVariable)"
apply (rule Fin_subset)
apply (assumption | rule LFV_subset_LAV LAV_Fin)+
done

lemma LBV_Fin:
  assumes major: "M: LTerm"
  shows "LBV(M): Fin(LVariable)"
apply (rule Fin_subset)
apply (rule_tac [2] major [THEN LAV_Fin])
apply (rule major [THEN LAV_eq_LFV_LBV, THEN ssubst])
apply (rule Un_upper2)
done

lemma Infinite_LVariable_LAlpha_lemma3:
  assumes infv: "Infinite(LVariable)"
  and major: "M: LTerm"
  and prem: "X: Fin(LVariable)"
  shows "EX M'. LAlpha(M, M') & LBV(M') Int X = 0"
apply (rule major [THEN LTerm.induct])
apply (rule exI)
apply (rule LAlpha_LVarI [THEN conjI])
apply assumption
apply (simp add: LBV_eqns)
apply safe
apply (frule LAlphaD1 [THEN LSkeltonEqD2])
apply (rule_tac F="X Un LAV(M') Un {x}" in infv [THEN InfiniteE])
apply (assumption | rule Fin_UnI LAV_Fin prem Fin.intros)+
apply (simp add: LAV_eq_LFV_LBV)
apply (erule conjE)+
apply (rule conjI [THEN exI])
apply (rule LAlpha_LLamI3)
prefer 3 apply assumption
apply (rule_tac [2] disjoint_LBV_LFV_imp_LFreeForIn)
prefer 2
apply simp
apply (rule disjointI)
apply blast
apply (assumption | rule LTerm.intros)+
apply (case_tac "x: LFV(M')")
prefer 2
apply (simp_all add: LBV_eqns LBV_Lsubst1)
apply (rule cons_eq [THEN subst])
apply (rule_tac [2] cons_eq [THEN subst])
apply (rule disjoint_UnI)
apply (rule_tac [3] disjoint_UnI)
apply (rule disjointI)
apply (rule_tac [3] disjointI)
prefer 2
prefer 4
apply assumption+
apply blast
apply blast
apply (rule conjI [THEN exI])
apply (assumption | rule LAlpha_LAppI)+
apply (simp add: LBV_eqns LAlphaD1 [THEN LSkeltonEqD2])
apply (assumption | rule disjoint_UnI)+
done

lemma LBeta1_LBV_lemma:
  assumes major: "LBeta1(M, N)"
  shows "LBV(N) <= LBV(M)"
apply (rule major [THEN rev_mp])
apply (rule major [THEN LBeta1_type2, THEN rev_bspec])
apply (rule major [THEN LBeta1_type1, THEN LTerm.induct])
apply (safe elim!: LBeta1_LTermEs LTerm_typeEs)
apply (case_tac [2] "xb: LFV(N')")
apply (rotate_tac [3] 5)
apply (rotate_tac [2] 6)
apply (rotate_tac [4] 5)
apply (rotate_tac [5] 5)
apply (simp_all add: LBV_eqns LBV_Lsubst1)
apply (drule_tac [3] bspec [THEN mp], erule_tac [3] LBeta1_type2,
       erule_tac [3] asm_rl)
apply (drule_tac [2] bspec [THEN mp], erule_tac [2] LBeta1_type2,
       erule_tac [2] asm_rl)
apply (drule_tac [1] bspec [THEN mp], erule_tac [1] LBeta1_type2,
       erule_tac [1] asm_rl)
apply safe
apply (erule swap, rule subsetD, assumption, assumption)
apply (erule subsetD, assumption)
apply (erule swap, rule subsetD, assumption, assumption)
done

lemma LBeta1_LFV_lemma:
  assumes major: "LBeta1(M, N)"
  shows "LFV(N) <= LFV(M)"
apply (rule major [THEN rev_mp])
apply (rule major [THEN LBeta1_type2, THEN [2] bspec])
apply (rule major [THEN LBeta1_type1, THEN LTerm.induct])
apply (safe elim!: LBeta1_LTermEs LTerm_typeEs)
apply (rotate_tac [3] 5)
apply (rotate_tac [4] 5)
apply simp_all
apply (drule_tac [4] bspec [THEN mp], erule_tac [4] LBeta1_type2,
       erule_tac [4] asm_rl)
apply (drule_tac [3] bspec [THEN mp], erule_tac [3] LBeta1_type2,
       erule_tac [3] asm_rl)
apply (drule_tac [1] bspec [THEN mp], erule_tac [1] LBeta1_type2,
       erule_tac [1] asm_rl)
apply (safe elim!: LFV_E LFreeIn_LsubstE LTag.free_elims)
apply (erule_tac [4] notE, erule_tac [4] LFV_I)
apply (erule_tac [3] notE, erule_tac [3] LFV_I)
apply (erule_tac [4] swap, rule_tac [4] subsetD,
       erule_tac [4] asm_rl, erule_tac [4] LFV_I)
apply (erule_tac [3] subsetD, erule_tac [3] LFV_I)
apply (erule_tac [1] subsetD, erule_tac [1] LFV_I)
apply (erule LFV_I)
done

lemma LBeta1_LAlpha_parallel_lemma:
  assumes infv: "Infinite(LVariable)"
  and major: "LBeta1(M, N)"
  and prem1: "X: Fin(LVariable)"
  shows "EX M' N'. LAlpha(M, M') & LAlpha(N, N') &
            LBV(M') Int X = 0  & LBeta1(M', N')"
apply (insert prem1)
apply (rule major [THEN rev_mp])
apply (rule major [THEN LBeta1_type2, THEN [2] bspec])
apply (rule major [THEN LBeta1_type1, THEN LTerm.induct])
apply (safe elim!: LBeta1_LTermEs)
apply (frule_tac [2] LFreeForInD2)
apply (frule_tac [2] LFreeForInD3)
apply (rule_tac [2] F="X Un LFV(N')" in infv [THEN InfiniteE])
apply (erule_tac [2] asm_rl | rule_tac [2] Fin_UnI prem1 LFV_Fin)+

apply (rule_tac [2] M1="N" and X1="X" in
         infv [THEN Infinite_LVariable_LAlpha_lemma3, THEN revcut_rl])
apply (erule_tac [2] asm_rl | rule_tac [2] prem1)+
apply (erule_tac [2] exE)
apply (erule_tac [2] conjE)
apply (frule_tac [2] LAlphaD1 [THEN LSkeltonEqD2])
apply (rule_tac [2] M1="N'" and X1="X Un {xb} Un LFV(M')" in
         infv [THEN Infinite_LVariable_LAlpha_lemma3, THEN revcut_rl])
apply (erule_tac [2] asm_rl | rule_tac [2] Fin.intros
        Fin_UnI prem1 LFV_Fin)+
apply (erule_tac [2] exE)
apply (simp_all add: disjoint_Un_iff2 disjoint_cons_iff2)
apply (erule_tac [2] conjE)+
apply (frule_tac [2] N="M'a" in LAlphaD1 [THEN LSkeltonEqD2])

apply (subgoal_tac [2] "xb ~: LFV(M'a)" "LFreeForIn(M', xb, M'a)"
         "LFreeForIn(LVar(xb), xa, M'a)")
apply (rule_tac [3] disjoint_LBV_LFV_imp_LFreeForIn)
prefer 3 apply (simp add: disjoint_Un_iff2 disjoint_cons_iff2)
apply (erule_tac [3] asm_rl | rule_tac [3] LTerm.intros)+
apply (erule_tac [3] disjoint_LBV_LFV_imp_LFreeForIn)
apply (rule_tac [6] notI)
apply (erule_tac [6] LFV_E)
apply (drule_tac [6] LAlpha_sym [THEN LAlphaD2], erule_tac [6] asm_rl)
apply (erule_tac [6] notE, erule_tac [6] LFV_I)
apply (erule_tac [3] asm_rl)+

apply (rule_tac [2] conjI [THEN exI])
apply (rule_tac [3] exI)
apply (rule_tac [2] LAlpha_LAppI)
apply (rule_tac [2] LAlpha_LLamI3)
apply (erule_tac [3] asm_rl)
apply (erule_tac [2] asm_rl | rule_tac [2] conjI)+
apply (rule_tac [3] conjI)
apply (rule_tac [4] LBeta1_baseI)
apply (case_tac [3] "xa: LFV(M'a)")
prefer 4 apply (simp add: LBV_eqns
                 disjoint_Un_iff disjoint_cons_iff)
prefer 3 apply (simp add: LBV_eqns LBV_Lsubst1
                 disjoint_Un_iff disjoint_cons_iff)
prefer 2
apply (simp add: Lsubst_lemma2)
prefer 2
apply (rule_tac [2] LAlpha_LsubstI)
apply (erule_tac [2] asm_rl
       | rule_tac [2] LAlpha_LsubstI LFreeForIn_name_change
       | erule_tac [2] disjoint_LBV_LFV_imp_LFreeForIn)+

apply (drule_tac [3] bspec [THEN mp], erule_tac [3] LBeta1_type2,
       erule_tac [3] asm_rl)
apply (drule_tac [2] bspec [THEN mp], erule_tac [2] LBeta1_type2,
       erule_tac [2] asm_rl)
apply (drule_tac [1] bspec [THEN mp], erule_tac [1] LBeta1_type2,
       erule_tac [1] asm_rl)
apply safe
apply (frule_tac N="M'" in LAlphaD1 [THEN LSkeltonEqD2])
apply (frule_tac N="N'a" in LAlphaD1 [THEN LSkeltonEqD2])
apply (frule_tac M="N'" in LAlphaD1 [THEN LSkeltonEqD1])
apply (rule_tac F="X Un LBV(M') Un LBV(N'a) Un LFV(M') Un LFV(N'a)"
        in infv [THEN InfiniteE])
apply (assumption | rule Fin_UnI prem1 LFV_Fin LBV_Fin)+
apply simp
apply (erule conjE)+
apply (subgoal_tac "LFreeForIn(LVar(xa), x, M')"
         "LFreeForIn(LVar(xa), x, N'a)")
apply (rule_tac [3] disjoint_LBV_LFV_imp_LFreeForIn)
apply (rule_tac [2] disjoint_LBV_LFV_imp_LFreeForIn)
prefer 2 apply (simp add: disjoint_Un_iff2 disjoint_cons_iff2)
prefer 5 apply (simp add: disjoint_Un_iff2 disjoint_cons_iff2)
apply (erule_tac [2] asm_rl | rule_tac [2] LTerm.intros)+
apply (rule conjI [THEN exI])
apply (rule_tac [2] exI)
apply (assumption | rule LAlpha_LLamI3 conjI)+
apply (case_tac "x: LFV(M')")
apply (simp add: LBV_eqns LBV_Lsubst1
         disjoint_Un_iff disjoint_cons_iff)
apply (simp add: LBV_eqns
         disjoint_Un_iff disjoint_cons_iff)
apply (assumption | rule LBeta1_LLamI LBeta1_LsubstI)+

apply (rule_tac M1="N" and X1="X" in
         infv [THEN Infinite_LVariable_LAlpha_lemma3, THEN revcut_rl])
apply (assumption | rule prem1)+
apply (erule exE)
apply (erule conjE)
apply (rule conjI [THEN exI])
apply (rule_tac [2] exI)
apply (assumption | rule LAlpha_LAppI conjI)+
apply (simp add: LAlphaD1 [THEN LSkeltonEqD2]
           disjoint_Un_iff LBV_eqns)
apply (assumption | rule LBeta1_LAppI1)+
apply (erule LAlphaD1 [THEN LSkeltonEqD2])

apply (rule_tac M1="M" and X1="X" in
         infv [THEN Infinite_LVariable_LAlpha_lemma3, THEN revcut_rl])
apply (assumption | rule prem1)+
apply (erule exE)
apply (erule conjE)
apply (rule conjI [THEN exI])
apply (rule_tac [2] exI)
apply (assumption | rule LAlpha_LAppI conjI)+
apply (simp add: LAlphaD1 [THEN LSkeltonEqD2]
           disjoint_Un_iff LBV_eqns)
apply (assumption | rule LBeta1_LAppI2)+
apply (erule LAlphaD1 [THEN LSkeltonEqD2])
done

lemma LBeta1_LAlpha_parallel:
  assumes infv: "Infinite(LVariable)"
  and major: "LBeta1(M, N)"
  and prem1: "x: LVariable"
  and prem2: "X: LTerm"
  shows "EX M' N'. LAlpha(M, M') & LAlpha(N, N') &
            LFreeForIn(X, x, M') & LFreeForIn(X, x, N') & LBeta1(M', N')"
apply (rule_tac X1="LFV(X)" in LBeta1_LAlpha_parallel_lemma
        [OF infv major, THEN revcut_rl])
apply (rule prem2 [THEN LFV_Fin])
apply (elim exE conjE)
apply (assumption | rule exI conjI)+
apply (assumption | rule disjoint_LBV_LFV_imp_LFreeForIn
         prem1 prem2 conjI disjoint_subset
         LBeta1_LBV_lemma subset_refl
       | erule LAlphaD1 [THEN LSkeltonEqD2])+
done

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Guess_ExI
imports
  Eisbach_Tools.Eisbach_Methods
  Eisbach_Tools.Apply_Debug
begin

(*
This file contains the experimental methods guess_exI and guess_spec. Each, as the name suggests,
attempts to guess an instantiation for their respective rules. It does so by looking
for a matching premise for the quantifying binder, checking that
this could be the only match for safety.
*)

method abs_used for P = (match (P) in "\<lambda>s. ?P" \<Rightarrow> \<open>fail\<close> \<bar> _ \<Rightarrow> \<open>-\<close>)

method in_conj for P Q = (
      match (Q) in "P" \<Rightarrow> \<open>-\<close>
    | match (Q) in "\<lambda>y. A y \<and> B y"  for A B  \<Rightarrow>
            \<open> match (A) in "(Q' :: 'b)" for Q' \<Rightarrow> \<open>match (B) in "(Q'' :: 'b)"  for Q'' \<Rightarrow>
             \<open> in_conj P Q' | in_conj P Q''\<close>\<close>\<close>
    )

method guess_exI =
    (require_determ \<open>(match conclusion in "\<exists>x. Q x" for Q \<Rightarrow>
                            \<open>match premises in "P y" for P y \<Rightarrow>
                             \<open>abs_used P, in_conj P Q, rule exI[where x=y]\<close>\<close>)\<close>)

lemma fun_uncurry:
  "(P \<longrightarrow> Q \<longrightarrow> R) \<longleftrightarrow> (P \<and> Q) \<longrightarrow> R"
  by auto

method guess_spec_inner for P uses I =
    ((match I in "\<forall>x. C x \<longrightarrow> _ x" for C \<Rightarrow> \<open>in_conj P C\<close> ))

method guess_spec =
    (require_determ \<open>(match premises in I:"\<forall>x. _ x \<longrightarrow> _ x" \<Rightarrow>
                            \<open>match premises in "P y" for P y \<Rightarrow>
                            \<open>abs_used P, guess_spec_inner P I:I[simplified fun_uncurry],
                                         insert I, drule spec[where x=y]\<close>\<close>)\<close>)

text \<open>Tests and examples\<close>
experiment begin

 lemma
    assumes Q: "Q x"
    shows  "P x \<Longrightarrow> \<forall>x. Q x \<longrightarrow> P x \<longrightarrow> R  \<Longrightarrow> R"
    by (guess_spec, blast intro: Q)

  (* Conflicting premises are checked *)
  lemma
    assumes Q: "Q x"
    shows "\<lbrakk> P x; P y \<rbrakk> \<Longrightarrow>  \<forall>x. Q x \<longrightarrow> P x \<longrightarrow> R \<Longrightarrow> R"
    apply (fails \<open>guess_spec\<close>)
    by (blast intro: Q)

  (* Conflicts between different conjuncts are checked *)
  lemma
    assumes Q: "Q x"
    shows "\<lbrakk> P x; Q y \<rbrakk> \<Longrightarrow> \<forall>x. Q x \<longrightarrow> P x \<longrightarrow> R \<Longrightarrow> R"
    apply (fails \<open>guess_spec\<close>)
    by (blast intro: Q)
end

text \<open>Tests and examples\<close>
experiment begin
  lemma "P x \<Longrightarrow> \<exists>x. P x"
    by guess_exI

  lemma
    assumes Q: "Q x"
    shows "P x \<Longrightarrow> \<exists>x. Q x \<and> P x"
    apply guess_exI
    by (blast intro: Q)

  (* Conflicting premises are checked *)
  lemma
    assumes Q: "Q x"
    shows "\<lbrakk> P x; P y \<rbrakk> \<Longrightarrow> \<exists>x. Q x \<and> P x"
    apply (fails \<open>guess_exI\<close>)
    by (blast intro: Q)

  (* Conflicts between different conjuncts are checked *)
  lemma
    assumes Q: "Q x"
    shows "\<lbrakk> P x; Q y \<rbrakk> \<Longrightarrow> \<exists>x. Q x \<and> P x"
    apply (fails \<open>guess_exI\<close>)
    by (blast intro: Q)
end

end


header "Small-Step Semantics of Commands"

theory Small_Step_7_8 imports Star Big_Step_7_8 begin

subsection "The transition relation"

inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq2:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)" |
Repeat:   "(REPEAT c UNTIL b,s) \<rightarrow>
            (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b,s)"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

subsection{* Executability *}

code_pred small_step .

values "{(c',map t [''x'',''y'',''z'']) |c' t.
   (''x'' ::= V ''z'';; ''y'' ::= V ''x'',
    <''x'' := 3, ''y'' := 7, ''z'' := 5>) \<rightarrow>* (c',t)}"

subsection{* Proof infrastructure *}

subsubsection{* Induction rules *}

text{* The default induction rule @{thm[source] small_step.induct} only works
for lemmas of the form @{text"a \<rightarrow> b \<Longrightarrow> \<dots>"} where @{text a} and @{text b} are
not already pairs @{text"(DUMMY,DUMMY)"}. We can generate a suitable variant
of @{thm[source] small_step.induct} for pairs by ``splitting'' the arguments
@{text"\<rightarrow>"} into pairs: *}
lemmas small_step_induct = small_step.induct[split_format(complete)]

subsubsection{* Proof automation *}

declare small_step.intros[simp,intro]

text{* Rule inversion: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm SkipE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"
inductive_cases RepeatE[elim]: "(REPEAT c UNTIL b, s) \<rightarrow> ct"

text{* A simple property: *}
lemma deterministic:
  "cs \<rightarrow> cs' \<Longrightarrow> cs \<rightarrow> cs'' \<Longrightarrow> cs'' = cs'"
apply(induction arbitrary: cs'' rule: small_step.induct)
apply blast+
done

subsection "Equivalence with big-step semantics"

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
proof(induction rule: star_induct)
  case refl thus ?case by simp
next
  case step
  thus ?case by (metis Seq2 star.step)
qed

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
by(blast intro: star.step star_seq2 star_trans)

text{* The following proof corresponds to one on the board where one would
show chains of @{text "\<rightarrow>"} and @{text "\<rightarrow>*"} steps. *}

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  fix s show "(SKIP,s) \<rightarrow>* (SKIP,s)" by simp
next
  fix x a s show "(x ::= a,s) \<rightarrow>* (SKIP, s(x := aval a s))" by auto
next
  fix c1 c2 s1 s2 s3
  assume "(c1,s1) \<rightarrow>* (SKIP,s2)" and "(c2,s2) \<rightarrow>* (SKIP,s3)"
  thus "(c1;;c2, s1) \<rightarrow>* (SKIP,s3)" by (rule seq_comp)
next
  fix s::state and b c0 c1 t
  assume "bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c0,s)" by simp
  moreover assume "(c0,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix s::state and b c0 c1 t
  assume "\<not>bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c1,s)" by simp
  moreover assume "(c1,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix b c and s::state
  assume b: "\<not>bval b s"
  let ?if = "IF b THEN c;; WHILE b DO c ELSE SKIP"
  have "(WHILE b DO c,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if,s) \<rightarrow> (SKIP, s)" by (simp add: b)
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,s)" by(metis star.refl star.step)
next
  fix b c s s' t
  let ?w  = "WHILE b DO c"
  let ?if = "IF b THEN c;; ?w ELSE SKIP"
  assume w: "(?w,s') \<rightarrow>* (SKIP,t)"
  assume c: "(c,s) \<rightarrow>* (SKIP,s')"
  assume b: "bval b s"
  have "(?w,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if, s) \<rightarrow> (c;; ?w, s)" by (simp add: b)
  moreover have "(c;; ?w,s) \<rightarrow>* (SKIP,t)" by(rule seq_comp[OF c w])
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix b t c s
  let ?ru = "IF b THEN SKIP ELSE REPEAT c UNTIL b"
  assume "bval b t"
  hence "(?ru, t) \<rightarrow>* (SKIP, t)" by auto
  moreover assume  "(c, s) \<rightarrow>* (SKIP, t)"
  ultimately have "(c;; ?ru, s) \<rightarrow>* (SKIP, t)" using seq_comp by blast
  moreover have "(REPEAT c UNTIL b, s) \<rightarrow> (c;; ?ru, s)" by auto
  ultimately show "(REPEAT c UNTIL b, s) \<rightarrow>* (SKIP, t)" by (auto intro: star.step)
next
  fix b s\<^sub>2 c s\<^sub>1 s\<^sub>3
  let ?ru = "IF b THEN SKIP ELSE REPEAT c UNTIL b"
  assume "\<not> bval b s\<^sub>2"
  assume "(c, s\<^sub>1) \<rightarrow>* (SKIP, s\<^sub>2)"
  hence "(REPEAT c UNTIL b, s\<^sub>1) \<rightarrow>* (SKIP;; ?ru, s\<^sub>2)" using star_seq2
    by (auto intro: star.step)
  moreover have "(SKIP;; ?ru, s\<^sub>2) \<rightarrow>* (REPEAT c UNTIL b, s\<^sub>2)" using `\<not> bval b s\<^sub>2`
    by (auto intro: star.step)
  moreover assume "(REPEAT c UNTIL b, s\<^sub>2) \<rightarrow>* (SKIP, s\<^sub>3)"
  ultimately show "(REPEAT c UNTIL b, s\<^sub>1) \<rightarrow>* (SKIP, s\<^sub>3)"
    by (auto intro: star_trans)
qed

text{* Each case of the induction can be proved automatically: *}
lemma  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  case Skip show ?case by blast
next
  case Assign show ?case by blast
next
  case Seq thus ?case by (blast intro: seq_comp)
next
  case IfTrue thus ?case by (blast intro: star.step)
next
  case IfFalse thus ?case by (blast intro: star.step)
next
  case WhileFalse thus ?case
    by (metis star.step star_step1 small_step.IfFalse small_step.While)
next
  case WhileTrue
  thus ?case
    by(metis While seq_comp small_step.IfTrue star.step[of small_step])
next
  case RepeatTrue
  thus ?case
    by (blast intro: seq_comp star.step)
next
  case RepeatFalse
  thus ?case
    by (metis star_trans star.step[OF Repeat star_seq2]
      star.step[OF Seq1 star.step[OF IfFalse star.refl[of small_step]]])
qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction arbitrary: t rule: small_step.induct)
apply auto
done

lemma small_to_big:
  "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
apply (induction cs "(SKIP,t)" rule: star.induct)
apply (auto intro: small1_big_continue)
done

text {*
  Finally, the equivalence theorem:
*}
theorem big_iff_small:
  "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
by(metis big_to_small small_to_big)

subsection "Final configurations and infinite reductions"

definition "final cs \<longleftrightarrow> \<not>(EX cs'. cs \<rightarrow> cs')"

lemma finalD: "final (c,s) \<Longrightarrow> c = SKIP"
apply(simp add: final_def)
apply(induction c)
apply blast+
done

lemma final_iff_SKIP: "final (c,s) = (c = SKIP)"
by (metis SkipE finalD final_def)

text{* Now we can show that @{text"\<Rightarrow>"} yields a final state iff @{text"\<rightarrow>"}
terminates: *}

lemma big_iff_small_termination:
  "(EX t. cs \<Rightarrow> t) \<longleftrightarrow> (EX cs'. cs \<rightarrow>* cs' \<and> final cs')"
by(simp add: big_iff_small final_iff_SKIP)

text{* This is the same as saying that the absence of a big step result is
equivalent with absence of a terminating small step sequence, i.e.\ with
nontermination.  Since @{text"\<rightarrow>"} is determininistic, there is no difference
between may and must terminate. *}

end


(*  Title:      JinjaDCI/BV/BVExec.thy

    Author:     Tobias Nipkow, Gerwin Klein, Susannah Mansky
    Copyright   2000 TUM, 2020 UIUC

    Based on the Jinja theory BV/BVExec.thy by Tobias Nipkow and Gerwin Klein
*)

section \<open> Kildall for the JVM \label{sec:JVM} \<close>

theory BVExec
imports Jinja.Abstract_BV TF_JVM Jinja.Typing_Framework_2
begin

definition kiljvm :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow>
             instr list \<Rightarrow> ex_table \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> ty\<^sub>i' err list"
where
  "kiljvm P mxs mxl T\<^sub>r is xt \<equiv>
  kildall (JVM_SemiType.le P mxs mxl) (JVM_SemiType.sup P mxs mxl)
          (exec P mxs T\<^sub>r xt is)"

definition wt_kildall :: "jvm_prog \<Rightarrow> cname \<Rightarrow> staticb \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
                 instr list \<Rightarrow> ex_table \<Rightarrow> bool"
where
  "wt_kildall P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<equiv> (b = Static \<or> b = NonStatic) \<and>
   0 < size is \<and>
   (let first  = Some ([],(case b of Static \<Rightarrow> [] | NonStatic \<Rightarrow> [OK (Class C')])
                            @(map OK Ts)@(replicate mxl\<^sub>0 Err));
        start  = (OK first)#(replicate (size is - 1) (OK None));
        result = kiljvm P mxs
                   ((case b of Static \<Rightarrow> 0 | NonStatic \<Rightarrow> 1)+size Ts+mxl\<^sub>0)
                     T\<^sub>r is xt start
    in \<forall>n < size is. result!n \<noteq> Err)"

definition wf_jvm_prog\<^sub>k :: "jvm_prog \<Rightarrow> bool"
where
  "wf_jvm_prog\<^sub>k P \<equiv>
  wf_prog (\<lambda>P C' (M,b,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)). wt_kildall P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt) P"

context start_context
begin

lemma Cons_less_Conss3 [simp]:
  "x#xs [\<sqsubset>\<^bsub>r\<^esub>] y#ys = (x \<sqsubset>\<^bsub>r\<^esub> y \<and> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys \<or> x = y \<and> xs [\<sqsubset>\<^bsub>r\<^esub>] ys)"
  apply (unfold lesssub_def )
  apply auto
  apply (insert sup_state_opt_err)
  apply (unfold lesssub_def lesub_def sup_state_opt_def sup_state_def sup_ty_opt_def)
  apply (simp only: JVM_le_unfold )
  apply fastforce
  done

lemma acc_le_listI3 [intro!]:
  " acc r \<Longrightarrow> acc (Listn.le r)"
apply (unfold acc_def)
apply (subgoal_tac
 "wf(UN n. {(ys,xs). size xs = n \<and> size ys = n \<and> xs <_(Listn.le r) ys})")
   apply (erule wf_subset)
 apply (blast intro: lesssub_lengthD)
apply (rule wf_UN)
 prefer 2
 apply (rename_tac m n)
 apply (case_tac "m=n")
  apply simp
 apply (fast intro!: equals0I dest: not_sym)
apply (rename_tac n)
apply (induct_tac n)
 apply (simp add: lesssub_def cong: conj_cong)
apply (rename_tac k)
apply (simp add: wf_eq_minimal del: r_def f_def step_def A_def)
apply (simp (no_asm) add: length_Suc_conv cong: conj_cong del: r_def f_def step_def A_def)
apply clarify
apply (rename_tac M m)
apply (case_tac "\<exists>x xs. size xs = k \<and> x#xs \<in> M")
 prefer 2
 apply (erule thin_rl)
 apply (erule thin_rl)
 apply blast
apply (erule_tac x = "{a. \<exists>xs. size xs = k \<and> a#xs:M}" in allE)
apply (erule impE)
 apply blast
apply (thin_tac "\<exists>x xs. P x xs" for P)
apply clarify
apply (rename_tac maxA xs)
apply (erule_tac x = "{ys. size ys = size xs \<and> maxA#ys \<in> M}" in allE)
apply (erule impE)
 apply blast
apply clarify
apply (thin_tac "m \<in> M")
apply (thin_tac "maxA#xs \<in> M")
apply (rule bexI)
 prefer 2
 apply assumption
apply clarify
apply (simp del: r_def f_def step_def A_def)
apply blast
  done

lemma wf_jvm: " wf {(ss', ss). ss [\<sqsubset>\<^bsub>r\<^esub>] ss'}"
  apply (insert acc_le_listI3 acc_JVM [OF wf])
  by (simp add: acc_def r_def)

lemma iter_properties_bv[rule_format]:
shows "\<lbrakk> \<forall>p\<in>w0. p < n; ss0 \<in> nlists n A; \<forall>p<n. p \<notin> w0 \<longrightarrow> stable r step ss0 p \<rbrakk> \<Longrightarrow>
         iter f step ss0 w0 = (ss',w') \<longrightarrow>
         ss' \<in> nlists n A \<and> stables r step ss' \<and> ss0 [\<sqsubseteq>\<^sub>r] ss' \<and>
         (\<forall>ts\<in>nlists n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow> ss' [\<sqsubseteq>\<^sub>r] ts)"
(*<*) (is "PROP ?P")

proof -
  show "PROP ?P"
    apply (insert semi bounded_step exec_pres_type step_mono[OF wf])
    apply (unfold iter_def stables_def)

    apply (rule_tac P = "\<lambda>(ss,w).
                ss \<in> nlists n A \<and> (\<forall>p<n. p \<notin> w \<longrightarrow> stable r step ss p) \<and> ss0 [\<sqsubseteq>\<^sub>r] ss \<and>
   (\<forall>ts\<in>nlists n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow> ss [\<sqsubseteq>\<^sub>r] ts) \<and>
   (\<forall>p\<in>w. p < n)" and
   r = "{(ss',ss) . ss [\<sqsubset>\<^sub>r] ss'} <*lex*> finite_psubset"
         in while_rule)

  \<comment> \<open>Invariant holds initially:\<close>
        apply (simp add:stables_def  semilat_Def   del: n_def A_def r_def f_def step_def)
        apply (blast intro:le_list_refl')

  \<comment> \<open>Invariant is preserved:\<close>
       apply(simp add: stables_def split_paired_all del: A_def r_def f_def step_def n_def)
       apply(rename_tac ss w)
       apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
        prefer 2 apply (fast intro: someI)
       apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
        prefer 2
        apply clarify
        apply (rule conjI)
         apply(clarsimp, blast dest!: boundedD)
        apply (subgoal_tac "(SOME p. p \<in> w) < n")
         apply (subgoal_tac "(ss ! (SOME p. p \<in> w)) \<in> A")
          apply (fastforce simp only:n_def dest:pres_typeD )
         apply simp
        apply simp
       apply (subst decomp_propa)
        apply blast
       apply (simp del:A_def r_def f_def step_def n_def)
       apply (rule conjI)
        apply (rule Semilat.merges_preserves_type[OF Semilat.intro, OF semi])
         apply blast
        apply clarify
        apply (rule conjI)
         apply(clarsimp, blast dest!: boundedD)
        apply (erule pres_typeD)
          prefer 3
          apply assumption
         apply (erule nlistsE_nth_in)
         apply blast
        apply (simp only:n_def)
       apply (rule conjI)
        apply clarify
        apply (subgoal_tac "ss \<in> nlists (length is) A" "\<forall>p\<in>w. p <  (length is) " "\<forall>p<(length is). p \<notin> w \<longrightarrow> stable r step ss p "
 "p < length is")
            apply (blast   intro!: Semilat.stable_pres_lemma[OF Semilat.intro, OF semi])
           apply (simp only:n_def)
          apply (simp only:n_def)
         apply (simp only:n_def)
        apply (simp only:n_def)
       apply (rule conjI)
        apply (subgoal_tac "ss \<in> nlists (length is) A"
               "\<forall>(q,t)\<in>set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length is \<and> t \<in> A"
               "ss [\<sqsubseteq>\<^bsub>r\<^esub>] merges f (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))) ss" "ss0\<in> nlists (size is) A"
               "merges f (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))) ss \<in> nlists (size is) A"
               "ss \<in>nlists (size is) A" "order r A" "ss0 [\<sqsubseteq>\<^bsub>r\<^esub>] ss ")
                apply (blast dest: le_list_trans)
               apply simp
              apply (simp only:semilat_Def)
             apply (simp only:n_def)
            apply (fastforce simp only: n_def dest:Semilat.merges_preserves_type[OF Semilat.intro, OF semi] )
           apply (simp only:n_def)
          apply (blast intro:Semilat.merges_incr[OF Semilat.intro, OF semi])
         apply (subgoal_tac "length ss = n")
          apply (simp only:n_def)
         apply (subgoal_tac "ss \<in>nlists n A")
          defer
          apply simp
         apply (simp only:n_def)
        prefer 5
        apply (simp only:nlistsE_length n_def)
       apply(rule conjI)
        apply (clarsimp simp del: A_def r_def f_def step_def)
        apply (blast intro!: Semilat.merges_bounded_lemma[OF Semilat.intro, OF semi])
       apply (subgoal_tac "bounded step n")
        apply (blast dest!: boundedD)
       apply (simp only:n_def)

  \<comment> \<open>Postcondition holds upon termination:\<close>
      apply(clarsimp simp add: stables_def split_paired_all)

  \<comment> \<open>Well-foundedness of the termination relation:\<close>
      apply (rule wf_lex_prod)
     apply (simp only:wf_jvm)
    apply (rule wf_finite_psubset)

  \<comment> \<open>Loop decreases along termination relation:\<close>
     apply(simp add: stables_def split_paired_all del: A_def r_def f_def step_def)
     apply(rename_tac ss w)
     apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
      prefer 2 apply (fast intro: someI)
     apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
      prefer 2
      apply clarify
      apply (rule conjI)
       apply(clarsimp, blast dest!: boundedD)
      apply (erule pres_typeD)
        prefer 3
        apply assumption
       apply (erule nlistsE_nth_in)
       apply blast
      apply blast
     apply (subst decomp_propa)
      apply blast
     apply clarify
  apply (simp del: nlistsE_length  A_def r_def f_def step_def
      add: lex_prod_def finite_psubset_def
           bounded_nat_set_is_finite)
     apply (rule termination_lemma)
        apply (insert Semilat.intro)
        apply assumption+
      defer
      apply assumption
     defer
     apply clarsimp
    done
qed

(*>*)

lemma kildall_properties_bv:
shows "\<lbrakk> ss0 \<in> nlists n A \<rbrakk> \<Longrightarrow>
  kildall r f step ss0 \<in> nlists n A \<and>
  stables r step (kildall r f step ss0) \<and>
  ss0 [\<sqsubseteq>\<^sub>r] kildall r f step ss0 \<and>
  (\<forall>ts\<in>nlists n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow>
                 kildall r f step ss0 [\<sqsubseteq>\<^sub>r] ts)"
(*<*) (is "PROP ?P")
proof -
  show "PROP ?P"
  apply (unfold kildall_def)
    apply(case_tac "iter f step ss0 (unstables r step ss0)")
    apply (simp del:r_def f_def n_def step_def A_def)
    apply (rule iter_properties_bv)
     apply (simp_all add: unstables_def stable_def)
    done
qed

end

theorem (in start_context) is_bcv_kiljvm:
  "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
(*<*)
  apply (insert wf)
  apply (unfold kiljvm_def)
  apply (fold r_def f_def step_def_exec n_def)
  apply(unfold is_bcv_def wt_step_def)
  apply(insert semi  kildall_properties_bv)
  apply(simp only:stables_def)
  apply clarify
  apply(subgoal_tac "kildall r f step \<tau>s\<^sub>0 \<in> nlists n A")
   prefer 2
   apply (fastforce intro: kildall_properties_bv)
  apply (rule iffI)
   apply (rule_tac x = "kildall r f step \<tau>s\<^sub>0" in bexI)
    apply (rule conjI)
     apply (fastforce intro: kildall_properties_bv)
  apply (force intro: kildall_properties_bv)
   apply simp
  apply clarify
  apply(subgoal_tac "kildall r f step \<tau>s\<^sub>0!pa <=_r \<tau>s!pa")
   defer
   apply (blast intro!: le_listD less_lengthI)
  apply (subgoal_tac "\<tau>s!pa \<noteq> Err")
   defer
   apply simp
  apply (rule ccontr)
  apply (simp only:top_def r_def JVM_le_unfold)
  apply fastforce
  done
(*
proof -
  let ?n = "length is"
  have "Semilat A r f" using semilat_JVM[OF wf]
    by (simp add: Semilat.intro sl_def2)
  moreover have "acc r" using wf by simp blast
  moreover have "top r Err" by (simp add: JVM_le_unfold)
  moreover have "pres_type step ?n A" by (rule exec_pres_type)
  moreover have "bounded step ?n" by (rule bounded_step)
  moreover have "mono r step ?n A" using step_mono[OF wf] by simp
  ultimately have "is_bcv r Err step ?n A (kildall r f step)"
    by(rule is_bcv_kildall)
  moreover have kileq: "kiljvm P mxs mxl T\<^sub>r is xt = kildall r f step"
    using f_def kiljvm_def r_def step_def_exec by blast
  ultimately show ?thesis by simp
qed
*)
(*>*)

(* FIXME: move? *)
lemma subset_replicate [intro?]: "set (replicate n x) \<subseteq> {x}"
  by (induct n) auto

lemma in_set_replicate:
  assumes "x \<in> set (replicate n y)"
  shows "x = y"
(*<*)
proof -
  note assms
  also have "set (replicate n y) \<subseteq> {y}" ..
  finally show ?thesis by simp
qed
(*>*)

lemma (in start_context) start_in_A [intro?]:
  "0 < size is \<Longrightarrow> start \<in> nlists (size is) A"
  using Ts C
(*<*)
proof(cases b)
qed (force simp: JVM_states_unfold intro!: nlistsI nlists_appendI
           dest!: in_set_replicate)+
(*>*)

theorem (in start_context) wt_kil_correct:
  assumes wtk: "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
  shows "\<exists>\<tau>s. wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
(*<*)
proof -
  from wtk obtain res where
    result:   "res = kiljvm P mxs mxl T\<^sub>r is xt start" and
    success:  "\<forall>n < size is. res!n \<noteq> Err" and
    instrs:   "0 < size is" and
    stab:     "b = Static \<or> b = NonStatic"
    by (unfold wt_kildall_def) simp

  have bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
    by (rule is_bcv_kiljvm)

  from instrs have "start \<in> nlists (size is) A" ..
  with bcv success result have
    "\<exists>ts\<in>nlists (size is) A. start [\<sqsubseteq>\<^sub>r] ts \<and> wt_step r Err step ts"
    by (unfold is_bcv_def) blast
  then obtain \<tau>s' where
    in_A: "\<tau>s' \<in> nlists (size is) A" and
    s:    "start [\<sqsubseteq>\<^sub>r] \<tau>s'" and
    w:    "wt_step r Err step \<tau>s'"
    by blast
  hence wt_err_step: "wt_err_step (sup_state_opt P) step \<tau>s'"
    by (simp add: wt_err_step_def JVM_le_Err_conv)

  from in_A have l: "size \<tau>s' = size is" by simp
  moreover {
    from in_A  have "check_types P mxs mxl \<tau>s'" by (simp add: check_types_def)
    also from w have "\<forall>x \<in> set \<tau>s'. x \<noteq> Err"
      by (auto simp add: wt_step_def all_set_conv_all_nth)
    hence [symmetric]: "map OK (map ok_val \<tau>s') = \<tau>s'"
      by (auto intro!: map_idI simp add: wt_step_def)
    finally  have "check_types P mxs mxl (map OK (map ok_val \<tau>s'))" .
  }
  moreover {
    from s have "start!0 \<sqsubseteq>\<^sub>r \<tau>s'!0" by (rule le_listD) simp
    moreover
    from instrs w l
    have "\<tau>s'!0 \<noteq> Err" by (unfold wt_step_def) simp
    then obtain \<tau>s0 where "\<tau>s'!0 = OK \<tau>s0" by auto
    ultimately
    have "wt_start P C b Ts mxl\<^sub>0 (map ok_val \<tau>s')" using l instrs
      by (unfold wt_start_def)
         (cases b; simp add: lesub_def JVM_le_Err_conv Err.le_def)
  }
  moreover
  from in_A have "set \<tau>s' \<subseteq> A" by simp
  with wt_err_step bounded_step
  have "wt_app_eff (sup_state_opt P) app eff (map ok_val \<tau>s')"
    by (auto intro: wt_err_imp_wt_app_eff simp add: l)
  ultimately
  have "wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt (map ok_val \<tau>s')"
    using instrs stab by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis by blast
qed
(*>*)

theorem (in start_context) wt_kil_complete:
  assumes wtm: "wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  shows "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
(*<*)
proof -
  from wtm obtain
    instrs:   "0 < size is" and
    length:   "length \<tau>s = length is" and
    ck_type:  "check_types P mxs mxl (map OK \<tau>s)" and
    wt_start: "wt_start P C b Ts mxl\<^sub>0 \<tau>s" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff \<tau>s"  and
    stab: "b = Static \<or> b = NonStatic"
    by (simp add: wt_method_def2 check_types_def )

  from ck_type
  have in_A: "set (map OK \<tau>s) \<subseteq> A"
    by (simp add: check_types_def)
  with app_eff in_A bounded_step
  have "wt_err_step (sup_state_opt P) (err_step (size \<tau>s) app eff) (map OK \<tau>s)"
    by - (erule wt_app_eff_imp_wt_err,
          auto simp add: exec_def length states_def)
  hence wt_err: "wt_err_step (sup_state_opt P) step (map OK \<tau>s)"
    by (simp add: length)
  have is_bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
    by (rule is_bcv_kiljvm)
  moreover from instrs have "start \<in> nlists (size is) A" ..
  moreover
  let ?\<tau>s = "map OK \<tau>s"
  have less_\<tau>s: "start [\<sqsubseteq>\<^sub>r] ?\<tau>s"
  proof (rule le_listI)
    from length instrs
    show "length start = length (map OK \<tau>s)" by simp
  next
    fix n
    from wt_start have "P \<turnstile> ok_val (start!0) \<le>' \<tau>s!0"
      by (cases b; simp add: wt_start_def)
    moreover from instrs length have "0 < length \<tau>s" by simp
    ultimately have "start!0 \<sqsubseteq>\<^sub>r ?\<tau>s!0"
      by (simp add: JVM_le_Err_conv lesub_def)
    moreover {
      fix n'
      have "OK None \<sqsubseteq>\<^sub>r ?\<tau>s!n"
        by (auto simp add: JVM_le_Err_conv Err.le_def lesub_def
                 split: err.splits)
      hence "\<lbrakk>n = Suc n'; n < size start\<rbrakk> \<Longrightarrow> start!n \<sqsubseteq>\<^sub>r ?\<tau>s!n" by simp
    }
    ultimately
    show "n < size start \<Longrightarrow> start!n \<sqsubseteq>\<^sub>r ?\<tau>s!n" by (cases n, blast+)
  qed
  moreover
  from ck_type length
  have "?\<tau>s \<in> nlists (size is) A"
    by (auto intro!: nlistsI simp add: check_types_def)
  moreover
  from wt_err have "wt_step r Err step ?\<tau>s"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  ultimately
  have "\<forall>p. p < size is \<longrightarrow> kiljvm P  mxs mxl T\<^sub>r is xt start ! p \<noteq> Err"
    by (unfold is_bcv_def) blast
  with instrs
  show "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
    using start_context_intro_auxi[OF staticb] using stab by (unfold wt_kildall_def) simp
qed
(*>*)

theorem jvm_kildall_correct:
  "wf_jvm_prog\<^sub>k P = wf_jvm_prog P"
(*<*)
proof -
  let ?\<Phi> = "\<lambda>C M. let (C,b,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)) = method P C M in
              SOME \<tau>s. wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  let ?A = "\<lambda>P C' (M, b, Ts, T\<^sub>r, mxs, mxl\<^sub>0, is, xt). wt_kildall P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
  let ?B\<^sub>\<Phi> = "\<lambda>\<Phi>. (\<lambda>P C (M,b,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)).
                wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt (\<Phi> C M))"

  show ?thesis proof(rule iffI)
    \<comment> \<open>soundness\<close>
    assume wt: "wf_jvm_prog\<^sub>k P"
    then have wt': "wf_prog ?A P" by(simp add: wf_jvm_prog\<^sub>k_def)
    moreover {
      fix wf_md C M b Ts Ca T m bd

      assume ass1: "wf_prog wf_md P" and sees: "P \<turnstile> Ca sees M, b :  Ts\<rightarrow>T = m in Ca" and
             ass2: "set Ts \<subseteq> types P" and ass3: "bd = (M, b, Ts, T, m)" and
             ass4: "?A P Ca bd"
      from ass3 ass4 have stab: "b = Static \<or> b = NonStatic" by (simp add:wt_kildall_def)
      from ass1 sees ass2 ass3 ass4 have "(?B\<^sub>\<Phi> ?\<Phi>) P Ca bd" using sees_method_is_class[OF sees]
        by (auto dest!: start_context.wt_kil_correct[OF start_context_intro_auxi[OF stab]]
                 intro: someI)
    }
    ultimately have "wf_prog (?B\<^sub>\<Phi> ?\<Phi>) P" by(rule wf_prog_lift)
    then have "wf_jvm_prog\<^bsub>?\<Phi>\<^esub> P" by (simp add: wf_jvm_prog_phi_def)
    thus "wf_jvm_prog P" by (unfold wf_jvm_prog_def) fast
  next
    \<comment> \<open>completeness\<close>

    assume wt: "wf_jvm_prog P"
    then obtain \<Phi> where "wf_prog (?B\<^sub>\<Phi> \<Phi>) P" by(clarsimp simp: wf_jvm_prog_def wf_jvm_prog_phi_def)
    moreover {
      fix wf_md C M b Ts Ca T m bd
      assume ass1: "wf_prog wf_md P" and sees: "P \<turnstile> Ca sees M, b :  Ts\<rightarrow>T = m in Ca" and
             ass2: "set Ts \<subseteq> types P" and ass3: "bd = (M, b, Ts, T, m)" and
             ass4: "(?B\<^sub>\<Phi> \<Phi>) P Ca bd"
      from ass3 ass4 have stab: "b = Static \<or> b = NonStatic"  by (simp add:wt_method_def)
      from ass1 sees ass2 ass3 ass4 have "?A P Ca bd" using sees_method_is_class[OF sees] using JVM_sl.staticb
        by (auto intro!: start_context.wt_kil_complete start_context_intro_auxi[OF stab])
    }
    ultimately have "wf_prog ?A P" by(rule wf_prog_lift)
    thus "wf_jvm_prog\<^sub>k P" by (simp add: wf_jvm_prog\<^sub>k_def)
  qed
qed
(*>*)

end


theory IOTickTock_SeqComp
  imports IOTickTock_Core
begin

lemma IOTT0_SeqCompTT:
  "IOTT0 Outs P \<Longrightarrow> IOTT0 Outs Q \<Longrightarrow> IOTT0 Outs (P ;\<^sub>C Q)"
  unfolding IOTT0_def SeqCompTT_def
proof auto
  fix x s
  assume case_assms: "\<forall>x. x \<in> P \<longrightarrow> IOTT0_trace Outs x \<in> P" "x \<in> P" "\<forall>s. x \<noteq> s @ [[Tick]\<^sub>E]" "IOTT0_trace Outs x = s @ [[Tick]\<^sub>E]"
  have "\<And>s. IOTT0_trace Outs x = s @ [[Tick]\<^sub>E] \<Longrightarrow> \<exists> x'. x = x' @ [[Tick]\<^sub>E]"
    apply (induct x rule:IOTT0_trace.induct, auto)
    apply (metis IOTT0_trace.elims last.simps list.distinct(1) snoc_eq_iff_butlast)
    by (metis append_Cons last.simps snoc_eq_iff_butlast ttobs.distinct(1))
  then obtain x' where "x = x' @ [[Tick]\<^sub>E]"
    using case_assms(4) by auto
  then show False
    using case_assms(3) by auto
next
  fix s t
  assume case_assms: "\<forall>x. x \<in> P \<longrightarrow> IOTT0_trace Outs x \<in> P" "\<forall>x. x \<in> Q \<longrightarrow> IOTT0_trace Outs x \<in> Q"
    "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q"
  have 1: "IOTT0_trace Outs s @ [[Tick]\<^sub>E] \<in> P"
    by (metis IOTT0_trace_append_event case_assms(1) case_assms(3))
  have 2: "IOTT0_trace Outs t \<in> Q"
    by (simp add: case_assms(2) case_assms(4))
  show "\<forall>sa. sa @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>ta. ta \<in> Q \<longrightarrow> IOTT0_trace Outs (s @ t) \<noteq> sa @ ta)
      \<Longrightarrow> IOTT0_trace Outs (s @ t) \<in> P"
    using 1 2 apply (erule_tac x="IOTT0_trace Outs s" in allE, auto)
    by (erule_tac x="IOTT0_trace Outs t" in allE, auto simp add: IOTT0_trace_append)
next
  fix s t sa
  assume case_assms: "\<forall>x. x \<in> P \<longrightarrow> IOTT0_trace Outs x \<in> P" "\<forall>x. x \<in> Q \<longrightarrow> IOTT0_trace Outs x \<in> Q"
    "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q" "IOTT0_trace Outs (s @ t) = sa @ [[Tick]\<^sub>E]"
    "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t)"
  have 1: "IOTT0_trace Outs s @ [[Tick]\<^sub>E] \<in> P"
    by (metis IOTT0_trace_append_event case_assms(1) case_assms(3))
  have 2: "IOTT0_trace Outs t \<in> Q"
    by (simp add: case_assms(2) case_assms(4))
  have 3: "IOTT0_trace Outs s @ IOTT0_trace Outs t = sa @ [[Tick]\<^sub>E]"
    by (metis IOTT0_trace_append case_assms(5))
  show "False"
    using 1 2 3 case_assms(6) by force
qed

end


theory NullableClassField
  imports
    Main
    "Ecore-GROOVE-Mapping.Type_Model_Graph_Mapping"
    "Ecore-GROOVE-Mapping.Identifier_List"
begin

section "Definition of a type model which introduces a field typed by a data type."

definition tmod_nullable_class_field :: "'t Id \<Rightarrow> 't \<Rightarrow> 't Id \<Rightarrow> 't type_model" where
  "tmod_nullable_class_field classtype name fieldtype = \<lparr>
    Class = {classtype, fieldtype},
    Enum = {},
    UserDataType = {},
    Field = {(classtype, name)},
    FieldSig = (\<lambda>x. if x = (classtype, name) then (\<questiondown>fieldtype, \<^bold>0..\<^bold>1) else undefined),
    EnumValue = {},
    Inh = {},
    Prop = {},
    Constant = {},
    ConstType = (\<lambda>x. undefined)
  \<rparr>"

lemma tmod_nullable_class_field_correct:
  assumes valid_ns: "\<not>id_in_ns fieldtype (Identifier classtype) \<and> \<not>id_in_ns classtype (Identifier fieldtype)"
  shows "type_model (tmod_nullable_class_field classtype name fieldtype)"
proof (intro type_model.intro)
  fix f
  assume "f \<in> Field (tmod_nullable_class_field classtype name fieldtype)"
  then have "f = (classtype, name)"
    unfolding tmod_nullable_class_field_def
    by simp
  then have "FieldSig (tmod_nullable_class_field classtype name fieldtype) f = (\<questiondown>fieldtype, \<^bold>0..\<^bold>1)"
    unfolding tmod_nullable_class_field_def
    by simp
  then show "fst (FieldSig (tmod_nullable_class_field classtype name fieldtype) f) \<in> Type (tmod_nullable_class_field classtype name fieldtype) \<and>
    multiplicity (snd (FieldSig (tmod_nullable_class_field classtype name fieldtype) f))"
  proof (intro conjI)
    assume "FieldSig (tmod_nullable_class_field classtype name fieldtype) f = (\<questiondown>fieldtype, \<^bold>0..\<^bold>1)"
    then have "fst (FieldSig (tmod_nullable_class_field classtype name fieldtype) f) = \<questiondown>fieldtype"
      by simp
    then show "fst (FieldSig (tmod_nullable_class_field classtype name fieldtype) f) \<in> Type (tmod_nullable_class_field classtype name fieldtype)"
      unfolding Type_def NonContainerType_def ClassType_def
      by (simp add: NullableClassType.rule_nullable_classes tmod_nullable_class_field_def)
  next
    assume "FieldSig (tmod_nullable_class_field classtype name fieldtype) f = (\<questiondown>fieldtype, \<^bold>0..\<^bold>1)"
    then have snd_def: "snd (FieldSig (tmod_nullable_class_field classtype name fieldtype) f) = \<^bold>0..\<^bold>1"
      by simp
    then show "multiplicity (snd (FieldSig (tmod_nullable_class_field classtype name fieldtype) f))"
      by (intro multiplicity.intro) (simp_all)
  qed
next
  fix x y
  assume "x \<in> Class (tmod_nullable_class_field classtype name fieldtype) \<union>
    Enum (tmod_nullable_class_field classtype name fieldtype) \<union>
    UserDataType (tmod_nullable_class_field classtype name fieldtype)"
  then have x_def: "x = classtype \<or> x = fieldtype"
    unfolding tmod_nullable_class_field_def
    by simp
  assume "y \<in> Class (tmod_nullable_class_field classtype name fieldtype) \<union>
    Enum (tmod_nullable_class_field classtype name fieldtype) \<union>
    UserDataType (tmod_nullable_class_field classtype name fieldtype)"
  then have y_def: "y = classtype \<or> y = fieldtype"
    unfolding tmod_nullable_class_field_def
    by simp
  show "\<not>id_in_ns x (Identifier y)"
    using x_def y_def valid_ns
    by fastforce
next
  have "asym {} \<and> irrefl {}"
    by (simp add: asym.intros irrefl_def)
  then show "asym (Inh (tmod_nullable_class_field classtype name fieldtype)) \<and> irrefl ((Inh (tmod_nullable_class_field classtype name fieldtype))\<^sup>+)"
    unfolding tmod_nullable_class_field_def
    by simp
next
  fix f
  assume assump: "f \<in> Field (tmod_nullable_class_field classtype name fieldtype) \<and>
    Type_Model.type (tmod_nullable_class_field classtype name fieldtype) f \<in> DataType \<union>
      EnumType (tmod_nullable_class_field classtype name fieldtype) \<union>
      UserDataTypeType (tmod_nullable_class_field classtype name fieldtype) \<union>
      ProperClassType (tmod_nullable_class_field classtype name fieldtype)"
  then have "f = (classtype, name)"
    unfolding tmod_nullable_class_field_def
    by simp
  then have "Type_Model.type (tmod_nullable_class_field classtype name fieldtype) f = \<questiondown>fieldtype"
    unfolding Type_Model.type_def tmod_nullable_class_field_def
    by simp
  then show "lower (tmod_nullable_class_field classtype name fieldtype) f = \<^bold>1"
    using assump
    by simp
next
  fix f
  assume assump: "f \<in> Field (tmod_nullable_class_field classtype name fieldtype) \<and>
    Type_Model.type (tmod_nullable_class_field classtype name fieldtype) f \<in> NullableClassType (tmod_nullable_class_field classtype name fieldtype)"
  then have "f = (classtype, name)"
    unfolding tmod_nullable_class_field_def
    by simp
  then show "lower (tmod_nullable_class_field classtype name fieldtype) f = \<^bold>0"
    unfolding lower_def tmod_nullable_class_field_def
    by simp
next
  fix f
  assume "f \<in> Field (tmod_nullable_class_field classtype name fieldtype) \<and>
    Type_Model.type (tmod_nullable_class_field classtype name fieldtype) f \<in> NonContainerType (tmod_nullable_class_field classtype name fieldtype)"
  then have "f = (classtype, name)"
    unfolding tmod_nullable_class_field_def
    by simp
  then show "upper (tmod_nullable_class_field classtype name fieldtype) f = \<^bold>1"
    unfolding upper_def tmod_nullable_class_field_def
    by simp
qed (simp_all add: tmod_nullable_class_field_def)

lemma tmod_nullable_class_field_combine_correct:
  assumes "type_model Tmod"
  assumes existing_classes: "{classtype, fieldtype} \<subseteq> Class Tmod"
  assumes new_field: "(classtype, name) \<notin> Field Tmod"
  assumes valid_ns: "\<not>id_in_ns fieldtype (Identifier classtype) \<and> \<not>id_in_ns classtype (Identifier fieldtype)"
  shows "type_model (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype))"
proof (intro tmod_combine_merge_correct)
  show "type_model (tmod_nullable_class_field classtype name fieldtype)"
    using valid_ns
    by (fact tmod_nullable_class_field_correct)
next
  fix c
  assume "c \<in> Class (tmod_nullable_class_field classtype name fieldtype)"
  then have "c \<in> Class Tmod"
    unfolding tmod_nullable_class_field_def
    using existing_classes
    by fastforce
  then show "c \<notin> Enum Tmod \<and> c \<notin> UserDataType Tmod"
    using assms(1) type_model.property_class_disjoint
    by blast
next
  fix e
  assume "e \<in> Enum Tmod"
  then have "e \<noteq> classtype \<and> e \<noteq> fieldtype"
    using assms(1) existing_classes type_model.property_enum_disjoint
    by blast
  then show "e \<notin> Class (tmod_nullable_class_field classtype name fieldtype) \<and> e \<notin> UserDataType (tmod_nullable_class_field classtype name fieldtype)"
    unfolding tmod_nullable_class_field_def
    by simp
next
  fix x y
  assume x_def: "x \<in> Class Tmod \<union> Enum Tmod \<union> UserDataType Tmod"
  assume "y \<in> Class (tmod_nullable_class_field classtype name fieldtype) \<union> Enum (tmod_nullable_class_field classtype name fieldtype) \<union> UserDataType (tmod_nullable_class_field classtype name fieldtype)"
  then have y_def: "y \<in> Class Tmod \<union> Enum Tmod \<union> UserDataType Tmod"
    unfolding tmod_nullable_class_field_def
    using existing_classes
    by fastforce
  show "\<not>id_in_ns x (Identifier y)"
    using x_def y_def assms(1) type_model.property_namespace_restriction
    by blast
  show "\<not>id_in_ns y (Identifier x)"
    using x_def y_def assms(1) type_model.property_namespace_restriction
    by blast
next
  have "irrefl ((Inh Tmod)\<^sup>+)"
    using assms(1) type_model.property_inh_wellformed_trancl_irrefl
    by blast
  then show "irrefl ((Inh Tmod \<union> Inh (tmod_nullable_class_field classtype name fieldtype))\<^sup>+)"
    unfolding tmod_nullable_class_field_def
    by simp
next
  have inh_wellformed_classes: "\<And>c. c \<in> Inh (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype)) \<Longrightarrow>
    fst c \<in> Class (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype)) \<and> snd c \<in> Class (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype))"
  proof
    fix c
    assume "c \<in> Inh (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype))"
    then have c_def: "c \<in> Inh Tmod"
      unfolding tmod_combine_def tmod_nullable_class_field_def
      by simp
    have "fst c \<in> Class Tmod"
      using c_def assms(1) type_model.structure_inh_wellformed_fst_class
      by blast
    then show "fst c \<in> Class (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype))"
      unfolding tmod_combine_def
      by simp
    have "snd c \<in> Class Tmod"
      using c_def assms(1) type_model.structure_inh_wellformed_snd_class
      by blast
    then show "snd c \<in> Class (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype))"
      unfolding tmod_combine_def
      by simp
  qed
  fix c1 c2 A B
  assume "identity c1 A \<in> tmod_combine_prop Tmod (tmod_nullable_class_field classtype name fieldtype)"
  then have "identity c1 A \<in> Prop Tmod"
  proof (cases)
    case identity_property_tmod1
    then show ?thesis
      by blast
  next
    case identity_property_tmod2
    then show ?thesis
      unfolding tmod_nullable_class_field_def
      by simp
  next
    case identity_property_both
    then show ?thesis
      unfolding tmod_nullable_class_field_def
      by simp
  qed
  assume "identity c2 B \<in> tmod_combine_prop Tmod (tmod_nullable_class_field classtype name fieldtype)"
  then have "identity c2 B \<in> Prop Tmod"
  proof (cases)
    case identity_property_tmod1
    then show ?thesis
      by blast
  next
    case identity_property_tmod2
    then show ?thesis
      unfolding tmod_nullable_class_field_def
      by simp
  next
    case identity_property_both
    then show ?thesis
      unfolding tmod_nullable_class_field_def
      by simp
  qed
  assume c1_c2_neq: "c1 \<noteq> c2"
  assume not_extend_tmod: "\<not>\<exclamdown>c1 \<sqsubseteq>[Tmod] \<exclamdown>c2"
  assume "\<exclamdown>c1 \<sqsubseteq>[tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype)] \<exclamdown>c2"
  then have "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_rel_altdef (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype))"
    unfolding subtype_def
    using inh_wellformed_classes subtype_rel_alt
    by blast
  then have "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_tuple ` Type (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype)) \<union>
    subtype_conv nullable nullable ` (Inh (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype)))\<^sup>+ \<union>
    subtype_conv proper proper ` (Inh (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype)))\<^sup>+ \<union>
    subtype_conv proper nullable ` subtype_tuple ` Class (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype)) \<union>
    subtype_conv proper nullable ` (Inh (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype)))\<^sup>+"
    unfolding subtype_rel_altdef_def
    by simp
  then have "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_rel_altdef Tmod"
  proof (elim UnE)
    assume "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_tuple ` Type (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype))"
    then have "c1 = c2"
      unfolding subtype_tuple_def
      by blast
    then show ?thesis
      using c1_c2_neq
      by blast
  next
    assume "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_conv nullable nullable ` (Inh (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype)))\<^sup>+"
    then show ?thesis
      unfolding subtype_conv_def
      by blast
  next
    assume "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_conv proper proper ` (Inh (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype)))\<^sup>+"
    then have "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_conv proper proper ` (Inh Tmod)\<^sup>+"
      unfolding tmod_combine_def tmod_nullable_class_field_def
      by simp
    then show ?thesis
      unfolding subtype_rel_altdef_def
      by blast
  next
    assume "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_conv proper nullable ` subtype_tuple ` Class (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype))"
    then show ?thesis
      unfolding subtype_conv_def
      by blast
  next
    assume "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_conv proper nullable ` (Inh (tmod_combine Tmod (tmod_nullable_class_field classtype name fieldtype)))\<^sup>+"
    then show ?thesis
      unfolding subtype_conv_def
      by blast
  qed
  then have "\<exclamdown>c1 \<sqsubseteq>[Tmod] \<exclamdown>c2"
    unfolding subtype_def
    by (simp add: assms(1) subtype_rel_alt type_model.structure_inh_wellformed_classes)
  then show "A \<subseteq> B"
    using not_extend_tmod
    by blast
qed (simp_all add: assms tmod_nullable_class_field_def)

section "Encoding of a class-typed field as edge type in GROOVE"

definition tg_nullable_class_field_as_edge_type :: "'t Id \<Rightarrow> 't \<Rightarrow> 't Id \<Rightarrow> ('t list) type_graph" where
  "tg_nullable_class_field_as_edge_type classtype name fieldtype = \<lparr>
    NT = {type (id_to_list classtype), type (id_to_list fieldtype)},
    ET = {(type (id_to_list classtype), edge [name], type (id_to_list fieldtype))},
    inh = {(type (id_to_list classtype), type (id_to_list classtype)), (type (id_to_list fieldtype), type (id_to_list fieldtype))},
    abs = {},
    mult = (\<lambda>x. if x = (type (id_to_list classtype), edge [name], type (id_to_list fieldtype)) then (\<^bold>0..\<^emph>, \<^bold>0..\<^bold>1) else undefined),
    contains = {}
  \<rparr>"

lemma tg_nullable_class_field_as_edge_type_correct:
  shows "type_graph (tg_nullable_class_field_as_edge_type classtype name fieldtype)"
proof (intro type_graph.intro)
  fix n
  assume "n \<in> NT (tg_nullable_class_field_as_edge_type classtype name fieldtype)"
  then have "n = type (id_to_list classtype) \<or> n = type (id_to_list fieldtype)"
    unfolding tg_nullable_class_field_as_edge_type_def
    by simp
  then show "n \<in> Lab\<^sub>t \<union> Lab\<^sub>p"
    using Lab\<^sub>t.rule_type_labels
    by fastforce
next
  fix s l t
  assume "(s, l, t) \<in> ET (tg_nullable_class_field_as_edge_type classtype name fieldtype)"
  then have "(s, l, t) = (type (id_to_list classtype), edge [name], type (id_to_list fieldtype))"
    unfolding tg_nullable_class_field_as_edge_type_def
    by simp
  then have "s \<in> {type (id_to_list classtype), type (id_to_list fieldtype)} \<and> l \<in> Lab\<^sub>e \<union> Lab\<^sub>f \<and> t \<in> {type (id_to_list classtype), type (id_to_list fieldtype)}"
  proof (intro conjI)
    assume "(s, l, t) = (type (id_to_list classtype), edge [name], type (id_to_list fieldtype))"
    then show "l \<in> Lab\<^sub>e \<union> Lab\<^sub>f"
      using Lab\<^sub>e.rule_edge_labels
      by fastforce
  qed (simp_all)
  then show "s \<in> NT (tg_nullable_class_field_as_edge_type classtype name fieldtype) \<and> l \<in> Lab\<^sub>e \<union> Lab\<^sub>f \<and> t \<in> NT (tg_nullable_class_field_as_edge_type classtype name fieldtype)"
    unfolding tg_nullable_class_field_as_edge_type_def
    by simp
next
  show "Relation.Field (inh (tg_nullable_class_field_as_edge_type classtype name fieldtype)) = NT (tg_nullable_class_field_as_edge_type classtype name fieldtype)"
    unfolding Relation.Field_def tg_nullable_class_field_as_edge_type_def
    by simp
next
  fix e
  assume "e \<in> ET (tg_nullable_class_field_as_edge_type classtype name fieldtype)"
  then have "mult (tg_nullable_class_field_as_edge_type classtype name fieldtype) e = (\<^bold>0..\<^emph>, \<^bold>0..\<^bold>1)"
    unfolding tg_nullable_class_field_as_edge_type_def
    by simp
  then show "multiplicity_pair (mult (tg_nullable_class_field_as_edge_type classtype name fieldtype) e)"
  proof (intro multiplicity_pair.intro)
    assume mult_e_def: "mult (tg_nullable_class_field_as_edge_type classtype name fieldtype) e = (\<^bold>0..\<^emph>, \<^bold>0..\<^bold>1)"
    show "multiplicity (m_in (mult (tg_nullable_class_field_as_edge_type classtype name fieldtype) e))"
      using mult_e_def
      by (intro multiplicity.intro) (simp_all)
    show "multiplicity (m_out (mult (tg_nullable_class_field_as_edge_type classtype name fieldtype) e))"
      using mult_e_def
      by (intro multiplicity.intro) (simp_all)
  qed
next
  show "Partial_order (inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))"
    unfolding tg_nullable_class_field_as_edge_type_def partial_order_on_def preorder_on_def refl_on_def antisym_def trans_def
    by simp
qed (simp_all add: tg_nullable_class_field_as_edge_type_def)

lemma tg_nullable_class_field_as_edge_type_combine_correct:
  assumes "type_graph TG"
  assumes existing_node_types: "{type (id_to_list classtype), type (id_to_list fieldtype)} \<subseteq> NT TG"
  assumes new_edge_type: "\<And>s l t. (s, type (id_to_list classtype)) \<in> inh TG \<or> (type (id_to_list classtype), s) \<in> inh TG \<Longrightarrow> l = edge [name] \<Longrightarrow> (s, l, t) \<notin> ET TG"
  shows "type_graph (tg_combine TG (tg_nullable_class_field_as_edge_type classtype name fieldtype))"
proof (intro tg_combine_merge_correct)
  show "type_graph (tg_nullable_class_field_as_edge_type classtype name fieldtype)"
    by (fact tg_nullable_class_field_as_edge_type_correct)
next
  show "ET TG \<inter> ET (tg_nullable_class_field_as_edge_type classtype name fieldtype) = {}"
    unfolding tg_nullable_class_field_as_edge_type_def
    using assms(1) existing_node_types new_edge_type type_graph.validity_inh_node
    by fastforce
next
  fix l s1 t1 s2 t2
  assume e1_def: "(s1, l, t1) \<in> ET TG"
  assume e2_def: "(s2, l, t2) \<in> ET TG"
  assume "(s1, s2) \<in> (inh TG \<union> inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))\<^sup>+ - inh TG \<or> (s2, s1) \<in> (inh TG \<union> inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))\<^sup>+ - inh TG"
  then have "(s1, s2) \<in> (inh TG)\<^sup>+ - inh TG \<or> (s2, s1) \<in> (inh TG)\<^sup>+ - inh TG"
    using Un_absorb2 assms(1) type_graph.validity_inh_node existing_node_types insert_subset sup.orderI sup_bot.right_neutral tg_nullable_class_field_as_edge_type_def type_graph.simps(3)
    by metis
  then have src_inh: "(s1, s2) \<in> inh TG - inh TG \<or> (s2, s1) \<in> inh TG - inh TG"
    by (simp add: assms(1) type_graph.validity_inh_trans)
  assume "(t1, t2) \<in> (inh TG \<union> inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))\<^sup>+ \<or> (t2, t1) \<in> (inh TG \<union> inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))\<^sup>+"
  show "s1 = s2 \<and> t1 = t2"
    using src_inh
    by blast
next
  fix l s1 t1 s2 t2
  assume e1_def: "(s1, l, t1) \<in> ET TG"
  assume e2_def: "(s2, l, t2) \<in> ET TG"
  assume "(s1, s2) \<in> (inh TG \<union> inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))\<^sup>+ \<or> (s2, s1) \<in> (inh TG \<union> inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))\<^sup>+"
  assume "(t1, t2) \<in> (inh TG \<union> inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))\<^sup>+ - inh TG \<or> (t2, t1) \<in> (inh TG \<union> inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))\<^sup>+ - inh TG"
  then have "(t1, t2) \<in> (inh TG)\<^sup>+ - inh TG \<or> (t2, t1) \<in> (inh TG)\<^sup>+ - inh TG"
    using Un_absorb2 assms(1) type_graph.validity_inh_node existing_node_types insert_subset sup.orderI sup_bot.right_neutral tg_nullable_class_field_as_edge_type_def type_graph.simps(3)
    by metis
  then have tgt_inh: "(t1, t2) \<in> inh TG - inh TG \<or> (t2, t1) \<in> inh TG - inh TG"
    by (simp add: assms(1) type_graph.validity_inh_trans)
  show "s1 = s2 \<and> t1 = t2"
    using tgt_inh
    by blast
next
  fix l s1 t1 s2 t2
  assume e1_def: "(s1, l, t1) \<in> ET TG"
  assume "(s2, l, t2) \<in> ET (tg_nullable_class_field_as_edge_type classtype name fieldtype)"
  then have e2_def: "(s2, l, t2) = (type (id_to_list classtype), edge [name], type (id_to_list fieldtype))"
    unfolding tg_nullable_class_field_as_edge_type_def
    by simp
  then have l_def: "l = edge [name]"
    by blast
  assume "(s1, s2) \<in> (inh TG \<union> inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))\<^sup>+ \<or> (s2, s1) \<in> (inh TG \<union> inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))\<^sup>+"
  then have "(s1, s2) \<in> (inh TG)\<^sup>+ \<or> (s2, s1) \<in> (inh TG)\<^sup>+"
    using Un_absorb2 assms(1) type_graph.validity_inh_node existing_node_types insert_subset sup.orderI sup_bot.right_neutral tg_nullable_class_field_as_edge_type_def type_graph.simps(3)
    by metis
  then have src_inh: "(s1, s2) \<in> inh TG \<or> (s2, s1) \<in> inh TG"
    by (simp add: assms(1) type_graph.validity_inh_trans)
  then show "s1 = s2 \<and> t1 = t2"
    using e1_def e2_def new_edge_type
    by simp
next
  have "antisym ((inh TG)\<^sup>+)"
    by (simp add: assms(1) type_graph.validity_inh_antisym type_graph.validity_inh_trans)
  then show "antisym ((inh TG \<union> inh (tg_nullable_class_field_as_edge_type classtype name fieldtype))\<^sup>+)"
    using Un_absorb2 assms(1) type_graph.validity_inh_node existing_node_types insert_subset sup.orderI sup_bot.right_neutral tg_nullable_class_field_as_edge_type_def type_graph.simps(3)
    by metis
qed (simp_all add: tg_nullable_class_field_as_edge_type_def assms)

subsection "Transformation functions"

definition tmod_nullable_class_field_to_tg_nullable_class_field_as_edge_type :: "'t Id \<Rightarrow> 't type_model \<Rightarrow> ('t list) type_graph" where
  "tmod_nullable_class_field_to_tg_nullable_class_field_as_edge_type fieldtype Tmod = \<lparr>
    NT = type ` id_to_list ` Class Tmod,
    ET = (\<lambda>x. (type (id_to_list (fst x)), edge [(snd x)], type (id_to_list fieldtype))) ` Field Tmod,
    inh = (\<lambda>x. (x, x)) ` type ` id_to_list ` Class Tmod,
    abs = {},
    mult = (\<lambda>x. if x \<in> (\<lambda>x. (type (id_to_list (fst x)), edge [(snd x)], type (id_to_list fieldtype))) ` Field Tmod then (\<^bold>0..\<^emph>, \<^bold>0..\<^bold>1) else undefined),
    contains = {}
  \<rparr>"

lemma tmod_nullable_class_field_to_tg_nullable_class_field_as_edge_type_proj:
  shows "tmod_nullable_class_field_to_tg_nullable_class_field_as_edge_type fieldtype (tmod_nullable_class_field classtype name fieldtype) = tg_nullable_class_field_as_edge_type classtype name fieldtype"
  unfolding tmod_nullable_class_field_to_tg_nullable_class_field_as_edge_type_def tmod_nullable_class_field_def tg_nullable_class_field_as_edge_type_def
  by auto

lemma tmod_nullable_class_field_to_tg_nullable_class_field_as_edge_type_func:
  shows "tg_combine_mapping_function (tmod_nullable_class_field_to_tg_nullable_class_field_as_edge_type fieldtype) (tmod_nullable_class_field classtype name fieldtype) (tg_nullable_class_field_as_edge_type classtype name fieldtype)"
  by (intro tg_combine_mapping_function.intro)
    (auto simp add: tmod_nullable_class_field_to_tg_nullable_class_field_as_edge_type_def tmod_nullable_class_field_def tg_nullable_class_field_as_edge_type_def tmod_combine_def)

definition tg_nullable_class_field_as_edge_type_to_tmod_nullable_class_field :: "'t Id \<Rightarrow> ('t list) type_graph \<Rightarrow> 't type_model" where
  "tg_nullable_class_field_as_edge_type_to_tmod_nullable_class_field fieldtype TG = \<lparr>
    Class = list_to_id ` unlabel ` NT TG,
    Enum = {},
    UserDataType = {},
    Field = (\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) ` ET TG,
    FieldSig = (\<lambda>x. if x \<in> (\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) ` ET TG then (\<questiondown>fieldtype, \<^bold>0..\<^bold>1) else undefined),
    EnumValue = {},
    Inh = {},
    Prop = {},
    Constant = {},
    ConstType = (\<lambda>x. undefined)
  \<rparr>"

lemma tg_nullable_class_field_as_edge_type_to_tmod_nullable_class_field_proj:
  shows "tg_nullable_class_field_as_edge_type_to_tmod_nullable_class_field fieldtype (tg_nullable_class_field_as_edge_type classtype name fieldtype) = tmod_nullable_class_field classtype name fieldtype"
  unfolding tg_nullable_class_field_as_edge_type_to_tmod_nullable_class_field_def tmod_nullable_class_field_def tg_nullable_class_field_as_edge_type_def
  by (simp add: id_to_list_inverse)

lemma tg_nullable_class_field_as_edge_type_to_tmod_nullable_class_field_func:
  shows "tmod_combine_mapping_function (tg_nullable_class_field_as_edge_type_to_tmod_nullable_class_field fieldtype) (tg_nullable_class_field_as_edge_type classtype name fieldtype) (tmod_nullable_class_field classtype name fieldtype)"
  by (intro tmod_combine_mapping_function.intro)
    (simp_all add: tg_nullable_class_field_as_edge_type_to_tmod_nullable_class_field_def tmod_nullable_class_field_def tg_nullable_class_field_as_edge_type_def tg_combine_def id_to_list_inverse)

end