(*  Title:      IPv4.thy
    Authors:    Cornelius Diekmann, Julius Michaelis
*)
theory IPv4
imports IP_Address
        NumberWang_IPv4
        (* include "~~/src/HOL/Library/Code_Target_Nat" if you need to work with actual numbers.*)
begin

section \<open>IPv4 Adresses\<close>
  text\<open>An IPv4 address is basically a 32 bit unsigned integer.\<close>
  type_synonym ipv4addr = "32 word"

  text\<open>Conversion between natural numbers and IPv4 adresses\<close>
  definition nat_of_ipv4addr :: "ipv4addr \<Rightarrow> nat" where
    "nat_of_ipv4addr a = unat a"
  definition ipv4addr_of_nat :: "nat \<Rightarrow> ipv4addr" where
    "ipv4addr_of_nat n =  of_nat n"

  text\<open>The maximum IPv4 addres\<close>
  definition max_ipv4_addr :: "ipv4addr" where
    "max_ipv4_addr \<equiv> ipv4addr_of_nat ((2^32) - 1)"

  lemma max_ipv4_addr_number: "max_ipv4_addr = 4294967295"
    unfolding max_ipv4_addr_def ipv4addr_of_nat_def by(simp)
  lemma "max_ipv4_addr = 0b11111111111111111111111111111111"
    by(fact max_ipv4_addr_number)
  lemma max_ipv4_addr_max_word: "max_ipv4_addr = max_word"
    by(simp add: max_ipv4_addr_number max_word_def)
  lemma max_ipv4_addr_max[simp]: "\<forall>a. a \<le> max_ipv4_addr"
    by(simp add: max_ipv4_addr_max_word)
  lemma UNIV_ipv4addrset: "UNIV = {0 .. max_ipv4_addr}" (*not in the simp set, for a reason*)
    by(simp add: max_ipv4_addr_max_word) fastforce

  text\<open>identity functions\<close>
  lemma nat_of_ipv4addr_ipv4addr_of_nat:
    "\<lbrakk> n \<le> nat_of_ipv4addr max_ipv4_addr \<rbrakk> \<Longrightarrow> nat_of_ipv4addr (ipv4addr_of_nat n) = n"
    by (simp add: ipv4addr_of_nat_def le_unat_uoi nat_of_ipv4addr_def)
  lemma nat_of_ipv4addr_ipv4addr_of_nat_mod: "nat_of_ipv4addr (ipv4addr_of_nat n) = n mod 2^32"
    by(simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def unat_of_nat)
  lemma ipv4addr_of_nat_nat_of_ipv4addr: "ipv4addr_of_nat (nat_of_ipv4addr addr) = addr"
    by(simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def)

