section \<open>\isaheader{Implementing Priority Queues by Annotated Lists}\<close>
theory PrioByAnnotatedList
imports
  "../spec/AnnotatedListSpec"
  "../spec/PrioSpec"
begin

text \<open>
  In this theory, we implement priority queues by annotated lists.

  The implementation is realized as a generic adapter from the
  AnnotatedList to the priority queue interface.

  Priority queues are realized as a sequence of pairs of
  elements and associated priority. The monoids operation
  takes the element with minimum priority.

  The element with minimum priority is extracted from the
  sum over all elements.
  Deleting the element with minimum priority is done by
  splitting the sequence at the point where the minimum priority
  of the elements read so far becomes equal to the minimum priority of
  all elements.
\<close>

subsection "Definitions"
subsubsection "Monoid"
datatype ('e, 'a) Prio = Infty | Prio 'e 'a

fun p_unwrap :: "('e,'a) Prio \<Rightarrow> ('e \<times> 'a)" where
"p_unwrap (Prio e a) = (e , a)"

fun p_min :: "('e, 'a::linorder) Prio \<Rightarrow> ('e, 'a) Prio \<Rightarrow> ('e, 'a) Prio"  where
  "p_min Infty Infty = Infty"|
  "p_min Infty (Prio e a) = Prio e a"|
  "p_min (Prio e a) Infty = Prio e a"|
  "p_min (Prio e1 a) (Prio e2 b) = (if a \<le> b then Prio e1 a else Prio e2 b)"

lemma p_min_re_neut[simp]: "p_min a Infty = a" by (induct a) auto
lemma p_min_le_neut[simp]: "p_min Infty a = a" by (induct a) auto
lemma p_min_asso: "p_min (p_min a b) c = p_min a (p_min b c)"
  apply(induct a b  rule: p_min.induct )
  apply auto
  apply (induct c)
  apply auto
  apply (induct c)
  apply auto
  done
lemma lp_mono: "class.monoid_add p_min Infty"
  by unfold_locales (auto simp add: p_min_asso)

instantiation Prio :: (type,linorder) monoid_add
begin
definition zero_def: "0 == Infty"
definition plus_def: "a+b == p_min a b"

instance by
  intro_classes
(auto simp add: p_min_asso zero_def plus_def)
end

fun p_less_eq :: "('e, 'a::linorder) Prio \<Rightarrow> ('e, 'a) Prio \<Rightarrow> bool" where
  "p_less_eq (Prio e a) (Prio f b) = (a \<le> b)"|
  "p_less_eq  _ Infty = True"|
  "p_less_eq Infty (Prio e a) = False"

fun p_less :: "('e, 'a::linorder) Prio \<Rightarrow> ('e, 'a) Prio \<Rightarrow> bool" where
  "p_less (Prio e a) (Prio f b) = (a < b)"|
  "p_less (Prio e a) Infty = True"|
  "p_less Infty _ = False"

lemma p_less_le_not_le : "p_less x y \<longleftrightarrow> p_less_eq x y \<and> \<not> (p_less_eq y x)"
  by (induct x y rule: p_less.induct) auto

lemma p_order_refl : "p_less_eq x x"
  by (induct x) auto

lemma p_le_inf : "p_less_eq Infty x \<Longrightarrow> x = Infty"
  by (induct x) auto

lemma p_order_trans : "\<lbrakk>p_less_eq x y; p_less_eq y z\<rbrakk> \<Longrightarrow> p_less_eq x z"
  apply (induct y z rule: p_less.induct)
  apply auto
  apply (induct x)
  apply auto
  apply (cases x)
  apply auto
  apply(induct x)
  apply (auto simp add: p_le_inf)
  apply (metis p_le_inf p_less_eq.simps(2))
  done

lemma p_linear2 : "p_less_eq x y \<or> p_less_eq y x"
  apply (induct x y rule: p_less_eq.induct)
  apply auto
  done

instantiation Prio :: (type, linorder) preorder
begin
definition plesseq_def: "less_eq = p_less_eq"
definition pless_def: "less = p_less"

instance
  apply (intro_classes)
  apply (simp only: p_less_le_not_le pless_def plesseq_def)
  apply (simp only: p_order_refl plesseq_def pless_def)
  apply (simp only: plesseq_def)
  apply (metis p_order_trans)
  done

end

subsubsection "Operations"
definition alprio_\<alpha> :: "('s \<Rightarrow> (unit \<times> ('e,'a::linorder) Prio) list)
  \<Rightarrow> 's \<Rightarrow> ('e \<times> 'a::linorder) multiset"
  where
  "alprio_\<alpha> \<alpha> al == (mset (map p_unwrap (map snd (\<alpha> al))))"

definition alprio_invar :: "('s \<Rightarrow> (unit \<times> ('c, 'd::linorder) Prio) list)
  \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
  where
  "alprio_invar \<alpha> invar al == invar al \<and> (\<forall> x\<in>set (\<alpha> al). snd x\<noteq>Infty)"

definition alprio_empty  where
  "alprio_empty empt = empt"

definition alprio_isEmpty  where
  "alprio_isEmpty isEmpty = isEmpty"

definition alprio_insert :: "(unit \<Rightarrow> ('e,'a) Prio \<Rightarrow> 's \<Rightarrow> 's)
  \<Rightarrow> 'e \<Rightarrow> 'a::linorder \<Rightarrow> 's  \<Rightarrow> 's"
  where
  "alprio_insert consl e a s = consl () (Prio e a) s"

definition alprio_find :: "('s \<Rightarrow> ('e,'a::linorder) Prio) \<Rightarrow> 's \<Rightarrow> ('e \<times> 'a)"
where
"alprio_find annot s = p_unwrap (annot s)"

definition alprio_delete :: "((('e,'a::linorder) Prio \<Rightarrow> bool)
  \<Rightarrow> ('e,'a) Prio \<Rightarrow> 's \<Rightarrow> ('s \<times> (unit \<times> ('e,'a) Prio) \<times> 's))
                      \<Rightarrow> ('s \<Rightarrow> ('e,'a) Prio) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> 's \<Rightarrow> 's"
  where
  "alprio_delete splits annot app s = (let (l, _ , r)
    = splits (\<lambda> x. x\<le>(annot s)) Infty s in app l r) "

definition alprio_meld where
  "alprio_meld app = app"

lemmas alprio_defs =
  alprio_invar_def
  alprio_\<alpha>_def
  alprio_empty_def
  alprio_isEmpty_def
  alprio_insert_def
  alprio_find_def
  alprio_delete_def
  alprio_meld_def

subsection "Correctness"

subsubsection "Auxiliary Lemmas"
lemma sum_list_split: "sum_list (l @ (a::'a::monoid_add) # r) = (sum_list l) + a + (sum_list r)"
  by (induct l) (auto simp add: add.assoc)

lemma p_linear: "(x::('e, 'a::linorder) Prio) \<le> y \<or> y \<le> x"
  by (unfold plesseq_def) (simp only: p_linear2)

lemma p_min_mon: "(x::(('e,'a::linorder) Prio)) \<le> y \<Longrightarrow> (z + x) \<le> y"
apply (unfold plus_def plesseq_def)
apply (induct x y rule: p_less_eq.induct)
apply (auto)
apply (induct z)
apply (auto)
done

lemma p_min_mon2: "p_less_eq x y \<Longrightarrow> p_less_eq (p_min z x) y"
apply (induct x y rule: p_less_eq.induct)
apply (auto)
apply (induct z)
apply (auto)
done

lemma ls_min: " \<forall>x \<in> set (xs:: ('e,'a::linorder) Prio list) . sum_list xs \<le> x"
proof (induct xs)
case Nil thus ?case by auto
next
case (Cons a ins) thus ?case
  apply (auto simp add: plus_def plesseq_def)
  apply (cases a)
  apply auto
  apply (cases "sum_list ins")
  apply auto
  apply (case_tac x)
  apply auto
  apply (cases a)
  apply auto
  apply (cases "sum_list ins")
  apply auto
  done
qed

lemma infadd: "x \<noteq> Infty \<Longrightarrow>x + y \<noteq> Infty"
apply (unfold plus_def)
apply (induct x y rule: p_min.induct)
apply auto
done

lemma prio_selects_one: "a+b = a \<or> a+b=(b::('e,'a::linorder) Prio)"
  apply (simp add: plus_def)
  apply (cases "(a,b)" rule: p_min.cases)
  apply simp_all
  done

lemma sum_list_in_set: "(l::('x \<times> ('e,'a::linorder) Prio) list)\<noteq>[] \<Longrightarrow>
  sum_list (map snd l) \<in> set (map snd l)"
  apply (induct l)
  apply simp
  apply (case_tac l)
  apply simp
  using prio_selects_one
  apply auto
  apply force
  apply force
  done

