(*  Title:      HOL/Quotient_Examples/FSet.thy
    Author:     Cezary Kaliszyk, TU Munich
    Author:     Christian Urban, TU Munich

Type of finite sets.
*)

(********************************************************************
  WARNING: There is a formalization of 'a fset as a subtype of sets in
  HOL/Library/FSet.thy using Lifting/Transfer. The user should use
  that file rather than this file unless there are some very specific
  reasons.
*********************************************************************)

theory FSet
imports "~~/src/HOL/Library/Multiset" "~~/src/HOL/Library/Quotient_List"
begin

text {*
  The type of finite sets is created by a quotient construction
  over lists. The definition of the equivalence:
*}

definition
  list_eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infix "\<approx>" 50)
where
  [simp]: "xs \<approx> ys \<longleftrightarrow> set xs = set ys"

lemma list_eq_reflp:
  "reflp list_eq"
  by (auto intro: reflpI)

lemma list_eq_symp:
  "symp list_eq"
  by (auto intro: sympI)

lemma list_eq_transp:
  "transp list_eq"
  by (auto intro: transpI)

lemma list_eq_equivp:
  "equivp list_eq"
  by (auto intro: equivpI list_eq_reflp list_eq_symp list_eq_transp)

text {* The @{text fset} type *}

quotient_type
  'a fset = "'a list" / "list_eq"
  by (rule list_eq_equivp)

text {*
  Definitions for sublist, cardinality,
  intersection, difference and respectful fold over
  lists.
*}

declare List.member_def [simp]

definition
  sub_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  [simp]: "sub_list xs ys \<longleftrightarrow> set xs \<subseteq> set ys"

definition
  card_list :: "'a list \<Rightarrow> nat"
where
  [simp]: "card_list xs = card (set xs)"

definition
  inter_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  [simp]: "inter_list xs ys = [x \<leftarrow> xs. x \<in> set xs \<and> x \<in> set ys]"

definition
  diff_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  [simp]: "diff_list xs ys = [x \<leftarrow> xs. x \<notin> set ys]"

definition
  rsp_fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> bool"
where
  "rsp_fold f \<longleftrightarrow> (\<forall>u v. f u \<circ> f v = f v \<circ> f u)"

lemma rsp_foldI:
  "(\<And>u v. f u \<circ> f v = f v \<circ> f u) \<Longrightarrow> rsp_fold f"
  by (simp add: rsp_fold_def)

lemma rsp_foldE:
  assumes "rsp_fold f"
  obtains "f u \<circ> f v = f v \<circ> f u"
  using assms by (simp add: rsp_fold_def)

definition
  fold_once :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b"
where
  "fold_once f xs = (if rsp_fold f then fold f (remdups xs) else id)"

lemma fold_once_default [simp]:
  "\<not> rsp_fold f \<Longrightarrow> fold_once f xs = id"
  by (simp add: fold_once_def)

lemma fold_once_fold_remdups:
  "rsp_fold f \<Longrightarrow> fold_once f xs = fold f (remdups xs)"
  by (simp add: fold_once_def)

section {* Quotient composition lemmas *}

lemma list_all2_refl':
  assumes q: "equivp R"
  shows "(list_all2 R) r r"
  by (rule list_all2_refl) (metis equivp_def q)

lemma compose_list_refl:
  assumes q: "equivp R"
  shows "(list_all2 R OOO op \<approx>) r r"
