(*
    File:        LAlpha.thy
    Time-stamp:  <2016-01-12T14:58:28Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory LAlpha imports LLambda Infinite begin

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

definition LSkeltonEq :: "[i, i] => o" where
"LSkeltonEq(M, N) == M: LTerm & N: LTerm &
   (ALL l. (EX x. <l, TLVar(x)>: LOcc(M))
                    <-> (EX x. <l, TLVar(x)>: LOcc(N))) &
   (ALL l. (EX x. <l, TLLam(x)>: LOcc(M))
                    <-> (EX x. <l, TLLam(x)>: LOcc(N))) &
   (ALL l. <l, TLApp>: LOcc(M) <-> <l, TLApp>: LOcc(N))"

definition LAlpha :: "[i, i]=>o" where
"LAlpha(M, N) == LSkeltonEq(M, N) &
   (ALL u. LFreeIn(u, M) <-> LFreeIn(u, N)) &
   (ALL l m. (EX T U. LBoundBy(<l, T>, <m, U>, M))
                     <-> (EX T U. LBoundBy(<l, T>, <m, U>, N)))"

(** LAV **)
lemma LAV_I1:
  "[| <l, TLVar(x)>: LOcc(M); M: LTerm |] ==> x: LAV(M)"
apply (unfold LAV_def)
apply (frule LOcc_typeD2)
apply assumption
apply (blast elim!: LTag_typeEs)
done

lemma LAV_I2:
  "[| <l, TLLam(x)>: LOcc(M); M: LTerm |] ==> x: LAV(M)"
apply (unfold LAV_def)
apply (frule LOcc_typeD2)
apply assumption
apply (blast elim!: LTag_typeEs)
done

lemma LAV_E:
  "[| x: LAV(M);
    !!l. [| <l, TLVar(x)>: LOcc(M); x: LVariable |]
        ==> R;
    !!l. [| <l, TLLam(x)>: LOcc(M); x: LVariable |]
        ==> R
   |] ==> R"
apply (unfold LAV_def)
apply blast
done

lemma LAV_LVar:
  "x: LVariable ==> LAV(LVar(x)) = {x}"
apply (unfold LAV_def)
apply (rule equalityI)
apply (blast elim!: LOcc_LTermEs LTag.free_elims
             intro: LOcc_LTermIs)+
done

lemma LAV_LLam:
  "x: LVariable ==> LAV(LLam(x, M)) = cons(x, LAV(M))"
apply (unfold LAV_def)
apply (rule equalityI)
apply (blast elim!: LOcc_LTermEs LTag.free_elims
             intro: LOcc_LTermIs)+
done

lemma LAV_LApp:
  "LAV(LApp(M, N)) = LAV(M) Un LAV(N)"
apply (unfold LAV_def)
apply (rule equalityI)
apply (blast elim!: LOcc_LTermEs LTag.free_elims
             intro: LOcc_LTermIs)+
done

lemmas LAV_eqns = LAV_LVar LAV_LLam LAV_LApp
declare LAV_eqns [simp]

lemmas LTerm_Occ_ind_cond_Occ_FinI = Occ_ind_cond_Occ_FinI [OF
  LTerm_Occ_ind_cond]

lemma LAV_Fin:
  "M: LTerm ==> LAV(M): Fin(LVariable)"
apply (unfold LAV_def)
apply (erule LTerm_Occ_ind_cond_Occ_FinI [THEN Fin_induct])
apply simp
apply (erule SigmaE)
apply (erule LTag.cases)
apply hypsubst
apply (rule_tac P="%x. x: Fin(LVariable)" in ssubst)
apply (erule_tac [2] Fin.intros)
prefer 2 apply assumption
apply (rule_tac [2] P="%x. x: Fin(LVariable)" in ssubst)
apply (erule_tac [3] Fin.intros)
prefer 3 apply assumption
apply (rule_tac [3] P="%x. x: Fin(LVariable)" in ssubst)
prefer 4 apply assumption
apply (rule equalityI,
       blast elim!: LTag.free_elims,
       blast elim!: LTag.free_elims)+
done

lemma LFV_subset_LAV:
  "M: LTerm ==> LFV(M) <= LAV(M)"
apply (erule LTerm.induct)
apply simp_all
apply blast+
done

(** LSkeltonEq **)
lemma LSkeltonEqD1:
  "LSkeltonEq(M, N) ==> M: LTerm"
apply (unfold LSkeltonEq_def)
apply (erule conjunct1)
done

lemma LSkeltonEqD2:
  "LSkeltonEq(M, N) ==> N: LTerm"
apply (unfold LSkeltonEq_def)
apply (erule conjunct2 [THEN conjunct1])
done

lemma LSkeltonEq_TLVarD:
  "[| LSkeltonEq(M, N); <l, TLVar(x)>: LOcc(M) |]
      ==> EX x. <l, TLVar(x)>: LOcc(N)"
apply (unfold LSkeltonEq_def)
apply blast
done

lemma LSkeltonEq_TLLamD:
  "[| LSkeltonEq(M, N); <l, TLLam(x)>: LOcc(M) |]
      ==> EX x. <l, TLLam(x)>: LOcc(N)"
apply (unfold LSkeltonEq_def)
apply blast
done

lemma LSkeltonEq_TLAppD:
  "[| LSkeltonEq(M, N); <l, TLApp>: LOcc(M) |]
      ==> <l, TLApp>: LOcc(N)"
apply (unfold LSkeltonEq_def)
apply blast
done

lemma LSkeltonEq_refl:
  "M: LTerm ==> LSkeltonEq(M, M)"
apply (unfold LSkeltonEq_def)
apply blast
done

lemma LSkeltonEq_sym:
  "LSkeltonEq(M, N) ==> LSkeltonEq(N, M)"
apply (unfold LSkeltonEq_def)
apply blast
done

lemma LSkeltonEq_trans:
  "[| LSkeltonEq(M, N); LSkeltonEq(N, L) |] ==> LSkeltonEq(M, L)"
apply (unfold LSkeltonEq_def)
apply blast
done

lemma LSkeltonEq_LVarI:
  "[| x: LVariable; y: LVariable |] ==> LSkeltonEq(LVar(x), LVar(y))"
apply (unfold LSkeltonEq_def)
apply (blast elim!: LOcc_LTermEs LTag.free_elims
        intro: LOcc_LTermIs)
done

lemma LSkeltonEq_LLamI:
  "[| x: LVariable; y: LVariable;  LSkeltonEq(M, N) |]
      ==> LSkeltonEq(LLam(x, M), LLam(y, N))"
apply (unfold LSkeltonEq_def)
apply (blast elim!: LOcc_LTermEs LTag.free_elims
        intro: LOcc_LTermIs)
done

lemma LSkeltonEq_LAppI:
"[| LSkeltonEq(A, C); LSkeltonEq(B, D)|]
    ==> LSkeltonEq(LApp(A, B), LApp(C, D))"
apply (unfold LSkeltonEq_def)
apply (elim conjE)
apply (intro LTerm.intros conjI)
apply assumption+
apply (blast elim!: LOcc_LTermEs LTag.free_elims
        intro: LOcc_LTermIs)+
done

lemmas LSkeltonEq_LTermIs = LSkeltonEq_LVarI LSkeltonEq_LLamI
                            LSkeltonEq_LAppI

lemma LSkeltonEq_LVarE:
  assumes major: "LSkeltonEq(LVar(x), N)"
  and prem: "!! y B. [| N = LVar(y); x: LVariable; y: LVariable |] ==> R"
  shows "R"
apply (insert major)
apply (unfold LSkeltonEq_def)
apply (elim LTerm_typeEs conjE)
apply (subgoal_tac "EX y. <[], TLVar(y)>: LOcc(N)"
                   "EX y: LVariable.  N = LVar(y)")
prefer 3
apply (erule spec [THEN iffD1])
apply (assumption | rule exI LOcc_LTermIs)+
prefer 2
apply (erule exE)
apply (erule_tac a="N" in LTerm.cases)
prefer 3
apply hypsubst
apply (blast elim!: LTag.free_elims list.free_elims LOcc_LTermEs)
prefer 2
apply (blast elim!: LTag.free_elims list.free_elims LOcc_LTermEs)
apply (assumption | rule bexI)+
apply (erule bexE)
apply (rule prem)
apply assumption+
done

lemma LSkeltonEq_LLamE:
  assumes major: "LSkeltonEq(LLam(x, A), N)"
  and prem:
     "!! y B. [| N = LLam(y, B); x: LVariable; y: LVariable;
        LSkeltonEq(A, B) |] ==> R"
  shows "R"
apply (insert major)
apply (unfold LSkeltonEq_def)
apply (elim LTerm_typeEs conjE)
apply (subgoal_tac "EX y. <[], TLLam(y)>: LOcc(N)"
          "EX y: LVariable.  EX B: LTerm. N = LLam(y, B)")
prefer 3
apply (erule spec [THEN iffD1])
apply (assumption | rule exI LOcc_LTermIs)+
prefer 2
apply (erule exE)
apply (erule_tac a="N" in LTerm.cases)
apply hypsubst
apply (blast elim!: LTag.free_elims LOcc_LTermEs)
prefer 2
apply (blast elim!: LTag.free_elims LOcc_LTermEs list.free_elims)
apply (assumption | rule bexI)+
apply (elim bexE exE)
apply hypsubst
apply (rule prem)
apply assumption+
apply (unfold LSkeltonEq_def)
apply (intro conjI)
apply assumption+

apply (intro allI iffI)
apply (erule exE)
apply (drule spec [THEN iffD1], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)
apply (erule exE)
apply (drule spec [THEN iffD2], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)

apply (intro allI iffI)
apply (erule exE)
apply (drule spec [THEN iffD1], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)
apply (erule exE)
apply (drule spec [THEN iffD2], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)

apply (intro allI iffI)
apply (drule spec [THEN iffD1], erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)
apply (drule spec [THEN iffD2], erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)

done

lemma LSkeltonEq_LAppE:
  assumes major: "LSkeltonEq(LApp(A, B), N)"
  and prem:
     "!! C D. [| N = LApp(C, D); LSkeltonEq(A, C); LSkeltonEq(B, D) |]
            ==> R"
  shows "R"
apply (insert major)
apply (unfold LSkeltonEq_def)
apply (elim LTerm_typeEs conjE)
apply (subgoal_tac "<[], TLApp>: LOcc(N)"
                   "EX C: LTerm.  EX D: LTerm. N = LApp(C, D)")
prefer 3
apply (erule spec [THEN iffD1])
apply (assumption | rule LOcc_LTermIs)+
prefer 2
apply (erule_tac a="N" in LTerm.cases)
apply hypsubst
apply (blast elim!: LTag.free_elims LOcc_LTermEs)
apply (blast elim!: LTag.free_elims list.free_elims LOcc_LTermEs)
apply (assumption | rule bexI)+

apply (elim bexE)
apply (rule prem)
apply assumption
apply (unfold LSkeltonEq_def)

apply hypsubst
apply (intro conjI)
apply assumption+

apply (intro allI iffI)
apply (erule exE)
apply (drule spec [THEN iffD1], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)
apply (erule exE)
apply (drule spec [THEN iffD2], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)

apply (intro allI iffI)
apply (erule exE)
apply (drule spec [THEN iffD1], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)
apply (erule exE)
apply (drule spec [THEN iffD2], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)

apply (intro allI iffI)
apply (drule spec [THEN iffD1], erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)
apply (drule spec [THEN iffD2], erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)

apply hypsubst
apply (intro conjI)
apply assumption+

apply (intro allI iffI)
apply (erule exE)
apply (drule spec [THEN iffD1], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)
apply (erule exE)
apply (drule spec [THEN iffD2], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)

apply (intro allI iffI)
apply (erule exE)
apply (drule spec [THEN iffD1], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)
apply (erule exE)
apply (drule spec [THEN iffD2], rule exI, erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)

apply (intro allI iffI)
apply (drule spec [THEN iffD1], erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)
apply (drule spec [THEN iffD2], erule LOcc_LTermIs)
apply (blast elim!: list.free_elims LTag.free_elims LOcc_LTermEs)

done

lemmas LSkeltonEq_LTermEs = LSkeltonEq_LVarE LSkeltonEq_LLamE
                          LSkeltonEq_LAppE

lemma LSkeltonEq_Lsubst_LVar:
  "[| M: LTerm; y: LVariable |] ==> LSkeltonEq(M, Lsubst(M, x, LVar(y)))"
