(* Title: Interval
   Author: Christoph Traut, TU Muenchen
           Fabian Immler, TU Muenchen
*)
section \<open>Interval Type\<close>
theory Interval
  imports
    Complex_MainRLT
    Lattice_Algebras
    Set_Algebras
begin

text \<open>A type of non-empty, closed intervals.\<close>

typedef (overloaded) 'a interval =
  "{(a::'a::preorder, b). a \<le> b}"
  morphisms bounds_of_interval Interval
  by auto

setup_lifting type_definition_interval

lift_definition lower::"('a::preorder) interval \<Rightarrow> 'a" is fst .

lift_definition upper::"('a::preorder) interval \<Rightarrow> 'a" is snd .

lemma interval_eq_iff: "a = b \<longleftrightarrow> lower a = lower b \<and> upper a = upper b"
  by transfer auto

lemma interval_eqI: "lower a = lower b \<Longrightarrow> upper a = upper b \<Longrightarrow> a = b"
  by (auto simp: interval_eq_iff)

lemma lower_le_upper[simp]: "lower i \<le> upper i"
  by transfer auto

lift_definition set_of :: "'a::preorder interval \<Rightarrow> 'a set" is "\<lambda>x. {fst x .. snd x}" .

lemma set_of_eq: "set_of x = {lower x .. upper x}"
  by transfer simp

context notes [[typedef_overloaded]] begin

lift_definition(code_dt) Interval'::"'a::preorder \<Rightarrow> 'a::preorder \<Rightarrow> 'a interval option"
  is "\<lambda>a b. if a \<le> b then Some (a, b) else None"
  by auto

lemma Interval'_split:
  "P (Interval' a b) \<longleftrightarrow>
    (\<forall>ivl. a \<le> b \<longrightarrow> lower ivl = a \<longrightarrow> upper ivl = b \<longrightarrow> P (Some ivl)) \<and> (\<not>a\<le>b \<longrightarrow> P None)"
  by transfer auto

lemma Interval'_split_asm:
  "P (Interval' a b) \<longleftrightarrow>
    \<not>((\<exists>ivl. a \<le> b \<and> lower ivl = a \<and> upper ivl = b \<and> \<not>P (Some ivl)) \<or> (\<not>a\<le>b \<and> \<not>P None))"
  unfolding Interval'_split
  by auto

lemmas Interval'_splits = Interval'_split Interval'_split_asm

lemma Interval'_eq_Some: "Interval' a b = Some i \<Longrightarrow> lower i = a \<and> upper i = b"
  by (simp split: Interval'_splits)

end

instantiation "interval" :: ("{preorder,equal}") equal
begin

definition "equal_class.equal a b \<equiv> (lower a = lower b) \<and> (upper a = upper b)"

instance proof qed (simp add: equal_interval_def interval_eq_iff)
end

instantiation interval :: ("preorder") ord begin

definition less_eq_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> bool"
  where "less_eq_interval a b \<longleftrightarrow> lower b \<le> lower a \<and> upper a \<le> upper b"

definition less_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> bool"
  where  "less_interval x y = (x \<le> y \<and> \<not> y \<le> x)"

instance proof qed
end

instantiation interval :: ("lattice") semilattice_sup
begin

lift_definition sup_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
  is "\<lambda>(a, b) (c, d). (inf a c, sup b d)"
  by (auto simp: le_infI1 le_supI1)

lemma lower_sup[simp]: "lower (sup A B) = inf (lower A) (lower B)"
  by transfer auto

lemma upper_sup[simp]: "upper (sup A B) = sup (upper A) (upper B)"
  by transfer auto

instance proof qed (auto simp: less_eq_interval_def less_interval_def interval_eq_iff)
end

lemma set_of_interval_union: "set_of A \<union> set_of B \<subseteq> set_of (sup A B)" for A::"'a::lattice interval"
  by (auto simp: set_of_eq)

lemma interval_union_commute: "sup A B = sup B A" for A::"'a::lattice interval"
  by (auto simp add: interval_eq_iff inf.commute sup.commute)

lemma interval_union_mono1: "set_of a \<subseteq> set_of (sup a A)" for A :: "'a::lattice interval"
  using set_of_interval_union by blast

lemma interval_union_mono2: "set_of A \<subseteq> set_of (sup a A)" for A :: "'a::lattice interval"
  using set_of_interval_union by blast

lift_definition interval_of :: "'a::preorder \<Rightarrow> 'a interval" is "\<lambda>x. (x, x)"
  by auto

lemma lower_interval_of[simp]: "lower (interval_of a) = a"
  by transfer auto

lemma upper_interval_of[simp]: "upper (interval_of a) = a"
  by transfer auto

definition width :: "'a::{preorder,minus} interval \<Rightarrow> 'a"
  where "width i = upper i - lower i"

instantiation "interval" :: ("ordered_ab_semigroup_add") ab_semigroup_add
begin

lift_definition plus_interval::"'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
  is "\<lambda>(a, b). \<lambda>(c, d). (a + c, b + d)"
  by (auto intro!: add_mono)
lemma lower_plus[simp]: "lower (plus A B) = plus (lower A) (lower B)"
  by transfer auto
lemma upper_plus[simp]: "upper (plus A B) = plus (upper A) (upper B)"
  by transfer auto

instance proof qed (auto simp: interval_eq_iff less_eq_interval_def ac_simps)
end

instance "interval" :: ("{ordered_ab_semigroup_add, lattice}") ordered_ab_semigroup_add
proof qed (auto simp: less_eq_interval_def intro!: add_mono)

instantiation "interval" :: ("{preorder,zero}") zero
begin

lift_definition zero_interval::"'a interval" is "(0, 0)" by auto
lemma lower_zero[simp]: "lower 0 = 0"
  by transfer auto
lemma upper_zero[simp]: "upper 0 = 0"
  by transfer auto
instance proof qed
end

instance "interval" :: ("{ordered_comm_monoid_add}") comm_monoid_add
proof qed (auto simp: interval_eq_iff)

instance "interval" :: ("{ordered_comm_monoid_add,lattice}") ordered_comm_monoid_add ..

instantiation "interval" :: ("{ordered_ab_group_add}") uminus
begin

lift_definition uminus_interval::"'a interval \<Rightarrow> 'a interval" is "\<lambda>(a, b). (-b, -a)" by auto
lemma lower_uminus[simp]: "lower (- A) = - upper A"
  by transfer auto
lemma upper_uminus[simp]: "upper (- A) = - lower A"
  by transfer auto
instance ..
end

instantiation "interval" :: ("{ordered_ab_group_add}") minus
begin

definition minus_interval::"'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
  where "minus_interval a b = a + - b"
lemma lower_minus[simp]: "lower (minus A B) = minus (lower A) (upper B)"
  by (auto simp: minus_interval_def)
lemma upper_minus[simp]: "upper (minus A B) = minus (upper A) (lower B)"
  by (auto simp: minus_interval_def)

instance ..
end

instantiation "interval" :: (linordered_semiring) times
begin

lift_definition times_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
  is "\<lambda>(a1, a2). \<lambda>(b1, b2).
    (let x1 = a1 * b1; x2 = a1 * b2; x3 = a2 * b1; x4 = a2 * b2
    in (min x1 (min x2 (min x3 x4)), max x1 (max x2 (max x3 x4))))"
  by (auto simp: Let_def intro!: min.coboundedI1 max.coboundedI1)

lemma lower_times:
  "lower (times A B) = Min {lower A * lower B, lower A * upper B, upper A * lower B, upper A * upper B}"
  by transfer (auto simp: Let_def)

lemma upper_times:
  "upper (times A B) = Max {lower A * lower B, lower A * upper B, upper A * lower B, upper A * upper B}"
  by transfer (auto simp: Let_def)

instance ..
end

lemma interval_eq_set_of_iff: "X = Y \<longleftrightarrow> set_of X = set_of Y" for X Y::"'a::order interval"
  by (auto simp: set_of_eq interval_eq_iff)

subsection \<open>Membership\<close>

abbreviation (in preorder) in_interval ("(_/ \<in>\<^sub>i _)" [51, 51] 50)
  where "in_interval x X \<equiv> x \<in> set_of X"

lemma in_interval_to_interval[intro!]: "a \<in>\<^sub>i interval_of a"
  by (auto simp: set_of_eq)

lemma plus_in_intervalI:
  fixes x y :: "'a :: ordered_ab_semigroup_add"
  shows "x \<in>\<^sub>i X \<Longrightarrow> y \<in>\<^sub>i Y \<Longrightarrow> x + y \<in>\<^sub>i X + Y"
  by (simp add: add_mono_thms_linordered_semiring(1) set_of_eq)

lemma connected_set_of[intro, simp]:
  "connected (set_of X)" for X::"'a::linear_continuum_topology interval"
  by (auto simp: set_of_eq )

lemma ex_sum_in_interval_lemma: "\<exists>xa\<in>{la .. ua}. \<exists>xb\<in>{lb .. ub}. x = xa + xb"
  if "la \<le> ua" "lb \<le> ub" "la + lb \<le> x" "x \<le> ua + ub"
    "ua - la \<le> ub - lb"
  for la b c d::"'a::linordered_ab_group_add"
proof -
  define wa where "wa = ua - la"
  define wb where "wb = ub - lb"
  define w where "w = wa + wb"
  define d where "d = x - la - lb"
  define da where "da = max 0 (min wa (d - wa))"
  define db where "db = d - da"
  from that have nonneg: "0 \<le> wa" "0 \<le> wb" "0 \<le> w" "0 \<le> d" "d \<le> w"
    by (auto simp add: wa_def wb_def w_def d_def add.commute le_diff_eq)
  have "0 \<le> db"
    by (auto simp: da_def nonneg db_def intro!: min.coboundedI2)
  have "x = (la + da) + (lb + db)"
    by (simp add: da_def db_def d_def)
  moreover
  have "x - la - ub \<le> da"
    using that
    unfolding da_def
    by (intro max.coboundedI2) (auto simp: wa_def d_def diff_le_eq diff_add_eq)
  then have "db \<le> wb"
    by (auto simp: db_def d_def wb_def algebra_simps)
  with \<open>0 \<le> db\<close> that nonneg have "lb + db \<in> {lb..ub}"
    by (auto simp: wb_def algebra_simps)
  moreover
  have "da \<le> wa"
    by (auto simp: da_def nonneg)
  then have "la + da \<in> {la..ua}"
    by (auto simp: da_def wa_def algebra_simps)
  ultimately show ?thesis
    by force
qed

lemma ex_sum_in_interval: "\<exists>xa\<ge>la. xa \<le> ua \<and> (\<exists>xb\<ge>lb. xb \<le> ub \<and> x = xa + xb)"
  if a: "la \<le> ua" and b: "lb \<le> ub" and x: "la + lb \<le> x" "x \<le> ua + ub"
  for la b c d::"'a::linordered_ab_group_add"
proof -
  from linear consider "ua - la \<le> ub - lb" | "ub - lb \<le> ua - la"
    by blast
  then show ?thesis
  proof cases
    case 1
    from ex_sum_in_interval_lemma[OF that 1]
    show ?thesis by auto
  next
    case 2
    from x have "lb + la \<le> x" "x \<le> ub + ua" by (simp_all add: ac_simps)
    from ex_sum_in_interval_lemma[OF b a this 2]
    show ?thesis by auto
  qed
qed

lemma Icc_plus_Icc:
  "{a .. b} + {c .. d} = {a + c .. b + d}"
  if "a \<le> b" "c \<le> d"
  for a b c d::"'a::linordered_ab_group_add"
  using ex_sum_in_interval[OF that]
  by (auto intro: add_mono simp: atLeastAtMost_iff Bex_def set_plus_def)

lemma set_of_plus:
  fixes A :: "'a::linordered_ab_group_add interval"
  shows "set_of (A + B) = set_of A + set_of B"
  using Icc_plus_Icc[of "lower A" "upper A" "lower B" "upper B"]
  by (auto simp: set_of_eq)

lemma plus_in_intervalE:
  fixes xy :: "'a :: linordered_ab_group_add"
  assumes "xy \<in>\<^sub>i X + Y"
  obtains x y where "xy = x + y" "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y"
  using assms
  unfolding set_of_plus set_plus_def
  by auto

lemma set_of_uminus: "set_of (-X) = {- x | x. x \<in> set_of X}"
  for X :: "'a :: ordered_ab_group_add interval"
  by (auto simp: set_of_eq simp: le_minus_iff minus_le_iff
      intro!: exI[where x="-x" for x])

lemma uminus_in_intervalI:
  fixes x :: "'a :: ordered_ab_group_add"
  shows "x \<in>\<^sub>i X \<Longrightarrow> -x \<in>\<^sub>i -X"
  by (auto simp: set_of_uminus)

lemma uminus_in_intervalD:
  fixes x :: "'a :: ordered_ab_group_add"
  shows "x \<in>\<^sub>i - X \<Longrightarrow> - x \<in>\<^sub>i X"
  by (auto simp: set_of_uminus)

lemma minus_in_intervalI:
  fixes x y :: "'a :: ordered_ab_group_add"
  shows "x \<in>\<^sub>i X \<Longrightarrow> y \<in>\<^sub>i Y \<Longrightarrow> x - y \<in>\<^sub>i X - Y"
  by (metis diff_conv_add_uminus minus_interval_def plus_in_intervalI uminus_in_intervalI)

lemma set_of_minus: "set_of (X - Y) = {x - y | x y . x \<in> set_of X \<and> y \<in> set_of Y}"
  for X Y :: "'a :: linordered_ab_group_add interval"
  unfolding minus_interval_def set_of_plus set_of_uminus set_plus_def
  by force

lemma times_in_intervalI:
  fixes x y::"'a::linordered_ring"
  assumes "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y"
  shows "x * y \<in>\<^sub>i X * Y"
proof -
  define X1 where "X1 \<equiv> lower X"
  define X2 where "X2 \<equiv> upper X"
  define Y1 where "Y1 \<equiv> lower Y"
  define Y2 where "Y2 \<equiv> upper Y"
  from assms have assms: "X1 \<le> x" "x \<le> X2" "Y1 \<le> y" "y \<le> Y2"
    by (auto simp: X1_def X2_def Y1_def Y2_def set_of_eq)
  have "(X1 * Y1 \<le> x * y \<or> X1 * Y2 \<le> x * y \<or> X2 * Y1 \<le> x * y \<or> X2 * Y2 \<le> x * y) \<and>
        (X1 * Y1 \<ge> x * y \<or> X1 * Y2 \<ge> x * y \<or> X2 * Y1 \<ge> x * y \<or> X2 * Y2 \<ge> x * y)"
  proof (cases x "0::'a" rule: linorder_cases)
    case x0: less
    show ?thesis
    proof (cases "y < 0")
      case y0: True
      from y0 x0 assms have "x * y \<le> X1 * y" by (intro mult_right_mono_neg, auto)
      also from x0 y0 assms have "X1 * y \<le> X1 * Y1" by (intro mult_left_mono_neg, auto)
      finally have 1: "x * y \<le> X1 * Y1".
      show ?thesis proof(cases "X2 \<le> 0")
        case True
        with assms have "X2 * Y2 \<le> X2 * y" by (auto intro: mult_left_mono_neg)
        also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono_neg)
        finally have "X2 * Y2 \<le> x * y".
        with 1 show ?thesis by auto
      next
        case False
        with assms have "X2 * Y1 \<le> X2 * y" by (auto intro: mult_left_mono)
        also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono_neg)
        finally have "X2 * Y1 \<le> x * y".
        with 1 show ?thesis by auto
      qed
    next
      case False
      then have y0: "y \<ge> 0" by auto
      from x0 y0 assms have "X1 * Y2 \<le> x * Y2" by (intro mult_right_mono, auto)
      also from y0 x0 assms have "... \<le> x * y" by (intro mult_left_mono_neg, auto)
      finally have 1: "X1 * Y2 \<le> x * y".
      show ?thesis
      proof(cases "X2 \<le> 0")
        case X2: True
        from assms y0 have "x * y \<le> X2 * y" by (intro mult_right_mono)
        also from assms X2 have "... \<le> X2 * Y1" by (auto intro: mult_left_mono_neg)
        finally have "x * y \<le> X2 * Y1".
        with 1 show ?thesis by auto
      next
        case X2: False
        from assms y0 have "x * y \<le> X2 * y" by (intro mult_right_mono)
        also from assms X2 have "... \<le> X2 * Y2" by (auto intro: mult_left_mono)
        finally have "x * y \<le> X2 * Y2".
        with 1 show ?thesis by auto
      qed
    qed
  next
    case [simp]: equal
    with assms show ?thesis by (cases "Y2 \<le> 0", auto intro:mult_sign_intros)
  next
    case x0: greater
    show ?thesis
    proof (cases "y < 0")
      case y0: True
      from x0 y0 assms have "X2 * Y1 \<le> X2 * y" by (intro mult_left_mono, auto)
      also from y0 x0 assms have "X2 * y \<le> x * y" by (intro mult_right_mono_neg, auto)
      finally have 1: "X2 * Y1 \<le> x * y".
      show ?thesis
      proof(cases "Y2 \<le> 0")
        case Y2: True
        from x0 assms have "x * y \<le> x * Y2" by (auto intro: mult_left_mono)
        also from assms Y2 have "... \<le> X1 * Y2" by (auto intro: mult_right_mono_neg)
        finally have "x * y \<le> X1 * Y2".
        with 1 show ?thesis by auto
      next
        case Y2: False
        from x0 assms have "x * y \<le> x * Y2" by (auto intro: mult_left_mono)
        also from assms Y2 have "... \<le> X2 * Y2" by (auto intro: mult_right_mono)
        finally have "x * y \<le> X2 * Y2".
        with 1 show ?thesis by auto
      qed
    next
      case y0: False
      from x0 y0 assms have "x * y \<le> X2 * y" by (intro mult_right_mono, auto)
      also from y0 x0 assms have "... \<le> X2 * Y2" by (intro mult_left_mono, auto)
      finally have 1: "x * y \<le> X2 * Y2".
      show ?thesis
      proof(cases "X1 \<le> 0")
        case True
        with assms have "X1 * Y2 \<le> X1 * y" by (auto intro: mult_left_mono_neg)
        also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono)
        finally have "X1 * Y2 \<le> x * y".
        with 1 show ?thesis by auto
      next
        case False
        with assms have "X1 * Y1 \<le> X1 * y" by (auto intro: mult_left_mono)
        also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono)
        finally have "X1 * Y1 \<le> x * y".
        with 1 show ?thesis by auto
      qed
    qed
  qed
  hence min:"min (X1 * Y1) (min (X1 * Y2) (min (X2 * Y1) (X2 * Y2))) \<le> x * y"
    and max:"x * y \<le> max (X1 * Y1) (max (X1 * Y2) (max (X2 * Y1) (X2 * Y2)))"
    by (auto simp:min_le_iff_disj le_max_iff_disj)
  show ?thesis using min max
    by (auto simp: Let_def X1_def X2_def Y1_def Y2_def set_of_eq lower_times upper_times)
