(*  Title:       Formalization of Schneider's generalized clock synchronization protocol.
    Author:      Alwen Tiu, LORIA, June 11, 2005
    Maintainer:  Alwen Tiu <Alwen.Tiu at loria.fr>
*)

theory GenClock imports Complex_Main begin

subsection{* Types and constants definitions *}

text{* Process is represented by natural numbers. The type 'event' corresponds
to synchronization rounds. *}

type_synonym process = nat
type_synonym event = nat      (* synchronization rounds *)
type_synonym time = real
type_synonym Clocktime = real

axiomatization
  \<delta> :: real and
  \<mu> :: real and
  \<rho> :: real and
  rmin :: real and
  rmax :: real and
  \<beta> :: real and
  \<Lambda> :: real and
  (* Number of processes *)
  np :: process and
  maxfaults :: process and
  (* Physical clocks *)
  PC :: "[process, time] \<Rightarrow> Clocktime" and
  (* Virtual / Logical clocks *)
  VC :: "[process, time] \<Rightarrow> Clocktime" and
  (* Starting (real) time of synchronization rounds *)
  te :: "[process, event] \<Rightarrow> time" and
  (* Clock readings at each round *)
  \<theta> :: "[process, event] \<Rightarrow> (process \<Rightarrow> Clocktime)" and
  (* Logical clock in-effect at a time interval *)
  IC :: "[process, event, time] \<Rightarrow> Clocktime" and
  (* Correct clocks *)
  correct :: "[process, time] \<Rightarrow> bool" and
  (* The averaging function to calculate clock adjustment *)
  cfn :: "[process, (process \<Rightarrow> Clocktime)] \<Rightarrow> Clocktime" and

  \<pi> :: "[Clocktime, Clocktime] \<Rightarrow> Clocktime" and

  \<alpha> :: "Clocktime \<Rightarrow> Clocktime"

definition
  count :: "[process \<Rightarrow> bool, process] \<Rightarrow> nat" where
  "count f n = card {p. p < n \<and> f p}"

definition
  (* Adjustment to a clock *)
  Adj :: "[process, event] \<Rightarrow> Clocktime" where
  "Adj = (\<lambda> p i. if 0 < i then cfn p (\<theta> p i) - PC p (te p i)
                 else 0)"

definition
  (* Auxilary predicates used in the definition of precision enhancement *)
  okRead1 :: "[process \<Rightarrow> Clocktime, Clocktime, process \<Rightarrow> bool] \<Rightarrow> bool" where
  "okRead1 f x ppred \<longleftrightarrow> (\<forall> l m. ppred l \<and> ppred m \<longrightarrow> \<bar>f l - f m\<bar> \<le> x)"

definition
  okRead2 :: "[process \<Rightarrow> Clocktime, process \<Rightarrow> Clocktime, Clocktime,
               process \<Rightarrow> bool] \<Rightarrow> bool" where
  "okRead2 f g x ppred \<longleftrightarrow> (\<forall> p. ppred p \<longrightarrow> \<bar>f p - g p\<bar> \<le> x)"

definition
  rho_bound1 :: "[[process, time] \<Rightarrow> Clocktime] \<Rightarrow> bool" where
  "rho_bound1 C \<longleftrightarrow> (\<forall> p s t. correct p t \<and> s \<le> t \<longrightarrow> C p t - C p s \<le> (t - s)*(1 + \<rho>))"
definition
  rho_bound2 :: "[[process, time] \<Rightarrow> Clocktime] \<Rightarrow> bool" where
  "rho_bound2 C \<longleftrightarrow> (\<forall> p s t. correct p t \<and> s \<le> t \<longrightarrow> (t - s)*(1 - \<rho>) \<le> C p t - C p s)"

subsection{* Clock conditions *}

text{* Some general assumptions *}
axiomatization where
  constants_ax: "0 < \<beta> \<and> 0 < \<mu> \<and> 0 < rmin
  \<and> rmin \<le> rmax \<and> 0 < \<rho> \<and> 0 < np \<and> maxfaults \<le> np"

axiomatization where
  PC_monotone: "\<forall> p s t. correct p t \<and> s \<le> t \<longrightarrow> PC p s \<le> PC p t"

axiomatization where
  VClock: "\<forall> p t i. correct p t \<and> te p i \<le> t \<and> t < te p (i + 1) \<longrightarrow> VC p t = IC p i t"

axiomatization where
  IClock: "\<forall> p t i. correct p t \<longrightarrow> IC p i t = PC p t + Adj p i"

text{* Condition 1: initial skew *}
axiomatization where
  init: "\<forall> p. correct p 0 \<longrightarrow> 0 \<le> PC p 0 \<and> PC p 0 \<le> \<mu>"

text{* Condition 2: bounded drift *}
axiomatization where
  rate_1: "\<forall> p s t. correct p t \<and> s \<le> t \<longrightarrow> PC p t - PC p s \<le> (t - s)*(1 + \<rho>)" and
  rate_2: "\<forall> p s t. correct p t \<and> s \<le> t \<longrightarrow> (t - s)*(1 - \<rho>) \<le> PC p t - PC p s"

text{* Condition 3: bounded interval *}
axiomatization where
  rts0: "\<forall> p t i. correct p t \<and> t \<le> te p (i+1) \<longrightarrow> t - te p i \<le> rmax" and
  rts1: "\<forall> p t i. correct p t \<and> te p (i+1) \<le> t \<longrightarrow> rmin \<le> t - te p i"

text{* Condition 4 : bounded delay *}
axiomatization where
  rts2a: "\<forall> p q t i. correct p t \<and> correct q t \<and> te q i + \<beta> \<le> t \<longrightarrow> te p i \<le> t"  and
  rts2b: "\<forall> p q i. correct p (te p i) \<and> correct q (te q i) \<longrightarrow> abs(te p i - te q i) \<le> \<beta>"

text{* Condition 5: initial synchronization *}
axiomatization where
  synch0: "\<forall> p. te p 0 = 0"

text{* Condition 6: nonoverlap *}
axiomatization where
  nonoverlap: "\<beta> \<le> rmin"

text{* Condition 7: reading errors *}
axiomatization where
  readerror: "\<forall> p q i. correct p (te p (i+1)) \<and> correct q (te p (i+1)) \<longrightarrow>
              abs(\<theta> p (i+1) q - IC q i (te p (i+1))) \<le> \<Lambda>"

text{* Condition 8: bounded faults *}
axiomatization where
  correct_closed: "\<forall> p s t. s \<le> t \<and> correct p t \<longrightarrow> correct p s" and
  correct_count:  "\<forall> t. np - maxfaults \<le> count (\<lambda> p. correct p t) np"

text{* Condition 9: Translation invariance *}
axiomatization where
  trans_inv: "\<forall> p f x. 0 \<le> x \<longrightarrow> cfn p (\<lambda> y. f y + x) = cfn p f + x"

text{* Condition 10: precision enhancement *}
axiomatization where
  prec_enh:
  "\<forall> ppred p q f g x y.
          np - maxfaults \<le> count ppred np \<and>
          okRead1 f y ppred \<and> okRead1 g y ppred \<and>
          okRead2 f g x ppred \<and> ppred p \<and> ppred q
      \<longrightarrow> abs(cfn p f - cfn q g) \<le> \<pi> x y"

text{* Condition 11: accuracy preservation *}
axiomatization where
  acc_prsv:
  "\<forall> ppred p q f x. okRead1 f x ppred \<and> np - maxfaults \<le> count ppred np
          \<and> ppred p \<and> ppred q \<longrightarrow> abs(cfn p f - f q) \<le> \<alpha> x"

subsubsection{* Some derived properties of clocks *}

lemma rts0d:
assumes cp: "correct p (te p (i+1))"
shows "te p (i+1) - te p i \<le> rmax"
using cp rts0 by simp

lemma rts1d:
assumes cp: "correct p (te p (i+1))"
shows "rmin \<le> te p (i+1) - te p i"
using cp rts1 by simp

lemma rte:
assumes cp: "correct p (te p (i+1))"
shows "te p i \<le> te p (i+1)"
proof-
  from cp rts1d have "rmin \<le> te p (i+1) - te p i"
    by simp
  from this constants_ax show ?thesis by arith
qed

lemma beta_bound1:
assumes corr_p: "correct p (te p (i+1))"
and corr_q: "correct q (te p (i+1))"
shows "0 \<le> te p (i+1) - te q i"
proof-
  from corr_p rte have "te p i \<le> te p (i+1)"
    by simp
  from this corr_p correct_closed have corr_pi: "correct p (te p i)"
    by blast
  from corr_p rts1d nonoverlap have "rmin \<le> te p (i+1) - te p i"
    by simp
  from this nonoverlap have "\<beta> \<le> te p (i+1) - te p i" by simp
  hence "te p i + \<beta> \<le> te p (i+1)" by simp

  from this corr_p corr_q rts2a
  have "te q i \<le> te p (i+1)"
    by blast
  thus ?thesis by simp
qed

lemma beta_bound2:
assumes corr_p: "correct p (te p (i+1))"
and corr_q: "correct q (te q i)"
shows "te p (i+1) - te q i \<le> rmax + \<beta>"
proof-
  from corr_p rte have "te p i \<le> te p (i+1)"
    by simp
  from this corr_p correct_closed have corr_pi: "correct p (te p i)"
    by blast

  have split: "te p (i+1) - te q i =
    (te p (i+1) - te p i) + (te p i - te q i)"
    by (simp)

  from corr_q corr_pi rts2b have Eq1: "abs(te p i - te q i) \<le> \<beta>"
    by simp
  have Eq2: "te p i - te q i \<le> \<beta>"
  proof cases
    assume "te q i \<le> te p i"
    from this Eq1 show ?thesis
      by (simp add: abs_if)
  next
    assume "\<not> (te q i \<le> te p i)"
    from this Eq1 show ?thesis
      by (simp add: abs_if)
  qed

  from corr_p rts0d have "te p (i+1) - te p i \<le> rmax"
    by simp
  from this split Eq2 show ?thesis by simp
qed

subsubsection{* Bounded-drift for logical clocks (IC) *}

lemma bd:
  assumes ie: "s \<le> t"
  and rb1: "rho_bound1 C"
  and rb2: "rho_bound2 D"
  and PC_ie: "D q t - D q s \<le> C p t - C p s"
  and corr_p: "correct p t"
  and corr_q: "correct q t"
  shows "\<bar> C p t - D q t \<bar>  \<le> \<bar> C p s - D q s \<bar> + 2*\<rho>*(t - s)"
proof-
  let ?Dt = "C p t - D q t"
  let ?Ds = "C p s - D q s"
  let ?Bp = "C p t - C p s"
  let ?Bq = "D q t - D q s"
  let ?I = "t - s"

  have "\<bar> ?Bp - ?Bq \<bar> \<le> 2*\<rho>*(t - s)"
  proof-
    from PC_ie have Eq1: "\<bar> ?Bp - ?Bq \<bar> = ?Bp - ?Bq" by (simp add: abs_if)
    from corr_p ie rb1 have Eq2: "?Bp - ?Bq \<le> ?I*(1+\<rho>) - ?Bq" (is "?E1 \<le> ?E2")
      by(simp add: rho_bound1_def)
    from corr_q ie rb2 have "?I*(1 - \<rho>) \<le> ?Bq"
      by(simp add: rho_bound2_def)
    from this have Eq3: "?E2 \<le> ?I*(1+\<rho>) - ?I*(1 - \<rho>)"
      by(simp)
    have Eq4: "?I*(1+\<rho>) - ?I*(1 - \<rho>) = 2*\<rho>*?I"
      by(simp add: algebra_simps)
    from Eq1 Eq2 Eq3 Eq4 show ?thesis by simp
  qed
  moreover
  have "\<bar>?Dt\<bar>  \<le> \<bar>?Bp - ?Bq\<bar>  + \<bar>?Ds\<bar>"
    by(simp add: abs_if)
  ultimately show ?thesis by simp
qed

lemma bounded_drift:
  assumes ie: "s \<le> t"
  and rb1: "rho_bound1 C"
  and rb2: "rho_bound2 C"
  and rb3: "rho_bound1 D"
  and rb4: "rho_bound2 D"
  and corr_p: "correct p t"
  and corr_q: "correct q t"
  shows "\<bar>C p t - D q t\<bar> \<le> \<bar>C p s - D q s\<bar>  + 2*\<rho>*(t - s)"
proof-
  let ?Bp = "C p t - C p s"
  let ?Bq = "D q t - D q s"

  show ?thesis
  proof cases
    assume "?Bq \<le> ?Bp"
    from this ie rb1 rb4 corr_p corr_q bd show ?thesis by simp
  next
    assume "\<not> (?Bq \<le> ?Bp)"
    hence "?Bp \<le> ?Bq" by simp
    from this ie rb2 rb3 corr_p corr_q bd
    have "\<bar>D q t - C p t\<bar>  \<le> \<bar>D q s - C p s\<bar> + 2*\<rho>*(t - s)"
      by simp
    from this show ?thesis by (simp add: abs_minus_commute)
  qed
qed

text{* Drift rate of logical clocks *}

lemma IC_rate1:
"rho_bound1 (\<lambda> p t. IC p i t)"
proof-
  {
    fix p::process
    fix s::time
    fix t::time
    assume cp: "correct p t"
    assume ie: "s \<le> t"
    from cp ie correct_closed have cps: "correct p s"
      by blast
    have "IC p i t - IC p i s \<le> (t - s)*(1+\<rho>)"
    proof-
      from cp IClock have "IC p i t = PC p t + Adj p i"
        by simp
      moreover
      from cps IClock have "IC p i s = PC p s + Adj p i"
        by simp
      moreover
      from cp ie rate_1 have "PC p t - PC p s \<le> (t - s)*(1+\<rho>)"
        by simp
      ultimately show ?thesis by simp
    qed
  }
  thus ?thesis by (simp add: rho_bound1_def)
qed

lemma IC_rate2:
"rho_bound2 (\<lambda> p t. IC p i t)"
proof-
  {
    fix p::process
    fix s::time
    fix t::time
    assume cp: "correct p t"
    assume ie: "s \<le> t"
    from cp ie correct_closed have cps: "correct p s"
      by blast
    have "(t - s)*(1 - \<rho>) \<le> IC p i t - IC p i s"
    proof-
      from cp IClock have "IC p i t = PC p t + Adj p i"
        by simp
      moreover
      from cps IClock have "IC p i s = PC p s + Adj p i"
        by simp
      moreover
      from cp ie rate_2 have "(t - s)*(1-\<rho>) \<le> PC p t - PC p s"
        by simp
      ultimately show ?thesis by simp
    qed
  }
  thus ?thesis by (simp add: rho_bound2_def)
qed

text{* Auxilary function @{text ICf}: we introduce this to avoid some
unification problem in some tactic of isabelle. *}

definition
  ICf :: "nat \<Rightarrow> (process \<Rightarrow> time \<Rightarrow> Clocktime)" where
  "ICf i = (\<lambda> p t. IC p i t)"

