theory Unification imports Main begin

type_synonym vname = "string \<times> int"

datatype "term" = V vname | T "string \<times> term list"

type_synonym subst = "(vname \<times> term) list"

definition indom :: "vname \<Rightarrow> subst \<Rightarrow> bool" where
  "indom x s = list_ex (\<lambda>(y, _). x = y) s"

fun app :: "subst \<Rightarrow> vname \<Rightarrow> term" where
  "app ((y,t)#s) x = (if x = y then t else app s x)"
| "app [] _ = undefined"

fun lift :: "subst \<Rightarrow> term \<Rightarrow> term" where
  "lift s (V x) = (if indom x s then app s x else V x)"
| "lift s (T(f,ts)) = T(f, map (lift s) ts)"

fun occurs :: "vname \<Rightarrow> term \<Rightarrow> bool" where
  "occurs x (V y) = (x = y)"
| "occurs x (T(_,ts)) = list_ex (occurs x) ts"

definition vars :: "term list \<Rightarrow> vname set" where
  "vars S = {x. \<exists>t \<in> set S. occurs x t}"

lemma vars_nest_eq:
  fixes ts :: "term list"
    and S :: "term list"
    and vn :: "string"
  shows "vars (ts @ S) = vars (T(vn, ts) # S)"
  unfolding vars_def
  by (induction ts, auto)

lemma vars_concat:
  fixes ts:: "term list"
    and S:: "term list"
  shows "vars (ts @ S) = vars ts \<union> vars S"
  unfolding vars_def
  by (induction ts, auto)

definition vars_eqs :: "(term \<times> term) list \<Rightarrow> vname set" where
  "vars_eqs l = vars (map fst l) \<union> vars (map snd l)"

lemma vars_eqs_zip:
  fixes ts:: "term list"
    and us:: "term list"
    and S:: "term list"
  shows "vars_eqs (zip ts us) \<subseteq> vars ts \<union> vars us"