subsection\<open>Representing IPv4 Adresses (Syntax)\<close>
  fun ipv4addr_of_dotdecimal :: "nat \<times> nat \<times> nat \<times> nat \<Rightarrow> ipv4addr" where
    "ipv4addr_of_dotdecimal (a,b,c,d) = ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a )"

  fun dotdecimal_of_ipv4addr :: "ipv4addr \<Rightarrow> nat \<times> nat \<times> nat \<times> nat" where
    "dotdecimal_of_ipv4addr a = (nat_of_ipv4addr ((a >> 24) AND 0xFF),
                                    nat_of_ipv4addr ((a >> 16) AND 0xFF),
                                    nat_of_ipv4addr ((a >> 8) AND 0xFF),
                                    nat_of_ipv4addr (a AND 0xff))"

  declare ipv4addr_of_dotdecimal.simps[simp del]
  declare dotdecimal_of_ipv4addr.simps[simp del]

  text\<open>Examples:\<close>
  lemma "ipv4addr_of_dotdecimal (192, 168, 0, 1) = 3232235521"
    by(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)
    (*could be solved by eval, but needs "~~/src/HOL/Library/Code_Target_Nat"*)
  lemma "dotdecimal_of_ipv4addr 3232235521 = (192, 168, 0, 1)"
    by(simp add: dotdecimal_of_ipv4addr.simps nat_of_ipv4addr_def)

  text\<open>a different notation for @{term ipv4addr_of_dotdecimal}\<close>
  lemma ipv4addr_of_dotdecimal_bit:
    "ipv4addr_of_dotdecimal (a,b,c,d) =
      (ipv4addr_of_nat a << 24) + (ipv4addr_of_nat b << 16) +
       (ipv4addr_of_nat c << 8) + ipv4addr_of_nat d"
  proof -
    have a: "(ipv4addr_of_nat a) << 24 = ipv4addr_of_nat (a * 16777216)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n)
    have b: "(ipv4addr_of_nat b) << 16 = ipv4addr_of_nat (b * 65536)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n)
    have c: "(ipv4addr_of_nat c) << 8 = ipv4addr_of_nat (c * 256)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n)
    have ipv4addr_of_nat_suc: "\<And>x. ipv4addr_of_nat (Suc x) = word_succ (ipv4addr_of_nat (x))"
      by(simp add: ipv4addr_of_nat_def, metis Abs_fnat_hom_Suc of_nat_Suc)
    { fix x y
      have "ipv4addr_of_nat x + ipv4addr_of_nat y = ipv4addr_of_nat (x+y)"
        apply(induction x arbitrary: y)
         apply(simp add: ipv4addr_of_nat_def; fail)
        by(simp add: ipv4addr_of_nat_suc word_succ_p1)
    } from this a b c
    show ?thesis
      apply(simp add: ipv4addr_of_dotdecimal.simps)
      apply(rule arg_cong[where f=ipv4addr_of_nat])
      apply(thin_tac _)+
      by presburger
  qed

  lemma size_ipv4addr: "size (x::ipv4addr) = 32" by(simp add:word_size)

  lemma dotdecimal_of_ipv4addr_ipv4addr_of_dotdecimal:
  "\<lbrakk> a < 256; b < 256; c < 256; d < 256 \<rbrakk> \<Longrightarrow>
    dotdecimal_of_ipv4addr (ipv4addr_of_dotdecimal (a,b,c,d)) = (a,b,c,d)"
  proof -
    assume  "a < 256" and "b < 256" and "c < 256" and "d < 256"
    note assms= \<open>a < 256\<close> \<open>b < 256\<close> \<open>c < 256\<close> \<open>d < 256\<close>
    hence a:  "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 24) AND mask 8) = a"
      apply(simp add: ipv4addr_of_nat_def word_of_nat)
      apply(simp add: nat_of_ipv4addr_def unat_def)
      apply(simp add: and_mask_mod_2p)
      apply(simp add: shiftr_div_2n)
      apply(simp add: uint_word_of_int)
      apply(subst mod_pos_pos_trivial)
        apply(simp; fail)
       apply(simp; fail)
      apply(simp)
      apply(subst mod_pos_pos_trivial)
        apply(simp; fail)
       apply(simp; fail)
      apply(subst mod_pos_pos_trivial)
        by simp+
    have ipv4addr_of_nat_AND_mask8: "(ipv4addr_of_nat a) AND mask 8 = (ipv4addr_of_nat (a mod 256))"
      for a
      apply(simp add: ipv4addr_of_nat_def and_mask_mod_2p)
      apply(simp add: word_of_nat) (*use this to get rid of of_nat. All thm are with word_of_int*)
      apply(simp add: uint_word_of_int)
      apply(subst mod_mod_cancel)
       apply(simp; fail)
      apply(simp add: zmod_int)
      done
    from assms have b:
      "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 16) AND mask 8) = b"
      apply(simp add: ipv4addr_of_nat_def word_of_nat)
      apply(simp add: nat_of_ipv4addr_def unat_def)
      apply(simp add: and_mask_mod_2p)
      apply(simp add: shiftr_div_2n)
      apply(simp add: uint_word_of_int)
      apply(subst mod_pos_pos_trivial)
        apply(simp; fail)
       apply(simp; fail)
      apply(subst mod_pos_pos_trivial[where b="4294967296"])
        apply(simp; fail)
       apply(simp; fail)
      apply(simp add: NumberWang_IPv4.div65536[simplified])
      (*The [simplified] is needed because Word_Lib adds some additional simp rules*)
      done
      --\<open>When @{file "../Word_Lib/Word_Lemmas.thy"} is imported,
         some @{file "Word_More.thy"} and @{file "NumberWang_IPv4.thy"} lemmas need the
         [simplified] attribute because @{text Word_Lib} adds some simp rules.
         This theory should also work without @{file "../Word_Lib/Word_Lemmas.thy"}\<close>
    from assms have c:
      "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 8) AND mask 8) = c"
      apply(simp add: ipv4addr_of_nat_def word_of_nat)
      apply(simp add: nat_of_ipv4addr_def unat_def)
      apply(simp add: and_mask_mod_2p)
      apply(simp add: shiftr_div_2n)
      apply(simp add: uint_word_of_int)
      apply(subst mod_pos_pos_trivial)
        apply(simp; fail)
       apply(simp; fail)
      apply(subst mod_pos_pos_trivial[where b="4294967296"])
        apply(simp; fail)
       apply(simp; fail)
      apply(simp add: NumberWang_IPv4.div256[simplified])
      done
    from \<open>d < 256\<close> have d: "nat_of_ipv4addr (ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) AND mask 8) = d"
      apply(simp add: ipv4addr_of_nat_AND_mask8)
      apply(simp add: ipv4addr_of_nat_def word_of_nat)
      apply(simp add: nat_of_ipv4addr_def)
      apply(subgoal_tac "(d + 256 * c + 65536 * b + 16777216 * a) mod 256 = d")
       apply(simp add: unat_def uint_word_of_int mod_pos_pos_trivial; fail)
      apply(simp add: NumberWang_IPv4.mod256)
      done
    from a b c d show ?thesis
      apply(simp add: ipv4addr_of_dotdecimal.simps dotdecimal_of_ipv4addr.simps)
      apply(simp add: mask_def)
      done
  qed

  lemma ipv4addr_of_dotdecimal_dotdecimal_of_ipv4addr:
    "(ipv4addr_of_dotdecimal (dotdecimal_of_ipv4addr ip)) = ip"
  proof -
    have ip_and_mask8_bl_drop24: "(ip::ipv4addr) AND mask 8 = of_bl (drop 24 (to_bl ip))"
      by(simp add: Word_Lemmas.of_drop_to_bl size_ipv4addr)
    have List_rev_drop_geqn: "length x \<ge> n \<Longrightarrow> (take n (rev x)) = rev (drop (length x - n) x)"
      for x :: "'a list" and n by(simp add: List.rev_drop)
    have and_mask_bl_take: "length x \<ge> n \<Longrightarrow> ((of_bl x) AND mask n) = (of_bl (rev (take n (rev (x)))))"
      for x n by(simp add: List_rev_drop_geqn of_bl_drop)
    have ipv4addr_and_255: "x AND 255 = x AND mask 8" for x :: ipv4addr
      by(simp add: mask_def)
    have bit_equality:
      "((ip >> 24) AND 0xFF << 24) + ((ip >> 16) AND 0xFF << 16) + ((ip >> 8) AND 0xFF << 8) + (ip AND 0xFF) =
       of_bl (take 8 (to_bl ip) @ take 8 (drop 8 (to_bl ip)) @ take 8 (drop 16 (to_bl ip)) @ drop 24 (to_bl ip))"
      apply(simp add: ipv4addr_and_255)
      apply(simp add: shiftr_slice)
      apply(simp add: Word.slice_take' size_ipv4addr)
      apply(simp add: and_mask_bl_take)
      apply(simp add: List_rev_drop_geqn)
      apply(simp add: drop_take)
      apply(simp add: Word.shiftl_of_bl)
      apply(simp add: of_bl_append)
      apply(simp add: ip_and_mask8_bl_drop24)
      done
    have blip_split: "\<And> blip. length blip = 32 \<Longrightarrow>
      blip = (take 8 blip) @ (take 8 (drop 8 blip)) @ (take 8 (drop 16 blip)) @ (take 8 (drop 24 blip))"
      by(rename_tac blip,case_tac blip,simp_all)+ (*I'm so sorry for this ...*)
    have "ipv4addr_of_dotdecimal (dotdecimal_of_ipv4addr ip) = of_bl (to_bl ip)"
      apply(subst blip_split)
       apply(simp; fail)
      apply(simp add: ipv4addr_of_dotdecimal_bit dotdecimal_of_ipv4addr.simps)
      apply(simp add: ipv4addr_of_nat_nat_of_ipv4addr)
      apply(simp add: bit_equality)
      done
    thus ?thesis using Word.word_bl.Rep_inverse[symmetric] by simp
  qed

  lemma ipv4addr_of_dotdecimal_eqE:
    "\<lbrakk> ipv4addr_of_dotdecimal (a,b,c,d) = ipv4addr_of_dotdecimal (e,f,g,h);
       a < 256; b < 256; c < 256; d < 256; e < 256; f < 256; g < 256; h < 256 \<rbrakk> \<Longrightarrow>
         a = e \<and> b = f \<and> c = g \<and> d = h"
     by (metis Pair_inject dotdecimal_of_ipv4addr_ipv4addr_of_dotdecimal)

subsection\<open>IP Ranges: Examples\<close>
  lemma "(UNIV :: ipv4addr set) = {0 .. max_ipv4_addr}" by(simp add: UNIV_ipv4addrset)
  lemma "(42::ipv4addr) \<in> UNIV" by(simp)

  (*Warning, not executable!*)

  lemma "ipset_from_netmask (ipv4addr_of_dotdecimal (192,168,0,42)) (ipv4addr_of_dotdecimal (255,255,0,0)) =
          {ipv4addr_of_dotdecimal (192,168,0,0) .. ipv4addr_of_dotdecimal (192,168,255,255)}"
   by(simp add: ipset_from_netmask_def ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)

  lemma "ipset_from_netmask (ipv4addr_of_dotdecimal (192,168,0,42)) (ipv4addr_of_dotdecimal (0,0,0,0)) = UNIV"
    by(simp add: UNIV_ipv4addrset ipset_from_netmask_def ipv4addr_of_dotdecimal.simps
                 ipv4addr_of_nat_def max_ipv4_addr_max_word)

  text\<open>192.168.0.0/24\<close>

  lemma fixes addr :: ipv4addr
    shows "ipset_from_cidr addr pflength =
            ipset_from_netmask addr ((mask pflength) << (32 - pflength))"
    by(simp add: ipset_from_cidr_def)

  lemma "ipset_from_cidr (ipv4addr_of_dotdecimal (192,168,0,42)) 16 =
          {ipv4addr_of_dotdecimal (192,168,0,0) .. ipv4addr_of_dotdecimal (192,168,255,255)}"
   by(simp add: ipset_from_cidr_alt mask_def  ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)

  lemma "ip \<in> (ipset_from_cidr (ipv4addr_of_dotdecimal (0, 0, 0, 0)) 0)"
    by(simp add: ipset_from_cidr_0)

  lemma ipv4set_from_cidr_32: fixes addr :: ipv4addr
    shows "ipset_from_cidr addr 32 = {addr}"
    by(simp add: ipset_from_cidr_alt mask_def)

  lemma  fixes pre :: ipv4addr
    shows "ipset_from_cidr pre len = {(pre AND ((mask len) << (32 - len))) .. pre OR (mask (32 - len))}"
    by (simp add: ipset_from_cidr_alt ipset_from_cidr_def)

  text\<open>making element check executable\<close>
  lemma addr_in_ipv4set_from_netmask_code[code_unfold]:
    fixes addr :: ipv4addr
    shows "addr \<in> (ipset_from_netmask base netmask) \<longleftrightarrow>
            (base AND netmask) \<le> addr \<and> addr \<le> (base AND netmask) OR (NOT netmask)"
    by (simp add: addr_in_ipset_from_netmask_code)
  lemma addr_in_ipv4set_from_cidr_code[code_unfold]:
    fixes addr :: ipv4addr
    shows "addr \<in> (ipset_from_cidr pre len) \<longleftrightarrow>
              (pre AND ((mask len) << (32 - len))) \<le> addr \<and> addr \<le> pre OR (mask (32 - len))"
    by(simp add: addr_in_ipset_from_cidr_code)

  (*small numbers because we didn't load Code_Target_Nat. Should work by eval*)
  lemma "ipv4addr_of_dotdecimal (192,168,42,8) \<in> (ipset_from_cidr (ipv4addr_of_dotdecimal (192,168,0,0)) 16)"
    by(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def ipset_from_cidr_def
                    ipset_from_netmask_def mask_def)

  definition ipv4range_UNIV :: "32 wordinterval" where "ipv4range_UNIV \<equiv> wordinterval_UNIV"

  lemma ipv4range_UNIV_set_eq: "wordinterval_to_set ipv4range_UNIV = UNIV"
    by(simp only: ipv4range_UNIV_def wordinterval_UNIV_set_eq)

  thm iffD1[OF wordinterval_eq_set_eq]
  (*TODO: probably the following is a good idea?*)
  (*
  declare iffD1[OF wordinterval_eq_set_eq, cong]
  *)

  text\<open>This @{text "len_of TYPE('a)"} is 32 for IPv4 addresses.\<close>
  lemma ipv4cidr_to_interval_simps[code_unfold]: "ipcidr_to_interval ((pre::ipv4addr), len) = (
      let netmask = (mask len) << (32 - len);
          network_prefix = (pre AND netmask)
      in (network_prefix, network_prefix OR (NOT netmask)))"
  by(simp add: ipcidr_to_interval_def Let_def ipcidr_to_interval_start.simps ipcidr_to_interval_end.simps)

end


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

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

datatype Nat = Z | S "Nat"

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(Nat list) list => (Nat list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu :: "(Nat list) list => Nat list" where
  "mergingbu (nil2) = nil2"
| "mergingbu (cons2 xs (nil2)) = xs"
| "mergingbu (cons2 xs (cons2 z x2)) =
     mergingbu (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu :: "Nat list => Nat list" where
  "msortbu x = mergingbu (map (% (y :: Nat) => cons2 y (nil2)) x)"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((le y y2) & (ordered (cons2 y2 xs)))"

theorem property0 :
  "ordered (msortbu xs)"
  oops

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_66
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter x (nil2) = nil2"
| "filter x (cons2 z xs) =
     (if x z then cons2 z (filter x xs) else filter x xs)"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) y = True"
| "t2 (S z) (Z) = False"
| "t2 (S z) (S x2) = t2 z x2"

theorem property0 :
  "t2 (len (filter p xs)) (len xs)"
  oops

theorem property0' :
  "t2 (len (filter p xs)) (len xs)"
  apply(induct rule:t2.induct)
    apply fastforce
  nitpick
  oops

end


section \<open>Preparations\<close>

theory TM_Common
  imports
    "HOL-Library.FuncSet"
begin

text \<open>A direction of a TM: go right, go left, or neutral (stay)\<close>
datatype dir = R | L | N

fun go_dir :: "dir \<Rightarrow> nat \<Rightarrow> nat" where
  "go_dir R n = Suc n"
| "go_dir L n = n - 1"
| "go_dir N n = n"

lemma finite_UNIV_dir[simp, intro]: "finite (UNIV :: dir set)"
proof -
  have id: "UNIV = {L,R,N}"
    using dir.exhaust by auto
  show ?thesis unfolding id by auto
qed

hide_const (open) L R N

lemma fin_funcsetI[intro]: "finite A \<Longrightarrow> finite ((UNIV :: 'a :: finite set) \<rightarrow> A)"
  by (metis PiE_UNIV_domain finite_PiE finite_code)

lemma finite_UNIV_fun_dir[simp,intro]: "finite (UNIV :: ('k :: finite \<Rightarrow> dir) set)"
  using fin_funcsetI[OF finite_UNIV_dir] by auto

lemma relpow_transI: "(x,y) \<in> R^^n \<Longrightarrow> (y,z) \<in> R^^m \<Longrightarrow> (x,z) \<in> R^^(n+m)"
  by (simp add: relcomp.intros relpow_add)

lemma relpow_mono: fixes R :: "'a rel" shows "R \<subseteq> S \<Longrightarrow> R^^n \<subseteq> S^^n"
  by (induct n, auto)

lemma finite_infinite_inj_on: assumes A: "finite (A :: 'a set)" and inf: "infinite (UNIV :: 'b set)"
  shows "\<exists> f :: 'a \<Rightarrow> 'b. inj_on f A"
proof -
  from inf obtain B :: "'b set" where B: "finite B" "card B = card A"
    by (meson infinite_arbitrarily_large)
  from A B obtain f :: "'a \<Rightarrow> 'b" where "bij_betw f A B"
    by (metis bij_betw_iff_card)
  thus ?thesis by (intro exI[of _ f], auto simp: bij_betw_def)
qed

lemma gauss_sum_nat2: "(\<Sum>i< (n :: nat). i) = (n - 1) * n div 2"
proof (cases n)
  case (Suc m)
  hence id: "{..<n} = {0..m}" by auto
  show ?thesis unfolding id unfolding gauss_sum_nat unfolding Suc by auto
qed auto

lemma aux_sum_formula: "(\<Sum>i<n. 10 + 5 * i) \<le> 3 * n^2 + 7 * (n :: nat)"
proof -
  have "(\<Sum>i<n. 10 + 5 * i) = 10 * n + 5 * (\<Sum>i<n. i)"
    by (subst sum.distrib, auto simp: sum_distrib_left)
  also have "\<dots> \<le> 10 * n + 3 * ((n - 1) * n)"
    by (unfold gauss_sum_nat2, rule add_left_mono, cases n, auto)
  also have "\<dots> = 3 * n^2 + 7 * n"
    unfolding power2_eq_square by (cases n, auto)
  finally show ?thesis .
qed

end


section \<open>The OneThirdRule Algorithm\<close>

theory OneThirdRule_Defs
imports Heard_Of.HOModel "../Consensus_Types"
begin

text \<open>The contents of this file have been taken almost verbatim from the
  Heard Of Model AFP entry. The only difference is that the types have been
  changed.\<close>

subsection \<open>Model of the algorithm\<close>

text \<open>
  The state of each process consists of two fields: \<open>last_vote\<close> holds
  the current value proposed by the process and \<open>decision\<close> the
  value (if any, hence the option type) it has decided.
\<close>

record 'val pstate =
  last_vote :: "'val"
  decision :: "'val option"

text \<open>
  The initial value of field \<open>last_vote\<close> is unconstrained, but no decision
  has been taken initially.
\<close>

definition OTR_initState where
  "OTR_initState p st \<equiv> decision st = None"

text \<open>
  Given a vector \<open>msgs\<close> of values (possibly null) received from
  each process, @{term "HOV msgs v"} denotes the set of processes from
  which value \<open>v\<close> was received.
\<close>

definition HOV :: "(process \<Rightarrow> 'val option) \<Rightarrow> 'val \<Rightarrow> process set" where
  "HOV msgs v \<equiv> { q . msgs q = Some v }"

text \<open>
  @{term "MFR msgs v"} (``most frequently received'') holds for
  vector \<open>msgs\<close> if no value has been received more frequently
  than \<open>v\<close>.

  Some such value always exists, since there is only a finite set of
  processes and thus a finite set of possible cardinalities of the
  sets @{term "HOV msgs v"}.
\<close>

definition MFR :: "(process \<Rightarrow> 'val option) \<Rightarrow> 'val \<Rightarrow> bool" where
  "MFR msgs v \<equiv> \<forall>w. card (HOV msgs w) \<le> card (HOV msgs v)"

lemma MFR_exists: "\<exists>v. MFR msgs v"
proof -
  let ?cards = "{ card (HOV msgs v) | v . True }"
  let ?mfr = "Max ?cards"
  have "\<forall>v. card (HOV msgs v) \<le> N" by (auto intro: card_mono)
  hence "?cards \<subseteq> { 0 .. N }" by auto
  hence fin: "finite ?cards" by (metis atLeast0AtMost finite_atMost finite_subset)
  hence "?mfr \<in> ?cards" by (rule Max_in) auto
  then obtain v where v: "?mfr = card (HOV msgs v)" by auto
  have "MFR msgs v"
  proof (auto simp: MFR_def)
    fix w
    from fin have "card (HOV msgs w) \<le> ?mfr" by (rule Max_ge) auto
    thus "card (HOV msgs w) \<le> card (HOV msgs v)" by (unfold v)
  qed
  thus ?thesis ..
qed

text \<open>
  Also, if a process has heard from at least one other process,
  the most frequently received values are among the received messages.
\<close>

lemma MFR_in_msgs:
  assumes HO:"HOs m p \<noteq> {}"
      and v: "MFR (HOrcvdMsgs OTR_M m p (HOs m p) (rho m)) v"
             (is "MFR ?msgs v")
  shows "\<exists>q \<in> HOs m p. v = the (?msgs q)"
proof -
  from HO obtain q where q: "q \<in> HOs m p"
    by auto
  with v have "HOV ?msgs (the (?msgs q)) \<noteq> {}"
    by (auto simp: HOV_def HOrcvdMsgs_def)
  hence HOp: "0 < card (HOV ?msgs (the (?msgs q)))"
    by auto
  also from v have "\<dots> \<le> card (HOV ?msgs v)"
    by (simp add: MFR_def)
  finally have "HOV ?msgs v \<noteq> {}"
    by auto
  thus ?thesis
    by (auto simp: HOV_def HOrcvdMsgs_def)
qed

text \<open>
  @{term "TwoThirds msgs v"} holds if value \<open>v\<close> has been
  received from more than $2/3$ of all processes.
\<close>

definition TwoThirds where
  "TwoThirds msgs v \<equiv> (2*N) div 3 < card (HOV msgs v)"

text \<open>
  The next-state relation of algorithm \emph{One-Third Rule} for every process
  is defined as follows:
  if the process has received values from more than $2/3$ of all processes,
  the \<open>last_vote\<close> field is set to the smallest among the most frequently received
  values, and the process decides value $v$ if it received $v$ from more than
  $2/3$ of all processes. If \<open>p\<close> hasn't heard from more than $2/3$ of
  all processes, the state remains unchanged.
  (Note that \<open>Some\<close> is the constructor of the option datatype, whereas
  \<open>\<some>\<close> is Hilbert's choice operator.)
  We require the type of values to be linearly ordered so that the minimum
  is guaranteed to be well-defined.
\<close>

definition OTR_nextState where
  "OTR_nextState r p (st::('val::linorder) pstate) msgs st' \<equiv>
   if (2*N) div 3 < card {q. msgs q \<noteq> None}
   then st' = \<lparr> last_vote = Min {v . MFR msgs v},
          decision = (if (\<exists>v. TwoThirds msgs v)
                    then Some (\<some>v. TwoThirds msgs v)
                    else decision st) \<rparr>
   else st' = st"

text \<open>
  The message sending function is very simple: at every round, every process
  sends its current proposal (field \<open>last_vote\<close> of its local state) to all
  processes.
\<close>

definition OTR_sendMsg where
  "OTR_sendMsg r p q st \<equiv> last_vote st"

subsection \<open>Communication predicate for \emph{One-Third Rule}\<close>

text \<open>
  We now define the communication predicate for the \emph{One-Third Rule}
  algorithm to be correct.
  It requires that, infinitely often, there is a round where all processes
  receive messages from the same set \<open>\<Pi>\<close> of processes where \<open>\<Pi>\<close>
  contains more than two thirds of all processes.
  The ``per-round'' part of the communication predicate is trivial.
\<close>

definition OTR_commPerRd where
  "OTR_commPerRd HOrs \<equiv> True"

definition OTR_commGlobal where
  "OTR_commGlobal HOs \<equiv>
    \<forall>r. \<exists>r0 \<Pi>. r0 \<ge> r \<and> (\<forall>p. HOs r0 p = \<Pi>) \<and> card \<Pi> > (2*N) div 3"

subsection \<open>The \emph{One-Third Rule} Heard-Of machine\<close>

text \<open>
  We now define the HO machine for the \emph{One-Third Rule} algorithm
  by assembling the algorithm definition and its communication-predicate.
  Because this is an uncoordinated algorithm, the \<open>crd\<close> arguments
  of the initial- and next-state predicates are unused.
\<close>

definition OTR_HOMachine where
  "OTR_HOMachine =
    \<lparr> CinitState =  (\<lambda> p st crd. OTR_initState p st),
     sendMsg =  OTR_sendMsg,
     CnextState = (\<lambda> r p st msgs crd st'. OTR_nextState r p st msgs st'),
     HOcommPerRd = OTR_commPerRd,
     HOcommGlobal = OTR_commGlobal \<rparr>"

abbreviation "OTR_M \<equiv> OTR_HOMachine::(process, 'val::linorder pstate, 'val) HOMachine"

end


section \<open> Fixed-points and Recursion \<close>

theory utp_recursion
  imports utp_pred_laws
begin

subsection \<open> Syntax \<close>

syntax
  "_utp_mu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<mu> _ \<bullet> _" [0, 10] 10)
  "_utp_nu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<nu> _ \<bullet> _" [0, 10] 10)

notation lfp ("\<nu>")
notation gfp ("\<mu>")

translations
  "\<nu> X \<bullet> P" == "CONST lfp (\<lambda> X. P)"
  "\<mu> X \<bullet> P" == "CONST gfp (\<lambda> X. P)"

text \<open> The mu and nu operators correspond to the greatest and least fixed-points of the refinement lattice. \<close>

lemma lfp_is_ref_gfp: "lfp = ref_lattice.gfp"
  by (simp add: lfp_def ref_lattice.gfp_def fun_eq_iff pred_ref_iff_le)

lemma gfp_is_ref_lfp: "gfp = ref_lattice.lfp"
  by (simp add: gfp_def ref_lattice.lfp_def fun_eq_iff pred_ref_iff_le)

subsection \<open> Fixed-point Laws \<close>

lemma mu_id: "(\<mu> X \<bullet> X) = true"
  by (simp add: gfp_eqI mono_def predicate1I true_pred_def)

lemma mu_const: "(\<mu> X \<bullet> P) = P"
  by (simp add: gfp_const)

lemma nu_id: "(\<nu> X \<bullet> X) = false"
  by (simp add: SEXP_def antisym false_pred_def lfp_lowerbound predicate1I)

lemma nu_const: "(\<nu> X \<bullet> P) = P"
  by (simp add: lfp_const)

lemma mu_refine_intro:
  fixes C :: "'s pred"
  assumes "(C \<longrightarrow> S) \<sqsubseteq> F(C \<longrightarrow> S)" "(C \<and> \<mu> F) = (C \<and> \<nu> F)"
  shows "(C \<longrightarrow> S) \<sqsubseteq> \<mu> F"
proof -
  from assms have "(C \<longrightarrow> S) \<sqsubseteq> \<nu> F"
    using lfp_lowerbound by (auto simp add: pred_ref_iff_le)
  with assms show ?thesis
    by (pred_auto)
qed

subsection \<open> Obtaining Unique Fixed-points \<close>

text \<open> Obtaining termination proofs via approximation chains. Theorems and proofs adapted
  from Chapter 2, page 63 of the UTP book~\cite{Hoare&98}.  \<close>

type_synonym 'a chain = "nat \<Rightarrow> 'a pred"

definition chain :: "'a chain \<Rightarrow> bool" where
  "chain Y = ((Y 0 = false) \<and> (\<forall> i. Y (Suc i) \<sqsubseteq> Y i))"

lemma chain0 [simp]: "chain Y \<Longrightarrow> Y 0 = false"
  by (simp add:chain_def)

lemma chainI:
  assumes "Y 0 = false" "\<And> i. Y (Suc i) \<sqsubseteq> Y i"
  shows "chain Y"
  using assms by (auto simp add: chain_def)

lemma chainE:
  assumes "chain Y" "\<And> i. \<lbrakk> Y 0 = false; Y (Suc i) \<sqsubseteq> Y i \<rbrakk> \<Longrightarrow> P"
  shows "P"
  using assms by (simp add: chain_def)

lemma L274:
  fixes X :: "'s pred"
  assumes "\<forall> n. ((E n \<and> X) = (E n \<and> Y))"
  shows "(\<Sqinter> (range E) \<and> X) = (\<Sqinter> (range E) \<and> Y)"
  using assms by (pred_auto)

text \<open> Constructive chains \<close>

definition constr ::
  "('a pred \<Rightarrow> 'a pred) \<Rightarrow> 'a chain \<Rightarrow> bool" where
"constr F E \<longleftrightarrow> chain E \<and> (\<forall> X n. ((F(X) \<and> E(n + 1)) = (F(X \<and> E(n)) \<and> E (n + 1))))"

lemma constrI:
  assumes "chain E" "\<And> X n. ((F(X) \<and> E(n + 1)) = (F(X \<and> E(n)) \<and> E (n + 1)))"
  shows "constr F E"
  using assms by (auto simp add: constr_def)

text \<open> This lemma gives a way of showing that there is a unique fixed-point when
        the predicate function can be built using a constructive function F
        over an approximation chain E \<close>

lemma chain_pred_terminates:
  assumes "constr F E" "mono F"
  shows "(\<Sqinter> (range E) \<and> \<mu> F) = (\<Sqinter> (range E) \<and> \<nu> F)"
proof -
  from assms have "\<forall> n. (E n \<and> \<mu> F) = (E n \<and> \<nu> F)"
  proof (rule_tac allI)
    fix n
    from assms show "(E n \<and> \<mu> F) = (E n \<and> \<nu> F)"
    proof (induct n)
      case 0 thus ?case by (simp add: constr_def)
    next
      case (Suc n)
      note hyp = this
      thus ?case
      proof -
        have "(E (n + 1) \<and> \<mu> F) = (E (n + 1) \<and> F (\<mu> F))"
          using gfp_unfold[OF hyp(3), THEN sym] by (simp add: constr_def)
        also from hyp have "... = (E (n + 1) \<and> F (E n \<and> \<mu> F))"
          by (metis constr_def pred_ba.inf.commute)
        also from hyp have "... = (E (n + 1) \<and> F (E n \<and> \<nu> F))"
          by simp
        also from hyp have "... = (E (n + 1) \<and> \<nu> F)"
          by (metis (no_types, lifting) constr_def lfp_fixpoint pred_ba.inf_commute)
        ultimately show ?thesis
          by simp
      qed
    qed
  qed
  thus ?thesis
    using L274 by blast
qed

theorem constr_fp_uniq:
  assumes "constr F E" "mono F" "\<Sqinter> (range E) = C"
  shows "(C \<and> \<mu> F) = (C \<and> \<nu> F)"
  using assms chain_pred_terminates by blast

subsection \<open> Noetherian Induction Instantiation\<close>

text \<open> Contribution from Yakoub Nemouchi.The following generalization was used by Tobias Nipkow
        and Peter Lammich  in \emph{Refine\_Monadic} \<close>

lemma  wf_fixp_uinduct_pure_ueq_gen:
  assumes fixp_unfold: "fp B = B (fp B)"
  and              WF: "wf R"
  and     induct_step:
          "\<And>f st. \<lbrakk>\<And>st'. (st',st) \<in> R  \<Longrightarrow> (((p \<and> e\<^sup>< = \<guillemotleft>st'\<guillemotright>) \<longrightarrow> q)\<^sub>e \<sqsubseteq> f)\<rbrakk>
               \<Longrightarrow> fp B = f \<Longrightarrow>((p \<and> e\<^sup>< = \<guillemotleft>st\<guillemotright>) \<longrightarrow> q)\<^sub>e \<sqsubseteq> (B f)"
        shows "((p \<longrightarrow> q)\<^sub>e \<sqsubseteq> fp B)"
proof -
  { fix st
    have "((p \<and> e\<^sup>< = \<guillemotleft>st\<guillemotright>) \<longrightarrow> q)\<^sub>e \<sqsubseteq> (fp B)"
    using WF proof (induction rule: wf_induct_rule)
      case (less x)
      hence "(p \<and> e\<^sup>< = \<guillemotleft>x\<guillemotright> \<longrightarrow> q)\<^sub>e \<sqsubseteq> B (fp B)"
        by (rule induct_step, auto)
      then show ?case
        using fixp_unfold by metis
    qed
  }
  thus ?thesis
    by (simp add: pred_refine_iff)
qed

text \<open> The next lemma shows that using substitution also work. However it is not that generic
        nor practical for proof automation ... \<close>

lemma refine_usubst_to_ueq:
  "vwb_lens E \<Longrightarrow> (p \<longrightarrow> q)\<^sub>e\<lbrakk>\<guillemotleft>st'\<guillemotright>/E\<rbrakk> \<sqsubseteq> f\<lbrakk>\<guillemotleft>st'\<guillemotright>/E\<rbrakk> = (((p \<and> $E = \<guillemotleft>st'\<guillemotright>) \<longrightarrow> q)\<^sub>e \<sqsubseteq> f)"
  oops

text \<open> By instantiation of @{thm wf_fixp_uinduct_pure_ueq_gen} with @{term \<mu>} and lifting of the
        well-founded relation we have ... \<close>

lemma mu_rec_total_pure_rule:
  assumes WF: "wf R"
  and     M: "mono B"
  and     induct_step:
          "\<And> f st.  \<lbrakk>(p \<and> (e\<^sup><,\<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright> \<longrightarrow> q)\<^sub>e \<sqsubseteq> f\<rbrakk>
               \<Longrightarrow> \<mu> B = f \<Longrightarrow> (p \<and> e\<^sup>< = \<guillemotleft>st\<guillemotright> \<longrightarrow> q)\<^sub>e \<sqsubseteq> (B f)"
        shows "(p \<longrightarrow> q)\<^sub>e \<sqsubseteq> \<mu> B"
proof (rule wf_fixp_uinduct_pure_ueq_gen[where fp=\<mu> and p=p and B=B and R=R and e=e])
  show "\<mu> B = B (\<mu> B)"
    by (simp add: M def_gfp_unfold)
  show "wf R"
    by (fact WF)
  show "\<And>f st. (\<And>st'. (st', st) \<in> R \<Longrightarrow> (p \<and> e\<^sup>< = \<guillemotleft>st'\<guillemotright> \<longrightarrow> q)\<^sub>e \<sqsubseteq> f) \<Longrightarrow>
                \<mu> B = f \<Longrightarrow>
                (p \<and> e\<^sup>< = \<guillemotleft>st\<guillemotright> \<longrightarrow> q)\<^sub>e \<sqsubseteq> B f"
    apply (rule induct_step) oops

lemma nu_rec_total_pure_rule:
  assumes WF: "wf R"
  and     M: "mono B"
  and     induct_step:
          "\<And> f st.  \<lbrakk>(p \<and> (e\<^sup><,\<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright> \<longrightarrow> q)\<^sub>e \<sqsubseteq> f\<rbrakk>
               \<Longrightarrow> \<nu> B = f \<Longrightarrow> (p \<and> e\<^sup>< = \<guillemotleft>st\<guillemotright> \<longrightarrow> q)\<^sub>e \<sqsubseteq> (B f)"
        shows "(p \<longrightarrow> q)\<^sub>e \<sqsubseteq> \<nu> B"
proof (rule wf_fixp_uinduct_pure_ueq_gen[where fp=\<nu> and p=p and B=B and R=R and e=e])
  show "\<nu> B = B (\<nu> B)"
    by (simp add: M def_lfp_unfold)
  show "wf R"
    by (fact WF)
  show "\<And>f st. (\<And>st'. (st', st) \<in> R \<Longrightarrow> (p \<and> e\<^sup>< = \<guillemotleft>st'\<guillemotright> \<longrightarrow> q)\<^sub>e \<sqsubseteq> f) \<Longrightarrow>
                \<nu> B = f \<Longrightarrow>
                (p \<and> e\<^sup>< = \<guillemotleft>st\<guillemotright> \<longrightarrow> q)\<^sub>e \<sqsubseteq> B f"
    oops

(*
text \<open>Since @{term "B (p \<and> (E\<^sup><,\<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright> \<longrightarrow> q)\<^sub>e \<sqsubseteq> B (\<mu> B)"} and
      @{term "mono B"}, thus,  @{thm mu_rec_total_pure_rule} can be expressed as follows\<close>

lemma mu_rec_total_utp_rule:
  assumes WF: "wf R"
    and     M: "mono B"
    and     induct_step:
    "\<And>st. (p \<and> e\<^sup>< = \<guillemotleft>st\<guillemotright> \<longrightarrow> q)\<^sub>u \<sqsubseteq> (B ((p \<and> (e\<^sup><,\<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright> \<longrightarrow> q))\<^sub>u)"
  shows "(p \<longrightarrow> q)\<^sub>u \<sqsubseteq> \<mu> B"
proof (rule mu_rec_total_pure_rule[where R=R and e=e], simp_all add: assms)
  show "\<And>f st. (p \<and> (e\<^sup><, \<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright> \<longrightarrow> q)\<^sub>u \<sqsubseteq> f \<Longrightarrow> \<mu> B = f \<Longrightarrow> (p \<and> e\<^sup>< = \<guillemotleft>st\<guillemotright> \<longrightarrow> q)\<^sub>u \<sqsubseteq> B f"
    using M induct_step monoD order_subst2 by (simp add: ref_by_set_def, blast)
qed

lemma nu_rec_total_utp_rule:
  assumes WF: "wf R"
    and     M: "mono B"
    and     induct_step:
    "\<And>st. (p \<and> e\<^sup>< = \<guillemotleft>st\<guillemotright> \<longrightarrow> q)\<^sub>u \<sqsubseteq> (B ((p \<and> (e\<^sup><,\<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright> \<longrightarrow> q))\<^sub>u)"
  shows "(p \<longrightarrow> q)\<^sub>u \<sqsubseteq> \<nu> B"
proof (rule nu_rec_total_pure_rule[where R=R and e=e], simp_all add: assms)
  show "\<And>f st. (p \<and> (e\<^sup><, \<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright> \<longrightarrow> q)\<^sub>u \<sqsubseteq> f \<Longrightarrow> \<nu> B = f \<Longrightarrow> (p \<and> e\<^sup>< = \<guillemotleft>st\<guillemotright> \<longrightarrow> q)\<^sub>u \<sqsubseteq> B f"
    using M induct_step monoD order_subst2 by (simp add: ref_by_set_def, blast)
qed
*)

end


theory sort_NMSortTDPermutes'
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

datatype Nat = Z | S "Nat"

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

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun null :: "'t list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun length :: "'t list => Nat" where
"length (Nil2) = Z"
| "length (Cons2 y xs) = S (length xs)"

fun half :: "Nat => Nat" where
"half (Z) = Z"
| "half (S (Z)) = Z"
| "half (S (S n)) = S (half n)"

fun elem :: "int => int list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (x = z) (elem x ys)"

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

fun nmsorttd :: "int list => int list" where
"nmsorttd (Nil2) = Nil2"
| "nmsorttd (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "nmsorttd (Cons2 y (Cons2 x2 x3)) =
     lmerge
       (nmsorttd
          (take
             (half (length (Cons2 y (Cons2 x2 x3)))) (Cons2 y (Cons2 x2 x3))))
       (nmsorttd
          (drop
             (half (length (Cons2 y (Cons2 x2 x3)))) (Cons2 y (Cons2 x2 x3))))"

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun isPermutation :: "int list => int list => bool" where
"isPermutation (Nil2) y = null y"
| "isPermutation (Cons2 z xs) y =
     and2 (elem z y) (isPermutation xs (delete z y))"

(*hipster take
          or2
          null
          lmerge
          length
          half
          elem
          drop
          nmsorttd
          delete
          and2
          isPermutation *)

theorem x0 :
  "!! (x :: int list) . isPermutation (nmsorttd x) x"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Exercise4
  imports Main
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refli: "iter r 0 x x" |
stepi: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

lemma iter_zero: "iter r 0 x y \<Longrightarrow> x=y"
  apply (rule iter.cases)
    apply simp
  apply auto
  done

lemma iter_one: "iter r 1 x y \<Longrightarrow> r x y"
  apply (rule iter.cases)
    apply simp
   apply simp
  using iter_zero apply fastforce
  done

lemma iter_more: "iter r (Suc n) x y \<Longrightarrow> \<exists>z. ((r x z) \<and> (iter r n z y))"
  apply (rule iter.cases)
    apply simp
   apply (simp add: Nat.Suc_neq_Zero)
  apply auto
  done

lemma iter_one_exists: "r x y \<Longrightarrow> iter r (Suc 0) x y"
  apply (metis iter.simps)
  done

lemma iter_pre: "iter r n x y \<Longrightarrow> r y z \<Longrightarrow> iter r (Suc n) x z"
  apply (induction rule: iter.induct)
   apply (simp add: iter_one_exists)
  apply (simp add: iter.intros)
  done

lemma iter_sum: "
  iter r n1 x y
  \<Longrightarrow> iter r n2 y z
  \<Longrightarrow> iter r (n1 + n2) x z
"
  apply (induction rule: iter.induct)
   apply (simp_all add: iter.stepi)
  done

theorem "star r x y \<Longrightarrow> \<exists>n. iter r n x y"
  apply (induction rule: star.induct)
  using iter.refli apply fastforce
  apply (metis iter.stepi)
  done

end


(*  Title:       Instances of Schneider's generalized protocol of clock synchronization
    Author:      Damián Barsotti <damian at hal.famaf.unc.edu.ar>, 2006
    Maintainer:  Damián Barsotti <damian at hal.famaf.unc.edu.ar>
*)

section \<open>Fault-tolerant Midpoint algorithm\<close>

theory LynchInstance imports Complex_Main begin

text \<open>This algorithm is presented in \cite{lynch_cs}.\<close>

subsection \<open>Model of the system\<close>

text \<open>The main ideas for the formalization of the system were
obtained from \cite{shankar92mechanical}.\<close>

subsubsection \<open>Types in the formalization\<close>

text \<open>The election of the basics types was based on
\cite{shankar92mechanical}. There, the process are natural numbers and
the real time and the clock readings are reals.\<close>

type_synonym process = nat
type_synonym time = real      \<comment> \<open>real time\<close>
type_synonym Clocktime = real \<comment> \<open>time of the clock readings (clock time)\<close>

subsubsection \<open>Some constants\<close>

text\<open>Here we define some parameters of the algorithm that we use:
the number of process and the number of lowest and highest readed
values that the algorithm discards. The defined constants must satisfy
this axiom. If not, the algorithm cannot obtain the maximum and
minimum value, because it will have discarded all the values.\<close>

axiomatization
  np  :: nat  \<comment> \<open>Number of processes\<close> and
  khl :: nat  \<comment> \<open>Number of lowest and highest values\<close> where
  constants_ax: "2 * khl < np"

text \<open>We define also the set of process that the algorithm
manage. This definition exist only for readability matters.\<close>

definition
PR :: "process set" where
[simp]: "PR = {..<np}"

subsubsection \<open>Convergence function\<close>

text \<open>This functions is called ``Fault-tolerant Midpoint''
(\cite{schneider87understanding})\<close>

text \<open>In this algorithm each process has an array where it store the
clocks readings from the others processes (including itself). We
formalise that as a function from processes to clock time as
\cite{shankar92mechanical}.\<close>

text \<open>First we define two functions. They take a function of clock
readings and a set of processes and they return a set of @{term khl}
processes which has the greater (smaller) clock readings. They were
defined with the Hilbert's $\varepsilon$-operator (the indefinite
description operator \<open>SOME\<close> in Isabelle) because in this way the
formalization is not fixed to a particular eleccion of the processes's
readings to discards and then the modelization is more general.\<close>

definition
kmax :: "(process \<Rightarrow> Clocktime) \<Rightarrow> process set \<Rightarrow> process set" where
"kmax f P = (SOME S. S \<subseteq> P \<and> card S = khl \<and>
                (\<forall> i\<in>S. \<forall> j\<in>(P-S). f j <= f i))"

definition
kmin :: "(process \<Rightarrow> Clocktime) \<Rightarrow> process set \<Rightarrow> process set" where
"kmin f P = (SOME S. S \<subseteq> P \<and> card S = khl \<and>
                (\<forall> i\<in>S. \<forall> j\<in>(P-S). f i <= f j))"

