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

(*
 * This file introduces an experimental "distinct" command that takes
 * a list of 'n' terms, and generates O(n^2) lemmas for you to prove
 * that the 'n' terms are all distinct. These proofs can typically be
 * carried out by an "apply auto" command, giving you O(n^2)
 * distinctness theorems relatively easily. These new theorems can then
 * be thrown into a simpset to avoid having to constantly unfold
 * definitions merely to prove distinctness.
 *
 * This may significantly simplify certain proofs where inequality of
 * defined terms is frequently relied upon.
 *
 * The "distinct" command is not really scalable, due to its O(n^2)
 * proof terms generated. If we wanted to use this in a larger example,
 * we would probably want a "ordered" command, which forces you to show
 * that 'n' terms have some ordering, and then automatically derive the
 * O(n^2) possible proof terms on-the-fly in a simproc (possibly using
 * Isabelle's existing "order_tac").
 *)
theory Distinct_Cmd
imports Main
  keywords "distinct" :: thy_goal
begin

ML \<open>
local

(*
 * Process a parsed binding, converting it from raw tokens (which
 * can't be passed into Local_Theory.note) into its semantic meaning
 * (which can).
 *)
fun process_binding lthy binding =
  apsnd (map (Attrib.check_src lthy)) binding

(* Parse the parameters to "distinct". *)
val distinct_parser =
  (Scan.optional (Parse_Spec.opt_thm_name ":") Binding.empty_atts
         -- Scan.repeat1 Parse.term)

(* Generate a prop of the form "a ~= b". *)
fun mk_inequality_pair a b =
  HOLogic.mk_eq (a, b)
  |> HOLogic.mk_not
  |> HOLogic.mk_Trueprop

(* Generate O(n^2) distinctness goals. *)
fun gen_distinct_goals terms =
  map_product
    (fn a => fn b =>
        if a = b then NONE
        else SOME (mk_inequality_pair a b))
    terms terms
  |> map_filter I
  |> map (fn t => (t, []))

(* Given a list of terms, coerce them all into the same type. *)
fun coerce_terms_to_same_type lthy terms =
  HOLogic.mk_list dummyT terms
  |> Syntax.check_term lthy
  |> HOLogic.dest_list

(* We save the theorems to the context afterwards. *)
fun after_qed thm_name thms lthy =
  Local_Theory.note (thm_name, (flat thms)) lthy |> snd

in

val _ =
   Outer_Syntax.local_theory_to_proof @{command_keyword "distinct"}
      "prove distinctness of a list of terms"
      (distinct_parser
        >> (fn (thm_name, terms) => fn lthy =>
              Proof.theorem NONE (after_qed (process_binding lthy thm_name)) [
                  map (Syntax.parse_term lthy) terms
                  |> coerce_terms_to_same_type lthy
                  |> gen_distinct_goals
              ] lthy
            ))

end
\<close>

(* Test. *)
context
  fixes A :: nat
  fixes B :: nat
  fixes C :: nat
  assumes x: "A = 1 \<and> B = 2 \<and> C = 3"
begin

distinct A B C "5" "6" "2 + 11"
  by (auto simp: x)

end

end


(*  Author:  Tobias Nipkow  *)

header "Comparing Enumeration and Archive"

theory ArchComp
imports ArchCompProps "~~/src/HOL/Library/Code_Target_Numeral"
begin

method_setup cond_eval = {*
  let
    fun eval_tac ctxt =
      let val conv = Code_Runtime.dynamic_holds_conv ctxt
      in CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1 conv)) ctxt) THEN' rtac TrueI end
  in
    Scan.succeed (fn ctxt =>
      SIMPLE_METHOD'
       (if getenv "ISABELLE_FULL_TEST" = "true" then eval_tac ctxt
        else Skip_Proof.cheat_tac))
  end
*} "solve goal by evaluation if ISABELLE_FULL_TEST=true)"

subsection {* Proofs by evaluation using generated code *}

lemma pre_iso_test3: "\<forall>g \<in> set Tri. pre_iso_test g"
by eval

lemma pre_iso_test4: "\<forall>g \<in> set Quad. pre_iso_test g"
by eval

lemma pre_iso_test5: "\<forall>g \<in> set Pent. pre_iso_test g"
by eval

lemma pre_iso_test6: "\<forall>g \<in> set Hex. pre_iso_test g"
by eval

lemma same3: "samet (tameEnumFilter 0) Tri"
by eval

lemma same4: "samet (tameEnumFilter 1) Quad"
by cond_eval

lemma same5: "samet (tameEnumFilter 2) Pent"
by cond_eval

lemma same6: "samet (tameEnumFilter 3) Hex"
by cond_eval

end


theory Sorting_Ex_Array_Idxs
imports Sorting_Introsort
begin

subsection \<open>Compare Indexes into Value Array\<close>

definition idx_less :: "'a::linorder list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where "idx_less vs i j \<equiv> vs!i < vs!j"
definition idx_cdom :: "'a::linorder list \<Rightarrow> nat set" where "idx_cdom vs \<equiv> {0..<length vs}"

definition "idx_pcmp vs i j \<equiv> do {
  ASSERT (i<length vs \<and> j<length vs);
  RETURN (vs!i < vs!j)
}"

sepref_def idx_pcmp_impl is "uncurry2 idx_pcmp" ::
  "(al_assn snat_assn)\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
  unfolding idx_pcmp_def
  by sepref

interpretation IDXO: weak_ordering_on_lt "idx_cdom vs" "idx_less vs"
  apply unfold_locales
  unfolding idx_less_def by auto

interpretation IDXO: parameterized_weak_ordering idx_cdom idx_less idx_pcmp
  apply unfold_locales
  unfolding idx_pcmp_def
  apply refine_vcg
  apply (auto simp: idx_less_def idx_cdom_def)
  done

lemma "random_access_iterator (woarray_assn snat_assn) (eoarray_assn snat_assn) snat_assn
  return return
  eo_extract_impl
  array_upd"
  apply unfold_locales
  apply (rule eo_hnr_dep)+
  done

locale pure_eo_adapter =
  fixes elem_assn :: "'a \<Rightarrow> 'ai::llvm_rep \<Rightarrow> assn"
    and wo_assn :: "'a list \<Rightarrow> 'oi::llvm_rep \<Rightarrow> assn"
    and wo_get_impl :: "'oi \<Rightarrow> 'size::len2 word \<Rightarrow> 'ai llM"
    and wo_set_impl :: "'oi \<Rightarrow> 'size::len2 word \<Rightarrow> 'ai \<Rightarrow> 'oi llM"
  assumes pure[safe_constraint_rules]: "is_pure elem_assn"
      and get_hnr: "(uncurry wo_get_impl,uncurry mop_list_get) \<in> wo_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a elem_assn"
      and set_hnr: "(uncurry2 wo_set_impl,uncurry2 mop_list_set) \<in> wo_assn\<^sup>d *\<^sub>a snat_assn\<^sup>k *\<^sub>a elem_assn\<^sup>k \<rightarrow>\<^sub>a\<^sub>d (\<lambda>_ ((ai,_),_). cnc_assn (\<lambda>x. x=ai) wo_assn)"