proof -
  have
    "map fst (zip xs ys) = take (min (length xs) (length ys)) xs"
    "map snd (zip xs ys) = take (min (length xs) (length ys)) ys"
    for xs ys :: "'a list"
    by (induct xs ys rule: list_induct2') simp_all
  then show ?thesis
    unfolding vars_eqs_def
    using vars_concat append_take_drop_id sup_ge1 Un_mono
    by metis
qed

lemma vars_eqs_concat:
  fixes ts:: "(term \<times> term) list"
    and S:: "(term \<times> term) list"
  shows "vars_eqs (ts @ S) = vars_eqs ts \<union> vars_eqs S"
  using vars_concat vars_eqs_def by auto

lemma vars_eqs_nest_subset:
  fixes ts :: "term list"
    and us :: "term list"
    and S :: "(term \<times> term) list"
    and vn :: "string"
    and wn :: "string"
  shows "vars_eqs (zip ts us @ S) \<subseteq> vars_eqs ((T(vn, ts), T(wn, us)) # S)"
proof -
  have "vars_eqs ((T(vn, ts), T(wn, us)) # S) = vars ts \<union> vars us \<union> vars_eqs S"
    using vars_concat vars_eqs_def vars_nest_eq by auto
  then show ?thesis
    using vars_eqs_concat vars_eqs_zip by fastforce
qed

definition n_var :: "(term \<times> term) list \<Rightarrow> nat" where
  "n_var l = card (vars_eqs l)"

lemma var_eqs_finite:
  fixes ts
  shows "finite (vars_eqs ts)"
proof -
  {
    fix t
    have "finite ({x. occurs x t})"
    proof (induction t rule: occurs.induct)
      case (1 x y)
      then show ?case by simp
    next
      case (2 x fn ts)
      have "{x. occurs x (T (fn, ts))} = vars ts"
        using vars_def Bex_set_list_ex
        by fastforce
      then show ?case using vars_def "2.IH" by simp
    qed
  }
  then show ?thesis
    using vars_def vars_eqs_def by simp
qed

lemma vars_eqs_subset_n_var_le:
  fixes S1:: "(term \<times> term) list"
    and S2:: "(term \<times> term) list"
  assumes "vars_eqs S1 \<subseteq> vars_eqs S2"
  shows "n_var S1 \<le> n_var S2"
  using assms var_eqs_finite n_var_def
  by (simp add: card_mono)

lemma vars_eqs_psubset_n_var_lt:
  fixes S1:: "(term \<times> term) list"
    and S2:: "(term \<times> term) list"
  assumes "vars_eqs S1 \<subset> vars_eqs S2"
  shows "n_var S1 < n_var S2"
  using assms var_eqs_finite n_var_def
  by (simp add: psubset_card_mono)

fun fun_count :: "term list \<Rightarrow> nat" where
  "fun_count [] = 0"
| "fun_count ((V _)#S) = fun_count S"
| "fun_count (T(_,ts)#S) = 1 + fun_count ts + fun_count S"

lemma fun_count_concat:
  fixes ts:: "term list"
    and us:: "term list"
  shows "fun_count (ts @ us) = fun_count ts + fun_count us"
proof (induction ts)
  case Nil
  then show ?case
    by force
next
  case (Cons a ts)
  show ?case
  proof (cases a)
    case (V _)
    then have "fun_count ((a # ts) @ us) = fun_count (ts @ us)"
      by simp
    then show ?thesis
      by (simp add: Cons.IH V)
  next
    case (T x)
    then obtain fn ts' where ts'_def: "x=(fn, ts')"
      by fastforce
    then have "fun_count ((a # ts) @ us) = 1 + fun_count (ts @ us) + fun_count ts'"
      by (simp add: T)
    then show ?thesis
      by (simp add: Cons.IH T ts'_def)
  qed
qed

definition n_fun :: "(term \<times> term) list \<Rightarrow> nat" where
  "n_fun l = fun_count (map fst l) + fun_count (map snd l)"

lemma n_fun_concat:
  fixes ts us
  shows "n_fun (ts @ us) = n_fun ts + n_fun us"
  unfolding n_fun_def using fun_count_concat
  by simp

lemma n_fun_nest_head:
  fixes ts g us S
  shows "n_fun (zip ts us @ S) + 2 \<le> n_fun ((T (g, ts), T (g, us)) # S)"
proof -
  let "?trunc_ts" = "map fst (zip ts us)"
  let "?trunc_us" = "map snd (zip ts us)"
  have trunc_sum: "n_fun ((T (g, ?trunc_ts), T (g, ?trunc_us)) # S) = 2 + n_fun (zip ts us @ S)"
    using n_fun_concat n_fun_def by auto

  obtain tsp where ts_rest: "map fst (zip ts us) @ tsp = ts"
    by (induct ts us rule:list_induct2') simp_all
  obtain usp where us_rest: "map snd (zip ts us) @ usp = us"
    by (induct ts us rule:list_induct2') simp_all
  have "fun_count [T(g, ?trunc_ts)] + fun_count tsp = fun_count [T(g, ts)]"
    using ts_rest fun_count_concat
    by (metis add.assoc add.right_neutral fun_count.simps(1) fun_count.simps(3))
  moreover have "fun_count [T(g, ?trunc_us)] + fun_count usp = fun_count [T(g, us)]"
    using us_rest fun_count_concat
    by (metis add.assoc add.right_neutral fun_count.simps(1) fun_count.simps(3))
  ultimately have "n_fun [(T (g, ?trunc_ts), T (g, ?trunc_us))] + fun_count tsp + fun_count usp =
      fun_count [T(g, ts)] + fun_count [T(g, us)]"
    by (simp add: n_fun_def)
  then have "n_fun ((T (g, ?trunc_ts), T (g, ?trunc_us)) # S) + fun_count tsp + fun_count usp =
      n_fun ((T (g, ts), T (g, us)) # S)"
    using n_fun_def n_fun_concat by simp
  from this and trunc_sum show ?thesis by simp
qed

abbreviation (noprint) "liftmap v t S' \<equiv>
  map (\<lambda>(t1, t2). (lift [(v, t)] t1, lift [(v, t)] t2)) S'"

lemma lift_elims:
  fixes x :: "vname"
    and t :: "term"
    and t0 :: "term"
  assumes "\<not> occurs x t"
  shows "\<not> occurs x (lift [(x, t)] t0)"
proof (induction "[(x, t)]" t0 rule: lift.induct)
  case (1 x)
  then show ?case
    by (simp add: assms indom_def vars_def)
next
  case (2 f ts)
  {
    fix v
    assume "occurs v (lift [(x, t)] (T (f, ts)))"
    then have "list_ex (occurs v) (map (lift [(x,t)]) ts)"
      by simp
    then obtain t1 where t1_def: "t1 \<in> set (map (lift [(x,t)]) ts) \<and> occurs v t1"
      by (meson Bex_set_list_ex)
    then obtain t1' where "t1 = lift [(x,t)] t1' \<and> t1' \<in> set ts" by auto

    then have "\<exists>t1 \<in> set ts. occurs v (lift [(x,t)] t1)"
      using t1_def by blast
  }
  then show ?case
    using "2.hyps" by blast
qed

lemma lift_inv_occurs:
  fixes x :: "vname"
    and v :: "vname"
    and st :: "term"
    and t :: "term"
  assumes "occurs v (lift [(x, st)] t)"
    and "\<not> occurs v st"
    and "v \<noteq> x"
  shows "occurs v t"
  using assms proof (induction t rule: occurs.induct)
  case (1 v y)
  have "lift [(x, st)] (V y) = V y"
    using "1.prems" indom_def by auto
  then show ?case
    using "1.prems"(1) by auto
next
  case (2 x f ts)
  then show ?case
    by (metis (mono_tags, lifting) Bex_set_list_ex imageE lift.simps(2) occurs.simps(2) set_map)
qed

lemma vars_elim:
  fixes x st S
  assumes "\<not> occurs x st"
  shows "vars (map (lift [(x,st)]) S) \<subseteq> vars [st] \<union> vars S \<and>
         x \<notin> vars (map (lift [(x,st)]) S)"
proof (induction S)
  case Nil
  then show ?case
    by (simp add: vars_def)
next
  case (Cons tx S)
  moreover have "vars (map (lift [(x, st)]) (tx # S)) =
    vars [lift [(x,st)] tx] \<union> vars (map (lift [(x, st)]) S)"
    using vars_concat
    by (metis append.left_neutral append_Cons list.simps(9))
  moreover have "vars [st] \<union> vars (tx # S) = vars [st] \<union> vars S \<union> vars [tx]"
    using vars_concat
    by (metis append.left_neutral append_Cons sup_commute)
  moreover {
    fix v
    assume v_mem_vars_lift: "v \<in> vars [lift [(x,st)] tx]"
    have v_neq_x: "v \<noteq> x" using lift_elims assms v_mem_vars_lift vars_def
      by fastforce
    moreover have "v \<in> vars [st] \<union> vars [tx]"
    proof (cases)
      assume "occurs v st"
      then show ?thesis unfolding vars_def by simp
    next
      assume not_occurs_v_st: "\<not>occurs v st"
      have "occurs v (lift [(x, st)] tx)"
        using v_mem_vars_lift vars_def by force
      then have "occurs v tx" using lift_inv_occurs
        using v_neq_x not_occurs_v_st by blast
      then show ?thesis
        by (simp add: vars_def)
    qed
    ultimately have "v \<in> vars [st] \<union> vars [tx] \<and> v \<noteq> x" by simp
  }
  ultimately show ?case by blast
qed

lemma n_var_elim:
  fixes x st S
  assumes "\<not> occurs x st"
  shows "n_var (liftmap x st S) < n_var ((V x, st) # S)"
proof -
  have "\<And>l f. map fst (map (\<lambda>(t1, t2). (f t1, f t2)) l) = map f (map fst l)"
    by (simp add: case_prod_unfold)
  moreover have "\<And>l f. map snd (map (\<lambda>(t1, t2). (f t1, f t2)) l) = map f (map snd l)"
    by (simp add: case_prod_unfold)
  ultimately have lhs_split: "vars_eqs (liftmap x st S) =
    vars (map (lift [(x,st)]) (map fst S)) \<union> vars (map (lift [(x,st)]) (map snd S))"
    unfolding vars_eqs_def by metis

  have "vars_eqs ((V x, st) # S) = vars_eqs [(V x, st)] \<union> vars_eqs S"
    using vars_eqs_concat
    by (metis append_Cons self_append_conv2)
  moreover have "vars_eqs [(V x, st)] = {x} \<union> vars [st]"
    unfolding vars_eqs_def using vars_def occurs.simps(1) by force
  ultimately have rhs_eq1: "vars_eqs ((V x, st) # S) = {x} \<union> vars [st] \<union> vars_eqs S"
    by presburger
  then have rhs_eq2:
    "vars_eqs ((V x, st) # S) = {x} \<union> vars [st] \<union> vars (map fst S) \<union> vars (map snd S)"
    unfolding vars_eqs_def
    by (simp add: sup.assoc)

  from this lhs_split vars_elim assms
  have "vars_eqs (liftmap x st S) \<subseteq> vars [st] \<union> vars_eqs S \<and>
        x \<notin> vars_eqs (liftmap x st S)"
    using vars_concat vars_eqs_def by (metis map_append)
  moreover have "x \<in> vars_eqs ((V x, st) # S)"
    by (simp add: rhs_eq2)
  ultimately have "vars_eqs (liftmap x st S) \<subset> vars_eqs ((V x, st) # S)"
    using rhs_eq1 by blast
  then show ?thesis using vars_eqs_psubset_n_var_lt by blast
qed

function (sequential) solve :: "(term \<times> term) list \<times> subst \<Rightarrow> subst option"
  and elim :: "vname \<times> term \<times> (term \<times> term) list \<times> subst \<Rightarrow> subst option" where
  "solve([], s) = Some s"
| "solve((V x, t) # S, s) = (
    if V x = t then solve(S,s) else elim(x,t,S,s))"
| "solve((t, V x) # S, s) = elim(x,t,S,s)"
| "solve((T(f,ts),T(g,us)) # S, s) = (
    if f = g then solve((zip ts us) @ S, s) else None)"

| "elim(x,t,S,s) = (
    if occurs x t then None
    else let xt = lift [(x,t)]
      in solve(map (\<lambda> (t1,t2). (xt t1, xt t2)) S,
        (x,t) # (map (\<lambda> (y,u). (y, xt u)) s)))"
  by pat_completeness auto
termination proof (
    relation "
      (\<lambda>XX. case XX of Inl(l,_) \<Rightarrow> n_var l | Inr(x,t,S,_) \<Rightarrow> n_var ((V x, t)#S)) <*mlex*>
      (\<lambda>XX. case XX of Inl(l,_) \<Rightarrow> n_fun l | Inr(x,t,S,_) \<Rightarrow> n_fun ((V x, t)#S)) <*mlex*>
      (\<lambda>XX. case XX of Inl(l,_) \<Rightarrow> size l | Inr(x,t,S,_) \<Rightarrow> size ((V x, t)#S)) <*mlex*>
      (\<lambda>XX. case XX of Inl(l,_) \<Rightarrow> 1 | Inr(x,t,S,_) \<Rightarrow> 0) <*mlex*>
      {}",
    auto simp add: wf_mlex mlex_less mlex_prod_def)
  have "\<And>v S. vars_eqs S \<subseteq> vars_eqs ((V v, V v)#S)"
    using vars_eqs_def vars_def by force
  then show "\<And>a b S. \<not> n_var S < n_var ((V (a, b), V (a, b)) # S) \<Longrightarrow>
      n_var S = n_var ((V (a, b), V (a, b)) # S)"
    using vars_eqs_subset_n_var_le by (simp add: nat_less_le)

  show "\<And>a b S. \<not> n_var S < n_var ((V (a, b), V (a, b)) # S) \<Longrightarrow>
             n_fun S \<noteq> n_fun ((V (a, b), V (a, b)) # S) \<Longrightarrow>
             n_fun S < n_fun ((V (a, b), V (a, b)) # S)"
    using n_fun_def by simp

  have "\<And>tx v. vars_eqs [(V v, T tx)] = vars_eqs [(T tx, V v)]"
    using vars_eqs_def
    by (simp add: sup_commute)
  then have "\<And>tx v S. vars_eqs ((V v, T tx) # S) = vars_eqs ((T tx, V v) # S)"
    using vars_eqs_concat
    by (metis append_Cons self_append_conv2)
  then have "\<And>a b v S. n_var ((V v, T (a, b)) # S) = n_var ((T (a, b), V v) # S)"
    unfolding n_var_def vars_eqs_def
    by presburger
  then show "\<And>a b aa ba S.
       \<not> n_var ((V (aa, ba), T (a, b)) # S) < n_var ((T (a, b), V (aa, ba)) # S) \<Longrightarrow>
       n_var ((V (aa, ba), T (a, b)) # S) = n_var ((T (a, b), V (aa, ba)) # S)"
    by simp

  show "\<And>a b aa ba S.
       \<not> n_var ((V (aa, ba), T (a, b)) # S) < n_var ((T (a, b), V (aa, ba)) # S) \<Longrightarrow>
       n_fun ((V (aa, ba), T (a, b)) # S) \<noteq> n_fun ((T (a, b), V (aa, ba)) # S) \<Longrightarrow>
       n_fun ((V (aa, ba), T (a, b)) # S) < n_fun ((T (a, b), V (aa, ba)) # S)"
    by (simp add: n_fun_def)

  show "\<And>ts g us S. \<not> n_var (zip ts us @ S) < n_var ((T (g, ts), T (g, us)) # S) \<Longrightarrow>
          n_var (zip ts us @ S) = n_var ((T (g, ts), T (g, us)) # S)"
    using vars_eqs_nest_subset vars_eqs_subset_n_var_le le_neq_implies_less by meson

  have n_fun_nested_gt: "\<And>ts g us S. n_fun (zip ts us @ S) < n_fun ((T (g, ts), T (g, us)) # S)"
    using n_fun_nest_head
    by (metis add_leD1 le_neq_implies_less add_2_eq_Suc' leD less_Suc_eq)
  show "\<And>ts g us S.
       \<not> n_var (zip ts us @ S) < n_var ((T (g, ts), T (g, us)) # S) \<Longrightarrow>
       \<not> n_fun (zip ts us @ S) < n_fun ((T (g, ts), T (g, us)) # S) \<Longrightarrow>
        n_fun (zip ts us @ S) = n_fun ((T (g, ts), T (g, us)) # S)"
    using n_fun_nested_gt by meson

  show "\<And>ts g us S.
       \<not> n_var (zip ts us @ S) < n_var ((T (g, ts), T (g, us)) # S) \<Longrightarrow>
       \<not> n_fun (zip ts us @ S) < n_fun ((T (g, ts), T (g, us)) # S) \<Longrightarrow>
        min (length ts) (length us) = 0"
    using n_fun_nested_gt by blast

  show "\<And>x t S.
       \<not> occurs x t \<Longrightarrow>
       \<not> n_var (liftmap x t S) < n_var ((V x, t) # S) \<Longrightarrow>
       n_var (liftmap x t S) = n_var ((V x, t) # S)"
    using n_var_elim leD linorder_neqE_nat by blast

  show "\<And>x t S.
       \<not> occurs x t \<Longrightarrow>
       \<not> n_var (liftmap x t S) < n_var ((V x, t) # S) \<Longrightarrow>
       n_fun (liftmap x t S) \<noteq> n_fun ((V x, t) # S) \<Longrightarrow>
       n_fun (liftmap x t S) < n_fun ((V x, t) # S)"
    using n_var_elim by simp
qed

code_reflect Unification
  datatypes
    "term" = V | T
    and
    char = Char
  functions
    solve

export_code solve in SML

ML \<open> open Unification \<close>

lemma "solve([(T([],[]),T([],[]))],[]) = Some []"
  by code_simp

ML_val \<open> solve([(T([],[]),T([],[]))],[]) \<close>

lemma "solve([(T([Char False False False False False False False False],[]),T([],[]))],[]) = None"
  by code_simp

ML_val \<open> solve([(T([Chara(false,false,false,false,false,false,false,false)],[]),T([],[]))],[]) \<close>

end


(* Author: Christian Sternagel *)

theory Natural_Mergesort
  imports "HOL-Data_Structures.Sorting"
begin

subsection \<open>Auxiliary Results\<close>

lemma C_merge_adj':
  "C_merge_adj xss \<le> length (concat xss)"
proof (induct xss rule: C_merge_adj.induct)
  case (3 xs ys zss)
  then show ?case using C_merge_ub [of xs ys] by simp
qed simp_all

lemma length_concat_merge_adj:
  "length (concat (merge_adj xss)) = length (concat xss)"
  by (induct xss rule: merge_adj.induct) (simp_all add: length_merge)

lemma C_merge_all':
  "C_merge_all xss \<le> length (concat xss) * \<lceil>log 2 (length xss)\<rceil>"
proof (induction xss rule: C_merge_all.induct)
  case (3 xs ys zss)
  let ?xss = "xs # ys # zss"
  let ?m = "length (concat ?xss)"

  have *: "\<lceil>log 2 (real n + 2)\<rceil> = \<lceil>log 2 (Suc n div 2 + 1)\<rceil> + 1" for n :: nat
    using ceiling_log2_div2 [of "n + 2"] by (simp add: algebra_simps)

  have "C_merge_all ?xss = C_merge_adj ?xss + C_merge_all (merge_adj ?xss)" by simp
  also have "\<dots> \<le> ?m + C_merge_all (merge_adj ?xss)"
    using C_merge_adj' [of ?xss] by auto
  also have "\<dots> \<le> ?m + length (concat (merge_adj ?xss)) * \<lceil>log 2 (length (merge_adj ?xss))\<rceil>"
    using "3.IH" by simp
  also have "\<dots> = ?m + ?m * \<lceil>log 2 (length (merge_adj ?xss))\<rceil>"
    by (simp only: length_concat_merge_adj)
  also have "\<dots> \<le> ?m * \<lceil>log 2 (length ?xss)\<rceil>"
    by (auto simp: * algebra_simps)
  finally show ?case by simp
qed simp_all

subsection \<open>Definition of Natural Mergesort\<close>

text \<open>
  Partition input into ascending and descending subsequences.
  (The latter are reverted on the fly.)
\<close>
fun runs :: "('a::linorder) list \<Rightarrow> 'a list list" and
    asc :: "'a \<Rightarrow> ('a list \<Rightarrow> 'a list) \<Rightarrow> 'a list \<Rightarrow> 'a list list" and
    desc :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list"
  where
    "runs (a # b # xs) = (if a > b then desc b [a] xs else asc b ((#) a) xs)"
  | "runs [x] = [[x]]"
  | "runs [] = []"
  | "asc a as (b # bs) = (if \<not> a > b then asc b (as \<circ> (#) a) bs else as [a] # runs (b # bs))"
  | "asc a as [] = [as [a]]"
  | "desc a as (b # bs) = (if a > b then desc b (a # as) bs else (a # as) # runs (b # bs))"
  | "desc a as [] = [a # as]"

definition nmsort :: "('a::linorder) list \<Rightarrow> 'a list"
  where
    "nmsort xs = merge_all (runs xs)"

subsection \<open>Functional Correctness\<close>

definition "ascP f = (\<forall>xs ys. f (xs @ ys) = f xs @ ys)"

lemma ascP_Cons [simp]: "ascP ((#) x)" by (simp add: ascP_def)

lemma ascP_comp_Cons [simp]: "ascP f \<Longrightarrow> ascP (f \<circ> (#) x)"
  by (auto simp: ascP_def simp flip: append_Cons)

lemma ascP_simp [simp]:
  assumes "ascP f"
  shows "f [x] = f [] @ [x]"
  using assms [unfolded ascP_def, THEN spec, THEN spec, of "[]" "[x]"] by simp

lemma
  shows mset_runs: "\<Sum>\<^sub># (image_mset mset (mset (runs xs))) = mset xs"
    and mset_asc: "ascP f \<Longrightarrow> \<Sum>\<^sub># (image_mset mset (mset (asc x f ys))) = {#x#} + mset (f []) + mset ys"
    and mset_desc: "\<Sum>\<^sub># (image_mset mset (mset (desc x xs ys))) = {#x#} + mset xs + mset ys"
  by (induct xs and x f ys and x xs ys rule: runs_asc_desc.induct) auto

lemma mset_nmsort:
  "mset (nmsort xs) = mset xs"
  by (auto simp: mset_merge_all nmsort_def mset_runs)

lemma
  shows sorted_runs: "\<forall>x\<in>set (runs xs). sorted x"
    and sorted_asc: "ascP f \<Longrightarrow> sorted (f []) \<Longrightarrow> \<forall>x\<in>set (f []). x \<le> a \<Longrightarrow> \<forall>x\<in>set (asc a f ys). sorted x"
    and sorted_desc: "sorted xs \<Longrightarrow> \<forall>x\<in>set xs. a \<le> x \<Longrightarrow> \<forall>x\<in>set (desc a xs ys). sorted x"
  by (induct xs and a f ys and a xs ys rule: runs_asc_desc.induct)
    (auto simp: sorted_append not_less dest: order_trans, fastforce)

lemma sorted_nmsort:
  "sorted (nmsort xs)"
  by (auto intro: sorted_merge_all simp: nmsort_def sorted_runs)

subsection \<open>Running Time Analysis\<close>

fun C_runs :: "('a::linorder) list \<Rightarrow> nat" and
    C_asc :: "('a::linorder) \<Rightarrow> 'a list \<Rightarrow> nat" and
    C_desc :: "('a::linorder) \<Rightarrow> 'a list \<Rightarrow> nat"
  where
    "C_runs (a # b # xs) = 1 + (if a > b then C_desc b xs else C_asc b xs)"
  | "C_runs xs = 0"
  | "C_asc a (b # bs) = 1 + (if \<not> a > b then C_asc b bs else C_runs (b # bs))"
  | "C_asc a [] = 0"
  | "C_desc a (b # bs) = 1 + (if a > b then C_desc b bs else C_runs (b # bs))"
  | "C_desc a [] = 0"

fun C_nmsort :: "('a::linorder) list \<Rightarrow> nat"
  where
    "C_nmsort xs = C_runs xs + C_merge_all (runs xs)"

lemma
  fixes a :: "'a::linorder" and xs ys :: "'a list"
  shows C_runs: "C_runs xs \<le> length xs - 1"
    and C_asc: "C_asc a ys \<le> length ys"
    and C_desc: "C_desc a ys \<le> length ys"
  by (induct xs and a ys and a ys rule: C_runs_C_asc_C_desc.induct) auto

lemma
  shows length_runs: "length (runs xs) \<le> length xs"
    and length_asc: "ascP f \<Longrightarrow> length (asc a f ys) \<le> 1 + length ys"
    and length_desc: "length (desc a xs ys) \<le> 1 + length ys"
  by (induct xs and a f ys and a xs ys rule: runs_asc_desc.induct) auto

lemma
  shows length_concat_runs [simp]: "length (concat (runs xs)) = length xs"
    and length_concat_asc: "ascP f \<Longrightarrow> length (concat (asc a f ys)) = 1 + length (f []) + length ys"
    and length_concat_desc: "length (concat (desc a xs ys)) = 1 + length xs + length ys"
  by (induct xs and a f ys and a xs ys rule: runs_asc_desc.induct) auto

lemma log2_mono:
  "x > 0 \<Longrightarrow> x \<le> y \<Longrightarrow> log 2 x \<le> log 2 y"
  by auto

lemma
  shows runs_ne: "xs \<noteq> [] \<Longrightarrow> runs xs \<noteq> []"
    and "ascP f \<Longrightarrow> asc a f ys \<noteq> []"
    and "desc a xs ys \<noteq> []"
  by (induct xs and a f ys and a xs ys rule: runs_asc_desc.induct) simp_all

lemma C_nmsort:
  assumes [simp]: "length xs = n"
  shows "C_nmsort xs \<le> n + n * \<lceil>log 2 n\<rceil>"
proof -
  have [simp]: "xs = [] \<longleftrightarrow> length xs = 0" by blast
  have "int (C_merge_all (runs xs)) \<le> int n * \<lceil>log 2 (length (runs xs))\<rceil>"
    using C_merge_all' [of "runs xs"] by simp
  also have "\<dots> \<le> int n * \<lceil>log 2 n\<rceil>"
    using length_runs [of xs]
    by (cases n) (auto intro!: runs_ne mult_mono ceiling_mono log2_mono)
  finally have "int (C_merge_all (runs xs)) \<le> int n * \<lceil>log 2 n\<rceil>" .
  moreover have "C_runs xs \<le> n" using C_runs [of xs] by auto
  ultimately show ?thesis by (auto intro: add_mono)
qed

end


(*<*)
theory Infinite_Sequences
imports
  CIMP_pred
begin

(*>*)
section\<open> Infinite Sequences \label{sec:infinite_sequences}\<close>

text\<open>

Infinite sequences and some operations on them.

We use the customary function-based representation.

\<close>

type_synonym 'a seq = "nat \<Rightarrow> 'a"
type_synonym 'a seq_pred = "'a seq \<Rightarrow> bool"

definition suffix :: "'a seq \<Rightarrow> nat \<Rightarrow> 'a seq" (infixl "|\<^sub>s" 60) where
  "\<sigma> |\<^sub>s i \<equiv> \<lambda>j. \<sigma> (j + i)"

primrec stake :: "nat \<Rightarrow> 'a seq \<Rightarrow> 'a list" where
  "stake 0 \<sigma> = []"
| "stake (Suc n) \<sigma> = \<sigma> 0 # stake n (\<sigma> |\<^sub>s 1)"

primrec shift :: "'a list \<Rightarrow> 'a seq \<Rightarrow> 'a seq" (infixr \<open>@-\<close> 65) where
  "shift [] \<sigma> = \<sigma>"
| "shift (x # xs) \<sigma> = (\<lambda>i. case i of 0 \<Rightarrow> x | Suc i \<Rightarrow> shift xs \<sigma> i)"

(* FIXME misleading: this is \<sigma>(i, i+j). Use a bundle for this notation. FIXME move *)
abbreviation interval_syn ("_'(_ \<rightarrow> _')" [69, 0, 0] 70) where (* FIXME priorities *)
  "\<sigma>(i \<rightarrow> j) \<equiv> stake j (\<sigma> |\<^sub>s i)"

lemma suffix_eval: "(\<sigma> |\<^sub>s i) j = \<sigma> (j + i)"
unfolding suffix_def by simp

lemma suffix_plus: "\<sigma> |\<^sub>s n |\<^sub>s m = \<sigma> |\<^sub>s (m + n)"
unfolding suffix_def by (simp add: add.assoc)

lemma suffix_commute: "((\<sigma> |\<^sub>s n) |\<^sub>s m) = ((\<sigma> |\<^sub>s m) |\<^sub>s n)"
by (simp add: suffix_plus add.commute)

lemma suffix_plus_com: "\<sigma> |\<^sub>s m |\<^sub>s n = \<sigma> |\<^sub>s (m + n)"
proof -
  have "\<sigma> |\<^sub>s n |\<^sub>s m = \<sigma> |\<^sub>s (m + n)" by (rule suffix_plus)
  then show "\<sigma> |\<^sub>s m |\<^sub>s n = \<sigma> |\<^sub>s (m + n)" by (simp add: suffix_commute)
qed

lemma suffix_zero: "\<sigma> |\<^sub>s 0 = \<sigma>"
unfolding suffix_def by simp

lemma comp_suffix: "f \<circ> \<sigma> |\<^sub>s i = (f \<circ> \<sigma>) |\<^sub>s i"
unfolding suffix_def comp_def by simp

lemmas suffix_simps[simp] =
  comp_suffix
  suffix_eval
  suffix_plus_com
  suffix_zero

lemma length_stake[simp]: "length (stake n s) = n"
by (induct n arbitrary: s) auto

lemma shift_simps[simp]:
   "(xs @- \<sigma>) 0 = (if xs = [] then \<sigma> 0 else hd xs)"
   "(xs @- \<sigma>) |\<^sub>s Suc 0 = (if xs = [] then \<sigma> |\<^sub>s Suc 0 else tl xs @- \<sigma>)"
by (induct xs) auto

lemma stake_nil[simp]:
  "stake i \<sigma> = [] \<longleftrightarrow> i = 0"
by (cases i; clarsimp)

lemma stake_shift:
  "stake i (w @- \<sigma>) = take i w @ stake (i - length w) \<sigma>"
by (induct i arbitrary: w) (auto simp: neq_Nil_conv)

lemma shift_snth_less[simp]:
  assumes "i < length xs"
  shows "(xs @- \<sigma>) i = xs ! i"
using assms
proof(induct i arbitrary: xs)
  case (Suc i xs) then show ?case by (cases xs) simp_all
qed (simp add: hd_conv_nth nth_tl)

lemma shift_snth_ge[simp]:
  assumes "i \<ge> length xs"
  shows "(xs @- \<sigma>) i = \<sigma> (i - length xs)"
using assms
proof(induct i arbitrary: xs)
  case (Suc i xs) then show ?case by (cases xs) simp_all
qed simp

lemma shift_snth:
  "(xs @- \<sigma>) i = (if i < length xs then xs ! i else \<sigma> (i - length xs))"
by simp

lemma suffix_shift:
  "(xs @- \<sigma>) |\<^sub>s i = drop i xs @- (\<sigma> |\<^sub>s i - length xs)"
proof(induct i arbitrary: xs)
  case (Suc i xs) then show ?case by (cases xs) simp_all
qed simp

lemma stake_nth[simp]:
  assumes "i < j"
  shows "stake j s ! i = s i"
using assms by (induct j arbitrary: s i) (simp_all add: nth_Cons')

lemma stake_suffix_id:
  "stake i \<sigma> @- (\<sigma> |\<^sub>s i) = \<sigma>"
by (induct i) (simp_all add: fun_eq_iff shift_snth split: nat.splits)

lemma id_stake_snth_suffix:
  "\<sigma> = (stake i \<sigma> @ [\<sigma> i]) @- (\<sigma> |\<^sub>s Suc i)"
using stake_suffix_id
apply (metis Suc_diff_le append_Nil2 diff_is_0_eq length_stake lessI nat.simps(3) nat_le_linear shift_snth stake_nil stake_shift take_Suc_conv_app_nth)
done

lemma stake_add[simp]:
  "stake i \<sigma> @ stake j (\<sigma> |\<^sub>s i) = stake (i + j) \<sigma>"
apply (induct i arbitrary: \<sigma>)
 apply simp
apply auto
apply (metis One_nat_def plus_1_eq_Suc suffix_plus_com)
done

lemma stake_append: "stake n (u @- s) = take (min (length u) n) u @ stake (n - length u) s"
proof (induct n arbitrary: u)
  case (Suc n) then show ?case
    apply clarsimp
    apply (cases u)
    apply auto
    done
qed auto

lemma stake_shift_stake_shift:
  "stake i \<sigma> @- stake j (\<sigma> |\<^sub>s i) @- \<beta> = stake (i + j) \<sigma> @- \<beta>"
apply (induct i arbitrary: \<sigma>)
 apply simp
apply auto
apply (metis One_nat_def plus_1_eq_Suc suffix_plus_com)
done

lemma stake_suffix_drop:
  "stake i (\<sigma> |\<^sub>s j) = drop j (stake (i + j) \<sigma>)"
by (metis append_eq_conv_conj length_stake semiring_normalization_rules(24) stake_add)

lemma stake_suffix:
  assumes "i \<le> j"
  shows "stake j \<sigma> @- u |\<^sub>s i = \<sigma>(i \<rightarrow> j - i) @- u"
by (simp add: assms stake_suffix_drop suffix_shift)

subsection\<open>Decomposing safety and liveness \label{sec:infinite_sequences-safety-liveness}\<close>

text\<open>

Famously properties on infinite sequences can be decomposed into
@{emph \<open>safety\<close>} and @{emph \<open>liveness\<close>}
properties \<^cite>\<open>"AlpernSchneider:1985" and "Schneider:1987"\<close>. See
\<^citet>\<open>"Kindler:1994"\<close> for an overview.

\<close>

definition safety :: "'a seq_pred \<Rightarrow> bool" where
  "safety P \<longleftrightarrow> (\<forall>\<sigma>. \<not>P \<sigma> \<longrightarrow> (\<exists>i. \<forall>\<beta>. \<not>P (stake i \<sigma> @- \<beta>)))"

lemma safety_def2: \<comment> \<open>Contraposition gives the customary prefix-closure definition\<close>
  "safety P \<longleftrightarrow> (\<forall>\<sigma>. (\<forall>i. \<exists>\<beta>. P (stake i \<sigma> @- \<beta>)) \<longrightarrow> P \<sigma>)"
unfolding safety_def by blast

definition liveness :: "'a seq_pred \<Rightarrow> bool" where
  "liveness P \<longleftrightarrow> (\<forall>\<alpha>. \<exists>\<sigma>. P (\<alpha> @- \<sigma>))"

lemmas safetyI = iffD2[OF safety_def, rule_format]
lemmas safetyI2 = iffD2[OF safety_def2, rule_format]
lemmas livenessI = iffD2[OF liveness_def, rule_format]

lemma safety_False:
  shows "safety (\<lambda>\<sigma>. False)"
by (rule safetyI) simp

lemma safety_True:
  shows "safety (\<lambda>\<sigma>. True)"
by (rule safetyI) simp

lemma safety_state_prop:
  shows "safety (\<lambda>\<sigma>. P (\<sigma> 0))"
by (rule safetyI) auto

lemma safety_invariant:
  shows "safety (\<lambda>\<sigma>. \<forall>i. P (\<sigma> i))"
apply (rule safetyI)
apply clarsimp
apply (metis length_stake lessI shift_snth_less stake_nth)
done

lemma safety_transition_relation:
  shows "safety (\<lambda>\<sigma>. \<forall>i. (\<sigma> i, \<sigma> (i + 1)) \<in> R)"
apply (rule safetyI)
apply clarsimp
apply (metis (no_types, opaque_lifting) Suc_eq_plus1 add.left_neutral add_Suc_right add_diff_cancel_left' le_add1 list.sel(1) list.simps(3) shift_simps(1) stake.simps(2) stake_suffix suffix_def)
done

lemma safety_conj:
  assumes "safety P"
  assumes "safety Q"
  shows "safety (P \<^bold>\<and> Q)"
using assms unfolding safety_def by blast

lemma safety_always_eventually[simplified]:
  assumes "safety P"
  assumes "\<forall>i. \<exists>j\<ge>i. \<exists>\<beta>. P (\<sigma>(0 \<rightarrow> j) @- \<beta>)"
  shows "P \<sigma>"
using assms unfolding safety_def2
apply -
apply (drule_tac x=\<sigma> in spec)
apply clarsimp
apply (drule_tac x=i in spec)
apply clarsimp
apply (rule_tac x="(stake j \<sigma> @- \<beta>) |\<^sub>s i" in exI)
apply (simp add: stake_shift_stake_shift stake_suffix)
done

lemma safety_disj:
  assumes "safety P"
  assumes "safety Q"
  shows "safety (P \<^bold>\<or> Q)"
unfolding safety_def2 using assms
by (metis safety_always_eventually add_diff_cancel_right' diff_le_self le_add_same_cancel2)

text\<open>

The decomposition is given by a form of closure.

\<close>

definition M\<^sub>p :: "'a seq_pred \<Rightarrow> 'a seq_pred" where
  "M\<^sub>p P = (\<lambda>\<sigma>. \<forall>i. \<exists>\<beta>. P (stake i \<sigma> @- \<beta>))"

definition Safe :: "'a seq_pred \<Rightarrow> 'a seq_pred" where
  "Safe P = (P \<^bold>\<or> M\<^sub>p P)"

definition Live :: "'a seq_pred \<Rightarrow> 'a seq_pred" where
  "Live P = (P \<^bold>\<or> \<^bold>\<not>M\<^sub>p P)"

lemma decomp:
  "P = (Safe P \<^bold>\<and> Live P)"
unfolding Safe_def Live_def by blast

lemma safe:
  "safety (Safe P)"
unfolding Safe_def safety_def M\<^sub>p_def
apply clarsimp
apply (simp add: stake_shift)
apply (rule_tac x=i in exI)
apply clarsimp
apply (rule_tac x=i in exI)
apply clarsimp
done

lemma live:
  "liveness (Live P)"
proof(rule livenessI)
  fix \<alpha>
  have "(\<exists>\<beta>. P (\<alpha> @- \<beta>)) \<or> \<not>(\<exists>\<beta>. P (\<alpha> @- \<beta>))" by blast
  also have "?this \<longleftrightarrow> (\<exists>\<beta>. P (\<alpha> @- \<beta>) \<or> (\<forall>\<gamma>. \<not>P (\<alpha> @- \<gamma>)))" by blast
  also have "\<dots> \<longleftrightarrow> (\<exists>\<beta>. P (\<alpha> @- \<beta>) \<or> (\<exists>i. i = length \<alpha> \<and> (\<forall>\<gamma>. \<not>P (stake i (\<alpha> @- \<beta>) @- \<gamma>))))" by (simp add: stake_shift)
  also have "\<dots> \<longrightarrow> (\<exists>\<beta>. P (\<alpha> @- \<beta>) \<or> (\<exists>i. (\<forall>\<gamma>. \<not>P (stake i (\<alpha> @- \<beta>) @- \<gamma>))))" by blast
  finally have "\<exists>\<beta>. P (\<alpha> @- \<beta>) \<or> (\<exists>i. \<forall>\<gamma>. \<not> P (stake i (\<alpha> @- \<beta>) @- \<gamma>))" .
  then show "\<exists>\<sigma>. Live P (\<alpha> @- \<sigma>)" unfolding Live_def M\<^sub>p_def by simp
qed

text\<open>

\<^cite>\<open>"Sistla:1994"\<close> proceeds to give a topological analysis of fairness. An \<^emph>\<open>absolute\<close>
liveness property is a liveness property whose complement is stable.

\<close>

definition absolute_liveness :: "'a seq_pred \<Rightarrow> bool" where \<comment> \<open> closed under prepending any finite sequence \<close>
  "absolute_liveness P \<longleftrightarrow> (\<exists>\<sigma>. P \<sigma>) \<and> (\<forall>\<sigma> \<alpha>. P \<sigma> \<longrightarrow> P (\<alpha> @- \<sigma>))"

definition stable :: "'a seq_pred \<Rightarrow> bool" where \<comment> \<open> closed under suffixes \<close>
  "stable P \<longleftrightarrow> (\<exists>\<sigma>. P \<sigma>) \<and> (\<forall>\<sigma> i. P \<sigma> \<longrightarrow> P (\<sigma> |\<^sub>s i))"

lemma absolute_liveness_liveness:
  assumes "absolute_liveness P"
  shows "liveness P"
using assms unfolding absolute_liveness_def liveness_def by blast

lemma stable_absolute_liveness:
  assumes "P \<sigma>"
  assumes "\<not>P \<sigma>'" \<comment>\<open> extra hypothesis \<close>
  shows "stable P \<longleftrightarrow> absolute_liveness (\<^bold>\<not> P)"
using assms unfolding stable_def absolute_liveness_def
apply auto
 apply (metis cancel_comm_monoid_add_class.diff_cancel drop_eq_Nil order_refl shift.simps(1) suffix_shift suffix_zero)
apply (metis stake_suffix_id)
done

(*
text\<open>

Fairness ala Sistla. Unmotivated.

FIXME safety properties are insensitive to fairness.
FIXME typically we prove \<open>sys \<longrightarrow> safety\<close>. The result below doesn't appear strong enough.
FIXME observe fairness is a special liveness property.

\<close>
*)

definition fairness :: "'a seq_pred \<Rightarrow> bool" where
  "fairness P \<longleftrightarrow> stable P \<and> absolute_liveness P"

lemma fairness_safety:
  assumes "safety P"
  assumes "fairness F"
  shows "(\<forall>\<sigma>. F \<sigma> \<longrightarrow> P \<sigma>) \<longleftrightarrow> (\<forall>\<sigma>. P \<sigma>)"
apply rule
using assms
apply clarsimp
unfolding safety_def fairness_def stable_def absolute_liveness_def
apply clarsimp
apply blast+
done

(*<*)

end
(*>*)


(*  Title:      HOL/Library/While_Combinator.thy
    Author:     Tobias Nipkow
    Author:     Alexander Krauss
*)

section \<open>A general ``while'' combinator\<close>

theory While_Combinator
imports Main
begin

subsection \<open>Partial version\<close>

definition while_option :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
"while_option b c s = (if (\<exists>k. ~ b ((c ^^ k) s))
   then Some ((c ^^ (LEAST k. ~ b ((c ^^ k) s))) s)
   else None)"

theorem while_option_unfold[code]:
"while_option b c s = (if b s then while_option b c (c s) else Some s)"
proof cases
  assume "b s"
  show ?thesis
  proof (cases "\<exists>k. ~ b ((c ^^ k) s)")
    case True
    then obtain k where 1: "~ b ((c ^^ k) s)" ..
    with \<open>b s\<close> obtain l where "k = Suc l" by (cases k) auto
    with 1 have "~ b ((c ^^ l) (c s))" by (auto simp: funpow_swap1)
    then have 2: "\<exists>l. ~ b ((c ^^ l) (c s))" ..
    from 1
    have "(LEAST k. ~ b ((c ^^ k) s)) = Suc (LEAST l. ~ b ((c ^^ Suc l) s))"
      by (rule Least_Suc) (simp add: \<open>b s\<close>)
    also have "... = Suc (LEAST l. ~ b ((c ^^ l) (c s)))"
      by (simp add: funpow_swap1)
    finally
    show ?thesis
      using True 2 \<open>b s\<close> by (simp add: funpow_swap1 while_option_def)
  next
    case False
    then have "~ (\<exists>l. ~ b ((c ^^ Suc l) s))" by blast
    then have "~ (\<exists>l. ~ b ((c ^^ l) (c s)))"
      by (simp add: funpow_swap1)
    with False  \<open>b s\<close> show ?thesis by (simp add: while_option_def)
  qed
next
  assume [simp]: "~ b s"
  have least: "(LEAST k. ~ b ((c ^^ k) s)) = 0"
    by (rule Least_equality) auto
  moreover
  have "\<exists>k. ~ b ((c ^^ k) s)" by (rule exI[of _ "0::nat"]) auto
  ultimately show ?thesis unfolding while_option_def by auto
qed

lemma while_option_stop2:
 "while_option b c s = Some t \<Longrightarrow> EX k. t = (c^^k) s \<and> \<not> b t"
apply(simp add: while_option_def split: if_splits)
by (metis (lifting) LeastI_ex)

lemma while_option_stop: "while_option b c s = Some t \<Longrightarrow> ~ b t"
by(metis while_option_stop2)

theorem while_option_rule:
  assumes step: "!!s. P s ==> b s ==> P (c s)"
    and result: "while_option b c s = Some t"
    and init: "P s"
  shows "P t"
proof -
  define k where "k = (LEAST k. ~ b ((c ^^ k) s))"
  from assms have t: "t = (c ^^ k) s"
    by (simp add: while_option_def k_def split: if_splits)
  have 1: "ALL i<k. b ((c ^^ i) s)"
    by (auto simp: k_def dest: not_less_Least)

  { fix i assume "i <= k" then have "P ((c ^^ i) s)"
      by (induct i) (auto simp: init step 1) }
  thus "P t" by (auto simp: t)
qed

lemma funpow_commute:
  "\<lbrakk>\<forall>k' < k. f (c ((c^^k') s)) = c' (f ((c^^k') s))\<rbrakk> \<Longrightarrow> f ((c^^k) s) = (c'^^k) (f s)"
by (induct k arbitrary: s) auto

lemma while_option_commute_invariant:
assumes Invariant: "\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> P (c s)"
assumes TestCommute: "\<And>s. P s \<Longrightarrow> b s = b' (f s)"
assumes BodyCommute: "\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> f (c s) = c' (f s)"
assumes Initial: "P s"
shows "map_option f (while_option b c s) = while_option b' c' (f s)"
unfolding while_option_def
proof (rule trans[OF if_distrib if_cong], safe, unfold option.inject)
  fix k
  assume "\<not> b ((c ^^ k) s)"
  with Initial show "\<exists>k. \<not> b' ((c' ^^ k) (f s))"
  proof (induction k arbitrary: s)
    case 0 thus ?case by (auto simp: TestCommute intro: exI[of _ 0])
  next
    case (Suc k) thus ?case
    proof (cases "b s")
      assume "b s"
      with Suc.IH[of "c s"] Suc.prems show ?thesis
        by (metis BodyCommute Invariant comp_apply funpow.simps(2) funpow_swap1)
    next
      assume "\<not> b s"
      with Suc show ?thesis by (auto simp: TestCommute intro: exI [of _ 0])
    qed
  qed
next
  fix k
  assume "\<not> b' ((c' ^^ k) (f s))"
  with Initial show "\<exists>k. \<not> b ((c ^^ k) s)"
  proof (induction k arbitrary: s)
    case 0 thus ?case by (auto simp: TestCommute intro: exI[of _ 0])
  next
    case (Suc k) thus ?case
    proof (cases "b s")
       assume "b s"
      with Suc.IH[of "c s"] Suc.prems show ?thesis
        by (metis BodyCommute Invariant comp_apply funpow.simps(2) funpow_swap1)
    next
      assume "\<not> b s"
      with Suc show ?thesis by (auto simp: TestCommute intro: exI [of _ 0])
    qed
  qed
next
  fix k
  assume k: "\<not> b' ((c' ^^ k) (f s))"
  have *: "(LEAST k. \<not> b' ((c' ^^ k) (f s))) = (LEAST k. \<not> b ((c ^^ k) s))"
          (is "?k' = ?k")
  proof (cases ?k')
    case 0
    have "\<not> b' ((c' ^^ 0) (f s))"
      unfolding 0[symmetric] by (rule LeastI[of _ k]) (rule k)
    hence "\<not> b s" by (auto simp: TestCommute Initial)
    hence "?k = 0" by (intro Least_equality) auto
    with 0 show ?thesis by auto
  next
    case (Suc k')
    have "\<not> b' ((c' ^^ Suc k') (f s))"
      unfolding Suc[symmetric] by (rule LeastI) (rule k)
    moreover
    { fix k assume "k \<le> k'"
      hence "k < ?k'" unfolding Suc by simp
      hence "b' ((c' ^^ k) (f s))" by (rule iffD1[OF not_not, OF not_less_Least])
    }
    note b' = this
    { fix k assume "k \<le> k'"
      hence "f ((c ^^ k) s) = (c' ^^ k) (f s)"
      and "b ((c ^^ k) s) = b' ((c' ^^ k) (f s))"
      and "P ((c ^^ k) s)"
        by (induct k) (auto simp: b' assms)
      with \<open>k \<le> k'\<close>
      have "b ((c ^^ k) s)"
      and "f ((c ^^ k) s) = (c' ^^ k) (f s)"
      and "P ((c ^^ k) s)"
        by (auto simp: b')
    }
    note b = this(1) and body = this(2) and inv = this(3)
    hence k': "f ((c ^^ k') s) = (c' ^^ k') (f s)" by auto
    ultimately show ?thesis unfolding Suc using b
    proof (intro Least_equality[symmetric], goal_cases)
      case 1
      hence Test: "\<not> b' (f ((c ^^ Suc k') s))"
        by (auto simp: BodyCommute inv b)
      have "P ((c ^^ Suc k') s)" by (auto simp: Invariant inv b)
      with Test show ?case by (auto simp: TestCommute)
    next
      case 2
      thus ?case by (metis not_less_eq_eq)
    qed
  qed
  have "f ((c ^^ ?k) s) = (c' ^^ ?k') (f s)" unfolding *
  proof (rule funpow_commute, clarify)
    fix k assume "k < ?k"
    hence TestTrue: "b ((c ^^ k) s)" by (auto dest: not_less_Least)
    from \<open>k < ?k\<close> have "P ((c ^^ k) s)"
    proof (induct k)
      case 0 thus ?case by (auto simp: assms)
    next
      case (Suc h)
      hence "P ((c ^^ h) s)" by auto
      with Suc show ?case
        by (auto, metis (lifting, no_types) Invariant Suc_lessD not_less_Least)
    qed
    with TestTrue show "f (c ((c ^^ k) s)) = c' (f ((c ^^ k) s))"
      by (metis BodyCommute)
  qed
  thus "\<exists>z. (c ^^ ?k) s = z \<and> f z = (c' ^^ ?k') (f s)" by blast
qed

lemma while_option_commute:
  assumes "\<And>s. b s = b' (f s)" "\<And>s. \<lbrakk>b s\<rbrakk> \<Longrightarrow> f (c s) = c' (f s)"
  shows "map_option f (while_option b c s) = while_option b' c' (f s)"
by(rule while_option_commute_invariant[where P = "\<lambda>_. True"])
  (auto simp add: assms)

subsection \<open>Total version\<close>

definition while :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
where "while b c s = the (while_option b c s)"

lemma while_unfold [code]:
  "while b c s = (if b s then while b c (c s) else s)"
unfolding while_def by (subst while_option_unfold) simp

lemma def_while_unfold:
  assumes fdef: "f == while test do"
  shows "f x = (if test x then f(do x) else x)"
unfolding fdef by (fact while_unfold)

text \<open>
 The proof rule for @{term while}, where @{term P} is the invariant.
\<close>

theorem while_rule_lemma:
  assumes invariant: "!!s. P s ==> b s ==> P (c s)"
    and terminate: "!!s. P s ==> \<not> b s ==> Q s"
    and wf: "wf {(t, s). P s \<and> b s \<and> t = c s}"
  shows "P s \<Longrightarrow> Q (while b c s)"
  using wf
  apply (induct s)
  apply simp
  apply (subst while_unfold)
  apply (simp add: invariant terminate)
  done

theorem while_rule:
  "[| P s;
      !!s. [| P s; b s  |] ==> P (c s);
      !!s. [| P s; \<not> b s  |] ==> Q s;
      wf r;
      !!s. [| P s; b s  |] ==> (c s, s) \<in> r |] ==>
   Q (while b c s)"
  apply (rule while_rule_lemma)
     prefer 4 apply assumption
    apply blast
   apply blast
  apply (erule wf_subset)
  apply blast
  done

text\<open>Proving termination:\<close>

theorem wf_while_option_Some:
  assumes "wf {(t, s). (P s \<and> b s) \<and> t = c s}"
  and "!!s. P s \<Longrightarrow> b s \<Longrightarrow> P(c s)" and "P s"
  shows "EX t. while_option b c s = Some t"
using assms(1,3)
proof (induction s)
  case less thus ?case using assms(2)
    by (subst while_option_unfold) simp
qed

lemma wf_rel_while_option_Some:
assumes wf: "wf R"
assumes smaller: "\<And>s. P s \<and> b s \<Longrightarrow> (c s, s) \<in> R"
assumes inv: "\<And>s. P s \<and> b s \<Longrightarrow> P(c s)"
assumes init: "P s"
shows "\<exists>t. while_option b c s = Some t"
proof -
 from smaller have "{(t,s). P s \<and> b s \<and> t = c s} \<subseteq> R" by auto
 with wf have "wf {(t,s). P s \<and> b s \<and> t = c s}" by (auto simp: wf_subset)
 with inv init show ?thesis by (auto simp: wf_while_option_Some)
qed

theorem measure_while_option_Some: fixes f :: "'s \<Rightarrow> nat"
shows "(!!s. P s \<Longrightarrow> b s \<Longrightarrow> P(c s) \<and> f(c s) < f s)
  \<Longrightarrow> P s \<Longrightarrow> EX t. while_option b c s = Some t"
by(blast intro: wf_while_option_Some[OF wf_if_measure, of P b f])

text\<open>Kleene iteration starting from the empty set and assuming some finite
bounding set:\<close>

lemma while_option_finite_subset_Some: fixes C :: "'a set"
  assumes "mono f" and "!!X. X \<subseteq> C \<Longrightarrow> f X \<subseteq> C" and "finite C"
  shows "\<exists>P. while_option (\<lambda>A. f A \<noteq> A) f {} = Some P"
proof(rule measure_while_option_Some[where
    f= "%A::'a set. card C - card A" and P= "%A. A \<subseteq> C \<and> A \<subseteq> f A" and s= "{}"])
  fix A assume A: "A \<subseteq> C \<and> A \<subseteq> f A" "f A \<noteq> A"
  show "(f A \<subseteq> C \<and> f A \<subseteq> f (f A)) \<and> card C - card (f A) < card C - card A"
    (is "?L \<and> ?R")
  proof
    show ?L by(metis A(1) assms(2) monoD[OF \<open>mono f\<close>])
    show ?R by (metis A assms(2,3) card_seteq diff_less_mono2 equalityI linorder_le_less_linear rev_finite_subset)
  qed
qed simp

lemma lfp_the_while_option:
  assumes "mono f" and "!!X. X \<subseteq> C \<Longrightarrow> f X \<subseteq> C" and "finite C"
  shows "lfp f = the(while_option (\<lambda>A. f A \<noteq> A) f {})"
proof-
  obtain P where "while_option (\<lambda>A. f A \<noteq> A) f {} = Some P"
    using while_option_finite_subset_Some[OF assms] by blast
  with while_option_stop2[OF this] lfp_Kleene_iter[OF assms(1)]
  show ?thesis by auto
qed

lemma lfp_while:
  assumes "mono f" and "!!X. X \<subseteq> C \<Longrightarrow> f X \<subseteq> C" and "finite C"
  shows "lfp f = while (\<lambda>A. f A \<noteq> A) f {}"
unfolding while_def using assms by (rule lfp_the_while_option) blast

lemma wf_finite_less:
  assumes "finite (C :: 'a::order set)"
  shows "wf {(x, y). {x, y} \<subseteq> C \<and> x < y}"
by (rule wf_measure[where f="\<lambda>b. card {a. a \<in> C \<and> a < b}", THEN wf_subset])
   (fastforce simp: less_eq assms intro: psubset_card_mono)

lemma wf_finite_greater:
  assumes "finite (C :: 'a::order set)"
  shows "wf {(x, y). {x, y} \<subseteq> C \<and> y < x}"
by (rule wf_measure[where f="\<lambda>b. card {a. a \<in> C \<and> b < a}", THEN wf_subset])
   (fastforce simp: less_eq assms intro: psubset_card_mono)

lemma while_option_finite_increasing_Some:
  fixes f :: "'a::order \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)" and "s \<le> f s"
  shows "\<exists>P. while_option (\<lambda>A. f A \<noteq> A) f s = Some P"
by (rule wf_rel_while_option_Some[where R="{(x, y). y < x}" and P="\<lambda>A. A \<le> f A" and s="s"])
   (auto simp: assms monoD intro: wf_finite_greater[where C="UNIV::'a set", simplified])

lemma lfp_the_while_option_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "lfp f = the (while_option (\<lambda>A. f A \<noteq> A) f bot)"
proof -
  obtain P where "while_option (\<lambda>A. f A \<noteq> A) f bot = Some P"
    using while_option_finite_increasing_Some[OF assms, where s=bot] by simp blast
  with while_option_stop2[OF this] lfp_Kleene_iter[OF assms(1)]
  show ?thesis by auto
qed

lemma lfp_while_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "lfp f = while (\<lambda>A. f A \<noteq> A) f bot"
unfolding while_def using assms by (rule lfp_the_while_option_lattice)

lemma while_option_finite_decreasing_Some:
  fixes f :: "'a::order \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)" and "f s \<le> s"
  shows "\<exists>P. while_option (\<lambda>A. f A \<noteq> A) f s = Some P"
by (rule wf_rel_while_option_Some[where R="{(x, y). x < y}" and P="\<lambda>A. f A \<le> A" and s="s"])
   (auto simp add: assms monoD intro: wf_finite_less[where C="UNIV::'a set", simplified])

lemma gfp_the_while_option_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "gfp f = the(while_option (\<lambda>A. f A \<noteq> A) f top)"
proof -
  obtain P where "while_option (\<lambda>A. f A \<noteq> A) f top = Some P"
    using while_option_finite_decreasing_Some[OF assms, where s=top] by simp blast
  with while_option_stop2[OF this] gfp_Kleene_iter[OF assms(1)]
  show ?thesis by auto
qed

lemma gfp_while_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "gfp f = while (\<lambda>A. f A \<noteq> A) f top"
unfolding while_def using assms by (rule gfp_the_while_option_lattice)

text\<open>Computing the reflexive, transitive closure by iterating a successor
function. Stops when an element is found that dos not satisfy the test.

More refined (and hence more efficient) versions can be found in ITP 2011 paper
by Nipkow (the theories are in the AFP entry Flyspeck by Nipkow)
and the AFP article Executable Transitive Closures by René Thiemann.\<close>

context
fixes p :: "'a \<Rightarrow> bool"
and f :: "'a \<Rightarrow> 'a list"
and x :: 'a
begin

qualified fun rtrancl_while_test :: "'a list \<times> 'a set \<Rightarrow> bool"
where "rtrancl_while_test (ws,_) = (ws \<noteq> [] \<and> p(hd ws))"

qualified fun rtrancl_while_step :: "'a list \<times> 'a set \<Rightarrow> 'a list \<times> 'a set"
where "rtrancl_while_step (ws, Z) =
  (let x = hd ws; new = remdups (filter (\<lambda>y. y \<notin> Z) (f x))
  in (new @ tl ws, set new \<union> Z))"

definition rtrancl_while :: "('a list * 'a set) option"
where "rtrancl_while = while_option rtrancl_while_test rtrancl_while_step ([x],{x})"

qualified fun rtrancl_while_invariant :: "'a list \<times> 'a set \<Rightarrow> bool"
where "rtrancl_while_invariant (ws, Z) =
   (x \<in> Z \<and> set ws \<subseteq> Z \<and> distinct ws \<and> {(x,y). y \<in> set(f x)} `` (Z - set ws) \<subseteq> Z \<and>
    Z \<subseteq> {(x,y). y \<in> set(f x)}^* `` {x} \<and> (\<forall>z\<in>Z - set ws. p z))"

qualified lemma rtrancl_while_invariant:
  assumes inv: "rtrancl_while_invariant st" and test: "rtrancl_while_test st"
  shows   "rtrancl_while_invariant (rtrancl_while_step st)"
proof (cases st)
  fix ws Z assume st: "st = (ws, Z)"
  with test obtain h t where "ws = h # t" "p h" by (cases ws) auto
  with inv st show ?thesis by (auto intro: rtrancl.rtrancl_into_rtrancl)
qed

lemma rtrancl_while_Some: assumes "rtrancl_while = Some(ws,Z)"
shows "if ws = []
       then Z = {(x,y). y \<in> set(f x)}^* `` {x} \<and> (\<forall>z\<in>Z. p z)
       else \<not>p(hd ws) \<and> hd ws \<in> {(x,y). y \<in> set(f x)}^* `` {x}"
proof -
  have "rtrancl_while_invariant ([x],{x})" by simp
  with rtrancl_while_invariant have I: "rtrancl_while_invariant (ws,Z)"
    by (rule while_option_rule[OF _ assms[unfolded rtrancl_while_def]])
  { assume "ws = []"
    hence ?thesis using I
      by (auto simp del:Image_Collect_case_prod dest: Image_closed_trancl)
  } moreover
  { assume "ws \<noteq> []"
    hence ?thesis using I while_option_stop[OF assms[unfolded rtrancl_while_def]]
      by (simp add: subset_iff)
  }
  ultimately show ?thesis by simp
qed

lemma rtrancl_while_finite_Some:
  assumes "finite ({(x, y). y \<in> set (f x)}\<^sup>* `` {x})" (is "finite ?Cl")
  shows "\<exists>y. rtrancl_while = Some y"
proof -
  let ?R = "(\<lambda>(_, Z). card (?Cl - Z)) <*mlex*> (\<lambda>(ws, _). length ws) <*mlex*> {}"
  have "wf ?R" by (blast intro: wf_mlex)
  then show ?thesis unfolding rtrancl_while_def
  proof (rule wf_rel_while_option_Some[of ?R rtrancl_while_invariant])
    fix st assume *: "rtrancl_while_invariant st \<and> rtrancl_while_test st"
    hence I: "rtrancl_while_invariant (rtrancl_while_step st)"
      by (blast intro: rtrancl_while_invariant)
    show "(rtrancl_while_step st, st) \<in> ?R"
    proof (cases st)
      fix ws Z let ?ws = "fst (rtrancl_while_step st)" and ?Z = "snd (rtrancl_while_step st)"
      assume st: "st = (ws, Z)"
      with * obtain h t where ws: "ws = h # t" "p h" by (cases ws) auto
      { assume "remdups (filter (\<lambda>y. y \<notin> Z) (f h)) \<noteq> []"
        then obtain z where "z \<in> set (remdups (filter (\<lambda>y. y \<notin> Z) (f h)))" by fastforce
        with st ws I have "Z \<subset> ?Z" "Z \<subseteq> ?Cl" "?Z \<subseteq> ?Cl" by auto
        with assms have "card (?Cl - ?Z) < card (?Cl - Z)" by (blast intro: psubset_card_mono)
        with st ws have ?thesis unfolding mlex_prod_def by simp
      }
      moreover
      { assume "remdups (filter (\<lambda>y. y \<notin> Z) (f h)) = []"
        with st ws have "?Z = Z" "?ws = t"  by (auto simp: filter_empty_conv)
        with st ws have ?thesis unfolding mlex_prod_def by simp
      }
      ultimately show ?thesis by blast
    qed
  qed (simp_all add: rtrancl_while_invariant)
qed

end

end


section \<open> Used-by \<close>

theory utp_usedby
  imports utp_unrest
begin

text \<open> The used-by predicate is the dual of unrestriction. It states that the given lens is an
  upper-bound on the size of state space the given expression depends on. It is similar to stating
  that the lens is a valid alphabet for the predicate. For convenience, and because the predicate
  uses a similar form, we will reuse much of unrestriction's infrastructure. \<close>

consts
  usedBy :: "'a \<Rightarrow> 'b \<Rightarrow> bool"

syntax
  "_usedBy" :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<natural>" 20)

translations
  "_usedBy x p" == "CONST usedBy x p"
  "_usedBy (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_usedBy (x +\<^sub>L y) P"

lift_definition usedBy_uexpr :: "('b \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> bool"
is "\<lambda> x e. (\<forall> b b'. e (b' \<oplus>\<^sub>L b on x) = e b)" .

adhoc_overloading usedBy usedBy_uexpr

lemma usedBy_lit [unrest]: "x \<natural> \<guillemotleft>v\<guillemotright>"
  by (transfer, simp)

lemma usedBy_sublens:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "x \<natural> P" "x \<subseteq>\<^sub>L y" "vwb_lens y"
  shows "y \<natural> P"
  using assms
  by (transfer, auto, metis Lens_Order.lens_override_idem lens_override_def sublens_obs_get vwb_lens_mwb)

lemma usedBy_svar [unrest]: "x \<natural> P \<Longrightarrow> &x \<natural> P"
  by (transfer, simp add: lens_defs)

lemma usedBy_lens_plus_1 [unrest]: "x \<natural> P \<Longrightarrow> x;y \<natural> P"
  by (transfer, simp add: lens_defs)

lemma usedBy_lens_plus_2 [unrest]: "\<lbrakk> x \<bowtie> y; y \<natural> P \<rbrakk> \<Longrightarrow> x;y \<natural> P"
  by (transfer, auto simp add: lens_defs lens_indep_comm)

text \<open> Linking used-by to unrestriction: if x is used-by P, and x is independent of y, then
  P cannot depend on any variable in y. \<close>

lemma usedBy_indep_uses:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "x \<natural> P" "x \<bowtie> y"
  shows "y \<sharp> P"
  using assms by (transfer, auto, metis lens_indep_get lens_override_def)

lemma usedBy_var [unrest]:
  assumes "vwb_lens x" "y \<subseteq>\<^sub>L x"
  shows "x \<natural> var y"
  using assms
  by (transfer, simp add: uexpr_defs pr_var_def)
     (metis lens_override_def sublens_obs_get vwb_lens_def wb_lens.get_put)

lemma usedBy_uop [unrest]: "x \<natural> e \<Longrightarrow> x \<natural> uop f e"
  by (transfer, simp)

lemma usedBy_bop [unrest]: "\<lbrakk> x \<natural> u; x \<natural> v \<rbrakk> \<Longrightarrow> x \<natural> bop f u v"
  by (transfer, simp)

lemma usedBy_trop [unrest]: "\<lbrakk> x \<natural> u; x \<natural> v; x \<natural> w \<rbrakk> \<Longrightarrow> x \<natural> trop f u v w"
  by (transfer, simp)

lemma usedBy_qtop [unrest]: "\<lbrakk> x \<natural> u; x \<natural> v; x \<natural> w; x \<natural> y \<rbrakk> \<Longrightarrow> x \<natural> qtop f u v w y"
  by (transfer, simp)

text \<open> For convenience, we also prove used-by rules for the bespoke operators on equality,
  numbers, arithmetic etc. \<close>

lemma usedBy_eq [unrest]: "\<lbrakk> x \<natural> u; x \<natural> v \<rbrakk> \<Longrightarrow> x \<natural> u =\<^sub>u v"
  by (simp add: eq_upred_def, transfer, simp)

lemma usedBy_zero [unrest]: "x \<natural> 0"
  by (simp add: usedBy_lit zero_uexpr_def)

lemma usedBy_one [unrest]: "x \<natural> 1"
  by (simp add: one_uexpr_def usedBy_lit)

lemma usedBy_numeral [unrest]: "x \<natural> (numeral n)"
  by (simp add: numeral_uexpr_simp usedBy_lit)

lemma usedBy_sgn [unrest]: "x \<natural> u \<Longrightarrow> x \<natural> sgn u"
  by (simp add: sgn_uexpr_def usedBy_uop)

lemma usedBy_abs [unrest]: "x \<natural> u \<Longrightarrow> x \<natural> abs u"
  by (simp add: abs_uexpr_def usedBy_uop)

lemma usedBy_plus [unrest]: "\<lbrakk> x \<natural> u; x \<natural> v \<rbrakk> \<Longrightarrow> x \<natural> u + v"
  by (simp add: plus_uexpr_def unrest)

lemma usedBy_uminus [unrest]: "x \<natural> u \<Longrightarrow> x \<natural> - u"
  by (simp add: uminus_uexpr_def unrest)

lemma usedBy_minus [unrest]: "\<lbrakk> x \<natural> u; x \<natural> v \<rbrakk> \<Longrightarrow> x \<natural> u - v"
  by (simp add: minus_uexpr_def unrest)

lemma usedBy_times [unrest]: "\<lbrakk> x \<natural> u; x \<natural> v \<rbrakk> \<Longrightarrow> x \<natural> u * v"
  by (simp add: times_uexpr_def unrest)

lemma usedBy_divide [unrest]: "\<lbrakk> x \<natural> u; x \<natural> v \<rbrakk> \<Longrightarrow> x \<natural> u / v"
  by (simp add: divide_uexpr_def unrest)

lemma usedBy_ulambda [unrest]:
  "\<lbrakk> \<And> x. v \<natural> F x \<rbrakk> \<Longrightarrow> v \<natural> (\<lambda> x \<bullet> F x)"
  by (transfer, simp)

lemma unrest_var_sep [unrest]:
  "vwb_lens x \<Longrightarrow> x \<natural> &x:y"
  by (transfer, simp add: lens_defs)

end


(*  Title:      ZF/Arith.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

(*"Difference" is subtraction of natural numbers.
  There are no negative numbers; we have
     m #- n = 0  iff  m<=n   and     m #- n = succ(k) iff m>n.
  Also, rec(m, 0, %z w.z) is pred(m).
*)

section{*Arithmetic Operators and Their Definitions*}

theory Arith imports Univ begin

text{*Proofs about elementary arithmetic: addition, multiplication, etc.*}

definition
  pred   :: "i=>i"    (*inverse of succ*)  where
    "pred(y) == nat_case(0, %x. x, y)"

definition
  natify :: "i=>i"    (*coerces non-nats to nats*)  where
    "natify == Vrecursor(%f a. if a = succ(pred(a)) then succ(f`pred(a))
                                                    else 0)"

consts
  raw_add  :: "[i,i]=>i"
  raw_diff  :: "[i,i]=>i"
  raw_mult  :: "[i,i]=>i"

primrec
  "raw_add (0, n) = n"
  "raw_add (succ(m), n) = succ(raw_add(m, n))"

primrec
  raw_diff_0:     "raw_diff(m, 0) = m"
  raw_diff_succ:  "raw_diff(m, succ(n)) =
                     nat_case(0, %x. x, raw_diff(m, n))"

primrec
  "raw_mult(0, n) = 0"
  "raw_mult(succ(m), n) = raw_add (n, raw_mult(m, n))"

definition
  add :: "[i,i]=>i"                    (infixl "#+" 65)  where
    "m #+ n == raw_add (natify(m), natify(n))"

definition
  diff :: "[i,i]=>i"                    (infixl "#-" 65)  where
    "m #- n == raw_diff (natify(m), natify(n))"

definition
  mult :: "[i,i]=>i"                    (infixl "#*" 70)  where
    "m #* n == raw_mult (natify(m), natify(n))"

definition
  raw_div  :: "[i,i]=>i"  where
    "raw_div (m, n) ==
       transrec(m, %j f. if j<n | n=0 then 0 else succ(f`(j#-n)))"

definition
  raw_mod  :: "[i,i]=>i"  where
    "raw_mod (m, n) ==
       transrec(m, %j f. if j<n | n=0 then j else f`(j#-n))"

definition
  div  :: "[i,i]=>i"                    (infixl "div" 70)  where
    "m div n == raw_div (natify(m), natify(n))"

definition
  mod  :: "[i,i]=>i"                    (infixl "mod" 70)  where
    "m mod n == raw_mod (natify(m), natify(n))"

notation (xsymbols)
  mult  (infixr "#\<times>" 70)

notation (HTML output)
  mult  (infixr "#\<times>" 70)

declare rec_type [simp]
        nat_0_le [simp]

lemma zero_lt_lemma: "[| 0<k; k \<in> nat |] ==> \<exists>j\<in>nat. k = succ(j)"
apply (erule rev_mp)
apply (induct_tac "k", auto)
done

(* @{term"[| 0 < k; k \<in> nat; !!j. [| j \<in> nat; k = succ(j) |] ==> Q |] ==> Q"} *)
lemmas zero_lt_natE = zero_lt_lemma [THEN bexE]

subsection{*@{text natify}, the Coercion to @{term nat}*}

lemma pred_succ_eq [simp]: "pred(succ(y)) = y"
by (unfold pred_def, auto)

lemma natify_succ: "natify(succ(x)) = succ(natify(x))"
by (rule natify_def [THEN def_Vrecursor, THEN trans], auto)

lemma natify_0 [simp]: "natify(0) = 0"
by (rule natify_def [THEN def_Vrecursor, THEN trans], auto)

lemma natify_non_succ: "\<forall>z. x \<noteq> succ(z) ==> natify(x) = 0"
by (rule natify_def [THEN def_Vrecursor, THEN trans], auto)

lemma natify_in_nat [iff,TC]: "natify(x) \<in> nat"
apply (rule_tac a=x in eps_induct)
apply (case_tac "\<exists>z. x = succ(z)")
apply (auto simp add: natify_succ natify_non_succ)
done

lemma natify_ident [simp]: "n \<in> nat ==> natify(n) = n"
apply (induct_tac "n")
apply (auto simp add: natify_succ)
done

lemma natify_eqE: "[|natify(x) = y;  x \<in> nat|] ==> x=y"
by auto

(*** Collapsing rules: to remove natify from arithmetic expressions ***)

lemma natify_idem [simp]: "natify(natify(x)) = natify(x)"
by simp

(** Addition **)

lemma add_natify1 [simp]: "natify(m) #+ n = m #+ n"
by (simp add: add_def)

lemma add_natify2 [simp]: "m #+ natify(n) = m #+ n"
by (simp add: add_def)

(** Multiplication **)

lemma mult_natify1 [simp]: "natify(m) #* n = m #* n"
by (simp add: mult_def)

lemma mult_natify2 [simp]: "m #* natify(n) = m #* n"
by (simp add: mult_def)

(** Difference **)

lemma diff_natify1 [simp]: "natify(m) #- n = m #- n"
by (simp add: diff_def)

lemma diff_natify2 [simp]: "m #- natify(n) = m #- n"
by (simp add: diff_def)

(** Remainder **)

lemma mod_natify1 [simp]: "natify(m) mod n = m mod n"
by (simp add: mod_def)

lemma mod_natify2 [simp]: "m mod natify(n) = m mod n"
by (simp add: mod_def)

(** Quotient **)

lemma div_natify1 [simp]: "natify(m) div n = m div n"
by (simp add: div_def)

lemma div_natify2 [simp]: "m div natify(n) = m div n"
by (simp add: div_def)

subsection{*Typing rules*}

(** Addition **)

lemma raw_add_type: "[| m\<in>nat;  n\<in>nat |] ==> raw_add (m, n) \<in> nat"
by (induct_tac "m", auto)

lemma add_type [iff,TC]: "m #+ n \<in> nat"
by (simp add: add_def raw_add_type)

(** Multiplication **)

lemma raw_mult_type: "[| m\<in>nat;  n\<in>nat |] ==> raw_mult (m, n) \<in> nat"
apply (induct_tac "m")
apply (simp_all add: raw_add_type)
done

lemma mult_type [iff,TC]: "m #* n \<in> nat"
by (simp add: mult_def raw_mult_type)

(** Difference **)

lemma raw_diff_type: "[| m\<in>nat;  n\<in>nat |] ==> raw_diff (m, n) \<in> nat"
by (induct_tac "n", auto)

lemma diff_type [iff,TC]: "m #- n \<in> nat"
by (simp add: diff_def raw_diff_type)

lemma diff_0_eq_0 [simp]: "0 #- n = 0"
apply (unfold diff_def)
apply (rule natify_in_nat [THEN nat_induct], auto)
done

(*Must simplify BEFORE the induction: else we get a critical pair*)
lemma diff_succ_succ [simp]: "succ(m) #- succ(n) = m #- n"
apply (simp add: natify_succ diff_def)
apply (rule_tac x1 = n in natify_in_nat [THEN nat_induct], auto)
done

(*This defining property is no longer wanted*)
declare raw_diff_succ [simp del]

(*Natify has weakened this law, compared with the older approach*)
lemma diff_0 [simp]: "m #- 0 = natify(m)"
by (simp add: diff_def)

lemma diff_le_self: "m\<in>nat ==> (m #- n) \<le> m"
apply (subgoal_tac " (m #- natify (n)) \<le> m")
apply (rule_tac [2] m = m and n = "natify (n) " in diff_induct)
apply (erule_tac [6] leE)
apply (simp_all add: le_iff)
done

subsection{*Addition*}

(*Natify has weakened this law, compared with the older approach*)
lemma add_0_natify [simp]: "0 #+ m = natify(m)"
by (simp add: add_def)

lemma add_succ [simp]: "succ(m) #+ n = succ(m #+ n)"
by (simp add: natify_succ add_def)

lemma add_0: "m \<in> nat ==> 0 #+ m = m"
by simp

(*Associative law for addition*)

(*The following two lemmas are used for add_commute and sometimes
  elsewhere, since they are safe for rewriting.*)
lemma add_0_right_natify [simp]: "m #+ 0 = natify(m)"
apply (subgoal_tac "natify(m) #+ 0 = natify(m)")
apply (rule_tac [2] n = "natify(m)" in nat_induct)
apply auto
done

lemma add_succ_right [simp]: "m #+ succ(n) = succ(m #+ n)"
apply (unfold add_def)
apply (rule_tac n = "natify(m) " in nat_induct)
apply (auto simp add: natify_succ)
done

lemma add_0_right: "m \<in> nat ==> m #+ 0 = m"
by auto

(*Commutative law for addition*)
lemma add_commute: "m #+ n = n #+ m"
apply (subgoal_tac "natify(m) #+ natify(n) = natify(n) #+ natify(m) ")
apply (rule_tac [2] n = "natify(m) " in nat_induct)
apply auto
done

(*for a/c rewriting*)
lemma add_left_commute: "m#+(n#+k)=n#+(m#+k)"
apply (rule add_commute [THEN trans])
apply (rule add_assoc [THEN trans])
apply (rule add_commute [THEN subst_context])
done

(*Addition is an AC-operator*)
lemmas add_ac = add_assoc add_commute add_left_commute

(*Cancellation law on the left*)
lemma raw_add_left_cancel:
     "[| raw_add(k, m) = raw_add(k, n);  k\<in>nat |] ==> m=n"
apply (erule rev_mp)
apply (induct_tac "k", auto)
done

lemma add_left_cancel_natify: "k #+ m = k #+ n ==> natify(m) = natify(n)"
apply (unfold add_def)
apply (drule raw_add_left_cancel, auto)
done

lemma add_left_cancel:
     "[| i = j;  i #+ m = j #+ n;  m\<in>nat;  n\<in>nat |] ==> m = n"
by (force dest!: add_left_cancel_natify)

(*Thanks to Sten Agerholm*)
lemma add_le_elim1_natify: "k#+m \<le> k#+n ==> natify(m) \<le> natify(n)"
apply (rule_tac P = "natify(k) #+m \<le> natify(k) #+n" in rev_mp)
apply (rule_tac [2] n = "natify(k) " in nat_induct)
apply auto
done

lemma add_le_elim1: "[| k#+m \<le> k#+n; m \<in> nat; n \<in> nat |] ==> m \<le> n"
by (drule add_le_elim1_natify, auto)

lemma add_lt_elim1_natify: "k#+m < k#+n ==> natify(m) < natify(n)"
apply (rule_tac P = "natify(k) #+m < natify(k) #+n" in rev_mp)
apply (rule_tac [2] n = "natify(k) " in nat_induct)
apply auto
done

lemma add_lt_elim1: "[| k#+m < k#+n; m \<in> nat; n \<in> nat |] ==> m < n"
by (drule add_lt_elim1_natify, auto)

lemma zero_less_add: "[| n \<in> nat; m \<in> nat |] ==> 0 < m #+ n \<longleftrightarrow> (0<m | 0<n)"
by (induct_tac "n", auto)

subsection{*Monotonicity of Addition*}

(*strict, in 1st argument; proof is by rule induction on 'less than'.
  Still need j\<in>nat, for consider j = omega.  Then we can have i<omega,
  which is the same as i\<in>nat, but natify(j)=0, so the conclusion fails.*)
lemma add_lt_mono1: "[| i<j; j\<in>nat |] ==> i#+k < j#+k"
apply (frule lt_nat_in_nat, assumption)
apply (erule succ_lt_induct)
apply (simp_all add: leI)
done

text{*strict, in second argument*}
lemma add_lt_mono2: "[| i<j; j\<in>nat |] ==> k#+i < k#+j"
by (simp add: add_commute [of k] add_lt_mono1)

text{*A [clumsy] way of lifting < monotonicity to @{text "\<le>"} monotonicity*}
lemma Ord_lt_mono_imp_le_mono:
  assumes lt_mono: "!!i j. [| i<j; j:k |] ==> f(i) < f(j)"
      and ford:    "!!i. i:k ==> Ord(f(i))"
      and leij:    "i \<le> j"
      and jink:    "j:k"
  shows "f(i) \<le> f(j)"
apply (insert leij jink)
apply (blast intro!: leCI lt_mono ford elim!: leE)
done

text{*@{text "\<le>"} monotonicity, 1st argument*}
lemma add_le_mono1: "[| i \<le> j; j\<in>nat |] ==> i#+k \<le> j#+k"
apply (rule_tac f = "%j. j#+k" in Ord_lt_mono_imp_le_mono, typecheck)
apply (blast intro: add_lt_mono1 add_type [THEN nat_into_Ord])+
done

text{*@{text "\<le>"} monotonicity, both arguments*}
lemma add_le_mono: "[| i \<le> j; k \<le> l; j\<in>nat; l\<in>nat |] ==> i#+k \<le> j#+l"
apply (rule add_le_mono1 [THEN le_trans], assumption+)
apply (subst add_commute, subst add_commute, rule add_le_mono1, assumption+)
done

text{*Combinations of less-than and less-than-or-equals*}

lemma add_lt_le_mono: "[| i<j; k\<le>l; j\<in>nat; l\<in>nat |] ==> i#+k < j#+l"
apply (rule add_lt_mono1 [THEN lt_trans2], assumption+)
apply (subst add_commute, subst add_commute, rule add_le_mono1, assumption+)
done

lemma add_le_lt_mono: "[| i\<le>j; k<l; j\<in>nat; l\<in>nat |] ==> i#+k < j#+l"
by (subst add_commute, subst add_commute, erule add_lt_le_mono, assumption+)

text{*Less-than: in other words, strict in both arguments*}
lemma add_lt_mono: "[| i<j; k<l; j\<in>nat; l\<in>nat |] ==> i#+k < j#+l"
apply (rule add_lt_le_mono)
apply (auto intro: leI)
done

(** Subtraction is the inverse of addition. **)

lemma diff_add_inverse: "(n#+m) #- n = natify(m)"
apply (subgoal_tac " (natify(n) #+ m) #- natify(n) = natify(m) ")
apply (rule_tac [2] n = "natify(n) " in nat_induct)
apply auto
done

lemma diff_add_inverse2: "(m#+n) #- n = natify(m)"
by (simp add: add_commute [of m] diff_add_inverse)

lemma diff_cancel: "(k#+m) #- (k#+n) = m #- n"
apply (subgoal_tac "(natify(k) #+ natify(m)) #- (natify(k) #+ natify(n)) =
                    natify(m) #- natify(n) ")
apply (rule_tac [2] n = "natify(k) " in nat_induct)
apply auto
done

lemma diff_cancel2: "(m#+k) #- (n#+k) = m #- n"
by (simp add: add_commute [of _ k] diff_cancel)

lemma diff_add_0: "n #- (n#+m) = 0"
apply (subgoal_tac "natify(n) #- (natify(n) #+ natify(m)) = 0")
apply (rule_tac [2] n = "natify(n) " in nat_induct)
apply auto
done

lemma pred_0 [simp]: "pred(0) = 0"
by (simp add: pred_def)

lemma eq_succ_imp_eq_m1: "[|i = succ(j); i\<in>nat|] ==> j = i #- 1 & j \<in>nat"
by simp

lemma pred_Un_distrib:
    "[|i\<in>nat; j\<in>nat|] ==> pred(i \<union> j) = pred(i) \<union> pred(j)"
apply (erule_tac n=i in natE, simp)
apply (erule_tac n=j in natE, simp)
apply (simp add:  succ_Un_distrib [symmetric])
done

lemma pred_type [TC,simp]:
    "i \<in> nat ==> pred(i) \<in> nat"
by (simp add: pred_def split: split_nat_case)

lemma nat_diff_pred: "[|i\<in>nat; j\<in>nat|] ==> i #- succ(j) = pred(i #- j)"
apply (rule_tac m=i and n=j in diff_induct)
apply (auto simp add: pred_def nat_imp_quasinat split: split_nat_case)
done

lemma diff_succ_eq_pred: "i #- succ(j) = pred(i #- j)"
apply (insert nat_diff_pred [of "natify(i)" "natify(j)"])
apply (simp add: natify_succ [symmetric])
done

lemma nat_diff_Un_distrib:
    "[|i\<in>nat; j\<in>nat; k\<in>nat|] ==> (i \<union> j) #- k = (i#-k) \<union> (j#-k)"
apply (rule_tac n=k in nat_induct)
apply (simp_all add: diff_succ_eq_pred pred_Un_distrib)
done

lemma diff_Un_distrib:
    "[|i\<in>nat; j\<in>nat|] ==> (i \<union> j) #- k = (i#-k) \<union> (j#-k)"
by (insert nat_diff_Un_distrib [of i j "natify(k)"], simp)

text{*We actually prove @{term "i #- j #- k = i #- (j #+ k)"}*}
lemma diff_diff_left [simplified]:
     "natify(i)#-natify(j)#-k = natify(i) #- (natify(j)#+k)"
by (rule_tac m="natify(i)" and n="natify(j)" in diff_induct, auto)

(** Lemmas for the CancelNumerals simproc **)

lemma eq_add_iff: "(u #+ m = u #+ n) \<longleftrightarrow> (0 #+ m = natify(n))"
apply auto
apply (blast dest: add_left_cancel_natify)
apply (simp add: add_def)
done

lemma less_add_iff: "(u #+ m < u #+ n) \<longleftrightarrow> (0 #+ m < natify(n))"
apply (auto simp add: add_lt_elim1_natify)
apply (drule add_lt_mono1)
apply (auto simp add: add_commute [of u])
done

lemma diff_add_eq: "((u #+ m) #- (u #+ n)) = ((0 #+ m) #- n)"
by (simp add: diff_cancel)

(*To tidy up the result of a simproc.  Only the RHS will be simplified.*)
lemma eq_cong2: "u = u' ==> (t==u) == (t==u')"
by auto

lemma iff_cong2: "u \<longleftrightarrow> u' ==> (t==u) == (t==u')"
by auto

subsection{*Multiplication*}

lemma mult_0 [simp]: "0 #* m = 0"
by (simp add: mult_def)

lemma mult_succ [simp]: "succ(m) #* n = n #+ (m #* n)"
by (simp add: add_def mult_def natify_succ raw_mult_type)

(*right annihilation in product*)
lemma mult_0_right [simp]: "m #* 0 = 0"
apply (unfold mult_def)
apply (rule_tac n = "natify(m) " in nat_induct)
apply auto
done

(*right successor law for multiplication*)
lemma mult_succ_right [simp]: "m #* succ(n) = m #+ (m #* n)"
apply (subgoal_tac "natify(m) #* succ (natify(n)) =
                    natify(m) #+ (natify(m) #* natify(n))")
apply (simp (no_asm_use) add: natify_succ add_def mult_def)
apply (rule_tac n = "natify(m) " in nat_induct)
apply (simp_all add: add_ac)
done

lemma mult_1_natify [simp]: "1 #* n = natify(n)"
by auto

lemma mult_1_right_natify [simp]: "n #* 1 = natify(n)"
by auto

lemma mult_1: "n \<in> nat ==> 1 #* n = n"
by simp

lemma mult_1_right: "n \<in> nat ==> n #* 1 = n"
by simp

(*Commutative law for multiplication*)
lemma mult_commute: "m #* n = n #* m"
apply (subgoal_tac "natify(m) #* natify(n) = natify(n) #* natify(m) ")
apply (rule_tac [2] n = "natify(m) " in nat_induct)
apply auto
done

(*addition distributes over multiplication*)
lemma add_mult_distrib: "(m #+ n) #* k = (m #* k) #+ (n #* k)"
apply (subgoal_tac "(natify(m) #+ natify(n)) #* natify(k) =
                    (natify(m) #* natify(k)) #+ (natify(n) #* natify(k))")
apply (rule_tac [2] n = "natify(m) " in nat_induct)
apply (simp_all add: add_assoc [symmetric])
done

(*Distributive law on the left*)
lemma add_mult_distrib_left: "k #* (m #+ n) = (k #* m) #+ (k #* n)"
apply (subgoal_tac "natify(k) #* (natify(m) #+ natify(n)) =
                    (natify(k) #* natify(m)) #+ (natify(k) #* natify(n))")
apply (rule_tac [2] n = "natify(m) " in nat_induct)
apply (simp_all add: add_ac)
done

(*Associative law for multiplication*)
lemma mult_assoc: "(m #* n) #* k = m #* (n #* k)"
apply (subgoal_tac "(natify(m) #* natify(n)) #* natify(k) =
                    natify(m) #* (natify(n) #* natify(k))")
apply (rule_tac [2] n = "natify(m) " in nat_induct)
apply (simp_all add: add_mult_distrib)
done

(*for a/c rewriting*)
lemma mult_left_commute: "m #* (n #* k) = n #* (m #* k)"
apply (rule mult_commute [THEN trans])
apply (rule mult_assoc [THEN trans])
apply (rule mult_commute [THEN subst_context])
done

lemmas mult_ac = mult_assoc mult_commute mult_left_commute

lemma lt_succ_eq_0_disj:
     "[| m\<in>nat; n\<in>nat |]
      ==> (m < succ(n)) \<longleftrightarrow> (m = 0 | (\<exists>j\<in>nat. m = succ(j) & j < n))"
by (induct_tac "m", auto)

lemma less_diff_conv [rule_format]:
     "[| j\<in>nat; k\<in>nat |] ==> \<forall>i\<in>nat. (i < j #- k) \<longleftrightarrow> (i #+ k < j)"
by (erule_tac m = k in diff_induct, auto)

lemmas nat_typechecks = rec_type nat_0I nat_1I nat_succI Ord_nat

end


(* Proving Simplifier Correctness -------------------------- *)
theory Example12
imports Main Example08
begin

(* Let's try a slightly more sophisticated approach ... *)

(* "plusConst n e" looks for a way to build an expression that
   is the sum of the (known) integer n and some IExpr e.
   Again, it looks for opportunities to apply constant folding
   and identity rules, but it can also take advantage of
   associativity to replace an expression of the form (x + m) + n
   with x + (m + n) when m and n are both known constants.
*)
fun plusConst :: "int \<Rightarrow> IExpr \<Rightarrow> IExpr"
 where "plusConst n (IntExpr m) = IntExpr (n+m)"
     | "plusConst n (PlusExpr e (IntExpr m)) = plusConst (n+m) e"
     | "plusConst n e = (if n=0 then e
                                else PlusExpr e (IntExpr n))"

lemma [simp] : "eval (plusConst n e) m = n + eval e m"
 apply (induction e
        arbitrary: n m
        rule: plusConst.induct)
 apply auto
 done

(* "plus l r" looks for opportunities to exploit the optimizations
   provided by "plusConst"; that is, it looks for special cases
   where one of the two arguments has a known integer value.
*)
fun plus :: "IExpr \<Rightarrow> IExpr => IExpr"
 where "plus (IntExpr n) e = plusConst n e"
     | "plus e (IntExpr n) = plusConst n e"
     | "plus l r           = PlusExpr l r"

lemma [simp] : "eval (plus l r) m = eval l m + eval r m"
  apply (induction rule: plus.induct)
  apply auto
  done

fun simpIExpr :: "IExpr \<Rightarrow> IExpr"
 where "simpIExpr (PlusExpr l r) = plus (simpIExpr l) (simpIExpr r)"
     | "simpIExpr other          = other"

(* Is our "optimization" correct? *)

value "PlusExpr ex2 ex3"
value "simpIExpr (PlusExpr ex2 ex3)"

(* It looks ok here, but can we be sure it will always work? *)

theorem "eval (simpIExpr e) m = eval e m"
  apply (induction rule: simpIExpr.induct)
  apply auto
  done

end
(* --------------------------------------------------------- *)


(* Author: Tobias Nipkow, TU Muenchen *)

section \<open>Sum and product over lists\<close>

theory Groups_List
imports List
begin

locale monoid_list = monoid
begin

definition F :: "'a list \<Rightarrow> 'a"
where
  eq_foldr [code]: "F xs = foldr f xs \<^bold>1"

lemma Nil [simp]:
  "F [] = \<^bold>1"
  by (simp add: eq_foldr)

lemma Cons [simp]:
  "F (x # xs) = x \<^bold>* F xs"
  by (simp add: eq_foldr)

lemma append [simp]:
  "F (xs @ ys) = F xs \<^bold>* F ys"
  by (induct xs) (simp_all add: assoc)

end

locale comm_monoid_list = comm_monoid + monoid_list
begin

lemma rev [simp]:
  "F (rev xs) = F xs"
  by (simp add: eq_foldr foldr_fold  fold_rev fun_eq_iff assoc left_commute)

end

locale comm_monoid_list_set = list: comm_monoid_list + set: comm_monoid_set
begin

lemma distinct_set_conv_list:
  "distinct xs \<Longrightarrow> set.F g (set xs) = list.F (map g xs)"
  by (induct xs) simp_all

lemma set_conv_list [code]:
  "set.F g (set xs) = list.F (map g (remdups xs))"
  by (simp add: distinct_set_conv_list [symmetric])

end

subsection \<open>List summation\<close>

context monoid_add
begin

sublocale sum_list: monoid_list plus 0
defines
  sum_list = sum_list.F ..

end

context comm_monoid_add
begin

sublocale sum_list: comm_monoid_list plus 0
rewrites
  "monoid_list.F plus 0 = sum_list"
proof -
  show "comm_monoid_list plus 0" ..
  then interpret sum_list: comm_monoid_list plus 0 .
  from sum_list_def show "monoid_list.F plus 0 = sum_list" by simp
qed

sublocale sum: comm_monoid_list_set plus 0
rewrites
  "monoid_list.F plus 0 = sum_list"
  and "comm_monoid_set.F plus 0 = sum"
proof -
  show "comm_monoid_list_set plus 0" ..
  then interpret sum: comm_monoid_list_set plus 0 .
  from sum_list_def show "monoid_list.F plus 0 = sum_list" by simp
  from sum_def show "comm_monoid_set.F plus 0 = sum" by (auto intro: sym)
qed

end

text \<open>Some syntactic sugar for summing a function over a list:\<close>
syntax (ASCII)
  "_sum_list" :: "pttrn => 'a list => 'b => 'b"    ("(3SUM _<-_. _)" [0, 51, 10] 10)
syntax
  "_sum_list" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)
translations \<comment> \<open>Beware of argument permutation!\<close>
  "\<Sum>x\<leftarrow>xs. b" == "CONST sum_list (CONST map (\<lambda>x. b) xs)"

context
  includes lifting_syntax
begin

lemma sum_list_transfer [transfer_rule]:
  "(list_all2 A ===> A) sum_list sum_list"
    if [transfer_rule]: "A 0 0" "(A ===> A ===> A) (+) (+)"
  unfolding sum_list.eq_foldr [abs_def]
  by transfer_prover

end

text \<open>TODO duplicates\<close>
lemmas sum_list_simps = sum_list.Nil sum_list.Cons
lemmas sum_list_append = sum_list.append
lemmas sum_list_rev = sum_list.rev

lemma (in monoid_add) fold_plus_sum_list_rev:
  "fold plus xs = plus (sum_list (rev xs))"
proof
  fix x
  have "fold plus xs x = sum_list (rev xs @ [x])"
    by (simp add: foldr_conv_fold sum_list.eq_foldr)
  also have "\<dots> = sum_list (rev xs) + x"
    by simp
  finally show "fold plus xs x = sum_list (rev xs) + x"
    .
qed

lemma (in comm_monoid_add) sum_list_map_remove1:
  "x \<in> set xs \<Longrightarrow> sum_list (map f xs) = f x + sum_list (map f (remove1 x xs))"
  by (induct xs) (auto simp add: ac_simps)

lemma (in monoid_add) size_list_conv_sum_list:
  "size_list f xs = sum_list (map f xs) + size xs"
  by (induct xs) auto

lemma (in monoid_add) length_concat:
  "length (concat xss) = sum_list (map length xss)"
  by (induct xss) simp_all

lemma (in monoid_add) length_product_lists:
  "length (product_lists xss) = foldr (*) (map length xss) 1"
proof (induct xss)
  case (Cons xs xss) then show ?case by (induct xs) (auto simp: length_concat o_def)
qed simp

lemma (in monoid_add) sum_list_map_filter:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> f x = 0"
  shows "sum_list (map f (filter P xs)) = sum_list (map f xs)"
  using assms by (induct xs) auto

lemma sum_list_filter_le_nat:
  fixes f :: "'a \<Rightarrow> nat"
  shows "sum_list (map f (filter P xs)) \<le> sum_list (map f xs)"
by(induction xs; simp)

lemma (in comm_monoid_add) distinct_sum_list_conv_Sum:
  "distinct xs \<Longrightarrow> sum_list xs = Sum (set xs)"
  by (induct xs) simp_all

lemma sum_list_upt[simp]:
  "m \<le> n \<Longrightarrow> sum_list [m..<n] = \<Sum> {m..<n}"
by(simp add: distinct_sum_list_conv_Sum)

context ordered_comm_monoid_add
begin

lemma sum_list_nonneg: "(\<And>x. x \<in> set xs \<Longrightarrow> 0 \<le> x) \<Longrightarrow> 0 \<le> sum_list xs"
by (induction xs) auto

lemma sum_list_nonpos: "(\<And>x. x \<in> set xs \<Longrightarrow> x \<le> 0) \<Longrightarrow> sum_list xs \<le> 0"
by (induction xs) (auto simp: add_nonpos_nonpos)

lemma sum_list_nonneg_eq_0_iff:
  "(\<And>x. x \<in> set xs \<Longrightarrow> 0 \<le> x) \<Longrightarrow> sum_list xs = 0 \<longleftrightarrow> (\<forall>x\<in> set xs. x = 0)"
by (induction xs) (simp_all add: add_nonneg_eq_0_iff sum_list_nonneg)

end

context canonically_ordered_monoid_add
begin

lemma sum_list_eq_0_iff [simp]:
  "sum_list ns = 0 \<longleftrightarrow> (\<forall>n \<in> set ns. n = 0)"
by (simp add: sum_list_nonneg_eq_0_iff)

lemma member_le_sum_list:
  "x \<in> set xs \<Longrightarrow> x \<le> sum_list xs"
by (induction xs) (auto simp: add_increasing add_increasing2)

lemma elem_le_sum_list:
  "k < size ns \<Longrightarrow> ns ! k \<le> sum_list (ns)"
by (rule member_le_sum_list) simp

end

lemma (in ordered_cancel_comm_monoid_diff) sum_list_update:
  "k < size xs \<Longrightarrow> sum_list (xs[k := x]) = sum_list xs + x - xs ! k"
apply(induction xs arbitrary:k)
 apply (auto simp: add_ac split: nat.split)
apply(drule elem_le_sum_list)
by (simp add: local.add_diff_assoc local.add_increasing)

lemma (in monoid_add) sum_list_triv:
  "(\<Sum>x\<leftarrow>xs. r) = of_nat (length xs) * r"
  by (induct xs) (simp_all add: distrib_right)

lemma (in monoid_add) sum_list_0 [simp]:
  "(\<Sum>x\<leftarrow>xs. 0) = 0"
  by (induct xs) (simp_all add: distrib_right)

text\<open>For non-Abelian groups \<open>xs\<close> needs to be reversed on one side:\<close>
lemma (in ab_group_add) uminus_sum_list_map:
  "- sum_list (map f xs) = sum_list (map (uminus \<circ> f) xs)"
  by (induct xs) simp_all

lemma (in comm_monoid_add) sum_list_addf:
  "(\<Sum>x\<leftarrow>xs. f x + g x) = sum_list (map f xs) + sum_list (map g xs)"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in ab_group_add) sum_list_subtractf:
  "(\<Sum>x\<leftarrow>xs. f x - g x) = sum_list (map f xs) - sum_list (map g xs)"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in semiring_0) sum_list_const_mult:
  "(\<Sum>x\<leftarrow>xs. c * f x) = c * (\<Sum>x\<leftarrow>xs. f x)"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in semiring_0) sum_list_mult_const:
  "(\<Sum>x\<leftarrow>xs. f x * c) = (\<Sum>x\<leftarrow>xs. f x) * c"
  by (induct xs) (simp_all add: algebra_simps)

lemma (in ordered_ab_group_add_abs) sum_list_abs:
  "\<bar>sum_list xs\<bar> \<le> sum_list (map abs xs)"
  by (induct xs) (simp_all add: order_trans [OF abs_triangle_ineq])

lemma sum_list_mono:
  fixes f g :: "'a \<Rightarrow> 'b::{monoid_add, ordered_ab_semigroup_add}"
  shows "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> (\<Sum>x\<leftarrow>xs. f x) \<le> (\<Sum>x\<leftarrow>xs. g x)"
by (induct xs) (simp, simp add: add_mono)

lemma sum_list_strict_mono:
  fixes f g :: "'a \<Rightarrow> 'b::{monoid_add, strict_ordered_ab_semigroup_add}"
  shows "\<lbrakk> xs \<noteq> [];  \<And>x. x \<in> set xs \<Longrightarrow> f x < g x \<rbrakk>
    \<Longrightarrow> sum_list (map f xs) < sum_list (map g xs)"
proof (induction xs)
  case Nil thus ?case by simp
next
  case C: (Cons _ xs)
  show ?case
  proof (cases xs)
    case Nil thus ?thesis using C.prems by simp
  next
    case Cons thus ?thesis using C by(simp add: add_strict_mono)
  qed
qed

text \<open>A much more general version of this monotonicity lemma
can be formulated with multisets and the multiset order\<close>

lemma sum_list_mono2: fixes xs :: "'a ::ordered_comm_monoid_add list"
shows "\<lbrakk> length xs = length ys; \<And>i. i < length xs \<longrightarrow> xs!i \<le> ys!i \<rbrakk>
  \<Longrightarrow> sum_list xs \<le> sum_list ys"
apply(induction xs ys rule: list_induct2)
by(auto simp: nth_Cons' less_Suc_eq_0_disj imp_ex add_mono)

lemma (in monoid_add) sum_list_distinct_conv_sum_set:
  "distinct xs \<Longrightarrow> sum_list (map f xs) = sum f (set xs)"
  by (induct xs) simp_all

lemma (in monoid_add) interv_sum_list_conv_sum_set_nat:
  "sum_list (map f [m..<n]) = sum f (set [m..<n])"
  by (simp add: sum_list_distinct_conv_sum_set)

lemma (in monoid_add) interv_sum_list_conv_sum_set_int:
  "sum_list (map f [k..l]) = sum f (set [k..l])"
  by (simp add: sum_list_distinct_conv_sum_set)

text \<open>General equivalence between \<^const>\<open>sum_list\<close> and \<^const>\<open>sum\<close>\<close>
lemma (in monoid_add) sum_list_sum_nth:
  "sum_list xs = (\<Sum> i = 0 ..< length xs. xs ! i)"
  using interv_sum_list_conv_sum_set_nat [of "(!) xs" 0 "length xs"] by (simp add: map_nth)

lemma sum_list_map_eq_sum_count:
  "sum_list (map f xs) = sum (\<lambda>x. count_list xs x * f x) (set xs)"
proof(induction xs)
  case (Cons x xs)
  show ?case (is "?l = ?r")
  proof cases
    assume "x \<in> set xs"
    have "?l = f x + (\<Sum>x\<in>set xs. count_list xs x * f x)" by (simp add: Cons.IH)
    also have "set xs = insert x (set xs - {x})" using \<open>x \<in> set xs\<close>by blast
    also have "f x + (\<Sum>x\<in>insert x (set xs - {x}). count_list xs x * f x) = ?r"
      by (simp add: sum.insert_remove eq_commute)
    finally show ?thesis .
  next
    assume "x \<notin> set xs"
    hence "\<And>xa. xa \<in> set xs \<Longrightarrow> x \<noteq> xa" by blast
    thus ?thesis by (simp add: Cons.IH \<open>x \<notin> set xs\<close>)
  qed
qed simp

lemma sum_list_map_eq_sum_count2:
assumes "set xs \<subseteq> X" "finite X"
shows "sum_list (map f xs) = sum (\<lambda>x. count_list xs x * f x) X"
proof-
  let ?F = "\<lambda>x. count_list xs x * f x"
  have "sum ?F X = sum ?F (set xs \<union> (X - set xs))"
    using Un_absorb1[OF assms(1)] by(simp)
  also have "\<dots> = sum ?F (set xs)"
    using assms(2)
    by(simp add: sum.union_disjoint[OF _ _ Diff_disjoint] del: Un_Diff_cancel)
  finally show ?thesis by(simp add:sum_list_map_eq_sum_count)
qed

lemma sum_list_replicate: "sum_list (replicate n c) = of_nat n * c"
by(induction n)(auto simp add: distrib_right)

lemma sum_list_nonneg:
    "(\<And>x. x \<in> set xs \<Longrightarrow> (x :: 'a :: ordered_comm_monoid_add) \<ge> 0) \<Longrightarrow> sum_list xs \<ge> 0"
  by (induction xs) simp_all

lemma sum_list_Suc:
  "sum_list (map (\<lambda>x. Suc(f x)) xs) = sum_list (map f xs) + length xs"
by(induction xs; simp)

lemma (in monoid_add) sum_list_map_filter':
  "sum_list (map f (filter P xs)) = sum_list (map (\<lambda>x. if P x then f x else 0) xs)"
  by (induction xs) simp_all

text \<open>Summation of a strictly ascending sequence with length \<open>n\<close>
  can be upper-bounded by summation over \<open>{0..<n}\<close>.\<close>

lemma sorted_wrt_less_sum_mono_lowerbound:
  fixes f :: "nat \<Rightarrow> ('b::ordered_comm_monoid_add)"
  assumes mono: "\<And>x y. x\<le>y \<Longrightarrow> f x \<le> f y"
  shows "sorted_wrt (<) ns \<Longrightarrow>
    (\<Sum>i\<in>{0..<length ns}. f i) \<le> (\<Sum>i\<leftarrow>ns. f i)"
proof (induction ns rule: rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc n ns)
  have "sum f {0..<length (ns @ [n])}
      = sum f {0..<length ns} + f (length ns)"
    by simp
  also have "sum f {0..<length ns} \<le> sum_list (map f ns)"
    using snoc by (auto simp: sorted_wrt_append)
  also have "length ns \<le> n"
    using sorted_wrt_less_idx[OF snoc.prems(1), of "length ns"] by auto
  finally have "sum f {0..<length (ns @ [n])} \<le> sum_list (map f ns) + f n"
    using mono add_mono by blast
  thus ?case by simp
qed

subsection \<open>Horner sums\<close>

context comm_semiring_0
begin

definition horner_sum :: \<open>('b \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> 'a\<close>
  where horner_sum_foldr: \<open>horner_sum f a xs = foldr (\<lambda>x b. f x + a * b) xs 0\<close>

lemma horner_sum_simps [simp]:
  \<open>horner_sum f a [] = 0\<close>
  \<open>horner_sum f a (x # xs) = f x + a * horner_sum f a xs\<close>
  by (simp_all add: horner_sum_foldr)

lemma horner_sum_eq_sum_funpow:
  \<open>horner_sum f a xs = (\<Sum>n = 0..<length xs. ((*) a ^^ n) (f (xs ! n)))\<close>
proof (induction xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons x xs)
  then show ?case
    by (simp add: sum.atLeast0_lessThan_Suc_shift sum_distrib_left del: sum.op_ivl_Suc)
qed

end

context
  includes lifting_syntax
begin

lemma horner_sum_transfer [transfer_rule]:
  \<open>((B ===> A) ===> A ===> list_all2 B ===> A) horner_sum horner_sum\<close>
  if [transfer_rule]: \<open>A 0 0\<close>
    and [transfer_rule]: \<open>(A ===> A ===> A) (+) (+)\<close>
    and [transfer_rule]: \<open>(A ===> A ===> A) (*) (*)\<close>
  by (unfold horner_sum_foldr) transfer_prover

end

context comm_semiring_1
begin

lemma horner_sum_eq_sum:
  \<open>horner_sum f a xs = (\<Sum>n = 0..<length xs. f (xs ! n) * a ^ n)\<close>
proof -
  have \<open>(*) a ^^ n = (*) (a ^ n)\<close> for n
    by (induction n) (simp_all add: ac_simps)
  then show ?thesis
    by (simp add: horner_sum_eq_sum_funpow ac_simps)
qed

lemma horner_sum_append:
  \<open>horner_sum f a (xs @ ys) = horner_sum f a xs + a ^ length xs * horner_sum f a ys\<close>
  using sum.atLeastLessThan_shift_bounds [of _ 0 \<open>length xs\<close> \<open>length ys\<close>]
    atLeastLessThan_add_Un [of 0 \<open>length xs\<close> \<open>length ys\<close>]
  by (simp add: horner_sum_eq_sum sum_distrib_left sum.union_disjoint ac_simps nth_append power_add)

end

context linordered_semidom
begin

lemma horner_sum_nonnegative:
  \<open>0 \<le> horner_sum of_bool 2 bs\<close>
  by (induction bs) simp_all

end

context unique_euclidean_semiring_numeral
begin

lemma horner_sum_bound:
  \<open>horner_sum of_bool 2 bs < 2 ^ length bs\<close>
proof (induction bs)
  case Nil
  then show ?case
    by simp
next
  case (Cons b bs)
  moreover define a where \<open>a = 2 ^ length bs - horner_sum of_bool 2 bs\<close>
  ultimately have *: \<open>2 ^ length bs = horner_sum of_bool 2 bs + a\<close>
    by simp
  have \<open>1 < a * 2\<close> if \<open>0 < a\<close>
    using that add_mono [of 1 a 1 a]
    by (simp add: mult_2_right discrete)
  with Cons show ?case
    by (simp add: algebra_simps *)
qed

end

lemma nat_horner_sum [simp]:
  \<open>nat (horner_sum of_bool 2 bs) = horner_sum of_bool 2 bs\<close>
  by (induction bs) (auto simp add: nat_add_distrib horner_sum_nonnegative)

context unique_euclidean_semiring_numeral
begin

lemma horner_sum_less_eq_iff_lexordp_eq:
  \<open>horner_sum of_bool 2 bs \<le> horner_sum of_bool 2 cs \<longleftrightarrow> lexordp_eq (rev bs) (rev cs)\<close>
  if \<open>length bs = length cs\<close>
proof -
  have \<open>horner_sum of_bool 2 (rev bs) \<le> horner_sum of_bool 2 (rev cs) \<longleftrightarrow> lexordp_eq bs cs\<close>
    if \<open>length bs = length cs\<close> for bs cs
  using that proof (induction bs cs rule: list_induct2)
    case Nil
    then show ?case
      by simp
  next
    case (Cons b bs c cs)
    with horner_sum_nonnegative [of \<open>rev bs\<close>] horner_sum_nonnegative [of \<open>rev cs\<close>]
      horner_sum_bound [of \<open>rev bs\<close>] horner_sum_bound [of \<open>rev cs\<close>]
    show ?case
      by (auto simp add: horner_sum_append not_le Cons intro: add_strict_increasing2 add_increasing)
  qed
  from that this [of \<open>rev bs\<close> \<open>rev cs\<close>] show ?thesis
    by simp
qed

lemma horner_sum_less_iff_lexordp:
  \<open>horner_sum of_bool 2 bs < horner_sum of_bool 2 cs \<longleftrightarrow> ord_class.lexordp (rev bs) (rev cs)\<close>
  if \<open>length bs = length cs\<close>
proof -
  have \<open>horner_sum of_bool 2 (rev bs) < horner_sum of_bool 2 (rev cs) \<longleftrightarrow> ord_class.lexordp bs cs\<close>
    if \<open>length bs = length cs\<close> for bs cs
  using that proof (induction bs cs rule: list_induct2)
    case Nil
    then show ?case
      by simp
  next
    case (Cons b bs c cs)
    with horner_sum_nonnegative [of \<open>rev bs\<close>] horner_sum_nonnegative [of \<open>rev cs\<close>]
      horner_sum_bound [of \<open>rev bs\<close>] horner_sum_bound [of \<open>rev cs\<close>]
    show ?case
      by (auto simp add: horner_sum_append not_less Cons intro: add_strict_increasing2 add_increasing)
  qed
  from that this [of \<open>rev bs\<close> \<open>rev cs\<close>] show ?thesis
    by simp
qed

end

subsection \<open>Further facts about \<^const>\<open>List.n_lists\<close>\<close>

lemma length_n_lists: "length (List.n_lists n xs) = length xs ^ n"
  by (induct n) (auto simp add: comp_def length_concat sum_list_triv)

lemma distinct_n_lists:
  assumes "distinct xs"
  shows "distinct (List.n_lists n xs)"
proof (rule card_distinct)
  from assms have card_length: "card (set xs) = length xs" by (rule distinct_card)
  have "card (set (List.n_lists n xs)) = card (set xs) ^ n"
  proof (induct n)
    case 0 then show ?case by simp
  next
    case (Suc n)
    moreover have "card (\<Union>ys\<in>set (List.n_lists n xs). (\<lambda>y. y # ys) ` set xs)
      = (\<Sum>ys\<in>set (List.n_lists n xs). card ((\<lambda>y. y # ys) ` set xs))"
      by (rule card_UN_disjoint) auto
    moreover have "\<And>ys. card ((\<lambda>y. y # ys) ` set xs) = card (set xs)"
      by (rule card_image) (simp add: inj_on_def)
    ultimately show ?case by auto
  qed
  also have "\<dots> = length xs ^ n" by (simp add: card_length)
  finally show "card (set (List.n_lists n xs)) = length (List.n_lists n xs)"
    by (simp add: length_n_lists)
qed

subsection \<open>Tools setup\<close>

lemmas sum_code = sum.set_conv_list

lemma sum_set_upto_conv_sum_list_int [code_unfold]:
  "sum f (set [i..j::int]) = sum_list (map f [i..j])"
  by (simp add: interv_sum_list_conv_sum_set_int)

lemma sum_set_upt_conv_sum_list_nat [code_unfold]:
  "sum f (set [m..<n]) = sum_list (map f [m..<n])"
  by (simp add: interv_sum_list_conv_sum_set_nat)

subsection \<open>List product\<close>

context monoid_mult
begin

sublocale prod_list: monoid_list times 1
defines
  prod_list = prod_list.F ..

end

context comm_monoid_mult
begin

sublocale prod_list: comm_monoid_list times 1
rewrites
  "monoid_list.F times 1 = prod_list"
proof -
  show "comm_monoid_list times 1" ..
  then interpret prod_list: comm_monoid_list times 1 .
  from prod_list_def show "monoid_list.F times 1 = prod_list" by simp
qed

sublocale prod: comm_monoid_list_set times 1
rewrites
  "monoid_list.F times 1 = prod_list"
  and "comm_monoid_set.F times 1 = prod"
proof -
  show "comm_monoid_list_set times 1" ..
  then interpret prod: comm_monoid_list_set times 1 .
  from prod_list_def show "monoid_list.F times 1 = prod_list" by simp
  from prod_def show "comm_monoid_set.F times 1 = prod" by (auto intro: sym)
qed

end

text \<open>Some syntactic sugar:\<close>

syntax (ASCII)
  "_prod_list" :: "pttrn => 'a list => 'b => 'b"    ("(3PROD _<-_. _)" [0, 51, 10] 10)
syntax
  "_prod_list" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Prod>_\<leftarrow>_. _)" [0, 51, 10] 10)
translations \<comment> \<open>Beware of argument permutation!\<close>
  "\<Prod>x\<leftarrow>xs. b" \<rightleftharpoons> "CONST prod_list (CONST map (\<lambda>x. b) xs)"

context
  includes lifting_syntax
begin

lemma prod_list_transfer [transfer_rule]:
  "(list_all2 A ===> A) prod_list prod_list"
    if [transfer_rule]: "A 1 1" "(A ===> A ===> A) (*) (*)"
  unfolding prod_list.eq_foldr [abs_def]
  by transfer_prover

end

lemma prod_list_zero_iff:
  "prod_list xs = 0 \<longleftrightarrow> (0 :: 'a :: {semiring_no_zero_divisors, semiring_1}) \<in> set xs"
  by (induction xs) simp_all

end


theory Lab2a_Induction
imports Main
begin

no_notation Nil("[]") and Cons (infix "#" 65) and append (infixr "@" 65)
hide_type list
hide_const rev

datatype 'a list = Nil ("[]")
  | Cons 'a "'a list" (infixr "#" 65)

primrec app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "@" 65) where
  "[] @ ys = ys"
  | "(x # xs) @ ys = x # (xs @ ys)"

primrec rev :: "'a list \<Rightarrow> 'a list" where
  "rev [] = []"
  | "rev (x # xs) = (rev xs) @ (x # [])"

lemma app_Nil2 [simp]: "xs @ [] = xs"
  apply(induct_tac xs)
  apply auto
done

lemma app_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"
  apply(induct_tac xs)
  apply auto
done

lemma rev_app [simp]: "rev (xs @ ys) = (rev ys) @ (rev xs)"
  apply(induct_tac xs)
  apply auto
done

theorem rev_rev [simp]: "rev (rev xs) = xs"
(*using [[simp_trace]]*)
  apply(induct_tac xs)
  apply auto
done
end


theory Misc
  imports Main "Graph_Theory.Shortest_Path"
begin

text \<open>These are some utility lemmas which are not directly concerned with the graph library.\<close>

lemma Sup_in_set:
"\<lbrakk> finite (A::('a::complete_linorder) set); A \<noteq> {}; a = Sup A\<rbrakk>
  \<Longrightarrow> a \<in> A"
proof(induction A arbitrary: a rule: finite_induct)
  case (insert x F)
  show ?case
  proof(cases "F = {}")
    case False
    with insert.IH have "\<exists>y. Sup F = y \<and> y \<in> F" by simp
    then obtain y where y_def: "Sup F = y" and y_in_F: "y \<in> F" by blast

    have [simp]: "Sup (insert x F) = sup x (Sup F)"
      using insert.hyps(1)
      by (induction F rule: finite_induct) (auto)

    with insert show ?thesis
    proof(cases "y \<le> x")
      case True
      then have "Sup (insert x F) = x"
        by (simp add: sup.absorb_iff1 y_def)
      with insert.prems(2) show ?thesis by blast
    next
      case False
      with y_def have "Sup (insert x F) = y"
        by (simp add: sup.absorb2)
      with insert.prems(2) y_in_F show ?thesis by blast
    qed
  qed (simp add: insert.prems)
qed simp

text \<open>Analogous to the proof of @{thm Sup_in_set}.\<close>
lemma Inf_in_set:
"\<lbrakk> finite (A::('a::complete_linorder) set); A \<noteq> {}; a = Inf A\<rbrakk>
  \<Longrightarrow> a \<in> A"
proof(induction A arbitrary: a rule: finite_induct)
  case (insert x F)
  show ?case
  proof(cases "F = {}")
    case False
    with insert.IH have "\<exists>y. Inf F = y \<and> y \<in> F" by simp
    then obtain y where y_def: "Inf F = y" and y_in_F: "y \<in> F" by blast

    have [simp]: "Inf (insert x F) = inf x (Inf F)"
      using insert.hyps(1)
      by (induction F rule: finite_induct) (auto)

    with insert show ?thesis
    proof(cases "y \<ge> x")
      case True
      then have "Inf (insert x F) = x"
        by (simp add: inf.absorb_iff1 y_def)
      with insert.prems(2) show ?thesis by blast
    next
      case False
      with y_def have "Inf (insert x F) = y"
        by (simp add: inf.absorb2)
      with insert.prems(2) y_in_F show ?thesis by blast
    qed
  qed (simp add: insert.prems)
qed simp

lemma mem_card1_singleton: "\<lbrakk> u \<in> U; card U = 1 \<rbrakk> \<Longrightarrow> U = {u}"
  by (metis card_1_singletonE singletonD)

lemma finite_Union: "\<lbrakk> finite A; \<forall>x \<in> A. finite (a x) \<rbrakk> \<Longrightarrow> finite (\<Union>{a x|x. x \<in> A})"
  by (induction A rule: finite_induct) (auto)

end