text \<open>With the previus functions we define a new one @{term
reduce}\footnote{The name of this function was taken from
\cite{lynch_cs}.}. This take a function of clock readings and a set of
processes and return de set of readings of the not dicarded
processes. In order to define this function we use the image operator
(@{term "(`)"}) of Isabelle.\<close>

definition
reduce :: "(process \<Rightarrow> Clocktime) \<Rightarrow> process set \<Rightarrow> Clocktime set" where
"reduce f P = f ` (P - (kmax f P \<union> kmin f P))"

text \<open>And finally the convergence function. This is defined with the
builtin @{term Max} and @{term Min} functions of Isabelle.
\<close>

definition
cfnl :: "process  \<Rightarrow> (process \<Rightarrow> Clocktime) \<Rightarrow> Clocktime" where
"cfnl p f = (Max (reduce f PR) + Min (reduce f PR)) / 2"

subsection \<open>Translation Invariance property.\<close>

subsubsection \<open>Auxiliary lemmas\<close>

text \<open>These lemmas proves the existence of the maximum and minimum
of the image of a set, if the set is finite and not empty.\<close>

(* The proofs are almost the same one that those of the lemmas @{thm *)
(* [source] ex_Max} and @{thm [source] ex_Min} in the Isabelle's standard *)
(* theories. *)

lemma ex_Maxf:
fixes S and f :: "'a \<Rightarrow> ('b::linorder)"
  assumes fin: "finite S"
  shows "S \<noteq> {} ==> \<exists>m\<in>S. \<forall>s \<in> S. f s \<le> f m"
using fin
proof (induct)
  case empty thus ?case by simp
next
  case (insert x S)
  show ?case
  proof (cases)
    assume "S = {}" thus ?thesis by simp
  next
    assume nonempty: "S \<noteq> {}"
    then obtain m where m: "m\<in>S" "\<forall>s\<in>S. f s \<le> f m"
      using insert by blast
    show ?thesis
    proof (cases)
      assume "f x \<le> f m" thus ?thesis using m by blast
    next
      assume "~ f x \<le> f m" thus ?thesis using m
        by(simp add:linorder_not_le order_less_le)
          (blast intro: order_trans)
    qed
  qed
qed

lemma ex_Minf:
fixes S and f :: "'a \<Rightarrow> ('b::linorder)"
  assumes fin: "finite S"
  shows "S \<noteq> {} ==> \<exists>m\<in>S. \<forall>s \<in> S. f m \<le> f s"
using fin
proof (induct)
  case empty thus ?case by simp
next
  case (insert x S)
  show ?case
  proof (cases)
    assume "S = {}" thus ?thesis by simp
  next
    assume nonempty: "S \<noteq> {}"
    then obtain m where m: "m\<in>S" "\<forall>s\<in>S. f m \<le> f s"
      using insert by blast
    show ?thesis
    proof (cases)
      assume "f m \<le> f x" thus ?thesis using m by blast
    next
      assume "~ f m \<le> f x" thus ?thesis using m
        by(simp add:linorder_not_le order_less_le)
          (blast intro: order_trans)
    qed
  qed
qed

text \<open>This trivial lemma is needed by the next two.\<close>

lemma khl_bound: "khl < np"
  using constants_ax by arith

text \<open>The next two lemmas prove that de functions kmin and kmax
return some values that satisfy their definition. This is not trivial
because we need to prove the existence of these values, according to
the rule of the Hilbert's operator. We will need this lemma many
times because is the only thing that we know about these functions.\<close>

lemma kmax_prop:
fixes f :: "nat \<Rightarrow> Clocktime"
  shows
"(kmax f PR) \<subseteq> PR \<and> card (kmax f PR) = khl \<and>
                (\<forall>i\<in>(kmax f PR). \<forall>j\<in>PR - (kmax f PR). f j \<le> f i)"
proof-
  have "khl <= np \<longrightarrow>
    (\<exists> S. S \<subseteq> PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f j \<le> f i))"
    ( is "khl <= np \<longrightarrow> ?P khl" )
  proof(induct (khl))
    have "?P 0" by force
    thus "0 <= np \<longrightarrow> ?P 0" ..
  next
    fix n
    assume asm: "n <= np \<longrightarrow> ?P n"
    show "Suc n <= np \<longrightarrow> ?P (Suc n)"
    proof
      assume asm2: "Suc n <= np"
      with asm have "?P n" by simp
      then obtain S where
        SinPR : "S\<subseteq>PR" and
        cardS: "card S = n" and
        HI: "(\<forall>i\<in>S. \<forall>j\<in>PR - S. f j \<le> f i)"
        by blast
      let ?e = "SOME i. i\<in>PR-S \<and>
        (\<forall>j\<in>PR-S. f j \<le> f i)"
      let ?S = "insert  ?e S"
      have "\<exists>i. i\<in>PR-S \<and> (\<forall>j\<in>PR-S. f j \<le> f i)"
      proof-
        from SinPR and finite_subset
        have "finite (PR-S)"
          by auto
        moreover
        from cardS and asm2 SinPR
        have "S\<subset>PR" by auto
        hence "PR-S \<noteq> {}" by auto
        ultimately
        show ?thesis using ex_Maxf by blast
      qed
      hence
        ePRS: "?e \<in> PR-S" and maxH: "(\<forall>j \<in> PR-S. f j \<le> f ?e)"
        by (auto dest!: someI_ex)
      from maxH and HI
      have "(\<forall>i\<in>?S. \<forall>j\<in>PR - ?S. f j \<le> f i)"
        by blast
      moreover
      from SinPR and finite_subset
      cardS and ePRS
      have "card ?S = Suc n"
        by (auto dest: card_insert_disjoint)
      moreover
      have "?S \<subseteq> PR" using SinPR and ePRS by auto
      ultimately
      show "?P (Suc n)" by blast
    qed
  qed
  hence "?P khl" using khl_bound by auto
  then obtain S where
    "S\<le>PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f j \<le> f i)" ..
    thus ?thesis by (unfold kmax_def)
      (rule someI [where P="\<lambda>S. S \<subseteq> PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f j \<le> f i)"])
