(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_05
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rev :: "'a list => 'a list" where
  "rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z xs) = S (length xs)"

theorem property0 :
  "((length (rev y)) = (length y))"
  oops

end


(*  Title:      HOL/Library/Numeral_Type.thy
    Author:     Brian Huffman
*)

section \<open>Numeral Syntax for Types\<close>

theory Numeral_Type
imports Cardinality
begin

subsection \<open>Numeral Types\<close>

typedef num0 = "UNIV :: nat set" ..
typedef num1 = "UNIV :: unit set" ..

typedef 'a bit0 = "{0 ..< 2 * int CARD('a::finite)}"
proof
  show "0 \<in> {0 ..< 2 * int CARD('a)}"
    by simp
qed

typedef 'a bit1 = "{0 ..< 1 + 2 * int CARD('a::finite)}"
proof
  show "0 \<in> {0 ..< 1 + 2 * int CARD('a)}"
    by simp
qed

lemma card_num0 [simp]: "CARD (num0) = 0"
  unfolding type_definition.card [OF type_definition_num0]
  by simp

lemma infinite_num0: "\<not> finite (UNIV :: num0 set)"
  using card_num0[unfolded card_eq_0_iff]
  by simp

lemma card_num1 [simp]: "CARD(num1) = 1"
  unfolding type_definition.card [OF type_definition_num1]
  by (simp only: card_UNIV_unit)

lemma card_bit0 [simp]: "CARD('a bit0) = 2 * CARD('a::finite)"
  unfolding type_definition.card [OF type_definition_bit0]
  by simp

lemma card_bit1 [simp]: "CARD('a bit1) = Suc (2 * CARD('a::finite))"
  unfolding type_definition.card [OF type_definition_bit1]
  by simp

subsection \<open>@{typ num1}\<close>

instance num1 :: finite
proof
  show "finite (UNIV::num1 set)"
    unfolding type_definition.univ [OF type_definition_num1]
    using finite by (rule finite_imageI)
qed

instantiation num1 :: CARD_1
begin

instance
proof
  show "CARD(num1) = 1" by auto
qed

end

lemma num1_eq_iff: "(x::num1) = (y::num1) \<longleftrightarrow> True"
  by (induct x, induct y) simp

instantiation num1 :: "{comm_ring,comm_monoid_mult,numeral}"
begin

instance
  by standard (simp_all add: num1_eq_iff)

end

lemma num1_eqI:
  fixes a::num1 shows "a = b"
by(simp add: num1_eq_iff)

lemma num1_eq1 [simp]:
  fixes a::num1 shows "a = 1"
  by (rule num1_eqI)

lemma forall_1[simp]: "(\<forall>i::num1. P i) \<longleftrightarrow> P 1"
  by (metis (full_types) num1_eq_iff)

lemma ex_1[simp]: "(\<exists>x::num1. P x) \<longleftrightarrow> P 1"
  by auto (metis (full_types) num1_eq_iff)

instantiation num1 :: linorder begin
definition "a < b \<longleftrightarrow> Rep_num1 a < Rep_num1 b"
definition "a \<le> b \<longleftrightarrow> Rep_num1 a \<le> Rep_num1 b"
instance
  by intro_classes (auto simp: less_eq_num1_def less_num1_def intro: num1_eqI)
end

instance num1 :: wellorder
  by intro_classes (auto simp: less_eq_num1_def less_num1_def)

instance bit0 :: (finite) card2
proof
  show "finite (UNIV::'a bit0 set)"
    unfolding type_definition.univ [OF type_definition_bit0]
    by simp
  show "2 \<le> CARD('a bit0)"
    by simp
qed

instance bit1 :: (finite) card2
proof
  show "finite (UNIV::'a bit1 set)"
    unfolding type_definition.univ [OF type_definition_bit1]
    by simp
  show "2 \<le> CARD('a bit1)"
    by simp
qed

subsection \<open>Locales for for modular arithmetic subtypes\<close>

locale mod_type =
  fixes n :: int
  and Rep :: "'a::{zero,one,plus,times,uminus,minus} \<Rightarrow> int"
  and Abs :: "int \<Rightarrow> 'a::{zero,one,plus,times,uminus,minus}"
  assumes type: "type_definition Rep Abs {0..<n}"
  and size1: "1 < n"
  and zero_def: "0 = Abs 0"
  and one_def:  "1 = Abs 1"
  and add_def:  "x + y = Abs ((Rep x + Rep y) mod n)"
  and mult_def: "x * y = Abs ((Rep x * Rep y) mod n)"
  and diff_def: "x - y = Abs ((Rep x - Rep y) mod n)"
  and minus_def: "- x = Abs ((- Rep x) mod n)"
begin

lemmas definitions =
  zero_def one_def add_def mult_def minus_def diff_def

lemma Rep_less_n: "Rep x < n"
by (rule type_definition.Rep [OF type, simplified, THEN conjunct2])

lemma Rep_le_n: "Rep x \<le> n"
by (rule Rep_less_n [THEN order_less_imp_le])

lemma Rep_inject_sym: "x = y \<longleftrightarrow> Rep x = Rep y"
by (rule type_definition.Rep_inject [OF type, symmetric])

lemma Rep_inverse: "Abs (Rep x) = x"
by (rule type_definition.Rep_inverse [OF type])

lemma Abs_inverse: "m \<in> {0..<n} \<Longrightarrow> Rep (Abs m) = m"
by (rule type_definition.Abs_inverse [OF type])

lemma Rep_Abs_mod: "Rep (Abs (m mod n)) = m mod n"
by (simp add: Abs_inverse pos_mod_conj [OF size0])

lemma Rep_Abs_0: "Rep (Abs 0) = 0"
by (simp add: Abs_inverse size0)

lemma Rep_0: "Rep 0 = 0"
by (simp add: zero_def Rep_Abs_0)

lemma Rep_Abs_1: "Rep (Abs 1) = 1"
by (simp add: Abs_inverse size1)

lemma Rep_1: "Rep 1 = 1"
by (simp add: one_def Rep_Abs_1)

lemma Rep_mod: "Rep x mod n = Rep x"
apply (rule_tac x=x in type_definition.Abs_cases [OF type])
apply (simp add: type_definition.Abs_inverse [OF type])
done

lemmas Rep_simps =
  Rep_inject_sym Rep_inverse Rep_Abs_mod Rep_mod Rep_Abs_0 Rep_Abs_1

lemma comm_ring_1: "OFCLASS('a, comm_ring_1_class)"
apply (intro_classes, unfold definitions)
apply (simp_all add: Rep_simps mod_simps field_simps)
done

end

locale mod_ring = mod_type n Rep Abs
  for n :: int
  and Rep :: "'a::{comm_ring_1} \<Rightarrow> int"
  and Abs :: "int \<Rightarrow> 'a::{comm_ring_1}"
begin

lemma of_nat_eq: "of_nat k = Abs (int k mod n)"
apply (induct k)
apply (simp add: zero_def)
apply (simp add: Rep_simps add_def one_def mod_simps ac_simps)
done

lemma of_int_eq: "of_int z = Abs (z mod n)"
apply (cases z rule: int_diff_cases)
apply (simp add: Rep_simps of_nat_eq diff_def mod_simps)
done

lemma Rep_numeral:
  "Rep (numeral w) = numeral w mod n"
using of_int_eq [of "numeral w"]
by (simp add: Rep_inject_sym Rep_Abs_mod)

lemma iszero_numeral:
  "iszero (numeral w::'a) \<longleftrightarrow> numeral w mod n = 0"
by (simp add: Rep_inject_sym Rep_numeral Rep_0 iszero_def)

lemma cases:
  assumes 1: "\<And>z. \<lbrakk>(x::'a) = of_int z; 0 \<le> z; z < n\<rbrakk> \<Longrightarrow> P"
  shows "P"
apply (cases x rule: type_definition.Abs_cases [OF type])
apply (rule_tac z="y" in 1)
apply (simp_all add: of_int_eq)
done

lemma induct:
  "(\<And>z. \<lbrakk>0 \<le> z; z < n\<rbrakk> \<Longrightarrow> P (of_int z)) \<Longrightarrow> P (x::'a)"
by (cases x rule: cases) simp

lemma UNIV_eq: "(UNIV :: 'a set) = Abs ` {0..<n}"
  using type type_definition.univ by blast

lemma CARD_eq: "CARD('a) = nat n"
proof -
  have "CARD('a) = card (Abs ` {0..<n})"
    by (simp add: UNIV_eq)
  also have "inj_on Abs {0..<n}"
    by (metis Abs_inverse inj_onI)
  hence "card (Abs ` {0..<n}) = nat n"
    using size1 by (subst card_image) auto
  finally show ?thesis .
qed

lemma CHAR_eq [simp]: "CHAR('a) = CARD('a)"
proof (rule CHAR_eqI)
  show "of_nat (CARD('a)) = (0 :: 'a)"
    by (simp add: CARD_eq of_nat_eq zero_def)
next
  fix n assume "of_nat n = (0 :: 'a)"
  thus "CARD('a) dvd n"
    by (metis CARD_eq Rep_0 Rep_Abs_mod Rep_le_n mod_0_imp_dvd nat_dvd_iff of_nat_eq)
qed

end

subsection \<open>Ring class instances\<close>

text \<open>
  Unfortunately \<open>ring_1\<close> instance is not possible for
  \<^typ>\<open>num1\<close>, since 0 and 1 are not distinct.
\<close>

instantiation
  bit0 and bit1 :: (finite) "{zero,one,plus,times,uminus,minus}"
begin

definition Abs_bit0' :: "int \<Rightarrow> 'a bit0" where
  "Abs_bit0' x = Abs_bit0 (x mod int CARD('a bit0))"

definition Abs_bit1' :: "int \<Rightarrow> 'a bit1" where
  "Abs_bit1' x = Abs_bit1 (x mod int CARD('a bit1))"

definition "0 = Abs_bit0 0"
definition "1 = Abs_bit0 1"
definition "x + y = Abs_bit0' (Rep_bit0 x + Rep_bit0 y)"
definition "x * y = Abs_bit0' (Rep_bit0 x * Rep_bit0 y)"
definition "x - y = Abs_bit0' (Rep_bit0 x - Rep_bit0 y)"
definition "- x = Abs_bit0' (- Rep_bit0 x)"

definition "0 = Abs_bit1 0"
definition "1 = Abs_bit1 1"
definition "x + y = Abs_bit1' (Rep_bit1 x + Rep_bit1 y)"
definition "x * y = Abs_bit1' (Rep_bit1 x * Rep_bit1 y)"
definition "x - y = Abs_bit1' (Rep_bit1 x - Rep_bit1 y)"
definition "- x = Abs_bit1' (- Rep_bit1 x)"

instance ..

end

interpretation bit0:
  mod_type "int CARD('a::finite bit0)"
           "Rep_bit0 :: 'a::finite bit0 \<Rightarrow> int"
           "Abs_bit0 :: int \<Rightarrow> 'a::finite bit0"
