(*  Title       : HTranscendental.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 2001 University of Edinburgh

Converted to Isar and polished by lcp
*)

section{*Nonstandard Extensions of Transcendental Functions*}

theory HTranscendental
imports Transcendental HSeries HDeriv
begin

definition
  exphr :: "real => hypreal" where
    --{*define exponential function using standard part *}
  "exphr x =  st(sumhr (0, whn, %n. inverse(real (fact n)) * (x ^ n)))"

definition
  sinhr :: "real => hypreal" where
  "sinhr x = st(sumhr (0, whn, %n. sin_coeff n * x ^ n))"

definition
  coshr :: "real => hypreal" where
  "coshr x = st(sumhr (0, whn, %n. cos_coeff n * x ^ n))"

subsection{*Nonstandard Extension of Square Root Function*}

lemma STAR_sqrt_zero [simp]: "( *f* sqrt) 0 = 0"
by (simp add: starfun star_n_zero_num)

lemma STAR_sqrt_one [simp]: "( *f* sqrt) 1 = 1"
by (simp add: starfun star_n_one_num)

lemma hypreal_sqrt_pow2_iff: "(( *f* sqrt)(x) ^ 2 = x) = (0 \<le> x)"
apply (cases x)
apply (auto simp add: star_n_le star_n_zero_num starfun hrealpow star_n_eq_iff
            simp del: hpowr_Suc power_Suc)
done

lemma hypreal_sqrt_gt_zero_pow2: "!!x. 0 < x ==> ( *f* sqrt) (x) ^ 2 = x"
by (transfer, simp)

lemma hypreal_sqrt_pow2_gt_zero: "0 < x ==> 0 < ( *f* sqrt) (x) ^ 2"
by (frule hypreal_sqrt_gt_zero_pow2, auto)

lemma hypreal_sqrt_not_zero: "0 < x ==> ( *f* sqrt) (x) \<noteq> 0"
apply (frule hypreal_sqrt_pow2_gt_zero)
apply (auto simp add: numeral_2_eq_2)
done

lemma hypreal_inverse_sqrt_pow2:
     "0 < x ==> inverse (( *f* sqrt)(x)) ^ 2 = inverse x"
apply (cut_tac n = 2 and a = "( *f* sqrt) x" in power_inverse [symmetric])
apply (auto dest: hypreal_sqrt_gt_zero_pow2)
done

lemma hypreal_sqrt_mult_distrib:
    "!!x y. [|0 < x; 0 <y |] ==>
      ( *f* sqrt)(x*y) = ( *f* sqrt)(x) * ( *f* sqrt)(y)"
apply transfer
apply (auto intro: real_sqrt_mult_distrib)
done

lemma hypreal_sqrt_mult_distrib2:
     "[|0\<le>x; 0\<le>y |] ==>
     ( *f* sqrt)(x*y) =  ( *f* sqrt)(x) * ( *f* sqrt)(y)"
by (auto intro: hypreal_sqrt_mult_distrib simp add: order_le_less)

lemma hypreal_sqrt_approx_zero [simp]:
     "0 < x ==> (( *f* sqrt)(x) @= 0) = (x @= 0)"
apply (auto simp add: mem_infmal_iff [symmetric])
apply (rule hypreal_sqrt_gt_zero_pow2 [THEN subst])
apply (auto intro: Infinitesimal_mult
            dest!: hypreal_sqrt_gt_zero_pow2 [THEN ssubst]
            simp add: numeral_2_eq_2)
done

lemma hypreal_sqrt_approx_zero2 [simp]:
     "0 \<le> x ==> (( *f* sqrt)(x) @= 0) = (x @= 0)"
by (auto simp add: order_le_less)

lemma hypreal_sqrt_sum_squares [simp]:
     "(( *f* sqrt)(x*x + y*y + z*z) @= 0) = (x*x + y*y + z*z @= 0)"
apply (rule hypreal_sqrt_approx_zero2)
apply (rule add_nonneg_nonneg)+
apply (auto)
done

lemma hypreal_sqrt_sum_squares2 [simp]:
     "(( *f* sqrt)(x*x + y*y) @= 0) = (x*x + y*y @= 0)"
apply (rule hypreal_sqrt_approx_zero2)
apply (rule add_nonneg_nonneg)
apply (auto)
done

lemma hypreal_sqrt_gt_zero: "!!x. 0 < x ==> 0 < ( *f* sqrt)(x)"
apply transfer
apply (auto intro: real_sqrt_gt_zero)
done

lemma hypreal_sqrt_ge_zero: "0 \<le> x ==> 0 \<le> ( *f* sqrt)(x)"
by (auto intro: hypreal_sqrt_gt_zero simp add: order_le_less)

lemma hypreal_sqrt_hrabs [simp]: "!!x. ( *f* sqrt)(x\<^sup>2) = abs(x)"
by (transfer, simp)

lemma hypreal_sqrt_hrabs2 [simp]: "!!x. ( *f* sqrt)(x*x) = abs(x)"
by (transfer, simp)

lemma hypreal_sqrt_hyperpow_hrabs [simp]:
     "!!x. ( *f* sqrt)(x pow (hypnat_of_nat 2)) = abs(x)"
by (transfer, simp)

lemma star_sqrt_HFinite: "\<lbrakk>x \<in> HFinite; 0 \<le> x\<rbrakk> \<Longrightarrow> ( *f* sqrt) x \<in> HFinite"
apply (rule HFinite_square_iff [THEN iffD1])
apply (simp only: hypreal_sqrt_mult_distrib2 [symmetric], simp)
done

lemma st_hypreal_sqrt:
     "[| x \<in> HFinite; 0 \<le> x |] ==> st(( *f* sqrt) x) = ( *f* sqrt)(st x)"
apply (rule power_inject_base [where n=1])
apply (auto intro!: st_zero_le hypreal_sqrt_ge_zero)
apply (rule st_mult [THEN subst])
apply (rule_tac [3] hypreal_sqrt_mult_distrib2 [THEN subst])
apply (rule_tac [5] hypreal_sqrt_mult_distrib2 [THEN subst])
apply (auto simp add: st_hrabs st_zero_le star_sqrt_HFinite)
done

lemma hypreal_sqrt_sum_squares_ge1 [simp]: "!!x y. x \<le> ( *f* sqrt)(x\<^sup>2 + y\<^sup>2)"
by transfer (rule real_sqrt_sum_squares_ge1)

lemma HFinite_hypreal_sqrt:
     "[| 0 \<le> x; x \<in> HFinite |] ==> ( *f* sqrt) x \<in> HFinite"
apply (auto simp add: order_le_less)
apply (rule HFinite_square_iff [THEN iffD1])
apply (drule hypreal_sqrt_gt_zero_pow2)
apply (simp add: numeral_2_eq_2)
done

lemma HFinite_hypreal_sqrt_imp_HFinite:
     "[| 0 \<le> x; ( *f* sqrt) x \<in> HFinite |] ==> x \<in> HFinite"
apply (auto simp add: order_le_less)
apply (drule HFinite_square_iff [THEN iffD2])
apply (drule hypreal_sqrt_gt_zero_pow2)
apply (simp add: numeral_2_eq_2 del: HFinite_square_iff)
done

lemma HFinite_hypreal_sqrt_iff [simp]:
     "0 \<le> x ==> (( *f* sqrt) x \<in> HFinite) = (x \<in> HFinite)"
by (blast intro: HFinite_hypreal_sqrt HFinite_hypreal_sqrt_imp_HFinite)

lemma HFinite_sqrt_sum_squares [simp]:
     "(( *f* sqrt)(x*x + y*y) \<in> HFinite) = (x*x + y*y \<in> HFinite)"
apply (rule HFinite_hypreal_sqrt_iff)
apply (rule add_nonneg_nonneg)
apply (auto)
done

lemma Infinitesimal_hypreal_sqrt:
     "[| 0 \<le> x; x \<in> Infinitesimal |] ==> ( *f* sqrt) x \<in> Infinitesimal"
apply (auto simp add: order_le_less)
apply (rule Infinitesimal_square_iff [THEN iffD2])
apply (drule hypreal_sqrt_gt_zero_pow2)
apply (simp add: numeral_2_eq_2)
done

lemma Infinitesimal_hypreal_sqrt_imp_Infinitesimal:
     "[| 0 \<le> x; ( *f* sqrt) x \<in> Infinitesimal |] ==> x \<in> Infinitesimal"
apply (auto simp add: order_le_less)
apply (drule Infinitesimal_square_iff [THEN iffD1])
apply (drule hypreal_sqrt_gt_zero_pow2)
apply (simp add: numeral_2_eq_2 del: Infinitesimal_square_iff [symmetric])
done

lemma Infinitesimal_hypreal_sqrt_iff [simp]:
     "0 \<le> x ==> (( *f* sqrt) x \<in> Infinitesimal) = (x \<in> Infinitesimal)"
