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

theory Conversions
imports Main
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


subsection \<open>Evaluation Stamp Theorems\<close>

theory StampEvalThms
  imports Graph.ValueThms
          Semantics.IRTreeEvalThms
begin

lemma
  assumes "take_bit b v = v"
  shows "signed_take_bit b v = v"
  using assms
  by (metis(full_types) eq_imp_le signed_take_bit_take_bit)

lemma unwrap_signed_take_bit:
  fixes v :: int64
  assumes "0 < b \<and> b \<le> 64"
  assumes "signed_take_bit (b - 1) v = v"
  shows "signed_take_bit 63 (Word.rep (signed_take_bit (b - Suc 0) v)) = sint v"
  using assms using size64 unfolding signed_def by auto

lemma unrestricted_new_int_always_valid [simp]:
  assumes "0 < b \<and> b \<le> 64"
  shows "valid_value (new_int b v) (unrestricted_stamp (IntegerStamp b lo hi))"
  unfolding unrestricted_stamp.simps new_int.simps valid_value.simps
  by (simp; metis One_nat_def assms int_power_div_base int_signed_value.simps int_signed_value_range linorder_not_le not_exp_less_eq_0_int zero_less_numeral)

lemma unary_undef: "val = UndefVal \<Longrightarrow> unary_eval op val = UndefVal"
  by (cases op; auto)

lemma unary_obj: "val = ObjRef x \<Longrightarrow> unary_eval op val = UndefVal"
  by (cases op; auto)

lemma unrestricted_stamp_valid:
  assumes "s = unrestricted_stamp (IntegerStamp b lo hi)"
  assumes "0 < b \<and> b \<le> 64"
  shows "valid_stamp s"
  using assms
  by (smt (z3) Stamp.inject(1) bit_bounds.simps not_exp_less_eq_0_int prod.sel(1) prod.sel(2) unrestricted_stamp.simps(2) upper_bounds_equiv valid_stamp.elims(1))

lemma unrestricted_stamp_valid_value [simp]:
  assumes 1: "result = IntVal b ival"
  assumes "take_bit b ival = ival"
  assumes "0 < b \<and> b \<le> 64"
  shows "valid_value result (unrestricted_stamp (IntegerStamp b lo hi))"
proof -
  have "valid_stamp (unrestricted_stamp (IntegerStamp b lo hi))"
    using assms unrestricted_stamp_valid by blast
  then show ?thesis
    unfolding 1 unrestricted_stamp.simps valid_value.simps
    using assms int_signed_value_bounds by presburger
qed

(* TODO: update to allow any bit size?
lemma unrestricted_stamp32_always_valid [simp]:
  assumes "fst (bit_bounds bits) \<le> sint ival \<and> sint ival \<le> snd (bit_bounds bits)"
  assumes "bits = 32 \<or> bits = 16 \<or> bits = 8 \<or> bits = 1"
  assumes "result = IntVal32 ival"
  shows "valid_value result (unrestricted_stamp (IntegerStamp bits lo hi))"
  using assms valid_value.simps(1) unrestricted_stamp.simps(2) by presburger

lemma larger_stamp32_always_valid [simp]:
  assumes "valid_value result (unrestricted_stamp (IntegerStamp inBits lo hi))"
  assumes "result = IntVal32 ival"
  assumes "outBits = 32 \<or> outBits = 16 \<or> outBits = 8 \<or> outBits = 1"
  assumes "inBits \<le> outBits"
  shows "valid_value result (unrestricted_stamp (IntegerStamp outBits lo hi))"
  using assms by (smt (z3)  bit_bounds.simps diff_le_mono linorder_not_less lower_bounds_equiv not_numeral_le_zero numerals(1) power_increasing_iff prod.sel(1) prod.sel(2) unrestricted_stamp.simps(2) valid_value.simps(1))
*)

subsubsection \<open>Support Lemmas for Integer Stamps and Associated IntVal values\<close>
(* TODO: these do not use eval so could go up into a StampThms.thy? *)

text \<open>Valid int implies some useful facts.\<close>
lemma valid_int_gives:
  assumes "valid_value (IntVal b val) stamp"
  obtains lo hi where "stamp = IntegerStamp b lo hi \<and>
       valid_stamp (IntegerStamp b lo hi) \<and>
       take_bit b val = val \<and>
       lo \<le> int_signed_value b val \<and> int_signed_value b val \<le> hi"
  using assms
  by (smt (z3) Value.distinct(7) Value.inject(1) valid_value.elims(1))

text \<open>And the corresponding lemma where we know the stamp rather than the value.\<close>
lemma valid_int_stamp_gives:
  assumes "valid_value val (IntegerStamp b lo hi)"
  obtains ival where "val = IntVal b ival \<and>
       valid_stamp (IntegerStamp b lo hi) \<and>
       take_bit b ival = ival \<and>
       lo \<le> int_signed_value b ival \<and> int_signed_value b ival \<le> hi"
  by (metis assms valid_int valid_value.simps(1))

text \<open>A valid int must have the expected number of bits.\<close>
lemma valid_int_same_bits:
  assumes "valid_value (IntVal b val) (IntegerStamp bits lo hi)"
  shows "b = bits"
  by (meson assms valid_value.simps(1))

text \<open>A valid value means a valid stamp.\<close>
lemma valid_int_valid_stamp:
  assumes "valid_value (IntVal b val) (IntegerStamp bits lo hi)"
  shows "valid_stamp (IntegerStamp bits lo hi)"
  by (metis assms valid_value.simps(1))

text \<open>A valid int means a valid non-empty stamp.\<close>
lemma valid_int_not_empty:
  assumes "valid_value (IntVal b val) (IntegerStamp bits lo hi)"
  shows "lo \<le> hi"
  by (metis assms order.trans valid_value.simps(1))

text \<open>A valid int fits into the given number of bits (and other bits are zero).\<close>
lemma valid_int_fits:
  assumes "valid_value (IntVal b val) (IntegerStamp bits lo hi)"
  shows "take_bit bits val = val"
  by (metis assms valid_value.simps(1))

lemma valid_int_is_zero_masked:
  assumes "valid_value (IntVal b val) (IntegerStamp bits lo hi)"
  shows "and val (not (mask bits)) = 0"
  by (metis (no_types, lifting) assms bit.conj_cancel_right take_bit_eq_mask valid_int_fits
             word_bw_assocs(1) word_log_esimps(1))

text \<open>Unsigned ints have bounds $0$ up to $2^bits$.\<close>
lemma valid_int_unsigned_bounds:
  assumes "valid_value (IntVal b val) (IntegerStamp bits lo hi)"
  (* Not actually needed: assumes "0 \<le> lo" *)
  shows "uint val < 2 ^ bits"
  by (metis assms(1) mask_eq_iff take_bit_eq_mask valid_value.simps(1))

text \<open>Signed ints have the usual two-complement bounds.\<close>
lemma valid_int_signed_upper_bound:
  assumes "valid_value (IntVal b val) (IntegerStamp bits lo hi)"
  shows "int_signed_value bits val < 2 ^ (bits - 1)"
  by (metis (mono_tags, opaque_lifting) diff_le_mono int_signed_value.simps less_imp_diff_less
       linorder_not_le one_le_numeral order_less_le_trans power_increasing signed_take_bit_int_less_exp_word sint_lt)

lemma valid_int_signed_lower_bound:
  assumes "valid_value (IntVal b val) (IntegerStamp bits lo hi)"
  shows "-(2 ^ (bits - 1)) \<le> int_signed_value bits val"
  by (smt (verit) diff_le_self int_signed_value.simps linorder_not_less power_increasing_iff signed_take_bit_int_greater_eq_minus_exp_word sint_greater_eq)

text \<open>and $bit\_bounds$ versions of the above bounds.\<close>
lemma valid_int_signed_upper_bit_bound:
  assumes "valid_value (IntVal b val) (IntegerStamp bits lo hi)"
  shows "int_signed_value bits val \<le> snd (bit_bounds bits)"