qed

lemma times_in_intervalE:
  fixes xy :: "'a :: {linordered_semiring, real_normed_algebra, linear_continuum_topology}"
    \<comment> \<open>TODO: linear continuum topology is pretty strong\<close>
  assumes "xy \<in>\<^sub>i X * Y"
  obtains x y where "xy = x * y" "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y"
proof -
  let ?mult = "\<lambda>(x, y). x * y"
  let ?XY = "set_of X \<times> set_of Y"
  have cont: "continuous_on ?XY ?mult"
    by (auto intro!: tendsto_eq_intros simp: continuous_on_def split_beta')
  have conn: "connected (?mult ` ?XY)"
    by (rule connected_continuous_image[OF cont]) auto
  have "lower (X * Y) \<in> ?mult ` ?XY" "upper (X * Y) \<in> ?mult ` ?XY"
    by (auto simp: set_of_eq lower_times upper_times min_def max_def split: if_splits)
  from connectedD_interval[OF conn this, of xy] assms
  obtain x y where "xy = x * y" "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y" by (auto simp: set_of_eq)
  then show ?thesis ..
qed

lemma set_of_times: "set_of (X * Y) = {x * y | x y. x \<in> set_of X \<and> y \<in> set_of Y}"
  for X Y::"'a :: {linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
  by (auto intro!: times_in_intervalI elim!: times_in_intervalE)

instance "interval" :: (linordered_idom) cancel_semigroup_add
proof qed (auto simp: interval_eq_iff)

lemma interval_mul_commute: "A * B = B * A" for A B:: "'a::linordered_idom interval"
  by (simp add: interval_eq_iff lower_times upper_times ac_simps)

lemma interval_times_zero_right[simp]: "A * 0 = 0" for A :: "'a::linordered_ring interval"
  by (simp add: interval_eq_iff lower_times upper_times ac_simps)

lemma interval_times_zero_left[simp]:
  "0 * A = 0" for A :: "'a::linordered_ring interval"
  by (simp add: interval_eq_iff lower_times upper_times ac_simps)

instantiation "interval" :: ("{preorder,one}") one
begin

lift_definition one_interval::"'a interval" is "(1, 1)" by auto
lemma lower_one[simp]: "lower 1 = 1"
  by transfer auto
lemma upper_one[simp]: "upper 1 = 1"
  by transfer auto
instance proof qed
end

instance interval :: ("{one, preorder, linordered_semiring}") power
proof qed

lemma set_of_one[simp]: "set_of (1::'a::{one, order} interval) = {1}"
  by (auto simp: set_of_eq)

instance "interval" ::
  ("{linordered_idom,linordered_ring, real_normed_algebra, linear_continuum_topology}") monoid_mult
  apply standard
  unfolding interval_eq_set_of_iff set_of_times
  subgoal
    by (auto simp: interval_eq_set_of_iff set_of_times; metis mult.assoc)
  by auto

lemma one_times_ivl_left[simp]: "1 * A = A" for A :: "'a::linordered_idom interval"
  by (simp add: interval_eq_iff lower_times upper_times ac_simps min_def max_def)

lemma one_times_ivl_right[simp]: "A * 1 = A" for A :: "'a::linordered_idom interval"
  by (metis interval_mul_commute one_times_ivl_left)

lemma set_of_power_mono: "a^n \<in> set_of (A^n)" if "a \<in> set_of A"
  for a :: "'a::linordered_idom"
  using that
  by (induction n) (auto intro!: times_in_intervalI)

lemma set_of_add_cong:
  "set_of (A + B) = set_of (A' + B')"
  if "set_of A = set_of A'" "set_of B = set_of B'"
  for A :: "'a::linordered_ab_group_add interval"
  unfolding set_of_plus that ..

lemma set_of_add_inc_left:
  "set_of (A + B) \<subseteq> set_of (A' + B)"
  if "set_of A \<subseteq> set_of A'"
  for A :: "'a::linordered_ab_group_add interval"
  unfolding set_of_plus using that by (auto simp: set_plus_def)

lemma set_of_add_inc_right:
  "set_of (A + B) \<subseteq> set_of (A + B')"
  if "set_of B \<subseteq> set_of B'"
  for A :: "'a::linordered_ab_group_add interval"
  using set_of_add_inc_left[OF that]
  by (simp add: add.commute)

lemma set_of_add_inc:
  "set_of (A + B) \<subseteq> set_of (A' + B')"
  if "set_of A \<subseteq> set_of A'" "set_of B \<subseteq> set_of B'"
  for A :: "'a::linordered_ab_group_add interval"
  using set_of_add_inc_left[OF that(1)] set_of_add_inc_right[OF that(2)]
  by auto

lemma set_of_neg_inc:
  "set_of (-A) \<subseteq> set_of (-A')"
  if "set_of A \<subseteq> set_of A'"
  for A :: "'a::ordered_ab_group_add interval"
  using that
  unfolding set_of_uminus
  by auto

lemma set_of_sub_inc_left:
  "set_of (A - B) \<subseteq> set_of (A' - B)"
  if "set_of A \<subseteq> set_of A'"
  for A :: "'a::linordered_ab_group_add interval"
  using that
  unfolding set_of_minus
  by auto

lemma set_of_sub_inc_right:
  "set_of (A - B) \<subseteq> set_of (A - B')"
  if "set_of B \<subseteq> set_of B'"
  for A :: "'a::linordered_ab_group_add interval"
  using that
  unfolding set_of_minus
  by auto

lemma set_of_sub_inc:
  "set_of (A - B) \<subseteq> set_of (A' - B')"
  if "set_of A \<subseteq> set_of A'" "set_of B \<subseteq> set_of B'"
  for A :: "'a::linordered_idom interval"
  using set_of_sub_inc_left[OF that(1)] set_of_sub_inc_right[OF that(2)]
  by auto

lemma set_of_mul_inc_right:
  "set_of (A * B) \<subseteq> set_of (A * B')"
  if "set_of B \<subseteq> set_of B'"
  for A :: "'a::linordered_ring interval"
  using that
  apply transfer
  apply (clarsimp simp add: Let_def)
  apply (intro conjI)
         apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
        apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
       apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
      apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
     apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
    apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
   apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
  apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
  done

lemma set_of_distrib_left:
  "set_of (B * (A1 + A2)) \<subseteq> set_of (B * A1 + B * A2)"
  for A1 :: "'a::linordered_ring interval"
  apply transfer
  apply (clarsimp simp: Let_def distrib_left distrib_right)
  apply (intro conjI)
         apply (metis add_mono min.cobounded1 min.left_commute)
        apply (metis add_mono min.cobounded1 min.left_commute)
       apply (metis add_mono min.cobounded1 min.left_commute)
      apply (metis add_mono min.assoc min.cobounded2)
     apply (meson add_mono order.trans max.cobounded1 max.cobounded2)
    apply (meson add_mono order.trans max.cobounded1 max.cobounded2)
   apply (meson add_mono order.trans max.cobounded1 max.cobounded2)
  apply (meson add_mono order.trans max.cobounded1 max.cobounded2)
  done

lemma set_of_distrib_right:
  "set_of ((A1 + A2) * B) \<subseteq> set_of (A1 * B + A2 * B)"
  for A1 A2 B :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
  unfolding set_of_times set_of_plus set_plus_def
  apply clarsimp
  subgoal for b a1 a2
    apply (rule exI[where x="a1 * b"])
    apply (rule conjI)
    subgoal by force
    subgoal
      apply (rule exI[where x="a2 * b"])
      apply (rule conjI)
      subgoal by force
      subgoal by (simp add: algebra_simps)
      done
    done
  done

lemma set_of_mul_inc_left:
  "set_of (A * B) \<subseteq> set_of (A' * B)"
  if "set_of A \<subseteq> set_of A'"
  for A :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
  using that
  unfolding set_of_times
  by auto

lemma set_of_mul_inc:
  "set_of (A * B) \<subseteq> set_of (A' * B')"
  if "set_of A \<subseteq> set_of A'" "set_of B \<subseteq> set_of B'"
  for A :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
  using that unfolding set_of_times by auto

lemma set_of_pow_inc:
  "set_of (A^n) \<subseteq> set_of (A'^n)"
  if "set_of A \<subseteq> set_of A'"
  for A :: "'a::{linordered_idom, real_normed_algebra, linear_continuum_topology} interval"
  using that
  by (induction n, simp_all add: set_of_mul_inc)

lemma set_of_distrib_right_left:
  "set_of ((A1 + A2) * (B1 + B2)) \<subseteq> set_of (A1 * B1 + A1 * B2 + A2 * B1 + A2 * B2)"
  for A1 :: "'a::{linordered_idom, real_normed_algebra, linear_continuum_topology} interval"
proof-
  have "set_of ((A1 + A2) * (B1 + B2)) \<subseteq> set_of (A1 * (B1 + B2) + A2 * (B1 + B2))"
    by (rule set_of_distrib_right)
  also have "... \<subseteq> set_of ((A1 * B1 + A1 * B2) + A2 * (B1 + B2))"
    by (rule set_of_add_inc_left[OF set_of_distrib_left])
  also have "... \<subseteq> set_of ((A1 * B1 + A1 * B2) + (A2 * B1 + A2 * B2))"
    by (rule set_of_add_inc_right[OF set_of_distrib_left])
  finally show ?thesis
    by (simp add: add.assoc)
qed

lemma mult_bounds_enclose_zero1:
  "min (la * lb) (min (la * ub) (min (lb * ua) (ua * ub))) \<le> 0"
  "0 \<le> max (la * lb) (max (la * ub) (max (lb * ua) (ua * ub)))"
  if "la \<le> 0" "0 \<le> ua"
  for la lb ua ub:: "'a::linordered_idom"
  subgoal by (metis (no_types, opaque_lifting) that eq_iff min_le_iff_disj mult_zero_left mult_zero_right
        zero_le_mult_iff)
  subgoal by (metis that le_max_iff_disj mult_zero_right order_refl zero_le_mult_iff)
  done

lemma mult_bounds_enclose_zero2:
  "min (la * lb) (min (la * ub) (min (lb * ua) (ua * ub))) \<le> 0"
  "0 \<le> max (la * lb) (max (la * ub) (max (lb * ua) (ua * ub)))"
  if "lb \<le> 0" "0 \<le> ub"
  for la lb ua ub:: "'a::linordered_idom"
  using mult_bounds_enclose_zero1[OF that, of la ua]
  by (simp_all add: ac_simps)

lemma set_of_mul_contains_zero:
  "0 \<in> set_of (A * B)"
  if "0 \<in> set_of A \<or> 0 \<in> set_of B"
  for A :: "'a::linordered_idom interval"
  using that
  by (auto simp: set_of_eq lower_times upper_times algebra_simps mult_le_0_iff
      mult_bounds_enclose_zero1 mult_bounds_enclose_zero2)

instance "interval" :: (linordered_semiring) mult_zero
  apply standard
  subgoal by transfer auto
  subgoal by transfer auto
  done

lift_definition min_interval::"'a::linorder interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval" is
  "\<lambda>(l1, u1). \<lambda>(l2, u2). (min l1 l2, min u1 u2)"
  by (auto simp: min_def)
lemma lower_min_interval[simp]: "lower (min_interval x y) = min (lower x) (lower y)"
  by transfer auto
lemma upper_min_interval[simp]: "upper (min_interval x y) = min (upper x) (upper y)"
  by transfer auto

lemma min_intervalI:
  "a \<in>\<^sub>i A \<Longrightarrow> b \<in>\<^sub>i B \<Longrightarrow> min a b \<in>\<^sub>i min_interval A B"
  by (auto simp: set_of_eq min_def)

lift_definition max_interval::"'a::linorder interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval" is
  "\<lambda>(l1, u1). \<lambda>(l2, u2). (max l1 l2, max u1 u2)"
  by (auto simp: max_def)
lemma lower_max_interval[simp]: "lower (max_interval x y) = max (lower x) (lower y)"
  by transfer auto
lemma upper_max_interval[simp]: "upper (max_interval x y) = max (upper x) (upper y)"
  by transfer auto

lemma max_intervalI:
  "a \<in>\<^sub>i A \<Longrightarrow> b \<in>\<^sub>i B \<Longrightarrow> max a b \<in>\<^sub>i max_interval A B"
  by (auto simp: set_of_eq max_def)

lift_definition abs_interval::"'a::linordered_idom interval \<Rightarrow> 'a interval" is
  "(\<lambda>(l,u). (if l < 0 \<and> 0 < u then 0 else min \<bar>l\<bar> \<bar>u\<bar>, max \<bar>l\<bar> \<bar>u\<bar>))"
  by auto

lemma lower_abs_interval[simp]:
  "lower (abs_interval x) = (if lower x < 0 \<and> 0 < upper x then 0 else min \<bar>lower x\<bar> \<bar>upper x\<bar>)"
  by transfer auto
lemma upper_abs_interval[simp]: "upper (abs_interval x) = max \<bar>lower x\<bar> \<bar>upper x\<bar>"
  by transfer auto

lemma in_abs_intervalI1:
  "lx < 0 \<Longrightarrow> 0 < ux \<Longrightarrow> 0 \<le> xa \<Longrightarrow> xa \<le> max (- lx) (ux) \<Longrightarrow> xa \<in> abs ` {lx..ux}"
  for xa::"'a::linordered_idom"
  by (metis abs_minus_cancel abs_of_nonneg atLeastAtMost_iff image_eqI le_less le_max_iff_disj
      le_minus_iff neg_le_0_iff_le order_trans)

lemma in_abs_intervalI2:
  "min (\<bar>lx\<bar>) \<bar>ux\<bar> \<le> xa \<Longrightarrow> xa \<le> max \<bar>lx\<bar> \<bar>ux\<bar> \<Longrightarrow> lx \<le> ux \<Longrightarrow> 0 \<le> lx \<or> ux \<le> 0 \<Longrightarrow>
    xa \<in> abs ` {lx..ux}"
  for xa::"'a::linordered_idom"
  by (force intro: image_eqI[where x="-xa"] image_eqI[where x="xa"])

lemma set_of_abs_interval: "set_of (abs_interval x) = abs ` set_of x"
  by (auto simp: set_of_eq not_less intro: in_abs_intervalI1 in_abs_intervalI2 cong del: image_cong_simp)

fun split_domain :: "('a::preorder interval \<Rightarrow> 'a interval list) \<Rightarrow> 'a interval list \<Rightarrow> 'a interval list list"
  where "split_domain split [] = [[]]"
  | "split_domain split (I#Is) = (
         let S = split I;
             D = split_domain split Is
         in concat (map (\<lambda>d. map (\<lambda>s. s # d) S) D)
       )"

context notes [[typedef_overloaded]] begin
lift_definition(code_dt) split_interval::"'a::linorder interval \<Rightarrow> 'a \<Rightarrow> ('a interval \<times> 'a interval)"
  is "\<lambda>(l, u) x. ((min l x, max l x), (min u x, max u x))"
  by (auto simp: min_def)
end

lemma split_domain_nonempty:
  assumes "\<And>I. split I \<noteq> []"
  shows "split_domain split I \<noteq> []"
  using last_in_set assms
  by (induction I, auto)

lemma lower_split_interval1: "lower (fst (split_interval X m)) = min (lower X) m"
  and lower_split_interval2: "lower (snd (split_interval X m)) = min (upper X) m"
  and upper_split_interval1: "upper (fst (split_interval X m)) = max (lower X) m"
  and upper_split_interval2: "upper (snd (split_interval X m)) = max (upper X) m"
  subgoal by transfer auto
  subgoal by transfer (auto simp: min.commute)
  subgoal by transfer (auto simp: )
  subgoal by transfer (auto simp: )
  done

lemma split_intervalD: "split_interval X x = (A, B) \<Longrightarrow> set_of X \<subseteq> set_of A \<union> set_of B"
  unfolding set_of_eq
  by transfer (auto simp: min_def max_def split: if_splits)

instantiation interval :: ("{topological_space, preorder}") topological_space
begin

definition open_interval_def[code del]: "open (X::'a interval set) =
  (\<forall>x\<in>X.
      \<exists>A B.
         open A \<and>
         open B \<and>
         lower x \<in> A \<and> upper x \<in> B \<and> Interval ` (A \<times> B) \<subseteq> X)"

instance
proof
  show "open (UNIV :: ('a interval) set)"
    unfolding open_interval_def by auto
next
  fix S T :: "('a interval) set"
  assume "open S" "open T"
  show "open (S \<inter> T)"
    unfolding open_interval_def
  proof (safe)
    fix x assume "x \<in> S" "x \<in> T"
    from \<open>x \<in> S\<close> \<open>open S\<close> obtain Sl Su where S:
      "open Sl" "open Su" "lower x \<in> Sl" "upper x \<in> Su" "Interval ` (Sl \<times> Su) \<subseteq> S"
      by (auto simp: open_interval_def)
    from \<open>x \<in> T\<close> \<open>open T\<close> obtain Tl Tu where T:
      "open Tl" "open Tu" "lower x \<in> Tl" "upper x \<in> Tu" "Interval ` (Tl \<times> Tu) \<subseteq> T"
      by (auto simp: open_interval_def)

    let ?L = "Sl \<inter> Tl" and ?U = "Su \<inter> Tu"
    have "open ?L \<and> open ?U \<and> lower x \<in> ?L \<and> upper x \<in> ?U \<and> Interval ` (?L \<times> ?U) \<subseteq> S \<inter> T"
      using S T by (auto simp add: open_Int)
    then show "\<exists>A B. open A \<and> open B \<and> lower x \<in> A \<and> upper x \<in> B \<and> Interval ` (A \<times> B) \<subseteq> S \<inter> T"
      by fast
  qed
qed (unfold open_interval_def, fast)

end

subsection \<open>Quickcheck\<close>

lift_definition Ivl::"'a \<Rightarrow> 'a::preorder \<Rightarrow> 'a interval" is "\<lambda>a b. (min a b, b)"
  by (auto simp: min_def)

instantiation interval :: ("{exhaustive,preorder}") exhaustive
begin

definition exhaustive_interval::"('a interval \<Rightarrow> (bool \<times> term list) option)
     \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
  where
    "exhaustive_interval f d =
    Quickcheck_Exhaustive.exhaustive (\<lambda>x. Quickcheck_Exhaustive.exhaustive (\<lambda>y. f (Ivl x y)) d) d"

instance ..

end

context
  includes term_syntax
begin

definition [code_unfold]:
  "valtermify_interval x y = Code_Evaluation.valtermify (Ivl::'a::{preorder,typerep}\<Rightarrow>_) {\<cdot>} x {\<cdot>} y"

end

instantiation interval :: ("{full_exhaustive,preorder,typerep}") full_exhaustive
begin

definition full_exhaustive_interval::
  "('a interval \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
     \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option" where
  "full_exhaustive_interval f d =
    Quickcheck_Exhaustive.full_exhaustive
      (\<lambda>x. Quickcheck_Exhaustive.full_exhaustive (\<lambda>y. f (valtermify_interval x y)) d) d"

instance ..

end

instantiation interval :: ("{random,preorder,typerep}") random
begin

definition random_interval ::
  "natural
  \<Rightarrow> natural \<times> natural
     \<Rightarrow> ('a interval \<times> (unit \<Rightarrow> term)) \<times> natural \<times> natural" where
  "random_interval i =
  scomp (Quickcheck_Random.random i)
    (\<lambda>man. scomp (Quickcheck_Random.random i) (\<lambda>exp. Pair (valtermify_interval man exp)))"

instance ..

end

lifting_update interval.lifting
lifting_forget interval.lifting

end


(*  Title:      Doc/Functions/Functions.thy
    Author:     Alexander Krauss, TU Muenchen

Tutorial for function definitions with the new "function" package.
*)

theory Functions
imports Main
begin

section \<open>Function Definitions for Dummies\<close>

text \<open>
  In most cases, defining a recursive function is just as simple as other definitions:
\<close>

fun fib :: "nat \<Rightarrow> nat"
where
  "fib 0 = 1"
| "fib (Suc 0) = 1"
| "fib (Suc (Suc n)) = fib n + fib (Suc n)"

text \<open>
  The syntax is rather self-explanatory: We introduce a function by
  giving its name, its type,
  and a set of defining recursive equations.
  If we leave out the type, the most general type will be
  inferred, which can sometimes lead to surprises: Since both \<^term>\<open>1::nat\<close> and \<open>+\<close> are overloaded, we would end up
  with \<open>fib :: nat \<Rightarrow> 'a::{one,plus}\<close>.
\<close>

text \<open>
  The function always terminates, since its argument gets smaller in
  every recursive call.
  Since HOL is a logic of total functions, termination is a
  fundamental requirement to prevent inconsistencies\footnote{From the
  \qt{definition} \<open>f(n) = f(n) + 1\<close> we could prove
  \<open>0 = 1\<close> by subtracting \<open>f(n)\<close> on both sides.}.
  Isabelle tries to prove termination automatically when a definition
  is made. In \S\ref{termination}, we will look at cases where this
  fails and see what to do then.
\<close>

subsection \<open>Pattern matching\<close>

text \<open>\label{patmatch}
  Like in functional programming, we can use pattern matching to
  define functions. At the moment we will only consider \emph{constructor
  patterns}, which only consist of datatype constructors and
  variables. Furthermore, patterns must be linear, i.e.\ all variables
  on the left hand side of an equation must be distinct. In
  \S\ref{genpats} we discuss more general pattern matching.

  If patterns overlap, the order of the equations is taken into
  account. The following function inserts a fixed element between any
  two elements of a list:
\<close>

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

text \<open>
  Overlapping patterns are interpreted as \qt{increments} to what is
  already there: The second equation is only meant for the cases where
  the first one does not match. Consequently, Isabelle replaces it
  internally by the remaining cases, making the patterns disjoint:
\<close>

thm sep.simps

text \<open>@{thm [display] sep.simps[no_vars]}\<close>

text \<open>
  \noindent The equations from function definitions are automatically used in
  simplification:
\<close>

lemma "sep 0 [1, 2, 3] = [1, 0, 2, 0, 3]"
by simp

subsection \<open>Induction\<close>

text \<open>

  Isabelle provides customized induction rules for recursive
  functions. These rules follow the recursive structure of the
  definition. Here is the rule @{thm [source] sep.induct} arising from the
  above definition of \<^const>\<open>sep\<close>:

  @{thm [display] sep.induct}

  We have a step case for list with at least two elements, and two
  base cases for the zero- and the one-element list. Here is a simple
  proof about \<^const>\<open>sep\<close> and \<^const>\<open>map\<close>
\<close>

lemma "map f (sep x ys) = sep (f x) (map f ys)"
apply (induct x ys rule: sep.induct)

text \<open>
  We get three cases, like in the definition.

  @{subgoals [display]}
\<close>

apply auto
done
text \<open>

  With the \cmd{fun} command, you can define about 80\% of the
  functions that occur in practice. The rest of this tutorial explains
  the remaining 20\%.
\<close>

section \<open>fun vs.\ function\<close>

text \<open>
  The \cmd{fun} command provides a
  convenient shorthand notation for simple function definitions. In
  this mode, Isabelle tries to solve all the necessary proof obligations
  automatically. If any proof fails, the definition is
  rejected. This can either mean that the definition is indeed faulty,
  or that the default proof procedures are just not smart enough (or
  rather: not designed) to handle the definition.

  By expanding the abbreviation to the more verbose \cmd{function} command, these proof obligations become visible and can be analyzed or
  solved manually. The expansion from \cmd{fun} to \cmd{function} is as follows:

\end{isamarkuptext}

\[\left[\;\begin{minipage}{0.25\textwidth}\vspace{6pt}
\cmd{fun} \<open>f :: \<tau>\<close>\\%
\cmd{where}\\%
\hspace*{2ex}{\it equations}\\%
\hspace*{2ex}\vdots\vspace*{6pt}
\end{minipage}\right]
\quad\equiv\quad
\left[\;\begin{minipage}{0.48\textwidth}\vspace{6pt}
\cmd{function} \<open>(\<close>\cmd{sequential}\<open>) f :: \<tau>\<close>\\%
\cmd{where}\\%
\hspace*{2ex}{\it equations}\\%
\hspace*{2ex}\vdots\\%
\cmd{by} \<open>pat_completeness auto\<close>\\%
\cmd{termination by} \<open>lexicographic_order\<close>\vspace{6pt}
\end{minipage}
\right]\]

\begin{isamarkuptext}
  \vspace*{1em}
  \noindent Some details have now become explicit:

  \begin{enumerate}
  \item The \cmd{sequential} option enables the preprocessing of
  pattern overlaps which we already saw. Without this option, the equations
  must already be disjoint and complete. The automatic completion only
  works with constructor patterns.

  \item A function definition produces a proof obligation which
  expresses completeness and compatibility of patterns (we talk about
  this later). The combination of the methods \<open>pat_completeness\<close> and
  \<open>auto\<close> is used to solve this proof obligation.

  \item A termination proof follows the definition, started by the
  \cmd{termination} command. This will be explained in \S\ref{termination}.
 \end{enumerate}
  Whenever a \cmd{fun} command fails, it is usually a good idea to
  expand the syntax to the more verbose \cmd{function} form, to see
  what is actually going on.
\<close>

section \<open>Termination\<close>

text \<open>\label{termination}
  The method \<open>lexicographic_order\<close> is the default method for
  termination proofs. It can prove termination of a
  certain class of functions by searching for a suitable lexicographic
  combination of size measures. Of course, not all functions have such
  a simple termination argument. For them, we can specify the termination
  relation manually.
\<close>

subsection \<open>The {\tt relation} method\<close>
text\<open>
  Consider the following function, which sums up natural numbers up to
  \<open>N\<close>, using a counter \<open>i\<close>:
\<close>

function sum :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "sum i N = (if i > N then 0 else i + sum (Suc i) N)"
by pat_completeness auto

text \<open>
  \noindent The \<open>lexicographic_order\<close> method fails on this example, because none of the
  arguments decreases in the recursive call, with respect to the standard size ordering.
  To prove termination manually, we must provide a custom wellfounded relation.

  The termination argument for \<open>sum\<close> is based on the fact that
  the \emph{difference} between \<open>i\<close> and \<open>N\<close> gets
  smaller in every step, and that the recursion stops when \<open>i\<close>
  is greater than \<open>N\<close>. Phrased differently, the expression
  \<open>N + 1 - i\<close> always decreases.

  We can use this expression as a measure function suitable to prove termination.
\<close>

termination sum
apply (relation "measure (\<lambda>(i,N). N + 1 - i)")

text \<open>
  The \cmd{termination} command sets up the termination goal for the
  specified function \<open>sum\<close>. If the function name is omitted, it
  implicitly refers to the last function definition.

  The \<open>relation\<close> method takes a relation of
  type \<^typ>\<open>('a \<times> 'a) set\<close>, where \<^typ>\<open>'a\<close> is the argument type of
  the function. If the function has multiple curried arguments, then
  these are packed together into a tuple, as it happened in the above
  example.

  The predefined function @{term[source] "measure :: ('a \<Rightarrow> nat) \<Rightarrow> ('a \<times> 'a) set"} constructs a
  wellfounded relation from a mapping into the natural numbers (a
  \emph{measure function}).

  After the invocation of \<open>relation\<close>, we must prove that (a)
  the relation we supplied is wellfounded, and (b) that the arguments
  of recursive calls indeed decrease with respect to the
  relation:

  @{subgoals[display,indent=0]}

  These goals are all solved by \<open>auto\<close>:
\<close>

apply auto
done

text \<open>
  Let us complicate the function a little, by adding some more
  recursive calls:
\<close>

function foo :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "foo i N = (if i > N
              then (if N = 0 then 0 else foo 0 (N - 1))
              else i + foo (Suc i) N)"
by pat_completeness auto

text \<open>
  When \<open>i\<close> has reached \<open>N\<close>, it starts at zero again
  and \<open>N\<close> is decremented.
  This corresponds to a nested
  loop where one index counts up and the other down. Termination can
  be proved using a lexicographic combination of two measures, namely
  the value of \<open>N\<close> and the above difference. The \<^const>\<open>measures\<close> combinator generalizes \<open>measure\<close> by taking a
  list of measure functions.
\<close>

termination
by (relation "measures [\<lambda>(i, N). N, \<lambda>(i,N). N + 1 - i]") auto

subsection \<open>How \<open>lexicographic_order\<close> works\<close>

(*fun fails :: "nat \<Rightarrow> nat list \<Rightarrow> nat"
where
  "fails a [] = a"
| "fails a (x#xs) = fails (x + a) (x # xs)"
*)

text \<open>
  To see how the automatic termination proofs work, let's look at an
  example where it fails\footnote{For a detailed discussion of the
  termination prover, see \<^cite>\<open>bulwahnKN07\<close>}:

\end{isamarkuptext}
\cmd{fun} \<open>fails :: "nat \<Rightarrow> nat list \<Rightarrow> nat"\<close>\\%
\cmd{where}\\%
\hspace*{2ex}\<open>"fails a [] = a"\<close>\\%
|\hspace*{1.5ex}\<open>"fails a (x#xs) = fails (x + a) (x#xs)"\<close>\\
\begin{isamarkuptext}

\noindent Isabelle responds with the following error:

\begin{isabelle}
*** Unfinished subgoals:\newline
*** (a, 1, <):\newline
*** \ 1.~\<open>\<And>x. x = 0\<close>\newline
*** (a, 1, <=):\newline
*** \ 1.~False\newline
*** (a, 2, <):\newline
*** \ 1.~False\newline
*** Calls:\newline
*** a) \<open>(a, x # xs) -->> (x + a, x # xs)\<close>\newline
*** Measures:\newline
*** 1) \<open>\<lambda>x. size (fst x)\<close>\newline
*** 2) \<open>\<lambda>x. size (snd x)\<close>\newline
*** Result matrix:\newline
*** \ \ \ \ 1\ \ 2  \newline
*** a:  ?   <= \newline
*** Could not find lexicographic termination order.\newline
*** At command "fun".\newline
\end{isabelle}
\<close>
text \<open>
  The key to this error message is the matrix at the bottom. The rows
  of that matrix correspond to the different recursive calls (In our
  case, there is just one). The columns are the function's arguments
  (expressed through different measure functions, which map the
  argument tuple to a natural number).

  The contents of the matrix summarize what is known about argument
  descents: The second argument has a weak descent (\<open><=\<close>) at the
  recursive call, and for the first argument nothing could be proved,
  which is expressed by \<open>?\<close>. In general, there are the values
  \<open><\<close>, \<open><=\<close> and \<open>?\<close>.

  For the failed proof attempts, the unfinished subgoals are also
  printed. Looking at these will often point to a missing lemma.
\<close>

subsection \<open>The \<open>size_change\<close> method\<close>

text \<open>
  Some termination goals that are beyond the powers of
  \<open>lexicographic_order\<close> can be solved automatically by the
  more powerful \<open>size_change\<close> method, which uses a variant of
  the size-change principle, together with some other
  techniques. While the details are discussed
  elsewhere \<^cite>\<open>krauss_phd\<close>,
  here are a few typical situations where
  \<open>lexicographic_order\<close> has difficulties and \<open>size_change\<close>
  may be worth a try:
  \begin{itemize}
  \item Arguments are permuted in a recursive call.
  \item Several mutually recursive functions with multiple arguments.
  \item Unusual control flow (e.g., when some recursive calls cannot
  occur in sequence).
  \end{itemize}

  Loading the theory \<open>Multiset\<close> makes the \<open>size_change\<close>
  method a bit stronger: it can then use multiset orders internally.
\<close>

subsection \<open>Configuring simplification rules for termination proofs\<close>

text \<open>
  Since both \<open>lexicographic_order\<close> and \<open>size_change\<close> rely on the simplifier internally,
  there can sometimes be the need for adding additional simp rules to them.
  This can be done either as arguments to the methods themselves, or globally via the
  theorem attribute \<open>termination_simp\<close>, which is useful in rare cases.
\<close>

section \<open>Mutual Recursion\<close>

text \<open>
  If two or more functions call one another mutually, they have to be defined
  in one step. Here are \<open>even\<close> and \<open>odd\<close>:
\<close>

function even :: "nat \<Rightarrow> bool"
    and odd  :: "nat \<Rightarrow> bool"
where
  "even 0 = True"
| "odd 0 = False"
| "even (Suc n) = odd n"
| "odd (Suc n) = even n"
by pat_completeness auto

text \<open>
  To eliminate the mutual dependencies, Isabelle internally
  creates a single function operating on the sum
  type \<^typ>\<open>nat + nat\<close>. Then, \<^const>\<open>even\<close> and \<^const>\<open>odd\<close> are
  defined as projections. Consequently, termination has to be proved
  simultaneously for both functions, by specifying a measure on the
  sum type:
\<close>

termination
by (relation "measure (\<lambda>x. case x of Inl n \<Rightarrow> n | Inr n \<Rightarrow> n)") auto

text \<open>
  We could also have used \<open>lexicographic_order\<close>, which
  supports mutual recursive termination proofs to a certain extent.
\<close>

subsection \<open>Induction for mutual recursion\<close>

text \<open>

  When functions are mutually recursive, proving properties about them
  generally requires simultaneous induction. The induction rule @{thm [source] "even_odd.induct"}
  generated from the above definition reflects this.

  Let us prove something about \<^const>\<open>even\<close> and \<^const>\<open>odd\<close>:
\<close>

lemma even_odd_mod2:
  "even n = (n mod 2 = 0)"
  "odd n = (n mod 2 = 1)"

text \<open>
  We apply simultaneous induction, specifying the induction variable
  for both goals, separated by \cmd{and}:\<close>

apply (induct n and n rule: even_odd.induct)

text \<open>
  We get four subgoals, which correspond to the clauses in the
  definition of \<^const>\<open>even\<close> and \<^const>\<open>odd\<close>:
  @{subgoals[display,indent=0]}
  Simplification solves the first two goals, leaving us with two
  statements about the \<open>mod\<close> operation to prove:
\<close>

apply simp_all

text \<open>
  @{subgoals[display,indent=0]}

  \noindent These can be handled by Isabelle's arithmetic decision procedures.

\<close>

apply arith
apply arith
done

text \<open>
  In proofs like this, the simultaneous induction is really essential:
  Even if we are just interested in one of the results, the other
  one is necessary to strengthen the induction hypothesis. If we leave
  out the statement about \<^const>\<open>odd\<close> and just write \<^term>\<open>True\<close> instead,
  the same proof fails:
\<close>

lemma failed_attempt:
  "even n = (n mod 2 = 0)"
  "True"
apply (induct n rule: even_odd.induct)

text \<open>
  \noindent Now the third subgoal is a dead end, since we have no
  useful induction hypothesis available:

  @{subgoals[display,indent=0]}
\<close>

oops

section \<open>Elimination\<close>

text \<open>
  A definition of function \<open>f\<close> gives rise to two kinds of elimination rules. Rule \<open>f.cases\<close>
  simply describes case analysis according to the patterns used in the definition:
\<close>

fun list_to_option :: "'a list \<Rightarrow> 'a option"
where
  "list_to_option [x] = Some x"
| "list_to_option _ = None"

thm list_to_option.cases
text \<open>
  @{thm[display] list_to_option.cases}

  Note that this rule does not mention the function at all, but only describes the cases used for
  defining it. In contrast, the rule @{thm[source] list_to_option.elims} also tell us what the function
  value will be in each case:
\<close>
thm list_to_option.elims
text \<open>
  @{thm[display] list_to_option.elims}

  \noindent
  This lets us eliminate an assumption of the form \<^prop>\<open>list_to_option xs = y\<close> and replace it
  with the two cases, e.g.:
\<close>

lemma "list_to_option xs = y \<Longrightarrow> P"
proof (erule list_to_option.elims)
  fix x assume "xs = [x]" "y = Some x" thus P sorry
next
  assume "xs = []" "y = None" thus P sorry
next
  fix a b xs' assume "xs = a # b # xs'" "y = None" thus P sorry
qed

text \<open>
  Sometimes it is convenient to derive specialized versions of the \<open>elim\<close> rules above and
  keep them around as facts explicitly. For example, it is natural to show that if
  \<^prop>\<open>list_to_option xs = Some y\<close>, then \<^term>\<open>xs\<close> must be a singleton. The command
  \cmd{fun\_cases} derives such facts automatically, by instantiating and simplifying the general
  elimination rules given some pattern:
\<close>

fun_cases list_to_option_SomeE[elim]: "list_to_option xs = Some y"

thm list_to_option_SomeE
text \<open>
  @{thm[display] list_to_option_SomeE}
\<close>

section \<open>General pattern matching\<close>
text\<open>\label{genpats}\<close>

subsection \<open>Avoiding automatic pattern splitting\<close>

text \<open>

  Up to now, we used pattern matching only on datatypes, and the
  patterns were always disjoint and complete, and if they weren't,
  they were made disjoint automatically like in the definition of
  \<^const>\<open>sep\<close> in \S\ref{patmatch}.

  This automatic splitting can significantly increase the number of
  equations involved, and this is not always desirable. The following
  example shows the problem:

  Suppose we are modeling incomplete knowledge about the world by a
  three-valued datatype, which has values \<^term>\<open>T\<close>, \<^term>\<open>F\<close>
  and \<^term>\<open>X\<close> for true, false and uncertain propositions, respectively.
\<close>

datatype P3 = T | F | X

text \<open>\noindent Then the conjunction of such values can be defined as follows:\<close>

fun And :: "P3 \<Rightarrow> P3 \<Rightarrow> P3"
where
  "And T p = p"
| "And p T = p"
| "And p F = F"
| "And F p = F"
| "And X X = X"

text \<open>
  This definition is useful, because the equations can directly be used
  as simplification rules. But the patterns overlap: For example,
  the expression \<^term>\<open>And T T\<close> is matched by both the first and
  the second equation. By default, Isabelle makes the patterns disjoint by
  splitting them up, producing instances:
\<close>

thm And.simps

text \<open>
  @{thm[indent=4] And.simps}

  \vspace*{1em}
  \noindent There are several problems with this:

  \begin{enumerate}
  \item If the datatype has many constructors, there can be an
  explosion of equations. For \<^const>\<open>And\<close>, we get seven instead of
  five equations, which can be tolerated, but this is just a small
  example.

  \item Since splitting makes the equations \qt{less general}, they
  do not always match in rewriting. While the term \<^term>\<open>And x F\<close>
  can be simplified to \<^term>\<open>F\<close> with the original equations, a
  (manual) case split on \<^term>\<open>x\<close> is now necessary.

  \item The splitting also concerns the induction rule @{thm [source]
  "And.induct"}. Instead of five premises it now has seven, which
  means that our induction proofs will have more cases.

  \item In general, it increases clarity if we get the same definition
  back which we put in.
  \end{enumerate}

  If we do not want the automatic splitting, we can switch it off by
  leaving out the \cmd{sequential} option. However, we will have to
  prove that our pattern matching is consistent\footnote{This prevents
  us from defining something like \<^term>\<open>f x = True\<close> and \<^term>\<open>f x
  = False\<close> simultaneously.}:
\<close>

function And2 :: "P3 \<Rightarrow> P3 \<Rightarrow> P3"
where
  "And2 T p = p"
| "And2 p T = p"
| "And2 p F = F"
| "And2 F p = F"
| "And2 X X = X"

text \<open>
  \noindent Now let's look at the proof obligations generated by a
  function definition. In this case, they are:

  @{subgoals[display,indent=0]}\vspace{-1.2em}\hspace{3cm}\vdots\vspace{1.2em}

  The first subgoal expresses the completeness of the patterns. It has
  the form of an elimination rule and states that every \<^term>\<open>x\<close> of
  the function's input type must match at least one of the patterns\footnote{Completeness could
  be equivalently stated as a disjunction of existential statements:
\<^term>\<open>(\<exists>p. x = (T, p)) \<or> (\<exists>p. x = (p, T)) \<or> (\<exists>p. x = (p, F)) \<or>
  (\<exists>p. x = (F, p)) \<or> (x = (X, X))\<close>, and you can use the method \<open>atomize_elim\<close> to get that form instead.}. If the patterns just involve
  datatypes, we can solve it with the \<open>pat_completeness\<close>
  method:
\<close>

apply pat_completeness

text \<open>
  The remaining subgoals express \emph{pattern compatibility}. We do
  allow that an input value matches multiple patterns, but in this
  case, the result (i.e.~the right hand sides of the equations) must
  also be equal. For each pair of two patterns, there is one such
  subgoal. Usually this needs injectivity of the constructors, which
  is used automatically by \<open>auto\<close>.
\<close>

by auto
termination by (relation "{}") simp

subsection \<open>Non-constructor patterns\<close>

text \<open>
  Most of Isabelle's basic types take the form of inductive datatypes,
  and usually pattern matching works on the constructors of such types.
  However, this need not be always the case, and the \cmd{function}
  command handles other kind of patterns, too.

  One well-known instance of non-constructor patterns are
  so-called \emph{$n+k$-patterns}, which are a little controversial in
  the functional programming world. Here is the initial fibonacci
  example with $n+k$-patterns:
\<close>

function fib2 :: "nat \<Rightarrow> nat"
where
  "fib2 0 = 1"
| "fib2 1 = 1"
| "fib2 (n + 2) = fib2 n + fib2 (Suc n)"

text \<open>
  This kind of matching is again justified by the proof of pattern
  completeness and compatibility.
  The proof obligation for pattern completeness states that every natural number is
  either \<^term>\<open>0::nat\<close>, \<^term>\<open>1::nat\<close> or \<^term>\<open>n +
  (2::nat)\<close>:

  @{subgoals[display,indent=0,goals_limit=1]}

  This is an arithmetic triviality, but unfortunately the
  \<open>arith\<close> method cannot handle this specific form of an
  elimination rule. However, we can use the method \<open>atomize_elim\<close> to do an ad-hoc conversion to a disjunction of
  existentials, which can then be solved by the arithmetic decision procedure.
  Pattern compatibility and termination are automatic as usual.
\<close>
apply atomize_elim
apply arith
apply auto
done
termination by lexicographic_order
text \<open>
  We can stretch the notion of pattern matching even more. The
  following function is not a sensible functional program, but a
  perfectly valid mathematical definition:
\<close>

function ev :: "nat \<Rightarrow> bool"
where
  "ev (2 * n) = True"
| "ev (2 * n + 1) = False"
apply atomize_elim
by arith+
termination by (relation "{}") simp

text \<open>
  This general notion of pattern matching gives you a certain freedom
  in writing down specifications. However, as always, such freedom should
  be used with care:

  If we leave the area of constructor
  patterns, we have effectively departed from the world of functional
  programming. This means that it is no longer possible to use the
  code generator, and expect it to generate ML code for our
  definitions. Also, such a specification might not work very well together with
  simplification. Your mileage may vary.
\<close>

subsection \<open>Conditional equations\<close>

text \<open>
  The function package also supports conditional equations, which are
  similar to guards in a language like Haskell. Here is Euclid's
  algorithm written with conditional patterns\footnote{Note that the
  patterns are also overlapping in the base case}:
\<close>

function gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "gcd x 0 = x"
| "gcd 0 y = y"
| "x < y \<Longrightarrow> gcd (Suc x) (Suc y) = gcd (Suc x) (y - x)"
| "\<not> x < y \<Longrightarrow> gcd (Suc x) (Suc y) = gcd (x - y) (Suc y)"
by (atomize_elim, auto, arith)
termination by lexicographic_order

text \<open>
  By now, you can probably guess what the proof obligations for the
  pattern completeness and compatibility look like.

  Again, functions with conditional patterns are not supported by the
  code generator.
\<close>

subsection \<open>Pattern matching on strings\<close>

text \<open>
  As strings (as lists of characters) are normal datatypes, pattern
  matching on them is possible, but somewhat problematic. Consider the
  following definition:

\end{isamarkuptext}
\noindent\cmd{fun} \<open>check :: "string \<Rightarrow> bool"\<close>\\%
\cmd{where}\\%
\hspace*{2ex}\<open>"check (''good'') = True"\<close>\\%
\<open>| "check s = False"\<close>
\begin{isamarkuptext}

  \noindent An invocation of the above \cmd{fun} command does not
  terminate. What is the problem? Strings are lists of characters, and
  characters are a datatype with a lot of constructors. Splitting the
  catch-all pattern thus leads to an explosion of cases, which cannot
  be handled by Isabelle.

  There are two things we can do here. Either we write an explicit
  \<open>if\<close> on the right hand side, or we can use conditional patterns:
\<close>

function check :: "string \<Rightarrow> bool"
where
  "check (''good'') = True"
| "s \<noteq> ''good'' \<Longrightarrow> check s = False"
by auto
termination by (relation "{}") simp

section \<open>Partiality \label{sec:partiality}\<close>

text \<open>
  In HOL, all functions are total. A function \<^term>\<open>f\<close> applied to
  \<^term>\<open>x\<close> always has the value \<^term>\<open>f x\<close>, and there is no notion
  of undefinedness.
  This is why we have to do termination
  proofs when defining functions: The proof justifies that the
  function can be defined by wellfounded recursion.

  However, the \cmd{function} package does support partiality to a
  certain extent. Let's look at the following function which looks
  for a zero of a given function f.
\<close>

function (*<*)(domintros)(*>*)findzero :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat"
where
  "findzero f n = (if f n = 0 then n else findzero f (Suc n))"
by pat_completeness auto

text \<open>
  \noindent Clearly, any attempt of a termination proof must fail. And without
  that, we do not get the usual rules \<open>findzero.simps\<close> and
  \<open>findzero.induct\<close>. So what was the definition good for at all?
\<close>

subsection \<open>Domain predicates\<close>

text \<open>
  The trick is that Isabelle has not only defined the function \<^const>\<open>findzero\<close>, but also
  a predicate \<^term>\<open>findzero_dom\<close> that characterizes the values where the function
  terminates: the \emph{domain} of the function. If we treat a
  partial function just as a total function with an additional domain
  predicate, we can derive simplification and
  induction rules as we do for total functions. They are guarded
  by domain conditions and are called \<open>psimps\<close> and \<open>pinduct\<close>:
\<close>

text \<open>
  \noindent\begin{minipage}{0.79\textwidth}@{thm[display,margin=85] findzero.psimps}\end{minipage}
  \hfill(@{thm [source] "findzero.psimps"})
  \vspace{1em}

  \noindent\begin{minipage}{0.79\textwidth}@{thm[display,margin=85] findzero.pinduct}\end{minipage}
  \hfill(@{thm [source] "findzero.pinduct"})
\<close>

text \<open>
  Remember that all we
  are doing here is use some tricks to make a total function appear
  as if it was partial. We can still write the term \<^term>\<open>findzero
  (\<lambda>x. 1) 0\<close> and like any other term of type \<^typ>\<open>nat\<close> it is equal
  to some natural number, although we might not be able to find out
  which one. The function is \emph{underdefined}.

  But it is defined enough to prove something interesting about it. We
  can prove that if \<^term>\<open>findzero f n\<close>
  terminates, it indeed returns a zero of \<^term>\<open>f\<close>:
\<close>

lemma findzero_zero: "findzero_dom (f, n) \<Longrightarrow> f (findzero f n) = 0"

text \<open>\noindent We apply induction as usual, but using the partial induction
  rule:\<close>

apply (induct f n rule: findzero.pinduct)

text \<open>\noindent This gives the following subgoals:

  @{subgoals[display,indent=0]}

  \noindent The hypothesis in our lemma was used to satisfy the first premise in
  the induction rule. However, we also get \<^term>\<open>findzero_dom (f, n)\<close> as a local assumption in the induction step. This
  allows unfolding \<^term>\<open>findzero f n\<close> using the \<open>psimps\<close>
  rule, and the rest is trivial.
\<close>
apply (simp add: findzero.psimps)
done

text \<open>
  Proofs about partial functions are often not harder than for total
  functions. Fig.~\ref{findzero_isar} shows a slightly more
  complicated proof written in Isar. It is verbose enough to show how
  partiality comes into play: From the partial induction, we get an
  additional domain condition hypothesis. Observe how this condition
  is applied when calls to \<^term>\<open>findzero\<close> are unfolded.
\<close>

text_raw \<open>
\begin{figure}
\hrule\vspace{6pt}
\begin{minipage}{0.8\textwidth}
\isabellestyle{it}
\isastyle\isamarkuptrue
\<close>
lemma "\<lbrakk>findzero_dom (f, n); x \<in> {n ..< findzero f n}\<rbrakk> \<Longrightarrow> f x \<noteq> 0"
proof (induct rule: findzero.pinduct)
  fix f n assume dom: "findzero_dom (f, n)"
               and IH: "\<lbrakk>f n \<noteq> 0; x \<in> {Suc n ..< findzero f (Suc n)}\<rbrakk> \<Longrightarrow> f x \<noteq> 0"
               and x_range: "x \<in> {n ..< findzero f n}"
  have "f n \<noteq> 0"
  proof
    assume "f n = 0"
    with dom have "findzero f n = n" by (simp add: findzero.psimps)
    with x_range show False by auto
  qed

  from x_range have "x = n \<or> x \<in> {Suc n ..< findzero f n}" by auto
  thus "f x \<noteq> 0"
  proof
    assume "x = n"
    with \<open>f n \<noteq> 0\<close> show ?thesis by simp
  next
    assume "x \<in> {Suc n ..< findzero f n}"
    with dom and \<open>f n \<noteq> 0\<close> have "x \<in> {Suc n ..< findzero f (Suc n)}" by (simp add: findzero.psimps)
    with IH and \<open>f n \<noteq> 0\<close>
    show ?thesis by simp
  qed
qed
text_raw \<open>
\isamarkupfalse\isabellestyle{tt}
\end{minipage}\vspace{6pt}\hrule
\caption{A proof about a partial function}\label{findzero_isar}
\end{figure}
\<close>

subsection \<open>Partial termination proofs\<close>

text \<open>
  Now that we have proved some interesting properties about our
  function, we should turn to the domain predicate and see if it is
  actually true for some values. Otherwise we would have just proved
  lemmas with \<^term>\<open>False\<close> as a premise.

  Essentially, we need some introduction rules for \<open>findzero_dom\<close>. The function package can prove such domain
  introduction rules automatically. But since they are not used very
  often (they are almost never needed if the function is total), this
  functionality is disabled by default for efficiency reasons. So we have to go
  back and ask for them explicitly by passing the \<open>(domintros)\<close> option to the function package:

\vspace{1ex}
\noindent\cmd{function} \<open>(domintros) findzero :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat"\<close>\\%
\cmd{where}\isanewline%
\ \ \ldots\\

  \noindent Now the package has proved an introduction rule for \<open>findzero_dom\<close>:
\<close>

thm findzero.domintros

text \<open>
  @{thm[display] findzero.domintros}

  Domain introduction rules allow to show that a given value lies in the
  domain of a function, if the arguments of all recursive calls
  are in the domain as well. They allow to do a \qt{single step} in a
  termination proof. Usually, you want to combine them with a suitable
  induction principle.

  Since our function increases its argument at recursive calls, we
  need an induction principle which works \qt{backwards}. We will use
  @{thm [source] inc_induct}, which allows to do induction from a fixed number
  \qt{downwards}:

  \begin{center}@{thm inc_induct}\hfill(@{thm [source] "inc_induct"})\end{center}

  Figure \ref{findzero_term} gives a detailed Isar proof of the fact
  that \<open>findzero\<close> terminates if there is a zero which is greater
  or equal to \<^term>\<open>n\<close>. First we derive two useful rules which will
  solve the base case and the step case of the induction. The
  induction is then straightforward, except for the unusual induction
  principle.

\<close>

text_raw \<open>
\begin{figure}
\hrule\vspace{6pt}
\begin{minipage}{0.8\textwidth}
\isabellestyle{it}
\isastyle\isamarkuptrue
\<close>
lemma findzero_termination:
  assumes "x \<ge> n" and "f x = 0"
  shows "findzero_dom (f, n)"
proof -
  have base: "findzero_dom (f, x)"
    by (rule findzero.domintros) (simp add:\<open>f x = 0\<close>)

  have step: "\<And>i. findzero_dom (f, Suc i)
    \<Longrightarrow> findzero_dom (f, i)"
    by (rule findzero.domintros) simp

  from \<open>x \<ge> n\<close> show ?thesis
  proof (induct rule:inc_induct)
    show "findzero_dom (f, x)" by (rule base)
  next
    fix i assume "findzero_dom (f, Suc i)"
    thus "findzero_dom (f, i)" by (rule step)
  qed
qed
text_raw \<open>
\isamarkupfalse\isabellestyle{tt}
\end{minipage}\vspace{6pt}\hrule
\caption{Termination proof for \<open>findzero\<close>}\label{findzero_term}
\end{figure}
\<close>

text \<open>
  Again, the proof given in Fig.~\ref{findzero_term} has a lot of
  detail in order to explain the principles. Using more automation, we
  can also have a short proof:
\<close>

lemma findzero_termination_short:
  assumes zero: "x >= n"
  assumes [simp]: "f x = 0"
  shows "findzero_dom (f, n)"
using zero
by (induct rule:inc_induct) (auto intro: findzero.domintros)

text \<open>
  \noindent It is simple to combine the partial correctness result with the
  termination lemma:
\<close>

lemma findzero_total_correctness:
  "f x = 0 \<Longrightarrow> f (findzero f 0) = 0"
by (blast intro: findzero_zero findzero_termination)

subsection \<open>Definition of the domain predicate\<close>

text \<open>
  Sometimes it is useful to know what the definition of the domain
  predicate looks like. Actually, \<open>findzero_dom\<close> is just an
  abbreviation:

  @{abbrev[display] findzero_dom}

  The domain predicate is the \emph{accessible part} of a relation \<^const>\<open>findzero_rel\<close>, which was also created internally by the function
  package. \<^const>\<open>findzero_rel\<close> is just a normal
  inductive predicate, so we can inspect its definition by
  looking at the introduction rules @{thm [source] findzero_rel.intros}.
  In our case there is just a single rule:

  @{thm[display] findzero_rel.intros}

  The predicate \<^const>\<open>findzero_rel\<close>
  describes the \emph{recursion relation} of the function
  definition. The recursion relation is a binary relation on
  the arguments of the function that relates each argument to its
  recursive calls. In general, there is one introduction rule for each
  recursive call.

  The predicate \<^term>\<open>Wellfounded.accp findzero_rel\<close> is the accessible part of
  that relation. An argument belongs to the accessible part, if it can
  be reached in a finite number of steps (cf.~its definition in \<open>Wellfounded.thy\<close>).

  Since the domain predicate is just an abbreviation, you can use
  lemmas for \<^const>\<open>Wellfounded.accp\<close> and \<^const>\<open>findzero_rel\<close> directly. Some
  lemmas which are occasionally useful are @{thm [source] accpI}, @{thm [source]
  accp_downward}, and of course the introduction and elimination rules
  for the recursion relation @{thm [source] "findzero_rel.intros"} and @{thm
  [source] "findzero_rel.cases"}.
\<close>

section \<open>Nested recursion\<close>

text \<open>
  Recursive calls which are nested in one another frequently cause
  complications, since their termination proof can depend on a partial
  correctness property of the function itself.

  As a small example, we define the \qt{nested zero} function:
\<close>

function nz :: "nat \<Rightarrow> nat"
where
  "nz 0 = 0"
| "nz (Suc n) = nz (nz n)"
by pat_completeness auto

text \<open>
  If we attempt to prove termination using the identity measure on
  naturals, this fails:
\<close>

termination
  apply (relation "measure (\<lambda>n. n)")
  apply auto

text \<open>
  We get stuck with the subgoal

  @{subgoals[display]}

  Of course this statement is true, since we know that \<^const>\<open>nz\<close> is
  the zero function. And in fact we have no problem proving this
  property by induction.
\<close>
(*<*)oops(*>*)
lemma nz_is_zero: "nz_dom n \<Longrightarrow> nz n = 0"
  by (induct rule:nz.pinduct) (auto simp: nz.psimps)

text \<open>
  We formulate this as a partial correctness lemma with the condition
  \<^term>\<open>nz_dom n\<close>. This allows us to prove it with the \<open>pinduct\<close> rule before we have proved termination. With this lemma,
  the termination proof works as expected:
\<close>

termination
  by (relation "measure (\<lambda>n. n)") (auto simp: nz_is_zero)

text \<open>
  As a general strategy, one should prove the statements needed for
  termination as a partial property first. Then they can be used to do
  the termination proof. This also works for less trivial
  examples. Figure \ref{f91} defines the 91-function, a well-known
  challenge problem due to John McCarthy, and proves its termination.
\<close>

text_raw \<open>
\begin{figure}
\hrule\vspace{6pt}
\begin{minipage}{0.8\textwidth}
\isabellestyle{it}
\isastyle\isamarkuptrue
\<close>

function f91 :: "nat \<Rightarrow> nat"
where
  "f91 n = (if 100 < n then n - 10 else f91 (f91 (n + 11)))"
by pat_completeness auto

lemma f91_estimate:
  assumes trm: "f91_dom n"
  shows "n < f91 n + 11"
using trm by induct (auto simp: f91.psimps)

termination
proof
  let ?R = "measure (\<lambda>x. 101 - x)"
  show "wf ?R" ..

  fix n :: nat assume "\<not> 100 < n" \<comment> \<open>Assumptions for both calls\<close>

  thus "(n + 11, n) \<in> ?R" by simp \<comment> \<open>Inner call\<close>

  assume inner_trm: "f91_dom (n + 11)" \<comment> \<open>Outer call\<close>
  with f91_estimate have "n + 11 < f91 (n + 11) + 11" .
  with \<open>\<not> 100 < n\<close> show "(f91 (n + 11), n) \<in> ?R" by simp
qed

text_raw \<open>
\isamarkupfalse\isabellestyle{tt}
\end{minipage}
\vspace{6pt}\hrule
\caption{McCarthy's 91-function}\label{f91}
\end{figure}
\<close>

section \<open>Higher-Order Recursion\<close>

text \<open>
  Higher-order recursion occurs when recursive calls
  are passed as arguments to higher-order combinators such as \<^const>\<open>map\<close>, \<^term>\<open>filter\<close> etc.
  As an example, imagine a datatype of n-ary trees:
\<close>

datatype 'a tree =
  Leaf 'a
| Branch "'a tree list"

text \<open>\noindent We can define a function which swaps the left and right subtrees recursively, using the
  list functions \<^const>\<open>rev\<close> and \<^const>\<open>map\<close>:\<close>

fun mirror :: "'a tree \<Rightarrow> 'a tree"
where
  "mirror (Leaf n) = Leaf n"
| "mirror (Branch l) = Branch (rev (map mirror l))"

text \<open>
  Although the definition is accepted without problems, let us look at the termination proof:
\<close>

termination proof
  text \<open>

  As usual, we have to give a wellfounded relation, such that the
  arguments of the recursive calls get smaller. But what exactly are
  the arguments of the recursive calls when mirror is given as an
  argument to \<^const>\<open>map\<close>? Isabelle gives us the
  subgoals

  @{subgoals[display,indent=0]}

  So the system seems to know that \<^const>\<open>map\<close> only
  applies the recursive call \<^term>\<open>mirror\<close> to elements
  of \<^term>\<open>l\<close>, which is essential for the termination proof.

  This knowledge about \<^const>\<open>map\<close> is encoded in so-called congruence rules,
  which are special theorems known to the \cmd{function} command. The
  rule for \<^const>\<open>map\<close> is

  @{thm[display] map_cong}

  You can read this in the following way: Two applications of \<^const>\<open>map\<close> are equal, if the list arguments are equal and the functions
  coincide on the elements of the list. This means that for the value
  \<^term>\<open>map f l\<close> we only have to know how \<^term>\<open>f\<close> behaves on
  the elements of \<^term>\<open>l\<close>.

  Usually, one such congruence rule is
  needed for each higher-order construct that is used when defining
  new functions. In fact, even basic functions like \<^const>\<open>If\<close> and \<^const>\<open>Let\<close> are handled by this mechanism. The congruence
  rule for \<^const>\<open>If\<close> states that the \<open>then\<close> branch is only
  relevant if the condition is true, and the \<open>else\<close> branch only if it
  is false:

  @{thm[display] if_cong}

  Congruence rules can be added to the
  function package by giving them the \<^term>\<open>fundef_cong\<close> attribute.

  The constructs that are predefined in Isabelle, usually
  come with the respective congruence rules.
  But if you define your own higher-order functions, you may have to
  state and prove the required congruence rules yourself, if you want to use your
  functions in recursive definitions.
\<close>
(*<*)oops(*>*)

subsection \<open>Congruence Rules and Evaluation Order\<close>

text \<open>
  Higher order logic differs from functional programming languages in
  that it has no built-in notion of evaluation order. A program is
  just a set of equations, and it is not specified how they must be
  evaluated.

  However for the purpose of function definition, we must talk about
  evaluation order implicitly, when we reason about termination.
  Congruence rules express that a certain evaluation order is
  consistent with the logical definition.

  Consider the following function.
\<close>

function f :: "nat \<Rightarrow> bool"
where
  "f n = (n = 0 \<or> f (n - 1))"
(*<*)by pat_completeness auto(*>*)

text \<open>
  For this definition, the termination proof fails. The default configuration
  specifies no congruence rule for disjunction. We have to add a
  congruence rule that specifies left-to-right evaluation order:

  \vspace{1ex}
  \noindent @{thm disj_cong}\hfill(@{thm [source] "disj_cong"})
  \vspace{1ex}

  Now the definition works without problems. Note how the termination
  proof depends on the extra condition that we get from the congruence
  rule.

  However, as evaluation is not a hard-wired concept, we
  could just turn everything around by declaring a different
  congruence rule. Then we can make the reverse definition:
\<close>

lemma disj_cong2[fundef_cong]:
  "(\<not> Q' \<Longrightarrow> P = P') \<Longrightarrow> (Q = Q') \<Longrightarrow> (P \<or> Q) = (P' \<or> Q')"
  by blast

fun f' :: "nat \<Rightarrow> bool"
where
  "f' n = (f' (n - 1) \<or> n = 0)"

text \<open>
  \noindent These examples show that, in general, there is no \qt{best} set of
  congruence rules.

  However, such tweaking should rarely be necessary in
  practice, as most of the time, the default set of congruence rules
  works well.
\<close>

end


(* File: boolexp.thy *)

theory boolexp
imports Main
begin

section{* Basic Type and Evaluation Function
         for Boolean Expressions *}

text{*
 The following type mirrors the BNF grammar
we gave in for boolean expressions.  We will use
only prefixed connectives here
*}

datatype 'a boolexp =
   TRUE | FALSE |Var 'a | Not "'a boolexp"
  | And "'a boolexp" "'a boolexp"
  | Or "'a boolexp" "'a boolexp"
  | Implies "'a boolexp" "'a boolexp"

text{*
The following is a recursive definition of the function for evaluating
boolean expressions. It is the same as the definition
of \textit{models} given in class.
*}

fun boolexp_eval
where
   "boolexp_eval env TRUE = True"
 | "boolexp_eval env FALSE = False"
 | "boolexp_eval env (Var x) = env x"
 | "boolexp_eval env (Not b) = (\<not> (boolexp_eval env b))"
 | "boolexp_eval env (And a b) =
    ((boolexp_eval env a) \<and> (boolexp_eval env b))"
 | "boolexp_eval env (Or a b) =
    ((boolexp_eval env a) \<or> (boolexp_eval env b))"
 | "boolexp_eval env (Implies a b) =
    ((\<not> (boolexp_eval env a))\<or> (boolexp_eval env b))"

text{*
Because all our definition have been purely
computational, we may use \tettt{value} to evaluate
expressions using the type \texttt{boolexp} and the term
boolexp_eval.
*}

(*
value "boolexp_eval
(\<lambda> x. case x of ''a'' \<Rightarrow> True | _ \<Rightarrow> False)
 (Implies (Var ''b'') (Var ''a''))"
*)

value "boolexp_eval
(\<lambda> x. case x of (0::nat) \<Rightarrow> True | _ \<Rightarrow> False)
 (Implies (Var (1::nat)) (Var (0::nat)))"

text{*
Our objective is to build a function that will tell
us all the ways a boolean expression can be satisfied.
Our approach is to put the boolean expression in
disjunctive normal form.
We start by eliminating implies.
*}

fun remove_implies where
   "remove_implies TRUE = TRUE"
 | "remove_implies FALSE = FALSE"
 | "remove_implies (Var x) = Var x"
 | "remove_implies (Not a) = Not (remove_implies a)"
 | "remove_implies (And a b) =
    And (remove_implies a) (remove_implies b)"
 | "remove_implies (Or a b) =
    Or (remove_implies a) (remove_implies b)"
 | "remove_implies (Implies a b) =
    (Or (Not (remove_implies a)) (remove_implies b))"

thm boolexp.induct

lemma remove_implies_same_eval [simp]:
"boolexp_eval env (remove_implies a) =
 boolexp_eval env a"
apply (induct "a")
by simp_all
(*
by (induct "a", auto)
*)

fun number_of_implies where
   "number_of_implies TRUE = (0::nat)"
 | "number_of_implies FALSE = 0"
 | "number_of_implies (Var x) = 0"
 | "number_of_implies (Not a) = number_of_implies a"
 | "number_of_implies (And a b) =
   (number_of_implies a) + (number_of_implies b)"
 | "number_of_implies (Or a b) =
   (number_of_implies a) + (number_of_implies b)"
 | "number_of_implies (Implies a b) =
   (number_of_implies a) + (number_of_implies b) + 1"

lemma number_of_implies_remove_implies_0 [simp]:
"number_of_implies (remove_implies a) = 0"
by (induct "a", auto)

fun push_not where
   "push_not TRUE = TRUE"
 | "push_not FALSE = FALSE"
 | "push_not (Var x) = Var x"
 | "push_not (Not TRUE) = FALSE"
 | "push_not (Not FALSE) = TRUE"
 | "push_not (Not (Var x)) = Not (Var x)"
 | "push_not (Not (Not a)) = push_not a"
 | "push_not (Not (And a b)) =
    (Or (push_not (Not a)) (push_not (Not b)))"
 | "push_not (Not (Or a b)) =
    (And (push_not (Not a)) (push_not (Not b)))"
 | "push_not (Not (Implies a b)) =
   (And (push_not a) (push_not (Not b)))"
 | "push_not (And a b) =
   (And (push_not a) (push_not b))"
 | "push_not (Or a b) =
   (Or (push_not a) (push_not b))"
 | "push_not (Implies a b) =
    (Implies (push_not a) (push_not b))"

lemma push_not_same_eval [simp]:
 "(boolexp_eval env (push_not (Not a))
   = (\<not> (boolexp_eval env (push_not a)))) \<and>
  (boolexp_eval env (push_not a) = boolexp_eval env a)"
by (induct "a", auto)

lemma push_not_preserves_no_implies_helper:
"number_of_implies a = 0 \<Longrightarrow>
 (number_of_implies (push_not a) = 0) \<and>
 (number_of_implies (push_not (Not a)) = 0)"
by (induct "a", auto)

lemma push_not_preserves_no_implies:
"number_of_implies a = 0 \<Longrightarrow>
 (number_of_implies (push_not a) = 0)"
by (auto simp add: push_not_preserves_no_implies_helper)

lemma push_not_remove_implies_no_implies [simp]:
"number_of_implies (push_not (remove_implies a)) = 0"
apply (rule push_not_preserves_no_implies)
apply (rule number_of_implies_remove_implies_0)
done

export_code boolexp_eval push_not remove_implies
in OCaml
 module_name Boolexp file "boolexp.ml"

datatype 'a boolexp_no_imp =
      TRUE_ni | FALSE_ni |Var_ni 'a
    | Not_ni "'a boolexp_no_imp"
    | And_ni "'a boolexp_no_imp" "'a boolexp_no_imp"
    | Or_ni "'a boolexp_no_imp" "'a boolexp_no_imp"

fun boolexp_no_imp_eval where
   "boolexp_no_imp_eval env TRUE_ni = True"
 | "boolexp_no_imp_eval env FALSE_ni = False"
 | "boolexp_no_imp_eval env (Var_ni x) = env x"
 | "boolexp_no_imp_eval env (Not_ni a) =
    (\<not> (boolexp_no_imp_eval env a))"
 | "boolexp_no_imp_eval env (And_ni a b) =
    ((boolexp_no_imp_eval env a) \<and>
     (boolexp_no_imp_eval env b))"
 | "boolexp_no_imp_eval env (Or_ni a b) =
    ((boolexp_no_imp_eval env a) \<or>
     (boolexp_no_imp_eval env b))"

fun remove_implies_ni where
   "remove_implies_ni TRUE = TRUE_ni"
 | "remove_implies_ni FALSE = FALSE_ni"
 | "remove_implies_ni (Var x) = Var_ni x"
 | "remove_implies_ni (Not a) =
    Not_ni (remove_implies_ni a)"
 | "remove_implies_ni (And a b) =
    And_ni (remove_implies_ni a) (remove_implies_ni b)"
 | "remove_implies_ni (Or a b) =
    Or_ni (remove_implies_ni a) (remove_implies_ni b)"
 | "remove_implies_ni (Implies a b) =
    (Or_ni (Not_ni (remove_implies_ni a))
           (remove_implies_ni b))"

lemma remove_implies_ni_same_eval:
  "boolexp_no_imp_eval env (remove_implies_ni a) =
   boolexp_eval env (remove_implies a)"
by (induct_tac a, auto)

datatype 'a boolexp_nipn =
    TRUE_nipn | FALSE_nipn |Var_nipn 'a
    | Not_Var_nipn 'a
    | And_nipn "'a boolexp_nipn" "'a boolexp_nipn"
    | Or_nipn "'a boolexp_nipn" "'a boolexp_nipn"

fun push_not_pn where
   "push_not_pn TRUE_ni = TRUE_nipn"
 | "push_not_pn FALSE_ni = FALSE_nipn"
 | "push_not_pn (Var_ni x) = Var_nipn x"
 | "push_not_pn (Not_ni TRUE_ni) = FALSE_nipn"
 | "push_not_pn (Not_ni FALSE_ni) = TRUE_nipn"
 | "push_not_pn (Not_ni (Var_ni x)) = Not_Var_nipn x"
 | "push_not_pn (Not_ni (Not_ni a)) = push_not_pn a"
 | "push_not_pn (Not_ni (And_ni a b)) =
    (Or_nipn (push_not_pn (Not_ni a))
             (push_not_pn (Not_ni b)))"
 | "push_not_pn (Not_ni (Or_ni a b)) =
    (And_nipn (push_not_pn (Not_ni a))
              (push_not_pn (Not_ni b)))"
 | "push_not_pn (And_ni a b) =
   (And_nipn (push_not_pn a) (push_not_pn b))"
 | "push_not_pn (Or_ni a b) =
   (Or_nipn (push_not_pn a) (push_not_pn b))"

fun boolexp_nipn_eval where
   "boolexp_nipn_eval env TRUE_nipn = True"
 | "boolexp_nipn_eval env FALSE_nipn = False"
 | "boolexp_nipn_eval env (Var_nipn x) = env x"
 | "boolexp_nipn_eval env (Not_Var_nipn a) =
    (\<not> (env a))"
 | "boolexp_nipn_eval env (And_nipn a b) =
    ((boolexp_nipn_eval env a) \<and>
     (boolexp_nipn_eval env b))"
 | "boolexp_nipn_eval env (Or_nipn a b) =
    ((boolexp_nipn_eval env a) \<or>
     (boolexp_nipn_eval env b))"

lemma push_not_pn_same_eval [simp]:
"(boolexp_nipn_eval env (push_not_pn (Not_ni b)) =
  (\<not> (boolexp_no_imp_eval env b))) \<and>
 (boolexp_nipn_eval env (push_not_pn b) =
  boolexp_no_imp_eval env b)"
