(*  Title:      ZF/Bin.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

   The sign Pls stands for an infinite string of leading 0's.
   The sign Min stands for an infinite string of leading 1's.

A number can have multiple representations, namely leading 0's with sign
Pls and leading 1's with sign Min.  See twos-compl.ML/int_of_binary for
the numerical interpretation.

The representation expects that (m mod 2) is 0 or 1, even if m is negative;
For instance, ~5 div 2 = ~3 and ~5 mod 2 = 1; thus ~5 = (~3)*2 + 1
*)

section\<open>Arithmetic on Binary Integers\<close>

theory Bin
imports Int Datatype
begin

consts  bin :: i
datatype
  "bin" = Pls
        | Min
        | Bit ("w \<in> bin", "b \<in> bool")     (infixl \<open>BIT\<close> 90)

consts
  integ_of  :: "i=>i"
  NCons     :: "[i,i]=>i"
  bin_succ  :: "i=>i"
  bin_pred  :: "i=>i"
  bin_minus :: "i=>i"
  bin_adder :: "i=>i"
  bin_mult  :: "[i,i]=>i"

primrec
  integ_of_Pls:  "integ_of (Pls)     = $# 0"
  integ_of_Min:  "integ_of (Min)     = $-($#1)"
  integ_of_BIT:  "integ_of (w BIT b) = $#b $+ integ_of(w) $+ integ_of(w)"

    (** recall that cond(1,b,c)=b and cond(0,b,c)=0 **)

primrec (*NCons adds a bit, suppressing leading 0s and 1s*)
  NCons_Pls: "NCons (Pls,b)     = cond(b,Pls BIT b,Pls)"
  NCons_Min: "NCons (Min,b)     = cond(b,Min,Min BIT b)"
  NCons_BIT: "NCons (w BIT c,b) = w BIT c BIT b"

primrec (*successor.  If a BIT, can change a 0 to a 1 without recursion.*)
  bin_succ_Pls:  "bin_succ (Pls)     = Pls BIT 1"
  bin_succ_Min:  "bin_succ (Min)     = Pls"
  bin_succ_BIT:  "bin_succ (w BIT b) = cond(b, bin_succ(w) BIT 0, NCons(w,1))"

primrec (*predecessor*)
  bin_pred_Pls:  "bin_pred (Pls)     = Min"
  bin_pred_Min:  "bin_pred (Min)     = Min BIT 0"
  bin_pred_BIT:  "bin_pred (w BIT b) = cond(b, NCons(w,0), bin_pred(w) BIT 1)"

primrec (*unary negation*)
  bin_minus_Pls:
    "bin_minus (Pls)       = Pls"
  bin_minus_Min:
    "bin_minus (Min)       = Pls BIT 1"
  bin_minus_BIT:
    "bin_minus (w BIT b) = cond(b, bin_pred(NCons(bin_minus(w),0)),
                                bin_minus(w) BIT 0)"

