(*
  Author: Jeremy Dawson, NICTA

  Theorems to do with integers, expressed using Pls, Min, BIT,
  theorems linking them to lists of booleans, and repeated splitting
  and concatenation.
*)

section "Bool lists and integers"

theory Bool_List_Representation
imports Main Bits_Int
begin

definition map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list"
where
  "map2 f as bs = map (split f) (zip as bs)"

lemma map2_Nil [simp, code]:
  "map2 f [] ys = []"
  unfolding map2_def by auto

lemma map2_Nil2 [simp, code]:
  "map2 f xs [] = []"
  unfolding map2_def by auto

lemma map2_Cons [simp, code]:
  "map2 f (x # xs) (y # ys) = f x y # map2 f xs ys"
  unfolding map2_def by auto

subsection {* Operations on lists of booleans *}

primrec bl_to_bin_aux :: "bool list \<Rightarrow> int \<Rightarrow> int"
where
  Nil: "bl_to_bin_aux [] w = w"
  | Cons: "bl_to_bin_aux (b # bs) w =
      bl_to_bin_aux bs (w BIT b)"

definition bl_to_bin :: "bool list \<Rightarrow> int"
where
  bl_to_bin_def: "bl_to_bin bs = bl_to_bin_aux bs 0"

primrec bin_to_bl_aux :: "nat \<Rightarrow> int \<Rightarrow> bool list \<Rightarrow> bool list"
where
  Z: "bin_to_bl_aux 0 w bl = bl"
  | Suc: "bin_to_bl_aux (Suc n) w bl =
      bin_to_bl_aux n (bin_rest w) ((bin_last w) # bl)"

definition bin_to_bl :: "nat \<Rightarrow> int \<Rightarrow> bool list"
where
  bin_to_bl_def : "bin_to_bl n w = bin_to_bl_aux n w []"

primrec bl_of_nth :: "nat \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool list"
where
  Suc: "bl_of_nth (Suc n) f = f n # bl_of_nth n f"
  | Z: "bl_of_nth 0 f = []"

primrec takefill :: "'a \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  Z: "takefill fill 0 xs = []"
  | Suc: "takefill fill (Suc n) xs = (
      case xs of [] => fill # takefill fill n xs
        | y # ys => y # takefill fill n ys)"

subsection "Arithmetic in terms of bool lists"

text {*
  Arithmetic operations in terms of the reversed bool list,
  assuming input list(s) the same length, and don't extend them.
*}

primrec rbl_succ :: "bool list => bool list"
where
  Nil: "rbl_succ Nil = Nil"
  | Cons: "rbl_succ (x # xs) = (if x then False # rbl_succ xs else True # xs)"

primrec rbl_pred :: "bool list => bool list"
where
  Nil: "rbl_pred Nil = Nil"
  | Cons: "rbl_pred (x # xs) = (if x then False # xs else True # rbl_pred xs)"

primrec rbl_add :: "bool list => bool list => bool list"
where
  -- "result is length of first arg, second arg may be longer"
  Nil: "rbl_add Nil x = Nil"
  | Cons: "rbl_add (y # ys) x = (let ws = rbl_add ys (tl x) in
    (y ~= hd x) # (if hd x & y then rbl_succ ws else ws))"

primrec rbl_mult :: "bool list => bool list => bool list"
where
  -- "result is length of first arg, second arg may be longer"
  Nil: "rbl_mult Nil x = Nil"
  | Cons: "rbl_mult (y # ys) x = (let ws = False # rbl_mult ys x in
    if y then rbl_add ws x else ws)"

lemma butlast_power:
  "(butlast ^^ n) bl = take (length bl - n) bl"
  by (induct n) (auto simp: butlast_take)

