theory NF
  imports
    Saturation
    Bot_Terms
    Regular_Tree_Relations.Tree_Automata
begin

subsection \<open>Recognizing normal forms of left linear TRSs\<close>

interpretation lift_total: semilattice_closure_partial_operator "\<lambda> x y. (x, y) \<in> mergeP" "(\<up>)" "\<lambda> x y. x \<le>\<^sub>b y" Bot
  apply unfold_locales apply (auto simp: merge_refl merge_symmetric merge_terms_assoc merge_terms_idem merge_bot_args_bless_eq_merge)
  using merge_dist apply blast
  using megeP_ass apply blast
  using merge_terms_commutative apply blast
  apply (metis bless_eq_mergeP bless_eq_trans merge_bot_args_bless_eq_merge merge_dist merge_symmetric merge_terms_commutative)
  apply (metis merge_bot_args_bless_eq_merge merge_symmetric merge_terms_commutative)
  using bless_eq_closued_under_supremum bless_eq_trans bless_eq_anti_sym
  by blast+

abbreviation "psubt_lhs_bot R \<equiv> {t\<^sup>\<bottom> | s t. s \<in> R \<and> s \<rhd> t}"
abbreviation "closure S \<equiv> lift_total.cl.pred_closure S"

definition states where
  "states R = insert Bot (closure (psubt_lhs_bot R))"

lemma psubt_mono:
  "R \<subseteq> S \<Longrightarrow> psubt_lhs_bot R \<subseteq> psubt_lhs_bot S" by auto

lemma states_mono:
  "R \<subseteq> S \<Longrightarrow> states R \<subseteq> states S"
  unfolding states_def using lift_total.cl.closure_mono[OF psubt_mono[of R S]]
  by auto

lemma finite_lhs_subt [simp, intro]:
  assumes "finite R"
  shows "finite (psubt_lhs_bot R)"
proof -
  have conv: "psubt_lhs_bot R = term_to_bot_term ` {t | s t . s \<in> R \<and> s \<rhd> t}" by auto
  from assms have "finite {t | s t . s \<in> R \<and> s \<rhd> t}"
    by (simp add: finite_strict_subterms)
  then show ?thesis using conv by auto
qed

lemma states_ref_closure:
  "states R \<subseteq> insert Bot (closure (psubt_lhs_bot R))"
  unfolding states_def by auto

lemma finite_R_finite_states [simp, intro]:
  "finite R \<Longrightarrow> finite (states R)"
  using finite_lhs_subt states_ref_closure
  using lift_total.cl.finite_S_finite_closure finite_subset
  by fastforce

abbreviation "lift_sup_small s S \<equiv> lift_total.supremum (lift_total.smaller_subset (Some s) (Some ` S))"
abbreviation "bound_max s S \<equiv> the (lift_sup_small s S)"

lemma bound_max_state_set:
  assumes "finite R"
  shows "bound_max t (psubt_lhs_bot R) \<in> states R"
  using lift_total.supremum_neut_or_in_closure[OF finite_lhs_subt[OF assms], of t]
  unfolding states_def by auto

context
includes fset.lifting
begin
lift_definition fstates :: "('a, 'b) term fset \<Rightarrow> 'a bot_term fset" is states
  by simp

lemma bound_max_state_fset:
  "bound_max t (psubt_lhs_bot (fset R)) |\<in>| fstates R"
  using bound_max_state_set[of "fset R" t]
  using fstates.rep_eq notin_fset by fastforce

end

definition nf_rules where
  "nf_rules R \<F> = {|TA_rule f qs q | f qs q. (f, length qs) |\<in>| \<F> \<and> fset_of_list qs |\<subseteq>| fstates R \<and>
      \<not>(\<exists> l |\<in>| R. l\<^sup>\<bottom> \<le>\<^sub>b BFun f qs) \<and> q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))|}"

lemma nf_rules_fmember:
  "TA_rule f qs q |\<in>| nf_rules R \<F> \<longleftrightarrow> (f, length qs) |\<in>| \<F> \<and> fset_of_list qs |\<subseteq>| fstates R \<and>
    \<not>(\<exists> l |\<in>| R. l\<^sup>\<bottom> \<le>\<^sub>b BFun f qs) \<and> q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))"
proof -
  let ?subP = "\<lambda> n qs. fset_of_list qs |\<subseteq>| fstates R \<and> length qs = n"
  let ?sub = "\<lambda> n. Collect (?subP n)"
  have *: "finite (?sub n)" for n
    using finite_lists_length_eq[of "fset (fstates R)" n]
    by (simp add: less_eq_fset.rep_eq fset_of_list.rep_eq)
  {fix f n assume mem: "(f, n) \<in> fset \<F>"
    have **: "{f} \<times> (?sub n) = {(f, qs) |qs. ?subP n qs}" by auto
    from mem have "finite {(f, qs) |qs. ?subP n qs}" using *
      using finite_cartesian_product[OF _ *[of n], of "{f}"] unfolding ** by simp}
  then have *: "finite (\<Union> (f, n) \<in> fset \<F> . {(f, qs) | qs. ?subP n qs})" by auto
  have **: "(\<Union> (f, n) \<in> fset \<F> . {(f, qs) | qs. ?subP n qs}) = {(f, qs) | f qs. (f, length qs) |\<in>| \<F> \<and> ?subP (length qs) qs}"
    by (auto simp: fmember_iff_member_fset)
  have *: "finite ({(f, qs) | f qs. (f, length qs) |\<in>| \<F> \<and> ?subP (length qs) qs} \<times> fset (fstates R))"
    using * unfolding ** by (intro finite_cartesian_product) auto
  have **: "{TA_rule f qs q | f qs q. (f, length qs) |\<in>| \<F> \<and> fset_of_list qs |\<subseteq>| fstates R \<and> q |\<in>| fstates R} =
    (\<lambda> ((f, qs), q). TA_rule f qs q) ` ({(f, qs) | f qs. (f, length qs) |\<in>| \<F> \<and> ?subP (length qs) qs} \<times> fset (fstates R))"
    by (auto simp: image_def fmember_iff_member_fset split!: prod.splits)
  have f: "finite {TA_rule f qs q | f qs q. (f, length qs) |\<in>| \<F> \<and> fset_of_list qs |\<subseteq>| fstates R \<and> q |\<in>| fstates R}"
    unfolding ** using * by auto
  show ?thesis
    by (auto simp: nf_rules_def bound_max_state_fset intro!: finite_subset[OF _ f])
qed

definition nf_ta where
  "nf_ta R \<F> = TA (nf_rules R \<F>) {||}"

definition nf_reg where
  "nf_reg R \<F> = Reg (fstates R) (nf_ta R \<F>)"

lemma bound_max_sound:
  assumes "finite R"
  shows "bound_max t (psubt_lhs_bot R) \<le>\<^sub>b t"
  using assms lift_total.lift_ord.supremum_smaller_subset[of "Some ` psubt_lhs_bot R" "Some t"]
  by auto (metis (no_types, lifting) lift_less_eq_total.elims(2) option.sel option.simps(3))

lemma Bot_in_filter:
  "Bot \<in> Set.filter (\<lambda>s. s \<le>\<^sub>b t) (states R)"
  by (auto simp: Set.filter_def states_def)

lemma bound_max_exists:
  "\<exists> p. p = bound_max t (psubt_lhs_bot R)"
  by blast

lemma bound_max_unique:
  assumes "p = bound_max t (psubt_lhs_bot R)" and "q = bound_max t (psubt_lhs_bot R)"
  shows "p = q" using assms by force

lemma nf_rule_to_bound_max:
  "f qs \<rightarrow> q |\<in>| nf_rules R \<F> \<Longrightarrow> q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))"
  by (auto simp: nf_rules_fmember)

lemma nf_rules_unique:
  assumes "f qs \<rightarrow> q |\<in>| nf_rules R \<F>" and "f qs \<rightarrow> q' |\<in>| nf_rules R \<F>"
  shows "q = q'" using assms unfolding nf_rules_def
  using nf_rule_to_bound_max[OF assms(1)]  nf_rule_to_bound_max[OF assms(2)]
  using bound_max_unique by blast

lemma nf_ta_det:
  shows "ta_det (nf_ta R \<F>)"
  by (auto simp add: ta_det_def nf_ta_def nf_rules_unique)

lemma term_instance_of_reach_state:
  assumes "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars t)" and "ground t"
  shows "q \<le>\<^sub>b t\<^sup>\<bottom>" using assms(1, 2)
proof(induct t arbitrary: q)
  case (Fun f ts)
  from Fun(2) obtain qs where wit: "f qs \<rightarrow> q |\<in>| nf_rules R \<F>" "length qs = length ts"
    "\<forall> i < length ts. qs ! i |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i))"
    by (auto simp add: nf_ta_def)
  then have "BFun f qs \<le>\<^sub>b Fun f ts\<^sup>\<bottom>" using Fun(1)[OF nth_mem, of i "qs !i" for i] using Fun(3)
    by auto
  then show ?case using bless_eq_trans wit(1) bound_max_sound[of "fset R"]
    by (auto simp: nf_rules_fmember)
qed auto

lemma subt_less_eq_res_less_eq:
  assumes ground: "ground t" and "l |\<in>| R" and "l \<rhd> s" and "s\<^sup>\<bottom> \<le>\<^sub>b t\<^sup>\<bottom>"
    and "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars t)"
  shows "s\<^sup>\<bottom> \<le>\<^sub>b q" using assms(2-)
proof (induction t arbitrary: q s)
  case (Var x)
  then show ?case using lift_total.anti_sym by fastforce
next
  case (Fun f ts) note IN = this
  from IN obtain qs where rule: "f qs \<rightarrow> q |\<in>| nf_rules R \<F>" and
    reach: "length qs = length ts" "\<forall> i < length ts. qs ! i |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i))"
    by (auto simp add: nf_ta_def)
  have q: "lift_sup_small (BFun f qs) (psubt_lhs_bot (fset R)) = Some q"
    using nf_rule_to_bound_max[OF rule]
    using lift_total.supremum_smaller_exists_unique[OF finite_lhs_subt, of "fset R" "BFun f qs"]
    by simp (metis option.collapse option.distinct(1))
  have subst: "s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs" using IN(1)[OF nth_mem, of i "term.args s ! i" "qs ! i" for i] IN(2-) reach
    by (cases s) (auto elim!: bless_eq.cases)
  have "s\<^sup>\<bottom> \<in> psubt_lhs_bot (fset R)" using Fun(2 - 4)
    by auto (metis notin_fset)
  then have "lift_total.lifted_less_eq (Some (s\<^sup>\<bottom>)) (lift_sup_small (BFun f qs) (psubt_lhs_bot (fset R)))"
    using subst
    by (intro lift_total.lift_ord.supremum_sound)
     (auto simp: lift_total.lift_ord.smaller_subset_def)
  then show ?case using subst q finite_lhs_subt
    by auto
qed

lemma ta_nf_sound1:
  assumes ground: "ground t" and lhs: "l |\<in>| R" and inst: "l\<^sup>\<bottom> \<le>\<^sub>b t\<^sup>\<bottom>"
  shows "ta_der (nf_ta R \<F>) (adapt_vars t) = {||}"