begin

  lemmas [sepref_fr_rules] = get_hnr set_hnr

  definition "only_some_rel \<equiv> {(a, Some a) | a. True} \<union> {(x, None) | x. True}"

  definition "eo_assn \<equiv> hr_comp wo_assn (\<langle>only_some_rel\<rangle>list_rel)"

  definition "eo_extract1 p i \<equiv> doN { r \<leftarrow> mop_list_get p i; RETURN (r,p) }"
  sepref_definition eo_extract_impl is "uncurry eo_extract1"
    :: "wo_assn\<^sup>d *\<^sub>a (snat_assn' TYPE('size))\<^sup>k \<rightarrow>\<^sub>a elem_assn \<times>\<^sub>a wo_assn"
    unfolding eo_extract1_def
    by sepref

  lemma mop_eo_extract_aux: "mop_eo_extract p i = doN { r \<leftarrow> mop_list_get p i; ASSERT (r\<noteq>None \<and> i<length p); RETURN (the r, p[i:=None]) }"
    by (auto simp: pw_eq_iff refine_pw_simps)

  lemma assign_none_only_some_list_rel:
    assumes SR[param]: "(a, a') \<in> \<langle>only_some_rel\<rangle>list_rel" and L: "i < length a'"
      shows "(a, a'[i := None]) \<in> \<langle>only_some_rel\<rangle>list_rel"
  proof -
    have "(a[i := a!i], a'[i := None]) \<in> \<langle>only_some_rel\<rangle>list_rel"
      apply (parametricity)
      by (auto simp: only_some_rel_def)
    also from L list_rel_imp_same_length[OF SR] have "a[i := a!i] = a" by auto
    finally show ?thesis .
  qed

  lemma eo_extract1_refine: "(eo_extract1, mop_eo_extract) \<in> \<langle>only_some_rel\<rangle>list_rel \<rightarrow> nat_rel \<rightarrow> \<langle>Id \<times>\<^sub>r \<langle>only_some_rel\<rangle>list_rel\<rangle>nres_rel"
    unfolding eo_extract1_def mop_eo_extract_aux
    supply R = mop_list_get.fref[THEN frefD, OF TrueI prod_relI, unfolded uncurry_apply, THEN nres_relD]
    apply (refine_rcg R)
    apply assumption
    apply (clarsimp simp: assign_none_only_some_list_rel)
    by (auto simp: only_some_rel_def)

  lemma eo_list_set_refine: "(mop_list_set, mop_eo_set) \<in> \<langle>only_some_rel\<rangle>list_rel \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>\<langle>only_some_rel\<rangle>list_rel\<rangle>nres_rel"
    unfolding mop_list_set_alt mop_eo_set_alt
    apply refine_rcg
    apply (simp add: list_rel_imp_same_length)
    apply simp
    apply parametricity
    apply (auto simp: only_some_rel_def)
    done

  lemma set_hnr': "(uncurry2 wo_set_impl,uncurry2 mop_list_set) \<in> wo_assn\<^sup>d *\<^sub>a snat_assn\<^sup>k *\<^sub>a elem_assn\<^sup>k \<rightarrow>\<^sub>a wo_assn"
    apply (rule hfref_cons[OF set_hnr])
    apply (auto simp: cnc_assn_def entails_lift_extract_simps sep_algebra_simps)
    done

  context
    notes [fcomp_norm_unfold] = eo_assn_def[symmetric]
  begin
    lemmas eo_extract_refine_aux = eo_extract_impl.refine[FCOMP eo_extract1_refine]

    lemma eo_extract_refine: "(uncurry eo_extract_impl, uncurry mop_eo_extract) \<in> eo_assn\<^sup>d *\<^sub>a snat_assn\<^sup>k
      \<rightarrow>\<^sub>a\<^sub>d (\<lambda>_ (ai,_). elem_assn \<times>\<^sub>a cnc_assn (\<lambda>x. x=ai) eo_assn)"
      apply (sepref_to_hnr)
      apply (rule hn_refine_nofailI)
      unfolding cnc_assn_prod_conv
      apply (rule hnr_ceq_assnI)
      subgoal
        supply R = eo_extract_refine_aux[to_hnr, unfolded APP_def]
        apply (rule hn_refine_cons[OF _ R])
        apply (auto simp: sep_algebra_simps entails_lift_extract_simps hn_ctxt_def pure_def invalid_assn_def)
        done
      subgoal
        unfolding eo_extract_impl_def mop_eo_extract_def hn_ctxt_def eo_assn_def hr_comp_def
        supply R = get_hnr[to_hnr, THEN hn_refineD, unfolded APP_def hn_ctxt_def]
        thm R
        supply [vcg_rules] = R
        supply [simp] = refine_pw_simps list_rel_imp_same_length
        apply (vcg)
        done
      done

    lemmas eo_set_refine_aux = set_hnr'[FCOMP eo_list_set_refine]

    lemma pure_part_cnc_imp_eq: "pure_part (cnc_assn (\<lambda>x. x = cc) wo_assn a c) \<Longrightarrow> c=cc"
      by (auto simp: pure_part_def cnc_assn_def pred_lift_extract_simps)

    (* TODO: Move *)
    lemma pure_entails_empty: "is_pure A \<Longrightarrow> A a c \<turnstile> \<box>"
      by (auto simp: is_pure_def sep_algebra_simps entails_lift_extract_simps)

    lemma eo_set_refine: "(uncurry2 wo_set_impl, uncurry2 mop_eo_set) \<in> eo_assn\<^sup>d *\<^sub>a snat_assn\<^sup>k *\<^sub>a elem_assn\<^sup>d \<rightarrow>\<^sub>a\<^sub>d (\<lambda>_ ((ai, _), _). cnc_assn (\<lambda>x. x = ai) eo_assn)"
      apply (sepref_to_hnr)
      apply (rule hn_refine_nofailI)
      apply (rule hnr_ceq_assnI)
      subgoal
        supply R = eo_set_refine_aux[to_hnr, unfolded APP_def]
        apply (rule hn_refine_cons[OF _ R])
        apply (auto simp: sep_algebra_simps entails_lift_extract_simps hn_ctxt_def pure_def invalid_assn_def pure_entails_empty[OF pure])
        done
      subgoal
        unfolding hn_ctxt_def eo_assn_def hr_comp_def
        supply R = set_hnr[to_hnr, THEN hn_refineD, unfolded APP_def hn_ctxt_def]
        supply [vcg_rules] = R
        supply [simp] = refine_pw_simps list_rel_imp_same_length pure_part_cnc_imp_eq
        apply (vcg')
        done
      done

  end
  thm mop_eo_extract_def

  find_theorems mop_eo_set mop_list_set

  thm mop_eo_set_alt

  lemma id_Some_only_some_rel: "(id, Some) \<in> Id \<rightarrow> only_some_rel"
    by (auto simp: only_some_rel_def)

  lemma map_some_only_some_rel_iff: "(xs, map Some ys) \<in> \<langle>only_some_rel\<rangle>list_rel \<longleftrightarrow> xs=ys"
    apply (rule iffI)
    subgoal
      apply (induction xs "map Some ys" arbitrary: ys rule: list_rel_induct)
      apply (auto simp: only_some_rel_def)
      done
    subgoal
      apply (rewrite in "(\<hole>,_)" list.map_id[symmetric])
      apply (parametricity add: id_Some_only_some_rel)
      by simp
    done

  lemma wo_assn_conv: "wo_assn xs ys = eo_assn (map Some xs) ys"
    unfolding eo_assn_def hr_comp_def
    by (auto simp: pred_lift_extract_simps sep_algebra_simps fun_eq_iff map_some_only_some_rel_iff)

  lemma to_eo_conv_refine: "(return, mop_to_eo_conv) \<in> wo_assn\<^sup>d \<rightarrow>\<^sub>a\<^sub>d (\<lambda>_ ai. cnc_assn (\<lambda>x. x = ai) eo_assn)"
    unfolding mop_to_eo_conv_def cnc_assn_def
    apply sepref_to_hoare
    apply (rewrite wo_assn_conv)
    apply vcg
    done

  lemma "None \<notin> set xs \<longleftrightarrow> (\<exists>ys. xs = map Some ys)"
    using None_not_in_set_conv by auto

  lemma to_wo_conv_refine: "(return, mop_to_wo_conv) \<in> eo_assn\<^sup>d \<rightarrow>\<^sub>a\<^sub>d (\<lambda>_ ai. cnc_assn (\<lambda>x. x = ai) wo_assn)"
    unfolding mop_to_wo_conv_def cnc_assn_def eo_assn_def hr_comp_def
    apply sepref_to_hoare
    apply (auto simp add: refine_pw_simps map_some_only_some_rel_iff elim!: None_not_in_set_conv)
    by vcg

  lemma random_access_iterator: "random_access_iterator wo_assn eo_assn elem_assn
    return return
    eo_extract_impl
    wo_set_impl"
    apply unfold_locales
    using to_eo_conv_refine to_wo_conv_refine eo_extract_refine eo_set_refine
    apply blast+
    done

  sublocale random_access_iterator wo_assn eo_assn elem_assn
    return return
    eo_extract_impl
    wo_set_impl
    by (rule random_access_iterator)

  find_theorems "?a = UNPROTECT ?a"

end

(*global_interpretation IDXO: random_access_iterator
  "woarray_assn snat_assn" "eoarray_assn snat_assn" snat_assn
  return return
  eo_extract_impl
  array_upd
  defines IDXO_swap_eo_impl = IDXO.swap_eo_impl
  apply unfold_locales
  apply (rule eo_hnr_dep)+
  done
*)

print_named_simpset llvm_inline

global_interpretation IDXO: parameterized_sort_impl_context
  "woarray_assn snat_assn" "eoarray_assn snat_assn" snat_assn
  return return
  eo_extract_impl
  array_upd
  idx_cdom idx_less idx_pcmp idx_pcmp_impl "al_assn snat_assn"
  defines
          IDXO_is_guarded_insert_impl = IDXO.is_guarded_param_insert_impl
      and IDXO_is_unguarded_insert_impl = IDXO.is_unguarded_param_insert_impl
      and IDXO_unguarded_insertion_sort_impl = IDXO.unguarded_insertion_sort_param_impl
      and IDXO_guarded_insertion_sort_impl = IDXO.guarded_insertion_sort_param_impl
      and IDXO_final_insertion_sort_impl = IDXO.final_insertion_sort_param_impl
      (*and IDXO_mop_lchild_impl  = IDXO.mop_lchild_impl
      and IDXO_mop_rchild_impl  = IDXO.mop_rchild_impl
      and IDXO_has_rchild_impl  = IDXO.has_rchild_impl
      and IDXO_has_lchild_impl  = IDXO.has_lchild_impl *)

      and IDXO_pcmpo_idxs_impl  = IDXO.pcmpo_idxs_impl
      and IDXO_pcmpo_v_idx_impl  = IDXO.pcmpo_v_idx_impl
      and IDXO_pcmpo_idx_v_impl  = IDXO.pcmpo_idx_v_impl
      and IDXO_pcmp_idxs_impl  = IDXO.pcmp_idxs_impl

      and IDXO_mop_geth_impl    = IDXO.mop_geth_impl
      and IDXO_mop_seth_impl    = IDXO.mop_seth_impl
      and IDXO_sift_down_impl   = IDXO.sift_down_impl
      and IDXO_heapify_btu_impl = IDXO.heapify_btu_impl
      and IDXO_heapsort_impl    = IDXO.heapsort_param_impl
      and IDXO_qsp_next_l_impl       = IDXO.qsp_next_l_impl
      and IDXO_qsp_next_h_impl       = IDXO.qsp_next_h_impl
      and IDXO_qs_partition_impl     = IDXO.qs_partition_impl
(*      and IDXO_qs_partitionXXX_impl     = IDXO.qs_partitionXXX_impl *)
      and IDXO_partition_pivot_impl  = IDXO.partition_pivot_impl
      and IDXO_introsort_aux_impl = IDXO.introsort_aux_param_impl
      and IDXO_introsort_impl        = IDXO.introsort_param_impl
      and IDXO_move_median_to_first_impl = IDXO.move_median_to_first_param_impl

  apply unfold_locales
  apply (rule eo_hnr_dep)+
  unfolding GEN_ALGO_def refines_param_relp_def (* TODO: thm gen_refines_param_relpI *)
  by (rule idx_pcmp_impl.refine)

(* TODO: This seems to be a quirk in llvm monadify and inline! FIXME! *)
lemmas [abs_def,llvm_inline] = array_upd_def eo_extract_impl_def

(*llvm_deps "IDXO_heapsort_impl :: 32 word ptr \<Rightarrow> _" *)

lemma al_pure_eo: "is_pure A \<Longrightarrow> pure_eo_adapter A (al_assn A) arl_nth arl_upd"
  apply unfold_locales
  apply assumption
  apply (rule al_nth_hnr_mop; simp)
  subgoal
    apply (sepref_to_hnr)
    apply (rule hn_refine_nofailI)
    apply (rule hnr_ceq_assnI)
    subgoal
      supply R = al_upd_hnr_mop[to_hnr, unfolded APP_def, of A]
      apply (rule hn_refine_cons[OF _ R])
      apply (auto simp: hn_ctxt_def pure_def invalid_assn_def sep_algebra_simps entails_lift_extract_simps)
      done
    subgoal
      unfolding hn_ctxt_def al_assn_def hr_comp_def pure_def in_snat_rel_conv_assn
      apply (erule is_pureE)
      apply (simp add: refine_pw_simps)
      supply [simp] = list_rel_imp_same_length
      by vcg
    done
  done

global_interpretation
  ALO: pure_eo_adapter snat_assn "al_assn snat_assn" arl_nth arl_upd
  defines ALO_eo_extract_impl = ALO.eo_extract_impl
  apply (rule al_pure_eo)
  by simp

global_interpretation ALO: parameterized_sort_impl_context
  "al_assn snat_assn" "ALO.eo_assn" snat_assn
  return return
  ALO_eo_extract_impl
  arl_upd
  idx_cdom idx_less idx_pcmp idx_pcmp_impl "al_assn snat_assn"
  defines
          ALO_is_guarded_insert_impl = ALO.is_guarded_param_insert_impl
      and ALO_is_unguarded_insert_impl = ALO.is_unguarded_param_insert_impl
      and ALO_unguarded_insertion_sort_impl = ALO.unguarded_insertion_sort_param_impl
      and ALO_guarded_insertion_sort_impl = ALO.guarded_insertion_sort_param_impl
      and ALO_final_insertion_sort_impl = ALO.final_insertion_sort_param_impl
      (*and ALO_mop_lchild_impl  = ALO.mop_lchild_impl
      and ALO_mop_rchild_impl  = ALO.mop_rchild_impl
      and ALO_has_rchild_impl  = ALO.has_rchild_impl
      and ALO_has_lchild_impl  = ALO.has_lchild_impl *)

      and ALO_pcmpo_idxs_impl  = ALO.pcmpo_idxs_impl
      and ALO_pcmpo_v_idx_impl  = ALO.pcmpo_v_idx_impl
      and ALO_pcmpo_idx_v_impl  = ALO.pcmpo_idx_v_impl
      and ALO_pcmp_idxs_impl  = ALO.pcmp_idxs_impl

      and ALO_mop_geth_impl    = ALO.mop_geth_impl
      and ALO_mop_seth_impl    = ALO.mop_seth_impl
      and ALO_sift_down_impl   = ALO.sift_down_impl
      and ALO_heapify_btu_impl = ALO.heapify_btu_impl
      and ALO_heapsort_impl    = ALO.heapsort_param_impl
      and ALO_qsp_next_l_impl       = ALO.qsp_next_l_impl
      and ALO_qsp_next_h_impl       = ALO.qsp_next_h_impl
      and ALO_qs_partition_impl     = ALO.qs_partition_impl
(*      and ALO_qs_partitionXXX_impl     = ALO.qs_partitionXXX_impl *)
      and ALO_partition_pivot_impl  = ALO.partition_pivot_impl
      and ALO_introsort_aux_impl = ALO.introsort_aux_param_impl
      and ALO_introsort_impl        = ALO.introsort_param_impl
      and ALO_move_median_to_first_impl = ALO.move_median_to_first_param_impl

  apply unfold_locales
  unfolding GEN_ALGO_def refines_param_relp_def (* TODO: thm gen_refines_param_relpI *)
  apply (rule idx_pcmp_impl.refine)
  done

lemmas [llvm_inline] = ALO.eo_extract_impl_def[THEN meta_fun_cong, THEN meta_fun_cong]

print_named_simpset llvm_inline

find_in_thms ALO_partition_pivot_impl in llvm_code

(*oops llvm_deps "ALO_heapsort_impl :: (32 word,64) array_list \<Rightarrow> (64 word,64) array_list \<Rightarrow> _"*)

(*export_llvm "ALO_heapsort_impl :: (32 word,64) array_list \<Rightarrow> (64 word,64) array_list \<Rightarrow> _"*)

export_llvm
  "ALO_heapsort_impl :: (32 word,64) array_list \<Rightarrow> (64 word,64) array_list \<Rightarrow> _"
  "ALO_introsort_impl :: (32 word,64) array_list \<Rightarrow> (64 word,64) array_list \<Rightarrow> _"

export_llvm
  "ALO_heapsort_impl :: (32 word,64) array_list \<Rightarrow> (64 word,64) array_list \<Rightarrow> _"
  "ALO_introsort_impl :: (32 word,64) array_list \<Rightarrow> (64 word,64) array_list \<Rightarrow> _"
  "IDXO_heapsort_impl :: (32 word,64) array_list \<Rightarrow> _" is "uint64_t* heapsort_idxs(array_list_32_64, uint64_t*, int64_t, int64_t)"
  "IDXO_introsort_impl :: (32 word,64) array_list \<Rightarrow> _" is "uint64_t* introsort_idxs(array_list_32_64, uint64_t*, int64_t, int64_t)"
  defines \<open>
    typedef struct {int64_t size; struct {int64_t capacity; int32_t *data;};} array_list_32_64;
    typedef struct {int64_t size; struct {int64_t capacity; int64_t *data;};} array_list_64_64;

    \<close>
  file "../code/introsort_param.ll"

  thm ALO.introsort_param_impl_correct

end


           (*-------------------------------------------*
            |       Uniform Candy Distribution          |
            |                                           |
            |           November 2007 for Isabelle 2005 |
            |           November 2008 for Isabelle 2008 |
            |           November 2012 for Isabelle 2012 |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory UCD_proc2
imports UCD_proc1
begin

(*****************************************************************

         1.

 *****************************************************************)

(* ======================= Circ ======================= *)

datatype PNRC = PreCircSpecC "(nat * (Att list))"
              | PreCircSpecL "(nat * (Att list))"
              | PreCircSpecR "(nat * (Att list))"

fun
  PNRCdef :: "PNRC => (PNRC, Event) proc"
where
 "PNRCdef (PreCircSpecC (n,s)) =
   IF (ChkLCR s & s~=[] & guardL s & guardR s) THEN
   ((left ! (n div 2) -> $PreCircSpecR(n div 2,s)) [+]
    (right ! (getNat (hd s) div 2) -> $PreCircSpecL(n,s)))
   ELSE STOP"

|"PNRCdef (PreCircSpecL (n,s)) =
   IF (ChkLCR s & s~=[] & guardL s & guardR s) THEN
   (left ! (n div 2) ->
      $PreCircSpecC (fill(n div 2 + getNat (hd s) div 2),nextR(nextL s, (n div 2))))
   ELSE STOP"

|"PNRCdef (PreCircSpecR (n,s)) =
   IF (ChkLCR s & s~=[] & guardL s & guardR s) THEN
   (right ! (getNat (hd s) div 2) ->
      $PreCircSpecC (fill(n + (getNat (hd s) div 2)),nextL(nextR(s,n))))
   ELSE STOP"
(*
defs (overloaded) Set_PNRCfun_def [simp]: "PNfun == PNRCdef"
*)
overloading Set_PNRCdef ==
  "PNfun :: (PNRC, Event) pnfun"
begin
  definition "PNfun == PNRCdef"
end

declare Set_PNRCdef_def [simp]

(* ------------------ *
      guardedness
 * ------------------ *)

lemma guardedfun_PNRC[simp]:
      "guardedfun PNRCdef"
apply (simp add: guardedfun_def)
apply (rule allI)
apply (induct_tac p)
apply (auto)
done

(* -----------------------DF---------------------------------- *)

datatype DFtickName = DFtick

primrec
  DFtickfun ::
    "DFtickName => (DFtickName, 'a) proc"
where
  "DFtickfun (DFtick) = (! x ->  $(DFtick)) |~| SKIP "

(*
defs (overloaded)
Set_DFtickfun_def [simp]: "PNfun == DFtickfun"
*)

overloading Set_DFtickfun ==
  "PNfun :: (DFtickName, Event) pnfun"
begin
  definition "(PNfun :: (DFtickName, Event) pnfun) == DFtickfun"
end

declare Set_DFtickfun_def [simp]

lemma guardedfun_DFtick[simp]:
      "guardedfun DFtickfun"
by (simp add: guardedfun_def, rule allI, induct_tac p, simp_all)

primrec
  DF_to_PreCircSpecC :: "DFtickName => (PNRC, Event) proc"
where
  "DF_to_PreCircSpecC (DFtick) =
     (!nat n .. !<stlist> s:{s. ChkLCR s & s~=[] & guardL s & guardR s} ..
           $PreCircSpecC (n,s))
     |~|
     (!nat n .. !<stlist> s:{s. ChkLCR s & s~=[] & guardL s & guardR s} ..
           $(PreCircSpecL (n,s)))
     |~|
     (!nat n .. !<stlist> s:{s. ChkLCR s & s~=[] & guardL s & guardR s} ..
           $PreCircSpecR (n,s))"

(* --------------------------------------- *
            deadlock freeness
 * --------------------------------------- *)

theorem PreCircSpecC_DF:
  "[| ChkLCR s ; s~=[] ; guardL s ; guardR s |]
   ==> (($DFtick)::(DFtickName, Event) proc) <=F $PreCircSpecC (n,s)"
apply (rule cspF_fp_induct_left[of _ "DF_to_PreCircSpecC"])
apply (auto)

(* base *)
 apply (rule cspF_Int_choice_left1)
 apply (rule cspF_Int_choice_left1)
 apply (rule cspF_Rep_int_choice_left)
 apply (rule_tac x="n" in exI)
 apply (simp)
 apply (rule cspF_Rep_int_choice_left)
 apply (simp)
 apply (rule_tac x="s" in exI)
 apply (simp)

(* step *)
 apply (induct_tac p, auto)

 (* 1 *)
 apply (rule cspF_Int_choice_left1)
 apply (simp add: Int_pre_choice_def)
 apply (cspF_unwind_right | cspF_hsf_right)+
 apply (rule cspF_decompo_ref)
 apply (simp_all)
  apply (elim disjE conjE exE)  (* right | left *)
  (* 1/2 *)(* right *)
  apply (simp)
  apply (cspF_simp)+
  apply (rule cspF_Int_choice_left1)
  apply (rule cspF_Int_choice_left2)
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="n" in exI)
  apply (simp)
  apply (rule cspF_Rep_int_choice_left)
  apply (simp)
  apply (rule_tac x="a" in exI)
  apply (simp)

   (* 1/2 *)(* left *)
  apply (cspF_simp)+
  apply (rule cspF_Int_choice_left2)
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="n div 2" in exI)
  apply (simp)
  apply (rule cspF_Rep_int_choice_left)
  apply (simp)
  apply (rule_tac x="a" in exI)
  apply (simp)

 (* 2 *)
 apply (rule cspF_Int_choice_left1)
 apply (simp add: Int_pre_choice_def)
 apply (cspF_unwind_right | cspF_hsf_right)+
 apply (rule cspF_decompo_ref)
 apply (simp_all)
  (* left *)
  apply (rule cspF_Int_choice_left1)
  apply (rule cspF_Int_choice_left1)
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="fill (n div 2 + getNat (hd a) div 2)" in exI)
  apply (simp)
  apply (rule cspF_Rep_int_choice_left)
  apply (simp)
  apply (rule_tac x="nextR (nextL a, n div 2)" in exI)
  apply (simp)
  apply (simp add: guardR_nextR_nextL)

 (* 3 *)
 apply (rule cspF_Int_choice_left1)
 apply (simp add: Int_pre_choice_def)
 apply (cspF_unwind_right | cspF_hsf_right)+
 apply (rule cspF_decompo_ref)
 apply (simp_all)
  (* right *)
  apply (rule cspF_Int_choice_left1)
  apply (rule cspF_Int_choice_left1)
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="fill (n + getNat (hd a) div 2)" in exI)
  apply (simp)
  apply (rule cspF_Rep_int_choice_left)
  apply (simp)
  apply (rule_tac x="nextL (nextR (a, n))" in exI)
  apply (simp)
  apply (simp add: guardL_nextL_nextR)