by (blast intro: Infinitesimal_hypreal_sqrt_imp_Infinitesimal Infinitesimal_hypreal_sqrt)

lemma Infinitesimal_sqrt_sum_squares [simp]:
     "(( *f* sqrt)(x*x + y*y) \<in> Infinitesimal) = (x*x + y*y \<in> Infinitesimal)"
apply (rule Infinitesimal_hypreal_sqrt_iff)
apply (rule add_nonneg_nonneg)
apply (auto)
done

lemma HInfinite_hypreal_sqrt:
     "[| 0 \<le> x; x \<in> HInfinite |] ==> ( *f* sqrt) x \<in> HInfinite"
apply (auto simp add: order_le_less)
apply (rule HInfinite_square_iff [THEN iffD1])
apply (drule hypreal_sqrt_gt_zero_pow2)
apply (simp add: numeral_2_eq_2)
done

lemma HInfinite_hypreal_sqrt_imp_HInfinite:
     "[| 0 \<le> x; ( *f* sqrt) x \<in> HInfinite |] ==> x \<in> HInfinite"
apply (auto simp add: order_le_less)
apply (drule HInfinite_square_iff [THEN iffD2])
apply (drule hypreal_sqrt_gt_zero_pow2)
apply (simp add: numeral_2_eq_2 del: HInfinite_square_iff)
done

lemma HInfinite_hypreal_sqrt_iff [simp]:
     "0 \<le> x ==> (( *f* sqrt) x \<in> HInfinite) = (x \<in> HInfinite)"
by (blast intro: HInfinite_hypreal_sqrt HInfinite_hypreal_sqrt_imp_HInfinite)

lemma HInfinite_sqrt_sum_squares [simp]:
     "(( *f* sqrt)(x*x + y*y) \<in> HInfinite) = (x*x + y*y \<in> HInfinite)"
apply (rule HInfinite_hypreal_sqrt_iff)
apply (rule add_nonneg_nonneg)
apply (auto)
done

lemma HFinite_exp [simp]:
     "sumhr (0, whn, %n. inverse (real (fact n)) * x ^ n) \<in> HFinite"
unfolding sumhr_app
apply (simp only: star_zero_def starfun2_star_of atLeast0LessThan)
apply (rule NSBseqD2)
apply (rule NSconvergent_NSBseq)
apply (rule convergent_NSconvergent_iff [THEN iffD1])
apply (rule summable_iff_convergent [THEN iffD1])
apply (rule summable_exp)
done

lemma exphr_zero [simp]: "exphr 0 = 1"
apply (simp add: exphr_def sumhr_split_add [OF hypnat_one_less_hypnat_omega, symmetric])
apply (rule st_unique, simp)
apply (rule subst [where P="\<lambda>x. 1 \<approx> x", OF _ approx_refl])
apply (rule rev_mp [OF hypnat_one_less_hypnat_omega])
apply (rule_tac x="whn" in spec)
apply (unfold sumhr_app, transfer, simp add: power_0_left)
done

lemma coshr_zero [simp]: "coshr 0 = 1"
apply (simp add: coshr_def sumhr_split_add
                   [OF hypnat_one_less_hypnat_omega, symmetric])
apply (rule st_unique, simp)
apply (rule subst [where P="\<lambda>x. 1 \<approx> x", OF _ approx_refl])
apply (rule rev_mp [OF hypnat_one_less_hypnat_omega])
apply (rule_tac x="whn" in spec)
apply (unfold sumhr_app, transfer, simp add: cos_coeff_def power_0_left)
done

lemma STAR_exp_zero_approx_one [simp]: "( *f* exp) (0::hypreal) @= 1"
apply (subgoal_tac "( *f* exp) (0::hypreal) = 1", simp)
apply (transfer, simp)
done

lemma STAR_exp_Infinitesimal: "x \<in> Infinitesimal ==> ( *f* exp) (x::hypreal) @= 1"
apply (case_tac "x = 0")
apply (cut_tac [2] x = 0 in DERIV_exp)
apply (auto simp add: NSDERIV_DERIV_iff [symmetric] nsderiv_def)
apply (drule_tac x = x in bspec, auto)
apply (drule_tac c = x in approx_mult1)
apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD]
            simp add: mult.assoc)
apply (rule approx_add_right_cancel [where d="-1"])
apply (rule approx_sym [THEN [2] approx_trans2])
apply (auto simp add: mem_infmal_iff)
done

lemma STAR_exp_epsilon [simp]: "( *f* exp) epsilon @= 1"
by (auto intro: STAR_exp_Infinitesimal)

lemma STAR_exp_add:
  "!!(x::'a:: {banach,real_normed_field} star) y. ( *f* exp)(x + y) = ( *f* exp) x * ( *f* exp) y"
by transfer (rule exp_add)

lemma exphr_hypreal_of_real_exp_eq: "exphr x = hypreal_of_real (exp x)"
apply (simp add: exphr_def)
apply (rule st_unique, simp)
apply (subst starfunNat_sumr [symmetric])
unfolding atLeast0LessThan
apply (rule NSLIMSEQ_D [THEN approx_sym])
apply (rule LIMSEQ_NSLIMSEQ)
apply (subst sums_def [symmetric])
apply (cut_tac exp_converges [where x=x], simp)
apply (rule HNatInfinite_whn)
done

lemma starfun_exp_ge_add_one_self [simp]: "!!x::hypreal. 0 \<le> x ==> (1 + x) \<le> ( *f* exp) x"
by transfer (rule exp_ge_add_one_self_aux)

(* exp (oo) is infinite *)
lemma starfun_exp_HInfinite:
     "[| x \<in> HInfinite; 0 \<le> x |] ==> ( *f* exp) (x::hypreal) \<in> HInfinite"
apply (frule starfun_exp_ge_add_one_self)
apply (rule HInfinite_ge_HInfinite, assumption)
apply (rule order_trans [of _ "1+x"], auto)
done

lemma starfun_exp_minus:
  "!!x::'a:: {banach,real_normed_field} star. ( *f* exp) (-x) = inverse(( *f* exp) x)"
by transfer (rule exp_minus)

(* exp (-oo) is infinitesimal *)
lemma starfun_exp_Infinitesimal:
     "[| x \<in> HInfinite; x \<le> 0 |] ==> ( *f* exp) (x::hypreal) \<in> Infinitesimal"
apply (subgoal_tac "\<exists>y. x = - y")
apply (rule_tac [2] x = "- x" in exI)
apply (auto intro!: HInfinite_inverse_Infinitesimal starfun_exp_HInfinite
            simp add: starfun_exp_minus HInfinite_minus_iff)
done

lemma starfun_exp_gt_one [simp]: "!!x::hypreal. 0 < x ==> 1 < ( *f* exp) x"
by transfer (rule exp_gt_one)

lemma starfun_ln_exp [simp]: "!!x. ( *f* ln) (( *f* exp) x) = x"
by transfer (rule ln_exp)

lemma starfun_exp_ln_iff [simp]: "!!x. (( *f* exp)(( *f* ln) x) = x) = (0 < x)"
by transfer (rule exp_ln_iff)

lemma starfun_exp_ln_eq: "!!u x. ( *f* exp) u = x ==> ( *f* ln) x = u"
by transfer (rule ln_unique)

lemma starfun_ln_less_self [simp]: "!!x. 0 < x ==> ( *f* ln) x < x"
by transfer (rule ln_less_self)

lemma starfun_ln_ge_zero [simp]: "!!x. 1 \<le> x ==> 0 \<le> ( *f* ln) x"
by transfer (rule ln_ge_zero)

lemma starfun_ln_gt_zero [simp]: "!!x .1 < x ==> 0 < ( *f* ln) x"
by transfer (rule ln_gt_zero)

lemma starfun_ln_not_eq_zero [simp]: "!!x. [| 0 < x; x \<noteq> 1 |] ==> ( *f* ln) x \<noteq> 0"
by transfer simp

lemma starfun_ln_HFinite: "[| x \<in> HFinite; 1 \<le> x |] ==> ( *f* ln) x \<in> HFinite"
apply (rule HFinite_bounded)
apply assumption
apply (simp_all add: starfun_ln_less_self order_less_imp_le)
done

lemma starfun_ln_inverse: "!!x. 0 < x ==> ( *f* ln) (inverse x) = -( *f* ln) x"
by transfer (rule ln_inverse)

lemma starfun_abs_exp_cancel: "\<And>x. \<bar>( *f* exp) (x::hypreal)\<bar> = ( *f* exp) x"
by transfer (rule abs_exp_cancel)

lemma starfun_exp_less_mono: "\<And>x y::hypreal. x < y \<Longrightarrow> ( *f* exp) x < ( *f* exp) y"
by transfer (rule exp_less_mono)

