(*  Title:      HOL/Word/Word_Miscellaneous.thy
    Author:     Miscellaneous
*)

section \<open>Miscellaneous lemmas, of at least doubtful value\<close>

theory Word_Miscellaneous
imports Main "~~/src/HOL/Library/Bit" Misc_Numeric
begin

lemma power_minus_simp:
  "0 < n \<Longrightarrow> a ^ n = a * a ^ (n - 1)"
  by (auto dest: gr0_implies_Suc)

lemma funpow_minus_simp:
  "0 < n \<Longrightarrow> f ^^ n = f \<circ> f ^^ (n - 1)"
  by (auto dest: gr0_implies_Suc)

lemma power_numeral:
  "a ^ numeral k = a * a ^ (pred_numeral k)"
  by (simp add: numeral_eq_Suc)

lemma funpow_numeral [simp]:
  "f ^^ numeral k = f \<circ> f ^^ (pred_numeral k)"
  by (simp add: numeral_eq_Suc)

lemma replicate_numeral [simp]:
  "replicate (numeral k) x = x # replicate (pred_numeral k) x"
  by (simp add: numeral_eq_Suc)

lemma rco_alt: "(f o g) ^^ n o f = f o (g o f) ^^ n"
  apply (rule ext)
  apply (induct n)
   apply (simp_all add: o_def)
  done

lemma list_exhaust_size_gt0:
  assumes y: "\<And>a list. y = a # list \<Longrightarrow> P"
  shows "0 < length y \<Longrightarrow> P"
  apply (cases y, simp)
  apply (rule y)
  apply fastforce
  done

lemma list_exhaust_size_eq0:
  assumes y: "y = [] \<Longrightarrow> P"
  shows "length y = 0 \<Longrightarrow> P"
  apply (cases y)
   apply (rule y, simp)
  apply simp
  done

lemma size_Cons_lem_eq:
  "y = xa # list ==> size y = Suc k ==> size list = k"
  by auto

lemmas ls_splits = prod.split prod.split_asm if_split_asm

lemma not_B1_is_B0: "y \<noteq> (1::bit) \<Longrightarrow> y = (0::bit)"
  by (cases y) auto

lemma B1_ass_B0:
  assumes y: "y = (0::bit) \<Longrightarrow> y = (1::bit)"
  shows "y = (1::bit)"
  apply (rule classical)
  apply (drule not_B1_is_B0)
  apply (erule y)
  done

\<comment> "simplifications for specific word lengths"
lemmas n2s_ths [THEN eq_reflection] = add_2_eq_Suc add_2_eq_Suc'

lemmas s2n_ths = n2s_ths [symmetric]

lemma and_len: "xs = ys ==> xs = ys & length xs = length ys"
  by auto

lemma size_if: "size (if p then xs else ys) = (if p then size xs else size ys)"
  by auto

lemma tl_if: "tl (if p then xs else ys) = (if p then tl xs else tl ys)"
  by auto

lemma hd_if: "hd (if p then xs else ys) = (if p then hd xs else hd ys)"
  by auto

lemma if_Not_x: "(if p then ~ x else x) = (p = (~ x))"
  by auto

lemma if_x_Not: "(if p then x else ~ x) = (p = x)"
  by auto

lemma if_same_and: "(If p x y & If p u v) = (if p then x & u else y & v)"
  by auto

lemma if_same_eq: "(If p x y  = (If p u v)) = (if p then x = (u) else y = (v))"
  by auto

lemma if_same_eq_not:
  "(If p x y  = (~ If p u v)) = (if p then x = (~u) else y = (~v))"
  by auto

(* note - if_Cons can cause blowup in the size, if p is complex,
  so make a simproc *)
lemma if_Cons: "(if p then x # xs else y # ys) = If p x y # If p xs ys"
  by auto

lemma if_single:
  "(if xc then [xab] else [an]) = [if xc then xab else an]"
  by auto

lemma if_bool_simps:
  "If p True y = (p | y) & If p False y = (~p & y) &
    If p y True = (p --> y) & If p y False = (p & y)"
  by auto

lemmas if_simps = if_x_Not if_Not_x if_cancel if_True if_False if_bool_simps

lemmas seqr = eq_reflection [where x = "size w"] for w (* FIXME: delete *)

lemma the_elemI: "y = {x} ==> the_elem y = x"
  by simp

lemma nonemptyE: "S ~= {} ==> (!!x. x : S ==> R) ==> R" by auto

lemma gt_or_eq_0: "0 < y \<or> 0 = (y::nat)" by arith

lemmas xtr1 = xtrans(1)
lemmas xtr2 = xtrans(2)
lemmas xtr3 = xtrans(3)
lemmas xtr4 = xtrans(4)
lemmas xtr5 = xtrans(5)
lemmas xtr6 = xtrans(6)
lemmas xtr7 = xtrans(7)
lemmas xtr8 = xtrans(8)

lemmas nat_simps = diff_add_inverse2 diff_add_inverse
lemmas nat_iffs = le_add1 le_add2

lemma sum_imp_diff: "j = k + i ==> j - i = (k :: nat)" by arith

lemmas pos_mod_sign2 = zless2 [THEN pos_mod_sign [where b = "2::int"]]
lemmas pos_mod_bound2 = zless2 [THEN pos_mod_bound [where b = "2::int"]]

lemma nmod2: "n mod (2::int) = 0 | n mod 2 = 1"
  by arith

lemmas eme1p = emep1 [simplified add.commute]

lemma le_diff_eq': "(a \<le> c - b) = (b + a \<le> (c::int))" by arith

lemma less_diff_eq': "(a < c - b) = (b + a < (c::int))" by arith

lemma diff_less_eq': "(a - b < c) = (a < b + (c::int))" by arith

lemmas m1mod22k = mult_pos_pos [OF zless2 zless2p, THEN zmod_minus1]

lemma z1pdiv2:
  "(2 * b + 1) div 2 = (b::int)" by arith

lemmas zdiv_le_dividend = xtr3 [OF div_by_1 [symmetric] zdiv_mono2,
  simplified int_one_le_iff_zero_less, simplified]

lemma axxbyy:
  "a + m + m = b + n + n ==> (a = 0 | a = 1) ==> (b = 0 | b = 1) ==>
   a = b & m = (n :: int)" by arith

lemma axxmod2:
  "(1 + x + x) mod 2 = (1 :: int) & (0 + x + x) mod 2 = (0 :: int)" by arith

lemma axxdiv2:
  "(1 + x + x) div 2 = (x :: int) & (0 + x + x) div 2 = (x :: int)"  by arith

lemmas iszero_minus = trans [THEN trans,
  OF iszero_def neg_equal_0_iff_equal iszero_def [symmetric]]

lemmas zadd_diff_inverse = trans [OF diff_add_cancel [symmetric] add.commute]

lemmas add_diff_cancel2 = add.commute [THEN diff_eq_eq [THEN iffD2]]

lemmas rdmods [symmetric] = mod_minus_eq
  mod_diff_left_eq mod_diff_right_eq mod_add_left_eq
  mod_add_right_eq mod_mult_right_eq mod_mult_left_eq

lemma mod_plus_right:
  "((a + x) mod m = (b + x) mod m) = (a mod m = b mod (m :: nat))"
  apply (induct x)
   apply (simp_all add: mod_Suc)
  apply arith
  done

lemma nat_minus_mod: "(n - n mod m) mod m = (0 :: nat)"
  by (induct n) (simp_all add : mod_Suc)

lemmas nat_minus_mod_plus_right = trans [OF nat_minus_mod mod_0 [symmetric],
  THEN mod_plus_right [THEN iffD2], simplified]

lemmas push_mods' = mod_add_eq
  mod_mult_eq mod_diff_eq
  mod_minus_eq

lemmas push_mods = push_mods' [THEN eq_reflection]
lemmas pull_mods = push_mods [symmetric] rdmods [THEN eq_reflection]
lemmas mod_simps =
  mod_mult_self2_is_0 [THEN eq_reflection]
  mod_mult_self1_is_0 [THEN eq_reflection]
  mod_mod_trivial [THEN eq_reflection]

lemma nat_mod_eq:
  "!!b. b < n ==> a mod n = b mod n ==> a mod n = (b :: nat)"
  by (induct a) auto

lemmas nat_mod_eq' = refl [THEN [2] nat_mod_eq]