by (induct_tac b, auto)

fun node_count where
   "node_count TRUE = (1::nat)"
 | "node_count FALSE = 1"
 | "node_count (Var x) = 1"
 | "node_count (Not x) = 1 + node_count x"
 | "node_count (And a b) =
    1 + (node_count a) + (node_count b)"
 | "node_count (Or a b) =
    1 + (node_count a) + (node_count b)"
 | "node_count (Implies a b) =
    1 + (node_count a) + (node_count b)"

lemma node_count_non_zero [simp]:
"0 < node_count b"
by (induct_tac b, auto)

function push_not_elim_imp where
   "push_not_elim_imp TRUE = TRUE_nipn"
 | "push_not_elim_imp FALSE = FALSE_nipn"
 | "push_not_elim_imp (Var x) = Var_nipn x"
 | "push_not_elim_imp (Not TRUE) = FALSE_nipn"
 | "push_not_elim_imp (Not FALSE) = TRUE_nipn"
 | "push_not_elim_imp (Not (Var x)) = Not_Var_nipn x"
 | "push_not_elim_imp (Not (Not b)) =
    push_not_elim_imp b"
 | "push_not_elim_imp (Not (And a b)) =
    (Or_nipn (push_not_elim_imp (Not a))
             (push_not_elim_imp (Not b)))"
 | "push_not_elim_imp (Not (Or a b)) =
    (And_nipn (push_not_elim_imp (Not a))
              (push_not_elim_imp (Not b)))"
 | "push_not_elim_imp (Not (Implies a b)) =
   (And_nipn (push_not_elim_imp a)
             (push_not_elim_imp (Not b)))"
 | "push_not_elim_imp (And a b) =
   (And_nipn (push_not_elim_imp a)
             (push_not_elim_imp b))"
 | "push_not_elim_imp (Or a b) =
   (Or_nipn (push_not_elim_imp a)
            (push_not_elim_imp b))"
 | "push_not_elim_imp (Implies a b) =
    (Or_nipn (push_not_elim_imp (Not a))
             (push_not_elim_imp b))"