lemma starfun_exp_HFinite: "x \<in> HFinite ==> ( *f* exp) (x::hypreal) \<in> HFinite"
apply (auto simp add: HFinite_def, rename_tac u)
apply (rule_tac x="( *f* exp) u" in rev_bexI)
apply (simp add: Reals_eq_Standard)
apply (simp add: starfun_abs_exp_cancel)
apply (simp add: starfun_exp_less_mono)
done

lemma starfun_exp_add_HFinite_Infinitesimal_approx:
     "[|x \<in> Infinitesimal; z \<in> HFinite |] ==> ( *f* exp) (z + x::hypreal) @= ( *f* exp) z"
apply (simp add: STAR_exp_add)
apply (frule STAR_exp_Infinitesimal)
apply (drule approx_mult2)
apply (auto intro: starfun_exp_HFinite)
done

(* using previous result to get to result *)
lemma starfun_ln_HInfinite:
     "[| x \<in> HInfinite; 0 < x |] ==> ( *f* ln) x \<in> HInfinite"
apply (rule ccontr, drule HFinite_HInfinite_iff [THEN iffD2])
apply (drule starfun_exp_HFinite)
apply (simp add: starfun_exp_ln_iff [THEN iffD2] HFinite_HInfinite_iff)
done

lemma starfun_exp_HInfinite_Infinitesimal_disj:
 "x \<in> HInfinite ==> ( *f* exp) x \<in> HInfinite | ( *f* exp) (x::hypreal) \<in> Infinitesimal"
apply (insert linorder_linear [of x 0])
apply (auto intro: starfun_exp_HInfinite starfun_exp_Infinitesimal)
done

(* check out this proof!!! *)
lemma starfun_ln_HFinite_not_Infinitesimal:
     "[| x \<in> HFinite - Infinitesimal; 0 < x |] ==> ( *f* ln) x \<in> HFinite"
apply (rule ccontr, drule HInfinite_HFinite_iff [THEN iffD2])
apply (drule starfun_exp_HInfinite_Infinitesimal_disj)
apply (simp add: starfun_exp_ln_iff [symmetric] HInfinite_HFinite_iff
            del: starfun_exp_ln_iff)
done

(* we do proof by considering ln of 1/x *)
lemma starfun_ln_Infinitesimal_HInfinite:
     "[| x \<in> Infinitesimal; 0 < x |] ==> ( *f* ln) x \<in> HInfinite"
apply (drule Infinitesimal_inverse_HInfinite)
apply (frule positive_imp_inverse_positive)
apply (drule_tac [2] starfun_ln_HInfinite)
apply (auto simp add: starfun_ln_inverse HInfinite_minus_iff)
done

lemma starfun_ln_less_zero: "!!x. [| 0 < x; x < 1 |] ==> ( *f* ln) x < 0"
by transfer (rule ln_less_zero)

lemma starfun_ln_Infinitesimal_less_zero:
     "[| x \<in> Infinitesimal; 0 < x |] ==> ( *f* ln) x < 0"
by (auto intro!: starfun_ln_less_zero simp add: Infinitesimal_def)

lemma starfun_ln_HInfinite_gt_zero:
     "[| x \<in> HInfinite; 0 < x |] ==> 0 < ( *f* ln) x"
by (auto intro!: starfun_ln_gt_zero simp add: HInfinite_def)

(*
Goalw [NSLIM_def] "(%h. ((x powr h) - 1) / h) -- 0 --NS> ln x"
*)

lemma HFinite_sin [simp]: "sumhr (0, whn, %n. sin_coeff n * x ^ n) \<in> HFinite"
unfolding sumhr_app
apply (simp only: star_zero_def starfun2_star_of atLeast0LessThan)
apply (rule NSBseqD2)
apply (rule NSconvergent_NSBseq)
apply (rule convergent_NSconvergent_iff [THEN iffD1])
apply (rule summable_iff_convergent [THEN iffD1])
apply (rule summable_sin)
done

lemma STAR_sin_zero [simp]: "( *f* sin) 0 = 0"
by transfer (rule sin_zero)

lemma STAR_sin_Infinitesimal [simp]: "x \<in> Infinitesimal ==> ( *f* sin) x @= x"
apply (case_tac "x = 0")
apply (cut_tac [2] x = 0 in DERIV_sin)
apply (auto simp add: NSDERIV_DERIV_iff [symmetric] nsderiv_def)
apply (drule bspec [where x = x], auto)
apply (drule approx_mult1 [where c = x])
apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD]
           simp add: mult.assoc)
done

lemma HFinite_cos [simp]: "sumhr (0, whn, %n. cos_coeff n * x ^ n) \<in> HFinite"
unfolding sumhr_app
apply (simp only: star_zero_def starfun2_star_of atLeast0LessThan)
apply (rule NSBseqD2)
apply (rule NSconvergent_NSBseq)
apply (rule convergent_NSconvergent_iff [THEN iffD1])
apply (rule summable_iff_convergent [THEN iffD1])
apply (rule summable_cos)
done

lemma STAR_cos_zero [simp]: "( *f* cos) 0 = 1"
by transfer (rule cos_zero)

lemma STAR_cos_Infinitesimal [simp]: "x \<in> Infinitesimal ==> ( *f* cos) x @= 1"
apply (case_tac "x = 0")
apply (cut_tac [2] x = 0 in DERIV_cos)
apply (auto simp add: NSDERIV_DERIV_iff [symmetric] nsderiv_def)
apply (drule bspec [where x = x])
apply auto
apply (drule approx_mult1 [where c = x])
apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD]
            simp add: mult.assoc)
apply (rule approx_add_right_cancel [where d = "-1"])
apply simp
done

lemma STAR_tan_zero [simp]: "( *f* tan) 0 = 0"
by transfer (rule tan_zero)

lemma STAR_tan_Infinitesimal: "x \<in> Infinitesimal ==> ( *f* tan) x @= x"
apply (case_tac "x = 0")
apply (cut_tac [2] x = 0 in DERIV_tan)
apply (auto simp add: NSDERIV_DERIV_iff [symmetric] nsderiv_def)
apply (drule bspec [where x = x], auto)
apply (drule approx_mult1 [where c = x])
apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD]
             simp add: mult.assoc)
done

lemma STAR_sin_cos_Infinitesimal_mult:
     "x \<in> Infinitesimal ==> ( *f* sin) x * ( *f* cos) x @= x"
apply (insert approx_mult_HFinite [of "( *f* sin) x" _ "( *f* cos) x" 1])
apply (simp add: Infinitesimal_subset_HFinite [THEN subsetD])
done

lemma HFinite_pi: "hypreal_of_real pi \<in> HFinite"
by simp

(* lemmas *)

lemma lemma_split_hypreal_of_real:
     "N \<in> HNatInfinite
      ==> hypreal_of_real a =
          hypreal_of_hypnat N * (inverse(hypreal_of_hypnat N) * hypreal_of_real a)"
by (simp add: mult.assoc [symmetric] zero_less_HNatInfinite)

lemma STAR_sin_Infinitesimal_divide:
     "[|x \<in> Infinitesimal; x \<noteq> 0 |] ==> ( *f* sin) x/x @= 1"
apply (cut_tac x = 0 in DERIV_sin)
apply (simp add: NSDERIV_DERIV_iff [symmetric] nsderiv_def)
done

(*------------------------------------------------------------------------*)
(* sin* (1/n) * 1/(1/n) @= 1 for n = oo                                   *)
(*------------------------------------------------------------------------*)

lemma lemma_sin_pi:
     "n \<in> HNatInfinite
      ==> ( *f* sin) (inverse (hypreal_of_hypnat n))/(inverse (hypreal_of_hypnat n)) @= 1"
apply (rule STAR_sin_Infinitesimal_divide)
apply (auto simp add: zero_less_HNatInfinite)
done

lemma STAR_sin_inverse_HNatInfinite:
     "n \<in> HNatInfinite
      ==> ( *f* sin) (inverse (hypreal_of_hypnat n)) * hypreal_of_hypnat n @= 1"
apply (frule lemma_sin_pi)
apply (simp add: divide_inverse)
done

lemma Infinitesimal_pi_divide_HNatInfinite:
     "N \<in> HNatInfinite
      ==> hypreal_of_real pi/(hypreal_of_hypnat N) \<in> Infinitesimal"
apply (simp add: divide_inverse)
apply (auto intro: Infinitesimal_HFinite_mult2)
done

lemma pi_divide_HNatInfinite_not_zero [simp]:
     "N \<in> HNatInfinite ==> hypreal_of_real pi/(hypreal_of_hypnat N) \<noteq> 0"
by (simp add: zero_less_HNatInfinite)

lemma STAR_sin_pi_divide_HNatInfinite_approx_pi:
     "n \<in> HNatInfinite
      ==> ( *f* sin) (hypreal_of_real pi/(hypreal_of_hypnat n)) * hypreal_of_hypnat n
          @= hypreal_of_real pi"