done

(* ------------------------------------------------------------ *)

fun
  PreCircSpecC_to_Step :: "PNRC => (PN, Event) proc"
where
  "PreCircSpecC_to_Step (PreCircSpecC (n,s)) =
     IF (ChkLCR s & s~=[] & guardL s & guardR s)
     THEN ($Child n <=-=> $LineSpec s) ELSE STOP"

 |"PreCircSpecC_to_Step (PreCircSpecL (n,s)) =
     IF (ChkLCR s & s~=[] & guardL s & guardR s)
     THEN ($ChildL (n, getNat (hd s) div 2) <=-=> $LineSpec (nextL s)) ELSE STOP"

 |"PreCircSpecC_to_Step (PreCircSpecR (n,s)) =
     IF (ChkLCR s & s~=[] & guardL s & guardR s)
     THEN ($ChildR n <=-=> $LineSpec (nextR (s, n))) ELSE STOP"

(* ----------------------------------- *
                 Circ
 * ----------------------------------- *)

lemma PreCircSpecC_Step_lm:
 "$PreCircSpecC (n,s) <=F PreCircSpecC_to_Step (PreCircSpecC (n,s))"
apply (rule cspF_fp_induct_left[of _ "PreCircSpecC_to_Step"])
apply (simp)+

 apply (induct_tac p)
 apply (auto)

(* PreCircSpecC *)
 apply (case_tac "~(ChkLCR b & b ~= [] & guardL b & guardR b)")
 apply (simp (no_asm_simp))
 apply (cspF_simp)+

 (* ChkLCR b & b ~= [] *)
  apply (simp add: not_nil_EX)
  apply (elim exE conjE)
  apply (simp)
  apply (elim conjE disjE exE)
  apply (simp_all)

  (* AttL *)
  apply (cspF_unwind | cspF_hsf)+
   (* rem head *)
   apply (rule)
   apply (simp)
   apply (simp)
    apply (elim disjE conjE exE)  (* left | right *)
   (* 1/2 *)(* left *)
    apply (simp)
    apply (cspF_simp)+
   (* 1/2 *)(* right  done *)

  (* AttC *)
  apply (cspF_unwind | cspF_hsf)+
   (* rem head *)
   apply (rule)
   apply (simp)
   apply (simp)
    apply (elim disjE conjE exE)  (* left | right *)
   (* 1/2 *)(* left *)
    apply (simp)
    apply (cspF_simp)+

(* PreCircSpecL *)
 apply (case_tac "~(ChkLCR b & b ~= [] & guardL b & guardR b)")
 apply (simp (no_asm_simp))
 apply (cspF_simp)+

 (* ChkLCR b & b ~= [] *)
  apply (simp add: not_nil_EX)
  apply (elim exE conjE)
  apply (simp)
  apply (elim conjE disjE exE)
  apply (simp_all)

  (* AttL *)
  apply (cspF_unwind | cspF_hsf)+
   (* rem head *)
   apply (rule)
   apply (simp)
   apply (simp)
    (* left *)
    apply (cspF_simp)+
    apply (simp add: guardR_nextR_nextL)
    apply (cspF_simp)+

  (* AttC *)
  apply (cspF_unwind | cspF_hsf)+
   (* rem head *)
   apply (rule)
   apply (simp)
   apply (simp)
   (* left *)
    apply (cspF_simp)+
    apply (simp add: ChkR_ChkCR guardR_nextR_AttR)
    apply (cspF_simp)+