apply (unfold LSkeltonEq_def Lsubst_def Lgraft_def)
apply (subgoal_tac "Occ_Graft(LOcc(M), domain(LFO(x, M)), LOcc(LVar(y))):
                     Occ_range(LTag, LArity)")
prefer 2
apply (assumption | rule LTerm.intros LTerm_Occ_Graft_in_Occ_range2
         LOcc_in_Occ_range Incomparable_LFO domain_mono LFO_subset_LOcc)+
apply (assumption | rule conjI LTerm_def_Occinv_type)+
apply (rule_tac [2] conjI)
apply (simp_all only: LTerm_def_Occ_Occinv)
apply (rule_tac [3] iffI allI)+
apply (rule_tac [2] iffI allI)+
apply (rule_tac [1] iffI allI)+
apply (erule_tac [4] exE)
apply (erule_tac [3] exE)
apply (erule_tac [2] exE)
apply (erule_tac [1] exE)
apply (case_tac "<l, TLVar(xa)>: LFO(x, M)")
prefer 2

apply (safe elim!: LOcc_LTermEs LTag.free_elims
        LOcc_domain [THEN [2] Occ_GraftE] Occ_ShiftE LFO_E)
apply (erule_tac [4] LFreeInE2)
apply (frule_tac [4] LOcc_domain [THEN subsetD, THEN SigmaD1])
prefer 4 apply assumption
prefer 4 apply simp
apply (erule exI)
prefer 3 apply (erule exI)
prefer 4 apply (erule exI)
apply (rule_tac [3] exI)
apply (rule_tac [2] exI)
apply (rule_tac [1] exI)
apply (rule_tac [4] Occ_GraftI1)
apply (rule_tac [3] Occ_GraftI1)
apply (rule_tac [2] Occ_GraftI2)
apply (rule_tac [1] Occ_GraftI1)
prefer 5
prefer 7
apply assumption+
apply (erule_tac [2] LFO_I [THEN domainI])
apply (rule_tac [2] P="%x. <x, TLVar(y)>: Occ_Shift(la, LOcc(LVar(y)))"
          in app_right_Nil [THEN subst])
apply (rule_tac [3] Occ_ShiftI)
apply (erule_tac [2] LOcc_domain [THEN subsetD, THEN SigmaD1])
prefer 2
prefer 3
apply (assumption | rule LOcc_LTermIs)+

apply (safe elim!: LTag.free_elims LFO_E LFreeInE2)

apply (rule_tac LOcc_in_Occ_range [THEN Occ_rangeE], assumption)
apply (subgoal_tac "la = l")
apply (erule_tac [2] DenseTree_CorrectArity_0D)
prefer 3
prefer 4
prefer 5
apply assumption+
prefer 2
apply (drule_tac x="TLVar(x)" in bspec)
apply (erule LOcc_domain [THEN subsetD, THEN SigmaD2])
apply assumption
apply simp
apply hypsubst
apply (subgoal_tac "TLVar(xa) = TLVar(x)")
apply (erule_tac [2] functionalD)
apply (clarify elim!: LTag.free_elims)
apply (erule notE)
apply (rule LFreeInI [THEN LFO_I])
apply (erule_tac [3] spec [THEN mp, THEN notE])
apply assumption+

apply (rule_tac LOcc_in_Occ_range [THEN Occ_rangeE], assumption)
apply (subgoal_tac "la = l")
apply (erule_tac [2] DenseTree_CorrectArity_0D)
prefer 3
prefer 4
prefer 5
apply assumption+
prefer 2
apply (drule_tac x="TLVar(x)" in bspec)
apply (erule LOcc_domain [THEN subsetD, THEN SigmaD2])
apply assumption
apply simp
apply hypsubst
apply (subgoal_tac "TLLam(xa) = TLVar(x)")
apply (erule_tac [2] functionalD)
apply (clarify elim!: LTag.free_elims)
apply assumption+

apply (rule_tac LOcc_in_Occ_range [THEN Occ_rangeE], assumption)
apply (subgoal_tac "la = l")
apply (erule_tac [2] DenseTree_CorrectArity_0D)
prefer 3
prefer 4
prefer 5
apply assumption+
prefer 2
apply (drule_tac x="TLVar(x)" in bspec)
apply (erule LOcc_domain [THEN subsetD, THEN SigmaD2])
apply assumption
apply simp
apply hypsubst
apply (subgoal_tac "TLApp = TLVar(x)")
apply (erule_tac [2] functionalD)
apply (clarify elim!: LTag.free_elims)
apply assumption+

done

(** LAlpha **)
lemma LAlphaD1:
  "LAlpha(M, N) ==> LSkeltonEq(M, N)"
apply (unfold LAlpha_def)
apply (erule conjunct1)
done

lemma LAlphaD2:
  "[| LAlpha(M, N); LFreeIn(u, M) |] ==> LFreeIn(u, N)"
apply (unfold LAlpha_def)
apply (erule conjunct2 [THEN conjunct1, THEN spec, THEN iffD1])
apply assumption
done

lemma LAlphaD3:
  "[| LAlpha(M, N); LBoundBy(<l, T>, <m, U>, M) |]
      ==> EX x. LBoundBy(<l, TLVar(x)>, <m, TLLam(x)>, N)"
apply (unfold LAlpha_def)
apply (frule conjunct2 [THEN conjunct2])
apply (drule spec [THEN spec, THEN iffD1])
apply (rule exI [THEN exI])
apply assumption
apply (elim exE)
apply (rule_tac M="N" in LBoundByE)
apply assumption
apply blast
done

lemma LAlphaI:
  assumes prem1: "LSkeltonEq(M, N)"
  and prem2:
      "!! l x. LFreeIn(<l, TLVar(x)>, M) <-> LFreeIn(<l, TLVar(x)>, N)"
  and prem3:
      "!! l m. (EX x. LBoundBy(<l, TLVar(x)>, <m, TLLam(x)>, M))
               <-> (EX x. LBoundBy(<l, TLVar(x)>, <m, TLLam(x)>, N))"
  shows "LAlpha(M, N)"
apply (unfold LAlpha_def)
apply (rule prem1 [THEN conjI])
apply safe

apply (rule LFreeInE)
apply assumption
apply hypsubst
apply (erule_tac prem2 [THEN iffD1])
apply (rule LFreeInE)
apply assumption
apply hypsubst
apply (erule_tac prem2 [THEN iffD2])

apply (rule LBoundByE)
apply assumption
apply safe
apply (drule_tac exI [THEN prem3 [THEN iffD1]])
apply blast
apply (rule LBoundByE)
apply assumption
apply safe
apply (drule_tac exI [THEN prem3 [THEN iffD2]])
apply blast

done

lemma LAlphaI2:
  assumes "M: LTerm"
  and "N: LTerm"
  and "!! l. (EX x. <l, TLLam(x)>: LOcc(M)) <->
                            (EX x. <l, TLLam(x)>: LOcc(N))"
  and "!! l. <l, TLApp>: LOcc(M) <-> <l, TLApp>: LOcc(N)"
  and prem1: "!! l x. LFreeIn(<l, TLVar(x)>, M) <-> LFreeIn(<l, TLVar(x)>, N)"
  and prem2: "!! l m. (EX x. LBoundBy(<l, TLVar(x)>, <m, TLLam(x)>, M))
               <-> (EX x. LBoundBy(<l, TLVar(x)>, <m, TLLam(x)>, N))"
  shows "LAlpha(M, N)"
apply (rule LAlphaI)
defer 1
apply (assumption | rule assms)+
apply (unfold LSkeltonEq_def)
apply (assumption | rule assms conjI)+
prefer 2
apply (assumption | rule assms allI conjI)+
apply safe
apply (drule_tac [2] TLVar_free_or_bound)
apply (drule_tac [1] TLVar_free_or_bound)
apply (rule assms)
prefer 2 apply (rule assms)
apply (safe elim!: LBoundInE LBinding_imp_LBoundByE)
apply (drule_tac [1] prem1 [THEN iffD1])
apply (drule_tac [3] prem1 [THEN iffD2])
apply (drule_tac [2] exI [THEN prem2 [THEN iffD1]])
apply (drule_tac [4] exI [THEN prem2 [THEN iffD2]])
apply (safe elim!: LBoundByE2 LBindingE2 LFreeInE2)
apply (erule exI)+
done

lemma LAlpha_refl:
  "M: LTerm ==> LAlpha(M, M)"
apply (unfold LAlpha_def)
apply (blast intro: LSkeltonEq_refl)
done

lemma LAlpha_sym:
  "LAlpha(M, N) ==> LAlpha(N, M)"
apply (unfold LAlpha_def)
apply (blast intro: LSkeltonEq_sym)
done

lemma LAlpha_trans:
  "[| LAlpha(M, N); LAlpha(N, L) |] ==> LAlpha(M, L)"
apply (unfold LAlpha_def)
apply (blast intro: LSkeltonEq_trans)
done

lemma LAlpha_LVarI:
  "x: LVariable ==> LAlpha(LVar(x), LVar(x))"
apply (rule LAlpha_refl)
apply (assumption | rule LTerm.intros)+
done

lemma LAlpha_LLamI1:
  "[| LAlpha(M, N); x: LVariable |]
       ==> LAlpha(LLam(x, M), LLam(x, N))"
apply (unfold LAlpha_def)
apply (elim conjE)
apply (frule LSkeltonEqD1)
apply (frule LSkeltonEqD2)
apply (assumption | rule LSkeltonEq_LLamI conjI)+
apply (rule iffI [THEN allI])
apply (erule_tac [2] LFreeIn_LTermEs)
apply (erule LFreeIn_LTermEs)
apply (drule spec [THEN iffD1], assumption)
apply hypsubst
prefer 2
apply (drule spec [THEN iffD2], assumption)
apply hypsubst
prefer 2
apply ((erule notE, erule sym)
      | (assumption | rule LFreeIn_LTermIs notI))+

apply (rule iffI [THEN allI, THEN allI])
apply (safe elim!: LBoundBy_LTermEs LTag.free_elims)

prefer 4 apply (drule spec [THEN spec, THEN iffD2], erule exI [THEN exI])
apply (elim exE)
prefer 4 apply (drule spec [THEN iffD2], assumption)
prefer 4 apply (drule spec [THEN spec, THEN iffD1], erule exI [THEN exI])
apply (elim exE)
prefer 4 apply (drule spec [THEN iffD1], assumption)
apply (assumption | rule LBoundBy_LTermIs exI)+
done

lemma LAlpha_LLamI2:
  "[| LAlpha(M, Lsubst(N, y, LVar(x))); LFreeForIn(LVar(x), y, N);
     x ~: LFV(N) |]
       ==> LAlpha(LLam(x, M), LLam(y, N))"
apply (unfold LAlpha_def)
apply (elim conjE)
apply (subgoal_tac "x: LVariable" "y: LVariable" "N: LTerm")
prefer 2
prefer 3
prefer 4
apply (erule LFreeForInE, erule LTerm_typeEs, assumption)+
apply (rule conjI)
apply (rule LSkeltonEq_LLamI)
apply assumption+
apply (rule LSkeltonEq_trans)
apply (rule_tac [2] LSkeltonEq_Lsubst_LVar [THEN LSkeltonEq_sym])
apply assumption+

apply (frule LSkeltonEqD1)
apply (rule conjI)
apply (rule_tac [2] iffI [THEN allI, THEN allI])
apply (rule iffI [THEN allI])
apply (safe elim!: LBoundBy_LTermEs LFreeIn_LTermEs)
apply (subgoal_tac [2] "x ~= ya")
prefer 3
apply (rule notI)
apply hypsubst
apply (erule notE, erule LFV_I)
prefer 2
apply (drule LFreeIn_LsubstI1)
apply assumption+
apply (drule spec [THEN iffD2], assumption)
prefer 2

apply (subgoal_tac [5] "ma: list(nat)"
          "LFreeIn(<ma @ [], TLVar(x)>, Lsubst(N, y, LVar(x)))")
apply (erule_tac [7] LFreeInE2)
apply (rule_tac [7] LOcc_domain [THEN subsetD, THEN SigmaD1])
prefer 8 apply assumption
prefer 7 apply assumption
prefer 6
apply (rule LFreeIn_LsubstI2)
apply (assumption | rule LFreeIn_LVarI LFO_I)+
prefer 5
apply (simp only: app_right_Nil)
apply (drule spec [THEN iffD2], assumption)
defer 1
defer 5

prefer 6
apply (drule LBoundBy_LsubstI1)
apply (drule_tac [2] spec [THEN spec, THEN iffD2],
       erule_tac [2] exI [THEN exI])
apply (assumption | rule LTerm.intros)+
apply (elim exE)
defer 1

prefer 4 apply (drule spec [THEN spec, THEN iffD1], erule exI [THEN exI])
apply (elim exE)
prefer 4 apply (drule spec [THEN iffD1], assumption)
prefer 4
prefer 4 apply (drule spec [THEN iffD1], assumption)

apply (frule_tac [4] u="<ma, Ta>" in LBoundByD1)
apply (erule_tac [4] LBindingE)
apply (safe elim!: LFreeIn_LTermEs LFO_E2 LBoundBy_LTermEs
        LTag.free_elims LFreeIn_LsubstE LBoundBy_LsubstE)
apply (rule_tac [3] exI [THEN exI])
apply (rule_tac [4] exI [THEN exI])
apply (rule_tac [5] exI [THEN exI])
apply (rule_tac [6] exI [THEN exI])
apply (rule_tac [7] exI [THEN exI])
apply (rule_tac [8] exI [THEN exI])
apply (rule_tac [8] LFreeIn_LTermIs LBoundBy_LTermIs)
apply (rule_tac [7] LFreeIn_LTermIs LBoundBy_LTermIs)
apply (rule_tac [6] LFreeIn_LTermIs LBoundBy_LTermIs)
apply (rule_tac [5] LFreeIn_LTermIs LBoundBy_LTermIs)
apply (rule_tac [4] LFreeIn_LTermIs LBoundBy_LTermIs)
apply (rule_tac [3] LFreeIn_LTermIs LBoundBy_LTermIs)
apply (rule_tac [2] LFreeIn_LTermIs LBoundBy_LTermIs)
apply (rule_tac [1] LFreeIn_LTermIs LBoundBy_LTermIs)
prefer 3
prefer 4
prefer 6
prefer 9
prefer 10
prefer 11
prefer 13
prefer 14
apply assumption+
prefer 4
apply (subgoal_tac "n: list(nat)")
apply (simp only: app_right_Nil)
apply (erule LFreeInE2)+
apply (rule LOcc_domain [THEN subsetD, THEN SigmaD1])
prefer 2 apply assumption
apply assumption
apply (blast intro: LFV_I)+
done

lemma LAlpha_LAppI:
  "[| LAlpha(A, C); LAlpha(B, D) |] ==> LAlpha(LApp(A, B), LApp(C, D))"
apply (unfold LAlpha_def)
apply (elim conjE)
apply (rule conjI)
apply (erule LSkeltonEq_LAppI)
apply assumption
apply (subgoal_tac "A: LTerm" "B: LTerm" "C: LTerm" "D: LTerm")
defer 1
apply (erule LSkeltonEqD1 LSkeltonEqD2)+
apply (rule conjI)
apply (rule_tac [2] iffI [THEN allI, THEN allI])
apply (rule iffI [THEN allI])
apply (safe elim!: LFreeIn_LTermEs LBoundBy_LTermEs)

prefer 8 apply (drule spec [THEN spec, THEN iffD2], erule exI [THEN exI])
apply (elim exE)
apply (intro exI)
prefer 8 apply (drule spec [THEN spec, THEN iffD2], erule exI [THEN exI])
apply (elim exE)
apply (intro exI)
prefer 8 apply (drule spec [THEN spec, THEN iffD1], erule exI [THEN exI])
apply (elim exE)
apply (intro exI)
prefer 8 apply (drule spec [THEN spec, THEN iffD1], erule exI [THEN exI])
apply (elim exE)
apply (intro exI)
prefer 8 apply (drule spec [THEN iffD2], assumption)
prefer 8 apply (drule spec [THEN iffD2], assumption)
prefer 8 apply (drule spec [THEN iffD1], assumption)
prefer 8 apply (drule spec [THEN iffD1], assumption)

apply (rule LFreeIn_LTermIs LBoundBy_LTermIs, assumption+)+
done

lemmas LAlpha_LTermIs = LAlpha_LVarI LAlpha_LLamI1
                      LAlpha_LLamI2 LAlpha_LAppI

lemma LFreeForIn_name_change:
  assumes prem1: "LFreeForIn(LVar(y), x, M)"
  and prem2: "LFreeForIn(N, x, M)"
  and prem3: "y ~: LFV(M)"
  shows "LFreeForIn(N, y, Lsubst(M, x, LVar(y)))"
apply (rule prem1 [THEN LFreeForInE])
apply (rule prem2 [THEN LFreeForInE])
apply (insert prem3)
apply (rule LFreeForInI)
apply (safe elim!: LTerm_typeEs LOcc_LsubstE LFreeIn_LsubstE LFO_E
                   LOcc_LTermEs LTag.free_elims LFreeIn_LTermEs
            intro!: Lsubst_type)