apply (frule STAR_sin_Infinitesimal_divide
               [OF Infinitesimal_pi_divide_HNatInfinite
                   pi_divide_HNatInfinite_not_zero])
apply (auto)
apply (rule approx_SReal_mult_cancel [of "inverse (hypreal_of_real pi)"])
apply (auto intro: Reals_inverse simp add: divide_inverse ac_simps)
done

lemma STAR_sin_pi_divide_HNatInfinite_approx_pi2:
     "n \<in> HNatInfinite
      ==> hypreal_of_hypnat n *
          ( *f* sin) (hypreal_of_real pi/(hypreal_of_hypnat n))
          @= hypreal_of_real pi"
apply (rule mult.commute [THEN subst])
apply (erule STAR_sin_pi_divide_HNatInfinite_approx_pi)
done

lemma starfunNat_pi_divide_n_Infinitesimal:
     "N \<in> HNatInfinite ==> ( *f* (%x. pi / real x)) N \<in> Infinitesimal"
by (auto intro!: Infinitesimal_HFinite_mult2
         simp add: starfun_mult [symmetric] divide_inverse
                   starfun_inverse [symmetric] starfunNat_real_of_nat)

lemma STAR_sin_pi_divide_n_approx:
     "N \<in> HNatInfinite ==>
      ( *f* sin) (( *f* (%x. pi / real x)) N) @=
      hypreal_of_real pi/(hypreal_of_hypnat N)"
apply (simp add: starfunNat_real_of_nat [symmetric])
apply (rule STAR_sin_Infinitesimal)
apply (simp add: divide_inverse)
apply (rule Infinitesimal_HFinite_mult2)
apply (subst starfun_inverse)
apply (erule starfunNat_inverse_real_of_nat_Infinitesimal)
apply simp
done

lemma NSLIMSEQ_sin_pi: "(%n. real n * sin (pi / real n)) ----NS> pi"
apply (auto simp add: NSLIMSEQ_def starfun_mult [symmetric] starfunNat_real_of_nat)
apply (rule_tac f1 = sin in starfun_o2 [THEN subst])
apply (auto simp add: starfun_mult [symmetric] starfunNat_real_of_nat divide_inverse)
apply (rule_tac f1 = inverse in starfun_o2 [THEN subst])
apply (auto dest: STAR_sin_pi_divide_HNatInfinite_approx_pi
            simp add: starfunNat_real_of_nat mult.commute divide_inverse)
done

lemma NSLIMSEQ_cos_one: "(%n. cos (pi / real n))----NS> 1"
apply (simp add: NSLIMSEQ_def, auto)
apply (rule_tac f1 = cos in starfun_o2 [THEN subst])
apply (rule STAR_cos_Infinitesimal)
apply (auto intro!: Infinitesimal_HFinite_mult2
            simp add: starfun_mult [symmetric] divide_inverse
                      starfun_inverse [symmetric] starfunNat_real_of_nat)
done

lemma NSLIMSEQ_sin_cos_pi:
     "(%n. real n * sin (pi / real n) * cos (pi / real n)) ----NS> pi"
by (insert NSLIMSEQ_mult [OF NSLIMSEQ_sin_pi NSLIMSEQ_cos_one], simp)

text{*A familiar approximation to @{term "cos x"} when @{term x} is small*}

lemma STAR_cos_Infinitesimal_approx:
     "x \<in> Infinitesimal ==> ( *f* cos) x @= 1 - x\<^sup>2"
apply (rule STAR_cos_Infinitesimal [THEN approx_trans])
apply (auto simp add: Infinitesimal_approx_minus [symmetric]
            add.assoc [symmetric] numeral_2_eq_2)
done

lemma STAR_cos_Infinitesimal_approx2:
     "x \<in> Infinitesimal ==> ( *f* cos) x @= 1 - (x\<^sup>2)/2"
apply (rule STAR_cos_Infinitesimal [THEN approx_trans])
apply (auto intro: Infinitesimal_SReal_divide
            simp add: Infinitesimal_approx_minus [symmetric] numeral_2_eq_2)
done

end


section\<open>Algebra problems\<close>

subsection \<open>IMO 2006 SL - A2\<close>

theory IMO_2006_SL_A2_sol
imports Complex_Main
begin

lemma sum_remove_zero:
  fixes n :: nat
  assumes "n > 0"
  shows "(\<Sum> k < n. f k) = f 0 + (\<Sum> k \<in> {1..<n}. f k)"
  using assms
  by (simp add: atLeast1_lessThan_eq_remove0 sum.remove)

theorem IMO_2006_SL_A2:
  fixes a :: "nat \<Rightarrow> real"
  assumes "a 0 = -1" "\<forall> n \<ge> 1. (\<Sum> k < n + 1. a (n - k) / (k + 1)) = 0" "n \<ge> 1"
  shows "a n > 0"
  using \<open>n \<ge> 1\<close>
proof (induction n rule: less_induct)
  case (less n)
  show ?case
  proof cases
    assume "n = 1"
    have "a 1 = 1/2"
      using assms
      by auto
    with \<open>n = 1\<close> show ?thesis
      by simp
  next
    assume "n \<noteq> 1"
    with \<open>n \<ge> 1\<close> have "n > 1"
      by simp

    have "0 = (n + 1) * (\<Sum> k < n + 1. a k / (n + 1 - k)) - n * (\<Sum> k < n. a k / (n - k))"
    proof-
      have "(\<Sum> k < n. a k / (n - k)) = 0"
        using assms(2)[rule_format, of "n - 1"] \<open>n > 1\<close>
              sum.nat_diff_reindex[of "\<lambda> k. a k / (n - k)" "n"]
        by simp

      moreover

      have "(\<Sum> k < n + 1. a k / (n + 1 - k)) = 0"
        using assms(2)[rule_format, of "n"] \<open>n > 1\<close>
              sum.nat_diff_reindex[of "\<lambda> k. a k / (n + 1 - k)" "n + 1"]
        by simp

      ultimately
      show ?thesis
        by simp
    qed
    then have "(n + 1) * a n = - (\<Sum> k < n. ((n + 1) / (n + 1 - k) - n / (n - k)) * a k)"
      by (simp add: algebra_simps sum_distrib_left sum_subtractf)
    then have "(n + 1) * a n = (\<Sum> k < n. (n / (n - k) - (n + 1) / (n + 1 - k)) * a k)"
      by (simp add: algebra_simps sum_negf[symmetric])
    also have "... = (\<Sum> k \<in> {1..<n}. (n / (n - k) - (n + 1) / (n + 1 - k)) * a k)"
      using \<open>n > 1\<close>
      by (subst sum_remove_zero, auto)
    also have "... > 0"
    proof (rule sum_pos)
      show "finite {1..<n}"
        by simp
    next
      show "{1..<n} \<noteq> {}"
        using \<open>n > 1\<close>
        by simp
    next
      fix i
      assume "i \<in> {1..<n}"
      show "(n / (n - i) - (n + 1) / (n + 1 - i)) * a i > 0" (is "?c * a i > 0")
      proof-
        have "a i > 0" using less \<open>i \<in> {1..<n}\<close> by simp

        moreover have "?c > 0"
        proof-
          have "?c = i / ((n - i) * (n + 1 - i))"
            using \<open>i \<in> {1..<n}\<close>
            by (simp add: field_simps of_nat_diff)
          then show ?thesis
            using \<open>i \<in> {1..<n}\<close>
            by simp
        qed

        ultimately show ?thesis by simp
      qed
    qed
    finally have "(n + 1) * a n > 0"
      .
    then show ?thesis
      by (smt mult_nonneg_nonpos of_nat_0_le_iff)
  qed
qed

end


theory Chap3
imports Main
begin

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

datatype aexp =
  N val |
  V vname |
  Plus aexp aexp

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (N n) s = n" |
  "aval (V x) s = s x" |
  "aval (Plus a1 a2) s = aval a1 s + aval a2 s"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
  "asimp_const ( N n ) = N n" |
  "asimp_const ( V x ) = V x" |
  "asimp_const ( Plus a1 a2 ) =
    ( case ( asimp_const a1 , asimp_const a2 ) of
        ( N n1 , N n2 ) \<Rightarrow> N ( n1 + n2 ) |
        ( b1 , b2 ) \<Rightarrow> Plus b1 b2 )"

lemma "aval ( asimp_const a ) s = aval a s"
  apply ( induction a )
  apply ( auto  split: aexp.split )
done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "plus ( N i1 ) ( N i2 ) = N ( i1 + i2 )"|
  "plus ( N i ) a = ( if  i = 0  then  a  else (  Plus ( N i ) a  ) )" |
  "plus a ( N i ) = ( if  i = 0  then  a  else (  Plus a ( N i )  ) )" |
  "plus a1 a2 = Plus a1 a2"