(* PreCircSpecR *)
 apply (case_tac "~(ChkLCR b & b ~= [] & guardL b & guardR b)")
 apply (simp (no_asm_simp))
 apply (cspF_simp)+

 (* ChkLCR b & b ~= [] *)
  apply (simp add: not_nil_EX)
  apply (elim exE conjE)
  apply (simp)
  apply (elim conjE disjE exE)
  apply (simp_all)

  (* AttL *)
  apply (cspF_unwind | cspF_hsf)+
  apply (case_tac "guardR (nextR (t, a))")
  apply (cspF_hsf)+
   (* rem head *)
   apply (rule)
   apply (simp)
   apply (simp)
    (* right *)
    apply (cspF_simp)+

  (* ~guardR (nextR (t, a) *)
  apply (cspF_hsf)+
   (* rem head *)
   apply (rule)
   apply (simp)
   apply (simp)
    (* right *)
    apply (cspF_simp)+

  (* AttC *)
  apply (cspF_unwind | cspF_hsf)+
  apply (case_tac "guardR (nextR (AttC n # t, a))")
  apply (cspF_hsf)+
   (* rem head *)
   apply (rule)
   apply (simp)
   apply (simp add: getNat_hd_nextR_AttC)
   apply (simp add: guardL_nextL_nextR)
   apply (cspF_simp)+
   apply (simp add: getNat_hd_nextR_AttC)

  apply (cspF_hsf)+
   (* rem head *)
   apply (rule)
   apply (simp)
   apply (simp add: getNat_hd_nextR_AttC)
   apply (simp add: guardL_nextL_nextR)
   apply (cspF_simp)+
   apply (simp add: getNat_hd_nextR_AttC)
done

(* --------------------------------- *
          PreCircSpecC (step main)
 * --------------------------------- *)

lemma cspF_tr_left_ref2:
   "[| P1 <=F[M1,M2] P2 ; P2 <=F[M2,M3] P3 |] ==> P1 <=F[M1,M3] P3"
by (simp add: refF_def eqF_def)

lemma PreCircSpecC_Step:
 "[| ChkLCR s ; s ~= [] ; guardL s ; guardR s |]
  ==> ($PreCircSpecC (n, s)::(PNRC,Event) proc) <=F $Child n <=-=> $LineSpec s"
apply (rule cspF_tr_left_ref2)
apply (rule PreCircSpecC_Step_lm)
apply (simp)
apply (cspF_simp)+
done

(* --------------------------------- *
               lemmas
 * --------------------------------- *)

(*
lemma PreCircChild_not_nil [simp]:
  "s ~= [] ==> PreCircChild (n # s) = ($Child n) <=-=> (LineChild s)"
apply (simp add: not_nil_EX)
apply (elim conjE exE)
by (simp)

lemma CircChild_not_nil [simp]:
  "s ~= [] ==> CircChild (n # s) = ($Child n) <===> (LineChild s)"
apply (simp add: not_nil_EX)
apply (elim conjE exE)
by (simp)
*)

(* ---------------------------------------------------- *
 |                                                      |
 |           Sequentialising PreCircChild s             |
 |                                                      |
 * ---------------------------------------------------- *)

theorem PreCircSpecC_PreCircChild:
 "s~=[] ==> $PreCircSpecC (n, toStb (map AttC s)) <=F PreCircChild (n#s)"
apply (rule cspF_tr_left_ref2)
apply (rule PreCircSpecC_Step)
apply (simp_all)
apply (simp add: ChkLCR_toStb)
apply (simp add: guardL_toStb_AttC)
apply (simp add: guardR_toStb_AttC)
apply (rule cspF_decompo | simp)+
apply (simp add: LineSpec_LineChild)
done

(* --------------------------------- *
 |       DF <= PreCircSpecC          |
 * --------------------------------- *)

lemma DF_PreCircSpecC_toStb:
 "s~=[] ==> (($DFtick)::(DFtickName, Event) proc)
            <=F $PreCircSpecC (n, toStb (map AttC s))"
apply (rule PreCircSpecC_DF)
apply (simp add: ChkLCR_toStb)
apply (simp)
apply (simp add: guardL_toStb_AttC)
apply (simp add: guardR_toStb_AttC)
done

(* ---------------------------------------------------- *
 |                                                      |
 |          PreCircChild s is dealock-free.             |
 |                                                      |
 * ---------------------------------------------------- *)

theorem DF_PreCircChild:
 "s~=[] ==> $DFtick <=F PreCircChild (n#s)"
apply (rule cspF_tr_left_ref2)
apply (rule DF_PreCircSpecC_toStb)
apply (simp)
apply (rule PreCircSpecC_PreCircChild)
apply (simp)
done

(* ======================= CircSpec ======================= *)

datatype PNR = CircSpec "(nat list)"

primrec
  PNRdef :: "PNR => (PNR, Event) proc"
where
 "PNRdef (CircSpec s) =
    IF (tl s~=[]) THEN
    (left ! ((hd s) div 2) -> $(CircSpec (circNext s)))
    ELSE STOP"
(*
defs (overloaded) Set_PNRfun_def [simp]: "PNfun == PNRdef"
*)
overloading Set_PNRdef ==
  "PNfun :: (PNR, Event) pnfun"
begin
  definition "PNfun == PNRdef"
end

declare Set_PNRdef_def [simp]

(* ------------------ *
      guardedness
 * ------------------ *)

lemma guardedfun_PNR[simp]:
      "guardedfun PNRdef"
apply (simp add: guardedfun_def)
apply (rule allI)
apply (induct_tac p)
apply (auto)
done

(* ------------------------------------------------------------ *)

declare toStb_simp [simp]

fun
  CircSpec_to_PreCircSpecC :: "PNR => (PNRC, Event) proc"
where
  "CircSpec_to_PreCircSpecC (CircSpec s) =
     IF (tl s~=[]) THEN
        ($PreCircSpecC (hd s, toStb (map AttC (tl s))) -- range right)
     ELSE STOP"

(* ------------- lemma ------------- *)

lemma CircSpec_PreCircSpecC_lm:
 "tl s ~= [] ==> $CircSpec s <=F CircSpec_to_PreCircSpecC (CircSpec s)"
apply (rule cspF_fp_induct_left[of _ "CircSpec_to_PreCircSpecC"])
apply (simp)+

 apply (induct_tac p)
 apply (auto)

 apply (case_tac "(tl xa = [])")
 apply (simp)
 apply (cspF_simp)+

 (* tl list ~= [] *)

  apply (cspF_unwind)
  apply (cspF_hsf)+

  apply (rule)  (* 1i |~| 2i *)

  (* 1i *)
   apply (cspF_unwind)
   apply (simp add: nextR_nextL_toStb_nextR_nextL_toStb)
   apply (cspF_hsf)+
   (* rem head *)
   apply (rule)
   apply (simp)
   apply (simp)
    (* left *)
    apply (cspF_simp)+
    apply (rule)  (* 1ii |~| 2ii *)

     (* 1ii *)
     apply (cspF_unwind_right)
     apply (cspF_hsf)+
     apply (simp add: nextL_nextR_toStb_lineNext)
     apply (simp add: tl_lineNext)
     apply (simp add: getNat_hd_toStb_map_AttC)
     apply (simp add: hd_circNext)
     apply (simp add: circNext_def)

     (* 2ii *)
     apply (simp add: nextL_nextR_toStb_lineNext)
     apply (simp add: tl_lineNext)
     apply (simp add: getNat_hd_toStb_map_AttC)
     apply (simp add: hd_circNext)
     apply (simp add: circNext_def)

  (* 2i *)
   apply (cspF_unwind)
   apply (simp add: nextR_nextL_toStb_nextR_nextL_toStb)
   apply (cspF_hsf)+
   (* rem head *)
   apply (rule)
   apply (simp)
   apply (simp)
    (* left *)
    apply (cspF_simp)+

     apply (simp add: nextL_nextR_toStb_lineNext)
     apply (simp add: tl_lineNext)
     apply (simp add: getNat_hd_toStb_map_AttC)
     apply (simp add: hd_circNext)
     apply (simp add: circNext_def)
done

(* ---------------------------------------------------- *
 |                                                      |
 |     CircSpec s <=F PreCircSpecC s -- range right     |
 |                                                      |
 * ---------------------------------------------------- *)

lemma CircSpec_PreCircSpecC:
 "tl s ~= [] ==> $CircSpec s <=F $PreCircSpecC (hd s, toStb (map AttC (tl s))) -- range right"
apply (rule cspF_tr_left_ref2)
apply (rule CircSpec_PreCircSpecC_lm)
apply (simp)
apply (simp)
apply (cspF_simp)+
done

(* ---------------------------------------------------- *
 |                                                      |
 |               CircSpec s <=F CircChild s             |
 |                                                      |
 * ---------------------------------------------------- *)

theorem CircSpec_CircChild:
 "tl s ~= [] ==> $CircSpec s <=F CircChild s"
apply (insert list_nil_or_unnil)
apply (drule_tac x="s" in spec)
apply (elim disjE exE)
apply (simp)
apply (simp)
apply (rule cspF_tr_left_ref2)
apply (rule CircSpec_PreCircSpecC)
apply (simp)
apply (simp)

apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_tr_left_ref2)
apply (rule PreCircSpecC_PreCircChild)
apply (simp)
apply (simp)
done

(*********************************************************
               Eventually Stable spec
 *********************************************************)

datatype PNS = Stable "nat"

primrec
  PNSdef :: "PNS => (PNS, Event) proc"
where
 "PNSdef (Stable n) = left ! n -> $Stable n"
(*
defs (overloaded) Set_PNSfun_def [simp]: "PNfun == PNSdef"
*)

overloading Set_PNSdef ==
  "PNfun :: (PNS, Event) pnfun"
begin
  definition "PNfun == PNSdef"
end

declare Set_PNSdef_def [simp]

(* ------------------ *
      guardedness
 * ------------------ *)

lemma guardedfun_PNS[simp]:
      "guardedfun PNSdef"
by (simp add: guardedfun_def, rule allI, induct_tac p, auto)

primrec
  Unstable     :: "nat => (nat list) => (PNS, Event) proc"
where
  "Unstable      0  = (%s. SKIP)"
 |"Unstable (Suc n) = (%s. left ! (hd s div 2) -> Unstable n (circNext s))"

definition
  EventuallyStable :: "(nat list) => (PNS, Event) proc"
where
  EventuallyStable_def:
   "EventuallyStable s == (!nat N .. Unstable N s) ;;
                          (!nat n .. $Stable n)"

(* ----------------------------------------------- *
          eventually stable specification
 * ----------------------------------------------- *)

primrec
  EventuallyStable_to_CircSpec :: "nat => PNS => (PNR, Event) proc"
where
  "EventuallyStable_to_CircSpec l (Stable n)   =  $CircSpec (makeStableList l (2 * n))"

(* ---------- lemmas ---------- *)

lemma Unstable_CircSpec_lm:
  "ALL s. (tl s ~= [] & P <=F $CircSpec (circNexts N s))
     --> Unstable N s ;; P <=F $CircSpec s"
apply (induct_tac N)
apply (auto | cspF_auto)+
done

lemma Unstable_CircSpec:
  "[| tl s ~= [] ; P <=F $CircSpec (circNexts N s) |]
   ==> Unstable N s ;; P <=F $CircSpec s"
by (simp add: Unstable_CircSpec_lm)

lemma Stable_CircSpec:
 "[| Suc 0 < l ; s=makeStableList l (2*n) |] ==>
  $Stable n <=F (($CircSpec s)::(PNR, Event) proc)"
apply (rule cspF_fp_induct_left[of _ "EventuallyStable_to_CircSpec l"])
apply (simp)+

 apply (induct_tac p)
 apply (auto | cspF_auto)+
 apply (simp_all add: stable_circNext)