apply (erule notE, erule LFV_I)
apply (erule spec [THEN spec, THEN spec, THEN mp], erule conjI)
apply safe
prefer 3 apply assumption
prefer 2 apply assumption
apply (subgoal_tac "n: list(nat)")
prefer 2
apply (erule LFreeInE2)
apply (erule LOcc_typeD1)
apply assumption
apply (simp only: app_right_Nil)
done

lemma LFV_Lsubst_notI:
  "[| x ~= y; x: LVariable; M: LTerm |]
       ==> y ~: LFV(Lsubst(M, y, LVar(x)))"
apply (rule notI)
apply (safe elim!: LFreeIn_LsubstE LFO_E LFV_E LFreeIn_LTermEs
           LTag.free_elims)
done

lemma LAlpha_LLamI3:
  "[| LAlpha(M, N); LFreeForIn(LVar(y), x, N); y ~: LFV(N) |]
       ==> LAlpha(LLam(x, M), LLam(y, Lsubst(N, x, LVar(y))))"
apply (frule LFreeForInD1)
apply (erule LTerm_typeEs)
apply (frule LFreeForInD2)
apply (frule LAlphaD1 [THEN LSkeltonEqD2])
apply (case_tac "y = x")
apply hypsubst
apply (rule LAlpha_LLamI1)
apply (simp add: Lsubst_self)
apply assumption
apply (rule LAlpha_LLamI2)
apply (simp add: Lsubst_lemma2 Lsubst_self)
apply (assumption | rule LFV_Lsubst_notI LFreeForIn_left_LVarI
         LFreeForIn_name_change)+
done

lemma Infinite_LVariable_LAlpha_lemma:
  assumes infv: "Infinite(LVariable)"
  and major: "M: LTerm"
  shows
    "[| x: LVariable; N: LTerm |] ==>
       EX M': LTerm. LAlpha(M, M') & LFreeForIn(N, x, M')"
apply (rule major [THEN LTerm.induct])
apply (rule bexI)
apply (assumption | rule LAlpha_LTermIs LFreeForIn_LTermIs
         LTerm.intros conjI)+
apply safe
apply (rule_tac F="cons(xa, LAV(N) Un LAV(M'))" in infv [THEN InfiniteE])
apply (assumption | rule Fin.intros LAV_Fin Fin_UnI)+
apply (rule_tac x="LLam(xaa, Lsubst(M', xa, LVar(xaa)))" in bexI)
prefer 2
apply (assumption | rule LTerm.intros Lsubst_type)+
apply (subgoal_tac "xaa ~: LFV(M')" "LFreeForIn(LVar(xaa), xa, M')")
apply safe
prefer 4 apply (blast intro: LFV_subset_LAV [THEN subsetD])
apply (erule_tac [3] swap, rule_tac [3] LFreeForInI)
prefer 6 apply (blast elim!: LFV_E LFreeIn_LTermEs LTag.free_elims
                      intro: LAV_I2)
apply (rule LAlpha_LLamI2)
apply (simp add: Lsubst_self Lsubst_lemma2)
apply (rule LFreeForIn_name_change)
apply (rule_tac [4] LFV_Lsubst_notI)
apply (assumption | rule LFreeForIn_left_LVarI)+
apply (rule LFreeForInI)
prefer 5
prefer 6
prefer 7
prefer 8
apply (assumption | rule conjI bexI LAlpha_LTermIs LFreeForIn_LTermIs
         LTerm.intros Lsubst_type)+
apply (safe elim!: LFV_E LFreeIn_LsubstE LFO_E2
                 LFreeForInE LOcc_LsubstE initseg_left_ConsE
                 list.free_elims LOcc_LTermEs LFreeIn_LTermEs
                 LTag.free_elims)
apply (erule LFreeInE2)+
apply (erule notE, erule LAV_I1)
apply assumption
apply (erule spec [THEN spec, THEN spec, THEN mp], intro conjI)
prefer 2 apply assumption
apply (assumption | rule LFV_I)+
done

lemma Infinite_LVariable_LAlpha_lemma2:
  assumes infv:  "Infinite(LVariable)"
  and major: "M: LTerm"
  shows
    "[| x: LVariable; X: Fin(LTerm) |] ==>
       EX M': LTerm. LAlpha(M, M') & (ALL N: X. LFreeForIn(N, x, M'))"
apply (rule major [THEN LTerm.induct])
apply (rule bexI)
apply ((assumption | rule LAlpha_LTermIs LFreeForIn_LTermIs
         LTerm.intros conjI ballI)
       | (drule Fin.dom_subset [THEN subsetD, THEN PowD],
          erule subsetD))+
apply safe
apply (rule_tac F="cons(xa, (UN N: X. LAV(N)) Un LAV(M'))" in
         infv [THEN InfiniteE])
apply (assumption | rule Fin.intros LAV_Fin Fin_UnI Fin_UnionI
        Fin_RepFunI)+

apply (rule_tac x="LLam(xaa, Lsubst(M', xa, LVar(xaa)))" in bexI)
prefer 2
apply (assumption | rule LTerm.intros Lsubst_type)+
apply (subgoal_tac "xaa ~: LFV(M')" "LFreeForIn(LVar(xaa), xa, M')")
apply safe
prefer 4 apply (blast intro!: LFV_subset_LAV [THEN subsetD])
apply (erule_tac [3] swap, rule_tac [3] LFreeForInI)
prefer 6 apply (blast elim!: LFV_E LFreeIn_LTermEs LTag.free_elims
                 intro: LAV_I2)
apply (rule LAlpha_LLamI2)
apply (simp add: Lsubst_self Lsubst_lemma2)
apply (rule LFreeForIn_name_change)
apply (rule_tac [4] LFV_Lsubst_notI)
apply (assumption | rule LFreeForIn_left_LVarI)+
apply (rule LFreeForInI)
defer 4
apply ((assumption | rule conjI Lsubst_type bexI LFV_I ballI
          LAlpha_LTermIs LFreeForIn_LAppI LTerm.intros)
       | (drule Fin.dom_subset [THEN subsetD, THEN PowD],
          erule subsetD)
       | (erule bspec))+
apply (safe elim!: LFV_E LFreeIn_LsubstE LFO_E2 LFreeForInE
        LOcc_LsubstE initseg_left_ConsE list.free_elims
        LOcc_LTermEs LFreeIn_LTermEs LTag.free_elims)
apply (erule LFreeInE2)+
apply (erule swap, rule UnionI)
apply (rule RepFunI)
apply assumption
apply (erule LAV_I1)
apply assumption
apply (drule bspec, assumption)
apply (erule LFreeForInE)
apply (erule spec [THEN spec, THEN spec, THEN mp], intro conjI,
       erule_tac [2] asm_rl)
prefer 2 apply assumption
apply (assumption | rule LFV_I)+
done

lemma LAlpha_LVarE:
  assumes major: "LAlpha(LVar(x), N)"
  and prem: "[| N = LVar(x); x: LVariable |] ==> R"
  shows "R"
apply (insert major)
apply (unfold LAlpha_def)
apply (rule prem)
apply (safe elim!: LSkeltonEq_LVarE)
apply (drule spec [THEN iffD1])
apply (rule LFreeIn_LTermIs)
apply (erule_tac [2] LFreeIn_LTermEs)
apply (safe elim!: LTag.free_elims)
done

lemma LAlpha_LLamE:
  assumes infv: "Infinite(LVariable)"
  and major: "LAlpha(LLam(x, M), N)"
  and prem1:
     "!! N'. [| N = LLam(x, N'); LAlpha(M, N') |] ==> R"
  and prem2:
     "!! y M' N'. [| N = LLam(y, N'); LAlpha(M, M');
                   LFreeForIn(LVar(y), x, M'); y ~: LFV(M');
                   LAlpha(N', Lsubst(M', x, LVar(y)))
      |] ==> R"
  shows "R"
apply (insert major)
apply (unfold LAlpha_def)
apply safe
apply (erule LSkeltonEq_LLamE)
apply (frule LSkeltonEqD1)
apply (frule LSkeltonEqD2)
apply (case_tac "x = y")
apply hypsubst
prefer 2
apply (rule_tac [2] prem1)
apply (rule_tac [1] M1="M" and N1="LVar(y)" and x1="x" in
        infv [THEN Infinite_LVariable_LAlpha_lemma, THEN bexE])
apply (assumption | rule LTerm.intros)+
apply (erule conjE)
apply (rule prem2)
prefer 6
apply assumption+
apply (unfold LAlpha_def)
apply (safe elim!: LFV_E)
apply (drule spec [THEN iffD2], assumption)
apply (drule spec [THEN iffD1], rule LFreeIn_LLamI)
apply assumption
apply (safe elim!: LFreeIn_LTermEs LTag.free_elims)
apply (erule LSkeltonEq_sym [THEN LSkeltonEq_trans])
apply (erule LSkeltonEq_trans)
apply (assumption | rule LSkeltonEq_Lsubst_LVar)+

apply (rule LFreeInE)
apply assumption
apply hypsubst
apply (case_tac "xaa = y")
apply hypsubst
prefer 2
apply (drule spec [THEN iffD2], erule LFreeIn_LLamI)
apply assumption+
apply (clarify elim!: LFreeIn_LTermEs list.free_elims LTag.free_elims)
apply (drule spec [THEN iffD1], assumption)
apply (rule LFreeIn_LsubstI1)
apply assumption+
apply (drule spec [THEN spec, THEN iffD2], rule exI [THEN exI],
       erule LBoundBy_LLamI1)
apply (safe elim!: LBoundBy_LTermEs list.free_elims LTag.free_elims)
apply (rule_tac P="%z. LFreeIn(<z, TLVar(y)>, Lsubst(xa, x, LVar(y)))"
        in app_right_Nil [THEN subst])
apply (rule_tac [2] LFreeIn_LsubstI2)
apply (drule_tac [4] spec [THEN iffD1], erule_tac [4] asm_rl)
apply (erule LFreeInE2)
apply (erule LOcc_typeD1)
apply (assumption | rule LFO_I LFreeIn_LTermIs)+

apply (rule LFreeInE)
apply assumption
apply hypsubst
apply (erule LFreeIn_LsubstE)
apply (assumption | rule LTerm.intros)+
apply (safe elim!: LFreeIn_LTermEs LFO_E LTag.free_elims)
apply (drule spec [THEN iffD2], assumption)
apply (drule spec [THEN iffD1], erule LFreeIn_LLamI)
apply blast
apply assumption
apply (safe elim!: LFreeIn_LTermEs list.free_elims LTag.free_elims)
apply (subgoal_tac "n: list(nat)")
prefer 2
apply (erule LFreeInE2, erule LOcc_typeD1, assumption)
apply (simp only: app_right_Nil)
apply (drule spec [THEN iffD2], assumption)
apply (drule spec [THEN spec, THEN iffD1], rule exI [THEN exI],
       erule LBoundBy_LLamI1)
apply (safe elim!: LBoundBy_LTermEs list.free_elims LTag.free_elims)

apply (frule LBoundByD1)
apply (erule LBindingE)
apply (frule_tac [2] LBoundByD1)
apply (erule_tac [2] LBindingE)
apply safe
apply (drule spec [THEN spec, THEN iffD2], rule exI [THEN exI],
       erule LBoundBy_LLamI2)
apply assumption
apply (safe elim!: LBoundBy_LTermEs list.free_elims LTag.free_elims)
apply (drule spec [THEN spec, THEN iffD1], erule exI [THEN exI])
apply (erule exE)+
apply (frule_tac M="xa" in LBoundByD1)
apply (erule LBindingE)
apply clarify
apply (rule exI)+
apply (rule LBoundBy_LsubstI1)
apply (assumption | rule LTerm.intros)+

apply (safe elim!: LBoundBy_LsubstE LBoundBy_LTermEs
        list.free_elims LTag.free_elims)
apply (drule spec [THEN spec, THEN iffD2], erule exI [THEN exI])
apply (erule exE)+
apply (frule_tac M="M" in LBoundByD1)
apply (erule LBindingE)
apply safe
apply (drule spec [THEN spec, THEN iffD1], rule exI [THEN exI],
       erule LBoundBy_LLamI2)
apply assumption
apply (safe elim!: LBoundBy_LTermEs list.free_elims LTag.free_elims)
apply (erule exI [THEN exI])

apply (rule LFreeInE)
apply assumption
apply hypsubst
apply (rule_tac [2] LFreeInE)
prefer 2 apply assumption
apply (case_tac "xa = x")
apply hypsubst
prefer 2
apply (drule spec [THEN iffD1], erule LFreeIn_LLamI)
apply assumption+
apply (safe elim!: LFreeIn_LTermEs list.free_elims LTag.free_elims)
apply (drule spec [THEN spec, THEN iffD1], rule exI [THEN exI],
       erule LBoundBy_LLamI1)
apply (safe elim!: LBoundBy_LTermEs list.free_elims LTag.free_elims)

apply (case_tac "xa = x")
apply hypsubst
prefer 2
apply (drule spec [THEN iffD2], erule LFreeIn_LLamI)
apply assumption+
apply (safe elim!: LFreeIn_LTermEs list.free_elims LTag.free_elims)
apply (drule spec [THEN spec, THEN iffD2], rule exI [THEN exI],
       erule LBoundBy_LLamI1)
apply (safe elim!: LBoundBy_LTermEs list.free_elims LTag.free_elims)

apply (frule LBoundByD1)
apply (erule LBindingE)
apply (frule_tac [2] LBoundByD1)
apply (erule_tac [2] LBindingE)
apply safe
apply (drule spec [THEN spec, THEN iffD1], rule exI [THEN exI],
       erule LBoundBy_LLamI2)
apply (drule_tac [3] spec [THEN spec, THEN iffD2],
       rule_tac [3] exI [THEN exI],
       erule_tac [3] LBoundBy_LLamI2)
apply (safe elim!: LBoundBy_LTermEs list.free_elims LTag.free_elims)
apply (assumption | rule exI)+
done

lemma LAlpha_LAppE:
  assumes major: "LAlpha(LApp(A, B), N)"
  and prem: "!! C D. [| N = LApp(C, D); LAlpha(A, C); LAlpha(B, D) |] ==> R"
  shows "R"
apply (insert major)
apply (unfold LAlpha_def)
apply (elim conjE)
apply (erule LSkeltonEq_LAppE)
apply (subgoal_tac "A: LTerm" "B: LTerm" "C: LTerm" "D: LTerm")
defer 1
apply (erule LSkeltonEqD1 LSkeltonEqD2)+
apply (rule prem)
apply assumption
apply (unfold LAlpha_def)
apply safe

prefer 8 apply (frule LBoundByD1, erule LBindingE)
prefer 8 apply (frule LBoundByD1, erule LBindingE)
prefer 8 apply (rule LFreeInE, assumption, hypsubst)
prefer 8 apply (rule LFreeInE, assumption, hypsubst)
prefer 8 apply (frule LBoundByD1, erule LBindingE)
prefer 8 apply (frule LBoundByD1, erule LBindingE)
prefer 8 apply (rule LFreeInE, assumption, hypsubst)
prefer 8 apply (rule LFreeInE, assumption, hypsubst)
apply safe