lemma aval_plus : "aval ( plus a1 a2 ) s = aval a1 s + aval a2 s"
  apply ( induction rule: plus.induct )
  apply ( auto )
done

fun asimp :: "aexp \<Rightarrow> aexp" where
  "asimp ( N n ) = N n" |
  "asimp ( V x ) = V x" |
  "asimp ( Plus a1 a2 ) = plus ( asimp a1 ) ( asimp a2 )"

lemma "assimp_correct" : "aval ( asimp a ) s = aval a s"
  apply ( induction a )
  apply ( auto simp add: aval_plus )
done

fun optimal :: "aexp \<Rightarrow> bool" where
  "optimal ( N n ) = True" |
  "optimal ( V x ) = True" |
  "optimal ( Plus ( N i ) ( N j ) ) = False" |
  "optimal ( Plus a1 a2 ) = ( optimal a1 \<and>  optimal a2 )"

lemma "optimal ( asimp_const a )"
  apply ( induction a )
  apply ( auto split: aexp.split)
done

fun full_asimp :: "aexp \<Rightarrow> aexp" where
  "full_asimp ( N n ) = N n" |
  "full_asimp ( V x ) = V x" |
  "full_asimp ( Plus a1 a2 ) =
    ( case ( full_asimp a1 , full_asimp a2 ) of
      ( N n1              , N n2 )              \<Rightarrow> ( N ( n1 + n2 ) ) |
      ( N n               , V y  )              \<Rightarrow> ( Plus ( V y ) ( N n ) ) |
      ( N n1              , Plus a2' ( N n2 ) ) \<Rightarrow> ( Plus a2' (N  (n1 + n2)) ) |
      ( N n               , Plus a21 a22 )      \<Rightarrow> ( Plus ( Plus a21 a22 ) ( N n ) ) |
      ( V x               , N n  )              \<Rightarrow> ( Plus ( V x ) ( N n ) ) |
      ( V x               , V y  )              \<Rightarrow> ( Plus ( V x ) ( V y ) ) |
      ( V x               , Plus a2' ( N n2 ) ) \<Rightarrow> ( Plus ( Plus ( V x ) a2' ) ( N  n2 ) ) |
      ( V x               , Plus a21 a22 )      \<Rightarrow> ( Plus ( V x ) ( Plus a21 a22 ) ) |
      ( Plus a1' ( N n1 ) , N n2 )              \<Rightarrow> ( Plus a1' ( N ( n1 + n2 ) ) ) |
      ( Plus a1' ( N n )  , V x  )              \<Rightarrow> ( Plus ( Plus a1' ( V x ) ) ( N n ) ) |
      ( Plus a1' ( N n1 ) , Plus a2' ( N n2 ) ) \<Rightarrow> ( Plus ( Plus a1' a2' ) (N  (n1 + n2)) ) |
      ( Plus a1' ( N n )  , Plus a21 a22)       \<Rightarrow> ( Plus ( Plus a1' ( Plus a21 a22 ) ) ( N n ) ) |
      ( Plus a11 a12      , N n  )              \<Rightarrow> ( Plus ( Plus a11 a12 ) ( N n ) ) |
      ( Plus a11 a12      , V x  )              \<Rightarrow> ( Plus ( Plus a11 a12 ) ( V x ) ) |
      ( Plus a11 a12      , Plus a2' ( N n ) )  \<Rightarrow> ( Plus ( Plus a11 ( Plus  a12 a2' ) ) ( N n ) ) |
      ( Plus a11 a12      , Plus a21 a22 )      \<Rightarrow> ( Plus ( Plus a11 a12 ) ( Plus a21 a22 ) ) )"

lemma "aval ( full_asimp a ) s = aval a s"
  apply ( induction a )
  apply ( auto split: aexp.split)
done

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "subst _ _ ( N n ) = N n" |
  "subst x t ( V y ) = ( if x = y then t else V y )" |
  "subst x t ( Plus a1 a2 ) = Plus ( subst x t  a1 ) ( subst x t a2 )"

lemma "substitution_lemma" : "aval ( subst x t e ) s = aval e ( s ( x := aval t s ) )"
  apply ( induction e )
  apply ( auto )
done

lemma "subst_equiv" : "aval a1 s = aval a2 s \<Longrightarrow> aval ( subst x a1 e ) s = aval ( subst x a2 e ) s"
  apply ( simp add: substitution_lemma )
done

datatype aexp2 =
  N val |
  V vname |
  Inc vname |
  Plus aexp2 aexp2 |
  Div aexp2 aexp2

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> ( val \<times> state ) option" where
  "aval2 ( N i ) s = Some (  i  , s )" |
  "aval2 ( V x ) s = Some ( s x , s )" |
  "aval2 ( Inc x ) s = Some ( s x , s ( x := ( s x ) + 1 ) )" |
  "aval2 ( Plus a1 a2 ) s =
    ( case ( aval2 a1 s ) of
      None \<Rightarrow> None |
      Some ( v1 , s1 ) \<Rightarrow>
        ( case ( aval2 a2 s1 ) of
          None \<Rightarrow> None |
          Some ( v2 , s2 ) \<Rightarrow> Some ( v1 + v2 , s2 ) ) )" |
  "aval2 ( Div a1 a2 ) s =
    ( case ( aval2 a2 s ) of
      None \<Rightarrow> None |
      Some ( v1 , s1 ) \<Rightarrow> ( if v1 = 0 then None else
        ( case ( aval2 a1 s1 ) of
          None \<Rightarrow> None |
          Some ( v2 , s2 ) \<Rightarrow> Some ( v1 div v2 , s2 ) ) ) )"

datatype lexp =
  Nl int |
  Vl vname |
  Plusl lexp lexp |
  LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
  "lval ( Nl n ) s = n" |
  "lval ( Vl x ) s = s x" |
  "lval ( Plusl a1 a2 ) s = lval a1 s + lval a2 s" |
  "lval ( LET x a1 a2 ) s = lval a2 ( s ( x := lval a1 s ) )"

fun inline :: "lexp \<Rightarrow> aexp" where
  "inline ( Nl n ) = aexp.N n" |
  "inline ( Vl x ) = aexp.V x" |
  "inline ( Plusl a1 a2 ) = aexp.Plus ( inline a1 ) ( inline a2 )" |
  "inline ( LET x t e ) = subst x ( inline t ) ( inline e )"

lemma "lval l s = aval ( inline l ) s"
  apply ( induction l  arbitrary: s )
  apply ( auto simp add: substitution_lemma)
done

datatype bexp =
  Bc bool |
  Not bexp |
  And bexp bexp |
  Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
  "bval ( Bc v ) s = v" |
  "bval ( Not b ) s = ( \<not> bval b s )" |
  "bval ( And b1 b2 ) s = ( bval b1 s \<and> bval b2 s )" |
  "bval ( Less a1 a2 ) s = ( aval a1 s < aval a2 s )"

fun not :: "bexp \<Rightarrow> bexp" where
  "not ( Bc True ) = Bc False" |
  "not ( Bc False ) = Bc True" |
  "not b = Not b"

lemma "not_lemma" : "bval ( not b ) s = bval ( Not b ) s"
  apply ( induction b )
  apply ( auto )
done

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
  "and ( Bc True ) b = b" |
  "and b ( Bc True ) = b" |
  "and ( Bc False ) _ = Bc False" |
  "and _ ( Bc False ) = Bc False" |
  "and b1 b2 = And b1 b2"

lemma "and_lemma" : "bval ( and b1 b2 ) s = bval ( And b1 b2 ) s"
  apply ( induction b1 b2 rule: and.induct )
  apply ( auto )
done

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "less ( aexp.N n1 ) ( aexp.N n2 ) = Bc ( n1 < n2 )" |
  "less a1 a2 = Less a1 a2"

lemma "less_lemma" : "bval ( less a1 a2 ) s = bval ( Less a1 a2 ) s"
  apply ( induction a1 a2 rule: less.induct )
  apply ( auto )
done

fun bsimp :: "bexp \<Rightarrow> bexp" where
  "bsimp ( Bc v ) = Bc v" |
  "bsimp ( Not b ) = not ( bsimp b )" |
  "bsimp ( And b1 b2 ) = and ( bsimp b1 ) ( bsimp b2 )" |
  "bsimp ( Less a1 a2 ) = less ( asimp a1 ) ( asimp a2 )"

lemma "bval ( bsimp b ) = bval b"
  apply ( induction b rule: bsimp.induct )
  apply ( auto split: bexp.split simp: not_lemma and_lemma less_lemma assimp_correct)
done

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Le a1 a2 = Not ( Less a2 a1 )"

lemma "bval ( Le a1 a2 ) s = ( aval a1 s \<le> aval a2 s )"
  apply ( auto simp add: Le_def)
done

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Eq a1 a2 = And ( Le a1 a2 ) ( Le a2 a1 )"