proof (rule ccontr)
  assume ass: "ta_der (nf_ta R \<F>) (adapt_vars t) \<noteq> {||}"
  show False proof (cases t)
    case [simp]: (Fun f ts) from ass
    obtain q qs where fin: "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (Fun f ts))" and
      rule: "(f qs \<rightarrow> q) |\<in>| rules (nf_ta R \<F>)" "length qs = length ts" and
      reach: "\<forall> i < length ts. qs ! i |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i))"
      by (auto simp add: nf_ta_def) blast
    have "l\<^sup>\<bottom> \<le>\<^sub>b  BFun f qs" using reach assms(1) inst rule(2)
      using subt_less_eq_res_less_eq[OF _ lhs, of "ts ! i" "term.args l ! i" "qs ! i" \<F> for i]
        by (cases l) (auto elim!: bless_eq.cases intro!: bless_eq.step)
    then show ?thesis using lhs rule by (auto simp: nf_ta_def nf_rules_def)
  qed (metis ground ground.simps(1))
qed

lemma ta_nf_tr_to_state:
  assumes "ground t" and "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars t)"
  shows "q |\<in>| fstates R" using assms bound_max_state_fset
  by (cases t) (auto simp: states_def nf_ta_def nf_rules_def)

lemma ta_nf_sound2:
  assumes linear: "\<forall> l |\<in>| R. linear_term l"
    and "ground (t :: ('f, 'v) term)" and "funas_term t \<subseteq> fset \<F>"
    and NF: "\<And> l s. l |\<in>| R \<Longrightarrow> t \<unrhd> s \<Longrightarrow> \<not> l\<^sup>\<bottom> \<le>\<^sub>b s\<^sup>\<bottom>"
  shows "\<exists> q. q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars t)" using assms(2 - 4)
proof (induct t)
  case (Fun f ts)
  have sub: "\<And> i. i < length ts \<Longrightarrow> (\<And>l s. l |\<in>| R \<Longrightarrow> ts ! i \<unrhd> s \<Longrightarrow> \<not> l\<^sup>\<bottom> \<le>\<^sub>b s\<^sup>\<bottom>) " using Fun(4) nth_mem by blast
  from Fun(1)[OF nth_mem] this Fun(2, 3) obtain qs where
    reach: "(\<forall> i < length ts. qs ! i |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i)))" and len: "length qs = length ts"
    using Ex_list_of_length_P[of "length ts" "\<lambda> x i. x |\<in>| (ta_der (nf_ta R \<F>) (adapt_vars (ts ! i)))"]
    by auto (meson UN_subset_iff nth_mem)
  have nt_inst: "\<not> (\<exists> s |\<in>| R. s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs)"
  proof (rule ccontr, simp)
    assume ass: "\<exists> s |\<in>| R. s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs"
    from term_instance_of_reach_state[of "qs ! i" R \<F> "ts ! i" for i] reach Fun(2) len
    have "BFun f qs \<le>\<^sub>b Fun f ts\<^sup>\<bottom>" by auto
    then show False using ass Fun(4) bless_eq_trans by blast
  qed
  obtain q where "q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))" by blast
  then have "f qs \<rightarrow> q |\<in>| rules (nf_ta R \<F>)" using Fun(2 - 4)
    using ta_nf_tr_to_state[of "ts ! i" "qs ! i" R \<F> for i] len nt_inst reach
    by (auto simp: nf_ta_def nf_rules_fmember, simp add: fmember_iff_member_fset)
       (metis (no_types, lifting) in_fset_idx nth_mem)
  then show ?case using reach len by auto
qed auto

lemma ta_nf_lang_sound:
  assumes "l |\<in>| R"
  shows "C\<langle>l \<cdot> \<sigma>\<rangle> \<notin> ta_lang (fstates R) (nf_ta R \<F>)"
proof (rule ccontr, simp del: ta_lang_to_gta_lang)
  assume *: "C\<langle>l \<cdot> \<sigma>\<rangle> \<in> ta_lang (fstates R) (nf_ta R \<F>)"
  then have cgr:"ground (C\<langle>l\<cdot>\<sigma>\<rangle>)" unfolding ta_lang_def by force
  then have gr: "ground (l \<cdot> \<sigma>)" by simp
  then have  "l\<^sup>\<bottom> \<le>\<^sub>b (l \<cdot> \<sigma>)\<^sup>\<bottom>" using instance_to_bless_eq by blast
  from ta_nf_sound1[OF gr assms(1) this] have res: "ta_der (nf_ta R \<F>) (adapt_vars (l \<cdot> \<sigma>)) = {||}" .
  from ta_langE * obtain q where "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (C\<langle>l\<cdot>\<sigma>\<rangle>))"
    by (metis adapt_vars_adapt_vars)
  with ta_der_ctxt_decompose[OF this[unfolded adapt_vars_ctxt]] res
  show False by blast
qed

lemma ta_nf_lang_complete:
  assumes linear: "\<forall> l |\<in>| R. linear_term l"
      and ground: "ground (t :: ('f, 'v) term)" and sig: "funas_term t \<subseteq> fset \<F>"
      and nf: "\<And>C \<sigma> l. l |\<in>| R \<Longrightarrow> C\<langle>l\<cdot>\<sigma>\<rangle> \<noteq> t"
    shows "t \<in> ta_lang (fstates R) (nf_ta R \<F>)"
proof -
  from nf have "\<And> l s. l |\<in>| R \<Longrightarrow> t \<unrhd> s \<Longrightarrow> \<not> l\<^sup>\<bottom> \<le>\<^sub>b s\<^sup>\<bottom>"
    using bless_eq_to_instance linear by blast
  from ta_nf_sound2[OF linear ground sig] this
  obtain q where "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars t)" by blast
  from this ta_nf_tr_to_state[OF ground this] ground show ?thesis
    by (intro ta_langI) (auto simp add: nf_ta_def)
qed

lemma ta_nf_\<L>_complete:
  assumes linear: "\<forall> l |\<in>| R. linear_term l"
      and sig: "funas_gterm t \<subseteq> fset \<F>"
      and nf: "\<And>C \<sigma> l. l |\<in>| R \<Longrightarrow> C\<langle>l\<cdot>\<sigma>\<rangle> \<noteq> (term_of_gterm t)"
    shows "t \<in> \<L> (nf_reg R \<F>)"
  using ta_nf_lang_complete[of R "term_of_gterm t" \<F>] assms
  by (force simp: \<L>_def nf_reg_def funas_term_of_gterm_conv)

lemma nf_ta_funas:
  assumes "ground t" "q |\<in>| ta_der (nf_ta R \<F>) t"
  shows "funas_term t \<subseteq> fset \<F>" using assms
proof (induct t arbitrary: q)
  case (Fun f ts)
  from Fun(2-) have "(f, length ts) |\<in>| \<F>"
    by (auto simp: nf_ta_def nf_rules_def)
  then show ?case using Fun
    by (auto simp: fmember_iff_member_fset) (metis Fun.hyps Fun.prems(2) in_set_idx subsetD ta_der_Fun)
qed auto

lemma gta_lang_nf_ta_funas:
  assumes "t \<in> \<L> (nf_reg R \<F>)"
  shows "funas_gterm t \<subseteq> fset \<F>" using assms nf_ta_funas[of "term_of_gterm t" _ R \<F>]
  unfolding nf_reg_def \<L>_def
  by (auto simp: funas_term_of_gterm_conv)

end


(*  Author:     Gertrud Bauer, Tobias Nipkow
*)

section \<open>Properties of Lower Bound Machinery\<close>

theory ScoreProps
imports ListSum TameEnum PlaneProps TameProps
begin

lemma deleteAround_empty[simp]: "deleteAround g a [] = []"
by (simp add: deleteAround_def)