by (pat_completeness, auto)
term "op <*mlex*>"
termination
by (relation "measures [node_count]", auto)

lemma push_not_elim_imp_push_not_pn_remove_implies_ni [simp]:
"(push_not_elim_imp (boolexp.Not a) =
  push_not_pn (Not_ni (remove_implies_ni a))) \<and>
 (push_not_elim_imp a =
  push_not_pn (remove_implies_ni a))"
by (induct_tac a, auto)

lemma push_not_elim_imp_same_eval [simp]:
"(boolexp_nipn_eval env (push_not_elim_imp (Not a)) =
  (\<not>(boolexp_eval env a))) \<and>
 (boolexp_nipn_eval env (push_not_elim_imp a) =
  boolexp_eval env a)"
by (induct_tac a, auto)

datatype 'a bool_atom =
   TRUE_at | FALSE_at |Var_at 'a | Not_Var_at 'a

fun bool_atom_eval where
   "bool_atom_eval env TRUE_at = True"
 | "bool_atom_eval env FALSE_at = False"
 | "bool_atom_eval env (Var_at x) = env x"
 | "bool_atom_eval env (Not_Var_at x) = (\<not>(env x))"

datatype 'a bool_conj =
   Atom "'a bool_atom"
 | And_conj "'a bool_atom" "'a bool_conj"