primrec (*sum*)
  bin_adder_Pls:
    "bin_adder (Pls)     = (\<lambda>w\<in>bin. w)"
  bin_adder_Min:
    "bin_adder (Min)     = (\<lambda>w\<in>bin. bin_pred(w))"
  bin_adder_BIT:
    "bin_adder (v BIT x) =
       (\<lambda>w\<in>bin.
         bin_case (v BIT x, bin_pred(v BIT x),
                   %w y. NCons(bin_adder (v) ` cond(x and y, bin_succ(w), w),
                               x xor y),
                   w))"

(*The bin_case above replaces the following mutually recursive function:
primrec
  "adding (v,x,Pls)     = v BIT x"
  "adding (v,x,Min)     = bin_pred(v BIT x)"
  "adding (v,x,w BIT y) = NCons(bin_adder (v, cond(x and y, bin_succ(w), w)),
                                x xor y)"
*)

definition
  bin_add   :: "[i,i]=>i"  where
    "bin_add(v,w) == bin_adder(v)`w"

primrec
  bin_mult_Pls:
    "bin_mult (Pls,w)     = Pls"
  bin_mult_Min:
    "bin_mult (Min,w)     = bin_minus(w)"
  bin_mult_BIT:
    "bin_mult (v BIT b,w) = cond(b, bin_add(NCons(bin_mult(v,w),0),w),
                                 NCons(bin_mult(v,w),0))"

syntax
  "_Int0" :: i  (\<open>#' 0\<close>)
  "_Int1" :: i  (\<open>#' 1\<close>)
  "_Int2" :: i  (\<open>#' 2\<close>)
  "_Neg_Int1" :: i  (\<open>#-' 1\<close>)
  "_Neg_Int2" :: i  (\<open>#-' 2\<close>)
translations
  "#0" \<rightleftharpoons> "CONST integ_of(CONST Pls)"
  "#1" \<rightleftharpoons> "CONST integ_of(CONST Pls BIT 1)"
  "#2" \<rightleftharpoons> "CONST integ_of(CONST Pls BIT 1 BIT 0)"
  "#-1" \<rightleftharpoons> "CONST integ_of(CONST Min)"
  "#-2" \<rightleftharpoons> "CONST integ_of(CONST Min BIT 0)"

syntax
  "_Int" :: "num_token => i"  (\<open>#_\<close> 1000)
  "_Neg_Int" :: "num_token => i"  (\<open>#-_\<close> 1000)

ML_file \<open>Tools/numeral_syntax.ML\<close>

declare bin.intros [simp,TC]

lemma NCons_Pls_0: "NCons(Pls,0) = Pls"
by simp

lemma NCons_Pls_1: "NCons(Pls,1) = Pls BIT 1"
by simp

lemma NCons_Min_0: "NCons(Min,0) = Min BIT 0"
by simp

lemma NCons_Min_1: "NCons(Min,1) = Min"
by simp

lemma NCons_BIT: "NCons(w BIT x,b) = w BIT x BIT b"
by (simp add: bin.case_eqns)

lemmas NCons_simps [simp] =
    NCons_Pls_0 NCons_Pls_1 NCons_Min_0 NCons_Min_1 NCons_BIT

(** Type checking **)

lemma integ_of_type [TC]: "w \<in> bin ==> integ_of(w) \<in> int"
apply (induct_tac "w")
apply (simp_all add: bool_into_nat)
done

lemma NCons_type [TC]: "[| w \<in> bin; b \<in> bool |] ==> NCons(w,b) \<in> bin"
by (induct_tac "w", auto)

lemma bin_succ_type [TC]: "w \<in> bin ==> bin_succ(w) \<in> bin"
by (induct_tac "w", auto)

lemma bin_pred_type [TC]: "w \<in> bin ==> bin_pred(w) \<in> bin"
by (induct_tac "w", auto)

lemma bin_minus_type [TC]: "w \<in> bin ==> bin_minus(w) \<in> bin"
by (induct_tac "w", auto)

(*This proof is complicated by the mutual recursion*)
lemma bin_add_type [rule_format]:
     "v \<in> bin ==> \<forall>w\<in>bin. bin_add(v,w) \<in> bin"
apply (unfold bin_add_def)
apply (induct_tac "v")
apply (rule_tac [3] ballI)
apply (rename_tac [3] "w'")
apply (induct_tac [3] "w'")
apply (simp_all add: NCons_type)
done

declare bin_add_type [TC]

lemma bin_mult_type [TC]: "[| v \<in> bin; w \<in> bin |] ==> bin_mult(v,w) \<in> bin"
by (induct_tac "v", auto)

subsubsection\<open>The Carry and Borrow Functions,
            \<^term>\<open>bin_succ\<close> and \<^term>\<open>bin_pred\<close>\<close>

(*NCons preserves the integer value of its argument*)
lemma integ_of_NCons [simp]:
     "[| w \<in> bin; b \<in> bool |] ==> integ_of(NCons(w,b)) = integ_of(w BIT b)"
apply (erule bin.cases)
apply (auto elim!: boolE)
done

lemma integ_of_succ [simp]:
     "w \<in> bin ==> integ_of(bin_succ(w)) = $#1 $+ integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac elim!: boolE)
done

lemma integ_of_pred [simp]:
     "w \<in> bin ==> integ_of(bin_pred(w)) = $- ($#1) $+ integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac elim!: boolE)
done

subsubsection\<open>\<^term>\<open>bin_minus\<close>: Unary Negation of Binary Integers\<close>

lemma integ_of_minus: "w \<in> bin ==> integ_of(bin_minus(w)) = $- integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac zminus_zadd_distrib  elim!: boolE)
done

subsubsection\<open>\<^term>\<open>bin_add\<close>: Binary Addition\<close>

lemma bin_add_Pls [simp]: "w \<in> bin ==> bin_add(Pls,w) = w"
by (unfold bin_add_def, simp)

lemma bin_add_Pls_right: "w \<in> bin ==> bin_add(w,Pls) = w"
apply (unfold bin_add_def)
apply (erule bin.induct, auto)
done

lemma bin_add_Min [simp]: "w \<in> bin ==> bin_add(Min,w) = bin_pred(w)"
by (unfold bin_add_def, simp)

lemma bin_add_Min_right: "w \<in> bin ==> bin_add(w,Min) = bin_pred(w)"
apply (unfold bin_add_def)
apply (erule bin.induct, auto)
done

lemma bin_add_BIT_Pls [simp]: "bin_add(v BIT x,Pls) = v BIT x"
by (unfold bin_add_def, simp)

lemma bin_add_BIT_Min [simp]: "bin_add(v BIT x,Min) = bin_pred(v BIT x)"
by (unfold bin_add_def, simp)

lemma bin_add_BIT_BIT [simp]:
     "[| w \<in> bin;  y \<in> bool |]
      ==> bin_add(v BIT x, w BIT y) =
          NCons(bin_add(v, cond(x and y, bin_succ(w), w)), x xor y)"
by (unfold bin_add_def, simp)

lemma integ_of_add [rule_format]:
     "v \<in> bin ==>
          \<forall>w\<in>bin. integ_of(bin_add(v,w)) = integ_of(v) $+ integ_of(w)"
apply (erule bin.induct, simp, simp)
apply (rule ballI)
apply (induct_tac "wa")
apply (auto simp add: zadd_ac elim!: boolE)
done

(*Subtraction*)
lemma diff_integ_of_eq:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $- integ_of(w) = integ_of(bin_add (v, bin_minus(w)))"
apply (unfold zdiff_def)
apply (simp add: integ_of_add integ_of_minus)
done

subsubsection\<open>\<^term>\<open>bin_mult\<close>: Binary Multiplication\<close>

lemma integ_of_mult:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(bin_mult(v,w)) = integ_of(v) $* integ_of(w)"
apply (induct_tac "v", simp)
apply (simp add: integ_of_minus)
apply (auto simp add: zadd_ac integ_of_add zadd_zmult_distrib  elim!: boolE)
done

subsection\<open>Computations\<close>

(** extra rules for bin_succ, bin_pred **)

lemma bin_succ_1: "bin_succ(w BIT 1) = bin_succ(w) BIT 0"
by simp

lemma bin_succ_0: "bin_succ(w BIT 0) = NCons(w,1)"
by simp

lemma bin_pred_1: "bin_pred(w BIT 1) = NCons(w,0)"
by simp

lemma bin_pred_0: "bin_pred(w BIT 0) = bin_pred(w) BIT 1"
by simp

(** extra rules for bin_minus **)

lemma bin_minus_1: "bin_minus(w BIT 1) = bin_pred(NCons(bin_minus(w), 0))"
by simp

lemma bin_minus_0: "bin_minus(w BIT 0) = bin_minus(w) BIT 0"
by simp

(** extra rules for bin_add **)

lemma bin_add_BIT_11: "w \<in> bin ==> bin_add(v BIT 1, w BIT 1) =
                     NCons(bin_add(v, bin_succ(w)), 0)"
by simp

lemma bin_add_BIT_10: "w \<in> bin ==> bin_add(v BIT 1, w BIT 0) =
                     NCons(bin_add(v,w), 1)"
by simp

lemma bin_add_BIT_0: "[| w \<in> bin;  y \<in> bool |]
      ==> bin_add(v BIT 0, w BIT y) = NCons(bin_add(v,w), y)"
by simp

(** extra rules for bin_mult **)

lemma bin_mult_1: "bin_mult(v BIT 1, w) = bin_add(NCons(bin_mult(v,w),0), w)"
by simp

lemma bin_mult_0: "bin_mult(v BIT 0, w) = NCons(bin_mult(v,w),0)"
by simp

(** Simplification rules with integer constants **)

lemma int_of_0: "$#0 = #0"
by simp

lemma int_of_succ: "$# succ(n) = #1 $+ $#n"
by (simp add: int_of_add [symmetric] natify_succ)

lemma zminus_0 [simp]: "$- #0 = #0"
by simp

lemma zadd_0_intify [simp]: "#0 $+ z = intify(z)"
by simp

lemma zadd_0_right_intify [simp]: "z $+ #0 = intify(z)"
by simp

lemma zmult_1_intify [simp]: "#1 $* z = intify(z)"
by simp

lemma zmult_1_right_intify [simp]: "z $* #1 = intify(z)"
by (subst zmult_commute, simp)

lemma zmult_0 [simp]: "#0 $* z = #0"
by simp

lemma zmult_0_right [simp]: "z $* #0 = #0"
by (subst zmult_commute, simp)

lemma zmult_minus1 [simp]: "#-1 $* z = $-z"
by (simp add: zcompare_rls)

lemma zmult_minus1_right [simp]: "z $* #-1 = $-z"
apply (subst zmult_commute)
apply (rule zmult_minus1)
done

subsection\<open>Simplification Rules for Comparison of Binary Numbers\<close>
text\<open>Thanks to Norbert Voelker\<close>

(** Equals (=) **)

lemma eq_integ_of_eq:
     "[| v \<in> bin;  w \<in> bin |]
      ==> ((integ_of(v)) = integ_of(w)) \<longleftrightarrow>
          iszero (integ_of (bin_add (v, bin_minus(w))))"
apply (unfold iszero_def)
apply (simp add: zcompare_rls integ_of_add integ_of_minus)
done

lemma iszero_integ_of_Pls: "iszero (integ_of(Pls))"
by (unfold iszero_def, simp)

lemma nonzero_integ_of_Min: "~ iszero (integ_of(Min))"
apply (unfold iszero_def)
apply (simp add: zminus_equation)
done

lemma iszero_integ_of_BIT:
     "[| w \<in> bin; x \<in> bool |]
      ==> iszero (integ_of (w BIT x)) \<longleftrightarrow> (x=0 & iszero (integ_of(w)))"
apply (unfold iszero_def, simp)
apply (subgoal_tac "integ_of (w) \<in> int")
apply typecheck
apply (drule int_cases)
apply (safe elim!: boolE)
apply (simp_all (asm_lr) add: zcompare_rls zminus_zadd_distrib [symmetric]
                     int_of_add [symmetric])
done

lemma iszero_integ_of_0:
     "w \<in> bin ==> iszero (integ_of (w BIT 0)) \<longleftrightarrow> iszero (integ_of(w))"
by (simp only: iszero_integ_of_BIT, blast)

lemma iszero_integ_of_1: "w \<in> bin ==> ~ iszero (integ_of (w BIT 1))"
by (simp only: iszero_integ_of_BIT, blast)

(** Less-than (<) **)

lemma less_integ_of_eq_neg:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $< integ_of(w)
          \<longleftrightarrow> znegative (integ_of (bin_add (v, bin_minus(w))))"
apply (unfold zless_def zdiff_def)
apply (simp add: integ_of_minus integ_of_add)
done

lemma not_neg_integ_of_Pls: "~ znegative (integ_of(Pls))"
by simp

lemma neg_integ_of_Min: "znegative (integ_of(Min))"
by simp

lemma neg_integ_of_BIT:
     "[| w \<in> bin; x \<in> bool |]
      ==> znegative (integ_of (w BIT x)) \<longleftrightarrow> znegative (integ_of(w))"
apply simp
apply (subgoal_tac "integ_of (w) \<in> int")
apply typecheck
apply (drule int_cases)
apply (auto elim!: boolE simp add: int_of_add [symmetric]  zcompare_rls)
apply (simp_all add: zminus_zadd_distrib [symmetric] zdiff_def
                     int_of_add [symmetric])
apply (subgoal_tac "$#1 $- $# succ (succ (n #+ n)) = $- $# succ (n #+ n) ")
 apply (simp add: zdiff_def)
apply (simp add: equation_zminus int_of_diff [symmetric])
done

(** Less-than-or-equals (<=) **)

lemma le_integ_of_eq_not_less:
     "(integ_of(x) $\<le> (integ_of(w))) \<longleftrightarrow> ~ (integ_of(w) $< (integ_of(x)))"
by (simp add: not_zless_iff_zle [THEN iff_sym])

(*Delete the original rewrites, with their clumsy conditional expressions*)
declare bin_succ_BIT [simp del]
        bin_pred_BIT [simp del]
        bin_minus_BIT [simp del]
        NCons_Pls [simp del]
        NCons_Min [simp del]
        bin_adder_BIT [simp del]
        bin_mult_BIT [simp del]

(*Hide the binary representation of integer constants*)
declare integ_of_Pls [simp del] integ_of_Min [simp del] integ_of_BIT [simp del]

lemmas bin_arith_extra_simps =
     integ_of_add [symmetric]
     integ_of_minus [symmetric]
     integ_of_mult [symmetric]
     bin_succ_1 bin_succ_0
     bin_pred_1 bin_pred_0
     bin_minus_1 bin_minus_0
     bin_add_Pls_right bin_add_Min_right
     bin_add_BIT_0 bin_add_BIT_10 bin_add_BIT_11
     diff_integ_of_eq
     bin_mult_1 bin_mult_0 NCons_simps

(*For making a minimal simpset, one must include these default simprules
  of thy.  Also include simp_thms, or at least (~False)=True*)
lemmas bin_arith_simps =
     bin_pred_Pls bin_pred_Min
     bin_succ_Pls bin_succ_Min
     bin_add_Pls bin_add_Min
     bin_minus_Pls bin_minus_Min
     bin_mult_Pls bin_mult_Min
     bin_arith_extra_simps

(*Simplification of relational operations*)
lemmas bin_rel_simps =
     eq_integ_of_eq iszero_integ_of_Pls nonzero_integ_of_Min
     iszero_integ_of_0 iszero_integ_of_1
     less_integ_of_eq_neg
     not_neg_integ_of_Pls neg_integ_of_Min neg_integ_of_BIT
     le_integ_of_eq_not_less

declare bin_arith_simps [simp]
declare bin_rel_simps [simp]

(** Simplification of arithmetic when nested to the right **)

lemma add_integ_of_left [simp]:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $+ (integ_of(w) $+ z) = (integ_of(bin_add(v,w)) $+ z)"
by (simp add: zadd_assoc [symmetric])

lemma mult_integ_of_left [simp]:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $* (integ_of(w) $* z) = (integ_of(bin_mult(v,w)) $* z)"
by (simp add: zmult_assoc [symmetric])

lemma add_integ_of_diff1 [simp]:
    "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $+ (integ_of(w) $- c) = integ_of(bin_add(v,w)) $- (c)"
apply (unfold zdiff_def)
apply (rule add_integ_of_left, auto)
done

lemma add_integ_of_diff2 [simp]:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $+ (c $- integ_of(w)) =
          integ_of (bin_add (v, bin_minus(w))) $+ (c)"
apply (subst diff_integ_of_eq [symmetric])
apply (simp_all add: zdiff_def zadd_ac)
done

(** More for integer constants **)

declare int_of_0 [simp] int_of_succ [simp]

lemma zdiff0 [simp]: "#0 $- x = $-x"
by (simp add: zdiff_def)

lemma zdiff0_right [simp]: "x $- #0 = intify(x)"
by (simp add: zdiff_def)

lemma zdiff_self [simp]: "x $- x = #0"
by (simp add: zdiff_def)

lemma znegative_iff_zless_0: "k \<in> int ==> znegative(k) \<longleftrightarrow> k $< #0"
by (simp add: zless_def)

lemma zero_zless_imp_znegative_zminus: "[|#0 $< k; k \<in> int|] ==> znegative($-k)"
by (simp add: zless_def)

lemma zero_zle_int_of [simp]: "#0 $\<le> $# n"
by (simp add: not_zless_iff_zle [THEN iff_sym] znegative_iff_zless_0 [THEN iff_sym])

lemma nat_of_0 [simp]: "nat_of(#0) = 0"
by (simp only: natify_0 int_of_0 [symmetric] nat_of_int_of)

lemma nat_le_int0_lemma: "[| z $\<le> $#0; z \<in> int |] ==> nat_of(z) = 0"
by (auto simp add: znegative_iff_zless_0 [THEN iff_sym] zle_def zneg_nat_of)

lemma nat_le_int0: "z $\<le> $#0 ==> nat_of(z) = 0"
apply (subgoal_tac "nat_of (intify (z)) = 0")
apply (rule_tac [2] nat_le_int0_lemma, auto)
done

lemma int_of_eq_0_imp_natify_eq_0: "$# n = #0 ==> natify(n) = 0"
by (rule not_znegative_imp_zero, auto)

lemma nat_of_zminus_int_of: "nat_of($- $# n) = 0"
by (simp add: nat_of_def int_of_def raw_nat_of zminus image_intrel_int)

lemma int_of_nat_of: "#0 $\<le> z ==> $# nat_of(z) = intify(z)"
apply (rule not_zneg_nat_of_intify)
apply (simp add: znegative_iff_zless_0 not_zless_iff_zle)
done

declare int_of_nat_of [simp] nat_of_zminus_int_of [simp]

lemma int_of_nat_of_if: "$# nat_of(z) = (if #0 $\<le> z then intify(z) else #0)"
by (simp add: int_of_nat_of znegative_iff_zless_0 not_zle_iff_zless)

lemma zless_nat_iff_int_zless: "[| m \<in> nat; z \<in> int |] ==> (m < nat_of(z)) \<longleftrightarrow> ($#m $< z)"
apply (case_tac "znegative (z) ")
apply (erule_tac [2] not_zneg_nat_of [THEN subst])
apply (auto dest: zless_trans dest!: zero_zle_int_of [THEN zle_zless_trans]
            simp add: znegative_iff_zless_0)
done

(** nat_of and zless **)

(*An alternative condition is  @{term"$#0 \<subseteq> w"}  *)
lemma zless_nat_conj_lemma: "$#0 $< z ==> (nat_of(w) < nat_of(z)) \<longleftrightarrow> (w $< z)"
apply (rule iff_trans)
apply (rule zless_int_of [THEN iff_sym])
apply (auto simp add: int_of_nat_of_if simp del: zless_int_of)
apply (auto elim: zless_asym simp add: not_zle_iff_zless)
apply (blast intro: zless_zle_trans)
done

lemma zless_nat_conj: "(nat_of(w) < nat_of(z)) \<longleftrightarrow> ($#0 $< z & w $< z)"
apply (case_tac "$#0 $< z")
apply (auto simp add: zless_nat_conj_lemma nat_le_int0 not_zless_iff_zle)
done

(*This simprule cannot be added unless we can find a way to make eq_integ_of_eq
  unconditional!
  [The condition "True" is a hack to prevent looping.
    Conditional rewrite rules are tried after unconditional ones, so a rule
    like eq_nat_number_of will be tried first to eliminate #mm=#nn.]
  lemma integ_of_reorient [simp]:
       "True ==> (integ_of(w) = x) \<longleftrightarrow> (x = integ_of(w))"
  by auto
*)

lemma integ_of_minus_reorient [simp]:
     "(integ_of(w) = $- x) \<longleftrightarrow> ($- x = integ_of(w))"
by auto

lemma integ_of_add_reorient [simp]:
     "(integ_of(w) = x $+ y) \<longleftrightarrow> (x $+ y = integ_of(w))"
by auto

lemma integ_of_diff_reorient [simp]:
     "(integ_of(w) = x $- y) \<longleftrightarrow> (x $- y = integ_of(w))"
by auto

lemma integ_of_mult_reorient [simp]:
     "(integ_of(w) = x $* y) \<longleftrightarrow> (x $* y = integ_of(w))"
by auto

(** To simplify inequalities involving integer negation and literals,
    such as -x = #3
**)

lemmas [simp] =
  zminus_equation [where y = "integ_of(w)"]
  equation_zminus [where x = "integ_of(w)"]
  for w

lemmas [iff] =
  zminus_zless [where y = "integ_of(w)"]
  zless_zminus [where x = "integ_of(w)"]
  for w

lemmas [iff] =
  zminus_zle [where y = "integ_of(w)"]
  zle_zminus [where x = "integ_of(w)"]
  for w

lemmas [simp] =
  Let_def [where s = "integ_of(w)"] for w

(*** Simprocs for numeric literals ***)

(** Combining of literal coefficients in sums of products **)

lemma zless_iff_zdiff_zless_0: "(x $< y) \<longleftrightarrow> (x$-y $< #0)"
  by (simp add: zcompare_rls)

lemma eq_iff_zdiff_eq_0: "[| x \<in> int; y \<in> int |] ==> (x = y) \<longleftrightarrow> (x$-y = #0)"
  by (simp add: zcompare_rls)

lemma zle_iff_zdiff_zle_0: "(x $\<le> y) \<longleftrightarrow> (x$-y $\<le> #0)"
  by (simp add: zcompare_rls)

(** For combine_numerals **)

lemma left_zadd_zmult_distrib: "i$*u $+ (j$*u $+ k) = (i$+j)$*u $+ k"
  by (simp add: zadd_zmult_distrib zadd_ac)

(** For cancel_numerals **)

lemma eq_add_iff1: "(i$*u $+ m = j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m = intify(n))"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

lemma eq_add_iff2: "(i$*u $+ m = j$*u $+ n) \<longleftrightarrow> (intify(m) = (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

context fixes n :: i
begin

lemmas rel_iff_rel_0_rls =
  zless_iff_zdiff_zless_0 [where y = "u $+ v"]
  eq_iff_zdiff_eq_0 [where y = "u $+ v"]
  zle_iff_zdiff_zle_0 [where y = "u $+ v"]
  zless_iff_zdiff_zless_0 [where y = n]
  eq_iff_zdiff_eq_0 [where y = n]
  zle_iff_zdiff_zle_0 [where y = n]
  for u v

lemma less_add_iff1: "(i$*u $+ m $< j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m $< n)"
  apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls)
  done

lemma less_add_iff2: "(i$*u $+ m $< j$*u $+ n) \<longleftrightarrow> (m $< (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls)
  done

end

lemma le_add_iff1: "(i$*u $+ m $\<le> j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m $\<le> n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

lemma le_add_iff2: "(i$*u $+ m $\<le> j$*u $+ n) \<longleftrightarrow> (m $\<le> (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

ML_file \<open>int_arith.ML\<close>

subsection \<open>examples:\<close>

text \<open>\<open>combine_numerals_prod\<close> (products of separate literals)\<close>
lemma "#5 $* x $* #3 = y" apply simp oops

schematic_goal "y2 $+ ?x42 = y $+ y2" apply simp oops

lemma "oo : int ==> l $+ (l $+ #2) $+ oo = oo" apply simp oops

lemma "#9$*x $+ y = x$*#23 $+ z" apply simp oops
lemma "y $+ x = x $+ z" apply simp oops

lemma "x : int ==> x $+ y $+ z = x $+ z" apply simp oops
lemma "x : int ==> y $+ (z $+ x) = z $+ x" apply simp oops
lemma "z : int ==> x $+ y $+ z = (z $+ y) $+ (x $+ w)" apply simp oops
lemma "z : int ==> x$*y $+ z = (z $+ y) $+ (y$*x $+ w)" apply simp oops

lemma "#-3 $* x $+ y $\<le> x $* #2 $+ z" apply simp oops
lemma "y $+ x $\<le> x $+ z" apply simp oops
lemma "x $+ y $+ z $\<le> x $+ z" apply simp oops

lemma "y $+ (z $+ x) $< z $+ x" apply simp oops
lemma "x $+ y $+ z $< (z $+ y) $+ (x $+ w)" apply simp oops
lemma "x$*y $+ z $< (z $+ y) $+ (y$*x $+ w)" apply simp oops

lemma "l $+ #2 $+ #2 $+ #2 $+ (l $+ #2) $+ (oo $+ #2) = uu" apply simp oops
lemma "u : int ==> #2 $* u = u" apply simp oops
lemma "(i $+ j $+ #12 $+ k) $- #15 = y" apply simp oops
lemma "(i $+ j $+ #12 $+ k) $- #5 = y" apply simp oops

lemma "y $- b $< b" apply simp oops
lemma "y $- (#3 $* b $+ c) $< b $- #2 $* c" apply simp oops

lemma "(#2 $* x $- (u $* v) $+ y) $- v $* #3 $* u = w" apply simp oops
lemma "(#2 $* x $* u $* v $+ (u $* v) $* #4 $+ y) $- v $* u $* #4 = w" apply simp oops
lemma "(#2 $* x $* u $* v $+ (u $* v) $* #4 $+ y) $- v $* u = w" apply simp oops
lemma "u $* v $- (x $* u $* v $+ (u $* v) $* #4 $+ y) = w" apply simp oops

lemma "(i $+ j $+ #12 $+ k) = u $+ #15 $+ y" apply simp oops
lemma "(i $+ j $* #2 $+ #12 $+ k) = j $+ #5 $+ y" apply simp oops

lemma "#2 $* y $+ #3 $* z $+ #6 $* w $+ #2 $* y $+ #3 $* z $+ #2 $* u = #2 $* y' $+ #3 $* z' $+ #6 $* w' $+ #2 $* y' $+ #3 $* z' $+ u $+ vv" apply simp oops

lemma "a $+ $-(b$+c) $+ b = d" apply simp oops
lemma "a $+ $-(b$+c) $- b = d" apply simp oops

text \<open>negative numerals\<close>
lemma "(i $+ j $+ #-2 $+ k) $- (u $+ #5 $+ y) = zz" apply simp oops
lemma "(i $+ j $+ #-3 $+ k) $< u $+ #5 $+ y" apply simp oops
lemma "(i $+ j $+ #3 $+ k) $< u $+ #-6 $+ y" apply simp oops
lemma "(i $+ j $+ #-12 $+ k) $- #15 = y" apply simp oops
lemma "(i $+ j $+ #12 $+ k) $- #-15 = y" apply simp oops
lemma "(i $+ j $+ #-12 $+ k) $- #-15 = y" apply simp oops

text \<open>Multiplying separated numerals\<close>
lemma "#6 $* ($# x $* #2) =  uu" apply simp oops
lemma "#4 $* ($# x $* $# x) $* (#2 $* $# x) =  uu" apply simp oops

end


theory Tactics
  imports Poly
begin

section {* Tactics *}

(* theorem silly1: "\<forall> n m p q::nat. n = m \<longrightarrow> [n, p] = [n, q] \<longrightarrow> [n, p] = [m, q]" *)
theorem silly1: "n = m \<longrightarrow> [n, p] = [n, q] \<longrightarrow> [n, p] = [m, q]"
  apply (simp)
  done

theorem silly_ex: "evenb n = True \<longrightarrow> oddb (Suc n) = True \<longrightarrow> evenb (Suc (Suc 1)) = True \<longrightarrow> oddb 4 = True"
  apply (simp)
  done

theorem rev_exercise1: "xs = rev ys \<longrightarrow> ys = rev xs"
  apply (simp add: rev_involutive)
  done

subsection {* The apply ... with ... Tactic *}

lemma trans_eq_example: "[a, b] = [c, d] \<longrightarrow> [c, d] = [e, f] \<longrightarrow> [a, b] = [e, f]"
  apply (simp)
  done

lemma trans_eq: "n = m \<longrightarrow> m = p \<longrightarrow> n = p"
  apply (simp)
  done

lemma trans_eq_exercise: "m = minustwo p \<longrightarrow> n + q = m \<longrightarrow> n + q = minustwo p"
  apply (simp)
  done

subsection {* The inversion tactic *}

theorem S_inversion: "\<forall> n m::nat. Suc n = Suc m \<longrightarrow> n = m"
  apply (simp)
  done

theorem inversion_ex1: "\<forall> n m p::nat. (n # m # []) = (p # p # []) \<longrightarrow> (n # []) = (m # [])"
  apply (simp)
  done

theorem inversion_ex2: "\<forall> n m::nat. (n # []) = (m # []) \<longrightarrow> n = m"
  apply (simp)
  done

theorem inversion_ex3: "x # y # l = z # j \<longrightarrow> y # l = x # j \<longrightarrow> x = y"
  apply (auto)
  done

theorem inversion_ex6: "x # y # l = [] \<longrightarrow> y # l = z # j \<longrightarrow> x = z"
  apply (simp)
  done

theorem f_equal: "x = y \<longrightarrow> f x = f y"
  apply (simp)
  done

subsection {* Using tactic on Hypotheses *}

theorem S_inj: "\<forall> n m::nat. beq_nat (Suc n) (Suc m) = b \<longrightarrow> beq_nat n m = b"
  apply (simp)
  done

theorem plus_n_n_injective: "\<forall> n m::nat. n + n = m + m \<longrightarrow> n = m"
  apply (simp)
  done

subsection {* Varying the induction Hypotheses *}

theorem beq_nat_true: "beq_nat n m = True \<longrightarrow> n = m"
  oops

subsection {* Unfolding Definition *}

definition square ::"nat \<Rightarrow> nat" where
  "square n = n * n"

lemma square_multi: "square (n * m) = (square n) * (square m)"
  unfolding Tactics.square_def
  apply (simp)
  done

definition foo ::"nat \<Rightarrow> nat" where "foo _ = 5"

theorem silly_fact_1: "foo m + 1 = foo (m + 1) + 1"
  unfolding Tactics.foo_def
  apply (simp)
  done

fun bar ::"nat \<Rightarrow> nat" where
  "bar 0 = 5"
| "bar (Suc n) = 5"

theorem silly_fact_2: "bar m + 1 = bar (m + 1) + 1"
  apply (induction m)
   apply (simp_all)
  done

subsection {* Using destruct on Compound Expressions *}

definition sillyfun :: "nat \<Rightarrow> bool" where
  "sillyfun n = (if n = 3 then False else (if n = 5 then False else False))"

theorem sillyfun_false: "sillyfun n = False"
  unfolding sillyfun_def
  apply (simp)
  done

theorem combine_split: "split xs = (ys, zs) \<longrightarrow> combine ys zs = xs"
  oops

end


header{* Tag-Based Encodings *}
theory T
imports T_G_Prelim
begin

subsection{* The tag translation *}

text{* The extension of the function symbols with type tags and type witnesses: *}

datatype ('fsym,'tp) efsym = Oldf 'fsym | Tag 'tp | Wit 'tp

context ProblemIkTpart
begin

text{* ``TE'' stands for ``tag encoding'' *}

fun TE_wtFsym where
 "TE_wtFsym (Oldf f) \<longleftrightarrow> wtFsym f"
|"TE_wtFsym (Tag \<sigma>) \<longleftrightarrow> True"
|"TE_wtFsym (Wit \<sigma>) \<longleftrightarrow> \<not> isRes \<sigma>"

fun TE_arOf where
 "TE_arOf (Oldf f) = arOf f"
|"TE_arOf (Tag \<sigma>) = [\<sigma>]"
|"TE_arOf (Wit \<sigma>) = []"

fun TE_resOf where
 "TE_resOf (Oldf f) = resOf f"
|"TE_resOf (Tag \<sigma>) = \<sigma>"
|"TE_resOf (Wit \<sigma>) = \<sigma>"

lemma countable_TE_wtFsym: "countable (Collect TE_wtFsym)" (is "countable ?K")
proof-
  let ?F = "\<lambda> ef. case ef of Oldf f \<Rightarrow> Inl f | Tag \<sigma> \<Rightarrow> Inr (Inl \<sigma>) | Wit \<sigma> \<Rightarrow> Inr (Inr \<sigma>)"
  let ?U = "(UNIV::'tp set) <+> (UNIV::'tp set)"
  let ?L = "(Collect wtFsym) <+> ?U"
  have "inj_on ?F ?K" unfolding inj_on_def apply clarify
  apply(case_tac x, simp_all) by (case_tac y, simp_all)+
  moreover have "?F ` ?K \<subseteq> ?L" apply clarify by (case_tac ef, auto)
  ultimately have "|?K| \<le>o |?L|" unfolding card_of_ordLeq[symmetric] by auto
  moreover have "countable ?L" using countable_wtFsym countable_tp
  by (metis countable_Plus)
  ultimately show ?thesis by(rule countable_ordLeq)
qed

end (* context ProblemIkTpart *)

sublocale ProblemIkTpart < TE : Signature
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf
apply default
using countable_tp countable_TE_wtFsym countable_wtPsym by auto

context ProblemIkTpart
begin

(* encoding of non-naked terms *)
fun tNN where
"tNN (Var x) =
 (if unprot (tpOfV x) \<or> protFw (tpOfV x) then Var x else Fn (Tag (tpOfV x)) [Var x])"
|
"tNN (Fn f Tl) = (if unprot (resOf f) \<or> protFw (resOf f)
                    then Fn (Oldf f) (map tNN Tl)
                    else Fn (Tag (resOf f)) [Fn (Oldf f) (map tNN Tl)])"

fun tT where
"tT (Var x) = (if unprot (tpOfV x) then Var x else Fn (Tag (tpOfV x)) [Var x])"
|
"tT t = tNN t"

fun tL where
"tL (Pos (Eq T1 T2)) = Pos (Eq (tT T1) (tT T2))"
|
"tL (Neg (Eq T1 T2)) = Neg (Eq (tNN T1) (tNN T2))"
|
"tL (Pos (Pr p Tl)) = Pos (Pr p (map tNN Tl))"
|
"tL (Neg (Pr p Tl)) = Neg (Pr p (map tNN Tl))"

definition "tC \<equiv> map tL"

(* The extra axioms: *)

(* The function axioms: *)
(* Lefthand side: *)
definition "rOfFax f = Fn (Oldf f) (getTvars (arOf f))"
(* Righthand side: *)
definition "lOfFax f = Fn (Tag (resOf f)) [rOfFax f]"
definition "Fax \<equiv> {[Pos (Eq (lOfFax f) (rOfFax f))] | f. wtFsym f}"

(* The witness axioms: *)
(* Lefthand side: *)
definition "rOfWax \<sigma> = Fn (Wit \<sigma>) []"
(* Righthand side: *)
definition "lOfWax \<sigma> = Fn (Tag \<sigma>) [rOfWax \<sigma>]"
definition "Wax \<equiv> {[Pos (Eq (lOfWax \<sigma>) (rOfWax \<sigma>))] | \<sigma>. \<not> isRes \<sigma> \<and> protFw \<sigma>}"

definition "tPB = tC ` \<Phi> \<union> Fax \<union> Wax"

(* Well-typedness of the translation: *)
lemma tpOf_tNN[simp]: "TE.tpOf (tNN T) = Ik.tpOf T"
by (induct T) auto

lemma tpOf_t[simp]: "TE.tpOf (tT T) = Ik.tpOf T"
by (cases T) auto

lemma wt_tNN[simp]: "Ik.wt T \<Longrightarrow> TE.wt (tNN T)"
by (induct T, auto simp add: list_all_iff)

lemma wt_t[simp]: "Ik.wt T \<Longrightarrow> TE.wt (tT T)"
by (cases T, auto simp add: list_all_iff)

lemma wtL_tL[simp]: "Ik.wtL l \<Longrightarrow> TE.wtL (tL l)"
apply(cases l) apply (rename_tac [!] atm) apply(case_tac [!] atm)
by (auto simp add: list_all_iff)

lemma wtC_tC[simp]: "Ik.wtC c \<Longrightarrow> TE.wtC (tC c)"
unfolding tC_def Ik.wtC_def TE.wtC_def by (induct c, auto)

lemma tpOf_rOfFax[simp]: "TE.tpOf (rOfFax f) = resOf f"
unfolding rOfFax_def by simp

lemma tpOf_lOfFax[simp]: "TE.tpOf (lOfFax f) = resOf f"
unfolding lOfFax_def by simp

lemma tpOf_rOfWax[simp]: "TE.tpOf (rOfWax \<sigma>) = \<sigma>"
unfolding rOfWax_def by simp

lemma tpOf_lOfWax[simp]: "TE.tpOf (lOfWax \<sigma>) = \<sigma>"
unfolding lOfWax_def by simp

lemma wt_rOfFax[simp]: "wtFsym f \<Longrightarrow> TE.wt (rOfFax f)"
unfolding rOfFax_def by simp

lemma wt_lOfFax[simp]: "wtFsym f \<Longrightarrow> TE.wt (lOfFax f)"
unfolding lOfFax_def by simp

lemma wt_rOfWax[simp]: "\<not> isRes \<sigma> \<Longrightarrow> TE.wt (rOfWax \<sigma>)"
unfolding rOfWax_def by simp

lemma wt_lOfWax[simp]: "\<not> isRes \<sigma> \<Longrightarrow> TE.wt (lOfWax \<sigma>)"
unfolding lOfWax_def by simp

lemma wtPB_Fax[simp]: "TE.wtPB Fax" unfolding Fax_def TE.wtPB_def TE.wtC_def by auto

lemma wtPB_Wax[simp]: "TE.wtPB Wax" unfolding Wax_def TE.wtPB_def TE.wtC_def by auto

lemma wtPB_tC_\<Phi>[simp]: "TE.wtPB (tC ` \<Phi>)"
using Ik.wt_\<Phi> unfolding Ik.wtPB_def TE.wtPB_def by auto

lemma wt_Tag:
assumes "TE.wt (Fn (Tag \<sigma>) Tl)"
shows "\<exists> T. Tl = [T] \<and> TE.wt T \<and> tpOf T = \<sigma>"
using assms
by simp (metis (hide_lams, no_types) list.inject list_all_simps(1) map_eq_Cons_conv neq_Nil_conv)

lemma tpOf_Tag: "TE.tpOf (Fn (Tag \<sigma>) Tl) = \<sigma>" by simp

lemma tpOf_Wit: "TE.tpOf (Fn (Wit \<sigma>) Tl) = \<sigma>" by simp

end (* context ProblemIkTpart *)

subsection{* Soundness *}

context ModelIkTpart begin

(* The identity-tag extension of a given structure of the original signature *)
fun TE_intF where
 "TE_intF (Oldf f) al = intF f al"
|"TE_intF (Tag \<sigma>) al = hd al"
|"TE_intF (Wit \<sigma>) al = pickT \<sigma>"
(* note: for tags, we only care about al being the singleton list [a],
   and hence the interpretation returns a; for witnesses, we only care
   about al being [] *)

end (* context ModelIkTpart *)

sublocale ModelIkTpart < TE : Struct
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf and intF = TE_intF
proof default
  fix ef al assume "TE_wtFsym ef" and "list_all2 intT (TE_arOf ef) al"
  thus "intT (TE_resOf ef) (TE_intF ef al)"
  using intF by (cases ef, auto)
qed auto

context ModelIkTpart begin

lemma tNN_int[simp]: "TE.int \<xi> (tNN T) = Ik.int \<xi> T"
proof(induct T)
  case (Fn f Tl)
  hence 0: "map (TE.int \<xi> \<circ> tNN) Tl = map (Ik.int \<xi>) Tl"
  unfolding list_eq_iff list_all_iff by auto
  show ?case by (simp add: 0)
qed auto

lemma map_tNN_int[simp]: "map (TE.int \<xi> \<circ> tNN) Tl = map (Ik.int \<xi>) Tl"
unfolding list_eq_iff list_all_iff by auto

lemma t_int[simp]: "TE.int \<xi> (tT T) = Ik.int \<xi> T"
using assms by (cases T, auto)

lemma map_t_int[simp]: "map (TE.int \<xi> \<circ> tT) Tl = map (Ik.int \<xi>) Tl"
unfolding list_eq_iff list_all_iff by auto

lemma tL_satL[simp]: "TE.satL \<xi> (tL l) \<longleftrightarrow> Ik.satL \<xi> l"
apply(cases l) apply (rename_tac [!] atm) apply(case_tac [!] atm) by auto

lemma tC_satC[simp]: "TE.satC \<xi> (tC c) \<longleftrightarrow> Ik.satC \<xi> c"
unfolding TE.satC_def Ik.satC_def tC_def by (induct c, auto)

lemma tC_\<Phi>_satPB[simp]: "TE.satPB \<xi> (tC ` \<Phi>) \<longleftrightarrow> Ik.satPB \<xi> \<Phi>"
unfolding TE.satPB_def Ik.satPB_def by auto

lemma Fax_Wax_satPB:
"TE.satPB \<xi> (Fax) \<and> TE.satPB \<xi> (Wax)"
unfolding TE.satPB_def TE.satC_def Fax_def Wax_def
by (auto simp add: lOfFax_def rOfFax_def lOfWax_def rOfWax_def)

lemmas Fax_satPB[simp] = Fax_Wax_satPB[THEN conjunct1]
lemmas Wax_satPB[simp] = Fax_Wax_satPB[THEN conjunct2]

theorem T_soundness:
"Model TE_wtFsym wtPsym TE_arOf TE_resOf parOf tPB intT TE_intF intP"
apply default using wtPB_tPB soundness by auto

end (* context ModelIkTpart *)

(* Soundness theorem in sublocale form: Given a problem (with indicated
type partition) and a model for it, we obtain a model of the tag-extended (TE)
problem: *)
sublocale ModelIkTpart < TE : Model
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf
and \<Phi> = tPB and intF = TE_intF
apply default using wtPB_tPB soundness by auto

subsection{* Completeness *}

(* iimg B f transforms f into a function f' having the same B-range as f
and such that it is the identity on its B-image, namely, \<forall> b \<in> B. f' (f' a) = f' a;
also, it holds that \<forall> b \<in> B. f' (f b) = f b *)
definition "iimg B f a \<equiv> if a \<in> f ` B then a else f a"

lemma inImage_iimg[simp]: "a \<in> f ` B \<Longrightarrow> iimg B f a = a"
unfolding iimg_def by auto

lemma not_inImage_iimg[simp]: "a \<notin> f ` B \<Longrightarrow> iimg B f a = f a"
unfolding iimg_def by auto

lemma iimg[simp]: "a \<in> B \<Longrightarrow> iimg B f (f a) = f a"
by (cases "a \<in> f ` B", auto)

(* Problem with type partition and model of its tag-encoding translation: *)

locale ProblemIkTpart_TEModel =
Ik : ProblemIkTpart wtFsym wtPsym arOf resOf parOf \<Phi> infTp prot protFw +
TE : Model "ProblemIkTpart.TE_wtFsym wtFsym resOf" wtPsym
           "ProblemIkTpart.TE_arOf arOf" "ProblemIkTpart.TE_resOf resOf" parOf
           tPB eintT eintF eintP
for wtFsym :: "'fsym \<Rightarrow> bool"
and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and prot and protFw
and eintT and eintF and eintP

context ProblemIkTpart_TEModel begin

(* new tag semantics (taking as input elements, instead of singleton lists): *)
definition
"ntsem \<sigma> \<equiv>
 if unprot \<sigma> \<or> protFw \<sigma> then id
                   else iimg {b. eintT \<sigma> b} (eintF (Tag \<sigma>) o singl)"

lemma unprot_ntsem[simp]: "unprot \<sigma> \<or> protFw \<sigma> \<Longrightarrow> ntsem \<sigma> a = a"
unfolding ntsem_def by simp

lemma protFw_ntsem[simp]: "protFw \<sigma> \<Longrightarrow> ntsem \<sigma> a = a"
unfolding ntsem_def by simp

lemma inImage_ntsem[simp]:
"a \<in> (eintF (Tag \<sigma>) o singl) ` {b. eintT \<sigma> b} \<Longrightarrow> ntsem \<sigma> a = a"
unfolding ntsem_def by simp

lemma not_unprot_inImage_ntsem[simp]:
assumes "\<not> unprot \<sigma>" and "\<not> protFw \<sigma>" and "a \<notin> (eintF (Tag \<sigma>) o singl) ` {b. eintT \<sigma> b}"
shows "ntsem \<sigma> a = eintF (Tag \<sigma>) [a]"
using assms unfolding ntsem_def by (simp add: singl_def)

(* crucial: *)
lemma ntsem[simp]:
"eintT \<sigma> b \<Longrightarrow> ntsem \<sigma> (eintF (Tag \<sigma>) [b]) = eintF (Tag \<sigma>) [b]"
unfolding singl_def[symmetric] by simp

lemma eintT_ntsem:
assumes a: "eintT \<sigma> a"  shows "eintT \<sigma> (ntsem \<sigma> a)"
proof(cases "unprot \<sigma> \<or> protFw \<sigma>")
  case False note unprot = False show ?thesis
  proof(cases "a \<in> (eintF (Tag \<sigma>) o singl) ` {b. eintT \<sigma> b}")
    case False hence 1: "ntsem \<sigma> a = eintF (Tag \<sigma>) [a]" using unprot by simp
    show ?thesis unfolding 1 using a TE.intF
    by (metis TE_arOf.simps TE_resOf.simps TE_wtFsym.simps list_all2_Cons list_all2_Nil)
  qed(insert a, auto)
qed(insert a, simp)

(* The reduct structure of a given structure in the tag-extended signature: *)
definition
"intT \<sigma> a \<equiv>
 if unprot \<sigma> then eintT \<sigma> a
 else if protFw \<sigma> then eintT \<sigma> a \<and> eintF (Tag \<sigma>) [a] = a
 else eintT \<sigma> a \<and> a \<in> (eintF (Tag \<sigma>) o singl) ` {b. eintT \<sigma> b}"
definition
"intF f al \<equiv>
 if unprot (resOf f) \<or> protFw (resOf f)
   then eintF (Oldf f) (map2 ntsem (arOf f) al)
   else eintF (Tag (resOf f)) [eintF (Oldf f) (map2 ntsem (arOf f) al)]"
definition
"intP p al \<equiv> eintP p (map2 ntsem (parOf p) al)"

(* Semantic rephrasings of the fact that the (tagged problem) model satisfies
   Fax and Wax *)
lemma TE_Tag: (* fixme: messy proof *)
assumes f: "wtFsym f" and al: "list_all2 eintT (arOf f) al"
shows "eintF (Tag (resOf f)) [eintF (Oldf f) al] = eintF (Oldf f) al"
proof-
  def xl \<equiv> "getVars (arOf f)"
  have l[simp]: "length xl = length al" "length al = length (arOf f)"
  unfolding xl_def using al unfolding list_all2_iff by auto
  have 1[simp]: "\<And> i. i < length (arOf f) \<Longrightarrow> tpOfV (xl!i) = (arOf f)!i"
  unfolding xl_def by auto
  have xl[simp]: "distinct xl" unfolding xl_def using distinct_getVars by auto
  def \<xi> \<equiv> "pickE xl al"
  have \<xi>: "TE.wtE \<xi>" unfolding \<xi>_def apply(rule wtE_pickE)
  using al  list_all2_nthD by auto
  have [simp]: "\<And> i. i < length (arOf f) \<Longrightarrow> \<xi> (xl ! i) = al ! i"
  using al unfolding \<xi>_def by (auto simp: list_all2_length intro: pickE)
  have 0: "map (TE.int \<xi>) (getTvars (arOf f)) = al"
  apply(rule nth_equalityI)
  using al by (auto simp: list_all2_length getTvars_def xl_def[symmetric])
  have "TE.satPB \<xi> Fax" using TE.sat_\<Phi>[OF \<xi>] unfolding tPB_def by simp
  hence "TE.satC \<xi> [Pos (Eq (lOfFax f) (rOfFax f))]"
  unfolding TE.satPB_def Fax_def using f by auto
  hence "TE.satA \<xi> (Eq (lOfFax f) (rOfFax f))" unfolding TE.satC_def by simp
  thus ?thesis using al by (simp add: lOfFax_def rOfFax_def 0)
qed

lemma TE_Wit:
assumes \<sigma>: "\<not> isRes \<sigma>" "protFw \<sigma>"
shows "eintF (Tag \<sigma>) [eintF (Wit \<sigma>) []] = eintF (Wit \<sigma>) []"
proof-
  def \<xi> \<equiv> "pickE [] []"
  have \<xi>: "TE.wtE \<xi>" unfolding \<xi>_def apply(rule wtE_pickE) by auto
  have "TE.satPB \<xi> Wax" using TE.sat_\<Phi>[OF \<xi>] unfolding tPB_def by simp
  hence "TE.satC \<xi> [Pos (Eq (lOfWax \<sigma>) (rOfWax \<sigma>))]"
  unfolding TE.satPB_def Wax_def using \<sigma> by auto
  hence "TE.satA \<xi> (Eq (lOfWax \<sigma>) (rOfWax \<sigma>))" unfolding TE.satC_def by auto
  thus ?thesis unfolding TE.satA.simps lOfWax_def rOfWax_def by simp
qed

lemma NE_intT_forget: "NE (intT \<sigma>)"
proof-
  obtain b where b: "eintT \<sigma> b" using TE.NE_intT by blast
  show ?thesis proof(cases "unprot \<sigma>")
    case True thus ?thesis using b unfolding intT_def by auto
  next
    case False note unprot = False show ?thesis
    proof(cases "protFw \<sigma>")
      case True note protFw = True show ?thesis proof(cases "isRes \<sigma>")
        case True then obtain f where f: "wtFsym f" and \<sigma>: "\<sigma> = resOf f"
        unfolding isRes_def by auto
        def al \<equiv> "map pickT (arOf f)"  have al: "list_all2 eintT (arOf f) al"
        unfolding al_def list_all2_map2 unfolding list_all2_length by auto
        def a \<equiv> "eintF (Oldf f) al"
        have "eintT \<sigma> a" unfolding a_def \<sigma> using f al
        by (metis TE_arOf.simps TE_resOf.simps TE_wtFsym.simps TE.intF)
        moreover have "eintF (Tag \<sigma>) [a] = a" unfolding \<sigma> a_def using TE_Tag[OF f al] .
        ultimately show ?thesis using unprot protFw unfolding intT_def by auto
      next
        case False def a \<equiv> "eintF (Wit \<sigma>) []"
        have "eintT \<sigma> a" unfolding a_def
        by (metis False TE_arOf.simps TE_resOf.simps TE_wtFsym.simps TE.intF list_all2_NilR)
        moreover have "eintF (Tag \<sigma>) [a] = a" unfolding a_def using TE_Wit[OF False protFw] .
        ultimately show ?thesis using unprot protFw unfolding intT_def by auto
      qed
    next
      case False  hence "eintT \<sigma> (eintF (Tag \<sigma>) [b])"
      using b list_all2_Cons list_all2_NilL
      by (metis TE.intF TE_arOf.simps TE_resOf.simps TE_wtFsym.simps)
      hence "intT \<sigma> (eintF (Tag \<sigma>) [b])"
      unfolding intT_def singl_def[abs_def] using b False by auto
      thus ?thesis by blast
    qed
  qed
qed

lemma wt_intF:
assumes f: "wtFsym f" and al: "list_all2 intT (arOf f) al"
shows "intT (resOf f) (intF f al)"
proof-
  let ?t = "eintF (Tag (resOf f))"
  let ?t'al = "map2 ntsem (arOf f) al"
  have al: "list_all2 eintT (arOf f) al"
  using al unfolding list_all2_length intT_def by metis
  have 0: "list_all2 eintT (arOf f) ?t'al"
  proof(rule listAll2_map2I)
    show l: "length (arOf f) = length al"
    using al unfolding list_all2_length by simp
    fix i assume "i < length (arOf f)"
    hence 1: "eintT (arOf f ! i) (al ! i)"
    using al unfolding list_all2_length by simp
    show "eintT (arOf f ! i) (ntsem (arOf f ! i) (al ! i))"
    using eintT_ntsem[OF 1] .
  qed
  hence 1: "eintT (resOf f) (eintF (Oldf f) ?t'al)"
  by (metis TE_arOf.simps TE_resOf.simps TE_wtFsym.simps f TE.intF)
  show ?thesis  proof(cases "unprot (resOf f)")
    case True thus ?thesis unfolding intF_def intT_def by (simp add: 1)
  next
    case False note unprot = False show ?thesis proof(cases "protFw (resOf f)")
      case True thus ?thesis using unprot TE_Tag[OF f 0] 1
      unfolding intF_def intT_def by simp
    next
      case False
      have "eintT (resOf f) (intF f al)" using intF_def 0 1 TE_Tag f by auto
      moreover have
      "intF f al \<in> (eintF (Tag (resOf f)) o singl) ` {b. eintT (resOf f) b}"
      unfolding intF_def using 1 unprot False by (auto simp add: singl_def)
      ultimately show ?thesis using False unfolding intT_def by simp
    qed
  qed
qed

lemma Struct: "Struct wtFsym wtPsym arOf resOf intT intF intP"
apply default using NE_intT_forget wt_intF by auto

end (* context ProblemIkTpart_TEModel *)

sublocale ProblemIkTpart_TEModel < Ik : Struct
where intT = intT and intF = intF and intP = intP
using Struct .

context ProblemIkTpart_TEModel begin

(* The inverse of the tag function (required for translating environments backwards)*)
definition
"invt \<sigma> a \<equiv> if unprot \<sigma> \<or> protFw \<sigma> then a else (SOME b. eintT \<sigma> b \<and> eintF (Tag \<sigma>) [b] = a)"

lemma unprot_invt[simp]: "unprot \<sigma> \<or> protFw \<sigma> \<Longrightarrow> invt \<sigma> a = a"
using assms unfolding invt_def by auto

lemma invt_invt_inImage:
assumes \<sigma>: "\<not> unprot \<sigma>" "\<not> protFw \<sigma>"
and a: "a \<in> (eintF (Tag \<sigma>) o singl) ` {b. eintT \<sigma> b}"
shows "eintT \<sigma> (invt \<sigma> a) \<and> eintF (Tag \<sigma>) [invt \<sigma> a] = a"
proof-
  obtain b where "eintT \<sigma> b" and "eintF (Tag \<sigma>) [b] = a"
  using a unfolding image_def singl_def[symmetric] by auto
  thus ?thesis using \<sigma> unfolding invt_def apply simp apply(rule someI_ex) by auto
qed

lemmas invt[simp] = invt_invt_inImage[THEN conjunct1]
lemmas invt_inImage[simp] = invt_invt_inImage[THEN conjunct2]

(* We translate the environments of the tag-extended-problem model
to environments of its original-signature reduct: *)  term invt
definition "eenv \<xi> x \<equiv> invt (tpOfV x) (\<xi> x)"

lemma wt_eenv:
assumes \<xi>: "Ik.wtE \<xi>"  shows "TE.wtE (eenv \<xi>)"
unfolding TE.wtE_def proof safe
  fix x let ?\<sigma> = "TE.tpOfV x"
  show "eintT ?\<sigma> (eenv \<xi> x)" proof(cases "unprot ?\<sigma>")
    case True note unprot = True
    thus ?thesis unfolding eenv_def by (metis \<xi> Ik.wtTE_intT intT_def unprot_invt)
  next
    case False note unprot = False show ?thesis proof(cases "protFw ?\<sigma>")
      case True thus ?thesis unfolding eenv_def using unprot \<xi>
      by (metis Ik.wtTE_intT intT_def unprot_invt)
    next
      case False thus ?thesis unfolding eenv_def using unprot \<xi>
      by (metis (no_types) \<xi> Ik.wtE_def intT_def invt)
    qed
  qed
qed

lemma int_tNN[simp]:
assumes T: "Ik.Ik.wt T" and \<xi>: "Ik.wtE \<xi>"
shows "TE.int (eenv \<xi>) (tNN T) = Ik.int \<xi> T"
using T proof(induct T)
  case (Var x) let ?\<sigma> = "TE.tpOfV x"  show ?case
  proof(cases "unprot ?\<sigma>")
    case False note unprot = False
    show ?thesis proof(cases "protFw ?\<sigma>")
      case True thus ?thesis using unprot \<xi>
      unfolding eenv_def Ik.wtE_def intT_def by simp
    next
      case False  hence "\<xi> x \<in> (eintF (Tag ?\<sigma>) \<circ> singl) ` {b. eintT ?\<sigma> b}"
      using \<xi> unprot unfolding wtE_def intT_def singl_def[abs_def] by simp
      thus ?thesis using unprot unfolding eenv_def using False by simp
    qed
  qed(unfold eenv_def, simp)
next
  case (Fn f Tl)
  let ?e\<xi> = "eenv \<xi>" let ?ar = "arOf f" let ?r = "resOf f"
  have l: "length ?ar = length Tl" using Fn by simp
  have 0: "map2 ntsem ?ar (map (Ik.int \<xi>) Tl) =
           map (TE.int ?e\<xi> \<circ> tNN) Tl"  (is "?L = ?R")
  proof(rule nth_equalityI, safe)
    fix i assume "i < length ?L"
    hence i: "i < length ?ar" using l by simp
    hence 1: "TE.int (eenv \<xi>) (tNN (Tl!i)) = Ik.int \<xi> (Tl!i)"
    using Fn by (auto simp: list_all_length)
    have 2: "?ar ! i = Ik.Ik.tpOf (Tl!i)" using Fn i by simp
    have 3: "intT (?ar ! i) (Ik.int \<xi> (Tl ! i))"
    unfolding 2 apply(rule wt_int)
    using Fn \<xi> i by (auto simp: list_all_length)
    show "?L!i = ?R!i" apply (cases "unprot (?ar ! i) \<or> protFw (?ar ! i)")
    using i 1 l 3 unfolding intT_def by auto
  qed(insert l, auto)
  show ?case apply(cases "unprot ?r \<or> protFw ?r")
  unfolding Ik.int.simps TE.int.simps tT.simps unfolding intF_def using Fn 0 by auto
qed

lemma map_int_tNN[simp]:
assumes Tl: "list_all Ik.Ik.wt Tl" and \<xi>: "Ik.wtE \<xi>"
shows
"map2 ntsem (map Ik.Ik.tpOf Tl) (map (Ik.int \<xi>) Tl) =
 map (TE.int (eenv \<xi>) \<circ> tNN) Tl"
proof-
  {fix i assume i: "i < length Tl"
   hence wt: "Ik.Ik.wt (Tl!i)" using Tl unfolding list_all_length by simp
   have "intT (Ik.Ik.tpOf (Tl!i)) (Ik.int \<xi> (Tl!i))" using Ik.wt_int[OF \<xi> wt] .
  }
  thus ?thesis
  using assms unfolding intT_def list_all_length
  unfolding list_eq_iff apply clarsimp by (metis inImage_ntsem unprot_ntsem)
qed

lemma int_t[simp]:
assumes T: "Ik.Ik.wt T" and \<xi>: "Ik.wtE \<xi>"
shows "TE.int (eenv \<xi>) (tT T) = Ik.int \<xi> T"
using T proof(induct T)
  case (Var x) let ?\<sigma> = "tpOfV x"  show ?case
  proof(cases "unprot ?\<sigma>")
    case False note unprot = False
    show ?thesis proof(cases "protFw ?\<sigma>")
      case True thus ?thesis using unprot \<xi>
      unfolding eenv_def Ik.wtE_def intT_def by simp
    next
      case False  hence "\<xi> x \<in> (eintF (Tag ?\<sigma>) \<circ> singl) ` {b. eintT ?\<sigma> b}"
      using \<xi> unprot unfolding wtE_def intT_def singl_def[abs_def] by simp
      thus ?thesis using unprot unfolding eenv_def using False by simp
    qed
  qed(unfold eenv_def, simp)
next
  case (Fn f Tl)
  let ?e\<xi> = "eenv \<xi>"  let ?ar = "arOf f"  let ?r = "resOf f"
  have l: "length ?ar = length Tl" using Fn by simp
  have ar: "?ar = map Ik.Ik.tpOf Tl" using Fn by simp
  have 0: "map2 ntsem ?ar (map (Ik.int \<xi>) Tl) = map (TE.int ?e\<xi> \<circ> tNN) Tl"
  unfolding ar apply(rule map_int_tNN[OF _ \<xi>]) using Fn by simp
  show ?case apply(cases "unprot ?r \<or> protFw ?r")
  unfolding  Ik.int.simps TE.int.simps tT.simps unfolding intF_def using Fn 0 by auto
qed

lemma map_int_t[simp]:
assumes Tl: "list_all Ik.Ik.wt Tl" and \<xi>: "Ik.wtE \<xi>"
shows
"map2 ntsem (map Ik.Ik.tpOf Tl) (map (Ik.int \<xi>) Tl) =
 map (TE.int (eenv \<xi>) \<circ> tT) Tl"
proof-
  {fix i assume i: "i < length Tl"
   hence wt: "Ik.Ik.wt (Tl!i)" using Tl unfolding list_all_length by simp
   have "intT (Ik.Ik.tpOf (Tl!i)) (Ik.int \<xi> (Tl!i))" using wt_int[OF \<xi> wt] .
  }
  thus ?thesis
  using assms unfolding intT_def list_all_length
  unfolding list_eq_iff apply clarsimp by (metis inImage_ntsem unprot_ntsem)
qed

lemma satL_tL[simp]:
assumes l: "Ik.Ik.wtL l" and \<xi>: "Ik.wtE \<xi>"
shows "TE.satL (eenv \<xi>) (tL l) \<longleftrightarrow> Ik.satL \<xi> l"
using assms apply(cases l) apply (rename_tac [!] atm) by (case_tac [!] atm) (auto simp add: intP_def)

lemma satC_tC[simp]:
assumes l: "Ik.Ik.wtC c" and \<xi>: "Ik.wtE \<xi>"
shows "TE.satC (eenv \<xi>) (tC c) \<longleftrightarrow> Ik.satC \<xi> c"
unfolding TE.satC_def Ik.satC_def
using assms by (induct c, auto simp add: Ik.Ik.wtC_def tC_def)

lemma satPB_tPB[simp]:
assumes \<xi>: "Ik.wtE \<xi>"
shows "TE.satPB (eenv \<xi>) (tC ` \<Phi>) \<longleftrightarrow> Ik.satPB \<xi> \<Phi>"
using Ik.wt_\<Phi> assms unfolding TE.satPB_def Ik.satPB_def by (auto simp add: Ik.Ik.wtPB_def)

lemma completeness: "Ik.SAT \<Phi>"
unfolding Ik.SAT_def proof safe
  fix \<xi> assume \<xi>: "Ik.wtE \<xi>" hence "TE.wtE (eenv \<xi>)" by(rule wt_eenv)
  hence "TE.satPB (eenv \<xi>) tPB" by (rule TE.sat_\<Phi>)
  hence "TE.satPB (eenv \<xi>) (tC ` \<Phi>)" unfolding tPB_def by simp
  thus "Ik.satPB \<xi> \<Phi>" using \<xi> by simp
qed

lemma T_completeness: "Model wtFsym wtPsym arOf resOf parOf \<Phi> intT intF intP"
apply default using completeness .

end (* context ProblemIkTpart_TEModel *)

(* Completeness theorem in sublocale form: Given a problem (with indicated
type partition) and a model for its tag-translated problem,
we obtain a model of the original problem: *)

sublocale ProblemIkTpart_TEModel < O : Model
where intT = intT and intF = intF and intP = intP
using T_completeness .

subsection{* The result of the tag translation is an infiniteness-augmented problem *}

(* Note that basic fact, merely stating that
the translation is well-defined between infiniteness-augmented problems,
is only proved at this late stage since it requires completeness.
This is an interesting dependency, not spotted in the paper. *)

sublocale ProblemIkTpart < TE : Problem
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf
and \<Phi> = tPB
apply default by auto

sublocale ProblemIkTpart < TE : ProblemIk
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf
and \<Phi> = tPB
proof default
  fix \<sigma> eintT eintF eintP a  assume \<sigma>: "infTp \<sigma>"
  assume M: "Model TE_wtFsym wtPsym TE_arOf TE_resOf parOf tPB eintT eintF eintP"
  let ?TE_intT = "ProblemIkTpart_TEModel.intT prot protFw eintT eintF"
  let ?TE_intF = "ProblemIkTpart_TEModel.intF arOf resOf prot protFw eintT eintF"
  let ?TE_intP = "ProblemIkTpart_TEModel.intP parOf prot protFw eintT eintF eintP"
  have 0: "ProblemIkTpart_TEModel wtFsym wtPsym arOf resOf parOf
                                   \<Phi> infTp prot protFw eintT eintF eintP"
  using M unfolding ProblemIkTpart_TEModel_def apply safe by default
  hence MM: "Ik.MModel ?TE_intT ?TE_intF ?TE_intP"
  by (rule ProblemIkTpart_TEModel.T_completeness)
  have "infinite {a. ?TE_intT \<sigma> a}" using infTp[OF \<sigma> MM] .
  moreover have "{a. ?TE_intT \<sigma> a} \<subseteq> {a. eintT \<sigma> a}"
  using ProblemIkTpart_TEModel.intT_def[OF 0] by auto
  ultimately show "infinite {a. eintT \<sigma> a}" using infinite_super by blast
qed

subsection{* The verification of the first monotonicity calculus criterion
for the tagged problem  *}

context ProblemIkTpart begin

lemma nvT_t[simp]: "\<not> unprot \<sigma> \<Longrightarrow> (\<forall> x \<in> TE.nvT (tT T). tpOfV x \<noteq> \<sigma>)"
apply(induct T) by auto

lemma nvL_tL[simp]: "\<not> unprot \<sigma> \<Longrightarrow> (\<forall> x \<in> TE.nvL (tL l). tpOfV x \<noteq> \<sigma>)"
apply(cases l) apply(rename_tac [!] atm) apply(case_tac [!] atm) by auto (metis nvT_t)+

lemma nvC_tC[simp]: "\<not> unprot \<sigma> \<Longrightarrow> (\<forall> x \<in> TE.nvC (tC c). tpOfV x \<noteq> \<sigma>)"
unfolding tC_def TE.nvC_def apply (induct c)
by auto (metis (full_types) nvL_tL)+

lemma unprot_nvT_t[simp]:
"unprot (tpOfV x) \<Longrightarrow> x \<in> TE.nvT (tT T) \<longleftrightarrow> x \<in>  TE.nvT T"
by (induct T, auto)

lemma tpL_nvT_tL[simp]:
"unprot (tpOfV x) \<Longrightarrow> x \<in> TE.nvL (tL l) \<longleftrightarrow> x \<in> TE.nvL l"
by (cases l, rename_tac [!] atm, case_tac [!] atm, auto)

lemma unprot_nvC_tC[simp]:
"unprot (tpOfV x) \<Longrightarrow> x \<in> TE.nvC (tC c) \<longleftrightarrow> x \<in> TE.nvC c"
unfolding tC_def TE.nvC_def apply (induct c) by auto

(* The added axioms are monotonic *)
lemma nv_OfFax[simp]:
"x \<notin> TE.nvT (lOfFax f)"  "x \<notin> TE.nvT (rOfFax f)"
unfolding lOfFax_def rOfFax_def lOfWax_def rOfWax_def by auto

lemma nv_OfWax[simp]:
"x \<notin> TE.nvT (lOfWax \<sigma>')"  "x \<notin> TE.nvT (rOfWax \<sigma>')"
unfolding lOfFax_def rOfFax_def lOfWax_def rOfWax_def by auto

lemma nvC_Fax: "c \<in> Fax \<Longrightarrow> TE.nvC c = {}" unfolding Fax_def TE.nvC_def by auto
lemma mcalc_Fax: "c \<in> Fax \<Longrightarrow> TE.mcalc \<sigma> c" using nvC_Fax unfolding TE.mcalc_iff by auto
lemma nvC_Wax: "c \<in> Wax \<Longrightarrow> TE.nvC c = {}" unfolding Wax_def TE.nvC_def by auto
lemma mcalc_Wax: "c \<in> Wax \<Longrightarrow> TE.mcalc \<sigma> c" using nvC_Wax[of c] by simp

end (* context ProblemIkTpart *)

sublocale ProblemIkTpart < TE: ProblemIkMcalc
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf
and \<Phi> = tPB
proof default
  fix \<sigma> c assume "c \<in> tPB"
  thus "TE.mcalc \<sigma> c" unfolding tPB_def proof safe
    fix d assume d: "d \<in> \<Phi>" thus "TE.mcalc \<sigma> (tC d)"
    using unprot_mcalc[OF _ d] unfolding TE.mcalc_iff by (cases "unprot \<sigma>", auto, force)
  qed(insert mcalc_Fax mcalc_Wax, blast+)
qed

(* We already know that ProblemIkMcalc < MonotProblem, so by transitivity we obtain
the following main theorem, stating that the tag translation yields a monotonic
problem *)
context ProblemIkTpart begin

theorem T_monotonic:
"MonotProblem TE_wtFsym wtPsym TE_arOf TE_resOf parOf tPB"
by default

end (* context ProblemIkTpart *)

sublocale ProblemIkTpart < TE: MonotProblem
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf and \<Phi> = tPB
using T_monotonic .

end


theory Subgradients
  imports "RLM_stable"
begin

definition subgradient :: "  ('a::euclidean_space \<Rightarrow> real) \<Rightarrow> 'a::euclidean_space set \<Rightarrow>
          'a::euclidean_space \<Rightarrow> 'a::euclidean_space \<Rightarrow> bool " where
  "subgradient f H' w v = (w \<in> H' \<and> ( \<forall> u \<in> H'. f (u) \<ge> f(w) + (inner (u-w) v)))"

definition diff_set :: "('a::euclidean_space \<Rightarrow> real) \<Rightarrow> 'a::euclidean_space set \<Rightarrow>
          'a::euclidean_space \<Rightarrow> 'a::euclidean_space set" where
  "diff_set f H' w = {h. subgradient f H' w h}"

fun hinge_loss :: "('a:: euclidean_space  \<Rightarrow> ('a \<times> real) \<Rightarrow> real)" where
  "hinge_loss w pair = (max 0 (1 - (snd pair) * inner w (fst pair)))"

text\<open>Don't need to prove it, if we show it is true for the hinge loss\<close>
lemma convex_has_subgradient:
  fixes f :: "'a::euclidean_space \<Rightarrow> real"
  fixes A :: "'a::euclidean_space set"
  fixes \<rho> :: "real"
  assumes "\<rho> \<ge> 0"
  assumes " open A"
  assumes "convex A"
  shows "convex_on A f \<longleftrightarrow> (\<forall> w \<in> A. \<exists> v \<in> A. \<forall> u \<in> A. f (u) \<ge> f(w) + (inner (u-w) v)) "
  sorry

lemma 147 :
  fixes f :: "'a::euclidean_space \<Rightarrow> real"
  fixes A :: "'a::euclidean_space set"
  fixes \<rho> :: "real"
  assumes "\<rho> \<ge> 0"
  assumes " open A"
  assumes "convex A"
  assumes has_subgrad: "\<forall> w \<in> A. \<exists> v. \<forall> u \<in> A. f (u) \<ge> f(w) + (inner (u-w) v)"
    and "convex_on A f"
  shows " \<rho>-lipschitz_on A f \<longleftrightarrow> (\<forall> w \<in> A. \<forall> v \<in> diff_set f A w. norm (v) \<le> \<rho>) "
proof
  assume bound_norm: "(\<forall> w \<in> A. \<forall> v \<in> diff_set f A w. norm (v) \<le> \<rho>)"
  have "\<forall>x\<in>A. \<forall>y\<in>A. dist (f x) (f y) \<le> \<rho> * dist x y"
  proof (rule)+
    fix x
    assume "x \<in> A"
    fix y
    assume " y \<in> A"

    then have "\<forall> v \<in> diff_set f A x. norm v \<le> \<rho>"
      using \<open>\<forall>w\<in>A. \<forall>v\<in>diff_set f A w. norm v \<le> \<rho>\<close> \<open>x \<in> A\<close> by blast
    have "\<forall> v \<in> diff_set f A x. subgradient f A x v"  unfolding diff_set_def by auto
    then have 1: "\<forall> u \<in> A. \<forall> v \<in> diff_set f A x. f (u) \<ge> f(x) + (inner (u-x) v)"
      unfolding subgradient_def by auto

    then have 2: "\<forall> u \<in> A. \<forall> v \<in> diff_set f A y. f (u) \<ge> f(y) + (inner (u-y) v)"
      unfolding diff_set_def unfolding subgradient_def by auto
    have "\<exists> v. \<forall> u \<in> A. f (u) \<ge> f(x) + (inner (u-x) v)" using has_subgrad assms
      using \<open>x \<in> A\<close> by blast
    then have "diff_set f A x \<noteq> {}" unfolding diff_set_def unfolding subgradient_def
      using  \<open>x \<in> A\<close> by blast
    have "\<exists> v. \<forall> u \<in> A. f (u) \<ge> f(y) + (inner (u-y) v)" using has_subgrad assms
      using \<open>y \<in> A\<close>   by blast
    then have "diff_set f A y \<noteq> {}" unfolding diff_set_def unfolding subgradient_def
      using  \<open>y  \<in> A\<close>  by blast

    have "\<forall> v \<in> diff_set f A x.  f x - f y  \<le> \<rho> * dist x y"
    proof
      fix v
      assume "v \<in> diff_set f A x"

      then have "  f (y) \<ge> f(x) + inner (y-x) v" using `y\<in> A` 1 by auto
      then have  " f x - f y \<le> inner (x - y) v"
        using   inner_minus_left minus_diff_eq by smt
      also have " inner (x - y) v \<le> norm ( x - y) * norm v"
        using norm_cauchy_schwarz by blast
      also have " norm (x - y) * norm v \<le> norm (x- y) * \<rho>"
        using bound_norm `v \<in> diff_set f A x`  \<open>x \<in> A\<close> mult_left_mono norm_ge_zero by blast
      finally have "f x - f y \<le>  \<rho> * norm (x- y)"
        by (simp add: mult.commute)
      then show " f x - f y  \<le> \<rho> * dist x y"
        by (simp add: dist_norm)
    qed
    then have "f x - f y  \<le> \<rho> * dist x y" using `diff_set f A x \<noteq> {}` by auto

    have "\<forall> v \<in> diff_set f A y.  f y - f x  \<le> \<rho> * dist y x"
    proof
      fix v
      assume "v \<in> diff_set f A y"

      then have "  f (x) \<ge> f(y) + inner (x-y) v" using `x\<in> A` 2 by auto
      then have  " f y - f x \<le> inner (y - x) v"
        using   inner_minus_left minus_diff_eq by smt
      also have " inner (y - x) v \<le> norm (y - x) * norm v"
        using norm_cauchy_schwarz by blast
      also have " norm (y - x) * norm v \<le> norm (y - x) * \<rho>"
        using bound_norm `v \<in> diff_set f A y`  \<open>y \<in> A\<close> mult_left_mono norm_ge_zero by blast
      finally have "f y - f x \<le>  \<rho> * norm (y- x)"
        by (simp add: mult.commute)
      then show " f y - f x  \<le> \<rho> * dist y x"
        by (simp add: dist_norm)
    qed
    then have "f y - f x  \<le> \<rho> * dist x y" using `diff_set f A y \<noteq> {}`
      by (simp add: diff_set_def dist_commute)
    then show " dist (f x) (f y)  \<le> \<rho> * dist x y" using `f x - f y  \<le> \<rho> * dist x y`
      by (simp add: dist_norm)
  qed
  then show "\<rho>-lipschitz_on A f" unfolding lipschitz_on_def using `\<rho> \<ge> 0` by auto
next
  assume "\<rho>-lipschitz_on A f"
  then have 1: "\<forall>x\<in>A. \<forall>y\<in>A. dist (f x) (f y) \<le> \<rho> * dist x y"
    unfolding lipschitz_on_def using `\<rho> \<ge> 0` by auto
  show "\<forall> w \<in> A. \<forall> v \<in> diff_set f A w. norm (v) \<le> \<rho>"
  proof (rule)+
    fix w
    assume "w \<in> A"
    fix v
    assume "v \<in> diff_set f A w"
    show " norm v \<le> \<rho>"
    proof (cases "norm v = 0")
      case True
      then show ?thesis using `\<rho> \<ge> 0` by auto
    next
      case False
      then have "norm v > 0" by auto
      have "\<exists>e>0. ball w e \<subseteq> A" using `open A` open_contains_ball
        using \<open>w \<in> A\<close> by blast
      then obtain e where "e>0" " ball w e \<subseteq> A" by auto
      then obtain e' where "e' > 0" "e' < e" by (meson field_lbound_gt_zero)
      let ?u = "w + (e' / (norm v)) *\<^sub>R v"

      have " norm ((e' / (norm v)) *\<^sub>R v) = e'"  using `norm v > 0`  `e' > 0`  by auto
      then have "dist w ?u = e'"
        by (simp add: dist_norm)

      then have "?u \<in> ball w e" by (simp add: \<open>e' < e\<close>)
      then have "?u \<in> A"  using \<open>ball w e \<subseteq> A\<close> by blast

      have "inner (?u - w) v = inner ((e'/norm v) *\<^sub>R v) v" by auto
      also have "\<dots> = (e'/norm v) * (inner v v)"
        using inner_scaleR_left by blast
      also have " \<dots> = (e'/norm v) * norm v * norm v"
        by (metis mult.assoc norm_cauchy_schwarz_eq)
      also have " \<dots> = e' * norm v" by auto
      finally have "inner (?u - w) v  = e' * norm v" by auto

      have "f ?u - f w \<ge> inner (?u - w) v"
        using  `v \<in> diff_set f A w` unfolding diff_set_def unfolding subgradient_def
        using `?u \<in> A`  by auto
      then have "f ?u - f w \<ge> e' * norm v" using `inner (?u - w) v  = e' * norm v` by auto

      have "\<rho> * e' = \<rho> * norm (?u - w)" using `dist w ?u = e' `
        by (simp add: dist_norm)
      then have "\<rho> * e' \<ge> norm (f ?u - f w)" using 1 `?u \<in> A` `w \<in> A` dist_norm
        by metis
      then have "\<rho> * e' \<ge> f ?u - f w" by auto
      then  have " \<rho> * e' \<ge>  e' * norm v" using `f ?u - f w \<ge> e' * norm v`
        by linarith
      then show "\<rho> \<ge> norm v"
        using \<open>0 < e'\<close> by auto
    qed
  qed
qed

lemma
  fixes A :: "'a::euclidean_space set"
  shows "\<forall> w \<in> A. \<exists> v. \<forall> u \<in> A. (\<lambda> z. hinge_loss z (x,y)) u \<ge>
      (\<lambda> z. hinge_loss z (x,y)) w + (inner (u-w) v)"
proof
  fix w
  assume "w \<in> A"
  show " \<exists> v. \<forall> u \<in> A.  hinge_loss u (x,y)  \<ge>
      hinge_loss w (x,y) + (inner (u-w) v)"
  proof(cases "1 - y * inner w x \<le> 0")
    case True
    have "\<forall> u. hinge_loss u (x,y)  \<ge>
      hinge_loss w (x,y)" unfolding hinge_loss.simps using True
      by auto
    then have "\<forall> u. hinge_loss u (x,y)  \<ge>
      hinge_loss w (x,y) + (inner (u-w) 0)" by auto
    then show ?thesis
      by blast
  next
    case False
    have " hinge_loss w (x,y) = 1 - y * inner w x" using hinge_loss.simps False by auto

    have " \<forall> u \<in> A.  hinge_loss u (x,y)  \<ge>
      hinge_loss w (x,y) + (inner (u-w) (- y *\<^sub>R x))"
    proof
      fix u
      assume "u\<in> A"
      have " hinge_loss u (x,y) \<ge> 1 - y * ( inner u x )" using hinge_loss.simps by auto
      also have "1 - y * ( inner u x ) =  1 - y * ( inner w x +  inner (u-w) x)"
        by (simp add: inner_diff_left )
      also have " \<dots> =  1 - y * inner w x - y * inner (u-w) x"
        by (simp add: distrib_left)
      also have " \<dots> =  hinge_loss w (x,y) + (inner (u-w) (- y *\<^sub>R x))"
        using \<open>hinge_loss w (x, y) = 1 - y * (w \<bullet> x)\<close> by auto
      finally show "hinge_loss u (x,y)  \<ge>
      hinge_loss w (x,y) + (inner (u-w) (- y *\<^sub>R x))" by auto
    qed
    then show ?thesis
      by blast
  qed
qed

lemma abv:
  fixes A :: "'a::euclidean_space set"

assumes "abs y = 1"
shows "(norm (x))-lipschitz_on A (\<lambda> z. hinge_loss z (x,y))"
proof -
  let ?f = "(\<lambda> z. hinge_loss z (x,y))"
  have "\<forall> u \<in> A. \<forall> v \<in> A. abs (?f u - ?f v) \<le> (norm x) * norm ( u - v )"
  proof (rule)+
    fix u
    fix v
    assume "u\<in>A"
    assume "v\<in>A"
    show "abs (?f u - ?f v) \<le> (norm x) * norm ( u - v )"
    proof (cases "1 - y * inner u x \<le> 0")
      case True
      then show ?thesis
      proof(cases "1 - y * inner v x \<le> 0")
        case True
        have "abs (?f u - ?f v) = 0" using True `1 - y * inner u x \<le> 0` by auto
        then show ?thesis by auto
      next
        case False
        have "?f v \<ge> 0" by auto
        have "abs(?f u - ?f v) = abs (?f v)" using  `1 - y * inner u x \<le> 0` by auto

        also have "abs (?f v) \<le> abs (?f v - 1 + y * inner u x)" using False `1 - y * inner u x \<le> 0`
          using `?f v \<ge> 0` by linarith
        also have "abs (?f v - 1 + y * inner u x) \<le> abs (- y * inner v x + y * inner u x)"
          using False by auto
        also have " abs (- y * inner v x + y * inner u x) = abs ( y * (inner u x - inner v x))"
          by (metis add.commute minus_mult_commute ring_normalization_rules(2) vector_space_over_itself.scale_right_distrib)
        also have " abs ( y * (inner u x - inner v x)) =  abs ( y * (inner (u-v) x))"
          by (simp add: inner_diff_left)
        also have "abs ( y * (inner (u-v) x)) = abs y * abs (inner (u-v) x)"
          using abs_mult by blast
        also have "abs y * abs (inner (u-v) x) = abs (inner (u-v) x)" using assms by auto
        also have "abs (inner (u-v) x) \<le> norm (u-v) * norm x"
          using Cauchy_Schwarz_ineq2 by blast
        finally show ?thesis
          by (simp add: mult.commute)
      qed
    next
      case False
      then show ?thesis
      proof (cases "1 - y * inner v x \<le> 0")
        case True
        have "?f u \<ge> 0" by auto
        have "abs(?f u - ?f v) = abs (?f u)" using  `1 - y * inner v x \<le> 0` by auto
        also have "abs (?f u) \<le> abs (?f u - 1 + y * inner v x)" using False `1 - y * inner v x \<le> 0`
          using `?f u \<ge> 0` by linarith
        also have "abs (?f u - 1 + y * inner v x) \<le> abs (- y * inner v x + y * inner u x)"
          using False by auto
        also have " abs (- y * inner v x + y * inner u x) = abs ( y * (inner u x - inner v x))"
          by (metis add.commute minus_mult_commute ring_normalization_rules(2) vector_space_over_itself.scale_right_distrib)
        also have " abs ( y * (inner u x - inner v x)) =  abs ( y * (inner (u-v) x))"
          by (simp add: inner_diff_left)
        also have "abs ( y * (inner (u-v) x)) = abs y * abs (inner (u-v) x)"
          using abs_mult by blast
        also have "abs y * abs (inner (u-v) x) = abs (inner (u-v) x)" using assms by auto
        also have "abs (inner (u-v) x) \<le> norm (u-v) * norm x"
          using Cauchy_Schwarz_ineq2 by blast
        finally show ?thesis
          by (simp add: mult.commute)
      next
        case False
        have "abs(?f u - ?f v)  \<le> abs (?f u - 1 + y * inner v x)"
          by simp
        also have "abs (?f u - 1 + y * inner v x) \<le> abs (- y * inner v x + y * inner u x)"
          using False by auto
        also have " abs (- y * inner v x + y * inner u x) = abs ( y * (inner u x - inner v x))"
          by (metis add.commute minus_mult_commute ring_normalization_rules(2) vector_space_over_itself.scale_right_distrib)
        also have " abs ( y * (inner u x - inner v x)) =  abs ( y * (inner (u-v) x))"
          by (simp add: inner_diff_left)
        also have "abs ( y * (inner (u-v) x)) = abs y * abs (inner (u-v) x)"
          using abs_mult by blast
        also have "abs y * abs (inner (u-v) x) = abs (inner (u-v) x)" using assms by auto
        also have "abs (inner (u-v) x) \<le> norm (u-v) * norm x"
          using Cauchy_Schwarz_ineq2 by blast
        finally show ?thesis
          by (simp add: mult.commute)
      qed
    qed
  qed
  then show ?thesis unfolding lipschitz_on_def
    by (simp add: dist_norm)
qed

lemma sum_of_max:
  fixes a :: real
  fixes b :: real
  shows "max 0 a + max 0 b \<ge>  max 0 (a+b)"
  by simp

lemma hinge_loss_convex:
  fixes H :: "'a::euclidean_space set"
    and D :: "('a \<times> real) pmf"
  shows "\<forall>z \<in> D. convex_on H (\<lambda> h. hinge_loss h z)"
proof
  fix z
  assume "z \<in> D"
  show " convex_on H (\<lambda> h. hinge_loss h z)" unfolding hinge_loss.simps
  proof(rule)+
    fix t
    fix x
    fix y
    assume " 0 < (t::real)"
    assume " t < 1"
    assume " x \<in> H"
    assume " y \<in> H"
    have 1 : "(1 - t) *(1 - snd z * (x \<bullet> fst z)) =
        (1 - t)*1 - (1 - t)* snd z * (x \<bullet> fst z)"
      by (metis inner_diff_right inner_real_def mult.assoc real_inner_1_right)
    have 2: " t*(1 - snd z * (y \<bullet> fst z)) =
       t*1 - t* snd z * (y \<bullet> fst z)"
      by (metis inner_diff_right inner_real_def mult.assoc real_inner_1_right)
    have "(1 - t) *
          max 0 (1 - snd z * (x \<bullet> fst z)) +
          t * max 0 (1 - snd z * (y \<bullet> fst z)) \<ge>

          max 0  (1 - t) *(1 - snd z * (x \<bullet> fst z)) +
           max 0 t*(1 - snd z * (y \<bullet> fst z))"
      by (smt \<open>0 < t\<close> \<open>t < 1\<close> inner_minus_right inner_real_def mult_pos_neg)
    also have " \<dots> \<ge> max 0 ((1 - t) *(1 - snd z * (x \<bullet> fst z)) +
                            t*(1 - snd z * (y \<bullet> fst z)))"
      using \<open>0 < t\<close> \<open>t < 1\<close> calculation by auto
    have "  max 0 ((1 - t) *(1 - snd z * (x \<bullet> fst z)) +
                            t*(1 - snd z * (y \<bullet> fst z)))
             =  max 0 (1 - t - (1 - t)* snd z * (x \<bullet> fst z) +
                            t - t* snd z * (y \<bullet> fst z))"
      using 1 2 by auto
    also  have " max 0 (1 - t - (1 - t)* snd z * (x \<bullet> fst z) +
                            t - t* snd z * (y \<bullet> fst z)) =
         max 0 (1  - (1 - t)* snd z * (x \<bullet> fst z) +
                             - t* snd z * (y \<bullet> fst z))" by auto
    also have " \<dots> =  max 0 (1  -  snd z * ((1 - t)*\<^sub>R x \<bullet> fst z)
                             - snd z * (t *\<^sub>R y \<bullet>  fst z))"
      by (simp add: mult.assoc mult.left_commute)
    also have " \<dots> = max 0 (1  -  snd z * (((1 - t)*\<^sub>R x \<bullet> fst z)
                             +  (t *\<^sub>R y \<bullet>  fst z)))"
      by (simp add: distrib_left)
    finally show " max 0
        (1 -
         snd z *
         (((1 - t) *\<^sub>R x + t *\<^sub>R y) \<bullet> fst z))
       \<le> (1 - t) *
          max 0 (1 - snd z * (x \<bullet> fst z)) +
          t * max 0 (1 - snd z * (y \<bullet> fst z))"
      by (metis (mono_tags, hide_lams) \<open>max 0 ((1 - t) * (1 - snd z * (x \<bullet> fst z)) + t * (1 - snd z * (y \<bullet> fst z))) = max 0 (1 - t - (1 - t) * snd z * (x \<bullet> fst z) + t - t * snd z * (y \<bullet> fst z))\<close> \<open>max 0 ((1 - t) * (1 - snd z * (x \<bullet> fst z)) + t * (1 - snd z * (y \<bullet> fst z))) \<le> (1 - t) * max 0 (1 - snd z * (x \<bullet> fst z)) + t * max 0 (1 - snd z * (y \<bullet> fst z))\<close> \<open>max 0 (1 - (1 - t) * snd z * (x \<bullet> fst z) + - t * snd z * (y \<bullet> fst z)) = max 0 (1 - snd z * ((1 - t) *\<^sub>R x \<bullet> fst z) - snd z * (t *\<^sub>R y \<bullet> fst z))\<close> \<open>max 0 (1 - snd z * ((1 - t) *\<^sub>R x \<bullet> fst z) - snd z * (t *\<^sub>R y \<bullet> fst z)) = max 0 (1 - snd z * ((1 - t) *\<^sub>R x \<bullet> fst z + t *\<^sub>R y \<bullet> fst z))\<close> \<open>max 0 (1 - t - (1 - t) * snd z * (x \<bullet> fst z) + t - t * snd z * (y \<bullet> fst z)) = max 0 (1 - (1 - t) * snd z * (x \<bullet> fst z) + - t * snd z * (y \<bullet> fst z))\<close> add.commute  inner_commute inner_left_distrib inner_real_def inner_scaleR_left inner_scaleR_right)
  qed
qed

lemma hinge_loss_pos:
  fixes H :: "'a::euclidean_space set"
    and D :: "('a \<times> real) pmf"
  shows "\<forall>h\<in>H. \<forall>z\<in>D. hinge_loss h z \<ge> 0"
  by auto

end