lemma bin_to_bl_aux_zero_minus_simp [simp]:
  "0 < n \<Longrightarrow> bin_to_bl_aux n 0 bl =
    bin_to_bl_aux (n - 1) 0 (False # bl)"
  by (cases n) auto

lemma bin_to_bl_aux_minus1_minus_simp [simp]:
  "0 < n ==> bin_to_bl_aux n (- 1) bl =
    bin_to_bl_aux (n - 1) (- 1) (True # bl)"
  by (cases n) auto

lemma bin_to_bl_aux_one_minus_simp [simp]:
  "0 < n \<Longrightarrow> bin_to_bl_aux n 1 bl =
    bin_to_bl_aux (n - 1) 0 (True # bl)"
  by (cases n) auto

lemma bin_to_bl_aux_Bit_minus_simp [simp]:
  "0 < n ==> bin_to_bl_aux n (w BIT b) bl =
    bin_to_bl_aux (n - 1) w (b # bl)"
  by (cases n) auto

lemma bin_to_bl_aux_Bit0_minus_simp [simp]:
  "0 < n ==> bin_to_bl_aux n (numeral (Num.Bit0 w)) bl =
    bin_to_bl_aux (n - 1) (numeral w) (False # bl)"
  by (cases n) auto

lemma bin_to_bl_aux_Bit1_minus_simp [simp]:
  "0 < n ==> bin_to_bl_aux n (numeral (Num.Bit1 w)) bl =
    bin_to_bl_aux (n - 1) (numeral w) (True # bl)"
  by (cases n) auto

text {* Link between bin and bool list. *}

lemma bl_to_bin_aux_append:
  "bl_to_bin_aux (bs @ cs) w = bl_to_bin_aux cs (bl_to_bin_aux bs w)"
  by (induct bs arbitrary: w) auto

lemma bin_to_bl_aux_append:
  "bin_to_bl_aux n w bs @ cs = bin_to_bl_aux n w (bs @ cs)"
  by (induct n arbitrary: w bs) auto

lemma bl_to_bin_append:
  "bl_to_bin (bs @ cs) = bl_to_bin_aux cs (bl_to_bin bs)"
  unfolding bl_to_bin_def by (rule bl_to_bin_aux_append)

lemma bin_to_bl_aux_alt:
  "bin_to_bl_aux n w bs = bin_to_bl n w @ bs"
  unfolding bin_to_bl_def by (simp add : bin_to_bl_aux_append)

lemma bin_to_bl_0 [simp]: "bin_to_bl 0 bs = []"
  unfolding bin_to_bl_def by auto

lemma size_bin_to_bl_aux:
  "size (bin_to_bl_aux n w bs) = n + length bs"
  by (induct n arbitrary: w bs) auto

lemma size_bin_to_bl [simp]: "size (bin_to_bl n w) = n"
  unfolding bin_to_bl_def by (simp add : size_bin_to_bl_aux)

lemma bin_bl_bin':
  "bl_to_bin (bin_to_bl_aux n w bs) =
    bl_to_bin_aux bs (bintrunc n w)"
  by (induct n arbitrary: w bs) (auto simp add : bl_to_bin_def)

lemma bin_bl_bin [simp]: "bl_to_bin (bin_to_bl n w) = bintrunc n w"
  unfolding bin_to_bl_def bin_bl_bin' by auto

lemma bl_bin_bl':
  "bin_to_bl (n + length bs) (bl_to_bin_aux bs w) =
    bin_to_bl_aux n w bs"
  apply (induct bs arbitrary: w n)
   apply auto
    apply (simp_all only : add_Suc [symmetric])
    apply (auto simp add : bin_to_bl_def)
  done

lemma bl_bin_bl [simp]: "bin_to_bl (length bs) (bl_to_bin bs) = bs"
  unfolding bl_to_bin_def
  apply (rule box_equals)
    apply (rule bl_bin_bl')
   prefer 2
   apply (rule bin_to_bl_aux.Z)
  apply simp
  done

lemma bl_to_bin_inj:
  "bl_to_bin bs = bl_to_bin cs ==> length bs = length cs ==> bs = cs"
  apply (rule_tac box_equals)
    defer
    apply (rule bl_bin_bl)
   apply (rule bl_bin_bl)
  apply simp
  done

lemma bl_to_bin_False [simp]: "bl_to_bin (False # bl) = bl_to_bin bl"
  unfolding bl_to_bin_def by auto

lemma bl_to_bin_Nil [simp]: "bl_to_bin [] = 0"
  unfolding bl_to_bin_def by auto

lemma bin_to_bl_zero_aux:
  "bin_to_bl_aux n 0 bl = replicate n False @ bl"
  by (induct n arbitrary: bl) (auto simp: replicate_app_Cons_same)

lemma bin_to_bl_zero: "bin_to_bl n 0 = replicate n False"
  unfolding bin_to_bl_def by (simp add: bin_to_bl_zero_aux)

lemma bin_to_bl_minus1_aux:
  "bin_to_bl_aux n (- 1) bl = replicate n True @ bl"
  by (induct n arbitrary: bl) (auto simp: replicate_app_Cons_same)

lemma bin_to_bl_minus1: "bin_to_bl n (- 1) = replicate n True"
  unfolding bin_to_bl_def by (simp add: bin_to_bl_minus1_aux)

lemma bl_to_bin_rep_F:
  "bl_to_bin (replicate n False @ bl) = bl_to_bin bl"
  apply (simp add: bin_to_bl_zero_aux [symmetric] bin_bl_bin')
  apply (simp add: bl_to_bin_def)
  done

lemma bin_to_bl_trunc [simp]:
  "n <= m ==> bin_to_bl n (bintrunc m w) = bin_to_bl n w"
  by (auto intro: bl_to_bin_inj)

lemma bin_to_bl_aux_bintr:
  "bin_to_bl_aux n (bintrunc m bin) bl =
    replicate (n - m) False @ bin_to_bl_aux (min n m) bin bl"
  apply (induct n arbitrary: m bin bl)
   apply clarsimp
  apply clarsimp
  apply (case_tac "m")
   apply (clarsimp simp: bin_to_bl_zero_aux)
   apply (erule thin_rl)
   apply (induct_tac n)
    apply auto
  done

lemma bin_to_bl_bintr:
  "bin_to_bl n (bintrunc m bin) =
    replicate (n - m) False @ bin_to_bl (min n m) bin"
  unfolding bin_to_bl_def by (rule bin_to_bl_aux_bintr)

lemma bl_to_bin_rep_False: "bl_to_bin (replicate n False) = 0"
  by (induct n) auto

lemma len_bin_to_bl_aux:
  "length (bin_to_bl_aux n w bs) = n + length bs"
  by (fact size_bin_to_bl_aux)

lemma len_bin_to_bl [simp]: "length (bin_to_bl n w) = n"
  by (fact size_bin_to_bl) (* FIXME: duplicate *)

lemma sign_bl_bin':
  "bin_sign (bl_to_bin_aux bs w) = bin_sign w"
  by (induct bs arbitrary: w) auto

lemma sign_bl_bin: "bin_sign (bl_to_bin bs) = 0"
  unfolding bl_to_bin_def by (simp add : sign_bl_bin')

lemma bl_sbin_sign_aux:
  "hd (bin_to_bl_aux (Suc n) w bs) =
    (bin_sign (sbintrunc n w) = -1)"
  apply (induct n arbitrary: w bs)
   apply clarsimp
   apply (cases w rule: bin_exhaust)
   apply simp
  done

lemma bl_sbin_sign:
  "hd (bin_to_bl (Suc n) w) = (bin_sign (sbintrunc n w) = -1)"
  unfolding bin_to_bl_def by (rule bl_sbin_sign_aux)

lemma bin_nth_of_bl_aux:
  "bin_nth (bl_to_bin_aux bl w) n =
    (n < size bl & rev bl ! n | n >= length bl & bin_nth w (n - size bl))"
  apply (induct bl arbitrary: w)
   apply clarsimp
  apply clarsimp
  apply (cut_tac x=n and y="size bl" in linorder_less_linear)
  apply (erule disjE, simp add: nth_append)+
  apply auto
  done

lemma bin_nth_of_bl: "bin_nth (bl_to_bin bl) n = (n < length bl & rev bl ! n)"
  unfolding bl_to_bin_def by (simp add : bin_nth_of_bl_aux)

lemma bin_nth_bl: "n < m \<Longrightarrow> bin_nth w n = nth (rev (bin_to_bl m w)) n"
  apply (induct n arbitrary: m w)
   apply clarsimp
   apply (case_tac m, clarsimp)
   apply (clarsimp simp: bin_to_bl_def)
   apply (simp add: bin_to_bl_aux_alt)
  apply clarsimp
  apply (case_tac m, clarsimp)
  apply (clarsimp simp: bin_to_bl_def)
  apply (simp add: bin_to_bl_aux_alt)
  done

lemma nth_rev:
  "n < length xs \<Longrightarrow> rev xs ! n = xs ! (length xs - 1 - n)"
  apply (induct xs)
   apply simp
  apply (clarsimp simp add : nth_append nth.simps split add : nat.split)
  apply (rule_tac f = "\<lambda>n. xs ! n" in arg_cong)
  apply arith
  done

lemma nth_rev_alt: "n < length ys \<Longrightarrow> ys ! n = rev ys ! (length ys - Suc n)"
  by (simp add: nth_rev)

lemma nth_bin_to_bl_aux:
  "n < m + length bl \<Longrightarrow> (bin_to_bl_aux m w bl) ! n =
    (if n < m then bin_nth w (m - 1 - n) else bl ! (n - m))"
  apply (induct m arbitrary: w n bl)
   apply clarsimp
  apply clarsimp
  apply (case_tac w rule: bin_exhaust)
  apply simp
  done

lemma nth_bin_to_bl: "n < m ==> (bin_to_bl m w) ! n = bin_nth w (m - Suc n)"
  unfolding bin_to_bl_def by (simp add : nth_bin_to_bl_aux)

lemma bl_to_bin_lt2p_aux:
  "bl_to_bin_aux bs w < (w + 1) * (2 ^ length bs)"
  apply (induct bs arbitrary: w)
   apply clarsimp
  apply clarsimp
  apply (drule meta_spec, erule xtrans(8) [rotated], simp add: Bit_def)+
  done

lemma bl_to_bin_lt2p: "bl_to_bin bs < (2 ^ length bs)"
  apply (unfold bl_to_bin_def)
  apply (rule xtrans(1))
   prefer 2
   apply (rule bl_to_bin_lt2p_aux)
  apply simp
  done

lemma bl_to_bin_ge2p_aux:
  "bl_to_bin_aux bs w >= w * (2 ^ length bs)"
  apply (induct bs arbitrary: w)
   apply clarsimp
  apply clarsimp
   apply (drule meta_spec, erule order_trans [rotated],
          simp add: Bit_B0_2t Bit_B1_2t algebra_simps)+
   apply (simp add: Bit_def)
  done

lemma bl_to_bin_ge0: "bl_to_bin bs >= 0"
  apply (unfold bl_to_bin_def)
  apply (rule xtrans(4))
   apply (rule bl_to_bin_ge2p_aux)
  apply simp
  done

lemma butlast_rest_bin:
  "butlast (bin_to_bl n w) = bin_to_bl (n - 1) (bin_rest w)"
  apply (unfold bin_to_bl_def)
  apply (cases w rule: bin_exhaust)
  apply (cases n, clarsimp)
  apply clarsimp
  apply (auto simp add: bin_to_bl_aux_alt)
  done

lemma butlast_bin_rest:
  "butlast bl = bin_to_bl (length bl - Suc 0) (bin_rest (bl_to_bin bl))"
  using butlast_rest_bin [where w="bl_to_bin bl" and n="length bl"] by simp

lemma butlast_rest_bl2bin_aux:
  "bl ~= [] \<Longrightarrow>
    bl_to_bin_aux (butlast bl) w = bin_rest (bl_to_bin_aux bl w)"
  by (induct bl arbitrary: w) auto

lemma butlast_rest_bl2bin:
  "bl_to_bin (butlast bl) = bin_rest (bl_to_bin bl)"
  apply (unfold bl_to_bin_def)
  apply (cases bl)
   apply (auto simp add: butlast_rest_bl2bin_aux)
  done

lemma trunc_bl2bin_aux:
  "bintrunc m (bl_to_bin_aux bl w) =
    bl_to_bin_aux (drop (length bl - m) bl) (bintrunc (m - length bl) w)"
proof (induct bl arbitrary: w)
  case Nil show ?case by simp
next
  case (Cons b bl) show ?case
  proof (cases "m - length bl")
    case 0 then have "Suc (length bl) - m = Suc (length bl - m)" by simp
    with Cons show ?thesis by simp
  next
    case (Suc n) then have *: "m - Suc (length bl) = n" by simp
    with Suc Cons show ?thesis by simp
  qed
qed

lemma trunc_bl2bin:
  "bintrunc m (bl_to_bin bl) = bl_to_bin (drop (length bl - m) bl)"
  unfolding bl_to_bin_def by (simp add : trunc_bl2bin_aux)

lemma trunc_bl2bin_len [simp]:
  "bintrunc (length bl) (bl_to_bin bl) = bl_to_bin bl"
  by (simp add: trunc_bl2bin)

lemma bl2bin_drop:
  "bl_to_bin (drop k bl) = bintrunc (length bl - k) (bl_to_bin bl)"
  apply (rule trans)
   prefer 2
   apply (rule trunc_bl2bin [symmetric])
  apply (cases "k <= length bl")
   apply auto
  done

lemma nth_rest_power_bin:
  "bin_nth ((bin_rest ^^ k) w) n = bin_nth w (n + k)"
  apply (induct k arbitrary: n, clarsimp)
  apply clarsimp
  apply (simp only: bin_nth.Suc [symmetric] add_Suc)
  done

lemma take_rest_power_bin:
  "m <= n ==> take m (bin_to_bl n w) = bin_to_bl m ((bin_rest ^^ (n - m)) w)"
  apply (rule nth_equalityI)
   apply simp
  apply (clarsimp simp add: nth_bin_to_bl nth_rest_power_bin)
  done

lemma hd_butlast: "size xs > 1 ==> hd (butlast xs) = hd xs"
  by (cases xs) auto

lemma last_bin_last':
  "size xs > 0 \<Longrightarrow> last xs \<longleftrightarrow> bin_last (bl_to_bin_aux xs w)"
  by (induct xs arbitrary: w) auto

lemma last_bin_last:
  "size xs > 0 ==> last xs \<longleftrightarrow> bin_last (bl_to_bin xs)"
  unfolding bl_to_bin_def by (erule last_bin_last')

lemma bin_last_last:
  "bin_last w \<longleftrightarrow> last (bin_to_bl (Suc n) w)"
  apply (unfold bin_to_bl_def)
  apply simp
  apply (auto simp add: bin_to_bl_aux_alt)
  done

(** links between bit-wise operations and operations on bool lists **)

lemma bl_xor_aux_bin:
  "map2 (%x y. x ~= y) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
    bin_to_bl_aux n (v XOR w) (map2 (%x y. x ~= y) bs cs)"
  apply (induct n arbitrary: v w bs cs)
   apply simp
  apply (case_tac v rule: bin_exhaust)
  apply (case_tac w rule: bin_exhaust)
  apply clarsimp
  apply (case_tac b)
  apply auto
  done

lemma bl_or_aux_bin:
  "map2 (op | ) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
    bin_to_bl_aux n (v OR w) (map2 (op | ) bs cs)"
  apply (induct n arbitrary: v w bs cs)
   apply simp
  apply (case_tac v rule: bin_exhaust)
  apply (case_tac w rule: bin_exhaust)
  apply clarsimp
  done

lemma bl_and_aux_bin:
  "map2 (op & ) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
    bin_to_bl_aux n (v AND w) (map2 (op & ) bs cs)"
  apply (induct n arbitrary: v w bs cs)
   apply simp
  apply (case_tac v rule: bin_exhaust)
  apply (case_tac w rule: bin_exhaust)
  apply clarsimp
  done

lemma bl_not_aux_bin:
  "map Not (bin_to_bl_aux n w cs) =
    bin_to_bl_aux n (NOT w) (map Not cs)"
  apply (induct n arbitrary: w cs)
   apply clarsimp
  apply clarsimp
  done

lemma bl_not_bin: "map Not (bin_to_bl n w) = bin_to_bl n (NOT w)"
  unfolding bin_to_bl_def by (simp add: bl_not_aux_bin)

lemma bl_and_bin:
  "map2 (op \<and>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v AND w)"
  unfolding bin_to_bl_def by (simp add: bl_and_aux_bin)

lemma bl_or_bin:
  "map2 (op \<or>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v OR w)"
  unfolding bin_to_bl_def by (simp add: bl_or_aux_bin)

lemma bl_xor_bin:
  "map2 (\<lambda>x y. x \<noteq> y) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v XOR w)"
  unfolding bin_to_bl_def by (simp only: bl_xor_aux_bin map2_Nil)

lemma drop_bin2bl_aux:
  "drop m (bin_to_bl_aux n bin bs) =
    bin_to_bl_aux (n - m) bin (drop (m - n) bs)"
  apply (induct n arbitrary: m bin bs, clarsimp)
  apply clarsimp
  apply (case_tac bin rule: bin_exhaust)
  apply (case_tac "m <= n", simp)
  apply (case_tac "m - n", simp)
  apply simp
  apply (rule_tac f = "%nat. drop nat bs" in arg_cong)
  apply simp
  done

lemma drop_bin2bl: "drop m (bin_to_bl n bin) = bin_to_bl (n - m) bin"
  unfolding bin_to_bl_def by (simp add : drop_bin2bl_aux)

lemma take_bin2bl_lem1:
  "take m (bin_to_bl_aux m w bs) = bin_to_bl m w"
  apply (induct m arbitrary: w bs, clarsimp)
  apply clarsimp
  apply (simp add: bin_to_bl_aux_alt)
  apply (simp add: bin_to_bl_def)
  apply (simp add: bin_to_bl_aux_alt)
  done

lemma take_bin2bl_lem:
  "take m (bin_to_bl_aux (m + n) w bs) =
    take m (bin_to_bl (m + n) w)"
  apply (induct n arbitrary: w bs)
   apply (simp_all (no_asm) add: bin_to_bl_def take_bin2bl_lem1)
  apply simp
  done

lemma bin_split_take:
  "bin_split n c = (a, b) \<Longrightarrow>
    bin_to_bl m a = take m (bin_to_bl (m + n) c)"
  apply (induct n arbitrary: b c)
   apply clarsimp
  apply (clarsimp simp: Let_def split: prod.split_asm)
  apply (simp add: bin_to_bl_def)
  apply (simp add: take_bin2bl_lem)
  done

lemma bin_split_take1:
  "k = m + n ==> bin_split n c = (a, b) ==>
    bin_to_bl m a = take m (bin_to_bl k c)"
  by (auto elim: bin_split_take)

lemma nth_takefill: "m < n \<Longrightarrow>
    takefill fill n l ! m = (if m < length l then l ! m else fill)"
  apply (induct n arbitrary: m l, clarsimp)
  apply clarsimp
  apply (case_tac m)
   apply (simp split: list.split)
  apply (simp split: list.split)
  done

lemma takefill_alt:
  "takefill fill n l = take n l @ replicate (n - length l) fill"
  by (induct n arbitrary: l) (auto split: list.split)

lemma takefill_replicate [simp]:
  "takefill fill n (replicate m fill) = replicate n fill"
  by (simp add : takefill_alt replicate_add [symmetric])

lemma takefill_le':
  "n = m + k \<Longrightarrow> takefill x m (takefill x n l) = takefill x m l"
  by (induct m arbitrary: l n) (auto split: list.split)

lemma length_takefill [simp]: "length (takefill fill n l) = n"
  by (simp add : takefill_alt)

lemma take_takefill':
  "!!w n.  n = k + m ==> take k (takefill fill n w) = takefill fill k w"
  by (induct k) (auto split add : list.split)

lemma drop_takefill:
  "!!w. drop k (takefill fill (m + k) w) = takefill fill m (drop k w)"
  by (induct k) (auto split add : list.split)

lemma takefill_le [simp]:
  "m \<le> n \<Longrightarrow> takefill x m (takefill x n l) = takefill x m l"
  by (auto simp: le_iff_add takefill_le')

lemma take_takefill [simp]:
  "m \<le> n \<Longrightarrow> take m (takefill fill n w) = takefill fill m w"
  by (auto simp: le_iff_add take_takefill')

lemma takefill_append:
  "takefill fill (m + length xs) (xs @ w) = xs @ (takefill fill m w)"
  by (induct xs) auto

lemma takefill_same':
  "l = length xs ==> takefill fill l xs = xs"
  by (induct xs arbitrary: l, auto)

lemmas takefill_same [simp] = takefill_same' [OF refl]

lemma takefill_bintrunc:
  "takefill False n bl = rev (bin_to_bl n (bl_to_bin (rev bl)))"
  apply (rule nth_equalityI)
   apply simp
  apply (clarsimp simp: nth_takefill nth_rev nth_bin_to_bl bin_nth_of_bl)
  done

lemma bl_bin_bl_rtf:
  "bin_to_bl n (bl_to_bin bl) = rev (takefill False n (rev bl))"
  by (simp add : takefill_bintrunc)

lemma bl_bin_bl_rep_drop:
  "bin_to_bl n (bl_to_bin bl) =
    replicate (n - length bl) False @ drop (length bl - n) bl"
  by (simp add: bl_bin_bl_rtf takefill_alt rev_take)

lemma tf_rev:
  "n + k = m + length bl ==> takefill x m (rev (takefill y n bl)) =
    rev (takefill y m (rev (takefill x k (rev bl))))"
  apply (rule nth_equalityI)
   apply (auto simp add: nth_takefill nth_rev)
  apply (rule_tac f = "%n. bl ! n" in arg_cong)
  apply arith
  done

lemma takefill_minus:
  "0 < n ==> takefill fill (Suc (n - 1)) w = takefill fill n w"
  by auto

lemmas takefill_Suc_cases =
  list.cases [THEN takefill.Suc [THEN trans]]

lemmas takefill_Suc_Nil = takefill_Suc_cases (1)
lemmas takefill_Suc_Cons = takefill_Suc_cases (2)

lemmas takefill_minus_simps = takefill_Suc_cases [THEN [2]
  takefill_minus [symmetric, THEN trans]]

lemma takefill_numeral_Nil [simp]:
  "takefill fill (numeral k) [] = fill # takefill fill (pred_numeral k) []"
  by (simp add: numeral_eq_Suc)

lemma takefill_numeral_Cons [simp]:
  "takefill fill (numeral k) (x # xs) = x # takefill fill (pred_numeral k) xs"
  by (simp add: numeral_eq_Suc)

(* links with function bl_to_bin *)

lemma bl_to_bin_aux_cat:
  "!!nv v. bl_to_bin_aux bs (bin_cat w nv v) =
    bin_cat w (nv + length bs) (bl_to_bin_aux bs v)"
  apply (induct bs)
   apply simp
  apply (simp add: bin_cat_Suc_Bit [symmetric] del: bin_cat.simps)
  done

lemma bin_to_bl_aux_cat:
  "!!w bs. bin_to_bl_aux (nv + nw) (bin_cat v nw w) bs =
    bin_to_bl_aux nv v (bin_to_bl_aux nw w bs)"
  by (induct nw) auto

lemma bl_to_bin_aux_alt:
  "bl_to_bin_aux bs w = bin_cat w (length bs) (bl_to_bin bs)"
  using bl_to_bin_aux_cat [where nv = "0" and v = "0"]
  unfolding bl_to_bin_def [symmetric] by simp

lemma bin_to_bl_cat:
  "bin_to_bl (nv + nw) (bin_cat v nw w) =
    bin_to_bl_aux nv v (bin_to_bl nw w)"
  unfolding bin_to_bl_def by (simp add: bin_to_bl_aux_cat)

lemmas bl_to_bin_aux_app_cat =
  trans [OF bl_to_bin_aux_append bl_to_bin_aux_alt]

lemmas bin_to_bl_aux_cat_app =
  trans [OF bin_to_bl_aux_cat bin_to_bl_aux_alt]

lemma bl_to_bin_app_cat:
  "bl_to_bin (bsa @ bs) = bin_cat (bl_to_bin bsa) (length bs) (bl_to_bin bs)"
  by (simp only: bl_to_bin_aux_app_cat bl_to_bin_def)

lemma bin_to_bl_cat_app:
  "bin_to_bl (n + nw) (bin_cat w nw wa) = bin_to_bl n w @ bin_to_bl nw wa"
  by (simp only: bin_to_bl_def bin_to_bl_aux_cat_app)

(* bl_to_bin_app_cat_alt and bl_to_bin_app_cat are easily interderivable *)
lemma bl_to_bin_app_cat_alt:
  "bin_cat (bl_to_bin cs) n w = bl_to_bin (cs @ bin_to_bl n w)"
  by (simp add : bl_to_bin_app_cat)

lemma mask_lem: "(bl_to_bin (True # replicate n False)) =
    (bl_to_bin (replicate n True)) + 1"
  apply (unfold bl_to_bin_def)
  apply (induct n)
   apply simp
  apply (simp only: Suc_eq_plus1 replicate_add
                    append_Cons [symmetric] bl_to_bin_aux_append)
  apply (simp add: Bit_B0_2t Bit_B1_2t)
  done

(* function bl_of_nth *)
lemma length_bl_of_nth [simp]: "length (bl_of_nth n f) = n"
  by (induct n)  auto

lemma nth_bl_of_nth [simp]:
  "m < n \<Longrightarrow> rev (bl_of_nth n f) ! m = f m"
  apply (induct n)
   apply simp
  apply (clarsimp simp add : nth_append)
  apply (rule_tac f = "f" in arg_cong)
  apply simp
  done

lemma bl_of_nth_inj:
  "(!!k. k < n ==> f k = g k) ==> bl_of_nth n f = bl_of_nth n g"
  by (induct n)  auto

lemma bl_of_nth_nth_le:
  "n \<le> length xs \<Longrightarrow> bl_of_nth n (nth (rev xs)) = drop (length xs - n) xs"
  apply (induct n arbitrary: xs, clarsimp)
  apply clarsimp
  apply (rule trans [OF _ hd_Cons_tl])
   apply (frule Suc_le_lessD)
   apply (simp add: nth_rev trans [OF drop_Suc drop_tl, symmetric])
   apply (subst hd_drop_conv_nth)
     apply force
    apply simp_all
  apply (rule_tac f = "%n. drop n xs" in arg_cong)
  apply simp
  done

lemma bl_of_nth_nth [simp]: "bl_of_nth (length xs) (op ! (rev xs)) = xs"
  by (simp add: bl_of_nth_nth_le)

lemma size_rbl_pred: "length (rbl_pred bl) = length bl"
  by (induct bl) auto

lemma size_rbl_succ: "length (rbl_succ bl) = length bl"
  by (induct bl) auto

lemma size_rbl_add:
  "!!cl. length (rbl_add bl cl) = length bl"
  by (induct bl) (auto simp: Let_def size_rbl_succ)

lemma size_rbl_mult:
  "!!cl. length (rbl_mult bl cl) = length bl"
  by (induct bl) (auto simp add : Let_def size_rbl_add)

lemmas rbl_sizes [simp] =
  size_rbl_pred size_rbl_succ size_rbl_add size_rbl_mult

lemmas rbl_Nils =
  rbl_pred.Nil rbl_succ.Nil rbl_add.Nil rbl_mult.Nil

lemma rbl_pred:
  "rbl_pred (rev (bin_to_bl n bin)) = rev (bin_to_bl n (bin - 1))"
  apply (induct n arbitrary: bin, simp)
  apply (unfold bin_to_bl_def)
  apply clarsimp
  apply (case_tac bin rule: bin_exhaust)
  apply (case_tac b)
   apply (clarsimp simp: bin_to_bl_aux_alt)+
  done

lemma rbl_succ:
  "rbl_succ (rev (bin_to_bl n bin)) = rev (bin_to_bl n (bin + 1))"
  apply (induct n arbitrary: bin, simp)
  apply (unfold bin_to_bl_def)
  apply clarsimp
  apply (case_tac bin rule: bin_exhaust)
  apply (case_tac b)
   apply (clarsimp simp: bin_to_bl_aux_alt)+
  done

lemma rbl_add:
  "!!bina binb. rbl_add (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb)) =
    rev (bin_to_bl n (bina + binb))"
  apply (induct n, simp)
  apply (unfold bin_to_bl_def)
  apply clarsimp
  apply (case_tac bina rule: bin_exhaust)
  apply (case_tac binb rule: bin_exhaust)
  apply (case_tac b)
   apply (case_tac [!] "ba")
     apply (auto simp: rbl_succ bin_to_bl_aux_alt Let_def ac_simps)
  done

lemma rbl_add_app2:
  "!!blb. length blb >= length bla ==>
    rbl_add bla (blb @ blc) = rbl_add bla blb"
  apply (induct bla, simp)
  apply clarsimp
  apply (case_tac blb, clarsimp)
  apply (clarsimp simp: Let_def)
  done

lemma rbl_add_take2:
  "!!blb. length blb >= length bla ==>
    rbl_add bla (take (length bla) blb) = rbl_add bla blb"
  apply (induct bla, simp)
  apply clarsimp
  apply (case_tac blb, clarsimp)
  apply (clarsimp simp: Let_def)
  done

lemma rbl_add_long:
  "m >= n ==> rbl_add (rev (bin_to_bl n bina)) (rev (bin_to_bl m binb)) =
    rev (bin_to_bl n (bina + binb))"
  apply (rule box_equals [OF _ rbl_add_take2 rbl_add])
   apply (rule_tac f = "rbl_add (rev (bin_to_bl n bina))" in arg_cong)
   apply (rule rev_swap [THEN iffD1])
   apply (simp add: rev_take drop_bin2bl)
  apply simp
  done

lemma rbl_mult_app2:
  "!!blb. length blb >= length bla ==>
    rbl_mult bla (blb @ blc) = rbl_mult bla blb"
  apply (induct bla, simp)
  apply clarsimp
  apply (case_tac blb, clarsimp)
  apply (clarsimp simp: Let_def rbl_add_app2)
  done

lemma rbl_mult_take2:
  "length blb >= length bla ==>
    rbl_mult bla (take (length bla) blb) = rbl_mult bla blb"
  apply (rule trans)
   apply (rule rbl_mult_app2 [symmetric])
   apply simp
  apply (rule_tac f = "rbl_mult bla" in arg_cong)
  apply (rule append_take_drop_id)
  done

lemma rbl_mult_gt1:
  "m >= length bl ==> rbl_mult bl (rev (bin_to_bl m binb)) =
    rbl_mult bl (rev (bin_to_bl (length bl) binb))"
  apply (rule trans)
   apply (rule rbl_mult_take2 [symmetric])
   apply simp_all
  apply (rule_tac f = "rbl_mult bl" in arg_cong)
  apply (rule rev_swap [THEN iffD1])
  apply (simp add: rev_take drop_bin2bl)
  done

lemma rbl_mult_gt:
  "m > n ==> rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl m binb)) =
    rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb))"
  by (auto intro: trans [OF rbl_mult_gt1])

lemmas rbl_mult_Suc = lessI [THEN rbl_mult_gt]

lemma rbbl_Cons:
  "b # rev (bin_to_bl n x) = rev (bin_to_bl (Suc n) (x BIT b))"
  apply (unfold bin_to_bl_def)
  apply simp
  apply (simp add: bin_to_bl_aux_alt)
  done

lemma rbl_mult: "!!bina binb.
    rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb)) =
    rev (bin_to_bl n (bina * binb))"
  apply (induct n)
   apply simp
  apply (unfold bin_to_bl_def)
  apply clarsimp
  apply (case_tac bina rule: bin_exhaust)
  apply (case_tac binb rule: bin_exhaust)
  apply (case_tac b)
   apply (case_tac [!] "ba")
     apply (auto simp: bin_to_bl_aux_alt Let_def)
     apply (auto simp: rbbl_Cons rbl_mult_Suc rbl_add)
  done

lemma rbl_add_split:
  "P (rbl_add (y # ys) (x # xs)) =
    (ALL ws. length ws = length ys --> ws = rbl_add ys xs -->
    (y --> ((x --> P (False # rbl_succ ws)) & (~ x -->  P (True # ws)))) &
    (~ y --> P (x # ws)))"
  apply (auto simp add: Let_def)
   apply (case_tac [!] "y")
     apply auto
  done

lemma rbl_mult_split:
  "P (rbl_mult (y # ys) xs) =
    (ALL ws. length ws = Suc (length ys) --> ws = False # rbl_mult ys xs -->
    (y --> P (rbl_add ws xs)) & (~ y -->  P ws))"
  by (clarsimp simp add : Let_def)

subsection "Repeated splitting or concatenation"

lemma sclem:
  "size (concat (map (bin_to_bl n) xs)) = length xs * n"
  by (induct xs) auto

lemma bin_cat_foldl_lem:
  "foldl (%u. bin_cat u n) x xs =
    bin_cat x (size xs * n) (foldl (%u. bin_cat u n) y xs)"
  apply (induct xs arbitrary: x)
   apply simp
  apply (simp (no_asm))
  apply (frule asm_rl)
  apply (drule meta_spec)
  apply (erule trans)
  apply (drule_tac x = "bin_cat y n a" in meta_spec)
  apply (simp add : bin_cat_assoc_sym min.absorb2)
  done

lemma bin_rcat_bl:
  "(bin_rcat n wl) = bl_to_bin (concat (map (bin_to_bl n) wl))"
  apply (unfold bin_rcat_def)
  apply (rule sym)
  apply (induct wl)
   apply (auto simp add : bl_to_bin_append)
  apply (simp add : bl_to_bin_aux_alt sclem)
  apply (simp add : bin_cat_foldl_lem [symmetric])
  done

lemmas bin_rsplit_aux_simps = bin_rsplit_aux.simps bin_rsplitl_aux.simps
lemmas rsplit_aux_simps = bin_rsplit_aux_simps

lemmas th_if_simp1 = split_if [where P = "op = l", THEN iffD1, THEN conjunct1, THEN mp] for l
lemmas th_if_simp2 = split_if [where P = "op = l", THEN iffD1, THEN conjunct2, THEN mp] for l

lemmas rsplit_aux_simp1s = rsplit_aux_simps [THEN th_if_simp1]

lemmas rsplit_aux_simp2ls = rsplit_aux_simps [THEN th_if_simp2]
(* these safe to [simp add] as require calculating m - n *)
lemmas bin_rsplit_aux_simp2s [simp] = rsplit_aux_simp2ls [unfolded Let_def]
lemmas rbscl = bin_rsplit_aux_simp2s (2)

lemmas rsplit_aux_0_simps [simp] =
  rsplit_aux_simp1s [OF disjI1] rsplit_aux_simp1s [OF disjI2]

lemma bin_rsplit_aux_append:
  "bin_rsplit_aux n m c (bs @ cs) = bin_rsplit_aux n m c bs @ cs"
  apply (induct n m c bs rule: bin_rsplit_aux.induct)
  apply (subst bin_rsplit_aux.simps)
  apply (subst bin_rsplit_aux.simps)
  apply (clarsimp split: prod.split)
  done

lemma bin_rsplitl_aux_append:
  "bin_rsplitl_aux n m c (bs @ cs) = bin_rsplitl_aux n m c bs @ cs"
  apply (induct n m c bs rule: bin_rsplitl_aux.induct)
  apply (subst bin_rsplitl_aux.simps)
  apply (subst bin_rsplitl_aux.simps)
  apply (clarsimp split: prod.split)
  done

lemmas rsplit_aux_apps [where bs = "[]"] =
  bin_rsplit_aux_append bin_rsplitl_aux_append

lemmas rsplit_def_auxs = bin_rsplit_def bin_rsplitl_def

lemmas rsplit_aux_alts = rsplit_aux_apps
  [unfolded append_Nil rsplit_def_auxs [symmetric]]

lemma bin_split_minus: "0 < n ==> bin_split (Suc (n - 1)) w = bin_split n w"
  by auto

lemmas bin_split_minus_simp =
  bin_split.Suc [THEN [2] bin_split_minus [symmetric, THEN trans]]

lemma bin_split_pred_simp [simp]:
  "(0::nat) < numeral bin \<Longrightarrow>
  bin_split (numeral bin) w =
  (let (w1, w2) = bin_split (numeral bin - 1) (bin_rest w)
   in (w1, w2 BIT bin_last w))"
  by (simp only: bin_split_minus_simp)

lemma bin_rsplit_aux_simp_alt:
  "bin_rsplit_aux n m c bs =
   (if m = 0 \<or> n = 0
   then bs
   else let (a, b) = bin_split n c in bin_rsplit n (m - n, a) @ b # bs)"
  unfolding bin_rsplit_aux.simps [of n m c bs]
  apply simp
  apply (subst rsplit_aux_alts)
  apply (simp add: bin_rsplit_def)
  done

lemmas bin_rsplit_simp_alt =
  trans [OF bin_rsplit_def bin_rsplit_aux_simp_alt]

lemmas bthrs = bin_rsplit_simp_alt [THEN [2] trans]

lemma bin_rsplit_size_sign' [rule_format] :
  "\<lbrakk>n > 0; rev sw = bin_rsplit n (nw, w)\<rbrakk> \<Longrightarrow>
    (ALL v: set sw. bintrunc n v = v)"
  apply (induct sw arbitrary: nw w v)
   apply clarsimp
  apply clarsimp
  apply (drule bthrs)
  apply (simp (no_asm_use) add: Let_def split: prod.split_asm split_if_asm)
  apply clarify
  apply (drule split_bintrunc)
  apply simp
  done

lemmas bin_rsplit_size_sign = bin_rsplit_size_sign' [OF asm_rl
  rev_rev_ident [THEN trans] set_rev [THEN equalityD2 [THEN subsetD]]]

lemma bin_nth_rsplit [rule_format] :
  "n > 0 ==> m < n ==> (ALL w k nw. rev sw = bin_rsplit n (nw, w) -->
       k < size sw --> bin_nth (sw ! k) m = bin_nth w (k * n + m))"
  apply (induct sw)
   apply clarsimp
  apply clarsimp
  apply (drule bthrs)
  apply (simp (no_asm_use) add: Let_def split: prod.split_asm split_if_asm)
  apply clarify
  apply (erule allE, erule impE, erule exI)
  apply (case_tac k)
   apply clarsimp
   prefer 2
   apply clarsimp
   apply (erule allE)
   apply (erule (1) impE)
   apply (drule bin_nth_split, erule conjE, erule allE,
          erule trans, simp add : ac_simps)+
  done

lemma bin_rsplit_all:
  "0 < nw ==> nw <= n ==> bin_rsplit n (nw, w) = [bintrunc n w]"
  unfolding bin_rsplit_def
  by (clarsimp dest!: split_bintrunc simp: rsplit_aux_simp2ls split: prod.split)

lemma bin_rsplit_l [rule_format] :
  "ALL bin. bin_rsplitl n (m, bin) = bin_rsplit n (m, bintrunc m bin)"
  apply (rule_tac a = "m" in wf_less_than [THEN wf_induct])
  apply (simp (no_asm) add : bin_rsplitl_def bin_rsplit_def)
  apply (rule allI)
  apply (subst bin_rsplitl_aux.simps)
  apply (subst bin_rsplit_aux.simps)
  apply (clarsimp simp: Let_def split: prod.split)
  apply (drule bin_split_trunc)
  apply (drule sym [THEN trans], assumption)
  apply (subst rsplit_aux_alts(1))
  apply (subst rsplit_aux_alts(2))
  apply clarsimp
  unfolding bin_rsplit_def bin_rsplitl_def
  apply simp
  done

lemma bin_rsplit_rcat [rule_format] :
  "n > 0 --> bin_rsplit n (n * size ws, bin_rcat n ws) = map (bintrunc n) ws"
  apply (unfold bin_rsplit_def bin_rcat_def)
  apply (rule_tac xs = "ws" in rev_induct)
   apply clarsimp
  apply clarsimp
  apply (subst rsplit_aux_alts)
  unfolding bin_split_cat
  apply simp
  done

lemma bin_rsplit_aux_len_le [rule_format] :
  "\<forall>ws m. n \<noteq> 0 \<longrightarrow> ws = bin_rsplit_aux n nw w bs \<longrightarrow>
    length ws \<le> m \<longleftrightarrow> nw + length bs * n \<le> m * n"
proof -
  { fix i j j' k k' m :: nat and R
    assume d: "(i::nat) \<le> j \<or> m < j'"
    assume R1: "i * k \<le> j * k \<Longrightarrow> R"
    assume R2: "Suc m * k' \<le> j' * k' \<Longrightarrow> R"
    have "R" using d
      apply safe
       apply (rule R1, erule mult_le_mono1)
      apply (rule R2, erule Suc_le_eq [THEN iffD2 [THEN mult_le_mono1]])
      done
  } note A = this
  { fix sc m n lb :: nat
    have "(0::nat) < sc \<Longrightarrow> sc - n + (n + lb * n) \<le> m * n \<longleftrightarrow> sc + lb * n \<le> m * n"
      apply safe
       apply arith
      apply (case_tac "sc >= n")
       apply arith
      apply (insert linorder_le_less_linear [of m lb])
      apply (erule_tac k2=n and k'2=n in A)
       apply arith
      apply simp
      done
  } note B = this
  show ?thesis
    apply (induct n nw w bs rule: bin_rsplit_aux.induct)
    apply (subst bin_rsplit_aux.simps)
    apply (simp add: B Let_def split: prod.split)
    done
qed

lemma bin_rsplit_len_le:
  "n \<noteq> 0 --> ws = bin_rsplit n (nw, w) --> (length ws <= m) = (nw <= m * n)"
  unfolding bin_rsplit_def by (clarsimp simp add : bin_rsplit_aux_len_le)

lemma bin_rsplit_aux_len:
  "n \<noteq> 0 \<Longrightarrow> length (bin_rsplit_aux n nw w cs) =
    (nw + n - 1) div n + length cs"
  apply (induct n nw w cs rule: bin_rsplit_aux.induct)
  apply (subst bin_rsplit_aux.simps)
  apply (clarsimp simp: Let_def split: prod.split)
  apply (erule thin_rl)
  apply (case_tac m)
  apply simp
  apply (case_tac "m <= n")
  apply auto
  done

lemma bin_rsplit_len:
  "n\<noteq>0 ==> length (bin_rsplit n (nw, w)) = (nw + n - 1) div n"
  unfolding bin_rsplit_def by (clarsimp simp add : bin_rsplit_aux_len)

lemma bin_rsplit_aux_len_indep:
  "n \<noteq> 0 \<Longrightarrow> length bs = length cs \<Longrightarrow>
    length (bin_rsplit_aux n nw v bs) =
    length (bin_rsplit_aux n nw w cs)"
proof (induct n nw w cs arbitrary: v bs rule: bin_rsplit_aux.induct)
  case (1 n m w cs v bs) show ?case
  proof (cases "m = 0")
    case True then show ?thesis using `length bs = length cs` by simp
  next
    case False
    from "1.hyps" `m \<noteq> 0` `n \<noteq> 0` have hyp: "\<And>v bs. length bs = Suc (length cs) \<Longrightarrow>
      length (bin_rsplit_aux n (m - n) v bs) =
      length (bin_rsplit_aux n (m - n) (fst (bin_split n w)) (snd (bin_split n w) # cs))"
    by auto
    show ?thesis using `length bs = length cs` `n \<noteq> 0`
      by (auto simp add: bin_rsplit_aux_simp_alt Let_def bin_rsplit_len
        split: prod.split)
  qed
qed

lemma bin_rsplit_len_indep:
  "n\<noteq>0 ==> length (bin_rsplit n (nw, v)) = length (bin_rsplit n (nw, w))"
  apply (unfold bin_rsplit_def)
  apply (simp (no_asm))
  apply (erule bin_rsplit_aux_len_indep)
  apply (rule refl)
  done

text {* Even more bit operations *}

instantiation int :: bitss
begin

definition [iff]:
  "i !! n \<longleftrightarrow> bin_nth i n"

definition
  "lsb i = (i :: int) !! 0"

definition
  "set_bit i n b = bin_sc n b i"

definition
  "set_bits f =
  (if \<exists>n. \<forall>n'\<ge>n. \<not> f n' then
     let n = LEAST n. \<forall>n'\<ge>n. \<not> f n'
     in bl_to_bin (rev (map f [0..<n]))
   else if \<exists>n. \<forall>n'\<ge>n. f n' then
     let n = LEAST n. \<forall>n'\<ge>n. f n'
     in sbintrunc n (bl_to_bin (True # rev (map f [0..<n])))
   else 0 :: int)"

definition
  "shiftl x n = (x :: int) * 2 ^ n"

definition
  "shiftr x n = (x :: int) div 2 ^ n"

definition
  "msb x \<longleftrightarrow> (x :: int) < 0"

instance ..

end

end


(*  Title:      HOL/Order_Relation.thy
    Author:     Tobias Nipkow
    Author:     Andrei Popescu, TU Muenchen
*)

section {* Orders as Relations *}

theory Order_Relation
imports Wfrec
begin

subsection{* Orders on a set *}

definition "preorder_on A r \<equiv> refl_on A r \<and> trans r"

definition "partial_order_on A r \<equiv> preorder_on A r \<and> antisym r"

definition "linear_order_on A r \<equiv> partial_order_on A r \<and> total_on A r"

definition "strict_linear_order_on A r \<equiv> trans r \<and> irrefl r \<and> total_on A r"

definition "well_order_on A r \<equiv> linear_order_on A r \<and> wf(r - Id)"

lemmas order_on_defs =
  preorder_on_def partial_order_on_def linear_order_on_def
  strict_linear_order_on_def well_order_on_def

lemma preorder_on_empty[simp]: "preorder_on {} {}"
by(simp add:preorder_on_def trans_def)

lemma partial_order_on_empty[simp]: "partial_order_on {} {}"
by(simp add:partial_order_on_def)

lemma lnear_order_on_empty[simp]: "linear_order_on {} {}"
by(simp add:linear_order_on_def)

lemma well_order_on_empty[simp]: "well_order_on {} {}"
by(simp add:well_order_on_def)

lemma preorder_on_converse[simp]: "preorder_on A (r^-1) = preorder_on A r"
by (simp add:preorder_on_def)

lemma partial_order_on_converse[simp]:
  "partial_order_on A (r^-1) = partial_order_on A r"
by (simp add: partial_order_on_def)

lemma linear_order_on_converse[simp]:
  "linear_order_on A (r^-1) = linear_order_on A r"
by (simp add: linear_order_on_def)

lemma strict_linear_order_on_diff_Id:
  "linear_order_on A r \<Longrightarrow> strict_linear_order_on A (r-Id)"
by(simp add: order_on_defs trans_diff_Id)

subsection{* Orders on the field *}

abbreviation "Refl r \<equiv> refl_on (Field r) r"

abbreviation "Preorder r \<equiv> preorder_on (Field r) r"

abbreviation "Partial_order r \<equiv> partial_order_on (Field r) r"

abbreviation "Total r \<equiv> total_on (Field r) r"

abbreviation "Linear_order r \<equiv> linear_order_on (Field r) r"

abbreviation "Well_order r \<equiv> well_order_on (Field r) r"

lemma subset_Image_Image_iff:
  "\<lbrakk> Preorder r; A \<subseteq> Field r; B \<subseteq> Field r\<rbrakk> \<Longrightarrow>
   r `` A \<subseteq> r `` B \<longleftrightarrow> (\<forall>a\<in>A.\<exists>b\<in>B. (b,a):r)"
unfolding preorder_on_def refl_on_def Image_def
apply (simp add: subset_eq)
unfolding trans_def by fast

lemma subset_Image1_Image1_iff:
  "\<lbrakk> Preorder r; a : Field r; b : Field r\<rbrakk> \<Longrightarrow> r `` {a} \<subseteq> r `` {b} \<longleftrightarrow> (b,a):r"
by(simp add:subset_Image_Image_iff)

lemma Refl_antisym_eq_Image1_Image1_iff:
  assumes r: "Refl r" and as: "antisym r" and abf: "a \<in> Field r" "b \<in> Field r"
  shows "r `` {a} = r `` {b} \<longleftrightarrow> a = b"
proof
  assume "r `` {a} = r `` {b}"
  hence e: "\<And>x. (a, x) \<in> r \<longleftrightarrow> (b, x) \<in> r" by (simp add: set_eq_iff)
  have "(a, a) \<in> r" "(b, b) \<in> r" using r abf by (simp_all add: refl_on_def)
  hence "(a, b) \<in> r" "(b, a) \<in> r" using e[of a] e[of b] by simp_all
  thus "a = b" using as[unfolded antisym_def] by blast
qed fast

lemma Partial_order_eq_Image1_Image1_iff:
  "\<lbrakk>Partial_order r; a:Field r; b:Field r\<rbrakk> \<Longrightarrow> r `` {a} = r `` {b} \<longleftrightarrow> a=b"
by(auto simp:order_on_defs Refl_antisym_eq_Image1_Image1_iff)

lemma Total_Id_Field:
assumes TOT: "Total r" and NID: "\<not> (r <= Id)"
shows "Field r = Field(r - Id)"
using mono_Field[of "r - Id" r] Diff_subset[of r Id]
proof(auto)
  have "r \<noteq> {}" using NID by fast
  then obtain b and c where "b \<noteq> c \<and> (b,c) \<in> r" using NID by auto
  hence 1: "b \<noteq> c \<and> {b,c} \<le> Field r" by (auto simp: Field_def)

  fix a assume *: "a \<in> Field r"
  obtain d where 2: "d \<in> Field r" and 3: "d \<noteq> a"
  using * 1 by auto
  hence "(a,d) \<in> r \<or> (d,a) \<in> r" using * TOT
  by (simp add: total_on_def)
  thus "a \<in> Field(r - Id)" using 3 unfolding Field_def by blast
qed

subsection{* Orders on a type *}

abbreviation "strict_linear_order \<equiv> strict_linear_order_on UNIV"

abbreviation "linear_order \<equiv> linear_order_on UNIV"

abbreviation "well_order \<equiv> well_order_on UNIV"

subsection {* Order-like relations *}

text{* In this subsection, we develop basic concepts and results pertaining
to order-like relations, i.e., to reflexive and/or transitive and/or symmetric and/or
total relations. We also further define upper and lower bounds operators. *}

subsubsection {* Auxiliaries *}

lemma refl_on_domain:
"\<lbrakk>refl_on A r; (a,b) : r\<rbrakk> \<Longrightarrow> a \<in> A \<and> b \<in> A"
by(auto simp add: refl_on_def)

corollary well_order_on_domain:
"\<lbrakk>well_order_on A r; (a,b) \<in> r\<rbrakk> \<Longrightarrow> a \<in> A \<and> b \<in> A"
by (auto simp add: refl_on_domain order_on_defs)

lemma well_order_on_Field:
"well_order_on A r \<Longrightarrow> A = Field r"
by(auto simp add: refl_on_def Field_def order_on_defs)

lemma well_order_on_Well_order:
"well_order_on A r \<Longrightarrow> A = Field r \<and> Well_order r"
using well_order_on_Field by auto

lemma Total_subset_Id:
assumes TOT: "Total r" and SUB: "r \<le> Id"
shows "r = {} \<or> (\<exists>a. r = {(a,a)})"
proof-
  {assume "r \<noteq> {}"
   then obtain a b where 1: "(a,b) \<in> r" by fast
   hence "a = b" using SUB by blast
   hence 2: "(a,a) \<in> r" using 1 by simp
   {fix c d assume "(c,d) \<in> r"
    hence "{a,c,d} \<le> Field r" using 1 unfolding Field_def by blast
    hence "((a,c) \<in> r \<or> (c,a) \<in> r \<or> a = c) \<and>
           ((a,d) \<in> r \<or> (d,a) \<in> r \<or> a = d)"
    using TOT unfolding total_on_def by blast
    hence "a = c \<and> a = d" using SUB by blast
   }
   hence "r \<le> {(a,a)}" by auto
   with 2 have "\<exists>a. r = {(a,a)}" by blast
  }
  thus ?thesis by blast
qed

lemma Linear_order_in_diff_Id:
assumes LI: "Linear_order r" and
        IN1: "a \<in> Field r" and IN2: "b \<in> Field r"
shows "((a,b) \<in> r) = ((b,a) \<notin> r - Id)"
using assms unfolding order_on_defs total_on_def antisym_def Id_def refl_on_def by force

subsubsection {* The upper and lower bounds operators  *}

text{* Here we define upper (``above") and lower (``below") bounds operators.
We think of @{text "r"} as a {\em non-strict} relation.  The suffix ``S"
at the names of some operators indicates that the bounds are strict -- e.g.,
@{text "underS a"} is the set of all strict lower bounds of @{text "a"} (w.r.t. @{text "r"}).
Capitalization of the first letter in the name reminds that the operator acts on sets, rather
than on individual elements. *}

definition under::"'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
where "under r a \<equiv> {b. (b,a) \<in> r}"

definition underS::"'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
where "underS r a \<equiv> {b. b \<noteq> a \<and> (b,a) \<in> r}"

definition Under::"'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
where "Under r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (b,a) \<in> r}"

definition UnderS::"'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
where "UnderS r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (b,a) \<in> r}"

definition above::"'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
where "above r a \<equiv> {b. (a,b) \<in> r}"

definition aboveS::"'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
where "aboveS r a \<equiv> {b. b \<noteq> a \<and> (a,b) \<in> r}"

definition Above::"'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
where "Above r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (a,b) \<in> r}"

definition AboveS::"'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
where "AboveS r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (a,b) \<in> r}"

definition ofilter :: "'a rel \<Rightarrow> 'a set \<Rightarrow> bool"
where "ofilter r A \<equiv> (A \<le> Field r) \<and> (\<forall>a \<in> A. under r a \<le> A)"

text{* Note:  In the definitions of @{text "Above[S]"} and @{text "Under[S]"},
  we bounded comprehension by @{text "Field r"} in order to properly cover
  the case of @{text "A"} being empty. *}

lemma underS_subset_under: "underS r a \<le> under r a"
by(auto simp add: underS_def under_def)

lemma underS_notIn: "a \<notin> underS r a"
by(simp add: underS_def)

lemma Refl_under_in: "\<lbrakk>Refl r; a \<in> Field r\<rbrakk> \<Longrightarrow> a \<in> under r a"
by(simp add: refl_on_def under_def)

lemma AboveS_disjoint: "A Int (AboveS r A) = {}"
by(auto simp add: AboveS_def)

lemma in_AboveS_underS: "a \<in> Field r \<Longrightarrow> a \<in> AboveS r (underS r a)"
by(auto simp add: AboveS_def underS_def)

lemma Refl_under_underS:
  assumes "Refl r" "a \<in> Field r"
  shows "under r a = underS r a \<union> {a}"
unfolding under_def underS_def
using assms refl_on_def[of _ r] by fastforce

lemma underS_empty: "a \<notin> Field r \<Longrightarrow> underS r a = {}"
by (auto simp: Field_def underS_def)

lemma under_Field: "under r a \<le> Field r"
by(unfold under_def Field_def, auto)

lemma underS_Field: "underS r a \<le> Field r"
by(unfold underS_def Field_def, auto)

lemma underS_Field2:
"a \<in> Field r \<Longrightarrow> underS r a < Field r"
using underS_notIn underS_Field by fast

lemma underS_Field3:
"Field r \<noteq> {} \<Longrightarrow> underS r a < Field r"
by(cases "a \<in> Field r", simp add: underS_Field2, auto simp add: underS_empty)

lemma AboveS_Field: "AboveS r A \<le> Field r"
by(unfold AboveS_def Field_def, auto)

lemma under_incr:
  assumes TRANS: "trans r" and REL: "(a,b) \<in> r"
  shows "under r a \<le> under r b"
proof(unfold under_def, auto)
  fix x assume "(x,a) \<in> r"
  with REL TRANS trans_def[of r]
  show "(x,b) \<in> r" by blast
qed

lemma underS_incr:
assumes TRANS: "trans r" and ANTISYM: "antisym r" and
        REL: "(a,b) \<in> r"
shows "underS r a \<le> underS r b"
proof(unfold underS_def, auto)
  assume *: "b \<noteq> a" and **: "(b,a) \<in> r"
  with ANTISYM antisym_def[of r] REL
  show False by blast
next
  fix x assume "x \<noteq> a" "(x,a) \<in> r"
  with REL TRANS trans_def[of r]
  show "(x,b) \<in> r" by blast
qed

lemma underS_incl_iff:
assumes LO: "Linear_order r" and
        INa: "a \<in> Field r" and INb: "b \<in> Field r"
shows "(underS r a \<le> underS r b) = ((a,b) \<in> r)"
proof
  assume "(a,b) \<in> r"
  thus "underS r a \<le> underS r b" using LO
  by (simp add: order_on_defs underS_incr)
next
  assume *: "underS r a \<le> underS r b"
  {assume "a = b"
   hence "(a,b) \<in> r" using assms
   by (simp add: order_on_defs refl_on_def)
  }
  moreover
  {assume "a \<noteq> b \<and> (b,a) \<in> r"
   hence "b \<in> underS r a" unfolding underS_def by blast
   hence "b \<in> underS r b" using * by blast
   hence False by (simp add: underS_notIn)
  }
  ultimately
  show "(a,b) \<in> r" using assms
  order_on_defs[of "Field r" r] total_on_def[of "Field r" r] by blast
qed

subsection {* Variations on Well-Founded Relations  *}

text {*
This subsection contains some variations of the results from @{theory Wellfounded}:
\begin{itemize}
\item means for slightly more direct definitions by well-founded recursion;
\item variations of well-founded induction;
\item means for proving a linear order to be a well-order.
\end{itemize}
*}

subsubsection {* Characterizations of well-foundedness *}

text {* A transitive relation is well-founded iff it is ``locally'' well-founded,
i.e., iff its restriction to the lower bounds of of any element is well-founded.  *}

lemma trans_wf_iff:
assumes "trans r"
shows "wf r = (\<forall>a. wf(r Int (r^-1``{a} \<times> r^-1``{a})))"
proof-
  obtain R where R_def: "R = (\<lambda> a. r Int (r^-1``{a} \<times> r^-1``{a}))" by blast
  {assume *: "wf r"
   {fix a
    have "wf(R a)"
    using * R_def wf_subset[of r "R a"] by auto
   }
  }
  (*  *)
  moreover
  {assume *: "\<forall>a. wf(R a)"
   have "wf r"
   proof(unfold wf_def, clarify)
     fix phi a
     assume **: "\<forall>a. (\<forall>b. (b,a) \<in> r \<longrightarrow> phi b) \<longrightarrow> phi a"
     obtain chi where chi_def: "chi = (\<lambda>b. (b,a) \<in> r \<longrightarrow> phi b)" by blast
     with * have "wf (R a)" by auto
     hence "(\<forall>b. (\<forall>c. (c,b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b) \<longrightarrow> (\<forall>b. chi b)"
     unfolding wf_def by blast
     moreover
     have "\<forall>b. (\<forall>c. (c,b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b"
     proof(auto simp add: chi_def R_def)
       fix b
       assume 1: "(b,a) \<in> r" and 2: "\<forall>c. (c, b) \<in> r \<and> (c, a) \<in> r \<longrightarrow> phi c"
       hence "\<forall>c. (c, b) \<in> r \<longrightarrow> phi c"
       using assms trans_def[of r] by blast
       thus "phi b" using ** by blast
     qed
     ultimately have  "\<forall>b. chi b" by (rule mp)
     with ** chi_def show "phi a" by blast
   qed
  }
  ultimately show ?thesis using R_def by blast
qed

text {* The next lemma is a variation of @{text "wf_eq_minimal"} from Wellfounded,
allowing one to assume the set included in the field.  *}

lemma wf_eq_minimal2:
"wf r = (\<forall>A. A <= Field r \<and> A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. \<not> (a',a) \<in> r))"
proof-
  let ?phi = "\<lambda> A. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. \<not> (a',a) \<in> r)"
  have "wf r = (\<forall>A. ?phi A)"
  by (auto simp: ex_in_conv [THEN sym], erule wfE_min, assumption, blast)
     (rule wfI_min, fast)
  (*  *)
  also have "(\<forall>A. ?phi A) = (\<forall>B \<le> Field r. ?phi B)"
  proof
    assume "\<forall>A. ?phi A"
    thus "\<forall>B \<le> Field r. ?phi B" by simp
  next
    assume *: "\<forall>B \<le> Field r. ?phi B"
    show "\<forall>A. ?phi A"
    proof(clarify)
      fix A::"'a set" assume **: "A \<noteq> {}"
      obtain B where B_def: "B = A Int (Field r)" by blast
      show "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r"
      proof(cases "B = {}")
        assume Case1: "B = {}"
        obtain a where 1: "a \<in> A \<and> a \<notin> Field r"
        using ** Case1 unfolding B_def by blast
        hence "\<forall>a' \<in> A. (a',a) \<notin> r" using 1 unfolding Field_def by blast
        thus ?thesis using 1 by blast
      next
        assume Case2: "B \<noteq> {}" have 1: "B \<le> Field r" unfolding B_def by blast
        obtain a where 2: "a \<in> B \<and> (\<forall>a' \<in> B. (a',a) \<notin> r)"
        using Case2 1 * by blast
        have "\<forall>a' \<in> A. (a',a) \<notin> r"
        proof(clarify)
          fix a' assume "a' \<in> A" and **: "(a',a) \<in> r"
          hence "a' \<in> B" unfolding B_def Field_def by blast
          thus False using 2 ** by blast
        qed
        thus ?thesis using 2 unfolding B_def by blast
      qed
    qed
  qed
  finally show ?thesis by blast
qed

subsubsection {* Characterizations of well-foundedness *}

text {* The next lemma and its corollary enable one to prove that
a linear order is a well-order in a way which is more standard than
via well-foundedness of the strict version of the relation.  *}

lemma Linear_order_wf_diff_Id:
assumes LI: "Linear_order r"
shows "wf(r - Id) = (\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r))"
proof(cases "r \<le> Id")
  assume Case1: "r \<le> Id"
  hence temp: "r - Id = {}" by blast
  hence "wf(r - Id)" by (simp add: temp)
  moreover
  {fix A assume *: "A \<le> Field r" and **: "A \<noteq> {}"
   obtain a where 1: "r = {} \<or> r = {(a,a)}" using LI
   unfolding order_on_defs using Case1 Total_subset_Id by auto
   hence "A = {a} \<and> r = {(a,a)}" using * ** unfolding Field_def by blast
   hence "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r" using 1 by blast
  }
  ultimately show ?thesis by blast
next
  assume Case2: "\<not> r \<le> Id"
  hence 1: "Field r = Field(r - Id)" using Total_Id_Field LI
  unfolding order_on_defs by blast
  show ?thesis
  proof
    assume *: "wf(r - Id)"
    show "\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r)"
    proof(clarify)
      fix A assume **: "A \<le> Field r" and ***: "A \<noteq> {}"
      hence "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id"
      using 1 * unfolding wf_eq_minimal2 by simp
      moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. ((a,a') \<in> r) = ((a',a) \<notin> r - Id)"
      using Linear_order_in_diff_Id[of r] ** LI by blast
      ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r" by blast
    qed
  next
    assume *: "\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r)"
    show "wf(r - Id)"
    proof(unfold wf_eq_minimal2, clarify)
      fix A assume **: "A \<le> Field(r - Id)" and ***: "A \<noteq> {}"
      hence "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r"
      using 1 * by simp
      moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. ((a,a') \<in> r) = ((a',a) \<notin> r - Id)"
      using Linear_order_in_diff_Id[of r] ** LI mono_Field[of "r - Id" r] by blast
      ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id" by blast
    qed
  qed
qed

corollary Linear_order_Well_order_iff:
assumes "Linear_order r"
shows "Well_order r = (\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r))"
using assms unfolding well_order_on_def using Linear_order_wf_diff_Id[of r] by blast

end


(*
  File: Wfrec.thy
  Author: Bohua Zhan

  Well-founded recursion.
*)

theory Wfrec
  imports FixedPt
begin

definition ord_minimal :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "ord_minimal(r,Z,x) \<longleftrightarrow> (\<forall>y\<in>.r. y <\<^sub>r x \<longrightarrow> y \<notin> Z)"

lemma rel_minimalD [forward]:
  "y \<in>. r \<Longrightarrow> ord_minimal(r,Z,x) \<Longrightarrow> y <\<^sub>r x \<Longrightarrow> y \<notin> Z" by auto2
setup {* del_prfstep_thm_eqforward @{thm ord_minimal_def} *}

definition wf :: "i \<Rightarrow> o" where [rewrite]:
  "wf(r) \<longleftrightarrow> refl_order(r) \<and> (\<forall>Z. Z \<subseteq> carrier(r) \<longrightarrow> Z \<noteq> \<emptyset> \<longrightarrow> (\<exists>x\<in>Z. ord_minimal(r,Z,x)))"

lemma wfD1 [forward]: "wf(r) \<Longrightarrow> refl_order(r)" by auto2
lemma wfD2 [backward]: "wf(r) \<Longrightarrow> Z \<noteq> \<emptyset> \<Longrightarrow> \<exists>x\<in>Z. ord_minimal(r,Z,x)" by auto2
setup {* del_prfstep_thm_eqforward @{thm wf_def} *}

lemma wf_to_order [forward]:
  "wf(R) \<Longrightarrow> trans(R) \<Longrightarrow> order(R)"
@proof
  @have "\<forall>x y. x \<le>\<^sub>R y \<longrightarrow> y \<le>\<^sub>R x \<longrightarrow> x = y" @with
    @let "Z = {x,y}"
    @obtain "z\<in>Z" where "ord_minimal(R,Z,z)"
  @end
@qed

(* Given \<langle>a,b\<rangle> \<in> r^+, take a' to be the predecessor of b in the chain from a to b. *)
lemma rel_rtrans_cl_prev [backward]:
  "raworder(R) \<Longrightarrow> S = rel_rtrans_cl(R) \<Longrightarrow> a <\<^sub>S b \<Longrightarrow> \<exists>a'\<in>.R. a' <\<^sub>R b \<and> a \<le>\<^sub>S a'"
@proof
  @induct "le(rel_rtrans_cl(R),a,b)" "a \<noteq> b \<longrightarrow> (\<exists>a'\<in>.R. a' <\<^sub>R b \<and> a \<le>\<^sub>S a')"
@qed

lemma wf_trans_cl [forward]:
  "wf(r) \<Longrightarrow> wf(rel_rtrans_cl(r))"
@proof
  @let "A = carrier(r)"
  @let "s = rel_rtrans_cl(r)"
  @have "\<forall>B. B \<subseteq> A \<longrightarrow> B \<noteq> \<emptyset> \<longrightarrow> (\<exists>x\<in>B. ord_minimal(s,B,x))" @with
    @contradiction
    @let "B' = {x\<in>A. \<exists>y\<in>B. y <\<^sub>s x}"
    @obtain "m\<in>B'" where "ord_minimal(r,B',m)"
    @have "m \<in> B" @with
      @obtain "y \<in> B" where "y <\<^sub>s m"
      @obtain "y' \<in> A" where "y' <\<^sub>r m" "y \<le>\<^sub>s y'"
    @end
    @have "\<forall>y\<in>.r. y <\<^sub>s m \<longrightarrow> y \<notin> B" @with
      @obtain "y' \<in> A" where "y' <\<^sub>r m" "y \<le>\<^sub>s y'"
    @end
  @end
@qed

(* Well-founded induction *)
lemma wf_induct [strong_induct]:
  "wf(r) \<and> a \<in>. r \<Longrightarrow> \<forall>x\<in>.r. (\<forall>y\<in>.r. y <\<^sub>r x \<longrightarrow> P(y)) \<longrightarrow> P(x) \<Longrightarrow> P(a)"
@proof
  @let "Z = {z \<in>. r. \<not>P(z)}"
  @case "Z = \<emptyset>" @with @have "a \<notin> Z" @end
  @obtain "m\<in>Z" where "ord_minimal(r,Z,m)"
@qed

definition ord_pred :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "ord_pred(r,a) = {x\<in>.r. x <\<^sub>r a}"
setup {* register_wellform_data ("ord_pred(r,a)", ["a \<in>. r"]) *}

lemma ord_predI [typing2,backward]: "raworder(r) \<Longrightarrow> x <\<^sub>r a \<Longrightarrow> x \<in> ord_pred(r,a)" by auto2
lemma ord_predE [forward]: "x \<in> ord_pred(r,a) \<Longrightarrow> x <\<^sub>r a" by auto2
setup {* del_prfstep_thm @{thm ord_pred_def} *}

(* f is a family indexed by ord_pred(r,a) (set of all x such that le(r,x,a)),
   H is a meta-function from x and the segment of f before x to T. *)
definition is_recfun :: "[i, i, [i, i] \<Rightarrow> i, i] \<Rightarrow> o" where [rewrite]:
  "is_recfun(r,a,H,f) \<longleftrightarrow> f = Tup(ord_pred(r,a), \<lambda>x. H(x, proj_set(f, ord_pred(r,x))))"

lemma is_recfun_is_family [forward]:
  "is_recfun(r,a,H,f) \<Longrightarrow> is_family(f) \<and> source(f) = ord_pred(r,a)" by auto2

lemma is_recfun_eval [rewrite]:
  "x \<in> source(f) \<Longrightarrow> is_recfun(r,a,H,f) \<Longrightarrow> f`x = H(x, proj_set(f, ord_pred(r,x)))" by auto2

lemma is_recfunI [backward2]:
  "is_family(f) \<Longrightarrow> source(f) = ord_pred(r,a) \<Longrightarrow>
   \<forall>x\<in>source(f). f`x = H(x, proj_set(f, ord_pred(r,x))) \<Longrightarrow> is_recfun(r,a,H,f)" by auto2
setup {* del_prfstep_thm @{thm is_recfun_def} *}

(* Uniqueness of is_recfun: main result proved by well-founded induction,
   followed by two corollaries. *)
lemma is_recfun_agree [forward]:
  "wf(r) \<Longrightarrow> trans(r) \<Longrightarrow> is_recfun(r,a,H,f) \<Longrightarrow> is_recfun(r,b,H,g) \<Longrightarrow>
   \<forall>x. x <\<^sub>r a \<longrightarrow> x <\<^sub>r b \<longrightarrow> f`x = g`x"
@proof
  @have "\<forall>x. x <\<^sub>r a \<longrightarrow> x <\<^sub>r b \<longrightarrow> f`x = g`x" @with
    @strong_induct "wf(r) \<and> x \<in>. r"
    @have (@rule) "\<forall>p1 p2. p1 = p2 \<longrightarrow> H(x,p1) = H(x,p2)"
  @end
@qed

lemma is_recfun_unique [forward]:
  "wf(r) \<Longrightarrow> trans(r) \<Longrightarrow> is_recfun(r,a,H,f) \<Longrightarrow> is_recfun(r,a,H,g) \<Longrightarrow> f = g" by auto2

lemma is_recfun_restrict_eq [forward]:
  "wf(r) \<Longrightarrow> trans(r) \<Longrightarrow> is_recfun(r,a,H,f) \<Longrightarrow> is_recfun(r,b,H,g) \<Longrightarrow>
   b \<le>\<^sub>r a \<Longrightarrow> proj_set(f, ord_pred(r,b)) = g" by auto2
setup {* del_prfstep_thm @{thm is_recfun_agree} *}

(* Define recursive function using THE operator. *)
definition the_recfun :: "[i, i, [i, i] \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "the_recfun(r,a,H) = (THE f. is_recfun(r,a,H,f))"

lemma the_recfun_eq [rewrite]:
  "wf(r) \<Longrightarrow> trans(r) \<Longrightarrow> is_recfun(r,a,H,f) \<Longrightarrow> the_recfun(r,a,H) = f" by auto2

lemma is_the_recfun:
  "wf(r) \<Longrightarrow> trans(r) \<Longrightarrow> is_recfun(r,a,H,f) \<Longrightarrow> is_recfun(r,a,H,the_recfun(r,a,H))" by auto2
setup {* add_forward_prfstep_cond @{thm is_the_recfun} [with_term "the_recfun(?r,?a,?H)"] *}
setup {* del_prfstep_thm @{thm the_recfun_def} *}

(* Existence of recursive function, proved by a second well-founded induction. *)
lemma unfold_the_recfun:
  "wf(r) \<Longrightarrow> trans(r) \<Longrightarrow> a \<in>. r \<Longrightarrow> is_recfun(r,a,H,the_recfun(r,a,H))"
@proof
  @strong_induct "wf(r) \<and> a \<in>. r"
  @let "f = Tup(ord_pred(r,a), \<lambda>y. H(y, the_recfun(r,y,H)))"
  @have (@rule) "\<forall>x p1 p2. p1 = p2 \<longrightarrow> H(x,p1) = H(x,p2)"
  @have "is_recfun(r,a,H,f)"
@qed
setup {* add_forward_prfstep_cond @{thm unfold_the_recfun} [with_term "the_recfun(?r,?a,?H)"] *}

(* The full recursive function and its rewrite property. *)
definition wftrec :: "[i, [i, i] \<Rightarrow> i, i] \<Rightarrow> i" where [rewrite]:
  "wftrec(r,H,a) = H(a, the_recfun(r,a,H))"
setup {* register_wellform_data ("wftrec(r,H,a)", ["a \<in> source(r)"]) *}

lemma wftrec_unfold [rewrite]:
  "wf(r) \<Longrightarrow> trans(r) \<Longrightarrow> a \<in>. r \<Longrightarrow>
   wftrec(r,H,a) = H(a, Tup(ord_pred(r,a), \<lambda>x. wftrec(r,H,x)))"
@proof
  @have (@rule) "\<forall>p1 p2. p1 = p2 \<longrightarrow> H(a,p1) = H(a,p2)"
@qed
setup {* del_prfstep_thm @{thm wftrec_def} *}

(* Definition that does not assume transitivity.

   Assuming r is a well-founded order and a is an element in source(r),
   H is a meta-function indicating how to obtain value at x from a mapping
   from x and the family of values at the set r^-1(x).
*)
definition wfrec :: "[i, [i, i] \<Rightarrow> i, i] \<Rightarrow> i" where [rewrite]:
  "wfrec(r,H,a) = wftrec(rel_rtrans_cl(r), \<lambda>x f. H(x, proj_set(f,ord_pred(r,x))), a)"
setup {* register_wellform_data ("wfrec(r,H,a)", ["a \<in> source(r)"]) *}

lemma wfrec_unfold [rewrite]:
  "wf(r) \<Longrightarrow> a \<in>. r \<Longrightarrow>
   wfrec(r,H,a) = H(a, Tup(ord_pred(r,a), \<lambda>x. wfrec(r,H,x)))"
@proof
  @have (@rule) "\<forall>p1 p2. p1 = p2 \<longrightarrow> H(a,p1) = H(a,p2)"
@qed
setup {* del_prfstep_thm @{thm wfrec_def} *}

end


theory Bij_betw_simplicial_complex_bool_func
  imports
    Simplicial_complex
begin

section\<open>Bijection between simplicial complexes and monotone Boolean functions\<close>

context simplicial_complex
begin

lemma ceros_of_boolean_input_in_set:
  assumes s: "\<sigma> \<in> simplices"
  shows "ceros_of_boolean_input (vec n (\<lambda>i. i \<notin> \<sigma>)) = \<sigma>"
  unfolding ceros_of_boolean_input_def using s unfolding simplices_def by auto

lemma
  assumes sigma: "\<sigma> \<in> simplices"
  and nempty: "\<sigma> \<noteq> {}"
  shows "Max \<sigma> < n"
proof -
  have "Max \<sigma> \<in> \<sigma>" using linorder_class.Max_in [OF finite_simplex [OF sigma] nempty] .
  thus ?thesis using sigma unfolding simplices_def by auto
qed

definition bool_vec_from_simplice :: "nat set => (bool vec)"
  where "bool_vec_from_simplice \<sigma> = vec n (\<lambda>i. i \<notin> \<sigma>)"

lemma [simp]:
  assumes n: "dim_vec f = n"
  shows "bool_vec_from_simplice (ceros_of_boolean_input f) = f"
  unfolding bool_vec_from_simplice_def
  unfolding ceros_of_boolean_input_def
  using n by auto

lemma "bool_vec_from_simplice {0} = vec n (\<lambda>i. i \<notin> {0})"
  unfolding bool_vec_from_simplice_def by auto

lemma "bool_vec_from_simplice {1,2} =
    vec n (\<lambda>i. i \<notin> {1,2})"
  unfolding bool_vec_from_simplice_def by auto

lemma simplicial_complex_implies_true:
  assumes "\<sigma> \<in> simplicial_complex_induced_by_monotone_boolean_function n f"
  shows "f (bool_vec_from_simplice \<sigma>)"
  unfolding bool_vec_from_simplice_def
  using assms
  unfolding simplicial_complex_induced_by_monotone_boolean_function_def
  unfolding ceros_of_boolean_input_def
  apply auto
  by (smt (verit, best) dim_vec eq_vecI index_vec)

definition bool_vec_set_from_simplice_set :: "nat set set => (bool vec) set"
  where "bool_vec_set_from_simplice_set K =
     {\<sigma>. (dim_vec \<sigma> = n) \<and> (\<exists>k\<in>K. \<sigma> = bool_vec_from_simplice k)}"

definition boolean_function_from_simplicial_complex :: "nat set set => (bool vec => bool)"
  where "boolean_function_from_simplicial_complex K =
          (\<lambda>x. x \<in> (bool_vec_set_from_simplice_set K))"

lemma "Collect (boolean_function_from_simplicial_complex K) = (bool_vec_set_from_simplice_set K)"
  unfolding boolean_function_from_simplicial_complex_def by simp

text\<open>The Boolean function induced by a simplicial complex is monotone.
  This result is proven in Scoville as part of the proof of Proposition 6.16.
  The opposite direction has been proven as
  @{thm monotone_bool_fun_induces_simplicial_complex}.\<close>

lemma
  simplicial_complex_induces_monotone_bool_fun:
  assumes mon: "simplicial_complex (K::nat set set)"
  shows "boolean_functions.monotone_bool_fun n (boolean_function_from_simplicial_complex K)"
proof (unfold boolean_functions.monotone_bool_fun_def)
  show "mono_on (carrier_vec n) (boolean_function_from_simplicial_complex K)"
  proof (intro mono_onI)
  fix r and s::"bool vec"
  assume r_le_s: "r \<le> s"
  show "boolean_function_from_simplicial_complex K r
        \<le> boolean_function_from_simplicial_complex K s"
  proof (cases "boolean_function_from_simplicial_complex K r")
    case False then show ?thesis by simp
  next
    case True
    have ce: "ceros_of_boolean_input s \<subseteq> ceros_of_boolean_input r"
      using monotone_ceros_of_boolean_input [OF r_le_s] .
    from True obtain k where r_def: "r = vec n (\<lambda>i. i \<notin> k)"
      and k: "k \<in> K"
      unfolding boolean_function_from_simplicial_complex_def
      unfolding bool_vec_set_from_simplice_set_def
      unfolding bool_vec_from_simplice_def by auto
    have r_in_K: "ceros_of_boolean_input r \<in> K"
      using k mon
      unfolding r_def
      unfolding ceros_of_boolean_input_def
      unfolding dim_vec
      using simplicial_complex_def [of K] by fastforce
    have "boolean_function_from_simplicial_complex K s"
    proof (unfold boolean_function_from_simplicial_complex_def
        bool_vec_set_from_simplice_set_def, rule, rule conjI)
      show "dim_vec s = n"
        by (metis less_eq_vec_def dim_vec r_def r_le_s)
      show "\<exists>k\<in>K. s = bool_vec_from_simplice k"
        proof (rule bexI [of _ "ceros_of_boolean_input s"], unfold bool_vec_from_simplice_def)
          show "ceros_of_boolean_input s \<in> K"
            using simplicial_complex_monotone [OF mon r_in_K ce] .
          show "s = vec n (\<lambda>i. i \<notin> ceros_of_boolean_input s)"
            using ce unfolding ceros_of_boolean_input_def
            using r_le_s
            unfolding less_eq_vec_def
            unfolding r_def
            unfolding dim_vec by auto
        qed
      qed
     thus ?thesis by simp
   qed
 qed
qed

lemma shows "(simplicial_complex_induced_by_monotone_boolean_function n) \<in>
          boolean_functions.monotone_bool_fun_set n
          \<rightarrow> (simplicial_complex_set::nat set set set)"
proof
  fix x::"bool vec \<Rightarrow> bool"
  assume x: "x \<in> boolean_functions.monotone_bool_fun_set n"
  show "simplicial_complex_induced_by_monotone_boolean_function n x \<in> simplicial_complex_set"
    using monotone_bool_fun_induces_simplicial_complex [of x] x
    unfolding boolean_functions.monotone_bool_fun_set_def
    unfolding boolean_functions.monotone_bool_fun_def simplicial_complex_set_def
    by auto
qed

lemma shows "boolean_function_from_simplicial_complex
          \<in> (simplicial_complex_set::nat set set set)
          \<rightarrow> boolean_functions.monotone_bool_fun_set n"
proof
  fix x::"nat set set" assume x: "x \<in> simplicial_complex_set"
  show "boolean_function_from_simplicial_complex x \<in> boolean_functions.monotone_bool_fun_set n"
    using simplicial_complex_induces_monotone_bool_fun [of x]
    unfolding boolean_functions.monotone_bool_fun_set_def
    unfolding boolean_functions.monotone_bool_fun_def
    using x unfolding simplicial_complex_set_def
    unfolding mem_Collect_eq by fast
qed

text\<open>Given a Boolean function @{term f}, if we build its associated
  simplicial complex and then the associated Boolean function,
  we obtain @{term f}.

  The result holds for every Boolean function @{term f}
  (the premise on @{term f} being monotone can be omitted).\<close>

lemma
  boolean_function_from_simplicial_complex_simplicial_complex_induced_by_monotone_boolean_function:
  fixes f :: "bool vec \<Rightarrow> bool"
  assumes dim: "v \<in> carrier_vec n"
  shows "boolean_function_from_simplicial_complex
    (simplicial_complex_induced_by_monotone_boolean_function n f) v = f v"
proof (intro iffI)
  assume xb: "f v"
  show bf: "boolean_function_from_simplicial_complex
      (simplicial_complex_induced_by_monotone_boolean_function n f) v"
  proof -
   have "f v \<and> v = bool_vec_from_simplice (ceros_of_boolean_input v)"
    unfolding ceros_of_boolean_input_def
    unfolding bool_vec_from_simplice_def
    using xb dim unfolding carrier_vec_def by auto
   then show ?thesis
    unfolding simplicial_complex_induced_by_monotone_boolean_function_def
    unfolding boolean_function_from_simplicial_complex_def
    unfolding bool_vec_set_from_simplice_set_def
    unfolding mem_Collect_eq
    using dim unfolding carrier_vec_def by blast
   qed
next
  assume "boolean_function_from_simplicial_complex
      (simplicial_complex_induced_by_monotone_boolean_function n f) v"
  then show "f v"
    unfolding simplicial_complex_induced_by_monotone_boolean_function_def
    unfolding boolean_function_from_simplicial_complex_def
    unfolding bool_vec_set_from_simplice_set_def
    unfolding mem_Collect_eq
    using \<open>boolean_function_from_simplicial_complex
      (simplicial_complex_induced_by_monotone_boolean_function n f) v\<close>
      boolean_function_from_simplicial_complex_def
      simplicial_complex.bool_vec_set_from_simplice_set_def
      simplicial_complex_implies_true by fastforce
qed

text\<open>Given a simplicial complex @{term K}, if we build its associated
  Boolean function, and then the associated simplicial complex,
  we obtain @{term K}.\<close>

lemma
  simplicial_complex_induced_by_monotone_boolean_function_boolean_function_from_simplicial_complex:
  fixes K :: "nat set set"
  assumes K: "simplicial_complex K"
  shows "simplicial_complex_induced_by_monotone_boolean_function n
    (boolean_function_from_simplicial_complex K) = K"
proof (intro equalityI)
  show "simplicial_complex_induced_by_monotone_boolean_function n
    (boolean_function_from_simplicial_complex K) \<subseteq> K"
  proof
    fix x :: "nat set"
    assume x: "x \<in> simplicial_complex_induced_by_monotone_boolean_function
              n (boolean_function_from_simplicial_complex K)"
    show "x \<in> K"
      using x
      unfolding boolean_function_from_simplicial_complex_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding bool_vec_from_simplice_def bool_vec_set_from_simplice_set_def
      using K
      unfolding simplicial_complex_def simplices_def
      by auto (metis assms bool_vec_from_simplice_def
          ceros_of_boolean_input_in_set simplicial_complex_def)
  qed
next
  show "K \<subseteq> simplicial_complex_induced_by_monotone_boolean_function n
            (boolean_function_from_simplicial_complex K)"
 proof
   fix x :: "nat set"
   assume "x \<in> K"
   hence x: "x \<in> simplices" using K unfolding simplicial_complex_def by simp
   have bvs: "ceros_of_boolean_input (bool_vec_from_simplice x) = x"
     unfolding one_bool_def
     unfolding bool_vec_from_simplice_def
     using ceros_of_boolean_input_in_set [OF x] .
   show "x \<in> simplicial_complex_induced_by_monotone_boolean_function n
          (boolean_function_from_simplicial_complex K)"
     unfolding boolean_function_from_simplicial_complex_def
     unfolding simplicial_complex_induced_by_monotone_boolean_function_def
     unfolding bool_vec_from_simplice_def bool_vec_set_from_simplice_set_def
     using x bool_vec_from_simplice_def bvs
     by (metis (mono_tags, lifting) \<open>x \<in> K\<close> dim_vec mem_Collect_eq)
 qed
qed

end

end


(*<*)
theory Trace
  imports "HOL-Library.Stream" Timestamp
begin
(*>*)

section \<open>Infinite Traces\<close>

inductive sorted_list :: "'a :: order list \<Rightarrow> bool" where
  [intro]: "sorted_list []"
| [intro]: "sorted_list [x]"
| [intro]: "x \<le> y \<Longrightarrow> sorted_list (y # ys) \<Longrightarrow> sorted_list (x # y # ys)"

lemma sorted_list_app: "sorted_list xs \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> x \<le> y) \<Longrightarrow> sorted_list (xs @ [y])"
  by (induction xs rule: sorted_list.induct) auto

lemma sorted_list_drop: "sorted_list xs \<Longrightarrow> sorted_list (drop n xs)"
proof (induction xs arbitrary: n rule: sorted_list.induct)
  case (2 x n)
  then show ?case
    by (cases n) auto
next
  case (3 x y ys n)
  then show ?case
    by (cases n) auto
qed auto

lemma sorted_list_ConsD: "sorted_list (x # xs) \<Longrightarrow> sorted_list xs"
  by (auto elim: sorted_list.cases)

lemma sorted_list_Cons_nth: "sorted_list (x # xs) \<Longrightarrow> j < length xs \<Longrightarrow> x \<le> xs ! j"
  by (induction "x # xs" arbitrary: x xs j rule: sorted_list.induct)
     (fastforce simp: nth_Cons split: nat.splits)+

lemma sorted_list_atD: "sorted_list xs \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs ! i \<le> xs ! j"
proof (induction xs arbitrary: i j rule: sorted_list.induct)
  case (2 x i j)
  then show ?case
    by (cases i) auto
next
  case (3 x y ys i j)
  have "x \<le> (x # y # ys) ! j"
    using 3(5) sorted_list_Cons_nth[OF sorted_list.intros(3)[OF 3(1,2)]]
    by (auto simp: nth_Cons split: nat.splits)
  then show ?case
    using 3
    by (cases i) auto
qed auto

coinductive ssorted :: "'a :: order stream \<Rightarrow> bool" where
  "shd s \<le> shd (stl s) \<Longrightarrow> ssorted (stl s) \<Longrightarrow> ssorted s"

lemma ssorted_siterate[simp]: "(\<And>n. n \<le> f n) \<Longrightarrow> ssorted (siterate f n)"
  by (coinduction arbitrary: n) auto

lemma ssortedD: "ssorted s \<Longrightarrow> s !! i \<le> stl s !! i"
  by (induct i arbitrary: s) (auto elim: ssorted.cases)

lemma ssorted_sdrop: "ssorted s \<Longrightarrow> ssorted (sdrop i s)"
  by (coinduction arbitrary: i s) (auto elim: ssorted.cases ssortedD)

lemma ssorted_monoD: "ssorted s \<Longrightarrow> i \<le> j \<Longrightarrow> s !! i \<le> s !! j"
proof (induct "j - i" arbitrary: j)
  case (Suc x)
  from Suc(1)[of "j - 1"] Suc(2-4) ssortedD[of s "j - 1"]
    show ?case by (cases j) (auto simp: le_Suc_eq Suc_diff_le)
qed simp

lemma sorted_stake: "ssorted s \<Longrightarrow> sorted_list (stake i s)"
proof (induct i arbitrary: s)
  case (Suc i)
  then show ?case
    by (cases i) (auto elim: ssorted.cases)
qed auto

lemma ssorted_monoI: "\<forall>i j. i \<le> j \<longrightarrow> s !! i \<le> s !! j \<Longrightarrow> ssorted s"
  by (coinduction arbitrary: s)
    (auto dest: spec2[of _ "Suc _" "Suc _"] spec2[of _ 0 "Suc 0"])

lemma ssorted_iff_mono: "ssorted s \<longleftrightarrow> (\<forall>i j. i \<le> j \<longrightarrow> s !! i \<le> s !! j)"
  using ssorted_monoI ssorted_monoD by metis

typedef (overloaded) ('a, 'b :: timestamp) trace = "{s :: ('a set \<times> 'b) stream.
  ssorted (smap snd s) \<and> (\<forall>x. x \<in> snd ` sset s \<longrightarrow> x \<in> tfin) \<and> (\<forall>i x. x \<in> tfin \<longrightarrow> (\<exists>j. \<not>snd (s !! j) \<le> snd (s !! i) + x))}"
  by (auto simp: \<iota>_mono \<iota>_tfin \<iota>_progressing stream.set_map
      intro!: exI[of _ "smap (\<lambda>n. ({}, \<iota> n)) nats"] ssorted_monoI)

setup_lifting type_definition_trace

lift_definition \<Gamma> :: "('a, 'b :: timestamp) trace \<Rightarrow> nat \<Rightarrow> 'a set" is
  "\<lambda>s i. fst (s !! i)" .
lift_definition \<tau> :: "('a, 'b :: timestamp) trace \<Rightarrow> nat \<Rightarrow> 'b" is
  "\<lambda>s i. snd (s !! i)" .

lemma \<tau>_mono[simp]: "i \<le> j \<Longrightarrow> \<tau> s i \<le> \<tau> s j"
  by transfer (auto simp: ssorted_iff_mono)

lemma \<tau>_fin: "\<tau> \<sigma> i \<in> tfin"
  by transfer auto

lemma ex_lt_\<tau>: "x \<in> tfin \<Longrightarrow> \<exists>j. \<not>\<tau> s j \<le> \<tau> s i + x"
  by transfer auto

lemma le_\<tau>_less: "\<tau> \<sigma> i \<le> \<tau> \<sigma> j \<Longrightarrow> j < i \<Longrightarrow> \<tau> \<sigma> i = \<tau> \<sigma> j"
  by (simp add: antisym)

lemma less_\<tau>D: "\<tau> \<sigma> i < \<tau> \<sigma> j \<Longrightarrow> i < j"
  by (meson \<tau>_mono less_le_not_le not_le_imp_less)

(*<*)
end
(*>*)