qed

lemma kmin_prop:
fixes f :: "nat \<Rightarrow> Clocktime"
  shows
"(kmin f PR) \<subseteq> PR \<and> card (kmin f PR) = khl \<and>
                (\<forall>i\<in>(kmin f PR). \<forall>j\<in>PR - (kmin f PR). f i \<le> f j)"
proof-
  have "khl <= np \<longrightarrow>
    (\<exists> S. S \<subseteq> PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f i \<le> f j))"
    ( is "khl <= np \<longrightarrow> ?P khl" )
  proof(induct (khl))
    have "?P 0" by force
    thus "0 <= np \<longrightarrow> ?P 0" ..
  next
    fix n
    assume asm: "n <= np \<longrightarrow> ?P n"
    show "Suc n <= np \<longrightarrow> ?P (Suc n)"
    proof
      assume asm2: "Suc n <= np"
      with asm have "?P n" by simp
      then obtain S where
        SinPR : "S\<subseteq>PR" and
        cardS: "card S = n" and
        HI: "(\<forall>i\<in>S. \<forall>j\<in>PR - S. f i \<le> f j)"
        by blast
      let ?e = "SOME i. i\<in>PR-S \<and>
        (\<forall>j\<in>PR-S. f i \<le> f j)"
      let ?S = "insert  ?e S"
      have "\<exists>i. i\<in>PR-S \<and> (\<forall>j\<in>PR-S. f i \<le> f j)"
      proof-
        from SinPR and finite_subset
        have "finite (PR-S)"
          by auto
        moreover
        from cardS and asm2 SinPR
        have "S\<subset>PR" by auto
        hence "PR-S \<noteq> {}" by auto
        ultimately
        show ?thesis using ex_Minf by blast
      qed
      hence
        ePRS: "?e \<in> PR-S" and minH: "(\<forall>j \<in> PR-S. f ?e \<le> f j)"
        by (auto dest!: someI_ex)
      from minH and  HI
      have "(\<forall>i\<in>?S. \<forall>j\<in>PR - ?S. f i \<le> f j)"
        by blast
      moreover
      from SinPR and finite_subset and
        cardS and ePRS
      have "card ?S = Suc n"
        by (auto dest: card_insert_disjoint)
      moreover
      have "?S \<subseteq> PR" using SinPR and ePRS by auto
      ultimately
      show "?P (Suc n)" by blast
    qed
  qed
  hence "?P khl" using khl_bound by auto
  then obtain S where
    "S\<le>PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f i \<le> f j)" ..
    thus ?thesis by (unfold kmin_def)
      (rule someI [where P="\<lambda>S. S \<subseteq> PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f i \<le> f j)"])