lemma IC_bd:
  assumes ie: "s \<le> t"
  and corr_p: "correct p t"
  and corr_q: "correct q t"
  shows "\<bar>IC p i t - IC q j t\<bar> \<le> \<bar>IC p i s - IC q j s\<bar> + 2*\<rho>*(t - s)"
proof-
  let ?C = "ICf i"
  let ?D = "ICf j"
  let ?G = "\<bar>?C p t - ?D q t\<bar> \<le> \<bar>?C p s - ?D q s\<bar> + 2*\<rho>*(t - s)"

  from IC_rate1 have rb1: "rho_bound1 (ICf i) \<and> rho_bound1 (ICf j)"
    by (simp add: ICf_def)

  from IC_rate2 have rb2: "rho_bound2 (ICf i) \<and> rho_bound2 (ICf j)"
    by (simp add: ICf_def)

  from ie rb1 rb2 corr_p corr_q bounded_drift
  have ?G by simp

  from this show ?thesis by (simp add: ICf_def)
qed

lemma event_bound:
assumes ie1: "0 \<le> (t::real)"
and corr_p: "correct p t"
and corr_q: "correct q t"
shows "\<exists> i. t < max (te p i) (te q i)"
proof (rule ccontr)
  assume A: "\<not> (\<exists> i. t < max (te p i) (te q i))"
  show False
  proof-
    have F1: "\<forall> i. te p i \<le> t"
    proof
      fix i :: nat
      from A have "\<not> (t < max (te p i) (te q i))"
        by simp
      hence Eq1: "max (te p i) (te q i) \<le> t" by arith
      have Eq2: "te p i \<le> max (te p i) (te q i)"
        by (simp add: max_def)
      from Eq1 Eq2 show "te p i \<le> t" by simp
    qed

    have F2: "\<forall> (i :: nat). correct p (te p i)"
    proof
      fix i :: nat
      from F1 have "te p i \<le> t" by simp
      from this corr_p correct_closed
      show "correct p (te p i)" by blast
    qed

    have F3: "\<forall> (i :: nat). real i * rmin \<le> te p i"
    proof
      fix i :: nat
      show "real i * rmin \<le> te p i"
      proof (induct i)
        from synch0 show "real (0::nat) * rmin \<le> te p 0" by simp
      next
        fix i :: nat assume ind_hyp: "real i * rmin \<le> te p i"

        show "real (Suc i) * rmin \<le> te p (Suc i)"
        proof-

          have Eq1: "real i * rmin + rmin = (real i + 1)*rmin"
            by (simp add: distrib_right)
          have Eq2: "real i + 1 = real (i+1)" by simp
          from Eq1 Eq2
          have Eq3: "real i * rmin + rmin = real (i+1) * rmin"
            by(simp)

          from F2 have cp1: "correct p (te p (i+1))"
            by simp
          from F2 have cp2: "correct p (te p i)"
            by simp
          from cp1 rts1d have "rmin \<le> te p (i+1) - te p i"
            by simp
          hence Eq4: "te p i + rmin \<le> te p (i+1)" by simp
          from ind_hyp have "real i * rmin + rmin \<le> te p i + rmin"
            by (simp)
          from this Eq4 have "real i * rmin + rmin \<le> te p (i+1)"
            by simp
          from this Eq3 show ?thesis by simp
        qed
      qed
    qed

    have F4: "\<forall> (i::nat). real i * rmin \<le> t"
    proof
      fix i::nat
      from F1 have "te p i \<le> t" by simp
      moreover
      from F3 have "real i * rmin \<le> te p i" by simp
      ultimately show "real i * rmin \<le> t" by simp
    qed

    from constants_ax have "0 < rmin" by simp

    from this reals_Archimedean3
    have Archi: "\<exists> (k::nat). t < real k * rmin"
      by blast

    from Archi obtain k::nat where C: "t < real k * rmin" ..

    from F4 have "real k * rmin \<le> t" by simp
    hence notC: "\<not> (t < real k * rmin)" by simp

    from C notC show False by simp
  qed
qed

subsection{* Agreement property *}

definition "\<gamma>1 x = \<pi> (2*\<rho>*\<beta> + 2*\<Lambda>) (2*\<Lambda> + x + 2*\<rho>*(rmax + \<beta>))"
definition "\<gamma>2 x = x + 2*\<rho>*rmax"
definition "\<gamma>3 x = \<alpha> (2*\<Lambda> + x + 2*\<rho>*(rmax + \<beta>)) + \<Lambda> + 2*\<rho>*\<beta>"

definition
  okmaxsync :: "[nat, Clocktime] \<Rightarrow> bool" where
  "okmaxsync i x \<longleftrightarrow> (\<forall> p q. correct p (max (te p i) (te q i))
     \<and> correct q (max (te p i) (te q i)) \<longrightarrow>
       \<bar>IC p i (max (te p i) (te q i)) - IC q i (max (te p i) (te q i))\<bar> \<le> x)"

definition
  okClocks :: "[process, process, nat] \<Rightarrow> bool" where
  "okClocks p q i \<longleftrightarrow> (\<forall> t. 0 \<le> t \<and> t < max (te p i) (te q i)
        \<and> correct p t \<and> correct q t
     \<longrightarrow> \<bar>VC p t - VC q t\<bar> \<le> \<delta>)"

lemma okClocks_sym:
assumes ok_pq: "okClocks p q i"
shows "okClocks q p i"
proof-
  {
    fix t :: time
    assume ie1: "0 \<le> t"
    assume ie2: "t < max (te q i) (te p i)"
    assume corr_q: "correct q t"
    assume corr_p: "correct p t"

    have "max (te q i) (te p i) = max (te p i) (te q i)"
      by (simp add: max_def)
    from this ok_pq ie1 ie2 corr_p corr_q
    have "\<bar>VC q t - VC p t\<bar> \<le> \<delta>"
      by(simp add: abs_minus_commute okClocks_def)
  }
  thus ?thesis by (simp add: okClocks_def)
qed

lemma ICp_Suc:
assumes corr_p: "correct p (te p (i+1))"
shows "IC p (i+1) (te p (i+1)) = cfn p (\<theta> p (i+1)) "
using corr_p IClock by(simp add: Adj_def)

lemma IC_trans_inv:
assumes ie1: "te q (i+1) \<le> te p (i+1)"
and corr_p: "correct p (te p (i+1))"
and corr_q: "correct q (te p (i+1))"
shows
"IC q (i+1) (te p (i+1)) =
  cfn q (\<lambda> n. \<theta> q (i+1) n + (PC q (te p (i+1)) - PC q (te q (i+1))))"
(is "?T1 = ?T2")
proof-
  let ?X = "PC q (te p (i+1)) - PC q (te q (i+1))"

  from corr_q ie1 PC_monotone have posX: "0 \<le> ?X"
    by (simp add: le_diff_eq)
  from IClock corr_q have "?T1 = cfn q (\<theta> q (i+1)) + ?X"
    by(simp add: Adj_def)

  from this posX trans_inv show ?thesis by simp
qed

lemma beta_rho:
assumes ie: "te q (i+1) \<le> te p (i+1)"
and corr_p: "correct p (te p (i+1))"
and corr_q: "correct q (te p (i+1))"
and corr_l: "correct l (te p (i+1))"
shows "\<bar>(PC l (te p (i+1)) - PC l (te q (i+1))) - (te p (i+1) - te q (i+1))\<bar> \<le> \<beta>*\<rho>"
proof-
  let ?X = "(PC l (te p (i+1)) - PC l (te q (i+1)))"
  let ?D = "te p (i+1) - te q (i+1)"

  from ie have posD: "0 \<le> ?D" by simp

  from ie PC_monotone corr_l have posX: "0 \<le> ?X"
    by (simp add: le_diff_eq)
  from ie corr_l rate_1 have bound1: "?X \<le> ?D * (1 + \<rho>)" by simp
  from ie corr_l correct_closed have corr_l_tq: "correct l (te q (i+1))"
    by(blast)
  from ie corr_q correct_closed have corr_q_tq: "correct q (te q (i+1))"
    by blast
  from corr_q_tq corr_p rts2b have "\<bar>?D\<bar> \<le> \<beta>"
    by(simp)
  from this constants_ax posD have D_beta: "?D*\<rho> \<le> \<beta>*\<rho>"
    by(simp add: abs_if)

  show ?thesis
  proof cases
    assume A: "?D \<le> ?X"
    from posX posD A have absEq: "\<bar>?X - ?D\<bar> = ?X - ?D"
      by(simp add: abs_if)
    from bound1 have bound2: "?X - ?D \<le> ?D*\<rho>"
      by(simp add: mult.commute distrib_right)
    from D_beta absEq bound2 show ?thesis by simp
  next
    assume notA: "\<not> (?D \<le> ?X)"
    from this have absEq2: "\<bar>?X - ?D\<bar> = ?D - ?X"
      by(simp add: abs_if)
    from ie corr_l rate_2 have bound3: "?D*(1 - \<rho>) \<le> ?X" by simp
    from this have "?D - ?X \<le> ?D*\<rho>" by (simp add: algebra_simps)
    from this absEq2 D_beta show ?thesis by simp
  qed
qed

text{* This lemma (and the next one pe-cond2) proves an assumption used
in the precision enhancement. *}

lemma pe_cond1:
assumes ie: "te q (i+1) \<le> te p (i+1)"
and corr_p: "correct p (te p (i+1))"
and corr_q: "correct q (te p (i + 1))"
and corr_l: "correct l (te p (i+1))"
shows "\<bar>\<theta> q (i+1) l + (PC q (te p (i+1)) - PC q (te q (i+1))) -
           \<theta> p (i+1) l\<bar> \<le> 2* \<rho> * \<beta> + 2*\<Lambda>"
(is "?M \<le> ?N")
proof-
  let ?Xl = "(PC l (te p (i+1)) - PC l (te q (i+1)))"
  let ?Xq = "(PC q (te p (i+1)) - PC q (te q (i+1)))"
  let ?D = "te p (i+1) - te q (i+1)"
  let ?T = "\<theta> p (i+1) l - \<theta> q (i+1) l"
  let ?RE1 = "\<theta> p (i+1) l - IC l i (te p (i+1))"
  let ?RE2 = "\<theta> q (i+1) l - IC l i (te q (i+1))"
  let ?ICT = "IC l i (te p (i+1)) - IC l i (te q (i+1))"

  have "?M = \<bar>(?Xq - ?D) - (?T - ?D)\<bar>"
  by(simp add: abs_if)

  hence Split: "?M \<le> \<bar>?Xq - ?D\<bar> + \<bar>?T - ?D\<bar>"
    by(simp add: abs_if)

  from ie corr_q correct_closed have corr_q_tq: "correct q (te q (i+1))"
    by(blast)
  from ie corr_l correct_closed have corr_l_tq: "correct l (te q (i+1))"
    by blast

  from corr_p corr_q corr_l ie beta_rho
  have XlD: "\<bar>?Xl - ?D\<bar> \<le> \<beta>*\<rho>"
    by simp

  from corr_p corr_q ie beta_rho
  have XqD: "\<bar>?Xq - ?D\<bar> \<le> \<beta>*\<rho>" by simp

  have TD: "\<bar>?T - ?D\<bar> \<le> 2*\<Lambda> + \<beta>*\<rho>"
  proof-
    have Eq1: "\<bar>?T - ?D\<bar> = \<bar>(?T - ?ICT) + (?ICT - ?D)\<bar>" (is "?E1 = ?E2")
      by (simp add: abs_if)

    have Eq2: "?E2 \<le> \<bar>?T - ?ICT\<bar> + \<bar>?ICT - ?D\<bar>"
      by(simp add: abs_if)

    have Eq3: "\<bar>?T - ?ICT\<bar> \<le>  \<bar>?RE1\<bar> + \<bar>?RE2\<bar>"
      by(simp add: abs_if)

    from readerror corr_p corr_l
    have Eq4: "\<bar>?RE1\<bar> \<le> \<Lambda>" by simp

    from corr_l_tq corr_q_tq this readerror
    have Eq5: "\<bar>?RE2\<bar> \<le> \<Lambda>" by simp

    from Eq3 Eq4 Eq5 have Eq6: "\<bar>?T - ?ICT\<bar> \<le> 2*\<Lambda>"
      by simp

    have Eq7: "?ICT - ?D = ?Xl - ?D"
    proof-
      from corr_p rte have "te p i \<le> te p (i+1)"
        by(simp)
      from this corr_l correct_closed have corr_l_tpi: "correct l (te p i)"
        by blast
      from corr_q_tq rte have "te q i \<le> te q (i+1)"
        by simp
      from this corr_l_tq correct_closed have corr_l_tqi: "correct l (te q i)"
        by blast

      from IClock corr_l
      have F1: "IC l i (te p (i+1)) = PC l (te p (i+1)) + Adj l i"
        by(simp)
      from IClock corr_l_tq
      have F2: "IC l i (te q (i+1)) = PC l (te q (i+1)) + Adj l i"
        by simp
      from F1 F2 show ?thesis by(simp)
    qed

    from this XlD have Eq8: "\<bar>?ICT - ?D\<bar> \<le> \<beta>*\<rho>"
      by arith
    from Eq1 Eq2 Eq6 Eq8 show ?thesis
      by(simp)
  qed

  from Split XqD TD have F1: "?M \<le> 2* \<beta> * \<rho> + 2*\<Lambda>"
    by(simp)
  have F2: "2 * \<rho> * \<beta> + 2*\<Lambda> = 2* \<beta> * \<rho> + 2*\<Lambda>"
    by simp
  from F1 show ?thesis by (simp only: F2)

qed

lemma pe_cond2:
assumes ie: "te m i \<le> te l i"
and corr_k: "correct k (te k (i+1))"
and corr_l_tk: "correct l (te k (i+1))"
and corr_m_tk: "correct m (te k (i+1))"
and ind_hyp: "\<bar>IC l i (te l i) - IC m i (te l i)\<bar> \<le> \<delta>S"
shows "\<bar>\<theta> k (i+1) l - \<theta> k (i+1) m\<bar> \<le> 2*\<Lambda> + \<delta>S + 2*\<rho>*(rmax + \<beta>)"
proof-
  let ?X = "\<theta> k (i+1) l - \<theta> k (i+1) m"
  let ?N = "2*\<Lambda> + \<delta>S + 2*\<rho>*(rmax + \<beta>)"
  let ?D1 = "\<theta> k (i+1) l - IC l i (te k (i+1))"
  let ?D2 = "\<theta> k (i+1) m - IC m i (te k (i+1))"
  let ?ICS = "IC l i (te k (i+1)) - IC m i (te k (i+1))"
  let ?tlm = "te l i"
  let ?IC = "IC l i ?tlm - IC m i ?tlm"

  have Eq1: "\<bar>?X\<bar> = \<bar>(?D1 - ?D2) + ?ICS\<bar>" (is "?E1 = ?E2")
    by (simp add: abs_if)

  have Eq2: "?E2 \<le> \<bar>?D1 - ?D2\<bar> + \<bar>?ICS\<bar>" by (simp add: abs_if)

  from corr_l_tk corr_k beta_bound1 have ie_lk: "te l i \<le> te k (i+1)"
    by (simp add: le_diff_eq)

  from this corr_l_tk correct_closed have corr_l: "correct l (te l i)"
    by blast

  from ie_lk corr_l_tk corr_m_tk IC_bd
  have Eq3: "\<bar>?ICS\<bar> \<le> \<bar>?IC\<bar> + 2*\<rho>*(te k (i+1) - ?tlm)"
    by simp
  from this ind_hyp have Eq4: "\<bar>?ICS\<bar> \<le> \<delta>S + 2*\<rho>*(te k (i+1) - ?tlm)"
    by simp

  from corr_l corr_k beta_bound2 have "te k (i+1) - ?tlm \<le> rmax + \<beta>"
    by simp
  from this constants_ax have "2*\<rho>*(te k (i+1) - ?tlm) \<le> 2*\<rho>*(rmax + \<beta>)"
    by (simp add: real_mult_le_cancel_iff2)
  from this Eq4 have Eq4a: "\<bar>?ICS\<bar> \<le> \<delta>S + 2*\<rho>*(rmax + \<beta>)"
    by (simp)

  from corr_k corr_l_tk readerror
  have Eq5: "\<bar>?D1\<bar> \<le> \<Lambda>" by simp
  from corr_k corr_m_tk readerror
  have Eq6: "\<bar>?D2\<bar> \<le> \<Lambda>" by simp
  have "\<bar>?D1 - ?D2\<bar> \<le> \<bar>?D1\<bar> + \<bar>?D2\<bar>" by (simp add: abs_if)
  from this Eq5 Eq6 have Eq7: "\<bar>?D1 - ?D2\<bar> \<le> 2*\<Lambda>"
    by (simp)

  from Eq1 Eq2 Eq4a Eq7 split show ?thesis by (simp)
