theory Tree_Automata_Derivation_Split
  imports Regular_Tree_Relations.Tree_Automata
    Ground_MCtxt
begin

lemma ta_der'_inf_mctxt:
  assumes "t |\<in>| ta_der' \<A> s"
  shows "fst (split_vars t) \<le> (mctxt_of_term s)" using assms
proof (induct s arbitrary: t)
  case (Fun f ts) then show ?case
    by (cases t) (auto simp: comp_def less_eq_mctxt_prime intro: less_eq_mctxt'.intros)
qed (auto simp: ta_der'.simps)

lemma ta_der'_poss_subt_at_ta_der':
  assumes "t |\<in>| ta_der' \<A> s" and "p \<in> poss t"
  shows "t |_ p |\<in>| ta_der' \<A> (s |_ p)" using assms
  by (induct s arbitrary: t p) (auto simp: ta_der'.simps, blast+)

lemma ta_der'_varposs_to_ta_der:
  assumes "t |\<in>| ta_der' \<A> s" and "p \<in> varposs t"
  shows "the_Var (t |_ p) |\<in>| ta_der \<A> (s |_ p)" using assms
  by (induct s arbitrary: t p) (auto simp: ta_der'.simps, blast+)

definition "ta_der'_target_mctxt t \<equiv> fst (split_vars t)"
definition "ta_der'_target_args t \<equiv>  snd (split_vars t)"
definition "ta_der'_source_args t s \<equiv> unfill_holes (fst (split_vars t)) s"

lemmas ta_der'_mctxt_simps = ta_der'_target_mctxt_def ta_der'_target_args_def ta_der'_source_args_def

lemma ta_der'_target_mctxt_funas [simp]:
  "funas_mctxt (ta_der'_target_mctxt u) = funas_term u"
  by (auto simp: ta_der'_target_mctxt_def)

lemma ta_der'_target_mctxt_ground [simp]:
  "ground_mctxt (ta_der'_target_mctxt t)"
  by (auto simp: ta_der'_target_mctxt_def)

lemma ta_der'_source_args_ground:
  "t |\<in>| ta_der' \<A> s \<Longrightarrow> ground s \<Longrightarrow> \<forall> u \<in> set (ta_der'_source_args t s). ground u"
  by (metis fill_unfill_holes ground_fill_holes length_unfill_holes ta_der'_inf_mctxt ta_der'_mctxt_simps)

lemma ta_der'_source_args_term_of_gterm:
  "t |\<in>| ta_der' \<A> (term_of_gterm s) \<Longrightarrow> \<forall> u \<in> set (ta_der'_source_args t (term_of_gterm s)). ground u"
  by (intro ta_der'_source_args_ground) auto

lemma ta_der'_source_args_length:
  "t |\<in>| ta_der' \<A> s \<Longrightarrow> num_holes (ta_der'_target_mctxt t) = length (ta_der'_source_args t s)"
  by (auto simp: ta_der'_mctxt_simps ta_der'_inf_mctxt)

lemma ta_der'_target_args_length:
  "num_holes (ta_der'_target_mctxt t) = length (ta_der'_target_args t)"
  by (auto simp: ta_der'_mctxt_simps split_vars_num_holes)

lemma ta_der'_target_args_vars_term_conv:
  "vars_term t = set (ta_der'_target_args t)"
  by (auto simp: ta_der'_target_args_def split_vars_vars_term_list)

lemma ta_der'_target_args_vars_term_list_conv:
  "ta_der'_target_args t = vars_term_list t"
  by (auto simp: ta_der'_target_args_def split_vars_vars_term_list)

lemma mctxt_args_ta_der':
  assumes "num_holes C = length qs" "num_holes C = length ss"
    and "\<forall> i < length ss. qs ! i |\<in>| ta_der \<A> (ss ! i)"
  shows "(fill_holes C (map Var qs)) |\<in>| ta_der' \<A> (fill_holes C ss)" using assms
proof (induct rule: fill_holes_induct2)
  case MHole then show ?case
    by (cases ss; cases qs) (auto simp: ta_der_to_ta_der')
next
  case (MFun f ts) then show ?case
    by (simp add: partition_by_nth_nth(1, 2))
qed auto

\<comment> \<open>Splitting derivation into multihole context containing the remaining function symbols and
  the states, where each state is reached via the automata\<close>
lemma ta_der'_mctxt_structure:
  assumes "t |\<in>| ta_der' \<A> s"
  shows "t = fill_holes (ta_der'_target_mctxt t) (map Var (ta_der'_target_args t))" (is "?G1")
    "s = fill_holes (ta_der'_target_mctxt t) (ta_der'_source_args t s)" (is "?G2")
    "num_holes (ta_der'_target_mctxt t) = length (ta_der'_source_args t s) \<and>
     length (ta_der'_source_args t s) = length (ta_der'_target_args t)" (is "?G3")
    "i < length (ta_der'_source_args t s) \<Longrightarrow> ta_der'_target_args t ! i |\<in>| ta_der \<A> (ta_der'_source_args t s ! i)"
proof -
  let ?C = "ta_der'_target_mctxt t" let ?ss = "ta_der'_source_args t s"
  let ?qs = "ta_der'_target_args t"
  have t_split: "?G1" by (auto simp: ta_der'_mctxt_simps split_vars_fill_holes)
  have s_split: "?G2" by (auto simp: ta_der'_mctxt_simps ta_der'_inf_mctxt[OF assms]
     intro!: fill_unfill_holes[symmetric])
  have len: "num_holes ?C = length ?ss" "length ?ss = length ?qs" using assms
    by (auto simp: ta_der'_mctxt_simps split_vars_num_holes ta_der'_inf_mctxt)
  have "i < length (ta_der'_target_args t) \<Longrightarrow>
       ta_der'_target_args t ! i |\<in>| ta_der \<A> (ta_der'_source_args t s ! i)" for i
    using ta_der'_poss_subt_at_ta_der'[OF assms, of "varposs_list t ! i"]
    unfolding ta_der'_mctxt_simps split_vars_vars_term_list length_map
    by (auto simp: unfill_holes_to_subst_at_hole_poss[OF ta_der'_inf_mctxt[OF assms]]
       simp flip: varposs_list_to_var_term_list[of i t, unfolded varposs_list_var_terms_length])
       (metis assms hole_poss_split_vars_varposs_list nth_map nth_mem
        ta_der'_varposs_to_ta_der ta_der_to_ta_der' varposs_eq_varposs_list varposs_list_var_terms_length)
  then show ?G1 ?G2 ?G3 "i < length (ta_der'_source_args t s) \<Longrightarrow>
       ta_der'_target_args t ! i |\<in>| ta_der \<A> (ta_der'_source_args t s ! i)" using len t_split s_split
    by (simp_all add: ta_der'_mctxt_simps)
qed

lemma ta_der'_ground_mctxt_structure:
  assumes "t |\<in>| ta_der' \<A> (term_of_gterm s)"
  shows "t = fill_holes (ta_der'_target_mctxt t) (map Var (ta_der'_target_args t))"
    "term_of_gterm s = fill_holes (ta_der'_target_mctxt t) (ta_der'_source_args t (term_of_gterm s))"
    "num_holes (ta_der'_target_mctxt t) =  length (ta_der'_source_args t (term_of_gterm s)) \<and>
     length (ta_der'_source_args t (term_of_gterm s)) = length (ta_der'_target_args t)"
    "i < length (ta_der'_target_args t) \<Longrightarrow> ta_der'_target_args t ! i |\<in>| ta_der \<A> (ta_der'_source_args t (term_of_gterm s) ! i)"
  using ta_der'_mctxt_structure[OF assms]
  by force+

\<comment> \<open>Splitting derivation into context containing the remaining function symbols and state\<close>

definition "ta_der'_gctxt t \<equiv> gctxt_of_gmctxt (gmctxt_of_mctxt (fst (split_vars t)))"
abbreviation "ta_der'_ctxt t \<equiv> ctxt_of_gctxt (ta_der'_gctxt t)"
definition "ta_der'_source_ctxt_arg t s \<equiv> hd (unfill_holes (fst (split_vars t)) s)"

abbreviation "ta_der'_source_gctxt_arg t s \<equiv> gterm_of_term (ta_der'_source_ctxt_arg t (term_of_gterm s))"

lemma ta_der'_ctxt_structure:
  assumes "t |\<in>| ta_der' \<A> s" "vars_term_list t = [q]"
  shows "t = (ta_der'_ctxt t)\<langle>Var q\<rangle>" (is "?G1")
    "s = (ta_der'_ctxt t)\<langle>ta_der'_source_ctxt_arg t s\<rangle>" (is "?G2")
    "ground_ctxt (ta_der'_ctxt t)" (is "?G3")
    "q |\<in>| ta_der \<A> (ta_der'_source_ctxt_arg t s)" (is "?G4")
proof -
  have *: "length xs = Suc 0 \<Longrightarrow> xs = [hd xs]" for xs
    by (metis length_0_conv length_Suc_conv list.sel(1))
  have [simp]: "length (snd (split_vars t)) = Suc 0" using assms(2) ta_der'_inf_mctxt[OF assms(1)]
    by (auto simp: split_vars_vars_term_list)
  have [simp]: "num_gholes (gmctxt_of_mctxt (fst (split_vars t))) = Suc 0" using assms(2)
    by (simp add: split_vars_num_holes split_vars_vars_term_list)
  have [simp]: "ta_der'_source_args t s = [ta_der'_source_ctxt_arg t s]"
    using assms(2) ta_der'_inf_mctxt[OF assms(1)]
    by (auto simp: ta_der'_source_args_def ta_der'_source_ctxt_arg_def split_vars_num_holes intro!: *)
  have t_split: ?G1 using assms(2)
    by (auto simp: ta_der'_gctxt_def split_vars_fill_holes
      split_vars_vars_term_list simp flip: ctxt_of_gctxt_gctxt_of_gmctxt_apply)
  have s_split: ?G2 using ta_der'_mctxt_structure[OF assms(1)] assms(2)
    by (auto simp: ta_der'_gctxt_def ta_der'_target_mctxt_def
          simp flip: ctxt_of_gctxt_gctxt_of_gmctxt_apply)
  from ta_der'_mctxt_structure[OF assms(1)] have ?G4
    by (auto simp: ta_der'_target_args_def assms(2) split_vars_vars_term_list)
  moreover have ?G3 unfolding ta_der'_gctxt_def by auto
  ultimately show ?G1 ?G2 ?G3 ?G4 using t_split s_split
    by force+
qed

lemma ta_der'_ground_ctxt_structure:
  assumes "t |\<in>| ta_der' \<A> (term_of_gterm s)" "vars_term_list t = [q]"
  shows "t = (ta_der'_ctxt t)\<langle>Var q\<rangle>"
    "s = (ta_der'_gctxt t)\<langle>ta_der'_source_gctxt_arg t s\<rangle>\<^sub>G"
    "ground (ta_der'_source_ctxt_arg t (term_of_gterm s))"
    "q |\<in>| ta_der \<A> (ta_der'_source_ctxt_arg t (term_of_gterm s))"
  using ta_der'_ctxt_structure[OF assms] term_of_gterm_ctxt_apply
  by force+

subsection \<open>Sufficient condition for splitting the reachability relation induced by a tree automaton\<close>

locale derivation_split =
  fixes A :: "('q, 'f) ta" and \<A> and \<B>
  assumes rule_split: "rules A = rules \<A> |\<union>| rules \<B>"
    and eps_split: "eps A = eps \<A> |\<union>| eps \<B>"
    and B_target_states: "rule_target_states (rules \<B>) |\<union>| (snd |`| (eps \<B>)) |\<inter>|
      (rule_arg_states (rules \<A>) |\<union>| (fst |`| (eps \<A>))) = {||}"
begin

abbreviation "\<Delta>\<^sub>A \<equiv> rules \<A>"
abbreviation "\<Delta>\<^sub>\<E>\<^sub>A \<equiv> eps \<A>"
abbreviation "\<Delta>\<^sub>B \<equiv> rules \<B>"
abbreviation "\<Delta>\<^sub>\<E>\<^sub>B \<equiv> eps \<B>"

abbreviation "\<Q>\<^sub>A \<equiv> \<Q> \<A>"
definition "\<Q>\<^sub>B \<equiv> rule_target_states \<Delta>\<^sub>B |\<union>| (snd |`| \<Delta>\<^sub>\<E>\<^sub>B)"
lemmas B_target_states' = B_target_states[folded \<Q>\<^sub>B_def]

lemma states_split [simp]: "\<Q> A = \<Q> \<A> |\<union>| \<Q> \<B>"
  by (auto simp add: \<Q>_def rule_split eps_split)

lemma A_args_states_not_B:
  "TA_rule f qs q |\<in>| \<Delta>\<^sub>A \<Longrightarrow> p |\<in>| fset_of_list qs \<Longrightarrow> p |\<notin>| \<Q>\<^sub>B"
  using B_target_states
  by (force simp add: \<Q>\<^sub>B_def)

lemma rule_statesD:
  "r |\<in>| \<Delta>\<^sub>A \<Longrightarrow> r_rhs r |\<in>| \<Q>\<^sub>A"
  "r |\<in>| \<Delta>\<^sub>B \<Longrightarrow> r_rhs r |\<in>| \<Q>\<^sub>B"
  "r |\<in>| \<Delta>\<^sub>A \<Longrightarrow> p |\<in>| fset_of_list (r_lhs_states r) \<Longrightarrow> p |\<in>| \<Q>\<^sub>A"
  "TA_rule f qs q |\<in>| \<Delta>\<^sub>A \<Longrightarrow> q |\<in>| \<Q>\<^sub>A"
  "TA_rule f qs q |\<in>| \<Delta>\<^sub>B \<Longrightarrow> q |\<in>| \<Q>\<^sub>B"
  "TA_rule f qs q |\<in>| \<Delta>\<^sub>A \<Longrightarrow> p |\<in>| fset_of_list qs \<Longrightarrow> p |\<in>| \<Q>\<^sub>A"
  by (auto simp: rule_statesD \<Q>\<^sub>B_def rev_fimage_eqI)

lemma eps_states_dest:
  "(p, q) |\<in>| \<Delta>\<^sub>\<E>\<^sub>A \<Longrightarrow> p |\<in>| \<Q>\<^sub>A"
  "(p, q) |\<in>| \<Delta>\<^sub>\<E>\<^sub>A \<Longrightarrow> q |\<in>| \<Q>\<^sub>A"
  "(p, q) |\<in>| \<Delta>\<^sub>\<E>\<^sub>A|\<^sup>+| \<Longrightarrow> p |\<in>| \<Q>\<^sub>A"
  "(p, q) |\<in>| \<Delta>\<^sub>\<E>\<^sub>A|\<^sup>+| \<Longrightarrow> q |\<in>| \<Q>\<^sub>A"
  "(p, q) |\<in>| \<Delta>\<^sub>\<E>\<^sub>B \<Longrightarrow> q |\<in>| \<Q>\<^sub>B"
  "(p, q) |\<in>| \<Delta>\<^sub>\<E>\<^sub>B|\<^sup>+| \<Longrightarrow> q |\<in>| \<Q>\<^sub>B"
  by (auto simp: eps_dest_all \<Q>\<^sub>B_def rev_fimage_eqI elim: ftranclE)

lemma transcl_eps_simp:
  "(eps A)|\<^sup>+| = \<Delta>\<^sub>\<E>\<^sub>A|\<^sup>+| |\<union>| \<Delta>\<^sub>\<E>\<^sub>B|\<^sup>+| |\<union>| (\<Delta>\<^sub>\<E>\<^sub>A|\<^sup>+| |O| \<Delta>\<^sub>\<E>\<^sub>B|\<^sup>+|)"
proof -
  have "\<Delta>\<^sub>\<E>\<^sub>B |O| \<Delta>\<^sub>\<E>\<^sub>A = {||}" using B_target_states'
    by (metis eps_states_dest(5) ex_fin_conv fimageI finterI frelcompE fst_conv inf_sup_distrib1 sup_eq_bot_iff)
  from ftrancl_Un2_separatorE[OF this] show ?thesis
    unfolding eps_split by auto
qed

lemma B_rule_eps_A_False:
  "f qs \<rightarrow> q |\<in>| \<Delta>\<^sub>B \<Longrightarrow> (q, p) |\<in>| \<Delta>\<^sub>\<E>\<^sub>A|\<^sup>+| \<Longrightarrow> False"
  using B_target_states unfolding \<Q>\<^sub>B_def
  by (metis B_target_states' equalsffemptyD fimage_eqI finter_iff fst_conv ftranclD funion_iff local.rule_statesD(5))

lemma to_A_rule_set:
  assumes "TA_rule f qs q |\<in>| rules A" and "q = p \<or> (q, p) |\<in>| (eps A)|\<^sup>+|" and "p |\<notin>| \<Q>\<^sub>B"
  shows "TA_rule f qs q |\<in>| \<Delta>\<^sub>A" "q = p \<or> (q, p) |\<in>| \<Delta>\<^sub>\<E>\<^sub>A|\<^sup>+|" using assms
  unfolding transcl_eps_simp rule_split
  by (auto dest: rule_statesD eps_states_dest dest: B_rule_eps_A_False)

lemma to_B_rule_set:
  assumes "TA_rule f qs q |\<in>| rules A" and "q |\<notin>| \<Q>\<^sub>A"
  shows "TA_rule f qs q |\<in>| \<Delta>\<^sub>B" using assms
  unfolding transcl_eps_simp rule_split
  by (auto dest: rule_statesD eps_states_dest)

declare fsubsetI[rule del]
lemma ta_der_monos:
  "ta_der \<A> t |\<subseteq>| ta_der A t" "ta_der \<B> t |\<subseteq>| ta_der A t"
  by (auto simp: sup.coboundedI1 rule_split eps_split intro!: ta_der_mono)
declare fsubsetI[intro!]

lemma ta_der_from_\<Delta>\<^sub>A:
  assumes "q |\<in>| ta_der A (term_of_gterm t)" and "q |\<notin>| \<Q>\<^sub>B"
  shows "q |\<in>| ta_der \<A> (term_of_gterm t)" using assms
proof (induct rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  have "i < length ts \<Longrightarrow> ps ! i |\<notin>| \<Q>\<^sub>B" for i using GFun A_args_states_not_B
    by (metis fnth_mem to_A_rule_set(1))
  then show ?case using GFun(2, 5) to_A_rule_set[OF GFun(1, 3, 6)]
    by (auto simp: transcl_eps_simp)
qed

lemma ta_state:
  assumes "q |\<in>| ta_der A (term_of_gterm s)"
  shows "q |\<in>| \<Q>\<^sub>A \<or> q |\<in>| \<Q>\<^sub>B" using assms
  by (cases s) (auto simp: rule_split transcl_eps_simp dest: rule_statesD eps_states_dest)

(* Main lemmas *)

lemma ta_der_split:
  assumes "q |\<in>| ta_der A (term_of_gterm s)" and "q |\<in>| \<Q>\<^sub>B"
  shows "\<exists> t. t |\<in>| ta_der' \<A> (term_of_gterm s) \<and> q |\<in>| ta_der \<B> t"
    (is "\<exists>t . ?P s q t") using assms
proof (induct rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  {fix i assume ass: "i < length ts"
    then have "\<exists> t. t |\<in>| ta_der' \<A> (term_of_gterm (ts ! i)) \<and> ps ! i |\<in>| ta_der \<B> t"
    proof (cases "ps ! i |\<notin>| \<Q>\<^sub>B")
      case True then show ?thesis
        using ta_state GFun(2, 4) ta_der_from_\<Delta>\<^sub>A[of "ps ! i" "ts ! i"] ass
        by (intro exI[of _ "Var (ps ! i)"]) (auto simp: ta_der_to_ta_der' \<Q>\<^sub>B_def)
    next
      case False
      then have "ps ! i |\<in>| \<Q>\<^sub>B" using ta_state[OF GFun(4)[OF ass]]
        by auto
      from GFun(5)[OF ass this] show ?thesis .
    qed}
  then obtain h where IH:
    "\<forall> i < length ts. h i |\<in>| ta_der' \<A> (term_of_gterm (ts ! i))"
    "\<forall> i < length ts. ps ! i |\<in>| ta_der \<B> (h i)"
    using GFun(1 - 4) choice_nat[of "length ts" "\<lambda> t i. ?P (ts ! i) (ps ! i) t"]
    by blast
  from GFun(1) consider (A) "f ps \<rightarrow> p |\<in>| \<Delta>\<^sub>A" | (B) "f ps \<rightarrow> p |\<in>| \<Delta>\<^sub>B" by (auto simp: rule_split)
  then show ?case
  proof cases
    case A then obtain q' where eps_sp: "p = q' \<or> (p, q') |\<in>| \<Delta>\<^sub>\<E>\<^sub>A|\<^sup>+|"
      "q' = q \<or> (q', q) |\<in>| \<Delta>\<^sub>\<E>\<^sub>B|\<^sup>+|" using GFun(3, 6)
      by (auto simp: transcl_eps_simp dest: eps_states_dest)
    from GFun(4)[THEN ta_der_from_\<Delta>\<^sub>A] A GFun(2, 4)
    have reach_fst: "p |\<in>| ta_der \<A> (term_of_gterm (GFun f ts))"
      using A_args_states_not_B by auto
    then have "q' |\<in>| ta_der \<A> (term_of_gterm (GFun f ts))" using eps_sp
      by (meson ta_der_trancl_eps)
    then show ?thesis using eps_sp(2)
      by (intro exI[of _ "Var q'"]) (auto simp flip: ta_der_to_ta_der' simp del: ta_der'_simps)
  next
    case B
    then have "p = q \<or> (p, q) |\<in>| \<Delta>\<^sub>\<E>\<^sub>B|\<^sup>+|" using GFun(3)
      by (auto simp: transcl_eps_simp dest: B_rule_eps_A_False)
    then show ?thesis using GFun(2, 4, 6) IH B
      by (auto intro!: exI[of _ "Fun f (map h [0 ..< length ts])"] exI[of _ ps])
  qed
qed

lemma ta_der'_split:
  assumes "t |\<in>| ta_der' A (term_of_gterm s)"
  shows "\<exists> u. u |\<in>| ta_der' \<A> (term_of_gterm s) \<and> t |\<in>| ta_der' \<B> u"
    (is "\<exists> u. ?P s t u") using assms
proof (induct s arbitrary: t)
  case (GFun f ts) show ?case
  proof (cases t)
    case [simp]: (Var q)
    have "q |\<in>| ta_der A (term_of_gterm (GFun f ts))" using GFun(2)
      by (auto simp flip: ta_der_to_ta_der')
    from ta_der_split[OF this] ta_der_from_\<Delta>\<^sub>A[OF this] ta_state[OF this]
    show ?thesis unfolding Var
      by (metis ta_der'_refl ta_der_to_ta_der')
  next
    case [simp]: (Fun g ss)
    obtain h where IH:
      "\<forall> i < length ts. h i |\<in>| ta_der' \<A> (term_of_gterm (ts ! i))"
      "\<forall> i < length ts. ss ! i |\<in>| ta_der' \<B> (h i)"
      using GFun choice_nat[of "length ts" "\<lambda> t i. ?P (ts ! i) (ss ! i) t"]
      by auto
    then show ?thesis using GFun(2)
      by (auto intro!: exI[of _ "Fun f (map h [0..<length ts])"])
  qed
qed

(* TODO rewrite using ta_der'_mctxt_structure *)
lemma ta_der_to_mcxtx:
  assumes "q |\<in>| ta_der A (term_of_gterm s)" and "q |\<in>| \<Q>\<^sub>B"
  shows "\<exists> C ss qs. length qs = length ss \<and> num_holes C = length ss \<and>
    (\<forall> i < length ss. qs ! i |\<in>| ta_der \<A> (term_of_gterm (ss ! i))) \<and>
    q |\<in>| ta_der \<B> (fill_holes C (map Var qs)) \<and>
    ground_mctxt C \<and> fill_holes C (map term_of_gterm ss) = term_of_gterm s"
    (is "\<exists>C ss qs. ?P s q C ss qs")
proof -
  from ta_der_split[OF assms] obtain t where
    wit: "t |\<in>| ta_der' \<A> (term_of_gterm s)" "q |\<in>| ta_der \<B> t" by auto
  let ?C = "fst (split_vars t)" let ?ss = "map (gsubt_at s) (varposs_list t)"
  let ?qs = "snd (split_vars t)"
  have poss [simp]:"i < length (varposs_list t) \<Longrightarrow> varposs_list t ! i \<in> gposs s" for i
    by (metis nth_mem ta_der'_poss[OF wit(1)] poss_gposs_conv subset_eq varposs_eq_varposs_list
        varposs_imp_poss varposs_list_var_terms_length)
  have len: "num_holes ?C = length ?ss" "length ?ss = length ?qs"
    by (simp_all add: split_vars_num_holes split_vars_vars_term_list varposs_list_var_terms_length)
  from unfill_holes_to_subst_at_hole_poss[OF ta_der'_inf_mctxt[OF wit(1)]]
  have "unfill_holes (fst (split_vars t)) (term_of_gterm s) = map (term_of_gterm \<circ> gsubt_at s) (varposs_list t)"
    by (auto simp: comp_def hole_poss_split_vars_varposs_list
        dest: in_set_idx intro!: nth_equalityI term_of_gterm_gsubt)
  from fill_unfill_holes[OF ta_der'_inf_mctxt[OF wit(1)]] this
  have rep: "fill_holes ?C (map term_of_gterm ?ss) = term_of_gterm s"
    by simp
  have reach_int: "i < length ?ss \<Longrightarrow> ?qs ! i |\<in>| ta_der \<A> (term_of_gterm (?ss ! i))" for i
    using wit(1) ta_der'_varposs_to_ta_der
    unfolding split_vars_vars_term_list length_map
    unfolding varposs_list_to_var_term_list[symmetric]
    by (metis nth_map nth_mem poss term_of_gterm_gsubt varposs_eq_varposs_list)
  have reach_end: "q |\<in>| ta_der \<B> (fill_holes ?C (map Var ?qs))" using wit
    using split_vars_fill_holes[of ?C t "map Var ?qs"]
    by auto
  show ?thesis using len rep reach_end reach_int
    by (metis split_vars_ground')
qed

lemma ta_der_to_gmcxtx:
  assumes "q |\<in>| ta_der A (term_of_gterm s)" and "q |\<in>| \<Q>\<^sub>B"
  shows "\<exists> C ss qs qs'. length qs' = length qs \<and> length qs = length ss \<and> num_gholes C = length ss \<and>
    (\<forall> i < length ss. qs ! i |\<in>| ta_der \<A> (term_of_gterm (ss ! i))) \<and>
    q |\<in>| ta_der \<B> (fill_holes (mctxt_of_gmctxt C) (map Var qs')) \<and>
    fill_gholes C ss = s"
  using ta_der_to_mcxtx[OF assms]
  by (metis gmctxt_of_mctxt_inv ground_gmctxt_of_gterm_of_term num_gholes_gmctxt_of_mctxt term_of_gterm_inv)

(* Reconstuction *)

lemma mctxt_const_to_ta_der:
  assumes "num_holes C = length ss" "length ss = length qs"
    and "\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> (ss ! i)"
    and "q |\<in>| ta_der \<B> (fill_holes C (map Var qs))"
  shows "q |\<in>| ta_der A (fill_holes C ss)"
proof -
  have mid: "fill_holes C (map Var qs) |\<in>| ta_der' A (fill_holes C ss)"
    using assms(1 - 3) ta_der_monos(1)
    by (intro mctxt_args_ta_der') auto
  then show ?thesis using assms(1, 2) ta_der_monos(2)[THEN fsubsetD, OF assms(4)]
    using ta_der'_trans
    by (simp add: ta_der'_ta_der)
qed

lemma ctxt_const_to_ta_der:
  assumes "q |\<in>| ta_der \<A> s"
    and "p |\<in>| ta_der \<B> C\<langle>Var q\<rangle>"
  shows "p |\<in>| ta_der A C\<langle>s\<rangle>" using assms
  by (meson fin_mono ta_der_ctxt ta_der_monos(1) ta_der_monos(2))

lemma gctxt_const_to_ta_der:
  assumes "q |\<in>| ta_der \<A> (term_of_gterm s)"
    and "p |\<in>| ta_der \<B> (ctxt_of_gctxt C)\<langle>Var q\<rangle>"
  shows "p |\<in>| ta_der A (term_of_gterm C\<langle>s\<rangle>\<^sub>G)" using assms
  by (metis ctxt_const_to_ta_der ctxt_of_gctxt_inv ground_ctxt_of_gctxt ground_gctxt_of_ctxt_apply_gterm)

end
end


(*
 * Copyright 2017, Data61, CSIRO
 *
 * 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(DATA61_BSD)
 *)

(*
  Adds positivity law to separation algebra, as well as defining
  the septraction and sep-coimplication operators, providing lemmas
  for each.
*)

theory Extended_Separation_Algebra
imports
  "../Lib"
  "../sep_algebra/Sep_Algebra_L4v"
begin

instantiation "bool" :: stronger_sep_algebra
begin
 definition "zero_bool \<equiv> True"
 definition "plus_bool \<equiv> \<lambda>(x :: bool) (y :: bool). x \<and> y"
 definition "sep_disj_bool \<equiv> \<lambda>(x :: bool) (y :: bool). x \<or> y"
instance
  by (intro_classes; fastforce simp: zero_bool_def plus_bool_def sep_disj_bool_def)
end

instantiation "prod" :: (stronger_sep_algebra, stronger_sep_algebra) stronger_sep_algebra
begin
definition "zero_prod \<equiv> (0,0)"
definition "plus_prod p p' \<equiv> (fst p + fst p', snd p + snd p')"
definition "sep_disj_prod p p' \<equiv> fst p ## fst p' \<and> snd p ## snd p'"
instance
  apply (intro_classes; simp add: zero_prod_def plus_prod_def sep_disj_prod_def)
     apply (simp add: sep_add_assoc | fastforce simp: sep_disj_commute sep_add_commute)+
  done
end

class positive_sep_algebra = stronger_sep_algebra +
  assumes sep_disj_positive : "a ## a \<Longrightarrow> a + a = b \<Longrightarrow> a = b"

class cancellative_sep_algebra = positive_sep_algebra +
  assumes sep_add_cancelD: "\<lbrakk> x + z = y + z ; x ## z ; y ## z \<rbrakk> \<Longrightarrow> x = y"
begin

(* In any heap, there exists at most one subheap for which P holds *)
definition
  precise :: "('a \<Rightarrow> bool) \<Rightarrow> bool"
where
  "precise P = (\<forall>h hp hp'. hp \<preceq> h \<and> P hp \<and> hp' \<preceq> h \<and> P hp' \<longrightarrow> hp = hp')"

lemma "precise (op = s)"
  by (metis (full_types) precise_def)

lemma sep_disj_positive_zero[simp]: "x ## y \<Longrightarrow> x + y = 0 \<Longrightarrow> x = 0 \<and> y = 0"
  by (metis (full_types) local.disjoint_zero_sym
local.sep_add_cancelD local.sep_add_disjD local.sep_add_zero_sym local.sep_disj_positive)

lemma sep_add_cancel:
  "x ## z \<Longrightarrow> y ## z \<Longrightarrow> (x + z = y + z) = (x = y)"
  by (metis sep_add_cancelD)

lemma precise_distribute:
  "precise P = (\<forall>Q R. ((Q and R) \<and>* P) = ((Q \<and>* P) and (R \<and>* P)))"
proof (rule iffI)
  assume pp: "precise P"
  {
    fix Q R
    fix h hp hp' s

    { assume a: "((Q and R) \<and>* P) s"
      hence "((Q \<and>* P) and (R \<and>* P)) s"
        by (simp add: local.sep_globalise pred_conj_def)
    }
    moreover
    { assume qs: "(Q \<and>* P) s" and qr: "(R \<and>* P) s"

      from qs obtain x y where sxy: "s = x + y" and xy: "x ## y"
        and x: "Q x" and y: "P y"
        by (fastforce dest!: sep_conjD)
      from qr obtain x' y' where sxy': "s = x' + y'" and xy': "x' ## y'"
        and x': "R x'" and y': "P y'"
        by (fastforce dest!: sep_conjD)

      from sxy have ys: "y \<preceq> x + y" using xy
        by (fastforce simp: sep_substate_disj_add' sep_disj_commute)
      from sxy' have ys': "y' \<preceq> x' + y'" using xy'
        by (fastforce simp: sep_substate_disj_add' sep_disj_commute)

      from pp have yy: "y = y'" using sxy sxy' xy xy' y y' ys ys'
        by (fastforce simp: precise_def)

      hence "x = x'" using sxy sxy' xy xy'
        by (fastforce dest!: sep_add_cancelD)

      hence "((Q and R) \<and>* P) s" using sxy x x' yy y' xy'
        by (metis local.sep_conjI pred_conj_def)
    }
    ultimately
    have "((Q and R) \<and>* P) s = ((Q \<and>* P) and (R \<and>* P)) s" by (metis pred_conj_def)
  }
  thus "\<forall>Q R. ((Q and R) \<and>* P) = ((Q \<and>* P) and (R \<and>* P))" by blast

next
  assume a: "\<forall>Q R. ((Q and R) \<and>* P) = ((Q \<and>* P) and (R \<and>* P))"
  thus "precise P"
  proof (clarsimp simp: precise_def)
    fix h hp hp' Q R
    assume hp: "hp \<preceq> h" and hp': "hp' \<preceq> h" and php: "P hp" and php': "P hp'"

    obtain z where hhp: "h = hp + z" and hpz: "hp ## z" using hp
      by (clarsimp simp: sep_substate_def)
    obtain z' where hhp': "h = hp' + z'" and hpz': "hp' ## z'" using hp'
      by (clarsimp simp: sep_substate_def)

    have h_eq: "z' + hp' = z + hp" using hhp hhp' hpz hpz'
      by (fastforce simp: sep_add_ac)

    from hhp hhp' a hpz hpz' h_eq
    have "\<forall>Q R. ((Q and R) \<and>* P) (z + hp) = ((Q \<and>* P) and (R \<and>* P)) (z' + hp')"
      by (fastforce simp: h_eq sep_add_ac sep_conj_commute)

    hence "((op = z and op = z') \<and>* P) (z + hp) =
           ((op = z \<and>* P) and (op = z' \<and>* P)) (z' + hp')" by blast

    thus  "hp = hp'" using php php' hpz hpz' h_eq
      apply (clarsimp simp: sep_add_cancel sep_conj_def pred_conj_def)
      by (metis hhp hhp' local.sep_add_cancelD local.sep_disj_commuteI)
  qed
qed

lemma strictly_precise: "strictly_exact P \<Longrightarrow> precise P"
  by (metis precise_def strictly_exactD)

end

instantiation "fun" :: (type, pre_sep_algebra) pre_sep_algebra
begin
definition "zero_fun = (\<lambda>x. 0)"
definition "plus_fun f f'  \<equiv> (\<lambda>x. (f x) + (f' x) )"
definition "sep_disj_fun   \<equiv> (\<lambda>f f'.  \<forall>x. f x ## f' x ) :: ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool "
instance
  apply (intro_classes)
      apply (clarsimp simp:  comp_def sep_disj_fun_def )
      apply (clarsimp simp: zero_fun_def sep_disj_fun_def plus_fun_def )
     apply (clarsimp simp: zero_fun_def comp_def sep_disj_fun_def plus_fun_def )
     apply (simp add: sep_disj_commute)
    apply (clarsimp simp: zero_fun_def sep_disj_commuteI sep_disj_fun_def plus_fun_def)
   apply (clarsimp simp: zero_fun_def sep_disj_commuteI sep_disj_fun_def plus_fun_def sep_add_commute)
  apply (clarsimp simp: zero_fun_def sep_disj_commuteI sep_disj_fun_def plus_fun_def sep_add_commute sep_add_assoc)
  done
end

instantiation "fun" :: (type, sep_algebra) sep_algebra
begin

instance
  apply (intro_classes)
   apply (clarsimp simp: zero_fun_def sep_disj_fun_def plus_fun_def )

  using sep_disj_addD apply blast
  apply (clarsimp simp: zero_fun_def comp_def sep_disj_fun_def plus_fun_def )

  by (simp add: sep_disj_addI1)
end

instantiation option :: (type) sep_algebra begin
definition "sep_disj_option (h :: 'a option) (h' :: 'a option) =
             (case h of (Some x) \<Rightarrow> h' = None | _ \<Rightarrow> h = None)"
definition "plus_option (h :: 'a option) (h' :: 'a option) = (case h of (Some x) \<Rightarrow> (case h' of (Some y) \<Rightarrow> None | _ \<Rightarrow> h) | _ \<Rightarrow> h')"
definition "zero_option = None"
instance
  apply (intro_classes)
        by (clarsimp simp: sep_disj_option_def zero_option_def plus_option_def split: option.splits)+
end

instantiation option :: (type) cancellative_sep_algebra begin
instance
  apply (intro_classes)
    apply (simp add: option.case_eq_if plus_option_def sep_disj_option_def)
   apply (clarsimp simp: zero_option_def option.case_eq_if plus_option_def sep_disj_option_def split: if_split_asm  option.splits)
   apply (clarsimp simp: zero_option_def option.case_eq_if plus_option_def sep_disj_option_def split: if_split_asm option.splits)
  done
end

instantiation "fun" :: (type, cancellative_sep_algebra) cancellative_sep_algebra begin
instance
  apply (intro_classes)
    apply (clarsimp simp: plus_fun_def sep_disj_fun_def zero_fun_def)
    apply (safe; fastforce)
   apply (clarsimp simp: plus_fun_def sep_disj_fun_def zero_fun_def)
    apply (rule ext)
    apply (meson sep_disj_positive)
   apply (rule ext)
  apply (clarsimp simp: plus_fun_def sep_disj_fun_def zero_fun_def)
  by (meson sep_add_cancel)
end

lemma sep_substate_antisym: "x \<preceq> y \<Longrightarrow> y \<preceq> x \<Longrightarrow> x = (y :: 'a ::cancellative_sep_algebra)"
  apply (clarsimp simp: sep_substate_def)
  apply (rename_tac h' h)
  apply (subgoal_tac "h' = 0")
   apply (clarsimp)
  apply (drule_tac trans[where s=x and t="x+0"])
   apply (clarsimp)
  apply (subgoal_tac "(x + h' + h = x + 0) \<longrightarrow> ((0 + x) = (h' + h) + x)")
   apply (drule mp, clarsimp)
  apply (metis Extended_Separation_Algebra.cancellative_sep_algebra_class.sep_add_cancelD sep_add_disj_eq sep_disj_commuteI sep_disj_positive_zero sep_disj_zero)
  by (metis sep_add_assoc sep_add_commute sep_add_zero sep_add_zero_sym sep_disj_commuteI)

(*
instantiation set :: (type) stronger_sep_algebra begin
definition "zero_set = {}"
definition "plus_set = (op \<union>)"
definition "sep_disj_set = (\<lambda>h h'. h \<inter> h' = {})"
instance
  apply (intro_classes; simp add: zero_set_def plus_set_def sep_disj_set_def; blast)
  done
end
*)

context sep_algebra begin

definition
  septraction :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infix "-*" 25)
where
  "septraction P Q = (not (P \<longrightarrow>* not Q))"

lemma septraction_impl1: "(P -* Q) s \<Longrightarrow> (\<And>s. P s \<Longrightarrow> P' s) \<Longrightarrow> (P' -* Q) s "
  apply (clarsimp simp: septraction_def pred_neg_def)
  using sep_impl_def by auto

lemma septraction_impl2: "(P -* Q) s \<Longrightarrow> (\<And>s. Q s \<Longrightarrow> Q' s) \<Longrightarrow> (P -* Q') s "
  apply (clarsimp simp: septraction_def pred_neg_def)
  using sep_impl_def by auto

definition
  sep_coimpl :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infix "\<leadsto>*" 24)
where
  "sep_coimpl P Q \<equiv> \<lambda>s. \<not> (P \<and>* not Q) s"

lemma sep_septraction_snake:"(P -* Q) s \<Longrightarrow> (\<And>s. Q s \<Longrightarrow> (P \<leadsto>* Q') s) \<Longrightarrow>  Q' s"
  apply (clarsimp simp: sep_coimpl_def septraction_def pred_neg_def sep_conj_def sep_impl_def)
  using local.sep_add_commute sep_disj_commute by auto

lemma sep_snake_septraction: "Q s \<Longrightarrow> (\<And>s. (P -* Q) s \<Longrightarrow> Q' s) \<Longrightarrow> (P \<leadsto>* Q') s  "
  apply (clarsimp simp: sep_coimpl_def septraction_def pred_neg_def sep_conj_def sep_impl_def)
  using local.sep_add_commute sep_disj_commute by fastforce

lemma septraction_snake_trivial: "(P -* (P \<leadsto>* R)) s \<Longrightarrow> R s" by (erule sep_septraction_snake)

end

lemma sep_impl_impl: "(P \<longrightarrow>* Q) s\<Longrightarrow> (\<And>s. Q s \<Longrightarrow> Q' s) \<Longrightarrow> (P \<longrightarrow>* Q') s"
  by (metis sep_implD sep_implI)

lemma disjointness_equiv:
  "(\<forall>P (s :: 'a :: sep_algebra). strictly_exact P \<longrightarrow> \<not>P 0 \<longrightarrow> (P \<leadsto>* (P \<leadsto>* sep_false)) s) =
   (\<forall>h :: 'a. h ## h \<longrightarrow> h = 0)"
  apply (rule iffI)
   apply (clarsimp)
   apply (erule_tac x="(op =) h" in allE)
   apply (drule mp)
    apply (clarsimp simp: strictly_exact_def)
   apply (rule ccontr)
   apply (drule mp)
    apply (clarsimp)
   apply (erule_tac x="h + h" in allE)
   apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def)
   apply (erule_tac x=h in allE, clarsimp)
   apply (erule_tac x=0 in allE, clarsimp)
  apply (clarsimp)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def strictly_exact_def)
  apply (erule_tac x=x in allE, erule_tac x=xa in allE, clarsimp simp: sep_empty_def)
  apply (erule_tac x=x in allE, clarsimp)
  using sep_disj_addD1 by blast

definition
  sep_min :: "(('a :: sep_algebra) \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" where
  "sep_min P \<equiv> P and (P \<leadsto>* \<box>)"

definition
  sep_subtract :: "(('a :: sep_algebra) \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" where
  "sep_subtract P Q \<equiv> P and (Q \<leadsto>* \<box>)"

lemma sep_min_subtract_subtract: "sep_min P = sep_subtract P P"
  apply (clarsimp simp: sep_subtract_def sep_min_def)
  done

lemma sep_subtract_distrib_disj:
  "sep_subtract (P or Q) R = ((sep_subtract P R) or (sep_subtract Q R))"
  apply (rule ext, rule iffI)
   apply (clarsimp simp: pred_disj_def pred_conj_def sep_subtract_def)
  apply (clarsimp simp: pred_disj_def pred_conj_def sep_subtract_def)
  apply (safe)
  done

lemma sep_snake_sep_impl:
  "(P \<longrightarrow>* R) s \<Longrightarrow> (\<And> s. R s \<Longrightarrow> (P \<leadsto>* sep_false) s) \<Longrightarrow> (not P \<and>* (not (P -* R))) s"
  apply (drule sep_impl_impl[where Q'="(P \<leadsto>* sep_false)"])
   apply (atomize)
   apply (erule allE, drule mp, assumption)
   apply (assumption)
  apply (erule contrapos_pp)
  apply (clarsimp simp: sep_impl_def sep_coimpl_def sep_conj_def pred_neg_def septraction_def)
  apply (erule_tac x=0 in allE)
  apply (erule_tac x=s in allE)
  apply (clarsimp)
  apply (rule_tac x=0 in exI)
  apply (clarsimp)
  by (metis (full_types) disjoint_zero_sym sep_add_commute sep_add_zero_sym sep_disj_commuteI)

lemma sep_snake_mp: "(P \<leadsto>* Q) s \<Longrightarrow> (P \<and>* sep_true) s \<Longrightarrow>  (P \<and>* Q) s  "
  apply (clarsimp simp: sep_coimpl_def)
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
  apply (fastforce)
  done

lemma sep_coimpl_contrapos: "(P \<leadsto>* Q) = ((not Q) \<leadsto>* (not P))"
  by (rule ext, rule iffI; simp add: sep_coimpl_def pred_neg_def sep_conj_commute)

lemma sep_coimpl_def': "(\<not> (P \<and>* Q) s) = ((P \<leadsto>* (not Q)) s)"
  by (simp add: pred_neg_def sep_coimpl_def)

lemma rewrite_sp: "(\<forall>R s. (P \<leadsto>* R) s \<longrightarrow> (Q \<and>* R) (f s))  \<longleftrightarrow> (\<forall>R s. R s \<longrightarrow> (Q \<and>* (P -* R)) (f s) )"
  apply (rule iffI)
   apply (clarsimp)
   apply (erule_tac x="P -* R" in allE)
   apply (erule_tac x=s in allE)
   apply (drule mp)
    apply (erule (1) sep_snake_septraction)
   apply (assumption)
  apply (clarsimp)
  apply (erule_tac x="P \<leadsto>* R" in allE)
  apply (erule_tac x=s in allE)
  apply (clarsimp)
  apply (sep_cancel)
  apply (erule (1) sep_septraction_snake)
  done

lemma sep_coimpl_weaken: "(P \<leadsto>* Q) s \<Longrightarrow> (\<And>s. P' s \<Longrightarrow> P s) \<Longrightarrow> (P' \<leadsto>* Q) s"
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def)
  apply (fastforce)
  done

lemma sep_curry': "R s \<Longrightarrow> (P \<longrightarrow>* (P \<and>* R)) s"
  by (simp add: sep_wand_trivial)

lemma sep_coimpl_mp_gen:
  "(P \<and>* Q) s \<Longrightarrow> (P' \<leadsto>* Q') s \<Longrightarrow> (\<And>s. P s \<Longrightarrow> P' s) \<Longrightarrow> ((P and P') \<and>* (Q and Q')) s"
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_conj_def pred_neg_def)
  apply (fastforce simp: sep_disj_commute sep_add_commute)
  done

lemma ex_pull: "\<exists>h s. P h s \<and> Q h \<Longrightarrow> \<exists>h. Q h \<and> (\<exists>s. P h s)"
  apply (fastforce)
  done

lemma sep_mp_snake_mp: "(P \<and>* (P \<longrightarrow>* (P \<leadsto>* Q))) s \<Longrightarrow> (P \<and>* Q) s"
  apply (clarsimp simp: sep_conj_def)
  apply (rename_tac x y)
  apply (rule_tac x=x in exI)
  apply (rule_tac x=y in exI)
  apply (clarsimp)
  apply (clarsimp simp: sep_impl_def)
  apply (erule_tac x=x in allE)
  apply (clarsimp simp: sep_disj_commute)
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
  apply (fastforce simp: sep_disj_commute sep_add_commute)
  done

lemma septract_cancel: "(P -* Q) s \<Longrightarrow> (\<And>s. P s \<Longrightarrow> P' s) \<Longrightarrow> (\<And>s. Q s \<Longrightarrow> Q' s) \<Longrightarrow> (P' -* Q') s"
  apply (clarsimp simp: septraction_def sep_impl_def pred_neg_def)
  apply (fastforce)
  done

lemma sep_coimpl_mp_zero: "(P \<leadsto>* Q) s \<Longrightarrow> P s   \<Longrightarrow> Q (0)"
  apply (clarsimp simp: sep_coimpl_def sep_conj_def)
  apply (erule_tac x=s in allE)
  apply (clarsimp, erule_tac x="0" in allE)
  apply (clarsimp simp: pred_neg_def)
  done

lemma sep_neg_not: "(P \<leadsto>* sep_false) s \<Longrightarrow> \<not>P s"
  apply (cases "P s")
   apply (drule(1) sep_coimpl_mp_zero)
   apply (clarsimp)
  apply (simp)
  done

lemma sep_antimp': "P s \<Longrightarrow> (Q \<leadsto>* (Q -* P)) s \<and> P s"
  apply (clarsimp)
  apply (erule sep_snake_septraction, assumption)
  done

definition
    sep_precise_conj :: "(('a :: sep_algebra) \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" where
  "sep_precise_conj P \<equiv> P and (ALLS R. (sep_true \<longrightarrow>* (P \<leadsto>* R)))"

notation sep_precise_conj (infix "\<and>@" 50)

definition
  coprecise ::  "(('a :: sep_algebra) \<Rightarrow> bool) \<Rightarrow>  bool" where
  "coprecise P = (\<forall>s h h'. P h \<longrightarrow> P h' \<longrightarrow> s \<preceq> h \<longrightarrow> s \<preceq> h' \<longrightarrow> s \<noteq> 0 \<longrightarrow> h = h')"

definition
  cointuitionistic :: "(('a :: sep_algebra) \<Rightarrow> bool) \<Rightarrow> bool" where
  "cointuitionistic P = (\<forall>h h'. P h \<and> h' \<preceq> h \<longrightarrow> P h')"

lemma intuitionistic_def':"intuitionistic P = (\<forall>s R. (P \<and>* R) s \<longrightarrow> P s)"
  apply (rule iffI)
   apply (clarsimp simp: intuitionistic_def)
   apply (clarsimp simp: sep_conj_def)
   using sep_substate_disj_add apply blast
  apply (clarsimp simp: intuitionistic_def)
  apply (erule_tac x=h' in allE)
  apply (drule mp)
   apply (rule_tac x=sep_true in exI)
   apply (clarsimp simp:sep_conj_def sep_substate_def, fastforce)
  apply (assumption)
  done

lemma cointuitionistic_def':  "cointuitionistic P = (\<forall>s R. P s \<longrightarrow> (R \<leadsto>* P) s)"
  apply (rule iffI)
   apply (clarsimp)
   apply (clarsimp simp: sep_coimpl_def)
   apply (clarsimp simp: sep_conj_def pred_neg_def cointuitionistic_def)
   apply (rename_tac R x y)
   apply (erule_tac x="x + y" in allE)
   apply (erule_tac x=y in allE)
   apply (clarsimp)
   using sep_disj_commuteI sep_substate_disj_add' apply blast
  apply (clarsimp simp: cointuitionistic_def)
  apply (erule_tac x=h in allE)
  apply (clarsimp)
  apply (clarsimp simp: sep_substate_def)
  apply (erule_tac x="\<lambda>s. s = z" in allE)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def)
  apply (fastforce simp: sep_disj_commute sep_add_commute)
  done

lemma saturated_split: "cointuitionistic P \<Longrightarrow> P s \<Longrightarrow> (Q \<and>* R) s \<Longrightarrow> ((P and Q) \<and>* (P and R)) s"
  apply (clarsimp simp: cointuitionistic_def sep_conj_def pred_conj_def)
  apply (rule_tac x=x in exI)
  apply (rule_tac x=y in exI)
  apply (clarsimp)
  using sep_disj_commuteI sep_substate_disj_add sep_substate_disj_add' by blast

lemma sep_wand_dne:"((P \<longrightarrow>* sep_false) \<longrightarrow>* sep_false) s \<Longrightarrow> \<exists>s. P s"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_conj_def sep_coimpl_def)
  apply (erule_tac x=0 in allE)
  apply (clarsimp)
  done

lemma sep_snake_dne: "(sep_true \<leadsto>* P) s \<Longrightarrow> ((P \<leadsto>* sep_false) \<leadsto>* sep_false) s"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_conj_def sep_coimpl_def)
  apply (rename_tac x y)
  apply (erule_tac x=y in allE)
  apply (erule_tac x=x in allE)
  apply (rule_tac x=x in exI)
  apply (rule_tac x=0 in exI)
  apply (clarsimp)
  apply (fastforce simp: sep_disj_commute sep_add_commute)
  done

lemma strictly_exactI:
  "(\<And>P s. ((P -* R) -* R) s \<Longrightarrow> P (s :: 'a :: cancellative_sep_algebra)) \<Longrightarrow> strictly_exact R"
  apply (atomize)
  apply (clarsimp simp: strictly_exact_def)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_conj_def sep_coimpl_def strictly_exact_def)
  apply (rename_tac h h')
  apply (erule_tac x="\<lambda>s. s = h" in allE)
  by (metis disjoint_zero_sym sep_add_commute sep_add_zero sep_disj_zero)

lemma strictly_exact_septractD:
  "strictly_exact R \<Longrightarrow> ((P -* R) -* R) s \<Longrightarrow> P (s :: 'a :: cancellative_sep_algebra)"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_conj_def sep_coimpl_def
                        strictly_exact_def)
  by (metis Extended_Separation_Algebra.cancellative_sep_algebra_class.sep_add_cancel sep_add_commute sep_disj_commuteI)

lemma strictly_exact_def':
  "(\<forall>P s. ((P -* R) -* R) s \<longrightarrow> P (s :: 'a :: cancellative_sep_algebra)) = strictly_exact R"
  using strictly_exactI strictly_exact_septractD by auto

lemma copreciseI: "(\<forall>(s ) R. (P -* R) s \<longrightarrow> (P \<longrightarrow>* R) s) \<Longrightarrow> coprecise P"
  apply (clarsimp simp: coprecise_def)
  apply (clarsimp simp: sep_substate_def)
  apply (erule_tac x="0" in allE)
  apply (rename_tac s h h')
  apply (erule_tac x="\<lambda>s'. s' = s + h" in allE)
  apply (drule mp)
   apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  done

lemma sep_implI': "strictly_exact P \<Longrightarrow> (P -* R) s \<Longrightarrow> (P \<longrightarrow>* R) s"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def coprecise_def strictly_exact_def)
  apply (fastforce)
  done

lemma "\<forall>s P. (P -* R) s \<longrightarrow> (P \<longrightarrow>* R) s \<Longrightarrow> \<exists>s. R s \<Longrightarrow> R s"
  apply (clarsimp simp: coprecise_def)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  by (metis disjoint_zero_sym sep_add_zero_sym)

lemma strictly_exactI':"\<forall>s R. (P -* R) s \<longrightarrow> (P \<longrightarrow>* R) s \<Longrightarrow> strictly_exact P"
  apply (clarsimp simp: strictly_exact_def)
  apply (erule_tac x="0" in allE)
  apply (rename_tac h h')
  apply (erule_tac x="\<lambda>h. h = h'" in allE)
  apply (drule mp)
   apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  done

lemma strictly_exact_def'': "(\<forall>s R. (P -* R) s \<longrightarrow> (P \<longrightarrow>* R) s) = strictly_exact P"
  using sep_implI' strictly_exactI' by blast

lemma conj_coimpl_precise: "(\<forall>s R. (P \<and>* R) s \<longrightarrow> (P \<leadsto>* R) s) \<Longrightarrow> precise P"
  apply (clarsimp simp: precise_def)
  apply (clarsimp simp: sep_substate_def)
  apply (rename_tac h h' z z')
  apply (erule_tac x="h + z" in allE)
  apply (erule_tac x="\<lambda>s. s= z" in allE)
  apply (drule mp)
   apply (clarsimp simp: sep_conj_def)
   apply (fastforce)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def)
  using sep_add_cancel by fastforce

lemma precise_conj_coimpl: "precise P \<Longrightarrow> (\<forall>s R. (P \<and>* R) s \<longrightarrow> (P \<leadsto>* R) s)"
  apply (clarsimp simp: precise_def)
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
  by (metis Extended_Separation_Algebra.cancellative_sep_algebra_class.sep_add_cancelD sep_add_commute sep_disj_commuteI sep_substate_disj_add)

lemma septract_cancel_eq_precise: "(\<forall>s. ((P -* (P \<and>* R)) s \<longrightarrow> R s)) = (\<forall>s. (P \<and>* R) s \<longrightarrow> (P \<leadsto>* R) s)"
  apply (rule iffI)
   apply (clarsimp)
   apply (clarsimp simp: sep_conj_def sep_impl_def septraction_def pred_neg_def sep_coimpl_def)
   apply (rule ccontr)
   apply (rename_tac x y h h')
   apply (erule_tac x=h' in allE)
   apply (clarsimp)
   apply (erule_tac x=h in allE)
   apply (clarsimp simp: sep_disj_commute)
   apply (erule_tac x=x in allE)
   apply (clarsimp)
   apply (erule_tac x=y in allE)
   apply (clarsimp)
   apply (fastforce simp: sep_disj_commute sep_add_commute)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  by (metis pred_neg_def sep_coimpl_def sep_conjI sep_conj_commuteI)

lemma sep_coimpl_cancel:"(P \<leadsto>* Q) s \<Longrightarrow> ((P \<and>* Q) s \<Longrightarrow> (P \<leadsto>* Q') s) \<Longrightarrow> (P \<leadsto>* Q') s"
  apply (clarsimp simp: sep_coimpl_def pred_neg_def)
  apply (clarsimp simp: sep_conj_def)
  by blast

lemma sep_cases: "R s \<Longrightarrow> (P \<and>* (P -* R)) s \<or> (P \<leadsto>* (sep_false)) s"
  apply (safe)
  apply (clarsimp simp: sep_coimpl_def)
  apply (rule ccontr)
  by (meson sep_antimp' sep_conj_sep_true_right sep_snake_mp)

lemma contra: "(\<forall>s. P s \<longrightarrow> Q s) \<Longrightarrow> (\<forall>s. \<not> Q s \<longrightarrow> \<not> P s )"
  apply (safe)
  apply (fastforce)
  done

lemma "(\<forall>R s. (P \<and>* R) (s) \<longrightarrow> (Q \<and>* R) (f s) ) = (\<forall>R s. (Q \<leadsto>* R) (f s) \<longrightarrow> (P \<leadsto>* R) ( s))"
  apply (clarsimp simp: sep_coimpl_def)
  apply (rule iffI)
   apply (clarsimp)
  apply (clarsimp)
  by (meson sep_coimpl_def sep_coimpl_def')

lemma "R s \<Longrightarrow> strictly_exact R \<Longrightarrow> (P \<longrightarrow>* R) s' \<Longrightarrow> (P -* R) s' \<Longrightarrow> s' \<preceq> s \<Longrightarrow> (P \<and>* sep_true) s"
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def septraction_def sep_impl_def)
  by (metis sep_add_commute sep_disj_commuteI strictly_exact_def)

lemma sep_coimpl_comb: " (R \<leadsto>* P) s \<Longrightarrow> (R \<leadsto>* Q) s \<Longrightarrow> (R \<leadsto>* (P and Q)) s"
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def pred_conj_def)
  done

lemma sep_coimpl_contra: "(R \<leadsto>* (not Q)) s \<Longrightarrow> (R \<leadsto>* Q) s \<Longrightarrow> (R \<leadsto>* sep_false) s"
  apply (drule sep_coimpl_comb, assumption)
  apply (clarsimp simp: pred_neg_def pred_conj_def)
  done

lemma sep_comb': "((not Q) \<leadsto>* P) s \<Longrightarrow> (Q \<leadsto>* R) s \<Longrightarrow> ((R or P) \<and>* sep_true) s"
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def)
  by (metis (full_types) disjoint_zero_sym pred_disj_def sep_add_zero sep_add_zero_sym sep_disj_zero)

lemma sep_coimpl_dne: "((R \<leadsto>* sep_false) \<leadsto>* sep_false) s \<Longrightarrow> (R \<and>* sep_true) s"
  by (metis sep_coimpl_def sep_conj_sep_true_right sep_neg_not)

lemma sep_antimp_contrapos: " (R) s \<Longrightarrow> ((P \<longrightarrow>* not R) \<leadsto>* (not P)) s "
  by (metis pred_neg_def sep_coimpl_def' sep_mp_gen)

lemma sep_snake_trivial:"(sep_true \<leadsto>* Q) s \<Longrightarrow> Q s"
  by (metis pred_neg_def sep_coimpl_def sep_conj_sep_true')

lemma min_predD: "(R \<leadsto>* \<box>) s \<Longrightarrow> (R \<and>* sep_true) s  \<Longrightarrow> R s"
  using Sep_Cancel_Set.sep_conj_empty' sep_coimpl_dne sep_snake_mp by blast

lemma septract_sep_wand: "(P -* R) s \<Longrightarrow> (P \<longrightarrow>* Q) s \<Longrightarrow> (P -* (Q and R)) s"
  apply (clarsimp simp: sep_impl_def septraction_def pred_neg_def)
  by (fastforce simp: pred_conj_def)

lemma "(P -* (P \<and>* R)) s \<Longrightarrow> (P \<longrightarrow>* Q) s \<Longrightarrow> (\<And>s. (Q and (P \<and>* R)) s \<Longrightarrow> (P \<leadsto>* R) s) \<Longrightarrow> R s"
  using sep_septraction_snake septract_sep_wand by blast

lemma sep_elsewhereD:"(P -* sep_true) s \<Longrightarrow> (P \<longrightarrow>* (P \<leadsto>* R)) s \<Longrightarrow> R s"
  apply (drule (1) septract_sep_wand, simp add: pred_conj_def)
  using sep_septraction_snake  by blast

lemma sep_conj_coimplI: "(Q \<leadsto>* R) s \<Longrightarrow>  ((P \<and>* Q) \<leadsto>* (P -* R)) s  "
  by (metis sep_coimpl_def sep_coimpl_def' sep_conj_commuteI sep_mp_frame septraction_def)

lemma sep_conj_septract_curry:"((P \<and>* Q) -* R) s \<Longrightarrow>  (P -* (Q -* R)) s"
  by (smt sep_antimp' sep_conj_coimplI sep_septraction_snake)

lemma sep_snake_boxI:"Q s \<Longrightarrow> (\<box> \<leadsto>* Q) s"
  by (simp add: pred_neg_def sep_coimpl_def)

lemma sep_snake_boxD:"(Q \<leadsto>* \<box>) s \<Longrightarrow> ((Q \<leadsto>* sep_false) or Q) s"
  apply (simp only: pred_disj_def)
  apply (safe)
  using Sep_Cancel_Set.sep_conj_empty' sep_coimpl_cancel by blast

lemma septract_wandD: "(( R \<longrightarrow>* (not Q)) -* Q) s \<Longrightarrow> (not R) s"
  apply (erule sep_septraction_snake)
  by (simp add: sep_antimp_contrapos)

lemma sep_impl_septractD:  "(P \<longrightarrow>* Q) s \<Longrightarrow> (R -* (not Q)) s \<Longrightarrow> ((R and not P) -* (not Q)) s"
  apply (clarsimp simp: sep_impl_def pred_neg_def septraction_def)
  apply (erule_tac x=h' in allE)
  apply (clarsimp simp: pred_conj_def)
  apply (fastforce)
  done

lemma sep_neg_impl: "(not (R \<longrightarrow>* Q)) = (R -* (not Q)) "
  apply (clarsimp simp: pred_neg_def septraction_def)
  done

lemma "P s \<Longrightarrow> (R -* Q) s \<Longrightarrow> ((R and (P -* Q)) -* Q) s"
  apply (clarsimp simp: septraction_def sep_impl_def pred_neg_def pred_conj_def)
  by (fastforce simp: sep_add_commute sep_disj_commute)

lemma sep_coimpl_notempty: "(Q \<leadsto>* (not \<box>)) s \<Longrightarrow> (not Q) s"
  apply (clarsimp simp: sep_coimpl_def pred_neg_def)
  done

method sep_subst uses add = (sep_frule (direct) add)

lemma septract_empty_empty:"(P -* \<box>) s \<Longrightarrow> \<box> (s :: 'a :: cancellative_sep_algebra)"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_empty_def)
  done

lemma septract_trivial: "P s \<Longrightarrow> (sep_true -* P) s"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_empty_def)
  using sep_disj_zero by fastforce

lemma sep_empty_and_conj:"\<box> s \<Longrightarrow> (P \<and>* Q) s \<Longrightarrow> P (s :: 'a :: cancellative_sep_algebra)"
  by (metis sep_conj_def sep_disj_positive_zero sep_empty_def)

lemma sep_conj_coimpl_mp:"(P \<and>* R) s \<Longrightarrow> (P \<leadsto>* Q) s \<Longrightarrow> (P \<and>* (Q and R)) s"
  apply (drule (2) sep_coimpl_mp_gen, clarsimp simp: pred_conj_def conj_commute)
  done

lemma sep_conj_coimpl_contrapos_mp:"(P \<and>* Q) s \<Longrightarrow> (R \<leadsto>* (not Q)) s \<Longrightarrow> (Q \<and>* (P and (not R))) s"
  apply (subst (asm) sep_coimpl_contrapos)
  apply (clarsimp simp: pred_neg_def)
  apply (sep_drule (direct) sep_conj_coimpl_mp[where P=Q], assumption)
  apply (clarsimp simp: pred_conj_def conj_commute)
  done

end


(*  Title:      CCL/Term.thy
    Author:     Martin Coen
    Copyright   1993  University of Cambridge
*)

section \<open>Definitions of usual program constructs in CCL\<close>

theory Term
imports CCL
begin

definition one :: "i"
  where "one == true"

definition "if" :: "[i,i,i]\<Rightarrow>i"  ("(3if _/ then _/ else _)" [0,0,60] 60)
  where "if b then t else u  == case(b, t, u, \<lambda> x y. bot, \<lambda>v. bot)"

definition inl :: "i\<Rightarrow>i"
  where "inl(a) == <true,a>"

definition inr :: "i\<Rightarrow>i"
  where "inr(b) == <false,b>"

definition split :: "[i,[i,i]\<Rightarrow>i]\<Rightarrow>i"
  where "split(t,f) == case(t, bot, bot, f, \<lambda>u. bot)"

definition "when" :: "[i,i\<Rightarrow>i,i\<Rightarrow>i]\<Rightarrow>i"
  where "when(t,f,g) == split(t, \<lambda>b x. if b then f(x) else g(x))"

definition fst :: "i\<Rightarrow>i"
  where "fst(t) == split(t, \<lambda>x y. x)"

definition snd :: "i\<Rightarrow>i"
  where "snd(t) == split(t, \<lambda>x y. y)"

definition thd :: "i\<Rightarrow>i"
  where "thd(t) == split(t, \<lambda>x p. split(p, \<lambda>y z. z))"

definition zero :: "i"
  where "zero == inl(one)"

definition succ :: "i\<Rightarrow>i"
  where "succ(n) == inr(n)"

definition ncase :: "[i,i,i\<Rightarrow>i]\<Rightarrow>i"
  where "ncase(n,b,c) == when(n, \<lambda>x. b, \<lambda>y. c(y))"

definition "let1" :: "[i,i\<Rightarrow>i]\<Rightarrow>i"
  where let_def: "let1(t, f) == case(t,f(true),f(false), \<lambda>x y. f(<x,y>), \<lambda>u. f(lam x. u(x)))"

syntax "_let1" :: "[idt,i,i]\<Rightarrow>i"  ("(3let _ be _/ in _)" [0,0,60] 60)
translations "let x be a in e" == "CONST let1(a, \<lambda>x. e)"

definition letrec :: "[[i,i\<Rightarrow>i]\<Rightarrow>i,(i\<Rightarrow>i)\<Rightarrow>i]\<Rightarrow>i"
  where "letrec(h, b) == b(\<lambda>x. fix(\<lambda>f. lam x. h(x,\<lambda>y. f`y))`x)"

definition letrec2 :: "[[i,i,i\<Rightarrow>i\<Rightarrow>i]\<Rightarrow>i,(i\<Rightarrow>i\<Rightarrow>i)\<Rightarrow>i]\<Rightarrow>i"
  where "letrec2 (h, f) ==
    letrec (\<lambda>p g'. split(p,\<lambda>x y. h(x,y,\<lambda>u v. g'(<u,v>))), \<lambda>g'. f(\<lambda>x y. g'(<x,y>)))"

definition letrec3 :: "[[i,i,i,i\<Rightarrow>i\<Rightarrow>i\<Rightarrow>i]\<Rightarrow>i,(i\<Rightarrow>i\<Rightarrow>i\<Rightarrow>i)\<Rightarrow>i]\<Rightarrow>i"
  where "letrec3 (h, f) ==
    letrec (\<lambda>p g'. split(p,\<lambda>x xs. split(xs,\<lambda>y z. h(x,y,z,\<lambda>u v w. g'(<u,<v,w>>)))),
      \<lambda>g'. f(\<lambda>x y z. g'(<x,<y,z>>)))"

syntax
  "_letrec" :: "[idt,idt,i,i]\<Rightarrow>i"  ("(3letrec _ _ be _/ in _)" [0,0,0,60] 60)
  "_letrec2" :: "[idt,idt,idt,i,i]\<Rightarrow>i"  ("(3letrec _ _ _ be _/ in _)" [0,0,0,0,60] 60)
  "_letrec3" :: "[idt,idt,idt,idt,i,i]\<Rightarrow>i"  ("(3letrec _ _ _ _ be _/ in _)" [0,0,0,0,0,60] 60)
parse_translation \<open>
  let
    fun abs_tr t u = Syntax_Trans.abs_tr [t, u];
    fun letrec_tr [f, x, a, b] =
      Syntax.const \<^const_syntax>\<open>letrec\<close> $ abs_tr x (abs_tr f a) $ abs_tr f b;
    fun letrec2_tr [f, x, y, a, b] =
      Syntax.const \<^const_syntax>\<open>letrec2\<close> $ abs_tr x (abs_tr y (abs_tr f a)) $ abs_tr f b;
    fun letrec3_tr [f, x, y, z, a, b] =
      Syntax.const \<^const_syntax>\<open>letrec3\<close> $ abs_tr x (abs_tr y (abs_tr z (abs_tr f a))) $ abs_tr f b;
  in
    [(\<^syntax_const>\<open>_letrec\<close>, K letrec_tr),
     (\<^syntax_const>\<open>_letrec2\<close>, K letrec2_tr),
     (\<^syntax_const>\<open>_letrec3\<close>, K letrec3_tr)]
  end
\<close>
print_translation \<open>
  let
    val bound = Syntax_Trans.mark_bound_abs;

    fun letrec_tr' [Abs(x,T,Abs(f,S,a)),Abs(ff,SS,b)] =
      let
        val (f',b') = Syntax_Trans.print_abs(ff,SS,b)
        val (_,a'') = Syntax_Trans.print_abs(f,S,a)
        val (x',a') = Syntax_Trans.print_abs(x,T,a'')
      in
        Syntax.const \<^syntax_const>\<open>_letrec\<close> $ bound(f',SS) $ bound(x',T) $ a' $ b'
      end;

    fun letrec2_tr' [Abs(x,T,Abs(y,U,Abs(f,S,a))),Abs(ff,SS,b)] =
      let
        val (f',b') = Syntax_Trans.print_abs(ff,SS,b)
        val ( _,a1) = Syntax_Trans.print_abs(f,S,a)
        val (y',a2) = Syntax_Trans.print_abs(y,U,a1)
        val (x',a') = Syntax_Trans.print_abs(x,T,a2)
      in
        Syntax.const \<^syntax_const>\<open>_letrec2\<close> $ bound(f',SS) $ bound(x',T) $ bound(y',U) $ a' $ b'
      end;

    fun letrec3_tr' [Abs(x,T,Abs(y,U,Abs(z,V,Abs(f,S,a)))),Abs(ff,SS,b)] =
      let
        val (f',b') = Syntax_Trans.print_abs(ff,SS,b)
        val ( _,a1) = Syntax_Trans.print_abs(f,S,a)
        val (z',a2) = Syntax_Trans.print_abs(z,V,a1)
        val (y',a3) = Syntax_Trans.print_abs(y,U,a2)
        val (x',a') = Syntax_Trans.print_abs(x,T,a3)
      in
        Syntax.const \<^syntax_const>\<open>_letrec3\<close> $
          bound(f',SS) $ bound(x',T) $ bound(y',U) $ bound(z',V) $ a' $ b'
      end;
  in
    [(\<^const_syntax>\<open>letrec\<close>, K letrec_tr'),
     (\<^const_syntax>\<open>letrec2\<close>, K letrec2_tr'),
     (\<^const_syntax>\<open>letrec3\<close>, K letrec3_tr')]
  end
\<close>

definition nrec :: "[i,i,[i,i]\<Rightarrow>i]\<Rightarrow>i"
  where "nrec(n,b,c) == letrec g x be ncase(x, b, \<lambda>y. c(y,g(y))) in g(n)"

definition nil :: "i"  ("([])")
  where "[] == inl(one)"

definition cons :: "[i,i]\<Rightarrow>i"  (infixr "$" 80)
  where "h$t == inr(<h,t>)"

definition lcase :: "[i,i,[i,i]\<Rightarrow>i]\<Rightarrow>i"
  where "lcase(l,b,c) == when(l, \<lambda>x. b, \<lambda>y. split(y,c))"

definition lrec :: "[i,i,[i,i,i]\<Rightarrow>i]\<Rightarrow>i"
  where "lrec(l,b,c) == letrec g x be lcase(x, b, \<lambda>h t. c(h,t,g(t))) in g(l)"

definition napply :: "[i\<Rightarrow>i,i,i]\<Rightarrow>i"  ("(_ ^ _ ` _)" [56,56,56] 56)
  where "f ^n` a == nrec(n,a,\<lambda>x g. f(g))"

lemmas simp_can_defs = one_def inl_def inr_def
  and simp_ncan_defs = if_def when_def split_def fst_def snd_def thd_def
lemmas simp_defs = simp_can_defs simp_ncan_defs

lemmas ind_can_defs = zero_def succ_def nil_def cons_def
  and ind_ncan_defs = ncase_def nrec_def lcase_def lrec_def
lemmas ind_defs = ind_can_defs ind_ncan_defs

lemmas data_defs = simp_defs ind_defs napply_def
  and genrec_defs = letrec_def letrec2_def letrec3_def

subsection \<open>Beta Rules, including strictness\<close>

lemma letB: "\<not> t=bot \<Longrightarrow> let x be t in f(x) = f(t)"
  apply (unfold let_def)
  apply (erule rev_mp)
  apply (rule_tac t = "t" in term_case)
      apply simp_all
  done

lemma letBabot: "let x be bot in f(x) = bot"
  unfolding let_def by (rule caseBbot)

lemma letBbbot: "let x be t in bot = bot"
  apply (unfold let_def)
  apply (rule_tac t = t in term_case)
      apply (rule caseBbot)
     apply simp_all
  done

lemma applyB: "(lam x. b(x)) ` a = b(a)"
  by (simp add: apply_def)

lemma applyBbot: "bot ` a = bot"
  unfolding apply_def by (rule caseBbot)

lemma fixB: "fix(f) = f(fix(f))"
  apply (unfold fix_def)
  apply (rule applyB [THEN ssubst], rule refl)
  done

lemma letrecB: "letrec g x be h(x,g) in g(a) = h(a,\<lambda>y. letrec g x be h(x,g) in g(y))"
  apply (unfold letrec_def)
  apply (rule fixB [THEN ssubst], rule applyB [THEN ssubst], rule refl)
  done

lemmas rawBs = caseBs applyB applyBbot

method_setup beta_rl = \<open>
  Scan.succeed (fn ctxt =>
    let val ctxt' = Context_Position.set_visible false ctxt in
      SIMPLE_METHOD' (CHANGED o
        simp_tac (ctxt' addsimps @{thms rawBs} setloop (fn _ => stac ctxt @{thm letrecB})))
    end)
\<close>

lemma ifBtrue: "if true then t else u = t"
  and ifBfalse: "if false then t else u = u"
  and ifBbot: "if bot then t else u = bot"
  unfolding data_defs by beta_rl+

lemma whenBinl: "when(inl(a),t,u) = t(a)"
  and whenBinr: "when(inr(a),t,u) = u(a)"
  and whenBbot: "when(bot,t,u) = bot"
  unfolding data_defs by beta_rl+

lemma splitB: "split(<a,b>,h) = h(a,b)"
  and splitBbot: "split(bot,h) = bot"
  unfolding data_defs by beta_rl+

lemma fstB: "fst(<a,b>) = a"
  and fstBbot: "fst(bot) = bot"
  unfolding data_defs by beta_rl+

lemma sndB: "snd(<a,b>) = b"
  and sndBbot: "snd(bot) = bot"
  unfolding data_defs by beta_rl+

lemma thdB: "thd(<a,<b,c>>) = c"
  and thdBbot: "thd(bot) = bot"
  unfolding data_defs by beta_rl+

lemma ncaseBzero: "ncase(zero,t,u) = t"
  and ncaseBsucc: "ncase(succ(n),t,u) = u(n)"
  and ncaseBbot: "ncase(bot,t,u) = bot"
  unfolding data_defs by beta_rl+

lemma nrecBzero: "nrec(zero,t,u) = t"
  and nrecBsucc: "nrec(succ(n),t,u) = u(n,nrec(n,t,u))"
  and nrecBbot: "nrec(bot,t,u) = bot"
  unfolding data_defs by beta_rl+

lemma lcaseBnil: "lcase([],t,u) = t"
  and lcaseBcons: "lcase(x$xs,t,u) = u(x,xs)"
  and lcaseBbot: "lcase(bot,t,u) = bot"
  unfolding data_defs by beta_rl+

lemma lrecBnil: "lrec([],t,u) = t"
  and lrecBcons: "lrec(x$xs,t,u) = u(x,xs,lrec(xs,t,u))"
  and lrecBbot: "lrec(bot,t,u) = bot"
  unfolding data_defs by beta_rl+

lemma letrec2B:
  "letrec g x y be h(x,y,g) in g(p,q) = h(p,q,\<lambda>u v. letrec g x y be h(x,y,g) in g(u,v))"
  unfolding data_defs letrec2_def by beta_rl+

lemma letrec3B:
  "letrec g x y z be h(x,y,z,g) in g(p,q,r) =
    h(p,q,r,\<lambda>u v w. letrec g x y z be h(x,y,z,g) in g(u,v,w))"
  unfolding data_defs letrec3_def by beta_rl+

lemma napplyBzero: "f^zero`a = a"
  and napplyBsucc: "f^succ(n)`a = f(f^n`a)"
  unfolding data_defs by beta_rl+

lemmas termBs = letB applyB applyBbot splitB splitBbot fstB fstBbot
  sndB sndBbot thdB thdBbot ifBtrue ifBfalse ifBbot whenBinl whenBinr
  whenBbot ncaseBzero ncaseBsucc ncaseBbot nrecBzero nrecBsucc
  nrecBbot lcaseBnil lcaseBcons lcaseBbot lrecBnil lrecBcons lrecBbot
  napplyBzero napplyBsucc

subsection \<open>Constructors are injective\<close>

lemma term_injs:
  "(inl(a) = inl(a')) \<longleftrightarrow> (a=a')"
  "(inr(a) = inr(a')) \<longleftrightarrow> (a=a')"
  "(succ(a) = succ(a')) \<longleftrightarrow> (a=a')"
  "(a$b = a'$b') \<longleftrightarrow> (a=a' \<and> b=b')"
  by (inj_rl applyB splitB whenBinl whenBinr ncaseBsucc lcaseBcons)

subsection \<open>Constructors are distinct\<close>

ML \<open>
ML_Thms.bind_thms ("term_dstncts",
  mkall_dstnct_thms \<^context> @{thms data_defs} (@{thms ccl_injs} @ @{thms term_injs})
    [["bot","inl","inr"], ["bot","zero","succ"], ["bot","nil","cons"]]);
\<close>

subsection \<open>Rules for pre-order \<open>[=\<close>\<close>

lemma term_porews:
  "inl(a) [= inl(a') \<longleftrightarrow> a [= a'"
  "inr(b) [= inr(b') \<longleftrightarrow> b [= b'"
  "succ(n) [= succ(n') \<longleftrightarrow> n [= n'"
  "x$xs [= x'$xs' \<longleftrightarrow> x [= x' \<and> xs [= xs'"
  by (simp_all add: data_defs ccl_porews)

subsection \<open>Rewriting and Proving\<close>

ML \<open>
  ML_Thms.bind_thms ("term_injDs", XH_to_Ds @{thms term_injs});
\<close>

lemmas term_rews = termBs term_injs term_dstncts ccl_porews term_porews

lemmas [simp] = term_rews
lemmas [elim!] = term_dstncts [THEN notE]
lemmas [dest!] = term_injDs

end


(*
 * Copyright 2019, NTU
 *
 * 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.
 *
 *  Author: Albert Rizaldi, NTU Singapore
 *)

theory Dflipflop_Typed
  imports VHDL_Hoare_Typed
begin

text \<open>datatype for all signals\<close>

datatype sig = D | CLK | OUT

definition dflipflop :: "sig conc_stmt" where
  "dflipflop \<equiv> process {CLK} : Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull"

text \<open>The following positive edge is only defined for a scalar signal.\<close>

abbreviation is_posedge2 :: "'signal worldline_init \<Rightarrow> 'signal \<Rightarrow> nat \<Rightarrow>  bool" where
  "is_posedge2 w s j \<equiv> (snd w s (j - 1) = Bv False \<and> snd w s j = Bv True)"

locale ff_typed =
  fixes \<Gamma> :: "sig tyenv"
  assumes tyd: "\<Gamma> D = Bty" and tyclk: "\<Gamma> CLK = Bty" and tyout: "\<Gamma> OUT = Bty"
begin

definition inv :: "sig assn2" where
  "inv tw \<equiv> 1 < fst tw \<longrightarrow> wline_of tw OUT (fst tw) = (if is_posedge2 (snd tw) CLK (fst tw - 1) then wline_of tw D (fst tw - 1) else wline_of tw OUT (fst tw - 1))"

definition inv2 :: "sig assn2" where
  "inv2 tw \<equiv> disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True) \<longrightarrow> (\<forall>i > fst tw. wline_of tw OUT i = wline_of tw OUT (fst tw))"

lemma conc_stmt_wf_mult:
  "conc_stmt_wf dflipflop"
  unfolding dflipflop_def conc_stmt_wf_def by auto

lemma nonneg_delay_conc_mult:
  "nonneg_delay_conc dflipflop"
  unfolding dflipflop_def by auto

lemma nonneg_delay_conc_mult':
  "  nonneg_delay_conc ( process {CLK} : Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull)"
  using nonneg_delay_conc_mult unfolding dflipflop_def by auto

lemma well_typed:
  "seq_wt \<Gamma> (Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull)"
  by (metis bexp_wt.intros(3) seq_wt.intros(1) seq_wt.intros(3) seq_wt.intros(4) tyclk tyd tyout)

lemma conc_wt_mult:
  "conc_wt \<Gamma> dflipflop"
  unfolding dflipflop_def by (meson conc_wt.intros(1) well_typed)

lemma conc_wt_mult':
  "conc_wt \<Gamma> ( process {CLK} : Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull)"
  using conc_wt_mult unfolding dflipflop_def by auto

lemma inv_next_time:
  fixes tw
  assumes "\<not> disjnt {CLK} (event_of tw)"
  defines "v \<equiv> eval_world_raw2 tw (Bsig D)"
  assumes "eval_world_raw2 tw (Bsig CLK) = Bv True"
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  assumes "wityping \<Gamma> (snd tw)"
  assumes "inv tw"
  shows   "inv (fst tw' + 1, snd tw')"
proof -
  { assume "1 < fst tw' + 1"
    hence "0 < fst tw"
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    have bexpIN1: "bexp_wt \<Gamma> (Bsig CLK) (Bty)"
      using ff_typed_axioms unfolding ff_typed_def by (metis bexp_wt.intros(3))+
    have *: "wline_of tw CLK (fst tw) \<noteq> wline_of tw CLK (fst tw - 1)"
      using assms(1) `0 < fst tw` unfolding event_of_alt_def by auto
    have **: "wline_of tw CLK (fst tw) = Bv True"
      using assms(3) by auto
    have "is_posedge2 (snd tw) CLK (fst tw)"
    proof -
      from * have neq: "wline_of tw CLK (fst tw) \<noteq> wline_of tw CLK (fst tw - 1)"
        by auto
      obtain bool where "wline_of tw CLK (fst tw - 1) = Bv bool"
        using eval_world_raw_bv[OF bexpIN1 `wityping \<Gamma> (snd tw)`, of "fst tw - 1"] by auto
      then show ?thesis
        using ** neq by auto
    qed
    have "wline_of tw' OUT (fst tw + 1) = v"
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    also have "... = wline_of tw D (fst tw)"
      using assms(2) unfolding v_def eval_world_raw.simps eval_arith.simps  Let_def comp_def by auto
    also have "... = (if is_posedge2 (snd tw) CLK (fst tw) then wline_of tw D (fst tw) else wline_of tw OUT (fst tw))"
      using `is_posedge2 (snd tw) CLK (fst tw)` by auto
    finally have "wline_of tw' OUT (fst tw + 1) = (if is_posedge2 (snd tw) CLK (fst tw) then wline_of tw D (fst tw) else wline_of tw OUT (fst tw))"
      by auto }
  thus ?thesis
    unfolding inv_def tw'_def worldline_upd2_def worldline_upd_def  by fastforce
qed

lemma inv2_next_time:
  fixes tw v
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  shows   "inv2 (fst tw' + 1, snd tw')"
  unfolding inv2_def  tw'_def worldline_upd2_def worldline_upd_def by auto

lemma conc_hoare:
  "\<And>tw. inv tw \<and> inv2 tw \<and> (disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True)) \<Longrightarrow> inv (fst tw + 1, snd tw)"
proof -
  fix tw
  assume "inv tw \<and> inv2 tw \<and> (disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True))"
  hence "inv tw" and "inv2 tw" and "disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True)"
    by auto
  { assume "1 < fst tw"
    have "wline_of tw OUT (fst tw + 1) = wline_of tw OUT (fst tw)"
      using `inv2 tw` `disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True)` unfolding inv2_def by auto
    also have *: "... = (if is_posedge2 (snd tw) CLK (get_time tw - 1) then wline_of tw D (get_time tw - 1) else wline_of tw OUT (get_time tw - 1))"
      using `inv tw` `1 < fst tw` unfolding inv_def by auto
    also have "... = (if is_posedge2 (snd tw) CLK (get_time tw) then wline_of tw D (get_time tw) else wline_of tw OUT (get_time tw))"
      using `disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True)`  unfolding event_of_alt_def   using *
      by (smt comp_apply diff_is_0_eq' disjnt_insert1 le_numeral_extra(1) mem_Collect_eq val.inject(1))
    finally have "wline_of tw OUT (fst tw + 1) = (if is_posedge2 (snd tw) CLK (get_time tw) then wline_of tw D (get_time tw) else wline_of tw OUT (get_time tw))"
      by auto }
  thus "inv (fst tw + 1, snd tw)"
    unfolding inv_def using \<open>local.inv tw\<close> local.inv_def
    by (smt \<open>local.inv tw \<and> inv2 tw \<and> (disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (get_time tw) \<noteq>
    Bv True)\<close> add_diff_cancel_right' comp_def disjnt_insert1 event_of_alt_def1 fst_conv inv2_def
    less_add_one mem_Collect_eq snd_conv val.inject(1) zero_less_diff)
qed

lemma conc_hoare2:
  "\<And>tw. inv2 tw \<and> (disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) \<noteq> (Bv True)) \<Longrightarrow> inv2 (fst tw + 1, snd tw)"
  unfolding inv2_def by auto

lemma conc_sim2':
  "\<Gamma> \<turnstile>\<^sub>s \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace> dflipflop \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace>"
  apply (rule While_Suc)
  apply (rule Conseq'[where P="wp3_conc \<Gamma> dflipflop (\<lambda>tw. inv  (fst tw + 1, snd tw) \<and>
                                                          inv2 (fst tw + 1, snd tw))", rotated])
  apply (rule wp3_conc_is_pre, rule conc_stmt_wf_mult, rule nonneg_delay_conc_mult, rule conc_wt_mult, simp)
  unfolding dflipflop_def  wp3_conc_single'[OF conc_wt_mult' nonneg_delay_conc_mult'] wp3_fun.simps
  using inv_next_time inv2_next_time conc_hoare conc_hoare2 by auto

subsection \<open>Initialisation satisfies @{term "inv"} and @{term "inv2"}\<close>

lemma nonneg_delay:
  "nonneg_delay ( Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull)"
  using nonneg_delay_conc_mult' by auto

lemma inv_next_time0:
  assumes "fst tw = 0"
  defines "v \<equiv> eval_world_raw2 tw (Bsig D)"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 v]"
  shows   "inv (fst tw' + 1, snd tw')"
  unfolding inv_def by (simp add: assms(1) tw'_def)

lemma inv2_next_time0:
  assumes "fst tw = 0"
  assumes "eval_world_raw2 tw (Bsig CLK) \<noteq> Bv True"
  assumes "\<forall>i. wline_of tw OUT i = wline_of tw OUT 0"
  shows   "inv2 (fst tw + 1, snd tw)"
  using assms unfolding inv2_def  by (metis comp_apply snd_conv)

lemma inv_next_time0'':
  assumes "fst tw = 0"
  shows   "inv (fst tw + 1, snd tw)"
  unfolding inv_def  by (simp add: assms(1))

lemma init_sat_nand_inv_comb:
  "init_sim2_hoare_wt \<Gamma> (\<lambda>tw. fst tw = 0 \<and> (\<forall>i. wline_of tw OUT i = wline_of tw OUT 0)) dflipflop (\<lambda>tw. inv tw \<and> inv2 tw)"
  unfolding dflipflop_def
  apply (rule AssignI_suc, rule SingleI)
  apply (rule Conseq3[where Q="\<lambda>tw. inv (fst tw + 1, snd tw) \<and> inv2 (fst tw + 1, snd tw)", rotated])
  apply (rule wp3_fun_is_pre[OF well_typed nonneg_delay], simp)
  unfolding wp3_fun.simps using inv_next_time inv2_next_time inv_next_time0 inv2_next_time0 inv_next_time0''
  by auto

lemma
  assumes "sim_fin2 w (i + 2) dflipflop tw'"
  assumes "\<forall>i. wline_of (0, w) OUT i = wline_of (0, w) OUT 0"
  assumes " conc_wt \<Gamma> dflipflop" and "wityping \<Gamma> w"
  shows "wline_of tw' OUT (i + 2) = (if is_posedge2 (snd tw') CLK (i + 1) then wline_of tw' D (i + 1) else wline_of tw' OUT (i + 1))"
  using grand_correctness2[OF assms(1) assms(4) conc_stmt_wf_mult conc_wt_mult nonneg_delay_conc_mult conc_sim2' assms(2) init_sat_nand_inv_comb]
  unfolding inv_def
  by (metis (no_types, lifting) add.assoc add_diff_cancel_right' assms(1) discrete le_add2 one_add_one sim_fin2.cases world_maxtime_lt_fst_tres)

end