lemma nat_mod_lem:
  "(0 :: nat) < n ==> b < n = (b mod n = b)"
  apply safe
   apply (erule nat_mod_eq')
  apply (erule subst)
  apply (erule mod_less_divisor)
  done

lemma mod_nat_add:
  "(x :: nat) < z ==> y < z ==>
   (x + y) mod z = (if x + y < z then x + y else x + y - z)"
  apply (rule nat_mod_eq)
   apply auto
  apply (rule trans)
   apply (rule le_mod_geq)
   apply simp
  apply (rule nat_mod_eq')
  apply arith
  done

lemma mod_nat_sub:
  "(x :: nat) < z ==> (x - y) mod z = x - y"
  by (rule nat_mod_eq') arith

lemma int_mod_eq:
  "(0 :: int) <= b ==> b < n ==> a mod n = b mod n ==> a mod n = b"
  by (metis mod_pos_pos_trivial)

lemmas int_mod_eq' = mod_pos_pos_trivial (* FIXME delete *)

lemma int_mod_le: "(0::int) <= a ==> a mod n <= a"
  by (fact Divides.semiring_numeral_div_class.mod_less_eq_dividend) (* FIXME: delete *)

lemma mod_add_if_z:
  "(x :: int) < z ==> y < z ==> 0 <= y ==> 0 <= x ==> 0 <= z ==>
   (x + y) mod z = (if x + y < z then x + y else x + y - z)"
  by (auto intro: int_mod_eq)

lemma mod_sub_if_z:
  "(x :: int) < z ==> y < z ==> 0 <= y ==> 0 <= x ==> 0 <= z ==>
   (x - y) mod z = (if y <= x then x - y else x - y + z)"
  by (auto intro: int_mod_eq)

lemmas zmde = mult_div_mod_eq [symmetric, THEN diff_eq_eq [THEN iffD2], symmetric]
lemmas mcl = mult_cancel_left [THEN iffD1, THEN make_pos_rule]

(* already have this for naturals, div_mult_self1/2, but not for ints *)
lemma zdiv_mult_self: "m ~= (0 :: int) ==> (a + m * n) div m = a div m + n"
  apply (rule mcl)
   prefer 2
   apply (erule asm_rl)
  apply (simp add: zmde ring_distribs)
  done

lemma mod_power_lem:
  "a > 1 ==> a ^ n mod a ^ m = (if m <= n then 0 else (a :: int) ^ n)"
  apply clarsimp
  apply safe
   apply (simp add: dvd_eq_mod_eq_0 [symmetric])
   apply (drule le_iff_add [THEN iffD1])
   apply (force simp: power_add)
  apply (rule mod_pos_pos_trivial)
   apply (simp)
  apply (rule power_strict_increasing)
   apply auto
  done

lemma pl_pl_rels:
  "a + b = c + d ==>
   a >= c & b <= d | a <= c & b >= (d :: nat)" by arith

lemmas pl_pl_rels' = add.commute [THEN [2] trans, THEN pl_pl_rels]

lemma minus_eq: "(m - k = m) = (k = 0 | m = (0 :: nat))"  by arith

lemma pl_pl_mm: "(a :: nat) + b = c + d ==> a - c = d - b"  by arith

lemmas pl_pl_mm' = add.commute [THEN [2] trans, THEN pl_pl_mm]

lemmas dme = div_mult_mod_eq
lemmas dtle = xtr3 [OF dme [symmetric] le_add1]
lemmas th2 = order_trans [OF order_refl [THEN [2] mult_le_mono] dtle]

lemma td_gal:
  "0 < c ==> (a >= b * c) = (a div c >= (b :: nat))"
  apply safe
   apply (erule (1) xtr4 [OF div_le_mono div_mult_self_is_m])
  apply (erule th2)
  done

lemmas td_gal_lt = td_gal [simplified not_less [symmetric], simplified]

lemma div_mult_le: "(a :: nat) div b * b <= a"
  by (fact dtle)

lemmas sdl = split_div_lemma [THEN iffD1, symmetric]

lemma given_quot: "f > (0 :: nat) ==> (f * l + (f - 1)) div f = l"
  by (rule sdl, assumption) (simp (no_asm))

lemma given_quot_alt: "f > (0 :: nat) ==> (l * f + f - Suc 0) div f = l"
  apply (frule given_quot)
  apply (rule trans)
   prefer 2
   apply (erule asm_rl)
  apply (rule_tac f="%n. n div f" in arg_cong)
  apply (simp add : ac_simps)
  done

lemma diff_mod_le: "(a::nat) < d ==> b dvd d ==> a - a mod b <= d - b"
  apply (unfold dvd_def)
  apply clarify
  apply (case_tac k)
   apply clarsimp
  apply clarify
  apply (cases "b > 0")
   apply (drule mult.commute [THEN xtr1])
   apply (frule (1) td_gal_lt [THEN iffD1])
   apply (clarsimp simp: le_simps)
   apply (rule minus_mod_eq_mult_div [symmetric, THEN [2] xtr4])
   apply (rule mult_mono)
      apply auto
  done

lemma less_le_mult':
  "w * c < b * c ==> 0 \<le> c ==> (w + 1) * c \<le> b * (c::int)"
  apply (rule mult_right_mono)
   apply (rule zless_imp_add1_zle)
   apply (erule (1) mult_right_less_imp_less)
  apply assumption
  done

lemma less_le_mult:
  "w * c < b * c \<Longrightarrow> 0 \<le> c \<Longrightarrow> w * c + c \<le> b * (c::int)"
  using less_le_mult' [of w c b] by (simp add: algebra_simps)

lemmas less_le_mult_minus = iffD2 [OF le_diff_eq less_le_mult,
  simplified left_diff_distrib]

lemma gen_minus: "0 < n ==> f n = f (Suc (n - 1))"
  by auto

lemma mpl_lem: "j <= (i :: nat) ==> k < j ==> i - j + k < i" by arith

lemma nonneg_mod_div:
  "0 <= a ==> 0 <= b ==> 0 <= (a mod b :: int) & 0 <= a div b"
  apply (cases "b = 0", clarsimp)
  apply (auto intro: pos_imp_zdiv_nonneg_iff [THEN iffD2])
  done

declare iszero_0 [intro]

lemma min_pm [simp]:
  "min a b + (a - b) = (a :: nat)"
  by arith

lemma min_pm1 [simp]:
  "a - b + min a b = (a :: nat)"
  by arith

lemma rev_min_pm [simp]:
  "min b a + (a - b) = (a :: nat)"
  by arith

lemma rev_min_pm1 [simp]:
  "a - b + min b a = (a :: nat)"
  by arith

lemma min_minus [simp]:
  "min m (m - k) = (m - k :: nat)"
  by arith

lemma min_minus' [simp]:
  "min (m - k) m = (m - k :: nat)"
  by arith

end


(*  Title:      HOL/Decision_Procs/Conversions.thy
    Author:     Stefan Berghofer
*)

theory Conversions
imports MainRLT
begin

ML \<open>
fun tactic_of_conv cv i st =
  if i > Thm.nprems_of st then Seq.empty
  else Seq.single (Conv.gconv_rule cv i st);

fun binop_conv cv cv' = Conv.combination_conv (Conv.arg_conv cv) cv';
\<close>

ML \<open>
fun err s ct =
   error (s ^ ": " ^ Syntax.string_of_term_global (Thm.theory_of_cterm ct) (Thm.term_of ct));
\<close>

attribute_setup meta =
  \<open>Scan.succeed (fn (ctxt, th) => (NONE, SOME (mk_meta_eq th)))\<close>
  \<open>convert equality to meta equality\<close>

ML \<open>
fun strip_app ct = ct |> Drule.strip_comb |>> Thm.term_of |>> dest_Const |>> fst;

fun inst cTs cts th =
  Thm.instantiate' (map SOME cTs) (map SOME cts) th;

fun transitive' eq eq' = Thm.transitive eq (eq' (Thm.rhs_of eq));

fun type_of_eqn eqn = Thm.ctyp_of_cterm (Thm.dest_arg1 (Thm.cprop_of eqn));

fun cong1 conv ct =
  Thm.combination (Thm.reflexive (Thm.dest_fun ct)) (conv (Thm.dest_arg ct));

fun cong1' conv' conv ct =
  let val eqn = conv (Thm.dest_arg ct)
  in
    Thm.transitive
      (Thm.combination (Thm.reflexive (Thm.dest_fun ct)) eqn)
      (conv' (Thm.rhs_of eqn))
  end;

fun cong2 conv1 conv2 ct =
  Thm.combination
    (Thm.combination
       (Thm.reflexive (Thm.dest_fun2 ct))
       (conv1 (Thm.dest_arg1 ct)))
    (conv2 (Thm.dest_arg ct));

fun cong2' conv conv1 conv2 ct =
  let
    val eqn1 = conv1 (Thm.dest_arg1 ct);
    val eqn2 = conv2 (Thm.dest_arg ct)
  in
    Thm.transitive
      (Thm.combination
         (Thm.combination (Thm.reflexive (Thm.dest_fun2 ct)) eqn1)
         eqn2)
      (conv (Thm.rhs_of eqn1) (Thm.rhs_of eqn2))
  end;

fun cong2'' conv eqn1 eqn2 =
  let val eqn3 = conv (Thm.rhs_of eqn1) (Thm.rhs_of eqn2)
  in
    Thm.transitive
      (Thm.combination
         (Thm.combination (Thm.reflexive (Thm.dest_fun2 (Thm.lhs_of eqn3))) eqn1)
         eqn2)
      eqn3
  end;

fun args1 conv ct = conv (Thm.dest_arg ct);
fun args2 conv ct = conv (Thm.dest_arg1 ct) (Thm.dest_arg ct);
\<close>

ML \<open>
fun strip_numeral ct = (case strip_app ct of
    (\<^const_name>\<open>uminus\<close>, [n]) => (case strip_app n of
      (\<^const_name>\<open>numeral\<close>, [b]) => (\<^const_name>\<open>uminus\<close>, [b])
    | _ => ("", []))
  | x => x);
\<close>

lemma nat_minus1_eq: "nat (- 1) = 0"
  by simp

ML \<open>
fun nat_conv i = (case strip_app i of
    (\<^const_name>\<open>zero_class.zero\<close>, []) => @{thm nat_0 [meta]}
  | (\<^const_name>\<open>one_class.one\<close>, []) => @{thm nat_one_as_int [meta, symmetric]}
  | (\<^const_name>\<open>numeral\<close>, [b]) => inst [] [b] @{thm nat_numeral [meta]}
  | (\<^const_name>\<open>uminus\<close>, [b]) => (case strip_app b of
      (\<^const_name>\<open>one_class.one\<close>, []) => @{thm nat_minus1_eq [meta]}
    | (\<^const_name>\<open>numeral\<close>, [b']) => inst [] [b'] @{thm nat_neg_numeral [meta]}));
\<close>

ML \<open>
fun add_num_conv b b' = (case (strip_app b, strip_app b') of
    ((\<^const_name>\<open>Num.One\<close>, []), (\<^const_name>\<open>Num.One\<close>, [])) =>
      @{thm add_num_simps(1) [meta]}
  | ((\<^const_name>\<open>Num.One\<close>, []), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      inst [] [n] @{thm add_num_simps(2) [meta]}
  | ((\<^const_name>\<open>Num.One\<close>, []), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      transitive'
        (inst [] [n] @{thm add_num_simps(3) [meta]})
        (cong1 (args2 add_num_conv))
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.One\<close>, [])) =>
      inst [] [m] @{thm add_num_simps(4) [meta]}
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      transitive'
        (inst [] [m, n] @{thm add_num_simps(5) [meta]})
        (cong1 (args2 add_num_conv))
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      transitive'
        (inst [] [m, n] @{thm add_num_simps(6) [meta]})
        (cong1 (args2 add_num_conv))
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.One\<close>, [])) =>
      transitive'
        (inst [] [m] @{thm add_num_simps(7) [meta]})
        (cong1 (args2 add_num_conv))
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      transitive'
        (inst [] [m, n] @{thm add_num_simps(8) [meta]})
        (cong1 (args2 add_num_conv))
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      transitive'
        (inst [] [m, n] @{thm add_num_simps(9) [meta]})
        (cong1 (cong2' add_num_conv (args2 add_num_conv) Thm.reflexive)));
\<close>

ML \<open>
fun BitM_conv m = (case strip_app m of
    (\<^const_name>\<open>Num.One\<close>, []) => @{thm BitM.simps(1) [meta]}
  | (\<^const_name>\<open>Num.Bit0\<close>, [n]) =>
      transitive'
        (inst [] [n] @{thm BitM.simps(2) [meta]})
        (cong1 (args1 BitM_conv))
  | (\<^const_name>\<open>Num.Bit1\<close>, [n]) =>
      inst [] [n] @{thm BitM.simps(3) [meta]});
\<close>

lemma dbl_neg_numeral:
  "Num.dbl (- Num.numeral k) = - Num.numeral (Num.Bit0 k)"
  by simp

ML \<open>
fun dbl_conv a =
  let
    val dbl_neg_numeral_a = inst [a] [] @{thm dbl_neg_numeral [meta]};
    val dbl_0_a = inst [a] [] @{thm dbl_simps(2) [meta]};
    val dbl_numeral_a = inst [a] [] @{thm dbl_simps(5) [meta]}
  in
    fn n =>
      case strip_numeral n of
        (\<^const_name>\<open>zero_class.zero\<close>, []) => dbl_0_a
      | (\<^const_name>\<open>numeral\<close>, [k]) => inst [] [k] dbl_numeral_a
      | (\<^const_name>\<open>uminus\<close>, [k]) => inst [] [k] dbl_neg_numeral_a
  end;
\<close>

lemma dbl_inc_neg_numeral:
  "Num.dbl_inc (- Num.numeral k) = - Num.numeral (Num.BitM k)"
  by simp

ML \<open>
fun dbl_inc_conv a =
  let
    val dbl_inc_neg_numeral_a = inst [a] [] @{thm dbl_inc_neg_numeral [meta]};
    val dbl_inc_0_a = inst [a] [] @{thm dbl_inc_simps(2) [folded numeral_One, meta]};
    val dbl_inc_numeral_a = inst [a] [] @{thm dbl_inc_simps(5) [meta]};
  in
    fn n =>
      case strip_numeral n of
        (\<^const_name>\<open>zero_class.zero\<close>, []) => dbl_inc_0_a
      | (\<^const_name>\<open>numeral\<close>, [k]) => inst [] [k] dbl_inc_numeral_a
      | (\<^const_name>\<open>uminus\<close>, [k]) =>
          transitive'
            (inst [] [k] dbl_inc_neg_numeral_a)
            (cong1 (cong1 (args1 BitM_conv)))
  end;
\<close>

lemma dbl_dec_neg_numeral:
  "Num.dbl_dec (- Num.numeral k) = - Num.numeral (Num.Bit1 k)"
  by simp

ML \<open>
fun dbl_dec_conv a =
  let
    val dbl_dec_neg_numeral_a = inst [a] [] @{thm dbl_dec_neg_numeral [meta]};
    val dbl_dec_0_a = inst [a] [] @{thm dbl_dec_simps(2) [folded numeral_One, meta]};
    val dbl_dec_numeral_a = inst [a] [] @{thm dbl_dec_simps(5) [meta]};
  in
    fn n =>
      case strip_numeral n of
        (\<^const_name>\<open>zero_class.zero\<close>, []) => dbl_dec_0_a
      | (\<^const_name>\<open>uminus\<close>, [k]) => inst [] [k] dbl_dec_neg_numeral_a
      | (\<^const_name>\<open>numeral\<close>, [k]) =>
          transitive'
            (inst [] [k] dbl_dec_numeral_a)
            (cong1 (args1 BitM_conv))
  end;
\<close>

ML \<open>
fun sub_conv a =
  let
    val [sub_One_One, sub_One_Bit0, sub_One_Bit1,
         sub_Bit0_One, sub_Bit1_One, sub_Bit0_Bit0,
         sub_Bit0_Bit1, sub_Bit1_Bit0, sub_Bit1_Bit1] =
      map (inst [a] []) @{thms sub_num_simps [meta]};
    val dbl_conv_a = dbl_conv a;
    val dbl_inc_conv_a = dbl_inc_conv a;
    val dbl_dec_conv_a = dbl_dec_conv a;

    fun conv m n = (case (strip_app m, strip_app n) of
        ((\<^const_name>\<open>Num.One\<close>, []), (\<^const_name>\<open>Num.One\<close>, [])) =>
          sub_One_One
      | ((\<^const_name>\<open>Num.One\<close>, []), (\<^const_name>\<open>Num.Bit0\<close>, [l])) =>
          transitive'
            (inst [] [l] sub_One_Bit0)
            (cong1 (cong1 (args1 BitM_conv)))
      | ((\<^const_name>\<open>Num.One\<close>, []), (\<^const_name>\<open>Num.Bit1\<close>, [l])) =>
          inst [] [l] sub_One_Bit1
      | ((\<^const_name>\<open>Num.Bit0\<close>, [k]), (\<^const_name>\<open>Num.One\<close>, [])) =>
          transitive'
            (inst [] [k] sub_Bit0_One)
            (cong1 (args1 BitM_conv))
      | ((\<^const_name>\<open>Num.Bit1\<close>, [k]), (\<^const_name>\<open>Num.One\<close>, [])) =>
          inst [] [k] sub_Bit1_One
      | ((\<^const_name>\<open>Num.Bit0\<close>, [k]), (\<^const_name>\<open>Num.Bit0\<close>, [l])) =>
          transitive'
            (inst [] [k, l] sub_Bit0_Bit0)
            (cong1' dbl_conv_a (args2 conv))
      | ((\<^const_name>\<open>Num.Bit0\<close>, [k]), (\<^const_name>\<open>Num.Bit1\<close>, [l])) =>
          transitive'
            (inst [] [k, l] sub_Bit0_Bit1)
            (cong1' dbl_dec_conv_a (args2 conv))
      | ((\<^const_name>\<open>Num.Bit1\<close>, [k]), (\<^const_name>\<open>Num.Bit0\<close>, [l])) =>
          transitive'
            (inst [] [k, l] sub_Bit1_Bit0)
            (cong1' dbl_inc_conv_a (args2 conv))
      | ((\<^const_name>\<open>Num.Bit1\<close>, [k]), (\<^const_name>\<open>Num.Bit1\<close>, [l])) =>
          transitive'
            (inst [] [k, l] sub_Bit1_Bit1)
            (cong1' dbl_conv_a (args2 conv)))
  in conv end;
\<close>

ML \<open>
fun expand1 a =
  let val numeral_1_eq_1_a = inst [a] [] @{thm numeral_One [meta, symmetric]}
  in
    fn n =>
      case Thm.term_of n of
        \<^Const_>\<open>one_class.one _\<close> => numeral_1_eq_1_a
      | \<^Const_>\<open>uminus _ for \<^Const_>\<open>one_class.one _\<close>\<close> =>
          Thm.combination (Thm.reflexive (Thm.dest_fun n)) numeral_1_eq_1_a
      | \<^Const_>\<open>zero_class.zero _\<close> => Thm.reflexive n
      | \<^Const_>\<open>numeral _ for _\<close> => Thm.reflexive n
      | \<^Const_>\<open>uminus _ for \<^Const_>\<open>numeral _ for _\<close>\<close> => Thm.reflexive n
      | _ => err "expand1" n
  end;

fun norm1_eq a =
  let val numeral_1_eq_1_a = inst [a] [] @{thm numeral_One [meta]}
  in
    fn eq =>
      case Thm.term_of (Thm.rhs_of eq) of
        \<^Const_>\<open>Num.numeral _ for \<^Const_>\<open>Num.One\<close>\<close> => Thm.transitive eq numeral_1_eq_1_a
      | \<^Const_>\<open>uminus _ for \<^Const_>\<open>Num.numeral _ for \<^Const_>\<open>Num.One\<close>\<close>\<close> =>
            Thm.transitive eq
              (Thm.combination (Thm.reflexive (Thm.dest_fun (Thm.rhs_of eq)))
                 numeral_1_eq_1_a)
      | _ => eq
  end;
\<close>

ML \<open>
fun plus_conv f a =
  let
    val add_0_a = inst [a] [] @{thm add_0 [meta]};
    val add_0_right_a = inst [a] [] @{thm add_0_right [meta]};
    val numeral_plus_numeral_a = inst [a] [] @{thm numeral_plus_numeral [meta]};
    val expand1_a = expand1 a;

    fun conv m n = (case (strip_app m, strip_app n) of
        ((\<^const_name>\<open>zero_class.zero\<close>, []), _) => inst [] [n] add_0_a
      | (_, (\<^const_name>\<open>zero_class.zero\<close>, [])) => inst [] [m] add_0_right_a
      | ((\<^const_name>\<open>numeral\<close>, [m]), (\<^const_name>\<open>numeral\<close>, [n])) =>
          transitive'
            (inst [] [m, n] numeral_plus_numeral_a)
            (cong1 (args2 add_num_conv))
      | _ => cong2'' (f conv) (expand1_a m) (expand1_a n))
  in f conv end;

val nat_plus_conv = plus_conv I \<^ctyp>\<open>nat\<close>;
\<close>

lemma neg_numeral_plus_neg_numeral:
  "- Num.numeral m + - Num.numeral n = (- Num.numeral (m + n) ::'a::neg_numeral)"
  by simp

ML \<open>
fun plus_neg_conv a =
  let
    val numeral_plus_neg_numeral_a =
      inst [a] [] @{thm add_neg_numeral_simps(1) [meta]};
    val neg_numeral_plus_numeral_a =
      inst [a] [] @{thm add_neg_numeral_simps(2) [meta]};
    val neg_numeral_plus_neg_numeral_a =
      inst [a] [] @{thm neg_numeral_plus_neg_numeral [meta]};
    val sub_conv_a = sub_conv a;
  in
    fn conv => fn m => fn n =>
      case (strip_numeral m, strip_numeral n) of
        ((\<^const_name>\<open>Num.numeral\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          Thm.transitive
            (inst [] [m, n] numeral_plus_neg_numeral_a)
            (sub_conv_a m n)
      | ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>Num.numeral\<close>, [n])) =>
          Thm.transitive
            (inst [] [m, n] neg_numeral_plus_numeral_a)
            (sub_conv_a n m)
      | ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          transitive'
            (inst [] [m, n] neg_numeral_plus_neg_numeral_a)
            (cong1 (cong1 (args2 add_num_conv)))
      | _ => conv m n
  end;

fun plus_conv' a = norm1_eq a oo plus_conv (plus_neg_conv a) a;

val int_plus_conv = plus_conv' \<^ctyp>\<open>int\<close>;
\<close>

lemma minus_one: "- 1 = - 1" by simp
lemma minus_numeral: "- numeral b = - numeral b" by simp

ML \<open>
fun uminus_conv a =
  let
    val minus_zero_a = inst [a] [] @{thm minus_zero [meta]};
    val minus_one_a = inst [a] [] @{thm minus_one [meta]};
    val minus_numeral_a = inst [a] [] @{thm minus_numeral [meta]};
    val minus_minus_a = inst [a] [] @{thm minus_minus [meta]}
  in
    fn n =>
      case strip_app n of
        (\<^const_name>\<open>zero_class.zero\<close>, []) => minus_zero_a
      | (\<^const_name>\<open>one_class.one\<close>, []) => minus_one_a
      | (\<^const_name>\<open>Num.numeral\<close>, [m]) => inst [] [m] minus_numeral_a
      | (\<^const_name>\<open>uminus\<close>, [m]) => inst [] [m] minus_minus_a
  end;

val int_neg_conv = uminus_conv \<^ctyp>\<open>int\<close>;
\<close>

ML \<open>
fun minus_conv a =
  let
    val [numeral_minus_numeral_a, numeral_minus_neg_numeral_a,
         neg_numeral_minus_numeral_a, neg_numeral_minus_neg_numeral_a] =
      map (inst [a] []) @{thms diff_numeral_simps [meta]};
    val diff_0_a = inst [a] [] @{thm diff_0 [meta]};
    val diff_0_right_a = inst [a] [] @{thm diff_0_right [meta]};
    val sub_conv_a = sub_conv a;
    val uminus_conv_a = uminus_conv a;
    val expand1_a = expand1 a;
    val norm1_eq_a = norm1_eq a;

    fun conv m n = (case (strip_numeral m, strip_numeral n) of
        ((\<^const_name>\<open>zero_class.zero\<close>, []), _) =>
          Thm.transitive (inst [] [n] diff_0_a) (uminus_conv_a n)
      | (_, (\<^const_name>\<open>zero_class.zero\<close>, [])) => inst [] [m] diff_0_right_a
      | ((\<^const_name>\<open>Num.numeral\<close>, [m]), (\<^const_name>\<open>Num.numeral\<close>, [n])) =>
          Thm.transitive
            (inst [] [m, n] numeral_minus_numeral_a)
            (sub_conv_a m n)
      | ((\<^const_name>\<open>Num.numeral\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          transitive'
            (inst [] [m, n] numeral_minus_neg_numeral_a)
            (cong1 (args2 add_num_conv))
      | ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>Num.numeral\<close>, [n])) =>
          transitive'
            (inst [] [m, n] neg_numeral_minus_numeral_a)
            (cong1 (cong1 (args2 add_num_conv)))
      | ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          Thm.transitive
            (inst [] [m, n] neg_numeral_minus_neg_numeral_a)
            (sub_conv_a n m)
      | _ => cong2'' conv (expand1_a m) (expand1_a n))
  in norm1_eq_a oo conv end;

val int_minus_conv = minus_conv \<^ctyp>\<open>int\<close>;
\<close>

ML \<open>
val int_numeral = Thm.apply \<^cterm>\<open>numeral :: num \<Rightarrow> int\<close>;

val nat_minus_refl = Thm.reflexive \<^cterm>\<open>minus :: nat \<Rightarrow> nat \<Rightarrow> nat\<close>;

val expand1_nat = expand1 \<^ctyp>\<open>nat\<close>;

fun nat_minus_conv m n = (case (strip_app m, strip_app n) of
    ((\<^const_name>\<open>zero_class.zero\<close>, []), _) =>
      inst [] [n] @{thm diff_0_eq_0 [meta]}
  | (_, (\<^const_name>\<open>zero_class.zero\<close>, [])) =>
      inst [] [m] @{thm minus_nat.diff_0 [meta]}
  | ((\<^const_name>\<open>numeral\<close>, [m]), (\<^const_name>\<open>numeral\<close>, [n])) =>
      transitive'
        (inst [] [m, n] @{thm diff_nat_numeral [meta]})
        (cong1' nat_conv (args2 int_minus_conv))
  | _ => cong2'' nat_minus_conv (expand1_nat m) (expand1_nat n));
\<close>

ML \<open>
fun mult_num_conv m n = (case (strip_app m, strip_app n) of
    (_, (\<^const_name>\<open>Num.One\<close>, [])) =>
      inst [] [m] @{thm mult_num_simps(1) [meta]}
  | ((\<^const_name>\<open>Num.One\<close>, []), _) =>
      inst [] [n] @{thm mult_num_simps(2) [meta]}
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      transitive'
        (inst [] [m, n] @{thm mult_num_simps(3) [meta]})
        (cong1 (cong1 (args2 mult_num_conv)))
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.Bit1\<close>, [n'])) =>
      transitive'
        (inst [] [m, n'] @{thm mult_num_simps(4) [meta]})
        (cong1 (args2 mult_num_conv))
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m']), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      transitive'
        (inst [] [m', n] @{thm mult_num_simps(5) [meta]})
        (cong1 (args2 mult_num_conv))
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      transitive'
        (inst [] [m, n] @{thm mult_num_simps(6) [meta]})
        (cong1 (cong2' add_num_conv
           (args2 add_num_conv)
           (cong1 (args2 mult_num_conv)))));
\<close>

ML \<open>
fun mult_conv f a =
  let
    val mult_zero_left_a = inst [a] [] @{thm mult_zero_left [meta]};
    val mult_zero_right_a = inst [a] [] @{thm mult_zero_right [meta]};
    val numeral_times_numeral_a = inst [a] [] @{thm numeral_times_numeral [meta]};
    val expand1_a = expand1 a;
    val norm1_eq_a = norm1_eq a;

    fun conv m n = (case (strip_app m, strip_app n) of
        ((\<^const_name>\<open>zero_class.zero\<close>, []), _) => inst [] [n] mult_zero_left_a
      | (_, (\<^const_name>\<open>zero_class.zero\<close>, [])) => inst [] [m] mult_zero_right_a
      | ((\<^const_name>\<open>numeral\<close>, [m]), (\<^const_name>\<open>numeral\<close>, [n])) =>
          transitive'
            (inst [] [m, n] numeral_times_numeral_a)
            (cong1 (args2 mult_num_conv))
      | _ => cong2'' (f conv) (expand1_a m) (expand1_a n))
  in norm1_eq_a oo f conv end;

val nat_mult_conv = mult_conv I \<^ctyp>\<open>nat\<close>;
\<close>

ML \<open>
fun mult_neg_conv a =
  let
    val [neg_numeral_times_neg_numeral_a, neg_numeral_times_numeral_a,
         numeral_times_neg_numeral_a] =
      map (inst [a] []) @{thms mult_neg_numeral_simps [meta]};
  in
    fn conv => fn m => fn n =>
      case (strip_numeral m, strip_numeral n) of
        ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          transitive'
            (inst [] [m, n] neg_numeral_times_neg_numeral_a)
            (cong1 (args2 mult_num_conv))
      | ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>numeral\<close>, [n])) =>
          transitive'
            (inst [] [m, n] neg_numeral_times_numeral_a)
            (cong1 (cong1 (args2 mult_num_conv)))
      | ((\<^const_name>\<open>numeral\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          transitive'
            (inst [] [m, n] numeral_times_neg_numeral_a)
            (cong1 (cong1 (args2 mult_num_conv)))
      | _ => conv m n
  end;

fun mult_conv' a = mult_conv (mult_neg_conv a) a;

val int_mult_conv = mult_conv' \<^ctyp>\<open>int\<close>;
\<close>

ML \<open>
fun eq_num_conv m n = (case (strip_app m, strip_app n) of
    ((\<^const_name>\<open>Num.One\<close>, []), (\<^const_name>\<open>Num.One\<close>, [])) =>
      @{thm eq_num_simps(1) [meta]}
  | ((\<^const_name>\<open>Num.One\<close>, []), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      inst [] [n] @{thm eq_num_simps(2) [meta]}
  | ((\<^const_name>\<open>Num.One\<close>, []), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      inst [] [n] @{thm eq_num_simps(3) [meta]}
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.One\<close>, [])) =>
      inst [] [m] @{thm eq_num_simps(4) [meta]}
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.One\<close>, [])) =>
      inst [] [m] @{thm eq_num_simps(5) [meta]}
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      Thm.transitive
        (inst [] [m, n] @{thm eq_num_simps(6) [meta]})
        (eq_num_conv m n)
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      inst [] [m, n] @{thm eq_num_simps(7) [meta]}
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      inst [] [m, n] @{thm eq_num_simps(8) [meta]}
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      Thm.transitive
        (inst [] [m, n] @{thm eq_num_simps(9) [meta]})
        (eq_num_conv m n));
\<close>

ML \<open>
fun eq_conv f a =
  let
    val zero_eq_zero_a = inst [a] [] @{thm refl [of 0, THEN Eq_TrueI]};
    val zero_neq_numeral_a =
      inst [a] [] @{thm zero_neq_numeral [THEN Eq_FalseI]};
    val numeral_neq_zero_a =
      inst [a] [] @{thm numeral_neq_zero [THEN Eq_FalseI]};
    val numeral_eq_iff_a = inst [a] [] @{thm numeral_eq_iff [meta]};
    val expand1_a = expand1 a;

    fun conv m n = (case (strip_app m, strip_app n) of
        ((\<^const_name>\<open>zero_class.zero\<close>, []), (\<^const_name>\<open>zero_class.zero\<close>, [])) =>
          zero_eq_zero_a
      | ((\<^const_name>\<open>zero_class.zero\<close>, []), (\<^const_name>\<open>numeral\<close>, [n])) =>
          inst [] [n] zero_neq_numeral_a
      | ((\<^const_name>\<open>numeral\<close>, [m]), (\<^const_name>\<open>zero_class.zero\<close>, [])) =>
          inst [] [m] numeral_neq_zero_a
      | ((\<^const_name>\<open>numeral\<close>, [m]), (\<^const_name>\<open>numeral\<close>, [n])) =>
          Thm.transitive
            (inst [] [m, n] numeral_eq_iff_a)
            (eq_num_conv m n)
      | _ => cong2'' (f conv) (expand1_a m) (expand1_a n))
  in f conv end;

val nat_eq_conv = eq_conv I \<^ctyp>\<open>nat\<close>;
\<close>

ML \<open>
fun eq_neg_conv a =
  let
    val neg_numeral_neq_zero_a =
      inst [a] [] @{thm neg_numeral_neq_zero [THEN Eq_FalseI]};
    val zero_neq_neg_numeral_a =
      inst [a] [] @{thm zero_neq_neg_numeral [THEN Eq_FalseI]};
    val neg_numeral_neq_numeral_a =
      inst [a] [] @{thm neg_numeral_neq_numeral [THEN Eq_FalseI]};
    val numeral_neq_neg_numeral_a =
      inst [a] [] @{thm numeral_neq_neg_numeral [THEN Eq_FalseI]};
    val neg_numeral_eq_iff_a = inst [a] [] @{thm neg_numeral_eq_iff [meta]}
  in
    fn conv => fn m => fn n =>
      case (strip_numeral m, strip_numeral n) of
        ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>zero_class.zero\<close>, [])) =>
          inst [] [m] neg_numeral_neq_zero_a
      | ((\<^const_name>\<open>zero_class.zero\<close>, []), (\<^const_name>\<open>uminus\<close>, [n])) =>
          inst [] [n] zero_neq_neg_numeral_a
      | ((\<^const_name>\<open>Num.numeral\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          inst [] [m, n] numeral_neq_neg_numeral_a
      | ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>Num.numeral\<close>, [n])) =>
          inst [] [m, n] neg_numeral_neq_numeral_a
      | ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          Thm.transitive
            (inst [] [m, n] neg_numeral_eq_iff_a)
            (eq_num_conv m n)
      | _ => conv m n
  end;

fun eq_conv' a = eq_conv (eq_neg_conv a) a;

val int_eq_conv = eq_conv' \<^ctyp>\<open>int\<close>;
\<close>

ML \<open>
fun le_num_conv m n = (case (strip_app m, strip_app n) of
    ((\<^const_name>\<open>Num.One\<close>, []), _) =>
      inst [] [n] @{thm le_num_simps(1) [meta]}
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.One\<close>, [])) =>
      inst [] [m] @{thm le_num_simps(2) [meta]}
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.One\<close>, [])) =>
      inst [] [m] @{thm le_num_simps(3) [meta]}
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      Thm.transitive
        (inst [] [m, n] @{thm le_num_simps(4) [meta]})
        (le_num_conv m n)
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      Thm.transitive
        (inst [] [m, n] @{thm le_num_simps(5) [meta]})
        (le_num_conv m n)
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      Thm.transitive
        (inst [] [m, n] @{thm le_num_simps(6) [meta]})
        (le_num_conv m n)
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      Thm.transitive
        (inst [] [m, n] @{thm le_num_simps(7) [meta]})
        (less_num_conv m n))

and less_num_conv m n = (case (strip_app m, strip_app n) of
    (_, (\<^const_name>\<open>Num.One\<close>, [])) =>
      inst [] [m] @{thm less_num_simps(1) [meta]}
  | ((\<^const_name>\<open>Num.One\<close>, []), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      inst [] [n] @{thm less_num_simps(2) [meta]}
  | ((\<^const_name>\<open>Num.One\<close>, []), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      inst [] [n] @{thm less_num_simps(3) [meta]}
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      Thm.transitive
        (inst [] [m, n] @{thm less_num_simps(4) [meta]})
        (less_num_conv m n)
  | ((\<^const_name>\<open>Num.Bit0\<close>, [m]), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      Thm.transitive
        (inst [] [m, n] @{thm less_num_simps(5) [meta]})
        (le_num_conv m n)
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.Bit1\<close>, [n])) =>
      Thm.transitive
        (inst [] [m, n] @{thm less_num_simps(6) [meta]})
        (less_num_conv m n)
  | ((\<^const_name>\<open>Num.Bit1\<close>, [m]), (\<^const_name>\<open>Num.Bit0\<close>, [n])) =>
      Thm.transitive
        (inst [] [m, n] @{thm less_num_simps(7) [meta]})
        (less_num_conv m n));
\<close>

ML \<open>
fun le_conv f a =
  let
    val zero_le_zero_a = inst [a] [] @{thm order_refl [of 0, THEN Eq_TrueI]};
    val zero_le_numeral_a =
      inst [a] [] @{thm zero_le_numeral [THEN Eq_TrueI]};
    val not_numeral_le_zero_a =
      inst [a] [] @{thm not_numeral_le_zero [THEN Eq_FalseI]};
    val numeral_le_iff_a = inst [a] [] @{thm numeral_le_iff [meta]};
    val expand1_a = expand1 a;

    fun conv m n = (case (strip_app m, strip_app n) of
        ((\<^const_name>\<open>zero_class.zero\<close>, []), (\<^const_name>\<open>zero_class.zero\<close>, [])) =>
          zero_le_zero_a
      | ((\<^const_name>\<open>zero_class.zero\<close>, []), (\<^const_name>\<open>numeral\<close>, [n])) =>
          inst [] [n] zero_le_numeral_a
      | ((\<^const_name>\<open>numeral\<close>, [m]), (\<^const_name>\<open>zero_class.zero\<close>, [])) =>
          inst [] [m] not_numeral_le_zero_a
      | ((\<^const_name>\<open>numeral\<close>, [m]), (\<^const_name>\<open>numeral\<close>, [n])) =>
          Thm.transitive
            (inst [] [m, n] numeral_le_iff_a)
            (le_num_conv m n)
      | _ => cong2'' (f conv) (expand1_a m) (expand1_a n))
  in f conv end;

val nat_le_conv = le_conv I \<^ctyp>\<open>nat\<close>;
\<close>

ML \<open>
fun le_neg_conv a =
  let
    val neg_numeral_le_zero_a =
      inst [a] [] @{thm neg_numeral_le_zero [THEN Eq_TrueI]};
    val not_zero_le_neg_numeral_a =
      inst [a] [] @{thm not_zero_le_neg_numeral [THEN Eq_FalseI]};
    val neg_numeral_le_numeral_a =
      inst [a] [] @{thm neg_numeral_le_numeral [THEN Eq_TrueI]};
    val not_numeral_le_neg_numeral_a =
      inst [a] [] @{thm not_numeral_le_neg_numeral [THEN Eq_FalseI]};
    val neg_numeral_le_iff_a = inst [a] [] @{thm neg_numeral_le_iff [meta]}
  in
    fn conv => fn m => fn n =>
      case (strip_numeral m, strip_numeral n) of
        ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>zero_class.zero\<close>, [])) =>
          inst [] [m] neg_numeral_le_zero_a
      | ((\<^const_name>\<open>zero_class.zero\<close>, []), (\<^const_name>\<open>uminus\<close>, [n])) =>
          inst [] [n] not_zero_le_neg_numeral_a
      | ((\<^const_name>\<open>Num.numeral\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          inst [] [m, n] not_numeral_le_neg_numeral_a
      | ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>Num.numeral\<close>, [n])) =>
          inst [] [m, n] neg_numeral_le_numeral_a
      | ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          Thm.transitive
            (inst [] [m, n] neg_numeral_le_iff_a)
            (le_num_conv n m)
      | _ => conv m n
  end;

fun le_conv' a = le_conv (le_neg_conv a) a;

val int_le_conv = le_conv' \<^ctyp>\<open>int\<close>;
\<close>

ML \<open>
fun less_conv f a =
  let
    val not_zero_less_zero_a = inst [a] [] @{thm less_irrefl [of 0, THEN Eq_FalseI]};
    val zero_less_numeral_a =
      inst [a] [] @{thm zero_less_numeral [THEN Eq_TrueI]};
    val not_numeral_less_zero_a =
      inst [a] [] @{thm not_numeral_less_zero [THEN Eq_FalseI]};
    val numeral_less_iff_a = inst [a] [] @{thm numeral_less_iff [meta]};
    val expand1_a = expand1 a;

    fun conv m n = (case (strip_app m, strip_app n) of
        ((\<^const_name>\<open>zero_class.zero\<close>, []), (\<^const_name>\<open>zero_class.zero\<close>, [])) =>
          not_zero_less_zero_a
      | ((\<^const_name>\<open>zero_class.zero\<close>, []), (\<^const_name>\<open>numeral\<close>, [n])) =>
          inst [] [n] zero_less_numeral_a
      | ((\<^const_name>\<open>numeral\<close>, [m]), (\<^const_name>\<open>zero_class.zero\<close>, [])) =>
          inst [] [m] not_numeral_less_zero_a
      | ((\<^const_name>\<open>numeral\<close>, [m]), (\<^const_name>\<open>numeral\<close>, [n])) =>
          Thm.transitive
            (inst [] [m, n] numeral_less_iff_a)
            (less_num_conv m n)
      | _ => cong2'' (f conv) (expand1_a m) (expand1_a n))
  in f conv end;

val nat_less_conv = less_conv I \<^ctyp>\<open>nat\<close>;
\<close>

ML \<open>
fun less_neg_conv a =
  let
    val neg_numeral_less_zero_a =
      inst [a] [] @{thm neg_numeral_less_zero [THEN Eq_TrueI]};
    val not_zero_less_neg_numeral_a =
      inst [a] [] @{thm not_zero_less_neg_numeral [THEN Eq_FalseI]};
    val neg_numeral_less_numeral_a =
      inst [a] [] @{thm neg_numeral_less_numeral [THEN Eq_TrueI]};
    val not_numeral_less_neg_numeral_a =
      inst [a] [] @{thm not_numeral_less_neg_numeral [THEN Eq_FalseI]};
    val neg_numeral_less_iff_a = inst [a] [] @{thm neg_numeral_less_iff [meta]}
  in
    fn conv => fn m => fn n =>
      case (strip_numeral m, strip_numeral n) of
        ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>zero_class.zero\<close>, [])) =>
          inst [] [m] neg_numeral_less_zero_a
      | ((\<^const_name>\<open>zero_class.zero\<close>, []), (\<^const_name>\<open>uminus\<close>, [n])) =>
          inst [] [n] not_zero_less_neg_numeral_a
      | ((\<^const_name>\<open>Num.numeral\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          inst [] [m, n] not_numeral_less_neg_numeral_a
      | ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>Num.numeral\<close>, [n])) =>
          inst [] [m, n] neg_numeral_less_numeral_a
      | ((\<^const_name>\<open>uminus\<close>, [m]), (\<^const_name>\<open>uminus\<close>, [n])) =>
          Thm.transitive
            (inst [] [m, n] neg_numeral_less_iff_a)
            (less_num_conv n m)
      | _ => conv m n
  end;

fun less_conv' a = less_conv (less_neg_conv a) a;

val int_less_conv = less_conv' \<^ctyp>\<open>int\<close>;
\<close>

ML \<open>
fun If_conv a =
  let
    val if_True = inst [a] [] @{thm if_True [meta]};
    val if_False = inst [a] [] @{thm if_False [meta]}
  in
    fn p => fn x => fn y => fn ct =>
      case strip_app ct of
        (\<^const_name>\<open>If\<close>, [cb, cx, cy]) =>
          let
            val p_eq = p cb
            val eq = Thm.combination (Thm.reflexive (Thm.dest_fun (Thm.dest_fun2 ct))) p_eq
          in
            case Thm.term_of (Thm.rhs_of p_eq) of
              \<^Const_>\<open>True\<close> =>
                let
                  val x_eq = x cx;
                  val cx = Thm.rhs_of x_eq;
                in
                  Thm.transitive
                    (Thm.combination
                       (Thm.combination eq x_eq)
                       (Thm.reflexive cy))
                    (inst [] [cx, cy] if_True)
                end
            | \<^Const_>\<open>False\<close> =>
                let
                  val y_eq = y cy;
                  val cy = Thm.rhs_of y_eq;
                in
                  Thm.transitive
                    (Thm.combination
                       (Thm.combination eq (Thm.reflexive cx))
                       y_eq)
                    (inst [] [cx, cy] if_False)
                end
            | _ => err "If_conv" (Thm.rhs_of p_eq)
          end
  end;
\<close>

ML \<open>
fun drop_conv a =
  let
    val drop_0_a = inst [a] [] @{thm drop_0 [meta]};
    val drop_Cons_a = inst [a] [] @{thm drop_Cons' [meta]};
    val If_conv_a = If_conv (type_of_eqn drop_0_a);

    fun conv n ys = (case Thm.term_of n of
        \<^Const_>\<open>zero_class.zero _\<close> => inst [] [ys] drop_0_a
      | _ => (case strip_app ys of
          (\<^const_name>\<open>Cons\<close>, [x, xs]) =>
            transitive'
              (inst [] [n, x, xs] drop_Cons_a)
              (If_conv_a (args2 nat_eq_conv)
                 Thm.reflexive
                 (cong2' conv (args2 nat_minus_conv) Thm.reflexive))))
  in conv end;
\<close>

ML \<open>
fun nth_conv a =
  let
    val nth_Cons_a = inst [a] [] @{thm nth_Cons' [meta]};
    val If_conv_a = If_conv a;

    fun conv ys n = (case strip_app ys of
        (\<^const_name>\<open>Cons\<close>, [x, xs]) =>
          transitive'
            (inst [] [x, xs, n] nth_Cons_a)
            (If_conv_a (args2 nat_eq_conv)
               Thm.reflexive
               (cong2' conv Thm.reflexive (args2 nat_minus_conv))))
  in conv end;
\<close>

end


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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3acc :: "Nat => Nat => Nat => Nat" where
  "add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
  "mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3acc
            (mul3acc x2 x3 x4)
            (add3acc
               (mul3acc (S Z) x3 x4) (mul3acc x2 (S Z) x4) (mul3acc x2 x3 (S Z)))
            (add3acc (S x2) (S x3) (S x4)))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3acc x1 (mul3acc x2 x3acc x4) x5) =
      (mul3acc x1 x2 (mul3acc x3acc x4 x5)))"
  oops

end


(*  Title:      HOL/Option.thy
    Author:     Folklore
*)

section \<open>Datatype option\<close>

theory Option
imports Lifting Finite_Set
begin

datatype 'a option =
    None
  | Some (the: 'a)

datatype_compat option

lemma [case_names None Some, cases type: option]:
  \<comment> \<open>for backward compatibility -- names of variables differ\<close>
  "(y = None \<Longrightarrow> P) \<Longrightarrow> (\<And>a. y = Some a \<Longrightarrow> P) \<Longrightarrow> P"
  by (rule option.exhaust)

lemma [case_names None Some, induct type: option]:
  \<comment> \<open>for backward compatibility -- names of variables differ\<close>
  "P None \<Longrightarrow> (\<And>option. P (Some option)) \<Longrightarrow> P option"
  by (rule option.induct)

text \<open>Compatibility:\<close>
setup \<open>Sign.mandatory_path "option"\<close>
lemmas inducts = option.induct
lemmas cases = option.case
setup \<open>Sign.parent_path\<close>

lemma not_None_eq [iff]: "x \<noteq> None \<longleftrightarrow> (\<exists>y. x = Some y)"
  by (induct x) auto

lemma not_Some_eq [iff]: "(\<forall>y. x \<noteq> Some y) \<longleftrightarrow> x = None"
  by (induct x) auto

text \<open>Although it may appear that both of these equalities are helpful
only when applied to assumptions, in practice it seems better to give
them the uniform iff attribute.\<close>

lemma inj_Some [simp]: "inj_on Some A"
  by (rule inj_onI) simp

lemma case_optionE:
  assumes c: "(case x of None \<Rightarrow> P | Some y \<Rightarrow> Q y)"
  obtains
    (None) "x = None" and P
  | (Some) y where "x = Some y" and "Q y"
  using c by (cases x) simp_all

lemma split_option_all: "(\<forall>x. P x) \<longleftrightarrow> P None \<and> (\<forall>x. P (Some x))"
  by (auto intro: option.induct)

lemma split_option_ex: "(\<exists>x. P x) \<longleftrightarrow> P None \<or> (\<exists>x. P (Some x))"
  using split_option_all[of "\<lambda>x. \<not> P x"] by blast

lemma UNIV_option_conv: "UNIV = insert None (range Some)"
  by (auto intro: classical)

lemma rel_option_None1 [simp]: "rel_option P None x \<longleftrightarrow> x = None"
  by (cases x) simp_all

lemma rel_option_None2 [simp]: "rel_option P x None \<longleftrightarrow> x = None"
  by (cases x) simp_all

lemma option_rel_Some1: "rel_option A (Some x) y \<longleftrightarrow> (\<exists>y'. y = Some y' \<and> A x y')" (* Option *)
by(cases y) simp_all

lemma option_rel_Some2: "rel_option A x (Some y) \<longleftrightarrow> (\<exists>x'. x = Some x' \<and> A x' y)" (* Option *)
by(cases x) simp_all

lemma rel_option_inf: "inf (rel_option A) (rel_option B) = rel_option (inf A B)"
  (is "?lhs = ?rhs")
proof (rule antisym)
  show "?lhs \<le> ?rhs" by (auto elim: option.rel_cases)
  show "?rhs \<le> ?lhs" by (auto elim: option.rel_mono_strong)
qed

lemma rel_option_reflI:
  "(\<And>x. x \<in> set_option y \<Longrightarrow> P x x) \<Longrightarrow> rel_option P y y"
  by (cases y) auto

subsubsection \<open>Operations\<close>

lemma ospec [dest]: "(\<forall>x\<in>set_option A. P x) \<Longrightarrow> A = Some x \<Longrightarrow> P x"
  by simp

setup \<open>map_theory_claset (fn ctxt => ctxt addSD2 ("ospec", @{thm ospec}))\<close>

lemma elem_set [iff]: "(x \<in> set_option xo) = (xo = Some x)"
  by (cases xo) auto

lemma set_empty_eq [simp]: "(set_option xo = {}) = (xo = None)"
  by (cases xo) auto

lemma map_option_case: "map_option f y = (case y of None \<Rightarrow> None | Some x \<Rightarrow> Some (f x))"
  by (auto split: option.split)

lemma map_option_is_None [iff]: "(map_option f opt = None) = (opt = None)"
  by (simp add: map_option_case split: option.split)

lemma None_eq_map_option_iff [iff]: "None = map_option f x \<longleftrightarrow> x = None"
by(cases x) simp_all

lemma map_option_eq_Some [iff]: "(map_option f xo = Some y) = (\<exists>z. xo = Some z \<and> f z = y)"
  by (simp add: map_option_case split: option.split)

lemma map_option_o_case_sum [simp]:
    "map_option f o case_sum g h = case_sum (map_option f o g) (map_option f o h)"
  by (rule o_case_sum)

lemma map_option_cong: "x = y \<Longrightarrow> (\<And>a. y = Some a \<Longrightarrow> f a = g a) \<Longrightarrow> map_option f x = map_option g y"
  by (cases x) auto

lemma map_option_idI: "(\<And>y. y \<in> set_option x \<Longrightarrow> f y = y) \<Longrightarrow> map_option f x = x"
by(cases x)(simp_all)

functor map_option: map_option
  by (simp_all add: option.map_comp fun_eq_iff option.map_id)

lemma case_map_option [simp]: "case_option g h (map_option f x) = case_option g (h \<circ> f) x"
  by (cases x) simp_all

lemma None_notin_image_Some [simp]: "None \<notin> Some ` A"
by auto

lemma notin_range_Some: "x \<notin> range Some \<longleftrightarrow> x = None"
by(cases x) auto

lemma rel_option_iff:
  "rel_option R x y = (case (x, y) of (None, None) \<Rightarrow> True
    | (Some x, Some y) \<Rightarrow> R x y
    | _ \<Rightarrow> False)"
  by (auto split: prod.split option.split)

definition combine_options :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> 'a option"
  where "combine_options f x y =
           (case x of None \<Rightarrow> y | Some x \<Rightarrow> (case y of None \<Rightarrow> Some x | Some y \<Rightarrow> Some (f x y)))"

lemma combine_options_simps [simp]:
  "combine_options f None y = y"
  "combine_options f x None = x"
  "combine_options f (Some a) (Some b) = Some (f a b)"
  by (simp_all add: combine_options_def split: option.splits)

lemma combine_options_cases [case_names None1 None2 Some]:
  "(x = None \<Longrightarrow> P x y) \<Longrightarrow> (y = None \<Longrightarrow> P x y) \<Longrightarrow>
     (\<And>a b. x = Some a \<Longrightarrow> y = Some b \<Longrightarrow> P x y) \<Longrightarrow> P x y"
  by (cases x; cases y) simp_all

lemma combine_options_commute:
  "(\<And>x y. f x y = f y x) \<Longrightarrow> combine_options f x y = combine_options f y x"
  using combine_options_cases[of x ]
  by (induction x y rule: combine_options_cases) simp_all

lemma combine_options_assoc:
  "(\<And>x y z. f (f x y) z = f x (f y z)) \<Longrightarrow>
     combine_options f (combine_options f x y) z =
     combine_options f x (combine_options f y z)"
  by (auto simp: combine_options_def split: option.splits)

lemma combine_options_left_commute:
  "(\<And>x y. f x y = f y x) \<Longrightarrow> (\<And>x y z. f (f x y) z = f x (f y z)) \<Longrightarrow>
     combine_options f y (combine_options f x z) =
     combine_options f x (combine_options f y z)"
  by (auto simp: combine_options_def split: option.splits)

lemmas combine_options_ac =
  combine_options_commute combine_options_assoc combine_options_left_commute

context
begin

qualified definition is_none :: "'a option \<Rightarrow> bool"
  where [code_post]: "is_none x \<longleftrightarrow> x = None"

lemma is_none_simps [simp]:
  "is_none None"
  "\<not> is_none (Some x)"
  by (simp_all add: is_none_def)

lemma is_none_code [code]:
  "is_none None = True"
  "is_none (Some x) = False"
  by simp_all

lemma rel_option_unfold:
  "rel_option R x y \<longleftrightarrow>
   (is_none x \<longleftrightarrow> is_none y) \<and> (\<not> is_none x \<longrightarrow> \<not> is_none y \<longrightarrow> R (the x) (the y))"
  by (simp add: rel_option_iff split: option.split)

lemma rel_optionI:
  "\<lbrakk> is_none x \<longleftrightarrow> is_none y; \<lbrakk> \<not> is_none x; \<not> is_none y \<rbrakk> \<Longrightarrow> P (the x) (the y) \<rbrakk>
  \<Longrightarrow> rel_option P x y"
  by (simp add: rel_option_unfold)

lemma is_none_map_option [simp]: "is_none (map_option f x) \<longleftrightarrow> is_none x"
  by (simp add: is_none_def)

lemma the_map_option: "\<not> is_none x \<Longrightarrow> the (map_option f x) = f (the x)"
  by (auto simp add: is_none_def)

qualified primrec bind :: "'a option \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> 'b option"
where
  bind_lzero: "bind None f = None"
| bind_lunit: "bind (Some x) f = f x"

lemma is_none_bind: "is_none (bind f g) \<longleftrightarrow> is_none f \<or> is_none (g (the f))"
  by (cases f) simp_all

lemma bind_runit[simp]: "bind x Some = x"
  by (cases x) auto

lemma bind_assoc[simp]: "bind (bind x f) g = bind x (\<lambda>y. bind (f y) g)"
  by (cases x) auto

lemma bind_rzero[simp]: "bind x (\<lambda>x. None) = None"
  by (cases x) auto

qualified lemma bind_cong: "x = y \<Longrightarrow> (\<And>a. y = Some a \<Longrightarrow> f a = g a) \<Longrightarrow> bind x f = bind y g"
  by (cases x) auto

lemma bind_split: "P (bind m f) \<longleftrightarrow> (m = None \<longrightarrow> P None) \<and> (\<forall>v. m = Some v \<longrightarrow> P (f v))"
  by (cases m) auto

lemma bind_split_asm: "P (bind m f) \<longleftrightarrow> \<not> (m = None \<and> \<not> P None \<or> (\<exists>x. m = Some x \<and> \<not> P (f x)))"
  by (cases m) auto

lemmas bind_splits = bind_split bind_split_asm

lemma bind_eq_Some_conv: "bind f g = Some x \<longleftrightarrow> (\<exists>y. f = Some y \<and> g y = Some x)"
  by (cases f) simp_all

lemma bind_eq_None_conv: "Option.bind a f = None \<longleftrightarrow> a = None \<or> f (the a) = None"
by(cases a) simp_all

lemma map_option_bind: "map_option f (bind x g) = bind x (map_option f \<circ> g)"
  by (cases x) simp_all

lemma bind_option_cong:
  "\<lbrakk> x = y; \<And>z. z \<in> set_option y \<Longrightarrow> f z = g z \<rbrakk> \<Longrightarrow> bind x f = bind y g"
  by (cases y) simp_all

lemma bind_option_cong_simp:
  "\<lbrakk> x = y; \<And>z. z \<in> set_option y =simp=> f z = g z \<rbrakk> \<Longrightarrow> bind x f = bind y g"
  unfolding simp_implies_def by (rule bind_option_cong)

lemma bind_option_cong_code: "x = y \<Longrightarrow> bind x f = bind y f"
  by simp

lemma bind_map_option: "bind (map_option f x) g = bind x (g \<circ> f)"
by(cases x) simp_all

lemma set_bind_option [simp]: "set_option (bind x f) = UNION (set_option x) (set_option \<circ> f)"
by(cases x) auto

lemma map_conv_bind_option: "map_option f x = Option.bind x (Some \<circ> f)"
by(cases x) simp_all

end

setup \<open>Code_Simp.map_ss (Simplifier.add_cong @{thm bind_option_cong_code})\<close>

context
begin

qualified definition these :: "'a option set \<Rightarrow> 'a set"
  where "these A = the ` {x \<in> A. x \<noteq> None}"

lemma these_empty [simp]: "these {} = {}"
  by (simp add: these_def)

lemma these_insert_None [simp]: "these (insert None A) = these A"
  by (auto simp add: these_def)

lemma these_insert_Some [simp]: "these (insert (Some x) A) = insert x (these A)"
proof -
  have "{y \<in> insert (Some x) A. y \<noteq> None} = insert (Some x) {y \<in> A. y \<noteq> None}"
    by auto
  then show ?thesis by (simp add: these_def)
qed

lemma in_these_eq: "x \<in> these A \<longleftrightarrow> Some x \<in> A"
proof
  assume "Some x \<in> A"
  then obtain B where "A = insert (Some x) B" by auto
  then show "x \<in> these A" by (auto simp add: these_def intro!: image_eqI)
next
  assume "x \<in> these A"
  then show "Some x \<in> A" by (auto simp add: these_def)
qed

lemma these_image_Some_eq [simp]: "these (Some ` A) = A"
  by (auto simp add: these_def intro!: image_eqI)

lemma Some_image_these_eq: "Some ` these A = {x\<in>A. x \<noteq> None}"
  by (auto simp add: these_def image_image intro!: image_eqI)

lemma these_empty_eq: "these B = {} \<longleftrightarrow> B = {} \<or> B = {None}"
  by (auto simp add: these_def)

lemma these_not_empty_eq: "these B \<noteq> {} \<longleftrightarrow> B \<noteq> {} \<and> B \<noteq> {None}"
  by (auto simp add: these_empty_eq)

end

subsection \<open>Transfer rules for the Transfer package\<close>

context includes lifting_syntax
begin

lemma option_bind_transfer [transfer_rule]:
  "(rel_option A ===> (A ===> rel_option B) ===> rel_option B)
    Option.bind Option.bind"
  unfolding rel_fun_def split_option_all by simp

lemma pred_option_parametric [transfer_rule]:
  "((A ===> op =) ===> rel_option A ===> op =) pred_option pred_option"
  by (rule rel_funI)+ (auto simp add: rel_option_unfold Option.is_none_def dest: rel_funD)

end

subsubsection \<open>Interaction with finite sets\<close>

lemma finite_option_UNIV [simp]:
  "finite (UNIV :: 'a option set) = finite (UNIV :: 'a set)"
  by (auto simp add: UNIV_option_conv elim: finite_imageD intro: inj_Some)

instance option :: (finite) finite
  by standard (simp add: UNIV_option_conv)

subsubsection \<open>Code generator setup\<close>

lemma equal_None_code_unfold [code_unfold]:
  "HOL.equal x None \<longleftrightarrow> Option.is_none x"
  "HOL.equal None = Option.is_none"
  by (auto simp add: equal Option.is_none_def)

code_printing
  type_constructor option \<rightharpoonup>
    (SML) "_ option"
    and (OCaml) "_ option"
    and (Haskell) "Maybe _"
    and (Scala) "!Option[(_)]"
| constant None \<rightharpoonup>
    (SML) "NONE"
    and (OCaml) "None"
    and (Haskell) "Nothing"
    and (Scala) "!None"
| constant Some \<rightharpoonup>
    (SML) "SOME"
    and (OCaml) "Some _"
    and (Haskell) "Just"
    and (Scala) "Some"
| class_instance option :: equal \<rightharpoonup>
    (Haskell) -
| constant "HOL.equal :: 'a option \<Rightarrow> 'a option \<Rightarrow> bool" \<rightharpoonup>
    (Haskell) infix 4 "=="

code_reserved SML
  option NONE SOME

code_reserved OCaml
  option None Some

code_reserved Scala
  Option None Some

end


section \<open>\isaheader{Implementation of Priority Queues by Skew Binomial Heaps}\<close>

theory SkewPrioImpl
imports
  "Binomial-Heaps.SkewBinomialHeap"
  "../spec/PrioSpec"
  "../tools/Record_Intf"
  "../tools/Locale_Code"
begin

(*@impl Prio
  @type ('a,'p::linorder) skew
  @abbrv skew
  Priority queues by skew binomial heaps.
*)

subsection "Definitions"
type_synonym ('a,'b) skew = "('a, 'b) SkewBinomialHeap"

definition skew_\<alpha> where "skew_\<alpha> q \<equiv> SkewBinomialHeap.to_mset q"
definition skew_insert where "skew_insert \<equiv> SkewBinomialHeap.insert"
abbreviation (input) skew_invar :: "('a, 'b) SkewBinomialHeap \<Rightarrow> bool"
  where "skew_invar \<equiv> \<lambda>_. True"
definition skew_find where "skew_find \<equiv> SkewBinomialHeap.findMin"
definition skew_delete where "skew_delete \<equiv> SkewBinomialHeap.deleteMin"
definition skew_meld where "skew_meld \<equiv> SkewBinomialHeap.meld"
definition skew_empty where "skew_empty \<equiv> \<lambda>_::unit. SkewBinomialHeap.empty"
definition skew_isEmpty where "skew_isEmpty = SkewBinomialHeap.isEmpty"

definition [icf_rec_def]: "skew_ops == \<lparr>
  prio_op_\<alpha> = skew_\<alpha>,
  prio_op_invar = skew_invar,
  prio_op_empty = skew_empty,
  prio_op_isEmpty = skew_isEmpty,
  prio_op_insert = skew_insert,
  prio_op_find = skew_find,
  prio_op_delete = skew_delete,
  prio_op_meld = skew_meld
\<rparr>"

lemmas skew_defs =
  skew_\<alpha>_def
  skew_insert_def
  skew_find_def
  skew_delete_def
  skew_meld_def
  skew_empty_def
  skew_isEmpty_def

subsection "Correctness"

theorem skew_empty_impl: "prio_empty skew_\<alpha> skew_invar skew_empty"
  by (unfold_locales, auto simp add: skew_defs)

theorem skew_isEmpty_impl: "prio_isEmpty skew_\<alpha> skew_invar skew_isEmpty"
  by unfold_locales
     (simp add: skew_defs SkewBinomialHeap.isEmpty_correct SkewBinomialHeap.empty_correct)

theorem skew_find_impl: "prio_find skew_\<alpha> skew_invar skew_find"
  apply unfold_locales
  apply (simp add: skew_defs SkewBinomialHeap.empty_correct SkewBinomialHeap.findMin_correct)
  done

lemma skew_insert_impl: "prio_insert skew_\<alpha> skew_invar skew_insert"
  apply(unfold_locales)
  apply(unfold skew_defs)
  apply (simp_all add: SkewBinomialHeap.insert_correct)
  done

lemma skew_meld_impl: "prio_meld skew_\<alpha> skew_invar skew_meld"
  apply(unfold_locales)
  apply(unfold skew_defs)
  apply(simp_all add: SkewBinomialHeap.meld_correct)
  done

lemma skew_delete_impl:
  "prio_delete skew_\<alpha> skew_invar skew_find skew_delete"
  apply intro_locales
  apply (rule skew_find_impl)
  apply(unfold_locales)
  apply(simp_all add: skew_defs SkewBinomialHeap.empty_correct SkewBinomialHeap.deleteMin_correct)
done

setup Locale_Code.open_block
interpretation skew: StdPrio skew_ops
  apply (rule StdPrio.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule
    skew_empty_impl
    skew_isEmpty_impl
    skew_find_impl
    skew_insert_impl
    skew_meld_impl
    skew_delete_impl
  )+
  done
interpretation skew: StdPrio_no_invar skew_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

definition test_codegen where "test_codegen \<equiv> (
  skew.empty,
  skew.isEmpty,
  skew.find,
  skew.insert,
  skew.meld,
  skew.delete
)"

export_code test_codegen checking SML

end


(* Author: Andreas Lochbihler, ETH Zürich
   Author: Florian Haftmann, TU Muenchen  *)

section \<open>Less common functions on lists\<close>

theory More_List
imports Main
begin

definition strip_while :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "strip_while P = rev \<circ> dropWhile P \<circ> rev"

lemma strip_while_rev [simp]:
  "strip_while P (rev xs) = rev (dropWhile P xs)"
  by (simp add: strip_while_def)

lemma strip_while_Nil [simp]:
  "strip_while P [] = []"
  by (simp add: strip_while_def)

lemma strip_while_append [simp]:
  "\<not> P x \<Longrightarrow> strip_while P (xs @ [x]) = xs @ [x]"
  by (simp add: strip_while_def)

lemma strip_while_append_rec [simp]:
  "P x \<Longrightarrow> strip_while P (xs @ [x]) = strip_while P xs"
  by (simp add: strip_while_def)

lemma strip_while_Cons [simp]:
  "\<not> P x \<Longrightarrow> strip_while P (x # xs) = x # strip_while P xs"
  by (induct xs rule: rev_induct) (simp_all add: strip_while_def)

lemma strip_while_eq_Nil [simp]:
  "strip_while P xs = [] \<longleftrightarrow> (\<forall>x\<in>set xs. P x)"
  by (simp add: strip_while_def)

lemma strip_while_eq_Cons_rec:
  "strip_while P (x # xs) = x # strip_while P xs \<longleftrightarrow> \<not> (P x \<and> (\<forall>x\<in>set xs. P x))"
  by (induct xs rule: rev_induct) (simp_all add: strip_while_def)

lemma split_strip_while_append:
  fixes xs :: "'a list"
  obtains ys zs :: "'a list"
  where "strip_while P xs = ys" and "\<forall>x\<in>set zs. P x" and "xs = ys @ zs"
proof (rule that)
  show "strip_while P xs = strip_while P xs" ..
  show "\<forall>x\<in>set (rev (takeWhile P (rev xs))). P x" by (simp add: takeWhile_eq_all_conv [symmetric])
  have "rev xs = rev (strip_while P xs @ rev (takeWhile P (rev xs)))"
    by (simp add: strip_while_def)
  then show "xs = strip_while P xs @ rev (takeWhile P (rev xs))"
    by (simp only: rev_is_rev_conv)
qed

lemma strip_while_snoc [simp]:
  "strip_while P (xs @ [x]) = (if P x then strip_while P xs else xs @ [x])"
  by (simp add: strip_while_def)

lemma strip_while_map:
  "strip_while P (map f xs) = map f (strip_while (P \<circ> f) xs)"
  by (simp add: strip_while_def rev_map dropWhile_map)

lemma strip_while_dropWhile_commute:
  "strip_while P (dropWhile Q xs) = dropWhile Q (strip_while P xs)"
proof (induct xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons x xs)
  show ?case
  proof (cases "\<forall>y\<in>set xs. P y")
    case True
    with dropWhile_append2 [of "rev xs"] show ?thesis
      by (auto simp add: strip_while_def dest: set_dropWhileD)
  next
    case False
    then obtain y where "y \<in> set xs" and "\<not> P y"
      by blast
    with Cons dropWhile_append3 [of P y "rev xs"] show ?thesis
      by (simp add: strip_while_def)
  qed
qed

lemma dropWhile_strip_while_commute:
  "dropWhile P (strip_while Q xs) = strip_while Q (dropWhile P xs)"
  by (simp add: strip_while_dropWhile_commute)

definition no_leading :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "no_leading P xs \<longleftrightarrow> (xs \<noteq> [] \<longrightarrow> \<not> P (hd xs))"

lemma no_leading_Nil [iff]:
  "no_leading P []"
  by (simp add: no_leading_def)

lemma no_leading_Cons [iff]:
  "no_leading P (x # xs) \<longleftrightarrow> \<not> P x"
  by (simp add: no_leading_def)

lemma no_leading_append [simp]:
  "no_leading P (xs @ ys) \<longleftrightarrow> no_leading P xs \<and> (xs = [] \<longrightarrow> no_leading P ys)"
  by (induct xs) simp_all

lemma no_leading_dropWhile [simp]:
  "no_leading P (dropWhile P xs)"
  by (induct xs) simp_all

lemma dropWhile_eq_obtain_leading:
  assumes "dropWhile P xs = ys"
  obtains zs where "xs = zs @ ys" and "\<And>z. z \<in> set zs \<Longrightarrow> P z" and "no_leading P ys"
proof -
  from assms have "\<exists>zs. xs = zs @ ys \<and> (\<forall>z \<in> set zs. P z) \<and> no_leading P ys"
  proof (induct xs arbitrary: ys)
    case Nil then show ?case by simp
  next
    case (Cons x xs ys)
    show ?case proof (cases "P x")
      case True with Cons.hyps [of ys] Cons.prems
      have "\<exists>zs. xs = zs @ ys \<and> (\<forall>a\<in>set zs. P a) \<and> no_leading P ys"
        by simp
      then obtain zs where "xs = zs @ ys" and "\<And>z. z \<in> set zs \<Longrightarrow> P z"
        and *: "no_leading P ys"
        by blast
      with True have "x # xs = (x # zs) @ ys" and "\<And>z. z \<in> set (x # zs) \<Longrightarrow> P z"
        by auto
      with * show ?thesis
        by blast    next
      case False
      with Cons show ?thesis by (cases ys) simp_all
    qed
  qed
  with that show thesis
    by blast
qed

lemma dropWhile_idem_iff:
  "dropWhile P xs = xs \<longleftrightarrow> no_leading P xs"
  by (cases xs) (auto elim: dropWhile_eq_obtain_leading)

abbreviation no_trailing :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "no_trailing P xs \<equiv> no_leading P (rev xs)"

lemma no_trailing_unfold:
  "no_trailing P xs \<longleftrightarrow> (xs \<noteq> [] \<longrightarrow> \<not> P (last xs))"
  by (induct xs) simp_all

lemma no_trailing_Nil [iff]:
  "no_trailing P []"
  by simp

lemma no_trailing_Cons [simp]:
  "no_trailing P (x # xs) \<longleftrightarrow> no_trailing P xs \<and> (xs = [] \<longrightarrow> \<not> P x)"
  by simp

lemma no_trailing_append:
  "no_trailing P (xs @ ys) \<longleftrightarrow> no_trailing P ys \<and> (ys = [] \<longrightarrow> no_trailing P xs)"
  by (induct xs) simp_all

lemma no_trailing_append_Cons [simp]:
  "no_trailing P (xs @ y # ys) \<longleftrightarrow> no_trailing P (y # ys)"
  by simp

lemma no_trailing_strip_while [simp]:
  "no_trailing P (strip_while P xs)"
  by (induct xs rule: rev_induct) simp_all

lemma strip_while_idem [simp]:
  "no_trailing P xs \<Longrightarrow> strip_while P xs = xs"
  by (cases xs rule: rev_cases) simp_all

lemma strip_while_eq_obtain_trailing:
  assumes "strip_while P xs = ys"
  obtains zs where "xs = ys @ zs" and "\<And>z. z \<in> set zs \<Longrightarrow> P z" and "no_trailing P ys"
proof -
  from assms have "rev (rev (dropWhile P (rev xs))) = rev ys"
    by (simp add: strip_while_def)
  then have "dropWhile P (rev xs) = rev ys"
    by simp
  then obtain zs where A: "rev xs = zs @ rev ys" and B: "\<And>z. z \<in> set zs \<Longrightarrow> P z"
    and C: "no_trailing P ys"
    using dropWhile_eq_obtain_leading by blast
  from A have "rev (rev xs) = rev (zs @ rev ys)"
    by simp
  then have "xs = ys @ rev zs"
    by simp
  moreover from B have "\<And>z. z \<in> set (rev zs) \<Longrightarrow> P z"
    by simp
  ultimately show thesis using that C by blast
qed

lemma strip_while_idem_iff:
  "strip_while P xs = xs \<longleftrightarrow> no_trailing P xs"
proof -
  define ys where "ys = rev xs"
  moreover have "strip_while P (rev ys) = rev ys \<longleftrightarrow> no_trailing P (rev ys)"
    by (simp add: dropWhile_idem_iff)
  ultimately show ?thesis by simp
qed

lemma no_trailing_map:
  "no_trailing P (map f xs) \<longleftrightarrow> no_trailing (P \<circ> f) xs"
  by (simp add: last_map no_trailing_unfold)

lemma no_trailing_drop [simp]:
  "no_trailing P (drop n xs)" if "no_trailing P xs"
proof -
  from that have "no_trailing P (take n xs @ drop n xs)"
    by simp
  then show ?thesis
    by (simp only: no_trailing_append)
qed

lemma no_trailing_upt [simp]:
  "no_trailing P [n..<m] \<longleftrightarrow> (n < m \<longrightarrow> \<not> P (m - 1))"
  by (auto simp add: no_trailing_unfold)

definition nth_default :: "'a \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a"
where
  "nth_default dflt xs n = (if n < length xs then xs ! n else dflt)"

lemma nth_default_nth:
  "n < length xs \<Longrightarrow> nth_default dflt xs n = xs ! n"
  by (simp add: nth_default_def)

lemma nth_default_beyond:
  "length xs \<le> n \<Longrightarrow> nth_default dflt xs n = dflt"
  by (simp add: nth_default_def)

lemma nth_default_Nil [simp]:
  "nth_default dflt [] n = dflt"
  by (simp add: nth_default_def)

lemma nth_default_Cons:
  "nth_default dflt (x # xs) n = (case n of 0 \<Rightarrow> x | Suc n' \<Rightarrow> nth_default dflt xs n')"
  by (simp add: nth_default_def split: nat.split)

lemma nth_default_Cons_0 [simp]:
  "nth_default dflt (x # xs) 0 = x"
  by (simp add: nth_default_Cons)

lemma nth_default_Cons_Suc [simp]:
  "nth_default dflt (x # xs) (Suc n) = nth_default dflt xs n"
  by (simp add: nth_default_Cons)

lemma nth_default_replicate_dflt [simp]:
  "nth_default dflt (replicate n dflt) m = dflt"
  by (simp add: nth_default_def)

lemma nth_default_append:
  "nth_default dflt (xs @ ys) n =
    (if n < length xs then nth xs n else nth_default dflt ys (n - length xs))"
  by (auto simp add: nth_default_def nth_append)

lemma nth_default_append_trailing [simp]:
  "nth_default dflt (xs @ replicate n dflt) = nth_default dflt xs"
  by (simp add: fun_eq_iff nth_default_append) (simp add: nth_default_def)

lemma nth_default_snoc_default [simp]:
  "nth_default dflt (xs @ [dflt]) = nth_default dflt xs"
  by (auto simp add: nth_default_def fun_eq_iff nth_append)

lemma nth_default_eq_dflt_iff:
  "nth_default dflt xs k = dflt \<longleftrightarrow> (k < length xs \<longrightarrow> xs ! k = dflt)"
  by (simp add: nth_default_def)

lemma nth_default_take_eq:
  "nth_default dflt (take m xs) n =
    (if n < m then nth_default dflt xs n else dflt)"
  by (simp add: nth_default_def)

lemma in_enumerate_iff_nth_default_eq:
  "x \<noteq> dflt \<Longrightarrow> (n, x) \<in> set (enumerate 0 xs) \<longleftrightarrow> nth_default dflt xs n = x"
  by (auto simp add: nth_default_def in_set_conv_nth enumerate_eq_zip)

lemma last_conv_nth_default:
  assumes "xs \<noteq> []"
  shows "last xs = nth_default dflt xs (length xs - 1)"
  using assms by (simp add: nth_default_def last_conv_nth)

lemma nth_default_map_eq:
  "f dflt' = dflt \<Longrightarrow> nth_default dflt (map f xs) n = f (nth_default dflt' xs n)"
  by (simp add: nth_default_def)

lemma finite_nth_default_neq_default [simp]:
  "finite {k. nth_default dflt xs k \<noteq> dflt}"
  by (simp add: nth_default_def)

lemma sorted_list_of_set_nth_default:
  "sorted_list_of_set {k. nth_default dflt xs k \<noteq> dflt} = map fst (filter (\<lambda>(_, x). x \<noteq> dflt) (enumerate 0 xs))"
  by (rule sorted_distinct_set_unique) (auto simp add: nth_default_def in_set_conv_nth
    sorted_filter distinct_map_filter enumerate_eq_zip intro: rev_image_eqI)

lemma map_nth_default:
  "map (nth_default x xs) [0..<length xs] = xs"
proof -
  have *: "map (nth_default x xs) [0..<length xs] = map (List.nth xs) [0..<length xs]"
    by (rule map_cong) (simp_all add: nth_default_nth)
  show ?thesis by (simp add: * map_nth)
qed

lemma range_nth_default [simp]:
  "range (nth_default dflt xs) = insert dflt (set xs)"
  by (auto simp add: nth_default_def [abs_def] in_set_conv_nth)

lemma nth_strip_while:
  assumes "n < length (strip_while P xs)"
  shows "strip_while P xs ! n = xs ! n"
proof -
  have "length (dropWhile P (rev xs)) + length (takeWhile P (rev xs)) = length xs"
    by (subst add.commute)
      (simp add: arg_cong [where f=length, OF takeWhile_dropWhile_id, unfolded length_append])
  then show ?thesis using assms
    by (simp add: strip_while_def rev_nth dropWhile_nth)
qed

lemma length_strip_while_le:
  "length (strip_while P xs) \<le> length xs"
  unfolding strip_while_def o_def length_rev
  by (subst (2) length_rev[symmetric])
    (simp add: strip_while_def length_dropWhile_le del: length_rev)

lemma nth_default_strip_while_dflt [simp]:
  "nth_default dflt (strip_while ((=) dflt) xs) = nth_default dflt xs"
  by (induct xs rule: rev_induct) auto

lemma nth_default_eq_iff:
  "nth_default dflt xs = nth_default dflt ys
     \<longleftrightarrow> strip_while (HOL.eq dflt) xs = strip_while (HOL.eq dflt) ys" (is "?P \<longleftrightarrow> ?Q")
proof
  let ?xs = "strip_while (HOL.eq dflt) xs" and ?ys = "strip_while (HOL.eq dflt) ys"
  assume ?P
  then have eq: "nth_default dflt ?xs = nth_default dflt ?ys"
    by simp
  have len: "length ?xs = length ?ys"
  proof (rule ccontr)
    assume len: "length ?xs \<noteq> length ?ys"
    { fix xs ys :: "'a list"
      let ?xs = "strip_while (HOL.eq dflt) xs" and ?ys = "strip_while (HOL.eq dflt) ys"
      assume eq: "nth_default dflt ?xs = nth_default dflt ?ys"
      assume len: "length ?xs < length ?ys"
      then have "length ?ys > 0" by arith
      then have "?ys \<noteq> []" by simp
      with last_conv_nth_default [of ?ys dflt]
      have "last ?ys = nth_default dflt ?ys (length ?ys - 1)"
        by auto
      moreover from \<open>?ys \<noteq> []\<close> no_trailing_strip_while [of "HOL.eq dflt" ys]
        have "last ?ys \<noteq> dflt" by (simp add: no_trailing_unfold)
      ultimately have "nth_default dflt ?xs (length ?ys - 1) \<noteq> dflt"
        using eq by simp
      moreover from len have "length ?ys - 1 \<ge> length ?xs" by simp
      ultimately have False by (simp only: nth_default_beyond) simp
    }
    from this [of xs ys] this [of ys xs] len eq show False
      by (auto simp only: linorder_class.neq_iff)
  qed
  then show ?Q
  proof (rule nth_equalityI [rule_format])
    fix n
    assume n: "n < length ?xs"
    with len have "n < length ?ys"
      by simp
    with n have xs: "nth_default dflt ?xs n = ?xs ! n"
      and ys: "nth_default dflt ?ys n = ?ys ! n"
      by (simp_all only: nth_default_nth)
    with eq show "?xs ! n = ?ys ! n"
      by simp
  qed
next
  assume ?Q
  then have "nth_default dflt (strip_while (HOL.eq dflt) xs) = nth_default dflt (strip_while (HOL.eq dflt) ys)"
    by simp
  then show ?P
    by simp
qed

lemma nth_default_map2:
  \<open>nth_default d (map2 f xs ys) n = f (nth_default d1 xs n) (nth_default d2 ys n)\<close>
    if \<open>length xs = length ys\<close> and \<open>f d1 d2 = d\<close> for bs cs
using that proof (induction xs ys arbitrary: n rule: list_induct2)
  case Nil
  then show ?case
    by simp
next
  case (Cons x xs y ys)
  then show ?case
    by (cases n) simp_all
qed

end