qed

lemma theta_bound:
assumes corr_l: "correct l (te p (i+1))"
and corr_m: "correct m (te p (i+1))"
and corr_p: "correct p (te p (i+1))"
and IC_bound:
    "\<bar>IC l i (max (te l i) (te m i)) - IC m i (max (te l i) (te m i))\<bar>
      \<le> \<delta>S"
shows "\<bar>\<theta> p (i+1) l - \<theta> p (i+1) m\<bar>
       \<le>  2*\<Lambda> + \<delta>S + 2*\<rho>*(rmax + \<beta>)"
proof-
  from corr_p corr_l beta_bound1 have tli_le_tp: "te l i \<le> te p (i+1)"
    by (simp add: le_diff_eq)
  from corr_p corr_m beta_bound1 have tmi_le_tp: "te m i \<le> te p (i+1)"
    by (simp add: le_diff_eq)

  let ?tml = "max (te l i) (te m i)"
  from tli_le_tp tmi_le_tp have tml_le_tp: "?tml \<le> te p (i+1)"
    by simp

  from tml_le_tp corr_l correct_closed have corr_l_tml: "correct l ?tml"
    by blast
  from tml_le_tp corr_m correct_closed have corr_m_tml: "correct m ?tml"
    by blast

  let ?Y = "2*\<Lambda> + \<delta>S + 2*\<rho>*(rmax + \<beta>)"
  show "\<bar>\<theta> p (i+1) l - \<theta> p (i+1) m\<bar> \<le> ?Y"
  proof cases
    assume A: "te m i < te l i"

    from this IC_bound
    have "\<bar>IC l i (te l i) - IC m i (te l i)\<bar> \<le> \<delta>S"
      by(simp add: max_def)
    from this A corr_p corr_l corr_m pe_cond2
    show ?thesis by(simp)
  next
    assume "\<not> (te m i < te l i)"
    hence Eq1: "te l i \<le> te m i" by simp
    from this IC_bound
    have Eq2: "\<bar>IC l i (te m i) - IC m i (te m i)\<bar> \<le> \<delta>S"
      by(simp add: max_def)

    hence "\<bar>IC m i (te m i) - IC l i (te m i)\<bar> \<le> \<delta>S"
      by (simp add: abs_minus_commute)
    from this Eq1 corr_p corr_l corr_m pe_cond2
    have "\<bar>\<theta> p (i+1) m - \<theta> p (i+1) l\<bar> \<le> ?Y"
      by(simp)
    thus ?thesis by (simp add: abs_minus_commute)
  qed
qed

lemma four_one_ind_half:
  assumes ie1: "\<beta> \<le> rmin"
  and ie2: "\<mu> \<le> \<delta>S"
  and ie3: "\<gamma>1 \<delta>S \<le> \<delta>S"
  and ind_hyp: "okmaxsync i \<delta>S"
  and ie4: "te q (i+1) \<le> te p (i+1)"
  and corr_p: "correct p (te p (i+1))"
  and corr_q: "correct q (te p (i+1))"
shows "\<bar>IC p (i+1) (te p (i+1)) - IC q (i+1) (te p (i+1))\<bar> \<le> \<delta>S"
proof-
  let ?tpq = "te p (i+1)"

  let ?f = "\<lambda> n. \<theta> q (i+1) n + (PC q (te p (i+1)) - PC q (te q (i+1)))"
  let ?g = "\<theta> p (i+1)"

  from ie4 corr_q correct_closed have corr_q_tq: "correct q (te q (i+1))"
    by blast

  have Eq_IC_cfn: "\<bar>IC p (i+1) ?tpq - IC q (i+1) ?tpq\<bar> =
    \<bar>cfn q ?f - cfn p ?g\<bar>"
  proof-
    from corr_p ICp_Suc have Eq1: "IC p (i+1) ?tpq = cfn p ?g" by simp

    from ie4 corr_p corr_q IC_trans_inv
    have Eq2: "IC q (i+1) ?tpq = cfn q ?f" by simp

    from Eq1 Eq2 show ?thesis by(simp add: abs_if)
  qed

  let ?ppred = "\<lambda> l. correct l (te p (i+1))"

  let ?X = "2*\<rho>*\<beta> + 2*\<Lambda>"
  have "\<forall> l. ?ppred l \<longrightarrow> \<bar>?f l - ?g l\<bar> \<le> ?X"
  proof -
    {
      fix l
      assume "?ppred l"
      from ie4 corr_p corr_q this pe_cond1
      have "\<bar>?f l - ?g l\<bar> \<le> (2*\<rho>*\<beta> + 2*\<Lambda>)"
        by(auto)
    }
    thus ?thesis by blast
  qed
  hence cond1: "okRead2 ?f ?g ?X ?ppred"
    by(simp add: okRead2_def)

  let ?Y = "2*\<Lambda> + \<delta>S + 2*\<rho>*(rmax + \<beta>)"

  have "\<forall> l m. ?ppred l \<and> ?ppred m \<longrightarrow> \<bar>?f l - ?f m\<bar> \<le> ?Y"
  proof-
    {
      fix l m
      assume corr_l: "?ppred l"
      assume corr_m: "?ppred m"

      from corr_p corr_l beta_bound1 have tli_le_tp: "te l i \<le> te p (i+1)"
        by (simp add: le_diff_eq)
      from corr_p corr_m beta_bound1 have tmi_le_tp: "te m i \<le> te p (i+1)"
        by (simp add: le_diff_eq)

      let ?tlm = "max (te l i) (te m i)"

      from tli_le_tp tmi_le_tp have tlm_le_tp: "?tlm \<le> te p (i+1)"
        by simp

      from ie4 corr_l correct_closed have corr_l_tq: "correct l (te q (i+1))"
        by blast
      from ie4 corr_m correct_closed have corr_m_tq: "correct m (te q (i+1))"
        by blast
      from tlm_le_tp corr_l correct_closed have corr_l_tlm: "correct l ?tlm"
        by blast
      from tlm_le_tp corr_m correct_closed have corr_m_tlm: "correct m ?tlm"
        by blast

      from ind_hyp corr_l_tlm corr_m_tlm
      have EqAbs1: "\<bar>IC l i ?tlm - IC m i ?tlm\<bar> \<le> \<delta>S"
        by(auto simp add: okmaxsync_def)

      have EqAbs3: "\<bar>?f l - ?f m\<bar> = \<bar>\<theta> q (i+1) l - \<theta> q (i+1) m\<bar>"
        by (simp add: abs_if)

      from EqAbs1 corr_q_tq corr_l_tq corr_m_tq theta_bound
      have "\<bar>\<theta> q (i+1) l - \<theta> q (i+1) m\<bar> \<le> ?Y"
        by simp
      from this EqAbs3  have "\<bar>?f l - ?f m\<bar> \<le> ?Y"
        by simp
    }
    thus ?thesis by simp
  qed
  hence cond2a: "okRead1 ?f ?Y ?ppred" by (simp add: okRead1_def)

  have "\<forall> l m. ?ppred l \<and> ?ppred m \<longrightarrow> \<bar>?g l - ?g m\<bar> \<le> ?Y"
  proof-
    {
      fix l m
      assume corr_l: "?ppred l"
      assume corr_m: "?ppred m"

      from corr_p corr_l beta_bound1 have tli_le_tp: "te l i \<le> te p (i+1)"
        by (simp add: le_diff_eq)
      from corr_p corr_m beta_bound1 have tmi_le_tp: "te m i \<le> te p (i+1)"
        by (simp add: le_diff_eq)

      let ?tlm = "max (te l i) (te m i)"
      from tli_le_tp tmi_le_tp have tlm_le_tp: "?tlm \<le> te p (i+1)"
        by simp

      from tlm_le_tp corr_l correct_closed have corr_l_tlm: "correct l ?tlm"
        by blast
      from tlm_le_tp corr_m correct_closed have corr_m_tlm: "correct m ?tlm"
        by blast

      from ind_hyp corr_l_tlm corr_m_tlm
      have EqAbs1: "\<bar>IC l i ?tlm - IC m i ?tlm\<bar> \<le> \<delta>S"
        by(auto simp add: okmaxsync_def)

      from EqAbs1 corr_p corr_l corr_m theta_bound
      have "\<bar>?g l - ?g m\<bar> \<le> ?Y" by simp
    }
    thus ?thesis by simp
  qed
  hence cond2b: "okRead1 ?g ?Y ?ppred" by (simp add: okRead1_def)

  from correct_count have "np - maxfaults \<le> count ?ppred np"
    by simp
  from this corr_p corr_q cond1 cond2a cond2b prec_enh
  have "\<bar>cfn q ?f - cfn p ?g\<bar> \<le> \<pi> ?X ?Y"
    by blast

  from ie3 this have "\<bar>cfn q ?f - cfn p ?g\<bar> \<le> \<delta>S"
    by (simp add: \<gamma>1_def)

  from this Eq_IC_cfn show ?thesis by (simp)
qed