qed

text \<open>The next two lemmas are trivial from the previous ones\<close>

lemma finite_kmax:
"finite (kmax f PR)"
proof-
  have "finite PR" by auto
  with  kmax_prop and finite_subset show ?thesis
    by blast
qed

lemma finite_kmin:
"finite (kmin f PR)"
proof-
  have "finite PR" by auto
  with  kmin_prop and finite_subset show ?thesis
    by blast
qed

text \<open>This lemma is necesary because the definition of the
convergence function use the builtin Max and Min.\<close>

lemma reduce_not_empty:
"reduce f PR \<noteq> {}"
proof-
  from constants_ax have
    "0 < (np - 2 * khl)" by arith
  also
  {
    from kmax_prop kmin_prop
    have "card (kmax f PR) = khl \<and> card (kmin f PR) = khl"
      by blast
    hence "card (kmax f PR \<union> kmin f PR) <= 2 * khl"
    using card_Un_le[of "kmax f PR" "kmin f PR"] by simp
  }
  hence
    "... <= card PR - card (kmax f PR \<union> kmin f PR)"
    by simp
  also
  {
    from kmax_prop and kmin_prop have
    "(kmax f PR \<union> kmin f PR) \<subseteq> PR" by blast
  }
  hence
    "... = card (PR-(kmax f PR \<union> kmin f PR))"
    apply (intro card_Diff_subset[THEN sym])
    apply (rule finite_subset)
    by auto
    (* by (intro card_Diff_subset,auto) *)
  finally
  have "0 < card (PR-(kmax f PR \<union> kmin f PR))" .
  hence "(PR-(kmax f PR \<union> kmin f PR)) \<noteq> {}"
    by (intro notI, simp only: card_0_eq, simp)
  thus ?thesis
    by (auto simp add: reduce_def)