done

lemma EventuallyStable_CircSpec:
 "[| Suc 0 < length s ; allEven s |] ==> EventuallyStable s <=F $CircSpec s"
apply (subgoal_tac "s~=[] & tl s ~= []")
apply (simp add: EventuallyStable_def)
apply (cspF_hsf)+
apply (rule cspF_Rep_int_choice_left)
apply (insert circNexts_eventually_stable[of s], simp)
apply (erule exE)
apply (rule_tac x="N" in exI)
apply (rule Unstable_CircSpec)
apply (simp_all)

apply (rule cspF_Rep_int_choice_left)
apply (rule_tac x="hd (circNexts N s) div 2" in exI)
apply (simp)
apply (rule Stable_CircSpec[of "length s"])
apply (simp_all)
apply (simp add: makeStableList_hd_stableList)
apply (simp add: list_length_more_one)
done

(* -------------------------------------------- *

                  Finally ...

     for any number of children more than two
     and any initial number of candies,

 * -------------------------------------------- *)

theorem EventuallyStable_CircChild:
 "[| 1 < length s ; allEven s |]
  ==> EventuallyStable s <=F CircChild s"
apply (rule cspF_tr_left_ref2)
apply (rule EventuallyStable_CircSpec)
apply (simp_all)
apply (rule CircSpec_CircChild)
apply (simp add: list_length_more_one)
done

end


(*  Title:      RTS/JinjaSuppl/ClassesAbove.thy
    Author:    Susannah Mansky, UIUC 2020
*)

section "@{term classes_above} theory"

text "This section contains theory around the classes above
 (superclasses of) a class in the class structure, in particular
 noting that if their contents have not changed, then much of what
 that class sees (methods, fields) stays the same."

theory ClassesAbove
imports ClassesChanged Subcls JinjaDCI.Exceptions
begin

abbreviation classes_above :: "'m prog \<Rightarrow> cname \<Rightarrow> cname set" where
"classes_above P c \<equiv> { cn. P \<turnstile> c \<preceq>\<^sup>* cn }"

abbreviation classes_between :: "'m prog \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> cname set" where
"classes_between P c d \<equiv> { cn. (P \<turnstile> c \<preceq>\<^sup>* cn \<and> P \<turnstile> cn \<preceq>\<^sup>* d) }"

abbreviation classes_above_xcpts :: "'m prog \<Rightarrow> cname set" where
"classes_above_xcpts P \<equiv> \<Union>x\<in>sys_xcpts. classes_above P x"

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

lemma classes_above_def2:
 "P \<turnstile> C \<prec>\<^sup>1 D \<Longrightarrow> classes_above P C = {C} \<union> classes_above P D"
using subcls1_confluent by auto

lemma classes_above_class:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {}; P \<turnstile> C \<preceq>\<^sup>* C' \<rbrakk>
  \<Longrightarrow> class P C' = class P' C'"
 by (drule classes_changed_class_set, simp)

lemma classes_above_subset:
assumes "classes_above P C \<inter> classes_changed P P' = {}"
shows "classes_above P C \<subseteq> classes_above P' C"
proof -
  have ind: "\<And>x. P \<turnstile> C \<preceq>\<^sup>* x \<Longrightarrow> P' \<turnstile> C \<preceq>\<^sup>* x"
  proof -
    fix x assume sub: "P \<turnstile> C \<preceq>\<^sup>* x"
    then show "P' \<turnstile> C \<preceq>\<^sup>* x"
    proof(induct rule: rtrancl_induct)
      case base then show ?case by simp
    next
      case (step y z)
      have "P' \<turnstile> y \<prec>\<^sup>1 z" by(rule class_subcls1[OF classes_above_class[OF assms step(1)] step(2)])
      then show ?case using step(3) by simp
    qed
  qed
  with classes_changed_class_set[OF assms] show ?thesis by clarsimp
qed

lemma classes_above_subcls:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {}; P \<turnstile> C \<preceq>\<^sup>* C' \<rbrakk>
   \<Longrightarrow> P' \<turnstile> C \<preceq>\<^sup>* C'"
 by (fastforce dest: classes_above_subset)

lemma classes_above_subset2:
assumes "classes_above P C \<inter> classes_changed P P' = {}"
shows "classes_above P' C \<subseteq> classes_above P C"
proof -
  have ind: "\<And>x. P' \<turnstile> C \<preceq>\<^sup>* x \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* x"
  proof -
    fix x assume sub: "P' \<turnstile> C \<preceq>\<^sup>* x"
    then show "P \<turnstile> C \<preceq>\<^sup>* x"
    proof(induct rule: rtrancl_induct)
      case base then show ?case by simp
    next
      case (step y z)
      with class_subcls1 classes_above_class[OF assms] rtrancl_into_rtrancl show ?case by metis
    qed
  qed
  with classes_changed_class_set[OF assms] show ?thesis by clarsimp
qed

lemma classes_above_subcls2:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {}; P' \<turnstile> C \<preceq>\<^sup>* C' \<rbrakk>
   \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* C'"
 by (fastforce dest: classes_above_subset2)

lemma classes_above_set:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {} \<rbrakk>
  \<Longrightarrow> classes_above P C = classes_above P' C"
 by(fastforce dest: classes_above_subset classes_above_subset2)

lemma classes_above_classes_changed_sym:
assumes "classes_above P C \<inter> classes_changed P P' = {}"
shows "classes_above P' C \<inter> classes_changed P' P = {}"
proof -
  have "classes_above P C = classes_above P' C" by(rule classes_above_set[OF assms])
  with classes_changed_sym[where P=P] assms show ?thesis by simp
qed

lemma classes_above_sub_classes_between_eq:
 "P \<turnstile> C \<preceq>\<^sup>* D \<Longrightarrow> classes_above P C = (classes_between P C D - {D}) \<union> classes_above P D"
using subcls_confluent by auto

lemma classes_above_subcls_subset:
 "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* C' \<rbrakk> \<Longrightarrow> classes_above P C' \<subseteq> classes_above P C"
 by auto

(************************************************************)
subsection "Methods"