text{* Theorem 4.1 in Shankar's paper. *}

theorem four_one:
  assumes ie1: "\<beta> \<le> rmin"
  and ie2: "\<mu> \<le> \<delta>S"
  and ie3: "\<gamma>1 \<delta>S \<le> \<delta>S"
shows "okmaxsync i \<delta>S"
proof(induct i)
  show "okmaxsync 0 \<delta>S"
  proof-
    {
      fix p q
      assume corr_p: "correct p (max (te p 0) (te q 0))"
      assume corr_q: "correct q (max (te p 0) (te q 0))"

      from corr_p synch0 have cp0: "correct p 0" by simp
      from corr_q synch0 have cq0: "correct q 0" by simp

      from synch0 cp0 cq0 IClock
      have IC_eq_PC:
        "\<bar>IC p 0 (max (te p 0) (te q 0)) - IC q 0 (max (te p 0) (te q 0))\<bar>
         = \<bar>PC p 0 - PC q 0\<bar>" (is "?T1 = ?T2")
        by(simp add: Adj_def)

      from ie2 init synch0 cp0 have range1: "0 \<le> PC p 0 \<and> PC p 0 \<le> \<delta>S"
        by auto
      from ie2 init synch0 cq0 have range2: "0 \<le> PC q 0 \<and> PC q 0 \<le> \<delta>S"
        by auto
      have "?T2 \<le> \<delta>S"
      proof cases
        assume A:"PC p 0 < PC q 0"
        from A range1 range2 show ?thesis
          by(auto simp add: abs_if)
      next
        assume notA: "\<not> (PC p 0 < PC q 0)"
        from notA range1 range2 show ?thesis
          by(auto simp add: abs_if)
      qed
      from this IC_eq_PC have "?T1 \<le> \<delta>S" by simp
    }
    thus ?thesis by (simp add: okmaxsync_def)
  qed
next
  fix i assume ind_hyp: "okmaxsync i \<delta>S"
  show "okmaxsync (Suc i) \<delta>S"
  proof-
    {
      fix p q
      assume corr_p: "correct p (max (te p (i + 1)) (te q (i + 1)))"
      assume corr_q: "correct q (max (te p (i + 1)) (te q (i + 1)))"
      let ?tp = "te p (i + 1)"
      let ?tq = "te q (i + 1)"
      let ?tpq = "max ?tp ?tq"

      have "\<bar>IC p (i+1) ?tpq - IC q (i+1) ?tpq\<bar> \<le> \<delta>S" (is "?E1 \<le> \<delta>S")
      proof cases
        assume A: "?tq < ?tp"
        from A corr_p have cp1: "correct p (te p (i+1))"
          by (simp add: max_def)
        from A corr_q have cq1: "correct q (te p (i+1))"
          by (simp add: max_def)
        from A
        have Eq1: "?E1 = \<bar>IC p (i+1) (te p (i+1)) - IC q (i+1) (te p (i+1))\<bar>"
                  (is "?E1 = ?E2")
          by (simp add: max_def)
        from A cp1 cq1 corr_p corr_q ind_hyp ie1 ie2 ie3
          four_one_ind_half
        have "?E2 \<le> \<delta>S" by (simp)
        from this Eq1 show ?thesis by simp
      next
        assume notA: "\<not> (?tq < ?tp)"
        from this corr_p have cp2: "correct p (te q (i+1))"
          by (simp add: max_def)
        from notA corr_q have cq2: "correct q (te q (i+1))"
          by (simp add: max_def)
        from notA
        have Eq2: "?E1 = \<bar>IC q (i+1) (te q (i+1)) - IC p (i+1) (te q (i+1))\<bar>"
                  (is "?E1  = ?E3")
          by (simp add: max_def abs_minus_commute)
        from notA have "?tp \<le> ?tq" by simp
        from this cp2 cq2 ind_hyp ie1 ie2 ie3 four_one_ind_half
        have "?E3 \<le> \<delta>S"
          by simp
        from this Eq2 show ?thesis by (simp)
      qed
    }
    thus ?thesis by (simp add: okmaxsync_def)
  qed
qed

lemma VC_cfn:
  assumes corr_p: "correct p (te p (i+1))"
  and ie: "te p (i+1) < te p (i+2)"
shows "VC p (te p (i+1)) = cfn p (\<theta> p (i+1))"
proof-
  from ie corr_p VClock have "VC p (te p (i+1)) = IC p (i+1) (te p (i+1))"
    by simp
  moreover
  from corr_p IClock
  have "IC p (i+1) (te p (i+1)) = PC p (te p (i+1)) + Adj p (i+1)"
    by blast
  moreover
  have "PC p (te p (i+1)) + Adj p (i+1) = cfn p (\<theta> p (i+1))"
    by(simp add: Adj_def)
  ultimately show ?thesis by simp
qed

text{* Lemma for the inductive case in Theorem 4.2 *}

lemma four_two_ind:
  assumes ie1: "\<beta> \<le> rmin"
  and ie2: "\<mu> \<le> \<delta>S"
  and ie3: "\<gamma>1 \<delta>S \<le> \<delta>S"
  and ie4: "\<gamma>2 \<delta>S \<le> \<delta>"
  and ie5: "\<gamma>3 \<delta>S \<le> \<delta>"
  and ie6: "te q (i+1) \<le> te p (i+1)"
  and ind_hyp: "okClocks p q i"
  and t_bound1: "0 \<le> t"
  and t_bound2: "t < max (te p (i+1)) (te q (i+1))"
  and t_bound3: "max (te p i) (te q i) \<le> t"
  and tpq_bound: "max (te p i) (te q i) < max (te p (i+1)) (te q (i+1))"
  and corr_p: "correct p t"
  and corr_q: "correct q t"
shows "\<bar>VC p t - VC q t\<bar> \<le> \<delta>"
proof cases
  assume A: "t < te q (i+1)"

  let ?tpq = "max (te p i) (te q i)"

  have Eq1: "te p i \<le> t \<and> te q i \<le> t"
  proof cases
    assume "te p i \<le> te q i"
    from this  t_bound3 show ?thesis by (simp add: max_def)
  next
    assume "\<not> (te p i \<le> te q i)"
    from this t_bound3 show ?thesis by (simp add: max_def)
  qed

  from ie6 have tp_max: "max (te p (i+1)) (te q (i+1)) = te p (i+1)"
    by(simp add: max_def)
  from this t_bound2 have Eq2: "t < te p (i+1)" by simp

  from VClock Eq1 Eq2 corr_p have Eq3: "VC p t = IC p i t" by simp

  from VClock Eq1 A corr_q have Eq4: "VC q t = IC q i t" by simp
  from Eq3 Eq4 have Eq5: "\<bar>VC p t - VC q t\<bar> = \<bar>IC p i t - IC q i t\<bar>"
    by simp

  from t_bound3 corr_p corr_q correct_closed
  have corr_tpq: "correct p ?tpq \<and> correct q ?tpq"
    by(blast)

  from t_bound3 IC_bd corr_p corr_q
  have Eq6: "\<bar>IC p i t - IC q i t\<bar>  \<le> \<bar>IC p i ?tpq - IC q i ?tpq\<bar>
    + 2*\<rho>*(t - ?tpq)" (is "?E1 \<le> ?E2")
    by(blast)

  from ie1 ie2 ie3 four_one have "okmaxsync i \<delta>S" by simp

  from this corr_tpq have "\<bar>IC p i ?tpq - IC q i ?tpq\<bar> \<le> \<delta>S"
    by(simp add: okmaxsync_def)

  from Eq6 this  have Eq7: "?E1 \<le> \<delta>S + 2*\<rho>*(t - ?tpq)" by simp

  from corr_p Eq2 rts0 have "t - te p i \<le> rmax" by simp
  from this have "t - ?tpq \<le> rmax" by (simp add: max_def)
  from this constants_ax have "2*\<rho>*(t - ?tpq) \<le> 2*\<rho>*rmax"
    by (simp add: real_mult_le_cancel_iff1)
  hence "\<delta>S + 2*\<rho>*(t - ?tpq) \<le> \<delta>S + 2*\<rho>*rmax"
    by simp
  from this Eq7 have "?E1 \<le> \<delta>S + 2*\<rho>*rmax" by simp
  from this Eq5 ie4 show ?thesis by(simp add: \<gamma>2_def)
next
  assume "\<not> (t < te q (i+1))"
  hence  B: "te q (i+1) \<le> t" by simp

  from ie6 t_bound2
  have tp_max: "max (te p (i+1)) (te q (i+1)) = te p (i+1)"
    by(simp add: max_def)

  have "te p i \<le> max (te p i) (te q i)"
    by(simp add: max_def)

  from this t_bound3 have tp_bound1: "te p i \<le> t" by simp

  from tp_max t_bound2 have tp_bound2: "t < te p (i+1)" by simp

  have tq_bound1: "t < te q (i+2)"
  proof (rule ccontr)
    assume "\<not> (t < te q (i+2))"
    hence C: "te q (i+2) \<le> t" by simp

    from C corr_q correct_closed
    have corr_q_t2: "correct q (te q (i+2))" by blast

    have "te q (i+1) + \<beta> \<le> t"
    proof-
      from corr_q_t2 rts1d have "rmin \<le> te q (i+2) - te q (i+1)"
        by simp
      from this ie1 have "\<beta> \<le> te q (i+2) - te q (i+1)"
        by simp
      hence "te q (i+1) + \<beta> \<le> te q (i+2)" by simp
      from this C show ?thesis by simp
    qed
    from this corr_p corr_q rts2a have "te p (i+1) \<le> t"
      by blast
    hence "\<not> (t < te p (i+1))" by simp
    from this tp_bound2 show False by simp
  qed

  from tq_bound1 B have tq_bound2: "te q (i+1) < te q (i+2)" by simp
  from B tp_bound2 have tq_bound3: "te q (i+1) < te p (i+1)"
    by simp
  from B corr_p correct_closed
  have corr_p_tq1: "correct p (te q (i+1))" by blast

  from B correct_closed corr_q
  have corr_q_tq1: "correct q (te q (i+1))" by blast

  from corr_p_tq1 corr_q_tq1 beta_bound1
  have tq_bound4: "te p i \<le> te q (i+1)"
    by(simp add: le_diff_eq)

  from tq_bound1 VClock B corr_q
  have Eq1: "VC q t = IC q (i+1) t" by simp

  from VClock tp_bound1 tp_bound2 corr_p
  have Eq2: "VC p t = IC p i t" by simp

  from Eq1 Eq2 have Eq3: "\<bar>VC p t - VC q t\<bar> = \<bar>IC p i t - IC q (i+1) t\<bar>"
    by simp

  from B corr_p corr_q IC_bd
  have "\<bar>IC p i t - IC q (i+1) t\<bar> \<le>
     \<bar>IC p i (te q (i+1)) - IC q (i+1) (te q (i+1))\<bar> + 2*\<rho>*(t - te q (i+1))"
    by simp

  from this Eq3
  have VC_split: "\<bar>VC p t - VC q t\<bar> \<le>
    \<bar>IC p i (te q (i+1)) - IC q (i+1) (te q (i+1))\<bar> + 2*\<rho>*(t - te q (i+1))"
    by simp

  from tq_bound2 VClock corr_q_tq1
  have Eq4: "VC q (te q (i+1)) = IC q (i+1) (te q (i+1))" by simp

  from this tq_bound2 VC_cfn corr_q_tq1
  have Eq5: "IC q (i+1) (te q (i+1)) = cfn q (\<theta> q (i+1))" by simp

  hence IC_eq_cfn: "IC p i (te q (i+1)) - IC q (i+1) (te q (i+1)) =
    IC p i (te q (i+1)) - cfn q (\<theta> q (i+1))"
    (is "?E1 = ?E2")
    by simp

  let ?f = "\<theta> q (i+1)"
  let ?ppred = "\<lambda> l. correct l (te q (i+1))"
  let ?X = "2*\<Lambda> + \<delta>S + 2*\<rho>*(rmax + \<beta>)"

  have "\<forall> l m. ?ppred l \<and> ?ppred m \<longrightarrow> \<bar>\<theta> q (i+1) l - \<theta> q (i+1) m\<bar> \<le> ?X"
  proof-
    {
      fix l :: process
      fix m :: process
      assume corr_l: "?ppred l"
      assume corr_m: "?ppred m"

      let ?tlm = "max (te l i) (te m i)"
      have tlm_bound: "?tlm \<le> te q (i+1)"
      proof-
        from corr_l corr_q_tq1 beta_bound1 have "te l i \<le> te q (i+1)"
          by (simp add: le_diff_eq)
        moreover
        from corr_m corr_q_tq1 beta_bound1 have "te m i \<le> te q (i+1)"
          by (simp add: le_diff_eq)
        ultimately show ?thesis by simp
      qed

      from tlm_bound corr_l corr_m correct_closed
      have corr_tlm: "correct l ?tlm \<and> correct m ?tlm"
        by blast

      have "\<bar>IC l i ?tlm - IC m i ?tlm\<bar> \<le> \<delta>S"
      proof-
        from ie1 ie2 ie3 four_one  have "okmaxsync i \<delta>S"
          by simp
        from this corr_tlm show ?thesis by(simp add: okmaxsync_def)
      qed

      from this corr_l corr_m corr_q_tq1 theta_bound
      have "\<bar>\<theta> q (i+1) l - \<theta> q (i+1) m\<bar> \<le> ?X" by simp
    }
    thus ?thesis by blast
  qed
  hence readOK: "okRead1 (\<theta> q (i+1)) ?X ?ppred"
    by(simp add: okRead1_def)

  let ?E3 = "cfn q (\<theta> q (i+1)) - \<theta> q (i+1) p"
  let ?E4 = "\<theta> q (i+1) p - IC p i (te q (i+1))"

  have "\<bar>?E2\<bar> = \<bar>?E3 + ?E4\<bar>" by (simp add: abs_if)
  hence Eq8: "\<bar>?E2\<bar> \<le> \<bar>?E3\<bar> + \<bar>?E4\<bar>" by (simp add: abs_if)

  from correct_count have ppredOK: "np - maxfaults \<le> count ?ppred np"
    by simp
  from readOK ppredOK corr_p_tq1 corr_q_tq1 acc_prsv
  have "\<bar>?E3\<bar> \<le> \<alpha> ?X"
    by blast
  from this Eq8 have Eq9: "\<bar>?E2\<bar> \<le> \<alpha> ?X + \<bar>?E4\<bar>" by simp

  from corr_p_tq1 corr_q_tq1 readerror
  have "\<bar>?E4\<bar> \<le> \<Lambda>" by simp

  from this Eq9 have Eq10: "\<bar>?E2\<bar> \<le> \<alpha> ?X + \<Lambda>" by simp

  from this VC_split IC_eq_cfn
  have almost_right:
    "\<bar>VC p t - VC q t\<bar> \<le>
     \<alpha> ?X + \<Lambda> + 2*\<rho>*(t - te q (i+1))"
    by simp

  have "t - te q (i+1) \<le> \<beta>"
  proof (rule ccontr)
    assume "\<not> (t - te q (i+1) \<le> \<beta>)"
    hence "te q (i+1) + \<beta> \<le> t" by simp
    from this corr_p corr_q rts2a have "te p (i+1) \<le> t"
      by auto
    hence "\<not> (t < te p (i+1))" by simp
    from this tp_bound2 show False
      by simp
  qed

  from this constants_ax
  have "\<alpha> ?X + \<Lambda> + 2*\<rho>*(t - te q (i+1))
        \<le> \<alpha> ?X + \<Lambda> + 2*\<rho>*\<beta>"
    by (simp)

  from this almost_right
  have "\<bar>VC p t - VC q t\<bar> \<le> \<alpha> ?X + \<Lambda> + 2*\<rho>*\<beta>"
    by arith

  from this ie5 show ?thesis by (simp add: \<gamma>3_def)
qed

text{* Theorem 4.2 in Shankar's paper. *}

theorem four_two:
  assumes ie1: "\<beta> \<le> rmin"
  and ie2: "\<mu> \<le> \<delta>S"
  and ie3: "\<gamma>1 \<delta>S \<le> \<delta>S"
  and ie4: "\<gamma>2 \<delta>S \<le> \<delta>"
  and ie5: "\<gamma>3 \<delta>S \<le> \<delta>"
shows "okClocks p q i"
proof (induct i)
  show "okClocks p q 0"
  proof-
    {
      fix t :: time
      assume t_bound1: "0 \<le> t"
      assume t_bound2: "t < max (te p 0) (te q 0)"
      assume corr_p: "correct p t"
      assume corr_q: "correct q t"
      from t_bound2 synch0 have "t < 0"
        by(simp add: max_def)
      from this t_bound1 have False by simp
      hence "\<bar>VC p t - VC q t\<bar> \<le> \<delta>" by simp
    }
    thus ?thesis by (simp add: okClocks_def)
  qed
next
  fix i::nat assume ind_hyp: "okClocks p q i"
  show "okClocks p q (Suc i)"
  proof -
    {
      fix t :: time
      assume t_bound1: "0 \<le> t"
      assume t_bound2: "t < max (te p (i+1)) (te q (i+1))"
      assume corr_p: "correct p t"
      assume corr_q: "correct q t"

      let ?tpq1 = "max (te p i) (te q i)"
      let ?tpq2 = "max (te p (i+1)) (te q (i+1))"

      have "\<bar>VC p t - VC q t\<bar> \<le> \<delta>"
      proof cases
        assume tpq_bound: "?tpq1 < ?tpq2"
        show ?thesis
        proof cases
          assume "t < ?tpq1"
          from t_bound1 this  corr_p corr_q ind_hyp
          show ?thesis by(simp add: okClocks_def)
        next
          assume "\<not> (t < ?tpq1)"
          hence tpq_le_t: "?tpq1 \<le> t" by arith

          show ?thesis
          proof cases
            assume A: "te q (i+1) \<le> te p (i+1)"

            from this tpq_le_t tpq_bound ie1 ie2 ie3 ie4 ie5
              ind_hyp t_bound1 t_bound2
              corr_p corr_q tpq_bound four_two_ind
            show ?thesis by(simp)
          next
            assume "\<not> (te q (i+1) \<le> te p (i+1))"
            hence B: "te p (i+1) \<le> te q (i+1)" by simp

            from ind_hyp okClocks_sym have ind_hyp1: "okClocks q p i"
              by blast

            have maxsym1: "max (te p (i+1)) (te q (i+1)) = max (te q (i+1)) (te p (i+1))"
              by (simp add: max_def)
            have maxsym2: "max (te p i) (te q i) = max (te q i) (te p i)"
              by (simp add: max_def)

            from maxsym1 t_bound2
            have t_bound21: "t < max (te q (i+1)) (te p (i+1))"
              by simp

            from maxsym1 maxsym2 tpq_bound
            have tpq_bound1: "max (te q i) (te p i) < max (te q (i+1)) (te p (i+1))"
              by simp
            from maxsym2 tpq_le_t
            have tpq_le_t1: "max (te q i) (te p i) \<le> t" by simp

            from B tpq_le_t1 tpq_bound1 ie1 ie2 ie3 ie4 ie5
              ind_hyp1 t_bound1 t_bound21
              corr_p corr_q tpq_bound four_two_ind
            have "\<bar>VC q t - VC p t\<bar> \<le> \<delta>" by(simp)
            thus ?thesis by (simp add: abs_minus_commute)
          qed

        qed
      next
        assume "\<not> (?tpq1 < ?tpq2)"
        hence "?tpq2 \<le> ?tpq1" by arith
        from t_bound2 this have "t < ?tpq1" by arith
        from t_bound1 this corr_p corr_q ind_hyp
        show ?thesis by(simp add: okClocks_def)
      qed
    }
    thus ?thesis by (simp add: okClocks_def)
  qed
qed

text{* The main theorem: all correct clocks are synchronized within the
bound delta. *}

theorem agreement:
  assumes ie1: "\<beta> \<le> rmin"
  and ie2: "\<mu> \<le> \<delta>S"
  and ie3: "\<gamma>1 \<delta>S \<le> \<delta>S"
  and ie4: "\<gamma>2 \<delta>S \<le> \<delta>"
  and ie5: "\<gamma>3 \<delta>S \<le> \<delta>"
  and ie6: "0 \<le> t"
  and cpq: "correct p t \<and> correct q t"
shows "\<bar>VC p t - VC q t\<bar> \<le> \<delta>"
proof-
  from ie6 cpq event_bound have "\<exists> i :: nat. t < max (te p i) (te q i)"
    by simp
  from this obtain i  :: nat where t_bound: "t < max (te p i) (te q i)" ..

  from t_bound ie1 ie2 ie3 ie4 ie5 four_two have "okClocks p q i"
    by simp

  from ie6 this t_bound cpq show ?thesis
    by (simp add: okClocks_def)
qed

end


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

theory Order_Quotient

imports
  Order_Locale
  Order_Morphism
  Quotient_Sets

begin

text {*

The quotient-order modulo @{text "BS_sim"} consists of all pairs
of equivalence classes with witnesses in the order.

*}

definition
  quot_order :: "['a orderT, 'a orderT] \<rightarrow> ('a set) orderT"
where
  quot_order_def: "quot_order BS_leq BS_sim \<defs> \<^relop>{:{x y | \<^infopa>{:x:}{:BS_leq:}{:y:} \<bullet> (\<^eclass>{:x:}{:BS_sim:} \<mapsto> \<^eclass>{:y:}{:BS_sim:})}:}"

notation ("" output)
  quot_order (infixl "'/'/" 90)

notation (zed)
  quot_order ("\<^quotord>{:_:}{:_:}")

text {*

The standard use of quotient orders is to convert a preorder to an
order by taking a quotient with respect to the equivalence induced
by symmetric pairs.

*}

definition
  default_equiv :: "('a orderT) \<rightarrow> ('a orderT)"
where
  default_equiv_def: "default_equiv BS_leq \<defs> (\<olambda> x y \<bullet> \<^infopa>{:x:}{:BS_leq:}{:y:} \<and> \<^infopa>{:y:}{:BS_leq:}{:x:})"

text {*

More generally, the quotient trick will work for any equivalence relation
with respect to which the preorder is antisymmetric.

*}

locale order_cong =
  r: preorder X r +
  BS_sim: equivalence X BS_sim
for
  X::"'a set" and
  r::"'a orderT" and
  BS_sim::"'a orderT" +
assumes
  ocong: "r_congruent (op \<sim>) (op \<hookrightarrow>)" and
  antisym': "(\<forall> x y | \<lch> x, y \<chIn> X \<rch> \<bullet> x \<hookrightarrow> y \<and> y \<hookrightarrow> x \<Rightarrow> x \<sim> y)"

begin

abbreviation
  X_BS_sim_qspace ("X\<^sub>\<sim>")
where
  "X_BS_sim_qspace \<defs> \<^qspace>{:X:}{:(op \<sim>):}"

abbreviation
  r_BS_sim_qorder (infixl "\<hookrightarrow>\<^sub>\<sim>" 50)
where
  "r_BS_sim_qorder \<defs>  \<^quotord>{:(op \<hookrightarrow>):}{:(op \<sim>):}"

lemma quotpoI:
  "\<^poset>{:X\<^sub>\<sim>:}{:(op \<hookrightarrow>\<^sub>\<sim>):}"
proof (rule partial_orderI,
       msafe(inference))
  from non_empty show
      "X\<^sub>\<sim> \<noteq> \<emptyset>"
    by (auto simp add: quot_set_def)
  from r.rel BS_sim.rel show
      "\<^oprel>{:(op \<hookrightarrow>\<^sub>\<sim>):} \<in> X\<^sub>\<sim> \<zrel> X\<^sub>\<sim>"
    by (auto simp add: quot_set_def quot_order_def op2rel_def rel2op_def rel_def eind_def)
next
  fix x
  assume
      "x \<in> X\<^sub>\<sim>"
  with r.refl show
      "x \<hookrightarrow>\<^sub>\<sim> x"
   by (auto simp add: quot_set_def quot_order_def rel2op_def)
next

txt {*

\includegraphics{qord_trans}

*}
  fix
    x y z
  assume
    b1: "x \<in> X\<^sub>\<sim>" "y \<in> X\<^sub>\<sim>" "z \<in> X\<^sub>\<sim>" and
    b2: "x \<hookrightarrow>\<^sub>\<sim> y" and
    b3: "y \<hookrightarrow>\<^sub>\<sim> z"
  from b2 b3 show
      "x \<hookrightarrow>\<^sub>\<sim> z"
    apply (cases x rule: quot_class_cases)
    apply (rule b1)
    apply (cases y rule: quot_class_cases)
    apply (rule b1)
    apply (cases z rule: quot_class_cases)
    apply (rule b1)
    apply (auto simp add: BS_sim.equiv_class_eq quot_set_def quot_order_def rel2op_def)
  proof -
    fix a a' b' b b'' c'' c
    assume
      ca: "a \<in> X" and cc: "c \<in> X" and
      c1: "a' \<hookrightarrow> b'" and c2: "b'' \<hookrightarrow> c''" and
      c3: "a \<sim> a'" and c4: "b \<sim> b'" and
      c5: "b \<sim> b''" and c6: "c \<sim> c''"
    from c1 c3 c4 ocong have
      c7: "a \<hookrightarrow> b"
      by (auto simp add: r_congruent_def)
    also from c2 c5 c6 ocong have
      c8: "b \<hookrightarrow> c"
      by (auto simp add: r_congruent_def)
    finally show
        "(\<exists> x \<bullet> a \<sim> x \<and> (\<exists> y \<bullet> c \<sim> y \<and> x \<hookrightarrow> y))"
      apply (witness "a")
      apply (msafe(inference))
      apply (rule BS_sim.refl [rule_format, OF ca])
      apply (witness "c")
      apply (msafe(inference))
      apply (rule BS_sim.refl [rule_format, OF cc])
      done
  qed
next

txt {*

\includegraphics{qord_antisym}

*}
  fix
    x y
  assume
    b1: "x \<in> X\<^sub>\<sim>" "y \<in> X\<^sub>\<sim>" and
    b2: "x \<hookrightarrow>\<^sub>\<sim> y" and
    b3: "y \<hookrightarrow>\<^sub>\<sim> x"
  from b2 b3 show
      "x = y"
    apply (cases x rule: quot_class_cases)
    apply (rule b1)
    apply (cases y rule: quot_class_cases)
    apply (rule b1)
    apply (auto simp add: BS_sim.equiv_class_eq quot_set_def quot_order_def rel2op_def)
  proof -
    fix a a' a'' b b' b''
    assume
      ca: "a \<in> X" and cb: "b \<in> X" and
      c1: "a' \<hookrightarrow> b'" and c2: "b'' \<hookrightarrow> a''" and
      c3: "a \<sim> a'" and c4: "b \<sim> b'" and
      c5: "b \<sim> b''" and c6: "a \<sim> a''"
    from c1 c3 c4 ocong have
      c7: "a \<hookrightarrow> b"
      by (auto simp add: r_congruent_def)
    moreover from c2 c5 c6 ocong have
      c8: "b \<hookrightarrow> a"
      by (auto simp add: r_congruent_def)
    ultimately show
        "a \<sim> b"
      apply (intro antisym' [rule_format])
      apply (auto simp add: ca cb)
      done
  qed
qed

end

context preorder

begin

abbreviation
  r_equiv (infixl "\<sim>" 50)
where
  "r_equiv \<defs> default_equiv (op \<hookrightarrow>)"

lemma default_order_congI:
  "order_cong X (op \<hookrightarrow>) (op \<sim>)"
  apply (intro_locales)
  apply (auto intro!: setrel_axioms.intro reflexive_axioms.intro transitive_axioms.intro symmetric_axioms.intro order_cong_axioms.intro simp add: r_congruent_def)
proof -
  from rel show
      "\<^oprel>{:(op \<sim>):} \<in> X \<zrel> X"
    by (auto simp add: default_equiv_def op2rel_def rel_def eind_def)
next
  fix
    x
  assume
    "x \<in> X"
  with refl show
      "x \<sim> x"
    by (simp add: default_equiv_def)
next
  fix x y z
  assume b1: "x \<in> X" "y \<in> X" "z \<in> X" and
    b2: "x \<sim> y" and
    b3: "y \<sim> z"
  from b2 have
      "x \<hookrightarrow> y"
    by (simp add: default_equiv_def)
  also from b3 have
      "y \<hookrightarrow> z"
    by (simp add: default_equiv_def)
  finally have
    b4: "x \<hookrightarrow> z"
    by (this)
  from b3 have
      "z \<hookrightarrow> y"
    by (simp add: default_equiv_def)
  also from b2 have
      "y \<hookrightarrow> x"
    by (simp add: default_equiv_def)
  finally have
    b5: "z \<hookrightarrow> x"
    by (this)
  from b4 b5 show
      "x \<sim> z"
    by (simp add: default_equiv_def)
next
  fix
    x y
  assume
      "x \<sim> y"
  then show
      "y \<sim> x"
    by (simp add: default_equiv_def)
next
  fix
    x x' y y'
  assume
    b1: "x \<sim> x'" and
    b2: "y \<sim> y'" and
    b3: "x' \<hookrightarrow> y'"
  from b1 have
      "x \<hookrightarrow> x'"
    by (simp add: default_equiv_def)
  also note b3
  also from b2 have
      "y' \<hookrightarrow> y"
    by (simp add: default_equiv_def)
  finally show
      "x \<hookrightarrow> y"
    by (this)
next
  fix
    x x' y y'
  assume
    b1: "x \<sim> x'" and
    b2: "y \<sim> y'" and
    b3: "x \<hookrightarrow> y"
  from b1 have
      "x' \<hookrightarrow> x"
    by (simp add: default_equiv_def)
  also note b3
  also from b2 have
      "y \<hookrightarrow> y'"
    by (simp add: default_equiv_def)
  finally show
      "x' \<hookrightarrow> y'"
    by (this)
next
  fix
    x y
  assume
      "x \<hookrightarrow> y" "y \<hookrightarrow> x"
  then show
      "x \<sim> y"
    by (simp add: default_equiv_def)
qed

abbreviation
  X_r_qspace :: "'a set set" ("X\<^sub>\<sim>")
where
  "X_r_qspace \<defs> \<^qspace>{:X:}{:(op \<sim>):}"

abbreviation
  r_dqorder (infixl "\<hookrightarrow>\<^sub>\<sim>" 50)
where
  "r_dqorder \<defs>  \<^quotord>{:(op \<hookrightarrow>):}{:(op \<sim>):}"

lemma default_quotient_poI:
    "partial_order X\<^sub>\<sim> (op \<hookrightarrow>\<^sub>\<sim>)"
  apply (rule order_cong.quotpoI)
  apply (rule default_order_congI)
  done

end

context partial_order

begin

lemma ord_congI:
  assumes
    a1: "r_congruent BS_sim (op \<preceq>)" and
    a2: "\<^infopa>{:x_d_1:}{:BS_sim:}{:x_d_2:}" "\<^infopa>{:y_d_1:}{:BS_sim:}{:y_d_2:}" and
    a3: "x_d_1 \<preceq> y_d_1"
  shows "x_d_2 \<preceq> y_d_2"
  using a1 a2 a3
  apply (simp add: r_congruent_def)
  apply (auto)
  done

lemma quot_order_conv:
  assumes
    equiv: "equivalence X BS_sim" and
    cong: "r_congruent BS_sim (op \<preceq>)"
  shows
      "\<^infopa>{:A:}{:\<^quotord>{:(op \<preceq>):}{:BS_sim:}:}{:B:}
      \<Leftrightarrow> A \<in> \<^qspace>{:X:}{:BS_sim:} \<and> B \<in> \<^qspace>{:X:}{:BS_sim:} \<and>
      (\<forall> x y | x \<in> A \<and> y \<in> B \<bullet> x \<preceq> y)"
  apply (auto simp del: ex_simps simp add: quot_order_def quot_set_def rel2op_def relD1 relD2)
  defer
  apply (rule exI, rule exI, msafe(inference), rule HOL.refl, rule HOL.refl)
proof -
  fix x x' y y'
  assume
    "x' \<in> \<^eclass>{:x:}{:BS_sim:}" "y' \<in> \<^eclass>{:y:}{:BS_sim:}" "x \<preceq> y"
  with cong show
      "x' \<preceq> y'"
    by (auto simp add: r_congruent_def equiv_class_def)
next
  fix x y
  assume
    b1: "(\<forall> x' y' | x' \<in> \<^eclass>{:x:}{:BS_sim:} \<and> y' \<in> \<^eclass>{:y:}{:BS_sim:} \<bullet> x' \<preceq> y')" and
    b2: "x \<in> X" "y \<in> X"
  from b2 equiv reflexive.reflD [of X BS_sim] have
    b3: "x \<in> \<^eclass>{:x:}{:BS_sim:}"
    by (auto simp add: equivalence_conv equiv_class_def reflexive_def relD1)
  from b2 equiv reflexive.reflD [of X BS_sim] have
    b4: "y \<in> \<^eclass>{:y:}{:BS_sim:}"
    by (auto simp add: equivalence_conv equiv_class_def reflexive_def relD1)
  from b3 b4 b1 show
      "x \<preceq> y"
    by (auto)
qed

lemma quot_order_conva:
  assumes
    equiv: "equivalence X BS_sim" and
    cong: "r_congruent BS_sim (op \<preceq>)"
  shows
      "\<^infopa>{:\<^eclass>{:x:}{:BS_sim:}:}{:\<^quotord>{:(op \<preceq>):}{:BS_sim:}:}{:\<^eclass>{:y:}{:BS_sim:}:} \<Leftrightarrow> x \<preceq> y" (is "?LHS = ?RHS")
proof (msafe(inference))
  assume
    b1: "?LHS"
  also have
      "?LHS
      \<Leftrightarrow> x \<in> X \<and> y \<in> X \<and> (\<forall> x' y' \<bullet> \<^infopa>{:x:}{:BS_sim:}{:x':} \<and> \<^infopa>{:y:}{:BS_sim:}{:y':} \<Rightarrow> x' \<preceq> y')"
    apply (simp add: quot_order_conv [OF equiv cong] equivalence.quot_set_mem_ec [OF equiv])
    apply (simp add: equiv_class_def)
    done
  also have "\<dots>
      \<Rightarrow> (x \<in> X \<and> y \<in> X) \<and> (\<^infopa>{:x:}{:BS_sim:}{:x:} \<and> \<^infopa>{:y:}{:BS_sim:}{:y:} \<Rightarrow> x \<preceq> y)"
    by (auto)
  also from equiv have "\<dots>
      \<Rightarrow> (\<^infopa>{:x:}{:BS_sim:}{:x:} \<and> \<^infopa>{:y:}{:BS_sim:}{:y:}) \<and> (\<^infopa>{:x:}{:BS_sim:}{:x:} \<and> \<^infopa>{:y:}{:BS_sim:}{:y:} \<Rightarrow> x \<preceq> y)"
    apply (mauto(wind))
    apply (simp add: equivalence_conv reflexive.reflD [of X BS_sim])
    done
  finally show
      "?RHS"
    by (auto)
next
  assume
    b1: "?RHS"
  from b1 show
      "?LHS"
    apply (auto dest: relD1 relD2 simp add: quot_order_conv [OF equiv cong] quot_setI)
    apply (simp add: equiv_class_def)
  proof -
    fix
      x' y'
    assume
        "\<^infopa>{:x:}{:BS_sim:}{:x':}" "\<^infopa>{:y:}{:BS_sim:}{:y':}"
    with cong have
        "x \<preceq> y \<Leftrightarrow> x' \<preceq> y'"
      by (auto simp add: r_congruent_def)
    with b1 show
        "x' \<preceq> y'"
      by (simp)
  qed
qed

lemma quot_poI:
  assumes
    equiv: "equivalence X BS_sim" and
    cong: "r_congruent BS_sim (op \<preceq>)"
  shows
      "\<^poset>{:\<^qspace>{:X:}{:BS_sim:}:}{:\<^quotord>{:(op \<preceq>):}{:BS_sim:}:}"
proof (rule partial_orderI,
       msafe(inference))
  from non_empty show
      "\<^qspace>{:X:}{:BS_sim:} \<noteq> \<emptyset>"
    by (simp add: quot_set_def)
next
  show
      "\<^oprel>{:\<^quotord>{:(op \<preceq>):}{:BS_sim:}:} \<in> \<^qspace>{:X:}{:BS_sim:} \<zrel> \<^qspace>{:X:}{:BS_sim:}"
    by (auto
          dest: relD1 relD2
          simp add: quot_order_def quot_set_def rel_def rel2op_def op2rel_def eind_def)
next
  fix
    A
  assume
    b1: "A \<in> \<^qspace>{:X:}{:BS_sim:}"
  then show
      "\<^infopa>{:A:}{:\<^quotord>{:(op \<preceq>):}{:BS_sim:}:}{:A:}"
    by (auto dest: reflD simp add: quot_set_mem quot_order_conva [OF equiv cong])
next
  fix
    A B C
  assume
      "A \<in> \<^qspace>{:X:}{:BS_sim:}"
      "B \<in> \<^qspace>{:X:}{:BS_sim:}"
      "C \<in> \<^qspace>{:X:}{:BS_sim:}"
      "\<^infopa>{:A:}{:\<^quotord>{:(op \<preceq>):}{:BS_sim:}:}{:B:}"
      "\<^infopa>{:B:}{:\<^quotord>{:(op \<preceq>):}{:BS_sim:}:}{:C:}"
  then show
      "\<^infopa>{:A:}{:\<^quotord>{:(op \<preceq>):}{:BS_sim:}:}{:C:}"
    by (auto dest: transD simp add: quot_set_mem quot_order_conva [OF equiv cong])
next
  fix
    A B
  assume
      "A \<in> \<^qspace>{:X:}{:BS_sim:}"
      "B \<in> \<^qspace>{:X:}{:BS_sim:}"
      "\<^infopa>{:A:}{:\<^quotord>{:(op \<preceq>):}{:BS_sim:}:}{:B:}"
      "\<^infopa>{:B:}{:\<^quotord>{:(op \<preceq>):}{:BS_sim:}:}{:A:}"
  then show
      "A = B"
    by (auto dest: antisymD simp add: quot_set_mem quot_order_conva [OF equiv cong])
qed

end

lemma (in order) quot_orderI:
  assumes
    equiv: "equivalence X BS_sim" and
    cong: "r_congruent BS_sim (op \<preceq>)"
  shows
    "\<^order>{:\<^qspace>{:X:}{:BS_sim:}:}{:\<^quotord>{:(op \<preceq>):}{:BS_sim:}:}"
  apply (rule partial_order.orderIa [OF quot_poI [OF equiv cong]])
  apply (auto dest: linD simp add: quot_set_mem quot_order_conva [OF equiv cong])
  done

end


(*  Title:      HOL/Nonstandard_Analysis/HDeriv.thy
    Author:     Jacques D. Fleuriot
    Copyright:  1998  University of Cambridge
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section \<open>Differentiation (Nonstandard)\<close>

theory HDeriv
  imports HLim
begin

text \<open>Nonstandard Definitions.\<close>

definition nsderiv :: "['a::real_normed_field \<Rightarrow> 'a, 'a, 'a] \<Rightarrow> bool"
    ("(NSDERIV (_)/ (_)/ :> (_))" [1000, 1000, 60] 60)
  where "NSDERIV f x :> D \<longleftrightarrow>
    (\<forall>h \<in> Infinitesimal - {0}. (( *f* f)(star_of x + h) - star_of (f x)) / h \<approx> star_of D)"

definition NSdifferentiable :: "['a::real_normed_field \<Rightarrow> 'a, 'a] \<Rightarrow> bool"
    (infixl "NSdifferentiable" 60)
  where "f NSdifferentiable x \<longleftrightarrow> (\<exists>D. NSDERIV f x :> D)"

definition increment :: "(real \<Rightarrow> real) \<Rightarrow> real \<Rightarrow> hypreal \<Rightarrow> hypreal"
  where "increment f x h =
    (SOME inc. f NSdifferentiable x \<and> inc = ( *f* f) (hypreal_of_real x + h) - hypreal_of_real (f x))"

subsection \<open>Derivatives\<close>

lemma DERIV_NS_iff: "(DERIV f x :> D) \<longleftrightarrow> (\<lambda>h. (f (x + h) - f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S D"
  by (simp add: DERIV_def LIM_NSLIM_iff)

lemma NS_DERIV_D: "DERIV f x :> D \<Longrightarrow> (\<lambda>h. (f (x + h) - f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S D"
  by (simp add: DERIV_def LIM_NSLIM_iff)

lemma Infinitesimal_of_hypreal:
  "x \<in> Infinitesimal \<Longrightarrow> (( *f* of_real) x::'a::real_normed_div_algebra star) \<in> Infinitesimal"
  by (metis Infinitesimal_of_hypreal_iff of_hypreal_def)

lemma of_hypreal_eq_0_iff: "\<And>x. (( *f* of_real) x = (0::'a::real_algebra_1 star)) = (x = 0)"
  by transfer (rule of_real_eq_0_iff)

lemma NSDeriv_unique:
  assumes "NSDERIV f x :> D" "NSDERIV f x :> E"
  shows "NSDERIV f x :> D \<Longrightarrow> NSDERIV f x :> E \<Longrightarrow> D = E"
proof -
  have "\<exists>s. (s::'a star) \<in> Infinitesimal - {0}"
    by (metis Diff_iff HDeriv.of_hypreal_eq_0_iff Infinitesimal_epsilon Infinitesimal_of_hypreal epsilon_not_zero singletonD)
  with assms show ?thesis
    by (meson approx_trans3 nsderiv_def star_of_approx_iff)
qed

text \<open>First \<open>NSDERIV\<close> in terms of \<open>NSLIM\<close>.\<close>

text \<open>First equivalence.\<close>
lemma NSDERIV_NSLIM_iff: "(NSDERIV f x :> D) \<longleftrightarrow> (\<lambda>h. (f (x + h) - f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S D"
  by (auto simp add: nsderiv_def NSLIM_def starfun_lambda_cancel mem_infmal_iff)

text \<open>Second equivalence.\<close>
lemma NSDERIV_NSLIM_iff2: "(NSDERIV f x :> D) \<longleftrightarrow> (\<lambda>z. (f z - f x) / (z - x)) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S D"
  by (simp add: NSDERIV_NSLIM_iff DERIV_LIM_iff LIM_NSLIM_iff [symmetric])

text \<open>While we're at it!\<close>
lemma NSDERIV_iff2:
  "(NSDERIV f x :> D) \<longleftrightarrow>
    (\<forall>w. w \<noteq> star_of x \<and> w \<approx> star_of x \<longrightarrow> ( *f* (\<lambda>z. (f z - f x) / (z - x))) w \<approx> star_of D)"
  by (simp add: NSDERIV_NSLIM_iff2 NSLIM_def)

lemma NSDERIVD5:
  "\<lbrakk>NSDERIV f x :> D; u \<approx> hypreal_of_real x\<rbrakk> \<Longrightarrow>
     ( *f* (\<lambda>z. f z - f x)) u \<approx> hypreal_of_real D * (u - hypreal_of_real x)"
  unfolding NSDERIV_iff2
  apply (case_tac "u = hypreal_of_real x", auto)
  by (metis (mono_tags, lifting) HFinite_star_of Infinitesimal_ratio approx_def approx_minus_iff approx_mult_subst approx_star_of_HFinite approx_sym mult_zero_right right_minus_eq)

lemma NSDERIVD4:
  "\<lbrakk>NSDERIV f x :> D; h \<in> Infinitesimal\<rbrakk>
    \<Longrightarrow> ( *f* f)(hypreal_of_real x + h) - hypreal_of_real (f x) \<approx> hypreal_of_real D * h"
  apply (clarsimp simp add: nsderiv_def)
  apply (case_tac "h = 0", simp)
  by (meson DiffI Infinitesimal_approx Infinitesimal_ratio Infinitesimal_star_of_mult2 approx_star_of_HFinite singletonD)

text \<open>Differentiability implies continuity nice and simple "algebraic" proof.\<close>
lemma NSDERIV_isNSCont:
  assumes "NSDERIV f x :> D" shows "isNSCont f x"
  unfolding isNSCont_NSLIM_iff NSLIM_def
proof clarify
  fix x'
  assume "x' \<noteq> star_of x" "x' \<approx> star_of x"
  then have m0: "x' - star_of x \<in> Infinitesimal - {0}"
    using bex_Infinitesimal_iff by auto
  then have "(( *f* f) x' - star_of (f x)) / (x' - star_of x) \<approx> star_of D"
    by (metis \<open>x' \<approx> star_of x\<close> add_diff_cancel_left' assms bex_Infinitesimal_iff2 nsderiv_def)
  then have "(( *f* f) x' - star_of (f x)) / (x' - star_of x) \<in> HFinite"
    by (metis approx_star_of_HFinite)
  then show "( *f* f) x' \<approx> star_of (f x)"
    by (metis (no_types) Diff_iff Infinitesimal_ratio m0 bex_Infinitesimal_iff insert_iff)
qed

text \<open>Differentiation rules for combinations of functions
  follow from clear, straightforward, algebraic manipulations.\<close>

text \<open>Constant function.\<close>

(* use simple constant nslimit theorem *)
lemma NSDERIV_const [simp]: "NSDERIV (\<lambda>x. k) x :> 0"
  by (simp add: NSDERIV_NSLIM_iff)

text \<open>Sum of functions- proved easily.\<close>

lemma NSDERIV_add:
  assumes "NSDERIV f x :> Da" "NSDERIV g x :> Db"
  shows "NSDERIV (\<lambda>x. f x + g x) x :> Da + Db"
proof -
  have "((\<lambda>x. f x + g x) has_field_derivative Da + Db) (at x)"
    using assms DERIV_NS_iff NSDERIV_NSLIM_iff field_differentiable_add by blast
  then show ?thesis
    by (simp add: DERIV_NS_iff NSDERIV_NSLIM_iff)
qed

text \<open>Product of functions - Proof is simple.\<close>

lemma NSDERIV_mult:
  assumes "NSDERIV g x :> Db" "NSDERIV f x :> Da"
  shows "NSDERIV (\<lambda>x. f x * g x) x :> (Da * g x) + (Db * f x)"
proof -
  have "(f has_field_derivative Da) (at x)" "(g has_field_derivative Db) (at x)"
    using assms by (simp_all add: DERIV_NS_iff NSDERIV_NSLIM_iff)
  then have "((\<lambda>a. f a * g a) has_field_derivative Da * g x + Db * f x) (at x)"
    using DERIV_mult by blast
  then show ?thesis
    by (simp add: DERIV_NS_iff NSDERIV_NSLIM_iff)
qed

text \<open>Multiplying by a constant.\<close>
lemma NSDERIV_cmult: "NSDERIV f x :> D \<Longrightarrow> NSDERIV (\<lambda>x. c * f x) x :> c * D"
  unfolding times_divide_eq_right [symmetric] NSDERIV_NSLIM_iff
      minus_mult_right right_diff_distrib [symmetric]
  by (erule NSLIM_const [THEN NSLIM_mult])

text \<open>Negation of function.\<close>
lemma NSDERIV_minus: "NSDERIV f x :> D \<Longrightarrow> NSDERIV (\<lambda>x. - f x) x :> - D"
proof (simp add: NSDERIV_NSLIM_iff)
  assume "(\<lambda>h. (f (x + h) - f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S D"
  then have deriv: "(\<lambda>h. - ((f(x+h) - f x) / h)) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S - D"
    by (rule NSLIM_minus)
  have "\<forall>h. - ((f (x + h) - f x) / h) = (- f (x + h) + f x) / h"
    by (simp add: minus_divide_left)
  with deriv have "(\<lambda>h. (- f (x + h) + f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S - D"
    by simp
  then show "(\<lambda>h. (f (x + h) - f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S D \<Longrightarrow> (\<lambda>h. (f x - f (x + h)) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S - D"
    by simp
qed

text \<open>Subtraction.\<close>
lemma NSDERIV_add_minus:
  "NSDERIV f x :> Da \<Longrightarrow> NSDERIV g x :> Db \<Longrightarrow> NSDERIV (\<lambda>x. f x + - g x) x :> Da + - Db"
  by (blast dest: NSDERIV_add NSDERIV_minus)

lemma NSDERIV_diff:
  "NSDERIV f x :> Da \<Longrightarrow> NSDERIV g x :> Db \<Longrightarrow> NSDERIV (\<lambda>x. f x - g x) x :> Da - Db"
  using NSDERIV_add_minus [of f x Da g Db] by simp

text \<open>Similarly to the above, the chain rule admits an entirely
  straightforward derivation. Compare this with Harrison's
  HOL proof of the chain rule, which proved to be trickier and
  required an alternative characterisation of differentiability-
  the so-called Carathedory derivative. Our main problem is
  manipulation of terms.\<close>

subsection \<open>Lemmas\<close>

lemma NSDERIV_zero:
  "\<lbrakk>NSDERIV g x :> D; ( *f* g) (star_of x + y) = star_of (g x); y \<in> Infinitesimal; y \<noteq> 0\<rbrakk>
    \<Longrightarrow> D = 0"
  by (force simp add: nsderiv_def)

text \<open>Can be proved differently using \<open>NSLIM_isCont_iff\<close>.\<close>
lemma NSDERIV_approx:
  "NSDERIV f x :> D \<Longrightarrow> h \<in> Infinitesimal \<Longrightarrow> h \<noteq> 0 \<Longrightarrow>
    ( *f* f) (star_of x + h) - star_of (f x) \<approx> 0"
  by (meson DiffI Infinitesimal_ratio approx_star_of_HFinite mem_infmal_iff nsderiv_def singletonD)

text \<open>From one version of differentiability

        \<open>f x - f a\<close>
      \<open>-------------- \<approx> Db\<close>
          \<open>x - a\<close>
\<close>

lemma NSDERIVD1:
    "\<lbrakk>NSDERIV f (g x) :> Da;
     ( *f* g) (star_of x + y) \<noteq> star_of (g x);
     ( *f* g) (star_of x + y) \<approx> star_of (g x)\<rbrakk>
    \<Longrightarrow> (( *f* f) (( *f* g) (star_of x + y)) -
         star_of (f (g x))) / (( *f* g) (star_of x + y) - star_of (g x)) \<approx>
        star_of Da"
  by (auto simp add: NSDERIV_NSLIM_iff2 NSLIM_def)

text \<open>From other version of differentiability

      \<open>f (x + h) - f x\<close>
     \<open>------------------ \<approx> Db\<close>
             \<open>h\<close>
\<close>

lemma NSDERIVD2: "[| NSDERIV g x :> Db; y \<in> Infinitesimal; y \<noteq> 0 |]
      ==> (( *f* g) (star_of(x) + y) - star_of(g x)) / y
          \<approx> star_of(Db)"
  by (auto simp add: NSDERIV_NSLIM_iff NSLIM_def mem_infmal_iff starfun_lambda_cancel)

text \<open>This proof uses both definitions of differentiability.\<close>
lemma NSDERIV_chain:
  "NSDERIV f (g x) :> Da \<Longrightarrow> NSDERIV g x :> Db \<Longrightarrow> NSDERIV (f \<circ> g) x :> Da * Db"
  using DERIV_NS_iff DERIV_chain NSDERIV_NSLIM_iff by blast

text \<open>Differentiation of natural number powers.\<close>
lemma NSDERIV_Id [simp]: "NSDERIV (\<lambda>x. x) x :> 1"
  by (simp add: NSDERIV_NSLIM_iff NSLIM_def del: divide_self_if)

lemma NSDERIV_cmult_Id [simp]: "NSDERIV ((*) c) x :> c"
  using NSDERIV_Id [THEN NSDERIV_cmult] by simp

lemma NSDERIV_inverse:
  fixes x :: "'a::real_normed_field"
  assumes "x \<noteq> 0" \<comment> \<open>can't get rid of \<^term>\<open>x \<noteq> 0\<close> because it isn't continuous at zero\<close>
  shows "NSDERIV (\<lambda>x. inverse x) x :> - (inverse x ^ Suc (Suc 0))"
proof -
  {
    fix h :: "'a star"
    assume h_Inf: "h \<in> Infinitesimal"
    from this assms have not_0: "star_of x + h \<noteq> 0"
      by (rule Infinitesimal_add_not_zero)
    assume "h \<noteq> 0"
    from h_Inf have "h * star_of x \<in> Infinitesimal"
      by (rule Infinitesimal_HFinite_mult) simp
    with assms have "inverse (- (h * star_of x) + - (star_of x * star_of x)) \<approx>
      inverse (- (star_of x * star_of x))"
    proof -
      have "- (h * star_of x) + - (star_of x * star_of x) \<approx> - (star_of x * star_of x)"
        using \<open>h * star_of x \<in> Infinitesimal\<close> assms bex_Infinitesimal_iff by fastforce
      then show ?thesis
        by (metis assms mult_eq_0_iff neg_equal_0_iff_equal star_of_approx_inverse star_of_minus star_of_mult)
    qed
    moreover from not_0 \<open>h \<noteq> 0\<close> assms
    have "inverse (- (h * star_of x) + - (star_of x * star_of x))
          = (inverse (star_of x + h) - inverse (star_of x)) / h"
      by (simp add: division_ring_inverse_diff inverse_mult_distrib [symmetric]
          inverse_minus_eq [symmetric] algebra_simps)
    ultimately have "(inverse (star_of x + h) - inverse (star_of x)) / h \<approx>
      - (inverse (star_of x) * inverse (star_of x))"
      using assms by simp
  }
  then show ?thesis by (simp add: nsderiv_def)
qed

subsubsection \<open>Equivalence of NS and Standard definitions\<close>

lemma divideR_eq_divide: "x /\<^sub>R y = x / y"
  by (simp add: divide_inverse mult.commute)

text \<open>Now equivalence between \<open>NSDERIV\<close> and \<open>DERIV\<close>.\<close>
lemma NSDERIV_DERIV_iff: "NSDERIV f x :> D \<longleftrightarrow> DERIV f x :> D"
  by (simp add: DERIV_def NSDERIV_NSLIM_iff LIM_NSLIM_iff)

text \<open>NS version.\<close>
lemma NSDERIV_pow: "NSDERIV (\<lambda>x. x ^ n) x :> real n * (x ^ (n - Suc 0))"
  by (simp add: NSDERIV_DERIV_iff DERIV_pow)

text \<open>Derivative of inverse.\<close>
lemma NSDERIV_inverse_fun:
  "NSDERIV f x :> d \<Longrightarrow> f x \<noteq> 0 \<Longrightarrow>
    NSDERIV (\<lambda>x. inverse (f x)) x :> (- (d * inverse (f x ^ Suc (Suc 0))))"
  for x :: "'a::{real_normed_field}"
  by (simp add: NSDERIV_DERIV_iff DERIV_inverse_fun del: power_Suc)

text \<open>Derivative of quotient.\<close>
lemma NSDERIV_quotient:
  fixes x :: "'a::real_normed_field"
  shows "NSDERIV f x :> d \<Longrightarrow> NSDERIV g x :> e \<Longrightarrow> g x \<noteq> 0 \<Longrightarrow>
    NSDERIV (\<lambda>y. f y / g y) x :> (d * g x - (e * f x)) / (g x ^ Suc (Suc 0))"
  by (simp add: NSDERIV_DERIV_iff DERIV_quotient del: power_Suc)

lemma CARAT_NSDERIV:
  "NSDERIV f x :> l \<Longrightarrow> \<exists>g. (\<forall>z. f z - f x = g z * (z - x)) \<and> isNSCont g x \<and> g x = l"
  by (simp add: CARAT_DERIV NSDERIV_DERIV_iff isNSCont_isCont_iff)

lemma hypreal_eq_minus_iff3: "x = y + z \<longleftrightarrow> x + - z = y"
  for x y z :: hypreal
  by auto

lemma CARAT_DERIVD:
  assumes all: "\<forall>z. f z - f x = g z * (z - x)"
    and nsc: "isNSCont g x"
  shows "NSDERIV f x :> g x"
proof -
  from nsc have "\<forall>w. w \<noteq> star_of x \<and> w \<approx> star_of x \<longrightarrow>
       ( *f* g) w * (w - star_of x) / (w - star_of x) \<approx> star_of (g x)"
    by (simp add: isNSCont_def)
  with all show ?thesis
    by (simp add: NSDERIV_iff2 starfun_if_eq cong: if_cong)
qed

subsubsection \<open>Differentiability predicate\<close>

lemma NSdifferentiableD: "f NSdifferentiable x \<Longrightarrow> \<exists>D. NSDERIV f x :> D"
  by (simp add: NSdifferentiable_def)

lemma NSdifferentiableI: "NSDERIV f x :> D \<Longrightarrow> f NSdifferentiable x"
  by (force simp add: NSdifferentiable_def)

subsection \<open>(NS) Increment\<close>

lemma incrementI:
  "f NSdifferentiable x \<Longrightarrow>
    increment f x h = ( *f* f) (hypreal_of_real x + h) - hypreal_of_real (f x)"
  by (simp add: increment_def)

lemma incrementI2:
  "NSDERIV f x :> D \<Longrightarrow>
    increment f x h = ( *f* f) (hypreal_of_real x + h) - hypreal_of_real (f x)"
  by (erule NSdifferentiableI [THEN incrementI])

text \<open>The Increment theorem -- Keisler p. 65.\<close>
lemma increment_thm:
  assumes "NSDERIV f x :> D" "h \<in> Infinitesimal" "h \<noteq> 0"
  shows "\<exists>e \<in> Infinitesimal. increment f x h = hypreal_of_real D * h + e * h"
proof -
  have inc: "increment f x h = ( *f* f) (hypreal_of_real x + h) - hypreal_of_real (f x)"
    using assms(1) incrementI2 by auto
  have "(( *f* f) (hypreal_of_real x + h) - hypreal_of_real (f x)) / h \<approx> hypreal_of_real D"
    by (simp add: NSDERIVD2 assms)
  then obtain y where "y \<in> Infinitesimal"
    "(( *f* f) (hypreal_of_real x + h) - hypreal_of_real (f x)) / h = hypreal_of_real D + y"
    by (metis bex_Infinitesimal_iff2)
  then have "increment f x h / h = hypreal_of_real D + y"
    by (metis inc)
  then show ?thesis
    by (metis (no_types) \<open>y \<in> Infinitesimal\<close> \<open>h \<noteq> 0\<close> distrib_right mult.commute nonzero_mult_div_cancel_left times_divide_eq_right)
qed

lemma increment_approx_zero: "NSDERIV f x :> D \<Longrightarrow> h \<approx> 0 \<Longrightarrow> h \<noteq> 0 \<Longrightarrow> increment f x h \<approx> 0"
  by (simp add: NSDERIV_approx incrementI2 mem_infmal_iff)

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.*)
  theory TIP_list_Interleave
imports "../../Test_Base"
begin

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

(*fun did not finish the proof.*)
function interleave :: "'a list => 'a list => 'a list" where
"interleave (nil2) y = y"
| "interleave (cons2 z xs) y = cons2 z (interleave y xs)"
  by pat_completeness auto

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (nil2) = nil2"
| "evens (cons2 y xs) = cons2 y (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 y xs) = evens xs"
by pat_completeness auto

theorem property0 :
  "((interleave (evens xs) (odds xs)) = xs)"
  oops

end


section "Multivariate Polynomials Extension"
theory MPolyExtension
  imports Polynomials.Polynomials (*MPoly_Type_Efficient_Code*) Polynomials.MPoly_Type_Class_FMap
begin

subsection "Definition Lifting"

lift_definition coeff_code::"'a::zero mpoly \<Rightarrow> (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a" is
  "lookup" .

lemma coeff_code[code]: "coeff = coeff_code"
  unfolding coeff_def apply(transfer) by auto

lemma coeff_transfer[transfer_rule]:\<comment> \<open>TODO: coeff should be defined via
lifting, this gives us the illusion\<close>
  "rel_fun cr_mpoly (=) lookup coeff" using coeff_code.transfer[folded
      coeff_code] .

lemmas coeff_add = coeff_add[symmetric]

lemma plus_monom_zero[simp]: "p + MPoly_Type.monom m 0 = p"
  by transfer auto

lift_definition monomials::"'a::zero mpoly \<Rightarrow> (nat \<Rightarrow>\<^sub>0 nat) set" is
  "Poly_Mapping.keys::((nat\<Rightarrow>\<^sub>0nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> _ set" .

lemma mpoly_induct [case_names monom sum]:\<comment> \<open>TODO: overwrites @{thm
mpoly_induct}\<close>
  assumes monom:"\<And>m a. P (MPoly_Type.monom m a)"
    and sum:"(\<And>p1 p2 m a. P p1 \<Longrightarrow> P p2 \<Longrightarrow> p2 = (MPoly_Type.monom m a) \<Longrightarrow> m \<notin> monomials p1
\<Longrightarrow> a \<noteq> 0 \<Longrightarrow> P (p1+p2))"
  shows "P p" using assms
proof (induction p rule: mpoly_induct)
  case (sum p1 p2 m a)
  then show ?case
    by (cases "a = 0") (auto simp: monomials.rep_eq)
qed simp

value "monomials ((Var 0 + Const (3::int) * Var 1)^2)"

lemma Sum_any_lookup_times_eq:
  "(\<Sum>k. ((lookup (x::'a\<Rightarrow>\<^sub>0('b::comm_semiring_1)) (k::'a)) * ((f:: 'a\<Rightarrow>('b::comm_semiring_1)) k))) = (\<Sum>k\<in>keys
x. (lookup x (k::'a)) * (f k))"
  by (subst Sum_any.conditionalize) (auto simp: in_keys_iff intro!:
      Sum_any.cong)

lemma Prod_any_power_lookup_eq:
  "(\<Prod>k::'a. f k ^ lookup (x::'a\<Rightarrow>\<^sub>0nat) k) = (\<Prod>k\<in>keys x. f k ^ lookup x k)"
  by (subst Prod_any.conditionalize) (auto simp: in_keys_iff intro!:
      Prod_any.cong)

lemma insertion_monom: "insertion i (monom m a) = a * (\<Prod>k\<in>keys m. i k ^
lookup m k)"
  by transfer (auto simp: insertion_aux_def insertion_fun_def
      Sum_any_lookup_times_eq Prod_any_power_lookup_eq)

lemma monomials_monom[simp]: "monomials (monom m a) = (if a = 0 then {}
else {m})"
  by transfer auto

lemma finite_monomials[simp]: "finite (monomials m)"
  by transfer auto

lemma monomials_add_disjoint:
  "monomials (a + b) = monomials a \<union> monomials b" if "monomials a \<inter>
monomials b = {}"
  using that
  by transfer (auto simp add: keys_plus_eqI)

lemma coeff_monom[simp]: "coeff (monom m a) m = a"
  by transfer simp

lemma coeff_not_in_monomials[simp]: "coeff m x = 0" if "x \<notin> monomials m"
  using that
  by transfer (simp add: in_keys_iff)

code_thms insertion

lemma insertion_code[code]: "insertion i mp =
   (\<Sum>m\<in>monomials mp. (coeff mp m) * (\<Prod>k\<in>keys m. i k ^ lookup m k))"
proof (induction mp rule: mpoly_induct)
  case (monom m a)
  show ?case
    by (simp add: insertion_monom)
next
  case (sum p1 p2 m a)
  have monomials_add: "monomials (p1 + p2) = insert m (monomials p1)"
    using sum.hyps
    by (auto simp: monomials_add_disjoint)
  have *: "coeff (monom m a) x = 0" if "x \<in> monomials p1" for x
    using sum.hyps that
    by (subst coeff_not_in_monomials) auto
  show ?case
    unfolding insertion_add monomials_add sum.IH
    using sum.hyps
    by (auto simp: coeff_add * algebra_simps)
qed

(* insertion f p
  takes in a mapping from natural numbers to the type of the polynomial and substitutes in
  the constant (f var) for each var variable in polynomial p
*)
code_thms insertion

value "insertion (nth [1, 2.3]) ((Var 0 + Const (3::int) * Var 1)^2)"

(* isolate_variable_sparse p var degree
    returns the coefficient of the term a*var^degree in polynomial p
 *)
lift_definition isolate_variable_sparse::"'a::comm_monoid_add mpoly \<Rightarrow>
nat \<Rightarrow> nat \<Rightarrow> 'a mpoly" is
  "\<lambda>(mp::'a mpoly) x d. sum
     (\<lambda>m. monomial (coeff mp m) (Poly_Mapping.update x 0 m))
     {m \<in> monomials mp. lookup m x = d}" .

lemma Poly_Mapping_update_code[code]: "Poly_Mapping.update a b (Pm_fmap
fm) = Pm_fmap (fmupd a b fm)"
  by (auto intro!: poly_mapping_eqI simp: update.rep_eq
      fmlookup_default_def)

lemma monom_zero [simp] : "monom m 0 = 0"
  by (simp add: coeff_all_0)

lemma remove_key_code[code]: "remove_key v (Pm_fmap fm) = Pm_fmap
(fmdrop v fm)"
  by (auto simp: remove_key_lookup fmlookup_default_def intro!:
      poly_mapping_eqI)
lemma extract_var_code[code]:
  "extract_var p v =
     (\<Sum>m\<in>monomials p. monom (remove_key v m) (monom (Poly_Mapping.single
v (lookup m v)) (coeff p m)))"
  apply (rule extract_var_finite_set[where S="monomials p"])
  using coeff_not_in_monomials by auto
value "extract_var ((Var 0 + Const (3::real) * Var 1)^2) 0"

(* degree p var
  takes in polynomial p and a variable var and finds the degree of that variable in the polynomial
  missing code theorems? still manages to evaluate
*)
code_thms degree
value "degree ((Var 0 + Const (3::real) * Var 1)^2) 0"

(* this function gives a set of all the variables in the polynomial
*)
lemma vars_code[code]: "vars p = \<Union> (keys ` monomials p)"
  unfolding monomials.rep_eq vars_def ..

value "vars ((Var 0 + Const (3::real) * Var 1)^2)"

(* return true if the polynomial contains no variables
*)
fun is_constant :: "'a::zero mpoly \<Rightarrow> bool" where
  "is_constant p = Set.is_empty (vars p)"

value "is_constant (Const (0::int))"

(*
  if the polynomial is constant, returns the real value associated with the polynomial,
  otherwise returns none
*)
fun get_if_const :: "real mpoly \<Rightarrow> real option" where
  "get_if_const p = (if is_constant p then Some (coeff p 0) else None)"

term "coeff p 0"

lemma insertionNegative : "insertion f p = - insertion f (-p)" try
  by (metis add.right_inverse eq_neg_iff_add_eq_0 insertion_add insertion_zero)

definition derivative :: "nat \<Rightarrow> real mpoly \<Rightarrow> real mpoly" where
  "derivative x p = (\<Sum>i\<in>{0..degree p x-1}. isolate_variable_sparse p x (i+1) * (Var x)^i * (Const (i+1)))"

text "get\\_coeffs $x$ $p$
  gets the tuple of coefficients $a$ $b$ $c$ of the term $a*x^2+b*x+c$ in polynomial $p$"
fun get_coeffs :: "nat \<Rightarrow> real mpoly \<Rightarrow> real mpoly * real mpoly * real mpoly" where
  "get_coeffs var x = (
  isolate_variable_sparse x var 2,
  isolate_variable_sparse x var 1,
  isolate_variable_sparse x var 0)