qed

text \<open>The next three are the main lemmas necessary for prove the
Translation Invariance property.\<close>

lemma reduce_shift:
fixes f :: "nat \<Rightarrow> Clocktime"
  shows
  "f ` (PR - (kmax f PR \<union> kmin f PR)) =
            f ` (PR - (kmax (\<lambda> p. f p + c) PR \<union> kmin (\<lambda> p. f p + c) PR))"
apply (unfold kmin_def kmax_def)
by simp

lemma max_shift:
fixes f :: "nat \<Rightarrow> Clocktime" and S
assumes notEmpFin: "S \<noteq> {}" "finite S"
shows
"Max (f`S) + x = Max ( (\<lambda> p. f p + x) ` S) "
proof-
  from notEmpFin have "f`S \<noteq> {}" and "(\<lambda> p. f p + x) ` S \<noteq> {}"
    by auto
  with notEmpFin have
    "Max (f`S) \<in> f ` S " "Max ((\<lambda> p. f p + x)`S) \<in> (\<lambda> p. f p + x) ` S "
    "(\<forall>fs \<in> (f`S). fs \<le> Max (f`S))"
    "(\<forall>fs \<in> ((\<lambda> p. f p + x)`S). fs \<le> Max ((\<lambda> p. f p + x)`S))"
    by auto
  thus ?thesis by force
qed

lemma min_shift:
fixes f :: "nat \<Rightarrow> Clocktime" and S
assumes notEmpFin: "S \<noteq> {}" "finite S"
shows
"Min (f`S) + x = Min ( (\<lambda> p. f p + x) ` S) "
proof-
  from notEmpFin have "f`S \<noteq> {}" and "(\<lambda> p. f p + x) ` S \<noteq> {}"
    by auto
  with notEmpFin have
    "Min (f`S) \<in> f ` S " "Min ((\<lambda> p. f p + x)`S) \<in> (\<lambda> p. f p + x) ` S "
    "(\<forall>fs \<in> (f`S). Min (f`S) <= fs)"
    "(\<forall>fs \<in> ((\<lambda> p. f p + x)`S). Min ((\<lambda> p. f p + x)`S) <= fs)"
    by auto
  thus ?thesis by force
qed

subsubsection \<open>Main theorem\<close>

theorem trans_inv:
fixes f :: "nat \<Rightarrow> Clocktime"
  shows
"cfnl p f + x = cfnl p (\<lambda> p. f p + x)"
proof-
  have "cfnl p (\<lambda> p. f p + x) =
      (Max (reduce (\<lambda> p. f p + x) PR) + Min (reduce (\<lambda> p. f p + x) PR)) / 2"
    by (unfold cfnl_def, simp)
  also
  have "... =
    (Max ((\<lambda> p. f p + x) `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))) +
     Min ((\<lambda> p. f p + x) `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR)))) / 2"
    by (unfold reduce_def, simp)
  also
  have
    "... =
    (Max (f `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))) + x +
     Min (f `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))) + x ) / 2"
  proof-
    have "finite (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))"
      by auto
    moreover
    from reduce_not_empty have
      "PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR) \<noteq> {}"
      by (auto simp add: reduce_def)
    ultimately
    have
      "Max ((\<lambda> p. f p + x) `
       (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR)))
      =
       Max (f `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))) + x"
       and
      "Min ((\<lambda> p. f p + x) `
       (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR)))
      =
       Min (f `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))) + x"
      using max_shift and min_shift
      by auto
    thus ?thesis by auto
  qed
  also
  from reduce_shift
  have
    "... =
    (Max (f `
             (PR - (kmax f  PR \<union> kmin f PR))) + x +
     Min (f `
             (PR - (kmax f PR \<union> kmin f PR))) + x ) / 2"
    by auto
  also
  have "... = ((Max (reduce f PR)+ x) + (Min (reduce f PR) + x)) / 2"
    by (auto simp add: reduce_def)
  also
  have "... = (Max (reduce f PR) + Min (reduce f PR)) / 2 + x"
    by auto
  finally
  show ?thesis by (auto simp add: cfnl_def)
qed

subsection \<open>Precision Enhancement property\<close>

text \<open>An informal proof of this theorem can be found in \cite{miner93}\<close>

subsubsection \<open>Auxiliary lemmas\<close>

text \<open>This first lemma is most important for prove the
property. This is a consecuence of the @{thm [source] card_Un_Int}
lemma\<close>

lemma pigeonhole:
assumes
  finitA: "finite A" and
  Bss: "B \<subseteq> A" and Css: "C \<subseteq> A" and
  cardH: "card A + k <= card B + card C"
shows "k <= card (B \<inter> C)"
proof-
  from Bss Css have "B \<union> C \<subseteq> A" by blast
  with finitA have "card (B \<union> C) <= card A"
    by (simp add: card_mono)
  with cardH have
      h: "k <= card B + card C - card (B \<union> C)"
    by arith
  from finitA Bss Css and finite_subset
  have "finite B \<and> finite C" by auto
  thus ?thesis
    using card_Un_Int and h by force
qed

text \<open>This lemma is a trivial consecuence of the previous one. With
only this lemma we can prove the Precision Enhancement property with
the bound $\pi(x,y) = x + y$. But this bound not satisfy the property
\[ \pi(2\Lambda + 2 \beta\rho, \delta_S + 2\rho(r_{max}+\beta) +
2\Lambda) \leq \delta_S
\] that is used in \cite{shankar92mechanical} for prove the
Schneider's schema.\<close>

lemma subsets_int:
assumes
  finitA: "finite A" and
  Bss: "B \<subseteq> A" and Css: "C \<subseteq> A" and
  cardH: "card A < card B + card C"
shows
  "B \<inter> C \<noteq> {}"
proof-
  from finitA Bss Css cardH
  have "1 <= card (B \<inter> C)"
    by (auto intro!:  pigeonhole)
  thus ?thesis by auto
qed

text \<open>This lemma is true because @{term "reduce f PR"} is the image
of @{term "PR-(kmax f PR \<union> kmin f PR)"} by the function @{term f}.\<close>

lemma exist_reduce:
"\<forall> c \<in> reduce f PR. \<exists> i\<in> PR-(kmax f PR \<union> kmin f PR). f i = c"
proof
fix c assume asm: "c \<in> reduce f PR"
thus "\<exists> i\<in> PR-(kmax f PR \<union> kmin f PR). f i = c"
  by (auto simp add: reduce_def kmax_def kmin_def)
qed

text \<open>The next three lemmas are consequence of the definition of
@{term reduce}, @{term kmax} and @{term kmin}\<close>

lemma finite_reduce:
"finite (reduce f PR)"
proof(unfold reduce_def)
  show "finite (f ` (PR - (kmax f PR \<union> kmin f PR)))"
    by auto