lemma deleteAroundCons:
  "deleteAround g a (p#ps) =
    (if fst p \<in> {v. \<exists>f \<in> set (facesAt g a).
               (length (vertices f) = 4) \<and> v \<in> {f \<bullet> a, f \<bullet> (f \<bullet> a)}
             \<or> (length (vertices f) \<noteq> 4) \<and> (v = f \<bullet> a)}
     then deleteAround g a ps
     else p#deleteAround g a ps)"
by (fastforce simp: nextV2 deleteAround_def)

lemma deleteAround_subset: "set (deleteAround g a ps) \<subseteq> set ps"
by (simp add: deleteAround_def)

lemma distinct_deleteAround: "distinct (map fst ps) \<Longrightarrow>
    distinct (map fst (deleteAround g (fst (a, b)) ps))"
proof (induct ps)
  case Nil then show ?case by simp
next
  case (Cons p ps)
  then have "fst p \<notin> fst ` set ps" by simp
  moreover have "set (deleteAround g a ps) \<subseteq> set ps"
    by (rule deleteAround_subset)
  ultimately have "fst p \<notin> fst ` set (deleteAround g a ps)" by auto

  moreover from Cons have "distinct (map fst ps)" by simp
  then have "distinct (map fst (deleteAround g (fst (a, b)) ps))"
    by (rule Cons)
  ultimately show ?case by (simp add: deleteAroundCons)
qed

definition deleteAround' :: "graph \<Rightarrow> vertex \<Rightarrow> (vertex \<times> nat) list \<Rightarrow>
    (vertex \<times> nat) list" where
  "deleteAround' g v ps \<equiv>
      let fs = facesAt g v;
      vs = (\<lambda>f. let n1 = f \<bullet> v;
                n2 = f \<bullet> n1 in
                if length (vertices f) = 4 then [n1, n2] else [n1]);
      ws = concat (map vs fs) in
      removeKeyList ws ps"

lemma deleteAround_eq: "deleteAround g v ps = deleteAround' g v ps"
apply (auto simp add: deleteAround_def deleteAround'_def split: if_split_asm)
apply (unfold nextV2[THEN eq_reflection], simp)
done

lemma deleteAround_nextVertex:
  "f \<in> set (facesAt g a) \<Longrightarrow>
  (f \<bullet> a, b) \<notin> set (deleteAround g a ps)"
by (auto simp add: deleteAround_eq deleteAround'_def removeKeyList_eq)

lemma deleteAround_nextVertex_nextVertex:
  "f \<in> set (facesAt g a) \<Longrightarrow> |vertices f| = 4 \<Longrightarrow>
  (f \<bullet> (f \<bullet> a), b) \<notin> set (deleteAround g a ps)"
by (auto simp add: deleteAround_eq deleteAround'_def removeKeyList_eq)

lemma deleteAround_prevVertex:
  "minGraphProps g \<Longrightarrow> a : \<V> g \<Longrightarrow> f \<in> set (facesAt g a) \<Longrightarrow>
  (f\<^bsup>-1\<^esup> \<bullet> a, b) \<notin> set (deleteAround g a ps)"
proof -
  assume a: "minGraphProps g" "a : \<V> g" "f \<in> set (facesAt g a)"
  have "(f\<^bsup>-1\<^esup> \<bullet> a, a) \<in> \<E> f" using a
    by(blast intro:prevVertex_in_edges minGraphProps)
  then obtain f' :: face where f': "f' \<in> set(facesAt g a)"
    and e: "(a, f\<^bsup>-1\<^esup> \<bullet> a) \<in> \<E> f'"
    using a by(blast dest:mgp_edge_face_ex)
  have "(f' \<bullet> a, b) \<notin> set (deleteAround g a ps)" using f'
    by (auto simp add: deleteAround_eq deleteAround'_def removeKeyList_eq)
  moreover have "f' \<bullet> a = f\<^bsup>-1\<^esup> \<bullet> a"
    using e by (simp add:edges_face_eq)
  ultimately show ?thesis by simp
qed

lemma deleteAround_separated:
assumes mgp: "minGraphProps g" and fin: "final g" and ag: "a : \<V> g" and 4: "|vertices f| \<le> 4"
and f: "f \<in> set(facesAt g a)"
shows "\<V> f \<inter> set [fst p. p \<leftarrow> deleteAround g a ps] \<subseteq> {a}" (is "?A")
proof -
  note MGP = mgp ag f
  have af: "a \<in> \<V> f" using MGP by(blast intro:minGraphProps)
  have "2 < |vertices f|" using MGP by(blast intro:minGraphProps)
  with 4 have "|vertices f| = 3 \<or> |vertices f| = 4" by arith
  then show "?A"
  proof
    assume 3: "|vertices f| = 3"
    show "?A"
    proof (rule ccontr)
      assume "\<not> ?A"
      then obtain b where b1: "b \<noteq> a" "b \<in> \<V> f"
        "b \<in> set (map fst (deleteAround g a ps))" by auto
      from MGP have d: "distinct (vertices f)"
        by(blast intro:minGraphProps)
      with af 3 have "\<V> f = {a, f \<bullet> a, f \<bullet> (f \<bullet> a)}"
          by (rule_tac vertices_triangle)
      also from d af 3 have
        "f \<bullet> (f \<bullet> a) = f\<^bsup>-1\<^esup> \<bullet> a"
        by (simp add: triangle_nextVertex_prevVertex)
      finally have
        "b \<in> {f \<bullet> a, f\<^bsup>-1\<^esup> \<bullet> a}"
        using b1 by simp
      with MGP have "b \<notin> set (map fst (deleteAround g a ps))"
      using deleteAround_nextVertex deleteAround_prevVertex by auto
      then show False by contradiction (rule b1)
    qed
  next
    assume 4: "|vertices f| = 4"
    show "?A"
    proof (rule ccontr)
      assume "\<not> ?A"
      then obtain b where b1: "b \<noteq> a" "b \<in> \<V> f"
        "b \<in> set (map fst (deleteAround g a ps))" by auto
      from MGP have d: "distinct (vertices f)" by(blast intro:minGraphProps)
      with af 4 have "\<V> f = {a, f \<bullet> a, f \<bullet> (f \<bullet> a), f \<bullet> (f \<bullet> (f \<bullet> a))}"
        by (rule_tac vertices_quad)
      also from d af 4 have "f \<bullet> (f \<bullet> (f \<bullet> a)) = f\<^bsup>-1\<^esup> \<bullet> a"
        by (simp add: quad_nextVertex_prevVertex)
      finally have "b \<in> {f \<bullet> a, f \<bullet> (f \<bullet> a), f\<^bsup>-1\<^esup> \<bullet> a}"
      using b1 by simp
      with MGP 4 have "b \<notin> set (map fst (deleteAround g a ps))"
      using deleteAround_nextVertex deleteAround_prevVertex
           deleteAround_nextVertex_nextVertex by auto
      then show False by contradiction (rule b1)
    qed
  qed
qed
(*
deleteAround g y loescht nextVertex f a,
nextVertex f (nextVertex f a),
prevVertex f a wird mit nachbarflaeche geloescht.
*)

lemma separated_insert:
assumes mgp: "minGraphProps g" and a: "a \<in> \<V> g"
  and Vg: "V \<subseteq> \<V> g"
  and ps: "separated g V"
  and s2: "(\<And>f. f \<in> set (facesAt g a) \<Longrightarrow> f \<bullet> a \<notin> V)"
  and s3: "(\<And>f. f \<in> set (facesAt g a) \<Longrightarrow>
      |vertices f| \<le> 4 \<Longrightarrow> \<V> f \<inter> V \<subseteq> {a})"
  shows "separated g (insert a V)"
proof (simp add: separated_def separated\<^sub>2_def separated\<^sub>3_def,
 intro conjI ballI impI)
  fix f assume f: "f \<in> set (facesAt g a)"
  then show "f \<bullet> a \<noteq> a" by (rule mgp_facesAt_no_loop[OF mgp a])
  from f show "f \<bullet> a \<notin> V" by (rule s2)
next
  fix f v assume v: "f \<in> set (facesAt g v)" and vV: "v \<in> V"
  have "v : \<V> g" using vV Vg by blast
  show "f \<bullet> v \<noteq> a"
  proof
    assume f: "f \<bullet> v = a"
    then obtain f' where f': "f' \<in> set(facesAt g a)" and v: "f' \<bullet> a = v"
      using mgp_nextVertex_face_ex2[OF mgp \<open>v : \<V> g\<close> v] by blast
    have "f' \<bullet> a \<in> V" using v vV by simp
    with f' s2 show False by blast
  qed
  from ps v vV show "f \<bullet> v \<notin> V"
    by (simp add: separated_def separated\<^sub>2_def)
next
  fix f assume f:  "f \<in> set (facesAt g a)" "|vertices f| \<le> 4"
  then have "\<V> f \<inter> V \<subseteq> {a}" by (rule s3)
  moreover from mgp a f have "a \<in> \<V> f" by(blast intro:minGraphProps)
  ultimately show "\<V> f \<inter> insert a V = {a}" by auto
next
  fix v f
  assume a: "v \<in> V" "f \<in> set (facesAt g v)"
    "|vertices f| \<le> 4"
  with ps have v: "\<V> f \<inter> V = {v}"
    by (simp add: separated_def separated\<^sub>3_def)
  have "v : \<V> g" using a Vg by blast
  show  "\<V> f \<inter> insert a V = {v}"
  proof cases
    assume "a = v"
    with v mgp a show ?thesis by(blast intro:minGraphProps)
  next
    assume n: "a \<noteq> v"
    have  "a \<notin> \<V> f"
    proof
      assume a2: "a \<in> \<V> f"
      with mgp a \<open>v : \<V> g\<close> have "f \<in> \<F> g" by(blast intro:minGraphProps)
      with mgp a2 have "f \<in> set (facesAt g a)" by(blast intro:minGraphProps)
      with a have "\<V> f \<inter> V \<subseteq> {a}" by (simp add: s3)
      with v have "a = v" by auto
      with n show False by auto
    qed
    with a  v show "\<V> f \<inter> insert a V = {v}" by blast
  qed
qed

function ExcessNotAtRecList :: "(vertex, nat) table \<Rightarrow> graph \<Rightarrow> vertex list" where
  "ExcessNotAtRecList [] = (\<lambda>g. [])"
  | "ExcessNotAtRecList ((x, y) # ps) = (\<lambda>g.
      let l1 = ExcessNotAtRecList ps g;
      l2 = ExcessNotAtRecList (deleteAround g x ps) g in
      if ExcessNotAtRec ps g
       \<le> y + ExcessNotAtRec (deleteAround g x ps) g
      then x # l2 else l1)"
by pat_completeness auto
termination by (relation "measure size")
  (auto simp add: less_Suc_eq_le length_deleteAround)

lemma isTable_deleteAround:
  "isTable E vs ((a,b)#ps) \<Longrightarrow> isTable E vs (deleteAround g a ps)"
by (rule isTable_subset, rule deleteAround_subset,
    rule isTable_Cons)

lemma ListSum_ExcessNotAtRecList:
 "isTable E vs ps \<Longrightarrow> ExcessNotAtRec ps g
  = (\<Sum>\<^bsub>p \<in> ExcessNotAtRecList ps g\<^esub> E p)" (is "?T ps \<Longrightarrow> ?P ps")
proof (induct ps rule: ExcessNotAtRecList.induct)
  case 1 show ?case by simp
next
  case (2 a b ps)
  from 2 have prem: "?T ((a,b)#ps)" by blast
  then have E: "b = E a" by (simp add: isTable_eq)
  from 2 have hyp1: "?T (deleteAround g a ps) \<Longrightarrow>
   ?P (deleteAround g a ps)" by blast
  from 2 have hyp2:  "?T ps \<Longrightarrow> ?P ps" by blast
  have H1: "?P (deleteAround g a ps)"
    by (rule hyp1, rule isTable_deleteAround) (rule prem)
  have H2: "?P ps" by (rule hyp2, rule isTable_Cons, rule prem)
  show "?P ((a,b)#ps)"
  proof cases
    assume
    "ExcessNotAtRec ps g
    \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
    with H1 E show ?thesis
      by (simp add: max_def split: if_split_asm)
  next
    assume "\<not> ExcessNotAtRec ps g
       \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
    with H2 E show ?thesis
      by (simp add: max_def split: if_split_asm)
  qed
qed

lemma ExcessNotAtRecList_subset:
  "set (ExcessNotAtRecList ps g) \<subseteq> set [fst p. p \<leftarrow> ps]" (is "?P ps")
proof (induct ps rule: ExcessNotAtRecList.induct)
  case 1 show ?case by simp
next
  case (2 a b ps)
  presume H1: "?P (deleteAround g a ps)"
  presume H2: "?P ps"
  show "?P ((a, b) # ps)"
  proof cases
    assume a: "ExcessNotAtRec ps g
      \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
    have "set (deleteAround g a ps) \<subseteq> set ps"
      by (simp add: deleteAround_subset)
    then have
    "fst ` set (deleteAround g a ps) \<subseteq> insert a (fst ` set ps)"
      by blast
    with a H1 show ?thesis by (simp)
  next
    assume "\<not> ExcessNotAtRec ps g
      \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
    with H2 show ?thesis by (auto)
  qed
qed simp

lemma separated_ExcessNotAtRecList:
 "minGraphProps g \<Longrightarrow> final g \<Longrightarrow> isTable E (vertices g) ps \<Longrightarrow>
  separated g (set (ExcessNotAtRecList ps g))"
proof -
  assume fin: "final g" and mgp: "minGraphProps g"
  show
   "isTable E (vertices g) ps \<Longrightarrow> separated g (set (ExcessNotAtRecList ps g))"
   (is "?T ps \<Longrightarrow> ?P ps")
  proof (induct rule: ExcessNotAtRec.induct)
    case 1 show ?case by simp
  next
    case (2 a b ps)
    from 2 have prem: "?T ((a,b)#ps)" by blast
    then have E: "b = E a" by (simp add: isTable_eq)
    have "a :\<V> g" using prem by(auto simp: isTable_def)
    from 2 have hyp1: "?T (deleteAround g a ps) \<Longrightarrow>
      ?P (deleteAround g a ps)" by blast
    from 2 have hyp2:  "?T ps \<Longrightarrow> ?P ps" by blast
    have H1: "?P (deleteAround g a ps)"
      by (rule hyp1, rule isTable_deleteAround) (rule prem)
    have H2: "?P ps" by (rule hyp2, rule isTable_Cons) (rule prem)

    show "?P ((a,b)#ps)"
    proof cases
      assume c: "ExcessNotAtRec ps g
        \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
      have "separated g
       (insert a (set (ExcessNotAtRecList (deleteAround g a ps) g)))"
      proof (rule separated_insert[OF mgp])
        from prem show "a \<in> set (vertices g)" by (auto simp add: isTable_def)

        show "set (ExcessNotAtRecList (deleteAround g a ps) g) \<subseteq> \<V> g"
        proof-
          have "set (ExcessNotAtRecList (deleteAround g a ps) g) \<subseteq>
                set (map fst (deleteAround g a ps))"
            by(rule ExcessNotAtRecList_subset[simplified concat_map_singleton])
          also have "\<dots> \<subseteq> set (map fst ps)"
            using deleteAround_subset by fastforce
          finally show ?thesis using prem by(auto simp: isTable_def)
        qed
        from H1
        show pS: "separated g
            (set (ExcessNotAtRecList (deleteAround g a ps) g))"
          by simp

        fix f assume f: "f \<in> set (facesAt g a)"
        then have
        "f \<bullet> a \<notin> set [fst p. p \<leftarrow> deleteAround g a ps]"
          by (auto simp add: facesAt_def deleteAround_eq deleteAround'_def
            removeKeyList_eq split: if_split_asm)
        moreover
        have "set (ExcessNotAtRecList (deleteAround g a ps) g)
          \<subseteq> set [fst p. p \<leftarrow> deleteAround g a ps]"
          by (rule ExcessNotAtRecList_subset)
        ultimately
        show "f \<bullet> a
          \<notin> set (ExcessNotAtRecList (deleteAround g a ps) g)"
          by auto
        assume "|vertices f| \<le> 4"
        from this f have "set (vertices f)
          \<inter> set [fst p. p \<leftarrow> deleteAround g a ps] \<subseteq> {a}"
          by (rule deleteAround_separated[OF mgp fin \<open>a : \<V> g\<close>])
        moreover
        have "set (ExcessNotAtRecList (deleteAround g a ps) g)
          \<subseteq> set [fst p. p \<leftarrow> deleteAround g a ps]"
           by (rule ExcessNotAtRecList_subset)
        ultimately
        show "set (vertices f)
           \<inter> set (ExcessNotAtRecList (deleteAround g a ps) g) \<subseteq> {a}"
          by blast
      qed
      with H1 E c show ?thesis by (simp)
    next
      assume "\<not> ExcessNotAtRec ps g
        \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
      with H2 E show ?thesis by simp
    qed
  qed
qed

lemma isTable_ExcessTable:
  "isTable (\<lambda>v. ExcessAt g v) vs (ExcessTable g vs)"
by (auto simp add: isTable_def ExcessTable_def ExcessAt_def)

lemma ExcessTable_subset:
  "set (map fst (ExcessTable g vs)) \<subseteq> set vs"
by (induct vs) (auto simp add: ExcessTable_def)

lemma distinct_ExcessNotAtRecList:
  "distinct (map fst ps) \<Longrightarrow> distinct (ExcessNotAtRecList ps g)"
    (is "?T ps \<Longrightarrow> ?P ps")
proof (induct rule: ExcessNotAtRec.induct)
  case 1 show ?case by simp
next
  case (2 a b ps)
  from 2 have prem: "?T ((a,b)#ps)" by blast
  then have a: "a \<notin> set (map fst ps)" by simp
  from 2 have hyp1: "?T (deleteAround g a ps) \<Longrightarrow>
    ?P (deleteAround g a ps)" by blast
  from 2 have hyp2:  "?T ps \<Longrightarrow> ?P ps" by blast
  from 2 have "?T ps" by simp
  then have H1: "?P (deleteAround g a ps)"
   by (rule_tac hyp1) (rule distinct_deleteAround [simplified])
  from prem have H2: "?P ps"
    by (rule_tac hyp2) simp

  have "a \<notin> set (ExcessNotAtRecList (deleteAround g a ps) g)"(* auto ?? *)
  proof
    assume "a \<in> set (ExcessNotAtRecList (deleteAround g a ps) g)"
    also have "set (ExcessNotAtRecList (deleteAround g a ps) g)
      \<subseteq> set [fst p. p \<leftarrow> deleteAround g a ps]"
     by (rule ExcessNotAtRecList_subset)
    also have "set (deleteAround g a ps) \<subseteq> set ps"
      by (rule deleteAround_subset)
    then have "set [fst p. p \<leftarrow> deleteAround g a ps]
      \<subseteq> set [fst p. p \<leftarrow> ps]" by auto
    finally have "a \<in> set (map fst ps)" by simp
    with a show False by contradiction
  qed
  with H1 H2 show "?P ((a,b)#ps)"
    by ( simp add: ExcessNotAtRecList_subset)
qed

(* alternative definition *)
primrec ExcessTable_cont ::
  "(vertex \<Rightarrow> nat) \<Rightarrow> vertex list \<Rightarrow> (vertex \<times> nat) list"
where
  "ExcessTable_cont ExcessAtPG [] = []" |
  "ExcessTable_cont ExcessAtPG (v#vs) =
   (let vi = ExcessAtPG v in
     if 0 < vi
     then (v, vi)#ExcessTable_cont ExcessAtPG vs
     else ExcessTable_cont ExcessAtPG vs)"

definition ExcessTable' :: "graph \<Rightarrow> vertex list \<Rightarrow> (vertex \<times> nat) list" where
  "ExcessTable' g \<equiv> ExcessTable_cont (ExcessAt g)"

lemma distinct_ExcessTable_cont:
  "distinct vs \<Longrightarrow>
  distinct (map fst (ExcessTable_cont (ExcessAt g) vs))"
proof (induct vs)
  case Nil then show ?case by (simp add: ExcessTable_def)
next
  case (Cons v vs)
  from Cons have v: "v \<notin> set vs" by simp
  from Cons have "distinct vs" by simp
  with Cons have IH:
    "distinct (map fst (ExcessTable_cont (ExcessAt g) vs))"
    by simp
  moreover have
    "v \<notin> fst ` set (ExcessTable_cont (ExcessAt g) vs)"
  proof
    assume "v \<in> fst ` set (ExcessTable_cont (ExcessAt g) vs)"
    also have "fst ` set (ExcessTable_cont (ExcessAt g) vs) \<subseteq> set vs"
      by (induct vs) auto
    finally have " v \<in> set vs" .
    with v show False by contradiction
  qed
  ultimately show ?case by (simp add: ExcessTable_def)
qed

lemma ExcessTable_cont_eq:
 "ExcessTable_cont E vs =
  [(v, E v). v \<leftarrow> [v\<leftarrow>vs . 0 < E v]]"
by (induct vs) (simp_all)

lemma ExcessTable_eq: "ExcessTable = ExcessTable'"
proof (rule ext, rule ext)
  fix p g vs show "ExcessTable g vs = ExcessTable' g vs"
  by (simp add: ExcessTable_def ExcessTable'_def ExcessTable_cont_eq)
qed

lemma distinct_ExcessTable:
   "distinct vs \<Longrightarrow> distinct [fst p. p \<leftarrow> ExcessTable g vs]"
by (simp_all add: ExcessTable_eq ExcessTable'_def distinct_ExcessTable_cont)

lemma ExcessNotAt_eq:
  "minGraphProps g \<Longrightarrow> final g \<Longrightarrow>
  \<exists>V. ExcessNotAt g None
      = (\<Sum>\<^bsub>v \<in> V\<^esub> ExcessAt g v)
   \<and> separated g (set V) \<and> set V \<subseteq> set (vertices g)
   \<and> distinct V"
proof (intro exI conjI)
  assume mgp: "minGraphProps g" and fin: "final g"
  let ?ps = "ExcessTable g (vertices g)"
  let ?V = "ExcessNotAtRecList ?ps g"
  let ?vs = "vertices g"
  let ?E = "\<lambda>v. ExcessAt g v"
  have t: "isTable ?E ?vs ?ps" by (rule isTable_ExcessTable)
  with this show "ExcessNotAt g None = (\<Sum>\<^bsub>v \<in> ?V\<^esub> ?E v)"
    by (simp add: ListSum_ExcessNotAtRecList ExcessNotAt_def)

  show "separated g (set ?V)"
    by(rule separated_ExcessNotAtRecList[OF mgp fin t])

  have "set (ExcessNotAtRecList ?ps g) \<subseteq> set (map fst ?ps)"
    by (rule ExcessNotAtRecList_subset[simplified concat_map_singleton])
  also have "\<dots> \<subseteq> set (vertices g)" by (rule ExcessTable_subset)
  finally show "set ?V \<subseteq> set (vertices g)" .

  show "distinct ?V"
    by (simp add: distinct_ExcessNotAtRecList distinct_ExcessTable[simplified concat_map_singleton])
qed

lemma excess_eq:
  assumes 7: "t + q \<le> 7"
  shows "excessAtType t q 0 + t * \<d> 3 + q * \<d> 4 = \<b> t q"
proof -
  note simps = excessAtType_def squanderVertex_def squanderFace_def
    nat_minus_add_max squanderTarget_def
  from 7 have "q=0 \<or> q=1 \<or> q=2 \<or> q=3 \<or> q=4 \<or> q=5 \<or> q=6 \<or> q=7" by arith
  then show ?thesis
  proof (elim disjE)
    assume q: "q = 0" (* 16 subgoals *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 1" (* 29 subgoals *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 2" (* 16 subgoals *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 3" (* 16 subgoals *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 4" (* 6 subgoals *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 5" (* 1 subgoal *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 6" (* 1 subgoal *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 7" (* 1 subgoal *)
    with 7 show ?thesis by (simp add: simps)
  qed
qed

lemma excess_eq1:
  "\<lbrakk> inv g; final g; tame g; except g v = 0; v \<in> set(vertices g) \<rbrakk> \<Longrightarrow>
   ExcessAt g v + (tri g v) * \<d> 3 + (quad g v) * \<d>  4
   = \<b> (tri g v) (quad g v)"
apply(subgoal_tac "finalVertex g v")
apply(simp add: ExcessAt_def excess_eq faceCountMax_bound)
apply(auto simp:finalVertex_def plane_final_facesAt)
done

text \<open>separating\<close>

definition separating :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> bool" where
  "separating V F \<equiv>
   (\<forall>v1 \<in> V. \<forall>v2 \<in> V. v1 \<noteq> v2 \<longrightarrow>  F v1 \<inter> F v2 = {})"

lemma separating_insert1:
  "separating (insert a V) F \<Longrightarrow> separating V F"
  by (simp add: separating_def)

lemma separating_insert2:
  "separating (insert a V) F \<Longrightarrow> a \<notin> V \<Longrightarrow>  v \<in> V \<Longrightarrow>
  F a \<inter> F v = {}"
  by (auto simp add: separating_def)

lemma sum_disj_Union:
 "finite V \<Longrightarrow>
  (\<And>f. finite (F f)) \<Longrightarrow>
  separating V F \<Longrightarrow>
  (\<Sum>v\<in>V. \<Sum>f\<in>(F v). (w f::nat)) = (\<Sum>f\<in>(\<Union>v\<in>V. F v). w f)"
proof (induct  rule: finite_induct)
  case empty then show ?case by simp
next
  case (insert a V)
  then have s: "separating (insert a V) F" by simp
  then have "separating V F" by (rule_tac separating_insert1)
  with insert
  have IH: "(\<Sum>v\<in>V. \<Sum>f\<in>(F v). w f) = (\<Sum>f\<in>(\<Union>v\<in>V. F v). w f)"
    by simp

  moreover have fin: "finite V" "a \<notin> V" "\<And>f. finite (F f)" by fact+

  moreover from s have "\<And>v. a \<notin> V \<Longrightarrow> v \<in> V \<Longrightarrow> F a \<inter> F v = {}"
   by (simp add: separating_insert2)
  with fin have "(F a) \<inter> (\<Union>v\<in>V. F v) = {}" by auto

  ultimately show ?case by (simp add: sum.union_disjoint)
qed

lemma separated_separating:
assumes Vg: "set V \<subseteq> \<V> g"
and pS: "separated g (set V)"
and noex: "\<forall>f\<in>P. |vertices f| \<le> 4"
shows "separating (set V) (\<lambda>v. set (facesAt g v) \<inter> P)"
proof -
  from pS have i: "\<forall>v\<in>set V. \<forall>f\<in>set (facesAt g v).
    |vertices f| \<le> 4 \<longrightarrow> set (vertices f) \<inter> set V = {v}"
    by (simp add: separated_def separated\<^sub>3_def)
  show "separating (set V) (\<lambda>v. set (facesAt g v) \<inter> P)"
  proof (simp add: separating_def, intro ballI impI)
    fix v1 v2 assume v: "v1 \<in> set V" "v2 \<in> set V" "v1 \<noteq> v2"
    hence "v1 : \<V> g" using Vg by blast
    show "(set (facesAt g v1) \<inter> P) \<inter> (set (facesAt g v2) \<inter> P) = {}" (is "?P")
    proof (rule ccontr)
      assume "\<not> ?P"
      then obtain f where f1: "f \<in> set (facesAt g v1)"
        and f2: "f \<in> set (facesAt g v2)" and "f : P" by auto
      with noex have l: "|vertices f| \<le> 4" by blast
      from v f1 l i have "set (vertices f) \<inter> set V = {v1}" by simp
      also from v f2 l i
      have "set (vertices f) \<inter> set V = {v2}" by simp
      finally have "v1 = v2" by auto
      then show False by contradiction (rule v)
    qed
  qed
qed

lemma ListSum_V_F_eq_ListSum_F:
assumes pl: "inv g"
and pS: "separated g (set V)" and dist: "distinct V"
and V_subset: "set V \<subseteq> set (vertices g)"
and noex: "\<forall>f \<in> Collect P. |vertices f| \<le> 4"
shows "(\<Sum>\<^bsub>v \<in> V\<^esub> \<Sum>\<^bsub>f \<in> filter P (facesAt g v)\<^esub> (w::face \<Rightarrow> nat) f)
       = (\<Sum>\<^bsub>f \<in> [f\<leftarrow>faces g . \<exists>v \<in> set V. f \<in> set (facesAt g v) \<inter> Collect P]\<^esub> w f)"
proof -
  have s: "separating (set V) (\<lambda>v. set (facesAt g v) \<inter> Collect P)"
    by (rule separated_separating[OF V_subset pS noex])
  moreover note dist
  moreover from pl V_subset
  have "\<And>v. v \<in> set V \<Longrightarrow> distinct (facesAt g v)"
    by(blast intro:mgp_dist_facesAt[OF inv_mgp])
  hence v: "\<And>v. v \<in> set V \<Longrightarrow> distinct (filter P (facesAt g v))"
    by simp
  moreover
  have "distinct [f\<leftarrow>faces g . \<exists>v \<in> set V. f \<in> set (facesAt g v) \<inter> Collect P]"
    by (intro distinct_filter minGraphProps11'[OF inv_mgp[OF pl]])
  moreover from pl have "{x. x \<in> \<F> g \<and> (\<exists>v \<in> set V. x \<in> set (facesAt g v) \<and> P x)} =
      (\<Union>v\<in>set V. set (facesAt g v) \<inter> Collect P)" using V_subset
    by (blast intro:minGraphProps inv_mgp)
  moreover from v have "(\<Sum>v\<in>set V. ListSum (filter P (facesAt g v)) w) = (\<Sum>v\<in>set V. sum w (set(facesAt g v) \<inter> Collect P))"
    by (auto simp add: ListSum_conv_sum Int_def)
  ultimately show ?thesis
    by (simp add: ListSum_conv_sum sum_disj_Union)
qed

lemma separated_disj_Union2:
assumes pl: "inv g" and fin: "final g" and ne: "noExceptionals g (set V)"
and pS: "separated g (set V)" and dist: "distinct V"
and V_subset: "set V \<subseteq> set (vertices g)"
shows "(\<Sum>\<^bsub>v \<in> V\<^esub> \<Sum>\<^bsub>f \<in> facesAt g v\<^esub> (w::face \<Rightarrow> nat) f)
       = (\<Sum>\<^bsub>f \<in> [f\<leftarrow>faces g . \<exists>v \<in> set V. f \<in> set (facesAt g v)]\<^esub> w f)"
proof -
  let ?P = "\<lambda>f. |vertices f| \<le> 4"
  have "\<forall>v \<in> set V. \<forall>f \<in> set (facesAt g v). |vertices f| \<le> 4"
    using V_subset ne
    by (auto simp: noExceptionals_def
      intro: minGraphProps5[OF inv_mgp[OF pl]] not_exceptional[OF pl fin])
  thus ?thesis
    using ListSum_V_F_eq_ListSum_F[where P = ?P, OF pl pS dist V_subset]
    by (simp add: Int_def cong: conj_cong)
qed

lemma squanderFace_distr2: "inv g \<Longrightarrow> final g \<Longrightarrow> noExceptionals g (set V) \<Longrightarrow>
  separated g (set V) \<Longrightarrow> distinct V \<Longrightarrow> set V \<subseteq> set (vertices g) \<Longrightarrow>
     (\<Sum>\<^bsub>f \<in> [f\<leftarrow>faces g. \<exists>v \<in> set V. f \<in> set (facesAt g v)]\<^esub>
         \<d> |vertices f| )
   = (\<Sum>\<^bsub>v \<in> V\<^esub> ((tri g v) * \<d> 3
         + (quad g v) * \<d> 4))"
proof -
  assume pl: "inv g"
  assume fin: "final g"
  assume ne: "noExceptionals g (set V)"
  assume "separated g (set V)"  "distinct V" and V_subset: "set V \<subseteq> set (vertices g)"
  with pl ne fin have
    "(\<Sum>\<^bsub>f \<in> [f\<leftarrow>faces g. \<exists>v\<in>set V. f\<in>set (facesAt g v)]\<^esub> \<d> |vertices f| )
   = (\<Sum>\<^bsub>v \<in> V\<^esub> \<Sum>\<^bsub>f \<in> facesAt g v\<^esub> \<d> |vertices f| )"
    by (simp add: separated_disj_Union2)
  also have "\<And>v. v \<in> set V \<Longrightarrow>
    (\<Sum>\<^bsub>f \<in> facesAt g v\<^esub> \<d> |vertices f| )
  = (tri g v) * \<d> 3 + (quad g v) * \<d> 4"
  proof -
    fix v assume v1: "v \<in> set V"
    with V_subset have v: "v \<in> set (vertices g)" by auto

    with ne have d:
      "\<And>f. f \<in> set (facesAt g v) \<Longrightarrow>
      |vertices f| = 3 \<or> |vertices f| = 4"
    proof -
      fix f assume f: "f \<in> set (facesAt g v)"
      then have ff: "f \<in> set (faces g)" by (rule minGraphProps5[OF inv_mgp[OF pl] v])
      with ne f v1 pl fin v have "|vertices f| \<le> 4"
        by (auto simp add: noExceptionals_def not_exceptional)
      moreover from pl ff have "3 \<le> |vertices f|" by(rule planeN4)
      ultimately show "?thesis f" by arith
    qed

    from d pl v have
      "(\<Sum>\<^bsub>f \<in> facesAt g v\<^esub> \<d> |vertices f| )
    = (\<Sum>\<^bsub>f\<in>[f \<leftarrow> facesAt g v. |vertices f| = 3]\<^esub> \<d> |vertices f| )
    + (\<Sum>\<^bsub>f\<in>[f \<leftarrow> facesAt g v. |vertices f| = 4]\<^esub> \<d> |vertices f| )"
      apply (rule_tac ListSum_disj_union)
      apply (rule distinct_filter) apply simp
      apply (rule distinct_filter) apply simp
      apply simp
      apply force
      apply force
      done
    also have "\<dots> = tri g v * \<d> 3 + quad g v * \<d> 4"
    proof -
      from pl fin v have "\<And>A.[f \<leftarrow> facesAt g v. final f \<and> A f]
        = [f \<leftarrow> facesAt g v. A f]"
        by (rule_tac filter_eqI) (auto simp:plane_final_facesAt)
      with fin show ?thesis  by (auto simp add: tri_def quad_def)
    qed
    finally show "(\<Sum>\<^bsub>f \<in> facesAt g v\<^esub> \<d> |vertices f| ) = tri g v * \<d> 3 + quad g v * \<d> 4" .
  qed
  then have "(\<Sum>\<^bsub>v \<in> V\<^esub> \<Sum>\<^bsub>f \<in> facesAt g v\<^esub> \<d> |vertices f| ) =
         (\<Sum>\<^bsub>v \<in> V\<^esub> (tri g v * \<d> 3 + quad g v * \<d> 4))"
     by (rule ListSum_eq)
  finally show ?thesis .
qed

lemma separated_subset: (* separated *)
   "V1 \<subseteq> V2 \<Longrightarrow> separated g V2 \<Longrightarrow> separated g V1"
proof (simp add:  separated_def separated\<^sub>3_def separated\<^sub>2_def,
  elim conjE, intro allI impI ballI conjI)
  fix v f
  assume a: "v \<in> V1" "V1 \<subseteq> V2" "f \<in> set (facesAt g v)"
    "|vertices f| \<le> 4"
    "\<forall>v\<in>V2. \<forall>f\<in>set (facesAt g v). |vertices f| \<le> 4 \<longrightarrow>
      set (vertices f) \<inter> V2 = {v}"
  then show "set (vertices f) \<inter> V1 = {v}" by auto
next
  fix v f
  assume a: "v \<in> V1" "V1 \<subseteq> V2" "f \<in> set (facesAt g v)"
    "\<forall>v\<in>V2. \<forall>f\<in>set (facesAt g v). f \<bullet> v \<notin> V2"
  then have "v \<in> V2" by auto
  with a have "f \<bullet> v \<notin> V2" by auto
  with a show "f \<bullet> v \<notin> V1" by auto
qed

end


section \<open>Reasoning about Values\<close>
theory Sep_Value_RS
imports Sep_Lift "../basic/LLVM_Basic_Main"
begin

  subsection \<open>Lifting Scheme on Maps\<close>
  definition "prefix_map1 i m \<equiv> \<lambda>[] \<Rightarrow> None | i'#as \<Rightarrow> if i=i' then m as else None"
  definition "project_map1 i m \<equiv> \<lambda>a. m (i#a)"
  definition "carve_map1 i m \<equiv> \<lambda>[] \<Rightarrow> m [] | i'#a \<Rightarrow> if i=i' then None else m (i'#a)"
  definition "prefix_adom1 va d = (#)va`d"

  lemma prefix_map1_apply: "prefix_map1 i m xs = (case xs of [] \<Rightarrow> None | j#as \<Rightarrow> if i=j then m as else None)"
    by (auto simp: prefix_map1_def)

  lemma project_map1_apply: "project_map1 i m xs = m (i#xs)"
    by (auto simp: project_map1_def)

  lemmas lift_map_apply = prefix_map1_apply project_map1_apply

  (* Lemmas for prefix_map *)
  lemma prefix_map1_empty[simp]:
    "prefix_map1 i Map.empty = Map.empty"
    "prefix_map1 i m = Map.empty \<longleftrightarrow> m=Map.empty"
    by (auto simp: prefix_map1_def fun_eq_iff split: if_splits list.splits)

  lemma prefix_map1_add_distrib[simp]: "prefix_map1 i (a\<^sub>1 ++ a\<^sub>2) = prefix_map1 i a\<^sub>1 ++ prefix_map1 i a\<^sub>2"
    apply (rule ext)
    by (auto simp: prefix_map1_def map_add_def split: list.splits option.splits)

  lemma prefix_map_complete_eq_iff[simp]:
    "prefix_map1 PFST a ++ prefix_map1 PSND b = prefix_map1 PFST a' ++ prefix_map1 PSND b'
    \<longleftrightarrow> a=a' \<and> b=b'"
    apply (auto simp: fun_eq_iff map_add_def prefix_map1_def split: option.split list.split)
    by (metis option.exhaust va_item.distinct(1))

  (* Lemmas for project_map *)
  lemma project_map1_empty[simp]: "project_map1 i Map.empty = Map.empty"
    by (auto simp: project_map1_def)

  lemma dom_project_map1_iff[simp]: "dom (project_map1 i b) = { a. i#a \<in> dom b}"
    by (auto simp: project_map1_def)

  lemma project_map_add_distrib[simp]: "project_map1 i (b\<^sub>1 ++ b\<^sub>2) = project_map1 i b\<^sub>1 ++ project_map1 i b\<^sub>2"
    apply (rule ext)
    by (auto simp: project_map1_def map_add_def)

  lemma project_map_prefix_id[simp]: "project_map1 i (prefix_map1 i a) = a"
    apply (rule ext)
    by (auto simp: project_map1_def prefix_map1_def)

  (* Lemmas for carve_map *)

  lemma carve_map1_empty[simp]:
    "carve_map1 i Map.empty = Map.empty"
    by (rule ext) (auto simp: carve_map1_def split: list.splits)

  lemma carve_map1_dom[simp]: "dom (carve_map1 i v) = dom v - {i # as |as. True}"
    by (auto simp: carve_map1_def split: list.splits if_splits)

  lemma carve_map_add_distrib[simp]: "carve_map1 i (b\<^sub>1 ++ b\<^sub>2) = carve_map1 i b\<^sub>1 ++ carve_map1 i b\<^sub>2"
    apply (rule ext)
    by (auto simp: carve_map1_def map_add_def split: list.splits if_splits)

  lemma project_carve_empty[simp]: "project_map1 i (carve_map1 i b) = Map.empty"
    apply (rule ext)
    by (auto simp: carve_map1_def project_map1_def split: list.splits if_splits)

  lemma carve_prefix_empty[simp]: "carve_map1 i (prefix_map1 i a) = Map.empty"
    apply (rule ext)
    by (auto simp: carve_map1_def prefix_map1_def split: list.splits if_splits)

  (* Lemmas for prefix-domain *)
  lemma prefix_adom_empty[simp]:
    "prefix_adom1 i {} = {}"
    by (auto simp: prefix_adom1_def)

  lemma prefix_adom_empty_iff[simp]:
    "prefix_adom1 i d = {} \<longleftrightarrow> d={}"
    by (auto simp: prefix_adom1_def)

  lemma prefix_adom_insert[simp]:
    "prefix_adom1 i (insert d e) = insert (i#d) (prefix_adom1 i e)"
    by (auto simp: prefix_adom1_def)

  lemma prefix_adom_union[simp]:
    "prefix_adom1 i (d\<union>e) = prefix_adom1 i d \<union> prefix_adom1 i e"
    by (auto simp: prefix_adom1_def)

  lemma in_prefix_adom_conv[simp]:
    "x\<in>prefix_adom1 i d \<longleftrightarrow> (\<exists>va'\<in>d. x=i#va')"
    by (auto simp: prefix_adom1_def)

  lemma prefix_map1_dom[simp]: "dom (prefix_map1 i m) = prefix_adom1 i (dom m)"
    by (auto simp: prefix_map1_def split: list.splits if_splits)

  lemma map1_split_complete: "prefix_map1 i (project_map1 i b) ++ carve_map1 i b = b"
    apply (rule ext)
    apply (auto simp: prefix_map1_def project_map1_def carve_map1_def map_add_def split: list.splits option.splits)
    done

  lemma project_map1_prefix_diff[simp]: "i\<noteq>j \<Longrightarrow> project_map1 i (prefix_map1 j a) = Map.empty"
    apply (rule ext)
    apply (auto simp: project_map1_def prefix_map1_def)
    done

  lemma carve_map1_prefix_diff[simp]: "i\<noteq>j \<Longrightarrow> carve_map1 i (prefix_map1 j a) = prefix_map1 j a"
    apply (rule ext)
    apply (auto simp: prefix_map1_def carve_map1_def split: list.splits)
    done

  subsection \<open>Independence of Addresses\<close>

  lemma lens_of_item_indepI: "i\<noteq>i' \<Longrightarrow> lens_of_item i \<bowtie> lens_of_item i'"
    apply (cases i; cases i')
    apply (simp_all add: lens_indep_sym)
    done

  lemma lens_of_item_indepD: "lens_of_item i \<bowtie> lens_of_item i' \<Longrightarrow> i\<noteq>i'"
    apply (cases i; cases i')
    apply (simp_all add: lens_indep_sym)
    apply (meson hlens_def lens.pre_get_imp_putI rnl_indep_not_refl rnlensI val.discI(1) val.distinct(1) val.fst\<^sub>L_lens val.fst\<^sub>L_pre_disc)
    by (meson hlens_def lens.pre_get_imp_putI rnl_indep_not_refl rnlensI val.discI(1) val.distinct(1) val.snd\<^sub>L_lens val.snd\<^sub>L_pre_disc)

  lemma lens_of_item_indep_eq[simp]: "lens_of_item i \<bowtie> lens_of_item i' \<longleftrightarrow> i\<noteq>i'"
    using lens_of_item_indepI lens_of_item_indepD by blast

  definition "vaddr_indep va va' \<longleftrightarrow> (lens_of_vaddr va :: unit val \<Longrightarrow> _) \<bowtie> lens_of_vaddr va'"

  lemma "\<not>(lens_of_vaddr [] \<bowtie> lens_of_vaddr va)" by simp
  lemma "\<not>(lens_of_vaddr va \<bowtie> lens_of_vaddr [])" by simp

  lemma lens_of_vaddr_indep_Cons: "(lens_of_vaddr (i#is) :: 'a val \<Longrightarrow> _) \<bowtie> lens_of_vaddr (j#js)
    \<longleftrightarrow> i\<noteq>j \<or> (lens_of_vaddr is :: 'a val \<Longrightarrow> _) \<bowtie> lens_of_vaddr js"
    apply (cases "i=j")
    by (auto simp: lens_indep_extend2)

  lemma lens_of_vaddr_indep_normalize:
    assumes "NO_MATCH TYPE(unit) TYPE('a)"
    shows "lens_of_vaddr va \<bowtie> (lens_of_vaddr va' :: 'a val \<Longrightarrow> _) \<longleftrightarrow> lens_of_vaddr va \<bowtie> (lens_of_vaddr va' :: unit val \<Longrightarrow> _)"
  proof (induction va arbitrary: va')
    case Nil
    then show ?case by auto
  next
    case (Cons a va)
    then show ?case
      apply (cases va')
      apply simp
      apply (simp only: lens_of_vaddr_indep_Cons)
      done

  qed

  lemma vaddr_indep_alt: "vaddr_indep a b \<longleftrightarrow> lens_of_vaddr a \<bowtie> lens_of_vaddr b"
    using lens_of_vaddr_indep_normalize vaddr_indep_def by auto

  lemma vaddr_indep_irrefl[simp, intro!]: "\<not>vaddr_indep a a"
    unfolding vaddr_indep_def by auto

  lemma vaddr_indep_sym: "vaddr_indep a b \<Longrightarrow> vaddr_indep b a"
    unfolding vaddr_indep_def
    using lens_indep_sym by auto

  lemma vaddr_indep_Nil:
    "\<not>vaddr_indep [] va"
    "\<not>vaddr_indep va []"
    by (simp_all add: vaddr_indep_def)

  lemma vaddr_indep_Cons:
    "vaddr_indep (a#va\<^sub>1) (b#va\<^sub>2) \<longleftrightarrow> (a\<noteq>b \<or> vaddr_indep va\<^sub>1 va\<^sub>2)"
    using lens_of_vaddr_indep_Cons vaddr_indep_def by auto

  lemmas vaddr_indep_simps[simp] = vaddr_indep_Nil vaddr_indep_Cons

  lemma vaddr_indep_prefix[simp]: "vaddr_indep (va@va\<^sub>1) (va@va\<^sub>2) \<longleftrightarrow> vaddr_indep va\<^sub>1 va\<^sub>2"
    by (induction va) auto

  definition "s_indep s1 s2 \<equiv> \<forall>x\<in>s1. \<forall>y\<in>s2. vaddr_indep x y"

  lemma s_indep_irrefl[simp]: "s_indep m m \<longleftrightarrow> m={}"
    by (force simp: s_indep_def)

  lemma s_indep_sym: "s_indep s1 s2 \<Longrightarrow> s_indep s2 s1"
    by (auto simp: s_indep_def vaddr_indep_sym)

  lemma s_indep_imp_disj: "s_indep s1 s2 \<Longrightarrow> s1 \<inter> s2 = {}"
    by (force simp: s_indep_def)

  lemma s_indep_simps[simp]:
    "s_indep {} s"
    "s_indep s {}"
    "s_indep (insert x s) r \<longleftrightarrow> (\<forall>y\<in>r. vaddr_indep x y) \<and> s_indep s r"
    "s_indep r (insert x s) \<longleftrightarrow> (\<forall>y\<in>r. vaddr_indep y x) \<and> s_indep r s"
    by (auto simp: s_indep_def)

  lemma s_indep_union[simp]:
    "s_indep (a\<union>b) c \<longleftrightarrow> s_indep a c \<and> s_indep b c"
    "s_indep a (b\<union>c) \<longleftrightarrow> s_indep a b \<and> s_indep a c"
    by (auto simp: s_indep_def)

  lemma s_indep_ne[simp, intro]:
    "[]\<in>s\<^sub>1 \<Longrightarrow> s_indep s\<^sub>1 s\<^sub>2 \<longleftrightarrow> s\<^sub>2={}"
    "[]\<in>s\<^sub>2 \<Longrightarrow> s_indep s\<^sub>1 s\<^sub>2 \<longleftrightarrow> s\<^sub>1={}"
    by (all \<open>force simp: s_indep_def\<close>)

  lemma s_indep_projectI: "s_indep s\<^sub>1 s\<^sub>2 \<Longrightarrow> s_indep {a. i # a \<in> s\<^sub>1} {a. i # a \<in> s\<^sub>2}"
    apply (auto simp: s_indep_def)
    using vaddr_indep_Cons by blast

  lemma s_indep_mono: "s_indep s\<^sub>1 s\<^sub>2 \<Longrightarrow> s\<^sub>1'\<subseteq>s\<^sub>1 \<Longrightarrow> s\<^sub>2'\<subseteq>s\<^sub>2 \<Longrightarrow> s_indep s\<^sub>1' s\<^sub>2'"
    by (auto simp: s_indep_def)

  lemma s_indep_Cons[simp]: "s_indep (prefix_adom1 a s\<^sub>1) (prefix_adom1 b s\<^sub>2) \<longleftrightarrow> a\<noteq>b \<or> s_indep s\<^sub>1 s\<^sub>2"
    by (auto simp: s_indep_def prefix_adom1_def)

  lemma s_indep_project_shift_prefix:
    "\<lbrakk>[] \<notin> dom b; s_indep (dom a) (dom (project_map1 i b))\<rbrakk>
       \<Longrightarrow> s_indep (dom (prefix_map1 i a)) (dom b)"
    apply (clarsimp simp: s_indep_def)
    by (metis domI neq_Nil_conv option.distinct(1) vaddr_indep_Cons vaddr_indep_sym)

  lemma s_indep_carve_prefix:
    "[] \<notin> dom b \<Longrightarrow> s_indep (dom (carve_map1 i b)) (dom (prefix_map1 i a))"
    apply (clarsimp simp: s_indep_def)
    by (metis neq_Nil_conv option.distinct(1) vaddr_indep_Cons)

  subsection \<open>Separation Algebra for Values\<close>

  typedef 'a aval = "{ m :: vaddr \<rightharpoonup> 'a. \<forall>va\<in>dom m. \<forall>va'\<in>dom m. va\<noteq>va' \<longrightarrow> vaddr_indep va va' }" by auto

  setup_lifting type_definition_aval

  instantiation aval :: (type) unique_zero_sep_algebra
  begin
    lift_definition sep_disj_aval :: "'a aval \<Rightarrow> 'a aval \<Rightarrow> bool" is "\<lambda>x y. s_indep (dom x) (dom y)" .
    lift_definition plus_aval :: "'a aval \<Rightarrow> 'a aval \<Rightarrow> 'a aval" is "\<lambda>m1 m2. if s_indep (dom m1) (dom m2) then m1 ++ m2 else Map.empty"
      apply (auto split: if_splits simp: s_indep_def) apply blast apply blast
      by (meson domI vaddr_indep_sym)

    lift_definition zero_aval :: "'a aval" is "Map.empty" by simp

    instance
      apply standard
      apply (determ transfer; auto simp: s_indep_def)
      apply (determ transfer; auto simp: s_indep_def dom_def; metis vaddr_indep_sym)
      apply (determ transfer; auto simp: s_indep_def)
      apply (determ transfer; auto simp: s_indep_imp_disj simp: map_add_comm s_indep_sym)
      apply (determ transfer; clarsimp; meson UnE s_indep_def)
      apply (determ transfer; unfold s_indep_def; auto simp: domI)
      apply (determ transfer; simp)
      done

  end

  subsection \<open>Lifting Scheme on \<open>aval\<close>\<close>
  lift_definition prefix_aval1 :: "va_item \<Rightarrow> 'a aval \<Rightarrow> 'a aval" is prefix_map1 by auto auto
  lift_definition prim_aval :: "'a \<Rightarrow> 'a aval" is "\<lambda>x. [[] \<mapsto> x]" by simp
  lift_definition adom :: "'a aval \<Rightarrow> vaddr set" is "dom" .
  lift_definition project_aval1 :: "va_item \<Rightarrow> 'a aval \<Rightarrow> 'a aval" is project_map1
    apply (auto simp: project_map1_def)
    by (meson domI list.inject vaddr_indep_Cons)

  lift_definition carve_aval1 :: "va_item \<Rightarrow> 'a aval \<Rightarrow> 'a aval" is carve_map1
    by (fastforce simp: carve_map1_def split: list.splits if_splits)

  lemma indep_prefix_aux1: "[]\<notin>dom b \<Longrightarrow> s_indep (prefix_adom1 i {a. i # a \<in> dom b}) (dom b - {as'. \<exists>as. as' = i # as})"
    apply (auto simp: prefix_adom1_def s_indep_def)
    by (metis neq_Nil_conv option.distinct(1) vaddr_indep_Cons)

  lemma carve_indep_id_aux1: "\<lbrakk>\<forall>va\<in>dom i. \<forall>va'\<in>dom i. va \<noteq> va' \<longrightarrow> vaddr_indep va va'; \<not> [] \<notin> dom i\<rbrakk> \<Longrightarrow> carve_map1 b i = i"
    apply (rule ext)
    apply (auto simp: carve_map1_def split: list.split)
    by (metis domIff list.distinct(1) option.distinct(1) vaddr_indep_simps(1))

  interpretation aval_lifting_scheme: sep_lifting_scheme "prefix_aval1 i" "project_aval1 i" "carve_aval1 i" "\<lambda>x. []\<notin>adom x"
    apply unfold_locales
    apply (all \<open>determ transfer\<close>)
    apply (all \<open>(simp;fail)?\<close>)
    subgoal by (auto simp: domI) []
    subgoal by (auto ) []
    subgoal by (auto simp: domI s_indep_projectI) []
    subgoal by (auto simp: domI s_indep_projectI) []
    subgoal by (auto intro: s_indep_mono)
    subgoal by (auto intro: s_indep_mono)
    subgoal by (rule s_indep_project_shift_prefix)
    subgoal by (rule s_indep_carve_prefix)
    subgoal by (auto simp: map1_split_complete indep_prefix_aux1) []
    subgoal by (auto simp: carve_indep_id_aux1)
    done

  subsubsection \<open>Additional Lemmas\<close>
  lemma adomZ[simp]: "adom 0 = {}"
    apply transfer by auto

  lemma adom_Z_iff[simp]: "adom v = {} \<Longrightarrow> v = 0"
    by (determ transfer) auto

  lemma disj_eq_adom: "a##b \<longleftrightarrow> s_indep (adom a) (adom b)"
    apply transfer by (auto simp: s_indep_def)

  lemma adom_plus[simp]: "a##b \<Longrightarrow> adom (a+b) = adom a \<union> adom b"
    apply transfer by auto

  lemma adom_primval[simp]: "adom (prim_aval x) = {[]}"
    apply transfer by auto

  lemma adom_prefix[simp]: "adom (prefix_aval1 i v) = (prefix_adom1 i (adom v))"
    by (determ transfer) auto

  lemma aval_project_prefix_diff[simp]: "i\<noteq>j \<Longrightarrow> project_aval1 i (prefix_aval1 j a) = 0"
    apply transfer by auto

  lemma carve_aval_prefix_diff[simp]: "i\<noteq>j \<Longrightarrow> carve_aval1 i (prefix_aval1 j a) = prefix_aval1 j a"
    apply transfer by auto

  lemma adom_cases: obtains (primitive) "adom a = {[]}" | (compound) "[]\<notin>adom a"
    by transfer force

  lemma va_item_complete:
    "i\<noteq>PFST \<Longrightarrow> i=PSND"
    "i\<noteq>PSND \<Longrightarrow> i=PFST"
    "PFST\<noteq>i \<Longrightarrow> i=PSND"
    "PSND\<noteq>i \<Longrightarrow> i=PFST"
    by (all \<open>cases i; auto\<close>)

  lemma aval_cases:
    obtains (primitive) x where "v = prim_aval x"
          | (compound) v\<^sub>1 v\<^sub>2 where "v = prefix_aval1 PFST v\<^sub>1 + prefix_aval1 PSND v\<^sub>2"
  proof -
    have "(\<exists>x. v = prim_aval x) \<or> (\<exists>v\<^sub>1 v\<^sub>2. v = prefix_aval1 PFST v\<^sub>1 + prefix_aval1 PSND v\<^sub>2)"
    proof (transfer, goal_cases)
      case (1 v)
      assume INDEP: "\<forall>vaa\<in>dom v. \<forall>va'\<in>dom v. vaa \<noteq> va' \<longrightarrow> vaddr_indep vaa va'"
      then consider (primitive) "dom v = {[]}" | (compound) "[]\<notin>dom v" by force
      then show ?case proof cases
        case primitive
        then show ?thesis
          apply (rule_tac disjI1)
          by (simp add: dom_eq_singleton_conv)

      next
        case compound
        then show ?thesis
          apply (rule_tac disjI2)
          apply (rule bexI[where x="project_map1 PFST v"])
          apply (rule bexI[where x="project_map1 PSND v"])
          subgoal
            apply (rule ext)
            subgoal for x
              apply (cases x)
              apply (auto simp add: map_add_def lift_map_apply dest: va_item_complete split: option.splits)
              done
            done
          using INDEP
          apply clarsimp_all
          apply (meson domI list.inject vaddr_indep_Cons)+
          done

      qed
    qed
    thus ?thesis using that by blast
  qed

  lemma prim_aval_complete[simp]:
    "prim_aval x ## v \<longleftrightarrow> v=0"
    "v ## prim_aval x \<longleftrightarrow> v=0"
    by (auto simp: disj_eq_adom)

  lemma prim_aval_neqZ[simp]: "prim_aval x \<noteq> 0"
    by (metis adomZ adom_primval empty_iff insert_iff)

  lemma prefix_aval_complete_eq_iff[simp]:
    "prefix_aval1 PFST a + prefix_aval1 PSND b = prefix_aval1 PFST a' + prefix_aval1 PSND b'
    \<longleftrightarrow> a=a' \<and> b=b'"
    apply transfer
    apply auto
    done

  lemma prefix_aval_split_ne_prim: "prefix_aval1 PFST a + prefix_aval1 PSND b \<noteq> prim_aval x"
  proof -
    have "adom (prefix_aval1 PFST a + prefix_aval1 PSND b) \<noteq> {[]}"
      by (metis aval_lifting_scheme.carve_disj_lift(2) aval_lifting_scheme.splittable_add_distrib aval_lifting_scheme.splittable_lift carve_aval_prefix_diff insertI1 va_item.distinct(1))
    then show ?thesis
      by (rule_tac ccontr; simp)
  qed

  lemma prim_aval_inj[simp]: "prim_aval x = prim_aval y \<longleftrightarrow> x = y"
    apply transfer
    apply (auto simp: fun_eq_iff split: if_splits)
    done

  subsection \<open>Lifter for Value Address Items\<close>

  fun val_dom where
    "val_dom (PRIMITIVE x) = {[]}"
  | "val_dom (PAIR x y) = prefix_adom1 PFST (val_dom x) \<union> prefix_adom1 PSND (val_dom y)"

  fun val_\<alpha> where
    "val_\<alpha> (PRIMITIVE x) = prim_aval x"
  | "val_\<alpha> (PAIR x y) = prefix_aval1 PFST (val_\<alpha> x) + prefix_aval1 PSND (val_\<alpha> y)"

  lemma ne_prefix_disjI[simp, intro]: "i\<noteq>j \<Longrightarrow> prefix_aval1 i v\<^sub>1 ## prefix_aval1 j v\<^sub>2"
    by (auto simp add: disj_eq_adom)

  lemma adom_val_\<alpha>[simp]: "adom (val_\<alpha> x) = val_dom x"
    by (induction x) (auto)

  definition "val_item_lifter i \<equiv> \<lparr>
    sep_lifter.lift = prefix_aval1 i,
    sep_lifter.project = project_aval1 i,
    sep_lifter.carve = carve_aval1 i,
    sep_lifter.splittable = \<lambda>a. [] \<notin> adom a,
    sep_lifter.L = lens_of_item i,
    sep_lifter.\<alpha>b = val_\<alpha>,
    sep_lifter.\<alpha>s = val_\<alpha>,
    sep_lifter.tyb = \<lambda>_. (),
    sep_lifter.tys = \<lambda>_. ()
  \<rparr>"

  lemma val_item_lifter_simps[simp]:
    "sep_lifter.lift (val_item_lifter i) = prefix_aval1 i"
    "sep_lifter.project (val_item_lifter i) = project_aval1 i"
    "sep_lifter.carve (val_item_lifter i) = carve_aval1 i"
    "sep_lifter.splittable (val_item_lifter i) = (\<lambda>a. [] \<notin> adom a)"
    "sep_lifter.L (val_item_lifter i) = lens_of_item i"
    "sep_lifter.\<alpha>b (val_item_lifter i) = val_\<alpha>"
    "sep_lifter.\<alpha>s (val_item_lifter i) = val_\<alpha>"
    "sep_lifter.tyb (val_item_lifter i) = (\<lambda>_. ())"
    "sep_lifter.tys (val_item_lifter i) = (\<lambda>_. ())"
    by (auto simp: val_item_lifter_def)

  lemma val_item_lifter[simp, intro!]: "sep_lifter (val_item_lifter i)"
    apply intro_locales
    subgoal by (simp add: val_item_lifter_def) unfold_locales
    subgoal
      apply (rule sep_lifter_axioms.intro)
      apply (clarsimp_all simp: val_item_lifter_def)

      subgoal for cb by (cases cb; cases i) auto
      subgoal for cb
        apply (cases cb; cases i)
        apply (auto simp:  )
        done
      subgoal for cb x
        apply (cases cb; cases i)
        apply (auto simp: sep_algebra_simps)
        done
      done
    done

  lemma val_\<alpha>_neqZ[simp]: "val_\<alpha> x \<noteq> 0"
    by (induction x) auto

  lemma val_\<alpha>_complete[simp]: "val_\<alpha> v ## x \<longleftrightarrow> x=0"
  proof (induction v arbitrary: x)
    case (PAIR v1 v2)
    show ?case
      apply (cases x rule: aval_cases)
      apply (auto simp: PAIR.IH)
      done

  next
    case (PRIMITIVE y)
    then show ?case
      by (cases x rule: aval_cases) auto
  qed

  lemma val_\<alpha>_inj[simp]: "val_\<alpha> v = val_\<alpha> v' \<longleftrightarrow> v=v'"
  proof (induction v arbitrary: v')
    case (PAIR v1 v2)
    then show ?case
      by (cases v') (auto simp: prefix_aval_split_ne_prim)

  next
    case (PRIMITIVE x)
    then show ?case
      apply (cases v')
      apply auto
      by (metis prefix_aval_split_ne_prim)
  qed

  subsection \<open>Lifter for Value Addresses\<close>

  definition "vaddr_lifter addr = foldr (\<lambda>i l. l \<bullet>\<^sub>l\<^sub>f\<^sub>t val_item_lifter i) addr (id_lifter (\<lambda>_. ()) val_\<alpha>)"

  lemma vaddr_lifter_rec_simps:
    "vaddr_lifter [] = id_lifter (\<lambda>_. ()) val_\<alpha>"
    "vaddr_lifter (i#a) = vaddr_lifter a \<bullet>\<^sub>l\<^sub>f\<^sub>t val_item_lifter i"
    unfolding vaddr_lifter_def by auto

  lemma vaddr_lifter_\<alpha>s_simp: "sep_lifter.\<alpha>s (vaddr_lifter addr) = val_\<alpha>"
    apply (induction addr) apply (auto simp: vaddr_lifter_rec_simps compose_lifter_simps) done

  lemma vaddr_lifter_\<alpha>b_simp: "sep_lifter.\<alpha>b (vaddr_lifter addr) = val_\<alpha>"
    apply (induction addr) apply (auto simp: vaddr_lifter_rec_simps compose_lifter_simps) done

  lemma vaddr_lifter_L_simp: "sep_lifter.L (vaddr_lifter addr) = lens_of_vaddr addr"
    apply (induction addr)
    apply (auto simp: vaddr_lifter_rec_simps compose_lifter_simps)
    done

  lemmas vaddr_lifter_simps[simp] = vaddr_lifter_\<alpha>s_simp vaddr_lifter_\<alpha>b_simp vaddr_lifter_L_simp

  lemma vaddr_lifter[simp, intro!]: "sep_lifter (vaddr_lifter addr)"
    apply (induction addr) apply (auto simp: vaddr_lifter_rec_simps compose_lifter_simps) done

  interpretation val_item_lifter: sep_lifter "val_item_lifter i" for i by simp
  interpretation vaddr_lifter: sep_lifter "vaddr_lifter addr" for addr by simp

  lemma vaddr_lift_Nil[simp]: "vaddr_lifter.lift [] = id"
    by (auto simp: vaddr_lifter_def id_lifter_def)

  lemma vaddr_lift_Cons[simp]: "vaddr_lifter.lift (i#as) = prefix_aval1 i o vaddr_lifter.lift as"
    apply (rule ext)
    apply (auto simp: vaddr_lifter_rec_simps compose_lifter_simps)
    done

  lemma vaddr_lift_append[simp]: "vaddr_lifter.lift (as\<^sub>1@as\<^sub>2) = vaddr_lifter.lift as\<^sub>1 o vaddr_lifter.lift as\<^sub>2"
    by (induction as\<^sub>1) auto

  subsection \<open>Points-To Assertion for Values\<close>

  definition "vpto_assn v addr \<equiv> vaddr_lifter.lift_assn addr (EXACT (val_\<alpha> v))"

  lemma vpto_assn_split: "vpto_assn (PAIR a b) addr = (vpto_assn a (addr@[PFST]) ** vpto_assn b (addr@[PSND]))"
    by (auto simp: vpto_assn_def EXACT_split)

  lemma vpto_assn_notZ[simp]: "\<not> vpto_assn x a 0"
    by (auto simp: vpto_assn_def)

  lemma vpto_assn_this[simp]: "vpto_assn v [] av = (av = val_\<alpha> v)"
    by (auto simp: vpto_assn_def)

  subsection \<open>Hoare-Triples for Load and Store\<close>

  lemma get_aval_rule: "htriple val_\<alpha> (EXACT (val_\<alpha> v)) Monad.get (\<lambda>r. \<up>(r=v) ** EXACT (val_\<alpha> v))"
    apply (rule htripleI')
    apply (auto simp: wp_def run_simps)
    apply (auto simp: sep_algebra_simps)
    done

  lemma set_aval_rule: "htriple val_\<alpha> (EXACT (val_\<alpha> v)) (Monad.set v') (\<lambda>_. EXACT (val_\<alpha> v'))"
    apply (rule htripleI')
    apply (auto simp: wp_def run_simps)
    done

  lemma vload_rule: "htriple val_\<alpha> (vpto_assn v a) (vload err a) (\<lambda>r. \<up>(r=v) ** vpto_assn v a)"
    unfolding vload_def vpto_assn_def
    apply (rule cons_post_rule)
    apply (rule vaddr_lifter.lift_operation[simplified])
    apply simp
    apply (rule get_aval_rule)
    by auto

  lemma vstore_rule: "htriple val_\<alpha> (vpto_assn v a) (vstore err v' a) (\<lambda>_. vpto_assn v' a)"
    unfolding vstore_def vpto_assn_def
    apply (rule cons_post_rule)
    apply (rule vaddr_lifter.lift_operation[simplified])
    apply simp
    apply (rule set_aval_rule)
    by auto

  lifting_forget aval.lifting

end


(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section {* \isaheader{Map implementation via tries} *}
theory TrieMapImpl imports
  Trie2
  "../gen_algo/MapGA"
begin
(*@impl Map
  @type ('k,'v) tm
  @abbrv tm,t
  Maps over keys of type @{typ "'k list"} implemented by tries.
*)

subsection {* Operations *}

type_synonym ('k, 'v) tm = "('k, 'v) trie"

definition [icf_rec_def]: "tm_basic_ops \<equiv> \<lparr>
  bmap_op_\<alpha> = Trie2.lookup,
  bmap_op_invar = \<lambda>_. True,
  bmap_op_empty = (\<lambda>_::unit. Trie2.empty),
  bmap_op_lookup = (\<lambda>k m. Trie2.lookup m k),
  bmap_op_update = Trie2.update,
  bmap_op_update_dj = Trie2.update,
  bmap_op_delete = Trie2.delete,
  bmap_op_list_it = Trie2.iteratei
\<rparr>"

setup Locale_Code.open_block
interpretation tm_basic: StdBasicMap tm_basic_ops
  apply unfold_locales
  apply (simp_all add: icf_rec_unf Trie2.finite_dom_lookup Trie2.iteratei_correct)
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "tm_ops \<equiv> tm_basic.dflt_ops"

setup Locale_Code.open_block
interpretation tm: StdMap tm_ops
  unfolding tm_ops_def
  by (rule tm_basic.dflt_ops_impl)
interpretation tm: StdMap_no_invar tm_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "tm"*}

lemma pi_trie_impl[proper_it]:
  shows "proper_it'
    ((Trie_Impl.iteratei) :: _ \<Rightarrow> (_,'\<sigma>a) set_iterator)
    ((Trie_Impl.iteratei) :: _ \<Rightarrow> (_,'\<sigma>b) set_iterator)"
  unfolding Trie_Impl.iteratei_def[abs_def]
proof (rule proper_it'I)
  (*note [[show_types, show_consts]]*)
  fix t :: "('k,'v) Trie.trie"
  {
    fix l and t :: "('k,'v) Trie.trie"
    have "proper_it ((Trie_Impl.iteratei_postfixed l t)
       :: (_,'\<sigma>a) set_iterator)
      ((Trie_Impl.iteratei_postfixed l t)
       :: (_,'\<sigma>b) set_iterator)"
    proof (induct t arbitrary: l)
      case (Trie vo kvs l)

      let ?ITA = "\<lambda>l t. (Trie_Impl.iteratei_postfixed l t)
        :: (_,'\<sigma>a) set_iterator"
      let ?ITB = "\<lambda>l t. (Trie_Impl.iteratei_postfixed l t)
        :: (_,'\<sigma>b) set_iterator"

      show ?case
        unfolding Trie_Impl.iteratei_postfixed_alt_def
        apply (rule pi_union)
        apply (auto split: option.split intro: icf_proper_iteratorI) []
      proof (rule pi_image)
        def bs \<equiv> "\<lambda>(k,t). SOME l'::('k list \<times> 'v) list.
          ?ITA (k#l) t = foldli l' \<and> ?ITB (k#l) t = foldli l'"

        have EQ1: "\<forall>(k,t)\<in>set kvs. ?ITA (k#l) t = foldli (bs (k,t))" and
          EQ2: "\<forall>(k,t)\<in>set kvs. ?ITB (k#l) t = foldli (bs (k,t))"
        proof (safe)
          fix k t
          assume A: "(k,t) \<in> set kvs"
          from Trie.hyps[OF A, of "k#l"] have
            PI: "proper_it (?ITA (k#l) t) (?ITB (k#l) t)"
            by assumption
          obtain l' where
            "?ITA (k#l) t = foldli l'
          \<and> (?ITB (k#l) t) = foldli l'"
            by (blast intro: proper_itE[OF PI])
          thus "?ITA (k#l) t = foldli (bs (k,t))"
            "?ITB (k#l) t = foldli (bs (k,t))"
            unfolding bs_def
            apply auto
            apply (metis (lifting, full_types) someI_ex)
            apply (metis (lifting, full_types) someI_ex)
            done
        qed

        have PEQ1: "set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITA (k#l) t)
          = set_iterator_product (foldli kvs) (\<lambda>kt. foldli (bs kt))"
          apply (rule set_iterator_product_eq2)
          using EQ1 by auto
        have PEQ2: "set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITB (k#l) t)
          = set_iterator_product (foldli kvs) (\<lambda>kt. foldli (bs kt))"
          apply (rule set_iterator_product_eq2)
          using EQ2 by auto
        show "proper_it
          (set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITA (k#l) t))
          (set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITB (k#l) t))"
          apply (subst PEQ1)
          apply (subst PEQ2)
          apply (auto simp: set_iterator_product_foldli_conv)
          by (blast intro: proper_itI)
      qed
    qed
  } thus "proper_it
      (iteratei_postfixed [] t :: (_,'\<sigma>a) set_iterator)
      (iteratei_postfixed [] t :: (_,'\<sigma>b) set_iterator)" .
qed

lemma pi_trie[proper_it]:
  "proper_it' Trie2.iteratei Trie2.iteratei"
  unfolding Trie2.iteratei_def[abs_def]
  apply (rule proper_it'I)
  apply (intro icf_proper_iteratorI)
  apply (rule proper_it'D)
  by (rule pi_trie_impl)

interpretation pi_trie: proper_it_loc Trie2.iteratei Trie2.iteratei
  apply unfold_locales
  apply (rule pi_trie)
  done

text {* Code generator test *}
definition "test_codegen \<equiv> (
  tm.add ,
  tm.add_dj ,
  tm.ball ,
  tm.bex ,
  tm.delete ,
  tm.empty ,
  tm.isEmpty ,
  tm.isSng ,
  tm.iterate ,
  tm.iteratei ,
  tm.list_it ,
  tm.lookup ,
  tm.restrict ,
  tm.sel ,
  tm.size ,
  tm.size_abort ,
  tm.sng ,
  tm.to_list ,
  tm.to_map ,
  tm.update ,
  tm.update_dj)"

export_code test_codegen in SML

end