"

end


theory Rewrite_Examples
imports Main "HOL-Library.Rewrite"
begin

section \<open>The rewrite Proof Method by Example\<close>

text\<open>
This theory gives an overview over the features of the pattern-based rewrite proof method.

Documentation: \<^url>\<open>https://arxiv.org/abs/2111.04082\<close>
\<close>

lemma
  fixes a::int and b::int and c::int
  assumes "P (b + a)"
  shows "P (a + b)"
by (rewrite at "a + b" add.commute)
   (rule assms)

(* Selecting a specific subterm in a large, ambiguous term. *)
lemma
  fixes a b c :: int
  assumes "f (a - a + (a - a)) + f (   0    + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f _ + f \<hole> = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (a - a +    0   ) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite at "f (_ + \<hole>) + f _ = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (  0   + (a - a)) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f (\<hole> + _) + _ = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (a - a +    0   ) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f (_ + \<hole>) + _ = _" diff_self) fact

lemma
  fixes x y :: nat
  shows"x + y > c \<Longrightarrow> y + x > c"
  by (rewrite at "\<hole> > c" add.commute) assumption

(* We can also rewrite in the assumptions.  *)
lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite in asm add.commute) fact

lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite in "x + y > c" at asm add.commute) fact

lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite at "\<hole> > c" at asm  add.commute) fact