apply (drule_tac [8] spec [THEN spec, THEN iffD2],
       rule_tac [8] exI [THEN exI],
       erule_tac [8] LBoundBy_LAppI2)
apply (drule_tac [7] spec [THEN spec, THEN iffD1],
       rule_tac [7] exI [THEN exI],
       erule_tac [7] LBoundBy_LAppI2)
apply (drule_tac [6] spec [THEN iffD2],
       erule_tac [6] LFreeIn_LAppI2)
apply (drule_tac [5] spec [THEN iffD1],
       erule_tac [5] LFreeIn_LAppI2)
apply (drule_tac [4] spec [THEN spec, THEN iffD2],
       rule_tac [4] exI [THEN exI],
       erule_tac [4] LBoundBy_LAppI1)
apply (drule_tac [3] spec [THEN spec, THEN iffD1],
       rule_tac [3] exI [THEN exI],
       erule_tac [3] LBoundBy_LAppI1)
apply (drule_tac [2] spec [THEN iffD2],
       erule_tac [2] LFreeIn_LAppI1)
apply (drule_tac [1] spec [THEN iffD1],
       erule_tac [1] LFreeIn_LAppI1)
apply (safe elim!: LFreeIn_LTermEs LBoundBy_LTermEs
         list.free_elims LTag.free_elims)
apply (assumption | rule exI)+
done

lemmas LAlpha_LTermEs = LAlpha_LVarE LAlpha_LLamE LAlpha_LAppE

(** Rules for depth induction **)
lemmas LTerm_Occ_Term_cons = Occ_Term_cons [OF
  LTerm_Occ_ind_cond LTerm_Term_cons_inj_cond]

lemma depth_ind_LLam:
  "[| LOcc(LLam(x, M)) <= Occ_fbs_op(LTag, Z); x: LVariable; M: LTerm |]
     ==> LOcc(M) <= domain(Z) * LTag"
apply (rule_tac P="%x. x <= domain(Z) * LTag" in ssubst)
apply (erule_tac [2] b="0" in Occ_subtree_Occ_fbs_op_lemma)
apply (simp add: LTerm_cons_eqns_sym LTerm_Occ_Term_cons
        Occ_subtree_Occ_cons)
done

lemma depth_ind_LApp1:
  "[| LOcc(LApp(M, N)) <= Occ_fbs_op(LTag, Z); M: LTerm; N: LTerm |]
     ==> LOcc(M) <= domain(Z) * LTag"
apply (rule_tac P="%x. x <= domain(Z) * LTag" in ssubst)
apply (erule_tac [2] b="0" in Occ_subtree_Occ_fbs_op_lemma)
apply (simp add: LTerm_cons_eqns_sym LTerm_Occ_Term_cons
        Occ_subtree_Occ_cons)
done

lemma depth_ind_LApp2:
  "[| LOcc(LApp(M, N)) <= Occ_fbs_op(LTag, Z); M: LTerm; N: LTerm |]
     ==> LOcc(N) <= domain(Z) * LTag"
apply (rule_tac P="%x. x <= domain(Z) * LTag" in ssubst)
apply (erule_tac [2] b="1" in Occ_subtree_Occ_fbs_op_lemma)
apply (simp add: LTerm_cons_eqns_sym LTerm_Occ_Term_cons
        Occ_subtree_Occ_cons)
done

lemma depth_ind_LSkeltonEq:
  "[| LSkeltonEq(M, N); LOcc(M) <= domain(Z) * LTag |] ==>
      LOcc(N) <= domain(Z) * LTag"
apply (unfold LSkeltonEq_def)
apply safe
apply (rule LOcc_domain [THEN subsetD, THEN SigmaE])
prefer 2 apply assumption
apply safe
apply (erule LTag.cases)
apply safe
prefer 3 apply (drule spec [THEN iffD2], assumption)
prefer 3 apply (drule spec [THEN iffD2], erule exI)
apply (erule exE)
prefer 3 apply (drule spec [THEN iffD2], erule exI)
apply (erule exE)
apply (drule subsetD, assumption, erule SigmaD1)+
done

lemma LAlpha_LsubstI:
  assumes prem1: "LAlpha(M, M')"
  and prem2: "LAlpha(N, N')"
  and prem3: "LFreeForIn(N, x, M)"
  and prem4: "LFreeForIn(N', x, M')"
  shows "LAlpha(Lsubst(M, x, N), Lsubst(M', x, N'))"
apply (subgoal_tac "M: LTerm" "M': LTerm" "N: LTerm" "N': LTerm")
defer 1
apply (rule prem1 [THEN LAlphaD1, THEN LSkeltonEqD1]
            prem1 [THEN LAlphaD1, THEN LSkeltonEqD2]
            prem2 [THEN LAlphaD1, THEN LSkeltonEqD1]
            prem2 [THEN LAlphaD1, THEN LSkeltonEqD2])+
apply (insert prem3 prem4)
apply (rule LAlphaI)
apply (unfold LSkeltonEq_def)
apply (safe elim!: LOcc_LsubstE LFO_E2 intro!: Lsubst_type)
apply (drule_tac [2] prem1 [THEN LAlphaD2]
                     prem1 [THEN LAlpha_sym, THEN LAlphaD2])
apply (drule_tac [4] prem1 [THEN LAlphaD2]
                     prem1 [THEN LAlpha_sym, THEN LAlphaD2])
apply (drule_tac [6] prem1 [THEN LAlphaD2]
                     prem1 [THEN LAlpha_sym, THEN LAlphaD2])
apply (drule_tac [8] prem1 [THEN LAlphaD2]
                     prem1 [THEN LAlpha_sym, THEN LAlphaD2])
apply (drule_tac [10] prem1 [THEN LAlphaD2]
                      prem1 [THEN LAlpha_sym, THEN LAlphaD2])
apply (drule_tac [12] prem1 [THEN LAlphaD2]
                      prem1 [THEN LAlpha_sym, THEN LAlphaD2])
apply (frule_tac [1] prem1 [THEN LAlphaD1, THEN LSkeltonEq_TLVarD])
apply (frule_tac [2] prem2 [THEN LAlphaD1, THEN LSkeltonEq_TLVarD])
apply (frule_tac [3] prem1 [THEN LAlpha_sym, THEN LAlphaD1, THEN LSkeltonEq_TLVarD])
apply (frule_tac [4] prem2 [THEN LAlpha_sym, THEN LAlphaD1, THEN LSkeltonEq_TLVarD])
apply (frule_tac [5] prem1 [THEN LAlphaD1, THEN LSkeltonEq_TLLamD])
apply (frule_tac [6] prem2 [THEN LAlphaD1, THEN LSkeltonEq_TLLamD])
apply (frule_tac [7] prem1 [THEN LAlpha_sym, THEN LAlphaD1, THEN LSkeltonEq_TLLamD])
apply (frule_tac [8] prem2 [THEN LAlpha_sym, THEN LAlphaD1, THEN LSkeltonEq_TLLamD])
apply (frule_tac [9] prem1 [THEN LAlphaD1, THEN LSkeltonEq_TLAppD])
apply (frule_tac [10] prem2 [THEN LAlphaD1, THEN LSkeltonEq_TLAppD])
apply (frule_tac [11] prem1 [THEN LAlpha_sym, THEN LAlphaD1, THEN LSkeltonEq_TLAppD])
apply (frule_tac [12] prem2 [THEN LAlpha_sym, THEN LAlphaD1, THEN LSkeltonEq_TLAppD])
apply safe
apply (erule_tac [12] LFO_I [THEN LOcc_LsubstI2])
apply (rule_tac [11] LOcc_LsubstI1)
apply (erule_tac [10] LFO_I [THEN LOcc_LsubstI2])
apply (rule_tac [9] LOcc_LsubstI1)
apply (rule_tac [8] exI, erule_tac [8] LFO_I [THEN LOcc_LsubstI2])
apply (rule_tac [7] exI, rule_tac [7] LOcc_LsubstI1)
apply (rule_tac [6] exI, erule_tac [6] LFO_I [THEN LOcc_LsubstI2])
apply (rule_tac [5] exI, rule_tac [5] LOcc_LsubstI1)
apply (rule_tac [4] exI, erule_tac [4] LFO_I [THEN LOcc_LsubstI2])
apply (rule_tac [3] exI, rule_tac [3] LOcc_LsubstI1)
apply (rule_tac [2] exI, erule_tac [2] LFO_I [THEN LOcc_LsubstI2])
apply (rule_tac [1] exI, rule_tac [1] LOcc_LsubstI1)
defer 1 apply assumption+
defer 1 apply assumption+
defer 1 apply assumption+
defer 1 apply assumption+
defer 1 apply assumption+
defer 1 apply assumption+
defer 1
defer 1
defer 1
defer 1
apply (safe elim!: LFO_E LTag.free_elims)
apply (drule_tac [2] prem1 [THEN LAlphaD2])
apply (drule_tac [1] prem1 [THEN LAlpha_sym, THEN LAlphaD2])
apply (subgoal_tac [2] "TLVar(xa) = TLVar(x)")
prefer 3
apply (erule LFreeInE2)
apply (rule LOcc_in_Occ_range [THEN Occ_range_functionalD,
        THEN functionalD])
prefer 2 apply assumption
apply assumption+
apply (subgoal_tac "TLVar(xa) = TLVar(x)")
prefer 2
apply (erule LFreeInE2)
apply (rule LOcc_in_Occ_range [THEN Occ_range_functionalD,
        THEN functionalD])
prefer 2 apply assumption
apply assumption+
apply (erule notE, simp, erule LFO_I)+
apply (safe elim!: LFreeIn_LsubstE LBoundBy_LsubstE LFO_E2)
apply (drule_tac [8] prem2 [THEN LAlpha_sym, THEN LAlphaD3])
apply (drule_tac [7] prem1 [THEN LAlpha_sym, THEN LAlphaD3])
apply (drule_tac [6] prem2 [THEN LAlphaD3])
apply (drule_tac [5] prem1 [THEN LAlphaD3])
apply (blast intro: prem1 [THEN LAlphaD2] prem2 [THEN LAlphaD2]
        prem1 [THEN LAlpha_sym, THEN LAlphaD2]
        prem2 [THEN LAlpha_sym, THEN LAlphaD2]
        LFO_I LFreeIn_LsubstI2 LFreeIn_LsubstI1
        LBoundBy_LsubstI2 LBoundBy_LsubstI1)+
done

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory ClockView
imports
  KBPsAlg
  Eval
  List_local
  ODList
  Trie
  "../Transitive-Closure/Transitive_Closure_List_Impl"
  "~~/src/HOL/Library/Mapping"
begin
(*>*)

subsection{* The Clock View *}

text{*

\label{sec:kbps-theory-clock-view}

The \emph{clock view} records the current time and the observation for
the most recent state:

*}

definition (in Environment)
  clock_jview :: "('a, 's, nat \<times> 'obs) JointView"
where
  "clock_jview \<equiv> \<lambda>a t. (tLength t, envObs a (tLast t))"
(*<*)

context Environment
begin

lemma clock_jview_tInit:
  "clock_jview a (tInit s) = (0, envObs a s)"
  unfolding clock_jview_def by simp

lemma clock_jview_tStep:
  "clock_jview a (t \<leadsto> s) = (Suc (tLength t), envObs a s)"
  unfolding clock_jview_def by simp

lemma clock_jview_tStepI[intro]:
  "\<lbrakk> tLength t = Suc n; envObs a (tLast t) = obs \<rbrakk>
     \<Longrightarrow> clock_jview a t = (Suc n, obs)"
  unfolding clock_jview_def by (cases t) simp_all

lemma clock_jview_inv:
  "clock_jview a t = (n, obs) \<Longrightarrow> envObs a (tLast t) = obs"
  unfolding clock_jview_def by (cases t) simp_all

lemmas clock_jview_simps =
  clock_jview_tInit
  clock_jview_tStep
  clock_jview_inv

lemma clock_jview_eq_inv[iff]:
  "clock_jview a t' = clock_jview a t
    \<longleftrightarrow> tLength t' = tLength t \<and> envObs a (tLast t') = envObs a (tLast t)"
  by (fastforce simp: clock_jview_def)

end(*>*)

text{*

This is the least-information synchronous view, given the requirements
of \S\ref{sec:kbps-views}. We show that finite-state implementations
exist for all environments with respect to this view as per
\citet{Ron:1996}.

The corresponding incremental view simply increments the counter
records the new observation.

*}

definition (in Environment)
  clock_jviewInit :: "'a \<Rightarrow> 'obs \<Rightarrow> nat \<times> 'obs"
where
  "clock_jviewInit \<equiv> \<lambda>a obs. (0, obs)"

definition (in Environment)
  clock_jviewIncr :: "'a \<Rightarrow> 'obs \<Rightarrow> nat \<times> 'obs \<Rightarrow> nat \<times> 'obs"
where
  "clock_jviewIncr \<equiv> \<lambda>a obs' (l, obs). (l + 1, obs')"

text{*

It is straightforward to demonstrate the assumptions of the
incremental environment locale (\S\ref{sec:kbps-environments}) with
respect to an arbitrary environment.

*}

sublocale Environment
        < Clock!: IncrEnvironment jkbp envInit envAction envTrans envVal
                        clock_jview envObs clock_jviewInit clock_jviewIncr
(*<*)
  apply (unfold_locales)
  apply (simp_all add: clock_jviewInit_def clock_jviewIncr_def clock_jview_def)
  done

(*>*)
text{*

As we later show, satisfaction of a formula at a trace @{text "t \<in>
Clock.jkbpC\<^bsub>n\<^esub>"} is determined by the set of final states of traces in
@{text "Clock.jkbpCn"}:

*}

context Environment
begin

abbreviation clock_commonAbs :: "'s Trace \<Rightarrow> 's set" where
  "clock_commonAbs t \<equiv> tLast ` Clock.jkbpCn (tLength t)"

text{*

Intuitively this set contains the states that the agents commonly
consider possible at time @{term "n"}, which is sufficient for
determining knowledge as the clock view ignores paths. Therefore we
can simulate trace @{term "t"} by pairing this abstraction of @{term
"t"} with its final state:

*}

type_synonym (in -) 's clock_simWorlds = "'s set \<times> 's"

definition clock_sim :: "'s Trace \<Rightarrow> 's clock_simWorlds" where
  "clock_sim \<equiv> \<lambda>t. (clock_commonAbs t, tLast t)"

text{*

In the Kripke structure for our simulation, we relate worlds for
@{term "a"} if the sets of commonly-held states coincide, and the
observation of the final states of the traces is the
same. Propositions are evaluated at the final state.

*}

definition clock_simRels :: "'a \<Rightarrow> 's clock_simWorlds Relation" where
  "clock_simRels \<equiv> \<lambda>a. { ((X, s), (X', s')) |X X' s s'.
                          X = X' \<and> {s, s'} \<subseteq> X \<and> envObs a s = envObs a s' }"