fun bool_conj_eval where
   "bool_conj_eval env (Atom a) = bool_atom_eval env a"
 | "bool_conj_eval env (And_conj a b) =
    ((bool_atom_eval env a) \<and>
     (bool_conj_eval env b))"

fun conj_and where
   "conj_and (Atom a) b = And_conj a b"
 | "conj_and (And_conj a b) c =
    And_conj a (conj_and b c)"

lemma conj_and_eval [simp]:
"bool_conj_eval env (conj_and a b) =
 ((bool_conj_eval env a) \<and> (bool_conj_eval env b))"
by (induct_tac a, auto)

datatype 'a bool_dnf =
   Conj "'a bool_conj"
 | Or_dnf "'a bool_conj" "'a bool_dnf"

fun bool_dnf_eval where
   "bool_dnf_eval env (Conj c) = bool_conj_eval env c"
 | "bool_dnf_eval env (Or_dnf a b) =
    ((bool_conj_eval env a) \<or> (bool_dnf_eval env b))"

fun dnf_or where
   "dnf_or (Conj a) b = Or_dnf a b"
 | "dnf_or (Or_dnf a b) c = Or_dnf a (dnf_or b c)"

lemma dnf_or_eval [simp]:
"bool_dnf_eval env (dnf_or a b) =
  ((bool_dnf_eval env a) \<or> (bool_dnf_eval env b))"