lemma
  assumes "P {x::int. y + 1 = 1 + x}"
  shows   "P {x::int. y + 1 = x + 1}"
  by (rewrite at "x+1" in "{x::int. \<hole> }" add.commute) fact

lemma
  assumes "P {x::int. y + 1 = 1 + x}"
  shows   "P {x::int. y + 1 = x + 1}"
  by (rewrite at "any_identifier_will_work+1" in "{any_identifier_will_work::int. \<hole> }" add.commute)
   fact

lemma
  assumes "P {(x::nat, y::nat, z). x + z * 3 = Q (\<lambda>s t. s * t + y - 3)}"
  shows   "P {(x::nat, y::nat, z). x + z * 3 = Q (\<lambda>s t. y + s * t - 3)}"
  by (rewrite at "b + d * e" in "\<lambda>(a, b, c). _ = Q (\<lambda>d e. \<hole>)" add.commute) fact

(* This is not limited to the first assumption *)
lemma
  assumes "PROP P \<equiv> PROP Q"
  shows "PROP R \<Longrightarrow> PROP P \<Longrightarrow> PROP Q"
    by (rewrite at asm assms)

lemma
  assumes "PROP P \<equiv> PROP Q"
  shows "PROP R \<Longrightarrow> PROP R \<Longrightarrow> PROP P \<Longrightarrow> PROP Q"
    by (rewrite at asm assms)