lemma "bval ( Eq a1 a2 ) s = ( aval a1 s = aval a2 s)"
  apply ( auto simp add: Eq_def Le_def )
done

datatype ifexp =
  Bc2 bool |
  If ifexp ifexp ifexp |
  Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
  "ifval ( Bc2 b ) s = b" |
  "ifval ( If i t e ) s = ( if ( ifval i s ) then ( ifval t s ) else ( ifval e s ) )" |
  "ifval ( Less2 a1 a2 ) s = ( aval a1 s < aval a2 s )"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
  "b2ifexp ( Bc b ) = Bc2 b" |
  "b2ifexp ( Not b ) = If ( b2ifexp b ) ( Bc2 False ) ( Bc2 True )" |
  "b2ifexp ( And b1 b2 ) = If ( b2ifexp b1 ) ( b2ifexp b2 ) ( Bc2 False )" |
  "b2ifexp ( Less a1 a2 ) = Less2 a1 a2"

lemma "ifval ( b2ifexp b ) s = bval b s"
  apply ( induction b )
  apply ( auto )
done

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
  "if2bexp ( Bc2 b ) = Bc b" |
  "if2bexp ( If i t e ) =
    And
      ( Not (  And ( if2bexp i )  ( Not ( if2bexp t ) )  ) )
      ( Not (  And ( Not ( if2bexp i ) )  ( Not ( if2bexp e ) )  ) )" |
  "if2bexp ( Less2 a1 a2 ) = Less a1 a2"

lemma "bval ( if2bexp i ) s = ifval i s"
  apply ( induction i )
  apply ( auto )
done

datatype pbexp =
  VAR vname |
  NOT pbexp |
  AND pbexp pbexp |
  OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> ( vname \<Rightarrow> bool ) \<Rightarrow> bool" where
  "pbval ( VAR x ) s = s x" |
  "pbval ( NOT p ) s = ( \<not> pbval p s )" |
  "pbval ( AND p1 p2 ) s = ( pbval p1 s \<and> pbval p2 s )" |
  "pbval ( OR p1 p2 ) s = ( pbval p1 s \<or> pbval p2 s )"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
  "is_nnf ( VAR _ ) = True" |
  "is_nnf ( NOT ( VAR x ) ) = True" |
  "is_nnf ( NOT b ) = False " |
  "is_nnf ( AND p1 p2 ) = ( is_nnf p1 \<and> is_nnf p2 )" |
  "is_nnf ( OR p1 p2 ) = ( is_nnf p1 \<and> is_nnf p2 )"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
  "nnf ( VAR x ) = VAR x" |
  "nnf ( NOT ( VAR x ) ) = NOT ( VAR x )" |
  "nnf ( NOT ( NOT b ) ) = nnf b" |
  "nnf ( NOT ( AND p1 p2 ) ) = OR  ( nnf ( NOT p1 ) )  ( nnf ( NOT p2 ) )" |
  "nnf ( NOT ( OR p1 p2 ) ) = AND  ( nnf ( NOT p1 ) )  ( nnf ( NOT p2 ) )" |
  "nnf ( AND p1 p2 ) = AND ( nnf p1 ) ( nnf p2 )" |
  "nnf ( OR p1 p2 ) = OR ( nnf p1 ) ( nnf p2 )"

lemma "is_nnf ( nnf b )"
  apply ( induction b rule: nnf.induct )
  apply ( auto )
done

lemma "pbval ( nnf b ) s = pbval b s"
  apply ( induction b rule: nnf.induct  )
  apply ( auto split: pbexp.split )
done

fun or_free :: "pbexp \<Rightarrow> bool" where
  "or_free ( VAR _ ) = True" |
  "or_free ( NOT b ) = ( or_free b )" |
  "or_free ( OR _ _ ) = False" |
  "or_free ( AND b1 b2 ) = ( or_free b1 \<and> or_free b2 )"

fun is_dnf :: "pbexp \<Rightarrow> bool" where
  "is_dnf ( VAR _ ) = True" |
  "is_dnf ( NOT ( VAR x ) ) = True" |
  "is_dnf ( NOT b ) = False" |
  "is_dnf ( OR b1 b2 ) = ( is_dnf b1 \<and> is_dnf b2 )" |
  "is_dnf ( AND b1 b2 ) = ( or_free b1 \<and> or_free b2 \<and> is_nnf b1 \<and> is_nnf b2 )"

lemma "nnf_if_dnf" : "is_dnf b \<Longrightarrow> is_nnf b"
  apply ( induction b rule: is_dnf.induct )
  apply ( auto )
done

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
  "dist_AND ( VAR x1 ) ( VAR x2 ) = AND ( VAR x1 ) ( VAR x2 )" |
  "dist_AND ( VAR x ) ( NOT b ) = AND ( VAR x ) ( NOT b)" |
  "dist_AND ( NOT b ) ( VAR x ) = AND ( NOT b ) ( VAR x )" |
  "dist_AND ( NOT b1 ) ( NOT b2 ) = AND ( NOT b1 ) ( NOT b2 )" |
  "dist_AND ( OR b1 b2 ) b = OR ( dist_AND b1 b ) ( dist_AND b2 b )" |
  "dist_AND b ( OR b1 b2 ) = OR ( dist_AND b b1 ) ( dist_AND b b2 )" |
  "dist_AND ( AND b1 b2 ) b = AND ( AND b1 b2 ) b" |
  "dist_AND b ( AND b1 b2 ) = AND b ( AND b1 b2 )"

lemma "dist_AND_correct" : "pbval ( dist_AND b1 b2 ) s = pbval ( AND b1 b2 ) s"
  apply ( induction b1 b2 rule: dist_AND.induct )
  apply ( auto )
done

lemma "or_free_if_dnf" : "is_dnf (NOT b) \<Longrightarrow> or_free b"
  apply ( induction b )
  apply ( auto )
done

lemma "dist_AND_preserves_dnf" : "is_dnf b1 \<Longrightarrow> is_dnf b2 \<Longrightarrow> is_dnf ( dist_AND b1 b2 )"
  apply ( induction b1 b2 rule: dist_AND.induct )
  apply ( auto simp: nnf_if_dnf or_free_if_dnf)
done

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
  "dnf_of_nnf ( VAR x ) = VAR x" |
  "dnf_of_nnf ( NOT b ) = NOT b" |
  "dnf_of_nnf ( OR b1 b2 ) = OR ( dnf_of_nnf b1 ) ( dnf_of_nnf b2 )" |
  "dnf_of_nnf ( AND b1 b2 ) = dist_AND ( dnf_of_nnf b1 ) ( dnf_of_nnf b2 )"

lemma "pbval ( dnf_of_nnf b ) s = pbval b s"
  apply ( induction b )
  apply ( auto simp add: dist_AND_correct )
done

lemma "dnf_if_nnf" : "is_nnf (NOT b) \<Longrightarrow> is_dnf (NOT b)"
  apply ( induction b )
  apply ( auto )
done

lemma "is_nnf b \<Longrightarrow> is_dnf ( dnf_of_nnf b )"
  apply ( induction b rule: dnf_of_nnf.induct )
  apply ( auto simp: dnf_if_nnf dist_AND_preserves_dnf )
done

datatype instr =
  LOADI val |
  LOAD vname |
  ADD

type_synonym stack = "val list"

abbreviation "hd2 xs \<equiv> hd ( tl xs )"
abbreviation "tl2 xs \<equiv> tl ( tl xs )"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
  "exec1 ( LOADI n ) _ stk = n # stk" |
  "exec1 ( LOAD x ) s stk = ( s x ) # stk" |
  "exec1 ( ADD ) _ stk = ( hd2 stk + hd stk ) # tl2 stk"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
  "exec [] _ stk = stk" |
  "exec ( i # is ) s stk = exec is s ( exec1 i s stk )"

fun comp :: "aexp \<Rightarrow> instr list" where
  "comp ( aexp.N n ) = [ LOADI n ]" |
  "comp ( aexp.V x ) = [ LOAD x ]" |
  "comp ( aexp.Plus e1 e2 ) = comp e1 @ comp e2 @ [ ADD ]"

lemma "exec_concat" : "exec ( is1 @ is2 ) s stk = exec is2 s ( exec is1 s stk )"
  apply ( induction is1 arbitrary: is2 s stk )
  apply ( auto )
done

lemma "exec ( comp a ) s stk = aval a s # stk"
  apply ( induction a arbitrary: s stk )
  apply ( auto simp: exec_concat )
done

end


theory Chapter1
  imports Chapter0
begin

section "1 Topology  Definition"

(* A topology on a set X is a collection T of subsets of X,
including the empty set \<emptyset> and X itself,
in which T is closed under arbitrary union and finite intersection *)

definition open_topo :: "('w \<sigma> \<Rightarrow> bool) \<Rightarrow> bool"
  where "open_topo T \<equiv> T \<^bold>\<top> \<and> T \<^bold>\<bottom>
                \<and> supremum_closed T
                \<and> meet_closed T"