by (induct_tac "a", auto)

fun conj_or where
   "conj_or a (Conj b) = Conj (conj_and a b)"
 | "conj_or a (Or_dnf b c) =
    Or_dnf(conj_and a b) (conj_or a c)"

lemma conj_or_eval [simp]:
"bool_dnf_eval env (conj_or a b) =
  ((bool_conj_eval env a) \<and> (bool_dnf_eval env b))"
by (induct_tac "b", auto)

fun dist_and_or where
   "dist_and_or (Conj a) b = conj_or a b"
 | "dist_and_or (Or_dnf a b) c =
    dnf_or (conj_or a c) (dist_and_or b c)"

lemma dist_and_or_and_eval [simp]:
"bool_dnf_eval env (dist_and_or a b) =
 ((bool_dnf_eval env a) \<and> (bool_dnf_eval env b))"
by (induct_tac a, auto)

fun basic_dnf where
   "basic_dnf TRUE_nipn = Conj(Atom TRUE_at)"
 | "basic_dnf FALSE_nipn = Conj(Atom FALSE_at)"
 | "basic_dnf (Var_nipn x) = Conj(Atom (Var_at x))"
 | "basic_dnf (Not_Var_nipn x) =
    Conj(Atom (Not_Var_at x))"
 | "basic_dnf (And_nipn a b) =
    dist_and_or (basic_dnf a) (basic_dnf b)"
 | "basic_dnf (Or_nipn a b) =
    dnf_or (basic_dnf a) (basic_dnf b)"

