src/HOL/Library/Saturated.thy
author wenzelm
Wed Jun 17 11:03:05 2015 +0200 (2015-06-17)
changeset 60500 903bb1495239
parent 60011 3eef7a43cd51
child 60679 ade12ef2773c
permissions -rw-r--r--
isabelle update_cartouches;
     1 (*  Title:      HOL/Library/Saturated.thy
     2     Author:     Brian Huffman
     3     Author:     Peter Gammie
     4     Author:     Florian Haftmann
     5 *)
     6 
     7 section \<open>Saturated arithmetic\<close>
     8 
     9 theory Saturated
    10 imports Numeral_Type "~~/src/HOL/Word/Type_Length"
    11 begin
    12 
    13 subsection \<open>The type of saturated naturals\<close>
    14 
    15 typedef ('a::len) sat = "{.. len_of TYPE('a)}"
    16   morphisms nat_of Abs_sat
    17   by auto
    18 
    19 lemma sat_eqI:
    20   "nat_of m = nat_of n \<Longrightarrow> m = n"
    21   by (simp add: nat_of_inject)
    22 
    23 lemma sat_eq_iff:
    24   "m = n \<longleftrightarrow> nat_of m = nat_of n"
    25   by (simp add: nat_of_inject)
    26 
    27 lemma Abs_sat_nat_of [code abstype]:
    28   "Abs_sat (nat_of n) = n"
    29   by (fact nat_of_inverse)
    30 
    31 definition Abs_sat' :: "nat \<Rightarrow> 'a::len sat" where
    32   "Abs_sat' n = Abs_sat (min (len_of TYPE('a)) n)"
    33 
    34 lemma nat_of_Abs_sat' [simp]:
    35   "nat_of (Abs_sat' n :: ('a::len) sat) = min (len_of TYPE('a)) n"
    36   unfolding Abs_sat'_def by (rule Abs_sat_inverse) simp
    37 
    38 lemma nat_of_le_len_of [simp]:
    39   "nat_of (n :: ('a::len) sat) \<le> len_of TYPE('a)"
    40   using nat_of [where x = n] by simp
    41 
    42 lemma min_len_of_nat_of [simp]:
    43   "min (len_of TYPE('a)) (nat_of (n::('a::len) sat)) = nat_of n"
    44   by (rule min.absorb2 [OF nat_of_le_len_of])
    45 
    46 lemma min_nat_of_len_of [simp]:
    47   "min (nat_of (n::('a::len) sat)) (len_of TYPE('a)) = nat_of n"
    48   by (subst min.commute) simp
    49 
    50 lemma Abs_sat'_nat_of [simp]:
    51   "Abs_sat' (nat_of n) = n"
    52   by (simp add: Abs_sat'_def nat_of_inverse)
    53 
    54 instantiation sat :: (len) linorder
    55 begin
    56 
    57 definition
    58   less_eq_sat_def: "x \<le> y \<longleftrightarrow> nat_of x \<le> nat_of y"
    59 
    60 definition
    61   less_sat_def: "x < y \<longleftrightarrow> nat_of x < nat_of y"
    62 
    63 instance
    64 by default (auto simp add: less_eq_sat_def less_sat_def not_le sat_eq_iff min.coboundedI1 mult.commute)
    65 
    66 end
    67 
    68 instantiation sat :: (len) "{minus, comm_semiring_1}"
    69 begin
    70 
    71 definition
    72   "0 = Abs_sat' 0"
    73 
    74 definition
    75   "1 = Abs_sat' 1"
    76 
    77 lemma nat_of_zero_sat [simp, code abstract]:
    78   "nat_of 0 = 0"
    79   by (simp add: zero_sat_def)
    80 
    81 lemma nat_of_one_sat [simp, code abstract]:
    82   "nat_of 1 = min 1 (len_of TYPE('a))"
    83   by (simp add: one_sat_def)
    84 
    85 definition
    86   "x + y = Abs_sat' (nat_of x + nat_of y)"
    87 
    88 lemma nat_of_plus_sat [simp, code abstract]:
    89   "nat_of (x + y) = min (nat_of x + nat_of y) (len_of TYPE('a))"
    90   by (simp add: plus_sat_def)
    91 
    92 definition
    93   "x - y = Abs_sat' (nat_of x - nat_of y)"
    94 
    95 lemma nat_of_minus_sat [simp, code abstract]:
    96   "nat_of (x - y) = nat_of x - nat_of y"
    97 proof -
    98   from nat_of_le_len_of [of x] have "nat_of x - nat_of y \<le> len_of TYPE('a)" by arith
    99   then show ?thesis by (simp add: minus_sat_def)
   100 qed
   101 
   102 definition
   103   "x * y = Abs_sat' (nat_of x * nat_of y)"
   104 
   105 lemma nat_of_times_sat [simp, code abstract]:
   106   "nat_of (x * y) = min (nat_of x * nat_of y) (len_of TYPE('a))"
   107   by (simp add: times_sat_def)
   108 
   109 instance proof
   110   fix a b c :: "('a::len) sat"
   111   show "a * b * c = a * (b * c)"
   112   proof(cases "a = 0")
   113     case True thus ?thesis by (simp add: sat_eq_iff)
   114   next
   115     case False show ?thesis
   116     proof(cases "c = 0")
   117       case True thus ?thesis by (simp add: sat_eq_iff)
   118     next
   119       case False with \<open>a \<noteq> 0\<close> show ?thesis
   120         by (simp add: sat_eq_iff nat_mult_min_left nat_mult_min_right mult.assoc min.assoc min.absorb2)
   121     qed
   122   qed
   123 next
   124   fix a :: "('a::len) sat"
   125   show "1 * a = a"
   126     apply (simp add: sat_eq_iff)
   127     apply (metis One_nat_def len_gt_0 less_Suc0 less_zeroE linorder_not_less min.absorb_iff1 min_nat_of_len_of nat_mult_1_right mult.commute)
   128     done
   129 next
   130   fix a b c :: "('a::len) sat"
   131   show "(a + b) * c = a * c + b * c"
   132   proof(cases "c = 0")
   133     case True thus ?thesis by (simp add: sat_eq_iff)
   134   next
   135     case False thus ?thesis
   136       by (simp add: sat_eq_iff nat_mult_min_left add_mult_distrib min_add_distrib_left min_add_distrib_right min.assoc min.absorb2)
   137   qed
   138 qed (simp_all add: sat_eq_iff mult.commute)
   139 
   140 end
   141 
   142 instantiation sat :: (len) ordered_comm_semiring
   143 begin
   144 
   145 instance
   146 by default (auto simp add: less_eq_sat_def less_sat_def not_le sat_eq_iff min.coboundedI1 mult.commute)
   147 
   148 end
   149 
   150 lemma Abs_sat'_eq_of_nat: "Abs_sat' n = of_nat n"
   151   by (rule sat_eqI, induct n, simp_all)
   152 
   153 abbreviation Sat :: "nat \<Rightarrow> 'a::len sat" where
   154   "Sat \<equiv> of_nat"
   155 
   156 lemma nat_of_Sat [simp]:
   157   "nat_of (Sat n :: ('a::len) sat) = min (len_of TYPE('a)) n"
   158   by (rule nat_of_Abs_sat' [unfolded Abs_sat'_eq_of_nat])
   159 
   160 lemma [code_abbrev]:
   161   "of_nat (numeral k) = (numeral k :: 'a::len sat)"
   162   by simp
   163 
   164 context
   165 begin
   166 
   167 qualified definition sat_of_nat :: "nat \<Rightarrow> ('a::len) sat"
   168   where [code_abbrev]: "sat_of_nat = of_nat"
   169 
   170 lemma [code abstract]:
   171   "nat_of (sat_of_nat n :: ('a::len) sat) = min (len_of TYPE('a)) n"
   172   by (simp add: sat_of_nat_def)
   173 
   174 end
   175 
   176 instance sat :: (len) finite
   177 proof
   178   show "finite (UNIV::'a sat set)"
   179     unfolding type_definition.univ [OF type_definition_sat]
   180     using finite by simp
   181 qed
   182 
   183 instantiation sat :: (len) equal
   184 begin
   185 
   186 definition
   187   "HOL.equal A B \<longleftrightarrow> nat_of A = nat_of B"
   188 
   189 instance proof
   190 qed (simp add: equal_sat_def nat_of_inject)
   191 
   192 end
   193 
   194 instantiation sat :: (len) "{bounded_lattice, distrib_lattice}"
   195 begin
   196 
   197 definition
   198   "(inf :: 'a sat \<Rightarrow> 'a sat \<Rightarrow> 'a sat) = min"
   199 
   200 definition
   201   "(sup :: 'a sat \<Rightarrow> 'a sat \<Rightarrow> 'a sat) = max"
   202 
   203 definition
   204   "bot = (0 :: 'a sat)"
   205 
   206 definition
   207   "top = Sat (len_of TYPE('a))"
   208 
   209 instance proof
   210 qed (simp_all add: inf_sat_def sup_sat_def bot_sat_def top_sat_def max_min_distrib2,
   211   simp_all add: less_eq_sat_def)
   212 
   213 end
   214 
   215 instantiation sat :: (len) "{Inf, Sup}"
   216 begin
   217 
   218 definition
   219   "Inf = (semilattice_neutr_set.F min top :: 'a sat set \<Rightarrow> 'a sat)"
   220 
   221 definition
   222   "Sup = (semilattice_neutr_set.F max bot :: 'a sat set \<Rightarrow> 'a sat)"
   223 
   224 instance ..
   225 
   226 end
   227 
   228 interpretation Inf_sat!: semilattice_neutr_set min "top :: 'a::len sat"
   229 where
   230   "semilattice_neutr_set.F min (top :: 'a sat) = Inf"
   231 proof -
   232   show "semilattice_neutr_set min (top :: 'a sat)" by default (simp add: min_def)
   233   show "semilattice_neutr_set.F min (top :: 'a sat) = Inf" by (simp add: Inf_sat_def)
   234 qed
   235 
   236 interpretation Sup_sat!: semilattice_neutr_set max "bot :: 'a::len sat"
   237 where
   238   "semilattice_neutr_set.F max (bot :: 'a sat) = Sup"
   239 proof -
   240   show "semilattice_neutr_set max (bot :: 'a sat)" by default (simp add: max_def bot.extremum_unique)
   241   show "semilattice_neutr_set.F max (bot :: 'a sat) = Sup" by (simp add: Sup_sat_def)
   242 qed
   243 
   244 instance sat :: (len) complete_lattice
   245 proof 
   246   fix x :: "'a sat"
   247   fix A :: "'a sat set"
   248   note finite
   249   moreover assume "x \<in> A"
   250   ultimately show "Inf A \<le> x"
   251     by (induct A) (auto intro: min.coboundedI2)
   252 next
   253   fix z :: "'a sat"
   254   fix A :: "'a sat set"
   255   note finite
   256   moreover assume z: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
   257   ultimately show "z \<le> Inf A" by (induct A) simp_all
   258 next
   259   fix x :: "'a sat"
   260   fix A :: "'a sat set"
   261   note finite
   262   moreover assume "x \<in> A"
   263   ultimately show "x \<le> Sup A"
   264     by (induct A) (auto intro: max.coboundedI2)
   265 next
   266   fix z :: "'a sat"
   267   fix A :: "'a sat set"
   268   note finite
   269   moreover assume z: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
   270   ultimately show "Sup A \<le> z" by (induct A) auto
   271 next
   272   show "Inf {} = (top::'a sat)"
   273     by (auto simp: top_sat_def)
   274 next
   275   show "Sup {} = (bot::'a sat)"
   276     by (auto simp: bot_sat_def)
   277 qed
   278 
   279 end
   280