definition closed_topo :: "('w \<sigma> \<Rightarrow> bool) \<Rightarrow> bool"
  where "closed_topo T \<equiv> T \<^bold>\<top> \<and> T \<^bold>\<bottom>
                \<and> join_closed T
                \<and> infimum_closed T"

section "2 Closure Operator Axioms"

(*
Associated with any topology T is the topological closure operator,
denoted Cl, which gives, for any subset A \<subseteq> X,
the smallest closed set containing A.

Obviously, a set A is closed if and only if Cl(A) = A.
Therefore, we can treat T as the collection of all fixed points of the Cl operator.
Here and below, we call a set A \<subseteq> X a fixed point of an operator Op
if and only if Op(A) = A.
*)

(* fix point definition *)
definition fixpoint_op::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("(_\<^sup>f\<^sup>p)")
  where "\<phi>\<^sup>f\<^sup>p  \<equiv> \<lambda>X. (\<phi> X) \<^bold>\<leftrightarrow> X"
definition fixpoint_pred::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<sigma> \<Rightarrow> bool)" ("fp")
  where "fp \<phi> \<equiv> \<lambda>X. \<phi> X \<^bold>\<approx> X"

(*
Denote P(X) as the powerset of X.
Then Cl as defined above is viewed as an operator Cl : P(X) \<rightarrow> P(X)
that satisfies the following properties (for any sets A, B \<subseteq> X):
[CO1] Cl(\<emptyset>) = \<emptyset>;
[CO2] A \<subseteq> Cl(A);
[CO3] Cl(Cl(A)) = Cl(A);
[CO4] Cl(A \<union> B) = Cl(A) \<union> Cl(B).
*)

(* Normality (NORM) *)
definition CO1::"'w cl \<Rightarrow> bool" ("NORM")
  where "CO1 Cl \<equiv> (Cl \<^bold>\<bottom>) \<^bold>\<approx> \<^bold>\<bottom>"
(* Expansive (EXPN) *)
definition CO2::"'w cl \<Rightarrow> bool" ("EXPN")
  where "CO2 Cl \<equiv> \<forall>A. A \<^bold>\<preceq> Cl A"
(* Idempotent (IDEM) *)
definition CO3::"'w cl \<Rightarrow> bool" ("IDEM")
  where "CO3 Cl \<equiv> \<forall>A. (Cl A) \<^bold>\<approx> Cl(Cl A)"
(* Additivity (ADDI) *)
definition CO4::"'w cl \<Rightarrow> bool" ("ADDI")
  where "CO4 Cl \<equiv> \<forall>A B. Cl(A \<^bold>\<or> B) \<^bold>\<approx> (Cl A) \<^bold>\<or> (Cl B)"

definition closure_op :: "'w cl \<Rightarrow> bool"
  where "closure_op \<equiv> CO1 \<^bold>\<and> CO2 \<^bold>\<and> CO3 \<^bold>\<and> CO4"

named_theorems closure_def (*to group together order-related definitions*)
declare
  CO1_def[closure_def]
  CO2_def[closure_def]
  CO3_def[closure_def]
  CO4_def[closure_def]

(*
Indeed, any operator Cl on P(X)
that satisfies the above four axioms (called Kuratowski Closure Axioms)
defines a topological closure operator.
Its fixed points {A| Cl(A) = A} form a set system
that can be properly identified as a collection of closed sets
*)

lemma
  (*assumes "closure_op Cl"*)
  fixes Cl
  assumes "closure_op Cl"
  shows "closed_topo (fp Cl)"
  unfolding closed_topo_def
proof
  show "fp Cl \<^bold>\<top>"
  proof (unfold fixpoint_pred_def setequ_def top_def, rule, rule)
    fix w
    show l2r: "Cl (\<lambda>w. True) w \<Longrightarrow> True" by simp
  next
    fix w
    show r2l: "True \<Longrightarrow> (Cl (\<lambda>w. True)) w"
    proof -
      have "\<forall>A. A \<^bold>\<preceq> Cl A"
        using CO2_def assms closure_op_def meet_def by metis
    hence "(\<lambda>w. True) \<^bold>\<preceq> Cl (\<lambda>w. True)" by simp
    thus "True \<Longrightarrow> (Cl (\<lambda>w. True)) w" by (simp add: subset_def)
  qed
qed
next
  show "fp Cl \<^bold>\<bottom> \<and> join_closed (fp Cl) \<and> infimum_closed (fp Cl)"
    apply (rule conjI)
  proof -

    from assms
    have "CO2 Cl" by (simp add: closure_op_def meet_def)
    thus "\<And>w. Cl (\<lambda>w. True) w"
      by (simp add: CO2_def subset_def)
  qed
next
  show "fp Cl \<^bold>\<bottom> \<and> join_closed (fp Cl) \<and> infimum_closed (fp Cl)"
  proof
    from assms
    have 1: "CO1 Cl" by (simp add: closure_op_def meet_def)
    thus "fp Cl \<^bold>\<bottom>" by (simp add: CO1_def fixpoint_pred_def)
  next
    show "join_closed (fp Cl) \<and> infimum_closed (fp Cl)"
      apply ( rule conjI )
       apply ( unfold join_closed_def join_def fixpoint_pred_def setequ_def)
       apply (rule allI, rule allI, rule impI, rule allI, rule iffI)
      apply auto
    proof -
      from assms
      have 4: "CO4 Cl" by (simp add: closure_op_def meet_def)
      thus "\<And>X Y w. Cl (\<lambda>w. X w \<or> Y w) w \<Longrightarrow> \<forall>w. Cl X w = X w \<Longrightarrow> \<forall>w. Cl Y w = Y w \<Longrightarrow> \<not> Y w \<Longrightarrow> X w"
        by (simp add: CO4_def join_def setequ_equ)
    next
      show "\<And>X Y w. \<forall>w. Cl X w = X w \<Longrightarrow> \<forall>w. Cl Y w = Y w \<Longrightarrow> X w \<Longrightarrow> Cl (\<lambda>w. X w \<or> Y w) w"
      proof -
        from assms
        have 4: "CO4 Cl" by (simp add: closure_op_def meet_def)
        thus "\<And>X Y w. \<forall>w. Cl X w = X w \<Longrightarrow> \<forall>w. Cl Y w = Y w \<Longrightarrow> X w \<Longrightarrow> Cl (\<lambda>w. X w \<or> Y w) w"
          by (simp add: CO4_def join_def setequ_equ)
      qed
    next
      show "\<And>X Y w. \<forall>w. Cl X w = X w \<Longrightarrow> \<forall>w. Cl Y w = Y w \<Longrightarrow> Y w \<Longrightarrow> Cl (\<lambda>w. X w \<or> Y w) w"
      proof -
        from assms
        have 4: "CO4 Cl" by (simp add: closure_op_def meet_def)
        thus "\<And>X Y w. \<forall>w. Cl X w = X w \<Longrightarrow> \<forall>w. Cl Y w = Y w \<Longrightarrow> Y w \<Longrightarrow> Cl (\<lambda>w. X w \<or> Y w) w"
          by (simp add: CO4_def join_def setequ_equ)
      qed
    next
      show "infimum_closed (\<lambda>X. \<forall>w. Cl X w = X w)"
        apply (unfold infimum_closed_def infimum_def)
        apply (rule allI, rule impI, rule allI, rule iffI)
        apply (rule allI )
      proof
        show "\<And>D w X. D \<sqsubseteq> (\<lambda>X. \<forall>w. Cl X w = X w) \<Longrightarrow> Cl (\<lambda>w. D \<sqsubseteq> (\<lambda>X. X w)) w \<Longrightarrow> D X \<Longrightarrow> X w" sledgehammer

(*
We can then take set-complement of each of these closed sets
to obtain another collection (i.e., another system of sets),
which properly form an (open set) topology
*)

lemma
  assumes "closure_op Cl"
  shows "open_topo (\<lambda>X. fp Cl (\<^bold>\<midarrow> X))" sorry

section "3 Interior Operator Axioms"

(*
Dual to the topological closure operator
is the topological interior operator Int,
which satisfies the following four axioms (for any sets A, B \<subseteq> X):
[IO1] Int(X) = X;
[IO2] Int(A) \<subseteq> A;
[IO3] Int(Int(A)) = Int(A);
[IO4] Int(A \<inter> B) = Int(A) \<inter> Int(B).
The fixed points of Int, the set system {A |Int(A) = A},
form a system of subsets of X that will be called “open sets”,
hence defining the topological space (X, T).
*)