proof -
  have "b = bits" using assms valid_int_same_bits by blast
  then show ?thesis
    using assms by force
qed

lemma valid_int_signed_lower_bit_bound:
  assumes "valid_value (IntVal b val) (IntegerStamp bits lo hi)"
  shows " fst (bit_bounds bits) \<le> int_signed_value bits val"
proof -
  have "b = bits" using assms valid_int_same_bits by blast
  then show ?thesis
    using assms by force
qed

text \<open>Valid values satisfy their stamp bounds.\<close>

lemma valid_int_signed_range:
  assumes "valid_value (IntVal b val) (IntegerStamp bits lo hi)"
  shows "lo \<le> int_signed_value bits val \<and> int_signed_value bits val \<le> hi"
  by (metis assms valid_value.simps(1))

subsubsection \<open>Validity of all Unary Operators\<close>

text \<open>We split the validity proof for unary operators into two lemmas,
  one for normal unary operators whose output bits equals their input bits,
  and the other case for the widen and narrow operators.\<close>

lemma eval_normal_unary_implies_valid_value:
  assumes "[m,p] \<turnstile> expr \<mapsto> val"
  assumes "result = unary_eval op val"
  assumes op: "op \<in> normal_unary"
  assumes "result \<noteq> UndefVal"
  assumes "valid_value val (stamp_expr expr)"
  shows "valid_value result (stamp_expr (UnaryExpr op expr))"