definition clock_simVal :: "'s clock_simWorlds \<Rightarrow> 'p \<Rightarrow> bool" where
  "clock_simVal \<equiv> envVal \<circ> snd"

abbreviation clock_simMC :: "('a, 'p, 's clock_simWorlds) KripkeStructure" where
  "clock_simMC \<equiv> mkKripke (clock_sim ` Clock.jkbpC) clock_simRels clock_simVal"
(*<*)

lemma clock_simVal_def2[iff]: "clock_simVal (clock_sim t) = envVal (tLast t)"
  unfolding clock_sim_def clock_simVal_def by simp

lemma clock_sim_range:
  "sim_range Clock.MC clock_simMC clock_sim"
  by (rule sim_rangeI) (simp_all add: clock_sim_def)

lemma clock_simVal:
  "sim_val Clock.MC clock_simMC clock_sim"
  by (rule sim_valI) (simp add: clock_simVal_def clock_sim_def)

lemma clock_sim_f:
  "sim_f Clock.MC clock_simMC clock_sim"
apply (rule sim_fI)
apply (simp add: clock_simRels_def clock_sim_def)
apply (intro conjI)
   apply (fastforce intro!: imageI)
  apply (fastforce intro!: imageI)
 apply (fastforce dest: Clock.mkM_simps(2))
apply (rule_tac x=v in image_eqI)
 apply simp_all
done

lemma clock_sim_r:
  "sim_r Clock.MC clock_simMC clock_sim"
  apply (rule sim_rI)
  apply (clarsimp simp: clock_simRels_def clock_sim_def)
  apply (rule_tac x=xa in exI)
  unfolding Clock.mkM_def
  apply auto
  done

(*>*)
text{*

That this is in fact a simulation
(\S\ref{sec:kripke-theory-simulations}) is entirely straightforward.

*}

lemma clock_sim:
  "sim Clock.MC clock_simMC clock_sim"
(*<*)
  using clock_sim_range clock_simVal clock_sim_f clock_sim_r
  unfolding sim_def
  by blast
(*>*)

end (* context Environment *)

text{*

The @{text "SimIncrEnvironment"} of
\S\ref{sec:kbps-theory-automata-env-sims} only requires that we
provide it an @{term "Environment"} and a simulation.

*}

sublocale Environment
        < Clock!: SimIncrEnvironment jkbp envInit envAction envTrans envVal
                  clock_jview envObs clock_jviewInit clock_jviewIncr
                  clock_sim clock_simRels clock_simVal
(*<*)
  by (unfold_locales, simp_all add: clock_sim)
(*>*)

text{*

We next consider algorithmic issues.

*}

(* **************************************** *)

subsubsection{* Representations *}

text{*

\label{sec:kbps-theory-clock-view-rep}

We now turn to the issue of how to represent equivalence classes of
states. As these are used as map keys, it is easiest to represent them
canonically. A simple approach is to use \emph{ordered distinct lists}
of type @{typ "'a odlist"} for the sets and \emph{tries} for the
maps. Therefore we ask that environment states @{typ "'s"} belong to
the class @{text "linorder"} of linearly-ordered types, and moreover
that the set @{text "agents"} be effectively presented. We introduce a
new locale capturing these requirements:

*}

locale FiniteLinorderEnvironment =
  Environment jkbp envInit envAction envTrans envVal envObs
    for jkbp :: "('a::{finite, linorder}, 'p, 'aAct) JKBP"
    and envInit :: "('s::{finite, linorder}) list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
    and envObs :: "'a \<Rightarrow> 's \<Rightarrow> 'obs"
+ fixes agents :: "'a odlist"
  assumes agents: "ODList.toSet agents = UNIV"

context FiniteLinorderEnvironment
begin

text{*

\label{sec:kbps-theory-clock-view-algops}

For a fixed agent @{term "a"}, we can reduce the number of worlds in
@{term "clock_simMC"} by taking its quotient with respect to the
equivalence relation for @{term "a"}. In other words, we represent a
simulated equivalence class by a pair of the set of all states
reachable at a particular time, and the subset of these that @{term
"a"} considers possible. The worlds in our representational Kripke
structure are therefore a pair of ordered, distinct lists:

*}

type_synonym (in -) 's clock_simWorldsRep = "'s odlist \<times> 's odlist"

text{*

We can readily abstract a representation to a set of simulated
equivalence classes:

*}

definition (in -)
  clock_simAbs :: "'s::linorder clock_simWorldsRep \<Rightarrow> 's clock_simWorlds set"
where
  "clock_simAbs X \<equiv> { (ODList.toSet (fst X), s) |s. s \<in> ODList.toSet (snd X) }"

text{*

Assuming @{term "X"} represents a simulated equivalence class for
@{term "t \<in> jkbpC"}, @{term "clock_simAbs X"} decomposes into these
two functions:

*}

definition
  agent_abs :: "'a \<Rightarrow> 's Trace \<Rightarrow> 's set"
where
  "agent_abs a t \<equiv>
     { tLast t' |t'. t' \<in> Clock.jkbpC \<and> clock_jview a t' = clock_jview a t}"

definition
  common_abs :: "'s Trace \<Rightarrow> 's set"
where
  "common_abs t \<equiv> tLast ` Clock.jkbpCn (tLength t)"
(*<*)

lemma aec_refl[intro, simp]:
  "t \<in> Clock.jkbpC \<Longrightarrow> tLast t \<in> agent_abs a t"
  unfolding agent_abs_def by auto

lemma aec_cec_subset:
  assumes tC: "t \<in> Clock.jkbpC"
      and aec: "ODList.toSet aec = agent_abs a t"
      and cec: "ODList.toSet cec = common_abs t"
  shows "x \<in> ODList.toSet aec \<Longrightarrow> x \<in> ODList.toSet cec"
  using assms
  unfolding agent_abs_def common_abs_def
  by fastforce

lemma clock_simAbs_refl:
  assumes tC: "t \<in> Clock.jkbpC"
      and ec: "clock_simAbs ec = Clock.sim_equiv_class a t"
  shows "clock_sim t \<in> clock_simAbs ec"
  using assms by simp

lemma common_abs:
  assumes tC: "t \<in> Clock.jkbpC"
  assumes ec: "clock_simAbs ec = Clock.sim_equiv_class a t"
  shows "ODList.toSet (fst ec) = common_abs t"
  using tC clock_simAbs_refl[OF tC ec]
  unfolding clock_sim_def clock_simAbs_def common_abs_def
  by (auto simp: ODList.toSet_def[symmetric])

lemma agent_abs:
  assumes tC: "t \<in> Clock.jkbpC"
  assumes ec: "clock_simAbs ec = Clock.sim_equiv_class a t"
  shows "ODList.toSet (snd ec) = agent_abs a t"
  using assms
  unfolding clock_sim_def clock_simAbs_def agent_abs_def
  apply auto
  apply (subgoal_tac "(ODList.toSet (fst ec), x) \<in> {(ODList.toSet (fst ec), s) |s. s \<in> ODList.toSet (snd ec)}")
  apply auto (* FIXME filthy *)
  done

(*>*)
text{*

This representation is canonical on the domain of interest (though not
in general):

*}

lemma clock_simAbs_inj_on:
  "inj_on clock_simAbs { x . clock_simAbs x \<in> Clock.jkbpSEC }"
(*<*)
proof(rule inj_onI)
  fix x y
  assume x: "x \<in> { x . clock_simAbs x \<in> Clock.jkbpSEC }"
     and y: "y \<in> { x . clock_simAbs x \<in> Clock.jkbpSEC }"
     and xy: "clock_simAbs x = clock_simAbs y"
  from x obtain a t
    where tC: "t \<in> Clock.jkbpC"
      and ec: "clock_simAbs x = Clock.sim_equiv_class a t"
    by auto
  from common_abs[OF tC ec] common_abs[OF tC trans[OF xy[symmetric] ec], symmetric]
  have "fst x = fst y" by (blast intro: injD[OF toSet_inj])
  moreover
  from agent_abs[OF tC ec] agent_abs[OF tC trans[OF xy[symmetric] ec], symmetric]
  have "snd x = snd y" by (blast intro: injD[OF toSet_inj])
  ultimately show "x = y" by (simp add: prod_eqI)
qed
(*>*)
text{*

We could further compress this representation by labelling each
element of the set of states reachable at time $n$ with a bit to
indicate whether the agent considers that state possible.  Note,
however, that the representation would be non-canonical: if @{text
"(s, True)"} is in the representation, indicating that the agent
considers @{text "s"} possible, then @{text "(s, False)"} may or may
not be. The associated abstraction function is not injective and hence
would obfuscate the following. Repairing this would entail introducing
a new type, which would again complicate this development.

The following lemmas make use of this Kripke structure, constructed
from the set of final states of a temporal slice @{term "X"}:

*}

definition
  clock_repRels :: "'a \<Rightarrow> ('s \<times> 's) set"
where
  "clock_repRels \<equiv> \<lambda>a. { (s, s'). envObs a s = envObs a s' }"

abbreviation
  clock_repMC :: "'s set \<Rightarrow> ('a, 'p, 's) KripkeStructure"
where
  "clock_repMC \<equiv> \<lambda>X. mkKripke X clock_repRels envVal"
(*<*)

lemma clock_repMC_kripke[intro, simp]: "kripke (clock_repMC X)"
  by (rule kripkeI) simp

lemma clock_repMC_S5n[intro, simp]: "S5n (clock_repMC X)"
  unfolding clock_repRels_def
  by (intro S5nI equivI refl_onI symI transI) auto

(*>*)
text{*

We can show that this Kripke structure retains sufficient information
from @{term "Clock.MCS"} by showing simulation. This is eased by
introducing an intermediary structure that focusses on a particular
trace:

*}

abbreviation
  clock_jkbpCSt :: "'b Trace \<Rightarrow> 's clock_simWorlds set"
where
  "clock_jkbpCSt t \<equiv> clock_sim ` Clock.jkbpCn (tLength t)"

abbreviation
  clock_simMCt :: "'b Trace \<Rightarrow> ('a, 'p, 's clock_simWorlds) KripkeStructure"
where
  "clock_simMCt t \<equiv> mkKripke (clock_jkbpCSt t) clock_simRels clock_simVal"

definition clock_repSim :: "'s clock_simWorlds \<Rightarrow> 's" where
  "clock_repSim \<equiv> snd"
(*<*)

lemma jkbpCSt_jkbpCS_subset:
  "clock_jkbpCSt t \<subseteq> clock_sim ` Clock.jkbpC"
  by auto

lemma jkbpCSt_refl[iff]:
  "t \<in> Clock.jkbpC \<Longrightarrow> clock_sim t \<in> clock_jkbpCSt t"
  by blast

lemma fst_clock_sim[iff]:
  "t \<in> Clock.jkbpC \<Longrightarrow> fst (clock_sim t) = tLast ` Clock.jkbpCn (tLength t)"
  by (simp add: clock_sim_def)

lemma clock_repSim_simps[simp]:
  "clock_repSim ` clock_sim ` T = tLast ` T"
  "clock_repSim (clock_sim t) = tLast t"
  unfolding clock_repSim_def clock_sim_def
  by (auto intro!: image_eqI)

(*>*)
text{**}

lemma clock_repSim:
  assumes tC: "t \<in> Clock.jkbpC"
  shows "sim (clock_simMCt t)
             ((clock_repMC \<circ> fst) (clock_sim t))
             clock_repSim"
(*<*) (is "sim ?M ?M' ?f")
proof
  show "sim_range ?M ?M' ?f"
  proof
    show "worlds ?M' = ?f ` worlds ?M"
      unfolding clock_sim_def clock_repSim_def by force
  next
    fix a
    show "relations ?M' a \<subseteq> worlds ?M' \<times> worlds ?M'"
      by (simp add: clock_sim_def clock_repSim_def)
  qed
next
  show "sim_val ?M ?M' ?f"
    by (rule, simp add: clock_sim_def clock_simVal_def clock_repSim_def split: split_split)
next
  show "sim_f ?M ?M' ?f"
    apply rule
    unfolding clock_repRels_def clock_repSim_def clock_simRels_def
    apply (auto iff: clock_sim_def)
    done
next
  show "sim_r ?M ?M' ?f"
    apply rule
    unfolding clock_repRels_def clock_repSim_def clock_simRels_def clock_sim_def
    apply clarsimp
    apply (rule_tac x=xa in image_eqI)
    apply auto
    done
qed

(*>*)
text{*

The following sections show how we satisfy the remaining requirements
of the @{text "Algorithm"} locale of
Figure~\ref{fig:kbps-alg-alg-locale}. Where the proof is routine, we
simply present the lemma without proof or comment.

Due to a limitation in the code generator in the present version of
Isabelle (2011), we need to define the equations we wish to execute
outside of a locale; the syntax @{text "(in -)"} achieves this by
making definitons at the theory top-level. We then define (but elide)
locale-local abbreviations that supply the locale-bound variables to
these definitions.

*}

(* **************************************** *)

subsubsection{* Initial states *}

text{*

The initial states of the automaton for an agent is simply @{term
"envInit"} paired with the partition of @{term "envInit"} under the
agent's observation.

*}

definition (in -)
  clock_simInit :: "('s::linorder) list \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
                \<Rightarrow> 'a \<Rightarrow> 'obs \<Rightarrow> 's clock_simWorldsRep"
where
  "clock_simInit envInit envObs \<equiv> \<lambda>a iobs.
    let cec = ODList.fromList envInit
     in (cec, ODList.filter (\<lambda>s. envObs a s = iobs) cec)"
(*<*)

abbreviation
  clock_simInit :: "'a \<Rightarrow> 'obs \<Rightarrow> 's clock_simWorldsRep"
where
  "clock_simInit \<equiv> ClockView.clock_simInit envInit envObs"

(*>*)
text{**}

