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

text {*
  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.
*}

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 listsum_split: "listsum (l @ (a::'a::monoid_add) # r) = (listsum l) + a + (listsum 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) . listsum 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 "listsum ins")
  apply auto
  apply (case_tac x)
  apply auto
  apply (cases a)
  apply auto
  apply (cases "listsum 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 listsum_in_set: "(l::('x \<times> ('e,'a::linorder) Prio) list)\<noteq>[] \<Longrightarrow>
  listsum (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 "listsum (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 = listsum (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 listsum_in_set[OF snn])
  hence "p_unwrap (annot s) \<in> set (map p_unwrap ?P)"
    by (metis image_iff in_set_conv_decomp set_map split_list_last)
  thus ?thesis
    by (metis mem_set_multiset_eq alprio_\<alpha>_def)
qed

lemma  listsum_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 (listsum (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 "listsum (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, listsum (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: listsum_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 + listsum (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 listsum_elem:
  assumes " ins = l @ (a::('e,'a::linorder)Prio) # r"
  and "\<not> listsum l \<le> listsum ins"
  and "listsum l + a \<le> listsum ins "
  shows " a = listsum ins"
proof -
  have "\<not> listsum l \<le> a" using assms prio_add_abc by simp
  hence lpa: "listsum l + a = a" using prio_add_alb by auto
  hence als: "a \<le> listsum ins" using assms(3) by simp
  have "listsum ins = a + listsum r"
    using lpa listsum_split[of l a r] assms(1) by auto
  thus ?thesis using prio_add_alb2[of a "listsum 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 + listsum (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> listsum (map snd (\<alpha> l)) \<le> annot s" and
    aneqa: "(listsum (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 = listsum_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 IMPExpressions

imports Main

begin

type_synonym vname = string

datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s"

definition exp :: "aexp" where "exp = (Plus (N 5) (V ''x''))"

value "aval exp ((\<lambda> x. 0)(''x'' := 1))"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a1 a2) =
  (case (asimp_const a1, asimp_const a2) of
    (N n1, N n2) \<Rightarrow> N(n1 + n2) |
    (b1, b2) \<Rightarrow> Plus b1 b2)"

lemma "aval (asimp_const a) s = aval a s"
  apply(induction a)
    apply(auto split: aexp.split)
  done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow>  aexp" where
"plus (N i1) (N i2) = N(i1 + i2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a1 a2 = Plus a1 a2"

lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply(induction rule: plus.induct)
    apply(auto)
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

lemma "aval (asimp a) s = aval a s"
  apply(induction a)
    apply(auto simp add: aval_plus)
  done

fun optimal_plus :: "aexp \<Rightarrow> aexp \<Rightarrow> bool" where
"optimal_plus (N _) (N _) = False" |
"optimal_plus a1 a2 = True"

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N _) = True" |
"optimal (V _) = True" |
"optimal (Plus a1 a2) = ((optimal a1) \<and> (optimal a2) \<and> (optimal_plus a1 a2))"

theorem "optimal(asimp_const a)"
  apply(induction a)
    apply(auto split: aexp.split)
  done

fun full_plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"full_plus (N n1) (N n2) = N (n1 + n2)" |
"full_plus (N n1) (Plus a (N n2)) = (Plus a (N (n1 + n2)))" |
"full_plus (Plus a (N n1)) (N n2) = (Plus a (N (n1 + n2)))" |
"full_plus a1 a2 = (Plus a1 a2)"

lemma full_plus_aval: "aval (full_plus a1 a2) s = aval a1 s + aval a2 s"
  apply(induction rule: full_plus.induct)
    apply(auto)
  done

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp (N n) = N n" |
"full_asimp (V x) = V x" |
"full_asimp (Plus a1 a2) = full_plus (full_asimp a1) (full_asimp a2)"

value "full_asimp (Plus (N 1) (Plus (V ''x'') (N 2)))"

theorem "aval (full_asimp a) s = aval a s"
  apply(induction a arbitrary: s)
    apply(auto simp add: full_plus_aval)
  done

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst v e (V x) = (if v = x then e else (V x))" |
"subst v e (Plus a1 a2) = (Plus (subst v e a1) (subst v e a2))" |
"subst v e a = a"

value "subst ''x''  (N 2) (Plus (V ''x'') (N 1))"

lemma subst_preserves_semantics: "aval (subst x a e) s = aval e (s(x := aval a s))"
  apply(induction e)
    apply(auto)
  done

theorem "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply(simp add: subst_preserves_semantics)
  done

end


theory symmetry
  imports Main
begin

datatype 'a palindrome = Nil | Merge "'a palindrome" "'a palindrome"

fun left :: "'a palindrome ⇒ 'a palindrome" where
  "left Nil = Nil" |
  "left (Merge l r) = l"

fun right :: "'a palindrome ⇒ 'a palindrome" where
  "right Nil = Nil" |
  "right (Merge l r) = r"

fun reversed :: "'a palindrome ⇒ 'a palindrome" where
  "reversed Nil = Nil" |
  "reversed (Merge l r) = Merge (reversed r) (reversed l)"

fun connect :: "'a palindrome ⇒ 'a palindrome ⇒ 'a palindrome"  where
 "connect Nil nw = Nil" |
 "connect (Merge l r) m = Merge (Merge l m) (Merge (reversed m) (reversed l))"

lemma double_reverse: "reversed (reversed a) = a"
  apply (induct_tac a)
  apply (auto)
  done

lemma reversed_commutativity:
  assumes "reversed a = b"
  shows "reversed b = a"

proof (cases "a")
  case (Merge l r)
  then have  "b = Merge (reversed r) (reversed l)" using assms by simp
  then have "reversed b = Merge (reversed (reversed l)) (reversed (reversed r))" by auto
  then have "reversed b = Merge l r" using double_reverse by auto
  thus ?thesis using Merge by auto
next
  case Nil
  then have "reversed a = Nil" by auto
  then have "b = Nil" using assms by auto
  then have "reversed b = Nil" by auto
  thus ?thesis using local.Nil by simp
qed

theorem recurrence_is_symmetric:
  fixes a b
  assumes "p = connect a b"
  shows "reversed (right p) = left p"

proof (cases "a")
  case (Merge l r)
    from assms have "p = connect a b" by auto
    then have "p = Merge (Merge l b) (Merge (reversed b) (reversed l))" by (simp add: Merge)
    also have "reversed (Merge l b) = Merge (reversed b) (reversed l)" by auto
    then have "reversed (left p) = right p" by (simp add: calculation)
    then have "reversed (right p) = left p" using reversed_commutativity by auto
    thus ?thesis by auto
  next
    case Nil
    then have "p = Nil" using assms by auto
    then have "left p = Nil" and "right p = Nil" and "reversed (right p) = Nil" by auto
    thus ?thesis by auto
 qed

end


theory Binary_Operations
  imports Bits_Digits Carries
begin

section \<open>Digit-wise Operations\<close>

subsection \<open>Binary AND\<close>

fun bitAND_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" (infix "&&" 64) where
  "0 && _ = 0" |
  "m && n = 2 * ((m div 2) && (n div 2)) + (m mod 2) * (n mod 2)"

lemma bitAND_zero[simp]: "n = 0 \<Longrightarrow> m && n = 0"
  by (induct m n rule:bitAND_nat.induct, auto)

lemma bitAND_1: "a && 1 = (a mod 2)"
  by (induction a; auto)

lemma bitAND_rec: "m && n = 2 * ((m div 2) && (n div 2)) + (m mod 2) * (n mod 2)"
  by (cases m; simp_all)

lemma bitAND_commutes:"m && n = n && m"
  by (induct m n rule: bitAND_nat.induct, simp) (metis bitAND_rec mult.commute)

lemma nth_digit_0: "x \<le> 1 \<Longrightarrow> nth_bit x 0 = x" by (simp add: nth_bit_def)

lemma bitAND_zeroone: "a \<le> 1 \<Longrightarrow> b \<le> 1 \<Longrightarrow> a && b \<le> 1"
  using nth_bit_def nth_digit_0 nat_le_linear bitAND_nat.elims
  by (metis (no_types, lifting) One_nat_def add.left_neutral bitAND_zero div_less le_zero_eq lessI
             mult.right_neutral mult_0_right not_mod2_eq_Suc_0_eq_0 numeral_2_eq_2)

lemma aux1_bitAND_digit_mult:
  fixes a b c :: nat
  shows "k > 0 \<and> a mod 2 = 0 \<and> b \<le> 1 \<Longrightarrow> (a + b) div 2^k = a div 2^k"
  by (induction k, auto)
     (metis One_nat_def add_cancel_left_right div_mult2_eq even_succ_div_two le_0_eq le_Suc_eq)

lemma bitAND_digit_mult:"(nth_bit (a && b) k) = (nth_bit a k) * (nth_bit b k)"
proof(induction k arbitrary: a b)
  case 0
  show ?case
    using nth_bit_def
    by auto (metis (no_types, opaque_lifting) Groups.add_ac(2) bitAND_rec mod_mod_trivial
              mod_mult_self2 mult_numeral_1_right mult_zero_right not_mod_2_eq_1_eq_0 numeral_One)
next
  case (Suc k)
  have "nth_bit (a && b) (Suc k)
        = (2 * (a div 2 && b div 2) + a mod 2 * (b mod 2)) div 2 ^(Suc k) mod 2"
    using bitAND_rec by (metis nth_bit_def)

  moreover have "(a mod 2) * (b mod 2) < (2 ^ Suc(k))"
    by (metis One_nat_def lessI mult_numeral_1_right mult_zero_right not_mod_2_eq_1_eq_0
              numeral_2_eq_2 numeral_One power_gt1 zero_less_numeral zero_less_power)

  ultimately have "nth_bit (a && b) (Suc k) = (2 * (a div 2 && b div 2)) div 2 ^(Suc k) mod 2"
    using aux1_bitAND_digit_mult
    by (metis le_numeral_extra(1) le_numeral_extra(4) mod_mult_self1_is_0 mult_numeral_1_right
              mult_zero_right not_mod_2_eq_1_eq_0 numeral_One zero_less_Suc)

  then have "nth_bit (a && b) (Suc k) = (nth_bit (a div 2 && b div 2) k)"
    by (auto simp add: nth_bit_def)

  then have "nth_bit (a && b) (Suc k) = (nth_bit (a div 2) k) * (nth_bit (b div 2) k)"
    using Suc
    by presburger

  then show ?case
    by (metis div_mult2_eq nth_bit_def power_Suc)
qed

lemma bitAND_single_bit_mult_equiv: "a \<le> 1 \<Longrightarrow> b \<le> 1 \<Longrightarrow> a * b = a && b"
  using bitAND_digit_mult[of a b 0] bitAND_zeroone by (auto simp: nth_digit_0)

lemma bitAND_mult_equiv:
  "(\<forall>k. (nth_bit c k) = (nth_bit a k) * (nth_bit b k)) \<longleftrightarrow> c = a && b" (is "?P \<longleftrightarrow> ?Q")
proof
  assume "?Q"
  then show "?P" using bitAND_digit_mult by simp
next
  assume "?P"
  then show "?Q" using bitAND_digit_mult digit_wise_equiv by presburger
qed

lemma bitAND_linear:
  fixes k::nat
  shows "(b < 2^k) \<and> (d < 2^k) \<Longrightarrow> (a * 2^k + b) && (c * 2^k + d) = (a && c) * 2^k + (b && d)"
proof(induction k arbitrary: a b c d)
  case 0
  then show ?case by simp
next
  case (Suc k)
  define m where "m = a * 2^(Suc k) + b"
  define n where "n = c * 2^(Suc k) + d"

  have "m && n = 2 * (bitAND_nat (m div 2) (n div 2)) + (m mod 2) * (n mod 2)"
    using bitAND_rec
    by blast

  moreover have "d mod 2 = n mod 2 \<and> b mod 2 = m mod 2"
    by (metis m_def n_def add.commute mod_mult_self2 power_Suc semiring_normalization_rules(19))

  ultimately have f0:"m && n
                      = 2 * ((a * 2^k + (b div 2)) && (c * 2^k + (d div 2))) + (b mod 2)*(d mod 2)"
    by (metis add.commute div_mult_self2 m_def n_def power_Suc semiring_normalization_rules(19)
              zero_neq_numeral)

  have "b div 2 < (2 ^ k) \<and> d div 2 < (2 ^ k)"
    using Suc.prems
    by auto

  then have f1:"m && n
                = ((a && c) * 2^(Suc k)) + 2 * ((b div 2) && (d div 2)) + (b mod 2) * (d mod 2)"
    using f0 Suc.IH
    by simp

  have "b && d = 2 * ((b div 2) && (d div 2)) + (b mod 2) * (d mod 2)"
    using bitAND_rec
    by blast

  then show ?case
    using f1
    by (auto simp add: m_def n_def)
qed

subsection \<open>Binary orthogonality\<close>
text \<open>cf. \<^cite>\<open>h10lecturenotes\<close> section 2.6.1 on "Binary orthogonality"\<close>
text \<open>The following definition differs slightly from the one in the paper. However, we later prove the
     equivalence of the two definitions.\<close>

fun orthogonal :: "nat => nat => bool" (infix "\<bottom>" 49) where
  "(orthogonal a b) = (a && b = 0)"

lemma ortho_mult_equiv: "a \<bottom> b \<longleftrightarrow> (\<forall>k. (nth_bit a k) * (nth_bit b k) = 0)" (is "?P \<longleftrightarrow> ?Q")
proof
  assume "?P"
  then show "?Q" using bitAND_digit_mult nth_bit_def by (metis div_0 mod_0 orthogonal.simps)
next
  assume "?Q"
  then show "?P" using bitAND_mult_equiv nth_bit_def by (metis div_0 mod_0 orthogonal.simps)
qed

lemma aux1_1_digit_lt_linear:
  assumes "b < 2^r" "k \<ge> r"
  shows  "bin_carry (a*2^r) b k = 0"
proof-
  have "b < 2^r \<longrightarrow>(a*2^r) \<bottom> b"
  proof(induct a  b rule: bitAND_nat.induct)
    case (1 uu)
    then show ?case by simp
  next
    case (2 v n)
    show ?case apply auto using bitAND_linear[of n r 0 0 "Suc(v)"] bitAND_commutes by auto
  qed
  then show ?thesis using ortho_mult_equiv no_carry_mult_equiv assms(1) by auto
qed

lemma aux1_digit_lt_linear:
  assumes "b < 2^r" and "k \<ge> r"
  shows "(a*2^r + b) \<exclamdown> k = (a*2^r) \<exclamdown> k"
proof-
  have "b div 2 ^ k = 0" using assms by (simp add: order.strict_trans2)
  moreover have "(a * 2 ^ r mod 2 ^ k +  b mod 2 ^ k) div 2 ^ k = 0" using assms
  proof-
    have "bin_carry (a*2^r) b k = 0" using assms aux1_1_digit_lt_linear by auto
    then show ?thesis using assms by (auto simp add: bin_carry_def)
  qed
  ultimately show ?thesis
    by (auto simp add: nth_bit_def div_add1_eq[of "a*2^r" "b" "2^k"])
qed

lemma aux_digit_shift: "(a * 2^t) \<exclamdown> (l+t) = a \<exclamdown> l"
  using nth_bit_def
  by (induct l; auto)
     (smt div_mult2_eq mult.commute nonzero_mult_div_cancel_right power_add power_not_zero zero_neq_numeral)

lemma aux_digit_lt_linear:
  assumes b: "b < (2::nat)^t"
  assumes d: "d < (2::nat)^t"
  shows "(a * 2^t + b) \<exclamdown> k \<le> (c * 2^t + d) \<exclamdown> k \<longleftrightarrow> ((a * 2^t) \<exclamdown> k \<le> (c * 2^t) \<exclamdown> k \<and> b \<exclamdown> k \<le> d \<exclamdown> k)"
proof (cases "k < t")
  case True
  from True have "(a * 2^t + b) \<exclamdown> k = b \<exclamdown> k"
    using aux2_digit_sum_repr assms(1) by auto
  moreover from True have "(c * 2^t + d) \<exclamdown> k = d \<exclamdown> k"
    using aux2_digit_sum_repr assms(2) by auto
  moreover from True have "(a * 2^t) \<exclamdown> k = 0"
    using aux2_digit_sum_repr[of "0"] nth_bit_def by auto
  ultimately show ?thesis
    using aux2_digit_sum_repr assms by auto
next
  case False
  from False have "(a * 2^t + b) \<exclamdown> k = (a * 2^t) \<exclamdown> k"
    using aux1_digit_lt_linear assms(1) by auto
  moreover from False have "(c * 2^t + d) \<exclamdown> k = (c * 2^t) \<exclamdown> k" using aux1_digit_lt_linear assms(2) by auto
  moreover from False have "b \<exclamdown> k = 0"
    using aux1_digit_lt_linear[of _ _ _ "0"] nth_bit_def assms(1) by auto
  ultimately show ?thesis by auto
qed

lemma aux2_digit_lt_linear:
  fixes a b c d t l :: nat
  shows "\<exists>k. (a * 2^t) \<exclamdown> k \<le> (c * 2^t) \<exclamdown> k \<longrightarrow> a \<exclamdown> l \<le> c \<exclamdown> l"
proof -
  define k where "k = l + t"
  have "(a * 2^t) \<exclamdown> k = a \<exclamdown> l" using nth_bit_def k_def
    using aux_digit_shift by auto
  moreover have "(c * 2^t) \<exclamdown> k = c \<exclamdown> l" using nth_bit_def k_def
    using aux_digit_shift by auto
  ultimately show ?thesis by metis
qed

lemma aux3_digit_lt_linear:
  fixes a b c d t k :: nat
  shows "\<exists>l. a \<exclamdown> l \<le> c \<exclamdown> l \<longrightarrow> (a * 2^t) \<exclamdown> k \<le> (c * 2^t) \<exclamdown> k"
proof (cases "k < t")
  case True
  hence "(a * 2^t) \<exclamdown> k = 0"
    using aux2_digit_sum_repr[of "0"] nth_bit_def by auto
  then show ?thesis by auto
next
  case False
  define l where "l = k - t"
  hence k: "k = l + t" using False by auto
  have "(a * 2^t) \<exclamdown> k = a \<exclamdown> l" using nth_bit_def l_def
    using aux_digit_shift k by auto
  moreover have "(c * 2^t) \<exclamdown> k = c \<exclamdown> l" using nth_bit_def l_def
    using aux_digit_shift k by auto
  ultimately show ?thesis by auto
qed

lemma digit_lt_linear:
  fixes a b c d t :: nat
  assumes b: "b < (2::nat)^t"
  assumes d: "d < (2::nat)^t"
  shows "(\<forall>k. (a * 2^t + b) \<exclamdown> k \<le> (c * 2^t + d) \<exclamdown> k) \<longleftrightarrow> (\<forall>l. a \<exclamdown> l \<le> c \<exclamdown> l \<and> b \<exclamdown> l \<le> d \<exclamdown> l)"
proof -
  have shift: "(\<forall>k. (a * 2^t) \<exclamdown> k \<le> (c * 2^t) \<exclamdown> k) \<longleftrightarrow> (\<forall>l. a \<exclamdown> l \<le> c \<exclamdown> l)" (is "?P \<longleftrightarrow> ?Q")
  proof
    assume P: ?P
    show ?Q using P aux2_digit_lt_linear by auto
  next
    assume Q: ?Q
    show ?P using Q aux3_digit_lt_linear by auto
  qed

  have main: "(\<forall>k. (a * 2^t + b) \<exclamdown> k \<le> (c * 2^t + d) \<exclamdown> k \<longleftrightarrow> ((a * 2^t) \<exclamdown> k \<le> (c * 2^t) \<exclamdown> k \<and> b \<exclamdown> k \<le> d \<exclamdown> k))"
    using aux_digit_lt_linear b d by auto

  from main shift show ?thesis by auto
qed

text \<open>Sufficient bitwise (digitwise) condition for the non-strict standard order of natural numbers\<close>

lemma digitwise_leq:
  assumes "b>1"
  shows "\<forall>t. nth_digit x t b \<le> nth_digit y t b \<Longrightarrow> x \<le> y"
proof -
  assume asm: "\<forall>t. nth_digit x t b \<le> nth_digit y t b"
  define r where "r \<equiv>(if x>y then x else y)"
  have "x = (\<Sum>k<x. (nth_digit x k b) * b ^ k)"
    using digit_gen_sum_repr_variant \<open>b>1\<close> by auto
  hence x: "x = (\<Sum>k=0..<r. (nth_digit x k b) * b ^ k)"
    using atLeast0LessThan r_def digit_gen_sum_index_variant \<open>b>1\<close>
    by (metis (full_types) linorder_neqE_nat)
  have "y = (\<Sum>k<y. (nth_digit y k b) * b ^ k)"
    using digit_gen_sum_repr_variant \<open>b>1\<close> by auto
  hence y: "y = (\<Sum>k=0..<r. (nth_digit y k b) * b ^ k)"
    using atLeast0LessThan r_def digit_gen_sum_index_variant \<open>b>1\<close> by auto
  show ?thesis using asm x y
    sum_mono[of "{0..<r}" "\<lambda>k. nth_digit x k b * b^k" "\<lambda>k. nth_digit y k b * b^k"]
    by auto
qed

subsection \<open>Binary masking\<close>

text \<open>Preliminary result on the standard non-strict of natural numbers\<close>

lemma bitwise_leq: "(\<forall>k. a \<exclamdown> k \<le>  b \<exclamdown> k) \<longrightarrow> a \<le> b"
  using digitwise_leq[of 2] by (simp add: nth_digit_base2_equiv)

text \<open>cf. \<^cite>\<open>h10lecturenotes\<close> section 2.6.2 on "Binary Masking"\<close>
text \<open>Again, the equivalence to the definition there will be proved in a later lemma.\<close>

fun masks :: "nat => nat => bool" (infix "\<preceq>" 49) where
  "masks 0 _ = True" |
  "masks a b = ((a div 2 \<preceq> b div 2) \<and> (a mod 2 \<le> b mod 2))"

lemma masks_substr: "a \<preceq> b \<Longrightarrow> (a div (2^k) \<preceq> b div (2^k))"
proof (induction k)
  case 0
  then show ?case by simp
next
  case (Suc k)
  moreover
  {
    fix ka :: nat
    assume a1: "a div 2 ^ ka \<preceq> b div 2 ^ ka"

    have f2: "\<forall>n na nb. (nb::nat) div na div n = nb div n div na"
      by (metis (no_types) div_mult2_eq semiring_normalization_rules(7))

    then have f3: "\<forall>n na nb nc.
                    (nc div nb = 0 \<or> nc div 2 div nb \<preceq> na div 2 div n) \<or> \<not> nc div nb \<preceq> na div n"
      by (metis (no_types) masks.elims(2))

    {
      assume "\<exists>n. a div n div 2 ^ ka \<noteq> 0" then have "a div 2 ^ ka \<noteq> 0" using f2 by (metis div_0)
      then have "a div 2 div 2 ^ ka \<preceq> b div 2 div 2 ^ ka" using f3 a1 by meson
    }
    then have "a div (2 * 2 ^ ka) \<preceq> b div (2 * 2 ^ ka)"
      by (metis (no_types) div_mult2_eq masks.simps(1))
  }
  ultimately show ?case by simp
qed

lemma masks_digit_leq:"(a \<preceq> b) \<Longrightarrow> (nth_bit a k) \<le> (nth_bit b k)"
proof (induction k arbitrary: a b)
  case 0
  then show ?case
    by (metis add_cancel_left_right bitAND_nat.elims div_by_1 le0 masks.simps(2) power_0
              mod_mult_self1_is_0 mod_mult_self4 nth_bit_def)
next
  case (Suc k)
  then show ?case
    by (simp add: nth_bit_def)
       (metis div_mult2_eq masks_substr nth_bit_def pow.simps(1) power_numeral)
qed

lemma masks_leq_equiv:"(a \<preceq> b) \<longleftrightarrow> (\<forall>k. (nth_bit a k) \<le> (nth_bit b k))" (is "?P \<longleftrightarrow> ?Q")
proof
  assume "?P"
  then show "?Q" using masks_digit_leq by auto
next
  assume "?Q"
  then show "?P" using nth_bit_def
  proof (induct a b rule: masks.induct)
    case (1 uu)
    then show ?case by simp
  next
    case (2 v b)
    then show ?case by simp (metis drop_bit_Suc drop_bit_eq_div div_by_1 power.simps(1))
  qed
qed

lemma masks_leq:"a \<preceq> b \<longrightarrow> a \<le> b"
  using masks_leq_equiv bitwise_leq by simp

lemma mask_linear:
  fixes a b c d t :: nat
  assumes b: "b < (2::nat)^t"
  assumes d: "d < (2::nat)^t"
  shows "((a * 2^t + b \<preceq> c * 2^t + d) \<longleftrightarrow> (a \<preceq> c \<and> b \<preceq> d))" (is "?P \<longleftrightarrow> ?Q")
proof -
  have "?P \<longleftrightarrow> (\<forall>k. (a * 2^t + b) \<exclamdown> k \<le> (c * 2^t + d) \<exclamdown> k)" using masks_leq_equiv by auto
  also have "... \<longleftrightarrow> (\<forall>k. a \<exclamdown> k \<le> c \<exclamdown> k \<and> b \<exclamdown> k \<le> d \<exclamdown> k)" using b d digit_lt_linear by auto
  also have "... \<longleftrightarrow> a \<preceq> c \<and> b \<preceq> d" using masks_leq_equiv by auto
  finally show ?thesis by auto
qed

lemma aux1_lm0241_pow2_up_bound:"(\<exists>(p::nat). (a::nat) < 2^(Suc p))"
  by (induction a) (use less_exp in fastforce)+

lemma aux2_lm0241_single_digit_binom:
  assumes "1 \<ge> (a::nat)"
  assumes "1 \<ge> (b::nat)"
  shows "\<not>(a = 1 \<and> b = 1) \<longleftrightarrow> ((a + b) choose b) = 1" (is "?P \<longleftrightarrow> ?Q")
  using assms(1) assms(2)
  by (metis Suc_eq_plus1 add.commute add_cancel_right_left add_eq_if
              binomial_n_0 choose_one le_add2 le_antisym zero_neq_one)

lemma aux3_lm0241_binom_bounds:
  assumes "1 \<ge> (m::nat)"
  assumes "1 \<ge> (n::nat)"
  shows "1 \<ge> m choose n"
  using assms(1) assms(2) le_Suc_eq by auto

lemma aux4_lm0241_prod_one:
  fixes f::"(nat \<Rightarrow> nat)"
  assumes "(\<forall>x. (1 \<ge> f x))"
  shows "(\<Prod>k \<le> n. (f k)) = 1 \<longrightarrow> (\<forall>k. k \<le> n \<longrightarrow> f k = 1)" (is "?P \<longrightarrow> ?Q")
proof(rule ccontr)
  assume assm:"\<not>(?P \<longrightarrow> ?Q)"
  hence f_zero:"\<exists>r. r \<le> n \<and> f r \<noteq> 1" by simp
  then obtain r where "f r \<noteq> 1"  and "r \<le> n" by blast
  hence "f r = 0" using assms le_antisym not_less by blast
  hence contr:"(\<Prod>k \<le> n. f k) = 0" using \<open>r \<le> n\<close> by auto
  then show False using assm contr by simp
qed

lemma aux5_lm0241:
  "(\<forall>i. (nth_bit (a + b) i) choose (nth_bit b i) = 1) \<longrightarrow>
   \<not>(nth_bit a i = 1 \<and> nth_bit b i = 1)"
   (is "?P \<longrightarrow> ?Q i")
proof(rule ccontr)
  assume assm:"\<not>(?P \<longrightarrow> ?Q i)"
  hence "(\<exists>i. \<not>?Q i)" by blast
  then obtain i where contr:"\<not>?Q i" and i_minimal:"(\<forall>j < i. ?Q j)"
    using obtain_smallest[of \<open>\<lambda>i. \<not>?Q i\<close>] by auto
  hence "\<forall>j. j < i \<longrightarrow> nth_bit a j * nth_bit b j = 0" by (simp add: nth_bit_def)
  hence "\<forall>j. j < i \<longrightarrow> ((nth_bit a j = 0 \<and> nth_bit b j = 1) \<or>
                            (nth_bit a j = 1 \<and> nth_bit b j = 0) \<or>
                            (nth_bit a j = 0 \<and> nth_bit b j = 0))"
      by (auto simp add: nth_bit_def)
  hence "\<forall>j. j < i \<longrightarrow> nth_bit a j + nth_bit b j \<le> 1" by auto
  hence "bin_carry a b i = 0"
    using no_carry by (metis contr add_self_mod_2 assm choose_one one_neq_zero)
  hence f0:"nth_bit (a + b) i = (nth_bit a i + nth_bit b i) mod 2"
    by(auto simp add:sum_digit_formula)
  have "... = 0" using contr by auto
  hence "(nth_bit (a + b) i) choose (nth_bit b i) = 0" using f0 contr by auto
  then show False using assm by fastforce
qed

end


theory Matching
imports Main
begin

type_synonym label = nat

section \<open>Definitions\<close>

definition finite_graph :: "'v set => ('v * 'v) set \<Rightarrow> bool" where
  "finite_graph V E = (finite V \<and> finite E \<and>
  (\<forall> e \<in> E. fst e \<in> V \<and> snd e \<in> V \<and> fst e ~= snd e))"

definition degree :: "('v * 'v) set \<Rightarrow> 'v \<Rightarrow> nat" where
  "degree E v = card {e \<in> E. fst e = v \<or> snd e = v}"

definition edge_as_set :: "('v * 'v) \<Rightarrow> 'v set" where
  "edge_as_set e = {fst e, snd e}"

definition N :: "'v set \<Rightarrow> ('v \<Rightarrow> label) \<Rightarrow> nat \<Rightarrow> nat" where
  "N V L i = card {v \<in> V. L v = i}"

definition weight:: "label set \<Rightarrow> (label \<Rightarrow> nat) \<Rightarrow> nat" where
  "weight LV f = f 1 + (\<Sum>i\<in>LV. (f i) div 2)"

definition OSC :: "('v \<Rightarrow> label) \<Rightarrow> ('v * 'v) set \<Rightarrow> bool" where
  "OSC L E = (\<forall>e \<in> E. L (fst e) = 1 \<or> L (snd e) = 1 \<or>
                     L (fst e) = L (snd e) \<and> L (fst e) > 1)"

definition disjoint_edges :: "('v * 'v) \<Rightarrow> ('v * 'v) \<Rightarrow> bool" where
  "disjoint_edges e1 e2 = (fst e1 \<noteq> fst e2 \<and> fst e1 \<noteq> snd e2 \<and>
                          snd e1 \<noteq> fst e2 \<and> snd e1 \<noteq> snd e2)"

definition matching :: "'v set \<Rightarrow> ('v * 'v) set \<Rightarrow> ('v * 'v) set \<Rightarrow> bool" where
  "matching V E M = (M \<subseteq> E \<and> finite_graph V E \<and>
  (\<forall>e1 \<in> M. \<forall> e2 \<in> M. e1 \<noteq> e2 \<longrightarrow> disjoint_edges e1 e2))"