proof -
  obtain b1 v1 where v1: "val = IntVal b1 v1"
    by (metis Value.exhaust assms(1) assms(2) assms(4) assms(5) evaltree_not_undef unary_obj valid_value.simps(11))
  then obtain b2 v2 where v2: "result = IntVal b2 v2"
    using assms(2) assms(4) is_IntVal_def unary_eval_int by presburger
  then have "result = unary_eval op (IntVal b1 v1)"
    using assms(2) v1 by blast
  then obtain vtmp where vtmp: "result = new_int b2 vtmp"
    using assms(3) v2 by auto
  obtain b' lo' hi' where "stamp_expr expr = IntegerStamp b' lo' hi'"
    by (metis assms(5) v1 valid_int_gives)
  then have "stamp_unary op (stamp_expr expr) =
    unrestricted_stamp
     (IntegerStamp (if op \<in> normal_unary then b' else ir_resultBits op) lo' hi')"
    using stamp_unary.simps(1) by presburger
  then obtain lo2 hi2 where s: "(stamp_expr (UnaryExpr op expr)) = unrestricted_stamp (IntegerStamp b2 lo2 hi2)"
    unfolding stamp_expr.simps
    using vtmp op
    by (smt (verit, best) Value.inject(1) \<open>(result::Value) = unary_eval (op::IRUnaryOp) (IntVal (b1::nat) (v1::64 word))\<close> \<open>stamp_expr (expr::IRExpr) = IntegerStamp (b'::nat) (lo'::int) (hi'::int)\<close> assms(5) insertE intval_abs.simps(1) intval_logic_negation.simps(1) intval_negate.simps(1) intval_not.simps(1) new_int.elims singleton_iff unary_eval.simps(1) unary_eval.simps(2) unary_eval.simps(3) unary_eval.simps(4) v1 valid_int_same_bits)
  then have "0 < b1 \<and> b1 \<le> 64"
    using valid_int_gives
    by (metis assms(5) v1 valid_stamp.simps(1))
  then have "fst (bit_bounds b2) \<le> int_signed_value b2 v2 \<and>
             int_signed_value b2 v2 \<le> snd (bit_bounds b2)"
    by (smt (verit, del_insts) Stamp.inject(1) assms(3) assms(5) int_signed_value_bounds s stamp_expr.simps(1) stamp_unary.simps(1) unrestricted_stamp.simps(2) v1 valid_int_gives)
  then show ?thesis
    unfolding s v2 unrestricted_stamp.simps valid_value.simps
    by (smt (z3) assms(3) assms(5) is_stamp_empty.simps(1) new_int_take_bits s stamp_expr.simps(1) stamp_unary.simps(1) unrestricted_stamp.simps(2) v1 v2 valid_int_gives valid_stamp.simps(1) vtmp)
qed

lemma narrow_widen_output_bits:
  assumes "unary_eval op val \<noteq> UndefVal"
  assumes "op \<notin> normal_unary"
  shows "0 < (ir_resultBits op) \<and> (ir_resultBits op) \<le> 64"
proof -
  consider ib ob where "op = UnaryNarrow ib ob"
         | ib ob where "op = UnarySignExtend ib ob"
         | ib ob where "op = UnaryZeroExtend ib ob"
    using IRUnaryOp.exhaust_sel assms(2) by blast
  then show ?thesis
  proof (cases)
    case 1
    then show ?thesis using assms intval_narrow_ok by force
  next
    case 2
    then show ?thesis using assms intval_sign_extend_ok by force
  next
    case 3
    then show ?thesis using assms intval_zero_extend_ok by force
  qed
qed

lemma eval_widen_narrow_unary_implies_valid_value:
  assumes "[m,p] \<turnstile> expr \<mapsto> val"
  assumes "result = unary_eval op val"
  assumes op: "op \<notin> normal_unary"
  assumes "result \<noteq> UndefVal"
  assumes "valid_value val (stamp_expr expr)"
  shows "valid_value result (stamp_expr (UnaryExpr op expr))"
proof -
  obtain b1 v1 where v1: "val = IntVal b1 v1"
    by (metis Value.exhaust assms(1) assms(2) assms(4) assms(5) evaltree_not_undef unary_obj valid_value.simps(11))
  then have "result = unary_eval op (IntVal b1 v1)"
    using assms(2) v1 by blast
  then obtain v2 where v2: "result = new_int (ir_resultBits op) v2"
    using assms by (cases op; simp; (meson new_int.simps)+)
  then obtain v3 where v3: "result = IntVal (ir_resultBits op) v3"
    using assms by (cases op; simp; (meson new_int.simps)+)
  then obtain lo2 hi2 where s: "(stamp_expr (UnaryExpr op expr)) = unrestricted_stamp (IntegerStamp (ir_resultBits op) lo2 hi2)"
    unfolding stamp_expr.simps stamp_unary.simps
    using assms(3) assms(5) v1 valid_int_gives by fastforce
  then have outBits: "0 < (ir_resultBits op) \<and> (ir_resultBits op) \<le> 64"
    using assms narrow_widen_output_bits
    by blast
  then have "fst (bit_bounds (ir_resultBits op)) \<le> int_signed_value (ir_resultBits op) v3 \<and>
             int_signed_value (ir_resultBits op) v3 \<le> snd (bit_bounds (ir_resultBits op))"
    using int_signed_value_bounds
    by (smt (verit, del_insts) Stamp.inject(1) assms(3) assms(5) int_signed_value_bounds s stamp_expr.simps(1) stamp_unary.simps(1) unrestricted_stamp.simps(2) v1 valid_int_gives)
  then show ?thesis
    unfolding s v3 unrestricted_stamp.simps valid_value.simps
    using outBits v2 v3 by auto
qed

lemma eval_unary_implies_valid_value:
  assumes "[m,p] \<turnstile> expr \<mapsto> val"
  assumes "result = unary_eval op val"
  assumes "result \<noteq> UndefVal"
  assumes "valid_value val (stamp_expr expr)"
  shows "valid_value result (stamp_expr (UnaryExpr op expr))"
  proof (cases "op \<in> normal_unary")
    case True
    then show ?thesis by (metis assms eval_normal_unary_implies_valid_value)
  next
    case False
    then show ?thesis by (metis assms eval_widen_narrow_unary_implies_valid_value)
  qed

subsubsection \<open>Support Lemmas for Binary Operators\<close>

lemma binary_undef: "v1 = UndefVal \<or> v2 = UndefVal \<Longrightarrow> bin_eval op v1 v2 = UndefVal"
  by (cases op; auto)

lemma binary_obj: "v1 = ObjRef x \<or> v2 = ObjRef y \<Longrightarrow> bin_eval op v1 v2 = UndefVal"
  by (cases op; auto)

text \<open>Some lemmas about the three different output sizes for binary operators.\<close>

lemma bin_eval_bits_binary_shift_ops:
  assumes "result = bin_eval op (IntVal b1 v1) (IntVal b2 v2)"
  assumes "result \<noteq> UndefVal"
  assumes "op \<in> binary_shift_ops"
  shows "\<exists>v. result = new_int b1 v"
  using assms
  by (cases op; simp; smt (verit, best) new_int.simps)+

lemma bin_eval_bits_fixed_32_ops:
  assumes "result = bin_eval op (IntVal b1 v1) (IntVal b2 v2)"
  assumes "result \<noteq> UndefVal"
  assumes "op \<in> binary_fixed_32_ops"
  shows "\<exists>v. result = new_int 32 v"
  using assms
  apply (cases op; simp)
  using assms bool_to_val.simps bin_eval_new_int new_int.simps bin_eval_unused_bits_zero
  by metis+

lemma bin_eval_bits_normal_ops:
  assumes "result = bin_eval op (IntVal b1 v1) (IntVal b2 v2)"
  assumes "result \<noteq> UndefVal"
  assumes "op \<notin> binary_shift_ops"
  assumes "op \<notin> binary_fixed_32_ops"
  shows "\<exists>v. result = new_int b1 v"
  using assms apply (cases op; simp)
  using assms apply (metis (mono_tags))+
  using take_bit_and apply metis
  using take_bit_or apply metis
  using take_bit_xor by metis

lemma bin_eval_input_bits_equal:
  assumes "result = bin_eval op (IntVal b1 v1) (IntVal b2 v2)"
  assumes "result \<noteq> UndefVal"
  assumes "op \<notin> binary_shift_ops"
  shows "b1 = b2"
  using assms apply (cases op; simp)
  by presburger+

lemma bin_eval_implies_valid_value:
  assumes "[m,p] \<turnstile> expr1 \<mapsto> val1"
  assumes "[m,p] \<turnstile> expr2 \<mapsto> val2"
  assumes "result = bin_eval op val1 val2"
  assumes "result \<noteq> UndefVal"
  assumes "valid_value val1 (stamp_expr expr1)"
  assumes "valid_value val2 (stamp_expr expr2)"
  shows "valid_value result (stamp_expr (BinaryExpr op expr1 expr2))"
proof -
  obtain b1 v1 where v1: "val1 = IntVal b1 v1"
    by (metis Value.collapse(1) assms(3) assms(4) bin_eval_inputs_are_ints bin_eval_int)
  obtain b2 v2 where v2: "val2 = IntVal b2 v2"
    by (metis Value.collapse(1) assms(3) assms(4) bin_eval_inputs_are_ints bin_eval_int)
  then obtain lo1 hi1 where s1: "stamp_expr expr1 = IntegerStamp b1 lo1 hi1"
    by (metis assms(5) v1 valid_int_gives)
  then obtain lo2 hi2 where s2: "stamp_expr expr2 = IntegerStamp b2 lo2 hi2"
    by (metis assms(6) v2 valid_int_gives)
  then have r: "result = bin_eval op (IntVal b1 v1) (IntVal b2 v2)"
    using assms(3) v1 v2 by blast
  then obtain bres vtmp where vtmp: "result = new_int bres vtmp"
    using assms bin_eval_bits_binary_shift_ops
    by (meson bin_eval_new_int)
  then obtain vres where vres: "result = IntVal bres vres"
    by force
  (* now calculate the result stamp for the three classes of operators. *)
  then have sres: "stamp_expr (BinaryExpr op expr1 expr2) =
             unrestricted_stamp (IntegerStamp bres lo1 hi1)
           \<and> 0 < bres \<and> bres \<le> 64"
    proof (cases "op \<in> binary_shift_ops")
      case True
      then show ?thesis
        unfolding s1 s2 stamp_binary.simps stamp_expr.simps
        using assms bin_eval_bits_binary_shift_ops
        by (metis Value.inject(1) eval_bits_1_64 new_int.simps r v1 vres)
    next
      case False
      then have "op \<notin> binary_shift_ops"
        by simp
      then have beq: "b1 = b2"
        using v1 v2 assms bin_eval_input_bits_equal by simp
      then show ?thesis
      proof (cases "op \<in> binary_fixed_32_ops")
        case True
        then show ?thesis
        unfolding s1 s2 stamp_binary.simps stamp_expr.simps
        using assms bin_eval_bits_fixed_32_ops
        by (metis False Value.inject(1) beq bin_eval_new_int le_add_same_cancel1 new_int.simps numeral_Bit0 vres zero_le_numeral zero_less_numeral)
      next
        case False
        then show ?thesis
        unfolding s1 s2 stamp_binary.simps stamp_expr.simps
        using assms
        by (metis beq bin_eval_new_int eval_bits_1_64 intval_bits.simps unrestricted_new_int_always_valid unrestricted_stamp.simps(2) v1 valid_int_same_bits vres)
    qed
  qed
  then show ?thesis
    unfolding vres
    using unrestricted_new_int_always_valid vres vtmp by presburger
qed

subsubsection \<open>Validity of Stamp Meet and Join Operators\<close>

lemma stamp_meet_integer_is_valid_stamp:
  assumes "valid_stamp stamp1"
  assumes "valid_stamp stamp2"
  assumes "is_IntegerStamp stamp1"
  assumes "is_IntegerStamp stamp2"
  shows "valid_stamp (meet stamp1 stamp2)"
  using assms unfolding is_IntegerStamp_def valid_stamp.simps meet.simps
  by (smt (verit, del_insts) meet.simps(2) valid_stamp.simps(1) valid_stamp.simps(8))

lemma stamp_meet_is_valid_stamp:
  assumes 1: "valid_stamp stamp1"
  assumes 2: "valid_stamp stamp2"
  shows "valid_stamp (meet stamp1 stamp2)"
  by (cases stamp1; cases stamp2; insert stamp_meet_integer_is_valid_stamp[OF 1 2]; auto)

lemma stamp_meet_commutes: "meet stamp1 stamp2 = meet stamp2 stamp1"
  by (cases stamp1; cases stamp2; auto)

lemma stamp_meet_is_valid_value1:
  assumes "valid_value val stamp1"  (*  \<or> valid_value val stamp2" *)
  assumes "valid_stamp stamp2"
  assumes "stamp1 = IntegerStamp b1 lo1 hi1"
  assumes "stamp2 = IntegerStamp b2 lo2 hi2"
  assumes "meet stamp1 stamp2 \<noteq> IllegalStamp"
  shows "valid_value val (meet stamp1 stamp2)"
proof -
  have m: "meet stamp1 stamp2 = IntegerStamp b1 (min lo1 lo2) (max hi1 hi2)"
    using assms by (metis meet.simps(2))
  obtain ival where val: "val = IntVal b1 ival"
    using assms valid_int by blast
  then have v: "valid_stamp (IntegerStamp b1 lo1 hi1) \<and>
       take_bit b1 ival = ival \<and>
       lo1 \<le> int_signed_value b1 ival \<and> int_signed_value b1 ival \<le> hi1"
    using assms by (metis valid_value.simps(1))
  then have mm: "min lo1 lo2 \<le> int_signed_value b1 ival \<and> int_signed_value b1 ival \<le> max hi1 hi2"
    by linarith
  then have "valid_stamp (IntegerStamp b1 (min lo1 lo2) (max hi1 hi2))"
    using assms v stamp_meet_is_valid_stamp
    by (metis meet.simps(2))
  then show ?thesis
    unfolding m val valid_value.simps
    using mm v by presburger
qed

text \<open>and the symmetric lemma follows by the commutativity of meet.\<close>

lemma stamp_meet_is_valid_value:
  assumes "valid_value val stamp2"
  assumes "valid_stamp stamp1"
  assumes "stamp1 = IntegerStamp b1 lo1 hi1"
  assumes "stamp2 = IntegerStamp b2 lo2 hi2"
  assumes "meet stamp1 stamp2 \<noteq> IllegalStamp"
  shows "valid_value val (meet stamp1 stamp2)"
  using assms stamp_meet_commutes stamp_meet_is_valid_value1
  by metis

subsubsection \<open>Validity of conditional expressions\<close>

lemma conditional_eval_implies_valid_value:
  assumes "[m,p] \<turnstile> cond \<mapsto> condv"
  assumes "expr = (if val_to_bool condv then expr1 else expr2)"
  assumes "[m,p] \<turnstile> expr \<mapsto> val"
  assumes "val \<noteq> UndefVal"
  assumes "valid_value condv (stamp_expr cond)"
  assumes "valid_value val (stamp_expr expr)"
  assumes "compatible (stamp_expr expr1) (stamp_expr expr2)"
  shows "valid_value val (stamp_expr (ConditionalExpr cond expr1 expr2))"
proof -
  have def: "meet (stamp_expr expr1) (stamp_expr expr2) \<noteq> IllegalStamp"
    using assms
    by (metis Stamp.distinct(13) Stamp.distinct(25) compatible.elims(2) meet.simps(1) meet.simps(2))
  then have "valid_stamp (meet (stamp_expr expr1) (stamp_expr expr2))"
    using assms
    by (smt (verit, best) compatible.elims(2) stamp_meet_is_valid_stamp valid_stamp.simps(2))
  then show ?thesis using stamp_meet_is_valid_value
    using assms def
    by (smt (verit, best) compatible.elims(2) never_void stamp_expr.simps(6) stamp_meet_commutes)
qed

subsubsection \<open>Validity of Whole Expression Tree Evaluation\<close>

text \<open> TODO: find a way to encode that conditional expressions must have
  compatible (and valid) stamps?  One approach would be for all the
  stamp\_expr operators to require that all input stamps are valid.\<close>

(*
experiment begin
lemma stamp_implies_valid_value:
  assumes "[m,p] \<turnstile> expr \<mapsto> val"
  shows "valid_value val (stamp_expr expr)"
  using assms proof (induction expr val)
  case (UnaryExpr expr val result op)
  then show ?case using eval_unary_implies_valid_value by simp
  next
    case (BinaryExpr expr1 val1 expr2 val2 result op)
    then show ?case using bin_eval_implies_valid_value by simp
  next
    case (ConditionalExpr cond condv expr expr1 expr2 val)
    have "compatible (stamp_expr expr1) (stamp_expr expr2)"
      using assms sorry
    then show ?case
      using assms conditional_eval_implies_valid_value
      using ConditionalExpr.IH(1) ConditionalExpr.IH(2) ConditionalExpr.hyps(1) ConditionalExpr.hyps(2) ConditionalExpr.hyps(3) ConditionalExpr.hyps(4) by blast
  next
    case (ParameterExpr x1 x2)
    then show ?case by auto
  next
    case (LeafExpr x1 x2)
    then show ?case by auto
  next
    case (ConstantExpr x)
    then show ?case by auto
qed

lemma value_range:
  assumes "[m, p] \<turnstile> e \<mapsto> v"
  shows "v \<in> {val . valid_value val (stamp_expr e)}"
  using assms sorry
end
*)

definition wf_stamp :: "IRExpr \<Rightarrow> bool" where
  "wf_stamp e = (\<forall>m p v. ([m, p] \<turnstile> e \<mapsto> v) \<longrightarrow> valid_value v (stamp_expr e))"

lemma stamp_under_defn:
  assumes "stamp_under (stamp_expr x) (stamp_expr y)"
  assumes "wf_stamp x \<and> wf_stamp y"
  assumes "([m, p] \<turnstile> x \<mapsto> xv) \<and> ([m, p] \<turnstile> y \<mapsto> yv)"
  shows "val_to_bool (bin_eval BinIntegerLessThan xv yv) \<or> (bin_eval BinIntegerLessThan xv yv) = UndefVal"
proof -
  have yval: "valid_value yv (stamp_expr y)"
    using assms wf_stamp_def by blast
  obtain b lx hi where xstamp: "stamp_expr x = IntegerStamp b lx hi"
    using assms(1)
    by (metis stamp_under.elims(2))
  then obtain b' lo hy where ystamp: "stamp_expr y = IntegerStamp b' lo hy"
    using assms(1)
    by (meson stamp_under.elims(2))
  obtain xvv where xvv: "xv = IntVal b xvv"
    by (metis assms(2) assms(3) valid_int wf_stamp_def xstamp)
  then have xval: "valid_value (IntVal b xvv) (stamp_expr x)"
    using assms(2) assms(3) wf_stamp_def by blast
  obtain yvv where yvv: "yv = IntVal b' yvv"
    by (metis valid_int ystamp yval)
  then have xval: "valid_value (IntVal b' yvv) (stamp_expr y)"
    using yval
    by blast
  have xunder: "int_signed_value b xvv \<le> hi"
    using xvv xval valid_value.simps
    by (metis assms(2) assms(3) wf_stamp_def xstamp)
  have yunder: "lo \<le> int_signed_value b' yvv"
    using yvv yval valid_value.simps
    by (metis ystamp)
  have unwrap: "\<forall>cond. bool_to_val_bin b b cond = bool_to_val cond"
    by simp
  from xunder yunder have "int_signed_value b xvv < int_signed_value b' yvv"
    using assms(1) xstamp ystamp by auto
  then have "(intval_less_than xv yv) = IntVal 32 1 \<or> (intval_less_than xv yv) = UndefVal"
    using xvv yvv
    using intval_less_than.simps(1) unwrap
    using bool_to_val.simps(1)
    by simp
  then show ?thesis
    by force
qed

lemma stamp_under_defn_inverse:
  assumes "stamp_under (stamp_expr y) (stamp_expr x)"
  assumes "wf_stamp x \<and> wf_stamp y"
  assumes "([m, p] \<turnstile> x \<mapsto> xv) \<and> ([m, p] \<turnstile> y \<mapsto> yv)"
  shows "\<not>(val_to_bool (bin_eval BinIntegerLessThan xv yv)) \<or> (bin_eval BinIntegerLessThan xv yv) = UndefVal"
proof -
  have yval: "valid_value yv (stamp_expr y)"
    using assms wf_stamp_def by blast
  obtain b lo hx where xstamp: "stamp_expr x = IntegerStamp b lo hx"
    using assms(1)
    by (metis stamp_under.elims(2))
  then obtain b' ly hi where ystamp: "stamp_expr y = IntegerStamp b' ly hi"
    using assms(1)
    by (meson stamp_under.elims(2))
  obtain xvv where xvv: "xv = IntVal b xvv"
    by (metis assms(2) assms(3) valid_int wf_stamp_def xstamp)
  then have xval: "valid_value (IntVal b xvv) (stamp_expr x)"
    using assms(2) assms(3) wf_stamp_def by blast
  obtain yvv where yvv: "yv = IntVal b' yvv"
    by (metis valid_int ystamp yval)
  then have xval: "valid_value (IntVal b' yvv) (stamp_expr y)"
    using yval by auto
  have yunder: "int_signed_value b' yvv \<le> hi"
    using yvv yval valid_value.simps
    by (metis ystamp)
  have xover: "lo \<le> int_signed_value b xvv"
    using xvv xval valid_value.simps
    by (metis assms(2) assms(3) wf_stamp_def xstamp)
  have unwrap: "\<forall>cond. bool_to_val_bin b b cond = bool_to_val cond"
    by simp
  from xover yunder have "int_signed_value b' yvv < int_signed_value b xvv"
    using assms(1) xstamp ystamp by auto
  then have "(intval_less_than xv yv) = IntVal 32 0  \<or> (intval_less_than xv yv) = UndefVal"
    using xvv yvv
    using intval_less_than.simps(1) unwrap by simp
  then show ?thesis
    by force
qed

end


(*<*)
theory Documents imports Main begin
(*>*)

section \<open>Concrete Syntax \label{sec:concrete-syntax}\<close>

text \<open>
  The core concept of Isabelle's framework for concrete syntax is that
  of \bfindex{mixfix annotations}.  Associated with any kind of
  constant declaration, mixfixes affect both the grammar productions
  for the parser and output templates for the pretty printer.

  In full generality, parser and pretty printer configuration is a
  subtle affair~@{cite "isabelle-isar-ref"}.  Your syntax specifications need
  to interact properly with the existing setup of Isabelle/Pure and
  Isabelle/HOL\@.  To avoid creating ambiguities with existing
  elements, it is particularly important to give new syntactic
  constructs the right precedence.

  Below we introduce a few simple syntax declaration
  forms that already cover many common situations fairly well.
\<close>

subsection \<open>Infix Annotations\<close>

text \<open>
  Syntax annotations may be included wherever constants are declared,
  such as \isacommand{definition} and \isacommand{primrec} --- and also
  \isacommand{datatype}, which declares constructor operations.
  Type-constructors may be annotated as well, although this is less
  frequently encountered in practice (the infix type \<open>\<times>\<close> comes
  to mind).

  Infix declarations\index{infix annotations} provide a useful special
  case of mixfixes.  The following example of the exclusive-or
  operation on boolean values illustrates typical infix declarations.
\<close>

definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool"    (infixl "[+]" 60)
where "A [+] B \<equiv> (A \<and> \<not> B) \<or> (\<not> A \<and> B)"

text \<open>
  \noindent Now \<open>xor A B\<close> and \<open>A [+] B\<close> refer to the
  same expression internally.  Any curried function with at least two
  arguments may be given infix syntax.  For partial applications with
  fewer than two operands, the operator is enclosed in parentheses.
  For instance, \<open>xor\<close> without arguments is represented as
  \<open>([+])\<close>; together with ordinary function application, this
  turns \<open>xor A\<close> into \<open>([+]) A\<close>.

  The keyword \isakeyword{infixl} seen above specifies an
  infix operator that is nested to the \emph{left}: in iterated
  applications the more complex expression appears on the left-hand
  side, and \<^term>\<open>A [+] B [+] C\<close> stands for \<open>(A [+] B) [+]
  C\<close>.  Similarly, \isakeyword{infixr} means nesting to the
  \emph{right}, reading \<^term>\<open>A [+] B [+] C\<close> as \<open>A [+] (B
  [+] C)\<close>.  A \emph{non-oriented} declaration via \isakeyword{infix}
  would render \<^term>\<open>A [+] B [+] C\<close> illegal, but demand explicit
  parentheses to indicate the intended grouping.

  The string @{text [source] "[+]"} in our annotation refers to the
  concrete syntax to represent the operator (a literal token), while
  the number \<open>60\<close> determines the precedence of the construct:
  the syntactic priorities of the arguments and result.  Isabelle/HOL
  already uses up many popular combinations of ASCII symbols for its
  own use, including both \<open>+\<close> and \<open>++\<close>.  Longer
  character combinations are more likely to be still available for
  user extensions, such as our~\<open>[+]\<close>.

  Operator precedences have a range of 0--1000.  Very low or high
  priorities are reserved for the meta-logic.  HOL syntax mainly uses
  the range of 10--100: the equality infix \<open>=\<close> is centered at
  50; logical connectives (like \<open>\<or>\<close> and \<open>\<and>\<close>) are
  below 50; algebraic ones (like \<open>+\<close> and \<open>*\<close>) are
  above 50.  User syntax should strive to coexist with common HOL
  forms, or use the mostly unused range 100--900.
\<close>

subsection \<open>Mathematical Symbols \label{sec:syntax-symbols}\<close>

text \<open>
  Concrete syntax based on ASCII characters has inherent limitations.
  Mathematical notation demands a larger repertoire of glyphs.
  Several standards of extended character sets have been proposed over
  decades, but none has become universally available so far.  Isabelle
  has its own notion of \bfindex{symbols} as the smallest entities of
  source text, without referring to internal encodings.  There are
  three kinds of such ``generalized characters'':

  \begin{enumerate}

  \item 7-bit ASCII characters

  \item named symbols: \verb,\,\verb,<,$ident$\verb,>,

  \item named control symbols: \verb,\,\verb,<^,$ident$\verb,>,

  \end{enumerate}

  Here $ident$ is any sequence of letters.
  This results in an infinite store of symbols, whose
  interpretation is left to further front-end tools.  For example, the
  Isabelle document processor (see \S\ref{sec:document-preparation})
  display the \verb,\,\verb,<forall>, symbol as~\<open>\<forall>\<close>.

  A list of standard Isabelle symbols is given in
  @{cite "isabelle-isar-ref"}.  You may introduce your own
  interpretation of further symbols by configuring the appropriate
  front-end tool accordingly, e.g.\ by defining certain {\LaTeX}
  macros (see also \S\ref{sec:doc-prep-symbols}).  There are also a
  few predefined control symbols, such as \verb,\,\verb,<^sub>, and
  \verb,\,\verb,<^sup>, for sub- and superscript of the subsequent
  printable symbol, respectively.  For example, \<^verbatim>\<open>A\<^sup>\<star>\<close>, is
  output as \<open>A\<^sup>\<star>\<close>.

  A number of symbols are considered letters by the Isabelle lexer and
  can be used as part of identifiers. These are the greek letters
  \<open>\<alpha>\<close> (\verb+\+\verb+<alpha>+), \<open>\<beta>\<close>
  (\verb+\+\verb+<beta>+), etc. (excluding \<open>\<lambda>\<close>),
  special letters like \<open>\<A>\<close> (\verb+\+\verb+<A>+) and \<open>\<AA>\<close> (\verb+\+\verb+<AA>+).  Moreover the control symbol
  \verb+\+\verb+<^sub>+ may be used to subscript a single letter or digit
  in the trailing part of an identifier. This means that the input

  \medskip
  {\small\noindent \<^verbatim>\<open>\<forall>\<alpha>\<^sub>1. \<alpha>\<^sub>1 = \<Pi>\<^sub>\<A>\<close>}

  \medskip
  \noindent is recognized as the term \<^term>\<open>\<forall>\<alpha>\<^sub>1. \<alpha>\<^sub>1 = \<Pi>\<^sub>\<A>\<close>
  by Isabelle.

  Replacing our previous definition of \<open>xor\<close> by the
  following specifies an Isabelle symbol for the new operator:
\<close>

(*<*)
hide_const xor
setup \<open>Sign.add_path "version1"\<close>
(*>*)
definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool"    (infixl "\<oplus>" 60)
where "A \<oplus> B \<equiv> (A \<and> \<not> B) \<or> (\<not> A \<and> B)"
(*<*)
setup \<open>Sign.local_path\<close>
(*>*)

text \<open>
  It is possible to provide alternative syntax forms
  through the \bfindex{print mode} concept~@{cite "isabelle-isar-ref"}.  By
  convention, the mode of ``$xsymbols$'' is enabled whenever
  Proof~General's X-Symbol mode or {\LaTeX} output is active.  Now
  consider the following hybrid declaration of \<open>xor\<close>:
\<close>

(*<*)
hide_const xor
setup \<open>Sign.add_path "version2"\<close>
(*>*)
definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool"    (infixl "[+]\<ignore>" 60)
where "A [+]\<ignore> B \<equiv> (A \<and> \<not> B) \<or> (\<not> A \<and> B)"

notation (xsymbols) xor (infixl "\<oplus>\<ignore>" 60)
(*<*)
setup \<open>Sign.local_path\<close>
(*>*)

text \<open>\noindent
The \commdx{notation} command associates a mixfix
annotation with a known constant.  The print mode specification,
here \<open>(xsymbols)\<close>, is optional.

We may now write \<open>A [+] B\<close> or \<open>A \<oplus> B\<close> in input, while
output uses the nicer syntax of $xsymbols$ whenever that print mode is
active.  Such an arrangement is particularly useful for interactive
development, where users may type ASCII text and see mathematical
symbols displayed during proofs.\<close>

subsection \<open>Prefix Annotations\<close>

text \<open>
  Prefix syntax annotations\index{prefix annotation} are another form
  of mixfixes @{cite "isabelle-isar-ref"}, without any template arguments or
  priorities --- just some literal syntax.  The following example
  associates common symbols with the constructors of a datatype.
\<close>

datatype currency =
    Euro nat    ("\<euro>")
  | Pounds nat  ("\<pounds>")
  | Yen nat     ("\<yen>")
  | Dollar nat  ("$")

text \<open>
  \noindent Here the mixfix annotations on the rightmost column happen
  to consist of a single Isabelle symbol each: \verb,\,\verb,<euro>,,
  \verb,\,\verb,<pounds>,, \verb,\,\verb,<yen>,, and \verb,$,.  Recall
  that a constructor like \<open>Euro\<close> actually is a function \<^typ>\<open>nat \<Rightarrow> currency\<close>.  The expression \<open>Euro 10\<close> will be
  printed as \<^term>\<open>\<euro> 10\<close>; only the head of the application is
  subject to our concrete syntax.  This rather simple form already
  achieves conformance with notational standards of the European
  Commission.

  Prefix syntax works the same way for other commands that introduce new constants, e.g. \isakeyword{primrec}.
\<close>

subsection \<open>Abbreviations \label{sec:abbreviations}\<close>

text\<open>Mixfix syntax annotations merely decorate particular constant
application forms with concrete syntax, for instance replacing
\<open>xor A B\<close> by \<open>A \<oplus> B\<close>.  Occasionally, the relationship
between some piece of notation and its internal form is more
complicated.  Here we need \emph{abbreviations}.

Command \commdx{abbreviation} introduces an uninterpreted notational
constant as an abbreviation for a complex term. Abbreviations are
unfolded upon parsing and re-introduced upon printing. This provides a
simple mechanism for syntactic macros.

A typical use of abbreviations is to introduce relational notation for
membership in a set of pairs, replacing \<open>(x, y) \<in> sim\<close> by
\<open>x \<approx> y\<close>. We assume that a constant \<open>sim\<close> of type
\<^typ>\<open>('a \<times> 'a) set\<close> has been introduced at this point.\<close>
(*<*)consts sim :: "('a \<times> 'a) set"(*>*)
abbreviation sim2 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"   (infix "\<approx>" 50)
where "x \<approx> y  \<equiv>  (x, y) \<in> sim"

text \<open>\noindent The given meta-equality is used as a rewrite rule
after parsing (replacing \mbox{\<^prop>\<open>x \<approx> y\<close>} by \<open>(x,y) \<in>
sim\<close>) and before printing (turning \<open>(x,y) \<in> sim\<close> back into
\mbox{\<^prop>\<open>x \<approx> y\<close>}). The name of the dummy constant \<open>sim2\<close>
does not matter, as long as it is unique.

Another common application of abbreviations is to
provide variant versions of fundamental relational expressions, such
as \<open>\<noteq>\<close> for negated equalities.  The following declaration
stems from Isabelle/HOL itself:
\<close>

abbreviation not_equal :: "'a \<Rightarrow> 'a \<Rightarrow> bool"    (infixl "~=\<ignore>" 50)
where "x ~=\<ignore> y  \<equiv>  \<not> (x = y)"

notation (xsymbols) not_equal (infix "\<noteq>\<ignore>" 50)

text \<open>\noindent The notation \<open>\<noteq>\<close> is introduced separately to restrict it
to the \emph{xsymbols} mode.

Abbreviations are appropriate when the defined concept is a
simple variation on an existing one.  But because of the automatic
folding and unfolding of abbreviations, they do not scale up well to
large hierarchies of concepts. Abbreviations do not replace
definitions.

Abbreviations are a simplified form of the general concept of
\emph{syntax translations}; even heavier transformations may be
written in ML @{cite "isabelle-isar-ref"}.
\<close>

section \<open>Document Preparation \label{sec:document-preparation}\<close>

text \<open>
  Isabelle/Isar is centered around the concept of \bfindex{formal
  proof documents}\index{documents|bold}.  The outcome of a formal
  development effort is meant to be a human-readable record, presented
  as browsable PDF file or printed on paper.  The overall document
  structure follows traditional mathematical articles, with sections,
  intermediate explanations, definitions, theorems and proofs.

  \medskip The Isabelle document preparation system essentially acts
  as a front-end to {\LaTeX}.  After checking specifications and
  proofs formally, the theory sources are turned into typesetting
  instructions in a schematic manner.  This lets you write authentic
  reports on theory developments with little effort: many technical
  consistency checks are handled by the system.

  Here is an example to illustrate the idea of Isabelle document
  preparation.
\<close>

text_raw \<open>\begin{quotation}\<close>

text \<open>
  The following datatype definition of \<open>'a bintree\<close> models
  binary trees with nodes being decorated by elements of type \<^typ>\<open>'a\<close>.
\<close>

datatype 'a bintree =
     Leaf | Branch 'a  "'a bintree"  "'a bintree"

text \<open>
  \noindent The datatype induction rule generated here is of the form
  @{thm [indent = 1, display] bintree.induct [no_vars]}
\<close>

text_raw \<open>\end{quotation}\<close>

text \<open>
  \noindent The above document output has been produced as follows:

  \begin{ttbox}
  text {\ttlbrace}*
    The following datatype definition of {\at}{\ttlbrace}text "'a bintree"{\ttrbrace}
    models binary trees with nodes being decorated by elements
    of type {\at}{\ttlbrace}typ 'a{\ttrbrace}.
  *{\ttrbrace}

  datatype 'a bintree =
    Leaf | Branch 'a  "'a bintree"  "'a bintree"
  \end{ttbox}
  \begin{ttbox}
  text {\ttlbrace}*
    {\ttback}noindent The datatype induction rule generated here is
    of the form {\at}{\ttlbrace}thm [display] bintree.induct [no_vars]{\ttrbrace}
  *{\ttrbrace}
  \end{ttbox}\vspace{-\medskipamount}

  \noindent Here we have augmented the theory by formal comments
  (using \isakeyword{text} blocks), the informal parts may again refer
  to formal entities by means of ``antiquotations'' (such as
  \texttt{\at}\verb,{text "'a bintree"}, or
  \texttt{\at}\verb,{typ 'a},), see also \S\ref{sec:doc-prep-text}.
\<close>

subsection \<open>Isabelle Sessions\<close>

text \<open>
  In contrast to the highly interactive mode of Isabelle/Isar theory
  development, the document preparation stage essentially works in
  batch-mode.  An Isabelle \bfindex{session} consists of a collection
  of source files that may contribute to an output document.  Each
  session is derived from a single parent, usually an object-logic
  image like \texttt{HOL}.  This results in an overall tree structure,
  which is reflected by the output location in the file system
  (the root directory is determined by the Isabelle settings variable
  \verb,ISABELLE_BROWSER_INFO,).

  \medskip The easiest way to manage Isabelle sessions is via
  \texttt{isabelle mkroot} (to generate an initial session source
  setup) and \texttt{isabelle build} (to run sessions as specified in
  the corresponding \texttt{ROOT} file).  These Isabelle tools are
  described in further detail in the \emph{Isabelle System Manual}
  @{cite "isabelle-system"}.

  For example, a new session \texttt{MySession} (with document
  preparation) may be produced as follows:

\begin{verbatim}
  isabelle mkroot MySession
  isabelle build -D MySession
\end{verbatim}

  The \texttt{isabelle build} job also informs about the file-system
  location of the ultimate results.  The above dry run should be able
  to produce some \texttt{document.pdf} (with dummy title, empty table
  of contents etc.).  Any failure at this stage usually indicates
  technical problems of the {\LaTeX} installation.

  \medskip The detailed arrangement of the session sources is as
  follows.

  \begin{itemize}

  \item Directory \texttt{MySession} holds the required theory files
  $T@1$\texttt{.thy}, \dots, $T@n$\texttt{.thy}.

  \item File \texttt{MySession/ROOT} specifies the session options and
  content, with declarations for all wanted theories; it is sufficient
  to specify the terminal nodes of the theory dependency graph.

  \item Directory \texttt{MySession/document} contains everything
  required for the {\LaTeX} stage; only \texttt{root.tex} needs to be
  provided initially.

  The latter file holds appropriate {\LaTeX} code to commence a
  document (\verb,\documentclass, etc.), and to include the generated
  files $T@i$\texttt{.tex} for each theory.  Isabelle will generate a
  file \texttt{session.tex} holding {\LaTeX} commands to include all
  generated theory output files in topologically sorted order, so
  \verb,\input{session}, in the body of \texttt{root.tex} does the job
  in most situations.

  \end{itemize}

  One may now start to populate the directory \texttt{MySession} and
  its \texttt{ROOT} file accordingly.  The file
  \texttt{MySession/document/root.tex} should also be adapted at some
  point; the default version is mostly self-explanatory.  Note that
  \verb,\isabellestyle, enables fine-tuning of the general appearance
  of characters and mathematical symbols (see also
  \S\ref{sec:doc-prep-symbols}).

  Especially observe the included {\LaTeX} packages \texttt{isabelle}
  (mandatory), \texttt{isabellesym} (required for mathematical
  symbols), and the final \texttt{pdfsetup} (provides sane defaults
  for \texttt{hyperref}, including URL markup).  All three are
  distributed with Isabelle. Further packages may be required in
  particular applications, say for unusual mathematical symbols.

  \medskip Any additional files for the {\LaTeX} stage go into the
  \texttt{MySession/document} directory as well.  In particular,
  adding a file named \texttt{root.bib} causes an automatic run of
  \texttt{bibtex} to process a bibliographic database; see also
  \texttt{isabelle document} @{cite "isabelle-system"}.

  \medskip Any failure of the document preparation phase in an
  Isabelle batch session leaves the generated sources in their target
  location, identified by the accompanying error message.  This lets
  you trace {\LaTeX} problems with the generated files at hand.
\<close>

subsection \<open>Structure Markup\<close>

text \<open>
  The large-scale structure of Isabelle documents follows existing
  {\LaTeX} conventions, with chapters, sections, subsubsections etc.
  The Isar language includes separate \bfindex{markup commands}, which
  do not affect the formal meaning of a theory (or proof), but result
  in corresponding {\LaTeX} elements.

  From the Isabelle perspective, each markup command takes a single
  $text$ argument (delimited by \verb,",~\<open>\<dots>\<close>~\verb,", or
  \verb,{,\verb,*,~\<open>\<dots>\<close>~\verb,*,\verb,},).  After stripping any
  surrounding white space, the argument is passed to a {\LaTeX} macro
  \verb,\isamarkupXYZ, for command \isakeyword{XYZ}.  These macros are
  defined in \verb,isabelle.sty, according to the meaning given in the
  rightmost column above.

  \medskip The following source fragment illustrates structure markup
  of a theory.  Note that {\LaTeX} labels may be included inside of
  section headings as well.

  \begin{ttbox}
  section {\ttlbrace}* Some properties of Foo Bar elements *{\ttrbrace}

  theory Foo_Bar
  imports Main
  begin

  subsection {\ttlbrace}* Basic definitions *{\ttrbrace}

  definition foo :: \dots

  definition bar :: \dots

  subsection {\ttlbrace}* Derived rules *{\ttrbrace}

  lemma fooI: \dots
  lemma fooE: \dots

  subsection {\ttlbrace}* Main theorem {\ttback}label{\ttlbrace}sec:main-theorem{\ttrbrace} *{\ttrbrace}

  theorem main: \dots

  end
  \end{ttbox}
\<close>

subsection \<open>Formal Comments and Antiquotations \label{sec:doc-prep-text}\<close>

text \<open>
  Isabelle \bfindex{source comments}, which are of the form
  \verb,(,\verb,*,~\<open>\<dots>\<close>~\verb,*,\verb,),, essentially act like
  white space and do not really contribute to the content.  They
  mainly serve technical purposes to mark certain oddities in the raw
  input text.  In contrast, \bfindex{formal comments} are portions of
  text that are associated with formal Isabelle/Isar commands
  (\bfindex{marginal comments}), or as standalone paragraphs within a
  theory or proof context (\bfindex{text blocks}).

  \medskip Marginal comments are part of each command's concrete
  syntax @{cite "isabelle-isar-ref"}; the common form is ``\verb,--,~$text$''
  where $text$ is delimited by \verb,",\<open>\<dots>\<close>\verb,", or
  \verb,{,\verb,*,~\<open>\<dots>\<close>~\verb,*,\verb,}, as before.  Multiple
  marginal comments may be given at the same time.  Here is a simple
  example:
\<close>

lemma "A --> A"
  \<comment> \<open>a triviality of propositional logic\<close>
  \<comment> \<open>(should not really bother)\<close>
  by (rule impI) \<comment> \<open>implicit assumption step involved here\<close>

text \<open>
  \noindent The above output has been produced as follows:

\begin{verbatim}
  lemma "A --> A"
    -- "a triviality of propositional logic"
    -- "(should not really bother)"
    by (rule impI) -- "implicit assumption step involved here"
\end{verbatim}

  From the {\LaTeX} viewpoint, ``\verb,--,'' acts like a markup
  command, associated with the macro \verb,\isamarkupcmt, (taking a
  single argument).

  \medskip Text blocks are introduced by the commands \bfindex{text}
  and \bfindex{txt}. Each takes again a single $text$ argument,
  which is interpreted as a free-form paragraph in {\LaTeX}
  (surrounded by some additional vertical space).  The typesetting
  may be changed by redefining the {\LaTeX} environments of
  \verb,isamarkuptext, or \verb,isamarkuptxt,, respectively
  (via \verb,\renewenvironment,).

  \medskip The $text$ part of Isabelle markup commands essentially
  inserts \emph{quoted material} into a formal text, mainly for
  instruction of the reader.  An \bfindex{antiquotation} is again a
  formal object embedded into such an informal portion.  The
  interpretation of antiquotations is limited to some well-formedness
  checks, with the result being pretty printed to the resulting
  document.  Quoted text blocks together with antiquotations provide
  an attractive means of referring to formal entities, with good
  confidence in getting the technical details right (especially syntax
  and types).

  The general syntax of antiquotations is as follows:
  \texttt{{\at}{\ttlbrace}$name$ $arguments${\ttrbrace}}, or
  \texttt{{\at}{\ttlbrace}$name$ [$options$] $arguments${\ttrbrace}}
  for a comma-separated list of options consisting of a $name$ or
  \texttt{$name$=$value$} each.  The syntax of $arguments$ depends on
  the kind of antiquotation, it generally follows the same conventions
  for types, terms, or theorems as in the formal part of a theory.

  \medskip This sentence demonstrates quotations and antiquotations:
  \<^term>\<open>%x y. x\<close> is a well-typed term.

  \medskip\noindent The output above was produced as follows:
  \begin{ttbox}
text {\ttlbrace}*
  This sentence demonstrates quotations and antiquotations:
  {\at}{\ttlbrace}term "%x y. x"{\ttrbrace} is a well-typed term.
*{\ttrbrace}
  \end{ttbox}\vspace{-\medskipamount}

  The notational change from the ASCII character~\verb,%, to the
  symbol~\<open>\<lambda>\<close> reveals that Isabelle printed this term, after
  parsing and type-checking.  Document preparation enables symbolic
  output by default.

  \medskip The next example includes an option to show the type of all
  variables.  The antiquotation
  \texttt{{\at}}\verb,{term [show_types] "%x y. x"}, produces the
  output @{term [show_types] "%x y. x"}.  Type inference has figured
  out the most general typings in the present theory context.  Terms
  may acquire different typings due to constraints imposed by their
  environment; within a proof, for example, variables are given the
  same types as they have in the main goal statement.

  \medskip Several further kinds of antiquotations and options are
  available @{cite "isabelle-isar-ref"}.  Here are a few commonly used
  combinations:

  \medskip

  \begin{tabular}{ll}
  \texttt{\at}\verb,{typ,~$\tau$\verb,}, & print type $\tau$ \\
  \texttt{\at}\verb,{const,~$c$\verb,}, & check existence of $c$ and print it \\
  \texttt{\at}\verb,{term,~$t$\verb,}, & print term $t$ \\
  \texttt{\at}\verb,{prop,~$\phi$\verb,}, & print proposition $\phi$ \\
  \texttt{\at}\verb,{prop [display],~$\phi$\verb,}, & print large proposition $\phi$ (with linebreaks) \\
  \texttt{\at}\verb,{prop [source],~$\phi$\verb,}, & check proposition $\phi$, print its input \\
  \texttt{\at}\verb,{thm,~$a$\verb,}, & print fact $a$ \\
  \texttt{\at}\verb,{thm,~$a$~\verb,[no_vars]}, & print fact $a$, fixing schematic variables \\
  \texttt{\at}\verb,{thm [source],~$a$\verb,}, & check availability of fact $a$, print its name \\
  \texttt{\at}\verb,{text,~$s$\verb,}, & print uninterpreted text $s$ \\
  \end{tabular}

  \medskip

  Note that \attrdx{no_vars} given above is \emph{not} an
  antiquotation option, but an attribute of the theorem argument given
  here.  This might be useful with a diagnostic command like
  \isakeyword{thm}, too.

  \medskip The \texttt{\at}\verb,{text, $s$\verb,}, antiquotation is
  particularly interesting.  Embedding uninterpreted text within an
  informal body might appear useless at first sight.  Here the key
  virtue is that the string $s$ is processed as Isabelle output,
  interpreting Isabelle symbols appropriately.

  For example, \texttt{\at}\verb,{text "\<forall>\<exists>"}, produces \<open>\<forall>\<exists>\<close>, according to the standard interpretation of these symbol
  (cf.\ \S\ref{sec:doc-prep-symbols}).  Thus we achieve consistent
  mathematical notation in both the formal and informal parts of the
  document very easily, independently of the term language of
  Isabelle.  Manual {\LaTeX} code would leave more control over the
  typesetting, but is also slightly more tedious.
\<close>

subsection \<open>Interpretation of Symbols \label{sec:doc-prep-symbols}\<close>

text \<open>
  As has been pointed out before (\S\ref{sec:syntax-symbols}),
  Isabelle symbols are the smallest syntactic entities --- a
  straightforward generalization of ASCII characters.  While Isabelle
  does not impose any interpretation of the infinite collection of
  named symbols, {\LaTeX} documents use canonical glyphs for certain
  standard symbols @{cite "isabelle-isar-ref"}.

  The {\LaTeX} code produced from Isabelle text follows a simple
  scheme.  You can tune the final appearance by redefining certain
  macros, say in \texttt{root.tex} of the document.

  \begin{enumerate}

  \item 7-bit ASCII characters: letters \texttt{A\dots Z} and
  \texttt{a\dots z} are output directly, digits are passed as an
  argument to the \verb,\isadigit, macro, other characters are
  replaced by specifically named macros of the form
  \verb,\isacharXYZ,.

  \item Named symbols: \verb,\,\verb,<XYZ>, is turned into
  \verb,{\isasymXYZ},; note the additional braces.

  \item Named control symbols: \verb,\,\verb,<^XYZ>, is turned into
  \verb,\isactrlXYZ,; subsequent symbols may act as arguments if the
  control macro is defined accordingly.

  \end{enumerate}

  You may occasionally wish to give new {\LaTeX} interpretations of
  named symbols.  This merely requires an appropriate definition of
  \verb,\isasymXYZ,, for \verb,\,\verb,<XYZ>, (see
  \texttt{isabelle.sty} for working examples).  Control symbols are
  slightly more difficult to get right, though.

  \medskip The \verb,\isabellestyle, macro provides a high-level
  interface to tune the general appearance of individual symbols.  For
  example, \verb,\isabellestyle{it}, uses the italics text style to
  mimic the general appearance of the {\LaTeX} math mode; double
  quotes are not printed at all.  The resulting quality of typesetting
  is quite good, so this should be the default style for work that
  gets distributed to a broader audience.
\<close>

subsection \<open>Suppressing Output \label{sec:doc-prep-suppress}\<close>

text \<open>
  By default, Isabelle's document system generates a {\LaTeX} file for
  each theory that gets loaded while running the session.  The
  generated \texttt{session.tex} will include all of these in order of
  appearance, which in turn gets included by the standard
  \texttt{root.tex}.  Certainly one may change the order or suppress
  unwanted theories by ignoring \texttt{session.tex} and load
  individual files directly in \texttt{root.tex}.  On the other hand,
  such an arrangement requires additional maintenance whenever the
  collection of theories changes.

  Alternatively, one may tune the theory loading process in
  \texttt{ROOT} itself: some sequential order of \textbf{theories}
  sections may enforce a certain traversal of the dependency graph,
  although this could degrade parallel processing.  The nodes of each
  sub-graph that is specified here are presented in some topological
  order of their formal dependencies.

  Moreover, the system build option \verb,document=false, allows to
  disable document generation for some theories.  Its usage in the
  session \texttt{ROOT} is like this:

\begin{verbatim}
  theories [document = false] T
\end{verbatim}

  \medskip Theory output may be suppressed more selectively, either
  via \bfindex{tagged command regions} or \bfindex{ignored material}.

  Tagged command regions works by annotating commands with named tags,
  which correspond to certain {\LaTeX} markup that tells how to treat
  particular parts of a document when doing the actual type-setting.
  By default, certain Isabelle/Isar commands are implicitly marked up
  using the predefined tags ``\emph{theory}'' (for theory begin and
  end), ``\emph{proof}'' (for proof commands), and ``\emph{ML}'' (for
  commands involving ML code).  Users may add their own tags using the
  \verb,%,\emph{tag} notation right after a command name.  In the
  subsequent example we hide a particularly irrelevant proof:
\<close>

lemma "x = x" by %invisible (simp)

text \<open>
  The original source has been ``\verb,lemma "x = x" by %invisible (simp),''.
  Tags observe the structure of proofs; adjacent commands with the
  same tag are joined into a single region.  The Isabelle document
  preparation system allows the user to specify how to interpret a
  tagged region, in order to keep, drop, or fold the corresponding
  parts of the document.  See the \emph{Isabelle System Manual}
  @{cite "isabelle-system"} for further details, especially on
  \texttt{isabelle build} and \texttt{isabelle document}.

  Ignored material is specified by delimiting the original formal
  source with special source comments
  \verb,(,\verb,*,\verb,<,\verb,*,\verb,), and
  \verb,(,\verb,*,\verb,>,\verb,*,\verb,),.  These parts are stripped
  before the type-setting phase, without affecting the formal checking
  of the theory, of course.  For example, we may hide parts of a proof
  that seem unfit for general public inspection.  The following
  ``fully automatic'' proof is actually a fake:
\<close>

lemma "x \<noteq> (0::int) \<Longrightarrow> 0 < x * x"
  by (auto(*<*)simp add: zero_less_mult_iff(*>*))

text \<open>
  \noindent The real source of the proof has been as follows:

\begin{verbatim}
  by (auto(*<*)simp add: zero_less_mult_iff(*>*))
\end{verbatim}
%(*

  \medskip Suppressing portions of printed text demands care.  You
  should not misrepresent the underlying theory development.  It is
  easy to invalidate the visible text by hiding references to
  questionable axioms, for example.
\<close>

(*<*)
end
(*>*)