lemma classes_above_sees_methods:
assumes int: "classes_above P C \<inter> classes_changed P P' = {}" and ms: "P \<turnstile> C sees_methods Mm"
shows "P' \<turnstile> C sees_methods Mm"
proof -
  have cls: "\<forall>C'\<in>classes_above P C. class P C' = class P' C'"
   by(rule classes_changed_class_set[OF int])

  have "\<And>C Mm. P \<turnstile> C sees_methods Mm \<Longrightarrow>
               \<forall>C'\<in>classes_above P C. class P C' = class P' C' \<Longrightarrow> P' \<turnstile> C sees_methods Mm"
  proof -
    fix C Mm assume "P \<turnstile> C sees_methods Mm" and "\<forall>C'\<in>classes_above P C. class P C' = class P' C'"
    then show "P' \<turnstile> C sees_methods Mm"
    proof(induct rule: Methods.induct)
      case Obj: (sees_methods_Object D fs ms Mm)
      with cls have "class P' Object = \<lfloor>(D, fs, ms)\<rfloor>" by simp
      with Obj show ?case by(auto intro!: sees_methods_Object)
    next
      case rec: (sees_methods_rec C D fs ms Mm Mm')
      then have "P \<turnstile> C \<preceq>\<^sup>* D" by (simp add: r_into_rtrancl[OF subcls1I])
      with converse_rtrancl_into_rtrancl have "\<And>x. P \<turnstile> D \<preceq>\<^sup>* x \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* x" by simp
      with rec.prems(1) have "\<forall>C'\<in>classes_above P D. class P C' = class P' C'" by simp
      with rec show ?case by(auto intro: sees_methods_rec)
    qed
  qed
  with ms cls show ?thesis by simp
qed

lemma classes_above_sees_method:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {};
     P \<turnstile> C sees M,b: Ts\<rightarrow>T = m in C' \<rbrakk>
  \<Longrightarrow> P' \<turnstile> C sees M,b: Ts\<rightarrow>T = m in C'"
 by (auto dest: classes_above_sees_methods simp: Method_def)

lemma classes_above_sees_method2:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {};
     P' \<turnstile> C sees M,b: Ts\<rightarrow>T = m in C' \<rbrakk>
  \<Longrightarrow> P \<turnstile> C sees M,b: Ts\<rightarrow>T = m in C'"
 by (auto dest: classes_above_classes_changed_sym intro: classes_above_sees_method)

lemma classes_above_method:
assumes "classes_above P C \<inter> classes_changed P P' = {}"
shows "method P C M = method P' C M"
proof(cases "\<exists>Ts T m D b. P \<turnstile> C sees M,b :  Ts\<rightarrow>T = m in D")
  case True
  with assms show ?thesis by (auto dest: classes_above_sees_method)
next
  case False
  with assms have "\<not>(\<exists>Ts T m D b. P' \<turnstile> C sees M,b :  Ts\<rightarrow>T = m in D)"
    by (auto dest: classes_above_sees_method2)
  with False show ?thesis by(simp add: method_def)
qed

(*********************************************)
subsection "Fields"

lemma classes_above_has_fields:
assumes int: "classes_above P C \<inter> classes_changed P P' = {}" and fs: "P \<turnstile> C has_fields FDTs"
shows "P' \<turnstile> C has_fields FDTs"
proof -
  have cls: "\<forall>C'\<in>classes_above P C. class P C' = class P' C'"
   by(rule classes_changed_class_set[OF int])

  have "\<And>C Mm. P \<turnstile> C has_fields FDTs \<Longrightarrow>
               \<forall>C'\<in>classes_above P C. class P C' = class P' C' \<Longrightarrow> P' \<turnstile> C has_fields FDTs"
  proof -
    fix C Mm assume "P \<turnstile> C has_fields FDTs" and "\<forall>C'\<in>classes_above P C. class P C' = class P' C'"
    then show "P' \<turnstile> C has_fields FDTs"
    proof(induct rule: Fields.induct)
      case Obj: (has_fields_Object D fs ms FDTs)
      with cls have "class P' Object = \<lfloor>(D, fs, ms)\<rfloor>" by simp
      with Obj show ?case by(auto intro!: has_fields_Object)
    next
      case rec: (has_fields_rec C D fs ms FDTs FDTs')
      then have "P \<turnstile> C \<preceq>\<^sup>* D" by (simp add: r_into_rtrancl[OF subcls1I])
      with converse_rtrancl_into_rtrancl have "\<And>x. P \<turnstile> D \<preceq>\<^sup>* x \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* x" by simp
      with rec.prems(1) have "\<forall>x. P \<turnstile> D \<preceq>\<^sup>* x \<longrightarrow> class P x = class P' x" by simp
      with rec show ?case by(auto intro: has_fields_rec)
    qed
  qed
  with fs cls show ?thesis by simp
qed

lemma classes_above_has_fields_dne:
assumes "classes_above P C \<inter> classes_changed P P' = {}"
shows "(\<forall>FDTs. \<not> P \<turnstile> C has_fields FDTs) = (\<forall>FDTs. \<not> P' \<turnstile> C has_fields FDTs)"
proof(rule iffI)
  assume asm: "\<forall>FDTs. \<not> P \<turnstile> C has_fields FDTs"
  from assms classes_changed_sym[where P=P] classes_above_set[OF assms]
   have int': "classes_above P' C \<inter> classes_changed P' P = {}" by simp
  from asm classes_above_has_fields[OF int'] show "\<forall>FDTs. \<not> P' \<turnstile> C has_fields FDTs" by auto
next
  assume "\<forall>FDTs. \<not> P' \<turnstile> C has_fields FDTs"
  with assms show "\<forall>FDTs. \<not> P \<turnstile> C has_fields FDTs" by(auto dest: classes_above_has_fields)
qed

lemma classes_above_has_field:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {};
    P \<turnstile> C has F,b:t in C' \<rbrakk>
   \<Longrightarrow> P' \<turnstile> C has F,b:t in C'"
 by(auto dest: classes_above_has_fields simp: has_field_def)

lemma classes_above_has_field2:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {};
     P' \<turnstile> C has F,b:t in C' \<rbrakk>
  \<Longrightarrow> P \<turnstile> C has F,b:t in C'"
 by(auto intro: classes_above_has_field dest: classes_above_classes_changed_sym)

lemma classes_above_sees_field:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {};
    P \<turnstile> C sees F,b:t in C' \<rbrakk>
   \<Longrightarrow> P' \<turnstile> C sees F,b:t in C'"
 by(auto dest: classes_above_has_fields simp: sees_field_def)

lemma classes_above_sees_field2:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {};
     P' \<turnstile> C sees F,b:t in C' \<rbrakk>
  \<Longrightarrow> P \<turnstile> C sees F,b:t in C'"
 by (auto intro: classes_above_sees_field dest: classes_above_classes_changed_sym)

lemma classes_above_field:
assumes "classes_above P C \<inter> classes_changed P P' = {}"
shows "field P C F = field P' C F"
proof(cases "\<exists>T D b. P \<turnstile> C sees F,b : T in D")
  case True
  with assms show ?thesis by (auto dest: classes_above_sees_field)
next
  case False
  with assms have "\<not>(\<exists>T D b. P' \<turnstile> C sees F,b : T in D)"
    by (auto dest: classes_above_sees_field2)
  with False show ?thesis by(simp add: field_def)
qed

lemma classes_above_fields:
assumes "classes_above P C \<inter> classes_changed P P' = {}"
shows "fields P C = fields P' C"
proof(cases "\<exists>FDTs. P \<turnstile> C has_fields FDTs")
  case True
  with assms show ?thesis by(auto dest: classes_above_has_fields)
next
  case False
  with assms show ?thesis by (auto dest: classes_above_has_fields_dne simp: fields_def)
qed

lemma classes_above_ifields:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {} \<rbrakk>
 \<Longrightarrow>
  ifields P C = ifields P' C"
 by (simp add: ifields_def classes_above_fields)

lemma classes_above_blank:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {} \<rbrakk>
 \<Longrightarrow>
  blank P C = blank P' C"
 by (simp add: blank_def classes_above_ifields)

lemma classes_above_isfields:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {} \<rbrakk>
 \<Longrightarrow>
  isfields P C = isfields P' C"
 by (simp add: isfields_def classes_above_fields)

lemma classes_above_sblank:
 "\<lbrakk> classes_above P C \<inter> classes_changed P P' = {} \<rbrakk>
 \<Longrightarrow>
  sblank P C = sblank P' C"
 by (simp add: sblank_def classes_above_isfields)

(******************************************)
subsection "Other"

lemma classes_above_start_heap:
assumes "classes_above_xcpts P \<inter> classes_changed P P' = {}"
shows "start_heap P = start_heap P'"
proof -
  from assms have "\<forall>C \<in> sys_xcpts. blank P C = blank P' C" by (auto intro: classes_above_blank)
  then show ?thesis by(simp add: start_heap_def)
qed

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |                 August 2005 (modified)    |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_surj
imports CSP_F_domain CSP_T.CSP_T_surj
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*********************************************************
            inverse function : DomT => proc
 *********************************************************)

definition
  head_failures :: "'a setF => 'a set"
  where
  head_failures_def :
  "head_failures F == {a. EX t X. (<Ev a> ^^^ t, X) :f F}"

definition
  tail_failures :: "'a setF => 'a => 'a setF"
  where
  tail_failures_def :
  "tail_failures F == (%a. {(t,X). (<Ev a> ^^^ t, X) :f F}f)"

primrec
  Proc_F_rec   :: "nat => 'a domF => ('p,'a) proc"
where
  "Proc_F_rec 0 = (%SF. !set X:{X. EX Y. (<>,Y) :f sndF SF &
                                  Ev ` X = Evset - Y & Tick : Y &
                                  (ALL a:X. <Ev a> :t fstF SF)} ..
                        (? x:X -> DIV))"
 |"Proc_F_rec (Suc n)
     = (%SF. (! a:(head_failures (sndF SF)) .. a ->
              Proc_F_rec n (tail_traces (fstF SF) a ,,
                           tail_failures (sndF SF) a)) [+] DIV)"
definition
  Proc_F    :: "'a domF => ('p,'a) proc"
  where
  Proc_F_def :
   "Proc_F SF == Proc_T (fstF SF) |~| (!nat n .. Proc_F_rec n SF)"

(*********************************************************
                     lemmas
 *********************************************************)

(* tail in setF *)

lemma tail_failures_setF: "{(t,X). (<Ev a> ^^^ t, X) :f F} : setF"
apply (simp add: setF_def)
apply (simp add: HC_F2_def)
apply (intro allI impI)
apply (rule memF_F2)
by (auto)

(* tail *)

lemma in_tail_failures:
  "((s,X) :f tail_failures F a) = ((<Ev a> ^^^ s, X) :f F)"
apply (simp add: tail_failures_def)
apply (simp add: tail_failures_setF CollectF_open_memF)
done

(* head & tail *)

lemma head_tail_failures_only_if:
   "(<Ev a> ^^^ s, X) :f F ==> a : head_failures F & (s,X) :f tail_failures F a"
apply (simp add: in_tail_failures)
apply (auto simp add: head_failures_def)
done

(* iff *)

lemma head_tail_failures:
   "(<Ev a> ^^^ s, X) :f F = (a : head_failures F & (s,X) :f tail_failures F a)"
apply (rule iffI)
apply (simp add: head_tail_failures_only_if)
apply (simp add: in_tail_failures)
done

(*** domF ***)

(* head *)

lemma head_failures_traces:
  "a : head_failures (sndF SF) ==> a : head_traces (fstF SF)"
apply (simp add: head_failures_def)
apply (simp add: head_traces_def)
apply (elim exE)
apply (rule_tac x="t" in exI)
apply (simp add: pairF_domF_T2)
done

(* T2 *)

lemma tail_traces_failures_T2:
  "HC_T2 (tail_traces (fstF SF) a , tail_failures (sndF SF) a)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim exE)
apply (simp add: in_tail_failures)
apply (subgoal_tac "a : head_traces (fstF SF)")
apply (simp add: in_tail_traces)
apply (simp add: pairF_domF_T2)

apply (simp add: head_tail_failures)
apply (simp add: head_failures_traces)
done

(* F3 *)

lemma tail_traces_failures_F3:
  "a : head_traces (fstF SF) ==>
   HC_F3 (tail_traces (fstF SF) a , tail_failures (sndF SF) a)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE)

apply (simp add: in_tail_failures)
apply (simp add: in_tail_traces)
apply (rule pairF_domF_F3)
apply (simp)
apply (simp)
apply (simp add: appt_assoc_sym)
done

(* T3_F4 *)

lemma tail_traces_failures_T3_F4:
  "a : head_traces (fstF SF) ==>
   HC_T3_F4 (tail_traces (fstF SF) a , tail_failures (sndF SF) a)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE)

apply (simp add: in_tail_failures)
apply (simp add: in_tail_traces)
apply (simp add: appt_assoc_sym)
apply (simp add: pairF_domF_F4)
apply (simp add: pairF_domF_T3)
done

lemma tail_traces_failures_domF:
  "a : head_traces (fstF SF) | a : head_failures (sndF SF)
   ==> (tail_traces (fstF SF) a , tail_failures (sndF SF) a) : domF"
apply (simp add: domF_iff)
apply (subgoal_tac "a : head_traces (fstF SF)")
apply (simp add: tail_traces_failures_T2)
apply (simp add: tail_traces_failures_F3)
apply (simp add: tail_traces_failures_T3_F4)
apply (auto simp add: head_failures_traces)
done

(*-------------------------------------*
 |   failures (Proc_T_rec n) --> Tick  |
 *-------------------------------------*)

lemma failures_Proc_T_rec_noTick_lm:
  "ALL s T. ((s, X) :f failures (Proc_T_rec n T) M & noTick s)
   --> (EX t. s ^^^ t ^^^ <Tick> :t T & noTick t)"
apply (induct_tac n)

(* base *)
 apply (simp add: in_traces)
 apply (simp add: in_failures)

(* step *)
 apply (intro allI impI)
 apply (simp add: in_failures)
 apply (elim conjE exE disjE bexE)
 apply (simp_all)

  apply (drule_tac x="sa" in spec)
  apply (drule_tac x="(tail_traces T a)" in spec)
  apply (simp)
  apply (elim conjE exE)
  apply (rule_tac x="t" in exI)
  apply (simp add: appt_assoc)
  apply (simp add: head_tail_traces)

  apply (simp add: in_traces)
  apply (simp add: in_traces)

  apply (case_tac "<Tick> :t T")

   apply (simp add: in_failures)
   apply (erule disjE)
    apply (rule_tac x="<>" in exI)
    apply (simp)
    apply (simp)

   apply (simp add: in_failures)
done

lemma failures_Proc_T_rec_noTick:
  "[| (s, X) :f failures (Proc_T_rec n T) M ; noTick s|]
   ==> (EX t. s ^^^ t ^^^ <Tick> :t T & noTick t)"
by (simp add: failures_Proc_T_rec_noTick_lm)

lemma failures_Proc_T_rec_lm:
  "ALL s T. ((s, X) :f failures (Proc_T_rec n T) M)
   --> s :t T"
apply (induct_tac n)

(* base *)
 apply (simp add: in_traces)
 apply (simp add: in_failures)

(* step *)
 apply (intro allI impI)
 apply (simp add: in_failures)
 apply (elim conjE exE disjE bexE)
 apply (simp_all)

  apply (drule_tac x="sa" in spec)
  apply (drule_tac x="(tail_traces T a)" in spec)
  apply (simp add: head_tail_traces)

  apply (case_tac "<Tick> :t T")
  apply (auto simp add: in_failures)
done

lemma failures_Proc_T_rec:
  "(s, X) :f failures (Proc_T_rec n T) M ==> s :t T"
by (simp add: failures_Proc_T_rec_lm)

lemma failures_Proc_T_rec_T3:
  "[| (s, X) :f failures (Proc_T_rec n (fstF SF)) M ; noTick s |]
   ==> (EX t. (s ^^^ t ^^^ <Tick>,Y) :f (sndF SF) & noTick t)"
apply (insert failures_Proc_T_rec_noTick_lm[of X n M])
apply (drule_tac x="s" in spec)
apply (drule_tac x="fstF SF" in spec)
apply (simp)
apply (elim conjE exE)
apply (rule_tac x="t" in exI)
apply (simp)
apply (simp add: appt_assoc_sym)
apply (simp add: pairF_domF_T3)
done

(*** head T --> head F **)

lemma head_traces_failures_noTick:
  "[| a : head_traces (fstF SF);
     (s, X) :f failures (Proc_T_rec n (tail_traces (fstF SF) a)) M; noTick s|]
   ==> a : head_failures (sndF SF)"
apply (insert failures_Proc_T_rec_noTick_lm[of X n M])
apply (drule_tac x="s" in spec)
apply (drule_tac x="tail_traces (fstF SF) a" in spec)
apply (simp)
apply (elim conjE exE)
apply (simp add: in_tail_traces)

apply (simp add: head_failures_def)
apply (rule_tac x="s ^^^ t ^^^ <Tick>" in exI)
apply (rule_tac x="X" in exI)
apply (simp add: appt_assoc_sym)
apply (simp add: pairF_domF_T3)
done

(*** head_traces_failures ***)

lemma head_traces_failures:  (* not used *)
  "[| a : head_traces (fstF SF);
     (s, X) :f failures (Proc_T_rec n (tail_traces (fstF SF) a)) M |]
   ==> a : head_failures (sndF SF)"
apply (case_tac "noTick s")
apply (simp add: head_traces_failures_noTick)
apply (simp add: noTick_def)

apply (simp add: Tick_in_sett)
apply (elim conjE exE)

apply (insert failures_Proc_T_rec_lm[of X n M])
apply (drule_tac x="s" in spec)
apply (drule_tac x="tail_traces (fstF SF) a" in spec)

apply (simp add: in_tail_traces)
apply (simp add: appt_assoc_sym)

apply (simp add: head_failures_def)
apply (rule_tac x="t ^^^ <Tick>" in exI)
apply (rule_tac x="X" in exI)
apply (simp add: appt_assoc_sym)
apply (simp add: pairF_domF_T3)
done

(*----------------------------*
 |         Proc_T lemma       |
 *----------------------------*)

(* traces(Proc_F_rec) => fst SF (lm) *)

lemma Proc_F_to_T_lm:
   "ALL SF t. t :t traces (Proc_F_rec n SF) M --> t :t fstF SF"
apply (induct_tac n)

(* base *)
 apply (simp add: in_traces)
 apply (intro allI impI)
 apply (elim conjE exE)

 apply (erule disjE, simp)
 apply (elim conjE exE)
 apply (simp)

(* step *)
 apply (intro allI impI)
 apply (simp add: in_traces)
 apply (elim conjE exE disjE bexE)
 apply (simp_all)
 apply (drule_tac x="(tail_traces (fstF SF) a ,, tail_failures (sndF SF) a)" in spec)
 apply (drule_tac x="s" in spec)
 apply (simp)
 apply (simp add: tail_traces_failures_domF pairF_fstF)
 apply (simp add: in_tail_traces head_failures_traces)
done

(* traces(Proc_F_rec) => fst SF *)

lemma Proc_F_to_T:
   "t :t traces (Proc_F_rec n SF) M ==> t :t fstF SF"
by (simp add: Proc_F_to_T_lm)

(* traces(Proc_F_rec) => fst SF (lm) *)

lemma Proc_T_to_F_lm:
   "ALL SF s X.
    (s, X) :f failures (Proc_T_rec n (fstF SF)) M --> (s, X) :f sndF SF"
apply (induct_tac n)

(* base *)
 apply (simp add: in_failures)

(* step *)
 apply (intro allI impI)
 apply (simp add: in_failures)
 apply (elim conjE exE disjE bexE)
 apply (simp_all)

  apply (drule_tac x="(tail_traces (fstF SF) a ,, tail_failures (sndF SF) a)" in spec)
  apply (drule_tac x="sa" in spec)
  apply (drule_tac x="X" in spec)
  apply (simp add: tail_traces_failures_domF pairF_fstF)
  apply (simp add: tail_traces_failures_domF pairF_sndF)
  apply (simp add: in_tail_failures)

  apply (simp add: in_traces)
  apply (simp add: in_traces)

  apply (case_tac "<Tick> :t fstF SF")
   apply (simp add: in_failures)
   apply (erule disjE)
    apply (simp add: pairF_domF_F2_F4)
    apply (simp add: pairF_domF_T3_Tick)

  apply (simp add: in_failures)
done

(* traces(Proc_F_rec) => fst SF *)

lemma Proc_T_to_F:
  "(s, X) :f failures (Proc_T_rec n (fstF SF)) M ==> (s, X) :f sndF SF"
by (simp add: Proc_T_to_F_lm)

(* failures(Proc_F_rec) => snd SF (lm) *)

lemma Proc_F_to_F_lm:
   "ALL SF s X. (s, X) :f failures (Proc_F_rec n SF) M --> (s, X) :f sndF SF"
apply (induct_tac n)

(* base *)
 apply (simp add: in_failures)
 apply (intro allI impI)
 apply (elim conjE exE)
 apply (rule memF_F2)
 apply (simp)
 apply (simp add: Evset_def)
 apply (blast)

(* step *)
 apply (intro allI impI)
 apply (simp add: in_failures)

 apply (elim conjE exE bexE disjE)
 apply (simp_all)

  apply (drule_tac x="(tail_traces (fstF SF) a ,, tail_failures (sndF SF) a)" in spec)
  apply (drule_tac x="sa" in spec)
  apply (drule_tac x="X" in spec)
  apply (simp add: tail_traces_failures_domF pairF_fstF)
  apply (simp add: tail_traces_failures_domF pairF_sndF)
  apply (simp add: head_tail_failures)

  apply (simp add: in_traces)
  apply (simp add: in_traces)
done

lemma Proc_F_to_F:
   "(s, X) :f failures (Proc_F_rec n SF) M ==> (s, X) :f sndF SF"
by (simp add: Proc_F_to_F_lm)

(* sndF SF => failures (Proc_F_rec) lm *)

lemma F_Proc_F_lm:
   "ALL SF X. ((s, X) :f sndF SF & noTick s & (Tick : X | s ^^^ <Tick> ~:t fstF SF))
             --> (s, X) :f failures (Proc_F_rec (lengtht s) SF) M"
apply (induct_tac s rule: induct_trace)

 (* <> *)
 apply (intro allI impI)
 apply (simp add: in_failures)
 apply (rule_tac x="{a. Ev a ~: X & <Ev a> :t fstF SF}" in exI)
 apply (rule)

  apply (elim conjE)
  apply (erule disjE)

   (* Tick : X *)
   apply (rule_tac x="X Un {(Ev a)|a. <Ev a> ~:t fstF SF}" in exI)
   apply (simp)
   apply (rule)

    apply (rule pairF_domF_F3)
     apply (simp)
     apply (simp)
     apply (force)
    apply (simp add: Evset_def not_Tick_to_Ev)
    apply (force)

   (* <Tick> ~:t fstF SF *)
   apply (rule_tac x="X Un ({Tick} Un {(Ev a)|a. <Ev a> ~:t fstF SF})" in exI)
   apply (rule)

    apply (rule pairF_domF_F3)
     apply (simp)
     apply (simp)
     apply (force)

    apply (simp add: Evset_def not_Tick_to_Ev)
    apply (force)
    apply (force)

 (* <Tick> *)
 apply (simp)

 (* <Ev a> ^^^ s *)
 apply (intro allI impI)
 apply (simp add: in_failures)
 apply (simp add: head_tail_failures)

 apply (drule_tac x="(tail_traces (fstF SF) a ,, tail_failures (sndF SF) a)" in spec)
 apply (drule_tac x="X" in spec)
 apply (simp add: tail_traces_failures_domF pairF_fstF pairF_sndF)
 apply (elim conjE exE disjE)
 apply (simp)

 apply (simp add: appt_assoc)
 apply (simp add: head_failures_traces head_tail_traces)
done

(* sndF SF => failures (Proc_F_rec) *)

lemma F_Proc_F:
   "[| (s, X) :f sndF SF ; noTick s ; Tick : X | s ^^^ <Tick> ~:t fstF SF |]
    ==> (s, X) :f failures (Proc_F_rec (lengtht s) SF) M"
by (simp add: F_Proc_F_lm)

(* sndF SF => failures (Proc_T_rec) (noTick) lm *)

declare lengtht_app_event_Suc_head [simp del]
declare lengtht_app_decompo1       [simp del]
declare lengtht_app_decompo2       [simp del]
declare Proc_T_rec.simps            [simp del]

lemma F_Proc_T_noTick_lm:
   "ALL SF X. (s, X) :f sndF SF & noTick s & Tick ~: X & s ^^^ <Tick> :t fstF SF
    --> (s, X) :f failures (Proc_T_rec (Suc (lengtht s)) (fstF SF)) M"
apply (induct_tac s rule: induct_trace)

 (* <> *)
 apply (intro allI impI)
 apply (simp add: Proc_T_rec.simps in_failures)
 apply (simp add: Evset_def)
 apply (fast)

 (* <Tick> *)
 apply (intro allI impI)
 apply (simp add: Proc_T_rec.simps in_failures)

 (* <Ev a> ^^^ s *)
 apply (intro allI impI)
 apply (simp (no_asm) add: Proc_T_rec.simps)
 apply (simp add: in_failures)
 apply (elim conjE)
 apply (simp add: appt_assoc)
 apply (simp add: head_tail_traces)

 apply (drule_tac x="(tail_traces (fstF SF) a ,, tail_failures (sndF SF) a)" in spec)
 apply (drule_tac x="X" in spec)
 apply (simp)
 apply (elim conjE)
 apply (simp add: tail_traces_failures_domF pairF_fstF pairF_sndF)
 apply (simp add: head_tail_failures)
 apply (simp add: lengtht_app_event_Suc_head)
done

(* sndF SF => failures (Proc_T_rec) noTick *)

lemma F_Proc_T_noTick:
   "[| (s, X) :f sndF SF ; noTick s ; Tick ~: X ; s ^^^ <Tick> :t fstF SF |]
    ==> (s, X) :f failures (Proc_T_rec (Suc (lengtht s)) (fstF SF)) M"
by (simp add: F_Proc_T_noTick_lm)

declare lengtht_app_event_Suc_head [simp]
declare lengtht_app_decompo1       [simp]
declare lengtht_app_decompo2       [simp]
declare Proc_T_rec.simps            [simp]

(* sndF SF => failures (Proc_T_rec) (Tick) lm *)

lemma F_Proc_T_Tick_lm:
   "ALL SF X. ((s, X) :f sndF SF & ~ noTick s)
    --> (s, X) :f failures (Proc_T_rec (lengtht s) (fstF SF)) M"
apply (induct_tac s rule: induct_trace)

 (* <> *)
 apply (intro allI impI)
 apply (simp add: in_failures)

 (* <Tick> *)
 apply (intro allI impI)
 apply (simp add: in_failures)
 apply (simp add: pairF_domF_T2)

 (* <Ev a> ^^^ s *)
 apply (intro allI impI)
 apply (simp add: in_failures)
 apply (elim conjE)
 apply (simp add: head_tail_failures)

 apply (drule_tac x="(tail_traces (fstF SF) a ,, tail_failures (sndF SF) a)" in spec)
 apply (drule_tac x="X" in spec)
 apply (simp add: tail_traces_failures_domF pairF_fstF pairF_sndF)
 apply (elim conjE)
 apply (simp add: head_failures_traces)
done

(* sndF SF => failures (Proc_T_rec) noTick *)

lemma F_Proc_T_Tick:
   "[| (s, X) :f sndF SF; ~ noTick s |]
           ==> (s, X) :f failures (Proc_T_rec (lengtht s) (fstF SF)) M"
by (simp add: F_Proc_T_Tick_lm)

(*==================================================*
 |                Proc_F lemma (main)               |
 *==================================================*)

lemma semF_Proc_F: "[[ Proc_F SF ]]Ff M = SF"
apply (simp add: Proc_F_def)
apply (rule order_antisym)

 (* <= *)
 apply (simp add: subdomF_decompo)
 apply (rule conjI)

  (* Proc <= fstF SF *)
  apply (rule)
  apply (simp add: in_traces)
  apply (simp add: semT_Proc_T[simplified semTf_def])
  apply (erule disjE, simp)
  apply (erule disjE, simp)
  apply (elim conjE exE)
  apply (simp add: Proc_F_to_T)

  (* Proc <= sndF SF *)
  apply (rule)
  apply (simp add: in_failures)
  apply (erule disjE)

   (* Proc T <= sndF SF *)
   apply (simp add: Proc_T_def)
   apply (simp add: in_failures)
   apply (erule exE)
   apply (simp add: Proc_T_to_F)

   (* Proc F <= sndF SF *)
   apply (erule exE)
   apply (simp add: Proc_F_to_F)

 (* <= *)
 apply (simp add: subdomF_decompo)
 apply (rule conjI)

  (* fstF SF <= Proc *)
  apply (rule)
  apply (simp add: in_traces)
  apply (simp add: semT_Proc_T[simplified semTf_def])

  (* sndF SF <= Proc *)
  apply (rule)
  apply (simp add: in_failures)
  apply (case_tac "noTick s & (Tick : X | s ^^^ <Tick> ~:t fstF SF)")
   apply (rule disjI2)
   apply (rule_tac x="lengtht s" in exI)
   apply (simp add: F_Proc_F)

   apply (simp)
   apply (rule disjI1)
   apply (simp add: Proc_T_def)
   apply (simp add: in_failures)
   apply (case_tac "noTick s")

    (* noTick s & s ^^^ <Tick> :t fstF SF *)
    apply (simp)
    apply (rule_tac x="Suc (lengtht s)" in exI)
    apply (simp add: F_Proc_T_noTick del: Proc_T_rec.simps)

    (* ~ noTick s *)
    apply (rule_tac x="lengtht s" in exI)
    apply (simp add: F_Proc_T_Tick)
done

(*----------------------------*
 |   [[ ]]F is surjective     |
 *----------------------------*)

theorem EX_proc_domF: "ALL SF. EX P::('p,'a) proc. [[P]]F = SF"
apply (rule allI)
apply (rule_tac x="Proc_F SF" in exI)
apply (simp add: semF_def semF_Proc_F)
done

theorem surj_domF: "surj (%P::('p,'a) proc. [[P]]F)"
apply (simp add: surj_def)
apply (rule allI)
apply (rule_tac x="Proc_F y" in exI)
apply (simp add: semF_def semF_Proc_F)
done

(*----------------------------*
 |   failures and Proc_F SF   |
 *----------------------------*)

lemma failures_Proc_F: "failures (Proc_F SF) M = sndF SF"
apply (insert semF_Proc_F[of SF M])
apply (simp add: semFf_def)
apply (simp add: eqF_decompo)
done

(*----------------------------*
 |    traces and Proc_F SF    |
 *----------------------------*)

lemma make_failures_from_T:
  "(T , failures (Proc_T T) M) : domF"
apply (subgoal_tac
  "(traces (Proc_T T) (fstF o M) , failures (Proc_T T) M) : domF")
apply (simp only: traces_Proc_T)
apply (simp)
done

lemma traces_Proc_F: "traces ((Proc_F SF)::('p,'a) proc) M = fstF SF"
apply (insert semF_Proc_F[of SF
  "(%p. (traces ((Proc_T (M p))::('p,'a) proc) (fstF o M'),,failures(Proc_T (M p)) M'))"])
apply (simp add: semFf_def)
apply (simp add: eqF_decompo)
apply (simp add: fstF_proc_domF_fun)
apply (simp add: traces_Proc_T)
done

lemma traces_Proc_T_F:
  "traces (Proc_T (fstF SF)) M = traces (Proc_F SF) M"
apply (simp add: traces_Proc_T)
apply (simp add: traces_Proc_F)
done

(*==========================================================*
 |                                                          |
 |              Generic Internal Choice                     |
 |                                                          |
 *==========================================================*)

definition
  Gen_int_choice_F_plus ::
    "('p,'a) proc set => ('p,'a) proc"    ("(1|~~|F _)" [900] 68)
  where
  Gen_int_choice_F_plus_def:
        "|~~|F Ps == Proc_F( (UnionT {(traces(P) (fstF o MF))|P. P:Ps},,
                              UnionF {(failures(P) MF) |P. P:Ps}))"

(* lemmas *)

lemma traces_Gen_int_choice_F_plus:
   "Ps ~= {} ==> traces ( |~~|F Ps ) M = (UnionT {(traces(P) (fstF o MF)) |P. P:Ps})"
apply (simp add: Gen_int_choice_F_plus_def)
apply (simp add: traces_Proc_F)
apply (simp add: pairF non_empty_UnionT_UnionF_domF)
done

lemma failures_Gen_int_choice_F_plus:
   "Ps ~= {} ==> failures ( |~~|F Ps ) M = (UnionF {(failures(P) MF) |P. P:Ps})"
apply (simp add: Gen_int_choice_F_plus_def)
apply (simp add: failures_Proc_F)
apply (simp add: pairF non_empty_UnionT_UnionF_domF)
done

lemma semF_Gen_int_choice_F_plus:
   "Ps ~= {} ==> [[ |~~|F Ps ]]F =
                 (UnionT {(traces(P) (fstF o MF)) |P. P:Ps}  ,,
                 (UnionF {(failures(P) MF) |P. P:Ps}))"
apply (simp add: semF_def semFf_def)
apply (simp add: traces_Gen_int_choice_F_plus failures_Gen_int_choice_F_plus)
done

lemma in_traces_Gen_int_choice_F_plus:
   "Ps ~= {} ==> t :t traces ( |~~|F Ps ) M = (EX P:Ps. t :t traces(P) (fstF o MF))"
apply (simp add: traces_Gen_int_choice_F_plus)
apply (subgoal_tac "{(traces P) |P. P : Ps} ~= {}")
apply (auto)
done

lemma in_failures_Gen_int_choice_F_plus:
   "Ps ~= {} ==> f :f failures ( |~~|F Ps ) M = (EX P:Ps. f :f failures(P) MF)"
apply (simp add: failures_Gen_int_choice_F_plus)
apply (subgoal_tac "{(traces P) |P. P : Ps} ~= {}")
apply (auto)
done

(****************** to add them again ******************)

declare disj_not1   [simp]

end


(*  Title:       Jive Data and Store Model
    Author:      Norbert Schirmer <schirmer at informatik.tu-muenchen.de>  and
                 Nicole Rauch <rauch at informatik.uni-kl.de>, 2005
    Maintainer:  Nicole Rauch <rauch at informatik.uni-kl.de>
    License:     LGPL
*)

header {* The Direct Subtype Relation of Java Types *}

theory DirectSubtypes
imports "../Isabelle/JavaType"
begin

text {*
In this theory, we formalize the direct subtype relations of the Java types (as defined
in Sec. \ref{java_typeid_definitions}) that appear in the program to be verified. Thus, this
theory has to be generated for each program.
\label{direct_subtype_relations}
*}

text {* We have the following type hierarchy:
\begin{center}
\includegraphics[width=13cm]{TypeHierarchy}
\end{center}
We need to describe all direct subtype relations of this  type hierarchy.
As you can see in the picture, all unnecessary direct subtype relations can be
ignored, e.g. the subclass relation between CounterImpl and Object, because it is
added
transitively by the widening relation of types (see Sec. \ref{widening_subtypes}).
*}

text {*
We have to specify the direct subtype relation between
\begin{itemize}
\item each ``leaf'' class or interface and its subtype \texttt{NullT}
\item each ``root'' class or interface and its supertype \texttt{Object}
\item each two types that are direct subtypes as specified in the code by
\texttt{extends} or \texttt{implements}
\item each array type of a primitive type and its subtype \texttt{NullT}
\item each array type of a primitive type and its supertype \texttt{Object}
\item each array type of a ``leaf'' class or interface and its subtype \texttt{NullT}
\item the array type \texttt{Object[]} and its supertype \texttt{Object}
\item two array types if their element types are in a subtype hierarchy
\end{itemize}
*}

definition direct_subtype :: "(Javatype * Javatype) set" where
"direct_subtype =
{ (NullT, AClassT Dummy),
  (NullT, CClassT UndoCounter),
  (NullT, CClassT NullPointerException),
  (NullT, CClassT ClassCastException),

  (AClassT Dummy, CClassT Object),
  (InterfaceT Counter, CClassT Object),
  (CClassT Exception, CClassT Object),

  (CClassT UndoCounter, CClassT CounterImpl),
  (CClassT CounterImpl, InterfaceT Counter),
  (CClassT NullPointerException, CClassT Exception),
  (CClassT ClassCastException, CClassT Exception),

  (NullT, ArrT BoolAT),
  (NullT, ArrT IntgAT),
  (NullT, ArrT ShortAT),
  (NullT, ArrT ByteAT),
  (ArrT BoolAT,  CClassT Object),
  (ArrT IntgAT,  CClassT Object),
  (ArrT ShortAT, CClassT Object),
  (ArrT ByteAT,  CClassT Object),

  (NullT, ArrT (AClassAT Dummy)),
  (NullT, ArrT (CClassAT UndoCounter)),
  (NullT, ArrT (CClassAT NullPointerException)),
  (NullT, ArrT (CClassAT ClassCastException)),

  (ArrT (CClassAT Object),      CClassT Object),

  (ArrT (AClassAT Dummy),       ArrT (CClassAT Object)),
  (ArrT (CClassAT CounterImpl), ArrT (InterfaceAT Counter)),
  (ArrT (InterfaceAT Counter),  ArrT (CClassAT Object)),
  (ArrT (CClassAT Exception),   ArrT (CClassAT Object)),
  (ArrT (CClassAT UndoCounter), ArrT (CClassAT CounterImpl)),
  (ArrT (CClassAT NullPointerException), ArrT (CClassAT Exception)),
  (ArrT (CClassAT ClassCastException),   ArrT (CClassAT Exception))
}"

text {* This lemma is used later in the Simplifier. *}

lemma direct_subtype:
  "(NullT, AClassT Dummy) \<in> direct_subtype"
  "(NullT, CClassT UndoCounter) \<in> direct_subtype"
  "(NullT, CClassT NullPointerException) \<in> direct_subtype"
  "(NullT, CClassT ClassCastException) \<in> direct_subtype"

  "(AClassT Dummy, CClassT Object) \<in> direct_subtype"
  "(InterfaceT Counter, CClassT Object) \<in> direct_subtype"
  "(CClassT Exception, CClassT Object) \<in> direct_subtype"

  "(CClassT UndoCounter, CClassT CounterImpl) \<in> direct_subtype"
  "(CClassT CounterImpl, InterfaceT Counter) \<in> direct_subtype"
  "(CClassT NullPointerException, CClassT Exception) \<in> direct_subtype"
  "(CClassT ClassCastException, CClassT Exception) \<in> direct_subtype"

  "(NullT, ArrT BoolAT) \<in> direct_subtype"
  "(NullT, ArrT IntgAT) \<in> direct_subtype"
  "(NullT, ArrT ShortAT) \<in> direct_subtype"
  "(NullT, ArrT ByteAT) \<in> direct_subtype"
  "(ArrT BoolAT,  CClassT Object) \<in> direct_subtype"
  "(ArrT IntgAT,  CClassT Object) \<in> direct_subtype"
  "(ArrT ShortAT, CClassT Object) \<in> direct_subtype"
  "(ArrT ByteAT,  CClassT Object) \<in> direct_subtype"

  "(NullT, ArrT (AClassAT Dummy)) \<in> direct_subtype"
  "(NullT, ArrT (CClassAT UndoCounter)) \<in> direct_subtype"
  "(NullT, ArrT (CClassAT NullPointerException)) \<in> direct_subtype"
  "(NullT, ArrT (CClassAT ClassCastException)) \<in> direct_subtype"

  "(ArrT (CClassAT Object),      CClassT Object) \<in> direct_subtype"

  "(ArrT (AClassAT Dummy),       ArrT (CClassAT Object)) \<in> direct_subtype"
  "(ArrT (CClassAT CounterImpl), ArrT (InterfaceAT Counter)) \<in> direct_subtype"
  "(ArrT (InterfaceAT Counter),  ArrT (CClassAT Object)) \<in> direct_subtype"
  "(ArrT (CClassAT Exception),   ArrT (CClassAT Object)) \<in> direct_subtype"
  "(ArrT (CClassAT UndoCounter), ArrT (CClassAT CounterImpl)) \<in> direct_subtype"
  "(ArrT (CClassAT NullPointerException), ArrT (CClassAT Exception)) \<in> direct_subtype"
  "(ArrT (CClassAT ClassCastException),   ArrT (CClassAT Exception)) \<in> direct_subtype"
  by (simp_all add: direct_subtype_def)

end