(* Rewriting "at asm" selects each full assumption, not any parts *)
lemma
  assumes "(PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP S \<Longrightarrow> PROP R)"
  shows "PROP S \<Longrightarrow> (PROP P \<Longrightarrow> PROP Q) \<Longrightarrow> PROP R"
  apply (rewrite at asm assms)
  apply assumption
  done

(* Rewriting with conditional rewriting rules works just as well. *)
lemma test_theorem:
  fixes x :: nat
  shows "x \<le> y \<Longrightarrow> x \<ge> y \<Longrightarrow> x = y"
  by (rule Orderings.order_antisym)

(* Premises of the conditional rule yield new subgoals. The
   assumptions of the goal are propagated into these subgoals
*)
lemma
  fixes f :: "nat \<Rightarrow> nat"
  shows "f x \<le> 0 \<Longrightarrow> f x \<ge> 0 \<Longrightarrow> f x = 0"
  apply (rewrite at "f x" to "0" test_theorem)
  apply assumption
  apply assumption
  apply (rule refl)
  done

(* This holds also for rewriting in assumptions. The order of assumptions is preserved *)
lemma
  assumes rewr: "PROP P \<Longrightarrow> PROP Q \<Longrightarrow> PROP R \<equiv> PROP R'"
  assumes A1: "PROP S \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP P"
  assumes A2: "PROP S \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP Q"
  assumes C: "PROP S \<Longrightarrow> PROP R' \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP V"
  shows "PROP S \<Longrightarrow> PROP R \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP V"
  apply (rewrite at asm rewr)
  apply (fact A1)
  apply (fact A2)
  apply (fact C)
  done