lemma p_unwrap_less_sum: "snd (p_unwrap ((Prio e aa) + b)) \<le> aa"
  apply (cases b)
  apply (auto simp add: plus_def)
done

lemma prio_add_alb: "\<not> b \<le> (a::('e,'a::linorder)Prio)  \<Longrightarrow> b + a = a"
  by (auto simp add: plus_def, cases "(a,b)" rule: p_min.cases) (auto simp add: plesseq_def)

lemma prio_add_alb2: " (a::('e,'a::linorder)Prio)  \<le> a + b \<Longrightarrow>  a + b = a"
  by (auto simp add: plus_def, cases "(a,b)" rule: p_min.cases) (auto simp add: plesseq_def)

lemma prio_add_abc:
  assumes "(l::('e,'a::linorder)Prio) + a \<le> c"
  and "\<not> l \<le> c"
  shows  "\<not> l \<le> a"
proof (rule ccontr)
  assume "\<not> \<not> l \<le> a"
  with assms have "l + a = l"
    apply (auto simp add: plus_def plesseq_def)
    apply (cases "(l,a)" rule: p_less_eq.cases)
    apply auto
    done
  with assms show False by simp
qed

lemma prio_add_abc2:
  assumes "(a::('e,'a::linorder)Prio) \<le> a + b"
  shows "a \<le> b"
proof (rule ccontr)
  assume ann: "\<not> a \<le> b"
  hence "a + b = b"
    apply (auto simp add: plus_def plesseq_def)
    apply (cases "(a,b)" rule: p_min.cases)
    apply auto
    done
  thus False using assms ann by simp
qed

subsubsection "Empty"
lemma alprio_empty_correct:
  assumes "al_empty \<alpha> invar empt"
  shows "prio_empty (alprio_\<alpha> \<alpha>) (alprio_invar \<alpha> invar) (alprio_empty empt)"
proof -
  interpret al_empty \<alpha> invar empt by fact
  show ?thesis
    apply (unfold_locales)
    apply (unfold alprio_invar_def)
    apply auto
    apply (unfold alprio_empty_def)
    apply (auto simp add: empty_correct)
    apply (unfold alprio_\<alpha>_def)
    apply auto
    apply (simp only: empty_correct)
    done
qed

subsubsection "Is Empty"

lemma alprio_isEmpty_correct:
  assumes "al_isEmpty \<alpha> invar isEmpty"
  shows "prio_isEmpty (alprio_\<alpha> \<alpha>) (alprio_invar \<alpha> invar) (alprio_isEmpty isEmpty)"
proof -
  interpret al_isEmpty \<alpha> invar isEmpty by fact
  show ?thesis by (unfold_locales) (auto simp add: alprio_defs isEmpty_correct)
qed

subsubsection "Insert"
lemma alprio_insert_correct:
  assumes "al_consl \<alpha> invar consl"
  shows "prio_insert (alprio_\<alpha> \<alpha>) (alprio_invar \<alpha> invar) (alprio_insert consl)"
proof -
  interpret al_consl \<alpha> invar consl by fact
  show ?thesis by unfold_locales (auto simp add: alprio_defs consl_correct)
qed

subsubsection "Meld"

lemma alprio_meld_correct:
  assumes "al_app \<alpha> invar app"
  shows "prio_meld (alprio_\<alpha> \<alpha>) (alprio_invar \<alpha> invar) (alprio_meld app)"
proof -
  interpret al_app \<alpha> invar app by fact
  show ?thesis by unfold_locales (auto simp add: alprio_defs app_correct)
qed

subsubsection "Find"

lemma annot_not_inf :
  assumes "(alprio_invar \<alpha> invar) s"
  and "(alprio_\<alpha> \<alpha>) s \<noteq> {#}"
  and "al_annot \<alpha> invar annot"
  shows "annot s \<noteq> Infty"
proof -
  interpret al_annot \<alpha> invar annot by fact
  show ?thesis
  proof -
    from assms(1) have invs: "invar s" by (simp add: alprio_defs)
    from assms(2) have sne: "set (\<alpha> s) \<noteq> {}"
    proof (cases "set (\<alpha> s) = {}")
      case True
      hence "\<alpha> s = []" by simp
      hence "(alprio_\<alpha> \<alpha>) s = {#}" by (simp add: alprio_defs)
      from this assms(2) show ?thesis by simp
    next
      case False thus ?thesis by simp
    qed
    hence "(\<alpha> s) \<noteq> []" by simp
    hence " \<exists>x xs. (\<alpha> s) = x # xs" by (cases "\<alpha> s") auto
    from this obtain x xs where [simp]: "(\<alpha> s) = x # xs" by blast
    from this assms(1) have "snd x \<noteq> Infty" by (auto simp add: alprio_defs)
    hence "sum_list (map snd (\<alpha> s)) \<noteq> Infty" by (auto simp add: infadd)
    thus "annot s \<noteq> Infty" using annot_correct invs by simp
  qed
qed

lemma annot_in_set:
  assumes "(alprio_invar \<alpha> invar) s"
  and "(alprio_\<alpha> \<alpha>) s \<noteq> {#}"
  and "al_annot \<alpha> invar annot"
  shows "p_unwrap (annot s) \<in># ((alprio_\<alpha> \<alpha>) s)"
proof -
  interpret al_annot \<alpha> invar annot by fact
  from assms(2) have snn: "\<alpha> s \<noteq> []" by (auto simp add: alprio_defs)
  from assms(1) have invs: "invar s" by (simp add: alprio_defs)
  hence ans: "annot s = sum_list (map snd (\<alpha> s))" by (simp add: annot_correct)
  let ?P = "map snd (\<alpha> s)"
  have "annot s \<in> set ?P"
    by (unfold ans) (rule sum_list_in_set[OF snn])
  then show ?thesis
    by (auto intro!: image_eqI simp add: alprio_\<alpha>_def)
qed

lemma  sum_list_less_elems: "\<forall>x\<in>set xs. snd x \<noteq> Infty \<Longrightarrow>
   \<forall>y\<in>set_mset (mset (map p_unwrap (map snd xs))).
              snd (p_unwrap (sum_list (map snd xs))) \<le> snd y"
    proof (induct xs)
    case Nil thus ?case by simp
    next
    case (Cons a as) thus ?case
      apply auto
      apply (cases "(snd a)" rule: p_unwrap.cases)
      apply auto
      apply (cases "sum_list (map snd as)")
      apply auto
      apply (metis linorder_linear p_min_re_neut
        p_unwrap.simps plus_def [abs_def] snd_eqD)
      apply (auto simp add: p_unwrap_less_sum)
      apply (unfold plus_def)
      apply (cases "(snd a, sum_list (map snd as))" rule: p_min.cases)
      apply auto
      apply (cases "map snd as")
      apply (auto simp add: infadd)
      done
qed

lemma alprio_find_correct:
  assumes  "al_annot \<alpha> invar annot"
  shows "prio_find (alprio_\<alpha> \<alpha>) (alprio_invar \<alpha> invar) (alprio_find annot)"
proof -
  interpret al_annot \<alpha> invar annot by fact
  show ?thesis
    apply unfold_locales
    apply (rule conjI)
    apply (insert assms)
    apply (unfold alprio_find_def)
    apply (simp add:annot_in_set)
    apply (unfold alprio_defs)
    apply (simp add: annot_correct)
    apply (auto simp add: sum_list_less_elems)
    done
qed

subsubsection "Delete"

lemma delpred_mon:
  "\<forall>(a:: ('e, 'a::linorder) Prio) b. ((\<lambda> x. x \<le> y) a
    \<longrightarrow> (\<lambda> x. x \<le> y) (a + b)) "
proof (intro impI allI)
  fix a b
  show "a \<le> y \<Longrightarrow> a + b \<le> y"
    apply (induct a b rule: p_less.induct)
    apply (auto simp add: plus_def)
    apply (metis linorder_linear order_trans
      p_linear p_min.simps(4) p_min_mon plus_def prio_selects_one)
    apply (metis order_trans p_linear p_min_mon p_min_re_neut plus_def)
    done
qed

(* alprio_delete erhält die Invariante *)
lemma alpriodel_invar:
  assumes "alprio_invar \<alpha> invar s"
  and "al_annot \<alpha> invar annot"
  and "alprio_\<alpha> \<alpha> s \<noteq> {#}"
  and "al_splits \<alpha> invar splits"
  and "al_app \<alpha> invar app"
  shows "alprio_invar \<alpha> invar (alprio_delete splits annot app s)"