qed

lemma kmax_ge:
  "\<forall> i\<in> (kmax f PR). \<forall> r \<in> (reduce f PR). r <= f i "
proof
  fix i assume asm: "i \<in> kmax f PR"
  show "\<forall>r\<in>reduce f PR. r \<le> f i"
  proof
    fix r assume asm2: "r \<in> reduce f PR"
    show "r \<le> f i"
    proof-
      from asm2 and exist_reduce have
        "\<exists> j \<in> PR-(kmax f PR \<union> kmin f PR). f j = r" by blast
      then obtain j
      where fjr:"j \<in> PR-(kmax f PR \<union> kmin f PR) \<and> f j = r"
        by blast
      hence "j \<in> (PR - kmax f PR)"
        by blast
      from this fjr asm
      show ?thesis using kmax_prop
        by auto
    qed
  qed
qed

lemma kmin_le:
  "\<forall> i\<in> (kmin f PR). \<forall> r \<in> (reduce f PR). f i <= r "
proof
  fix i assume asm: "i \<in> kmin f PR"
  show "\<forall>r\<in>reduce f PR. f i \<le> r"
  proof
    fix r assume asm2: "r \<in> reduce f PR"
    show "f i <= r"
    proof-
      from asm2 and exist_reduce have
        "\<exists> j\<in> PR-(kmax f PR \<union> kmin f PR). f j = r" by blast
      then obtain j
      where fjr:"j \<in> PR-(kmax f PR \<union> kmin f PR) \<and> f j = r"
        by blast
      hence "j \<in> (PR - kmin f PR)"
        by blast
      from this fjr asm
      show ?thesis using kmin_prop
        by auto
    qed
  qed
qed

text \<open>The next lemma is used for prove the Precision Enhancement
property. This has been proved in ICS. The proof is in the appendix
\ref{sec:abs_distrib_mult}.  This cannot be prove by a simple \<open>arith\<close> or \<open>auto\<close> tactic.\<close>

text\<open>This lemma is true also with \<open>0 <= c\<close> !!\<close>

lemma abs_distrib_div:
  "0 < (c::real)  \<Longrightarrow> \<bar>a / c - b / c\<bar> = \<bar>a - b\<bar> / c"
proof-
  assume ch: "0<c"
  {
    fix d :: real
    assume dh: "0<=d"
    have "a * d - b * d = (a - b) * d "
      by (simp add: algebra_simps)
    hence "\<bar>a * d - b * d\<bar> = \<bar>(a - b) * d\<bar>"
      by simp
    also with dh have
      "... = \<bar>a - b\<bar> * d"
      by (simp add: abs_mult)
    finally
      have "\<bar>a * d - b * d\<bar> = \<bar>a - b\<bar> * d"
        .
    (* This sublemma is solved by ICS, file: abs_distrib_mult.ics *)
    (* It is not solved nor
       by (auto simp add: distrib_right diff_minus)(arith)
        in Isabelle  *)
  }
  with ch and divide_inverse show ?thesis
    by (auto simp add: divide_inverse)
qed

text \<open>The next three lemmas are about the existence of bounds of the
values @{term "Max (reduce f PR)"} and @{term "Min (reduce f PR)"}. These
are used in the proof of the main property.\<close>

lemma uboundmax:
assumes
  hC: "C \<subseteq> PR" and
  hCk: "np <= card C + khl"
shows
  "\<exists> i\<in>C. Max (reduce f PR) <= f i"
proof-
  from reduce_not_empty and finite_reduce
  have maxrinr: "Max (reduce f PR) \<in> reduce f PR"
    by simp
  with exist_reduce
  have "\<exists> i\<in> PR-(kmax f PR \<union> kmin f PR). f i = Max (reduce f PR)"
    by simp
  then obtain pmax where
    pmax_in_reduc: "pmax \<in> PR-(kmax f PR \<union> kmin f PR)" and
    fpmax_ismax: "f pmax = Max (reduce f PR)" ..
  hence "C \<inter> insert pmax (kmax f PR)  \<noteq> {}"
  proof-
    from kmax_prop and pmax_in_reduc
      and finite_kmax and hCk  have
      "card PR < card C + card (insert pmax (kmax f PR))"
      by simp
    moreover
    from pmax_in_reduc and kmax_prop
    have "insert pmax (kmax f PR) \<subseteq> PR" by blast
    moreover
    note hC
    ultimately
    show ?thesis
      using subsets_int[of PR C "insert pmax (kmax f PR)"]
      by simp
  qed
  hence res: "\<exists> i\<in>C. i=pmax \<or> i \<in> kmax f PR" by blast
  then obtain i where
    iinC: "i\<in>C" and altern: "i=pmax \<or> i \<in> kmax f PR" ..
  thus ?thesis
  proof(cases "i=pmax")
    case True
    with iinC fpmax_ismax show ?thesis by force
  next
    case False
    with altern maxrinr fpmax_ismax kmax_ge
    have "f pmax <= f i" by simp
    with iinC fpmax_ismax show ?thesis by auto
  qed
qed

lemma lboundmin:
assumes
  hC: "C \<subseteq> PR" and
  hCk: "np <= card C + khl"
shows
  "\<exists> i\<in>C. f i <= Min (reduce f PR)"
proof-
  from reduce_not_empty and finite_reduce
  have minrinr: "Min (reduce f PR) \<in> reduce f PR"
    by simp
  with exist_reduce
  have "\<exists> i\<in> PR-(kmax f PR \<union> kmin f PR). f i = Min (reduce f PR)"
    by simp
  then obtain pmin where
    pmin_in_reduc: "pmin \<in> PR-(kmax f PR \<union> kmin f PR)" and
    fpmin_ismin: "f pmin = Min (reduce f PR)" ..
  hence "C \<inter> insert pmin (kmin f PR)  \<noteq> {}"
  proof-
    from kmin_prop and pmin_in_reduc
      and finite_kmin and hCk  have
      "card PR < card C + card (insert pmin (kmin f PR))"
      by simp
    moreover
    from pmin_in_reduc and kmin_prop
    have "insert pmin (kmin f PR) \<subseteq> PR" by blast
    moreover
    note hC
    ultimately
    show ?thesis
      using subsets_int[of PR C "insert pmin (kmin f PR)"]
      by simp
  qed
  hence res: "\<exists> i\<in>C. i=pmin \<or> i \<in> kmin f PR" by blast
  then obtain i where
    iinC: "i\<in>C" and altern: "i=pmin \<or> i \<in> kmin f PR" ..
  thus ?thesis
  proof(cases "i=pmin")
    case True
    with iinC fpmin_ismin show ?thesis by force
  next
    case False
    with altern minrinr fpmin_ismin kmin_le
    have "f i <= f pmin" by simp
    with iinC fpmin_ismin show ?thesis by auto
  qed
qed

lemma same_bound:
assumes
  hC: "C \<subseteq> PR" and
  hCk: "np <= card C + khl" and
  hnk: "3 * khl < np"
shows
  "\<exists> i\<in>C. Min (reduce f PR) <= f i \<and> g i <= Max (reduce g PR) "