(*
   Instantiation.

   Since all rewriting is now done via conversions,
   instantiation becomes fairly easy to do.
*)

(* We first introduce a function f and an extended
   version of f that is annotated with an invariant. *)
fun f :: "nat \<Rightarrow> nat" where "f n = n"
definition "f_inv (I :: nat \<Rightarrow> bool) n \<equiv> f n"

lemma annotate_f: "f = f_inv I"
  by (simp add: f_inv_def fun_eq_iff)

(* We have a lemma with a bound variable n, and
   want to add an invariant to f. *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>_. True) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite to "f_inv (\<lambda>_. True)" annotate_f) fact

(* We can also add an invariant that contains the variable n bound in the outer context.
   For this, we need to bind this variable to an identifier. *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>x. n < x + 1) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite in "\<lambda>n. \<hole>" to "f_inv (\<lambda>x. n < x + 1)" annotate_f) fact

(* Any identifier will work *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>x. n < x + 1) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite in "\<lambda>abc. \<hole>" to "f_inv (\<lambda>x. abc < x + 1)" annotate_f) fact

(* The "for" keyword. *)
lemma
  assumes "P (2 + 1)"
  shows "\<And>x y. P (1 + 2 :: nat)"
by (rewrite in "P (1 + 2)" at for (x) add.commute) fact

lemma
  assumes "\<And>x y. P (y + x)"
  shows "\<And>x y. P (x + y :: nat)"
by (rewrite in "P (x + _)" at for (x y) add.commute) fact

lemma
  assumes "\<And>x y z. y + x + z = z + y + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "x + y" in "x + y + z" in for (x y z) add.commute) fact

lemma
  assumes "\<And>x y z. z + (x + y) = z + y + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "(_ + y) + z" in for (y z) add.commute) fact

lemma
  assumes "\<And>x y z. x + y + z = y + z + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "\<hole> + _" at "_ = \<hole>" in for () add.commute) fact

lemma
  assumes eq: "\<And>x. P x \<Longrightarrow> g x = x"
  assumes f1: "\<And>x. Q x \<Longrightarrow> P x"
  assumes f2: "\<And>x. Q x \<Longrightarrow> x"
  shows "\<And>x. Q x \<Longrightarrow> g x"
  apply (rewrite at "g x" in for (x) eq)
  apply (fact f1)
  apply (fact f2)
  done

(* The for keyword can be used anywhere in the pattern where there is an \<And>-Quantifier. *)
lemma
  assumes "(\<And>(x::int). x < 1 + x)"
  and     "(x::int) + 1 > x"
  shows   "(\<And>(x::int). x + 1 > x) \<Longrightarrow> (x::int) + 1 > x"
by (rewrite at "x + 1" in for (x) at asm add.commute)
   (rule assms)

(* The rewrite method also has an ML interface *)
lemma
  assumes "\<And>a b. P ((a + 1) * (1 + b)) "
  shows "\<And>a b :: nat. P ((a + 1) * (b + 1))"
  apply (tactic \<open>
    let
      val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
      (* Note that the pattern order is reversed *)
      val pat = [
        Rewrite.For [(x, SOME \<^Type>\<open>nat\<close>)],
        Rewrite.In,
        Rewrite.Term (\<^Const>\<open>plus \<^Type>\<open>nat\<close> for \<open>Free (x, \<^Type>\<open>nat\<close>)\<close> \<^term>\<open>1 :: nat\<close>\<close>, [])]
      val to = NONE
    in CCONVERSION (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) 1 end
  \<close>)
  apply (fact assms)
  done

lemma
  assumes "Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. a + b))"
  shows "Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. b + a))"
  apply (tactic \<open>
    let
      val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
      val pat = [
        Rewrite.Concl,
        Rewrite.In,
        Rewrite.Term (Free ("Q", (\<^Type>\<open>int\<close> --> TVar (("'b",0), [])) --> \<^Type>\<open>bool\<close>)
          $ Abs ("x", \<^Type>\<open>int\<close>, Rewrite.mk_hole 1 (\<^Type>\<open>int\<close> --> TVar (("'b",0), [])) $ Bound 0), [(x, \<^Type>\<open>int\<close>)]),
        Rewrite.In,
        Rewrite.Term (\<^Const>\<open>plus \<^Type>\<open>int\<close> for \<open>Free (x, \<^Type>\<open>int\<close>)\<close> \<open>Var (("c", 0), \<^Type>\<open>int\<close>)\<close>\<close>, [])
        ]
      val to = NONE
    in CCONVERSION (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) 1 end
  \<close>)
  apply (fact assms)
  done

(* There is also conversion-like rewrite function: *)
ML \<open>
  val ct = \<^cprop>\<open>Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. b + a))\<close>
  val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
  val pat = [
    Rewrite.Concl,
    Rewrite.In,
    Rewrite.Term (Free ("Q", (\<^typ>\<open>int\<close> --> TVar (("'b",0), [])) --> \<^typ>\<open>bool\<close>)
      $ Abs ("x", \<^typ>\<open>int\<close>, Rewrite.mk_hole 1 (\<^typ>\<open>int\<close> --> TVar (("'b",0), [])) $ Bound 0), [(x, \<^typ>\<open>int\<close>)]),
    Rewrite.In,
    Rewrite.Term (\<^Const>\<open>plus \<^Type>\<open>int\<close> for \<open>Free (x, \<^Type>\<open>int\<close>)\<close> \<open>Var (("c", 0), \<^Type>\<open>int\<close>)\<close>\<close>, [])
    ]
  val to = NONE
  val th = Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute} ct
\<close>

text \<open>Some regression tests\<close>

ML \<open>
  val ct = \<^cterm>\<open>(\<lambda>b :: int. (\<lambda>a. b + a))\<close>
  val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
  val pat = [
    Rewrite.In,
    Rewrite.Term (\<^Const>\<open>plus \<^Type>\<open>int\<close> for \<open>Var (("c", 0), \<^Type>\<open>int\<close>)\<close> \<open>Var (("c", 0), \<^Type>\<open>int\<close>)\<close>\<close>, [])
    ]
  val to = NONE
  val _ =
    case try (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) ct of
      NONE => ()
    | _ => error "should not have matched anything"
\<close>

ML \<open>
  Rewrite.params_pconv (Conv.all_conv |> K |> K) \<^context> (Vartab.empty, []) \<^cterm>\<open>\<And>x. PROP A\<close>
\<close>

lemma
  assumes eq: "PROP A \<Longrightarrow> PROP B \<equiv> PROP C"
  assumes f1: "PROP D \<Longrightarrow> PROP A"
  assumes f2: "PROP D \<Longrightarrow> PROP C"
  shows "\<And>x. PROP D \<Longrightarrow> PROP B"
  apply (rewrite eq)
  apply (fact f1)
  apply (fact f2)
  done

end


theory Smap_siterate
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

text_raw \<open>\DefineSnippet{streamdefs}{\<close>
codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")

primcorec smap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "smap f xs = SCons (f (shd xs)) (smap f (stl xs))"

primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Stream" where
  "siterate f a = SCons a (siterate f (f a))"

cohipster smap siterate \<comment> "tell Hipster to explore these functions"

text_raw \<open>}%EndSnippet\<close>

text_raw \<open>\DefineSnippet{streamoutput}{\<close>
lemma lemma_a [thy_expl]: "SCons (y z) (smap y x2) = smap y (SCons z x2)"
  by(coinduction arbitrary: x2 y z rule: Stream.coinduct_strong)
simp

lemma lemma_aa [thy_expl]: "smap y (siterate y z) = siterate y (y z)"
  by(coinduction arbitrary: y z rule: Stream.coinduct_strong)
auto

lemma lemma_ab [thy_expl]: "smap z (SCons y (siterate z x2)) = SCons (z y) (siterate z (z x2))"
  by(coinduction arbitrary: x2 y z rule: Stream.coinduct_strong)
    (simp add: Smap_siterate.lemma_aa)
text_raw \<open>}%EndSnippet\<close>

end