lemma clock_simInit:
  assumes "iobs \<in> envObs a ` set envInit"
  shows "clock_simAbs (clock_simInit a iobs)
       = clock_sim ` { t' \<in> Clock.jkbpC.
                       clock_jview a t' = clock_jviewInit a iobs }"
(*<*)
  using assms
  unfolding clock_simInit_def clock_simAbs_def clock_sim_def [abs_def] Let_def
  apply clarsimp
  apply rule
   apply clarsimp
   apply (rule_tac x="tInit s" in image_eqI)
    apply (auto simp: Set.image_def Clock.jviewInit)[2]
  apply clarsimp
  apply (case_tac t)
   apply clarsimp
   apply rule
    apply rule
     apply clarsimp
    apply clarsimp
    apply (rule_tac x="tInit xa" in image_eqI)
    apply (auto intro!: image_eqI simp: Clock.jviewInit)
  done
(*>*)

(* **************************************** *)

subsubsection{* Simulated observations *}

text{*

Agent @{term "a"} will make the same observation at any of the worlds
that it considers possible, so we choose the first one in the list:

*}

definition (in -)
  clock_simObs :: "('a \<Rightarrow> ('s :: linorder) \<Rightarrow> 'obs)
                \<Rightarrow> 'a \<Rightarrow> 's clock_simWorldsRep \<Rightarrow> 'obs"
where
  "clock_simObs envObs \<equiv> \<lambda>a. envObs a \<circ> ODList.hd \<circ> snd"
(*<*)

abbreviation
  clock_simObs :: "'a \<Rightarrow> 's clock_simWorldsRep \<Rightarrow> 'obs"
where
  "clock_simObs \<equiv> ClockView.clock_simObs envObs"

(*>*)
text{**}

lemma clock_simObs:
  assumes tC: "t \<in> Clock.jkbpC"
      and ec: "clock_simAbs ec = Clock.sim_equiv_class a t"
  shows "clock_simObs a ec = envObs a (tLast t)"
(*<*)
proof -
  have A: "\<forall>s \<in> set (toList (snd ec)). envObs a s = envObs a (tLast t)"
    using agent_abs[OF tC ec]
    by (clarsimp simp: agent_abs_def toSet_def)
  have B: "tLast t \<in> set (toList (snd ec))"
    using clock_simAbs_refl[OF assms]
    unfolding clock_simAbs_def clock_sim_def
    by (simp add: toSet_def snd_def)
  show ?thesis
    unfolding clock_simObs_def by (simp add: list_choose_hd[OF A B] ODList.hd_def)
qed
(*>*)

(* **************************************** *)

subsubsection{* Evaluation *}

text{*

\label{sec:kbps-theory-clock-view-eval}

We define our @{text "eval"} function in terms of @{term "evalS"},
which implements boolean logic over @{typ "'s odlist"} in the usual
way -- see \S\ref{sec:kbps-spr-single-agent-eval} for the relevant
clauses. It requires three functions specific to the representation:
one each for propositions, knowledge and common knowledge.

Propositions define subsets of the worlds considered possible:

*}

abbreviation (in -)
  clock_evalProp :: "(('s::linorder) \<Rightarrow> 'p \<Rightarrow> bool)
                  \<Rightarrow> 's odlist \<Rightarrow> 'p \<Rightarrow> 's odlist"
where
  "clock_evalProp envVal \<equiv> \<lambda>X p. ODList.filter (\<lambda>s. envVal s p) X"

text{*

The knowledge relation computes the subset of the
commonly-held-possible worlds @{text "cec"} that agent @{term "a"}
considers possible at world @{term "s"}:

*}

definition (in -)
  clock_knowledge :: "('a \<Rightarrow> ('s :: linorder) \<Rightarrow> 'obs) \<Rightarrow> 's odlist
                  \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> 's odlist"
where
  "clock_knowledge envObs cec \<equiv> \<lambda>a s.
     ODList.filter (\<lambda>s'. envObs a s = envObs a s') cec"

text{*

Similarly the common knowledge operation computes the transitive
closure of the union of the knowledge relations for the agents @{text
"as"}:

*}

definition (in -)
  clock_commonKnowledge :: "('a \<Rightarrow> ('s :: linorder) \<Rightarrow> 'obs) \<Rightarrow> 's odlist
           \<Rightarrow> 'a list \<Rightarrow> 's \<Rightarrow> 's odlist"
where
  "clock_commonKnowledge envObs cec \<equiv> \<lambda>as s.
     let r = \<lambda>a. ODList.fromList [ (s', s'') . s' \<leftarrow> toList cec, s'' \<leftarrow> toList cec,
                                   envObs a s' = envObs a s'' ];
         R = toList (ODList.big_union r as)
      in ODList.fromList (memo_list_trancl R s)"

text{*

The function @{text "memo_list_trancl"} comes from the executable
transitive closure theory of \citep{AFP:TRANCL}.

The evaluation function evaluates a subjective knowledge formula on
the representation of an equivalence class:

*}

definition (in -)
  eval :: "(('s :: linorder) \<Rightarrow> 'p \<Rightarrow> bool)
        \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
        \<Rightarrow> 's clock_simWorldsRep \<Rightarrow> ('a, 'p) Kform \<Rightarrow> bool"
where
  "eval envVal envObs \<equiv> \<lambda>(cec, aec). evalS (clock_evalProp envVal)
                                      (clock_knowledge envObs cec)
                                      (clock_commonKnowledge envObs cec)
                                      aec"

text{*

This function corresponds with the standard semantics:

*}
(*<*)

lemma clock_coEC_relation_image:
  "s \<in> ODList.toSet Y
    \<Longrightarrow> ODList.toSet (clock_knowledge envObs Y a s) = relations (clock_repMC (ODList.toSet Y)) a `` {s}"
  unfolding clock_knowledge_def clock_repRels_def Image_def
  by auto

lemma clock_commonKnowledge_relation_image_aux:
  "(\<Union>x\<in>set as. \<Union>a\<in>ODList.toSet Y. \<Union>aa\<in>ODList.toSet Y \<inter> {s''. envObs x a = envObs x s''}. {(a, aa)})
 = ((\<Union>a\<in>set as. {(s, s'). envObs a s = envObs a s'}) \<inter> ODList.toSet Y \<times> ODList.toSet Y)"
  by auto

lemma clock_commonKnowledge_relation_image:
  "s \<in> ODList.toSet Y
    \<Longrightarrow> ODList.toSet (clock_commonKnowledge envObs Y as s) = (\<Union>a \<in> set as. relations (clock_repMC (ODList.toSet Y)) a)\<^sup>+ `` {s}"
  unfolding clock_commonKnowledge_def clock_repRels_def Let_def
  apply (simp add: memo_list_trancl toSet_def[symmetric] Image_def clock_commonKnowledge_relation_image_aux)
  done

lemma eval_rec_models:
  assumes XY: "ODList.toSet X \<subseteq> ODList.toSet Y"
      and s: "s \<in> ODList.toSet X"
  shows "s \<in> ODList.toSet (eval_rec (clock_evalProp envVal) (clock_knowledge envObs Y) (clock_commonKnowledge envObs Y) X \<phi>)
     \<longleftrightarrow> clock_repMC (ODList.toSet Y), s \<Turnstile> \<phi>"
using XY s
proof(induct \<phi> arbitrary: X s)
  case (Kknows a' \<phi> X s)
  from `s \<in> ODList.toSet X` clock_coEC_relation_image[OF set_mp[OF Kknows(2) Kknows(3)], where a=a']
  show ?case
    apply simp
    apply rule
     apply (drule arg_cong[where f="ODList.toSet"])
     apply (clarsimp simp: odlist_all_iff)
     apply (cut_tac s="w'" and X="clock_knowledge envObs Y a' s" in Kknows.hyps)
      using Kknows(2) Kknows(3)
      apply (auto simp add: S5n_rels_closed[OF clock_repMC_S5n])[3]

    apply (clarsimp simp: toSet_eq_iff odlist_all_iff)
    apply (subst Kknows.hyps)
      using Kknows(2) Kknows(3)
      apply (auto simp add: S5n_rels_closed[OF clock_repMC_S5n])
    done
next
  case (Kcknows as \<phi> X s)
  show ?case
  proof(cases "as = Nil")
    case True with `s \<in> ODList.toSet X` show ?thesis by clarsimp
  next
    case False
    with `s \<in> ODList.toSet X` clock_commonKnowledge_relation_image[OF set_mp[OF Kcknows(2) Kcknows(3)], where as=as]
    show ?thesis
      apply simp
      apply rule
       apply (drule arg_cong[where f="ODList.toSet"])
       apply (clarsimp simp: odlist_all_iff)
       apply (cut_tac s="w'" and X="clock_commonKnowledge envObs Y as s" in Kcknows.hyps)
        using Kcknows(2) Kcknows(3)
        apply (auto simp add: S5n_rels_closed[OF clock_repMC_S5n])[3]
        apply (subst (asm) trancl_unfold) back back back
        apply auto[1] (* FIXME disgusting *)

      apply (clarsimp simp: toSet_eq_iff odlist_all_iff)
      apply (subst Kcknows.hyps)
       using Kcknows(2) Kcknows(3)
       apply (auto simp add: S5n_rels_closed[OF clock_repMC_S5n])
        apply (subst (asm) trancl_unfold) back back back
        apply auto[1] (* FIXME disgusting *)

      done
  qed
qed simp_all

lemma trc_aux:
  assumes tC: "t \<in> Clock.jkbpC"
      and aec: "ODList.toSet aec = agent_abs a t"
      and cec: "ODList.toSet cec = common_abs t"
  shows "ODList.toSet (big_union (clock_commonKnowledge envObs cec as) (toList aec)) \<subseteq> ODList.toSet cec"
  apply (clarsimp simp: toSet_def[symmetric])
  apply (subst (asm) clock_commonKnowledge_relation_image)
   apply (erule aec_cec_subset[OF tC aec cec])
  apply (subst (asm) trancl_unfold)
  using assms
  apply (auto simp: agent_abs_def)
  done

lemma clock_repMC_aec:
  assumes tC: "t \<in> Clock.jkbpC"
      and aec: "ODList.toSet aec = agent_abs a t"
      and cec: "ODList.toSet cec = common_abs t"
      and x: "x \<in> ODList.toSet aec"
      and xy: "(x, y) \<in> relations (clock_repMC (ODList.toSet cec)) a"
  shows "y \<in> ODList.toSet aec"
  using assms
  unfolding clock_repRels_def agent_abs_def common_abs_def
  by auto

lemma clock_repMC_cec:
  assumes tC: "t \<in> Clock.jkbpC"
      and aec: "ODList.toSet aec = agent_abs a t"
      and cec: "ODList.toSet cec = common_abs t"
      and x: "x \<in> ODList.toSet aec"
      and y: "y \<in> ODList.toSet aec"
  shows "(x, y) \<in> relations (clock_repMC (ODList.toSet cec)) a"
  using assms
  unfolding clock_repRels_def agent_abs_def common_abs_def
  by auto

lemma evalS_models:
  assumes tC: "t \<in> Clock.jkbpC"
      and aec: "ODList.toSet aec = agent_abs a t"
      and cec: "ODList.toSet cec = common_abs t"
      and subj_phi: "subjective a \<phi>"
      and s: "s \<in> ODList.toSet aec"
  shows "evalS (clock_evalProp envVal) (clock_knowledge envObs cec) (clock_commonKnowledge envObs cec) aec \<phi>
     \<longleftrightarrow> clock_repMC (ODList.toSet cec), s \<Turnstile> \<phi>" (is "?lhs \<phi> = ?rhs \<phi>")
using subj_phi s aec cec
proof(induct \<phi> rule: subjective.induct[case_names Kprop Knot Kand Kknows Kcknows])
  case (Kknows a a' \<psi>) show ?case
    apply (clarsimp simp: toSet_eq_iff)
    apply rule
     apply clarsimp
     apply (subgoal_tac "w' \<in> ODList.toSet aec")
     apply (drule_tac c="w'" in subsetD)
       apply assumption
      apply (simp add: eval_rec_models[OF subsetI[OF aec_cec_subset[OF tC aec cec]]])
     apply (rule clock_repMC_aec[OF tC Kknows(3) Kknows(4), rotated, where x=s])
       using Kknows
       apply simp
      using Kknows
      apply simp

    apply clarsimp
    apply (simp add: eval_rec_models[OF subsetI[OF aec_cec_subset[OF tC aec cec]]])
    using tC Kknows
    apply (clarsimp simp: agent_abs_def)
    apply (erule (1) ballE)
    using Kknows
    apply (cut_tac x="tLast t'" and y="tLast t'a" in clock_repMC_cec[OF tC Kknows(3) Kknows(4)])
      unfolding clock_repRels_def
      apply auto
    done
next
  case (Kcknows a as \<psi>)
  have "?lhs (Kcknows as \<psi>)
      = (\<forall>y\<in>ODList.toSet aec.
           \<forall>x\<in>(\<Union>a\<in>set as. relations (clock_repMC (ODList.toSet cec)) a)\<^sup>+ `` {y}.
              x \<in> ODList.toSet (eval_rec (clock_evalProp envVal) (clock_knowledge envObs cec) (clock_commonKnowledge envObs cec)
                       (big_union (clock_commonKnowledge envObs cec as) (toList aec)) \<psi>))"
    (* FIXME dreaming of a cong rule here. *)
    using toSet_def[symmetric]
    apply (clarsimp simp: toSet_eq_iff toSet_def[symmetric] subset_eq)
    apply (rule ball_cong[OF refl])
    apply (rule ball_cong)
    apply (subst clock_commonKnowledge_relation_image[OF aec_cec_subset[OF tC Kcknows(3) Kcknows(4)]])
    apply simp_all
    done
  also have "... = (\<forall>s\<in>ODList.toSet aec. clock_repMC (ODList.toSet cec), s \<Turnstile> Kcknows as \<psi>)"
    apply (rule ball_cong[OF refl])
    apply simp
    apply (rule ball_cong[OF refl])
    apply (subst eval_rec_models[OF trc_aux[OF tC Kcknows(3) Kcknows(4), where as=as], symmetric])
     apply (simp add: toSet_def[symmetric])
     apply (rule_tac x=y in bexI)
      apply (subst clock_commonKnowledge_relation_image[OF aec_cec_subset[OF tC Kcknows(3) Kcknows(4)]])
      apply assumption
     apply simp
     apply (rule refl)
    done
  also have "... = clock_repMC (ODList.toSet cec), s \<Turnstile> Kknows a (Kcknows as \<psi>)"
    using clock_repMC_aec[OF tC Kcknows(3) Kcknows(4) Kcknows(2)]
          clock_repMC_cec[OF tC Kcknows(3) Kcknows(4) Kcknows(2)]
    by (auto cong: ball_cong)
  also have "... = clock_repMC (ODList.toSet cec), s \<Turnstile> Kcknows as \<psi>"
    apply (rule S5n_common_knowledge_fixed_point_simpler[symmetric])
    using Kcknows
    apply (auto intro: aec_cec_subset[OF tC Kcknows(3) Kcknows(4) Kcknows(2)])
    done
  finally show ?case .
qed simp_all

(*>*)
lemma eval_models:
  assumes tC: "t \<in> Clock.jkbpC"
      and aec: "ODList.toSet aec = agent_abs a t"
      and cec: "ODList.toSet cec = common_abs t"
      and subj_phi: "subjective a \<phi>"
      and s: "s \<in> ODList.toSet aec"
  shows "eval envVal envObs (cec, aec) \<phi>
     \<longleftrightarrow> clock_repMC (ODList.toSet cec), s \<Turnstile> \<phi>"
(*<*)
  unfolding eval_def
  using evalS_models[OF tC aec cec subj_phi s]
  apply (simp add: Let_def)
  done

(*>*)

(* **************************************** *)

subsubsection{* Simulated actions *}

text{*

From a common equivalence class and a subjective equivalence class for
agent @{term "a"}, we can compute the actions enabled for @{term "a"}:

*}

definition (in -)
  clock_simAction :: "('a, 'p, 'aAct) JKBP \<Rightarrow> (('s :: linorder) \<Rightarrow> 'p \<Rightarrow> bool)
                  \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
                  \<Rightarrow> 'a \<Rightarrow> 's clock_simWorldsRep \<Rightarrow> 'aAct list"
where
  "clock_simAction jkbp envVal envObs \<equiv> \<lambda>a (Y, X).
     [ action gc. gc \<leftarrow> jkbp a, eval envVal envObs (Y, X) (guard gc) ]"
(*<*)

abbreviation
  clock_simAction :: "'a \<Rightarrow> 's clock_simWorldsRep \<Rightarrow> 'aAct list"
where
  "clock_simAction \<equiv> ClockView.clock_simAction jkbp envVal envObs"

(*>*)
text{*

Using the above result about evaluation, we can relate @{text
"clock_simAction"} to @{term "jAction"}. Firstly, @{text
"clock_simAction"} behaves the same as @{term "jAction"} using the
@{term "clock_repMC"} structure:

*}

lemma clock_simAction_jAction:
  assumes tC: "t \<in> Clock.jkbpC"
      and aec: "ODList.toSet aec = agent_abs a t"
      and cec: "ODList.toSet cec = common_abs t"
  shows "set (clock_simAction a (cec, aec))
       = set (jAction (clock_repMC (ODList.toSet cec)) (tLast t) a)"
(*<*)
  unfolding clock_simAction_def jAction_def
  apply clarsimp
  apply rule
   apply clarsimp
   apply (rule_tac x=xa in bexI)
    apply simp
   apply clarsimp
   apply (subst eval_models[OF tC aec cec, symmetric])
     using tC aec cec subj
     apply simp_all
  apply clarsimp
  apply (rule_tac x=xa in bexI)
   apply (rule refl)
  apply clarsimp
  apply (subst eval_models[OF tC aec cec])
    using tC aec cec subj
    apply simp_all
  done

lemma clock_submodel_aux:
  assumes tC: "t \<in> Clock.jkbpC"
      and s: "s \<in> worlds (clock_simMCt t)"
  shows "gen_model Clock.MCS s = gen_model (clock_simMCt t) s"
proof(rule gen_model_subset[where T="clock_jkbpCSt t"])
  fix a
  let ?X = "clock_sim ` Clock.jkbpCn (tLength t)"
  show "relations Clock.MCS a \<inter> ?X \<times> ?X
      = relations (clock_simMCt t) a \<inter> ?X \<times> ?X"
    by (simp add: Int_ac Int_absorb1
                  relation_mono[OF jkbpCSt_jkbpCS_subset jkbpCSt_jkbpCS_subset])