lemma basic_dnv_eval [simp]:
"bool_dnf_eval env (basic_dnf a) =
 boolexp_nipn_eval env a"
by (induct_tac a, auto)

definition dnf where
"dnf a = basic_dnf (push_not_elim_imp a)"

lemma dnf_eval [simp]:
"boolexp_eval env a = bool_dnf_eval env (dnf a)"
by (auto simp only: dnf_def push_not_elim_imp_same_eval basic_dnv_eval)

fun sat_bool_atom where
   "sat_bool_atom TRUE_at = Some (None)"
 | "sat_bool_atom FALSE_at = None"
 | "sat_bool_atom (Var_at x) = Some(Some(x,True))"
 | "sat_bool_atom (Not_Var_at x) = Some(Some(x,False))"

lemma sat_bool_atom_no_sat [simp]:
"sat_bool_atom a = None \<Longrightarrow> \<not>(bool_atom_eval env a)"
by (case_tac "a", simp_all)

lemma sat_bool_atom_sound [simp]:
"\<lbrakk> sat_bool_atom a = Some l;
   (l = None) \<or> l = Some (y, env y) \<rbrakk> \<Longrightarrow>
 bool_atom_eval env a"
by (induct a, auto)

lemma sat_bool_atom_complete [simp]:
"bool_atom_eval env a \<Longrightarrow>
\<exists> l y. ((sat_bool_atom a = Some l) \<and>
     ((l = None) \<or> l = Some(y, env y)))"