(* dual Normality (DNRM).*)
definition IO1::"'w cl \<Rightarrow> bool" ("DNRM") where "IO1 Int' \<equiv> (Int' \<^bold>\<top>) \<^bold>\<approx> \<^bold>\<top>"
(* Expansive dual - contractive (CNTR).*)
definition IO2::"'w cl \<Rightarrow> bool" ("CNTR") where "IO2 Int' \<equiv> \<forall>A. Int' A \<^bold>\<preceq> A"
(* Idempotent (IDEM) *)
definition IO3::"'w cl \<Rightarrow> bool" ("IDEM") where "IO3 Int' \<equiv> \<forall>A. (Int' A) \<^bold>\<approx> Int'(Int' A)"
(* Additivity (ADDI) *)
definition IO4::"'w cl \<Rightarrow> bool" ("MULT") where "IO4 Int' \<equiv> \<forall>A B. Int' (A \<^bold>\<and> B) \<^bold>\<approx> (Int' A) \<^bold>\<and> (Int' B)"

definition interior_op :: "'w cl \<Rightarrow> bool"
  where "interior_op  \<equiv> IO1 \<^bold>\<and> IO2 \<^bold>\<and> IO3 \<^bold>\<and> IO4"

lemma assumes "interior_op Int'" shows "open_topo (fp Int')" sorry

section "4 Comprehension and Outlook"

(* ...

The equivalence of the above two axiomatically defined operators on P(X) in specifying any topology T is well known. In addition to the closure or interior operators defining
a topological space, there are other four set operators widely used as primitive operators
in topology.

They are the exterior operator, the boundary operator, the derived-set operator,
and the dually defined co-derived-set operator. All these operators have been shown to be
able to specify an identical topology T —they are equivalent to one another, as with Cl
and Int operators. We call these various inter-related set operators specifying the one
and the same topology a Topological System, while still use (X, T ) to denote it. Each of
the six above-mentioned operators P(X) \<rightarrow> P(X) provides equivalent characterizations
of (X, T ). In a Topological System, the various operators, when taken together, provide
comprehensive topological semantics to ground first-order modal logic.

In parallel to these various axiomatizations of a Topological System, it is also long
established that the topological closure operator can be relaxed to the more general setting
of a Closure System in which the closure operator satisfies, instead of [CO1]–[CO4], three
similar axioms (see below), without enforcing axiom [CO1] (related to “groundedness”)
and axiom [CO4] (related to “stable under union”). The fixed points associated with
this generalized closure operator are called (generalized) closed sets. Viewed in this way, the
closed set system of a Topological System is just a special case of a generalized Closure
System. Other applications of the Closure System include Matroid, Antimatroid/Learning
Space [4–7], or Concept Lattice [8], in which the generalized closure operator is enhanced
with an additional exchange axiom, anti-exchange axiom, or a Galois connection.

...

*)

end


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

theory utp_recursion
  imports
    utp_pred_laws
    utp_rel
begin

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

lemma mu_id: "(\<mu> X \<bullet> X) = true"
  by (simp add: antisym gfp_upperbound)

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

lemma nu_id: "(\<nu> X \<bullet> X) = false"
  by (meson lfp_lowerbound utp_pred_laws.bot.extremum_unique)

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

lemma mu_refine_intro:
  assumes "(C \<Rightarrow> S) \<sqsubseteq> F(C \<Rightarrow> S)" "(C \<and> \<mu> F) = (C \<and> \<nu> F)"
  shows "(C \<Rightarrow> S) \<sqsubseteq> \<mu> F"
proof -
  from assms have "(C \<Rightarrow> S) \<sqsubseteq> \<nu> F"
    by (simp add: lfp_lowerbound)
  with assms show ?thesis
    by (pred_auto)
qed

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

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

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

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

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

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

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

lemma L274:
  assumes "\<forall> n. ((E n \<and>\<^sub>p X) = (E n \<and> Y))"
  shows "(\<Sqinter> (range E) \<and> X) = (\<Sqinter> (range E) \<and> Y)"
  using assms by (pred_auto)

text \<open> Constructive chains \<close>

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

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

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

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

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

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

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

lemma  wf_fixp_uinduct_pure_ueq_gen:
  assumes fixp_unfold: "fp B = B (fp B)"
  and              WF: "wf R"
  and     induct_step:
          "\<And>f st. \<lbrakk>\<And>st'. (st',st) \<in> R  \<Longrightarrow> (((Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st'\<guillemotright>) \<Rightarrow> Post) \<sqsubseteq> f)\<rbrakk>
               \<Longrightarrow> fp B = f \<Longrightarrow>((Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright>) \<Rightarrow> Post) \<sqsubseteq> (B f)"
        shows "((Pre \<Rightarrow> Post) \<sqsubseteq> fp B)"
proof -
  { fix st
    have "((Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright>) \<Rightarrow> Post) \<sqsubseteq> (fp B)"
    using WF proof (induction rule: wf_induct_rule)
      case (less x)
      hence "(Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>x\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> B (fp B)"
        by (rule induct_step, rel_blast, simp)
      then show ?case
        using fixp_unfold by auto
    qed
  }
  thus ?thesis
  by pred_simp
qed

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

lemma refine_usubst_to_ueq:
  "vwb_lens E \<Longrightarrow> (Pre \<Rightarrow> Post)\<lbrakk>\<guillemotleft>st'\<guillemotright>/$E\<rbrakk> \<sqsubseteq> f\<lbrakk>\<guillemotleft>st'\<guillemotright>/$E\<rbrakk> = (((Pre \<and> $E =\<^sub>u \<guillemotleft>st'\<guillemotright>) \<Rightarrow> Post) \<sqsubseteq> f)"
  by (rel_auto, metis vwb_lens_wb wb_lens.get_put)

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

lemma mu_rec_total_pure_rule:
  assumes WF: "wf R"
  and     M: "mono B"
  and     induct_step:
          "\<And> f st.  \<lbrakk>(Pre \<and> (\<lceil>e\<rceil>\<^sub><,\<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> f\<rbrakk>
               \<Longrightarrow> \<mu> B = f \<Longrightarrow>(Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> (B f)"
        shows "(Pre \<Rightarrow> Post) \<sqsubseteq> \<mu> B"
proof (rule wf_fixp_uinduct_pure_ueq_gen[where fp=\<mu> and Pre=Pre and B=B and R=R and e=e])
  show "\<mu> B = B (\<mu> B)"
    by (simp add: M def_gfp_unfold)
  show "wf R"
    by (fact WF)
  show "\<And>f st. (\<And>st'. (st', st) \<in> R \<Longrightarrow> (Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st'\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> f) \<Longrightarrow>
                \<mu> B = f \<Longrightarrow>
                (Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> B f"
    by (rule induct_step, rel_simp, simp)
qed

lemma nu_rec_total_pure_rule:
  assumes WF: "wf R"
  and     M: "mono B"
  and     induct_step:
          "\<And> f st.  \<lbrakk>(Pre \<and> (\<lceil>e\<rceil>\<^sub><,\<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> f\<rbrakk>
               \<Longrightarrow> \<nu> B = f \<Longrightarrow>(Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> (B f)"
        shows "(Pre \<Rightarrow> Post) \<sqsubseteq> \<nu> B"
proof (rule wf_fixp_uinduct_pure_ueq_gen[where fp=\<nu> and Pre=Pre and B=B and R=R and e=e])
  show "\<nu> B = B (\<nu> B)"
    by (simp add: M def_lfp_unfold)
  show "wf R"
    by (fact WF)
  show "\<And>f st. (\<And>st'. (st', st) \<in> R \<Longrightarrow> (Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st'\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> f) \<Longrightarrow>
                \<nu> B = f \<Longrightarrow>
                (Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> B f"
    by (rule induct_step, rel_simp, simp)
qed

text \<open>Since @{term "B ((Pre \<and> (\<lceil>E\<rceil>\<^sub><,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright> \<Rightarrow> Post)) \<sqsubseteq> B (\<mu> B)"} and
      @{term "mono B"}, thus,  @{thm mu_rec_total_pure_rule} can be expressed as follows\<close>

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

lemma nu_rec_total_utp_rule:
  assumes WF: "wf R"
    and     M: "mono B"
    and     induct_step:
    "\<And>st. (Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> (B ((Pre \<and> (\<lceil>e\<rceil>\<^sub><,\<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<Rightarrow> Post)))"
  shows "(Pre \<Rightarrow> Post) \<sqsubseteq> \<nu> B"
proof (rule nu_rec_total_pure_rule[where R=R and e=e], simp_all add: assms)
  show "\<And>f st. (Pre \<and> (\<lceil>e\<rceil>\<^sub><, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> f \<Longrightarrow> \<nu> B = f \<Longrightarrow> (Pre \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright> \<Rightarrow> Post) \<sqsubseteq> B f"
    by (simp add: M induct_step monoD order_subst2)
qed

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_sort_nat_MSortBUIsSort
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

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

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

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

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

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

fun insert :: "Nat => Nat list => Nat list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

theorem property0 :
  "((msortbu xs) = (isort xs))"
  oops

end