apply (rule mod_type.intro)
apply (simp add: type_definition_bit0)
apply (rule one_less_int_card)
apply (rule zero_bit0_def)
apply (rule one_bit0_def)
apply (rule plus_bit0_def [unfolded Abs_bit0'_def])
apply (rule times_bit0_def [unfolded Abs_bit0'_def])
apply (rule minus_bit0_def [unfolded Abs_bit0'_def])
apply (rule uminus_bit0_def [unfolded Abs_bit0'_def])
done

interpretation bit1:
  mod_type "int CARD('a::finite bit1)"
           "Rep_bit1 :: 'a::finite bit1 \<Rightarrow> int"
           "Abs_bit1 :: int \<Rightarrow> 'a::finite bit1"
apply (rule mod_type.intro)
apply (simp add: type_definition_bit1)
apply (rule one_less_int_card)
apply (rule zero_bit1_def)
apply (rule one_bit1_def)
apply (rule plus_bit1_def [unfolded Abs_bit1'_def])
apply (rule times_bit1_def [unfolded Abs_bit1'_def])
apply (rule minus_bit1_def [unfolded Abs_bit1'_def])
apply (rule uminus_bit1_def [unfolded Abs_bit1'_def])
done

instance bit0 :: (finite) comm_ring_1
  by (rule bit0.comm_ring_1)

instance bit1 :: (finite) comm_ring_1
  by (rule bit1.comm_ring_1)

interpretation bit0:
  mod_ring "int CARD('a::finite bit0)"
           "Rep_bit0 :: 'a::finite bit0 \<Rightarrow> int"
           "Abs_bit0 :: int \<Rightarrow> 'a::finite bit0"
  ..

interpretation bit1:
  mod_ring "int CARD('a::finite bit1)"
           "Rep_bit1 :: 'a::finite bit1 \<Rightarrow> int"
           "Abs_bit1 :: int \<Rightarrow> 'a::finite bit1"
  ..

text \<open>Set up cases, induction, and arithmetic\<close>

lemmas bit0_cases [case_names of_int, cases type: bit0] = bit0.cases
lemmas bit1_cases [case_names of_int, cases type: bit1] = bit1.cases

lemmas bit0_induct [case_names of_int, induct type: bit0] = bit0.induct
lemmas bit1_induct [case_names of_int, induct type: bit1] = bit1.induct

lemmas bit0_iszero_numeral [simp] = bit0.iszero_numeral
lemmas bit1_iszero_numeral [simp] = bit1.iszero_numeral

lemmas [simp] = eq_numeral_iff_iszero [where 'a="'a bit0"] for dummy :: "'a::finite"
lemmas [simp] = eq_numeral_iff_iszero [where 'a="'a bit1"] for dummy :: "'a::finite"

subsection \<open>Order instances\<close>

instantiation bit0 and bit1 :: (finite) linorder begin
definition "a < b \<longleftrightarrow> Rep_bit0 a < Rep_bit0 b"
definition "a \<le> b \<longleftrightarrow> Rep_bit0 a \<le> Rep_bit0 b"
definition "a < b \<longleftrightarrow> Rep_bit1 a < Rep_bit1 b"
definition "a \<le> b \<longleftrightarrow> Rep_bit1 a \<le> Rep_bit1 b"

instance
  by(intro_classes)
    (auto simp add: less_eq_bit0_def less_bit0_def less_eq_bit1_def less_bit1_def Rep_bit0_inject Rep_bit1_inject)
end

lemma (in preorder) tranclp_less: "(<) \<^sup>+\<^sup>+ = (<)"
by(auto simp add: fun_eq_iff intro: less_trans elim: tranclp.induct)

instance bit0 and bit1 :: (finite) wellorder
proof -
  have "wf {(x :: 'a bit0, y). x < y}"
    by(auto simp add: trancl_def tranclp_less intro!: finite_acyclic_wf acyclicI)
  thus "OFCLASS('a bit0, wellorder_class)"
    by(rule wf_wellorderI) intro_classes
next
  have "wf {(x :: 'a bit1, y). x < y}"
    by(auto simp add: trancl_def tranclp_less intro!: finite_acyclic_wf acyclicI)
  thus "OFCLASS('a bit1, wellorder_class)"
    by(rule wf_wellorderI) intro_classes
qed

subsection \<open>Code setup and type classes for code generation\<close>

text \<open>Code setup for \<^typ>\<open>num0\<close> and \<^typ>\<open>num1\<close>\<close>

definition Num0 :: num0 where "Num0 = Abs_num0 0"
code_datatype Num0

instantiation num0 :: equal begin
definition equal_num0 :: "num0 \<Rightarrow> num0 \<Rightarrow> bool"
  where "equal_num0 = (=)"
instance by intro_classes (simp add: equal_num0_def)
end

lemma equal_num0_code [code]:
  "equal_class.equal Num0 Num0 = True"
by(rule equal_refl)

code_datatype "1 :: num1"

instantiation num1 :: equal begin
definition equal_num1 :: "num1 \<Rightarrow> num1 \<Rightarrow> bool"
  where "equal_num1 = (=)"
instance by intro_classes (simp add: equal_num1_def)
end

lemma equal_num1_code [code]:
  "equal_class.equal (1 :: num1) 1 = True"
by(rule equal_refl)

instantiation num1 :: enum begin
definition "enum_class.enum = [1 :: num1]"
definition "enum_class.enum_all P = P (1 :: num1)"
definition "enum_class.enum_ex P = P (1 :: num1)"
instance
  by intro_classes
     (auto simp add: enum_num1_def enum_all_num1_def enum_ex_num1_def num1_eq_iff Ball_def)
end

instantiation num0 and num1 :: card_UNIV begin
definition "finite_UNIV = Phantom(num0) False"
definition "card_UNIV = Phantom(num0) 0"
definition "finite_UNIV = Phantom(num1) True"
definition "card_UNIV = Phantom(num1) 1"
instance
  by intro_classes
     (simp_all add: finite_UNIV_num0_def card_UNIV_num0_def infinite_num0 finite_UNIV_num1_def card_UNIV_num1_def)
end

text \<open>Code setup for \<^typ>\<open>'a bit0\<close> and \<^typ>\<open>'a bit1\<close>\<close>

declare
  bit0.Rep_inverse[code abstype]
  bit0.Rep_0[code abstract]
  bit0.Rep_1[code abstract]

lemma Abs_bit0'_code [code abstract]:
  "Rep_bit0 (Abs_bit0' x :: 'a :: finite bit0) = x mod int (CARD('a bit0))"
by(auto simp add: Abs_bit0'_def intro!: Abs_bit0_inverse)

lemma inj_on_Abs_bit0:
  "inj_on (Abs_bit0 :: int \<Rightarrow> 'a bit0) {0..<2 * int CARD('a :: finite)}"
by(auto intro: inj_onI simp add: Abs_bit0_inject)

declare
  bit1.Rep_inverse[code abstype]
  bit1.Rep_0[code abstract]
  bit1.Rep_1[code abstract]

lemma Abs_bit1'_code [code abstract]:
  "Rep_bit1 (Abs_bit1' x :: 'a :: finite bit1) = x mod int (CARD('a bit1))"
  by(auto simp add: Abs_bit1'_def intro!: Abs_bit1_inverse)

lemma inj_on_Abs_bit1:
  "inj_on (Abs_bit1 :: int \<Rightarrow> 'a bit1) {0..<1 + 2 * int CARD('a :: finite)}"
by(auto intro: inj_onI simp add: Abs_bit1_inject)

instantiation bit0 and bit1 :: (finite) equal begin

definition "equal_class.equal x y \<longleftrightarrow> Rep_bit0 x = Rep_bit0 y"
definition "equal_class.equal x y \<longleftrightarrow> Rep_bit1 x = Rep_bit1 y"

instance
  by intro_classes (simp_all add: equal_bit0_def equal_bit1_def Rep_bit0_inject Rep_bit1_inject)

end

instantiation bit0 :: (finite) enum begin
definition "(enum_class.enum :: 'a bit0 list) = map (Abs_bit0' \<circ> int) (upt 0 (CARD('a bit0)))"
definition "enum_class.enum_all P = (\<forall>b :: 'a bit0 \<in> set enum_class.enum. P b)"
definition "enum_class.enum_ex P = (\<exists>b :: 'a bit0 \<in> set enum_class.enum. P b)"

instance proof
  show "distinct (enum_class.enum :: 'a bit0 list)"
    by (simp add: enum_bit0_def distinct_map inj_on_def Abs_bit0'_def Abs_bit0_inject)

  let ?Abs = "Abs_bit0 :: _ \<Rightarrow> 'a bit0"
  interpret type_definition Rep_bit0 ?Abs "{0..<2 * int CARD('a)}"
    by (fact type_definition_bit0)
  have "UNIV = ?Abs ` {0..<2 * int CARD('a)}"
    by (simp add: Abs_image)
  also have "\<dots> = ?Abs ` (int ` {0..<2 * CARD('a)})"
    by (simp add: image_int_atLeastLessThan)
  also have "\<dots> = (?Abs \<circ> int) ` {0..<2 * CARD('a)}"
    by (simp add: image_image cong: image_cong)
  also have "\<dots> = set enum_class.enum"
    by (simp add: enum_bit0_def Abs_bit0'_def cong: image_cong_simp)
  finally show univ_eq: "(UNIV :: 'a bit0 set) = set enum_class.enum" .

  fix P :: "'a bit0 \<Rightarrow> bool"
  show "enum_class.enum_all P = Ball UNIV P"
    and "enum_class.enum_ex P = Bex UNIV P"
    by(simp_all add: enum_all_bit0_def enum_ex_bit0_def univ_eq)
qed

end

instantiation bit1 :: (finite) enum begin
definition "(enum_class.enum :: 'a bit1 list) = map (Abs_bit1' \<circ> int) (upt 0 (CARD('a bit1)))"
definition "enum_class.enum_all P = (\<forall>b :: 'a bit1 \<in> set enum_class.enum. P b)"
definition "enum_class.enum_ex P = (\<exists>b :: 'a bit1 \<in> set enum_class.enum. P b)"

instance
proof(intro_classes)
  show "distinct (enum_class.enum :: 'a bit1 list)"
    by(simp only: Abs_bit1'_def zmod_int[symmetric] enum_bit1_def distinct_map Suc_eq_plus1 card_bit1 o_apply inj_on_def)
      (clarsimp simp add: Abs_bit1_inject)

  let ?Abs = "Abs_bit1 :: _ \<Rightarrow> 'a bit1"
  interpret type_definition Rep_bit1 ?Abs "{0..<1 + 2 * int CARD('a)}"
    by (fact type_definition_bit1)
  have "UNIV = ?Abs ` {0..<1 + 2 * int CARD('a)}"
    by (simp add: Abs_image)
  also have "\<dots> = ?Abs ` (int ` {0..<1 + 2 * CARD('a)})"
    by (simp add: image_int_atLeastLessThan)
  also have "\<dots> = (?Abs \<circ> int) ` {0..<1 + 2 * CARD('a)}"
    by (simp add: image_image cong: image_cong)
  finally show univ_eq: "(UNIV :: 'a bit1 set) = set enum_class.enum"
    by (simp only: enum_bit1_def set_map set_upt) (simp add: Abs_bit1'_def cong: image_cong_simp)

  fix P :: "'a bit1 \<Rightarrow> bool"
  show "enum_class.enum_all P = Ball UNIV P"
    and "enum_class.enum_ex P = Bex UNIV P"
    by(simp_all add: enum_all_bit1_def enum_ex_bit1_def univ_eq)
qed

end

instantiation bit0 and bit1 :: (finite) finite_UNIV begin
definition "finite_UNIV = Phantom('a bit0) True"
definition "finite_UNIV = Phantom('a bit1) True"
instance by intro_classes (simp_all add: finite_UNIV_bit0_def finite_UNIV_bit1_def)
end

instantiation bit0 and bit1 :: ("{finite,card_UNIV}") card_UNIV begin
definition "card_UNIV = Phantom('a bit0) (2 * of_phantom (card_UNIV :: 'a card_UNIV))"
definition "card_UNIV = Phantom('a bit1) (1 + 2 * of_phantom (card_UNIV :: 'a card_UNIV))"
instance by intro_classes (simp_all add: card_UNIV_bit0_def card_UNIV_bit1_def card_UNIV)
end

subsection \<open>Syntax\<close>

syntax
  "_NumeralType" :: "num_token => type"  ("_")
  "_NumeralType0" :: type ("0")
  "_NumeralType1" :: type ("1")

translations
  (type) "1" == (type) "num1"
  (type) "0" == (type) "num0"

parse_translation \<open>
  let
    fun mk_bintype n =
      let
        fun mk_bit 0 = Syntax.const \<^type_syntax>\<open>bit0\<close>
          | mk_bit 1 = Syntax.const \<^type_syntax>\<open>bit1\<close>;
        fun bin_of n =
          if n = 1 then Syntax.const \<^type_syntax>\<open>num1\<close>
          else if n = 0 then Syntax.const \<^type_syntax>\<open>num0\<close>
          else if n = ~1 then raise TERM ("negative type numeral", [])
          else
            let val (q, r) = Integer.div_mod n 2;
            in mk_bit r $ bin_of q end;
      in bin_of n end;

    fun numeral_tr [Free (str, _)] = mk_bintype (the (Int.fromString str))
      | numeral_tr ts = raise TERM ("numeral_tr", ts);

  in [(\<^syntax_const>\<open>_NumeralType\<close>, K numeral_tr)] end
\<close>

print_translation \<open>
  let
    fun int_of [] = 0
      | int_of (b :: bs) = b + 2 * int_of bs;

    fun bin_of (Const (\<^type_syntax>\<open>num0\<close>, _)) = []
      | bin_of (Const (\<^type_syntax>\<open>num1\<close>, _)) = [1]
      | bin_of (Const (\<^type_syntax>\<open>bit0\<close>, _) $ bs) = 0 :: bin_of bs
      | bin_of (Const (\<^type_syntax>\<open>bit1\<close>, _) $ bs) = 1 :: bin_of bs
      | bin_of t = raise TERM ("bin_of", [t]);

    fun bit_tr' b [t] =
          let
            val rev_digs = b :: bin_of t handle TERM _ => raise Match
            val i = int_of rev_digs;
            val num = string_of_int (abs i);
          in
            Syntax.const \<^syntax_const>\<open>_NumeralType\<close> $ Syntax.free num
          end
      | bit_tr' b _ = raise Match;
  in
   [(\<^type_syntax>\<open>bit0\<close>, K (bit_tr' 0)),
    (\<^type_syntax>\<open>bit1\<close>, K (bit_tr' 1))]
  end
\<close>

subsection \<open>Examples\<close>

lemma "CARD(0) = 0" by simp
lemma "CARD(17) = 17" by simp
lemma "CHAR(23) = 23" by simp
lemma "8 * 11 ^ 3 - 6 = (2::5)" by simp

(*******************)
(* bit0 and bit1 have wide type definitions *)

(* Preliminaries *)
(* *)
definition surjf :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int" where
"surjf i j \<equiv> \<lambda>u. if u < j then u else j-1"

lemma surjf_between: "0 < j \<Longrightarrow> j \<le> i \<Longrightarrow> 0 \<le> u \<Longrightarrow> u < i \<Longrightarrow>
  0 \<le> surjf i j u \<and> surjf i j u < j"
unfolding surjf_def by fastforce

lemma surjf_surj: "0 < j \<Longrightarrow> j \<le> i \<Longrightarrow>
  0 \<le> u \<Longrightarrow> u < j \<Longrightarrow>
  \<exists>v. (0 \<le> v \<and> v < i) \<and> u = surjf i j v"
unfolding surjf_def by fastforce

lemma surj_surjf: "0 < j \<Longrightarrow> j \<le> i \<Longrightarrow> surjf i j ` {0..<i} = {0..<j}"
unfolding surjf_def by fastforce

term "atLeastLessThan 0 (int (card(UNIV::('a::finite)set)))"

(* bit0 has a wide type definition *)

definition isBit0 where
"isBit0 (a::'a::finite) i \<equiv> 0 \<le> i \<and> i < 2 * int CARD('a::finite)"

lemma atLeastLessThan_Collect_bit0:
"{0 ..< 2 * int CARD('a::finite)} = Collect (isBit0 (a::'a))"
unfolding isBit0_def by auto

lemma bit0_type_definition:
"type_definition
   (Rep_bit0::'a bit0 \<Rightarrow> int) Abs_bit0
   (Collect (isBit0 (a::'a::finite)))"
unfolding atLeastLessThan_Collect_bit0[symmetric]
using type_definition_bit0 by blast

(* *)

lemma isBit0_aux: "isBit0 = isBit0" ..
local_setup \<open>RLTHM @{binding isBit0_rlt_neper_param} @{thm isBit0_aux}\<close>
thm isBit0_rlt_neper_param
(* A to D: This is the issue with itself, right? *)

lemma isBit0_rlt_simp[simp]: "neper (R::'a::finite\<Rightarrow>'a\<Rightarrow>bool) \<Longrightarrow>
 isBit0_rlt R a =
 (\<lambda>i. (0 \<le> i \<and> i < 2 * int (card {getRepr R a |a. R a a})))"
unfolding isBit0_rlt_def fun_eq_iff
apply simp unfolding rlt_eq by simp

definition hh0 where
"hh0 \<equiv> \<lambda>R::'a::finite\<Rightarrow>'a\<Rightarrow>bool.
    surjf (2 * int (CARD('a)))
          (2 * int (card {getRepr R a |a. R a a}))"

definition bit0_rel :: "('a::finite \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a bit0 \<Rightarrow> 'a bit0 \<Rightarrow> bool"
where "bit0_rel R \<equiv>
inv_imagep
  (restr (inv_imagep (restr (=) (isBit0_rlt R undefined)) (hh0 R))
         (isBit0 (undefined::'a)))
  Rep_bit0"

lemma isBit0_rlt_hh0:
"neper (R::'a::finite\<Rightarrow>'a\<Rightarrow>bool) \<Longrightarrow>
 isBit0 (undefined::'a) x \<Longrightarrow> isBit0_rlt R (undefined::'a) (hh0 R x)"
unfolding isBit0_def isBit0_rlt_simp  hh0_def
  unfolding isBit0_def isBit0_rlt_simp hh0_def
  apply(rule surjf_between) apply auto
  using card_gt_0_iff ne_getRepr apply fastforce
  by (simp add: card_mono)

lemma bij_upto_hh0:
assumes R: "neper (R::'a::finite\<Rightarrow>'a\<Rightarrow>bool)"
shows "bij_upto (bit0_rel R) (restr (=) (isBit0_rlt R undefined)) (hh0 R \<circ> Rep_bit0::'a bit0 \<Rightarrow> int)"
apply(rule bij_upto_criterion[OF bit0_type_definition, of "(=)" "undefined::'a" "isBit0_rlt R undefined" "hh0 R",simped,
unfolded bit0_rel_def[symmetric]])
  subgoal using isBit0_rlt_hh0[OF R] .
  subgoal for u unfolding isBit0_def isBit0_rlt_simp[OF R] hh0_def
  apply(rule surjf_surj) by (auto simp: card_mono) .

lemma hh0_eq': "0 \<le> i \<Longrightarrow> i < 2 * int CARD('a::finite) \<Longrightarrow> hh0 ((=)::'a\<Rightarrow>'a\<Rightarrow>bool) i = i"
unfolding hh0_def surjf_def by auto

lemma hh0_eq[simp]: "hh0 ((=)::'a::finite\<Rightarrow>'a\<Rightarrow>bool) (Rep_bit0 (a::'a bit0)) = Rep_bit0 a"
apply(rule hh0_eq') using Rep_bit0 by auto

lemma bit0_rel_neper:
"neper (R::'a::finite\<Rightarrow>'a\<Rightarrow>bool) \<Longrightarrow> neper (bit0_rel R::'a bit0 \<Rightarrow> 'a bit0 \<Rightarrow> bool)"
unfolding bit0_rel_def
apply(rule neper_criterion[OF bit0_type_definition, of _ "undefined::'a"])
  subgoal by auto
  subgoal apply(rule exI[of _ 0]) unfolding isBit0_def by auto
  subgoal apply(drule isBit0_rlt_hh0) by auto .

lemma bit0_rel_eq[simp]: "bit0_rel (((=)::'a::finite\<Rightarrow>'a\<Rightarrow>bool)) = (=)"
unfolding bit0_rel_def rlt_eq inv_imagep_def fun_eq_iff restr_def apply simp
using Rep_bit0 Rep_bit0_inject atLeastLessThan_Collect_bit0 by blast

(* *)

wide_typedef bit0 rel: bit0_rel rep: "\<lambda>R. hh0 R \<circ> Rep_bit0"
  subgoal using bit0_rel_neper .
  subgoal using bit0_rel_eq .
  subgoal for R
  unfolding rlt_eq apply simp
  unfolding isBit0_rlt_simp[of R undefined, symmetric]
  using bij_upto_hh0 .
  subgoal unfolding fun_eq_iff comp_def apply safe using hh0_eq . .

(*****)
(* bit1 has a wide type definition *)

definition isBit1 where
"isBit1 (a::'a::finite) i \<equiv> 0 \<le> i \<and> i < 1 + 2 * int CARD('a::finite)"

lemma atLeastLessThan_Collect_bit1:
"{0 ..< 1 + 2 * int CARD('a::finite)} = Collect (isBit1 (a::'a))"
unfolding isBit1_def by auto

lemma bit1_type_definition:
"type_definition
   (Rep_bit1::'a bit1 \<Rightarrow> int) Abs_bit1
   (Collect (isBit1 (a::'a::finite)))"
unfolding atLeastLessThan_Collect_bit1[symmetric]
using type_definition_bit1 by blast

(* *)

lemma isBit1_aux: "isBit1 = isBit1" ..
local_setup \<open>RLTHM @{binding isBit1_rlt_neper_param} @{thm isBit1_aux}\<close>
thm isBit1_rlt_neper_param

lemma isBit1_rlt_simp[simp]: "neper (R::'a::finite\<Rightarrow>'a\<Rightarrow>bool) \<Longrightarrow>
 isBit1_rlt R a =
 (\<lambda>i. (0 \<le> i \<and> i < 1 + 2 * int (card {getRepr R a |a. R a a})))"
unfolding isBit1_rlt_def fun_eq_iff
apply simp unfolding rlt_eq by simp

definition hh1 where
"hh1 \<equiv> \<lambda>R::'a::finite\<Rightarrow>'a\<Rightarrow>bool.
    surjf (1 + 2 * int (CARD('a)))
          (1 + 2 * int (card {getRepr R a |a. R a a}))"

definition bit1_rel :: "('a::finite \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a bit1 \<Rightarrow> 'a bit1 \<Rightarrow> bool"
where "bit1_rel R \<equiv>
inv_imagep
  (restr (inv_imagep (restr (=) (isBit1_rlt R undefined)) (hh1 R))
         (isBit1 (undefined::'a)))
  Rep_bit1"

lemma isBit1_rlt_hh1:
"neper (R::'a::finite\<Rightarrow>'a\<Rightarrow>bool) \<Longrightarrow>
 isBit1 (undefined::'a) x \<Longrightarrow> isBit1_rlt R (undefined::'a) (hh1 R x)"
unfolding isBit1_def isBit1_rlt_simp  hh1_def
  unfolding isBit1_def isBit1_rlt_simp hh1_def
  apply(rule surjf_between) apply auto
  by (simp add: card_mono)

lemma bij_upto_hh1:
assumes R: "neper (R::'a::finite\<Rightarrow>'a\<Rightarrow>bool)"
shows "bij_upto (bit1_rel R) (restr (=) (isBit1_rlt R undefined)) (hh1 R \<circ> Rep_bit1::'a bit1 \<Rightarrow> int)"
apply(rule bij_upto_criterion[OF bit1_type_definition, of "(=)" "undefined::'a" "isBit1_rlt R undefined" "hh1 R",simped,
unfolded bit1_rel_def[symmetric]])
  subgoal using isBit1_rlt_hh1[OF R] .
  subgoal for u unfolding isBit1_def isBit1_rlt_simp[OF R] hh1_def
  apply(rule surjf_surj) by (auto simp: card_mono) .

lemma hh1_eq': "0 \<le> i \<Longrightarrow> i < 1 + 2 * int CARD('a::finite) \<Longrightarrow>
    hh1 ((=)::'a\<Rightarrow>'a\<Rightarrow>bool) i = i"
unfolding hh1_def surjf_def by auto

lemma hh1_eq[simp]: "hh1 ((=)::'a::finite\<Rightarrow>'a\<Rightarrow>bool) (Rep_bit1 (a::'a bit1)) = Rep_bit1 a"
apply(rule hh1_eq') using Rep_bit1 by auto

lemma bit1_rel_neper:
"neper (R::'a::finite\<Rightarrow>'a\<Rightarrow>bool) \<Longrightarrow> neper (bit1_rel R::'a bit1 \<Rightarrow> 'a bit1 \<Rightarrow> bool)"
unfolding bit1_rel_def
apply(rule neper_criterion[OF bit1_type_definition, of _ "undefined::'a"])
  subgoal by auto
  subgoal apply(rule exI[of _ 0]) unfolding isBit1_def by auto
  subgoal apply(drule isBit1_rlt_hh1) by auto .

lemma bit1_rel_eq[simp]: "bit1_rel (((=)::'a::finite\<Rightarrow>'a\<Rightarrow>bool)) = (=)"
unfolding bit1_rel_def rlt_eq inv_imagep_def fun_eq_iff restr_def apply simp
using Rep_bit1 Rep_bit1_inject atLeastLessThan_Collect_bit1 by blast

(* *)

wide_typedef bit1 rel: bit1_rel rep: "\<lambda>R. hh1 R \<circ> Rep_bit1"
  subgoal using bit1_rel_neper .
  subgoal using bit1_rel_eq .
  subgoal for R
  unfolding rlt_eq apply simp
  unfolding isBit1_rlt_simp[of R undefined, symmetric]
  using bij_upto_hh1 .
  subgoal unfolding fun_eq_iff comp_def apply safe using hh1_eq . .

end


section \<open>Refinement Lattice \label{S:lattice}\<close>

theory Refinement_Lattice
imports
  Main
begin

unbundle lattice_syntax

text \<open>
  The underlying lattice of commands is complete and distributive.
  We follow the refinement calculus tradition so that $\nondet$
  is non-deterministic choice and $c \refsto d$ means $c$ is refined
  (or implemented) by $d$.
\<close>

declare [[show_sorts]]

text \<open>Remove existing notation for quotient as it interferes with the rely quotient\<close>
no_notation Equiv_Relations.quotient  (infixl "'/'/" 90)

class refinement_lattice = complete_distrib_lattice
begin

text \<open>The refinement lattice infimum corresponds to non-deterministic choice for commands.\<close>

abbreviation
  refine :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
where
  "c \<sqsubseteq> d \<equiv> less_eq c d"

abbreviation
  refine_strict :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>" 50)
where
  "c \<sqsubset> d \<equiv> less c d"

text \<open>Non-deterministic choice is monotonic in both arguments\<close>
lemma inf_mono_left: "a \<sqsubseteq> b \<Longrightarrow> a \<sqinter> c \<sqsubseteq> b \<sqinter> c"
  using inf_mono by auto

lemma inf_mono_right: "c \<sqsubseteq> d \<Longrightarrow> a \<sqinter> c \<sqsubseteq> a \<sqinter> d"
  using inf_mono by auto

text \<open>Binary choice is a special case of choice over a set.\<close>
lemma Inf2_inf: "\<Sqinter>{ f x | x. x \<in> {c, d}} = f c \<sqinter> f d"
proof -
  have "{ f x | x. x \<in> {c, d}} = {f c, f d}" by blast
  then have "\<Sqinter>{ f x | x. x \<in> {c, d}} = \<Sqinter>{f c, f d}" by simp
  also have "... = f c \<sqinter> f d" by simp
  finally show ?thesis .
qed

text \<open>Helper lemma for choice over indexed set.\<close>
lemma INF_Inf: "(\<Sqinter>x\<in>X. f x) = (\<Sqinter>{f x |x. x \<in> X})"
  by (simp add: Setcompr_eq_image)

lemma (in -) INF_absorb_args: "(\<Sqinter>i j. (f::nat \<Rightarrow> 'c::complete_lattice) (i + j)) = (\<Sqinter>k. f k)"
proof (rule order_class.order.antisym)
  show "(\<Sqinter>k. f k) \<le> (\<Sqinter>i j. f (i + j))"
    by (simp add: complete_lattice_class.INF_lower complete_lattice_class.le_INF_iff)
next
  have "\<And>k. \<exists>i j. f (i + j) \<le> f k"
    by (metis Nat.add_0_right order_refl)
  then have "\<And>k. \<exists>i. (\<Sqinter>j. f (i + j)) \<le> f k"
    by (meson UNIV_I complete_lattice_class.INF_lower2)
  then show "(\<Sqinter>i j. f (i + j)) \<le> (\<Sqinter>k. f k)"
    by (simp add: complete_lattice_class.INF_mono)
qed

lemma (in -) nested_Collect: "{f y |y. y \<in> {g x |x. x \<in> X}} = {f (g x) |x. x \<in> X}"
  by blast

text \<open>A transition lemma for INF distributivity properties, going from Inf to INF,
  qualified version followed by a straightforward one.\<close>

lemma Inf_distrib_INF:
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes f_Inf_distrib: "\<And>c D. f c (\<Sqinter> D) = \<Sqinter> {f c d | d . d \<in> D }"
  shows "f c (\<Sqinter>x\<in>X. d x) = (\<Sqinter>x\<in>X. f c (d x))"
  by (simp add: Setcompr_eq_image f_Inf_distrib image_comp)

end

lemmas refine_trans = order.trans

text \<open>More transitivity rules to make calculational reasoning smoother\<close>
declare ord_eq_le_trans[trans]
declare ord_le_eq_trans[trans]
declare dual_order.trans[trans]

abbreviation
  dist_over_sup :: "('a::refinement_lattice \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "dist_over_sup F \<equiv> (\<forall> X . F (\<Squnion> X) = (\<Squnion>x\<in>X. F (x)))"

abbreviation
  dist_over_inf :: "('a::refinement_lattice \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "dist_over_inf F \<equiv> (\<forall> X . F (\<Sqinter> X) = (\<Sqinter>x\<in>X. F (x)))"

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory RS_pair
imports RS
begin

(*****************************************************************

         1. Pairs of RS are also RS.
         2.
         3.
         4.

 *****************************************************************)

(**********************************************************
              def: pair of restriction space
 **********************************************************)

instantiation prod :: (rs, rs) rs0
begin

definition
  pair_restriction_def :
    "(xc::('a::rs * 'b::rs)) .|. n
        == (((fst xc) .|. n) , ((snd xc) .|. n))"

  instance proof qed

end

definition
  pair_Limit :: "(('a::ms_rs * 'b::ms_rs) infinite_seq) => ('a::ms_rs * 'b::ms_rs)"
(*  pair_Limit :: "(('a::ms_rs * 'b::ms_rs) infinite_seq) => ('a::ms_rs * 'b::ms_rs)" *)
  where
  pair_Limit_def :
     "pair_Limit xcs == (Limit (fst o xcs) , Limit (snd o xcs))"

(************************************************************
                         Basics
 ************************************************************)

lemma rest_to_pair_rest:
    "[| (fst xc) .|. n = (fst yc) .|. n ;
        (snd xc) .|. n = (snd yc) .|. n |]
     ==> (xc::('a::rs * 'b::rs)) .|. n = yc .|. n"
by (simp add: pair_restriction_def)

(************************************************************
                   Pair RS ==> RS
 ************************************************************)

(*** pair_zero_eq_rs ***)

lemma pair_zero_eq_rs:
  "(xc::('a::rs * 'b::rs)) .|. 0 = yc .|. 0"
by (simp add: pair_restriction_def)

(*** pair_min_rs ***)

lemma pair_min_rs:
  "((xc::('a::rs * 'b::rs)) .|. m) .|. n = xc .|. (min m n)"
apply (simp add: pair_restriction_def)
by (simp add: min_rs)

(*** contra_pair_diff_rs ***)

lemma contra_pair_diff_rs:
  "(ALL n. (xc::('a::rs * 'b::rs)) .|. n = yc .|. n) ==> (xc = yc)"
apply (simp add: pair_restriction_def)

apply (insert contra_diff_rs[of "fst xc" "fst yc"])
apply (insert contra_diff_rs[of "snd xc" "snd yc"])
apply (simp add: prod_eq_iff)

done
(*** pair_diff_rs ***)

lemma pair_diff_rs:
  "((xc::('a::rs * 'b::rs)) ~= yc) ==> (EX n. xc .|. n ~= yc .|. n)"
apply (erule contrapos_pp)
apply (insert contra_pair_diff_rs[of xc yc])
by (simp)

(*****************************************
              Pair RS => RS
 *****************************************)

instance prod :: (rs,rs) rs
apply (intro_classes)
apply (simp add: pair_zero_eq_rs)
apply (simp add: pair_min_rs)
apply (simp add: pair_diff_rs)
done

(************************************************************
                     Pair RS ==> MS
 ************************************************************)

instantiation prod :: (rs,rs) ms0
begin

(*
fun pair_distance_def :: "(('a::rs * 'b::rs) * ('a::rs * 'b::rs)) => real"
where "distance xy = distance_rs xy"
*)

definition
  pair_distance_def: "distance (xy::('a::rs * 'b::rs) * ('a::rs * 'b::rs)) = distance_rs xy"

  instance proof qed
end

instance prod :: (rs,rs) ms
apply (intro_classes)
apply (simp_all add: pair_distance_def)
apply (simp add: diagonal_rs)
apply (simp add: pair_distance_def symmetry_rs)
apply (simp add: pair_distance_def triangle_inequality_rs)
done

(* isabelle 2009-1
instance * :: (rs,rs) ms
apply (intro_classes)
apply (simp)
apply (simp add: diagonal_rs)
apply (simp add: symmetry_rs)
apply (simp add: triangle_inequality_rs)
done
*)

(************************************************************
             i.e.  Pair RS ==> MS & RS
 ************************************************************)

instance prod :: (rs,rs) ms_rs
apply (intro_classes)
apply (simp add: pair_distance_def)
done

(************************************************************
                     Lemmas (distance)
 ************************************************************)

(* distance_nat *)

lemma pair_distance_nat_le_fst:
      "fst xc ~= fst yc
       ==> distance_nat ((xc::('a::rs * 'b::rs)), yc)
        <= distance_nat (fst xc, fst yc)"
apply (case_tac "xc = yc", simp)
apply (simp add: distance_nat_le_1[THEN sym])

apply (insert distance_nat_is[of xc yc], simp)
apply (simp add: isMAX_def)
apply (simp add: distance_nat_set_def)
by (simp add: pair_restriction_def)

lemma pair_distance_nat_le_snd:
      "snd xc ~= snd yc
       ==> distance_nat ((xc::('a::rs * 'b::rs)), yc)
        <= distance_nat (snd xc, snd yc)"
apply (case_tac "xc = yc", simp)
apply (simp add: distance_nat_le_1[THEN sym])

apply (insert distance_nat_is[of xc yc], simp)
apply (simp add: isMAX_def)
apply (simp add: distance_nat_set_def)
by (simp add: pair_restriction_def)

lemmas pair_distance_nat_le = pair_distance_nat_le_fst
                              pair_distance_nat_le_snd

(* distance *)

lemma pair_distance_def_le_fst:
   "distance (fst xc, fst yc) <= distance ((xc::('a::ms0_rs * 'b::ms0_rs)), yc)"
apply (case_tac "fst xc = fst yc", simp)
apply (case_tac "xc = yc", simp)
apply (simp_all add: to_distance_rs)
apply (case_tac "xc = yc", simp)
apply (simp add: distance_iff)
apply (rule power_decreasing, simp_all)
by (simp add: pair_distance_nat_le_fst)

lemma pair_distance_def_le_fst_compo:
   "distance (a1, a2) <= distance ((a1::'a::ms0_rs, b1::'b::ms0_rs), (a2, b2))"
apply (insert pair_distance_def_le_fst[of "(a1,b1)" "(a2,b2)"])
by (simp)

lemma pair_distance_def_le_snd:
   "distance (snd xc, snd yc) <= distance ((xc::('a::ms0_rs * 'b::ms0_rs)), yc)"
apply (case_tac "snd xc = snd yc", simp)
apply (case_tac "xc = yc", simp)
apply (simp_all add: to_distance_rs)
apply (case_tac "xc = yc", simp)
apply (simp add: distance_iff)
apply (rule power_decreasing, simp_all)
by (simp add: pair_distance_nat_le_snd)

lemma pair_distance_def_le_snd_compo:
   "distance (b1, b2) <= distance ((a1::'a::ms0_rs, b1::'b::ms0_rs), (a2, b2))"
apply (insert pair_distance_def_le_snd[of "(a1,b1)" "(a2,b2)"])
by (simp)

lemmas pair_distance_def_le =
       pair_distance_def_le_fst pair_distance_def_le_snd

lemmas pair_distance_def_le_compo =
       pair_distance_def_le_fst_compo pair_distance_def_le_snd_compo

(*** pair_distance (max) ***)

lemma pair_distance_max:
  "distance ((xc::('a::ms_rs * 'b::ms_rs)), yc)
  = max (distance (fst xc, fst yc)) (distance (snd xc, snd yc))"
apply (case_tac "distance (fst xc, fst yc) <= distance (snd xc, snd yc)")
apply (simp add: max_is)
apply (rule order_antisym)
apply (simp_all add: pair_distance_def_le)

apply (case_tac "xc = yc", simp)
apply (case_tac "snd xc = snd yc", simp)
apply (case_tac "fst xc = fst yc", simp)
apply (simp add: pair_neq_decompo)
apply (erule contrapos_pp)
apply (simp add: linorder_not_le diff_pnt_pos_if)

 (* xc ~= yc; snd xc ~= snd yc *)
apply (simp add: to_distance_rs)
 apply (simp add: distance_iff)
 apply (rule power_decreasing, simp_all)
 apply (simp add: distance_nat_le_1[THEN sym])
 apply (simp add: pair_restriction_def)
 apply (simp add: distance_nat_rest)

 apply (case_tac "fst xc = fst yc", simp)
 apply (simp add: distance_iff)
 apply (rule rest_equal_preserve)
 apply (rule distance_nat_rest)
 apply (simp_all)
 apply (rule rev_power_decreasing, simp_all)

      (* ~ distance (fst xc, fst yc) <= distance (snd xc, snd yc) *)

apply (simp add: max_is)
apply (rule order_antisym)
apply (simp_all add: pair_distance_def_le)

apply (case_tac "xc = yc", simp)
apply (case_tac "fst xc = fst yc", simp)

 (* xc ~= yc; fst xc ~= fst yc *)
 apply (simp add: to_distance_rs)
 apply (simp add: distance_iff)
 apply (rule power_decreasing, simp_all)
 apply (simp add: distance_nat_le_1[THEN sym])
 apply (simp add: pair_restriction_def)
 apply (simp add: distance_nat_rest)

 apply (case_tac "snd xc = snd yc", simp)
 apply (simp add: distance_iff)
 apply (rule rest_equal_preserve)
 apply (rule distance_nat_rest)
 apply (simp_all)

apply (simp add: linorder_not_le)
apply (insert rev_power_decreasing[of "1/2"])
by (simp)

lemma pair_distance_max_compo:
  "distance ((a1::('a::ms_rs), b1::('b::ms_rs)), (a2, b2))
  = max (distance (a1, a2)) (distance (b1, b2))"
apply (insert pair_distance_max[of "(a1, b1)" "(a2, b2)"])
by (simp)

lemma ALL_pair_distance_max:
  "ALL xc yc. distance ((xc::('a::ms_rs * 'b::ms_rs)), yc)
       = max (distance (fst xc, fst yc)) (distance (snd xc, snd yc))"
by (simp add: pair_distance_max)

(*****************************************
               pair maps
 *****************************************)

(*** fst ***)

lemma fst_non_expand: "non_expanding (fst::('a::ms_rs * 'b::ms_rs)=>'a)"
apply (simp add: non_expanding_def)
apply (simp add: map_alpha_def)
apply (simp add: pair_distance_def_le_compo)
done

(*** snd ***)

lemma snd_non_expand: "non_expanding (snd::('a::ms_rs * 'b::ms_rs)=>'b)"
apply (simp add: non_expanding_def)
apply (simp add: map_alpha_def)
apply (simp add: pair_distance_def_le_compo)
done

(*---------------------*
 |      map_alpha      |
 *---------------------*)

(* only_if *)

lemma pair_map_alpha_only_if:
  "map_alpha (fc::('a::ms_rs => ('b::ms_rs * 'c::ms_rs))) alpha
   ==> (map_alpha (fst o fc) alpha &
        map_alpha (snd o fc) alpha)"
by (simp add: compo_non_expand_map_alpha fst_non_expand snd_non_expand)

(* if *)

lemma pair_map_alpha_if:
  "[| map_alpha (fst o fc) alpha ; map_alpha (snd o fc) alpha |]
   ==> map_alpha (fc::('a::ms_rs => ('b::ms_rs * 'c::ms_rs))) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (insert ALL_pair_distance_max)
apply (rotate_tac -1, drule_tac x="fc x" in spec)
apply (rotate_tac -1, drule_tac x="fc y" in spec)
by (simp)

(* iff *)

lemma pair_map_alpha:
  "map_alpha (fc::('a::ms_rs => ('b::ms_rs * 'c::ms_rs))) alpha
   = (map_alpha (fst o fc) alpha & map_alpha (snd o fc) alpha)"
apply (rule iffI)
apply (simp add: pair_map_alpha_only_if)
apply (simp add: pair_map_alpha_if)
done

lemma pair_map_alpha_compo:
  "map_alpha (f ** g) alpha
   = (map_alpha (f::('a::ms_rs => 'b::ms_rs)) alpha &
      map_alpha (g::('a::ms_rs => 'c::ms_rs)) alpha)"
apply (insert pair_map_alpha[of "f ** g"])
by (simp)

(*---------------------*
 |    non_expanding    |
 *---------------------*)

lemma pair_non_expand:
  "non_expanding (fc::('a::ms_rs => ('b::ms_rs * 'c::ms_rs)))
   = (non_expanding (fst o fc) & non_expanding (snd o fc))"
apply (simp add: non_expanding_def)
by (simp add: pair_map_alpha)

lemma pair_non_expand_compo:
  "non_expanding (f ** g)
   = (non_expanding (f::('a::ms_rs => 'b::ms_rs)) &
      non_expanding (g::('a::ms_rs => 'c::ms_rs)))"
apply (simp add: non_expanding_def)
by (simp add: pair_map_alpha_compo)

(*---------------------*
 |  alpha_contraction  |
 *---------------------*)

lemma pair_contra_alpha:
  "contraction_alpha (fc::('a::ms_rs => ('b::ms_rs * 'c::ms_rs))) alpha
   = (contraction_alpha (fst o fc) alpha & contraction_alpha (snd o fc) alpha)"
apply (simp add: contraction_alpha_def)
by (auto simp add: pair_map_alpha)

lemma pair_contra_alpha_compo:
  "contraction_alpha (f ** g) alpha
   = (contraction_alpha (f::('a::ms_rs => 'b::ms_rs)) alpha &
      contraction_alpha (g::('a::ms_rs => 'c::ms_rs)) alpha)"
apply (simp add: contraction_alpha_def)
by (auto simp add: pair_map_alpha_compo)

(************************************************************
                       Lemmas (Limit)
 ************************************************************)

(*****************************************
                  cauchy
 *****************************************)

lemma pair_cauchy_seq_fst:
  "cauchy (xcs::('a::ms_rs * 'b::ms_rs) infinite_seq)
   ==> cauchy (fst o xcs)"
apply (simp add: cauchy_def)
apply (intro allI impI)

apply (drule_tac x="delta" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rename_tac delta N n m)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
apply (simp add: pair_distance_max)
done

lemma pair_cauchy_seq_snd:
  "cauchy (xcs::('a::ms_rs * 'b::ms_rs) infinite_seq)
   ==> cauchy (snd o xcs)"
apply (simp add: cauchy_def)
apply (intro allI impI)

apply (drule_tac x="delta" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rename_tac delta N n m)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
apply (simp add: pair_distance_max)
done

lemmas pair_cauchy_seq = pair_cauchy_seq_fst pair_cauchy_seq_snd

lemma pair_cauchy_seq_fst_compo:
  "cauchy ((xc::'a::ms_rs infinite_seq) ** (yc::'a::ms_rs infinite_seq))
   ==> cauchy xc"
apply (insert pair_cauchy_seq_fst[of "xc ** yc"])
by (simp)

lemma pair_cauchy_seq_snd_compo:
  "cauchy ((xc::'a::ms_rs infinite_seq) ** (yc::'a::ms_rs infinite_seq))
   ==> cauchy yc"
apply (insert pair_cauchy_seq_snd[of "xc ** yc"])
by (simp)

lemmas pair_cauchy_seq_compo = pair_cauchy_seq_fst_compo pair_cauchy_seq_snd_compo

(*** normal ***)

lemma pair_normal_seq_fst:
  "normal (xcs::('a::ms_rs * 'b::ms_rs) infinite_seq)
   ==> normal (fst o xcs)"
apply (simp add: normal_def)
apply (intro allI)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
by (simp add: pair_distance_max)

lemma pair_normal_seq_snd:
  "normal (xcs::('a::ms_rs * 'b::ms_rs) infinite_seq)
   ==> normal (snd o xcs)"
apply (simp add: normal_def)
apply (intro allI)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
by (simp add: pair_distance_max)

lemmas pair_normal_seq = pair_normal_seq_fst pair_normal_seq_snd

lemma pair_normal_seq_fst_compo:
  "normal ((xc::'a::ms_rs infinite_seq) ** (yc::'a::ms_rs infinite_seq))
   ==> normal xc"
apply (insert pair_normal_seq_fst[of "xc ** yc"])
by (simp)

lemma pair_normal_seq_snd_compo:
  "normal ((xc::'a::ms_rs infinite_seq) ** (yc::'a::ms_rs infinite_seq))
   ==> normal yc"
apply (insert pair_normal_seq_snd[of "xc ** yc"])
by (simp)

lemmas pair_normal_seq_compo = pair_normal_seq_fst_compo pair_normal_seq_snd_compo

lemma pair_normal_seq_compo_only_if:
  "[| normal xc ; normal yc |] ==>
   normal ((xc::'a::ms_rs infinite_seq) ** (yc::'b::ms_rs infinite_seq))"
apply (simp add: normal_def)
apply (intro allI)
apply (drule_tac x="n" in spec)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
apply (drule_tac x="m" in spec)
apply (simp add: pair_distance_max)
apply (simp add: pair_fun_def)
done

(* iff *)

lemma pair_normal_seq_compo_iff:
  "normal (xcs::('a::ms_rs * 'b::ms_rs) infinite_seq)
   = (normal (fst o xcs) & normal (snd o xcs))"
apply (rule)
apply (simp add: pair_normal_seq)
apply (insert pair_normal_seq_compo_only_if[of "(fst o xcs)" "(snd o xcs)"])
apply (simp add: pair_fun_def)
done

(*-----------------------*
 |     pairof Limits     |
 *-----------------------*)

(*** Limit (single <-- pair) ***)

lemma pair_convergeTo_fst_only_if:
  "(xcs::(('a::ms_rs * 'b::ms_rs) infinite_seq)) convergeTo yc
   ==> (fst o xcs) convergeTo (fst yc)"
apply (simp add: convergeTo_def)
apply (intro allI impI)

apply (drule_tac x="eps" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rename_tac eps N n)
apply (drule_tac x="n" in spec)
apply (simp add: pair_distance_max)
done

lemma pair_convergeTo_snd_only_if:
  "(xcs::(('a::ms_rs * 'b::ms_rs) infinite_seq)) convergeTo yc
   ==> (snd o xcs) convergeTo (snd yc)"
apply (simp add: convergeTo_def)
apply (intro allI impI)

apply (drule_tac x="eps" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rename_tac eps N n)
apply (drule_tac x="n" in spec)
apply (simp add: pair_distance_max)
done

(*** Limit (single --> pair) (note: ms_rs) ***)

lemma pair_convergeTo_if:
  "[| (fst o xcs) convergeTo (fst yc) ; (snd o xcs) convergeTo (snd yc) |]
   ==> (xcs::(('a::ms_rs * 'b::ms_rs) infinite_seq)) convergeTo yc"
apply (simp add: convergeTo_def)
apply (intro allI impI)

apply (drule_tac x="eps" in spec)
apply (drule_tac x="eps" in spec)
apply (simp)
apply (erule exE)+
apply (rename_tac eps N2 N1)

apply (rule_tac x="max N1 N2" in exI)
apply (simp add: pair_distance_max)
done

(*** iff ***)

lemma pair_convergeTo:
  "(xcs::(('a::ms_rs * 'b::ms_rs) infinite_seq)) convergeTo yc
   = ((fst o xcs) convergeTo (fst yc) & (snd o xcs) convergeTo (snd yc))"
apply (rule iffI)
apply (simp add: pair_convergeTo_fst_only_if pair_convergeTo_snd_only_if)
apply (simp add: pair_convergeTo_if)
done

lemma pair_convergeTo_compo:
  "((xs::('a::ms_rs infinite_seq)) ** (ys::('b::ms_rs infinite_seq)))
   convergeTo (x, y)
   = (xs convergeTo x & ys convergeTo y)"
apply (insert pair_convergeTo[of "xs ** ys" "(x,y)"])
by (simp)

(*****************************************
     Limit (cms and cauchy --> Limit)
 *****************************************)

lemma pair_cms_cauchy_Limit:
  "cauchy (xcs::(('a::cms_rs * 'b::cms_rs) infinite_seq))
   ==> xcs convergeTo (pair_Limit xcs)"
apply (simp add: pair_convergeTo)
by (simp add: pair_Limit_def pair_cauchy_seq Limit_is)

(*****************************************
     Pair Complete Metric Space (RS)
 *****************************************)

lemma pair_cms_rs:
  "cauchy (xcs::(('a::cms_rs * 'b::cms_rs) infinite_seq))
   ==> EX yc. xcs convergeTo yc"
apply (rule_tac x="pair_Limit xcs" in exI)
by (simp add: pair_cms_cauchy_Limit)

(************************************************************
                   Pair RS ==> CMS and RS
 ************************************************************)

instance prod :: (cms_rs,cms_rs) cms_rs
apply (intro_classes)
apply (intro allI impI)
by (rule pair_cms_rs, simp)

(*----------------------------------------------------------*
 |                                                          |
 |                Continuity on Metric space                |
 |                                                          |
 *----------------------------------------------------------*)

declare disj_not1 [simp del]

lemma pair_continuous_rs:
   "[| continuous_rs R1 ; continuous_rs R2 |]
     ==> continuous_rs (%xc. (R1 (fst xc) & R2 (snd xc)))"
apply (simp add: continuous_rs_def)
apply (intro allI)
apply (rule conjI)

apply (intro impI)
apply (drule_tac x="a" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rotate_tac -1)
apply (drule_tac x="b" in spec)
apply (simp add: pair_restriction_def)

apply (intro impI)
apply (rotate_tac -1)
apply (drule_tac x="b" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rotate_tac -2)
apply (drule_tac x="ba" in spec)
apply (simp add: pair_restriction_def)
done

(*----------------------------------------------------------*
 |                                                          |
 |      !!!     order and restriction space     !!!         |
 |                                                          |
 *----------------------------------------------------------*)

instance prod :: (ms_rs_order,ms_rs_order) ms_rs_order0
by (intro_classes)

instance prod :: (ms_rs_order,ms_rs_order) ms_rs_order
apply (intro_classes)
apply (simp add: order_pair_def pair_restriction_def)
apply (intro allI)
apply (rule iffI)
apply (rule conjI)
apply (insert rs_order_iff)
apply (drule_tac x="a" in spec)
apply (drule_tac x="aa" in spec)
apply (fast)
apply (drule_tac x="b" in spec)
apply (drule_tac x="ba" in spec)
apply (fast)

apply (intro allI)
apply (rule conjI)
apply (drule_tac x="a" in spec)
apply (drule_tac x="aa" in spec)
apply (fast)
apply (insert rs_order_iff)
apply (drule_tac x="b" in spec)
apply (drule_tac x="ba" in spec)
apply (fast)
done

(*** cms rs order ***)

instance prod :: (cms_rs_order,cms_rs_order) cms_rs_order
by (intro_classes)

(****************** to add it again ******************)

declare disj_not1 [simp]

end


theory rotate_snoc_self
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun snoc :: "'a => 'a list => 'a list" where
"snoc x (Nil2) = Cons2 x (Nil2)"
| "snoc x (Cons2 z ys) = Cons2 z (snoc x ys)"

fun rotate :: "Nat => 'a list => 'a list" where
"rotate (Z) y = y"
| "rotate (S z) (Nil2) = Nil2"
| "rotate (S z) (Cons2 x2 x3) = rotate z (snoc x2 x3)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

(*hipster snoc rotate append *)

theorem x0 :
  "!! (n :: Nat) (xs :: 'a list) .
     (rotate n (append xs xs)) = (append (rotate n xs) (rotate n xs))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory "C-Meet"
imports C "HOLCF-Meet"
begin

instantiation C :: Finite_Meet_cpo begin
  fixrec C_meet :: "C \<rightarrow> C \<rightarrow> C"
    where "C_meet\<cdot>(C\<cdot>a)\<cdot>(C\<cdot>b) = C\<cdot>(C_meet\<cdot>a\<cdot>b)"

  instance
  apply standard
  proof(intro exI conjI strip)
    fix x y
    {
      fix t
      have "(t \<sqsubseteq> C_meet\<cdot>x\<cdot>y) = (t \<sqsubseteq> x \<and> t \<sqsubseteq> y)"
      proof (induct t rule:C.take_induct)
        fix n
        show "(C_take n\<cdot>t \<sqsubseteq> C_meet\<cdot>x\<cdot>y) = (C_take n\<cdot>t \<sqsubseteq> x \<and> C_take n\<cdot>t \<sqsubseteq> y)"
        proof (induct n arbitrary: t x y rule:nat_induct)
          case 0 thus ?case by auto
          next
          case (Suc n t x y)
            with C.nchotomy[of t] C.nchotomy[of x] C.nchotomy[of y]
            show ?case by fastforce
        qed
     qed auto
    } note * = this
    show "C_meet\<cdot>x\<cdot>y \<sqsubseteq> x" using * by auto
    show "C_meet\<cdot>x\<cdot>y \<sqsubseteq> y" using * by auto
    fix z
    assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
    thus "z \<sqsubseteq> C_meet\<cdot>x\<cdot>y" using * by auto
qed
end

lemma C_meet_is_meet: "(z \<sqsubseteq> C_meet\<cdot>x\<cdot>y) = (z \<sqsubseteq> x \<and> z \<sqsubseteq> y)"
proof (induct z rule:C.take_induct)
  fix n
  show "(C_take n\<cdot>z \<sqsubseteq> C_meet\<cdot>x\<cdot>y) = (C_take n\<cdot>z \<sqsubseteq> x \<and> C_take n\<cdot>z \<sqsubseteq> y)"
  proof (induct n arbitrary: z x y rule:nat_induct)
    case 0 thus ?case by auto
    next
    case (Suc n z x y) thus ?case
      apply -
      apply (cases z, simp)
      apply (cases x, simp)
      apply (cases y, simp)
      apply (fastforce simp add: cfun_below_iff)
      done
  qed
qed auto

instance C :: cont_binary_meet
proof (standard, goal_cases)
  have [simp]:"\<And> x y. x \<sqinter> y = C_meet\<cdot>x\<cdot>y"
    using C_meet_is_meet
    by (blast intro: is_meetI)
  case 1 thus ?case
    by (simp add: ch2ch_Rep_cfunR contlub_cfun_arg contlub_cfun_fun)
qed

lemma [simp]: "r \<sqinter> C\<cdot>r = r"
  by (auto intro: is_meetI simp add: below_C)

lemma [simp]: "C\<cdot>r \<sqinter> C\<cdot>r' = C\<cdot>(r \<sqinter> r')"
  apply (rule is_meetI)
  apply (metis below_refl meet_below1 monofun_cfun_arg)
  apply (metis below_refl meet_below2 monofun_cfun_arg)
  apply (case_tac a)
  apply auto
  by (metis meet_above_iff)

end


theory mpredSet
  imports OrdRec_Model_Base
begin

context OrdRec_Model begin

lemma mpredset_eq :
  assumes j : "j : mOrd"
  shows "mpredSet j = <set, ord \<oplus> predSet (snd j)>"
  unfolding mpredSet_def mpredSet'_def
  using assms by auto

lemmas tmap_ord_set = tmap_set[OF tag_pmem[OF ord_tag]]

lemma mpredset_msetof :
  assumes j : "j : mOrd"
  shows "mpredSet j : mSetOf mOrd"
  unfolding mpredset_eq[OF j]
proof (rule msetofI, rule msetI)
  obtain j' where
    j' : "j' : Ord" and j_eq: "j = <ord,j'>"
    using mordE[OF j] .
  have "ord \<oplus> predSet (snd j) \<subseteq> Tier j' \<ominus> set"
    unfolding j_eq ord_snd_eq'[OF j']
  proof
    fix i assume "i \<in> ord \<oplus> predSet j'"
    then obtain i' where
      i': "i' : Ord" "i' < j'" and "i = <ord, i'>"
     using tmapE[OF tag_pmem[OF ord_tag] predset_set[OF j']]
           predsetD[OF j'] by metis
    thus "i \<in> Tier j' \<ominus> set"
      using ord_tierI[OF i'(1) j' leqI1[OF i'(1) j']]
        exsetI[OF tier_set[OF j']] not_excluded_set_mord
      by auto
  qed
  thus "<set, ord \<oplus> predSet (snd j)> : M"
    using mI_mset[OF j' tmap_set[OF
            tag_pmem[OF ord_tag] predset_set[OF j']]]
    unfolding ord_snd_eq[OF j' j_eq] by auto
  fix b assume
    "b m <set, ord \<oplus> predSet (snd j)>"
  hence "b \<in> ord \<oplus> predSet (snd j)"
    using mmemD by auto
 then obtain i' where
    i': "i' : Ord" "i' < j'" and "b = <ord, i'>"
   using tmapE[OF tag_pmem[OF ord_tag] predset_set[OF j']]
         predsetD[OF j']
   unfolding ord_snd_eq[OF j' j_eq] by metis
  thus "b : mOrd" using mordI by auto
qed

lemma mpredset_iff :
  assumes i : "i : mOrd" and j : "j : mOrd"
   shows "i \<lless> j \<longleftrightarrow> i m mpredSet j"
proof -
  obtain i' j' where
  i': "i' : Ord" "i = <ord, i'>" and
  j': "j' : Ord" "j = <ord, j'>"
  using mordE[OF i] mordE[OF j] by metis
  show ?thesis
    unfolding mpredset_eq[OF j]
proof (rule, rule mmemI)
  assume ij: "i \<lless> j"
  show "\<langle>set,ord \<oplus> predSet (\<pi> j)\<rangle> : mSet"
    using msetof_mset[OF mpredset_msetof[OF j]]
    unfolding mpredset_eq[OF j] .
  show "i \<in> ord \<oplus> predSet (\<pi> j)"
    using tmapI[OF tag_pmem[OF ord_tag]
                   predset_set[OF mord_snd_ord[OF j]]
            predsetI[OF i'(1) mord_snd_ord[OF j]]] mltD ij
   unfolding ord_snd_eq[OF j']
   unfolding i' j' by auto
next
  assume "i m <set, ord \<oplus> predSet (snd j)>"
  hence "i \<in> ord \<oplus> predSet (snd j)"
    using mmemD by auto
  hence "i' \<in> predSet j'"
    unfolding ord_snd_eq[OF j'] i'
      tmap_iff[OF tag_pmem[OF ord_tag]
        predset_set[OF j'(1)] ord_setmem[OF i'(1)]].
  hence "i' < j'"
    using predsetD[OF j'(1) ] by auto
  thus "i \<lless> j"
    unfolding i' j'
    using mltI[OF i'(1) j'(1)] by auto
  qed
qed

theorem mpredset_ax :
  "m\<forall>j : mOrd. m\<forall>i : mOrd. i \<lless> j \<longleftrightarrow> i m mpredSet j"
  unfolding mtall_def mall_def
  using mpredset_iff by auto

theorem mpredset_rsp :
  "mpredSet j : M"
  using mset_m[OF msetof_mset[OF mpredset_msetof]]
        OrdRec_Model_mdefault_m
  unfolding mpredSet_def by auto

end
end


section \<open>The algorithm\<close>

theory Generic_Join
  imports MFOTL_Monitor.Table
begin

type_synonym 'a atable = "nat set \<times> 'a table"
type_synonym 'a query = "'a atable set"
type_synonym vertices = "nat set"

subsection \<open>Generic algorithm\<close>

locale getIJ =
  fixes getIJ :: "'a query \<Rightarrow> 'a query \<Rightarrow> vertices \<Rightarrow> vertices \<times> vertices"
  assumes coreProperties: "card V \<ge> 2 \<Longrightarrow> getIJ Q_pos Q_neg V = (I, J) \<Longrightarrow>
    card I \<ge> 1 \<and> card J \<ge> 1 \<and> V = I \<union> J \<and> I \<inter> J = {}"
begin

lemma getIJProperties:
  assumes "card V \<ge> 2"
  assumes "(I, J) = getIJ Q_pos Q_neg V"
  shows "card I \<ge> 1" and "card J \<ge> 1" and "card I < card V" and "card J < card V"
    and "V = I \<union> J" and "I \<inter> J = {}"
proof -
  show "1 \<le> card I" using coreProperties[of V Q_pos Q_neg I J] assms by auto
  show "1 \<le> card J" using coreProperties[of V Q_pos Q_neg I J] assms by auto
  show "card I < card V" by (metis (no_types, lifting) Int_ac(3) One_nat_def Suc_le_lessD assms(1)
        assms(2) card_gt_0_iff card_seteq dual_order.trans getIJ.coreProperties getIJ_axioms leI
        le_iff_inf one_le_numeral sup_ge1 sup_ge2)
  show "card J < card V" by (metis One_nat_def Suc_1 assms(1) assms(2) card_gt_0_iff card_seteq
        getIJ.coreProperties getIJ_axioms leI le_0_eq le_iff_inf nat.simps(3) sup_ge1 sup_ge2)
  show "V = I \<union> J" by (metis assms(1) assms(2) getIJ.coreProperties getIJ_axioms)
  show "I \<inter> J = {}" by (metis assms(1) assms(2) getIJ_axioms getIJ_def)
qed

fun projectTable :: "vertices \<Rightarrow> 'a atable \<Rightarrow> 'a atable" where
  "projectTable V (s, t) = (s \<inter> V, Set.image (restrict V) t)"

fun filterQuery :: "vertices \<Rightarrow> 'a query \<Rightarrow> 'a query" where
  "filterQuery V Q = Set.filter (\<lambda>(s, _). \<not> Set.is_empty (s \<inter> V)) Q"

fun filterQueryNeg :: "vertices \<Rightarrow> 'a query \<Rightarrow> 'a query" where
  "filterQueryNeg V Q = Set.filter (\<lambda>(A, _). A \<subseteq> V) Q"

fun projectQuery :: "vertices \<Rightarrow> 'a query \<Rightarrow> 'a query" where
  "projectQuery V s = Set.image (projectTable V) s"

fun isSameIntersection :: "'a tuple \<Rightarrow> nat set \<Rightarrow> 'a tuple \<Rightarrow> bool" where
  "isSameIntersection t1 s t2 = (\<forall>i\<in>s. t1!i = t2!i)"

fun semiJoin :: "'a atable \<Rightarrow> (nat set \<times> 'a tuple) \<Rightarrow> 'a atable" where
  "semiJoin (s, tab) (st, tup) = (s, Set.filter (isSameIntersection tup (s \<inter> st)) tab)"

fun newQuery :: "vertices \<Rightarrow> 'a query \<Rightarrow> (nat set \<times> 'a tuple) \<Rightarrow> 'a query" where
  "newQuery V Q (st, t) = Set.image (\<lambda>tab. projectTable V (semiJoin tab (st, t))) Q"

fun merge_option :: "'a option \<times> 'a option \<Rightarrow> 'a option" where
  "merge_option (None, None) = None"
| "merge_option (Some x, None) = Some x"
| "merge_option (None, Some x) = Some x"
| "merge_option (Some a, Some b) = Some a"
(* Last case shouldn't happen but useful for proof *)

fun merge :: "'a tuple \<Rightarrow> 'a tuple \<Rightarrow> 'a tuple" where
  "merge t1 t2 = map merge_option (zip t1 t2)"

function (sequential) genericJoin :: "vertices \<Rightarrow> 'a query \<Rightarrow> 'a query \<Rightarrow> 'a table" where
  "genericJoin V Q_pos Q_neg =
    (if card V \<le> 1 then
      (\<Inter>(_, x) \<in> Q_pos. x) - (\<Union>(_, x) \<in> Q_neg. x)
    else
      let (I, J) = getIJ Q_pos Q_neg V in
      let Q_I_pos = projectQuery I (filterQuery I Q_pos) in
      let Q_I_neg = filterQueryNeg I Q_neg in
      let R_I = genericJoin I Q_I_pos Q_I_neg in
      let Q_J_neg = Q_neg - Q_I_neg in
      let Q_J_pos = filterQuery J Q_pos in
      let X = {(t, genericJoin J (newQuery J Q_J_pos (I, t)) (newQuery J Q_J_neg (I, t))) | t . t \<in> R_I} in
      (\<Union>(t, x) \<in> X. {merge xx t | xx . xx \<in> x}))"
by pat_completeness auto
termination
  by (relation "measure (\<lambda>(V, Q_pos, Q_neg). card V)") (auto simp add: getIJProperties)

fun wrapperGenericJoin :: "'a query \<Rightarrow> 'a query \<Rightarrow> 'a table" where
  "wrapperGenericJoin Q_pos Q_neg =
    (if ((\<exists>(A, X)\<in>Q_pos. Set.is_empty X) \<or> (\<exists>(A, X)\<in>Q_neg. Set.is_empty A \<and> \<not> Set.is_empty X)) then
      {}
    else
      let Q = Set.filter (\<lambda>(A, _). \<not> Set.is_empty A) Q_pos in
      if Set.is_empty Q then
        (\<Inter>(A, X)\<in>Q_pos. X) -  (\<Union>(A, X)\<in>Q_neg. X)
      else
        let V = (\<Union>(A, X)\<in>Q. A) in
        let Qn = Set.filter (\<lambda>(A, _). A \<subseteq> V \<and> card A \<ge> 1) Q_neg in
        genericJoin V Q Qn)"

end

subsection \<open>An instantation\<close>

fun score :: "'a query \<Rightarrow> nat \<Rightarrow> nat" where
  "score Q i = (let relevant = Set.image (\<lambda>(_, x). card x) (Set.filter (\<lambda>(sign, _). i \<in> sign) Q) in
    let l = sorted_list_of_set relevant in
    foldl (+) 0 l
)"

fun arg_max_list :: "('a \<Rightarrow> nat) \<Rightarrow> 'a list \<Rightarrow> 'a" where
  "arg_max_list f l = (let m = Max (set (map f l)) in arg_min_list (\<lambda>x. m - f x) l)"

lemma arg_max_list_element:
  assumes "length l \<ge> 1" shows "arg_max_list f l \<in> set l"
  by (metis One_nat_def arg_max_list.simps arg_min_list_in assms le_imp_less_Suc less_irrefl list.size(3))

fun max_getIJ :: "'a query \<Rightarrow> 'a query \<Rightarrow> vertices \<Rightarrow> vertices \<times> vertices" where
  "max_getIJ Q_pos Q_neg V = (
  let l = sorted_list_of_set V in
  if Set.is_empty Q_neg then
    let x = arg_max_list (score Q_pos) l in
    ({x}, V - {x})
  else
    let x = arg_max_list (score Q_neg) l in
    (V - {x}, {x}))"

lemma max_getIJ_coreProperties:
  assumes "card V \<ge> 2"
  assumes "(I, J) = max_getIJ Q_pos Q_neg V"
  shows "card I \<ge> 1 \<and> card J \<ge> 1 \<and> V = I \<union> J \<and> I \<inter> J = {}"
proof -
  have "finite V" using assms(1) card_infinite by force
  define l where "l = sorted_list_of_set V"
  then have "length l \<ge> 1" by (metis Suc_1 Suc_le_lessD \<open>finite V\<close> assms(1) distinct_card
        distinct_sorted_list_of_set less_imp_le set_sorted_list_of_set)
  show ?thesis
  proof (cases "Set.is_empty Q_neg")
    case True
    define x where "x = arg_max_list (score Q_pos) l"
    then have "x \<in> (set l)" using \<open>1 \<le> length l\<close> arg_max_list_element by blast
    then have "x \<in> V" by (simp add: \<open>finite V\<close> l_def)
    moreover have "(I, J) = ({x}, V - {x})"
    proof -
      have "(I, J) =  (let l = sorted_list_of_set V in
    let x = arg_max_list (score Q_pos) l in
    ({x}, V - {x}))" by (simp add: True assms(2))
      then show ?thesis by (metis l_def x_def)
    qed
    then show ?thesis using Pair_inject \<open>finite V\<close> assms(1) calculation by auto
  next
    case False
    define x where "x = arg_max_list (score Q_neg) l"
    then have "x \<in> (set l)" using \<open>1 \<le> length l\<close> arg_max_list_element by blast
    then have "x \<in> V" by (simp add: \<open>finite V\<close> l_def)
    moreover have "(I, J) = (V - {x}, {x})"
    proof -
      have "(I, J) = (let l = sorted_list_of_set V in
  let x = arg_max_list (score Q_neg) l in (V - {x}, {x}))" by (simp add: False assms(2))
      then show ?thesis by (metis l_def x_def)
    qed
    then show ?thesis using Pair_inject \<open>finite V\<close> assms(1) calculation by auto
  qed
qed

global_interpretation New_max: getIJ max_getIJ
  defines New_max_getIJ_genericJoin = "New_max.genericJoin"
  and New_max_getIJ_wrapperGenericJoin = "New_max.wrapperGenericJoin"
  by standard (metis max_getIJ_coreProperties)

end


(*  Title:      HOL/Analysis/Product_Vector.thy
    Author:     Brian Huffman
*)

section \<open>Cartesian Products as Vector Spaces\<close>

theory Product_Vector
imports
  Inner_Product
  "~~/src/HOL/Library/Product_Plus"
begin

subsection \<open>Product is a real vector space\<close>

instantiation prod :: (real_vector, real_vector) real_vector
begin

definition scaleR_prod_def:
  "scaleR r A = (scaleR r (fst A), scaleR r (snd A))"

lemma fst_scaleR [simp]: "fst (scaleR r A) = scaleR r (fst A)"
  unfolding scaleR_prod_def by simp

lemma snd_scaleR [simp]: "snd (scaleR r A) = scaleR r (snd A)"
  unfolding scaleR_prod_def by simp

lemma scaleR_Pair [simp]: "scaleR r (a, b) = (scaleR r a, scaleR r b)"
  unfolding scaleR_prod_def by simp

instance
proof
  fix a b :: real and x y :: "'a \<times> 'b"
  show "scaleR a (x + y) = scaleR a x + scaleR a y"
    by (simp add: prod_eq_iff scaleR_right_distrib)
  show "scaleR (a + b) x = scaleR a x + scaleR b x"
    by (simp add: prod_eq_iff scaleR_left_distrib)
  show "scaleR a (scaleR b x) = scaleR (a * b) x"
    by (simp add: prod_eq_iff)
  show "scaleR 1 x = x"
    by (simp add: prod_eq_iff)
qed

end

subsection \<open>Product is a metric space\<close>

(* TODO: Product of uniform spaces and compatibility with metric_spaces! *)

instantiation prod :: (metric_space, metric_space) dist
begin

definition dist_prod_def[code del]:
  "dist x y = sqrt ((dist (fst x) (fst y))\<^sup>2 + (dist (snd x) (snd y))\<^sup>2)"

instance ..
end

instantiation prod :: (metric_space, metric_space) uniformity_dist
begin

definition [code del]:
  "(uniformity :: (('a \<times> 'b) \<times> ('a \<times> 'b)) filter) =
    (INF e:{0 <..}. principal {(x, y). dist x y < e})"

instance
  by standard (rule uniformity_prod_def)
end

declare uniformity_Abort[where 'a="'a :: metric_space \<times> 'b :: metric_space", code]

instantiation prod :: (metric_space, metric_space) metric_space
begin

lemma dist_Pair_Pair: "dist (a, b) (c, d) = sqrt ((dist a c)\<^sup>2 + (dist b d)\<^sup>2)"
  unfolding dist_prod_def by simp

lemma dist_fst_le: "dist (fst x) (fst y) \<le> dist x y"
  unfolding dist_prod_def by (rule real_sqrt_sum_squares_ge1)

lemma dist_snd_le: "dist (snd x) (snd y) \<le> dist x y"
  unfolding dist_prod_def by (rule real_sqrt_sum_squares_ge2)

instance
proof
  fix x y :: "'a \<times> 'b"
  show "dist x y = 0 \<longleftrightarrow> x = y"
    unfolding dist_prod_def prod_eq_iff by simp
next
  fix x y z :: "'a \<times> 'b"
  show "dist x y \<le> dist x z + dist y z"
    unfolding dist_prod_def
    by (intro order_trans [OF _ real_sqrt_sum_squares_triangle_ineq]
        real_sqrt_le_mono add_mono power_mono dist_triangle2 zero_le_dist)
next
  fix S :: "('a \<times> 'b) set"
  have *: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)"
  proof
    assume "open S" show "\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S"
    proof
      fix x assume "x \<in> S"
      obtain A B where "open A" "open B" "x \<in> A \<times> B" "A \<times> B \<subseteq> S"
        using \<open>open S\<close> and \<open>x \<in> S\<close> by (rule open_prod_elim)
      obtain r where r: "0 < r" "\<forall>y. dist y (fst x) < r \<longrightarrow> y \<in> A"
        using \<open>open A\<close> and \<open>x \<in> A \<times> B\<close> unfolding open_dist by auto
      obtain s where s: "0 < s" "\<forall>y. dist y (snd x) < s \<longrightarrow> y \<in> B"
        using \<open>open B\<close> and \<open>x \<in> A \<times> B\<close> unfolding open_dist by auto
      let ?e = "min r s"
      have "0 < ?e \<and> (\<forall>y. dist y x < ?e \<longrightarrow> y \<in> S)"
      proof (intro allI impI conjI)
        show "0 < min r s" by (simp add: r(1) s(1))
      next
        fix y assume "dist y x < min r s"
        hence "dist y x < r" and "dist y x < s"
          by simp_all
        hence "dist (fst y) (fst x) < r" and "dist (snd y) (snd x) < s"
          by (auto intro: le_less_trans dist_fst_le dist_snd_le)
        hence "fst y \<in> A" and "snd y \<in> B"
          by (simp_all add: r(2) s(2))
        hence "y \<in> A \<times> B" by (induct y, simp)
        with \<open>A \<times> B \<subseteq> S\<close> show "y \<in> S" ..
      qed
      thus "\<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S" ..
    qed
  next
    assume *: "\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S" show "open S"
    proof (rule open_prod_intro)
      fix x assume "x \<in> S"
      then obtain e where "0 < e" and S: "\<forall>y. dist y x < e \<longrightarrow> y \<in> S"
        using * by fast
      define r where "r = e / sqrt 2"
      define s where "s = e / sqrt 2"
      from \<open>0 < e\<close> have "0 < r" and "0 < s"
        unfolding r_def s_def by simp_all
      from \<open>0 < e\<close> have "e = sqrt (r\<^sup>2 + s\<^sup>2)"
        unfolding r_def s_def by (simp add: power_divide)
      define A where "A = {y. dist (fst x) y < r}"
      define B where "B = {y. dist (snd x) y < s}"
      have "open A" and "open B"
        unfolding A_def B_def by (simp_all add: open_ball)
      moreover have "x \<in> A \<times> B"
        unfolding A_def B_def mem_Times_iff
        using \<open>0 < r\<close> and \<open>0 < s\<close> by simp
      moreover have "A \<times> B \<subseteq> S"
      proof (clarify)
        fix a b assume "a \<in> A" and "b \<in> B"
        hence "dist a (fst x) < r" and "dist b (snd x) < s"
          unfolding A_def B_def by (simp_all add: dist_commute)
        hence "dist (a, b) x < e"
          unfolding dist_prod_def \<open>e = sqrt (r\<^sup>2 + s\<^sup>2)\<close>
          by (simp add: add_strict_mono power_strict_mono)
        thus "(a, b) \<in> S"
          by (simp add: S)
      qed
      ultimately show "\<exists>A B. open A \<and> open B \<and> x \<in> A \<times> B \<and> A \<times> B \<subseteq> S" by fast
    qed
  qed
  show "open S = (\<forall>x\<in>S. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> S)"
    unfolding * eventually_uniformity_metric
    by (simp del: split_paired_All add: dist_prod_def dist_commute)
qed

end

declare [[code abort: "dist::('a::metric_space*'b::metric_space)\<Rightarrow>('a*'b) \<Rightarrow> real"]]

lemma Cauchy_fst: "Cauchy X \<Longrightarrow> Cauchy (\<lambda>n. fst (X n))"
  unfolding Cauchy_def by (fast elim: le_less_trans [OF dist_fst_le])

lemma Cauchy_snd: "Cauchy X \<Longrightarrow> Cauchy (\<lambda>n. snd (X n))"
  unfolding Cauchy_def by (fast elim: le_less_trans [OF dist_snd_le])

lemma Cauchy_Pair:
  assumes "Cauchy X" and "Cauchy Y"
  shows "Cauchy (\<lambda>n. (X n, Y n))"
proof (rule metric_CauchyI)
  fix r :: real assume "0 < r"
  hence "0 < r / sqrt 2" (is "0 < ?s") by simp
  obtain M where M: "\<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m) (X n) < ?s"
    using metric_CauchyD [OF \<open>Cauchy X\<close> \<open>0 < ?s\<close>] ..
  obtain N where N: "\<forall>m\<ge>N. \<forall>n\<ge>N. dist (Y m) (Y n) < ?s"
    using metric_CauchyD [OF \<open>Cauchy Y\<close> \<open>0 < ?s\<close>] ..
  have "\<forall>m\<ge>max M N. \<forall>n\<ge>max M N. dist (X m, Y m) (X n, Y n) < r"
    using M N by (simp add: real_sqrt_sum_squares_less dist_Pair_Pair)
  then show "\<exists>n0. \<forall>m\<ge>n0. \<forall>n\<ge>n0. dist (X m, Y m) (X n, Y n) < r" ..
qed

subsection \<open>Product is a complete metric space\<close>

instance prod :: (complete_space, complete_space) complete_space
proof
  fix X :: "nat \<Rightarrow> 'a \<times> 'b" assume "Cauchy X"
  have 1: "(\<lambda>n. fst (X n)) \<longlonglongrightarrow> lim (\<lambda>n. fst (X n))"
    using Cauchy_fst [OF \<open>Cauchy X\<close>]
    by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
  have 2: "(\<lambda>n. snd (X n)) \<longlonglongrightarrow> lim (\<lambda>n. snd (X n))"
    using Cauchy_snd [OF \<open>Cauchy X\<close>]
    by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
  have "X \<longlonglongrightarrow> (lim (\<lambda>n. fst (X n)), lim (\<lambda>n. snd (X n)))"
    using tendsto_Pair [OF 1 2] by simp
  then show "convergent X"
    by (rule convergentI)
qed

subsection \<open>Product is a normed vector space\<close>

instantiation prod :: (real_normed_vector, real_normed_vector) real_normed_vector
begin

definition norm_prod_def[code del]:
  "norm x = sqrt ((norm (fst x))\<^sup>2 + (norm (snd x))\<^sup>2)"

definition sgn_prod_def:
  "sgn (x::'a \<times> 'b) = scaleR (inverse (norm x)) x"

lemma norm_Pair: "norm (a, b) = sqrt ((norm a)\<^sup>2 + (norm b)\<^sup>2)"
  unfolding norm_prod_def by simp

instance
proof
  fix r :: real and x y :: "'a \<times> 'b"
  show "norm x = 0 \<longleftrightarrow> x = 0"
    unfolding norm_prod_def
    by (simp add: prod_eq_iff)
  show "norm (x + y) \<le> norm x + norm y"
    unfolding norm_prod_def
    apply (rule order_trans [OF _ real_sqrt_sum_squares_triangle_ineq])
    apply (simp add: add_mono power_mono norm_triangle_ineq)
    done
  show "norm (scaleR r x) = \<bar>r\<bar> * norm x"
    unfolding norm_prod_def
    apply (simp add: power_mult_distrib)
    apply (simp add: distrib_left [symmetric])
    apply (simp add: real_sqrt_mult_distrib)
    done
  show "sgn x = scaleR (inverse (norm x)) x"
    by (rule sgn_prod_def)
  show "dist x y = norm (x - y)"
    unfolding dist_prod_def norm_prod_def
    by (simp add: dist_norm)
qed

end

declare [[code abort: "norm::('a::real_normed_vector*'b::real_normed_vector) \<Rightarrow> real"]]

instance prod :: (banach, banach) banach ..

subsubsection \<open>Pair operations are linear\<close>

lemma bounded_linear_fst: "bounded_linear fst"
  using fst_add fst_scaleR
  by (rule bounded_linear_intro [where K=1], simp add: norm_prod_def)

lemma bounded_linear_snd: "bounded_linear snd"
  using snd_add snd_scaleR
  by (rule bounded_linear_intro [where K=1], simp add: norm_prod_def)

lemmas bounded_linear_fst_comp = bounded_linear_fst[THEN bounded_linear_compose]

lemmas bounded_linear_snd_comp = bounded_linear_snd[THEN bounded_linear_compose]

lemma bounded_linear_Pair:
  assumes f: "bounded_linear f"
  assumes g: "bounded_linear g"
  shows "bounded_linear (\<lambda>x. (f x, g x))"
proof
  interpret f: bounded_linear f by fact
  interpret g: bounded_linear g by fact
  fix x y and r :: real
  show "(f (x + y), g (x + y)) = (f x, g x) + (f y, g y)"
    by (simp add: f.add g.add)
  show "(f (r *\<^sub>R x), g (r *\<^sub>R x)) = r *\<^sub>R (f x, g x)"
    by (simp add: f.scaleR g.scaleR)
  obtain Kf where "0 < Kf" and norm_f: "\<And>x. norm (f x) \<le> norm x * Kf"
    using f.pos_bounded by fast
  obtain Kg where "0 < Kg" and norm_g: "\<And>x. norm (g x) \<le> norm x * Kg"
    using g.pos_bounded by fast
  have "\<forall>x. norm (f x, g x) \<le> norm x * (Kf + Kg)"
    apply (rule allI)
    apply (simp add: norm_Pair)
    apply (rule order_trans [OF sqrt_add_le_add_sqrt], simp, simp)
    apply (simp add: distrib_left)
    apply (rule add_mono [OF norm_f norm_g])
    done
  then show "\<exists>K. \<forall>x. norm (f x, g x) \<le> norm x * K" ..
qed

subsubsection \<open>Frechet derivatives involving pairs\<close>

lemma has_derivative_Pair [derivative_intros]:
  assumes f: "(f has_derivative f') (at x within s)" and g: "(g has_derivative g') (at x within s)"
  shows "((\<lambda>x. (f x, g x)) has_derivative (\<lambda>h. (f' h, g' h))) (at x within s)"
proof (rule has_derivativeI_sandwich[of 1])
  show "bounded_linear (\<lambda>h. (f' h, g' h))"
    using f g by (intro bounded_linear_Pair has_derivative_bounded_linear)
  let ?Rf = "\<lambda>y. f y - f x - f' (y - x)"
  let ?Rg = "\<lambda>y. g y - g x - g' (y - x)"
  let ?R = "\<lambda>y. ((f y, g y) - (f x, g x) - (f' (y - x), g' (y - x)))"

  show "((\<lambda>y. norm (?Rf y) / norm (y - x) + norm (?Rg y) / norm (y - x)) \<longlongrightarrow> 0) (at x within s)"
    using f g by (intro tendsto_add_zero) (auto simp: has_derivative_iff_norm)

  fix y :: 'a assume "y \<noteq> x"
  show "norm (?R y) / norm (y - x) \<le> norm (?Rf y) / norm (y - x) + norm (?Rg y) / norm (y - x)"
    unfolding add_divide_distrib [symmetric]
    by (simp add: norm_Pair divide_right_mono order_trans [OF sqrt_add_le_add_sqrt])
qed simp

lemmas has_derivative_fst [derivative_intros] = bounded_linear.has_derivative [OF bounded_linear_fst]
lemmas has_derivative_snd [derivative_intros] = bounded_linear.has_derivative [OF bounded_linear_snd]

lemma has_derivative_split [derivative_intros]:
  "((\<lambda>p. f (fst p) (snd p)) has_derivative f') F \<Longrightarrow> ((\<lambda>(a, b). f a b) has_derivative f') F"
  unfolding split_beta' .

subsection \<open>Product is an inner product space\<close>

instantiation prod :: (real_inner, real_inner) real_inner
begin

definition inner_prod_def:
  "inner x y = inner (fst x) (fst y) + inner (snd x) (snd y)"

lemma inner_Pair [simp]: "inner (a, b) (c, d) = inner a c + inner b d"
  unfolding inner_prod_def by simp

instance
proof
  fix r :: real
  fix x y z :: "'a::real_inner \<times> 'b::real_inner"
  show "inner x y = inner y x"
    unfolding inner_prod_def
    by (simp add: inner_commute)
  show "inner (x + y) z = inner x z + inner y z"
    unfolding inner_prod_def
    by (simp add: inner_add_left)
  show "inner (scaleR r x) y = r * inner x y"
    unfolding inner_prod_def
    by (simp add: distrib_left)
  show "0 \<le> inner x x"
    unfolding inner_prod_def
    by (intro add_nonneg_nonneg inner_ge_zero)
  show "inner x x = 0 \<longleftrightarrow> x = 0"
    unfolding inner_prod_def prod_eq_iff
    by (simp add: add_nonneg_eq_0_iff)
  show "norm x = sqrt (inner x x)"
    unfolding norm_prod_def inner_prod_def
    by (simp add: power2_norm_eq_inner)
qed

end

lemma inner_Pair_0: "inner x (0, b) = inner (snd x) b" "inner x (a, 0) = inner (fst x) a"
    by (cases x, simp)+

lemma
  fixes x :: "'a::real_normed_vector"
  shows norm_Pair1 [simp]: "norm (0,x) = norm x"
    and norm_Pair2 [simp]: "norm (x,0) = norm x"
by (auto simp: norm_Pair)

lemma norm_commute: "norm (x,y) = norm (y,x)"
  by (simp add: norm_Pair)

lemma norm_fst_le: "norm x \<le> norm (x,y)"
  by (metis dist_fst_le fst_conv fst_zero norm_conv_dist)

lemma norm_snd_le: "norm y \<le> norm (x,y)"
  by (metis dist_snd_le snd_conv snd_zero norm_conv_dist)

end


section \<open>Power-Products Represented by Polynomial Mappings\<close>

theory Power_Products_PM
  imports More_MPoly_PM Fun_Conv
begin

subsection \<open>Natural and Integer-Valued Polynomial Mappings\<close>

lift_definition of_nat_pm :: "('a \<Rightarrow>\<^sub>0 nat) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b::semiring_1)" is of_nat_fun
proof -
  fix f::"'a \<Rightarrow> nat"
  have "{x. of_nat_fun f x \<noteq> 0} \<subseteq> {x. f x \<noteq> 0}"
  proof (rule, simp add: of_nat_fun_def)
    fix x
    assume "of_nat (f x) \<noteq> 0"
    have "f x \<noteq> 0"
    proof
      assume "f x = 0"
      hence "of_nat (f x) = 0" by simp
      with \<open>of_nat (f x) \<noteq> 0\<close> show False ..
    qed
    thus "0 < f x" by simp
  qed
  moreover assume "finite {x. f x \<noteq> 0}"
  ultimately show "finite {x. of_nat_fun f x \<noteq> 0}" by (rule finite_subset)
qed

(* OBSOLETE? *)
lift_definition of_int_pm :: "('a \<Rightarrow>\<^sub>0 int) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b::ring_1)" is of_int_fun
proof -
  fix f::"'a \<Rightarrow> int"
  have "{x. of_int_fun f x \<noteq> 0} \<subseteq> {x. f x \<noteq> 0}"
  proof (rule, simp add: of_int_fun_def, rule)
    fix x
    assume "of_int (f x) \<noteq> 0"
    assume "f x = 0"
    hence "of_int (f x) = 0" by simp
    with \<open>of_int (f x) \<noteq> 0\<close> show False ..
  qed
  moreover assume "finite {x. f x \<noteq> 0}"
  ultimately show "finite {x. of_int_fun f x \<noteq> 0}" by (rule finite_subset)
qed

(* OBSOLETE? *)
lift_definition of_rat_pm :: "('a \<Rightarrow>\<^sub>0 rat) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b::field_char_0)" is of_rat_fun
proof -
  fix f::"'a \<Rightarrow> rat"
  have "{x. of_rat_fun f x \<noteq> 0} \<subseteq> {x. f x \<noteq> 0}" by (rule, simp add: of_rat_fun_def)
  moreover assume "finite {x. f x \<noteq> 0}"
  ultimately show "finite {x. of_rat_fun f x \<noteq> 0}" by (rule finite_subset)
qed

lemma lookup_of_nat_pm: "lookup (of_nat_pm t) x = of_nat (lookup t x)"
  by (simp add: of_nat_fun_def of_nat_pm.rep_eq)

lemma keys_of_nat_pm_subset: "keys (of_nat_pm t) \<subseteq> keys t"
  by (auto simp add: lookup_of_nat_pm simp flip: lookup_not_eq_zero_eq_in_keys intro!: gr0I)

lemma keys_of_nat_pm [simp]: "keys ((of_nat_pm t)::_ \<Rightarrow>\<^sub>0 _::semiring_char_0) = keys t"
  by (auto simp add: lookup_of_nat_pm simp flip: lookup_not_eq_zero_eq_in_keys)

lemma lookup_of_int_pm: "lookup (of_int_pm t) x = of_int (lookup t x)"
  by (simp add: of_int_fun_def of_int_pm.rep_eq)

lemma lookup_of_rat_pm: "lookup (of_rat_pm t) x = of_rat (lookup t x)"
  by (simp add: of_rat_fun_def of_rat_pm.rep_eq)

lemma of_nat_pm_injective [simp]: "of_nat_pm s = ((of_nat_pm t)::_ \<Rightarrow>\<^sub>0 _::semiring_char_0) \<longleftrightarrow> s = t"
  by (metis lookup_of_nat_pm of_nat_eq_iff poly_mapping_eqI)

lemma inj_of_nat_pm: "inj (of_nat_pm::_ \<Rightarrow> (_ \<Rightarrow>\<^sub>0 _::semiring_char_0))"
  by (simp add: inj_def)

lemma of_int_pm_injective [simp]: "of_int_pm s = ((of_int_pm t)::_ \<Rightarrow>\<^sub>0 _::ring_char_0) \<longleftrightarrow> s = t"
  by (metis lookup_of_int_pm of_int_eq_iff poly_mapping_eqI)

lemma inj_of_int_pm: "inj (of_int_pm::_ \<Rightarrow> (_ \<Rightarrow>\<^sub>0 _::ring_char_0))"
  by (simp add: inj_def)

lemma deg_of_nat_pm: "deg_pm (of_nat_pm t) = (of_nat (deg_pm t) :: _::semiring_char_0)"
  by (simp add: deg_pm_superset[OF subset_refl finite_keys] of_nat_pm.rep_eq of_nat_fun_def)

lift_definition to_nat_pm :: "('a \<Rightarrow>\<^sub>0 'b::floor_ceiling) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 nat)" is to_nat_fun
proof -
  fix f::"'a \<Rightarrow> 'b"
  have "{x. to_nat_fun f x \<noteq> 0} \<subseteq> {x. f x \<noteq> 0}"
  proof (rule, simp add: to_nat_fun_def, rule)
    fix x
    assume "0 < to_nat (f x)"
    hence "to_nat (f x) \<noteq> 0" by simp
    assume "f x = 0"
    hence "to_nat (f x) = 0" by (simp add: to_nat_def)
    with \<open>to_nat (f x) \<noteq> 0\<close> show False ..
  qed
  moreover assume "finite {x. f x \<noteq> 0}"
  ultimately show "finite {x. to_nat_fun f x \<noteq> 0}" by (rule finite_subset)
qed

lift_definition to_int_pm :: "('a \<Rightarrow>\<^sub>0 'b::floor_ceiling) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 int)" is to_int_fun
proof -
  fix f::"'a \<Rightarrow> 'b"
  have "{x. to_int_fun f x \<noteq> 0} \<subseteq> {x. f x \<noteq> 0}" by (rule, simp add: to_int_fun_def, rule, simp)
  moreover assume "finite {x. f x \<noteq> 0}"
  ultimately show "finite {x. to_int_fun f x \<noteq> 0}" by (rule finite_subset)
qed

lemma lookup_to_nat_pm: "lookup (to_nat_pm t) x = to_nat (lookup t x)"
  by (simp add: to_nat_fun_def to_nat_pm.rep_eq)

lemma lookup_to_int_pm: "lookup (to_int_pm t) x = floor (lookup t x)"
  by (simp add: to_int_fun_def to_int_pm.rep_eq)

definition is_nat_pm where "is_nat_pm t = is_nat_fun (lookup t)"
definition is_int_pm where "is_int_pm t = is_int_fun (lookup t)"

lemma is_nat_pmI:
  assumes "\<And>x. x \<in> keys t \<Longrightarrow> lookup t x \<in> \<nat>"
  shows "is_nat_pm t"
  unfolding is_nat_pm_def
proof (rule is_nat_funI)
  fix x
  show "lookup t x \<in> \<nat>"
  proof (cases "x \<in> keys t")
    case True
    thus ?thesis by (rule assms)
  next
    case False
    thus ?thesis by (simp add: in_keys_iff)
  qed
qed

lemma is_nat_pmD: "is_nat_pm t \<Longrightarrow> lookup t x \<in> \<nat>"
  unfolding is_nat_pm_def by (drule is_nat_funD)

lemma is_int_pmI:
  assumes "\<And>x. x \<in> keys t \<Longrightarrow> lookup t x \<in> \<int>"
  shows "is_int_pm t"
  unfolding is_int_pm_def
proof (rule is_int_funI)
  fix x
  show "lookup t x \<in> \<int>"
  proof (cases "x \<in> keys t")
    case True
    thus ?thesis by (rule assms)
  next
    case False
    thus ?thesis by (simp add: in_keys_iff)
  qed
qed

lemma is_int_pmD: "is_int_pm t \<Longrightarrow> lookup t x \<in> \<int>"
  unfolding is_int_pm_def by (drule is_int_funD)

lemma nat_pm_is_int_pm:
  assumes "is_nat_pm t"
  shows "is_int_pm t"
proof (rule is_int_pmI)
  fix x
  from assms have "lookup t x \<in> \<nat>" by (rule is_nat_pmD)
  thus "lookup t x \<in> \<int>" by (rule Nats_imp_Ints)
qed

lemma int_pm_is_nat_pm:
  assumes "is_int_pm t" and "\<And>x. x \<in> keys t \<Longrightarrow> (0::_::linordered_idom) \<le> lookup t x"
  shows "is_nat_pm t"
  unfolding is_nat_pm_def
proof (rule is_nat_funI)
  fix x
  show "lookup t x \<in> \<nat>"
  proof (cases "x \<in> keys t")
    case True
    from assms(1) have "lookup t x \<in> \<int>" by (rule is_int_pmD)
    moreover from True have "0 \<le> lookup t x" by (rule assms(2))
    ultimately show ?thesis by (rule Ints_imp_Nats)
  next
    case False
    thus ?thesis by (simp add: in_keys_iff)
  qed
qed

lemma int_pm_is_nat_pmI:
  assumes "is_int_pm f" and "is_nat_pm g" and "g \<unlhd> (f::_ \<Rightarrow>\<^sub>0 _::linordered_idom)"
  shows "is_nat_pm f"
  using assms(1)
proof (rule int_pm_is_nat_pm)
  fix x
  from assms(2) have "lookup g x \<in> \<nat>" by (rule is_nat_pmD)
  hence "0 \<le> lookup g x" by (rule Nats_ge_0)
  also from assms(3) have "\<dots> \<le> lookup f x" by (rule le_pmD)
  finally show "0 \<le> lookup f x" .
qed

lemma of_nat_pm_is_nat_pm: "is_nat_pm (of_nat_pm f)"
  unfolding is_nat_pm_def by (rule is_nat_funI) (simp add: lookup_of_nat_pm)

lemma of_int_pm_is_int_pm: "is_int_pm (of_int_pm f)"
  unfolding is_int_pm_def by (rule is_int_funI) (simp add: lookup_of_int_pm)

lemma of_nat_pm_is_int_pm: "is_int_pm (of_nat_pm f)"
  using of_nat_pm_is_nat_pm by (rule nat_pm_is_int_pm)

lemma lcs_of_nat_pm:
  assumes "\<And>m n::nat. of_nat m \<le> ((of_nat n)::'b::{semiring_1, add_linorder}) \<longleftrightarrow> m \<le> n"
  shows "lcs (of_nat_pm a) (of_nat_pm b) = ((of_nat_pm (lcs a b))::'a \<Rightarrow>\<^sub>0 'b)"
  by (transfer, auto simp add: of_nat_fun_def max_of_nat[OF assms])

lemma gcs_of_nat_pm:
  assumes "\<And>m n::nat. of_nat m \<le> ((of_nat n)::'b::{semiring_1, add_linorder}) \<longleftrightarrow> m \<le> n"
  shows "gcs (of_nat_pm a) (of_nat_pm b) = ((of_nat_pm (gcs a b))::'a \<Rightarrow>\<^sub>0 'b)"
  by (rule poly_mapping_eqI, simp add: lookup_gcs_fun of_nat_pm.rep_eq gcs_fun of_nat_fun_def,
      auto simp add: min_of_nat[OF assms])

lemmas lcs_of_nat_pm_linordered_semidom = lcs_of_nat_pm[OF Nat.linordered_nonzero_semiring_class.of_nat_le_iff]
lemmas gcs_of_nat_pm_linordered_semidom = gcs_of_nat_pm[OF Nat.linordered_nonzero_semiring_class.of_nat_le_iff]

lemma lcs_is_nat_pm: "is_nat_pm f \<Longrightarrow> is_nat_pm g \<Longrightarrow> is_nat_pm (lcs f g)"
  by (auto simp: is_nat_pm_def lookup_lcs_fun lcs_fun_def intro: is_nat_funI Nats_max is_nat_funD)

lemma lcs_is_nat_pm': "is_nat_pm f \<Longrightarrow> is_int_pm g \<Longrightarrow> is_nat_pm (lcs f (g::_ \<Rightarrow>\<^sub>0 _::linordered_idom))"
  by (auto simp: is_nat_pm_def is_int_pm_def lookup_lcs_fun lcs_fun_def
          intro: is_nat_funI Nats_max' is_nat_funD is_int_funD)

lemma lcs_is_int_pm: "is_int_pm f \<Longrightarrow> is_int_pm g \<Longrightarrow> is_int_pm (lcs f g)"
  by (auto simp: is_int_pm_def lookup_lcs_fun lcs_fun_def intro: is_int_funI Ints_max is_int_funD)

lemma gcs_is_nat_pm: "is_nat_pm f \<Longrightarrow> is_nat_pm g \<Longrightarrow> is_nat_pm (gcs f g)"
  by (auto simp: is_nat_pm_def lookup_gcs_fun gcs_fun intro: is_nat_funI Nats_min is_nat_funD)

lemma gcs_is_int_pm: "is_int_pm f \<Longrightarrow> is_int_pm g \<Longrightarrow> is_int_pm (gcs f g)"
  by (auto simp: is_int_pm_def lookup_gcs_fun gcs_fun intro: is_int_funI Ints_min is_int_funD)

lemma zero_is_nat_pm [simp]: "is_nat_pm 0"
  unfolding is_nat_pm_def by (rule is_nat_funI) simp

lemma zero_is_int_pm [simp]: "is_int_pm 0"
  using zero_is_nat_pm by (rule nat_pm_is_int_pm)

lemma of_nat_pm_zero [simp]: "of_nat_pm 0 = 0"
  by (rule poly_mapping_eqI, simp add: lookup_of_nat_pm)

lemma of_int_pm_zero [simp]: "of_int_pm 0 = 0"
  by (rule poly_mapping_eqI, simp add: lookup_of_int_pm)

lemma of_nat_pm_single: "of_nat_pm (Poly_Mapping.single x e) = Poly_Mapping.single x (of_nat e)"
  by (rule poly_mapping_eqI) (simp add: lookup_of_nat_pm lookup_single when_distrib)

lemma plus_is_nat_pm: "is_nat_pm f \<Longrightarrow> is_nat_pm g \<Longrightarrow> is_nat_pm (f + g)"
  by (simp add: is_nat_pm_def plus_poly_mapping.rep_eq plus_fun_def is_nat_fun_alt)

lemma minus_is_nat_pm:
  assumes "is_int_pm f" and "is_int_pm g"
  shows "is_nat_pm (f - g) \<longleftrightarrow> lookup g \<le> lookup (f::_ \<Rightarrow>\<^sub>0 _::floor_ceiling)"
proof -
  from assms have a2: "lookup f x \<in> \<int>" and a3: "lookup g x \<in> \<int>" for x
    by (simp_all add: is_int_pm_def is_int_fun_alt)
  show ?thesis
  proof
    assume "is_nat_pm (f - g)"
    hence a1: "lookup (f - g) x \<in> \<nat>" for x by (rule is_nat_pmD)

    show "lookup g \<le> lookup f" unfolding le_fun_def
    proof
      fix x
      from a1 have "(lookup f x) - (lookup g x) \<in> \<nat>" by (simp only: lookup_minus)
      thus "lookup g x \<le> lookup f x" unfolding Nats_minus[OF a2 a3] .
    qed
  next
    assume "lookup g \<le> lookup f"
    show "is_nat_pm (f - g)"
    proof (rule is_nat_pmI)
      fix x
      from \<open>lookup g \<le> lookup f\<close> have "lookup g x \<le> lookup f x" unfolding le_fun_def ..
      hence "(lookup f x) - (lookup g x) \<in> \<nat>" unfolding Nats_minus[OF a2 a3] .
      thus "lookup (f - g) x \<in> \<nat>" by (simp only: lookup_minus)
    qed
  qed
qed

lemma plus_is_int_pm: "is_int_pm f \<Longrightarrow> is_int_pm g \<Longrightarrow> is_int_pm (f + g)"
  by (simp add: is_int_pm_def plus_poly_mapping.rep_eq plus_fun_def is_int_fun_alt)

lemma minus_is_int_pm: "is_int_pm f \<Longrightarrow> is_int_pm g \<Longrightarrow> is_int_pm (f - g)"
  by (simp add: is_int_pm_def lookup_minus is_int_fun_alt)

lemma uminus_is_int_pm: "is_int_pm f \<Longrightarrow> is_int_pm (- f)"
  by (simp add: is_int_pm_def is_int_fun_alt)

lemma of_nat_pm_plus: "of_nat_pm (f + g) = of_nat_pm f + of_nat_pm g"
  by (rule poly_mapping_eqI, simp add: lookup_of_nat_pm lookup_add)

lemma of_nat_pm_minus: "g adds f \<Longrightarrow> of_nat_pm (f - g) = of_nat_pm f - of_nat_pm g"
  by (metis add_minus_2 addsE of_nat_pm_plus)

lemma of_int_pm_plus: "of_int_pm (f + g) = of_int_pm f + of_int_pm g"
  by (rule poly_mapping_eqI, simp add: lookup_of_int_pm lookup_add)

lemma Nats_deg: "is_nat_pm t \<Longrightarrow> deg_pm t \<in> \<nat>"
  by (auto simp: deg_pm_superset[OF subset_refl finite_keys] intro: Nats_sum dest: is_nat_pmD)

lemma Ints_deg: "is_int_pm t \<Longrightarrow> deg_pm t \<in> \<int>"
  by (auto simp: deg_pm_superset[OF subset_refl finite_keys] intro: Ints_sum dest: is_int_pmD)

lemma map_scale_is_nat_pm: "c \<in> \<nat> \<Longrightarrow> is_nat_pm t \<Longrightarrow> is_nat_pm (c \<cdot> t)"
  by (auto simp: is_nat_pm_def is_nat_fun_alt)

lemma map_scale_is_int_pm: "c \<in> \<int> \<Longrightarrow> is_int_pm t \<Longrightarrow> is_int_pm (c \<cdot> t)"
  by (auto simp: is_int_pm_def is_int_fun_alt)

lemma of_nat_pm_map_scale: "of_nat_pm (c \<cdot> t) = of_nat c \<cdot> of_nat_pm t"
  by (rule poly_mapping_eqI) (simp add: lookup_of_nat_pm)

subsubsection \<open>Composition\<close>

lemma to_int_pm_comp_of_int_pm [simp]: "to_int_pm (of_int_pm t) = t"
  by (rule poly_mapping_eqI, simp add: lookup_to_int_pm lookup_of_int_pm)

lemma to_nat_pm_comp_of_nat_pm [simp]: "to_nat_pm (of_nat_pm t) = t"
  by (rule poly_mapping_eqI, simp add: lookup_to_nat_pm lookup_of_nat_pm to_nat_def)

lemma to_nat_pm_comp_of_int_pm [simp]: "lookup (to_nat_pm (of_int_pm t)) = nat \<circ> (lookup t)"
  by (simp add: to_nat_pm.rep_eq of_int_pm.rep_eq to_nat_fun_comp_of_int_fun)

lemma of_nat_pm_comp_to_nat_pm: "is_nat_pm t \<Longrightarrow> of_nat_pm (to_nat_pm t) = t"
  by (simp add: is_nat_pm_def poly_mapping_eq_iff of_nat_pm.rep_eq to_nat_pm.rep_eq,
      intro of_nat_fun_comp_to_nat_fun)

lemma of_nat_pm_comp_to_nat_pm_eq_to_int_pm:
  "is_nat_pm (t::_ \<Rightarrow>\<^sub>0 _::floor_ceiling) \<Longrightarrow> of_nat_pm (to_nat_pm t) = to_int_pm t"
  by (simp add: is_nat_pm_def poly_mapping_eq_iff of_nat_pm.rep_eq to_nat_pm.rep_eq to_int_pm.rep_eq,
      intro of_nat_fun_comp_to_nat_fun_eq_to_int_fun)

lemma of_int_pm_comp_to_int_pm: "is_int_pm t \<Longrightarrow> of_int_pm (to_int_pm t) = t"
  by (simp add: is_int_pm_def poly_mapping_eq_iff of_int_pm.rep_eq to_int_pm.rep_eq,
      intro of_int_fun_comp_to_int_fun)

lemma of_int_pm_comp_of_nat_pm [simp]: "of_int_pm (of_nat_pm t) = of_nat_pm t"
  by (simp add: poly_mapping_eq_iff of_int_pm.rep_eq of_nat_pm.rep_eq, fact of_int_fun_comp_of_nat_fun)

lemma to_nat_deg_pm_le:
  assumes "is_int_pm t"
  shows "to_nat (deg_pm t) \<le> deg_pm (to_nat_pm t)"
proof -
  from subset_refl finite_keys have "deg_pm t = sum (lookup t) (keys t)" by (rule deg_pm_superset)
  also have "to_nat \<dots> \<le> (\<Sum>x\<in>keys t. to_nat (lookup t x))" by (intro to_nat_sum_le is_int_pmD assms)
  also have "\<dots> = sum (lookup (to_nat_pm t)) (keys t)" by (simp flip: lookup_to_nat_pm)
  also have "\<dots> = deg_pm (to_nat_pm t)"
    by (rule sym, rule deg_pm_superset) (auto simp: in_keys_iff lookup_to_nat_pm)
  finally show ?thesis .
qed

subsection \<open>Order relation on polynomial mappings\<close>

lemma le_of_nat_pm: "of_nat_pm s \<unlhd> ((of_nat_pm t)::_ \<Rightarrow>\<^sub>0 _::linordered_semidom) \<longleftrightarrow> s \<unlhd> t"
  by (simp add: le_pm_def of_nat_pm.rep_eq leq_of_nat_fun)

lemma zero_le_of_nat_pm: "0 \<unlhd> ((of_nat_pm t)::_ \<Rightarrow>\<^sub>0 _::linordered_semidom)"
  using le_of_nat_pm zero_le_pm by force

lemma le_of_int_pm: "of_int_pm s \<unlhd> ((of_int_pm t)::_ \<Rightarrow>\<^sub>0 _::linordered_idom) \<longleftrightarrow> s \<unlhd> t"
  by (simp add: le_pm_def of_int_pm.rep_eq leq_of_int_fun)

lemma to_nat_pm_mono: "s \<unlhd> t \<Longrightarrow> to_nat_pm s \<unlhd> to_nat_pm t"
  by (simp add: le_pm_def to_nat_pm.rep_eq to_nat_fun_mono)

lemma to_int_pm_mono: "s \<unlhd> t \<Longrightarrow> to_int_pm s \<unlhd> to_int_pm t"
  by (simp add: le_pm_def to_int_pm.rep_eq to_int_fun_mono)

lemma leD_to_int_pm:
  assumes "to_int_pm s \<unlhd> to_int_pm t" and "is_int_pm s" and "is_int_pm t"
  shows "s \<unlhd> t"
proof -
  from assms(2) have "s = of_int_pm (to_int_pm s)" by (simp only: of_int_pm_comp_to_int_pm)
  also from assms(1) have "\<dots> \<unlhd> of_int_pm (to_int_pm t)" by (simp only: le_of_int_pm)
  also from assms(3) have "\<dots> = t" by (simp only: of_int_pm_comp_to_int_pm)
  finally show ?thesis .
qed

lemma of_nat_to_nat_ge_pm: "is_int_pm t \<Longrightarrow> t \<unlhd> of_nat_pm (to_nat_pm t)"
  by (auto intro!: le_pmI of_nat_to_nat_ge is_int_pmD simp: lookup_of_nat_pm lookup_to_nat_pm)

end (* theory *)