proof -
  interpret al_splits \<alpha> invar splits by fact
  let ?P = "\<lambda>x. x \<le> annot s"
  obtain l p r where
    [simp]:"splits ?P Infty s = (l, p, r)"
    by (cases "splits ?P Infty s")  auto
  obtain e a where
    "p = (e, a)"
    by (cases p, blast)
  hence
    lear:"splits ?P Infty s = (l, (e,a), r)"
    by simp
  from annot_not_inf[OF assms(1) assms(3) assms(2)] have
    "annot s \<noteq> Infty" .
  hence
    sv1: "\<not> Infty \<le> annot s"
    by (simp add: plesseq_def, cases "annot s", auto)
  from assms(1) have
    invs: "invar s"
    unfolding alprio_invar_def by simp
  interpret al_annot \<alpha> invar annot by fact
  from invs have
    sv2: "Infty + sum_list (map snd (\<alpha> s)) \<le> annot s"
    by (auto simp add: annot_correct plus_def
      plesseq_def p_min_le_neut p_order_refl)
  note sp = splits_correct[of s "?P" Infty l e a r]
  note dp = delpred_mon[of "annot s"]
  from sp[OF invs dp sv1 sv2 lear] have
    invlr: "invar l \<and> invar r" and
    alr: "\<alpha> s = \<alpha> l @ (e, a) # \<alpha> r"
    by auto
  interpret al_app \<alpha> invar app by fact
  from invlr app_correct have
    invapplr: "invar (app l r)"
    by simp
  from invlr app_correct have
    sr: "\<alpha> (app l r) = (\<alpha> l) @ (\<alpha> r)"
    by simp
  from alr have
    "set (\<alpha> s) \<supseteq> (set (\<alpha> l) Un set (\<alpha> r))"
    by auto
  with app_correct[of l r] invlr have
    "set (\<alpha> s) \<supseteq> set (\<alpha> (app l r))" by auto
  with invapplr assms(1)
  show ?thesis
    unfolding alprio_defs by auto
qed

lemma sum_list_elem:
  assumes " ins = l @ (a::('e,'a::linorder)Prio) # r"
  and "\<not> sum_list l \<le> sum_list ins"
  and "sum_list l + a \<le> sum_list ins "
  shows " a = sum_list ins"
proof -
  have "\<not> sum_list l \<le> a" using assms prio_add_abc by simp
  hence lpa: "sum_list l + a = a" using prio_add_alb by auto
  hence als: "a \<le> sum_list ins" using assms(3) by simp
  have "sum_list ins = a + sum_list r"
    using lpa sum_list_split[of l a r] assms(1) by auto
  thus ?thesis using prio_add_alb2[of a "sum_list r"] prio_add_abc2 als
    by auto
qed