proof
  have *: "r \<approx> r" by (rule equivp_reflp[OF fset_equivp])
  show "list_all2 R r r" by (rule list_all2_refl'[OF q])
  with * show "(op \<approx> OO list_all2 R) r r" ..
qed

lemma map_list_eq_cong: "b \<approx> ba \<Longrightarrow> map f b \<approx> map f ba"
  by (simp only: list_eq_def set_map)

lemma quotient_compose_list_g:
  assumes q: "Quotient3 R Abs Rep"
  and     e: "equivp R"
  shows  "Quotient3 ((list_all2 R) OOO (op \<approx>))
    (abs_fset \<circ> (map Abs)) ((map Rep) \<circ> rep_fset)"
  unfolding Quotient3_def comp_def
proof (intro conjI allI)
  fix a r s
  show "abs_fset (map Abs (map Rep (rep_fset a))) = a"
    by (simp add: abs_o_rep[OF q] Quotient3_abs_rep[OF Quotient3_fset] List.map.id)
  have b: "list_all2 R (map Rep (rep_fset a)) (map Rep (rep_fset a))"
    by (rule list_all2_refl'[OF e])
  have c: "(op \<approx> OO list_all2 R) (map Rep (rep_fset a)) (map Rep (rep_fset a))"
    by (rule, rule equivp_reflp[OF fset_equivp]) (rule b)
  show "(list_all2 R OOO op \<approx>) (map Rep (rep_fset a)) (map Rep (rep_fset a))"
    by (rule, rule list_all2_refl'[OF e]) (rule c)
  show "(list_all2 R OOO op \<approx>) r s = ((list_all2 R OOO op \<approx>) r r \<and>
        (list_all2 R OOO op \<approx>) s s \<and> abs_fset (map Abs r) = abs_fset (map Abs s))"
  proof (intro iffI conjI)
    show "(list_all2 R OOO op \<approx>) r r" by (rule compose_list_refl[OF e])
    show "(list_all2 R OOO op \<approx>) s s" by (rule compose_list_refl[OF e])
  next
    assume a: "(list_all2 R OOO op \<approx>) r s"
    then have b: "map Abs r \<approx> map Abs s"
    proof (elim relcomppE)
      fix b ba
      assume c: "list_all2 R r b"
      assume d: "b \<approx> ba"
      assume e: "list_all2 R ba s"
      have f: "map Abs r = map Abs b"
        using Quotient3_rel[OF list_quotient3[OF q]] c by blast
      have "map Abs ba = map Abs s"
        using Quotient3_rel[OF list_quotient3[OF q]] e by blast
      then have g: "map Abs s = map Abs ba" by simp
      then show "map Abs r \<approx> map Abs s" using d f map_list_eq_cong by simp
    qed
    then show "abs_fset (map Abs r) = abs_fset (map Abs s)"
      using Quotient3_rel[OF Quotient3_fset] by blast
  next
    assume a: "(list_all2 R OOO op \<approx>) r r \<and> (list_all2 R OOO op \<approx>) s s
      \<and> abs_fset (map Abs r) = abs_fset (map Abs s)"
    then have s: "(list_all2 R OOO op \<approx>) s s" by simp
    have d: "map Abs r \<approx> map Abs s"
      by (subst Quotient3_rel [OF Quotient3_fset, symmetric]) (simp add: a)
    have b: "map Rep (map Abs r) \<approx> map Rep (map Abs s)"
      by (rule map_list_eq_cong[OF d])
    have y: "list_all2 R (map Rep (map Abs s)) s"
      by (fact rep_abs_rsp_left[OF list_quotient3[OF q], OF list_all2_refl'[OF e, of s]])
    have c: "(op \<approx> OO list_all2 R) (map Rep (map Abs r)) s"
      by (rule relcomppI) (rule b, rule y)
    have z: "list_all2 R r (map Rep (map Abs r))"
      by (fact rep_abs_rsp[OF list_quotient3[OF q], OF list_all2_refl'[OF e, of r]])
    then show "(list_all2 R OOO op \<approx>) r s"
      using a c relcomppI by simp
  qed
qed

lemma quotient_compose_list[quot_thm]:
  shows  "Quotient3 ((list_all2 op \<approx>) OOO (op \<approx>))
    (abs_fset \<circ> (map abs_fset)) ((map rep_fset) \<circ> rep_fset)"
  by (rule quotient_compose_list_g, rule Quotient3_fset, rule list_eq_equivp)

section {* Quotient definitions for fsets *}

subsection {* Finite sets are a bounded, distributive lattice with minus *}

instantiation fset :: (type) "{bounded_lattice_bot, distrib_lattice, minus}"
begin

quotient_definition
  "bot :: 'a fset"
  is "Nil :: 'a list" done

abbreviation
  empty_fset  ("{||}")
where
  "{||} \<equiv> bot :: 'a fset"

quotient_definition
  "less_eq_fset :: ('a fset \<Rightarrow> 'a fset \<Rightarrow> bool)"
  is "sub_list :: ('a list \<Rightarrow> 'a list \<Rightarrow> bool)" by simp

abbreviation
  subset_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<subseteq>|" 50)
where
  "xs |\<subseteq>| ys \<equiv> xs \<le> ys"

definition
  less_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool"
where
  "xs < ys \<equiv> xs \<le> ys \<and> xs \<noteq> (ys::'a fset)"

abbreviation
  psubset_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<subset>|" 50)
where
  "xs |\<subset>| ys \<equiv> xs < ys"

quotient_definition
  "sup :: 'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
  is "append :: 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" by simp

abbreviation
  union_fset (infixl "|\<union>|" 65)
where
  "xs |\<union>| ys \<equiv> sup xs (ys::'a fset)"

quotient_definition
  "inf :: 'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
  is "inter_list :: 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" by simp

abbreviation
  inter_fset (infixl "|\<inter>|" 65)
where
  "xs |\<inter>| ys \<equiv> inf xs (ys::'a fset)"

quotient_definition
  "minus :: 'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
  is "diff_list :: 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" by fastforce

instance
proof
  fix x y z :: "'a fset"
  show "x |\<subset>| y \<longleftrightarrow> x |\<subseteq>| y \<and> \<not> y |\<subseteq>| x"
    by (unfold less_fset_def, descending) auto
  show "x |\<subseteq>| x" by (descending) (simp)
  show "{||} |\<subseteq>| x" by (descending) (simp)
  show "x |\<subseteq>| x |\<union>| y" by (descending) (simp)
  show "y |\<subseteq>| x |\<union>| y" by (descending) (simp)
  show "x |\<inter>| y |\<subseteq>| x" by (descending) (auto)
  show "x |\<inter>| y |\<subseteq>| y" by (descending) (auto)
  show "x |\<union>| (y |\<inter>| z) = x |\<union>| y |\<inter>| (x |\<union>| z)"
    by (descending) (auto)
next
  fix x y z :: "'a fset"
  assume a: "x |\<subseteq>| y"
  assume b: "y |\<subseteq>| z"
  show "x |\<subseteq>| z" using a b by (descending) (simp)
next
  fix x y :: "'a fset"
  assume a: "x |\<subseteq>| y"
  assume b: "y |\<subseteq>| x"
  show "x = y" using a b by (descending) (auto)
next
  fix x y z :: "'a fset"
  assume a: "y |\<subseteq>| x"
  assume b: "z |\<subseteq>| x"
  show "y |\<union>| z |\<subseteq>| x" using a b by (descending) (simp)
next
  fix x y z :: "'a fset"
  assume a: "x |\<subseteq>| y"
  assume b: "x |\<subseteq>| z"
  show "x |\<subseteq>| y |\<inter>| z" using a b by (descending) (auto)
qed

end

subsection {* Other constants for fsets *}

quotient_definition
  "insert_fset :: 'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
  is "Cons" by auto

syntax
  "_insert_fset"     :: "args => 'a fset"  ("{|(_)|}")

translations
  "{|x, xs|}" == "CONST insert_fset x {|xs|}"
  "{|x|}"     == "CONST insert_fset x {||}"

quotient_definition
  fset_member
where
  "fset_member :: 'a fset \<Rightarrow> 'a \<Rightarrow> bool" is "List.member" by fastforce

abbreviation
  in_fset :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<in>|" 50)
where
  "x |\<in>| S \<equiv> fset_member S x"

abbreviation
  notin_fset :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<notin>|" 50)
where
  "x |\<notin>| S \<equiv> \<not> (x |\<in>| S)"

subsection {* Other constants on the Quotient Type *}

quotient_definition
  "card_fset :: 'a fset \<Rightarrow> nat"
  is card_list by simp

quotient_definition
  "map_fset :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b fset"
  is map by simp

quotient_definition
  "remove_fset :: 'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
  is removeAll by simp

quotient_definition
  "fset :: 'a fset \<Rightarrow> 'a set"
  is "set" by simp

lemma fold_once_set_equiv:
  assumes "xs \<approx> ys"
  shows "fold_once f xs = fold_once f ys"
proof (cases "rsp_fold f")
  case False then show ?thesis by simp
next
  case True
  then have "\<And>x y. x \<in> set (remdups xs) \<Longrightarrow> y \<in> set (remdups xs) \<Longrightarrow> f x \<circ> f y = f y \<circ> f x"
    by (rule rsp_foldE)
  moreover from assms have "multiset_of (remdups xs) = multiset_of (remdups ys)"
    by (simp add: set_eq_iff_multiset_of_remdups_eq)
  ultimately have "fold f (remdups xs) = fold f (remdups ys)"
    by (rule fold_multiset_equiv)
  with True show ?thesis by (simp add: fold_once_fold_remdups)
qed

quotient_definition
  "fold_fset :: ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b \<Rightarrow> 'b"
  is fold_once by (rule fold_once_set_equiv)

lemma concat_rsp_pre:
  assumes a: "list_all2 op \<approx> x x'"
  and     b: "x' \<approx> y'"
  and     c: "list_all2 op \<approx> y' y"
  and     d: "\<exists>x\<in>set x. xa \<in> set x"
  shows "\<exists>x\<in>set y. xa \<in> set x"
proof -
  obtain xb where e: "xb \<in> set x" and f: "xa \<in> set xb" using d by auto
  have "\<exists>y. y \<in> set x' \<and> xb \<approx> y" by (rule list_all2_find_element[OF e a])
  then obtain ya where h: "ya \<in> set x'" and i: "xb \<approx> ya" by auto
  have "ya \<in> set y'" using b h by simp
  then have "\<exists>yb. yb \<in> set y \<and> ya \<approx> yb" using c by (rule list_all2_find_element)
  then show ?thesis using f i by auto
qed

quotient_definition
  "concat_fset :: ('a fset) fset \<Rightarrow> 'a fset"
  is concat
proof (elim relcomppE)
fix a b ba bb
  assume a: "list_all2 op \<approx> a ba"
  with list_symp [OF list_eq_symp] have a': "list_all2 op \<approx> ba a" by (rule sympE)
  assume b: "ba \<approx> bb"
  with list_eq_symp have b': "bb \<approx> ba" by (rule sympE)
  assume c: "list_all2 op \<approx> bb b"
  with list_symp [OF list_eq_symp] have c': "list_all2 op \<approx> b bb" by (rule sympE)
  have "\<forall>x. (\<exists>xa\<in>set a. x \<in> set xa) = (\<exists>xa\<in>set b. x \<in> set xa)"
  proof
    fix x
    show "(\<exists>xa\<in>set a. x \<in> set xa) = (\<exists>xa\<in>set b. x \<in> set xa)"
    proof
      assume d: "\<exists>xa\<in>set a. x \<in> set xa"
      show "\<exists>xa\<in>set b. x \<in> set xa" by (rule concat_rsp_pre[OF a b c d])
    next
      assume e: "\<exists>xa\<in>set b. x \<in> set xa"
      show "\<exists>xa\<in>set a. x \<in> set xa" by (rule concat_rsp_pre[OF c' b' a' e])
    qed
  qed
  then show "concat a \<approx> concat b" by auto
qed

quotient_definition
  "filter_fset :: ('a \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
  is filter by force

subsection {* Compositional respectfulness and preservation lemmas *}

lemma Nil_rsp2 [quot_respect]:
  shows "(list_all2 op \<approx> OOO op \<approx>) Nil Nil"
  by (rule compose_list_refl, rule list_eq_equivp)

lemma Cons_rsp2 [quot_respect]:
  shows "(op \<approx> ===> list_all2 op \<approx> OOO op \<approx> ===> list_all2 op \<approx> OOO op \<approx>) Cons Cons"
  apply (auto intro!: rel_funI)
  apply (rule_tac b="x # b" in relcomppI)
  apply auto
  apply (rule_tac b="x # ba" in relcomppI)
  apply auto
  done

lemma Nil_prs2 [quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "(Abs \<circ> map f) [] = Abs []"
  by simp

lemma Cons_prs2 [quot_preserve]:
  assumes q: "Quotient3 R1 Abs1 Rep1"
  and     r: "Quotient3 R2 Abs2 Rep2"
  shows "(Rep1 ---> (map Rep1 \<circ> Rep2) ---> (Abs2 \<circ> map Abs1)) (op #) = (id ---> Rep2 ---> Abs2) (op #)"
  by (auto simp add: fun_eq_iff comp_def Quotient3_abs_rep [OF q])

lemma append_prs2 [quot_preserve]:
  assumes q: "Quotient3 R1 Abs1 Rep1"
  and     r: "Quotient3 R2 Abs2 Rep2"
  shows "((map Rep1 \<circ> Rep2) ---> (map Rep1 \<circ> Rep2) ---> (Abs2 \<circ> map Abs1)) op @ =
    (Rep2 ---> Rep2 ---> Abs2) op @"
  by (simp add: fun_eq_iff abs_o_rep[OF q] List.map.id)

lemma list_all2_app_l:
  assumes a: "reflp R"
  and b: "list_all2 R l r"
  shows "list_all2 R (z @ l) (z @ r)"
  using a b by (induct z) (auto elim: reflpE)

lemma append_rsp2_pre0:
  assumes a:"list_all2 op \<approx> x x'"
  shows "list_all2 op \<approx> (x @ z) (x' @ z)"
  using a apply (induct x x' rule: list_induct2')
  by simp_all (rule list_all2_refl'[OF list_eq_equivp])

lemma append_rsp2_pre1:
  assumes a:"list_all2 op \<approx> x x'"
  shows "list_all2 op \<approx> (z @ x) (z @ x')"
  using a apply (induct x x' arbitrary: z rule: list_induct2')
  apply (rule list_all2_refl'[OF list_eq_equivp])
  apply (simp_all del: list_eq_def)
  apply (rule list_all2_app_l)
  apply (simp_all add: reflpI)
  done

lemma append_rsp2_pre:
  assumes "list_all2 op \<approx> x x'"
    and "list_all2 op \<approx> z z'"
  shows "list_all2 op \<approx> (x @ z) (x' @ z')"
  using assms by (rule list_all2_appendI)

lemma compositional_rsp3:
  assumes "(R1 ===> R2 ===> R3) C C" and "(R4 ===> R5 ===> R6) C C"
  shows "(R1 OOO R4 ===> R2 OOO R5 ===> R3 OOO R6) C C"
  by (auto intro!: rel_funI)
     (metis (full_types) assms rel_funE relcomppI)

lemma append_rsp2 [quot_respect]:
  "(list_all2 op \<approx> OOO op \<approx> ===> list_all2 op \<approx> OOO op \<approx> ===> list_all2 op \<approx> OOO op \<approx>) append append"
  by (intro compositional_rsp3)
     (auto intro!: rel_funI simp add: append_rsp2_pre)

lemma map_rsp2 [quot_respect]:
  "((op \<approx> ===> op \<approx>) ===> list_all2 op \<approx> OOO op \<approx> ===> list_all2 op \<approx> OOO op \<approx>) map map"
proof (auto intro!: rel_funI)
  fix f f' :: "'a list \<Rightarrow> 'b list"
  fix xa ya x y :: "'a list list"
  assume fs: "(op \<approx> ===> op \<approx>) f f'" and x: "list_all2 op \<approx> xa x" and xy: "set x = set y" and y: "list_all2 op \<approx> y ya"
  have a: "(list_all2 op \<approx>) (map f xa) (map f x)"
    using x
    by (induct xa x rule: list_induct2')
       (simp_all, metis fs rel_funE list_eq_def)
  have b: "set (map f x) = set (map f y)"
    using xy fs
    by (induct x y rule: list_induct2')
       (simp_all, metis image_insert)
  have c: "(list_all2 op \<approx>) (map f y) (map f' ya)"
    using y fs
    by (induct y ya rule: list_induct2')
       (simp_all, metis apply_rsp' list_eq_def)
  show "(list_all2 op \<approx> OOO op \<approx>) (map f xa) (map f' ya)"
    by (metis a b c list_eq_def relcomppI)
qed

lemma map_prs2 [quot_preserve]:
  shows "((abs_fset ---> rep_fset) ---> (map rep_fset \<circ> rep_fset) ---> abs_fset \<circ> map abs_fset) map = (id ---> rep_fset ---> abs_fset) map"
  by (auto simp add: fun_eq_iff)
     (simp only: map_map[symmetric] map_prs_aux[OF Quotient3_fset Quotient3_fset])

section {* Lifted theorems *}

subsection {* fset *}

lemma fset_simps [simp]:
  shows "fset {||} = {}"
  and   "fset (insert_fset x S) = insert x (fset S)"
  by (descending, simp)+

lemma finite_fset [simp]:
  shows "finite (fset S)"
  by (descending) (simp)

lemma fset_cong:
  shows "fset S = fset T \<longleftrightarrow> S = T"
  by (descending) (simp)

lemma filter_fset [simp]:
  shows "fset (filter_fset P xs) = Collect P \<inter> fset xs"
  by (descending) (auto)

lemma remove_fset [simp]:
  shows "fset (remove_fset x xs) = fset xs - {x}"
  by (descending) (simp)

lemma inter_fset [simp]:
  shows "fset (xs |\<inter>| ys) = fset xs \<inter> fset ys"
  by (descending) (auto)

lemma union_fset [simp]:
  shows "fset (xs |\<union>| ys) = fset xs \<union> fset ys"
  by (lifting set_append)

lemma minus_fset [simp]:
  shows "fset (xs - ys) = fset xs - fset ys"
  by (descending) (auto)

subsection {* in_fset *}

lemma in_fset:
  shows "x |\<in>| S \<longleftrightarrow> x \<in> fset S"
  by descending simp

lemma notin_fset:
  shows "x |\<notin>| S \<longleftrightarrow> x \<notin> fset S"
  by (simp add: in_fset)

lemma notin_empty_fset:
  shows "x |\<notin>| {||}"
  by (simp add: in_fset)

lemma fset_eq_iff:
  shows "S = T \<longleftrightarrow> (\<forall>x. (x |\<in>| S) = (x |\<in>| T))"
  by descending auto

lemma none_in_empty_fset:
  shows "(\<forall>x. x |\<notin>| S) \<longleftrightarrow> S = {||}"
  by descending simp

subsection {* insert_fset *}

lemma in_insert_fset_iff [simp]:
  shows "x |\<in>| insert_fset y S \<longleftrightarrow> x = y \<or> x |\<in>| S"
  by descending simp

lemma
  shows insert_fsetI1: "x |\<in>| insert_fset x S"
  and   insert_fsetI2: "x |\<in>| S \<Longrightarrow> x |\<in>| insert_fset y S"
  by simp_all

lemma insert_absorb_fset [simp]:
  shows "x |\<in>| S \<Longrightarrow> insert_fset x S = S"
  by (descending) (auto)

lemma empty_not_insert_fset[simp]:
  shows "{||} \<noteq> insert_fset x S"
  and   "insert_fset x S \<noteq> {||}"
  by (descending, simp)+

lemma insert_fset_left_comm:
  shows "insert_fset x (insert_fset y S) = insert_fset y (insert_fset x S)"
  by (descending) (auto)

lemma insert_fset_left_idem:
  shows "insert_fset x (insert_fset x S) = insert_fset x S"
  by (descending) (auto)

lemma singleton_fset_eq[simp]:
  shows "{|x|} = {|y|} \<longleftrightarrow> x = y"
  by (descending) (auto)

lemma in_fset_mdef:
  shows "x |\<in>| F \<longleftrightarrow> x |\<notin>| (F - {|x|}) \<and> F = insert_fset x (F - {|x|})"
  by (descending) (auto)

subsection {* union_fset *}

lemmas [simp] =
  sup_bot_left[where 'a="'a fset"]
  sup_bot_right[where 'a="'a fset"]

lemma union_insert_fset [simp]:
  shows "insert_fset x S |\<union>| T = insert_fset x (S |\<union>| T)"
  by (lifting append.simps(2))

lemma singleton_union_fset_left:
  shows "{|a|} |\<union>| S = insert_fset a S"
  by simp

lemma singleton_union_fset_right:
  shows "S |\<union>| {|a|} = insert_fset a S"
  by (subst sup.commute) simp

lemma in_union_fset:
  shows "x |\<in>| S |\<union>| T \<longleftrightarrow> x |\<in>| S \<or> x |\<in>| T"
  by (descending) (simp)

subsection {* minus_fset *}

lemma minus_in_fset:
  shows "x |\<in>| (xs - ys) \<longleftrightarrow> x |\<in>| xs \<and> x |\<notin>| ys"
  by (descending) (simp)

lemma minus_insert_fset:
  shows "insert_fset x xs - ys = (if x |\<in>| ys then xs - ys else insert_fset x (xs - ys))"
  by (descending) (auto)

lemma minus_insert_in_fset[simp]:
  shows "x |\<in>| ys \<Longrightarrow> insert_fset x xs - ys = xs - ys"
  by (simp add: minus_insert_fset)

lemma minus_insert_notin_fset[simp]:
  shows "x |\<notin>| ys \<Longrightarrow> insert_fset x xs - ys = insert_fset x (xs - ys)"
  by (simp add: minus_insert_fset)

lemma in_minus_fset:
  shows "x |\<in>| F - S \<Longrightarrow> x |\<notin>| S"
  unfolding in_fset minus_fset
  by blast

lemma notin_minus_fset:
  shows "x |\<in>| S \<Longrightarrow> x |\<notin>| F - S"
  unfolding in_fset minus_fset
  by blast

subsection {* remove_fset *}

lemma in_remove_fset:
  shows "x |\<in>| remove_fset y S \<longleftrightarrow> x |\<in>| S \<and> x \<noteq> y"
  by (descending) (simp)

lemma notin_remove_fset:
  shows "x |\<notin>| remove_fset x S"
  by (descending) (simp)

lemma notin_remove_ident_fset:
  shows "x |\<notin>| S \<Longrightarrow> remove_fset x S = S"
  by (descending) (simp)

lemma remove_fset_cases:
  shows "S = {||} \<or> (\<exists>x. x |\<in>| S \<and> S = insert_fset x (remove_fset x S))"
  by (descending) (auto simp add: insert_absorb)

subsection {* inter_fset *}

lemma inter_empty_fset_l:
  shows "{||} |\<inter>| S = {||}"
  by simp

lemma inter_empty_fset_r:
  shows "S |\<inter>| {||} = {||}"
  by simp

lemma inter_insert_fset:
  shows "insert_fset x S |\<inter>| T = (if x |\<in>| T then insert_fset x (S |\<inter>| T) else S |\<inter>| T)"
  by (descending) (auto)

lemma in_inter_fset:
  shows "x |\<in>| (S |\<inter>| T) \<longleftrightarrow> x |\<in>| S \<and> x |\<in>| T"
  by (descending) (simp)

subsection {* subset_fset and psubset_fset *}

lemma subset_fset:
  shows "xs |\<subseteq>| ys \<longleftrightarrow> fset xs \<subseteq> fset ys"
  by (descending) (simp)

lemma psubset_fset:
  shows "xs |\<subset>| ys \<longleftrightarrow> fset xs \<subset> fset ys"
  unfolding less_fset_def
  by (descending) (auto)

lemma subset_insert_fset:
  shows "(insert_fset x xs) |\<subseteq>| ys \<longleftrightarrow> x |\<in>| ys \<and> xs |\<subseteq>| ys"
  by (descending) (simp)

lemma subset_in_fset:
  shows "xs |\<subseteq>| ys = (\<forall>x. x |\<in>| xs \<longrightarrow> x |\<in>| ys)"
  by (descending) (auto)

lemma subset_empty_fset:
  shows "xs |\<subseteq>| {||} \<longleftrightarrow> xs = {||}"
  by (descending) (simp)

lemma not_psubset_empty_fset:
  shows "\<not> xs |\<subset>| {||}"
  by (metis fset_simps(1) psubset_fset not_psubset_empty)

subsection {* map_fset *}

lemma map_fset_simps [simp]:
   shows "map_fset f {||} = {||}"
  and   "map_fset f (insert_fset x S) = insert_fset (f x) (map_fset f S)"
  by (descending, simp)+

lemma map_fset_image [simp]:
  shows "fset (map_fset f S) = f ` (fset S)"
  by (descending) (simp)

lemma inj_map_fset_cong:
  shows "inj f \<Longrightarrow> map_fset f S = map_fset f T \<longleftrightarrow> S = T"
  by (descending) (metis inj_vimage_image_eq list_eq_def set_map)

lemma map_union_fset:
  shows "map_fset f (S |\<union>| T) = map_fset f S |\<union>| map_fset f T"
  by (descending) (simp)

lemma in_fset_map_fset[simp]: "a |\<in>| map_fset f X = (\<exists>b. b |\<in>| X \<and> a = f b)"
  by descending auto

subsection {* card_fset *}

lemma card_fset:
  shows "card_fset xs = card (fset xs)"
  by (descending) (simp)

lemma card_insert_fset_iff [simp]:
  shows "card_fset (insert_fset x S) = (if x |\<in>| S then card_fset S else Suc (card_fset S))"
  by (descending) (simp add: insert_absorb)

lemma card_fset_0[simp]:
  shows "card_fset S = 0 \<longleftrightarrow> S = {||}"
  by (descending) (simp)

lemma card_empty_fset[simp]:
  shows "card_fset {||} = 0"
  by (simp add: card_fset)

lemma card_fset_1:
  shows "card_fset S = 1 \<longleftrightarrow> (\<exists>x. S = {|x|})"
  by (descending) (auto simp add: card_Suc_eq)

lemma card_fset_gt_0:
  shows "x \<in> fset S \<Longrightarrow> 0 < card_fset S"
  by (descending) (auto simp add: card_gt_0_iff)

lemma card_notin_fset:
  shows "(x |\<notin>| S) = (card_fset (insert_fset x S) = Suc (card_fset S))"
  by simp

lemma card_fset_Suc:
  shows "card_fset S = Suc n \<Longrightarrow> \<exists>x T. x |\<notin>| T \<and> S = insert_fset x T \<and> card_fset T = n"
  apply(descending)
  apply(auto dest!: card_eq_SucD)
  by (metis Diff_insert_absorb set_removeAll)

lemma card_remove_fset_iff [simp]:
  shows "card_fset (remove_fset y S) = (if y |\<in>| S then card_fset S - 1 else card_fset S)"
  by (descending) (simp)

lemma card_Suc_exists_in_fset:
  shows "card_fset S = Suc n \<Longrightarrow> \<exists>a. a |\<in>| S"
  by (drule card_fset_Suc) (auto)

lemma in_card_fset_not_0:
  shows "a |\<in>| A \<Longrightarrow> card_fset A \<noteq> 0"
  by (descending) (auto)

lemma card_fset_mono:
  shows "xs |\<subseteq>| ys \<Longrightarrow> card_fset xs \<le> card_fset ys"
  unfolding card_fset psubset_fset
  by (simp add: card_mono subset_fset)

lemma card_subset_fset_eq:
  shows "xs |\<subseteq>| ys \<Longrightarrow> card_fset ys \<le> card_fset xs \<Longrightarrow> xs = ys"
  unfolding card_fset subset_fset
  by (auto dest: card_seteq[OF finite_fset] simp add: fset_cong)

lemma psubset_card_fset_mono:
  shows "xs |\<subset>| ys \<Longrightarrow> card_fset xs < card_fset ys"
  unfolding card_fset subset_fset
  by (metis finite_fset psubset_fset psubset_card_mono)

lemma card_union_inter_fset:
  shows "card_fset xs + card_fset ys = card_fset (xs |\<union>| ys) + card_fset (xs |\<inter>| ys)"
  unfolding card_fset union_fset inter_fset
  by (rule card_Un_Int[OF finite_fset finite_fset])

lemma card_union_disjoint_fset:
  shows "xs |\<inter>| ys = {||} \<Longrightarrow> card_fset (xs |\<union>| ys) = card_fset xs + card_fset ys"
  unfolding card_fset union_fset
  apply (rule card_Un_disjoint[OF finite_fset finite_fset])
  by (metis inter_fset fset_simps(1))

lemma card_remove_fset_less1:
  shows "x |\<in>| xs \<Longrightarrow> card_fset (remove_fset x xs) < card_fset xs"
  unfolding card_fset in_fset remove_fset
  by (rule card_Diff1_less[OF finite_fset])

lemma card_remove_fset_less2:
  shows "x |\<in>| xs \<Longrightarrow> y |\<in>| xs \<Longrightarrow> card_fset (remove_fset y (remove_fset x xs)) < card_fset xs"
  unfolding card_fset remove_fset in_fset
  by (rule card_Diff2_less[OF finite_fset])

lemma card_remove_fset_le1:
  shows "card_fset (remove_fset x xs) \<le> card_fset xs"
  unfolding remove_fset card_fset
  by (rule card_Diff1_le[OF finite_fset])

lemma card_psubset_fset:
  shows "ys |\<subseteq>| xs \<Longrightarrow> card_fset ys < card_fset xs \<Longrightarrow> ys |\<subset>| xs"
  unfolding card_fset psubset_fset subset_fset
  by (rule card_psubset[OF finite_fset])

lemma card_map_fset_le:
  shows "card_fset (map_fset f xs) \<le> card_fset xs"
  unfolding card_fset map_fset_image
  by (rule card_image_le[OF finite_fset])

lemma card_minus_insert_fset[simp]:
  assumes "a |\<in>| A" and "a |\<notin>| B"
  shows "card_fset (A - insert_fset a B) = card_fset (A - B) - 1"
  using assms
  unfolding in_fset card_fset minus_fset
  by (simp add: card_Diff_insert[OF finite_fset])

lemma card_minus_subset_fset:
  assumes "B |\<subseteq>| A"
  shows "card_fset (A - B) = card_fset A - card_fset B"
  using assms
  unfolding subset_fset card_fset minus_fset
  by (rule card_Diff_subset[OF finite_fset])

lemma card_minus_fset:
  shows "card_fset (A - B) = card_fset A - card_fset (A |\<inter>| B)"
  unfolding inter_fset card_fset minus_fset
  by (rule card_Diff_subset_Int) (simp)

subsection {* concat_fset *}

lemma concat_empty_fset [simp]:
  shows "concat_fset {||} = {||}"
  by descending simp

lemma concat_insert_fset [simp]:
  shows "concat_fset (insert_fset x S) = x |\<union>| concat_fset S"
  by descending simp

lemma concat_union_fset [simp]:
  shows "concat_fset (xs |\<union>| ys) = concat_fset xs |\<union>| concat_fset ys"
  by descending simp

lemma map_concat_fset:
  shows "map_fset f (concat_fset xs) = concat_fset (map_fset (map_fset f) xs)"
  by (lifting map_concat)

subsection {* filter_fset *}

lemma subset_filter_fset:
  "filter_fset P xs |\<subseteq>| filter_fset Q xs = (\<forall> x. x |\<in>| xs \<longrightarrow> P x \<longrightarrow> Q x)"
  by descending auto

lemma eq_filter_fset:
  "(filter_fset P xs = filter_fset Q xs) = (\<forall>x. x |\<in>| xs \<longrightarrow> P x = Q x)"
  by descending auto

lemma psubset_filter_fset:
  "(\<And>x. x |\<in>| xs \<Longrightarrow> P x \<Longrightarrow> Q x) \<Longrightarrow> (x |\<in>| xs & \<not> P x & Q x) \<Longrightarrow>
    filter_fset P xs |\<subset>| filter_fset Q xs"
  unfolding less_fset_def by (auto simp add: subset_filter_fset eq_filter_fset)

subsection {* fold_fset *}

lemma fold_empty_fset:
  "fold_fset f {||} = id"
  by descending (simp add: fold_once_def)

lemma fold_insert_fset: "fold_fset f (insert_fset a A) =
  (if rsp_fold f then if a |\<in>| A then fold_fset f A else fold_fset f A \<circ> f a else id)"
  by descending (simp add: fold_once_fold_remdups)

lemma remdups_removeAll:
  "remdups (removeAll x xs) = remove1 x (remdups xs)"
  by (induct xs) auto

lemma member_commute_fold_once:
  assumes "rsp_fold f"
    and "x \<in> set xs"
  shows "fold_once f xs = fold_once f (removeAll x xs) \<circ> f x"
proof -
  from assms have "fold f (remdups xs) = fold f (remove1 x (remdups xs)) \<circ> f x"
    by (auto intro!: fold_remove1_split elim: rsp_foldE)
  then show ?thesis using `rsp_fold f` by (simp add: fold_once_fold_remdups remdups_removeAll)
qed

lemma in_commute_fold_fset:
  "rsp_fold f \<Longrightarrow> h |\<in>| b \<Longrightarrow> fold_fset f b = fold_fset f (remove_fset h b) \<circ> f h"
  by descending (simp add: member_commute_fold_once)

subsection {* Choice in fsets *}

lemma fset_choice:
  assumes a: "\<forall>x. x |\<in>| A \<longrightarrow> (\<exists>y. P x y)"
  shows "\<exists>f. \<forall>x. x |\<in>| A \<longrightarrow> P x (f x)"
  using a
  apply(descending)
  using finite_set_choice
  by (auto simp add: Ball_def)

section {* Induction and Cases rules for fsets *}

lemma fset_exhaust [case_names empty insert, cases type: fset]:
  assumes empty_fset_case: "S = {||} \<Longrightarrow> P"
  and     insert_fset_case: "\<And>x S'. S = insert_fset x S' \<Longrightarrow> P"
  shows "P"
  using assms by (lifting list.exhaust)

lemma fset_induct [case_names empty insert]:
  assumes empty_fset_case: "P {||}"
  and     insert_fset_case: "\<And>x S. P S \<Longrightarrow> P (insert_fset x S)"
  shows "P S"
  using assms
  by (descending) (blast intro: list.induct)

lemma fset_induct_stronger [case_names empty insert, induct type: fset]:
  assumes empty_fset_case: "P {||}"
  and     insert_fset_case: "\<And>x S. \<lbrakk>x |\<notin>| S; P S\<rbrakk> \<Longrightarrow> P (insert_fset x S)"
  shows "P S"
proof(induct S rule: fset_induct)
  case empty
  show "P {||}" using empty_fset_case by simp
next
  case (insert x S)
  have "P S" by fact
  then show "P (insert_fset x S)" using insert_fset_case
    by (cases "x |\<in>| S") (simp_all)
qed

lemma fset_card_induct:
  assumes empty_fset_case: "P {||}"
  and     card_fset_Suc_case: "\<And>S T. Suc (card_fset S) = (card_fset T) \<Longrightarrow> P S \<Longrightarrow> P T"
  shows "P S"
proof (induct S)
  case empty
  show "P {||}" by (rule empty_fset_case)
next
  case (insert x S)
  have h: "P S" by fact
  have "x |\<notin>| S" by fact
  then have "Suc (card_fset S) = card_fset (insert_fset x S)"
    using card_fset_Suc by auto
  then show "P (insert_fset x S)"
    using h card_fset_Suc_case by simp
qed

lemma fset_raw_strong_cases:
  obtains "xs = []"
    | ys x where "\<not> List.member ys x" and "xs \<approx> x # ys"
proof (induct xs)
  case Nil
  then show thesis by simp
next
  case (Cons a xs)
  have a: "\<lbrakk>xs = [] \<Longrightarrow> thesis; \<And>x ys. \<lbrakk>\<not> List.member ys x; xs \<approx> x # ys\<rbrakk> \<Longrightarrow> thesis\<rbrakk> \<Longrightarrow> thesis"
    by (rule Cons(1))
  have b: "\<And>x' ys'. \<lbrakk>\<not> List.member ys' x'; a # xs \<approx> x' # ys'\<rbrakk> \<Longrightarrow> thesis" by fact
  have c: "xs = [] \<Longrightarrow> thesis" using b
    apply(simp)
    by (metis list.set(1) emptyE empty_subsetI)
  have "\<And>x ys. \<lbrakk>\<not> List.member ys x; xs \<approx> x # ys\<rbrakk> \<Longrightarrow> thesis"
  proof -
    fix x :: 'a
    fix ys :: "'a list"
    assume d:"\<not> List.member ys x"
    assume e:"xs \<approx> x # ys"
    show thesis
    proof (cases "x = a")
      assume h: "x = a"
      then have f: "\<not> List.member ys a" using d by simp
      have g: "a # xs \<approx> a # ys" using e h by auto
      show thesis using b f g by simp
    next
      assume h: "x \<noteq> a"
      then have f: "\<not> List.member (a # ys) x" using d by auto
      have g: "a # xs \<approx> x # (a # ys)" using e h by auto
      show thesis using b f g by (simp del: List.member_def)
    qed
  qed
  then show thesis using a c by blast
qed

lemma fset_strong_cases:
  obtains "xs = {||}"
    | ys x where "x |\<notin>| ys" and "xs = insert_fset x ys"
  by (lifting fset_raw_strong_cases)

lemma fset_induct2:
  "P {||} {||} \<Longrightarrow>
  (\<And>x xs. x |\<notin>| xs \<Longrightarrow> P (insert_fset x xs) {||}) \<Longrightarrow>
  (\<And>y ys. y |\<notin>| ys \<Longrightarrow> P {||} (insert_fset y ys)) \<Longrightarrow>
  (\<And>x xs y ys. \<lbrakk>P xs ys; x |\<notin>| xs; y |\<notin>| ys\<rbrakk> \<Longrightarrow> P (insert_fset x xs) (insert_fset y ys)) \<Longrightarrow>
  P xsa ysa"
  apply (induct xsa arbitrary: ysa)
  apply (induct_tac x rule: fset_induct_stronger)
  apply simp_all
  apply (induct_tac xa rule: fset_induct_stronger)
  apply simp_all
  done

text {* Extensionality *}

lemma fset_eqI:
  assumes "\<And>x. x \<in> fset A \<longleftrightarrow> x \<in> fset B"
  shows "A = B"
using assms proof (induct A arbitrary: B)
  case empty then show ?case
    by (auto simp add: in_fset none_in_empty_fset [symmetric] sym)
next
  case (insert x A)
  from insert.prems insert.hyps(1) have "\<And>z. z \<in> fset A \<longleftrightarrow> z \<in> fset (B - {|x|})"
    by (auto simp add: in_fset)
  then have A: "A = B - {|x|}" by (rule insert.hyps(2))
  with insert.prems [symmetric, of x] have "x |\<in>| B" by (simp add: in_fset)
  with A show ?case by (metis in_fset_mdef)
qed

subsection {* alternate formulation with a different decomposition principle
  and a proof of equivalence *}

inductive
  list_eq2 :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<approx>2 _")
where
  "(a # b # xs) \<approx>2 (b # a # xs)"
| "[] \<approx>2 []"
| "xs \<approx>2 ys \<Longrightarrow> ys \<approx>2 xs"
| "(a # a # xs) \<approx>2 (a # xs)"
| "xs \<approx>2 ys \<Longrightarrow> (a # xs) \<approx>2 (a # ys)"
| "xs1 \<approx>2 xs2 \<Longrightarrow> xs2 \<approx>2 xs3 \<Longrightarrow> xs1 \<approx>2 xs3"

lemma list_eq2_refl:
  shows "xs \<approx>2 xs"
  by (induct xs) (auto intro: list_eq2.intros)

lemma cons_delete_list_eq2:
  shows "(a # (removeAll a A)) \<approx>2 (if List.member A a then A else a # A)"
  apply (induct A)
  apply (simp add: list_eq2_refl)
  apply (case_tac "List.member (aa # A) a")
  apply (simp_all)
  apply (case_tac [!] "a = aa")
  apply (simp_all)
  apply (case_tac "List.member A a")
  apply (auto)[2]
  apply (metis list_eq2.intros(3) list_eq2.intros(4) list_eq2.intros(5) list_eq2.intros(6))
  apply (metis list_eq2.intros(1) list_eq2.intros(5) list_eq2.intros(6))
  apply (auto simp add: list_eq2_refl)
  done

lemma member_delete_list_eq2:
  assumes a: "List.member r e"
  shows "(e # removeAll e r) \<approx>2 r"
  using a cons_delete_list_eq2[of e r]
  by simp

lemma list_eq2_equiv:
  "(l \<approx> r) \<longleftrightarrow> (list_eq2 l r)"
proof
  show "list_eq2 l r \<Longrightarrow> l \<approx> r" by (induct rule: list_eq2.induct) auto
next
  {
    fix n
    assume a: "card_list l = n" and b: "l \<approx> r"
    have "l \<approx>2 r"
      using a b
    proof (induct n arbitrary: l r)
      case 0
      have "card_list l = 0" by fact
      then have "\<forall>x. \<not> List.member l x" by auto
      then have z: "l = []" by auto
      then have "r = []" using `l \<approx> r` by simp
      then show ?case using z list_eq2_refl by simp
    next
      case (Suc m)
      have b: "l \<approx> r" by fact
      have d: "card_list l = Suc m" by fact
      then have "\<exists>a. List.member l a"
        apply(simp)
        apply(drule card_eq_SucD)
        apply(blast)
        done
      then obtain a where e: "List.member l a" by auto
      then have e': "List.member r a" using list_eq_def [simplified List.member_def [symmetric], of l r] b
        by auto
      have f: "card_list (removeAll a l) = m" using e d by (simp)
      have g: "removeAll a l \<approx> removeAll a r" using remove_fset.rsp b by simp
      have "(removeAll a l) \<approx>2 (removeAll a r)" by (rule Suc.hyps[OF f g])
      then have h: "(a # removeAll a l) \<approx>2 (a # removeAll a r)" by (rule list_eq2.intros(5))
      have i: "l \<approx>2 (a # removeAll a l)"
        by (rule list_eq2.intros(3)[OF member_delete_list_eq2[OF e]])
      have "l \<approx>2 (a # removeAll a r)" by (rule list_eq2.intros(6)[OF i h])
      then show ?case using list_eq2.intros(6)[OF _ member_delete_list_eq2[OF e']] by simp
    qed
    }
  then show "l \<approx> r \<Longrightarrow> l \<approx>2 r" by blast
qed

(* We cannot write it as "assumes .. shows" since Isabelle changes
   the quantifiers to schematic variables and reintroduces them in
   a different order *)
lemma fset_eq_cases:
 "\<lbrakk>a1 = a2;
   \<And>a b xs. \<lbrakk>a1 = insert_fset a (insert_fset b xs); a2 = insert_fset b (insert_fset a xs)\<rbrakk> \<Longrightarrow> P;
   \<lbrakk>a1 = {||}; a2 = {||}\<rbrakk> \<Longrightarrow> P; \<And>xs ys. \<lbrakk>a1 = ys; a2 = xs; xs = ys\<rbrakk> \<Longrightarrow> P;
   \<And>a xs. \<lbrakk>a1 = insert_fset a (insert_fset a xs); a2 = insert_fset a xs\<rbrakk> \<Longrightarrow> P;
   \<And>xs ys a. \<lbrakk>a1 = insert_fset a xs; a2 = insert_fset a ys; xs = ys\<rbrakk> \<Longrightarrow> P;
   \<And>xs1 xs2 xs3. \<lbrakk>a1 = xs1; a2 = xs3; xs1 = xs2; xs2 = xs3\<rbrakk> \<Longrightarrow> P\<rbrakk>
  \<Longrightarrow> P"
  by (lifting list_eq2.cases[simplified list_eq2_equiv[symmetric]])

lemma fset_eq_induct:
  assumes "x1 = x2"
  and "\<And>a b xs. P (insert_fset a (insert_fset b xs)) (insert_fset b (insert_fset a xs))"
  and "P {||} {||}"
  and "\<And>xs ys. \<lbrakk>xs = ys; P xs ys\<rbrakk> \<Longrightarrow> P ys xs"
  and "\<And>a xs. P (insert_fset a (insert_fset a xs)) (insert_fset a xs)"
  and "\<And>xs ys a. \<lbrakk>xs = ys; P xs ys\<rbrakk> \<Longrightarrow> P (insert_fset a xs) (insert_fset a ys)"
  and "\<And>xs1 xs2 xs3. \<lbrakk>xs1 = xs2; P xs1 xs2; xs2 = xs3; P xs2 xs3\<rbrakk> \<Longrightarrow> P xs1 xs3"
  shows "P x1 x2"
  using assms
  by (lifting list_eq2.induct[simplified list_eq2_equiv[symmetric]])

ML {*
fun dest_fsetT (Type (@{type_name fset}, [T])) = T
  | dest_fsetT T = raise TYPE ("dest_fsetT: fset type expected", [T], []);
*}

no_notation
  list_eq (infix "\<approx>" 50) and
  list_eq2 (infix "\<approx>2" 50)

end


section \<open>Concrete Atomic Presburger Formulas\<close>

(*<*)
theory Presburger_Formula
imports
  Abstract_Formula
  "HOL-Library.Code_Target_Int"
  "List-Index.List_Index"
begin
(*>*)

declare [[coercion "of_bool :: bool \<Rightarrow> nat"]]
declare [[coercion int]]
declare [[coercion_map map]]
declare [[coercion_enabled]]

fun len :: "nat \<Rightarrow> nat" where \<comment> \<open>FIXME yet another logarithm\<close>
  "len 0 = 0"
| "len (Suc 0) = 1"
| "len n = Suc (len (n div 2))"

lemma len_eq0_iff: "len n = 0 \<longleftrightarrow> n = 0"
  by (induct n rule: len.induct) auto

lemma len_mult2[simp]: "len (2 * x) = (if x = 0 then 0 else Suc (len x))"
proof (induct x rule: len.induct)
  show "len (2 * Suc 0) = (if Suc 0 = 0 then 0 else Suc (len (Suc 0)))" by (simp add: numeral_eq_Suc)
qed auto

lemma len_Suc_mult2[simp]: "len (Suc (2 * x)) = Suc (len x)"
proof (induct x rule: len.induct)
  show "len (Suc (2 * Suc 0)) = Suc (len (Suc 0))"
    by (metis div_less One_nat_def div2_Suc_Suc len.simps(3) lessI mult.right_neutral numeral_2_eq_2)
qed auto

lemma len_le_iff: "len x \<le> l \<longleftrightarrow> x < 2 ^ l"
proof (induct x arbitrary: l rule: len.induct)
  fix l show "(len (Suc 0) \<le> l) = (Suc 0 < 2 ^ l)"
  proof (cases l)
    case Suc then show ?thesis using le_less by fastforce
  qed simp
next
  fix v l assume "\<And>l. (len (Suc (Suc v) div 2) \<le> l) = (Suc (Suc v) div 2 < 2 ^ l)"
  then show "(len (Suc (Suc v)) \<le> l) = (Suc (Suc v) < 2 ^ l)"
    by (cases l) (simp_all, linarith)
qed simp

lemma len_pow2[simp]: "len (2 ^ x) = Suc x"
  by (induct x) auto

lemma len_div2[simp]: "len (x div 2) = len x - 1"
  by (induct x rule: len.induct) auto

lemma less_pow2_len[simp]: "x < 2 ^ len x"
  by (induct x rule: len.induct) auto

lemma len_alt: "len x = (LEAST i. x < 2 ^ i)"
proof (rule antisym)
  show "len x \<le> (LEAST i. x < 2 ^ i)"
    unfolding len_le_iff by (rule LeastI) (rule less_pow2_len)
qed (auto intro: Least_le)

lemma len_mono[simp]: "x \<le> y \<Longrightarrow> len x \<le> len y"
  unfolding len_le_iff using less_pow2_len[of y] by linarith

lemma len_div_pow2[simp]: "len (x div 2 ^ m) = len x - m"
  by (induct m arbitrary: x) (auto simp: div_mult2_eq)

lemma len_mult_pow2[simp]: "len (x * 2 ^ m) = (if x = 0 then 0 else len x + m)"
  by (induct m arbitrary: x) (auto simp: div_mult2_eq mult.assoc[symmetric] mult.commute[of _ 2])

lemma map_index'_Suc[simp]: "map_index' (Suc i) f xs = map_index' i (\<lambda>i. f (Suc i)) xs"
  by (induct xs arbitrary: i) auto

abbreviation (input) "zero n \<equiv> replicate n False"
abbreviation (input) "SUC \<equiv> \<lambda>_::unit. Suc"
definition "test_bit m n \<equiv> (m :: nat) div 2 ^ n mod 2 = 1"
definition "downshift m \<equiv> (m :: nat) div 2"
definition "upshift m \<equiv> (m :: nat) * 2"
definition "set_bit n m \<equiv> m + (if \<not> test_bit m n then 2 ^ n else (0 :: nat))"
definition "cut_bits n m \<equiv> (m :: nat) mod 2 ^ n"

typedef interp = "{(n :: nat, xs :: nat list). \<forall>x \<in> set xs. len x \<le> n}"
  by (force intro: exI[of _ "[]"])

setup_lifting type_definition_interp
type_synonym atom = "bool list"
type_synonym "value" = "nat"
datatype presb = Eq (tm: "int list") (const: int) (offset: "int")
derive linorder list
derive linorder presb
type_synonym formula = "(presb, unit) aformula"

lift_definition assigns :: "nat \<Rightarrow> interp \<Rightarrow> unit \<Rightarrow> value" ("_\<^bsup>_\<^esup>_" [900, 999, 999] 999) is
  "\<lambda>n (_, I) _. if n < length I then I ! n else 0" .

lift_definition nvars :: "interp \<Rightarrow> nat" ("#\<^sub>V _" [1000] 900) is
  "\<lambda>(_, I). length I" .

lift_definition Length :: "interp \<Rightarrow> nat" is "\<lambda>(n, _). n" .

lift_definition Extend :: "unit \<Rightarrow> nat \<Rightarrow> interp \<Rightarrow> value \<Rightarrow> interp" is
  "\<lambda>_ i (n, I) m. (max n (len m), insert_nth i m I)"
  by (force simp: max_def dest: in_set_takeD in_set_dropD)

lift_definition CONS :: "atom \<Rightarrow> interp \<Rightarrow> interp" is
  "\<lambda>bs (n, I). (Suc n, map_index (\<lambda>i n. 2 * n + (if bs ! i then 1 else 0)) I)"
  by (auto simp: set_zip)

lift_definition SNOC :: "atom \<Rightarrow> interp \<Rightarrow> interp" is
  "\<lambda>bs (n, I). (Suc n, map_index (\<lambda>i m. m + (if bs ! i then 2 ^ n else 0)) I)"
  by (auto simp: all_set_conv_all_nth len_le_iff)

definition extend :: "unit \<Rightarrow> bool \<Rightarrow> atom \<Rightarrow> atom" where
  "extend _ b bs \<equiv> b # bs"

abbreviation (input) size_atom :: "atom \<Rightarrow> nat" where
  "size_atom \<equiv> length"

definition FV0 :: "unit \<Rightarrow> presb \<Rightarrow> nat set" where
  "FV0 _ fm = (case fm of Eq is _ _ \<Rightarrow> {n. n < length is \<and> is!n \<noteq> 0})"

lemma FV0_code[code]:
  "FV0 x (Eq is i off) = Option.these (set (map_index (\<lambda>i x. if x = 0 then None else Some i) is))"
  unfolding FV0_def by (force simp: Option.these_def image_iff)

primrec wf0 :: "nat \<Rightarrow> presb \<Rightarrow> bool" where
  "wf0 idx (Eq is _ _) = (length is = idx)"

fun find0 where
  "find0 (_::unit) n (Eq is _ _) = (is ! n \<noteq> 0)"

primrec decr0 where
  "decr0 (_::unit) k (Eq is i d) = Eq (take k is @ drop (Suc k) is) i d"

definition scalar_product :: "nat list \<Rightarrow> int list \<Rightarrow> int" where
  "scalar_product ns is =
     sum_list (map_index (\<lambda>i b. (if i < length ns then ns ! i else 0) * b) is)"

lift_definition eval_tm :: "interp \<Rightarrow> int list \<Rightarrow> int" is
  "\<lambda>(_, I). scalar_product I" .

primrec satisfies0 where
  "satisfies0 I (Eq is i d) = (eval_tm I is = i - (2 ^ Length I) * d)"

inductive lformula0 where
  "lformula0 (Eq is i 0)"

code_pred lformula0 .

fun lderiv0 :: "bool list \<Rightarrow> presb \<Rightarrow> formula" where
  "lderiv0 bs (Eq is i d) = (if d \<noteq> 0 then undefined else
  (let v = i - scalar_product bs is
   in if v mod 2 = 0 then FBase (Eq is (v div 2) 0) else FBool False))"

fun rderiv0 :: "bool list \<Rightarrow> presb \<Rightarrow> formula" where
  "rderiv0 bs (Eq is i d) =
  (let
     l = - sum_list [i. i \<leftarrow> is, i < 0];
     h = - sum_list [i. i \<leftarrow> is, i > 0];
     d' = scalar_product bs is + 2 * d
   in if d' \<in> {min h i .. max l i} then FBase (Eq is i d') else FBool False)"

primrec nullable0 where
  "nullable0 (Eq is i off) = (i = off)"

definition \<sigma> :: "nat \<Rightarrow> atom list" where
  "\<sigma> n = List.n_lists n [True, False]"

named_theorems Presb_simps

lemma nvars_Extend[Presb_simps]: "#\<^sub>V (Extend () i \<AA> P) = Suc (#\<^sub>V \<AA>)"
  by (transfer, auto)

lemma Length_Extend[Presb_simps]: "Length (Extend () i \<AA> P) = max (Length \<AA>) (len P)"
  by (transfer, auto)

lemma Length0_inj[Presb_simps]: "Length \<AA> = 0 \<Longrightarrow> Length \<BB> = 0 \<Longrightarrow> #\<^sub>V \<AA> = #\<^sub>V \<BB> \<Longrightarrow> \<AA> = \<BB>"
  by transfer (auto intro: nth_equalityI simp: all_set_conv_all_nth len_eq0_iff)

lemma ex_Length0[Presb_simps]: "\<exists>\<AA>. Length \<AA> = 0 \<and> #\<^sub>V \<AA> = idx"
  by (transfer fixing: idx) (auto intro: exI[of _ "replicate idx 0"])

lemma Extend_commute_safe[Presb_simps]: "\<lbrakk>j \<le> i; i < Suc (#\<^sub>V \<AA>)\<rbrakk> \<Longrightarrow>
  Extend k j (Extend k i \<AA> P) Q = Extend k (Suc i) (Extend k j \<AA> Q) P"
  by transfer (auto simp add: min_def take_Cons take_drop le_imp_diff_is_add split: nat.splits)

lemma assigns_Extend[Presb_simps]: "i < Suc (#\<^sub>V \<AA>) \<Longrightarrow>
  m\<^bsup>Extend k i \<AA> P\<^esup>k' = (if k = k' then if m = i then P else dec i m\<^bsup>\<AA>\<^esup>k else m\<^bsup>\<AA>\<^esup>k')"
  by transfer (auto simp: nth_append dec_def min_def)

lemma assigns_SNOC_zero[Presb_simps]: "m < #\<^sub>V \<AA> \<Longrightarrow> m\<^bsup>SNOC (zero (#\<^sub>V \<AA>)) \<AA>\<^esup>k = m\<^bsup>\<AA>\<^esup>k"
  by transfer auto

lemma Length_CONS[Presb_simps]: "Length (CONS x \<AA>) = Suc (Length \<AA>)"
  by transfer auto

lemma Length_SNOC[Presb_simps]: "Length (SNOC x \<AA>) = Suc (Length \<AA>)"
  by transfer auto

lemma nvars_CONS[Presb_simps]: "#\<^sub>V (CONS x \<AA>) = #\<^sub>V \<AA>"
  by transfer auto

lemma Extend_CONS[Presb_simps]: "#\<^sub>V \<AA> = length x \<Longrightarrow>
  Extend k 0 (CONS x \<AA>) P = CONS (extend k (test_bit P 0) x) (Extend k 0 \<AA> (downshift P))"
  by transfer (auto simp: extend_def downshift_def test_bit_def, presburger+)

lemma Extend_SNOC[Presb_simps]: "\<lbrakk>#\<^sub>V \<AA> = length x; len P \<le> Length (SNOC x \<AA>)\<rbrakk> \<Longrightarrow>
  Extend k 0 (SNOC x \<AA>) P =
    SNOC (extend k (test_bit P (Length \<AA>)) x) (Extend k 0 \<AA> (cut_bits (Length \<AA>) P))"
  apply transfer
  apply (auto simp: cut_bits_def extend_def test_bit_def nth_Cons' max_absorb1 len_le_iff
    split: if_splits cong del: if_weak_cong)
   apply (metis add.commute mod_less mod_mult2_eq mult_numeral_1_right numeral_1_eq_Suc_0 power_commuting_commutes)
  apply (metis Euclidean_Division.div_eq_0_iff div_0 less_mult_imp_div_less mod_less nat_dvd_not_less semiring_normalization_rules(7))
  done

lemma odd_neq_even:
  "Suc (2 * x) = 2 * y \<longleftrightarrow> False"
  "2 * y = Suc (2 * x) \<longleftrightarrow> False"
  by presburger+

lemma CONS_inj[Presb_simps]: "size x = #\<^sub>V \<AA> \<Longrightarrow> size y = #\<^sub>V \<AA> \<Longrightarrow> #\<^sub>V \<AA> = #\<^sub>V \<BB> \<Longrightarrow>
  CONS x \<AA> = CONS y \<BB> \<longleftrightarrow> (x = y \<and> \<AA> = \<BB>)"
  by transfer (auto simp: list_eq_iff_nth_eq odd_neq_even split: if_splits)

lemma mod_2_Suc_iff:
  "x mod 2 = Suc 0 \<longleftrightarrow> x = Suc (2 * (x div 2))"
  by presburger+

lemma CONS_surj[Presb_simps]: "Length \<AA> \<noteq> 0 \<Longrightarrow>
  \<exists>x \<BB>. \<AA> = CONS x \<BB> \<and> #\<^sub>V \<BB> = #\<^sub>V \<AA> \<and> size x = #\<^sub>V \<AA>"
  by transfer
    (auto simp: gr0_conv_Suc list_eq_iff_nth_eq len_le_iff split: if_splits
    intro!: exI[of _ "map (\<lambda>n. n mod 2 \<noteq> 0) _"] exI[of _ "map (\<lambda>n. n div 2) _"];
    auto simp: mod_2_Suc_iff)

lemma [Presb_simps]:
  "length (extend k b x) = Suc (length x)"
  "downshift (upshift P) = P"
  "downshift (set_bit 0 P) = downshift P"
  "test_bit (set_bit n P) n"
  "\<not> test_bit (upshift P) 0"
  "len P \<le> p \<Longrightarrow> \<not> test_bit P p"
  "len (cut_bits n P) \<le> n"
  "len P \<le> n \<Longrightarrow> cut_bits n P = P"
  "len (upshift P) = (case len P of 0 \<Rightarrow> 0 | Suc n \<Rightarrow> Suc (Suc n))"
  "len (downshift P) = (case len P of 0 \<Rightarrow> 0 | Suc n \<Rightarrow> n)"
  by (auto simp: extend_def set_bit_def cut_bits_def upshift_def downshift_def test_bit_def
    len_le_iff len_eq0_iff div_add_self2 split: nat.split)

lemma Suc0_div_pow2_eq: "Suc 0 div 2 ^ i = (if i = 0 then 1 else 0)"
  by (induct i) (auto simp: div_mult2_eq)

lemma set_unset_bit_preserves_len:
  assumes "x div 2 ^ m = 2 * q" "m < len x"
  shows "x + 2 ^ m < 2 ^ len x"
using assms proof (induct m arbitrary: x)
  case 0 then show ?case
    by (auto simp: div_mult2_eq len_Suc_mult2[symmetric]
      simp del: len_Suc_mult2 power_Suc split: if_splits)
next
  case (Suc m)
  with Suc(1)[of "x div 2"] show ?case by (cases "len x") (auto simp: div_mult2_eq)
qed

lemma len_set_bit[Presb_simps]: "len (set_bit m P) = max (Suc m) (len P)"
proof (rule antisym)
  show "len (set_bit m P) \<le> max (Suc m) (len P)"
    by (auto simp: set_bit_def test_bit_def max_def Suc_le_eq not_less len_le_iff
      set_unset_bit_preserves_len simp del: One_nat_def)
next
  have "P < 2 ^ len (P + 2 ^ m)" by (rule order.strict_trans2[OF less_pow2_len]) auto
  moreover have "m < len (P + 2 ^ m)" by (rule order.strict_trans2[OF _ len_mono[of "2 ^ m"]]) auto
  ultimately show "max (Suc m) (len P) \<le> len (set_bit m P)"
    by (auto simp: set_bit_def test_bit_def max_def Suc_le_eq not_less len_le_iff)
qed

lemma mod_pow2_div_pow2:
  fixes p m n :: nat
  shows "m < n \<Longrightarrow> p mod 2 ^ n div 2 ^ m = p div 2 ^ m mod 2 ^ (n - m)"
  by (induct m arbitrary: p n) (auto simp: div_mult2_eq mod_mult2_eq Suc_less_eq2)

lemma irrelevant_set_bit[simp]:
  fixes p m n :: nat
  assumes "n \<le> m"
  shows "(p + 2 ^ m) mod 2 ^ n = p mod 2 ^ n"
proof -
  from assms obtain q :: nat where "2 ^ m = q * 2 ^ n"
    by (metis le_add_diff_inverse mult.commute power_add)
  then show ?thesis by simp
qed

lemma mod_lemma: "\<lbrakk> (0::nat) < c; r < b \<rbrakk> \<Longrightarrow> b * (q mod c) + r < b * c"
  by (metis add_gr_0 div_le_mono div_mult_self1_is_m less_imp_add_positive mod_less_divisor not_less split_div)

lemma relevant_set_bit[simp]:
  fixes p m n :: nat
  assumes "m < n" "p div 2 ^ m = 2 * q"
  shows "(p + 2 ^ m) mod 2 ^ n = p mod 2 ^ n + 2 ^ m"
proof -
  have "p mod 2 ^ n + 2 ^ m < 2 ^ n"
  using assms proof (induct m arbitrary: p n)
    case 0 then show ?case
      by (auto simp: gr0_conv_Suc)
         (metis One_nat_def Suc_eq_plus1 lessI mod_lemma numeral_2_eq_2 zero_less_numeral zero_less_power)
  next
    case (Suc m)
    from Suc(1)[of "n - 1" "p div 2"] Suc(2,3) show ?case
      by (auto simp: div_mult2_eq mod_mult2_eq Suc_less_eq2)
  qed
  with \<open>m < n\<close> show ?thesis by (subst mod_add_eq [symmetric]) auto
qed

lemma wf0_decr0[Presb_simps]:
  "wf0 (Suc idx) a \<Longrightarrow> l < Suc idx \<Longrightarrow> \<not> find0 k l a \<Longrightarrow> wf0 idx (decr0 k l a)"
  by (induct a) auto

lemma lformula0_decr0[Presb_simps]: "lformula0 a \<Longrightarrow> lformula0 (decr0 k l a)"
  by (induct a) (auto elim: lformula0.cases intro: lformula0.intros)

abbreviation sat0_syn (infix "\<Turnstile>0" 65) where
 "sat0_syn \<equiv> satisfies0"
abbreviation sat_syn (infix "\<Turnstile>" 65) where
 "sat_syn \<equiv> Formula_Operations.satisfies Extend Length satisfies0"
abbreviation sat_bounded_syn (infix "\<Turnstile>\<^sub>b" 65) where
 "sat_bounded_syn \<equiv> Formula_Operations.satisfies_bounded Extend Length len satisfies0"

lemma scalar_product_Nil[simp]: "scalar_product [] xs = 0"
  by (induct xs) (auto simp: scalar_product_def)

lemma scalar_product_Nil2[simp]: "scalar_product xs [] = 0"
  by (induct xs) (auto simp: scalar_product_def)

lemma scalar_product_Cons[simp]:
  "scalar_product xs (y # ys) = (case xs of x # xs \<Rightarrow> x * y + scalar_product xs ys | [] \<Rightarrow> 0)"
  by (cases xs) (simp, auto simp: scalar_product_def cong del: if_weak_cong)

lemma scalar_product_append[simp]: "scalar_product ns (xs @ ys) =
  scalar_product (take (length xs) ns) xs + scalar_product (drop (length xs) ns) ys"
  by (induct xs arbitrary: ns) (auto split: list.splits)

lemma scalar_product_trim: "scalar_product ns xs = scalar_product (take (length xs) ns) xs"
  by (induct xs arbitrary: ns) (auto split: list.splits)

lemma Extend_satisfies0_decr0[Presb_simps]:
  assumes "\<not> find0 k i a" "i < Suc (#\<^sub>V \<AA>)" "lformula0 a \<or> len P \<le> Length \<AA>"
  shows "Extend k i \<AA> P \<Turnstile>0 a = \<AA> \<Turnstile>0 decr0 k i a"
proof -
   { fix "is" :: "int list"
     assume "is ! i = 0"
     with assms(1,2) have "eval_tm (Extend k i \<AA> P) is = eval_tm \<AA> (take i is @ drop (Suc i) is)"
       by (cases a, transfer)
         (force intro: trans[OF scalar_product_trim] simp: min_def
         arg_cong2[OF refl id_take_nth_drop, of i _ scalar_product "take i xs @ _" for i x xs])
  } note * = this
  from assms show ?thesis
    by (cases a) (auto dest!: * simp: Length_Extend max_def elim: lformula0.cases)
qed

lemma scalar_product_eq0: "\<forall>c\<in>set ns. c = 0 \<Longrightarrow> scalar_product ns is = 0"
proof (induct "is" arbitrary: "ns")
  case Cons
  then show ?case by (cases ns) (auto simp: scalar_product_def cong del: if_weak_cong)
qed (simp add: scalar_product_def)

lemma nullable0_satisfies0[Presb_simps]: "Length \<AA> = 0 \<Longrightarrow> nullable0 a = \<AA> \<Turnstile>0 a"
proof (induct a)
  case Eq then show ?case unfolding nullable0.simps satisfies0.simps
    by transfer (auto simp: len_eq0_iff scalar_product_eq0)
qed

lemma satisfies0_cong: "wf0 (#\<^sub>V \<BB>) a \<Longrightarrow> #\<^sub>V \<AA> = #\<^sub>V \<BB> \<Longrightarrow> lformula0 a \<Longrightarrow>
  (\<And>m k. m < #\<^sub>V \<BB> \<Longrightarrow> m\<^bsup>\<AA>\<^esup>k = m\<^bsup>\<BB>\<^esup>k) \<Longrightarrow> \<AA> \<Turnstile>0 a = \<BB> \<Turnstile>0 a"
proof (induct a)
  case Eq then show ?case unfolding satisfies0.simps
    by transfer (auto simp: scalar_product_def
      intro!: arg_cong[of _ _ sum_list] map_index_cong elim!: lformula0.cases)
qed

lemma wf_lderiv0[Presb_simps]:
  "wf0 idx a \<Longrightarrow> lformula0 a \<Longrightarrow> Formula_Operations.wf (\<lambda>_. Suc) wf0 idx (lderiv0 x a)"
  by (induct a) (auto elim: lformula0.cases simp: Formula_Operations.wf.simps Let_def)

lemma lformula_lderiv0[Presb_simps]:
  "lformula0 a \<Longrightarrow> Formula_Operations.lformula lformula0 (lderiv0 x a)"
  by (induct a)
    (auto elim: lformula0.cases intro: lformula0.intros simp: Let_def Formula_Operations.lformula.simps)

lemma wf_rderiv0[Presb_simps]:
  "wf0 idx a \<Longrightarrow> Formula_Operations.wf (\<lambda>_. Suc) wf0 idx (rderiv0 x a)"
  by (induct a) (auto elim: lformula0.cases simp: Formula_Operations.wf.simps Let_def)

lemma find0_FV0[Presb_simps]: "\<lbrakk>wf0 idx a; l < idx\<rbrakk> \<Longrightarrow> find0 k l a = (l \<in> FV0 k a)"
  by (induct a) (auto simp: FV0_def)

lemma FV0_less[Presb_simps]: "wf0 idx a \<Longrightarrow> v \<in> FV0 k a \<Longrightarrow> v < idx"
  by (induct a) (auto simp: FV0_def)

lemma finite_FV0[Presb_simps]: "finite (FV0 k a)"
  by (induct a) (auto simp: FV0_def)

lemma finite_lderiv0[Presb_simps]:
  assumes "lformula0 a"
  shows "finite {\<phi>. \<exists>xs. \<phi> = fold (Formula_Operations.deriv extend lderiv0) xs (FBase a)}"
proof -
  define d where "d = Formula_Operations.deriv extend lderiv0"
  define l where "l is = sum_list [i. i \<leftarrow> is, i < 0]" for "is" :: "int list"
  define h where "h is = sum_list [i. i \<leftarrow> is, i > 0]" for "is" :: "int list"
  define \<Phi> where "\<Phi> a = (case a of
    Eq is n z \<Rightarrow> {FBase (Eq is i 0) | i . i \<in> {min (- h is) n .. max (- l is) n}} \<union>
      {FBool False :: formula})" for a
  { fix xs
    note Formula_Operations.fold_deriv_FBool[simp] Formula_Operations.deriv.simps[simp] \<Phi>_def[simp]
    from \<open>lformula0 a\<close> have "FBase a \<in> \<Phi> a" by (auto simp: elim!: lformula0.cases)
    moreover have "\<And>x \<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> d x \<phi> \<in> \<Phi> a"
    proof (induct a, unfold \<Phi>_def presb.case, elim UnE CollectE insertE emptyE exE conjE)
      fix "is" :: "int list" and bs :: "bool list" and i n :: int and \<phi> :: formula
      assume "i \<in> {min (- h is) n..max (- l is) n}" "\<phi> = FBase (presb.Eq is i 0)"
      moreover have "scalar_product bs is \<le> h is"
      proof (induct "is" arbitrary: bs)
        case (Cons x xs)
        from Cons[of "tl bs"] show ?case by (cases bs) (auto simp: h_def)
      qed (auto simp: h_def scalar_product_def)
      moreover have "l is \<le> scalar_product bs is"
      proof (induct "is" arbitrary: bs)
        case (Cons x xs)
        from Cons[of "tl bs"] show ?case by (cases bs) (auto simp: l_def)
      qed (auto simp: l_def scalar_product_def)
      ultimately show "d bs \<phi> \<in>
        {FBase (presb.Eq is i 0) |i. i \<in> {min (- h is) n..max (- l is) n}} \<union> {FBool False}"
        by (auto simp: d_def Let_def)
    qed (auto simp: d_def)
    then have "\<And>\<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> fold d xs \<phi> \<in> \<Phi> a" by (induct xs) auto
    ultimately have "fold d xs (FBase a) \<in> \<Phi> a" by blast
   }
   moreover have "finite (\<Phi> a)" unfolding \<Phi>_def by (auto split: presb.splits)
   ultimately show "?thesis" unfolding d_def by (blast intro: finite_subset)
qed

lemma finite_rderiv0[Presb_simps]:
  "finite {\<phi>. \<exists>xs. \<phi> = fold (Formula_Operations.deriv extend rderiv0) xs (FBase a)}"
proof -
  define d where "d = Formula_Operations.deriv extend rderiv0"
  define l where "l is = sum_list [i. i \<leftarrow> is, i < 0]"for "is" :: "int list"
  define h where "h is = sum_list [i. i \<leftarrow> is, i > 0]"for "is" :: "int list"
  define \<Phi> where "\<Phi> a = (case a of
    Eq is n z \<Rightarrow> {FBase (Eq is n i) | i . i \<in> {min (- h is) (min n z) .. max (- l is) (max n z)}} \<union>
      {FBool False :: formula})" for a
  { fix xs
    note Formula_Operations.fold_deriv_FBool[simp] Formula_Operations.deriv.simps[simp] \<Phi>_def[simp]
    have "FBase a \<in> \<Phi> a" by (auto split: presb.splits)
    moreover have "\<And>x \<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> d x \<phi> \<in> \<Phi> a"
    proof (induct a, unfold \<Phi>_def presb.case, elim UnE CollectE insertE emptyE exE conjE)
      fix "is" :: "int list" and bs :: "bool list" and i n m :: int and \<phi> :: formula
      assume "i \<in> {min (- h is) (min n m)..max (- l is) (max n m)}" "\<phi> = FBase (presb.Eq is n i)"
      moreover have "scalar_product bs is \<le> h is"
      proof (induct "is" arbitrary: bs)
        case (Cons x xs)
        from Cons[of "tl bs"] show ?case by (cases bs) (auto simp: h_def)
      qed (auto simp: h_def scalar_product_def)
      moreover have "l is \<le> scalar_product bs is"
      proof (induct "is" arbitrary: bs)
        case (Cons x xs)
        from Cons[of "tl bs"] show ?case by (cases bs) (auto simp: l_def)
      qed (auto simp: l_def scalar_product_def)
      ultimately show "d bs \<phi> \<in>
        {FBase (presb.Eq is n i) |i. i \<in> {min (- h is) (min n m)..max (- l is) (max n m)}} \<union> {FBool False}"
        by (auto 0 1 simp: d_def Let_def h_def l_def)
    qed (auto simp: d_def)
    then have "\<And>\<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> fold d xs \<phi> \<in> \<Phi> a" by (induct xs) auto
    ultimately have "fold d xs (FBase a) \<in> \<Phi> a" by blast
   }
   moreover have "finite (\<Phi> a)" unfolding \<Phi>_def by (auto split: presb.splits)
   ultimately show "?thesis" unfolding d_def by (blast intro: finite_subset)
qed

lemma scalar_product_CONS: "length xs = length (bs :: bool list) \<Longrightarrow>
  scalar_product (map_index (\<lambda>i n. 2 * n + bs ! i) xs) is =
  scalar_product bs is + 2 * scalar_product xs is"
  by (induct "is" arbitrary: bs xs) (auto split: list.splits simp: algebra_simps)

lemma eval_tm_CONS[simp]:
  "\<lbrakk>length is \<le> #\<^sub>V \<AA>; #\<^sub>V \<AA> = length x\<rbrakk> \<Longrightarrow>
   eval_tm (CONS x \<AA>) is = scalar_product x is + 2 * eval_tm \<AA> is"
  by transfer (auto simp: scalar_product_CONS[symmetric]
    intro!: arg_cong2[of _ _ _ _ scalar_product] nth_equalityI)

lemma satisfies_lderiv0[Presb_simps]:
  "\<lbrakk>wf0 (#\<^sub>V \<AA>) a; #\<^sub>V \<AA> = length x; lformula0 a\<rbrakk> \<Longrightarrow> \<AA> \<Turnstile> lderiv0 x a \<longleftrightarrow> CONS x \<AA> \<Turnstile>0 a"
  by (auto simp: Let_def Formula_Operations.satisfies_gen.simps
    split: if_splits elim!: lformula0.cases)

lemma satisfies_bounded_lderiv0[Presb_simps]:
  "\<lbrakk>wf0 (#\<^sub>V \<AA>) a; #\<^sub>V \<AA> = length x; lformula0 a\<rbrakk> \<Longrightarrow> \<AA> \<Turnstile>\<^sub>b lderiv0 x a \<longleftrightarrow> CONS x \<AA> \<Turnstile>0 a"
  by (auto simp: Let_def Formula_Operations.satisfies_gen.simps
    split: if_splits elim!: lformula0.cases)

lemma scalar_product_SNOC: "length xs = length (bs :: bool list)  \<Longrightarrow>
  scalar_product (map_index (\<lambda>i m. m + 2 ^ a * bs ! i) xs) is =
  scalar_product xs is + 2 ^ a * scalar_product bs is"
  by (induct "is" arbitrary: bs xs) (auto split: list.splits simp: algebra_simps)

lemma eval_tm_SNOC[simp]:
  "\<lbrakk>length is \<le> #\<^sub>V \<AA>; #\<^sub>V \<AA> = length x\<rbrakk> \<Longrightarrow>
   eval_tm (SNOC x \<AA>) is = eval_tm \<AA> is + 2 ^ Length \<AA> * scalar_product x is"
  by transfer (auto simp: scalar_product_SNOC[symmetric]
    intro!: arg_cong2[of _ _ _ _ scalar_product] nth_equalityI)

lemma Length_eq0_eval_tm_eq0[simp]: "Length \<AA> = 0 \<Longrightarrow> eval_tm \<AA> is = 0"
  by transfer (auto simp: len_eq0_iff scalar_product_eq0)

lemma less_pow2: "x < 2 ^ a \<Longrightarrow> int x < 2 ^ a"
  by (metis of_nat_less_iff of_nat_numeral of_nat_power [symmetric])

lemma scalar_product_upper_bound: "\<forall>x\<in>set b. len x \<le> a \<Longrightarrow>
  scalar_product b is \<le> (2 ^ a - 1) * sum_list [i. i \<leftarrow> is, i > 0]"
proof (induct "is" arbitrary: b)
  case (Cons i "is")
  then have "scalar_product (tl b) is \<le> (2 ^ a - 1) * sum_list [i. i \<leftarrow> is, i > 0]"
    by (auto simp: in_set_tlD)
  with Cons(2) show ?case
    by (auto 0 3 split: list.splits simp: len_le_iff mult_le_0_iff
      distrib_left add.commute[of _ "(2 ^ a - 1) * i"] less_pow2
      intro: add_mono elim: order_trans[OF add_mono[OF order_refl]])
qed simp

lemma scalar_product_lower_bound: "\<forall>x\<in>set b. len x \<le> a \<Longrightarrow>
  scalar_product b is \<ge> (2 ^ a - 1) * sum_list [i. i \<leftarrow> is, i < 0]"
proof (induct "is" arbitrary: b)
  case (Cons i "is")
  then have "scalar_product (tl b) is \<ge> (2 ^ a - 1) * sum_list [i. i \<leftarrow> is, i < 0]"
    by (auto simp: in_set_tlD)
  with Cons(2) show ?case
    by (auto 0 3 split: list.splits simp: len_le_iff mult_le_0_iff
      distrib_left add.commute[of _ "(2 ^ a - 1) * i"] less_pow2
      intro: add_mono elim: order_trans[OF add_mono[OF order_refl]] order_trans)
qed simp

lemma eval_tm_upper_bound: "eval_tm \<AA> is \<le> (2 ^ Length \<AA> - 1) * sum_list [i. i \<leftarrow> is, i > 0]"
  by transfer (auto simp: scalar_product_upper_bound)

lemma eval_tm_lower_bound: "eval_tm \<AA> is \<ge> (2 ^ Length \<AA> - 1) * sum_list [i. i \<leftarrow> is, i < 0]"
  by transfer (auto simp: scalar_product_lower_bound)

lemma satisfies_bounded_rderiv0[Presb_simps]:
  "\<lbrakk>wf0 (#\<^sub>V \<AA>) a; #\<^sub>V \<AA> = length x\<rbrakk> \<Longrightarrow> \<AA> \<Turnstile>\<^sub>b rderiv0 x a \<longleftrightarrow> SNOC x \<AA> \<Turnstile>0 a"
proof (induct a)
  case (Eq "is" n d)
  let ?l = "Length \<AA>"
  define d' where "d' = scalar_product x is + 2 * d"
  define l where "l = sum_list  [i. i \<leftarrow> is, i < 0]"
  define h where "h = sum_list  [i. i \<leftarrow> is, i > 0]"
  from Eq show ?case
  unfolding wf0.simps satisfies0.simps rderiv0.simps Let_def
  proof (split if_splits, simp only: Formula_Operations.satisfies_gen.simps satisfies0.simps
    Length_SNOC eval_tm_SNOC simp_thms(13) de_Morgan_conj not_le
    min_less_iff_conj max_less_iff_conj d'_def[symmetric] h_def[symmetric] l_def[symmetric], safe)
    assume "eval_tm \<AA> is + 2 ^ ?l * scalar_product x is = n - 2 ^ Suc ?l * d"
    with eval_tm_upper_bound[of \<AA> "is"] eval_tm_lower_bound[of \<AA> "is"] have
      *: "n + h \<le> 2 ^ ?l * (h + d')" "2 ^ ?l * (l + d') \<le> n + l"
      by (auto simp: algebra_simps h_def l_def d'_def)
    assume **: "d' \<notin> {min (- h) n..max (- l) n}"
    { assume "0 \<le> n + h"
      from order_trans[OF this *(1)] have "0 \<le> h + d'"
        unfolding zero_le_mult_iff using zero_less_power[of 2] by presburger
    }
    moreover
    { assume "n + h < 0"
      with *(1) have "n \<le> d'" by (auto dest: order_trans[OF _ mult_right_mono_neg[of 1]])
    }
    moreover
    { assume "n + l < 0"
      from le_less_trans[OF *(2) this] have "l + d' < 0" unfolding mult_less_0_iff by auto
    }
    moreover
    { assume "0 \<le> n + l"
      then have "0 \<le> l + d'" using ** calculation(1-2) by force
      with *(2) have "d' \<le> n" by (force dest: order_trans[OF mult_right_mono[of 1], rotated])
    }
    ultimately have "min (- h) n \<le> d'" "d' \<le> max (- l) n" by (auto simp: min_def max_def)
    with ** show False by auto
  qed (auto simp: algebra_simps d'_def)
qed

declare [[goals_limit = 100]]

global_interpretation Presb: Formula
  where SUC = SUC and LESS = "\<lambda>_. (<)" and Length = Length
  and assigns = assigns and nvars = nvars and Extend = Extend and CONS = CONS and SNOC = SNOC
  and extend = extend and size = size_atom and zero = zero and alphabet = \<sigma> and eval = test_bit
  and downshift = downshift and upshift = upshift and add = set_bit and cut = cut_bits and len = len
  and restrict = "\<lambda>_ _. True" and Restrict = "\<lambda>_ _. FBool True" and lformula0 = lformula0
  and FV0 = FV0 and find0 = find0 and wf0 = wf0 and decr0 = decr0 and satisfies0 = satisfies0
  and nullable0 = nullable0 and lderiv0 = lderiv0 and rderiv0 = rderiv0
  and TYPEVARS = undefined
  defines norm = "Formula_Operations.norm find0 decr0"
  and nFOr = "Formula_Operations.nFOr :: formula \<Rightarrow> _"
  and nFAnd = "Formula_Operations.nFAnd :: formula \<Rightarrow> _"
  and nFNot = "Formula_Operations.nFNot find0 decr0 :: formula \<Rightarrow> _"
  and nFEx = "Formula_Operations.nFEx find0 decr0"
  and nFAll = "Formula_Operations.nFAll find0 decr0"
  and decr = "Formula_Operations.decr decr0 :: _ \<Rightarrow> _ \<Rightarrow> formula \<Rightarrow> _"
  and find = "Formula_Operations.find find0 :: _ \<Rightarrow> _ \<Rightarrow> formula \<Rightarrow> _"
  and FV = "Formula_Operations.FV FV0"
  and RESTR = "Formula_Operations.RESTR (\<lambda>_ _. FBool True) :: _ \<Rightarrow> formula"
  and RESTRICT = "Formula_Operations.RESTRICT (\<lambda>_ _. FBool True) FV0"
  and deriv = "\<lambda>d0 (a :: atom) (\<phi> :: formula). Formula_Operations.deriv extend d0 a \<phi>"
  and nullable = "\<lambda>\<phi> :: formula. Formula_Operations.nullable nullable0 \<phi>"
  and fut_default = "Formula.fut_default extend zero rderiv0"
  and fut = "Formula.fut extend zero find0 decr0 rderiv0"
  and finalize = "Formula.finalize SUC extend zero find0 decr0 rderiv0"
  and final = "Formula.final SUC extend zero find0 decr0
     nullable0 rderiv0 :: nat \<Rightarrow> formula \<Rightarrow> _"
  and presb_wf = "Formula_Operations.wf SUC (wf0 :: nat \<Rightarrow> presb \<Rightarrow> _)"
  and presb_lformula = "Formula_Operations.lformula (lformula0 :: presb \<Rightarrow> _) :: formula \<Rightarrow> _"
  and check_eqv = "\<lambda>idx. DAs.check_eqv
    (\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: formula)
    (\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
    (final idx) (\<lambda>\<phi> :: formula. presb_wf idx \<phi> \<and> presb_lformula \<phi>)
    (\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: formula)
    (\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
    (final idx) (\<lambda>\<phi> :: formula. presb_wf idx \<phi> \<and> presb_lformula \<phi>)
    (=)"
  and bounded_check_eqv = "\<lambda>idx. DAs.check_eqv
    (\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: formula)
    (\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
    nullable (\<lambda>\<phi> :: formula. presb_wf idx \<phi> \<and> presb_lformula \<phi>)
    (\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: formula)
    (\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
    nullable (\<lambda>\<phi> :: formula. presb_wf idx \<phi> \<and> presb_lformula \<phi>)
    (=)"
  and automaton = "DA.automaton
    (\<lambda>a \<phi>. norm (deriv lderiv0 (a :: atom) \<phi> :: formula))"
  by standard (auto simp: Presb_simps \<sigma>_def set_n_lists distinct_n_lists
    Formula_Operations.lformula.simps Formula_Operations.satisfies_gen.simps Formula_Operations.wf.simps
    dest: satisfies0_cong split: presb.splits if_splits)

(*Workaround for code generation*)
lemma check_eqv_code[code]: "check_eqv idx r s =
  ((presb_wf idx r \<and> presb_lformula r) \<and> (presb_wf idx s \<and> presb_lformula s) \<and>
  (case rtrancl_while (\<lambda>(p, q). final idx p = final idx q)
    (\<lambda>(p, q). map (\<lambda>a. (norm (deriv lderiv0 a p), norm (deriv lderiv0 a q))) (\<sigma> idx))
    (norm (RESTRICT r), norm (RESTRICT s)) of
    None \<Rightarrow> False
  | Some ([], x) \<Rightarrow> True
  | Some (a # list, x) \<Rightarrow> False))"
  unfolding check_eqv_def Presb.check_eqv_def Presb.step_alt ..

definition while where [code del, code_abbrev]: "while idx \<phi> = while_default (fut_default idx \<phi>)"
declare while_default_code[of "fut_default idx \<phi>" for idx \<phi>, folded while_def, code]

lemma check_eqv_sound:
  "\<lbrakk>#\<^sub>V \<AA> = idx; check_eqv idx \<phi> \<psi>\<rbrakk> \<Longrightarrow> (Presb.sat \<AA> \<phi> \<longleftrightarrow> Presb.sat \<AA> \<psi>)"
  unfolding check_eqv_def by (rule Presb.check_eqv_soundness)

lemma bounded_check_eqv_sound:
  "\<lbrakk>#\<^sub>V \<AA> = idx; bounded_check_eqv idx \<phi> \<psi>\<rbrakk> \<Longrightarrow> (Presb.sat\<^sub>b \<AA> \<phi> \<longleftrightarrow> Presb.sat\<^sub>b \<AA> \<psi>)"
  unfolding bounded_check_eqv_def by (rule Presb.bounded_check_eqv_soundness)

method_setup check_equiv = \<open>
  let
    fun tac ctxt =
      let
        val conv = @{computation_check terms: Trueprop
          "0 :: nat" "1 :: nat" "2 :: nat" "3 :: nat" Suc
          "plus :: nat \<Rightarrow> _" "minus :: nat \<Rightarrow> _"
          "times :: nat \<Rightarrow> _" "divide :: nat \<Rightarrow> _" "modulo :: nat \<Rightarrow> _"
          "0 :: int" "1 :: int" "2 :: int" "3 :: int" "-1 :: int"
          check_eqv datatypes: formula "int list" integer bool} ctxt
      in
        CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1 conv)) ctxt) THEN'
        resolve_tac ctxt [TrueI]
      end
  in
    Scan.succeed (SIMPLE_METHOD' o tac)
  end
\<close>

end


section \<open>\isaheader{Implementation of Annotated Lists by 2-3 Finger Trees}\<close>
theory FTAnnotatedListImpl
imports
  "Finger-Trees.FingerTree"
  "../tools/Locale_Code"
  "../tools/Record_Intf"
  "../spec/AnnotatedListSpec"
begin

(*@impl AnnotatedList
  @type ('a,'b::monoid_add) ft
  @abbrv ft
  Annotated lists implemented by 2-3 finger trees.
*)

type_synonym ('a,'b) ft = "('a,'b) FingerTree"
subsection "Definitions"

definition ft_\<alpha> where
  "ft_\<alpha> \<equiv> FingerTree.toList"
abbreviation (input) ft_invar :: "('a,'b) FingerTree \<Rightarrow> bool" where
  "ft_invar \<equiv> \<lambda>_. True"
definition ft_empty where
  "ft_empty \<equiv> \<lambda>_::unit. FingerTree.empty"
definition ft_isEmpty where
  "ft_isEmpty \<equiv> FingerTree.isEmpty"
definition ft_count where
  "ft_count \<equiv> FingerTree.count"
definition ft_consl where
  "ft_consl e a s = FingerTree.lcons (e,a) s"
definition ft_consr where
  "ft_consr s e a = FingerTree.rcons s (e,a)"
definition ft_head where
  "ft_head \<equiv> FingerTree.head"
definition ft_tail where
  "ft_tail \<equiv> FingerTree.tail"
definition ft_headR where
  "ft_headR \<equiv> FingerTree.headR"
definition ft_tailR where
  "ft_tailR \<equiv> FingerTree.tailR"
definition ft_foldl where
  "ft_foldl \<equiv> FingerTree.foldl"
definition ft_foldr where
  "ft_foldr \<equiv> FingerTree.foldr"
definition ft_app where
  "ft_app \<equiv> FingerTree.app"
definition ft_annot where
  "ft_annot \<equiv> FingerTree.annot"
definition ft_splits where
  "ft_splits \<equiv> FingerTree.splitTree"

lemmas ft_defs =
  ft_\<alpha>_def
  ft_empty_def
  ft_isEmpty_def
  ft_count_def
  ft_consl_def
  ft_consr_def
  ft_head_def
  ft_tail_def
  ft_headR_def
  ft_tailR_def
  ft_foldl_def
  ft_foldr_def
  ft_app_def
  ft_annot_def
  ft_splits_def

lemma ft_empty_impl: "al_empty ft_\<alpha> ft_invar ft_empty"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.empty_correct)
  done

lemma ft_consl_impl: "al_consl ft_\<alpha> ft_invar ft_consl"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.lcons_correct)
done

lemma ft_consr_impl: "al_consr ft_\<alpha> ft_invar ft_consr"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.rcons_correct)
done

lemma ft_isEmpty_impl: "al_isEmpty ft_\<alpha> ft_invar ft_isEmpty"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.isEmpty_correct FingerTree.empty_correct)
  done

lemma ft_count_impl: "al_count ft_\<alpha> ft_invar ft_count"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.count_correct)
  done

lemma ft_head_impl: "al_head ft_\<alpha> ft_invar ft_head"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.head_correct FingerTree.empty_correct)
done

lemma ft_tail_impl: "al_tail ft_\<alpha> ft_invar ft_tail"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.tail_correct FingerTree.empty_correct)
done

lemma ft_headR_impl: "al_headR ft_\<alpha> ft_invar ft_headR"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.headR_correct FingerTree.empty_correct)
done

lemma ft_tailR_impl: "al_tailR ft_\<alpha> ft_invar ft_tailR"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.tailR_correct FingerTree.empty_correct)
    done

lemma ft_foldl_impl: "al_foldl ft_\<alpha> ft_invar ft_foldl"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.foldl_correct)
  done

lemma ft_foldr_impl: "al_foldr ft_\<alpha> ft_invar ft_foldr"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.foldr_correct)
  done

lemma ft_foldl_cunfold[code_unfold]:
  "List.foldl f \<sigma> (ft_\<alpha> t) = ft_foldl f \<sigma> t"
  apply (auto simp add: ft_defs FingerTree.foldl_correct)
  done

lemma ft_foldr_cunfold[code_unfold]:
  "List.foldr f (ft_\<alpha> t) \<sigma> = ft_foldr f t \<sigma>"
  apply (auto simp add: ft_defs FingerTree.foldr_correct)
  done

lemma ft_app_impl: "al_app ft_\<alpha> ft_invar ft_app"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.app_correct)
  done

lemma ft_annot_impl: "al_annot ft_\<alpha> ft_invar ft_annot"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.annot_correct)
  done

lemma ft_splits_impl: "al_splits ft_\<alpha> ft_invar ft_splits"
  apply unfold_locales
  apply (unfold ft_defs)
  apply (simp only: FingerTree.annot_correct[symmetric])
  apply (frule (3) FingerTree.splitTree_correct(1))
  apply (frule (3) FingerTree.splitTree_correct(2))
  apply (frule (3) FingerTree.splitTree_correct(3))
  apply (simp only: FingerTree.annot_correct[symmetric])
  apply simp
  done

subsubsection "Record Based Implementation"

definition [icf_rec_def]: "ft_ops = \<lparr>
  alist_op_\<alpha> = ft_\<alpha>,
  alist_op_invar = ft_invar,
  alist_op_empty = ft_empty,
  alist_op_isEmpty = ft_isEmpty,
  alist_op_count = ft_count,
  alist_op_consl = ft_consl,
  alist_op_consr = ft_consr,
  alist_op_head = ft_head,
  alist_op_tail = ft_tail,
  alist_op_headR = ft_headR,
  alist_op_tailR = ft_tailR,
  alist_op_app = ft_app,
  alist_op_annot = ft_annot,
  alist_op_splits = ft_splits
  \<rparr>"

setup Locale_Code.open_block
interpretation ft: StdAL ft_ops
  apply (rule StdAL.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule
    ft_empty_impl
    ft_consl_impl
    ft_consr_impl
    ft_isEmpty_impl
    ft_count_impl
    ft_head_impl
    ft_tail_impl
    ft_headR_impl
    ft_tailR_impl
    ft_foldl_impl
    ft_foldr_impl
    ft_app_impl
    ft_annot_impl
    ft_splits_impl
  )+
  done
interpretation ft: StdAL_no_invar ft_ops
  by (unfold_locales) (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup \<open>ICF_Tools.revert_abbrevs "ft"\<close>

definition "test_codegen \<equiv> (
  ft.empty,
  ft.isEmpty,
  ft.count,
  ft.consl,
  ft.consr,
  ft.head,
  ft.tail,
  ft.headR,
  ft.tailR,
  ft.app,
  ft.annot,
  ft.splits,
  ft.foldl,
  ft.foldr
)"

export_code test_codegen checking SML

end


(*  Title:      ZF/UNITY/MultisetSum.thy
    Author:     Sidi O Ehmety
*)

section \<open>Setsum for Multisets\<close>

theory MultisetSum
imports "ZF-Induct.Multiset"
begin

definition
  lcomm :: "[i, i, [i,i]=>i]=>o"  where
  "lcomm(A, B, f) ==
   (\<forall>x \<in> A. \<forall>y \<in> A. \<forall>z \<in> B. f(x, f(y, z))= f(y, f(x, z)))  &
   (\<forall>x \<in> A. \<forall>y \<in> B. f(x, y) \<in> B)"

definition
  general_setsum :: "[i,i,i, [i,i]=>i, i=>i] =>i"  where
   "general_setsum(C, B, e, f, g) ==
    if Finite(C) then fold[cons(e, B)](%x y. f(g(x), y), e, C) else e"

definition
  msetsum :: "[i=>i, i, i]=>i"  where
  "msetsum(g, C, B) == normalize(general_setsum(C, Mult(B), 0, (+#), g))"

definition  (* sum for naturals *)
  nsetsum :: "[i=>i, i] =>i"  where
  "nsetsum(g, C) == general_setsum(C, nat, 0, (#+), g)"

lemma mset_of_normalize: "mset_of(normalize(M)) \<subseteq> mset_of(M)"
by (auto simp add: mset_of_def normalize_def)

lemma general_setsum_0 [simp]: "general_setsum(0, B, e, f, g) = e"
by (simp add: general_setsum_def)

lemma general_setsum_cons [simp]:
"[| C \<in> Fin(A); a \<in> A; a\<notin>C; e \<in> B; \<forall>x \<in> A. g(x) \<in> B; lcomm(B, B, f) |] ==>
  general_setsum(cons(a, C), B, e, f, g) =
    f(g(a), general_setsum(C, B, e, f,g))"
apply (simp add: general_setsum_def)
apply  (auto simp add: Fin_into_Finite [THEN Finite_cons] cons_absorb)
prefer 2 apply (blast dest: Fin_into_Finite)
apply (rule fold_typing.fold_cons)
apply (auto simp add: fold_typing_def lcomm_def)
done

(** lcomm **)

lemma lcomm_mono: "[| C\<subseteq>A; lcomm(A, B, f) |] ==> lcomm(C, B,f)"
by (auto simp add: lcomm_def, blast)

lemma munion_lcomm [simp]: "lcomm(Mult(A), Mult(A), (+#))"
by (auto simp add: lcomm_def Mult_iff_multiset munion_lcommute)

(** msetsum **)

lemma multiset_general_setsum:
     "[| C \<in> Fin(A); \<forall>x \<in> A. multiset(g(x))& mset_of(g(x))\<subseteq>B  |]
      ==> multiset(general_setsum(C, B -||> nat - {0}, 0, \<lambda>u v. u +# v, g))"
apply (erule Fin_induct, auto)
apply (subst general_setsum_cons)
apply (auto simp add: Mult_iff_multiset)
done

lemma msetsum_0 [simp]: "msetsum(g, 0, B) = 0"
by (simp add: msetsum_def)

lemma msetsum_cons [simp]:
  "[| C \<in> Fin(A); a\<notin>C; a \<in> A; \<forall>x \<in> A. multiset(g(x)) & mset_of(g(x))\<subseteq>B  |]
   ==> msetsum(g, cons(a, C), B) = g(a) +#  msetsum(g, C, B)"
apply (simp add: msetsum_def)
apply (subst general_setsum_cons)
apply (auto simp add: multiset_general_setsum Mult_iff_multiset)
done

(* msetsum type *)

lemma msetsum_multiset: "multiset(msetsum(g, C, B))"
by (simp add: msetsum_def)

lemma mset_of_msetsum:
     "[| C \<in> Fin(A); \<forall>x \<in> A. multiset(g(x)) & mset_of(g(x))\<subseteq>B |]
      ==> mset_of(msetsum(g, C, B))\<subseteq>B"
by (erule Fin_induct, auto)

(*The reversed orientation looks more natural, but LOOPS as a simprule!*)
lemma msetsum_Un_Int:
     "[| C \<in> Fin(A); D \<in> Fin(A); \<forall>x \<in> A. multiset(g(x)) & mset_of(g(x))\<subseteq>B |]
      ==> msetsum(g, C \<union> D, B) +# msetsum(g, C \<inter> D, B)
        = msetsum(g, C, B) +# msetsum(g, D, B)"
apply (erule Fin_induct)
apply (subgoal_tac [2] "cons (x, y) \<union> D = cons (x, y \<union> D) ")
apply (auto simp add: msetsum_multiset)
apply (subgoal_tac "y \<union> D \<in> Fin (A) & y \<inter> D \<in> Fin (A) ")
apply clarify
apply (case_tac "x \<in> D")
apply (subgoal_tac [2] "cons (x, y) \<inter> D = y \<inter> D")
apply (subgoal_tac "cons (x, y) \<inter> D = cons (x, y \<inter> D) ")
apply (simp_all (no_asm_simp) add: cons_absorb munion_assoc msetsum_multiset)
apply (simp (no_asm_simp) add: munion_lcommute msetsum_multiset)
apply auto
done

lemma msetsum_Un_disjoint:
     "[| C \<in> Fin(A); D \<in> Fin(A); C \<inter> D = 0;
         \<forall>x \<in> A. multiset(g(x)) & mset_of(g(x))\<subseteq>B |]
      ==> msetsum(g, C \<union> D, B) = msetsum(g, C, B) +# msetsum(g,D, B)"
apply (subst msetsum_Un_Int [symmetric])
apply (auto simp add: msetsum_multiset)
done

lemma UN_Fin_lemma [rule_format (no_asm)]:
     "I \<in> Fin(A) ==> (\<forall>i \<in> I. C(i) \<in> Fin(B)) \<longrightarrow> (\<Union>i \<in> I. C(i)):Fin(B)"
by (erule Fin_induct, auto)

lemma msetsum_UN_disjoint [rule_format (no_asm)]:
     "[| I \<in> Fin(K); \<forall>i \<in> K. C(i) \<in> Fin(A) |] ==>
      (\<forall>x \<in> A. multiset(f(x)) & mset_of(f(x))\<subseteq>B) \<longrightarrow>
      (\<forall>i \<in> I. \<forall>j \<in> I. i\<noteq>j \<longrightarrow> C(i) \<inter> C(j) = 0) \<longrightarrow>
        msetsum(f, \<Union>i \<in> I. C(i), B) = msetsum (%i. msetsum(f, C(i),B), I, B)"
apply (erule Fin_induct, auto)
apply (subgoal_tac "\<forall>i \<in> y. x \<noteq> i")
 prefer 2 apply blast
apply (subgoal_tac "C(x) \<inter> (\<Union>i \<in> y. C (i)) = 0")
 prefer 2 apply blast
apply (subgoal_tac " (\<Union>i \<in> y. C (i)):Fin (A) & C(x) :Fin (A) ")
prefer 2 apply (blast intro: UN_Fin_lemma dest: FinD, clarify)
apply (simp (no_asm_simp) add: msetsum_Un_disjoint)
apply (subgoal_tac "\<forall>x \<in> K. multiset (msetsum (f, C(x), B)) & mset_of (msetsum (f, C(x), B)) \<subseteq> B")
apply (simp (no_asm_simp))
apply clarify
apply (drule_tac x = xa in bspec)
apply (simp_all (no_asm_simp) add: msetsum_multiset mset_of_msetsum)
done

lemma msetsum_addf:
    "[| C \<in> Fin(A);
      \<forall>x \<in> A. multiset(f(x)) & mset_of(f(x))\<subseteq>B;
      \<forall>x \<in> A. multiset(g(x)) & mset_of(g(x))\<subseteq>B |] ==>
      msetsum(%x. f(x) +# g(x), C, B) = msetsum(f, C, B) +# msetsum(g, C, B)"
apply (subgoal_tac "\<forall>x \<in> A. multiset (f(x) +# g(x)) & mset_of (f(x) +# g(x)) \<subseteq> B")
apply (erule Fin_induct)
apply (auto simp add: munion_ac)
done

lemma msetsum_cong:
    "[| C=D; !!x. x \<in> D ==> f(x) = g(x) |]
     ==> msetsum(f, C, B) = msetsum(g, D, B)"
by (simp add: msetsum_def general_setsum_def cong add: fold_cong)

lemma multiset_union_diff: "[| multiset(M); multiset(N) |] ==> M +# N -# N = M"
by (simp add: multiset_equality)

lemma msetsum_Un: "[| C \<in> Fin(A); D \<in> Fin(A);
  \<forall>x \<in> A. multiset(f(x)) & mset_of(f(x)) \<subseteq> B  |]
   ==> msetsum(f, C \<union> D, B) =
          msetsum(f, C, B) +# msetsum(f, D, B) -# msetsum(f, C \<inter> D, B)"
apply (subgoal_tac "C \<union> D \<in> Fin (A) & C \<inter> D \<in> Fin (A) ")
apply clarify
apply (subst msetsum_Un_Int [symmetric])
apply (simp_all (no_asm_simp) add: msetsum_multiset multiset_union_diff)
apply (blast dest: FinD)
done

lemma nsetsum_0 [simp]: "nsetsum(g, 0)=0"
by (simp add: nsetsum_def)

lemma nsetsum_cons [simp]:
     "[| Finite(C); x\<notin>C |] ==> nsetsum(g, cons(x, C))= g(x) #+ nsetsum(g, C)"
apply (simp add: nsetsum_def general_setsum_def)
apply (rule_tac A = "cons (x, C)" in fold_typing.fold_cons)
apply (auto intro: Finite_cons_lemma simp add: fold_typing_def)
done

lemma nsetsum_type [simp,TC]: "nsetsum(g, C) \<in> nat"
apply (case_tac "Finite (C) ")
 prefer 2 apply (simp add: nsetsum_def general_setsum_def)
apply (erule Finite_induct, auto)
done

end