apply (case_tac "sat_bool_atom a", auto)
by (induct a, auto)

fun member where
   "member x [] = False"
 | "member x (y#ys) = ((x = y) \<or> (member x ys))"

fun sat_conj where
   "sat_conj (Atom a) =
    (case sat_bool_atom a of None \<Rightarrow> None
        | Some None \<Rightarrow> Some []
        | Some (Some (y,t)) \<Rightarrow> Some[(y,t)])"
 | "sat_conj (And_conj a b) =
    (case sat_bool_atom a of None \<Rightarrow> None
        | Some None \<Rightarrow> sat_conj b
        | Some (Some (y,t)) \<Rightarrow>
         (case sat_conj b of None \<Rightarrow> None
             | Some l \<Rightarrow>
               (if member (y,\<not>t) l then None
                else if member (y,t) l then Some l
                else Some ((y,t)#l))))"

fun sat_to_env where
   "sat_to_env [] = {env. True}"
 | "sat_to_env ((y,b)#l) = {env. env y = b} \<inter> (sat_to_env l)"

(*
lemma sat_conj_sound:
"\<lbrakk> sat_conj a = Some l; env \<in> sat_to_env l \<rbrakk> \<Longrightarrow> bool_conj_eval env a"
apply (induct "a", simp_all)
apply (case_tac "bool_atom", simp_all)
apply auto
*)

fun sat_dnf where
    "sat_dnf (Conj a) =
     (case sat_conj a of None \<Rightarrow> []
         | Some l \<Rightarrow> [l])"
 | "sat_dnf (Or_dnf a b) =
    (case sat_conj a of None \<Rightarrow> sat_dnf b
        | Some l => l# (sat_dnf b))"

definition sat where
"sat a \<equiv> sat_dnf (dnf a)"

export_code sat
in OCaml
 module_name Sat file "sat.ml"

end


section \<open>Propositional Formulas and CNFs\<close>

text \<open>We provide a straight-forward definition of propositional formulas, defined as arbitray formulas
  using variables, negations, conjunctions and disjunctions. CNFs are represented as lists of lists of
  literals and then converted into formulas.\<close>

theory Propositional_Formula
  imports Main
begin

subsection \<open>Propositional Formulas\<close>

datatype 'a formula =
  Prop 'a |
  Conj "'a formula list" |
  Disj "'a formula list" |
  Neg "'a formula" |
  Impl "'a formula" "'a formula" |
  Equiv "'a formula" "'a formula"

fun eval :: "('a \<Rightarrow> bool) \<Rightarrow> 'a formula \<Rightarrow> bool" where
  "eval v (Prop x) = v x"
| "eval v (Neg f) = (\<not> eval v f)"
| "eval v (Conj fs) = (\<forall> f \<in> set fs. eval v f)"
| "eval v (Disj fs) = (\<exists> f \<in> set fs. eval v f)"
| "eval v (Impl f g) = (eval v f \<longrightarrow> eval v g)"
| "eval v (Equiv f g) = (eval v f \<longleftrightarrow> eval v g)"

text \<open>Definition of propositional formula size: number of connectives\<close>

fun size_pf :: "'a formula \<Rightarrow> nat" where
  "size_pf (Prop x) = 1"
| "size_pf (Neg f) = 1 + size_pf f"
| "size_pf (Conj fs) = 1 + sum_list (map size_pf fs)"
| "size_pf (Disj fs) = 1 + sum_list (map size_pf fs)"
| "size_pf (Impl f g) = 1 + size_pf f + size_pf g"
| "size_pf (Equiv f g) = 1 + size_pf f + size_pf g"

subsection \<open>Conjunctive Normal Forms\<close>

type_synonym 'a clause = "('a \<times> bool) list"
type_synonym 'a cnf = "'a clause list"

fun formula_of_lit :: "'a \<times> bool \<Rightarrow> 'a formula" where
  "formula_of_lit (x,True) = Prop x"
| "formula_of_lit (x,False) = Neg (Prop x)"

definition formula_of_cnf :: "'a cnf \<Rightarrow> 'a formula" where
  "formula_of_cnf = (Conj o map (Disj o map formula_of_lit))"

definition eval_cnf :: "('a \<Rightarrow> bool) \<Rightarrow> 'a cnf \<Rightarrow> bool" where
  "eval_cnf \<alpha> cnf = eval \<alpha> (formula_of_cnf cnf)"

lemma eval_cnf_alt_def: "eval_cnf \<alpha> cnf = Ball (set cnf) (\<lambda> c. Bex (set c) (\<lambda> l. \<alpha> (fst l) = snd l))"
  unfolding eval_cnf_def formula_of_cnf_def o_def eval.simps set_map Ball_image_comp bex_simps
  apply (intro ball_cong bex_cong refl)
  subgoal for c l by (cases l; cases "snd l", auto)
  done

text \<open>The size of a CNF is the number of literals + the number of clauses, i.e.,
  the sum of the lengths of all clauses + the length.\<close>

definition size_cnf :: "'a cnf \<Rightarrow> nat" where
  "size_cnf cnf = sum_list (map length cnf) + length cnf"

end


(*  Title:      HOL/Examples/Knaster_Tarski.thy
    Author:     Makarius

Typical textbook proof example.
*)

section \<open>Textbook-style reasoning: the Knaster-Tarski Theorem\<close>

theory Knaster_Tarski
  imports Main "HOL-Library.Lattice_Syntax"
begin

subsection \<open>Prose version\<close>

text \<open>
  According to the textbook @{cite \<open>pages 93--94\<close> "davey-priestley"}, the
  Knaster-Tarski fixpoint theorem is as follows.\<^footnote>\<open>We have dualized the
  argument, and tuned the notation a little bit.\<close>

  \<^bold>\<open>The Knaster-Tarski Fixpoint Theorem.\<close> Let \<open>L\<close> be a complete lattice and
  \<open>f: L \<rightarrow> L\<close> an order-preserving map. Then \<open>\<Sqinter>{x \<in> L | f(x) \<le> x}\<close> is a fixpoint
  of \<open>f\<close>.

  \<^bold>\<open>Proof.\<close> Let \<open>H = {x \<in> L | f(x) \<le> x}\<close> and \<open>a = \<Sqinter>H\<close>. For all \<open>x \<in> H\<close> we have
  \<open>a \<le> x\<close>, so \<open>f(a) \<le> f(x) \<le> x\<close>. Thus \<open>f(a)\<close> is a lower bound of \<open>H\<close>, whence
  \<open>f(a) \<le> a\<close>. We now use this inequality to prove the reverse one (!) and
  thereby complete the proof that \<open>a\<close> is a fixpoint. Since \<open>f\<close> is
  order-preserving, \<open>f(f(a)) \<le> f(a)\<close>. This says \<open>f(a) \<in> H\<close>, so \<open>a \<le> f(a)\<close>.\<close>

subsection \<open>Formal versions\<close>

text \<open>
  The Isar proof below closely follows the original presentation. Virtually
  all of the prose narration has been rephrased in terms of formal Isar
  language elements. Just as many textbook-style proofs, there is a strong
  bias towards forward proof, and several bends in the course of reasoning.
\<close>

theorem Knaster_Tarski:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "\<exists>a. f a = a"
proof
  let ?H = "{u. f u \<le> u}"
  let ?a = "\<Sqinter>?H"
  show "f ?a = ?a"
  proof -
    {
      fix x
      assume "x \<in> ?H"
      then have "?a \<le> x" by (rule Inf_lower)
      with \<open>mono f\<close> have "f ?a \<le> f x" ..
      also from \<open>x \<in> ?H\<close> have "\<dots> \<le> x" ..
      finally have "f ?a \<le> x" .
    }
    then have "f ?a \<le> ?a" by (rule Inf_greatest)
    {
      also presume "\<dots> \<le> f ?a"
      finally (order_antisym) show ?thesis .
    }
    from \<open>mono f\<close> and \<open>f ?a \<le> ?a\<close> have "f (f ?a) \<le> f ?a" ..
    then have "f ?a \<in> ?H" ..
    then show "?a \<le> f ?a" by (rule Inf_lower)
  qed
qed

text \<open>
  Above we have used several advanced Isar language elements, such as explicit
  block structure and weak assumptions. Thus we have mimicked the particular
  way of reasoning of the original text.

  In the subsequent version the order of reasoning is changed to achieve
  structured top-down decomposition of the problem at the outer level, while
  only the inner steps of reasoning are done in a forward manner. We are
  certainly more at ease here, requiring only the most basic features of the
  Isar language.
\<close>

theorem Knaster_Tarski':
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "\<exists>a. f a = a"
proof
  let ?H = "{u. f u \<le> u}"
  let ?a = "\<Sqinter>?H"
  show "f ?a = ?a"
  proof (rule order_antisym)
    show "f ?a \<le> ?a"
    proof (rule Inf_greatest)
      fix x
      assume "x \<in> ?H"
      then have "?a \<le> x" by (rule Inf_lower)
      with \<open>mono f\<close> have "f ?a \<le> f x" ..
      also from \<open>x \<in> ?H\<close> have "\<dots> \<le> x" ..
      finally show "f ?a \<le> x" .
    qed
    show "?a \<le> f ?a"
    proof (rule Inf_lower)
      from \<open>mono f\<close> and \<open>f ?a \<le> ?a\<close> have "f (f ?a) \<le> f ?a" ..
      then show "f ?a \<in> ?H" ..
    qed
  qed
qed

end