next
  let ?X = "clock_sim ` Clock.jkbpCn (tLength t)"
  from s show "(\<Union>a. relations (clock_simMCt t) a)\<^sup>* `` {s} \<subseteq> ?X"
    apply (clarsimp simp del: mkKripke_simps)
    apply (erule kripke_rels_trc_worlds)
    apply auto
    done
next
  let ?Y = "Clock.jkbpCn (tLength t)"
  let ?X = "clock_sim ` ?Y"
  from s obtain t'
    where st': "s = clock_sim t'"
      and t'C: "t' \<in> Clock.jkbpC"
      and t'O: "tLength t = tLength t'"
    by fastforce
  { fix t''
    assume tt': "(t', t'') \<in> (\<Union>a. relations Clock.MC a)\<^sup>*"
    from t'C tt' have t''C: "t'' \<in> Clock.jkbpC"
      by - (erule kripke_rels_trc_worlds, simp_all)
    from t'O tt' have t''O: "tLength t = tLength t''"
      by (simp add: Clock.sync_tLength_eq_trc)
    from t''C t''O have "t'' \<in> ?Y" by fastforce }
  hence "(\<Union>a. relations Clock.MC a)\<^sup>* `` {t'} \<subseteq> ?Y"
    by clarsimp
  hence "clock_sim ` ((\<Union>a. relations Clock.MC a)\<^sup>* `` {t'}) \<subseteq> ?X"
    by (rule image_mono)
  with st' t'C
  show "(\<Union>a. relations Clock.MCS a)\<^sup>* `` {s} \<subseteq> ?X"
    using sim_trc_commute[OF Clock.mkM_kripke clock_sim, where t=t'] by simp
qed (insert s, auto)

(*>*)
text{*

We can connect the agent's choice of actions on the @{text
"clock_repMC"} structure to those on the @{text "Clock.MC"}
structure using our earlier results about actions being preserved by
generated models and simulations.

*}

lemma clock_simAction':
  assumes tC: "t \<in> Clock.jkbpC"
  assumes aec: "ODList.toSet aec = agent_abs a t"
  assumes cec: "ODList.toSet cec = common_abs t"
  shows "set (clock_simAction a (cec, aec)) = set (jAction Clock.MC t a)"