proof-
  have b1: "khl + 1 <= card (C \<inter> (PR - kmin f PR))"
  proof(rule pigeonhole)
    show "finite PR" by simp
  next
    show "C \<subseteq> PR" by fact
  next
    show "PR - kmin f PR \<subseteq> PR" by blast
  next
    show "card PR + (khl + 1) \<le> card C + card (PR - kmin f PR)"
    proof-
      from hnk and hCk have
        "np + khl < np + card C - khl" by arith
      also
      from kmin_prop
      have "... = np + card C - card (kmin f PR)"
        by auto
      also
      have "... = card C + (card PR - card (kmin f PR))"
      proof-
        from kmin_prop have
          "card (kmin f PR) <= card PR"
          by (intro card_mono, auto)
        thus ?thesis by (simp)
      qed
      also
      from kmin_prop
      have "... = card C +  card (PR - kmin f PR)"
      proof-
        from kmin_prop and finite_kmin have
          "card PR - card (kmin f PR) =  card (PR - kmin f PR)"
          by (intro card_Diff_subset[THEN sym])(auto)
        thus ?thesis by auto
      qed
      finally
      show ?thesis
        by (simp)
    qed
  qed

  have "C \<inter> (PR - kmin f PR) \<inter> (PR - kmax g PR) \<noteq> {}"
  proof(intro subsets_int)
    show "finite PR" by simp
  next
    show "C \<inter> (PR - kmin f PR) \<subseteq> PR"
      by blast
  next
    show "PR - kmax g PR \<subseteq> PR"
      by blast
  next
    show "card PR <
      card (C \<inter> (PR - kmin f PR)) + card (PR - kmax g PR)"
    proof-
      from kmax_prop and finite_kmax
      have "card (PR - kmax g PR)= card PR - card (kmax g PR) "
        by  (intro card_Diff_subset, auto)
      with kmax_prop have
        "card (PR - kmax g PR) = card PR - khl" by simp
      with b1
      show ?thesis by arith
    qed
  qed

  hence
    "\<exists> i. i \<in> C \<and> i \<in> (PR - kmin f PR) \<and> i \<in> (PR - kmax g PR)"
    by blast
  then obtain i where
    in_C: "i \<in> C" and
    not_in_kmin: "i \<in> (PR - kmin f PR)" and
    not_in_kmax: "i \<in> (PR - kmax g PR)" by blast
  have "Min (reduce f PR) <= f i"
  proof(cases "i \<in> kmax f PR")
    case True
    from reduce_not_empty and finite_reduce have
      " Min (reduce f PR) \<in> reduce f PR" by auto
    with True show ?thesis
      using kmax_ge by blast
  next
    case False
    with not_in_kmin
    have "i \<in> PR - (kmax f PR \<union> kmin f PR)"
      by blast
    with reduce_def have "f i \<in> reduce f PR"
      by auto
    with reduce_not_empty and finite_reduce
    show ?thesis by auto
  qed
  moreover
  have "g i <= Max (reduce g PR)"
  proof(cases "i \<in> kmin g PR")
    case True
    from reduce_not_empty and finite_reduce have
      " Max (reduce g PR) \<in> reduce g PR" by auto
    with True show ?thesis
      using kmin_le by blast
  next
    case False
    with not_in_kmax
    have "i \<in> PR - (kmax g PR \<union> kmin g PR)"
      by blast
    with reduce_def have "g i \<in> reduce g PR"
      by auto
    with reduce_not_empty and finite_reduce
    show ?thesis by auto
  qed
  moreover
  note in_C
  ultimately
  show ?thesis by blast
qed

subsubsection \<open>Main theorem\<close>

text \<open>The most part of this theorem can be proved with CVC-lite
using the three previous lemmas (appendix \ref{sec:bound_prec_enh}).\<close>

theorem prec_enh:
assumes
  hC: "C \<subseteq> PR" and
  hCF: "np - nF <= card C" and
  hFn: "3 * nF < np" and
  hFk: "nF = khl" and
  hbx: "\<forall> l\<in>C. \<bar>f l - g l\<bar> <= x" and
  hby1: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hby2: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>g l - g m\<bar> <= y" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C"
shows "\<bar> cfnl p f - cfnl q g \<bar> <= y / 2 + x"
proof-
  from hCF and hFk
  have hCk: "np <= card C + khl" by arith
  from hFn and hFk
  have hnk: "3 * khl < np"  by arith
  let    ?maxf = "Max (reduce f PR)"
    and  ?minf = "Min (reduce f PR)"
    and  ?maxg = "Max (reduce g PR)"
    and  ?ming = "Min (reduce g PR)"
  from abs_distrib_div
  have "\<bar>cfnl p f - cfnl q g\<bar> =
    \<bar>?maxf + ?minf  +  - ?maxg + - ?ming\<bar> / 2"
    by (unfold cfnl_def) simp
  moreover
  have "\<bar>?maxf + ?minf  +  - ?maxg + - ?ming\<bar> <= y + 2 * x"
    \<comment> \<open>The rest of the property can be proved by CVC-lite
           (see appendix \ref{sec:bound_prec_enh})\<close>
  proof ( cases "0 <= ?maxf + ?minf  +  - ?maxg + - ?ming")
    case True
    hence
    "\<bar>?maxf + ?minf  +  - ?maxg + - ?ming\<bar> =
      ?maxf + ?minf  +  - ?maxg + - ?ming" by arith
    moreover
    from uboundmax hC hCk
    obtain mxf
      where mxfinC: "mxf\<in>C" and
            maxf: "?maxf <= f mxf" by blast
    moreover
    from lboundmin hC hCk
    obtain mng
      where mnginC: "mng\<in>C" and
            ming: "g mng <= ?ming" by blast
    moreover
    from same_bound hC hCk hnk
    obtain mxn
      where mxninC: "mxn\<in>C" and
            mxnf: "?minf  \<le> f mxn" and
            mxng: "g mxn \<le> ?maxg" by blast
    ultimately
    have
      "\<bar> ?maxf + ?minf  +  - ?maxg + - ?ming\<bar> <=
      (f mxf + - g mng) + (f mxn  +  - g mxn)" by arith
    also
    from  mxninC hbx abs_le_D1
    have
      "... <= (f mxf + - g mng) + x"
      by auto
    also
    have
      "... = (f mxf + - f mng ) + ( f mng + - g mng) + x"
      by arith
    also
    have "... <= y + ( f mng + - g mng) + x"
    proof-
      from  mxfinC mnginC hby1 abs_le_D1
      have "f mxf + - f mng <= y"
        by auto
      thus ?thesis
        by auto
    qed
    also
    from  mnginC hbx abs_le_D1
    have "... <= y + 2 * x"
      by auto
    finally
    show ?thesis .
  next
    case False
    hence
    "\<bar>?maxf + ?minf  +  - ?maxg + - ?ming\<bar> =
      ?maxg + ?ming  +  - ?maxf + - ?minf" by arith
    moreover
    from uboundmax hC hCk
    obtain mxg
      where mxginC: "mxg\<in>C" and
            maxg: "?maxg <= g mxg" by blast
    moreover
    from lboundmin hC hCk
    obtain mnf
      where mnfinC: "mnf\<in>C" and
            minf: "f mnf <= ?minf" by blast
    moreover
    from same_bound hC hCk hnk
    obtain mxn
      where mxninC: "mxn\<in>C" and
            mxnf: "?ming  \<le> g mxn" and
            mxng: "f mxn \<le> ?maxf" by blast
    ultimately
    have
      "\<bar> ?maxf + ?minf  +  - ?maxg + - ?ming\<bar> <=
      (g mxg + - f mnf) + (g mxn  +  - f mxn)" by arith
    also
    from  mxninC hbx
    have "... <= (g mxg + - f mnf) + x"
        by (auto dest!: abs_le_D2)
    also
    have
      "... = (g mxg + - g mnf ) + ( g mnf + - f mnf) + x"
      by arith
    also
    have "... <= y + ( g mnf + - f mnf) + x"
    proof-
      from  mxginC mnfinC hby2 abs_le_D1
      have "g mxg + - g mnf <= y"
        by auto
      thus ?thesis
        by auto
    qed
    also
    from  mnfinC hbx
    have "... <= y + 2 * x"
      by (auto dest!: abs_le_D2)
    finally
    show ?thesis .
  qed
  ultimately
  show ?thesis
    by simp
qed

subsection \<open>Accuracy Preservation property\<close>

text \<open>No new lemmas are needed for prove this property. The bound
has been found using the lemmas @{thm [source] uboundmax} and @{thm
[source] lboundmin}\<close>

text \<open>This theorem can be proved with ICS and CVC-lite assuming
those lemmas (see appendix \ref{sec:accur_pres}).\<close>

theorem accur_pres:
assumes
  hC: "C \<subseteq> PR" and
  hCF: "np - nF <= card C" and
  hFk: "nF = khl" and
  hby: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hqC: "q\<in>C"
shows "\<bar> cfnl p f - f q \<bar> <= y"
proof-
  from hCF and hFk
  have npleCk: "np <= card C + khl" by arith
  show ?thesis
  proof(cases "f q <= cfnl p f")
    case True
    from npleCk hC and  uboundmax
    have "\<exists> i\<in>C. Max (reduce f PR) <= f i"
      by auto
    then obtain pi where
      hpiC: "pi \<in> C" and
      fpiGeMax: "Max (reduce f PR) <= f pi" by blast
    from reduce_not_empty
    have "Min (reduce f PR) <= Max (reduce f PR)"
      by (auto simp add: reduce_def)
    with fpiGeMax have
      cfnlLefpi: "cfnl p f <= f pi"
      by (auto simp add: cfnl_def)
    with True have
      "\<bar> cfnl p f - f q \<bar> <= \<bar> f pi - f q \<bar>"
      by arith
    with hpiC and hqC and hby show ?thesis
      by force
  next
    case False
    from npleCk hC and lboundmin
    have "\<exists> i\<in>C. f i <= Min (reduce f PR)"
      by auto
    then obtain qi where
      hqiC: "qi \<in> C" and
      fqiLeMax: "f qi <= Min (reduce f PR)" by blast
    from reduce_not_empty
    have "Min (reduce f PR) <= Max (reduce f PR)"
      by (auto simp add: reduce_def)
    with fqiLeMax
    have "f qi <= cfnl p f"
      by (auto simp add: cfnl_def)
    with False have
      "\<bar> cfnl p f - f q \<bar> <= \<bar> f qi - f q \<bar>"
      by arith
    with hqiC and hqC and hby show ?thesis
      by force
  qed
qed

end