lemma alpriodel_right:
  assumes "alprio_invar \<alpha> invar s"
  and "al_annot \<alpha> invar annot"
  and "alprio_\<alpha> \<alpha> s \<noteq> {#}"
  and "al_splits \<alpha> invar splits"
  and "al_app \<alpha> invar app"
  shows "alprio_\<alpha> \<alpha> (alprio_delete splits annot app s) =
          alprio_\<alpha> \<alpha> s - {#p_unwrap (annot s)#}"
proof -
  interpret al_splits \<alpha> invar splits by fact
  let ?P = "\<lambda>x. x \<le> annot s"
  obtain l p r where
    [simp]:"splits ?P Infty s = (l, p, r)"
    by (cases "splits ?P Infty s")  auto
  obtain e a where
    "p = (e, a)"
    by (cases p, blast)
  hence
    lear:"splits ?P Infty s = (l, (e,a), r)"
    by simp
  from annot_not_inf[OF assms(1) assms(3) assms(2)] have
    "annot s \<noteq> Infty" .
  hence
    sv1: "\<not> Infty \<le> annot s"
    by (simp add: plesseq_def, cases "annot s", auto)
  from assms(1) have
    invs: "invar s"
    unfolding alprio_invar_def by simp
  interpret al_annot \<alpha> invar annot by fact
  from invs have
    sv2: "Infty + sum_list (map snd (\<alpha> s)) \<le> annot s"
    by (auto simp add: annot_correct plus_def
      plesseq_def p_min_le_neut p_order_refl)
  note sp = splits_correct[of s "?P" Infty l e a r]
  note dp = delpred_mon[of "annot s"]

  from sp[OF invs dp sv1 sv2 lear] have
    invlr: "invar l \<and> invar r" and
    alr: "\<alpha> s = \<alpha> l @ (e, a) # \<alpha> r" and
    anlel: "\<not> sum_list (map snd (\<alpha> l)) \<le> annot s" and
    aneqa: "(sum_list (map snd (\<alpha> l)) + a) \<le> annot s"
    by (auto simp add: plus_def zero_def)
  have mapalr: "map snd (\<alpha> s) = (map snd (\<alpha> l)) @ a # (map snd (\<alpha> r))"
    using alr by simp
  note lsa = sum_list_elem[of "map snd (\<alpha> s)" "map snd (\<alpha> l)" a "map snd (\<alpha> r)"]
  note lsa2 = lsa[OF mapalr]
  hence a_is_annot: "a = annot s"
    using annot_correct[OF invs] anlel aneqa by auto
  have "map p_unwrap (map snd (\<alpha> s)) =
    (map p_unwrap (map snd (\<alpha> l))) @ (p_unwrap a)
      # (map p_unwrap (map snd (\<alpha> r)))"
    using alr by simp
  hence alpriolst: "(alprio_\<alpha> \<alpha> s) = (alprio_\<alpha> \<alpha> l) +{# p_unwrap a #}+ (alprio_\<alpha> \<alpha> r)"
    unfolding alprio_defs
    by (simp add: algebra_simps)
  interpret al_app \<alpha> invar app by fact
  from alpriolst show ?thesis using app_correct[of l r] invlr a_is_annot
    by (auto simp add: alprio_defs algebra_simps)
qed

lemma alprio_delete_correct:
  assumes "al_annot \<alpha> invar annot"
  and "al_splits \<alpha> invar splits"
  and "al_app \<alpha> invar app"
  shows "prio_delete (alprio_\<alpha> \<alpha>) (alprio_invar \<alpha> invar)
           (alprio_find annot) (alprio_delete splits annot app)"
proof-
  interpret al_annot \<alpha> invar annot by fact
  interpret al_splits \<alpha> invar splits by fact
  interpret al_app \<alpha> invar app by fact
  show ?thesis
    apply intro_locales
    apply (rule alprio_find_correct,simp add: assms)
    apply unfold_locales
    apply (insert assms)
    apply (simp add: alpriodel_invar)
    apply (simp add: alpriodel_right alprio_find_def)
    done
qed

lemmas alprio_correct =
  alprio_empty_correct
  alprio_isEmpty_correct
  alprio_insert_correct
  alprio_delete_correct
  alprio_find_correct
  alprio_meld_correct

locale alprio_defs = StdALDefs ops
  for ops :: "(unit,('e,'a::linorder) Prio,'s) alist_ops"
begin
  definition [icf_rec_def]: "alprio_ops \<equiv> \<lparr>
    prio_op_\<alpha> = alprio_\<alpha> \<alpha>,
    prio_op_invar = alprio_invar \<alpha> invar,
    prio_op_empty = alprio_empty empty,
    prio_op_isEmpty = alprio_isEmpty isEmpty,
    prio_op_insert = alprio_insert consl,
    prio_op_find = alprio_find annot,
    prio_op_delete = alprio_delete splits annot app,
    prio_op_meld = alprio_meld app
    \<rparr>"

end

locale alprio = alprio_defs ops + StdAL ops
  for ops :: "(unit,('e,'a::linorder) Prio,'s) alist_ops"
begin
  lemma alprio_ops_impl: "StdPrio alprio_ops"
    apply (rule StdPrio.intro)
    apply (simp_all add: icf_rec_unf)
    apply (rule alprio_correct, unfold_locales) []
    apply (rule alprio_correct, unfold_locales) []
    apply (rule alprio_correct, unfold_locales) []
    apply (rule alprio_correct, unfold_locales) []
    apply (rule alprio_correct, unfold_locales) []
    apply (rule alprio_correct, unfold_locales) []
    done
end

end


theory Szip_sconst2
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")
datatype ('a, 'b) Pair2 = Pair2 'a 'b
primcorec szip :: "'a Stream \<Rightarrow> 'b Stream \<Rightarrow> (('a, 'b) Pair2) Stream" where
  "shd (szip s1 s2) = Pair2 (shd s1) (shd s2)"
| "stl (szip s1 s2) = szip (stl s1) (stl s2)"

primcorec smap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "smap f xs = SCons (f (shd xs)) (smap f (stl xs))"

primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Stream" where
  "shd (siterate f x) = x"
| "stl (siterate f x) = siterate f (f x)"

(*abbreviation "sconst \<equiv> siterate id"*)
primcorec sconst :: "'a \<Rightarrow> 'a Stream" where
  "sconst x = SCons x (sconst x)"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsStream :: "int \<Rightarrow> 'a Stream \<Rightarrow> 'a Lst" where
"obsStream n s = (if (n \<le> 0) then Emp else Cons (shd s) (obsStream (n - 1) (stl s)))"

(*hipster_obs Stream Lst obsStream szip smap*)
  (*exception XML_BODY [] raised (line 397 of "PIDE/xml.ML") when exploring szip, smap*)
(*tip-spec output in outputSzipSmap file*)
theorem szip_sconst2:
"szip xs (sconst b) = smap (\<lambda>x. (Pair2 x b)) xs"
  apply(coinduction arbitrary: xs)
  apply(auto)
    done
(* Why can't we automate this proof?*)
(*   by hipster_coinduct_sledgehammer results in following error:
Failed to apply initial proof method\<here>:
goal (1 subgoal):
 1. szip xs (sconst b) = smap (\<lambda>x. Pair2 x b) xs
constants:
  Pure.prop :: prop \<Rightarrow> prop
  Pair2 :: 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) Pair2
  smap :: ('a \<Rightarrow> ('a, 'b) Pair2) \<Rightarrow> 'a Stream \<Rightarrow> ('a, 'b) Pair2 Stream
  id :: 'b \<Rightarrow> 'b
  siterate :: ('b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'b Stream
  szip :: 'a Stream \<Rightarrow> 'b Stream \<Rightarrow> ('a, 'b) Pair2 Stream
  op = :: ('a, 'b) Pair2 Stream \<Rightarrow> ('a, 'b) Pair2 Stream \<Rightarrow> bool
  Trueprop :: bool \<Rightarrow> prop
  op \<Longrightarrow> :: prop \<Rightarrow> prop \<Rightarrow> prop*)
end


(*
 * Social Choice Functions (SCFs).
 * (C)opyright Peter Gammie, peteg42 at gmail.com, commenced July 2006.
 * License: BSD
 *)

(*<*)
theory SCFs

imports RPRs

begin
(*>*)

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

subsection{* Choice Sets, Choice Functions *}

text{* A \emph{choice set} is the subset of @{term "A"} where every element
of that subset is (weakly) preferred to every other element of @{term "A"}
with respect to a given RPR. A \emph{choice function} yields a non-empty
choice set whenever @{term "A"} is non-empty. *}

definition choiceSet :: "'a set \<Rightarrow> 'a RPR \<Rightarrow> 'a set" where
  "choiceSet A r \<equiv> { x \<in> A . \<forall>y \<in> A. x \<^bsub>r\<^esub>\<preceq> y }"

definition choiceFn :: "'a set \<Rightarrow> 'a RPR \<Rightarrow> bool" where
  "choiceFn A r \<equiv> \<forall>A' \<subseteq> A. A' \<noteq> {} \<longrightarrow> choiceSet A' r \<noteq> {}"

lemma choiceSetI[intro]:
  "\<lbrakk> x \<in> A; \<And>y. y \<in> A \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y \<rbrakk> \<Longrightarrow> x \<in> choiceSet A r"
  unfolding choiceSet_def by simp

lemma choiceFnI[intro]:
  "(\<And>A'. \<lbrakk> A' \<subseteq> A; A' \<noteq> {} \<rbrakk> \<Longrightarrow> choiceSet A' r \<noteq> {}) \<Longrightarrow> choiceFn A r"
  unfolding choiceFn_def by simp

text{* If a complete and reflexive relation is also \emph{quasi-transitive}
it will yield a choice function. *}

definition quasi_trans :: "'a RPR \<Rightarrow> bool" where
  "quasi_trans r \<equiv> \<forall>x y z. x \<^bsub>r\<^esub>\<prec> y \<and> y \<^bsub>r\<^esub>\<prec> z \<longrightarrow> x \<^bsub>r\<^esub>\<prec> z"

lemma quasi_transI[intro]:
  "(\<And>x y z. \<lbrakk> x \<^bsub>r\<^esub>\<prec> y; y \<^bsub>r\<^esub>\<prec> z \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> z) \<Longrightarrow> quasi_trans r"
  unfolding quasi_trans_def by blast

lemma quasi_transD: "\<lbrakk> x \<^bsub>r\<^esub>\<prec> y; y \<^bsub>r\<^esub>\<prec> z; quasi_trans r \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> z"
  unfolding quasi_trans_def by blast

lemma trans_imp_quasi_trans: "trans r \<Longrightarrow> quasi_trans r"
  by (rule quasi_transI, unfold strict_pref_def trans_def, blast)

lemma r_c_qt_imp_cf:
  assumes finiteA: "finite A"
      and c: "complete A r"
      and qt: "quasi_trans r"
      and r: "refl_on A r"
  shows "choiceFn A r"
proof
  fix B assume B: "B \<subseteq> A" "B \<noteq> {}"
  with finite_subset finiteA have finiteB: "finite B" by auto
  from finiteB B show "choiceSet B r \<noteq> {}"
  proof(induct rule: finite_subset_induct')
    case empty with B show ?case by auto
  next
    case (insert a B)
    hence finiteB: "finite B"
        and aA: "a \<in> A"
        and AB: "B \<subseteq> A"
        and aB: "a \<notin> B"
        and cF: "B \<noteq> {} \<Longrightarrow> choiceSet B r \<noteq> {}" by - blast
    show ?case
    proof(cases "B = {}")
      case True with aA r show ?thesis
        unfolding choiceSet_def by blast
    next
      case False
      with cF obtain b where bCF: "b \<in> choiceSet B r" by blast
      from AB aA bCF complete_refl_on[OF c r]
      have "a \<^bsub>r\<^esub>\<prec> b \<or> b \<^bsub>r\<^esub>\<preceq> a" unfolding choiceSet_def strict_pref_def by blast
      thus ?thesis
      proof
        assume ab: "b \<^bsub>r\<^esub>\<preceq> a"
        with bCF show ?thesis unfolding choiceSet_def by auto
      next
        assume ab: "a \<^bsub>r\<^esub>\<prec> b"
        have "a \<in> choiceSet (insert a B) r"
        proof(rule ccontr)
          assume aCF: "a \<notin> choiceSet (insert a B) r"
          from aB have "\<And>b. b \<in> B \<Longrightarrow> a \<noteq> b" by auto
          with aCF aA AB c r obtain b' where B: "b' \<in> B" "b' \<^bsub>r\<^esub>\<prec> a"
            unfolding choiceSet_def complete_def strict_pref_def by blast
          with ab qt have "b' \<^bsub>r\<^esub>\<prec> b" by (blast dest: quasi_transD)
          with bCF B show False unfolding choiceSet_def strict_pref_def by blast
        qed
        thus ?thesis by auto
      qed
    qed
  qed
qed

lemma rpr_choiceFn: "\<lbrakk> finite A; rpr A r \<rbrakk> \<Longrightarrow> choiceFn A r"
  unfolding rpr_def by (blast dest: trans_imp_quasi_trans r_c_qt_imp_cf)

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

subsection{* Social Choice Functions (SCFs) *}

text {* A \emph{social choice function} (SCF), also called a
\emph{collective choice rule} by Sen \cite[p28]{Sen:70a}, is a function that
somehow aggregates society's opinions, expressed as a profile, into a
preference relation. *}

type_synonym ('a, 'i) SCF = "('a, 'i) Profile \<Rightarrow> 'a RPR"

text {* The least we require of an SCF is that it be \emph{complete} and
some function of the profile. The latter condition is usually implied by
other conditions, such as @{term "iia"}. *}

definition
  SCF :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> ('a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) Profile \<Rightarrow> bool) \<Rightarrow> bool"
where
  "SCF scf A Is Pcond \<equiv> (\<forall>P. Pcond A Is P \<longrightarrow> (complete A (scf P)))"

lemma SCFI[intro]:
  assumes c: "\<And>P. Pcond A Is P \<Longrightarrow> complete A (scf P)"
  shows "SCF scf A Is Pcond"
  unfolding SCF_def using assms by blast

lemma SCF_completeD[dest]: "\<lbrakk> SCF scf A Is Pcond; Pcond A Is P \<rbrakk> \<Longrightarrow> complete A (scf P)"
  unfolding SCF_def by blast

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

subsection{* Social Welfare Functions (SWFs) *}

text {* A \emph{Social Welfare Function} (SWF) is an SCF that expresses the
society's opinion as a single RPR.

In some situations it might make sense to restrict the allowable
profiles. *}

definition
  SWF :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> ('a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) Profile \<Rightarrow> bool) \<Rightarrow> bool"
where
  "SWF swf A Is Pcond \<equiv> (\<forall>P. Pcond A Is P \<longrightarrow> rpr A (swf P))"

lemma SWF_rpr[dest]: "\<lbrakk> SWF swf A Is Pcond; Pcond A Is P \<rbrakk> \<Longrightarrow> rpr A (swf P)"
  unfolding SWF_def by simp

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

subsection{* General Properties of an SCF *}

text{* An SCF has a \emph{universal domain} if it works for all profiles. *}

definition universal_domain :: "'a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) Profile \<Rightarrow> bool" where
  "universal_domain A Is P \<equiv> profile A Is P"

declare universal_domain_def[simp]

text{* An SCF is \emph{weakly Pareto-optimal} if, whenever everyone strictly
prefers @{term "x"} to @{term "y"}, the SCF does too. *}

definition
  weak_pareto :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> ('a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) Profile \<Rightarrow> bool) \<Rightarrow> bool"
where
  "weak_pareto scf A Is Pcond \<equiv>
     (\<forall>P x y. Pcond A Is P \<and> x \<in> A \<and> y \<in> A \<and> (\<forall>i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y) \<longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y)"

lemma weak_paretoI[intro]:
  "(\<And>P x y. \<lbrakk>Pcond A Is P; x \<in> A; y \<in> A; \<And>i. i\<in>Is \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> y\<rbrakk> \<Longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y)
  \<Longrightarrow> weak_pareto scf A Is Pcond"
  unfolding weak_pareto_def by simp

lemma weak_paretoD:
  "\<lbrakk> weak_pareto scf A Is Pcond; Pcond A Is P; x \<in> A; y \<in> A;
     (\<And>i. i \<in> Is \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> y) \<rbrakk> \<Longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y"
  unfolding weak_pareto_def by simp

text{*

An SCF satisfies \emph{independence of irrelevant alternatives} if, for two
preference profiles @{term "P"} and @{term "P'"} where for all individuals
@{term "i"}, alternatives @{term "x"} and @{term "y"} drawn from set @{term
"S"} have the same order in @{term "P i"} and @{term "P' i"}, then
alternatives @{term "x"} and @{term "y"} have the same order in @{term "scf
P"} and @{term "scf P'"}.

*}

definition iia :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> bool" where
  "iia scf S Is \<equiv>
    (\<forall>P P' x y. profile S Is P \<and> profile S Is P'
      \<and> x \<in> S \<and> y \<in> S
      \<and> (\<forall>i \<in> Is. ((x \<^bsub>(P i)\<^esub>\<preceq> y) \<longleftrightarrow> (x \<^bsub>(P' i)\<^esub>\<preceq> y)) \<and> ((y \<^bsub>(P i)\<^esub>\<preceq> x) \<longleftrightarrow> (y \<^bsub>(P' i)\<^esub>\<preceq> x)))
         \<longrightarrow> ((x \<^bsub>(scf P)\<^esub>\<preceq> y) \<longleftrightarrow> (x \<^bsub>(scf P')\<^esub>\<preceq> y)))"

lemma iiaI[intro]:
  "(\<And>P P' x y.
    \<lbrakk> profile S Is P; profile S Is P';
      x \<in> S; y \<in> S;
      \<And>i. i \<in> Is \<Longrightarrow> ((x \<^bsub>(P i)\<^esub>\<preceq> y) \<longleftrightarrow> (x \<^bsub>(P' i)\<^esub>\<preceq> y)) \<and> ((y \<^bsub>(P i)\<^esub>\<preceq> x) \<longleftrightarrow> (y \<^bsub>(P' i)\<^esub>\<preceq> x))
    \<rbrakk> \<Longrightarrow> ((x \<^bsub>(swf P)\<^esub>\<preceq> y) \<longleftrightarrow> (x \<^bsub>(swf P')\<^esub>\<preceq> y)))
  \<Longrightarrow> iia swf S Is"
  unfolding iia_def by simp

lemma iiaE:
  "\<lbrakk> iia swf S Is;
     {x,y} \<subseteq> S;
     a \<in> {x, y}; b \<in> {x, y};
     \<And>i a b. \<lbrakk> a \<in> {x, y}; b \<in> {x, y}; i \<in> Is \<rbrakk> \<Longrightarrow> (a \<^bsub>(P' i)\<^esub>\<preceq> b) \<longleftrightarrow> (a \<^bsub>(P i)\<^esub>\<preceq> b);
     profile S Is P; profile S Is P' \<rbrakk>
  \<Longrightarrow> (a \<^bsub>(swf P)\<^esub>\<preceq> b) \<longleftrightarrow> (a \<^bsub>(swf P')\<^esub>\<preceq> b)"
  unfolding iia_def by (simp, blast)

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

subsection{* Decisiveness and Semi-decisiveness *}

text{* This notion is the key to Arrow's Theorem, and hinges on the use of
strict preference \cite[p42]{Sen:70a}. *}

text{* A coalition @{term "C"} of agents is \emph{semi-decisive} for @{term
"x"} over @{term "y"} if, whenever the coalition prefers @{term "x"} to
@{term "y"} and all other agents prefer the converse, the coalition
prevails. *}

definition semidecisive :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> 'i set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "semidecisive scf A Is C x y \<equiv>
    C \<subseteq> Is \<and> (\<forall>P. profile A Is P \<and> (\<forall>i \<in> C. x \<^bsub>(P i)\<^esub>\<prec> y) \<and> (\<forall>i \<in> Is - C. y \<^bsub>(P i)\<^esub>\<prec> x)
      \<longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y)"

lemma semidecisiveI[intro]:
  "\<lbrakk> C \<subseteq> Is;
    \<And>P. \<lbrakk> profile A Is P; \<And>i. i \<in> C \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> y; \<And>i. i \<in> Is - C \<Longrightarrow> y \<^bsub>(P i)\<^esub>\<prec> x \<rbrakk>
     \<Longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> semidecisive scf A Is C x y"
  unfolding semidecisive_def by simp

lemma semidecisive_coalitionD[dest]: "semidecisive scf A Is C x y \<Longrightarrow> C \<subseteq> Is"
  unfolding semidecisive_def by simp

lemma sd_refl: "\<lbrakk> C \<subseteq> Is; C \<noteq> {} \<rbrakk> \<Longrightarrow> semidecisive scf A Is C x x"
  unfolding semidecisive_def strict_pref_def by blast

text{* A coalition @{term "C"} is \emph{decisive} for @{term "x"} over
@{term "y"} if, whenever the coalition prefers @{term "x"} to @{term "y"},
the coalition prevails. *}

definition decisive :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> 'i set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "decisive scf A Is C x y \<equiv>
    C \<subseteq> Is \<and> (\<forall>P. profile A Is P \<and> (\<forall>i \<in> C. x \<^bsub>(P i)\<^esub>\<prec> y) \<longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y)"

lemma decisiveI[intro]:
  "\<lbrakk> C \<subseteq> Is; \<And>P. \<lbrakk> profile A Is P; \<And>i. i \<in> C \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> x \<^bsub>(scf P)\<^esub>\<prec> y \<rbrakk>
    \<Longrightarrow> decisive scf A Is C x y"
  unfolding decisive_def by simp

lemma d_imp_sd: "decisive scf A Is C x y \<Longrightarrow> semidecisive scf A Is C x y"
  unfolding decisive_def by (rule semidecisiveI, blast+)

lemma decisive_coalitionD[dest]: "decisive scf A Is C x y \<Longrightarrow> C \<subseteq> Is"
  unfolding decisive_def by simp

text {* Anyone is trivially decisive for @{term "x"} against @{term "x"}. *}

lemma d_refl: "\<lbrakk> C \<subseteq> Is; C \<noteq> {} \<rbrakk> \<Longrightarrow> decisive scf A Is C x x"
  unfolding decisive_def strict_pref_def by simp

text{* Agent @{term "j"} is a \emph{dictator} if her preferences always
prevail. This is the same as saying that she is decisive for all @{term "x"}
and @{term "y"}. *}

definition dictator :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> 'i \<Rightarrow> bool" where
  "dictator scf A Is j \<equiv> j \<in> Is \<and> (\<forall>x \<in> A. \<forall>y \<in> A. decisive scf A Is {j} x y)"

lemma dictatorI[intro]:
  "\<lbrakk> j \<in> Is; \<And>x y. \<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> decisive scf A Is {j} x y \<rbrakk> \<Longrightarrow> dictator scf A Is j"
  unfolding dictator_def by simp

lemma dictator_individual[dest]: "dictator scf A Is j \<Longrightarrow> j \<in> Is"
  unfolding dictator_def by simp

(*<*)
end
(*>*)


theory Induction_Demo
imports Main
begin

subsection{* Generalization *}

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev [] ys = ys" |
"itrev (x#xs) ys = itrev xs (x#ys)"

value "itrev [1,2,3::int] [6,7,8]"

lemma "itrev xs ys = rev xs @ ys"
  apply (induction xs arbitrary: ys)
   apply (auto)
   done

lemma itrev_rev_aux: "itrev xs ys = rev xs @ ys"
  apply (induction xs ys rule: itrev.induct)
   apply (auto)
   done

lemma "itrev xs [] = rev xs"
  by (auto simp: itrev_rev_aux)

subsection{* Computation Induction *}

fun sep :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep a [] = []" |
"sep a [x] = [x]" |
"sep a (x#y#zs) = x # a # sep a (y#zs)"

lemma "map f (sep a xs) = sep (f a) (map f xs)"
apply(induction a xs rule: sep.induct)
apply auto
done

subsection {* Auxiliary Lemmas *}

hide_const rev  (* Get predefined rev of standard lib out of way! *)
fun rev where
  "rev [] = []"
| "rev (x#xs) = rev xs @ [x]"

lemma "rev (xs @ [a]) = a # rev xs"
  apply (induction xs) apply auto done


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_HSortSorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Heap = Node "Heap" "int" "Heap" | Nil

fun toHeap :: "int list => Heap list" where
  "toHeap (nil2) = nil2"
| "toHeap (cons2 y z) = cons2 (Node Nil y Nil) (toHeap z)"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

fun hpairwise :: "Heap list => Heap list" where
  "hpairwise (nil2) = nil2"
| "hpairwise (cons2 p (nil2)) = cons2 p (nil2)"
| "hpairwise (cons2 p (cons2 q qs)) =
     cons2 (hmerge p q) (hpairwise qs)"

(*fun did not finish the proof*)
function hmerging :: "Heap list => Heap" where
  "hmerging (nil2) = Nil"
| "hmerging (cons2 p (nil2)) = p"
| "hmerging (cons2 p (cons2 z x2)) =
     hmerging (hpairwise (cons2 p (cons2 z x2)))"
  by pat_completeness auto

fun toHeap2 :: "int list => Heap" where
  "toHeap2 x = hmerging (toHeap x)"

(*fun did not finish the proof*)
function toList :: "Heap => int list" where
  "toList (Node p y q) = cons2 y (toList (hmerge p q))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hsort :: "int list => int list" where
  "hsort x = toList (toHeap2 x)"

theorem property0 :
  "ordered (hsort xs)"
  oops

end


section \<open>Extending FOL by a modified version of HOL set theory\<close>

theory Set
imports FOL
begin

declare [[eta_contract]]

typedecl 'a set
instance set :: ("term") "term" ..

subsection \<open>Set comprehension and membership\<close>

axiomatization Collect :: "['a \<Rightarrow> o] \<Rightarrow> 'a set"
  and mem :: "['a, 'a set] \<Rightarrow> o"  (infixl ":" 50)
where mem_Collect_iff: "(a : Collect(P)) \<longleftrightarrow> P(a)"
  and set_extension: "A = B \<longleftrightarrow> (ALL x. x:A \<longleftrightarrow> x:B)"

syntax
  "_Coll" :: "[idt, o] \<Rightarrow> 'a set"  ("(1{_./ _})")
translations
  "{x. P}" == "CONST Collect(\<lambda>x. P)"

lemma CollectI: "P(a) \<Longrightarrow> a : {x. P(x)}"
  apply (rule mem_Collect_iff [THEN iffD2])
  apply assumption
  done

lemma CollectD: "a : {x. P(x)} \<Longrightarrow> P(a)"
  apply (erule mem_Collect_iff [THEN iffD1])
  done

lemmas CollectE = CollectD [elim_format]

lemma set_ext: "(\<And>x. x:A \<longleftrightarrow> x:B) \<Longrightarrow> A = B"
  apply (rule set_extension [THEN iffD2])
  apply simp
  done

subsection \<open>Bounded quantifiers\<close>

definition Ball :: "['a set, 'a \<Rightarrow> o] \<Rightarrow> o"
  where "Ball(A, P) == ALL x. x:A \<longrightarrow> P(x)"

definition Bex :: "['a set, 'a \<Rightarrow> o] \<Rightarrow> o"
  where "Bex(A, P) == EX x. x:A \<and> P(x)"

syntax
  "_Ball" :: "[idt, 'a set, o] \<Rightarrow> o"  ("(ALL _:_./ _)" [0, 0, 0] 10)
  "_Bex" :: "[idt, 'a set, o] \<Rightarrow> o"  ("(EX _:_./ _)" [0, 0, 0] 10)
translations
  "ALL x:A. P"  == "CONST Ball(A, \<lambda>x. P)"
  "EX x:A. P"   == "CONST Bex(A, \<lambda>x. P)"

lemma ballI: "(\<And>x. x:A \<Longrightarrow> P(x)) \<Longrightarrow> ALL x:A. P(x)"
  by (simp add: Ball_def)

lemma bspec: "\<lbrakk>ALL x:A. P(x); x:A\<rbrakk> \<Longrightarrow> P(x)"
  by (simp add: Ball_def)

lemma ballE: "\<lbrakk>ALL x:A. P(x); P(x) \<Longrightarrow> Q; \<not> x:A \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  unfolding Ball_def by blast

lemma bexI: "\<lbrakk>P(x); x:A\<rbrakk> \<Longrightarrow> EX x:A. P(x)"
  unfolding Bex_def by blast

lemma bexCI: "\<lbrakk>EX x:A. \<not>P(x) \<Longrightarrow> P(a); a:A\<rbrakk> \<Longrightarrow> EX x:A. P(x)"
  unfolding Bex_def by blast

lemma bexE: "\<lbrakk>EX x:A. P(x); \<And>x. \<lbrakk>x:A; P(x)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  unfolding Bex_def by blast

(*Trival rewrite rule;   (! x:A.P)=P holds only if A is nonempty!*)
lemma ball_rew: "(ALL x:A. True) \<longleftrightarrow> True"
  by (blast intro: ballI)

subsubsection \<open>Congruence rules\<close>

lemma ball_cong:
  "\<lbrakk>A = A'; \<And>x. x:A' \<Longrightarrow> P(x) \<longleftrightarrow> P'(x)\<rbrakk> \<Longrightarrow>
    (ALL x:A. P(x)) \<longleftrightarrow> (ALL x:A'. P'(x))"
  by (blast intro: ballI elim: ballE)

lemma bex_cong:
  "\<lbrakk>A = A'; \<And>x. x:A' \<Longrightarrow> P(x) \<longleftrightarrow> P'(x)\<rbrakk> \<Longrightarrow>
    (EX x:A. P(x)) \<longleftrightarrow> (EX x:A'. P'(x))"
  by (blast intro: bexI elim: bexE)

subsection \<open>Further operations\<close>

definition subset :: "['a set, 'a set] \<Rightarrow> o"  (infixl "<=" 50)
  where "A <= B == ALL x:A. x:B"

definition mono :: "['a set \<Rightarrow> 'b set] \<Rightarrow> o"
  where "mono(f) == (ALL A B. A <= B \<longrightarrow> f(A) <= f(B))"

definition singleton :: "'a \<Rightarrow> 'a set"  ("{_}")
  where "{a} == {x. x=a}"

definition empty :: "'a set"  ("{}")
  where "{} == {x. False}"

definition Un :: "['a set, 'a set] \<Rightarrow> 'a set"  (infixl "Un" 65)
  where "A Un B == {x. x:A | x:B}"

definition Int :: "['a set, 'a set] \<Rightarrow> 'a set"  (infixl "Int" 70)
  where "A Int B == {x. x:A \<and> x:B}"

definition Compl :: "('a set) \<Rightarrow> 'a set"
  where "Compl(A) == {x. \<not>x:A}"

subsection \<open>Big Intersection / Union\<close>

definition INTER :: "['a set, 'a \<Rightarrow> 'b set] \<Rightarrow> 'b set"
  where "INTER(A, B) == {y. ALL x:A. y: B(x)}"

definition UNION :: "['a set, 'a \<Rightarrow> 'b set] \<Rightarrow> 'b set"
  where "UNION(A, B) == {y. EX x:A. y: B(x)}"

syntax
  "_INTER" :: "[idt, 'a set, 'b set] \<Rightarrow> 'b set"  ("(INT _:_./ _)" [0, 0, 0] 10)
  "_UNION" :: "[idt, 'a set, 'b set] \<Rightarrow> 'b set"  ("(UN _:_./ _)" [0, 0, 0] 10)
translations
  "INT x:A. B" == "CONST INTER(A, \<lambda>x. B)"
  "UN x:A. B" == "CONST UNION(A, \<lambda>x. B)"

definition Inter :: "(('a set)set) \<Rightarrow> 'a set"
  where "Inter(S) == (INT x:S. x)"

definition Union :: "(('a set)set) \<Rightarrow> 'a set"
  where "Union(S) == (UN x:S. x)"

subsection \<open>Rules for subsets\<close>

lemma subsetI: "(\<And>x. x:A \<Longrightarrow> x:B) \<Longrightarrow> A <= B"
  unfolding subset_def by (blast intro: ballI)

(*Rule in Modus Ponens style*)
lemma subsetD: "\<lbrakk>A <= B; c:A\<rbrakk> \<Longrightarrow> c:B"
  unfolding subset_def by (blast elim: ballE)

(*Classical elimination rule*)
lemma subsetCE: "\<lbrakk>A <= B; \<not>(c:A) \<Longrightarrow> P; c:B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast dest: subsetD)

lemma subset_refl: "A <= A"
  by (blast intro: subsetI)

lemma subset_trans: "\<lbrakk>A <= B; B <= C\<rbrakk> \<Longrightarrow> A <= C"
  by (blast intro: subsetI dest: subsetD)

subsection \<open>Rules for equality\<close>

(*Anti-symmetry of the subset relation*)
lemma subset_antisym: "\<lbrakk>A <= B; B <= A\<rbrakk> \<Longrightarrow> A = B"
  by (blast intro: set_ext dest: subsetD)

lemmas equalityI = subset_antisym

(* Equality rules from ZF set theory -- are they appropriate here? *)
lemma equalityD1: "A = B \<Longrightarrow> A<=B"
  and equalityD2: "A = B \<Longrightarrow> B<=A"
  by (simp_all add: subset_refl)

lemma equalityE: "\<lbrakk>A = B; \<lbrakk>A <= B; B <= A\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (simp add: subset_refl)

lemma equalityCE: "\<lbrakk>A = B; \<lbrakk>c:A; c:B\<rbrakk> \<Longrightarrow> P; \<lbrakk>\<not> c:A; \<not> c:B\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast elim: equalityE subsetCE)

lemma trivial_set: "{x. x:A} = A"
  by (blast intro: equalityI subsetI CollectI dest: CollectD)

subsection \<open>Rules for binary union\<close>

lemma UnI1: "c:A \<Longrightarrow> c : A Un B"
  and UnI2: "c:B \<Longrightarrow> c : A Un B"
  unfolding Un_def by (blast intro: CollectI)+

(*Classical introduction rule: no commitment to A vs B*)
lemma UnCI: "(\<not>c:B \<Longrightarrow> c:A) \<Longrightarrow> c : A Un B"
  by (blast intro: UnI1 UnI2)

lemma UnE: "\<lbrakk>c : A Un B; c:A \<Longrightarrow> P; c:B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  unfolding Un_def by (blast dest: CollectD)

subsection \<open>Rules for small intersection\<close>

lemma IntI: "\<lbrakk>c:A; c:B\<rbrakk> \<Longrightarrow> c : A Int B"
  unfolding Int_def by (blast intro: CollectI)

lemma IntD1: "c : A Int B \<Longrightarrow> c:A"
  and IntD2: "c : A Int B \<Longrightarrow> c:B"
  unfolding Int_def by (blast dest: CollectD)+

lemma IntE: "\<lbrakk>c : A Int B; \<lbrakk>c:A; c:B\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast dest: IntD1 IntD2)

subsection \<open>Rules for set complement\<close>

lemma ComplI: "(c:A \<Longrightarrow> False) \<Longrightarrow> c : Compl(A)"
  unfolding Compl_def by (blast intro: CollectI)

(*This form, with negated conclusion, works well with the Classical prover.
  Negated assumptions behave like formulae on the right side of the notional
  turnstile...*)
lemma ComplD: "c : Compl(A) \<Longrightarrow> \<not>c:A"
  unfolding Compl_def by (blast dest: CollectD)

lemmas ComplE = ComplD [elim_format]

subsection \<open>Empty sets\<close>

lemma empty_eq: "{x. False} = {}"
  by (simp add: empty_def)

lemma emptyD: "a : {} \<Longrightarrow> P"
  unfolding empty_def by (blast dest: CollectD)

lemmas emptyE = emptyD [elim_format]

lemma not_emptyD:
  assumes "\<not> A={}"
  shows "EX x. x:A"
proof -
  have "\<not> (EX x. x:A) \<Longrightarrow> A = {}"
    by (rule equalityI) (blast intro!: subsetI elim!: emptyD)+
  with assms show ?thesis by blast
qed

subsection \<open>Singleton sets\<close>

lemma singletonI: "a : {a}"
  unfolding singleton_def by (blast intro: CollectI)

lemma singletonD: "b : {a} \<Longrightarrow> b=a"
  unfolding singleton_def by (blast dest: CollectD)

lemmas singletonE = singletonD [elim_format]

subsection \<open>Unions of families\<close>

(*The order of the premises presupposes that A is rigid; b may be flexible*)
lemma UN_I: "\<lbrakk>a:A; b: B(a)\<rbrakk> \<Longrightarrow> b: (UN x:A. B(x))"
  unfolding UNION_def by (blast intro: bexI CollectI)

lemma UN_E: "\<lbrakk>b : (UN x:A. B(x)); \<And>x. \<lbrakk>x:A; b: B(x)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding UNION_def by (blast dest: CollectD elim: bexE)

lemma UN_cong: "\<lbrakk>A = B; \<And>x. x:B \<Longrightarrow> C(x) = D(x)\<rbrakk> \<Longrightarrow> (UN x:A. C(x)) = (UN x:B. D(x))"
  by (simp add: UNION_def cong: bex_cong)

subsection \<open>Intersections of families\<close>

lemma INT_I: "(\<And>x. x:A \<Longrightarrow> b: B(x)) \<Longrightarrow> b : (INT x:A. B(x))"
  unfolding INTER_def by (blast intro: CollectI ballI)

lemma INT_D: "\<lbrakk>b : (INT x:A. B(x)); a:A\<rbrakk> \<Longrightarrow> b: B(a)"
  unfolding INTER_def by (blast dest: CollectD bspec)

(*"Classical" elimination rule -- does not require proving X:C *)
lemma INT_E: "\<lbrakk>b : (INT x:A. B(x)); b: B(a) \<Longrightarrow> R; \<not> a:A \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding INTER_def by (blast dest: CollectD bspec)

lemma INT_cong: "\<lbrakk>A = B; \<And>x. x:B \<Longrightarrow> C(x) = D(x)\<rbrakk> \<Longrightarrow> (INT x:A. C(x)) = (INT x:B. D(x))"
  by (simp add: INTER_def cong: ball_cong)

subsection \<open>Rules for Unions\<close>

(*The order of the premises presupposes that C is rigid; A may be flexible*)
lemma UnionI: "\<lbrakk>X:C; A:X\<rbrakk> \<Longrightarrow> A : Union(C)"
  unfolding Union_def by (blast intro: UN_I)

lemma UnionE: "\<lbrakk>A : Union(C); \<And>X. \<lbrakk> A:X; X:C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding Union_def by (blast elim: UN_E)

subsection \<open>Rules for Inter\<close>

lemma InterI: "(\<And>X. X:C \<Longrightarrow> A:X) \<Longrightarrow> A : Inter(C)"
  unfolding Inter_def by (blast intro: INT_I)

(*A "destruct" rule -- every X in C contains A as an element, but
  A:X can hold when X:C does not!  This rule is analogous to "spec". *)
lemma InterD: "\<lbrakk>A : Inter(C);  X:C\<rbrakk> \<Longrightarrow> A:X"
  unfolding Inter_def by (blast dest: INT_D)

(*"Classical" elimination rule -- does not require proving X:C *)
lemma InterE: "\<lbrakk>A : Inter(C); A:X \<Longrightarrow> R; \<not> X:C \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding Inter_def by (blast elim: INT_E)

section \<open>Derived rules involving subsets; Union and Intersection as lattice operations\<close>

subsection \<open>Big Union -- least upper bound of a set\<close>

lemma Union_upper: "B:A \<Longrightarrow> B <= Union(A)"
  by (blast intro: subsetI UnionI)

lemma Union_least: "(\<And>X. X:A \<Longrightarrow> X<=C) \<Longrightarrow> Union(A) <= C"
  by (blast intro: subsetI dest: subsetD elim: UnionE)

subsection \<open>Big Intersection -- greatest lower bound of a set\<close>

lemma Inter_lower: "B:A \<Longrightarrow> Inter(A) <= B"
  by (blast intro: subsetI dest: InterD)

lemma Inter_greatest: "(\<And>X. X:A \<Longrightarrow> C<=X) \<Longrightarrow> C <= Inter(A)"
  by (blast intro: subsetI InterI dest: subsetD)

subsection \<open>Finite Union -- the least upper bound of 2 sets\<close>

lemma Un_upper1: "A <= A Un B"
  by (blast intro: subsetI UnI1)

lemma Un_upper2: "B <= A Un B"
  by (blast intro: subsetI UnI2)

lemma Un_least: "\<lbrakk>A<=C; B<=C\<rbrakk> \<Longrightarrow> A Un B <= C"
  by (blast intro: subsetI elim: UnE dest: subsetD)

subsection \<open>Finite Intersection -- the greatest lower bound of 2 sets\<close>

lemma Int_lower1: "A Int B <= A"
  by (blast intro: subsetI elim: IntE)

lemma Int_lower2: "A Int B <= B"
  by (blast intro: subsetI elim: IntE)

lemma Int_greatest: "\<lbrakk>C<=A; C<=B\<rbrakk> \<Longrightarrow> C <= A Int B"
  by (blast intro: subsetI IntI dest: subsetD)

subsection \<open>Monotonicity\<close>

lemma monoI: "(\<And>A B. A <= B \<Longrightarrow> f(A) <= f(B)) \<Longrightarrow> mono(f)"
  unfolding mono_def by blast

lemma monoD: "\<lbrakk>mono(f); A <= B\<rbrakk> \<Longrightarrow> f(A) <= f(B)"
  unfolding mono_def by blast

lemma mono_Un: "mono(f) \<Longrightarrow> f(A) Un f(B) <= f(A Un B)"
  by (blast intro: Un_least dest: monoD intro: Un_upper1 Un_upper2)

lemma mono_Int: "mono(f) \<Longrightarrow> f(A Int B) <= f(A) Int f(B)"
  by (blast intro: Int_greatest dest: monoD intro: Int_lower1 Int_lower2)

subsection \<open>Automated reasoning setup\<close>

lemmas [intro!] = ballI subsetI InterI INT_I CollectI ComplI IntI UnCI singletonI
  and [intro] = bexI UnionI UN_I
  and [elim!] = bexE UnionE UN_E CollectE ComplE IntE UnE emptyE singletonE
  and [elim] = ballE InterD InterE INT_D INT_E subsetD subsetCE

lemma mem_rews:
  "(a : A Un B)   \<longleftrightarrow>  (a:A | a:B)"
  "(a : A Int B)  \<longleftrightarrow>  (a:A \<and> a:B)"
  "(a : Compl(B)) \<longleftrightarrow>  (\<not>a:B)"
  "(a : {b})      \<longleftrightarrow>  (a=b)"
  "(a : {})       \<longleftrightarrow>   False"
  "(a : {x. P(x)}) \<longleftrightarrow>  P(a)"
  by blast+

lemmas [simp] = trivial_set empty_eq mem_rews
  and [cong] = ball_cong bex_cong INT_cong UN_cong

section \<open>Equalities involving union, intersection, inclusion, etc.\<close>

subsection \<open>Binary Intersection\<close>

lemma Int_absorb: "A Int A = A"
  by (blast intro: equalityI)

lemma Int_commute: "A Int B  =  B Int A"
  by (blast intro: equalityI)

lemma Int_assoc: "(A Int B) Int C  =  A Int (B Int C)"
  by (blast intro: equalityI)

lemma Int_Un_distrib: "(A Un B) Int C  =  (A Int C) Un (B Int C)"
  by (blast intro: equalityI)

lemma subset_Int_eq: "(A<=B) \<longleftrightarrow> (A Int B = A)"
  by (blast intro: equalityI elim: equalityE)

subsection \<open>Binary Union\<close>

lemma Un_absorb: "A Un A = A"
  by (blast intro: equalityI)

lemma Un_commute: "A Un B  =  B Un A"
  by (blast intro: equalityI)

lemma Un_assoc: "(A Un B) Un C  =  A Un (B Un C)"
  by (blast intro: equalityI)

lemma Un_Int_distrib: "(A Int B) Un C  =  (A Un C) Int (B Un C)"
  by (blast intro: equalityI)

lemma Un_Int_crazy:
    "(A Int B) Un (B Int C) Un (C Int A) = (A Un B) Int (B Un C) Int (C Un A)"
  by (blast intro: equalityI)

lemma subset_Un_eq: "(A<=B) \<longleftrightarrow> (A Un B = B)"
  by (blast intro: equalityI elim: equalityE)

subsection \<open>Simple properties of \<open>Compl\<close> -- complement of a set\<close>

lemma Compl_disjoint: "A Int Compl(A) = {x. False}"
  by (blast intro: equalityI)

lemma Compl_partition: "A Un Compl(A) = {x. True}"
  by (blast intro: equalityI)

lemma double_complement: "Compl(Compl(A)) = A"
  by (blast intro: equalityI)

lemma Compl_Un: "Compl(A Un B) = Compl(A) Int Compl(B)"
  by (blast intro: equalityI)

lemma Compl_Int: "Compl(A Int B) = Compl(A) Un Compl(B)"
  by (blast intro: equalityI)

lemma Compl_UN: "Compl(UN x:A. B(x)) = (INT x:A. Compl(B(x)))"
  by (blast intro: equalityI)

lemma Compl_INT: "Compl(INT x:A. B(x)) = (UN x:A. Compl(B(x)))"
  by (blast intro: equalityI)

(*Halmos, Naive Set Theory, page 16.*)
lemma Un_Int_assoc_eq: "((A Int B) Un C = A Int (B Un C)) \<longleftrightarrow> (C<=A)"
  by (blast intro: equalityI elim: equalityE)

subsection \<open>Big Union and Intersection\<close>

lemma Union_Un_distrib: "Union(A Un B) = Union(A) Un Union(B)"
  by (blast intro: equalityI)

lemma Union_disjoint:
    "(Union(C) Int A = {x. False}) \<longleftrightarrow> (ALL B:C. B Int A = {x. False})"
  by (blast intro: equalityI elim: equalityE)

lemma Inter_Un_distrib: "Inter(A Un B) = Inter(A) Int Inter(B)"
  by (blast intro: equalityI)

subsection \<open>Unions and Intersections of Families\<close>

lemma UN_eq: "(UN x:A. B(x)) = Union({Y. EX x:A. Y=B(x)})"
  by (blast intro: equalityI)

(*Look: it has an EXISTENTIAL quantifier*)
lemma INT_eq: "(INT x:A. B(x)) = Inter({Y. EX x:A. Y=B(x)})"
  by (blast intro: equalityI)

lemma Int_Union_image: "A Int Union(B) = (UN C:B. A Int C)"
  by (blast intro: equalityI)

lemma Un_Inter_image: "A Un Inter(B) = (INT C:B. A Un C)"
  by (blast intro: equalityI)

section \<open>Monotonicity of various operations\<close>

lemma Union_mono: "A<=B \<Longrightarrow> Union(A) <= Union(B)"
  by blast

lemma Inter_anti_mono: "B <= A \<Longrightarrow> Inter(A) <= Inter(B)"
  by blast

lemma UN_mono: "\<lbrakk>A <= B; \<And>x. x:A \<Longrightarrow> f(x)<=g(x)\<rbrakk> \<Longrightarrow> (UN x:A. f(x)) <= (UN x:B. g(x))"
  by blast

lemma INT_anti_mono: "\<lbrakk>B <= A; \<And>x. x:A \<Longrightarrow> f(x) <= g(x)\<rbrakk> \<Longrightarrow> (INT x:A. f(x)) <= (INT x:A. g(x))"
  by blast

lemma Un_mono: "\<lbrakk>A <= C; B <= D\<rbrakk> \<Longrightarrow> A Un B <= C Un D"
  by blast

lemma Int_mono: "\<lbrakk>A <= C; B <= D\<rbrakk> \<Longrightarrow> A Int B <= C Int D"
  by blast

lemma Compl_anti_mono: "A <= B \<Longrightarrow> Compl(B) <= Compl(A)"
  by blast

end