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

(*
   Test proofs for corres methods. Builds on AInvs image.
*)

theory Corres_Test
imports "../proof/refine/ARM/VSpace_R" Corres_Method
begin

chapter \<open>The Corres Method\<close>

section \<open>Introduction\<close>

text \<open>The @{method corres} method tries to do for corres-style refinement proofs what
@{method wp} did for hoare logic proofs. The intention is to automate the application
of corres calculational rules, so that the bulk of the manual proof is now handling
a verification condition. In general refinement proofs are difficult to automate, so here we
exploit the fact that in l4v the abstract and executable specifications tend to be structurally
similar. Corres proofs are based on the @{const corres_underlying} constant, which takes a number
of parameters that allow it to be specialized for different flavours of refinement.

A corres statement has the following form: @{term "corres_underlying sr nf nf' r P P' f f'"}, where
@{term sr} is a state-relation, @{term nf} and @{term nf'} refer to whether or not the left and
right hand functions may fail, @{term r} is a return value relation between the functions, @{term P}
and @{term P'} are preconditions for the functions @{term f} and @{term f'} respectively. Informally
the statement says that: under the given preconditions, for every execution of @{term f'} there exists
an execution of @{term f} that is related by the given state relation @{term sr} and return-value
relation @{term r}.

If the left and right side of a corres statement share similar structure, we can "unzip" the function
into one corres obligation for each atomic function. This is done through the application of
  @{thm corres_split}.
\<close>

thm corres_split[no_vars]

text \<open>Briefly this states that: given a corres goal proving refinement between @{term "a >>= b"} and
  @{term "c >>= d"}, we can decompose this into a proof showing refinement between @{term a} and
@{term c}, and between @{term a} and @{term c}. Additionally @{term a} and @{term c} must establish
appropriate postconditions to satisfy the obligations of proving refinement between @{term b} and @{term d}.

The first subgoal that is produced has an important characteristic: the preconditions for each
side may only discuss the return value of its respective side. This means that rules such as
@{term "corres_underlying sr nf nf' r (\<lambda>s. x = x') (\<lambda>_. True) (f x) (f' x')"} will not apply to a goal
 if @{term x} and @{term x'} are variables generated by applying @{thm corres_split} (i.e. the
return values of functions).

This means that any such conditions must instead be phrased as an assumption to the rule, and our rule must be
rephrased as follows:
  @{term "x = x' \<Longrightarrow> corres_underlying sr nf nf' r (\<lambda>_. True) (\<lambda>_. True) (f x) (f' x')"}.
The result is that we must solve @{term "x = x'"} immediately after applying our rule. While this
is not a major concern for a manual proof, it proves to be a significant obstacle if we're trying
to focus on automating the "corres" part of the refinement.
\<close>

section \<open>corres_underlyingK and corres_rv\<close>

text \<open>To remedy this situation, we augment the @{const corres_underlying} definition to include
yet another flag: a single boolean. This new constant: @{const corres_underlyingK},
will form the basis of the calculus for our corres method.\<close>

thm corres_underlyingK_def[no_vars]

text \<open>The boolean in @{const corres_underlyingK} can be thought of as a stateless precondition. It
is used to propagate additional proof obligations for rules that either do not need to discuss
either the left or right hand state, or must discuss bound variables from both sides.\<close>

thm corresK_split[no_vars]

text \<open>In this split rule for @{const corres_underlyingK} we see that the additional precondition @{term F'}
may discuss both @{term rv} and @{term rv'}. To show that this condition is satisified, however,
we can't use hoare logic and instead need a new definition: @{const corres_rv}.\<close>

thm corres_rv_def_I_know_what_I'm_doing[no_vars]

text \<open>This is a weaker form of @{const corres_underlying} that is only interested in the return value
of the functions. In essence, it states the given functions will establish @{term Q} after executing,
assuming the given return-value relation @{term r} holds, along with the given stateless precondition
@{term F} and left/right preconditions @{term P} and @{term P'}.

The assumption in general is that corres_rv rules should never be written, instead corres_rv obligations
should be propagated into either the stateless precondition (@{term F} from @{term corres_underlyingK}),
the left precondition (@{term P}) or the right precondition @{term P'}. This is implicitly handled
by @{method corres_rv} (called from @{method corres}) by applying one of the following rules to each conjunct:\<close>

thm corres_rv_defer
thm corres_rv_wp_left
thm corres_rv_wp_right

text \<open>If none of these rules can be safely applied, then @{method corres_rv} will leave the
  obligation untouched. The user can manually apply one of them if desired, but this is liable to
  create unsolvable proof obligations. In the worst case, the user may manually solve the goal in-place.\<close>

thm corres_rv_proveT[no_vars]

section \<open>The corres method\<close>

text \<open>The core algorithm of the corres method is simple:
  1) start by applying any necessary weakening rules to ensure the goal has schematic preconditions
  2) apply a known @{thm corres} or @{thm corresK} rule (see next section)
  3) if unsuccessful, apply a split rule (i.e. @{thm corresK_split}) and go to 2

Importantly, @{method corres} will not split a goal if it ultimately is not able to apply at least
one @{thm corres} or @{thm corresK} rule.
\<close>

subsection \<open>The corres and corresK named_theorems\<close>

text \<open>To address the fact that existing refinement rules are phrased as @{const corres_underlying}
and not @{const corres_underlyingK} there are two different named_theorems that are used for different
kind of rules @{thm corres} and @{thm corresK}. A @{thm corres} rule is understood to be phrased
with @{const corres_underlying} and may have additional assumptions. These assumptions will be
propagated through the additional @{term F} flag in @{const corres_underlyingK}, rather than presented
as proof obligations immediately. A @{thm corresK} rule is understood to be phrased with
@{const corres_underlyingK}, and is meant for calculational rules which may have proper assumptions that
should not be propagated.
\<close>
thm corresK
thm corres

subsection \<open>The corresc method\<close>

text \<open>Similar to @{method wpc}, @{method corresc} can handle case statements in @{const corres_underlyingK}
proof goals. Importantly, however, it is split into two sub-methods @{method corresc_left} and
@{method corresc_right}, which perform case-splitting on each side respectively. The combined method
@{method corresc}, however, attempts to discharge the contradictions that arise from the quadratic
blowup of a case analysis on both the left and right sides.\<close>

subsection \<open>corres_concrete_r, corres_concrete_rE\<close>

text \<open>Some @{thm corresK} rules should only be applied if certain variables are concrete
(i.e. not schematic) in the goal. These are classified separately with the named_theorems
@{thm corres_concrete_r} and @{thm corres_concrete_rER}. The first
indicates that the return value relation of the goal must be concrete, the second indicates that
only the left side of the error relation must be concrete.\<close>

thm corres_concrete_r
thm corres_concrete_rER

subsection \<open>The corres_search method\<close>

text \<open>The purpose of @{method corres_search} is to address cases where there is non-trivial control flow.
In particular: in the case where there is an "if" statement or either side needs to be symbolically
executed. The core idea is that corres_search should be provided with a "search" rule that acts
as an anchoring point. Symbolic execution and control flow is decomposed until either the given
rule is successfully applied or all search branches are exhausted.\<close>

subsubsection \<open>Symbolic Execution\<close>

text \<open>Symbolic execution is handled by two named theorems:
 @{thm corres_symb_exec_ls} and @{thm corres_symb_exec_rs}, which perform symbolic execution on
the left and right hand sides of a corres goal.\<close>

thm corres_symb_exec_ls
thm corres_symb_exec_rs

text \<open>A function may be symbolically executed if it does not modify the state, i.e. its only purpose
is to compute some value and return it. After being symbolically executed,
this value can only be discussed by the precondition of the associated side or the stateless
precondition of corresK. The resulting @{const corres_rv} goal has @{const corres_noop} as the
function on the alternate side. This gives @{method corres_rv} a hint that the resulting obligation
should be aggressively re-written into a hoare triple over @{term m} if it can't be propagated
back statelessly safely.
\<close>

section \<open>Demo\<close>

context begin interpretation Arch .

(* VSpace_R *)

lemmas load_hw_asid_corres_args[corres] =
  load_hw_asid_corres[@lift_corres_args]

lemmas invalidate_asid_corres_args[corres] =
  invalidate_asid_corres[@lift_corres_args]

lemmas invalidate_hw_asid_entry_corres_args[corres] =
  invalidate_hw_asid_entry_corres[@lift_corres_args]

lemma invalidate_asid_entry_corres:
  "corres dc (valid_arch_objs and valid_asid_map
                and K (asid \<le> mask asid_bits \<and> asid \<noteq> 0)
                and vspace_at_asid asid pd and valid_vs_lookup
                and unique_table_refs o caps_of_state
                and valid_global_objs and valid_arch_state
                and pspace_aligned and pspace_distinct)
             (pspace_aligned' and pspace_distinct' and no_0_obj')
             (invalidate_asid_entry asid) (invalidateASIDEntry asid)"
  apply (simp add: invalidate_asid_entry_def invalidateASIDEntry_def)
  apply_debug (trace) (* apply_trace between steps *)
   (tags "corres") (* break at breakpoints labelled "corres" *)
   corres (* weaken precondition *)
   continue (* split *)
   continue (* solve load_hw_asid *)
   continue (* split *)
   continue (* apply corres_when *)
   continue (* trivial simplification *)
   continue (* invalidate _hw_asid_entry *)
   finish (* invalidate_asid *)

  apply (corressimp wp: load_hw_asid_wp)+
  apply clarsimp
  apply (fastforce simp: pd_at_asid_uniq)
  done

crunch typ_at'[wp]: invalidateASIDEntry, flushSpace "typ_at' T t"
crunch pspace_aligned'[wp]: invalidateASIDEntry "pspace_aligned'"
crunch pspace_distinct'[wp]: invalidateASIDEntry "pspace_distinct'"
crunch ksCurThread[wp]: invalidateASIDEntry, flushSpace "\<lambda>s. P (ksCurThread s)"
crunch obj_at'[wp]: invalidateASIDEntry, flushSpace "obj_at' P p"

lemmas flush_space_corres_args[corres] =
  flush_space_corres[@lift_corres_args]

lemmas invalidate_asid_entry_corres_args[corres] =
  invalidate_asid_entry_corres[@lift_corres_args]

lemma corres_inst_eq_ext:
  "(\<And>x. corres_inst_eq (f x) (f' x)) \<Longrightarrow> corres_inst_eq f f'"
  by (auto simp add: corres_inst_eq_def)

lemma delete_asid_corresb:
  notes [corres] = corres_gets_asid gct_corres set_asid_pool_corres and
    [@lift_corres_args, corres] =  get_asid_pool_corres_inv'
    invalidate_asid_entry_corres
    set_vm_root_corres
  notes [wp] = set_asid_pool_asid_map_unmap set_asid_pool_vs_lookup_unmap'
    set_asid_pool_arch_objs_unmap'
    invalidate_asid_entry_invalidates
    getASID_wp
  shows
    "corres dc
          (invs and valid_etcbs and K (asid \<le> mask asid_bits \<and> asid \<noteq> 0))
          (pspace_aligned' and pspace_distinct' and no_0_obj'
              and valid_arch_state' and cur_tcb')
          (delete_asid asid pd) (deleteASID asid pd)"
  apply (simp add: delete_asid_def deleteASID_def)
  apply_debug (trace) (* apply_trace between steps *)
    (tags "corres") (* break at breakpoints labelled "corres" *)
    corres (* weaken precondition *)
   continue (* split *)
       continue (* gets rule *)
      continue (* corresc *)
       continue (* return rule *)
      continue (* split *)
          continue (* function application *)
          continue (* liftM rule *)
          continue (* get_asid_pool_corres_inv' *)
         continue (* function application *)
         continue (* function application *)
         continue (* corresK_when *)
         continue (* split *)
             continue (* flush_space_corres *)
            continue (* K_bind *)
            continue (* K_bind *)
            continue (* split *)
                continue (* invalidate_asid_entry_corres *)
               continue (* K_bind *)
               continue (* return bind *)
               continue (* K_bind *)
               continue (* split *)
                   continue (* backtracking *)
               continue (* split *)
                   continue (* function application *)
                   continue (* set_asid_pool_corres *)
                  continue (* K_bind *)
                  continue (* K_bind *)
                  continue (* split *)
                      continue (* gct_corres *)
                     continue (* set_vm_root_corres *)
                    finish (* backtracking? *)
                    apply (corressimp simp: mask_asid_low_bits_ucast_ucast
      | fold cur_tcb_def | wps)+
  apply (frule arm_asid_table_related,clarsimp)
  apply (rule conjI)
   apply (intro impI allI)
    apply (rule conjI)
     apply (safe; assumption?)
     apply (rule ext)
     apply (fastforce simp: inv_def dest: ucast_ucast_eq)
    apply (rule context_conjI)
    apply (fastforce simp: o_def dest: valid_asid_tableD invs_valid_asid_table)
   apply (intro allI impI)
   apply (subgoal_tac "vspace_at_asid asid pd s")
    prefer 2
    apply (simp add: vspace_at_asid_def)
    apply (rule vs_lookupI)
     apply (simp add: vs_asid_refs_def)
     apply (rule image_eqI[OF refl])
     apply (rule graph_ofI)
     apply fastforce
    apply (rule r_into_rtrancl)
    apply simp
    apply (rule vs_lookup1I [OF _ _ refl], assumption)
    apply (simp add: vs_refs_def)
    apply (rule image_eqI[rotated], erule graph_ofI)
    apply (simp add: mask_asid_low_bits_ucast_ucast)
   prefer 2
   apply (intro allI impI context_conjI; assumption?)
    apply (rule aligned_distinct_relation_asid_pool_atI'; fastforce?)
    apply (fastforce simp: o_def dest: valid_asid_tableD invs_valid_asid_table)
    apply (simp add: cur_tcb'_def)
    apply (safe; assumption?)
    apply (erule ko_at_weakenE)
    apply (clarsimp simp: graph_of_def)
    apply (fastforce split: if_split_asm)
   apply (frule invs_arch_objs)
   apply (drule (2) valid_arch_objsD)
   apply (erule ranE)
   apply (fastforce split: if_split_asm)
  apply (erule ko_at_weakenE)
  apply (clarsimp simp: graph_of_def)
  apply (fastforce split: if_split_asm)
  done

lemma cte_wp_at_ex:
  "cte_wp_at (\<lambda>_. True) p s \<Longrightarrow> (\<exists>cap. cte_wp_at (op = cap) p s)"
  by (simp add: cte_wp_at_def)

lemma set_vm_root_for_flush_corres:
  notes [corres] = gct_corres getSlotCap_corres
  shows
  "corres (op =)
          (cur_tcb and vspace_at_asid asid pd
           and K (asid \<noteq> 0 \<and> asid \<le> mask asid_bits)
           and valid_asid_map and valid_vs_lookup
           and valid_arch_objs and valid_global_objs
           and unique_table_refs o caps_of_state
           and valid_arch_state
           and pspace_aligned and pspace_distinct)
          (pspace_aligned' and pspace_distinct' and no_0_obj')
          (set_vm_root_for_flush pd asid)
          (setVMRootForFlush pd asid)"
  apply (simp add: set_vm_root_for_flush_def setVMRootForFlush_def getThreadVSpaceRoot_def locateSlot_conv)
  apply corres
  apply_debug (trace) (tags "corres_search")
     (corres_search search: arm_context_switch_corres)
    continue (* step left *)
    continue (* if rule *)
    continue (* failed corres on first subgoal, trying next *)
    continue (* fail corres on last subgoal, trying reverse if rule *)
    continue (* can't make corres progress here, trying other goal *)
    finish (* successful goal discharged by corres *)

  apply (corressimp wp: get_cap_wp getSlotCap_wp)+
  apply (rule context_conjI)
  subgoal by (simp add: cte_map_def objBits_simps tcb_cnode_index_def
                        tcbVTableSlot_def to_bl_1 cte_level_bits_def)
  apply (rule context_conjI)
  subgoal by (fastforce simp: cur_tcb_def intro!: tcb_at_cte_at_1[simplified])
  apply (rule conjI)
   subgoal by (fastforce simp: isCap_simps)
  apply (drule cte_wp_at_ex)
  apply clarsimp
  apply (drule (1) pspace_relation_cte_wp_at[rotated 1]; (assumption | clarsimp)?)
  apply (drule cte_wp_at_norm')
  apply clarsimp
  apply (rule_tac x="cteCap cte" in exI)
  apply (auto elim: cte_wp_at_weakenE' dest!: curthread_relation)
  done

text \<open>Note we can wrap it all up in corressimp\<close>

lemma set_vm_root_for_flush_corres':
  notes [corres] = gct_corres getSlotCap_corres
  shows
  "corres (op =)
          (cur_tcb and vspace_at_asid asid pd
           and K (asid \<noteq> 0 \<and> asid \<le> mask asid_bits)
           and valid_asid_map and valid_vs_lookup
           and valid_arch_objs and valid_global_objs
           and unique_table_refs o caps_of_state
           and valid_arch_state
           and pspace_aligned and pspace_distinct)
          (pspace_aligned' and pspace_distinct' and no_0_obj')
          (set_vm_root_for_flush pd asid)
          (setVMRootForFlush pd asid)"
  apply (simp add: set_vm_root_for_flush_def setVMRootForFlush_def getThreadVSpaceRoot_def locateSlot_conv)
  apply (corressimp search: arm_context_switch_corres
                        wp: get_cap_wp getSlotCap_wp
                      simp: isCap_simps)
  apply (rule context_conjI)
  subgoal by (simp add: cte_map_def objBits_simps tcb_cnode_index_def
                        tcbVTableSlot_def to_bl_1 cte_level_bits_def)
  apply (rule context_conjI)
  subgoal by (fastforce simp: cur_tcb_def intro!: tcb_at_cte_at_1[simplified])
  apply (rule conjI)
   subgoal by (fastforce)
  apply (drule cte_wp_at_ex)
  apply clarsimp
  apply (drule (1) pspace_relation_cte_wp_at[rotated 1]; (assumption | clarsimp)?)
  apply (drule cte_wp_at_norm')
  apply clarsimp
  apply (rule_tac x="cteCap cte" in exI)
  apply (auto elim: cte_wp_at_weakenE' dest!: curthread_relation)
  done

end
end


theory mutualEx
  imports ECMP
begin

definition I :: "scalrValueType" where [simp]:
 "I \<equiv> enum ''state'' ''I''"

definition T :: "scalrValueType" where [simp]:
 "T \<equiv> enum ''state'' ''T''"

definition C :: "scalrValueType" where [simp]:
 "C \<equiv> enum ''state'' ''C''"

definition E :: "scalrValueType" where [simp]:
 "E \<equiv> enum ''state'' ''E''"

definition true :: "scalrValueType" where [simp]:
 "true \<equiv> boolV True"

definition false :: "scalrValueType" where [simp]:
 "false \<equiv> boolV False"

primrec env :: "nat => envType" where
"env N (Ident n) = (if Ident n = Ident ''x'' then
  boolType
else
  anyType
)"|
"env N (Para n i) = (if Para n i = Para ''n'' i \<and> (i \<le> N) then
  enumType
else
  anyType
)"|
"env N dontCareVar = anyType"

lemma env_simp :
 "[|i <= N|] ==> env N (Para ''n'' i) = enumType"

"  env N (Ident ''x'') = boolType"

"[|i > N|] ==> env N (Para n i) = anyType"

   apply(auto      )

done

definition initSpec0 :: "nat \<Rightarrow> formula" where [simp]:
 "initSpec0 N \<equiv> (\<forall>\<^sub>fi. IVar (Para ''n'' i) =\<^sub>f Const I) N"

lemma symPreds0 [intro]:
 "  symPredSet' N {initSpec0 N}"
 unfolding initSpec0_def   apply(rule symPredSetForall)
unfolding symParamForm_def  apply(auto      )

done

lemma deriveFormInitSpec0 [intro]:
 "[|f : {initSpec0 N}|] ==> deriveForm (env N) f"
   apply(auto      )

done

definition initSpec1 :: "formula" where [simp]:
 "initSpec1 \<equiv> IVar (Ident ''x'') =\<^sub>f Const true"

lemma symPreds1 [intro]:
 "  symPredSet' N {initSpec1}"
   apply(auto      )

done

lemma deriveFormInitSpec1 [intro]:
 "[|f : {initSpec1}|] ==> deriveForm (env N) f"
   apply(auto      )

done

definition allInitSpecs :: "nat \<Rightarrow> formula set" where [simp]:
 "allInitSpecs N \<equiv> {initSpec0 N} \<union> {initSpec1}"

lemma symPreds [intro]:
 "  symPredSet' N (allInitSpecs N)"
 unfolding allInitSpecs_def   apply(rule symPredsUnion)
  apply(blast      )

  apply(blast      )

done

lemma deriveFormAllInitSpec :
 "[|f : allInitSpecs N|] ==> deriveForm (env N) f"
  using deriveFormInitSpec0 deriveFormInitSpec1 apply(auto      simp del: initSpec0_def initSpec1_def)

done

definition Try :: "nat \<Rightarrow> rule" where
 "Try i \<equiv>
   IVar (Para ''n'' i) =\<^sub>f Const I
  \<triangleright>
   assign (Para ''n'' i, Const T)"

lemma symTry :
 "  symParamRule N Try"

"[|i <= N|] ==> wellFormedRule (env N) N (Try i)"

 unfolding Try_def  apply(auto intro!: symParamRuleI2 symParamRuleI symParamFormAnd symParamFormForall symParamFormForallExcl symParamFormImply symParamStatementParallel symParamStatementForall symParamStatementForallExcl symParamStatementIte     )

unfolding symParamForm_def  symParamStatement_def     symParamForm2_def symParamStatement2_def mutualDiffVars_def equivForm_def  apply(auto      )

done

definition Trys :: "nat \<Rightarrow> rule set" where
 "Trys N \<equiv> oneParamCons N Try"

definition Crit :: "nat \<Rightarrow> rule" where
 "Crit i \<equiv>
   IVar (Para ''n'' i) =\<^sub>f Const T \<and>\<^sub>f
   IVar (Ident ''x'') =\<^sub>f Const true
  \<triangleright>
   assign (Para ''n'' i, Const C) ||
   assign (Ident ''x'', Const false)"

lemma symCrit :
 "  symParamRule N Crit"

"[|i <= N|] ==> wellFormedRule (env N) N (Crit i)"

 unfolding Crit_def  apply(auto intro!: symParamRuleI2 symParamRuleI symParamFormAnd symParamFormForall symParamFormForallExcl symParamFormImply symParamStatementParallel symParamStatementForall symParamStatementForallExcl symParamStatementIte     )

unfolding symParamForm_def  symParamStatement_def     symParamForm2_def symParamStatement2_def mutualDiffVars_def equivForm_def  apply(auto      )

done

definition Crits :: "nat \<Rightarrow> rule set" where
 "Crits N \<equiv> oneParamCons N Crit"

definition Exit :: "nat \<Rightarrow> rule" where
 "Exit i \<equiv>
   IVar (Para ''n'' i) =\<^sub>f Const C
  \<triangleright>
   assign (Para ''n'' i, Const E)"

lemma symExit :
 "  symParamRule N Exit"

"[|i <= N|] ==> wellFormedRule (env N) N (Exit i)"

 unfolding Exit_def  apply(auto intro!: symParamRuleI2 symParamRuleI symParamFormAnd symParamFormForall symParamFormForallExcl symParamFormImply symParamStatementParallel symParamStatementForall symParamStatementForallExcl symParamStatementIte     )

unfolding symParamForm_def  symParamStatement_def     symParamForm2_def symParamStatement2_def mutualDiffVars_def equivForm_def  apply(auto      )

done

definition Exits :: "nat \<Rightarrow> rule set" where
 "Exits N \<equiv> oneParamCons N Exit"

definition Idle :: "nat \<Rightarrow> rule" where
 "Idle i \<equiv>
   IVar (Para ''n'' i) =\<^sub>f Const E
  \<triangleright>
   assign (Para ''n'' i, Const I) ||
   assign (Ident ''x'', Const true)"

lemma symIdle :
 "  symParamRule N Idle"

"[|i <= N|] ==> wellFormedRule (env N) N (Idle i)"

 unfolding Idle_def  apply(auto intro!: symParamRuleI2 symParamRuleI symParamFormAnd symParamFormForall symParamFormForallExcl symParamFormImply symParamStatementParallel symParamStatementForall symParamStatementForallExcl symParamStatementIte     )

unfolding symParamForm_def  symParamStatement_def     symParamForm2_def symParamStatement2_def mutualDiffVars_def equivForm_def  apply(auto      )

done

definition Idles :: "nat \<Rightarrow> rule set" where
 "Idles N \<equiv> oneParamCons N Idle"

definition mutualEx :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> formula" where
 "mutualEx N i j \<equiv> \<not>\<^sub>f Const (index i) =\<^sub>f Const (index j) \<longrightarrow>\<^sub>f
  IVar (Para ''n'' i) =\<^sub>f Const C \<longrightarrow>\<^sub>f
  \<not>\<^sub>f IVar (Para ''n'' j) =\<^sub>f Const C"

definition ABS_Crit :: "rule" where
 "ABS_Crit \<equiv>
   IVar (Ident ''x'') =\<^sub>f Const true
  \<triangleright>
   assign (Ident ''x'', Const false)"

definition ABS_Crits :: "rule set" where
 "ABS_Crits \<equiv> {ABS_Crit}"

definition ABS_Idle :: "nat \<Rightarrow> rule" where
 "ABS_Idle N \<equiv>
   (\<forall>\<^sub>fj. \<not>\<^sub>f IVar (Para ''n'' j) =\<^sub>f Const C \<and>\<^sub>f
   \<not>\<^sub>f IVar (Para ''n'' j) =\<^sub>f Const E) N
  \<triangleright>
   assign (Ident ''x'', Const true)"

definition ABS_Idles :: "nat \<Rightarrow> rule set" where
 "ABS_Idles N \<equiv> {ABS_Idle N}"

definition Lemma_1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> formula" where
 "Lemma_1 N p i \<equiv> IVar (Para ''n'' i) =\<^sub>f Const E \<longrightarrow>\<^sub>f
  forallFormExcl (\<lambda>j. \<not>\<^sub>f IVar (Para ''n'' j) =\<^sub>f Const C \<and>\<^sub>f
  \<not>\<^sub>f IVar (Para ''n'' j) =\<^sub>f Const E) i N"

definition rules :: "nat \<Rightarrow> rule set" where
 "rules N = (Trys N \<union> (Crits N \<union> (Exits N \<union> Idles N)))"

lemma deriveAll :
 "[|r : Trys N|] ==> deriveRule (env N) r"

"[|r : Crits N|] ==> deriveRule (env N) r"

"[|r : Exits N|] ==> deriveRule (env N) r"

"[|r : Idles N|] ==> deriveRule (env N) r"

"[|r : ABS_Crits|] ==> deriveRule (env N) r"

"[|r : ABS_Idles N|] ==> deriveRule (env N) r"

 unfolding deriveRule_def deriveForm_def deriveStmt_def Trys_def Try_def Crits_def Crit_def Exits_def Exit_def Idles_def Idle_def ABS_Crits_def ABS_Crit_def ABS_Idles_def ABS_Idle_def  apply(auto      )

done

lemma symProtAll :
 "  symProtRules' N (Trys N)"

"  symProtRules' N (Crits N)"

"  symProtRules' N (Exits N)"

"  symProtRules' N (Idles N)"

  using symTry(1) Trys_def symParaRuleInfSymRuleSet symParaRuleInfSymRuleSet2 apply(auto      )[1]

 using symCrit(1) Crits_def symParaRuleInfSymRuleSet symParaRuleInfSymRuleSet2 apply(auto      )[1]

 using symExit(1) Exits_def symParaRuleInfSymRuleSet symParaRuleInfSymRuleSet2 apply(auto      )[1]

 using symIdle(1) Idles_def symParaRuleInfSymRuleSet symParaRuleInfSymRuleSet2 apply(auto      )[1]

done

lemma symmutualEx :
 "  symParamForm2 N (mutualEx N)"
 unfolding mutualEx_def  apply(auto      )

  apply(intro  symParamForm2Imply symParamFormForallExcl2 )

unfolding symParamForm2_def  apply(auto      )

done

lemma symLemma_1 :
 "  symParamForm2 N (Lemma_1 N)"
 unfolding Lemma_1_def  apply(auto      )

  apply(intro  symParamForm2Imply symParamFormForallExcl2 )

unfolding symParamForm2_def  apply(auto      )

done

definition lemmasFor_Try :: "nat \<Rightarrow> ((nat \<Rightarrow> nat \<Rightarrow> formula) list)" where
 "lemmasFor_Try N = []"

definition Try_ref :: "nat \<Rightarrow> rule" where
 "Try_ref i \<equiv>
   IVar (Para ''n'' i) =\<^sub>f Const I
  \<triangleright>
   assign (Para ''n'' i, Const T)"

lemma symTry_ref :
 "  symParamRule N Try_ref"

"[|i <= N|] ==> wellFormedRule (env N) N (Try_ref i)"

 unfolding Try_ref_def  apply(auto intro!: symParamRuleI2 symParamRuleI symParamFormAnd symParamFormForall symParamFormForallExcl symParamFormImply symParamStatementParallel symParamStatementForall symParamStatementForallExcl symParamStatementIte     )

unfolding symParamForm_def  symParamStatement_def     symParamForm2_def symParamStatement2_def mutualDiffVars_def equivForm_def  apply(auto      )

done

definition Try_refs :: "nat \<Rightarrow> rule set" where
 "Try_refs N \<equiv> oneParamCons N Try_ref"

lemma Try_strengthen :
 "  strengthenRuleByFrmL2 (map2' (lemmasFor_Try N) j i) (Try i) = Try_ref i"
 unfolding lemmasFor_Try_def  Try_def Try_ref_def  apply(auto      )

done

lemma abs_Try_ref :
 "[|M <= N;i <= M|] ==> absTransfRule (env N) M (Try_ref i) = Try_ref i"

"[|M <= N;i > M|] ==> absTransfRule (env N) M (Try_ref i) = skipRule"

 unfolding Try_ref_def Try_ref_def skipRule_def  apply(auto     simp add: Let_def )

done

definition lemmasFor_Crit :: "nat \<Rightarrow> ((nat \<Rightarrow> nat \<Rightarrow> formula) list)" where
 "lemmasFor_Crit N = []"

definition Crit_ref :: "nat \<Rightarrow> rule" where
 "Crit_ref i \<equiv>
   IVar (Para ''n'' i) =\<^sub>f Const T \<and>\<^sub>f
   IVar (Ident ''x'') =\<^sub>f Const true
  \<triangleright>
   assign (Para ''n'' i, Const C) ||
   assign (Ident ''x'', Const false)"

lemma symCrit_ref :
 "  symParamRule N Crit_ref"

"[|i <= N|] ==> wellFormedRule (env N) N (Crit_ref i)"

 unfolding Crit_ref_def  apply(auto intro!: symParamRuleI2 symParamRuleI symParamFormAnd symParamFormForall symParamFormForallExcl symParamFormImply symParamStatementParallel symParamStatementForall symParamStatementForallExcl symParamStatementIte     )

unfolding symParamForm_def  symParamStatement_def     symParamForm2_def symParamStatement2_def mutualDiffVars_def equivForm_def  apply(auto      )

done

definition Crit_refs :: "nat \<Rightarrow> rule set" where
 "Crit_refs N \<equiv> oneParamCons N Crit_ref"

lemma Crit_strengthen :
 "  strengthenRuleByFrmL2 (map2' (lemmasFor_Crit N) j i) (Crit i) = Crit_ref i"
 unfolding lemmasFor_Crit_def  Crit_def Crit_ref_def  apply(auto      )

done

lemma abs_Crit_ref :
 "[|M <= N;i <= M|] ==> absTransfRule (env N) M (Crit_ref i) = Crit_ref i"

"[|M <= N;i > M|] ==> absTransfRule (env N) M (Crit_ref i) = ABS_Crit"

 unfolding Crit_ref_def Crit_ref_def ABS_Crit_def  apply(auto     simp add: Let_def )

done

definition lemmasFor_Exit :: "nat \<Rightarrow> ((nat \<Rightarrow> nat \<Rightarrow> formula) list)" where
 "lemmasFor_Exit N = []"

definition Exit_ref :: "nat \<Rightarrow> rule" where
 "Exit_ref i \<equiv>
   IVar (Para ''n'' i) =\<^sub>f Const C
  \<triangleright>
   assign (Para ''n'' i, Const E)"

lemma symExit_ref :
 "  symParamRule N Exit_ref"

"[|i <= N|] ==> wellFormedRule (env N) N (Exit_ref i)"

 unfolding Exit_ref_def  apply(auto intro!: symParamRuleI2 symParamRuleI symParamFormAnd symParamFormForall symParamFormForallExcl symParamFormImply symParamStatementParallel symParamStatementForall symParamStatementForallExcl symParamStatementIte     )

unfolding symParamForm_def  symParamStatement_def     symParamForm2_def symParamStatement2_def mutualDiffVars_def equivForm_def  apply(auto      )

done

definition Exit_refs :: "nat \<Rightarrow> rule set" where
 "Exit_refs N \<equiv> oneParamCons N Exit_ref"

lemma Exit_strengthen :
 "  strengthenRuleByFrmL2 (map2' (lemmasFor_Exit N) j i) (Exit i) = Exit_ref i"
 unfolding lemmasFor_Exit_def  Exit_def Exit_ref_def  apply(auto      )

done

lemma abs_Exit_ref :
 "[|M <= N;i <= M|] ==> absTransfRule (env N) M (Exit_ref i) = Exit_ref i"

"[|M <= N;i > M|] ==> absTransfRule (env N) M (Exit_ref i) = skipRule"

 unfolding Exit_ref_def Exit_ref_def skipRule_def  apply(auto     simp add: Let_def )

done

definition lemmasFor_Idle :: "nat \<Rightarrow> ((nat \<Rightarrow> nat \<Rightarrow> formula) list)" where
 "lemmasFor_Idle N = [Lemma_1 N]"

definition Idle_ref :: "nat \<Rightarrow> nat \<Rightarrow> rule" where
 "Idle_ref N i \<equiv>
   IVar (Para ''n'' i) =\<^sub>f Const E \<and>\<^sub>f
   forallFormExcl (\<lambda>j. \<not>\<^sub>f IVar (Para ''n'' j) =\<^sub>f Const C \<and>\<^sub>f
   \<not>\<^sub>f IVar (Para ''n'' j) =\<^sub>f Const E) i N
  \<triangleright>
   assign (Para ''n'' i, Const I) ||
   assign (Ident ''x'', Const true)"

lemma symIdle_ref :
 "  symParamRule N (Idle_ref N)"

"[|i <= N|] ==> wellFormedRule (env N) N (Idle_ref N i)"

 unfolding Idle_ref_def  apply(auto intro!: symParamRuleI2 symParamRuleI symParamFormAnd symParamFormForall symParamFormForallExcl symParamFormImply symParamStatementParallel symParamStatementForall symParamStatementForallExcl symParamStatementIte     )

unfolding symParamForm_def  symParamStatement_def     symParamForm2_def symParamStatement2_def mutualDiffVars_def equivForm_def  apply(auto      )

done

definition Idle_refs :: "nat \<Rightarrow> rule set" where
 "Idle_refs N \<equiv> oneParamCons N (Idle_ref N)"

lemma Idle_strengthen :
 "  strengthenRuleByFrmL2 (map2' (lemmasFor_Idle N) j i) (Idle i) = Idle_ref N i"
 unfolding lemmasFor_Idle_def Lemma_1_def Idle_def Idle_ref_def  apply(auto      )

done

lemma abs_Idle_ref :
 "[|M <= N;i <= M|] ==> absTransfRule (env N) M (Idle_ref N i) = Idle_ref M i"

"[|M <= N;i > M|] ==> absTransfRule (env N) M (Idle_ref N i) = ABS_Idle M"

 unfolding Idle_ref_def Idle_ref_def ABS_Idle_def  apply(auto     simp add: Let_def )

done

definition InvS :: "nat \<Rightarrow> (((nat \<Rightarrow> nat \<Rightarrow> formula) list) list)" where
 "InvS N = [lemmasFor_Try N, lemmasFor_Crit N, lemmasFor_Exit N, lemmasFor_Idle N]"

definition rule_refs :: "nat \<Rightarrow> rule set" where
 "rule_refs N = (Try_refs N \<union> (Crit_refs N \<union> (Exit_refs N \<union> Idle_refs N)))"

lemma TryStrengthRel :
 "  strengthenRel (Trys N) (set (InvS N)) (Try_refs N) N"
 unfolding Trys_def Try_refs_def  apply(rule_tac ?lemmasFor_r="lemmasFor_Try" in strengthenExt1)
 using Try_strengthen apply(presburger      )

unfolding InvS_def  apply(auto      )

done

lemma CritStrengthRel :
 "  strengthenRel (Crits N) (set (InvS N)) (Crit_refs N) N"
 unfolding Crits_def Crit_refs_def  apply(rule_tac ?lemmasFor_r="lemmasFor_Crit" in strengthenExt1)
 using Crit_strengthen apply(presburger      )

unfolding InvS_def  apply(auto      )

done

lemma ExitStrengthRel :
 "  strengthenRel (Exits N) (set (InvS N)) (Exit_refs N) N"
 unfolding Exits_def Exit_refs_def  apply(rule_tac ?lemmasFor_r="lemmasFor_Exit" in strengthenExt1)
 using Exit_strengthen apply(presburger      )

unfolding InvS_def  apply(auto      )

done

lemma IdleStrengthRel :
 "  strengthenRel (Idles N) (set (InvS N)) (Idle_refs N) N"
 unfolding Idles_def Idle_refs_def  apply(rule_tac ?lemmasFor_r="lemmasFor_Idle" in strengthenExt1)
 using Idle_strengthen apply(presburger      )

unfolding InvS_def  apply(auto      )

done

lemma deriveAllRef :
 "[|r : Try_refs N|] ==> deriveRule (env N) r"

"[|r : Crit_refs N|] ==> deriveRule (env N) r"

"[|r : Exit_refs N|] ==> deriveRule (env N) r"

"[|r : Idle_refs N|] ==> deriveRule (env N) r"

 unfolding deriveRule_def deriveForm_def deriveStmt_def Try_refs_def Try_ref_def Crit_refs_def Crit_ref_def Exit_refs_def Exit_ref_def Idle_refs_def Idle_ref_def  apply(auto      )

done

lemma symProtAllRef :
 "  symProtRules' N (Try_refs N)"

"  symProtRules' N (Crit_refs N)"

"  symProtRules' N (Exit_refs N)"

"  symProtRules' N (Idle_refs N)"

  using symTry_ref(1) Try_refs_def symCrit_ref(1) Crit_refs_def symExit_ref(1) Exit_refs_def symIdle_ref(1) Idle_refs_def symParaRuleInfSymRuleSet symParaRuleInfSymRuleSet2 apply(auto      )

done

lemma StrengthRelRules2Rule_refs :
 "  strengthenRel (rules N) (set (InvS N)) (rule_refs N) N"
 unfolding rules_def rule_refs_def   apply(rule strenRelUnion)
  apply(blast intro: TryStrengthRel     )

   apply(rule strenRelUnion)
  apply(blast intro: CritStrengthRel     )

   apply(rule strenRelUnion)
  apply(blast intro: ExitStrengthRel     )

  apply(blast intro: IdleStrengthRel     )

done

lemma Abs_Try_refs :
 "[|M < N|] ==> (absTransfRule (env N) M ` Try_refs N) = (Try_refs M Un {skipRule})"
 unfolding Try_refs_def   apply(rule absGen)
 using abs_Try_ref apply(auto      )

done

lemma Abs_Crit_refs :
 "[|M < N|] ==> (absTransfRule (env N) M ` Crit_refs N) = (Crit_refs M Un ABS_Crits)"
 unfolding Crit_refs_def ABS_Crits_def   apply(rule absGen)
 using abs_Crit_ref apply(auto      )

done

lemma Abs_Exit_refs :
 "[|M < N|] ==> (absTransfRule (env N) M ` Exit_refs N) = (Exit_refs M Un {skipRule})"
 unfolding Exit_refs_def   apply(rule absGen)
 using abs_Exit_ref apply(auto      )

done

lemma Abs_Idle_refs :
 "[|M < N|] ==> (absTransfRule (env N) M ` Idle_refs N) = (Idle_refs M Un ABS_Idles M)"
 unfolding Idle_refs_def ABS_Idles_def   apply(rule absGen)
 using abs_Idle_ref apply(auto      )

done

definition ABS_rules :: "nat \<Rightarrow> rule set" where [simp]:
 "ABS_rules N = (Try_refs N \<union> (Crit_refs N \<union> (ABS_Crits \<union> (Exit_refs N \<union> (Idle_refs N \<union> (ABS_Idles N \<union> {skipRule}))))))"

definition ABS_rules' :: "nat \<Rightarrow> rule set" where [simp]:
 "ABS_rules' N = ((Try_refs N \<union> {skipRule}) \<union> ((Crit_refs N \<union> ABS_Crits) \<union> ((Exit_refs N \<union> {skipRule}) \<union> (Idle_refs N \<union> ABS_Idles N))))"

lemma ABS_rules_eq_rules' :
 "  ABS_rules M = ABS_rules' M"
   apply(auto      )

done

lemma ABS_all :
 "[|M < N|] ==> (absTransfRule (env N) M ` rule_refs N) = ABS_rules M"
   apply(subst ABS_rules_eq_rules'       )

unfolding rule_refs_def ABS_rules'_def  apply(intro  image_UnI )

  apply(auto     simp add: Abs_Try_refs Abs_Crit_refs Abs_Exit_refs Abs_Idle_refs )

done

definition Lemma_1' :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> formula" where
 "Lemma_1' N i j \<equiv> \<not>\<^sub>f Const (index i) =\<^sub>f Const (index j) \<and>\<^sub>f
  IVar (Para ''n'' i) =\<^sub>f Const E \<longrightarrow>\<^sub>f
  \<not>\<^sub>f IVar (Para ''n'' j) =\<^sub>f Const C \<and>\<^sub>f
  \<not>\<^sub>f IVar (Para ''n'' j) =\<^sub>f Const E"

lemma absTransfLemma_1' :
 "[|M < N;M = 1;l <= 1|] ==> absTransfForm (env N) M (Lemma_1' N 0 l) = Lemma_1' N 0 l"
 unfolding Lemma_1'_def  apply(auto      )

done

lemma strengthenVsObsLemma_1 :
 "  strengthenVsObs (Lemma_1 N) (Lemma_1' N) N"
 unfolding Lemma_1_def Lemma_1'_def   apply(rule strengthenVsObsDiff)
unfolding symParamForm_def  apply(auto      )

done

lemma SafeAndderiveFormLemma_1' :
 "[|M < N;M = 1;l <= M;k <= M|] ==> safeForm (env N) M (Lemma_1' N k l) & deriveForm (env N) (Lemma_1' N k l)"
 unfolding Lemma_1'_def  apply(auto      )

done

lemma symInvs :
 "  symParamForm2 N (Lemma_1' N)"

 unfolding Lemma_1'_def  apply(auto      )

subgoal    apply(intro  symParamForm2Imply symParamFormForallExcl2 )

  unfolding symParamForm2_def  apply(auto      )
   done

done

definition lemmasFor_Try' :: "nat \<Rightarrow> ((nat \<Rightarrow> nat \<Rightarrow> formula) list)" where
 "lemmasFor_Try' N = []"

lemma strengthenVsObsLs_lemmasFor_Try :
 "  strengthenVsObsLs (lemmasFor_Try N) (lemmasFor_Try' N) N"
 unfolding strengthenVsObsLs_def lemmasFor_Try_def lemmasFor_Try'_def  apply(auto      )

done

lemma lemmaTry_fitEnv :
 "[|formEval (pre r) s;fitEnv s (env N);r : Try_refs N|] ==> fitEnv (trans1 (act r) s) (env N)"
 unfolding Try_refs_def Try_ref_def  apply(auto      )

done

definition lemmasFor_Crit' :: "nat \<Rightarrow> ((nat \<Rightarrow> nat \<Rightarrow> formula) list)" where
 "lemmasFor_Crit' N = []"

lemma strengthenVsObsLs_lemmasFor_Crit :
 "  strengthenVsObsLs (lemmasFor_Crit N) (lemmasFor_Crit' N) N"
 unfolding strengthenVsObsLs_def lemmasFor_Crit_def lemmasFor_Crit'_def  apply(auto      )

done

lemma lemmaCrit_fitEnv :
 "[|formEval (pre r) s;fitEnv s (env N);r : Crit_refs N|] ==> fitEnv (trans1 (act r) s) (env N)"
 unfolding Crit_refs_def Crit_ref_def  apply(auto      )

done

definition lemmasFor_Exit' :: "nat \<Rightarrow> ((nat \<Rightarrow> nat \<Rightarrow> formula) list)" where
 "lemmasFor_Exit' N = []"

lemma strengthenVsObsLs_lemmasFor_Exit :
 "  strengthenVsObsLs (lemmasFor_Exit N) (lemmasFor_Exit' N) N"
 unfolding strengthenVsObsLs_def lemmasFor_Exit_def lemmasFor_Exit'_def  apply(auto      )

done

lemma lemmaExit_fitEnv :
 "[|formEval (pre r) s;fitEnv s (env N);r : Exit_refs N|] ==> fitEnv (trans1 (act r) s) (env N)"
 unfolding Exit_refs_def Exit_ref_def  apply(auto      )

done

definition lemmasFor_Idle' :: "nat \<Rightarrow> ((nat \<Rightarrow> nat \<Rightarrow> formula) list)" where
 "lemmasFor_Idle' N = [Lemma_1' N]"

lemma strengthenVsObsLs_lemmasFor_Idle :
 "  strengthenVsObsLs (lemmasFor_Idle N) (lemmasFor_Idle' N) N"
 unfolding strengthenVsObsLs_def lemmasFor_Idle_def lemmasFor_Idle'_def  apply(auto intro: strengthenVsObsLemma_1     )

done

lemma lemmaIdle_fitEnv :
 "[|formEval (pre r) s;fitEnv s (env N);r : Idle_refs N|] ==> fitEnv (trans1 (act r) s) (env N)"
 unfolding Idle_refs_def Idle_ref_def  apply(auto      )

done

definition InvS' :: "nat \<Rightarrow> (((nat \<Rightarrow> nat \<Rightarrow> formula) list) list)" where
 "InvS' N = [lemmasFor_Try' N, lemmasFor_Crit' N, lemmasFor_Exit' N, lemmasFor_Idle' N]"

lemma wellFormedRule_refs :
 "[|r : rule_refs N|] ==> wellFormedRule (env N) N r"
   apply(auto     simp add: rule_refs_def   Try_refs_def Crit_refs_def Exit_refs_def Idle_refs_def symTry_ref symCrit_ref symExit_ref symIdle_ref )

done

lemma SafeAndderiveAll :
 "[|M < N;M = 1;l <= M;k <= M;pinvL : set (InvS' N);pf : set pinvL|] ==> safeForm (env N) M (pf k l) & deriveForm (env N) (pf k l)"
 unfolding InvS'_def lemmasFor_Try'_def lemmasFor_Crit'_def lemmasFor_Exit'_def lemmasFor_Idle'_def using SafeAndderiveFormLemma_1' apply(auto      )

done

lemma rulesIsSym :
 "  symProtRules' N (rules N)"
 unfolding rules_def   apply(rule symProtRulesUnion, blast intro:symProtAll)+
unfolding rules_def  apply(blast intro: symProtAll     )

done

lemma rule_refsIsSym :
 "  symProtRules' N (rule_refs N)"
 unfolding rule_refs_def   apply(rule symProtRulesUnion, blast intro:symProtAllRef)+
unfolding rule_refs_def  apply(blast intro: symProtAllRef     )

done

lemma rule_refsWellTyped :
 "[|r : rule_refs N|] ==> deriveRule (env N) r"
 unfolding rule_refs_def using deriveAllRef apply(auto      )

done

lemma ReachStafitEnv :
 "[|reachableUpTo (allInitSpecs N) (rule_refs N) k s|] ==> fitEnv s (env N)"
   apply(erule invIntro1)
subgoal for s0
  unfolding fitEnv_def   apply(rule allI)
     apply(rule impI)
  apply(case_tac   "v")

  subgoal for v x1
    apply(case_tac   "x1 = ''x''")

    apply(subgoal_tac   "formEval (initSpec1) s0")

      apply(auto      )[1]

      apply(auto      )[1]

      apply(auto      )
     done

  subgoal for v x21 x22
    apply(case_tac   "x21 = ''n''")

    apply(subgoal_tac   "formEval (initSpec0 N) s0")

      apply(auto      )[1]

      apply(auto      )[1]

      apply(auto      )
     done

    apply(auto      )
   done

subgoal for r sk
  unfolding rule_refs_def  apply(auto intro: Un_iff lemmaTry_fitEnv lemmaCrit_fitEnv lemmaExit_fitEnv lemmaIdle_fitEnv     )
   done

done

lemma absProtSim :
 "[|M < N;M = 1;isProtObsInvSet (ABS_rules M) (absTransfForm (env N) M ` allInitSpecs N) (set (InvS' N)) M (env N)|] ==> isParamProtInvSet (rules N) (allInitSpecs N) (set (InvS N)) N"
   apply(rule_tac ?rs2.0 = "rule_refs N" and env="env N" and S="set (InvS N)" and S'="set (InvS' N)" and M=M and absRules="ABS_rules M" in CMP)
subgoal for r
   using wellFormedRule_refs apply(auto      )
   done

subgoal  unfolding InvS'_def lemmasFor_Try'_def lemmasFor_Crit'_def lemmasFor_Exit'_def lemmasFor_Idle'_def using symInvs apply(auto      )
   done

subgoal   using rulesIsSym apply(auto      )
   done

subgoal   using symPreds apply(auto      )
   done

subgoal    apply(auto      )
   done

subgoal    apply(auto      )
   done

subgoal   using SafeAndderiveAll apply(auto      )
   done

subgoal   using StrengthRelRules2Rule_refs apply(auto      )
   done

subgoal   using rule_refsIsSym apply(auto      )
   done

subgoal   using rule_refsWellTyped apply(auto      )
   done

subgoal    apply(auto      )
   done

subgoal   using ReachStafitEnv apply(auto      )
   done

subgoal  unfolding InvS_def InvS'_def  apply(auto      )

  subgoal   using strengthenVsObsLs_lemmasFor_Try apply(auto      )
     done

  subgoal   using strengthenVsObsLs_lemmasFor_Crit apply(auto      )
     done

  subgoal   using strengthenVsObsLs_lemmasFor_Exit apply(auto      )
     done

  subgoal   using strengthenVsObsLs_lemmasFor_Idle apply(auto      )
     done
  done

   apply(rule equivRuleSetReflex)
 using ABS_all  apply(auto      )

done

end


section \<open>Operation Identification Phase\<close>
theory Sepref_Id_Op
imports
  Main
  Automatic_Refinement.Refine_Lib
  Automatic_Refinement.Autoref_Tagging
  "Lib/Named_Theorems_Rev"
begin

text \<open>
  The operation identification phase is adapted from the Autoref tool.
  The basic idea is to have a type system, which works on so called
  interface types (also called conceptual types). Each conceptual type
  denotes an abstract data type, e.g., set, map, priority queue.

  Each abstract operation, which must be a constant applied to its arguments,
  is assigned a conceptual type. Additionally, there is a set of
  {\emph pattern rewrite rules},
  which are applied to subterms before type inference takes place, and
  which may be backtracked over.
  This way, encodings of abstract operations in Isabelle/HOL, like
  @{term [source] "\<lambda>_. None"} for the empty map,
  or @{term [source] "fun_upd m k (Some v)"} for map update, can be rewritten
  to abstract operations, and get properly typed.
\<close>

subsection "Proper Protection of Term"
text \<open> The following constants are meant to encode abstraction and
  application as proper HOL-constants, and thus avoid strange effects with
  HOL's higher-order unification heuristics and automatic
  beta and eta-contraction.

  The first step of operation identification is to protect the term
  by replacing all function applications and abstractions be
  the constants defined below.
\<close>

definition [simp]: "PROTECT2 x (y::prop) \<equiv> x"
consts DUMMY :: "prop"

abbreviation PROTECT2_syn ("'(#_#')") where "PROTECT2_syn t \<equiv> PROTECT2 t DUMMY"

abbreviation (input)ABS2 :: "('a\<Rightarrow>'b)\<Rightarrow>'a\<Rightarrow>'b" (binder "\<lambda>\<^sub>2" 10)
  where "ABS2 f \<equiv> (\<lambda>x. PROTECT2 (f x) DUMMY)"

lemma beta: "(\<lambda>\<^sub>2x. f x)$x \<equiv> f x" by simp

text \<open>
  Another version of @{const "APP"}. Treated like @{const APP} by our tool.
  Required to avoid infinite pattern rewriting in some cases, e.g., map-lookup.
\<close>

definition APP' (infixl "$''" 900) where [simp, autoref_tag_defs]: "f$'a \<equiv> f a"

text \<open>
  Sometimes, whole terms should be protected from being processed by our tool.
  For example, our tool should not look into numerals. For this reason,
  the \<open>PR_CONST\<close> tag indicates terms that our tool shall handle as
  atomic constants, an never look into them.

  The special form \<open>UNPROTECT\<close> can be used inside pattern rewrite rules.
  It has the effect to revert the protection from its argument, and then wrap
  it into a \<open>PR_CONST\<close>.
\<close>
definition [simp, autoref_tag_defs]: "PR_CONST x \<equiv> x" \<comment> \<open>Tag to protect constant\<close>
definition [simp, autoref_tag_defs]: "UNPROTECT x \<equiv> x" \<comment> \<open>Gets
  converted to @{term PR_CONST}, after unprotecting its content\<close>

subsection \<open>Operation Identification\<close>

text \<open> Indicator predicate for conceptual typing of a constant \<close>
definition intf_type :: "'a \<Rightarrow> 'b itself \<Rightarrow> bool" (infix "::\<^sub>i" 10) where
  [simp]: "c::\<^sub>iI \<equiv> True"

lemma itypeI: "c::\<^sub>iI" by simp
lemma itypeI': "intf_type c TYPE('T)" by (rule itypeI)

lemma itype_self: "(c::'a) ::\<^sub>i TYPE('a)" by simp

definition CTYPE_ANNOT :: "'b \<Rightarrow> 'a itself \<Rightarrow> 'b" (infix ":::\<^sub>i" 10) where
  [simp]: "c:::\<^sub>iI \<equiv> c"

text \<open> Wrapper predicate for an conceptual type inference \<close>
definition ID :: "'a \<Rightarrow> 'a \<Rightarrow> 'c itself \<Rightarrow> bool"
  where [simp]: "ID t t' T \<equiv> t=t'"

subsubsection \<open>Conceptual Typing Rules\<close>

lemma ID_unfold_vars: "ID x y T \<Longrightarrow> x\<equiv>y" by simp
lemma ID_PR_CONST_trigger: "ID (PR_CONST x) y T \<Longrightarrow> ID (PR_CONST x) y T" .

lemma pat_rule:
  "\<lbrakk> p\<equiv>p'; ID p' t' T \<rbrakk> \<Longrightarrow> ID p t' T" by simp

lemma app_rule:
  "\<lbrakk> ID f f' TYPE('a\<Rightarrow>'b); ID x x' TYPE('a)\<rbrakk> \<Longrightarrow> ID (f$x) (f'$x') TYPE('b)"
  by simp

lemma app'_rule:
  "\<lbrakk> ID f f' TYPE('a\<Rightarrow>'b); ID x x' TYPE('a)\<rbrakk> \<Longrightarrow> ID (f$'x) (f'$x') TYPE('b)"
  by simp

lemma abs_rule:
  "\<lbrakk> \<And>x x'. ID x x' TYPE('a) \<Longrightarrow> ID (t x) (t' x x') TYPE('b) \<rbrakk> \<Longrightarrow>
    ID (\<lambda>\<^sub>2x. t x) (\<lambda>\<^sub>2x'. t' x' x') TYPE('a\<Rightarrow>'b)"
  by simp

lemma id_rule: "c::\<^sub>iI \<Longrightarrow> ID c c I" by simp

lemma annot_rule: "ID t t' I \<Longrightarrow> ID (t:::\<^sub>iI) t' I"
  by simp

lemma fallback_rule:
  "ID (c::'a) c TYPE('c)"
  by simp

lemma unprotect_rl1: "ID (PR_CONST x) t T \<Longrightarrow> ID (UNPROTECT x) t T"
  by simp

subsection \<open> ML-Level code \<close>
ML \<open>
infix 0 THEN_ELSE_COMB'

signature ID_OP_TACTICAL = sig
  val SOLVE_FWD: tactic' -> tactic'
  val DF_SOLVE_FWD: bool -> tactic' -> tactic'
end

structure Id_Op_Tactical :ID_OP_TACTICAL = struct

  fun SOLVE_FWD tac i st = SOLVED' (
    tac
    THEN_ALL_NEW_FWD (SOLVE_FWD tac)) i st

  (* Search for solution with DFS-strategy. If dbg-flag is given,
    return sequence of stuck states if no solution is found.
  *)
  fun DF_SOLVE_FWD dbg tac = let
    val stuck_list_ref = Unsynchronized.ref []

    fun stuck_tac _ st = if dbg then (
      stuck_list_ref := st :: !stuck_list_ref;
      Seq.empty
    ) else Seq.empty

    fun rec_tac i st = (
        (tac THEN_ALL_NEW_FWD (SOLVED' rec_tac))
        ORELSE' stuck_tac
      ) i st

    fun fail_tac _ _ = if dbg then
      Seq.of_list (rev (!stuck_list_ref))
    else Seq.empty
  in
    rec_tac ORELSE' fail_tac
  end

end
\<close>

named_theorems_rev id_rules "Operation identification rules"
named_theorems_rev pat_rules "Operation pattern rules"
named_theorems_rev def_pat_rules "Definite operation pattern rules (not backtracked over)"

ML \<open>

  structure Id_Op = struct

    fun id_a_conv cnv ct = case Thm.term_of ct of
      @{mpat "ID _ _ _"} => Conv.fun_conv (Conv.fun_conv (Conv.arg_conv cnv)) ct
    | _ => raise CTERM("id_a_conv",[ct])

    fun
      protect env (@{mpat "?t:::\<^sub>i?I"}) = let
        val t = protect env t
      in
        @{mk_term env: "?t:::\<^sub>i?I"}
      end
    | protect _ (t as @{mpat "PR_CONST _"}) = t
    | protect env (t1$t2) = let
        val t1 = protect env t1
        val t2 = protect env t2
      in
        @{mk_term env: "?t1.0 $ ?t2.0"}
      end
    | protect env (Abs (x,T,t)) = let
        val t = protect (T::env) t
      in
        @{mk_term env: "\<lambda>v_x::?'v_T. PROTECT2 ?t DUMMY"}
      end
    | protect _ t = t

    fun protect_conv ctxt = Refine_Util.f_tac_conv ctxt
      (protect [])
      (simp_tac
        (put_simpset HOL_basic_ss ctxt addsimps @{thms PROTECT2_def APP_def}) 1)

    fun unprotect_conv ctxt
      = Simplifier.rewrite (put_simpset HOL_basic_ss ctxt
        addsimps @{thms PROTECT2_def APP_def})

    fun do_unprotect_tac ctxt =
      resolve_tac ctxt @{thms unprotect_rl1} THEN'
      CONVERSION (Refine_Util.HOL_concl_conv (fn ctxt => id_a_conv (unprotect_conv ctxt)) ctxt)

    val cfg_id_debug =
      Attrib.setup_config_bool @{binding id_debug} (K false)

    val cfg_id_trace_fallback =
      Attrib.setup_config_bool @{binding id_trace_fallback} (K false)

    fun dest_id_rl thm = case Thm.concl_of thm of
      @{mpat (typs) "Trueprop (?c::\<^sub>iTYPE(?'v_T))"} => (c,T)
    | _ => raise THM("dest_id_rl",~1,[thm])

    val add_id_rule = snd oo Thm.proof_attributes [Named_Theorems_Rev.add @{named_theorems_rev id_rules}]

    datatype id_tac_mode = Init | Step | Normal | Solve

    fun id_tac ss ctxt = let
      open Id_Op_Tactical
      val certT = Thm.ctyp_of ctxt
      val cert = Thm.cterm_of ctxt

      val thy = Proof_Context.theory_of ctxt

      val id_rules = Named_Theorems_Rev.get ctxt @{named_theorems_rev id_rules}
      val pat_rules = Named_Theorems_Rev.get ctxt @{named_theorems_rev pat_rules}
      val def_pat_rules = Named_Theorems_Rev.get ctxt @{named_theorems_rev def_pat_rules}

      val rl_net = Tactic.build_net (
        (pat_rules |> map (fn thm => thm RS @{thm pat_rule}))
        @ @{thms annot_rule app_rule app'_rule abs_rule}
        @ (id_rules |> map (fn thm => thm RS @{thm id_rule}))
      )

      val def_rl_net = Tactic.build_net (
        (def_pat_rules |> map (fn thm => thm RS @{thm pat_rule}))
      )

      val id_pr_const_rename_tac =
          resolve_tac ctxt @{thms ID_PR_CONST_trigger} THEN'
          Subgoal.FOCUS (fn { context=ctxt, prems, ... } =>
            let
              fun is_ID @{mpat "Trueprop (ID _ _ _)"} = true | is_ID _ = false
              val prems = filter (Thm.prop_of #> is_ID) prems
              val eqs = map (fn thm => thm RS @{thm ID_unfold_vars}) prems
              val conv = Conv.rewrs_conv eqs
              val conv = fn ctxt => (Conv.top_sweep_conv (K conv) ctxt)
              val conv = fn ctxt => Conv.fun2_conv (Conv.arg_conv (conv ctxt))
              val conv = Refine_Util.HOL_concl_conv conv ctxt
            in CONVERSION conv 1 end
          ) ctxt THEN'
          resolve_tac ctxt @{thms id_rule} THEN'
          resolve_tac ctxt id_rules

      val ityping = id_rules
        |> map dest_id_rl
        |> filter (is_Const o #1)
        |> map (apfst (#1 o dest_Const))
        |> Symtab.make_list

      val has_type = Symtab.defined ityping

      fun mk_fallback name cT =
        case try (Sign.the_const_constraint thy) name of
          SOME T => try (Thm.instantiate'
                          [SOME (certT cT), SOME (certT T)] [SOME (cert (Const (name,cT)))])
                        @{thm fallback_rule}
        | NONE => NONE

      fun trace_fallback thm =
        Config.get ctxt cfg_id_trace_fallback
        andalso let
          open Pretty
          val p = block [str "ID_OP: Applying fallback rule: ", Thm.pretty_thm ctxt thm]
        in
          string_of p |> tracing;
          false
        end

      val fallback_tac = CONVERSION Thm.eta_conversion THEN' IF_EXGOAL (fn i => fn st =>
        case Logic.concl_of_goal (Thm.prop_of st) i of
          @{mpat "Trueprop (ID (mpaq_STRUCT (mpaq_Const ?name ?cT)) _ _)"} => (
            if not (has_type name) then
              case mk_fallback name cT of
                SOME thm => (trace_fallback thm; resolve_tac ctxt [thm] i st)
              | NONE => Seq.empty
            else Seq.empty
          )
        | _ => Seq.empty)

      val init_tac = CONVERSION (
        Refine_Util.HOL_concl_conv (fn ctxt => (id_a_conv (protect_conv ctxt)))
          ctxt
      )

      val step_tac = (FIRST' [
        assume_tac ctxt,
        eresolve_tac ctxt @{thms id_rule},
        resolve_from_net_tac ctxt def_rl_net,
        resolve_from_net_tac ctxt rl_net,
        id_pr_const_rename_tac,
        do_unprotect_tac ctxt,
        fallback_tac])

      val solve_tac = DF_SOLVE_FWD (Config.get ctxt cfg_id_debug) step_tac

    in
      case ss of
        Init => init_tac
      | Step => step_tac
      | Normal => init_tac THEN' solve_tac
      | Solve => solve_tac

    end

  end

\<close>

subsection \<open>Default Setup\<close>

subsubsection \<open>Numerals\<close>
lemma pat_numeral[def_pat_rules]: "numeral$x \<equiv> UNPROTECT (numeral$x)" by simp

lemma id_nat_const[id_rules]: "(PR_CONST (a::nat)) ::\<^sub>i TYPE(nat)" by simp
lemma id_int_const[id_rules]: "(PR_CONST (a::int)) ::\<^sub>i TYPE(int)" by simp

(*subsection \<open>Example\<close>
schematic_lemma
  "ID (\<lambda>a b. (b(1::int\<mapsto>2::nat) |`(-{3})) a, Map.empty, \<lambda>a. case a of None \<Rightarrow> Some a | Some _ \<Rightarrow> None) (?c) (?T::?'d itself)"
  (*"TERM (?c,?T)"*)
  using [[id_debug]]
  apply (tactic {* Id_Op.id_tac Id_Op.Normal @{context} 1  *})
  done
*)

end


theory spatial
imports Main
begin

declare [[ smt_timeout = 20 ]]

abbreviation reflexive
  where "reflexive \<equiv> \<lambda> R. \<forall> r. R r r"
abbreviation transitive
  where "transitive \<equiv> \<lambda> R. \<forall> x. \<forall> y. \<forall> z. R x y \<and> R y z \<longrightarrow> R x z"
abbreviation symmetric
  where "symmetric \<equiv> \<lambda> R. \<forall> x. \<forall> y. R x y \<longrightarrow> R y x"

(*The mutually recursive datatypes of processes and names*)
datatype P = Null             ("\<^bold>0")
           | Input n n P      ("_\<leftarrow>_._." 80)
           | Lift n P         ("_\<triangleleft>_\<triangleright>" 80)
           | Drop n           ("\<acute>_`" 80)
           | Par P P          (infixl "\<parallel>" 75)
     and n = Quote P          ("`_\<acute>")
termination
  apply size_change
  proof - qed

(*Syntactic sugar for output on a channel*)
abbreviation Output :: "n \<Rightarrow> n \<Rightarrow> P" ("_[[_]]")
  where "Output x y \<equiv> x\<triangleleft>\<acute>y`\<triangleright>"

value "a[[b]]"
value "zero \<leftarrow> zero.\<^bold>0"
value "\<^bold>0\<parallel>\<^bold>0"
value "\<acute>zero`"
value "zero\<triangleleft>\<^bold>0\<triangleright>"
value "(c\<leftarrow>d.(e))"

fun newName :: "nat \<Rightarrow> n"
  where "newName 0 = `\<^bold>0\<acute>"
       |"newName (Suc n) = `(Output (newName n) (newName n))\<acute>"

abbreviation zero :: n
  where "zero \<equiv> `\<^bold>0\<acute>"
abbreviation one :: n
  where "one \<equiv> newName 1"
abbreviation two :: n
  where "two \<equiv> newName 2"
abbreviation three :: n
  where "three \<equiv> newName 3"
abbreviation four :: n
  where "four \<equiv> newName 4"

abbreviation Zero :: P
  where "Zero \<equiv> Null"
abbreviation One :: P
  where "One \<equiv> \<acute>one`"
abbreviation Two :: P
  where "Two \<equiv> \<acute>two`"
abbreviation Three :: P
  where "Three \<equiv> \<acute>three`"
abbreviation Four :: P
  where "Four \<equiv> \<acute>four`"

value "zero \<leftarrow> zero.\<^bold>0."
value "\<^bold>0\<parallel>\<^bold>0"
value "\<acute>zero`"
value "zero\<triangleleft>\<^bold>0\<triangleright>"
value "(c\<leftarrow>d.(e).)"

fun getList :: "P \<Rightarrow> P list"
where
  "getList \<^bold>0 = []"
 |"getList (a\<parallel>b) = ((getList a)@(getList b))"
 |"getList a = [a]"

(*
fun la :: "P \<Rightarrow> P"
where
  "la (a\<parallel>(b\<parallel>c)) = ((la (a\<parallel>b))\<parallel>(la c))"
 |"la a = a"

value "la (Null \<parallel> (Null \<parallel> (Null \<parallel> (Null \<parallel> Null))))"
value "la ((Null \<parallel> Null) \<parallel> (Null \<parallel> (Null \<parallel> Null)))"
*)

function congru :: "P \<Rightarrow> P \<Rightarrow> bool" (infixl "=C" 42)
     and eq2 :: "P list \<Rightarrow> P list \<Rightarrow> P list \<Rightarrow> bool"
where
   "congru (a\<parallel>b) (c\<parallel>d)       = (eq2 (getList (a\<parallel>b)) (getList (c\<parallel>d)) [])"
  |"congru (x\<leftarrow>y.(a).) (xx\<leftarrow>yy.(b).) = ((a =C b) \<and> (x=xx) \<and> (y = yy))"
  |"congru (x\<triangleleft>a\<triangleright>) (y\<triangleleft>b\<triangleright>)     = ((a =C b) \<and> (x = y))"
  |"congru (\<acute>a`) (\<acute>b`)       = (a = b)"
  |"congru Null Null         = True"
  |"congru (a\<parallel>b) Null        = ((a =C Null)\<and>(b =C Null))"
  |"congru Null (a\<parallel>b)        = ((a =C Null)\<and>(b =C Null))"
  |"congru (a\<parallel>b) (c\<leftarrow>d.(e).)  = (eq2 (getList (a\<parallel>b)) ((c\<leftarrow>d.(e).)#[]) [])"
  |"congru (c\<leftarrow>d.(e).) (a\<parallel>b)  = (eq2 (getList (a\<parallel>b)) ((c\<leftarrow>d.(e).)#[]) [])"
  |"congru (a\<parallel>b) (c\<triangleleft>d\<triangleright>)      = (eq2 (getList (a\<parallel>b)) ((c\<triangleleft>d\<triangleright>)#[]) [])"
  |"congru (c\<triangleleft>d\<triangleright>) (a\<parallel>b)      = (eq2 (getList (a\<parallel>b)) ((c\<triangleleft>d\<triangleright>)#[]) [])"
  |"congru (a\<parallel>b) (\<acute>c`)       = (eq2 (getList (a\<parallel>b)) ((\<acute>c`)#[]) [])"
  |"congru (\<acute>c`) (a\<parallel>b)       = (eq2 (getList (a\<parallel>b)) ((\<acute>c`)#[]) [])"

  (* for f*cks sake, why cant I have some statement for remaining cases? *)
  |"congru (\<acute>a`) Null        = False"
  |"congru Null (\<acute>b`)        = False"
  |"congru (\<acute>a`) (_\<leftarrow>_._.)    = False"
  |"congru (_\<leftarrow>_._.) (\<acute>b`)    = False"
  |"congru (\<acute>a`) (_\<triangleleft>_\<triangleright>)      = False"
  |"congru (_\<triangleleft>_\<triangleright>) (\<acute>b`)      = False"
  |"congru (_\<triangleleft>_\<triangleright>) Null       = False"
  |"congru Null (_\<triangleleft>_\<triangleright>)       = False"
  |"congru (_\<triangleleft>_\<triangleright>) (_\<leftarrow>_._.)   = False"
  |"congru (_\<leftarrow>_._.) (_\<triangleleft>_\<triangleright>)   = False"
  |"congru (_\<leftarrow>_._.) Null     = False"
  |"congru Null (_\<leftarrow>_._.)     = False"

  |"eq2 [] [] [] = True"
  |"eq2 (x#xs) [] [] = False"
  |"eq2 [] [] (a#as) = False"
  |"eq2 (x#xs) [] (b#bs) = False"
  |"eq2 [] (b#bs) _ = False"
  |"eq2 (x#xs) (y#ys) zs = (if (x =C y) then (eq2 xs (zs@ys) []) else (eq2 (x#xs) ys (y#zs)))"
by (auto, pat_completeness)

(*
  in order to proof the termination I'd need to find a measure function
  the bad part is that i need to prove the termination of this counting function as well
 *)

abbreviation maxl where "maxl \<equiv> \<lambda>l. foldl (\<lambda>a.\<lambda>b. (max a b)) 0 l"

fun sdepth :: "P \<Rightarrow> nat" where
  "sdepth Null = 0"
  | "sdepth (x \<leftarrow> y . P.) = 1 + sdepth P"
  | "sdepth (x \<triangleleft> P \<triangleright>) = 1 + sdepth P"
  | "sdepth (P \<parallel> Q) = 1 + (max (sdepth P) (sdepth Q))"
  | "sdepth (\<acute>x`) = 0"

fun di::"nat \<Rightarrow> nat" where
  "di 0 = 0"
| "di (Suc(Suc v)) = (Suc (di v))"

abbreviation llength where "llength \<equiv> \<lambda>x::P list. (di ((length x)*(length x + 1)))"

function
  depth :: "P \<Rightarrow> nat"
where
  "depth \<^bold>0 = 0"
  | "depth (x \<leftarrow> y . P.) = 1 + depth P"
  | "depth (x \<triangleleft> P \<triangleright>) = 1 + depth P"
  | "depth (P \<parallel> Q) = 1 + (maxl (map depth (getList (P\<parallel>Q)))) + llength (getList (P\<parallel>Q))"
  | "depth (\<acute>x`) = 0"
apply auto
apply pat_completeness
done
termination
apply (relation "measure (\<lambda>x.(sdepth x))")
apply auto
(*proof -
  fix P Q x
  assume "x\<in> set (getList P)"
  show "sdepth x < Suc (max (sdepth P) (sdepth Q))"
  (* damn it, so close *)*)
sorry

termination congru
(* cannot come up with a good measuring function without *)
apply (relation "measure (
\<lambda>x. case x of
  Inl (a,b)
    \<Rightarrow> (Max({depth a, depth b}))
| Inr (a,b,c)
    \<Rightarrow> max (maxl (map depth (a))) (maxl (map depth (b@c))) )")
apply auto
sorry

value "(( \<^bold>0 \<parallel> (n\<^sub>1\<triangleleft>\<^bold>0 \<parallel> \<^bold>0\<triangleright>)) =C (n\<^sub>1\<triangleleft>\<^bold>0\<triangleright>))"

(*
theorem eqReflexive:
  assumes "reflexive congru"
  shows "reflexive eq"
proof
  fix r
  show "eq r r"
  proof (induction r)
    show "eq [] []" by simp
  next
    fix a r
    assume eqr: "eq r r"
    show "eq (a#r) (a#r)"
    proof auto
      assume "a =C a"
      show "eq2 r r []" using eqr by auto
    next
      assume na: "\<not> a =C a"
      show "eq2 (a#r) r [a]"
      proof -
       (* assume req: "reflexive eq"
        from this req have "reflexive congru" by (meson assms eq.elims(2) eq2.simps(4) eq2.simps(6))*)
        from assms have "a =C a" by simp
        from this na show "eq2 (a#r) r [a]" by simp (* i want to prove this through contradiction *)
      qed
    qed
  qed
qed

lemma "getList r = getList r" by simp
*)

(*
lemma listtocongru:
  assumes "eq2 (getList a) (getList a) []"
  shows "a =C a"
  apply (induction a)
  apply auto
  proof -
    fix a1 a2
    assume "a1 =C a1" and "a2 =C a2"
    show "eq2 (getList a1 @ getList a2) (getList a1 @ getList a2) []"
    apply (induction a1)
    apply auto
sorry
*)

(*
lemma congrutolist:
  assumes "a =C a"
  shows "eq2 (getList a) (getList a) []"
  apply (induction a)
  apply auto
  apply (simp add: listtocongru)
  apply (simp add: listtocongru)
  proof -
    fix a1 a2
    assume h1: "eq2 (getList a1) (getList a1) []"
    assume h2: "eq2 (getList a2) (getList a2) []"
    show "eq2 (getList a1 @ getList a2) (getList a1 @ getList a2) []"
    apply (induction a1)
    apply auto
    apply (simp add: h1 h2)
    apply (simp add: h1 h2)
    proof (rule ccontr)
      fix x1 x2a a1
      assume "eq2 (getList a1 @ getList a2) (getList a1 @ getList a2) []"
      assume "\<not> a1 =C a1"
      from assms have "a1 =C a1"

sorry

lemma partolist:
  assumes "a =C a" and "b =C b"
  shows "eq2 ((getList a)@(getList b)) ((getList a)@(getList b)) []"
sorry
*)
(*
  proof (auto, induction r1)
      show "eq2 (getList \<^bold>0 @ getList r2) (getList \<^bold>0 @ getList r2) []"
      apply auto
      apply (simp add: congrutolist b)
      done
    next
      fix x1 x2a::n
      fix P2:: "n \<Rightarrow> bool"
      assume "P2 x1"
      assume "P2 x2a"
      assume "eq2 (getList r1 @ getList r2) (getList r1 @ getList r2) []"
      show "eq2 (getList (x1\<leftarrow>x2a.(r1)) @ getList r2) (getList (x1\<leftarrow>x2a.(r1)) @ getList r2) []"
      proof -
*)

(*
theorem asdadsds:
  assumes "\<forall> a. a =C a"
  shows "eq (getList a) (getList a)"
  apply auto
  apply (induction a)
  apply auto
  apply (simp add: listtocongru)
  apply (simp add: listtocongru)
  proof -
    fix a1 a2
    assume h1: "eq2 (getList a1) (getList a1) []"
    assume h2: "eq2 (getList a2) (getList a2) []"
    show "eq2 (getList a1 @ getList a2) (getList a1 @ getList a2) []"
    apply (induction a1)
    apply auto
    apply (simp add: h1 h2)
    apply (simp add: h1 h2)
    proof (rule ccontr)
      fix x1 x2a a1
      assume "eq2 (getList a1 @ getList a2) (getList a1 @ getList a2) []"
      assume "\<not> a1 =C a1"
      from assms have "a1 =C a1"
    sledgehammer
*)
(*
theorem congruReflexive:
  shows "reflexive congru"
  and "\<forall>b::P. eq2 (getList b) (getList b) []"
proof auto
  fix r
  fix b::P
  show "r =C r"  "eq2 (getList r) (getList r) []"
  apply (induct r)
  apply auto
  proof -
    show "Null =C Null" by simp
  next
    fix x1 x2a r2
    assume "r2 =C r2"
    show "(Input x1 x2a r2 =C Input x1 x2a r2)" by (simp add: \<open>r2 =C r2\<close>)
  next
    fix x1 r2
    assume a:"r2 =C r2"
    show "(x1\<triangleleft>r2\<triangleright>) =C (x1\<triangleleft>r2\<triangleright>)" by (simp add: a)
  next
    fix x
    show "\<acute>x` =C \<acute>x`" by simp
  next
    fix r1 r2
    assume a: "r1 =C r1" and b: "r2 =C r2"
    show "(r1\<parallel>r2) =C (r1\<parallel>r2)"
    apply auto
    apply (simp add: a b partolist)
    done
  next
    (* I have no idea what I have to show here!? *)
    fix r2
    fix P2::"n \<Rightarrow> bool"
    assume "r2 =C r2"
    show "P2 `r2\<acute>"
    sorry
  next
  qed
qed
*)

theorem congruReflexive:
  shows "reflexive congru"
sorry

theorem congruTransitive:
  shows "transitive congru"
sorry

theorem congruSymmetric:
  shows "symmetric congru"
sorry

theorem eqReflexive:
  shows "\<forall> a b. (eq2 a a [])"
sorry

theorem eqSymmetric:
  shows "\<forall> a b. (eq2 a b [] \<longrightarrow> eq2 b a [])"
sorry

theorem eqTransitive:
  shows "\<forall> a b c. (((eq2 a b []) \<and> (eq2 b c [])) \<longrightarrow> (eq2 a c []))"
sorry

theorem parAssoc:
  shows "((a\<parallel>b)\<parallel>c) =C (a\<parallel>(b\<parallel>c))"
sorry

theorem parKommutative:
  shows "a\<parallel>b =C b\<parallel>a"
sorry

theorem zeroLeft:
  shows "(Null \<parallel> a) =C a"
sorry

theorem zeroRight:
  shows "(a \<parallel> Null) =C a"
sorry

theorem someshit:
shows "(((zero\<leftarrow>zero.\<^bold>0.) \<parallel> \<^bold>0) \<parallel> (zero\<leftarrow>zero.\<^bold>0.)) =C (((zero\<leftarrow>zero.\<^bold>0.) \<parallel> (zero\<leftarrow>zero.\<^bold>0.)) \<parallel> \<^bold>0)"
by simp

value "getList ((a \<parallel> b) \<parallel> c)"
value "(((zero\<leftarrow>zero.\<^bold>0.) \<parallel> \<^bold>0) \<parallel> (zero\<leftarrow>zero.\<^bold>0.)) =C (((zero\<leftarrow>zero.\<^bold>0.) \<parallel> (zero\<leftarrow>zero.\<^bold>0.)) \<parallel> \<^bold>0)"

(*Name equivalence*)
fun name_equivalence :: "n \<Rightarrow> n \<Rightarrow> bool" (infix "=N" 52)
  where
    "zero =N `Input x y P\<acute> = False"
  | "zero =N `Lift _ _\<acute> = False"
  | "zero =N `Par P Q\<acute> = (Null =C (P\<parallel>Q))"
  | "zero =N `\<acute>a`\<acute> = (zero =N a)"
  | "zero =N zero = True"

  | "((`(Input x y P)\<acute>) =N `Input p q Q\<acute>) = ((Input x y P)  =C (Input p q Q))"
  | "((`(Input x y P)\<acute>) =N `Lift _ _\<acute>) = False"
  | "((`(Input x y P)\<acute>) =N `Par _ _\<acute>) = False"
  | "((`(Input x y P)\<acute>) =N zero) = False"
  | "((`(Input x y P)\<acute>) =N `\<acute>a`\<acute>) = (`(Input x y P)\<acute> =N a)"

  | "((`Lift x P\<acute>) =N `Lift y Q\<acute>) = (Lift x P =C Lift y Q)"
  | "((`Lift x P\<acute>) =N `Input _ _ _\<acute>) = False"
  | "((`Lift x P\<acute>) =N `Par _ _\<acute>) = False"
  | "((`Lift x P\<acute>) =N zero) = False"
  | "((`Lift x P\<acute>) =N `\<acute>a`\<acute>) = (`(Lift x P)\<acute> =N a)"

  | "((`P\<parallel>Q\<acute>) =N (`A\<parallel>B\<acute>)) = ((P\<parallel>Q) =C (A\<parallel>B))"
  | "((`P\<parallel>Q\<acute>) =N (`Lift _ _\<acute>)) = False"
  | "((`P\<parallel>Q\<acute>) =N (`Input _ _ _\<acute>)) = False"
  | "((`P\<parallel>Q\<acute>) =N zero) = ((P\<parallel>Q) =C Null)"
  | "((`P\<parallel>Q\<acute>) =N (`\<acute>a`\<acute>)) = (`(P\<parallel>Q)\<acute> =N a)"

  | "`\<acute>a`\<acute> =N `Input x y P\<acute> = (a =N `Input x y P\<acute>)"
  | "`\<acute>a`\<acute> =N `Lift x P\<acute> = (a =N `Lift x P\<acute>)"
  | "`\<acute>a`\<acute> =N `Par P Q\<acute> = (a =N `Par P Q\<acute>)"
  | "`\<acute>a`\<acute> =N `\<acute>b`\<acute> = (a =N b)"
  | "`\<acute>a`\<acute> =N zero = (a =N zero)"

value "`\<acute>zero`\<acute> =N zero"
value "`\<acute>`\<acute>zero`\<acute>`\<acute> =N zero"
value "newName 3 =N three"
value "newName 3 =N zero"
value "three =N newName 3"
value "`((One\<parallel>Two)\<parallel>(Three\<parallel>Four))\<parallel>Null\<acute> =N `((One\<parallel>Three)\<parallel>(Two\<parallel>Four))\<acute>"

theorem name_equivalence_reflexive:
  shows "reflexive name_equivalence"
apply auto
proof -
  fix r
  show "r =N r"
  using congruReflexive by (induction r rule: name_equivalence.induct, auto)
qed

theorem name_equivalence_symmetric:
  assumes "x =N y"
  shows "y =N x"
using assms congruSymmetric eqSymmetric by (induct x rule: name_equivalence.induct, auto)

theorem name_equivalence_transitive:
  assumes "a =N b" and "b =N c"
  shows "a =N c"
(* I dont know how to make an induction argument here which runs over all three variables *)
(*
using assms apply (induct a c rule: name_equivalence.induct)
apply auto
apply (simp add: assms congruTransitive eqTransitive)
*)
sorry

value "`p \<parallel> (\<^bold>0 \<parallel> q)\<acute> =N `q \<parallel> p\<acute>"

theorem testNameEQ1:
  shows "`p \<parallel> (\<^bold>0 \<parallel> q)\<acute> =N `q \<parallel> p\<acute>"
using parKommutative by auto

(*Gives the set of free names in a process*)
fun free :: "P \<Rightarrow> n set" where
  "free \<^bold>0 = {}"
  | "free (x \<leftarrow> y . P.) = {x} \<union> (free(P) - {y})"
  | "free (x \<triangleleft> P \<triangleright>) = {x} \<union> free P"
  | "free (P \<parallel> Q) = free P \<union> free Q"
  | "free (\<acute>x`) = {x}"

(*Gives the set of bound names in a process*)
fun bound :: "P \<Rightarrow> n set" where
  "bound \<^bold>0 = {}"
  | "bound (x \<leftarrow> y . P.) = {y} \<union> bound(P)"
  | "bound (x \<triangleleft> P \<triangleright>) = bound P"
  | "bound (P \<parallel> Q) = bound P \<union> bound Q"
  | "bound (\<acute>x`) = {}"

(*Names occurring in a process*)
fun names :: "P \<Rightarrow> n set"
  where "names P = free(P) \<union> bound(P)"

(*quote depth*)
function n_depth :: "n \<Rightarrow> nat" ("#" 60)
  and P_depth :: "P \<Rightarrow> nat" ("#" 60)
  where
  "n_depth `P\<acute> = 1 + (P_depth P)"
  | "P_depth P = (if (names P \<noteq> {}) then Max({ ( n_depth x ) | x. x \<in> (names P)}) else 0)"
  apply pat_completeness
  apply blast
  apply simp
  by blast
termination
  sorry  (*Even without termination proof, we can use the n_depth/P_depth function*)

value "P_depth (\<acute>zero`)"

(*substitution*)
(*Takes a process, specifies the names to be substituted and returns a process*)

abbreviation sn :: "n \<Rightarrow> n \<Rightarrow> n \<Rightarrow> n" where
  "sn x q p \<equiv> (if (x =N p) then q else x)"

value "(sn zero zero zero)"
value "newName (Max ({(n_depth zero), 0::nat}))"

(*with z = (newName (P_depth(R)))*)
abbreviation genz
  where "genz \<equiv> \<lambda> q::n.  \<lambda> p::n. \<lambda> R::P. newName (Max({(n_depth(q)), (P_depth(R)), (n_depth(p)) }))"

(* syntactic substitution *)
function s :: "P \<Rightarrow> n \<Rightarrow> n \<Rightarrow> P" ("(_) {_\<setminus>_}" 52)
where "(\<^bold>0){_\<setminus>_}             = \<^bold>0"
   | "(R \<parallel> S){q\<setminus>p}          = ((R){q\<setminus>p}) \<parallel> ((S){q\<setminus>p})"
   | "( x \<leftarrow> y . R.){q\<setminus>p}    = ((sn x q p) \<leftarrow> (genz q p R)  . ((R {(genz q p R)\<setminus>y}){q\<setminus>p}).)"
   | "(x \<triangleleft> R \<triangleright>) {q\<setminus>p}       = ((sn x q p) \<triangleleft>R{q\<setminus>p}\<triangleright>)"
   | "(\<acute>x`){q\<setminus>p}            = (if (x =N p) then \<acute>q` else \<acute>x`)"
apply pat_completeness by auto
termination
apply (relation "measure (\<lambda>(p,x,y). (P_depth p))", auto)

(* see http://isabelle.in.tum.de/doc/functions.pdf *)
  sorry (*induction measure on n_depth*)

(* semantic substitution *)
function ss :: "P \<Rightarrow> n \<Rightarrow> n \<Rightarrow> P" ("(_) s{_\<setminus>_}" 52)
where "(\<^bold>0)s{_\<setminus>_}             = \<^bold>0"
   | "(R \<parallel> S) s{q\<setminus>p}          = ((R) s{q\<setminus>p}) \<parallel> ((S) s{q\<setminus>p})"
   | "( x \<leftarrow> y . R.) s{q\<setminus>p}    = ((sn x q p) \<leftarrow> (genz q p R)  . ((R {(genz q p R)\<setminus>y}) s{q\<setminus>p}).)"
   | "(x \<triangleleft> R \<triangleright>) s{q\<setminus>p}       = ((sn x q p) \<triangleleft>R s{q\<setminus>p}\<triangleright>)"
   | "(\<acute>x`) s{`q\<acute>\<setminus>p}            = (if (x =N p) then q else \<acute>x`)" (* semantic substitution *)
apply pat_completeness by auto
termination
apply (relation "measure (\<lambda>(p,x,y). (P_depth p))", auto)

(* see http://isabelle.in.tum.de/doc/functions.pdf *)
  sorry (*induction measure on n_depth*)

value "\<^bold>0{zero\<setminus>zero}"
value "(zero \<leftarrow> zero . Zero){two \<setminus> zero}"
value "(\<^bold>0 \<parallel> (\<acute>zero`)) { (newName 2) \<setminus> zero }"

(*
 2.6 Dynamic quote: an example
*)

value "zero\<triangleleft>zero[[three]]\<triangleright>{two\<setminus>three}"
value "(zero\<triangleleft>zero[[three]]\<triangleright>{two\<setminus>three}) = (zero\<triangleleft>zero[[two]]\<triangleright>)"

value "zero[[`zero[[three]]\<acute>]]{two\<setminus>three}"
value "zero[[`zero[[three]]\<acute>]]{two\<setminus>three} = (zero[[`zero[[three]]\<acute>]])"

(* Operational Semantics *)

fun toPar:: "P list \<Rightarrow> P" where
  "toPar []   = Null"
 |"toPar (x#[]) = x"
 |"toPar (x#y#xs) = (x \<parallel> (toPar (y#xs)))"

fun syncable:: "P \<Rightarrow> P \<Rightarrow> bool" where
  "syncable (Lift x Q) (Input y z P)    = (x =N z)"
 |"syncable (Input y z P) (Lift x Q)    = (x =N z)"
 |"syncable (Lift y P) (Lift x Q)       = False"
 |"syncable (Input y z P) (Input a b Q) = False"
 |"syncable _ (vc \<parallel> vd)                 = False"
 |"syncable   (vc \<parallel> vd) _               = False"
 |"syncable   (\<acute>v`) _                   = False"
 |"syncable _ (\<acute>v`)                     = False"
 |"syncable   Null _                    = False"
 |"syncable _ Null                      = False"

fun sync:: "P \<Rightarrow> P \<Rightarrow> P" where
  "sync (Lift x Q) (Input y z P) = (P s{`Q\<acute>\<setminus>y})"
 |"sync (Input y z P) (Lift x Q) = (P s{`Q\<acute>\<setminus>y})"

function fineRun:: "P list \<Rightarrow> P list \<Rightarrow> P list \<Rightarrow> P list" where
   "fineRun []     []  []         = []"
  |"fineRun (x#[]) []  []         = (x#[])"
  |"fineRun (x#y#xs) []  zs       = (fineRun (y#xs) (x#[]) zs)"
  |"fineRun [] (y#ys) (z#[])      = (z#y#ys)"
  |"fineRun [] (y#ys) (z#zs)      = (fineRun zs (z#y#ys) [])"
  |"fineRun (x#xs) (y#ys) zs      = (if (syncable x y) then ((sync x y)#xs@ys@zs) else (fineRun (xs) (y#ys) (x#zs)))"
apply auto
sorry
termination
sorry

fun step:: "P \<Rightarrow> P" where
  "step P = toPar( fineRun (getList P) [] [])"

abbreviation replication where "replication \<equiv> (\<lambda>y.\<lambda>(P,x).(x\<triangleleft>((y\<leftarrow>x.(x[[y]]\<parallel>\<acute>y`).)\<parallel>P)\<triangleright>\<parallel>(y \<leftarrow> x.(x[[y]]\<parallel>\<acute>y`).)))(`zero[[zero]]\<acute>)"
abbreviation xx where "xx \<equiv> zero"
abbreviation yy where "yy \<equiv> `xx[[xx]]\<acute>"

value "(replication (two, zero))"
value "step (replication (two, zero))"
value "step(step (replication (two, zero)))"
value "step(step(step (replication (two, zero))))"
value "step(step(step(step (replication (two, zero)))))"

lemma False
sledgehammer
(*theory is consistent, yay*)
oops

section\<open>Alpha equivalence\<close>
text\<open>Alpha equivalence equates processes that only differ by their bound variables. In our calculus,
the bound variables are the names to which we bound input values. As an example we would want the
following terms to be alpha-equal: \<close>

(*
theorem alphaEq:
shows "zero \<leftarrow> zero . Zero \<equiv>\<alpha> one \<leftarrow> zero . Zero"
sorry
*)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory ArraysMemInstance
imports Arrays CompoundCTypes
begin

primrec
  array_tag_n :: "nat \<Rightarrow> ('a::c_type,'b::finite) array typ_info"
where
  atn_base:
  "array_tag_n 0 = ((empty_typ_info (typ_name (typ_uinfo_t TYPE('a)) @ ''_array_'' @
      nat_to_bin_string (CARD('b::finite))))::('a::c_type,'b) array
          typ_info)"
| atn_rec:
  "array_tag_n (Suc n) = ((ti_typ_combine TYPE('a::c_type)
      (\<lambda>x. index x n) (\<lambda>x f. update f n x) (replicate n CHR ''1'')
          (array_tag_n n))::('a,'b::finite) array typ_info)"

definition
  array_tag :: "('a::c_type,'b::finite) array itself \<Rightarrow> ('a,'b) array typ_info" where
  "array_tag t \<equiv> array_tag_n (CARD('b))"

instantiation array :: (c_type,finite) c_type
begin
instance ..
end

overloading typ_info_array \<equiv> typ_info_t begin
definition
  typ_info_array: "typ_info_array (w::('a::c_type,'b::finite) array itself) \<equiv> array_tag w"
end

lemma field_names_array_tag_length [rule_format]:
  "x \<in> set (field_names_list (array_tag_n n)) \<longrightarrow> length x < n"
apply(induct_tac n)
 apply simp
apply clarsimp
done

lemma replicate_mem_field_names_array_tag [simp]:
  "replicate n x \<notin> set (field_names_list (array_tag_n n))"
apply clarsimp
apply(drule field_names_array_tag_length)
apply simp
done

lemma aggregate_array_tag [simp]:
  "aggregate (array_tag_n n)"
apply(case_tac n)
 apply simp+
done

lemma wf_desc_array_tag [simp]:
  "wf_desc ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info)"
apply(induct_tac n)
 apply simp+
apply(erule wf_desc_ti_typ_combine)
apply simp
done

lemma wf_size_desc_array_tag [simp, rule_format]:
  "0 < n \<longrightarrow> wf_size_desc ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info)"
apply(induct n)
 apply simp+
apply(case_tac "n=0")
 apply simp
apply(rule wf_size_desc_ti_typ_combine)
apply simp
done

lemma g_ind_array_tag_udpate [simp]:
  "n \<le> m \<longrightarrow> n \<le> CARD('b) \<longrightarrow>
      g_ind (lf_set ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info) []) (\<lambda>x f. update f m x)"
apply(induct_tac n)
 apply clarsimp+
apply(erule g_ind_ti_typ_combine)
 apply clarsimp+
done

lemma fc_array_tag_udpate [simp]:
  "n \<le> m \<longrightarrow> n \<le> CARD('b) \<longrightarrow>
      fu_commutes (update_ti_t ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info)) (\<lambda>x f. update f m x)"
apply(induct_tac n)
 apply clarsimp+
apply(erule fc_ti_typ_combine)
  apply(clarsimp simp: fg_cons_def)
 apply clarsimp+
done

lemma f_ind_array_tag_udpate [simp, rule_format]:
  "n \<le> m \<longrightarrow> m < CARD('b) \<longrightarrow>
      f_ind (\<lambda>x. index x m) (lf_fd ` lf_set ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info) [])"
apply(induct_tac n)
 apply clarsimp+
apply(erule f_ind_ti_typ_combine)
 apply clarsimp
apply simp
done

lemma fa_fu_g_array_tag_udpate [simp, rule_format]:
  "n \<le> m \<longrightarrow> m < CARD('b) \<longrightarrow>
      fa_ind (lf_fd ` lf_set ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info) []) (\<lambda>x f. update f m x)"
apply(induct_tac n)
 apply clarsimp+
apply(erule fa_ind_ti_typ_combine)
apply clarsimp+
done

lemma wf_fdp_array_tag [simp, rule_format]:
  "n \<le> CARD('b) \<longrightarrow>
      wf_lf (lf_set ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info) [])"
apply(induct_tac n)
 apply clarsimp+
apply(erule wf_lf_ti_typ_combine)
      apply simp+
done

lemma upd_local_update [simp]:
  "upd_local (\<lambda>x f. update f n x)"
apply(auto simp: upd_local_def)
apply(subst cart_eq)
apply clarsimp
apply(subst (asm) cart_eq)
apply(drule_tac x=i in spec)
apply clarsimp
apply(case_tac "i=n")
 apply simp+
done

lemma fu_eq_mask_array_tag [simp, rule_format]:
  "n \<le> CARD('b) \<longrightarrow> (\<forall>m. (\<forall>k v. k < CARD('b) \<longrightarrow>
      index ((m v)::('a,'b) array) k = (if n \<le> k then
          index (undefined::('a::mem_type,'b::finite) array) k
          else index v k)) \<longrightarrow> fu_eq_mask (array_tag_n n) m)"
apply(induct n)
 apply clarsimp
 apply(rule fu_eq_mask_empty_typ_info)
 apply clarsimp
 apply(subst cart_eq)
 apply simp
apply clarsimp
apply(rule fu_eq_mask_ti_typ_combine)
     apply(drule_tac x="\<lambda>v. update (m v) n (index undefined n)" in spec)
     apply(erule impE)
      apply clarsimp
      apply(drule_tac x=k in spec)
      apply clarsimp
      apply(case_tac "k=n")
       apply simp
      apply clarsimp
     apply(subgoal_tac "\<forall>v bs. m (update v n bs) = update (m v) n bs")
      apply clarsimp+
     apply(subst cart_eq)
     apply clarsimp
     apply(drule_tac x=i in spec)
     apply clarsimp
     apply(case_tac "i=n")
      apply clarsimp+
     apply(frule_tac x="update v n bs" in spec)
     apply(drule_tac x="v" in spec)
     apply clarsimp
     apply(case_tac "Suc n \<le> i")
      apply clarsimp+
    apply(clarsimp simp: fg_cons_def)
   apply(clarsimp)
  apply simp
done

lemma size_td_array_tag [simp]:
  "size_td (((array_tag_n n)::('a,'b::finite) array typ_info)) =
      n * size_of TYPE('a::c_type)"
apply(induct_tac n)
 apply simp
apply simp
apply(simp add: size_td_lt_ti_typ_combine size_of_def)
done

lemma align_td_array_tag [rule_format]:
  "0 < n \<longrightarrow> align_td ((array_tag_n n)::('a,'b::finite) array typ_info) = (align_td (typ_info_t (TYPE('a::c_type))))"
apply(induct_tac n)
 apply simp
apply(clarsimp simp: ti_typ_combine_def Let_def)
apply(case_tac "n = 0")
 apply(clarsimp simp: align_of_def max_def)+
done

lemma align_field_array [simp]:
  "align_field ((array_tag_n n)::('a::mem_type,'b::finite) array typ_info)"
apply(induct_tac n)
 apply simp
apply clarsimp
apply(erule align_field_ti_typ_combine)
apply simp
apply(rule dvd_mult)
apply(subgoal_tac "align_of TYPE('a) dvd size_of TYPE('a)")
 apply(simp add: align_of_def)
apply(rule align_size_of)
done

instantiation array :: (mem_type,finite) mem_type_sans_size
begin

instance
apply intro_classes
     apply(simp_all add: typ_info_array array_tag_def size_of_def
                         norm_bytes_def)

 apply clarsimp
 apply(rule fu_eq_mask)
  apply(simp add: size_of_def)
 apply(rule fu_eq_mask_array_tag)
    apply simp+

apply(clarsimp simp: align_of_def typ_info_array array_tag_def)
apply(subst align_td_array_tag)
 apply simp
apply(rule dvd_trans)
 apply(subgoal_tac "align_of TYPE('a) dvd size_of TYPE('a)")
  apply(simp only: align_of_def)
 apply(rule align_size_of)
apply(simp add: size_of_def)
done

end

declare atn_base [simp del]
declare atn_rec [simp del]

lemma size_of_array [simp]:
  "size_of TYPE(('a,'b::finite) array) = CARD('b) * size_of TYPE('a::c_type)"
  by (simp add: size_of_def typ_info_array array_tag_def)

lemma size_td_array:
  "size_td (typ_info_t TYPE(('a,'b::finite) array)) = CARD('b) * size_of TYPE('a::c_type)"
  by (simp add: size_of_def typ_info_array array_tag_def)

lemma align_td_array:
  "2^align_td (typ_info_t TYPE(('a,'b::finite) array)) = align_of TYPE('a::c_type)"
apply(simp add: align_of_def typ_info_array array_tag_def)
apply(subst align_td_array_tag)
 apply simp+
done

(* Showing arrays are in mem_type requires maximum sizes for objects,
   and maximum counts for elements *)
class oneMB_size = mem_type +
  assumes oneMB_size_ax: "size_of TYPE('a::c_type) < 2 ^ 19"

class fourthousand_count = finite +
  assumes fourthousand_count_ax: "CARD ('a) <= 2 ^ 13"

instantiation array :: (oneMB_size, fourthousand_count) mem_type
begin

instance
apply intro_classes
apply simp
apply (subgoal_tac "addr_card = 2 ^ (addr_bitsize - 19) * 2 ^ 19")
  apply (erule ssubst)
  apply (rule less_le_trans[where y = "card (UNIV::'b set) * 2 ^ 19"])
    apply (rule mult_less_mono2)
      apply (rule oneMB_size_ax)
    apply simp
  apply (rule mult_le_mono1)
    apply (rule le_trans[where j = "2 ^ 13"])
      apply (rule fourthousand_count_ax)
    apply simp
  apply simp
apply (simp add: addr_card)
done

end

class twoToSix_size = oneMB_size +
  assumes twoToSix_size_ax: "size_of TYPE('a::c_type) < 2 ^ 6"

instantiation array :: (twoToSix_size, fourthousand_count) oneMB_size
begin

instance
apply intro_classes
apply simp
  apply (rule order_less_le_trans)
   apply (rule mult_le_less_imp_less)
    apply (rule fourthousand_count_ax)
   apply (rule twoToSix_size_ax)
  apply simp
   apply simp
  apply simp
  done

end

instantiation word :: (len8) oneMB_size
begin
instance
apply intro_classes
apply(simp add: size_of_def)
apply(subgoal_tac "len_of TYPE('a) \<le> 128")
 apply simp
apply(rule len8_width)
done
end

instantiation word :: (len8) twoToSix_size
begin
instance
apply intro_classes
apply(simp add: size_of_def)
apply(subgoal_tac "len_of TYPE('a) \<le> 128")
 apply simp
apply(rule len8_width)
done
end

instantiation ptr :: (c_type) oneMB_size
begin
instance
apply intro_classes
apply (simp add: size_of_def)
done
end

instantiation ptr :: (c_type) twoToSix_size
begin
instance
apply intro_classes
apply (simp add: size_of_def)
done
end

class lt12 = finite +
  assumes lt12_ax: "CARD ('a) < 2 ^ 12"
class lt11 = lt12 +
  assumes lt11_ax: "CARD ('a) < 2 ^ 11"
class lt10 = lt11 +
  assumes lt10_ax: "CARD ('a) < 2 ^ 10"
class lt9 = lt10 +
  assumes lt9_ax: "CARD ('a) < 2 ^ 9"
class lt8 = lt9 +
  assumes lt8_ax: "CARD ('a) < 2 ^ 8"
class lt7 = lt8 +
  assumes lt7_ax: "CARD ('a) < 2 ^ 7"
class lt6 = lt7 +
  assumes lt6_ax: "CARD ('a) < 2 ^ 6"
class lt5 = lt6 +
  assumes lt5_ax: "CARD ('a) < 2 ^ 5"
class lt4 = lt5 +
  assumes lt4_ax: "CARD ('a) < 2 ^ 4"
class lt3 = lt4 +
  assumes lt3_ax: "CARD ('a) < 2 ^ 3"
class lt2 = lt3 +
  assumes lt2_ax: "CARD ('a) < 2 ^ 2"
class lt1 = lt2 +
  assumes lt1_ax: "CARD ('a) < 2 ^ 1"

instantiation bit0 :: (lt12) fourthousand_count
begin
instance
  by (intro_classes, insert lt12_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt12) fourthousand_count
begin
instance
  by (intro_classes, insert lt12_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt11) lt12
begin
instance
  by (intro_classes, insert lt11_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt11) lt12
begin
instance
  by (intro_classes, insert lt11_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt10) lt11
begin
instance
  by (intro_classes, insert lt10_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt10) lt11
begin
instance
  by (intro_classes, insert lt10_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt9) lt10
begin
instance
  by (intro_classes, insert lt9_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt9) lt10
begin
instance
  by (intro_classes, insert lt9_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt8) lt9
begin
instance
  by (intro_classes, insert lt8_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt8) lt9
begin
instance
  by (intro_classes, insert lt8_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt7) lt8
begin
instance
  by (intro_classes, insert lt7_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt7) lt8
begin
instance
  by (intro_classes, insert lt7_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt6) lt7
begin
instance
  by (intro_classes, insert lt6_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt6) lt7
begin
instance
  by (intro_classes, insert lt6_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt5) lt6
begin
instance
  by (intro_classes, insert lt5_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt5) lt6
begin
instance
  by (intro_classes, insert lt5_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt4) lt5
begin
instance
  by (intro_classes, insert lt4_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt4) lt5
begin
instance
  by (intro_classes, insert lt4_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt3) lt4
begin
instance
  by (intro_classes, insert lt3_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt3) lt4
begin
instance
  by (intro_classes, insert lt3_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt2) lt3
begin
instance
  by (intro_classes, insert lt2_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt2) lt3
begin
instance
  by (intro_classes, insert lt2_ax[where 'a = 'a], simp)
end

instantiation bit0 :: (lt1) lt2
begin
instance
  by (intro_classes, insert lt1_ax[where 'a = 'a], simp)
end

instantiation bit1 :: (lt1) lt2
begin
instance
  by (intro_classes, insert lt1_ax[where 'a = 'a], simp)
end

instantiation num1 :: lt1
begin
instance
  by (intro_classes, simp_all)
end

(* don't understand why this also seems to be necessary *)
instantiation num1 :: fourthousand_count
begin
instance
  by (intro_classes, simp)
end

(* introduce hackish handling of 8192 type by making a copy of the type
   under a constructor, and then manually showing that it is an instance of
   fourthousand_count *)
datatype ty8192 = ty8192 "8192"

lemma univ8192: "(UNIV::ty8192 set) = image ty8192 (UNIV::8192 set)"
apply (simp add: set_eq_iff image_iff)
apply (rule_tac allI)
apply (rule_tac ty8192.induct)
apply simp
done

instance "ty8192" :: finite
apply intro_classes
apply (simp add: univ8192)
done

lemma card8192[simp]: "CARD(ty8192) = CARD(8192)"
apply (simp add: univ8192 card_image inj_on_def)
done

instance "ty8192" :: fourthousand_count
by intro_classes simp

end