(*<*) (is "?lhs = ?rhs")
proof -
  from tC aec cec
  have "?lhs = set (jAction (clock_repMC (ODList.toSet cec)) (tLast t) a)"
    by (rule clock_simAction_jAction)
  also from tC aec cec
  have "... = set (jAction (clock_simMCt t) (clock_sim t) a)"
    by (simp add: simulation_jAction_eq[OF _ clock_repSim] common_abs_def)
  also from tC
  have "... = set (jAction Clock.MCS (clock_sim t) a)"
    using gen_model_jAction_eq[OF clock_submodel_aux[OF tC, where s="clock_sim t"], where w'="clock_sim t"]
          gen_model_world_refl[where w="clock_sim t" and M="clock_simMCt t"]
    by simp
  also from tC have "... = set (jAction Clock.MC t a)"
    by (simp add: simulation_jAction_eq[OF _ clock_sim])
  finally show ?thesis .
qed

(*>*)
text{*

The @{term "Algorithm"} locale requires a specialisation of this
lemma:

*}

lemma clock_simAction:
  assumes tC: "t \<in> Clock.jkbpC"
  assumes ec: "clock_simAbs ec = Clock.sim_equiv_class a t"
  shows "set (clock_simAction a ec) = set (jAction Clock.MC t a)"
(*<*)
  using assms clock_simAction'[OF tC, where cec="fst ec" and aec="snd ec"]
  apply (simp add: common_abs agent_abs)
  done
(*>*)

(* **************************************** *)

subsubsection{* Simulated transitions *}

text{*

We need to determine the image of the set of commonly-held-possible
states under the transition function, and also for the agent's
subjective equivalence class. We do this with the @{text
"clock_trans"} function:

*}

definition (in -)
  clock_trans :: "('a :: linorder) odlist \<Rightarrow> ('a, 'p, 'aAct) JKBP
              \<Rightarrow> (('s :: linorder) \<Rightarrow> 'eAct list)
              \<Rightarrow> ('eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's)
              \<Rightarrow> ('s \<Rightarrow> 'p \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
              \<Rightarrow> 's odlist \<Rightarrow> 's odlist \<Rightarrow> 's odlist"
where
  "clock_trans agents jkbp envAction envTrans envVal envObs \<equiv> \<lambda>cec X.
     ODList.fromList (concat
       [ [ envTrans eact aact s .
                     eact \<leftarrow> envAction s,
                     aact \<leftarrow> listToFuns (\<lambda>a. clock_simAction jkbp envVal envObs a
                                        (cec, clock_knowledge envObs cec a s))
                                        (toList agents) ] .
                   s \<leftarrow> toList X ])"
(*<*)

abbreviation
  clock_trans :: "'s odlist \<Rightarrow> 's odlist \<Rightarrow> 's odlist"
where
  "clock_trans \<equiv> ClockView.clock_trans agents jkbp envAction envTrans envVal envObs"

lemma clock_trans_aux:
  assumes t'C: "t' \<in> Clock.jkbpC"
      and ec: "clock_simAbs ec = Clock.sim_equiv_class a' t'"
      and tC: "t \<in> Clock.jkbpCn (tLength t')"
      and eact: "eact \<in> set (envAction (tLast t))"
  shows "(aact \<in> set (listToFuns (\<lambda>a. clock_simAction a (fst ec, clock_knowledge envObs (fst ec) a (tLast t)))
                            (toList agents)))
     \<longleftrightarrow> (\<forall>a. aact a \<in> set (jAction (Clock.MCn (tLength t')) t a))"
  using assms
  apply -
  apply (frule Clock.jkbpCn_jkbpC_inc)
  apply (clarsimp simp: listToFuns_ext[OF agents[unfolded toSet_def]])
  apply (subst clock_simAction')
     apply (erule Clock.jkbpCn_jkbpC_inc)
    apply (subst clock_coEC_relation_image)
     apply (simp add: common_abs common_abs_def toSet_def[symmetric])
    apply (fastforce simp: common_abs agent_abs_def common_abs_def clock_repRels_def)
   apply (simp add: common_abs common_abs_def)
  apply (simp add: Clock.jkbpC_jkbpCn_jAction_eq)
  done

(*>*)
text{*

The function @{term "listToFuns"} exhibits the isomorphism between @{typ
"('a \<times> 'b list) list"} and @{typ "('a \<Rightarrow> 'b) list"} for finite types
@{typ "'a"}.

We can show that the transition function works for both the
commonly-held set of states and the agent subjective one. The proofs
are  straightforward.

*}

lemma clock_trans_common:
  assumes tC: "t \<in> Clock.jkbpC"
  assumes ec: "clock_simAbs ec = Clock.sim_equiv_class a t"
  shows "ODList.toSet (clock_trans (fst ec) (fst ec))
       = { s |t' s. t' \<leadsto> s \<in> Clock.jkbpC \<and> tLength t' = tLength t }"
(*<*) (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs"
    unfolding clock_trans_def
    apply (clarsimp simp: toSet_def[symmetric] common_abs[OF assms] common_abs_def)
    apply (rule_tac x=xa in exI)
    apply clarsimp
    apply (rule Clock.jkbpCn_jkbpC_inc[where n="Suc (tLength t)"])
    apply (auto simp: Let_def iff: clock_trans_aux[OF tC ec])
    done
next
  show "?rhs \<subseteq> ?lhs"
    unfolding clock_trans_def
    apply (clarsimp simp: toSet_def[symmetric] common_abs[OF assms] common_abs_def)
    apply (drule Clock.jkbpC_tLength_inv[where n="Suc (tLength t)"])
    apply (auto simp: Let_def iff: clock_trans_aux[OF tC ec])
    done
qed

(*>*)
text{**}

lemma clock_trans_agent:
  assumes tC: "t \<in> Clock.jkbpC"
  assumes ec: "clock_simAbs ec = Clock.sim_equiv_class a t"
  shows "ODList.toSet (clock_trans (fst ec) (snd ec))
       = { s |t' s. t' \<leadsto> s \<in> Clock.jkbpC \<and> clock_jview a t' = clock_jview a t }"
(*<*) (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs"
    unfolding clock_trans_def
    apply (clarsimp simp: toSet_def[symmetric] common_abs[OF assms] agent_abs[OF assms] common_abs_def agent_abs_def)
    apply (rule_tac x=t' in exI)
    apply clarsimp
    apply (rule Clock.jkbpCn_jkbpC_inc[where n="Suc (tLength t)"])
    apply (auto simp: Let_def iff: clock_trans_aux[OF tC ec])
    done
next
  show "?rhs \<subseteq> ?lhs"
    unfolding clock_trans_def
    apply (clarsimp simp: toSet_def[symmetric] common_abs[OF assms] agent_abs[OF assms] common_abs_def agent_abs_def)
    apply (drule Clock.jkbpC_tLength_inv[where n="Suc (tLength t)"])
    apply (auto simp: Let_def iff: clock_trans_aux[OF tC ec])
    done
qed

(*>*)
text{*

Note that the clock semantics disregards paths, so we simply compute
the successors of the temporal slice and partition that. Similarly the
successors of the agent's subjective equivalence class tell us what
the set of possible observations are:

*}

definition (in -)
  clock_mkSuccs :: "('s :: linorder \<Rightarrow> 'obs) \<Rightarrow> 'obs \<Rightarrow> 's odlist
                \<Rightarrow> 's clock_simWorldsRep"
where
  "clock_mkSuccs envObs obs Y' \<equiv> (Y', ODList.filter (\<lambda>s. envObs s = obs) Y')"

text{*

Finally we can define our transition function on simulated states:

*}

definition (in -)
  clock_simTrans :: "('a :: linorder) odlist \<Rightarrow> ('a, 'p, 'aAct) JKBP
              \<Rightarrow> (('s :: linorder) \<Rightarrow> 'eAct list)
              \<Rightarrow> ('eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's)
              \<Rightarrow> ('s \<Rightarrow> 'p \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
              \<Rightarrow> 'a \<Rightarrow> 's clock_simWorldsRep \<Rightarrow> 's clock_simWorldsRep list"
where
  "clock_simTrans agents jkbp envAction envTrans envVal envObs \<equiv> \<lambda>a (Y, X).
     let X' = clock_trans agents jkbp envAction envTrans envVal envObs Y X;
        Y' = clock_trans agents jkbp envAction envTrans envVal envObs Y Y
      in [ clock_mkSuccs (envObs a) obs Y' .
             obs \<leftarrow> map (envObs a) (toList X') ]"
(*<*)

abbreviation
  clock_simTrans :: "'a \<Rightarrow> 's clock_simWorldsRep \<Rightarrow> 's clock_simWorldsRep list"
where
  "clock_simTrans \<equiv> ClockView.clock_simTrans agents jkbp envAction envTrans envVal envObs"

(*>*)
text{*

Showing that this respects the property asked of it by the @{term
"Algorithm"} locale is straightforward:

*}

lemma clock_simTrans:
  assumes tC: "t \<in> Clock.jkbpC"
      and ec: "clock_simAbs ec = Clock.sim_equiv_class a t"
  shows "clock_simAbs ` set (clock_simTrans a ec)
      = { Clock.sim_equiv_class a (t' \<leadsto> s)
          |t' s. t' \<leadsto> s \<in> Clock.jkbpC \<and> clock_jview a t' = clock_jview a t }"
(*<*) (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs"
    unfolding clock_simTrans_def clock_mkSuccs_def
    using clock_trans_common[OF tC ec] clock_trans_agent[OF tC ec]
    apply (clarsimp simp: toSet_def[symmetric] clock_simAbs_def Let_def)

    apply (rule_tac x=t' in exI)
    apply (rule_tac x=xa in exI)

    apply (clarsimp simp: clock_sim_def)
    apply safe

     apply clarsimp
     apply (rule_tac x="t'a \<leadsto> s" in image_eqI)
      apply (clarsimp simp: Let_def Set.image_def)
      apply safe
        apply (rule_tac x="t'b \<leadsto> x" in exI)
        apply (clarsimp simp: Let_def Set.image_def)
        apply (drule_tac t="t'b \<leadsto> x" in Clock.jkbpC_tLength_inv[OF _ refl])
        apply (auto simp: Let_def)[1]
       apply (rule_tac x="ta" in exI)
       apply simp
       apply (rule Clock.jkbpCn_jkbpC_inc[where n="Suc (tLength t)"])
       apply (auto simp: Let_def)[3]

    apply (rule_tac x="tLast ta" in exI)
    apply (clarsimp simp: Let_def Set.image_def)
    apply safe
      apply (rule_tac x="taa" in exI)
      apply simp
      apply (rule Clock.jkbpCn_jkbpC_inc[where n="Suc (tLength t)"])
       apply (auto simp: Let_def)[1]
     apply (drule_tac t="t'a \<leadsto> x" in Clock.jkbpC_tLength_inv[OF _ refl])
     apply (rule_tac x="t'a \<leadsto> x" in exI)
     apply (auto simp: Let_def)[1]
    apply (drule_tac t="ta" in Clock.jkbpC_tLength_inv)
     apply blast
    apply (clarsimp simp: Let_def)
    apply (rule_tac x="ta" in exI)
    apply simp
    apply (rule Clock.jkbpCn_jkbpC_inc[where n="Suc (tLength t)"])
    apply (auto simp: Let_def)
    done
next
  show "?rhs \<subseteq> ?lhs"
    unfolding clock_simTrans_def Let_def
    apply (cases ec)
    using clock_trans_common[OF tC ec] clock_trans_agent[OF tC ec]
    apply (clarsimp simp: toSet_def[symmetric] Set.image_def clock_simAbs_def
                simp del: split_paired_Ex)

    apply (rule_tac x="clock_mkSuccs (envObs a) (envObs a s) (clock_trans aa aa)" in exI)
    apply safe
      apply auto[1]
     apply (rule_tac x="tLast x" in exI)
     apply (clarsimp simp: clock_trans_common[OF tC ec] clock_mkSuccs_def)
     apply safe
       apply (clarsimp simp: clock_sim_def simp del: Clock.jkbpCn.simps)
       apply rule
        apply (clarsimp simp: Let_def)
        apply (rule_tac x="ta" in exI)
        apply (simp add: Let_def)
        apply (rule Clock.jkbpCn_jkbpC_inc[where n="Suc (tLength t)"])
        apply (clarsimp simp: Let_def)
        apply (rule_tac x=eact in exI)
        apply (rule_tac x=aact in exI)
        apply clarsimp
       apply (clarsimp simp: Let_def Set.image_def)
       apply (drule_tac t="t'a \<leadsto> xa" in Clock.jkbpC_tLength_inv[OF _ refl])
       apply (rule_tac x="t'a \<leadsto> xa" in exI)
       apply (auto simp: Let_def)[1]
      apply (drule_tac t="x" in Clock.jkbpC_tLength_inv[OF _ refl])
      apply (simp only: Let_def Clock.jkbpCn.simps)
      apply clarify
      apply (rule_tac x="ta" in exI)
      apply simp
      apply (rule Clock.jkbpCn_jkbpC_inc[where n="Suc (tLength t)"])
      apply (auto simp: Let_def)[1]
     apply (clarsimp simp: clock_trans_common[OF tC ec] clock_mkSuccs_def)
     apply (rule_tac x="t'a \<leadsto> sa" in exI)
     apply (clarsimp simp: clock_sim_def Let_def)
     (* FIXME similar to above *)
     apply rule
      apply (clarsimp simp: Set.image_def)
      apply (rule_tac x="t'b \<leadsto> x" in exI)
      apply (drule_tac t="t'b \<leadsto> x" in Clock.jkbpC_tLength_inv[OF _ refl])
      apply (auto simp: Let_def)[1]
    apply clarsimp
    apply (rule_tac x="ta" in exI)
    apply auto
    apply (rule Clock.jkbpCn_jkbpC_inc[where n="Suc (tLength t)"])
    apply (auto simp: Let_def)
    done
qed
(*>*)

end (* context FiniteLinorderEnvironment *)

(* **************************************** *)

subsubsection{* Maps *}

text{*

\label{sec:kbps-theory-clock-view-maps}

As mentioned above, the canonicity of our ordered, distinct list
representation of automaton states allows us to use them as keys in a
digital trie; a value of type @{typ "('key, 'val) trie"} maps keys of
type @{typ "'key list"} to values of type @{typ "'val"}.

In this specific case we track automaton transitions using a two-level
structure mapping sets of states to an association list mapping
observations to sets of states, and for actions automaton states map
directly to agent actions.

*}

type_synonym ('s, 'obs) clock_trans_trie
  = "('s, ('s, ('obs, 's clock_simWorldsRep) mapping) trie) trie"
type_synonym ('s, 'aAct) clock_acts_trie = "('s, ('s, 'aAct) trie) trie"
(*<*)

definition
  trans_MapOps_lookup :: "('s :: linorder, 'obs) clock_trans_trie
                        \<Rightarrow> 's clock_simWorldsRep \<times> 'obs
                        \<rightharpoonup> 's clock_simWorldsRep"
where
  "trans_MapOps_lookup \<equiv> \<lambda>m k.
     Option.bind (trie_odlist_lookup m (fst (fst k))) (\<lambda>m.
       (Option.bind (trie_odlist_lookup m (snd (fst k))) (\<lambda>m.
         Mapping.lookup m (snd k))))"

definition
  trans_MapOps_update :: "('s :: linorder) clock_simWorldsRep \<times> 'obs \<Rightarrow> 's clock_simWorldsRep
                        \<Rightarrow> ('s :: linorder, 'obs) clock_trans_trie
                        \<Rightarrow> ('s :: linorder, 'obs) clock_trans_trie"
where
  "trans_MapOps_update \<equiv> \<lambda>k v m.
     trie_odlist_update_with (fst (fst k)) m trie_empty (\<lambda>m.
       trie_odlist_update_with (snd (fst k)) m Mapping.empty (\<lambda>m.
          Mapping.update (snd k) v m))"

definition
  trans_MapOps :: "(('s :: linorder, 'obs) clock_trans_trie,
                    's clock_simWorldsRep \<times> 'obs, 's clock_simWorldsRep) MapOps"
where
  "trans_MapOps \<equiv>
     \<lparr> MapOps.empty = trie_empty,
       lookup = trans_MapOps_lookup,
       update = trans_MapOps_update \<rparr>"

lemma (in FiniteLinorderEnvironment) trans_MapOps:
  "MapOps (\<lambda>k. (clock_simAbs (fst k), snd k)) (Clock.jkbpSEC \<times> UNIV) trans_MapOps"
proof
  fix k show "MapOps.lookup trans_MapOps (MapOps.empty trans_MapOps) k = None"
    unfolding trans_MapOps_def trans_MapOps_lookup_def trie_odlist_lookup_def
    by (auto split: split_split)
next
  fix e k k' M
  assume k: "(clock_simAbs (fst k), snd k) \<in> Clock.jkbpSEC \<times> (UNIV :: 'z set)"
     and k': "(clock_simAbs (fst k'), snd k') \<in> Clock.jkbpSEC \<times> (UNIV :: 'z set)"
  show "MapOps.lookup trans_MapOps (MapOps.update trans_MapOps k e M) k'
         = (if (clock_simAbs (fst k'), snd k') = (clock_simAbs (fst k), snd k)
             then Some e else MapOps.lookup trans_MapOps M k')"
  proof(cases "(clock_simAbs (fst k'), snd k') = (clock_simAbs (fst k), snd k)")
    case True hence "k = k'"
      using inj_onD[OF clock_simAbs_inj_on] k k' by (auto iff: prod_eqI)
    thus ?thesis
      unfolding trans_MapOps_def trans_MapOps_lookup_def trans_MapOps_update_def trie_odlist_lookup_def trie_odlist_update_with_def
        by (simp add: trie_lookup_trie_update_with lookup_update split: option.split split_split)
  next
    case False thus ?thesis
      unfolding trans_MapOps_def trans_MapOps_lookup_def trans_MapOps_update_def trie_odlist_lookup_def trie_odlist_update_with_def
      by (cases "fst k = fst k'")
       (auto simp add: lookup_empty lookup_update_neq prod_eq_iff trie_lookup_trie_update_with split: option.split split_split)
  qed
qed

(* A map for the agent actions. *)

definition
  acts_MapOps_lookup :: "('s :: linorder, 'aAct) clock_acts_trie
                      \<Rightarrow> 's clock_simWorldsRep
                      \<rightharpoonup> 'aAct"
where
  "acts_MapOps_lookup \<equiv> \<lambda>m k.
     Option.bind (trie_odlist_lookup m (fst k)) (\<lambda>m.
       (trie_odlist_lookup m (snd k)))"

definition
  acts_MapOps_update :: "('s :: linorder) clock_simWorldsRep \<Rightarrow> 'aAct
                      \<Rightarrow> ('s :: linorder, 'aAct) clock_acts_trie
                      \<Rightarrow> ('s :: linorder, 'aAct) clock_acts_trie"
where
  "acts_MapOps_update \<equiv> \<lambda>k v m.
     trie_odlist_update_with (fst k) m trie_empty (\<lambda>m.
       trie_odlist_update (snd k) v m)"

definition
  acts_MapOps :: "(('s :: linorder, 'aAct) clock_acts_trie, 's clock_simWorldsRep, 'aAct) MapOps"
where
  "acts_MapOps \<equiv>
     \<lparr> MapOps.empty = trie_empty,
       lookup = acts_MapOps_lookup,
       update = acts_MapOps_update \<rparr>"

lemma (in FiniteLinorderEnvironment) acts_MapOps:
  "MapOps clock_simAbs Clock.jkbpSEC acts_MapOps"
proof
  fix k show "MapOps.lookup acts_MapOps (MapOps.empty acts_MapOps) k = None"
    unfolding acts_MapOps_def acts_MapOps_lookup_def trie_odlist_lookup_def
    by auto
next
  fix e k k' M
  assume k: "clock_simAbs k \<in> Clock.jkbpSEC"
     and k': "clock_simAbs k' \<in> Clock.jkbpSEC"
  show "MapOps.lookup acts_MapOps (MapOps.update acts_MapOps k e M) k'
         = (if clock_simAbs k' = clock_simAbs k
             then Some e else MapOps.lookup acts_MapOps M k')"
  proof(cases "clock_simAbs k' = clock_simAbs k")
    case True hence "k = k'"
      using inj_onD[OF clock_simAbs_inj_on] k k' by (auto iff: prod_eqI)
    thus ?thesis
      unfolding acts_MapOps_def acts_MapOps_lookup_def acts_MapOps_update_def
      by (auto simp: trie_lookup_trie_update trie_lookup_trie_update_with
                     trie_odlist_update_with_def trie_odlist_update_def trie_odlist_lookup_def)
  next
    case False thus ?thesis
      unfolding acts_MapOps_def acts_MapOps_lookup_def acts_MapOps_update_def
      by (auto simp: trie_lookup_trie_update trie_lookup_trie_update_with
                     trie_odlist_update_with_def trie_odlist_update_def trie_odlist_lookup_def
               dest: prod_eqI
              split: option.split)
  qed
qed

(*>*)
text{*

We define two records @{term "acts_MapOps"} and @{term "trans_MapOps"}
satisfying the @{term "MapOps"} predicate
(\S\ref{sec:kbps-theory-map-ops}). Discharging the obligations in the
@{term "Algorithm"} locale is routine, leaning on the work of
\citet{DBLP:conf/itp/LammichL10}.

*}

subsubsection{* Locale instantiation *}

text{*

Finally we assemble the algorithm and discharge the proof obligations.

*}

sublocale FiniteLinorderEnvironment
        < Clock!: Algorithm
            jkbp envInit envAction envTrans envVal
            clock_jview envObs clock_jviewInit clock_jviewIncr
            clock_sim clock_simRels clock_simVal
            clock_simAbs clock_simObs clock_simInit clock_simTrans clock_simAction
            acts_MapOps trans_MapOps
(*<*)
  apply (unfold_locales)

  apply clarify
  apply (rule clock_simInit)
  apply simp

  apply clarify
  apply (erule (1) clock_simObs)

  apply clarify
  apply (erule (1) clock_simAction)

  apply clarify
  apply (erule (1) clock_simTrans)

  apply (rule acts_MapOps)
  apply (rule trans_MapOps)

  done

(*>*)
text{*

Explicitly, the algorithm for this case is:

*}

definition
  "mkClockAuto \<equiv> \<lambda>agents jkbp envInit envAction envTrans envVal envObs.
    mkAlgAuto acts_MapOps
              trans_MapOps
              (clock_simObs envObs)
              (clock_simInit envInit envObs)
              (clock_simTrans agents jkbp envAction envTrans envVal envObs)
              (clock_simAction jkbp envVal envObs)
              (\<lambda>a. map (clock_simInit envInit envObs a \<circ> envObs a) envInit)"

lemma (in FiniteLinorderEnvironment) mkClockAuto_implements:
  "Clock.implements
    (mkClockAuto agents jkbp envInit envAction envTrans envVal envObs)"
(*<*)
  using Clock.k_mkAlgAuto_implements
  unfolding mkClockAuto_def mkAlgAuto_def Clock.k_frontier_def
  by simp

(*

We actually run this unfolding of the algorithm. The lemma is keeping
us honest.

*)

definition
  "ClockAutoDFS \<equiv> \<lambda>agents jkbp envInit envAction envTrans envVal envObs. \<lambda>a.
    alg_dfs acts_MapOps
            trans_MapOps
            (clock_simObs envObs a)
            (clock_simTrans agents jkbp envAction envTrans envVal envObs a)
            (clock_simAction jkbp envVal envObs a)
            (map (clock_simInit envInit envObs a \<circ> envObs a) envInit)"

lemma (in FiniteLinorderEnvironment)
  "mkClockAuto agents jkbp envInit envAction envTrans envVal envObs
 = (\<lambda>a. alg_mk_auto acts_MapOps trans_MapOps (clock_simInit a) (ClockAutoDFS agents jkbp envInit envAction envTrans envVal envObs a))"
  unfolding mkClockAuto_def ClockAutoDFS_def mkAlgAuto_def alg_mk_auto_def by (simp add: Let_def)

(*>*)
text{*

We discuss the clock semantics further in \S\ref{sec:kbps-alg-clock}.

*}

(*<*)
end
(*>*)