definition matching_i :: "nat \<Rightarrow> 'v set \<Rightarrow> ('v * 'v) set \<Rightarrow> ('v * 'v) set \<Rightarrow>
  ('v \<Rightarrow> label) \<Rightarrow> ('v * 'v) set" where
  "matching_i i V E M L = {e \<in> M. i=1 \<and> (L (fst e) = i \<or> L (snd e) = i)
  \<or> i>1 \<and> L (fst e) = i \<and> L (snd e) = i}"

definition V_i:: "nat \<Rightarrow> 'v set \<Rightarrow> ('v * 'v) set \<Rightarrow> ('v * 'v) set \<Rightarrow>
                  ('v \<Rightarrow> label) \<Rightarrow> 'v set" where
  "V_i i V E M L = \<Union> (edge_as_set ` matching_i i V E M L)"

definition endpoint_inV :: "'v set \<Rightarrow> ('v * 'v) \<Rightarrow> 'v" where
  "endpoint_inV V e = (if fst e \<in> V then fst e else snd e)"

definition relevant_endpoint :: "('v \<Rightarrow> label) \<Rightarrow> 'v set \<Rightarrow>
                                 ('v * 'v) \<Rightarrow> 'v" where
  "relevant_endpoint L V e = (if L (fst e) = 1 then fst e else snd e)"

section \<open>Lemmas\<close>

lemma definition_of_range:
  "endpoint_inV V1 ` matching_i 1 V E M L =
  { v. \<exists> e \<in> matching_i 1 V E M L. endpoint_inV V1 e = v }" by auto

lemma matching_i_edges_as_sets:
  "edge_as_set ` matching_i i V E M L =
  { e1. \<exists> (u, v) \<in> matching_i i V E M L. edge_as_set (u, v) = e1}" by auto

lemma matching_disjointness:
  assumes "matching V E M"
  assumes "e1 \<in> M"
  assumes "e2 \<in> M"
  assumes "e1 \<noteq> e2"
  shows  "edge_as_set e1 \<inter> edge_as_set e2 = {}"
  using assms
  by (auto simp add: edge_as_set_def disjoint_edges_def matching_def)

lemma expand_set_containment:
  assumes "matching V E M"
  assumes "e \<in> M"
  shows "e \<in> E"
  using assms
  by (auto simp add:matching_def)

theorem injectivity:
  assumes is_osc: "OSC L E"
  assumes is_m: "matching V E M"
  assumes e1_in_M1: "e1 \<in> matching_i 1 V E M L"
      and e2_in_M1: "e2 \<in> matching_i 1 V E M L"
  assumes diff: "(e1 \<noteq> e2)"
  shows "endpoint_inV {v \<in> V. L v = 1} e1 \<noteq> endpoint_inV {v \<in> V. L v = 1} e2"
proof -
  from e1_in_M1 have "e1 \<in> M" by (auto simp add: matching_i_def)
  moreover
  from e2_in_M1 have "e2 \<in> M" by (auto simp add: matching_i_def)
  ultimately
  have disjoint_edge_sets: "edge_as_set e1 \<inter> edge_as_set e2 = {}"
    using diff is_m matching_disjointness by fast
  then show ?thesis by (auto simp add: edge_as_set_def endpoint_inV_def)
qed

subsection \<open>\<open>|M1| \<le> n1\<close>\<close>

lemma card_M1_le_NVL1:
  assumes "matching V E M"
  assumes "OSC L E"
  shows "card (matching_i 1 V E M L) \<le> ( N V L 1)"
proof -
  let ?f = "endpoint_inV {v \<in> V. L v = 1}"
  let ?A = "matching_i 1 V E M L"
  let ?B = "{v \<in> V. L v = 1}"
  have "inj_on ?f ?A" using assms injectivity
    unfolding inj_on_def by blast
  moreover have "?f ` ?A \<subseteq> ?B"
  proof -
    {
      fix e assume "e \<in> matching_i 1 V E M L"
      then have "endpoint_inV {v \<in> V. L v = 1} e \<in> {v \<in> V. L v = 1}"
        using assms
        by (auto simp add: endpoint_inV_def matching_def
          matching_i_def OSC_def finite_graph_def definition_of_range)
    }
    then show ?thesis using assms definition_of_range by blast
  qed
  moreover have "finite ?B" using assms
    by (simp add: matching_def finite_graph_def)
  ultimately show ?thesis unfolding N_def by (rule card_inj_on_le)
qed

lemma edge_as_set_inj_on_Mi:
  assumes "matching V E M"
  shows "inj_on edge_as_set (matching_i i V E M L)"
  using assms
  unfolding inj_on_def edge_as_set_def matching_def
    disjoint_edges_def matching_i_def
  by blast

lemma card_Mi_eq_card_edge_as_set_Mi:
  assumes "matching V E M"
  shows "card (matching_i i V E M L) = card (edge_as_set` matching_i i V E M L)"
  (is "card ?Mi = card (?f ` _)")
proof -
  from assms have "bij_betw ?f ?Mi (?f ` ?Mi)"
    by (simp add: bij_betw_def matching_i_edges_as_sets edge_as_set_inj_on_Mi)
  then show ?thesis by (rule bij_betw_same_card)
qed

lemma card_edge_as_set_Mi_twice_card_partitions:
  assumes "OSC L E \<and> matching V E M \<and> i > 1"
  shows "2 * card (edge_as_set`matching_i i V E M L)
  = card (V_i i V E M L)" (is "2 * card ?C = card ?Vi")
proof -
  from assms have 1: "finite (\<Union> ?C)"
    by (auto simp add: matching_def finite_graph_def
      matching_i_def edge_as_set_def finite_subset)
  show ?thesis unfolding V_i_def
  proof (rule card_partition)
    show "finite ?C" using 1 by (rule finite_UnionD)
  next
    show "finite (\<Union> ?C)" using 1 .
  next
    fix c assume "c \<in> ?C" then show "card c = 2"
    proof (rule imageE)
      fix x
      assume 2: "c = edge_as_set x" and 3: "x \<in> matching_i i V E M L"
      with assms have "x \<in> E"
        unfolding matching_i_def matching_def by blast
      then have "fst x \<noteq> snd x" using assms 3
        by (auto simp add: matching_def finite_graph_def)
      with 2 show ?thesis by (auto simp add: edge_as_set_def)
    qed
  next
    fix x1 x2
    assume 4: "x1 \<in> ?C" and 5: "x2 \<in> ?C" and 6: "x1 \<noteq> x2"
    {
      fix e1 e2
      assume 7: "x1 = edge_as_set e1" "e1 \<in> matching_i i V E M L"
        "x2 = edge_as_set e2" "e2 \<in> matching_i i V E M L"
      from assms have "matching V E M" by simp
      moreover
      from 7 assms have "e1 \<in> M" and "e2 \<in> M"
        by (simp_all add: matching_i_def)
      moreover from 6 7 have "e1 \<noteq> e2" by blast
      ultimately have "x1 \<inter> x2 = {}" unfolding 7
        by (rule matching_disjointness)
    }
    with 4 5 show "x1 \<inter> x2 = {}" by clarsimp
  qed
qed

lemma card_Mi_twice_card_Vi:
  assumes "OSC L E \<and> matching V E M \<and> i > 1"
  shows "2 * card (matching_i i V E M L) = card (V_i i V E M L)"
proof -
  from assms have "finite (V_i i V E M L)"
    by (auto simp add: edge_as_set_def finite_subset
      matching_def finite_graph_def V_i_def matching_i_def )
  with assms show ?thesis
    by (simp add: card_Mi_eq_card_edge_as_set_Mi
      card_edge_as_set_Mi_twice_card_partitions V_i_def)
qed

lemma card_Mi_le_floor_div_2_Vi:
  assumes "OSC L E \<and> matching V E M \<and> i > 1"
  shows "card (matching_i i V E M L) \<le> (card (V_i i V E M L)) div 2"
  using card_Mi_twice_card_Vi[OF assms]
  by arith

lemma card_Vi_le_NVLi:
  assumes "i>1 \<and> matching V E M"
  shows "card (V_i i V E M L) \<le> N V L i"
  unfolding N_def
proof (rule card_mono)
  show "finite {v \<in> V. L v = i}" using assms
    by (simp add: matching_def finite_graph_def)
next
  let ?A = "edge_as_set ` matching_i i V E M L"
  let ?C = "{v \<in> V. L v = i}"
  show "V_i i V E M L \<subseteq> ?C" using assms unfolding V_i_def
  proof (intro Union_least)
    fix X assume "X \<in> ?A"
    with assms have "\<exists>x \<in> matching_i i V E M L. edge_as_set x = X"
      by (simp add: matching_i_edges_as_sets)
    with assms show "X \<subseteq> ?C"
      unfolding finite_graph_def matching_def
        matching_i_def edge_as_set_def by blast
  qed
qed

subsection \<open>\<open>|Mi| \<le> \<lfloor>ni/2\<rfloor>\<close>\<close>

lemma card_Mi_le_floor_div_2_NVLi:
  assumes "OSC L E \<and> matching V E M \<and> i > 1"
  shows "card (matching_i i V E M L) \<le> (N V L i) div 2"
proof -
  from assms have "card (V_i i V E M L) \<le> (N V L i)"
    by (simp add: card_Vi_le_NVLi)
  then have "card (V_i i V E M L) div 2 \<le> (N V L i) div 2"
    by simp
  moreover from assms have
    "card (matching_i i V E M L) \<le> card (V_i i V E M L) div 2"
    by (intro card_Mi_le_floor_div_2_Vi)
  ultimately show ?thesis by auto
qed
subsection \<open>\<open>|M| \<le> \<Sum>|Mi|\<close>\<close>
lemma card_M_le_sum_card_Mi:
assumes "matching V E M" and "OSC L E"
shows "card M \<le> (\<Sum> i \<in> L`V. card (matching_i i V E M L))"
  (is "card _ \<le> ?CardMi")
proof -
  let ?UnMi = "\<Union>x \<in> L`V. matching_i x V E M L"
  from assms have 1: "finite ?UnMi"
    by (auto simp add: matching_def
      finite_graph_def matching_i_def finite_subset)
  {
    fix e assume e_inM: "e \<in> M"
    let ?v = "relevant_endpoint L V e"
    have 1: "e \<in> matching_i (L ?v) V E M L" using assms e_inM
      proof cases
        assume "L (fst e) = 1"
        thus ?thesis using assms e_inM
          by (simp add: relevant_endpoint_def matching_i_def)
      next
        assume a: "L (fst e) \<noteq> 1"
        have "L (fst e) = 1 \<or> L (snd e) = 1
          \<or>  (L (fst e) = L (snd e) \<and> L (fst e) >1)"
          using assms e_inM unfolding OSC_def
          by (blast intro: expand_set_containment)
        thus ?thesis using assms e_inM a
          by (auto simp add: relevant_endpoint_def matching_i_def)
      qed
      have 2: "?v \<in> V" using assms e_inM
        by (auto simp add: matching_def
          relevant_endpoint_def matching_i_def finite_graph_def)
      then have "\<exists> v \<in> V. e \<in> matching_i (L v) V E M L" using assms 1 2
        by (intro bexI)
    }
    with assms have "M \<subseteq> ?UnMi" by (auto)
    with assms and 1 have "card M \<le> card ?UnMi" by (intro card_mono)
    moreover from assms have "card ?UnMi = ?CardMi"
    proof (intro card_UN_disjoint)
      show "finite (L`V)" using assms
        by (simp add: matching_def finite_graph_def)
    next
      show "\<forall>i\<in>L`V. finite (matching_i i V E M L)" using assms
        unfolding matching_def finite_graph_def matching_i_def
        by (blast intro: finite_subset)
    next
      show "\<forall>i \<in> L`V. \<forall>j \<in> L`V. i \<noteq> j \<longrightarrow>
        matching_i i V E M L \<inter> matching_i j V E M L = {}" using assms
        by (auto simp add: matching_i_def)
    qed
  ultimately show ?thesis by simp
qed

theorem card_M_le_weight_NVLi:
  assumes "matching V E M" and "OSC L E"
  shows "card M \<le> weight {i \<in> L ` V. i > 1} (N V L)" (is "_ \<le> ?W")
proof -
  let ?M01 = "\<Sum>i| i \<in> L`V \<and> (i=1 \<or> i=0). card (matching_i i V E M L)"
  let ?Mgr1 = "\<Sum>i| i \<in> L`V \<and> 1 < i. card (matching_i i V E M L)"
  let ?Mi = "\<Sum> i\<in>L`V. card (matching_i i V E M L)"
  have "card M \<le> ?Mi" using assms by (rule card_M_le_sum_card_Mi)
  moreover
  have "?Mi \<le> ?W"
  proof -
    let ?A = "{i \<in> L ` V. i = 1 \<or> i = 0}"
    let ?B = "{i \<in> L ` V. 1 < i}"
    let ?g = "\<lambda> i. card (matching_i i V E M L)"
    let ?set01 = "{ i. i : L ` V & (i = 1 | i = 0)}"
    have a: "L ` V = ?A \<union> ?B" using assms by auto
    have "finite V" using assms
      by (simp add: matching_def finite_graph_def)
    have b: "sum ?g (?A \<union> ?B) = sum ?g ?A + sum ?g ?B"
      using assms \<open>finite V\<close> by (auto intro: sum.union_disjoint)
    have 1: "?Mi = ?M01+ ?Mgr1" using assms a b
      by (simp add: matching_def finite_graph_def)
    moreover
    have 0: "card (matching_i 0 V E M L) = 0" using assms
      by (simp add: matching_i_def)
      have 2: "?M01 \<le> N V L 1"
      proof cases
        assume a: "1 \<in> L`V"
        have "?M01 = card (matching_i 1 V E M L)"
        proof cases
          assume b: "0 \<in> L`V"
          with a assms have  "?set01 = {0, 1}" by blast
          thus ?thesis using assms 0 by simp
        next
          assume b: "0 \<notin> L`V"
          with a have "?set01 = {1}" by (auto simp del:One_nat_def)
          thus ?thesis by simp
        qed
        thus ?thesis using assms a
          by (simp del: One_nat_def, intro card_M1_le_NVL1)
      next
        assume a: "1 \<notin> L`V"
        show ?thesis
        proof cases
          assume b: "0 \<in> L`V"
          with a assms have  "?set01 = {0}" by (auto simp del:One_nat_def)
          thus ?thesis using assms 0 by auto
        next
          assume b: "0 \<notin> L`V"
          with a have "?set01 = {}" by (auto simp del:One_nat_def)
            then have "?M01 = (\<Sum>i\<in>{}. card (matching_i i V E M L))" by auto
            thus ?thesis by simp
          qed
        qed
      moreover
      have 3: "?Mgr1 \<le> (\<Sum>i|i\<in>L`V \<and> 1 < i. N V L i div 2)" using assms
        by (intro sum_mono card_Mi_le_floor_div_2_NVLi, simp)
    ultimately
    show ?thesis using 1 2 3 assms by (simp add: weight_def)
  qed
  ultimately show ?thesis by simp
qed

section \<open>Final Theorem\<close>
text\<open>The following theorem is due to Edmond~\cite{Edmonds:matching}:\<close>

theorem maximum_cardinality_matching:
  assumes "matching V E M" and "OSC L E"
  and "card M = weight {i \<in> L ` V. i > 1} (N V L)"
  and "matching V E M'"
  shows "card M' \<le> card M"
  using assms card_M_le_weight_NVLi
  by simp

text\<open>The widely used algorithmic library LEDA has a certifying algorithm for maximum cardinality matching.
This Isabelle proof is part of the work done to verify the checker of this certifying algorithm. For more information see \cite{VerificationofCertifyingComputations}.\<close>
end


theory Chapter13_7
imports "HOL-IMP.Abs_Int2" "Short_Theory"
begin

text{*
\setcounter{exercise}{15}
\exercise
Give a readable proof that if @{text "\<gamma> ::"} \noquotes{@{typ[source]"'a::lattice \<Rightarrow> 'b::lattice"}}
is a monotone function, then @{prop "\<gamma> (a\<^sub>1 \<sqinter> a\<^sub>2) \<le> \<gamma> a\<^sub>1 \<sqinter> \<gamma> a\<^sub>2"}:
*}

lemma fixes \<gamma> :: "'a::lattice \<Rightarrow> 'b :: lattice"
assumes mono: "\<And>x y. x \<le> y \<Longrightarrow> \<gamma> x \<le> \<gamma> y"
shows "\<gamma> (a\<^sub>1 \<sqinter> a\<^sub>2) \<le> \<gamma> a\<^sub>1 \<sqinter> \<gamma> a\<^sub>2"
(* your definition/proof here *)

text{*
Give an example of two lattices and a monotone @{text \<gamma>}
where @{prop"\<gamma> a\<^sub>1 \<sqinter> \<gamma> a\<^sub>2 \<le> \<gamma> (a\<^sub>1 \<sqinter> a\<^sub>2)"} does not hold.
*}

text{*
\endexercise

\exercise
Consider a simple sign analysis based on this abstract domain:
*}

datatype sign = None | Neg | Pos0 | Any

fun \<gamma> :: "sign \<Rightarrow> val set" where
"\<gamma> None = {}" |
"\<gamma> Neg = {i. i < 0}" |
"\<gamma> Pos0 = {i. i \<ge> 0}" |
"\<gamma> Any = UNIV"

text{*
Define inverse analyses for ``@{text"+"}'' and ``@{text"<"}''
and prove the required correctness properties:
*}

fun inv_plus' :: "sign \<Rightarrow> sign \<Rightarrow> sign \<Rightarrow> sign * sign" where
(* your definition/proof here *)

lemma
  "\<lbrakk> inv_plus' a a1 a2 = (a1',a2');  i1 \<in> \<gamma> a1;  i2 \<in> \<gamma> a2; i1+i2 \<in> \<gamma> a \<rbrakk>
  \<Longrightarrow> i1 \<in> \<gamma> a1' \<and> i2 \<in> \<gamma> a2' "
(* your definition/proof here *)

fun inv_less' :: "bool \<Rightarrow> sign \<Rightarrow> sign \<Rightarrow> sign * sign" where
(* your definition/proof here *)

lemma
  "\<lbrakk> inv_less' bv a1 a2 = (a1',a2');  i1 \<in> \<gamma> a1;  i2 \<in> \<gamma> a2; (i1<i2) = bv \<rbrakk>
  \<Longrightarrow> i1 \<in> \<gamma> a1' \<and> i2 \<in> \<gamma> a2'"
(* your definition/proof here *)

text{*
\indent
For the ambitious: turn the above fragment into a full-blown abstract interpreter
by replacing the interval analysis in theory @{short_theory "Abs_Int2"}@{text"_ivl"}
by a sign analysis.
\endexercise
*}

end


(*  Title:      HOL/Number_Theory/Residues.thy
    Author:     Jeremy Avigad

An algebraic treatment of residue rings, and resulting proofs of
Euler's theorem and Wilson's theorem.
*)

section \<open>Residue rings\<close>

theory Residues
imports
  Cong
  "HOL-Algebra.Multiplicative_Group"
  Totient
begin

definition QuadRes :: "int \<Rightarrow> int \<Rightarrow> bool"
  where "QuadRes p a = (\<exists>y. ([y^2 = a] (mod p)))"

definition Legendre :: "int \<Rightarrow> int \<Rightarrow> int"
  where "Legendre a p =
    (if ([a = 0] (mod p)) then 0
     else if QuadRes p a then 1
     else -1)"

subsection \<open>A locale for residue rings\<close>

definition residue_ring :: "int \<Rightarrow> int ring"
  where
    "residue_ring m =
      \<lparr>carrier = {0..m - 1},
       monoid.mult = \<lambda>x y. (x * y) mod m,
       one = 1,
       zero = 0,
       add = \<lambda>x y. (x + y) mod m\<rparr>"

locale residues =
  fixes m :: int and R (structure)
  assumes m_gt_one: "m > 1"
  defines "R \<equiv> residue_ring m"
begin

lemma abelian_group: "abelian_group R"
proof -
  have "\<exists>y\<in>{0..m - 1}. (x + y) mod m = 0" if "0 \<le> x" "x < m" for x
  proof (cases "x = 0")
    case True
    with m_gt_one show ?thesis by simp
  next
    case False
    then have "(x + (m - x)) mod m = 0"
      by simp
    with m_gt_one that show ?thesis
      by (metis False atLeastAtMost_iff diff_ge_0_iff_ge diff_left_mono int_one_le_iff_zero_less less_le)
  qed
  with m_gt_one show ?thesis
    by (fastforce simp add: R_def residue_ring_def mod_add_right_eq ac_simps  intro!: abelian_groupI)
qed

lemma comm_monoid: "comm_monoid R"
  unfolding R_def residue_ring_def
  apply (rule comm_monoidI)
    using m_gt_one  apply auto
  apply (metis mod_mult_right_eq mult.assoc mult.commute)
  apply (metis mult.commute)
  done

lemma cring: "cring R"
  apply (intro cringI abelian_group comm_monoid)
  unfolding R_def residue_ring_def
  apply (auto simp add: comm_semiring_class.distrib mod_add_eq mod_mult_left_eq)
  done

end

sublocale residues < cring
  by (rule cring)

context residues
begin

text \<open>
  These lemmas translate back and forth between internal and
  external concepts.
\<close>

lemma res_carrier_eq: "carrier R = {0..m - 1}"
  by (auto simp: R_def residue_ring_def)

lemma res_add_eq: "x \<oplus> y = (x + y) mod m"
  by (auto simp: R_def residue_ring_def)

lemma res_mult_eq: "x \<otimes> y = (x * y) mod m"
  by (auto simp: R_def residue_ring_def)

lemma res_zero_eq: "\<zero> = 0"
  by (auto simp: R_def residue_ring_def)

lemma res_one_eq: "\<one> = 1"
  by (auto simp: R_def residue_ring_def units_of_def)

lemma res_units_eq: "Units R = {x. 0 < x \<and> x < m \<and> coprime x m}"
  using m_gt_one
  apply (auto simp add: Units_def R_def residue_ring_def ac_simps invertible_coprime intro: ccontr)
  apply (subst (asm) coprime_iff_invertible'_int)
   apply (auto simp add: cong_def)
  done

lemma res_neg_eq: "\<ominus> x = (- x) mod m"
  using m_gt_one unfolding R_def a_inv_def m_inv_def residue_ring_def
  apply simp
  apply (rule the_equality)
   apply (simp add: mod_add_right_eq)
   apply (simp add: add.commute mod_add_right_eq)
  apply (metis add.right_neutral minus_add_cancel mod_add_right_eq mod_pos_pos_trivial)
  done

lemma finite [iff]: "finite (carrier R)"
  by (simp add: res_carrier_eq)

lemma finite_Units [iff]: "finite (Units R)"
  by (simp add: finite_ring_finite_units)

text \<open>
  The function \<open>a \<mapsto> a mod m\<close> maps the integers to the
  residue classes. The following lemmas show that this mapping
  respects addition and multiplication on the integers.
\<close>

lemma mod_in_carrier [iff]: "a mod m \<in> carrier R"
  unfolding res_carrier_eq
  using insert m_gt_one by auto

lemma add_cong: "(x mod m) \<oplus> (y mod m) = (x + y) mod m"
  by (auto simp: R_def residue_ring_def mod_simps)

lemma mult_cong: "(x mod m) \<otimes> (y mod m) = (x * y) mod m"
  by (auto simp: R_def residue_ring_def mod_simps)

lemma zero_cong: "\<zero> = 0"
  by (auto simp: R_def residue_ring_def)

lemma one_cong: "\<one> = 1 mod m"
  using m_gt_one by (auto simp: R_def residue_ring_def)

(* FIXME revise algebra library to use 1? *)
lemma pow_cong: "(x mod m) [^] n = x^n mod m"
  using m_gt_one
  apply (induct n)
  apply (auto simp add: nat_pow_def one_cong)
  apply (metis mult.commute mult_cong)
  done

lemma neg_cong: "\<ominus> (x mod m) = (- x) mod m"
  by (metis mod_minus_eq res_neg_eq)

lemma (in residues) prod_cong: "finite A \<Longrightarrow> (\<Otimes>i\<in>A. (f i) mod m) = (\<Prod>i\<in>A. f i) mod m"
  by (induct set: finite) (auto simp: one_cong mult_cong)

lemma (in residues) sum_cong: "finite A \<Longrightarrow> (\<Oplus>i\<in>A. (f i) mod m) = (\<Sum>i\<in>A. f i) mod m"
  by (induct set: finite) (auto simp: zero_cong add_cong)

lemma mod_in_res_units [simp]:
  assumes "1 < m" and "coprime a m"
  shows "a mod m \<in> Units R"
proof (cases "a mod m = 0")
  case True
  with assms show ?thesis
    by (auto simp add: res_units_eq gcd_red_int [symmetric])
next
  case False
  from assms have "0 < m" by simp
  then have "0 \<le> a mod m" by (rule pos_mod_sign [of m a])
  with False have "0 < a mod m" by simp
  with assms show ?thesis
    by (auto simp add: res_units_eq gcd_red_int [symmetric] ac_simps)
qed

lemma res_eq_to_cong: "(a mod m) = (b mod m) \<longleftrightarrow> [a = b] (mod m)"
  by (auto simp: cong_def)

text \<open>Simplifying with these will translate a ring equation in R to a congruence.\<close>
lemmas res_to_cong_simps =
  add_cong mult_cong pow_cong one_cong
  prod_cong sum_cong neg_cong res_eq_to_cong

text \<open>Other useful facts about the residue ring.\<close>
lemma one_eq_neg_one: "\<one> = \<ominus> \<one> \<Longrightarrow> m = 2"
  apply (simp add: res_one_eq res_neg_eq)
  apply (metis add.commute add_diff_cancel mod_mod_trivial one_add_one uminus_add_conv_diff
    zero_neq_one zmod_zminus1_eq_if)
  done

end

subsection \<open>Prime residues\<close>

locale residues_prime =
  fixes p :: nat and R (structure)
  assumes p_prime [intro]: "prime p"
  defines "R \<equiv> residue_ring (int p)"

sublocale residues_prime < residues p
  unfolding R_def residues_def
  using p_prime apply auto
  apply (metis (full_types) of_nat_1 of_nat_less_iff prime_gt_1_nat)
  done

context residues_prime
begin

lemma p_coprime_left:
  "coprime p a \<longleftrightarrow> \<not> p dvd a"
  using p_prime by (auto intro: prime_imp_coprime dest: coprime_common_divisor)

lemma p_coprime_right:
  "coprime a p  \<longleftrightarrow> \<not> p dvd a"
  using p_coprime_left [of a] by (simp add: ac_simps)

lemma p_coprime_left_int:
  "coprime (int p) a \<longleftrightarrow> \<not> int p dvd a"
  using p_prime by (auto intro: prime_imp_coprime dest: coprime_common_divisor)

lemma p_coprime_right_int:
  "coprime a (int p) \<longleftrightarrow> \<not> int p dvd a"
  using p_coprime_left_int [of a] by (simp add: ac_simps)

lemma is_field: "field R"
proof -
  have "0 < x \<Longrightarrow> x < int p \<Longrightarrow> coprime (int p) x" for x
    by (rule prime_imp_coprime) (auto simp add: zdvd_not_zless)
  then show ?thesis
    by (intro cring.field_intro2 cring)
      (auto simp add: res_carrier_eq res_one_eq res_zero_eq res_units_eq ac_simps)
qed

lemma res_prime_units_eq: "Units R = {1..p - 1}"
  apply (subst res_units_eq)
  apply (auto simp add: p_coprime_right_int zdvd_not_zless)
  done

end

sublocale residues_prime < field
  by (rule is_field)

section \<open>Test cases: Euler's theorem and Wilson's theorem\<close>

subsection \<open>Euler's theorem\<close>

lemma (in residues) totatives_eq:
  "totatives (nat m) = nat ` Units R"
proof -
  from m_gt_one have "\<bar>m\<bar> > 1"
    by simp
  then have "totatives (nat \<bar>m\<bar>) = nat ` abs ` Units R"
    by (auto simp add: totatives_def res_units_eq image_iff le_less)
      (use m_gt_one zless_nat_eq_int_zless in force)
  moreover have "\<bar>m\<bar> = m" "abs ` Units R = Units R"
    using m_gt_one by (auto simp add: res_units_eq image_iff)
  ultimately show ?thesis
    by simp
qed

lemma (in residues) totient_eq:
  "totient (nat m) = card (Units R)"
proof  -
  have *: "inj_on nat (Units R)"
    by (rule inj_onI) (auto simp add: res_units_eq)
  then show ?thesis
    by (simp add: totient_def totatives_eq card_image)
qed

lemma (in residues_prime) totient_eq: "totient p = p - 1"
  using totient_eq by (simp add: res_prime_units_eq)

lemma (in residues) euler_theorem:
  assumes "coprime a m"
  shows "[a ^ totient (nat m) = 1] (mod m)"
proof -
  have "a ^ totient (nat m) mod m = 1 mod m"
    by (metis assms finite_Units m_gt_one mod_in_res_units one_cong totient_eq pow_cong units_power_order_eq_one)
  then show ?thesis
    using res_eq_to_cong by blast
qed

lemma euler_theorem:
  fixes a m :: nat
  assumes "coprime a m"
  shows "[a ^ totient m = 1] (mod m)"
proof (cases "m = 0 \<or> m = 1")
  case True
  then show ?thesis by auto
next
  case False
  with assms show ?thesis
    using residues.euler_theorem [of "int m" "int a"] cong_int_iff
    by (auto simp add: residues_def gcd_int_def) fastforce
qed

lemma fermat_theorem:
  fixes p a :: nat
  assumes "prime p" and "\<not> p dvd a"
  shows "[a ^ (p - 1) = 1] (mod p)"
proof -
  from assms prime_imp_coprime [of p a] have "coprime a p"
    by (auto simp add: ac_simps)
  then have "[a ^ totient p = 1] (mod p)"
     by (rule euler_theorem)
  also have "totient p = p - 1"
    by (rule totient_prime) (rule assms)
  finally show ?thesis .
qed

subsection \<open>Wilson's theorem\<close>

lemma (in field) inv_pair_lemma: "x \<in> Units R \<Longrightarrow> y \<in> Units R \<Longrightarrow>
    {x, inv x} \<noteq> {y, inv y} \<Longrightarrow> {x, inv x} \<inter> {y, inv y} = {}"
  apply auto
  apply (metis Units_inv_inv)+
  done

lemma (in residues_prime) wilson_theorem1:
  assumes a: "p > 2"
  shows "[fact (p - 1) = (-1::int)] (mod p)"
proof -
  let ?Inverse_Pairs = "{{x, inv x}| x. x \<in> Units R - {\<one>, \<ominus> \<one>}}"
  have UR: "Units R = {\<one>, \<ominus> \<one>} \<union> \<Union>?Inverse_Pairs"
    by auto
  have "(\<Otimes>i\<in>Units R. i) = (\<Otimes>i\<in>{\<one>, \<ominus> \<one>}. i) \<otimes> (\<Otimes>i\<in>\<Union>?Inverse_Pairs. i)"
    apply (subst UR)
    apply (subst finprod_Un_disjoint)
         apply (auto intro: funcsetI)
    using inv_one apply auto[1]
    using inv_eq_neg_one_eq apply auto
    done
  also have "(\<Otimes>i\<in>{\<one>, \<ominus> \<one>}. i) = \<ominus> \<one>"
    apply (subst finprod_insert)
        apply auto
    apply (frule one_eq_neg_one)
    using a apply force
    done
  also have "(\<Otimes>i\<in>(\<Union>?Inverse_Pairs). i) = (\<Otimes>A\<in>?Inverse_Pairs. (\<Otimes>y\<in>A. y))"
    apply (subst finprod_Union_disjoint)
       apply (auto simp: pairwise_def disjnt_def)
     apply (metis Units_inv_inv)+
    done
  also have "\<dots> = \<one>"
    apply (rule finprod_one_eqI)
     apply auto
    apply (subst finprod_insert)
        apply auto
    apply (metis inv_eq_self)
    done
  finally have "(\<Otimes>i\<in>Units R. i) = \<ominus> \<one>"
    by simp
  also have "(\<Otimes>i\<in>Units R. i) = (\<Otimes>i\<in>Units R. i mod p)"
    by (rule finprod_cong') (auto simp: res_units_eq)
  also have "\<dots> = (\<Prod>i\<in>Units R. i) mod p"
    by (rule prod_cong) auto
  also have "\<dots> = fact (p - 1) mod p"
    apply (simp add: fact_prod)
    using assms
    apply (subst res_prime_units_eq)
    apply (simp add: int_prod zmod_int prod_int_eq)
    done
  finally have "fact (p - 1) mod p = \<ominus> \<one>" .
  then show ?thesis
    by (simp add: cong_def res_neg_eq res_one_eq zmod_int)
qed

lemma wilson_theorem:
  assumes "prime p"
  shows "[fact (p - 1) = - 1] (mod p)"
proof (cases "p = 2")
  case True
  then show ?thesis
    by (simp add: cong_def fact_prod)
next
  case False
  then show ?thesis
    using assms prime_ge_2_nat
    by (metis residues_prime.wilson_theorem1 residues_prime.intro le_eq_less_or_eq)
qed

text \<open>
  This result can be transferred to the multiplicative group of
  \<open>\<int>/p\<int>\<close> for \<open>p\<close> prime.\<close>

lemma mod_nat_int_pow_eq:
  fixes n :: nat and p a :: int
  shows "a \<ge> 0 \<Longrightarrow> p \<ge> 0 \<Longrightarrow> (nat a ^ n) mod (nat p) = nat ((a ^ n) mod p)"
  by (simp add: int_one_le_iff_zero_less nat_mod_distrib order_less_imp_le nat_power_eq[symmetric])

theorem residue_prime_mult_group_has_gen:
 fixes p :: nat
 assumes prime_p : "prime p"
 shows "\<exists>a \<in> {1 .. p - 1}. {1 .. p - 1} = {a^i mod p|i . i \<in> UNIV}"
proof -
  have "p \<ge> 2"
    using prime_gt_1_nat[OF prime_p] by simp
  interpret R: residues_prime p "residue_ring p"
    by (simp add: residues_prime_def prime_p)
  have car: "carrier (residue_ring (int p)) - {\<zero>\<^bsub>residue_ring (int p)\<^esub>} = {1 .. int p - 1}"
    by (auto simp add: R.zero_cong R.res_carrier_eq)

  have "x [^]\<^bsub>residue_ring (int p)\<^esub> i = x ^ i mod (int p)"
    if "x \<in> {1 .. int p - 1}" for x and i :: nat
    using that R.pow_cong[of x i] by auto
  moreover
  obtain a where a: "a \<in> {1 .. int p - 1}"
    and a_gen: "{1 .. int p - 1} = {a[^]\<^bsub>residue_ring (int p)\<^esub>i|i::nat . i \<in> UNIV}"
    using field.finite_field_mult_group_has_gen[OF R.is_field]
    by (auto simp add: car[symmetric] carrier_mult_of)
  moreover
  have "nat ` {1 .. int p - 1} = {1 .. p - 1}" (is "?L = ?R")
  proof
    have "n \<in> ?R" if "n \<in> ?L" for n
      using that \<open>p\<ge>2\<close> by force
    then show "?L \<subseteq> ?R" by blast
    have "n \<in> ?L" if "n \<in> ?R" for n
      using that \<open>p\<ge>2\<close> by (auto intro: rev_image_eqI [of "int n"])
    then show "?R \<subseteq> ?L" by blast
  qed
  moreover
  have "nat ` {a^i mod (int p) | i::nat. i \<in> UNIV} = {nat a^i mod p | i . i \<in> UNIV}" (is "?L = ?R")
  proof
    have "x \<in> ?R" if "x \<in> ?L" for x
    proof -
      from that obtain i where i: "x = nat (a^i mod (int p))"
        by blast
      then have "x = nat a ^ i mod p"
        using mod_nat_int_pow_eq[of a "int p" i] a \<open>p\<ge>2\<close> by auto
      with i show ?thesis by blast
    qed
    then show "?L \<subseteq> ?R" by blast
    have "x \<in> ?L" if "x \<in> ?R" for x
    proof -
      from that obtain i where i: "x = nat a^i mod p"
        by blast
      with mod_nat_int_pow_eq[of a "int p" i] a \<open>p\<ge>2\<close> show ?thesis
        by auto
    qed
    then show "?R \<subseteq> ?L" by blast
  qed
  ultimately have "{1 .. p - 1} = {nat a^i mod p | i. i \<in> UNIV}"
    by presburger
  moreover from a have "nat a \<in> {1 .. p - 1}" by force
  ultimately show ?thesis ..
qed

subsection \<open>Upper bound for the number of $n$-th roots\<close>

lemma roots_mod_prime_bound:
  fixes n c p :: nat
  assumes "prime p" "n > 0"
  defines "A \<equiv> {x\<in>{..<p}. [x ^ n = c] (mod p)}"
  shows   "card A \<le> n"
proof -
  define R where "R = residue_ring (int p)"
  from assms(1) interpret residues_prime p R
    by unfold_locales (simp_all add: R_def)
  interpret R: UP_domain R "UP R" by (unfold_locales)

  let ?f = "UnivPoly.monom (UP R) \<one>\<^bsub>R\<^esub> n \<ominus>\<^bsub>(UP R)\<^esub> UnivPoly.monom (UP R) (int (c mod p)) 0"
  have in_carrier: "int (c mod p) \<in> carrier R"
    using prime_gt_1_nat[OF assms(1)] by (simp add: R_def residue_ring_def)

  have "deg R ?f = n"
    using assms in_carrier by (simp add: R.deg_minus_eq)
  hence f_not_zero: "?f \<noteq> \<zero>\<^bsub>UP R\<^esub>" using assms by (auto simp add : R.deg_nzero_nzero)
  have roots_bound: "finite {a \<in> carrier R. UnivPoly.eval R R id a ?f = \<zero>\<^bsub>R\<^esub>} \<and>
                     card {a \<in> carrier R. UnivPoly.eval R R id a ?f = \<zero>\<^bsub>R\<^esub>} \<le> deg R ?f"
                    using finite in_carrier by (intro R.roots_bound[OF _ f_not_zero]) simp
  have subs: "{x \<in> carrier R. x [^]\<^bsub>R\<^esub> n = int (c mod p)} \<subseteq>
                {a \<in> carrier R. UnivPoly.eval R R id a ?f = \<zero>\<^bsub>R\<^esub>}"
    using in_carrier by (auto simp: R.evalRR_simps)
  then have "card {x \<in> carrier R. x [^]\<^bsub>R\<^esub> n = int (c mod p)} \<le>
               card {a \<in> carrier R. UnivPoly.eval R R id a ?f = \<zero>\<^bsub>R\<^esub>}"
    using finite by (intro card_mono) auto
  also have "\<dots> \<le> n"
    using \<open>deg R ?f = n\<close> roots_bound by linarith
  also {
    fix x assume "x \<in> carrier R"
    hence "x [^]\<^bsub>R\<^esub> n = (x ^ n) mod (int p)"
      by (subst pow_cong [symmetric]) (auto simp: R_def residue_ring_def)
  }
  hence "{x \<in> carrier R. x [^]\<^bsub>R\<^esub> n = int (c mod p)} = {x \<in> carrier R. [x ^ n = int c] (mod p)}"
    by (fastforce simp: cong_def zmod_int)
  also have "bij_betw int A {x \<in> carrier R. [x ^ n = int c] (mod p)}"
    by (rule bij_betwI[of int _ _ nat])
       (use cong_int_iff in \<open>force simp: R_def residue_ring_def A_def\<close>)+
  from bij_betw_same_card[OF this] have "card {x \<in> carrier R. [x ^ n = int c] (mod p)} = card A" ..
  finally show ?thesis .
qed

end


section \<open>Challenge 2.A\<close>
theory Challenge2A
imports "lib/VTcomp"
begin

text \<open>Problem definition:
\<^url>\<open>https://ethz.ch/content/dam/ethz/special-interest/infk/chair-program-method/pm/documents/Verify%20This/Challenges%202019/cartesian_trees.pdf\<close>\<close>

text \<open>Polished and worked-over version.\<close>

subsection \<open>Specification\<close>

text \<open>We first fix the input, a list of integers\<close>
context fixes xs :: "int list" begin

text \<open>We then specify the desired output:
  For each index \<open>j\<close>, return the greatest index \<open>i<j\<close> such that \<open>xs!i < xs!j\<close>, or \<open>None\<close> if
  no such index exists.

  Note that our indexes start at zero, and we use an option datatype to model that
  no left-smaller value may exists.
\<close>
definition
  "left_spec j = (if (\<exists>i<j. xs ! i < xs ! j) then Some (GREATEST i. i < j \<and> xs ! i < xs ! j) else None)"

text \<open>The output of the algorithm should be an array \<open>lf\<close>, containing the indexes of the
  left-smaller values:
\<close>
definition "all_left_spec lf \<equiv> length lf = length xs \<and> (\<forall>i<length xs. lf!i = left_spec i)"

subsection \<open>Auxiliary Theory\<close>
text \<open>We derive some theory specific to this algorithm\<close>

subsubsection \<open>Has-Left and The-Left\<close>
text \<open>We split the specification of nearest left value into a predicate and a total function\<close>
definition "has_left j = (\<exists>i<j. xs ! i < xs ! j)"
definition "the_left j = (GREATEST i. i < j \<and> xs ! i < xs ! j)"

lemma left_alt: "left_spec j = (if has_left j then Some (the_left j) else None)"
  by (auto simp: left_spec_def has_left_def the_left_def)

lemma the_leftI: "has_left j \<Longrightarrow> the_left j < j \<and> xs!the_left j < xs!j"
  apply (clarsimp simp: has_left_def the_left_def)
  by (metis (no_types, lifting) GreatestI_nat less_le_not_le nat_le_linear pinf(5))

lemma the_left_decr[simp]: "has_left i \<Longrightarrow> the_left i < i"
  by (simp add: the_leftI)

lemma le_the_leftI:
  assumes "i\<le>j" "xs!i < xs!j"
  shows "i \<le> the_left j"
  using assms unfolding the_left_def
  by (metis (no_types, lifting)
      Greatest_le_nat le_less_linear less_imp_not_less less_irrefl
      order.not_eq_order_implies_strict)

lemma the_left_leI:
  assumes "\<forall>k. j<k \<and> k<i \<longrightarrow> \<not>xs!k<xs!i"
  assumes "has_left i"
  shows "the_left i \<le> j"
  using assms
  unfolding the_left_def has_left_def
  apply auto
  by (metis (full_types) the_leftI assms(2) not_le the_left_def)

subsubsection \<open>Derived Stack\<close>
text \<open>We note that the stack in the algorithm doesn't contain any
  extra information. It can be derived from the left neighbours that have been
  computed so far:
  The first element of the stack is the current index - 1, and each next element is
  the nearest left smaller value of the previous element:
\<close>

fun der_stack where
  "der_stack i = (if has_left i then the_left i # der_stack (the_left i) else [])"
declare der_stack.simps[simp del]

text \<open>
  Although the refinement framework would allow us to phrase the
  algorithm without a stack first, and then introduce the stack in a subsequent
  refinement step (or omit it altogether), for simplicity of presentation, we decided
  to model the algorithm with a stack in first place. However, the invariant will account for
  the stack being derived.
\<close>

lemma set_der_stack_lt: "k \<in> set (der_stack i\<^sub>0) \<Longrightarrow> k<i\<^sub>0"
  apply (induction i\<^sub>0 rule: der_stack.induct)
  apply (subst (asm) der_stack.simps)
  apply auto
  using less_trans the_leftI by blast

subsection \<open>Abstract Implementation\<close>
text \<open>We first implement the algorithm on lists.
  The assertions that we annotated into the algorithm ensure
  that all list index accesses are in bounds.
\<close>
definition "pop stk v \<equiv> dropWhile (\<lambda>j. xs!j\<ge>v) stk"

lemma pop_Nil[simp]: "pop [] v = []" by (auto simp: pop_def)
lemma pop_cons: "pop (j#js) v = (if xs!j \<ge> v then pop js v else j#js)"
  by (simp add: pop_def)

definition "all_left \<equiv> doN {
  (_,lf) \<leftarrow> nfoldli [0..<length xs] (\<lambda>_. True) (\<lambda>i (stk,lf). doN {
    ASSERT (set stk \<subseteq> {0..<length xs} );
    let stk = pop stk (xs!i);
    ASSERT (stk = der_stack i);
    ASSERT (i<length lf);
    if (stk = []) then doN {
      let lf = lf[i:=None];
      RETURN (i#stk,lf)
    } else doN {
      let lf = lf[i:= Some (hd stk)];
      RETURN (i#stk,lf)
    }
  }) ([],replicate (length xs) None);
  RETURN lf
}"

subsection \<open>Correctness Proof\<close>

subsubsection \<open>Popping From the Stack\<close>

text \<open>We show that the abstract algorithm implements its specification.
  The main idea here is the popping of the stack.
  Top obtain a left smaller value, it is enough to follow the left-values of
  the left-neighbour, until we have found the value or there are no more left-values.

  The following theorem formalizes this idea:
\<close>
theorem find_left_rl:
  assumes "i\<^sub>0 < length xs"
  assumes "i<i\<^sub>0"
  assumes "left_spec i\<^sub>0 \<le> Some i"
  shows "if xs!i < xs!i\<^sub>0 then left_spec i\<^sub>0 = Some i
         else left_spec i\<^sub>0 \<le> left_spec i"
  using assms
  apply (simp; intro impI conjI; clarsimp)
  subgoal
    apply (auto simp: left_alt split: if_splits)
    apply (simp add: le_antisym le_the_leftI)
    apply (auto simp: has_left_def)
    done
  subgoal
    apply (auto simp: left_alt split: if_splits)
    subgoal
      apply (drule the_leftI)
      using nat_less_le by (auto simp: has_left_def)
    subgoal
      using le_the_leftI the_leftI by fastforce
    done
  done

text \<open>Using this lemma, we can show that the stack popping procedure preserves the form of the stack.\<close>
lemma pop_aux: "\<lbrakk> k<i\<^sub>0; i\<^sub>0<length xs; left_spec i\<^sub>0 \<le> Some k \<rbrakk> \<Longrightarrow> pop (k # der_stack k) (xs!i\<^sub>0) = der_stack i\<^sub>0"
  apply (induction k rule: nat_less_induct)
  apply (clarsimp)
  by (smt der_stack.simps left_alt pop_def the_leftI dropWhile.simps(1) find_left_rl leD less_option_None_Some option.inject pop_cons)

subsubsection \<open>Main Algorithm\<close>

text \<open>Ad-Hoc lemmas\<close>
lemma swap_adhoc[simp]:
  "None = left i \<longleftrightarrow> left i = None"
  "Some j = left i \<longleftrightarrow> left i = Some j" by auto

lemma left_spec_None_iff[simp]: "left_spec i = None \<longleftrightarrow> \<not>has_left i" by (auto simp: left_alt)

subsection \<open>Implementation With Arrays\<close>
text \<open>We refine the algorithm to use actual arrays for the input and output.
  The stack remains a list, as pushing and popping from a (functional) list is efficient.
\<close>

subsubsection \<open>Implementation of Pop\<close>
text \<open>In a first step, we refine the pop function to an explicit loop.\<close>

definition "pop2 stk v \<equiv>
  monadic_WHILEIT
    (\<lambda>_. set stk \<subseteq> {0..<length xs})
    (\<lambda>[] \<Rightarrow> RETURN False | k#stk \<Rightarrow> doN { ASSERT (k<length xs); RETURN (v \<le> xs!k) })
    (\<lambda>stk. mop_list_tl stk)
    stk"

lemma pop2_refine_aux: "set stk \<subseteq> {0..<length xs} \<Longrightarrow> pop2 stk v \<le> RETURN (pop stk v)"
  apply (induction stk)
  unfolding pop_def pop2_def
  subgoal
    apply (subst monadic_WHILEIT_unfold)
    by auto
  subgoal
    apply (subst monadic_WHILEIT_unfold)
    unfolding mop_list_tl_def op_list_tl_def by auto
  done

end \<comment> \<open>Context fixing the input \<open>xs\<close>.\<close>

text \<open>The refinement lemma written in higher-order form.\<close>

text \<open>Next, we use the Sepref tool to synthesize an implementation on arrays.\<close>
sepref_definition pop2_impl is "uncurry2 pop2" :: "(array_assn id_assn)\<^sup>k *\<^sub>a (list_assn id_assn)\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a list_assn id_assn"
  unfolding pop2_def
  by sepref
lemmas [sepref_fr_rules] = pop2_impl.refine[FCOMP pop2_refine]

subsubsection \<open>Implementation of Main Algorithm\<close>

sepref_definition all_left_impl is all_left :: "(array_assn id_assn)\<^sup>k \<rightarrow>\<^sub>a array_assn (option_assn id_assn)"
  unfolding all_left_def
  apply (rewrite at "nfoldli _ _ _ (\<hole>,_)" HOL_list.fold_custom_empty)
  apply (rewrite in "nfoldli _ _ _ (_,\<hole>)" array_fold_custom_replicate)
  by sepref

subsubsection \<open>Correctness Theorem for Concrete Algorithm\<close>
text \<open>We compose the correctness theorem and the refinement theorem, to get a correctness
  theorem for the final implementation.\<close>

text \<open>Abstract correctness theorem in higher-order form.\<close>
lemma algo_correct': "(all_left, SPEC o all_left_spec)
  \<in> \<langle>Id\<rangle>list_rel \<rightarrow> \<langle>\<langle>\<langle>Id\<rangle>option_rel\<rangle>list_rel\<rangle>nres_rel"
  using algo_correct by (auto simp: nres_relI)

text \<open>Main correctness theorem in higher-order form.\<close>
theorem algo_impl_correct:
    "(all_left_impl, SPEC o all_left_spec)
    \<in> (array_assn int_assn, array_assn int_assn) \<rightarrow>\<^sub>a array_assn (option_assn nat_assn)"
  using all_left_impl.refine[FCOMP algo_correct', simplified] .

text \<open>Main correctness theorem as Hoare-Triple\<close>
theorem algo_impl_correct': "
  <array_assn int_assn xs xsi>
    all_left_impl xsi
  <\<lambda>lfi. \<exists>\<^sub>Alf. array_assn int_assn xs xsi
        * array_assn (option_assn id_assn) lf lfi
        * \<up>(all_left_spec xs lf)>\<^sub>t"
  apply (rule cons_rule[OF _ _ algo_impl_correct[to_hnr, THEN hn_refineD, unfolded autoref_tag_defs]])
  apply (simp add: hn_ctxt_def, rule ent_refl)
  by (auto simp: hn_ctxt_def)

subsection \<open>Code Generation\<close>

export_code all_left_impl checking SML Scala Haskell? OCaml?

text \<open>The example from the problem description, in ML using the verified algorithm\<close>
ML_val \<open>
  (* Convert from option to 1-based indexes *)
  fun cnv NONE = 0
    | cnv (SOME i) = @{code integer_of_nat} i + 1

  (* The verified algorithm, boxing the input list into an array,
    and unboxing the output to a list, and converting it from option to 1-based *)
  fun all_left xs =
       @{code all_left_impl} (Array.fromList (map @{code int_of_integer} xs)) ()
    |> Array.foldr (op ::) []
    |> map cnv

  val test = all_left [ 4, 7, 8, 1, 2, 3, 9, 5, 6 ]
\<close>

end


section \<open> Algebraic Laws \<close>

theory ISQ_Algebra
  imports ISQ_Proof
begin

subsection \<open> Quantity Scale \<close>

lemma scaleQ_add_right: "a *\<^sub>Q x + y = (a *\<^sub>Q x) + (a *\<^sub>Q y)"
  by (si_simp add: distrib_left)

lemma scaleQ_add_left: "a + b *\<^sub>Q x = (a *\<^sub>Q x) + (b *\<^sub>Q x)"
  by (si_simp add: distrib_right)

lemma scaleQ_scaleQ [simp]: "a *\<^sub>Q b *\<^sub>Q x = a \<cdot> b *\<^sub>Q x"
  by si_simp

lemma scaleQ_one [simp]: "1 *\<^sub>Q x = x"
  by si_simp

lemma scaleQ_zero [simp]: "0 *\<^sub>Q x = 0"
  by si_simp

lemma scaleQ_inv: "-a *\<^sub>Q x = a *\<^sub>Q -x"
  by si_calc

lemma scaleQ_as_qprod: "a *\<^sub>Q x \<cong>\<^sub>Q (a *\<^sub>Q \<one>) \<^bold>\<cdot> x"
  by si_simp

lemma mult_scaleQ_left [simp]: "(a *\<^sub>Q x) \<^bold>\<cdot> y = a *\<^sub>Q x \<^bold>\<cdot> y"
  by si_simp

lemma mult_scaleQ_right [simp]: "x \<^bold>\<cdot> (a *\<^sub>Q y) = a *\<^sub>Q x \<^bold>\<cdot> y"
  by si_simp

subsection \<open> Field Laws \<close>

lemma qtimes_commute: "x \<^bold>\<cdot> y \<cong>\<^sub>Q y \<^bold>\<cdot> x"
  by si_calc

lemma qtimes_assoc: "(x \<^bold>\<cdot> y) \<^bold>\<cdot> z  \<cong>\<^sub>Q  x \<^bold>\<cdot> (y \<^bold>\<cdot> z)"
  by (si_calc)

lemma qtimes_left_unit: "\<one> \<^bold>\<cdot> x \<cong>\<^sub>Q x"
  by (si_calc)

lemma qtimes_right_unit: "x \<^bold>\<cdot> \<one> \<cong>\<^sub>Q x"
  by (si_calc)

text\<open>The following weak congruences will allow for replacing equivalences in contexts
     built from product and inverse. \<close>

lemma qtimes_weak_cong_left:
  assumes "x \<cong>\<^sub>Q y"
  shows  "x\<^bold>\<cdot>z \<cong>\<^sub>Q y\<^bold>\<cdot>z"
  using assms by si_simp

lemma qtimes_weak_cong_right:
  assumes "x \<cong>\<^sub>Q y"
  shows  "z\<^bold>\<cdot>x \<cong>\<^sub>Q z\<^bold>\<cdot>y"
  using assms by si_calc

lemma scaleQ_cong:
  assumes "y \<cong>\<^sub>Q z"
  shows "x *\<^sub>Q y \<cong>\<^sub>Q x *\<^sub>Q z"
  using assms by si_calc

lemma qinverse_qinverse: "x\<^sup>-\<^sup>\<one>\<^sup>-\<^sup>\<one> \<cong>\<^sub>Q x"
  by si_calc

lemma qinverse_nonzero_iff_nonzero: "x\<^sup>-\<^sup>\<one> = 0 \<longleftrightarrow> x = 0"
  by (auto, si_calc+)

lemma qinverse_qtimes: "(x \<^bold>\<cdot> y)\<^sup>-\<^sup>\<one> \<cong>\<^sub>Q x\<^sup>-\<^sup>\<one> \<^bold>\<cdot> y\<^sup>-\<^sup>\<one>"
  by (si_simp add: inverse_distrib)

lemma qinverse_qdivide: "(x \<^bold>/ y)\<^sup>-\<^sup>\<one> \<cong>\<^sub>Q y \<^bold>/ x"
  by si_simp

lemma qtimes_cancel: "x \<noteq> 0 \<Longrightarrow> x \<^bold>/ x \<cong>\<^sub>Q \<one>"
  by si_calc

end


theory Exe4p3
  imports Main
begin

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS : "ev n \<Longrightarrow> ev (Suc(Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc(Suc n)) = evn n"

lemma "ev (Suc m) \<Longrightarrow> \<not> ev m"
proof (induction "Suc m" arbitrary: m rule: ev.induct)
  fix n assume IH: "\<And>m. n = Suc m \<Longrightarrow> \<not>ev m"
  show "\<not>ev (Suc n)"
  proof
    assume "ev(Suc n)"
    thus False
    proof cases
      fix k assume "n = Suc k" "ev k"
      thus False using IH by auto
    qed
  qed
qed

lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
proof -
  have "ev(Suc(Suc n)) \<Longrightarrow> ev n"
  proof (induction "Suc(Suc n)" arbitrary: n rule: ev.induct)
    case ev0
    fix n assume "ev n"
    thus "ev n" by simp
  qed
  thus ?thesis using a by simp
qed

end