theory ActivationLanguage_bool
imports Lattices ActivationLanguageSyntax
  "../Boolean_Expression_Checkers/Boolean_Expression_Checkers"
begin

section \<open>Boolean expression\<close>

text \<open>Copied from Boolean_Expression_Example\<close>

datatype 'a bexp =
  Const bool |
  Atom 'a |
  Neg "'a bexp" |
  And "'a bexp" "'a bexp"

fun bval where
"bval (Const b) s = b" |
"bval (Atom a) s = s a" |
"bval (Neg b) s = (\<not> bval b s)" |
"bval (And b1 b2) s = (bval b1 s \<and> bval b2 s)"

subsection \<open>Indirect Translation using the Boolean Expression Interface\<close>

text \<open>Now we translate into @{datatype bool_expr} provided by the checkers interface and show that the
  semantics remains the same:\<close>

fun bool_expr_of_bexp :: "'a bexp \<Rightarrow> 'a bool_expr"
where
  "bool_expr_of_bexp (Const b) = Const_bool_expr b"
| "bool_expr_of_bexp (Atom a) = Atom_bool_expr a"
| "bool_expr_of_bexp (Neg b) = Neg_bool_expr(bool_expr_of_bexp b)"
| "bool_expr_of_bexp (And b1 b2) = And_bool_expr (bool_expr_of_bexp b1) (bool_expr_of_bexp b2)"

lemma val_preservation:
  "val_bool_expr (bool_expr_of_bexp b) s = bval b s"
  by (induction b) auto

definition "my_taut_test_bool = bool_taut_test o bool_expr_of_bexp"
definition "my_sat_test_bool = bool_sat_test o bool_expr_of_bexp"

corollary my_taut_test:
  "my_taut_test_bool b = (\<forall>s. bval b s)"
  by (simp add: my_taut_test_bool_def val_preservation bool_tests)

subsection \<open>Direct Translation into Reduced Binary Decision Trees\<close>

text \<open>Now we translate into a reduced binary decision tree, show that the semantics remains the same and
  the tree is reduced:\<close>

fun ifex_of :: "'a bexp \<Rightarrow> 'a ifex"
where
  "ifex_of (Const b) = (if b then Trueif else Falseif)"
| "ifex_of (Atom a) = IF a Trueif Falseif"
| "ifex_of (Neg b)   = normif Mapping.empty (ifex_of b) Falseif Trueif"
| "ifex_of (And b1 b2) = normif Mapping.empty (ifex_of b1) (ifex_of b2) Falseif"

lemma val_ifex:
  "val_ifex (ifex_of b) s = bval b s"
  by (induction b) (simp_all add: agree_Nil val_normif)

theorem reduced_ifex:
  "reduced (ifex_of b) {}"
  by (induction b) (simp; metis keys_empty reduced_normif)+

definition "my_taut_test_ifex = taut_test ifex_of"

corollary my_taut_test_ifex:
  "my_taut_test_ifex b = (\<forall>s. bval b s)"
proof -
  interpret reduced_bdt_checkers ifex_of bval
    by (unfold_locales; insert val_ifex reduced_ifex; blast)
  show ?thesis
    by (simp add: my_taut_test_ifex_def taut_test)
qed

instantiation bexp :: (type) activation_language_algebra
begin

definition
  "bot_bexp = Const False"

definition
  "compl_bexp x = (Neg x)"

definition
  "inf_bexp x y = (And x y)"

definition
  "tautology_bexp x = my_taut_test_bool x"

definition
  "contradiction_bexp x = (\<not> my_sat_test_bool x)"

instance proof
qed
end

end


theory TimSort
  imports "Simpl/Vcg" Main "~~/src/HOL/Library/Code_Target_Numeral" "TimSortLemma" "TimSortProc" "GallopA"
begin

definition equal_size :: "nat list \<Rightarrow> nat list \<Rightarrow> bool" where
"equal_size a b = (size a = size b)"

definition invariant :: "nat list \<Rightarrow> nat list \<Rightarrow> int list \<Rightarrow> nat \<Rightarrow> bool" where
"invariant run_len run_base a stack_size \<equiv>
(size (run_base) = size (run_len)) \<and>
(size a < 120 \<longrightarrow>  size run_len = 4) \<and>
(size a \<ge> 120 \<and> size a < 1542 \<longrightarrow>  size run_len = 9) \<and>
(size a \<ge>1542 \<and> size a < 119151 \<longrightarrow>  size run_len = 18) \<and>
(size a \<ge> 119151 \<and> size a < 2917196496 \<longrightarrow>  size run_len = 39) \<and>
(size a < 2917196496) \<and>
(run_base!0 + (sumn run_len stack_size) \<le> size a) \<and>
(stack_size \<ge> 0) \<and> (stack_size \<le> size run_base) \<and>
(\<forall>i. ((i\<ge>5 \<and> i\<le>stack_size)\<longrightarrow>(elem_inv run_len (stack_size-i) 16))) \<and>
(stack_size \<ge>4 \<longrightarrow> elem_bigger_than_next run_len (stack_size-4)) \<and>
(stack_size \<ge>3 \<longrightarrow> elem_larger_than_bound run_len (stack_size-3) 16) \<and>
(stack_size \<ge>2 \<longrightarrow>elem_larger_than_bound run_len (stack_size-2) 16) \<and>
(stack_size \<ge>1 \<longrightarrow>elem_larger_than_bound run_len (stack_size-1) 1) \<and>
(\<forall>i. ((i\<ge>0 \<and> i<stack_size-1)\<longrightarrow>(run_base!i + run_len!i = run_base!(i+1)))) \<and>
(elem_larger_than_bound run_base 0 0)"

lemma (in merge_at_impl) merge_at_spec:
"\<forall>\<sigma>. \<Gamma>\<turnstile> \<lbrace>\<sigma>.
(\<acute>stack_size=2 \<longrightarrow> \<acute>i=\<acute>stack_size-2) \<and>
(\<acute>stack_size\<ge>3 \<longrightarrow> (\<acute>i=\<acute>stack_size-2 \<or>\<acute>i=\<acute>stack_size-3)) \<and>
(\<acute>stack_size > 1) \<and> (\<acute>i\<ge>0) \<and>
(\<acute>a \<noteq> []) \<and>
(invariant \<acute>run_len \<acute>run_base \<acute>a \<acute>stack_size) \<rbrace>
  PROC merge_at(\<acute>i)
\<lbrace> (\<acute>i = \<^bsup>\<sigma>\<^esup>i) \<and> (\<acute>run_base!0 = \<^bsup>\<sigma>\<^esup>run_base!0) \<and>
(size \<acute>a = size \<^bsup>\<sigma>\<^esup>a) \<and>
(\<acute>stack_size = \<^bsup>\<sigma>\<^esup>stack_size - 1) \<and>
(\<acute>run_len!\<acute>i = (\<^bsup>\<sigma>\<^esup>run_len)!(\<acute>i) + (\<^bsup>\<sigma>\<^esup>run_len!(\<acute>i+1))) \<and>
((\<acute>i = \<^bsup>\<sigma>\<^esup>stack_size -3)\<longrightarrow>(\<acute>run_len!(\<acute>i+1) = \<^bsup>\<sigma>\<^esup>run_len!(\<acute>i+2)) \<and> (\<acute>run_base!(\<acute>i+1) = \<^bsup>\<sigma>\<^esup>run_base!(\<acute>i+2))) \<and>
(invariant \<acute>run_len \<acute>run_base \<acute>a \<acute>stack_size) \<and>
(sumn \<acute>run_len \<acute>stack_size = sumn \<^bsup>\<sigma>\<^esup>run_len \<^bsup>\<sigma>\<^esup>stack_size) \<and>
(\<acute>run_len!(\<acute>stack_size-1) \<ge> \<^bsup>\<sigma>\<^esup>run_len!(\<^bsup>\<sigma>\<^esup>stack_size-1)) \<rbrace>"
  apply (simp only:invariant_def)
  apply (hoare_rule HoarePartial.ProcNoRec1)
  apply vcg
  apply (rename_tac a ys xs l i)
  apply (case_tac "l=2")
   apply (subgoal_tac "sumn xs 2 = xs!0 + xs!1")
  prefer 2
  using sumn.simps numeral_2_eq_2
    apply (metis Nat.add_0_right One_nat_def add.commute)
   apply (clarsimp simp add: elem_inv_def elem_larger_than_bound_def elem_bigger_than_next_2_def elem_bigger_than_next_def)
   apply (subgoal_tac "length xs > 0")
    apply (clarsimp simp add:nth_list_update)
   apply force
(* finish the case of stack_size = 2 *)
  apply clarsimp
  apply (erule disjE)
   apply (subgoal_tac "i\<noteq>l-3")
    prefer 2
    apply linarith
  apply clarsimp
   apply (intro conjI impI)
  apply (clarsimp simp add:elem_larger_than_bound_def)
     apply (metis diff_less less_Suc_eq_le less_antisym less_imp_diff_less not_gr_zero not_le not_numeral_le_zero)
  using run_len_iter
    apply (smt One_nat_def Suc_diff_Suc Suc_lessD leD leI le_add2 less_le_trans numeral_2_eq_2)
   apply (rule allI)
   apply (clarsimp simp add:elem_larger_than_bound_def elem_inv_def elem_bigger_than_next_2_def elem_bigger_than_next_def)
   apply (intro conjI impI)
              apply (metis Suc_leI numeral_2_eq_2 sumn1)
             apply linarith
            apply clarsimp
           apply (smt Suc_diff_Suc Suc_le_mono Suc_numeral Suc_pred le_imp_less_Suc le_less_trans less_imp_le_nat not_less_eq numeral_3_eq_3 semiring_norm(2) semiring_norm(8))
          apply (metis (no_types) numeral_3_eq_3)
         apply (metis Suc_diff_Suc Suc_lessD leD minus_nat.diff_0 not_less_eq nth_list_update_eq numeral_2_eq_2 trans_le_add2)
  using sumn1
        apply (metis Suc_leI numeral_2_eq_2)
       apply (metis Suc_diff_Suc Suc_eq_plus1 diff_zero discrete le_add2 less_or_eq_imp_le nth_list_update_eq numeral_2_eq_2)
      apply (metis Suc_diff_Suc diff_zero gr0I leD not_less_eq numeral_2_eq_2)
     apply (metis Suc_diff_Suc leD less_le minus_nat.diff_0 not_less_eq numeral_2_eq_2)
  using run_len_iter
    apply (metis One_nat_def Suc_diff_Suc Suc_lessD add.commute numeral_2_eq_2)
(* finish the first 1/3 of i=stack_size - 2 *)
   apply (rule allI)
   apply clarsimp
   apply (intro conjI impI)
  using sumn1
                   apply (metis One_nat_def Suc_1 Suc_leI)
                  apply linarith
                 apply clarsimp
                apply clarsimp
                apply (smt Suc_diff_Suc Suc_le_mono Suc_numeral Suc_pred le_imp_less_Suc le_less_trans less_imp_le_nat not_less_eq numeral_3_eq_3 semiring_norm(2) semiring_norm(8))
               apply (metis numeral_3_eq_3)
              apply (metis Suc_diff_Suc Suc_lessD leD minus_nat.diff_0 not_less_eq nth_list_update_eq numeral_2_eq_2 trans_le_add2)
  using Suc_leI numeral_2_eq_2 sumn1 apply presburger
            apply (metis Suc_diff_Suc Suc_eq_plus1 diff_zero discrete le_add2 less_or_eq_imp_le nth_list_update_eq numeral_2_eq_2)
  apply (subgoal_tac "ys ! Suc (l - 2) + xs!Suc(l-2) \<le> length a")
            apply linarith
  using run_len_iter
           apply (metis One_nat_def Suc_diff_Suc Suc_lessD add.commute numeral_2_eq_2)
  using Suc_leI numeral_2_eq_2 sumn1 apply presburger
         apply linarith
        apply clarsimp
       apply clarsimp
       apply (smt Suc_diff_Suc Suc_le_mono Suc_less_eq Suc_numeral le_imp_less_Suc le_less_trans less_imp_le_nat minus_nat.diff_0 numeral_3_eq_3 semiring_norm(2) semiring_norm(8))
      apply (metis numeral_3_eq_3)
     apply (metis Suc_leI add_gr_0 less_le_trans nth_list_update_eq numeral_2_eq_2)
  using Suc_leI numeral_2_eq_2 sumn1 apply presburger
   apply (metis Suc_diff_Suc Suc_eq_plus1 diff_zero discrete le_add2 less_or_eq_imp_le nth_list_update_eq numeral_2_eq_2)
(* finish the case of i = stack_size -2 *)
  apply (clarsimp)
  apply (intro conjI)
  apply (clarsimp simp add:elem_larger_than_bound_def)
    apply (metis Suc_lessD diff_Suc_less gr0I le_less less_imp_diff_less not_numeral_le_zero numeral_3_eq_3)
  apply (subgoal_tac "ys ! Suc (l - 2) \<le> length a")
    apply (metis Suc_diff_Suc Suc_lessI le_antisym lessI nat_le_linear numeral_2_eq_2 numeral_3_eq_3 trans_le_add1)
  using run_len_iter
   apply (smt One_nat_def Suc_diff_Suc Suc_lessD leD leI le_add2 less_le_trans numeral_2_eq_2)
  apply (rule allI)
  apply (clarsimp simp add:elem_larger_than_bound_def elem_inv_def elem_bigger_than_next_2_def elem_bigger_than_next_def)
  apply (intro conjI impI)
  using sumn2
              apply (metis Suc_leI Suc_lessI numeral_2_eq_2 numeral_3_eq_3)
             apply linarith
            apply clarsimp
           apply clarsimp
           apply (smt Suc_diff_Suc Suc_le_mono Suc_numeral Suc_pred le_imp_less_Suc le_less_trans less_imp_le_nat not_less_eq numeral_3_eq_3 semiring_norm(2) semiring_norm(8))
          apply (metis nth_list_update_eq numeral_3_eq_3 trans_le_add1)
         apply clarsimp
         apply (smt One_nat_def Suc_diff_Suc Suc_eq_plus1_left Suc_lessD Suc_lessI leD length_list_update minus_nat.diff_0 not_less_eq nth_list_update_eq numeral_3_eq_3 one_add_one)
        apply clarsimp
        apply (case_tac "i=l-3")
         apply clarsimp
         apply (metis Suc_diff_Suc Suc_mono ab_semigroup_add_class.add_ac(1) less_SucI)
        apply clarsimp
  using sumn2
       apply (metis Suc_leI Suc_lessI eval_nat_numeral(3) numeral_2_eq_2)
      apply clarsimp
      apply (smt Suc_diff_Suc Suc_lessI leD length_list_update less_or_eq_imp_le minus_nat.diff_0 not_less_eq nth_list_update_eq numeral_2_eq_2 numeral_3_eq_3)
     apply (smt Suc_diff_Suc Suc_lessD Suc_pred gr0I leD not_less_eq not_numeral_le_zero numeral_2_eq_2 numeral_3_eq_3)
  apply (subgoal_tac "length xs > l-2" "Suc(l-3) = l-2")
      apply (metis (no_types) diff_less less_le_trans numeral_1_eq_Suc_0 zero_less_numeral)
     apply linarith
    apply linarith
  using run_len_iter
   apply (smt One_nat_def Suc_diff_Suc Suc_lessD Suc_lessI leD leI le_add2 less_le_trans numeral_2_eq_2 numeral_3_eq_3)
  apply (rule allI)
  apply (intro conjI impI)
  using sumn2 apply(simp_all)
              apply clarsimp
             apply clarsimp
             apply (smt Suc_diff_Suc Suc_le_mono Suc_numeral le_imp_less_Suc le_less_trans less_imp_le_nat minus_nat.diff_0 not_less_eq numeral_3_eq_3 semiring_norm(2) semiring_norm(8))
            apply (metis nth_list_update_eq numeral_3_eq_3 trans_le_add1)
           apply clarsimp
           apply (smt One_nat_def Suc_diff_Suc Suc_eq_plus1_left Suc_lessD Suc_lessI leD length_list_update minus_nat.diff_0 not_less_eq nth_list_update_eq numeral_3_eq_3 one_add_one)
          apply clarsimp
          apply (case_tac "i=l-3")
           apply clarsimp
           apply (metis Suc_diff_Suc Suc_mono ab_semigroup_add_class.add_ac(1) less_SucI)
          apply clarsimp
         apply (smt Suc_diff_Suc Suc_lessI leD length_list_update less_or_eq_imp_le minus_nat.diff_0 not_less_eq nth_list_update_eq numeral_2_eq_2 numeral_3_eq_3)
        apply(subgoal_tac "ys ! Suc (l - 3) + xs!Suc(l-3) \<le> length a")
         apply linarith
  using run_len_iter
        apply (smt One_nat_def Suc_diff_Suc Suc_lessD Suc_lessI leD leI le_add2 lessI less_le_trans numeral_2_eq_2 numeral_3_eq_3)
       apply clarsimp
      apply clarsimp
      apply (smt Suc_diff_Suc Suc_le_mono Suc_numeral le_imp_less_Suc le_less_trans less_imp_le_nat minus_nat.diff_0 not_less_eq numeral_3_eq_3 semiring_norm(2) semiring_norm(8))
     apply (metis nth_list_update_eq numeral_3_eq_3 trans_le_add1)
    apply clarsimp
    apply (smt One_nat_def Suc_diff_Suc Suc_eq_plus1_left Suc_lessD Suc_lessI leD length_list_update minus_nat.diff_0 not_less_eq nth_list_update_eq numeral_3_eq_3 one_add_one)
   apply clarsimp
   apply (case_tac "i=l-3")
    apply clarsimp
    apply (metis Suc_diff_Suc Suc_mono ab_semigroup_add_class.add_ac(1) less_SucI)
   apply clarsimp
  apply clarsimp
  apply (smt Suc_diff_Suc Suc_lessI leD length_list_update less_or_eq_imp_le minus_nat.diff_0 not_less_eq nth_list_update_eq numeral_2_eq_2 numeral_3_eq_3)
  done

lemma (in push_run_impl) push_run_spec:
"\<forall>\<sigma>. \<Gamma>\<turnstile> \<lbrace>\<sigma>.
(\<acute>run_len_i>0)\<and>(\<acute>run_len_i\<le>size \<acute>a)\<and>(\<acute>run_base_i\<ge>0)\<and>
(\<acute>stack_size>0 \<longrightarrow> (\<acute>run_base_i=\<acute>run_base!(\<acute>stack_size-1)+\<acute>run_len!(\<acute>stack_size-1))) \<and>
(\<acute>run_len_i+\<acute>run_base_i \<le> size \<acute>a) \<and>
(\<forall>i. ((i\<ge>3 \<and> i\<le>\<acute>stack_size)\<longrightarrow>(elem_inv \<acute>run_len (\<acute>stack_size-i) 16))) \<and>
(\<acute>stack_size\<ge>2 \<longrightarrow> elem_bigger_than_next \<acute>run_len (\<acute>stack_size-2)) \<and>
(\<acute>stack_size\<ge>1 \<longrightarrow> elem_larger_than_bound \<acute>run_len (\<acute>stack_size-1) 16) \<and>
(\<acute>stack_size\<ge>0 \<and> \<acute>stack_size\<le>(size \<acute>run_len)) \<and>
(invariant \<acute>run_len \<acute>run_base \<acute>a \<acute>stack_size)
 \<rbrace>
PROC push_run(\<acute>run_base_i, \<acute>run_len_i)
\<lbrace> (\<acute>run_base!(\<^bsup>\<sigma>\<^esup>stack_size) = \<acute>run_base_i) \<and>
(\<acute>run_len!( \<^bsup>\<sigma>\<^esup>stack_size) = \<acute>run_len_i) \<and>
(\<acute>stack_size =  \<^bsup>\<sigma>\<^esup>stack_size + 1) \<and>
(\<acute>run_base_i = \<^bsup>\<sigma>\<^esup>run_base_i) \<and>
(\<acute>run_len_i = \<^bsup>\<sigma>\<^esup>run_len_i) \<and>
(\<forall>i. (i\<ge>0 \<and> i<\<acute>stack_size-1) \<longrightarrow> (\<acute>run_len!i = \<^bsup>\<sigma>\<^esup>run_len!i)) \<and>
(\<forall>i. (i\<ge>0 \<and> i<\<acute>stack_size-1) \<longrightarrow> (\<acute>run_base!i = \<^bsup>\<sigma>\<^esup>run_base!i)) \<and>
(invariant \<acute>run_len \<acute>run_base \<acute>a \<acute>stack_size) \<and>
(size \<acute>a = size \<^bsup>\<sigma>\<^esup>a) \<rbrace>"
  apply (simp add:invariant_def)
  apply (hoare_rule HoarePartial.ProcNoRec1)
  apply vcg
  apply (subgoal_tac "stack_size<length run_len")
   apply (rename_tac a ys xs l bi li)
   apply (simp add: elem_inv_def elem_larger_than_bound_def elem_bigger_than_next_2_def elem_bigger_than_next_def)
   apply (intro conjI impI)
  using sumn_update_no_use apply simp
     apply (case_tac "l=0")
      apply simp
     apply simp
     apply (subgoal_tac "ys!0 + sumn xs l = xs!(l-1) + ys!(l-1)")
      apply simp
  using run_len_iter apply simp
    apply clarsimp
    apply(drule_tac x="i-1" in spec)
    apply clarsimp
    apply (metis Suc_le_mono Suc_numeral Suc_pred diff_is_0_eq' eval_nat_numeral(3) le_SucI less_imp_diff_less less_than semiring_norm(2) semiring_norm(8) zero_less_numeral)
   apply clarsimp
   apply (smt One_nat_def Suc_le_eq Suc_lessI Suc_pred diff_Suc_1 less_nat_zero_code not_less nth_list_update_eq nth_list_update_neq)
(* lemma stack_never_overflow *)
  apply (rename_tac a rb rl l rbi rli)
  apply (subgoal_tac "l \<le> length rl")
  prefer 2
   apply simp
  apply (subgoal_tac "l \<noteq> length rl")
   apply simp
  apply clarsimp
  apply (subgoal_tac "rl \<noteq> []")
   prefer 2
   apply force
  apply (simp add: elem_inv_def)
  apply (case_tac "length a < 120")
  prefer 2
   apply (case_tac "length a < 1542")
    prefer 2
  apply (case_tac "length a < 119151")
     apply (simp_all add: elem_bigger_than_next_2_def elem_bigger_than_next_def elem_larger_than_bound_def)
     prefer 2
     prefer 2
     prefer 3
     prefer 4

     apply (subgoal_tac "119 \<le> sumn rl 4")
      prefer 2
  using rl_sum_lower_bound[of 4 _ 16, simplified] apply blast
       apply (subgoal_tac "rb ! 3 + rl ! 3 = rb ! 0 + sumn rl 4")
      prefer 2
  using run_len_iter[of 4] apply simp
     apply linarith

    apply (subgoal_tac "1541 \<le> sumn rl 9")
     prefer 2
  using rl_sum_lower_bound[of 9 _ 16, simplified] apply blast
       apply (subgoal_tac "rb ! 8 + rl ! 8 = rb ! 0 + sumn rl 9")
      prefer 2
  using run_len_iter[of 9] apply simp
    apply linarith

   apply (subgoal_tac "119150 \<le> sumn rl 18")
     prefer 2
  using rl_sum_lower_bound[of 18 _ 16, simplified] apply blast
       apply (subgoal_tac "rb ! 17 + rl ! 17 = rb ! 0 + sumn rl 18")
      prefer 2
  using run_len_iter[of 18] apply simp
   apply linarith

  apply (subgoal_tac "2917196495 \<le> sumn rl 39")
     prefer 2
  using rl_sum_lower_bound[of 39 _ 16, simplified] apply blast
       apply (subgoal_tac "rb ! 38 + rl ! 38 = rb ! 0 + sumn rl 39")
      prefer 2
  using run_len_iter[of 39] apply simp
  apply linarith
  done

lemma (in merge_collapse_impl) merge_collapse_spec:
"\<forall>\<sigma>. \<Gamma>\<turnstile> \<lbrace>\<sigma>. (\<acute>stack_size>0) \<and> (\<acute>stack_size\<ge>4 \<longrightarrow> elem_inv \<acute>run_len (\<acute>stack_size-4) 16) \<and>
(\<acute>stack_size\<ge>3 \<longrightarrow> elem_bigger_than_next \<acute>run_len (\<acute>stack_size-3)) \<and>
(\<acute>a \<noteq> []) \<and>
(invariant \<acute>run_len \<acute>run_base \<acute>a \<acute>stack_size) \<rbrace>
PROC merge_collapse()
\<lbrace> (\<forall>i. ((i\<ge>3 \<and> i\<le>\<acute>stack_size)\<longrightarrow>(elem_inv \<acute>run_len (\<acute>stack_size-i) 16))) \<and>
(\<acute>stack_size\<ge>2 \<longrightarrow> elem_bigger_than_next \<acute>run_len (\<acute>stack_size-2)) \<and>
(sumn \<acute>run_len \<acute>stack_size = sumn \<^bsup>\<sigma>\<^esup>run_len \<^bsup>\<sigma>\<^esup>stack_size ) \<and>
(\<acute>run_len!(\<acute>stack_size-1) \<ge> \<^bsup>\<sigma>\<^esup>run_len!(\<^bsup>\<sigma>\<^esup>stack_size-1)) \<and>
(\<acute>stack_size>0 \<and> \<acute>stack_size \<le> \<^bsup>\<sigma>\<^esup>stack_size) \<and>
(invariant \<acute>run_len \<acute>run_base \<acute>a \<acute>stack_size) \<and>
(size \<acute>a = size \<^bsup>\<sigma>\<^esup>a)\<and>
(\<acute>run_base!0 = \<^bsup>\<sigma>\<^esup>run_base!0) \<rbrace>"
  apply (hoare_rule HoarePartial.ProcNoRec1)
  apply (hoare_rule anno="TRY WHILE \<acute>stack_size > 1
    INV \<lbrace>
    (sumn \<acute>run_len \<acute>stack_size  = sumn \<^bsup>\<sigma>\<^esup>run_len \<^bsup>\<sigma>\<^esup>stack_size) \<and>
    (\<forall>i. ((i\<ge>5 \<and> i\<le>\<acute>stack_size)\<longrightarrow>(elem_inv \<acute>run_len (\<acute>stack_size-i) 16))) \<and>
    (\<acute>stack_size \<ge>4 \<longrightarrow> elem_bigger_than_next \<acute>run_len (\<acute>stack_size-4)) \<and>
    (\<acute>stack_size \<ge>3 \<longrightarrow> elem_larger_than_bound \<acute>run_len (\<acute>stack_size-3) 16) \<and>
    (\<acute>stack_size \<ge>2 \<longrightarrow>elem_larger_than_bound \<acute>run_len (\<acute>stack_size-2) 16) \<and>
    (\<acute>stack_size \<ge>1 \<longrightarrow>elem_larger_than_bound \<acute>run_len (\<acute>stack_size-1) 1) \<and>
    (\<forall>i. ((i\<ge>0 \<and> i<\<acute>stack_size-1)\<longrightarrow>(\<acute>run_base!i + \<acute>run_len!i = \<acute>run_base!(i+1)))) \<and>
    (\<acute>run_len!(\<acute>stack_size-1) \<ge> \<^bsup>\<sigma>\<^esup>run_len!(\<^bsup>\<sigma>\<^esup>stack_size-1)) \<and>
    (\<acute>stack_size>0 \<and> \<acute>stack_size \<le> \<^bsup>\<sigma>\<^esup>stack_size) \<and>
    (* add from class invariant *)
    (elem_larger_than_bound \<acute>run_base 0 0) \<and>
    (size \<acute>run_base = size \<acute>run_len) \<and>
    (\<acute>stack_size\<ge>0 \<and> \<acute>stack_size\<le>(size \<acute>run_len)) \<and>
    (size \<acute>a < 120 \<longrightarrow>  size \<acute>run_len = 4) \<and>
    (size \<acute>a \<ge> 120 \<and> size \<acute>a < 1542 \<longrightarrow>  size \<acute>run_len = 9) \<and>
    (size \<acute>a \<ge>1542 \<and> size \<acute>a < 119151 \<longrightarrow>  size \<acute>run_len = 18) \<and>
    (size \<acute>a \<ge> 119151 \<and> size \<acute>a < 2917196496\<longrightarrow>  size \<acute>run_len = 39) \<and>
    (size \<acute>a < 2917196496) \<and>
    (\<acute>run_base!0 + (sumn \<acute>run_len \<acute>stack_size) \<le> size \<acute>a) \<and>
    (* add from class invariant *)
      (size \<acute>a =  size \<^bsup>\<sigma>\<^esup>a)\<and> (\<^bsup>\<sigma>\<^esup>a\<noteq>[]) \<and> (* a \<noteq> [] is redundant actually but without make it clear you have to prove it *)
      (\<acute>run_base!0 = \<^bsup>\<sigma>\<^esup>run_base!0) \<rbrace>
    DO \<acute>n :== \<acute>stack_size-2;;
    IF (\<acute>n>0 \<and> \<acute>run_len!(\<acute>n-1) \<le> \<acute>run_len!\<acute>n + \<acute>run_len!(\<acute>n+1))
    \<or> (\<acute>n>1 \<and> \<acute>run_len!(\<acute>n-2) \<le> \<acute>run_len!(\<acute>n-1) + \<acute>run_len!\<acute>n)
    THEN IF \<acute>run_len!(\<acute>n-1) < \<acute>run_len!(\<acute>n+1) THEN \<acute>n:==\<acute>n-1 FI
    ELSE IF \<acute>n<0 \<or> \<acute>run_len!\<acute>n > \<acute>run_len!(\<acute>n+1) THEN THROW FI
    FI;;
    CALL merge_at(\<acute>n) OD CATCH SKIP END"
 in HoarePartial.annotateI)
  apply vcg
  apply (simp_all only:invariant_def)
    apply clarsimp
  prefer 2
   apply clarsimp
  apply (simp)
  apply (rename_tac xs l a ys xsn ln)
  apply (intro conjI impI allI)
             apply simp_all
        apply force
       apply force
      apply force
     apply force
    prefer 3
    apply force
   apply (simp_all add: elem_inv_def elem_bigger_than_next_2_def elem_bigger_than_next_def)
     apply (erule_tac conjE)
     apply (erule_tac conjE)
     apply (case_tac "i\<ge>5")
      apply (blast)
     apply (subgoal_tac "i=3\<or>i=4")
      prefer 2
      apply (metis Suc_numeral eval_nat_numeral(3) le_less_Suc_eq not_less semiring_norm(2) semiring_norm(8))
     apply (erule disjE)
      apply (clarsimp)
      apply (rule conjI)
       apply (metis Suc_diff_le diff_Suc_Suc not_less numeral_2_eq_2 numeral_3_eq_3)
      apply (metis Suc_diff_le diff_Suc_Suc not_less numeral_2_eq_2 numeral_3_eq_3 trans_le_add1)
     apply (rule conjI)
   apply (smt Suc_diff_le Suc_numeral diff_Suc_Suc nat_less_le not_less numeral_2_eq_2 numeral_3_eq_3 semiring_norm(2) semiring_norm(8) zero_less_Suc zero_less_diff)
  apply (simp add:elem_larger_than_bound_def)
     apply (smt Suc_diff_le Suc_lessI Suc_numeral diff_Suc_Suc diff_le_self diff_less le_antisym le_less_trans less_imp_le_nat semiring_norm(2) semiring_norm(8) zero_less_Suc zero_less_numeral)
  done

lemma (in merge_force_collapse_impl) merge_force_collapse_spec:
"\<forall>\<sigma>. \<Gamma>\<turnstile> \<lbrace>\<sigma>. (\<acute>stack_size > 0) \<and>
(\<acute>a \<noteq> []) \<and>
(invariant \<acute>run_len \<acute>run_base \<acute>a \<acute>stack_size) \<rbrace>
PROC merge_force_collapse()
\<lbrace> (\<acute>stack_size = 1) \<and>
(invariant \<acute>run_len \<acute>run_base \<acute>a \<acute>stack_size) \<and>
(size \<acute>a = size \<^bsup>\<sigma>\<^esup>a) \<rbrace>"
  apply (hoare_rule HoarePartial.ProcNoRec1)
  apply (hoare_rule anno="WHILE \<acute>stack_size > 1
INV \<lbrace> (sumn \<acute>run_len \<acute>stack_size  = sumn \<^bsup>\<sigma>\<^esup>run_len \<^bsup>\<sigma>\<^esup>stack_size) \<and>
    (\<forall>i. ((i\<ge>5 \<and> i\<le>\<acute>stack_size)\<longrightarrow>(elem_inv \<acute>run_len (\<acute>stack_size-i) 16))) \<and>
    (\<acute>stack_size \<ge>4 \<longrightarrow> elem_bigger_than_next \<acute>run_len (\<acute>stack_size-4)) \<and>
    (\<acute>stack_size \<ge>3 \<longrightarrow> elem_larger_than_bound \<acute>run_len (\<acute>stack_size-3) 16) \<and>
    (\<acute>stack_size \<ge>2 \<longrightarrow>elem_larger_than_bound \<acute>run_len (\<acute>stack_size-2) 16) \<and>
    (\<acute>stack_size \<ge>1 \<longrightarrow>elem_larger_than_bound \<acute>run_len (\<acute>stack_size-1) 1) \<and>
    (\<forall>i. ((i\<ge>0 \<and> i<\<acute>stack_size-1)\<longrightarrow>(\<acute>run_base!i + \<acute>run_len!i = \<acute>run_base!(i+1)))) \<and>
    (\<acute>run_len!(\<acute>stack_size-1) \<ge> \<^bsup>\<sigma>\<^esup>run_len!(\<^bsup>\<sigma>\<^esup>stack_size-1)) \<and>
    (\<acute>stack_size>0 \<and> \<acute>stack_size \<le> \<^bsup>\<sigma>\<^esup>stack_size) \<and>
    (* add from class invariant *)
    (elem_larger_than_bound \<acute>run_base 0 0) \<and>
    (size \<acute>run_base = size \<acute>run_len) \<and>
    (\<acute>stack_size\<ge>0 \<and> \<acute>stack_size\<le>(size \<acute>run_len)) \<and>
    (size \<acute>a < 120 \<longrightarrow>  size \<acute>run_len = 4) \<and>
    (size \<acute>a \<ge> 120 \<and> size \<acute>a < 1542 \<longrightarrow>  size \<acute>run_len = 9) \<and>
    (size \<acute>a \<ge>1542 \<and> size \<acute>a < 119151 \<longrightarrow>  size \<acute>run_len = 18) \<and>
    (size \<acute>a \<ge> 119151 \<and> size \<acute>a < 2917196496\<longrightarrow>  size \<acute>run_len = 39) \<and>
    (size \<acute>a < 2917196496) \<and>
    (\<acute>run_base!0 + (sumn \<acute>run_len \<acute>stack_size) \<le> size \<acute>a)
    (* add from class invariant *) \<and>
    (elem_larger_than_bound \<acute>run_base 0 0) \<and>
    (size \<acute>a = size \<^bsup>\<sigma>\<^esup>a) \<and> (\<^bsup>\<sigma>\<^esup>a\<noteq>[])\<rbrace>
DO \<acute>n :== \<acute>stack_size - 2;;
IF (\<acute>n > 0 \<and> \<acute>run_len!(\<acute>n-1) < \<acute>run_len!(\<acute>n+1)) THEN \<acute>n:==\<acute>n - 1 FI;;
CALL merge_at(\<acute>n) OD" in HoarePartial.annotateI)
  apply vcg
  apply (simp_all only:invariant_def)
    apply clarsimp
   prefer 2
   apply clarsimp
  apply clarsimp
  apply (intro conjI impI)
     apply force
    apply auto[1]
   apply force
  apply auto[1]
  done

lemma (in reverse_range_impl) reverse_range_modifies:
  shows
  "\<forall> \<sigma>. \<Gamma>\<turnstile> {\<sigma>} PROC reverse_range(\<acute>array, \<acute>lo, \<acute>hi, \<acute>ret)
            {t. t may_only_modify_globals \<sigma> in []}"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply (vcg spec=modifies)
  done

lemma (in reverse_range_impl) reverse_range_spec:
"\<forall>\<sigma>. \<Gamma>\<turnstile> \<lbrace>\<sigma>. (\<acute>array \<noteq> []) \<and>(\<acute>lo \<ge> 0) \<and>
(\<acute>lo \<le> \<acute>hi) \<and> (\<acute>hi \<le> size \<acute>array) \<rbrace>
PROC reverse_range(\<acute>array, \<acute>lo, \<acute>hi, \<acute>ret)
\<lbrace> (size \<acute>ret = size \<^bsup>\<sigma>\<^esup>array) \<rbrace>
"
  apply (hoare_rule HoarePartial.ProcNoRec1)
  apply (hoare_rule anno= "TRY
            IF \<acute>hi = 0 THEN THROW ELSE \<acute>hi :== \<acute>hi - 1;;
            WHILE \<acute>lo < \<acute>hi
            INV \<lbrace>
            (\<^bsup>\<sigma>\<^esup>lo \<le> \<acute>lo) \<and> (\<^bsup>\<sigma>\<^esup>hi > \<acute>hi) \<and> (\<acute>lo \<le> \<acute>hi + 1) \<and>
            (\<acute>lo - \<^bsup>\<sigma>\<^esup>lo = \<^bsup>\<sigma>\<^esup>hi - 1 - \<acute>hi) \<and>
            ( \<forall>i. i\<ge>\<^bsup>\<sigma>\<^esup>lo \<and> i<\<acute>lo \<longrightarrow> \<acute>array!i = \<^bsup>\<sigma>\<^esup>array!(\<^bsup>\<sigma>\<^esup>lo+\<^bsup>\<sigma>\<^esup>hi-i-1)) \<and>
            ( \<forall>i. i<\<^bsup>\<sigma>\<^esup>hi \<and> i>\<acute>hi \<longrightarrow> \<acute>array!i = \<^bsup>\<sigma>\<^esup>array!(\<^bsup>\<sigma>\<^esup>lo+\<^bsup>\<sigma>\<^esup>hi-i-1)) \<and>
            ( \<forall>i. i\<ge>\<acute>lo \<and> i\<le>\<acute>hi  \<longrightarrow> \<acute>array!i = \<^bsup>\<sigma>\<^esup>array!(i) ) \<and>
            (size \<acute>array = size \<^bsup>\<sigma>\<^esup>array) \<and>
            (\<^bsup>\<sigma>\<^esup>hi \<le> size \<^bsup>\<sigma>\<^esup>array)
            \<rbrace>
            DO \<acute>t :== \<acute>array ! \<acute>lo;; \<acute>array ! \<acute>lo :== \<acute>array ! \<acute>hi;;
               \<acute>array ! \<acute>hi :== \<acute>t;; \<acute>lo :== \<acute>lo + 1;;
               \<acute>hi :== \<acute>hi - 1
            OD FI CATCH Skip END;;
           \<acute>ret :== \<acute>array" in HoarePartial.annotateI)
  apply vcg
    apply simp
  apply linarith
    apply (intro conjI impI allI)
        apply simp_all
     apply (case_tac "i=loa")
      apply simp
      apply (metis Suc_diff_Suc add.commute add_diff_cancel_right' diff_Suc_diff_eq1 le_add_diff_inverse nat_less_le)
     apply simp
    apply (case_tac "i=loa")
     apply clarify
  using neq0_conv apply linarith
    apply (case_tac "i=hia")
     apply clarsimp
     apply (metis Nat.add_diff_assoc Suc_leI le_add_diff_inverse)
   apply clarsimp
  apply clarsimp
  done

lemma (in binary_sort_impl) binary_sort_modifies:
  shows
  "\<forall> \<sigma>. \<Gamma>\<turnstile> {\<sigma>} PROC binary_sort(\<acute>array, \<acute>lo, \<acute>hi, \<acute>start, \<acute>ret)
            {t. t may_only_modify_globals \<sigma> in []}"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply (vcg spec=modifies)
  done

print_locale binary_sort_impl
lemma (in binary_sort_impl) binary_sort_spec:
"\<forall>\<sigma>. \<Gamma>\<turnstile> \<lbrace>\<sigma>. (\<acute>array \<noteq> []) \<and> (\<acute>lo \<ge> 0) \<and>
(\<acute>lo < \<acute>hi) \<and> (\<acute>hi \<le> size \<acute>array) \<and>
(\<acute>start \<le> \<acute>hi) \<and> (\<acute>lo \<le> \<acute>start)  \<rbrace>
PROC binary_sort(\<acute>array, \<acute>lo, \<acute>hi, \<acute>start, \<acute>ret)
\<lbrace>
(size \<acute>ret = size \<^bsup>\<sigma>\<^esup>array)  (* these variables are not modified by the procedure, so the class invariant holds *)
\<rbrace>
"
  apply (hoare_rule HoarePartial.ProcNoRec1)
  apply (hoare_rule anno="
IF \<acute>start = \<acute>lo THEN \<acute>start :== \<acute>start + 1 FI;;
WHILE \<acute>start < \<acute>hi
 INV \<lbrace> \<acute>start\<ge>\<acute>lo \<and> \<acute>start\<le>\<acute>hi \<and>
       size \<acute>array = size \<^bsup>\<sigma>\<^esup>array \<and> \<acute>hi \<le> size \<acute>array \<rbrace>
 DO
 \<acute>pivot :== \<acute>array!\<acute>start;;
 \<acute>left :== \<acute>lo;;
 \<acute>right :== \<acute>start;;
 WHILE \<acute>left < \<acute>right
 INV \<lbrace> \<acute>left\<ge>0 \<and> \<acute>left\<le>\<acute>right \<and> \<acute>right\<le>\<acute>start \<and>
       \<acute>left\<le>(\<acute>right+\<acute>left) div 2 \<and> \<acute>right\<ge>(\<acute>right+\<acute>left) div 2 \<and>
       \<acute>left \<le> size \<acute>array \<and> size \<acute>array = size \<^bsup>\<sigma>\<^esup>array \<and>
       \<acute>start\<ge>\<acute>lo \<and> \<acute>start<\<acute>hi \<and>
       \<acute>hi \<le> size \<acute>array  \<rbrace>
 DO
  \<acute>mid :== (\<acute>left+\<acute>right) div 2;;
  IF \<acute>pivot < \<acute>array!\<acute>mid
  THEN
    \<acute>right :== \<acute>mid
  ELSE
    \<acute>left :== \<acute>mid+1
  FI
 OD;;
 \<acute>move :== \<acute>start - \<acute>left;;
 \<acute>array :== list_copy \<acute>array (\<acute>left+1) \<acute>array \<acute>left \<acute>move;;
 \<acute>array!\<acute>left :== \<acute>pivot;;
 \<acute>start :== \<acute>start + 1
OD;;
\<acute>ret :== \<acute>array" in HoarePartial.annotateI)
  apply vcg
  apply auto
  done

lemma (in count_run_and_make_ascending_impl) count_run_and_make_ascending_modifies:
  shows
  "\<forall> \<sigma>. \<Gamma>\<turnstile> {\<sigma>} PROC count_run_and_make_ascending(\<acute>array, \<acute>lo, \<acute>hi, \<acute>ret_value, \<acute>ret)
            {t. t may_only_modify_globals \<sigma> in []}"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply (vcg spec=modifies)
  done

lemma (in count_run_and_make_ascending_impl) count_run_and_make_ascending_spec:
"\<forall>\<sigma>. \<Gamma>\<turnstile> \<lbrace>\<sigma>. (\<acute>array \<noteq> []) \<and> (\<acute>lo \<ge> 0) \<and>
(\<acute>lo < \<acute>hi) \<and> (\<acute>hi \<le> size \<acute>array) \<rbrace>
PROC count_run_and_make_ascending(\<acute>array, \<acute>lo, \<acute>hi, \<acute>ret_value, \<acute>ret)
\<lbrace> (\<acute>ret_value \<ge> 0 \<and> \<acute>ret_value \<le> \<^bsup>\<sigma>\<^esup>hi - \<^bsup>\<sigma>\<^esup>lo) \<and>
(size \<acute>ret = size \<^bsup>\<sigma>\<^esup>array)
\<rbrace>
"
  apply (hoare_rule HoarePartial.ProcNoRec1)
  apply (hoare_rule anno=" \<acute>run_hi :== \<acute>lo + 1;;
            TRY IF \<acute>run_hi = \<acute>hi THEN \<acute>ret_value:==1;;\<acute>ret :== \<acute>array;; THROW FI;;
                IF \<acute>array ! \<acute>run_hi < \<acute>array ! \<acute>lo
                THEN \<acute>run_hi :== \<acute>run_hi + 1;;
                  WHILE \<acute>run_hi < \<acute>hi \<and>
                        \<acute>array ! \<acute>run_hi < \<acute>array ! (\<acute>run_hi - 1)
                  INV \<lbrace> \<acute>lo<\<acute>run_hi \<and> \<acute>run_hi\<le>\<acute>hi \<and>
                    size \<acute>array = size \<^bsup>\<sigma>\<^esup>array \<and>
                    \<^bsup>\<sigma>\<^esup>array\<noteq>[] \<and> \<acute>hi \<le> size \<^bsup>\<sigma>\<^esup>array \<and>
                    \<acute>lo = \<^bsup>\<sigma>\<^esup>lo \<and> \<acute>hi = \<^bsup>\<sigma>\<^esup>hi\<rbrace>
                  DO \<acute>run_hi :== \<acute>run_hi + 1 OD;;
                  \<acute>array :== CALL reverse_range(\<acute>array, \<acute>lo, \<acute>run_hi)
                ELSE \<acute>run_hi :== \<acute>run_hi + 1;;
                  WHILE \<acute>run_hi < \<acute>hi \<and>
                        \<acute>array ! (\<acute>run_hi - 1) \<le> \<acute>array ! \<acute>run_hi
                  INV \<lbrace> \<acute>lo<\<acute>run_hi \<and> \<acute>run_hi\<le>\<acute>hi \<and>
                    size \<acute>array = size \<^bsup>\<sigma>\<^esup>array \<and>
                    \<acute>lo = \<^bsup>\<sigma>\<^esup>lo \<and> \<acute>hi = \<^bsup>\<sigma>\<^esup>hi\<rbrace>
                  DO \<acute>run_hi :== \<acute>run_hi + 1 OD
                FI;;
                \<acute>ret_value :== \<acute>run_hi - \<acute>lo;;
                \<acute>ret :== \<acute>array
            CATCH SKIP END" in HoarePartial.annotateI)
  apply vcg
  apply auto
  done

lemma sumn_equal:"\<forall>i. i\<ge>0 \<and> i<n\<longrightarrow> xs!i=ys!i \<Longrightarrow> sumn xs n = sumn ys n"
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have sn:"sumn xs n = sumn ys n" by simp
  from Suc.prems have an:"xs!n = ys!n" by blast
  from sn an show ?case by simp
qed

lemma (in sort_impl) sort_spec:
"\<forall>\<sigma>. \<Gamma>\<turnstile> \<lbrace>\<sigma>. (\<acute>array \<noteq> []) \<and> (\<acute>lo \<ge> 0) \<and>
(\<acute>lo +2\<le> \<acute>hi) \<and> (\<acute>hi \<le> size \<acute>array) \<and> (\<acute>hi - \<acute>lo \<ge> 16) \<and> (length \<acute>array < 2917196496) \<rbrace> (* if lo + 1 = hi then the array is already sorted *)
PROC sort(\<acute>array, \<acute>lo, \<acute>hi, \<acute>ret)
\<lbrace> True\<rbrace>"
  apply (hoare_rule HoarePartial.ProcNoRec1)
  apply (hoare_rule anno = "
             TRY \<acute>n_remaining :== \<acute>hi - \<acute>lo;; IF \<acute>n_remaining < 2 THEN \<acute>ret :== \<acute>array;; THROW FI;;
                IF \<acute>n_remaining < 32
                THEN
                  CALL count_run_and_make_ascending(\<acute>array, \<acute>lo, \<acute>hi, \<acute>init_run_len_i, \<acute>array);;
                  \<acute>array :== CALL binary_sort(\<acute>array, \<acute>lo, \<acute>hi, \<acute>lo+\<acute>init_run_len_i);;
                  \<acute>ret :== \<acute>array;; THROW
                FI;;
            \<acute>a :== \<acute>array;; \<acute>stack_size :== 0;; \<acute>min_run :== 16;;
            IF size \<acute>a < 120 THEN \<acute>stack_len :== 4 ELSE
            IF size \<acute>a < 1542 THEN \<acute>stack_len :== 9 ELSE
            IF size \<acute>a < 119151 THEN \<acute>stack_len :== 18 ELSE
            \<acute>stack_len :== 39 FI FI FI;;
            \<acute>run_len :== replicate \<acute>stack_len (0::nat);;
            \<acute>run_base :== replicate \<acute>stack_len (0::nat);;
          CALL count_run_and_make_ascending(\<acute>a, \<acute>lo, \<acute>hi, \<acute>run_len_i, \<acute>a);;
          IF \<acute>run_len_i < \<acute>min_run
          THEN IF \<acute>n_remaining \<le> \<acute>min_run THEN \<acute>force :== \<acute>n_remaining ELSE \<acute>force :== \<acute>min_run FI;;
             \<acute>a :== CALL binary_sort(\<acute>a, \<acute>lo, \<acute>lo+\<acute>force, \<acute>lo+\<acute>run_len_i);;
             \<acute>run_len_i :== \<acute>force
          FI;;
          CALL push_run(\<acute>lo,\<acute>run_len_i);; CALL merge_collapse();; \<acute>lo :== \<acute>lo + \<acute>run_len_i;; \<acute>n_remaining :== \<acute>n_remaining - \<acute>run_len_i;;
            WHILE \<acute>n_remaining \<noteq> 0
            INV \<lbrace> (\<acute>stack_size>0 \<and> \<acute>stack_size \<le> size \<acute>run_len) \<and>
              (\<acute>n_remaining \<ge> 0) \<and> (\<acute>min_run \<ge> 16) \<and> (\<acute>lo + \<acute>n_remaining = \<acute>hi) \<and>
              (\<acute>lo =  \<^bsup>\<sigma>\<^esup>lo + sumn \<acute>run_len \<acute>stack_size) \<and>
              (\<forall>i. ((i\<ge>3 \<and> i\<le>\<acute>stack_size)\<longrightarrow>(elem_inv \<acute>run_len (\<acute>stack_size-i) 16))) \<and>
              (\<acute>stack_size\<ge>2 \<longrightarrow> elem_bigger_than_next \<acute>run_len (\<acute>stack_size-2)) \<and>
              (\<acute>stack_size\<ge>2 \<longrightarrow> elem_larger_than_bound \<acute>run_len (\<acute>stack_size-2) 16) \<and>
              (\<acute>stack_size\<ge>1 \<longrightarrow> elem_larger_than_bound \<acute>run_len (\<acute>stack_size-1) 1) \<and>
              (\<acute>n_remaining>0 \<longrightarrow> (\<acute>stack_size\<ge>1 \<longrightarrow> elem_larger_than_bound \<acute>run_len (\<acute>stack_size-1) 16)) \<and>
              (\<forall>i. ((i\<ge>0 \<and> i<\<acute>stack_size-1)\<longrightarrow>(\<acute>run_base!i + \<acute>run_len!i = \<acute>run_base!(i+1)))) \<and>
              (\<acute>stack_size > 0 \<longrightarrow> \<acute>run_base!0 = \<^bsup>\<sigma>\<^esup>lo) \<and>
              (\<acute>stack_size = 0 \<longrightarrow> (\<acute>n_remaining > 0 \<and> \<acute>run_base!0 = 0)) \<and>
              (* add from class invariant *)
              length \<acute>run_base = length \<acute>run_len \<and>
              (length \<acute>a < 120 \<longrightarrow> length \<acute>run_len = 4) \<and>
              (120 \<le> length \<acute>a \<and> length \<acute>a < 1542 \<longrightarrow> length \<acute>run_len = 9) \<and>
              (1542 \<le> length \<acute>a \<and> length \<acute>a < 119151 \<longrightarrow> length \<acute>run_len = 18) \<and>
              (119151 \<le> length \<acute>a \<and> length \<acute>a < 2917196496 \<longrightarrow> length \<acute>run_len = 39) \<and>
              (length \<acute>a < 2917196496) \<and>
              (\<acute>run_base ! 0 + sumn \<acute>run_len \<acute>stack_size \<le> length \<acute>a) \<and>
              (\<acute>stack_size \<le> length \<acute>run_base) \<and>
              (\<acute>hi =  \<^bsup>\<sigma>\<^esup>hi) \<and> (\<^bsup>\<sigma>\<^esup>hi \<le> length \<acute>a)\<rbrace>
            DO CALL count_run_and_make_ascending(\<acute>a, \<acute>lo, \<acute>hi ,\<acute>run_len_i, \<acute>a);;
               IF \<acute>run_len_i < \<acute>min_run
               THEN IF \<acute>n_remaining \<le> \<acute>min_run
                    THEN \<acute>force :== \<acute>n_remaining
                    ELSE \<acute>force :== \<acute>min_run FI;;
                 \<acute>a :== CALL binary_sort(\<acute>a, \<acute>lo, \<acute>lo+\<acute>force, \<acute>lo+\<acute>run_len_i);;
                 \<acute>run_len_i :== \<acute>force
               FI;;
               CALL push_run(\<acute>lo,\<acute>run_len_i);;
               CALL merge_collapse();; \<acute>lo :== \<acute>lo + \<acute>run_len_i;;
               \<acute>n_remaining :== \<acute>n_remaining - \<acute>run_len_i
            OD;;
            CALL merge_force_collapse();;
            \<acute>ret :== \<acute>a
            CATCH Skip END" in HoarePartial.annotateI)
  apply vcg
    apply (simp_all only:invariant_def)
    apply clarsimp
    apply (rule conjI)
  using add.commute apply auto[1]
    apply (simp add:elem_larger_than_bound_def)
    apply (intro conjI impI)
       apply (intro allI)
       apply clarsimp
     apply (intro conjI impI)
            apply fastforce
           apply fastforce
          apply fastforce
         apply fastforce
        apply (clarsimp)
        apply (rule conjI)
         apply (clarsimp)+
       apply fastforce
      apply fastforce
     apply clarsimp
     apply (rule conjI)
      apply (clarsimp)+
    apply (intro conjI impI)
          apply fastforce
         apply fastforce
        apply fastforce
       apply clarsimp
       apply (rule conjI)
        apply clarsimp
       apply clarsimp
      apply fastforce
     apply fastforce
    apply clarsimp
    apply (rule conjI)
     apply clarsimp
    apply clarsimp

(* finish p \<longrightarrow> inv *)
   apply clarify
   apply simp
   apply (intro conjI impI)
       apply clarsimp
      apply (simp add:elem_inv_def)+
    apply (simp add:elem_larger_than_bound_def)
   apply (intro allI)
   apply clarsimp
   apply (intro conjI impI)
          apply clarsimp
  using run_len_iter apply (metis One_nat_def add.commute)
        apply clarsimp
        apply (intro conjI impI)
          apply (simp add:elem_inv_def elem_larger_than_bound_def elem_bigger_than_next_2_def)
          apply (simp add:elem_bigger_than_next_def)
         apply force
  using sumn_equal apply presburger
       apply clarsimp
  using run_len_iter apply (metis One_nat_def add.commute)
     apply clarsimp
     apply (intro conjI impI)
       apply (simp add:elem_inv_def elem_larger_than_bound_def elem_bigger_than_next_2_def)
       apply (simp add:elem_bigger_than_next_def)
      apply force
  using sumn_equal apply presburger
  using run_len_iter  apply (metis One_nat_def add.commute)
  apply clarsimp
   apply (intro conjI impI)
     apply (simp add:elem_inv_def elem_larger_than_bound_def elem_bigger_than_next_2_def)
     apply (simp add:elem_bigger_than_next_def)
    apply force
  using sumn_equal apply presburger
   apply (simp only:elem_larger_than_bound_def)
(* finish {inv} c {inv} *)
  apply (intro conjI impI)
     apply (simp_all add:elem_larger_than_bound_def elem_inv_def elem_bigger_than_next_2_def elem_bigger_than_next_def)
  apply (subgoal_tac "length a \<noteq> 0")
   apply clarsimp
  apply clarsimp
  apply (case_tac "stack_size")
   apply clarify
  using sumn.simps apply clarsimp
  done

end


(*  Title:      HOL/UNITY/Simple/Deadlock.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Deadlock examples from section 5.6 of
    Misra, "A Logic for Concurrent Programming", 1994
*)

theory Deadlock imports "../UNITY" begin

(*Trivial, two-process case*)
lemma "[| F \<in> (A \<inter> B) co A;  F \<in> (B \<inter> A) co B |] ==> F \<in> stable (A \<inter> B)"
  unfolding constrains_def stable_def by blast

(*a simplification step*)
lemma Collect_le_Int_equals:
     "(\<Inter>i \<in> atMost n. A(Suc i) \<inter> A i) = (\<Inter>i \<in> atMost (Suc n). A i)"
  by (induct n) (auto simp add: atMost_Suc)

(*Dual of the required property.  Converse inclusion fails.*)
lemma UN_Int_Compl_subset:
     "(\<Union>i \<in> lessThan n. A i) \<inter> (- A n) \<subseteq>
      (\<Union>i \<in> lessThan n. (A i) \<inter> (- A (Suc i)))"
  by (induct n) (auto simp: lessThan_Suc)

(*Converse inclusion fails.*)
lemma INT_Un_Compl_subset:
     "(\<Inter>i \<in> lessThan n. -A i \<union> A (Suc i))  \<subseteq>
      (\<Inter>i \<in> lessThan n. -A i) \<union> A n"
  by (induct n) (auto simp: lessThan_Suc)

(*Specialized rewriting*)
lemma INT_le_equals_Int_lemma:
     "A 0 \<inter> (-(A n) \<inter> (\<Inter>i \<in> lessThan n. -A i \<union> A (Suc i))) = {}"
by (blast intro: gr0I dest: INT_Un_Compl_subset [THEN subsetD])

(*Reverse direction makes it harder to invoke the ind hyp*)
lemma INT_le_equals_Int:
     "(\<Inter>i \<in> atMost n. A i) =
      A 0 \<inter> (\<Inter>i \<in> lessThan n. -A i \<union> A(Suc i))"
  by (induct n)
    (simp_all add: Int_ac Int_Un_distrib Int_Un_distrib2
      INT_le_equals_Int_lemma lessThan_Suc atMost_Suc)

lemma INT_le_Suc_equals_Int:
     "(\<Inter>i \<in> atMost (Suc n). A i) =
      A 0 \<inter> (\<Inter>i \<in> atMost n. -A i \<union> A(Suc i))"
by (simp add: lessThan_Suc_atMost INT_le_equals_Int)

(*The final deadlock example*)
lemma
  assumes zeroprem: "F \<in> (A 0 \<inter> A (Suc n)) co (A 0)"
      and allprem:
            "!!i. i \<in> atMost n ==> F \<in> (A(Suc i) \<inter> A i) co (-A i \<union> A(Suc i))"
  shows "F \<in> stable (\<Inter>i \<in> atMost (Suc n). A i)"
apply (unfold stable_def)
apply (rule constrains_Int [THEN constrains_weaken])
   apply (rule zeroprem)
  apply (rule constrains_INT)
  apply (erule allprem)
 apply (simp add: Collect_le_Int_equals Int_assoc INT_absorb)
apply (simp add: INT_le_Suc_equals_Int)
done

end


theory T59
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


theory ALCdemo  imports Main begin
typedecl i
type_synonym \<tau> = "(i\<Rightarrow>bool)"
type_synonym \<sigma> = "(i\<Rightarrow>i\<Rightarrow>bool)"

(* Standard Description Logic ALC: Syntax und Semantic *)
abbreviation empty_concept ("\<bottom>") where
  "\<bottom> \<equiv> \<lambda>x. False"
abbreviation universal_concept ("\<top>") where
  "\<top> \<equiv> \<lambda>x. True"
abbreviation negation ("\<sim>") where
  "\<sim>A \<equiv> \<lambda>x. \<not>A(x)"
abbreviation disjunction (infixr "\<squnion>" 40) where
  "A \<squnion> B \<equiv> \<lambda>x. A(x) \<or> B(x)"
abbreviation conjunction (infixr "\<sqinter>" 41) where
  "A \<sqinter> B \<equiv> \<lambda>x. A(x) \<and> B(x)"
abbreviation existential_role_restriction ("\<exists>") where
  "\<exists>r A \<equiv> \<lambda>x.\<exists>y. r x y \<and> A(y)"
abbreviation universal_role_restriction ("\<forall>") where
  "\<forall>r A \<equiv> \<lambda>x.\<forall>y. r x y \<longrightarrow> A(y)"

abbreviation subsumtion  (infixr "\<sqsubseteq>" 39) where
  "A\<sqsubseteq>B \<equiv> \<forall>x. A(x) \<longrightarrow> B(x)"
abbreviation equality (infixr "\<doteq>" 38) where
  "A \<doteq> B \<equiv> A \<sqsubseteq> B \<and> B \<sqsubseteq> A"

(* ALC: Simple Meta-Theory Examples *)
 lemma L1: "\<top> \<doteq> \<sim>\<bottom>"                      by metis
 lemma L2: "A\<sqinter>B \<doteq> \<sim>(\<sim>A\<squnion>\<sim>B)"              by metis
 lemma L3: "\<exists>r C \<doteq> \<sim>(\<forall>r (\<sim>C))"            by auto
 lemma L4: "(A \<sqsubseteq> B) \<equiv> \<exists>X.(A \<doteq> (X \<sqinter> B))"   sledgehammer  oops
 lemma L5: "(A \<sqsubseteq> B) \<equiv> ((A \<sqinter> \<sim>B) \<doteq> \<bottom>)"    by auto

(* ALC: Example Signatur *)
 consts HappyMan::\<tau> Human::\<tau> Female::\<tau> Doctor::\<tau> Professor::\<tau>  (* Concepts *)
 consts married::\<sigma> hasChild::\<sigma>                                (* Roles *)
 consts BOB::i MARY::i                                        (* Individuals *)
 axiomatization where diff1: "BOB \<noteq> MARY"

(* ALC: Simple TBox Example *)
 axiomatization where
  tbox1: "HappyMan \<doteq> (Human \<sqinter> \<sim>Female \<sqinter> (\<exists>married Doctor) \<sqinter> (\<forall>hasChild (Doctor \<squnion> Professor)))" and
  tbox2: "Doctor \<sqsubseteq> Human" and
  tbox3: "Professor \<sqsubseteq> Human"

(* ALC: Example Queries *)
 lemma "HappyMan \<sqsubseteq> \<exists>married Human" using tbox1 tbox2 by blast
 lemma "\<exists>married Human \<sqsubseteq> HappyMan" nitpick [user_axioms,show_all,format=2,atoms=BOB MARY] oops

(* ALC: Simple ABox Example *)
 axiomatization where
  abox1: "HappyMan BOB" and
  abox2: "hasChild BOB MARY" and
  abox3: "\<not> Doctor MARY"

(* ALC: Example Queries *)
 lemma "(\<exists>married Human) BOB" using abox1 tbox1 tbox2 by blast
 lemma "(\<exists>married Human) a" nitpick [satisfy,user_axioms,show_all,format=2,atoms=BOB MARY] oops
 lemma "HappyMan a" nitpick [satisfy,user_axioms,show_all,format=2,atoms=BOB MARY] oops

(* ALC: Soundness of ALC-Tableaurules *)
lemma "(A \<sqinter> B)(x) \<longrightarrow> (A(x) \<and> B(x))"       by metis
lemma "(A \<squnion> B)(x) \<longrightarrow> (A(x) \<or> B(x))"       by metis
lemma "(\<exists>r A)(x) \<longrightarrow> (\<exists>b. r x b \<and> A(b))"   by metis
lemma "((\<forall>r A)(x) \<and> r x y) \<longrightarrow> A(y)"       by (metis (hide_lams, mono_tags))
lemma "(A(x) \<and> \<sim>A(x)) \<longrightarrow> False"           by metis

(* Propositional Multimodal Logik K *)
 abbreviation mfalse ("\<^bold>\<bottom>") where
  "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
 abbreviation mtrue ("\<^bold>\<top>") where
  "\<^bold>\<top> \<equiv> \<lambda>w. True"
 abbreviation mnot ("\<^bold>\<not>") where
  "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
 abbreviation mand (infixr "\<^bold>\<and>" 51) where
  "\<phi> \<^bold>\<and> \<psi> \<equiv> \<lambda>w. \<phi>(w) \<and> \<psi>(w)"
 abbreviation mor (infixr "\<^bold>\<or>" 50) where
  "\<phi> \<^bold>\<or> \<psi> \<equiv> \<lambda>w. \<phi>(w) \<or> \<psi>(w)"
 abbreviation mbox ("\<^bold>\<box>") where
  "\<^bold>\<box>r \<phi> \<equiv> \<lambda>w.\<forall>v. r w v \<longrightarrow> \<phi>(v)"
 abbreviation mdia ("\<^bold>\<diamond>") where
  "\<^bold>\<diamond>r \<phi> \<equiv> \<lambda>w.\<exists>v. r w v \<and> \<phi>(v)"

 abbreviation valid :: "\<tau> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>") where   "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"

(* Description Logic ALC is a reinvention of Propositional Multimodal Logic K *)

lemma "\<top> = \<^bold>\<top>"              by metis
lemma "\<bottom> = \<^bold>\<bottom>"              by metis
lemma "(A \<sqinter> B) = (A \<^bold>\<and> B)"  by metis
lemma "(A \<squnion> B) = (A \<^bold>\<or> B)"  by metis
lemma "(\<forall>r A) = (\<^bold>\<box>r A)"    by auto
lemma "(\<exists>r A) = (\<^bold>\<diamond>r A)"    by simp

(* Description Logic ALCQI as extension of ALC *)

abbreviation cardinality_restriction_leq ("\<le>") where
  "\<le>n r A \<equiv> \<lambda>x. card({y. r x y \<longrightarrow> A(y)}) \<le> n"
abbreviation cardinality_restriction_geq ("\<ge>") where
  "\<ge>n r A \<equiv> \<lambda>x. card({y. r x y \<longrightarrow> A(y)}) \<ge> n"
abbreviation cardinality_restriction_eq ("=") where
  "=n r A \<equiv> (\<ge>n r A) \<sqinter> (\<le>n r A) "

lemma "(\<ge>1 married Human) a" nitpick [satisfy,user_axioms,show_all,format=2] oops (*model*)
lemma "(\<ge>1 married Human) a" nitpick [user_axioms,show_all,format=2] oops (*ctm*)
lemma "(\<ge>1 married H) a" nitpick[satisfy,user_axioms,show_all,format=2] oops
lemma "(=0 married Human) a" nitpick [satisfy,user_axioms,show_all,format=2] oops (*model*)

(*
(* A small example first-order predicate logic *)
consts
  Peter::i Ben::i Sue::i
  likes::"(i\<Rightarrow>i\<Rightarrow>bool)" loves::"(i\<Rightarrow>i\<Rightarrow>bool)"

axiomatization where A0: "Peter \<noteq> Ben  \<and> Peter \<noteq> Sue \<and> Ben \<noteq> Sue"

axiomatization where
  A1: "\<forall>x. likes Peter x \<longrightarrow> likes Ben x" and
  A2: "\<forall>x y. loves x y \<longrightarrow> likes x y" and
  A3: "loves Peter Sue"

lemma "\<exists>x. likes Ben x" sledgehammer
  nitpick [satisfy,user_axioms,show_all,format=2,card=3,atoms=Sue Ben Peter] oops

lemma "\<exists>x. loves Ben x" sledgehammer
  nitpick [user_axioms,show_all,format=2,card=3,atoms=Ben Peter Sue] oops
*)

consts state::bool

lemma "(\<lambda>f x. f x) (\<lambda>x. x) state"

(*
Interpretation of a (tau-program) is an conditional polynomial.

We are thus interpreting (tau-program) over the set of all conditional polynomials.
That leaves us with the question What are conditional ploynomials?

A polynomial is a finite expression involving addition and multiplication of
variables and ring elements.

A conditional polynomial is a finite expression involving addition and multiplication and
the floor-function of variables and ring elements.

The floor function f(x) = 0 if and only if x = 0, and 1 otherwise.

f(x) = x or (not-allowed-)

we choose the ring ...

g of variables (also called
indeterminates) and coefficients, that involves only the operations of addition,
subtraction, multiplication, and non-negative integer exponentiation of variables.
An example of a polynomial of a single indeterminate x is x2 − 4x + 7.
An example in three variables is x3 + 2xyz2 − yz + 1.

Corrections:
We can translate/compile each (tau-program) into an conditional polynomial.

*)
end


theory ex_2_9
  imports Main ex_2_2
begin
fun itadd::"nat \<Rightarrow> nat \<Rightarrow> nat" where
"itadd 0 y = y" |
"itadd (Suc x) y = itadd x (Suc y)"

theorem itadd_equiv: "itadd m n = add m n"
  apply (induction m arbitrary:n)
  by (auto)
end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_86
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun elem :: "Nat => Nat list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = (if x y z2 then True else elem y xs)"

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

fun ins :: "Nat => Nat list => Nat list" where
  "ins y (nil2) = cons2 y (nil2)"
| "ins y (cons2 z2 xs) =
     (if t2 y z2 then cons2 y (cons2 z2 xs) else cons2 z2 (ins y xs))"

theorem property0 :
  "((t2 y z) ==> ((elem y (ins z xs)) = (elem y xs)))"
  oops

end


section\<open>Attic\<close>
theory attic
imports Main "Lib/FiniteGraph"
begin

text\<open>old lemma, mainly unused.\<close>

lemma exists_x1x2_x1notoffending_natLeq:
  fixes
    G::"'v graph" and
    f and
    p::"'v \<Rightarrow> nat"
  assumes
    "wf_graph G"
    "\<exists>(e1, e2)\<in>(edges G). \<not> (p e1 \<le> p e2)" and
    "f \<subseteq> edges G \<and> (\<forall>(e1, e2)\<in>f. \<not> p e1 \<le> p e2)" and
    "\<forall>(e1, e2)\<in>(edges G) - f. p e1 \<le> p e2"
  shows "\<exists> x1 x2. (x1,x2)\<in>(edges G) \<and> (x1,x2)\<in> f \<and> x1 \<in> fst ` f \<and> x1 \<notin> snd ` f \<and> ((p x1) = Max (p`fst` f))"
proof -
   from assms have a2: "\<exists>x\<in>(edges G). \<not> (case x of (e1, e2) \<Rightarrow> p e1 \<le> p e2)" by auto
   from assms have a3: "f \<subseteq>(edges G) \<and> (\<forall>(e1, e2)\<in>f. \<not> p e1 \<le> p e2)" by simp
   from assms have a4: "\<forall>(e1, e2)\<in>(edges G) - f. p e1 \<le> p e2" by simp
   from assms(1) have finiteE: "finite (edges G)" using wf_graph.finiteE by fast
   from finiteE conjunct1[OF a3] have  finiteF: "finite f" by (metis rev_finite_subset)

   \<comment> \<open>Find a suitable x1, it is the Max of the firsts\<close>
   from finiteF have x12: "\<forall> x \<in> f. Max (p`fst` f) \<ge> p (fst x)" by (metis Max_ge finite_imageI image_eqI)
   from a2 a4 have x14: "\<exists> x1. (p x1) \<in> p`fst` f \<and> x1 \<in> fst` f" by fast
   from finiteF have "(p`fst` f) \<noteq> {} \<Longrightarrow> Max (p`fst` f) \<in> (p`fst` f)" by simp
   hence x15: "Max (p`fst` f) \<in> (p`fst` f)" using x14 by fastforce
   hence "\<exists> x1. ((p x1) = Max (p`fst` f)) \<and> x1 \<in> fst` f" by force
   from this x14 obtain x1 where x1Cond: "((p x1) = Max (p`fst` f)) \<and> x1 \<in> fst` f" by blast

   \<comment> \<open>Thus x1 is not in the seconds, not offending\<close>
   from x1Cond x15 have x1ImportantProp3: "(p x1) \<in> p`fst` f" by presburger
   from x1Cond conjunct2[OF a3] x12 have "\<forall>(e1, e2) \<in> f. p x1 > p e2" by fastforce

   from x1Cond this a2 a3 a4 have x1ImportantProp1: "(p x1) \<notin> p`snd` f" by force
   hence x1ImportantProp2: "x1 \<notin> snd` f" by blast

   \<comment> \<open>Obtain x2\<close>
   from x1ImportantProp3 x1Cond have x1ImportantProp4: "x1 \<in> fst` f" by presburger
   from this x1ImportantProp2 have  "\<exists> x1 x2. (x1,x2) \<in> f \<and> x1 \<notin> snd` f" by fastforce
   from this x1Cond x1ImportantProp2 obtain x2 where x2Cond:"(x1,x2) \<in> f \<and> x1 \<notin> snd` f" by force

   from a3 have "\<And> x. x \<in> f \<Longrightarrow> x \<in> (edges G)" by blast
   from this x2Cond have x1x2Cond: "(x1,x2) \<in> (edges G)" by blast

   from x1x2Cond x2Cond x1Cond show ?thesis by auto
qed

lemma exCasePairSimp: "(\<exists>x. x \<in> A \<and> (case x of (e1, e2) \<Rightarrow> P e1 e2)) = (\<exists>(e1, e2) \<in> A. (P e1 e2))"
  by auto

lemma exCasePairNotSimp: "(\<exists>x. x \<in> A \<and> \<not> (case x of (e1, e2) \<Rightarrow> P e1 e2)) = (\<exists>(e1, e2) \<in> A. \<not> (P e1 e2))"
  by auto

(* moved here from FiniteGraph.thy. Currently unused *)
subsection \<open>Paths\<close>
  text \<open>A path is represented by a list of adjacent edges.\<close>
  type_synonym 'v path = "('v \<times> 'v) list"

  context wf_graph
  begin
    text \<open>The following predicate describes a valid path:\<close>
    (* is-path src [src, ...., dst] dst *)
    fun is_path :: "'v \<Rightarrow> 'v path \<Rightarrow> 'v \<Rightarrow> bool" where
      "is_path v [] v' \<longleftrightarrow> v=v' \<and> v'\<in>V" |
      "is_path v ((v1,v2)#p) v' \<longleftrightarrow> v=v1 \<and> (v1,v2)\<in>E \<and> is_path v2 p v'"

    lemma is_path_simps[simp, intro!]:
      "is_path v [] v \<longleftrightarrow> v\<in>V"
      "is_path v [(v,v')] v' \<longleftrightarrow> (v,v')\<in>E"
      by (auto dest: E_wfD)

    lemma is_path_memb[simp]:
      "is_path v p v' \<Longrightarrow> v\<in>V \<and> v'\<in>V"
      apply (induction p arbitrary: v)
       apply (auto dest: E_wfD)
      done

    lemma is_path_split:
      "is_path v (p1@p2) v' \<longleftrightarrow> (\<exists>u. is_path v p1 u \<and> is_path u p2 v')"
      by (induct p1 arbitrary: v) auto

    lemma is_path_split'[simp]:
      "is_path v (p1@(u,u')#p2) v'
        \<longleftrightarrow> is_path v p1 u \<and> (u,u')\<in>E \<and> is_path u' p2 v'"
      by (auto simp add: is_path_split)
  end

  text \<open>Set of intermediate vertices of a path. These are all vertices but
    the last one. Note that, if the last vertex also occurs earlier on the path,
    it is contained in \<open>int_vertices\<close>.\<close>
  definition int_vertices :: "'v path \<Rightarrow> 'v set" where
    "int_vertices p \<equiv> set (map fst p)"

  lemma int_vertices_simps[simp]:
    "int_vertices [] = {}"
    "int_vertices (vv#p) = insert (fst vv) (int_vertices p)"
    "int_vertices (p1@p2) = int_vertices p1 \<union> int_vertices p2"
    by (auto simp add: int_vertices_def)

  lemma (in wf_graph) int_vertices_subset:
    "is_path v p v' \<Longrightarrow> int_vertices p \<subseteq> V"
    apply (induct p arbitrary: v)
     apply (simp)
    apply (force dest: E_wfD)
    done

  lemma int_vertices_empty[simp]: "int_vertices p = {} \<longleftrightarrow> p=[]"
    by (cases p) auto

subsubsection \<open>Splitting Paths\<close>
  text \<open>Split a path at the point where it first leaves the set \<open>W\<close>:\<close>
  lemma (in wf_graph) path_split_set:
    assumes "is_path v p v'" and "v\<in>W" and "v'\<notin>W"
    obtains p1 p2 u w u' where
    "p=p1@(u,u')#p2" and
    "int_vertices p1 \<subseteq> W" and "u\<in>W" and "u'\<notin>W"
    using assms
  proof (induct p arbitrary: v thesis)
    case Nil thus ?case by auto
  next
    case (Cons vv p)
    note [simp, intro!] = \<open>v\<in>W\<close> \<open>v'\<notin>W\<close>
    from Cons.prems obtain u' where
      [simp]: "vv=(v,u')" and
        REST: "is_path u' p v'"
      by (cases vv) auto

    txt \<open>Distinguish wether the second node \<open>u'\<close> of the path is
      in \<open>W\<close>. If yes, the proposition follows by the
      induction hypothesis, otherwise it is straightforward, as
      the split takes place at the first edge of the path.\<close>
    {
      assume A [simp, intro!]: "u'\<in>W"
      from Cons.hyps[OF _ REST] obtain p1 uu uu' p2 where
        "p=p1@(uu,uu')#p2" "int_vertices p1 \<subseteq> W" "uu \<in> W" "uu' \<notin> W"
        by blast
      with Cons.prems(1)[of "vv#p1" uu uu' p2] have thesis by auto
    } moreover {
      assume "u'\<notin>W"
      with Cons.prems(1)[of "[]" v u' p] have thesis by auto
    } ultimately show thesis by blast
  qed

  text \<open>Split a path at the point where it first enters the set \<open>W\<close>:\<close>

  text \<open>Split a path at the point where a given vertex is first visited:\<close>
  lemma (in wf_graph) path_split_vertex:
    assumes "is_path v p v'" and "u\<in>int_vertices p"
    obtains p1 p2 where
    "p=p1@p2" and
    "is_path v p1 u" and
    "u \<notin> int_vertices p1"
    using assms
  proof (induct p arbitrary: v thesis)
    case Nil thus ?case by auto
  next
    case (Cons vv p)
    from Cons.prems obtain u' where
      [simp]: "vv=(v,u')" "v\<in>V" "(v,u')\<in>E" and
        REST: "is_path u' p v'"
      by (cases vv) auto

    {
      assume "u=v"
      with Cons.prems(1)[of "[]" "vv#p"] have thesis by auto
    } moreover {
      assume [simp]: "u\<noteq>v"
      with Cons.hyps(1)[OF _ REST] Cons.prems(3) obtain p1 p2 where
        "p=p1@p2" "is_path u' p1 u" "u\<notin>int_vertices p1"
        by auto
      with Cons.prems(1)[of "vv#p1" p2] have thesis
        by auto
    } ultimately show ?case by blast
  qed

end


section \<open>Catalan numbers\<close>

theory Catalan_Auxiliary_Integral
imports "HOL-Analysis.Equivalence_Lebesgue_Henstock_Integration"
begin

subsection \<open>Auxiliary integral\<close>

text \<open>
  First, we will prove the integral $$\int\limits_0^4 \sqrt{\frac{4-x}{x}}\,\textrm{d}x = 2\pi$$
  which occurs in the proof for the integral formula for the Catalan numbers.
\<close>

context
begin

text \<open>
  First of all, we prove two limits that we will require.
\<close>
private lemma limit1: "filterlim (\<lambda>x::real. sqrt (4/x - 1) / (x - 4)) at_bot (at_left 4)"
proof (rule lhopital_left)
  show "((\<lambda>x::real. sqrt (4 / x - 1)) \<longlongrightarrow> 0) (at_left 4)"
    by (force intro: tendsto_eq_intros)
  show "((\<lambda>x::real. x - 4) \<longlongrightarrow> 0) (at_left 4)"
    by (force intro: tendsto_eq_intros)
  show "\<forall>\<^sub>F x in at_left 4. ((\<lambda>x. x - 4) has_real_derivative 1) (at x)"
    by (intro always_eventually) (auto intro!: derivative_eq_intros)
  show "\<forall>\<^sub>F x in at_left 4. ((\<lambda>x. sqrt (4/x - 1)) has_real_derivative
          -2 / (sqrt (4/x - 1) * x^2)) (at x)"
    by (intro eventually_at_leftI[of 0])
       (auto intro!: derivative_eq_intros simp: field_simps power2_eq_square)

  have *: "((\<lambda>x::real. sqrt (4 / x - 1) * x\<^sup>2) \<longlongrightarrow> 0) (at_left 4)"
    by (force intro!: tendsto_eq_intros)
  have "filterlim (\<lambda>x. - (2 / (sqrt (4 / x - 1) * x\<^sup>2))) at_bot (at_left 4)"
    unfolding filterlim_uminus_at_top [symmetric]
    by (rule LIM_at_top_divide tendsto_const eventually_at_leftI[of 0] * | simp)+
  thus "filterlim (\<lambda>x::real. - 2 / (sqrt (4 / x - 1) * x\<^sup>2) / 1) at_bot (at_left 4)" by simp
qed (auto intro: eventually_at_leftI[of 0])

private lemma limit2: "((\<lambda>x. sqrt (4/x - 1) * x) \<longlongrightarrow> 0) (at_right 0)"
proof (rule Lim_transform_eventually)
  show "((\<lambda>x::real. sqrt ((4 - x) * x)) \<longlongrightarrow> 0) (at_right 0)"
    by (force intro: tendsto_eq_intros)
  show "\<forall>\<^sub>F x in at_right 0. sqrt ((4 - x) * x) = sqrt (4 / x - 1) * x"
  proof (rule eventually_at_rightI)
    fix x :: real assume x: "x \<in> {0<..<1}"
    from x have "(4 - x) * x = (4/x - 1) * x^2" by (simp add: field_simps power2_eq_square)
    also from x have "sqrt \<dots> = sqrt (4/x - 1) * x" by (subst real_sqrt_mult) simp_all
    finally show "sqrt ((4 - x) * x) = sqrt (4/x - 1) * x" .
  qed simp_all
qed

text \<open>
  Now we prove the integral by explicitly constructing the indefinite integral.
\<close>
lemma catalan_aux_integral:
  "((\<lambda>x::real. sqrt ((4 - x) / x)) has_integral 2 * pi) {0..4}"
proof -
  define F where "F \<equiv> \<lambda>x. sqrt (4/x - 1) * x - 2 * arctan ((sqrt (4/x - 1) * (x - 2)) / (x - 4))"
    \<comment> \<open>The nice part of the indefinite integral. The endpoints are removable singularities.\<close>

  define G where "G \<equiv> \<lambda>x. if x = 4 then pi else if x = 0 then -pi else F x"
    \<comment> \<open>The actual indefinite integral including the endpoints.\<close>

  \<comment> \<open>We now prove that the indefinite integral indeed tends to @{term "pi"} resp. @{term "-pi"}
      at the edges of the integration interval.\<close>
  have "filterlim (\<lambda>x. (x - 2) / (x - 4) * sqrt (-1 + 4/x)) at_top (at_right 0)"
    by (rule filterlim_tendsto_pos_mult_at_top tendsto_intros filterlim_tendsto_add_at_top
          filterlim_compose[OF sqrt_at_top] LIM_at_top_divide eventually_at_rightI[of 0 1] | simp)+
  hence *: "filterlim (\<lambda>x. (sqrt (4/x - 1) * (x - 2)) / (x - 4)) at_top (at_right 0)"
    by (simp add: field_simps)
  have "(F \<longlongrightarrow> 0 - 2 * (pi/2)) (at_right 0)" unfolding F_def
    by (intro tendsto_intros limit2 filterlim_compose[OF tendsto_arctan_at_top] *)
  hence "(F \<longlongrightarrow> -pi) (at_right 0)" by simp
  hence G_0: "(G \<longlongrightarrow> -pi) (at_right 0)" unfolding G_def
    by (rule Lim_transform_eventually) (auto intro!: eventually_at_rightI[of 0 1])

  have *: "((\<lambda>x. sqrt (4 / x - 1) * x) \<longlongrightarrow> 0) (at_left 4)"
    by (force intro: tendsto_eq_intros)
  have "filterlim (\<lambda>x. (x - 2) * (sqrt (4 / x - 1) / (x - 4))) at_bot (at_left 4)"
    by (rule filterlim_tendsto_pos_mult_at_bot tendsto_intros limit1 | simp)+
  hence **: "LIM x at_left 4. sqrt (4 / x - 1) * (x - 2) / (x - 4) :> at_bot"
    by (simp add: mult_ac)
  have "(F \<longlongrightarrow> 0 - 2 * -(pi/2)) (at_left 4)" unfolding F_def
    by (intro tendsto_intros * ** filterlim_compose[OF tendsto_arctan_at_bot])
  hence "(F \<longlongrightarrow> pi) (at_left 4)" by simp
  hence G_4: "(G \<longlongrightarrow> pi) (at_left 4)" unfolding G_def
    by (rule Lim_transform_eventually) (auto intro!: eventually_at_leftI[of 1])

  \<comment> \<open>The derivative of @{term G} is indeed the integrand in the interior of
      the integration interval.\<close>
  have deriv_G: "(G has_field_derivative sqrt ((4 - x) / x)) (at x)" if x: "x \<in> {0<..<4}" for x
  proof -
    from x have "eventually (\<lambda>y. y \<in> {0<..<4}) (nhds x)"
      by (intro eventually_nhds_in_open) simp_all
    hence eq: "eventually (\<lambda>x. F x = G x) (nhds x)" by eventually_elim (simp add: G_def)

    define T where "T \<equiv> \<lambda>x::real. 4 / (sqrt (4/x - 1) * (x - 4) * x^2)"
    have *: "((\<lambda>x. (sqrt (4/x - 1) * (x - 2)) / (x - 4)) has_field_derivative T x) (at x)"
      by (insert x, rule derivative_eq_intros refl | simp)+
         (simp add: divide_simps T_def, simp add: field_simps power2_eq_square)
    have "((\<lambda>x. 2 * arctan ((sqrt (4/x - 1) * (x - 2)) / (x - 4))) has_field_derivative
             2 * T x / (1 + (sqrt (4 / x - 1) * (x - 2) / (x - 4))\<^sup>2)) (at x)"
      by (rule * derivative_eq_intros refl | simp)+ (simp add: field_simps)
    also from x have "(sqrt (4 / x - 1) * (x - 2) / (x - 4))\<^sup>2 = (4/x - 1) * (x-2)^2 / (x - 4)^2"
      by (simp add: power_mult_distrib power_divide)
    also from x have "1 + \<dots> = -4 / ((x - 4) * x)"
      by (simp add: divide_simps power2_eq_square mult_ac) (simp add: algebra_simps)?
    also from x have "2 * T x / \<dots> = - (2 / (x * sqrt (4 / x - 1)))"
      by (simp add: T_def power2_eq_square)
    finally have *: "((\<lambda>x. 2 * arctan (sqrt (4 / x - 1) * (x - 2) / (x - 4))) has_real_derivative
                        - (2 / (x * sqrt (4 / x - 1)))) (at x)" .
    have "(F has_field_derivative sqrt (4 / x - 1)) (at x)" unfolding F_def
      by (insert x, (rule * derivative_eq_intros refl | simp)+) (simp add: field_simps)
    thus ?thesis by (subst (asm) DERIV_cong_ev[OF refl eq refl]) (insert x, simp add: field_simps)
  qed

  \<comment> \<open>It is now obvious that @{term G} is continuous over the entire integration interval.\<close>
  have cont_G: "continuous_on {0..4} G" unfolding continuous_on
  proof safe
    fix x :: real assume "x \<in> {0..4}"
    then consider "x = 0" | "x = 4" | "x \<in> {0<..<4}" by force
    thus "(G \<longlongrightarrow> G x) (at x within {0..4})"
    proof cases
      assume "x = 0"
      have *: "at (0::real) within {0..4} \<le> at_right 0" unfolding at_within_def
        by (rule inf_mono) auto
      from G_0 have "(G \<longlongrightarrow> -pi) (at x within {0..4})"
        by (rule filterlim_mono) (simp_all add: * \<open>x = 0\<close>)
      also have "-pi = G x" by (simp add: G_def \<open>x = 0\<close>)
      finally show ?thesis .
    next
      assume "x = 4"
      have *: "at (4::real) within {0..4} \<le> at_left 4" unfolding at_within_def
        by (rule inf_mono) auto
      from G_4 have "(G \<longlongrightarrow> pi) (at x within {0..4})"
        by (rule filterlim_mono) (simp_all add: * \<open>x = 4\<close>)
      also have "pi = G x" by (simp add: G_def \<open>x = 4\<close>)
      finally show ?thesis .
    next
      assume "x \<in> {0<..<4}"
      from deriv_G[OF this] have "isCont G x" by (rule DERIV_isCont)
      thus ?thesis unfolding isCont_def by (rule filterlim_mono) (auto simp: at_le)
    qed
  qed

  \<comment> \<open>Finally, we can apply the Fundamental Theorem of Calculus.\<close>
  have "((\<lambda>x. sqrt ((4 - x) / x)) has_integral G 4 - G 0) {0..4}"
    using cont_G deriv_G
    by (intro fundamental_theorem_of_calculus_interior)
       (auto simp: has_field_derivative_iff_has_vector_derivative)
  also have "G 4 - G 0 = 2 * pi" by (simp add: G_def)
  finally show ?thesis .
qed

end

end


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

section{*Star-Transforms in Non-Standard Analysis*}

theory Star
imports NSA
begin

definition
    (* internal sets *)
  starset_n :: "(nat => 'a set) => 'a star set" ("*sn* _" [80] 80) where
  "*sn* As = Iset (star_n As)"

definition
  InternalSets :: "'a star set set" where
  "InternalSets = {X. \<exists>As. X = *sn* As}"

definition
  (* nonstandard extension of function *)
  is_starext  :: "['a star => 'a star, 'a => 'a] => bool" where
  "is_starext F f = (\<forall>x y. \<exists>X \<in> Rep_star(x). \<exists>Y \<in> Rep_star(y).
                        ((y = (F x)) = ({n. Y n = f(X n)} : FreeUltrafilterNat)))"

definition
  (* internal functions *)
  starfun_n :: "(nat => ('a => 'b)) => 'a star => 'b star"   ("*fn* _" [80] 80) where
  "*fn* F = Ifun (star_n F)"

definition
  InternalFuns :: "('a star => 'b star) set" where
  "InternalFuns = {X. \<exists>F. X = *fn* F}"

(*--------------------------------------------------------
   Preamble - Pulling "EX" over "ALL"
 ---------------------------------------------------------*)

(* This proof does not need AC and was suggested by the
   referee for the JCM Paper: let f(x) be least y such
   that  Q(x,y)
*)
lemma no_choice: "\<forall>x. \<exists>y. Q x y ==> \<exists>(f :: 'a => nat). \<forall>x. Q x (f x)"
apply (rule_tac x = "%x. LEAST y. Q x y" in exI)
apply (blast intro: LeastI)
done

subsection{*Properties of the Star-transform Applied to Sets of Reals*}

lemma STAR_star_of_image_subset: "star_of ` A <= *s* A"
by auto

lemma STAR_hypreal_of_real_Int: "*s* X Int Reals = hypreal_of_real ` X"
by (auto simp add: SReal_def)

lemma STAR_star_of_Int: "*s* X Int Standard = star_of ` X"
by (auto simp add: Standard_def)

lemma lemma_not_hyprealA: "x \<notin> hypreal_of_real ` A ==> \<forall>y \<in> A. x \<noteq> hypreal_of_real y"
by auto

lemma lemma_not_starA: "x \<notin> star_of ` A ==> \<forall>y \<in> A. x \<noteq> star_of y"
by auto

lemma lemma_Compl_eq: "- {n. X n = xa} = {n. X n \<noteq> xa}"
by auto

lemma STAR_real_seq_to_hypreal:
    "\<forall>n. (X n) \<notin> M ==> star_n X \<notin> *s* M"
apply (unfold starset_def star_of_def)
apply (simp add: Iset_star_n)
done

lemma STAR_singleton: "*s* {x} = {star_of x}"
by simp

lemma STAR_not_mem: "x \<notin> F ==> star_of x \<notin> *s* F"
by transfer

lemma STAR_subset_closed: "[| x : *s* A; A <= B |] ==> x : *s* B"
by (erule rev_subsetD, simp)

text{*Nonstandard extension of a set (defined using a constant
   sequence) as a special case of an internal set*}

lemma starset_n_starset: "\<forall>n. (As n = A) ==> *sn* As = *s* A"
apply (drule fun_eq_iff [THEN iffD2])
apply (simp add: starset_n_def starset_def star_of_def)
done

(*----------------------------------------------------------------*)
(* Theorems about nonstandard extensions of functions             *)
(*----------------------------------------------------------------*)

(*----------------------------------------------------------------*)
(* Nonstandard extension of a function (defined using a           *)
(* constant sequence) as a special case of an internal function   *)
(*----------------------------------------------------------------*)

lemma starfun_n_starfun: "\<forall>n. (F n = f) ==> *fn* F = *f* f"
apply (drule fun_eq_iff [THEN iffD2])
apply (simp add: starfun_n_def starfun_def star_of_def)
done

(*
   Prove that abs for hypreal is a nonstandard extension of abs for real w/o
   use of congruence property (proved after this for general
   nonstandard extensions of real valued functions).

   Proof now Uses the ultrafilter tactic!
*)

lemma hrabs_is_starext_rabs: "is_starext abs abs"
apply (simp add: is_starext_def, safe)
apply (rule_tac x=x in star_cases)
apply (rule_tac x=y in star_cases)
apply (unfold star_n_def, auto)
apply (rule bexI, rule_tac [2] lemma_starrel_refl)
apply (rule bexI, rule_tac [2] lemma_starrel_refl)
apply (fold star_n_def)
apply (unfold star_abs_def starfun_def star_of_def)
apply (simp add: Ifun_star_n star_n_eq_iff)
done

text{*Nonstandard extension of functions*}

lemma starfun:
      "( *f* f) (star_n X) = star_n (%n. f (X n))"
by (rule starfun_star_n)

lemma starfun_if_eq:
     "!!w. w \<noteq> star_of x
       ==> ( *f* (\<lambda>z. if z = x then a else g z)) w = ( *f* g) w"
by (transfer, simp)

(*-------------------------------------------
  multiplication: ( *f) x ( *g) = *(f x g)
 ------------------------------------------*)
lemma starfun_mult: "!!x. ( *f* f) x * ( *f* g) x = ( *f* (%x. f x * g x)) x"
by (transfer, rule refl)
declare starfun_mult [symmetric, simp]

(*---------------------------------------
  addition: ( *f) + ( *g) = *(f + g)
 ---------------------------------------*)
lemma starfun_add: "!!x. ( *f* f) x + ( *f* g) x = ( *f* (%x. f x + g x)) x"
by (transfer, rule refl)
declare starfun_add [symmetric, simp]

(*--------------------------------------------
  subtraction: ( *f) + -( *g) = *(f + -g)
 -------------------------------------------*)
lemma starfun_minus: "!!x. - ( *f* f) x = ( *f* (%x. - f x)) x"
by (transfer, rule refl)
declare starfun_minus [symmetric, simp]

(*FIXME: delete*)
lemma starfun_add_minus: "!!x. ( *f* f) x + -( *f* g) x = ( *f* (%x. f x + -g x)) x"
by (transfer, rule refl)
declare starfun_add_minus [symmetric, simp]

lemma starfun_diff: "!!x. ( *f* f) x  - ( *f* g) x = ( *f* (%x. f x - g x)) x"
by (transfer, rule refl)
declare starfun_diff [symmetric, simp]

(*--------------------------------------
  composition: ( *f) o ( *g) = *(f o g)
 ---------------------------------------*)

lemma starfun_o2: "(%x. ( *f* f) (( *f* g) x)) = *f* (%x. f (g x))"
by (transfer, rule refl)

lemma starfun_o: "( *f* f) o ( *f* g) = ( *f* (f o g))"
by (transfer o_def, rule refl)

text{*NS extension of constant function*}
lemma starfun_const_fun [simp]: "!!x. ( *f* (%x. k)) x = star_of k"
by (transfer, rule refl)

text{*the NS extension of the identity function*}

lemma starfun_Id [simp]: "!!x. ( *f* (%x. x)) x = x"
by (transfer, rule refl)

(* this is trivial, given starfun_Id *)
lemma starfun_Idfun_approx:
  "x @= star_of a ==> ( *f* (%x. x)) x @= star_of a"
by (simp only: starfun_Id)

text{*The Star-function is a (nonstandard) extension of the function*}

lemma is_starext_starfun: "is_starext ( *f* f) f"
apply (simp add: is_starext_def, auto)
apply (rule_tac x = x in star_cases)
apply (rule_tac x = y in star_cases)
apply (auto intro!: bexI [OF _ Rep_star_star_n]
            simp add: starfun star_n_eq_iff)
done

text{*Any nonstandard extension is in fact the Star-function*}

lemma is_starfun_starext: "is_starext F f ==> F = *f* f"
apply (simp add: is_starext_def)
apply (rule ext)
apply (rule_tac x = x in star_cases)
apply (drule_tac x = x in spec)
apply (drule_tac x = "( *f* f) x" in spec)
apply (auto simp add: starfun_star_n)
apply (simp add: star_n_eq_iff [symmetric])
apply (simp add: starfun_star_n [of f, symmetric])
done

lemma is_starext_starfun_iff: "(is_starext F f) = (F = *f* f)"
by (blast intro: is_starfun_starext is_starext_starfun)

text{*extented function has same solution as its standard
   version for real arguments. i.e they are the same
   for all real arguments*}
lemma starfun_eq: "( *f* f) (star_of a) = star_of (f a)"
by (rule starfun_star_of)

lemma starfun_approx: "( *f* f) (star_of a) @= star_of (f a)"
by simp

(* useful for NS definition of derivatives *)
lemma starfun_lambda_cancel:
  "!!x'. ( *f* (%h. f (x + h))) x'  = ( *f* f) (star_of x + x')"
by (transfer, rule refl)

lemma starfun_lambda_cancel2:
  "( *f* (%h. f(g(x + h)))) x' = ( *f* (f o g)) (star_of x + x')"
by (unfold o_def, rule starfun_lambda_cancel)

lemma starfun_mult_HFinite_approx:
  fixes l m :: "'a::real_normed_algebra star"
  shows "[| ( *f* f) x @= l; ( *f* g) x @= m;
                  l: HFinite; m: HFinite
               |] ==>  ( *f* (%x. f x * g x)) x @= l * m"
apply (drule (3) approx_mult_HFinite)
apply (auto intro: approx_HFinite [OF _ approx_sym])
done

lemma starfun_add_approx: "[| ( *f* f) x @= l; ( *f* g) x @= m
               |] ==>  ( *f* (%x. f x + g x)) x @= l + m"
by (auto intro: approx_add)

text{*Examples: hrabs is nonstandard extension of rabs
              inverse is nonstandard extension of inverse*}

(* can be proved easily using theorem "starfun" and *)
(* properties of ultrafilter as for inverse below we  *)
(* use the theorem we proved above instead          *)

lemma starfun_rabs_hrabs: "*f* abs = abs"
by (simp only: star_abs_def)

lemma starfun_inverse_inverse [simp]: "( *f* inverse) x = inverse(x)"
by (simp only: star_inverse_def)

lemma starfun_inverse: "!!x. inverse (( *f* f) x) = ( *f* (%x. inverse (f x))) x"
by (transfer, rule refl)
declare starfun_inverse [symmetric, simp]

lemma starfun_divide: "!!x. ( *f* f) x / ( *f* g) x = ( *f* (%x. f x / g x)) x"
by (transfer, rule refl)
declare starfun_divide [symmetric, simp]

lemma starfun_inverse2: "!!x. inverse (( *f* f) x) = ( *f* (%x. inverse (f x))) x"
by (transfer, rule refl)

text{*General lemma/theorem needed for proofs in elementary
    topology of the reals*}
lemma starfun_mem_starset:
      "!!x. ( *f* f) x : *s* A ==> x : *s* {x. f x  \<in> A}"
by (transfer, simp)

text{*Alternative definition for hrabs with rabs function
   applied entrywise to equivalence class representative.
   This is easily proved using starfun and ns extension thm*}
lemma hypreal_hrabs:
     "abs (star_n X) = star_n (%n. abs (X n))"
by (simp only: starfun_rabs_hrabs [symmetric] starfun)

text{*nonstandard extension of set through nonstandard extension
   of rabs function i.e hrabs. A more general result should be
   where we replace rabs by some arbitrary function f and hrabs
   by its NS extenson. See second NS set extension below.*}
lemma STAR_rabs_add_minus:
   "*s* {x. abs (x + - y) < r} =
     {x. abs(x + -star_of y) < star_of r}"
by (transfer, rule refl)

lemma STAR_starfun_rabs_add_minus:
  "*s* {x. abs (f x + - y) < r} =
       {x. abs(( *f* f) x + -star_of y) < star_of r}"
by (transfer, rule refl)

text{*Another characterization of Infinitesimal and one of @= relation.
   In this theory since @{text hypreal_hrabs} proved here. Maybe
   move both theorems??*}
lemma Infinitesimal_FreeUltrafilterNat_iff2:
     "(star_n X \<in> Infinitesimal) =
      (\<forall>m. {n. norm(X n) < inverse(real(Suc m))}
                \<in>  FreeUltrafilterNat)"
by (simp add: Infinitesimal_hypreal_of_nat_iff star_of_def
     hnorm_def star_of_nat_def starfun_star_n
     star_n_inverse star_n_less real_of_nat_def)

lemma HNatInfinite_inverse_Infinitesimal [simp]:
     "n \<in> HNatInfinite ==> inverse (hypreal_of_hypnat n) \<in> Infinitesimal"
apply (cases n)
apply (auto simp add: of_hypnat_def starfun_star_n real_of_nat_def [symmetric] star_n_inverse real_norm_def
      HNatInfinite_FreeUltrafilterNat_iff
      Infinitesimal_FreeUltrafilterNat_iff2)
apply (drule_tac x="Suc m" in spec)
apply (erule ultra, simp)
done

lemma approx_FreeUltrafilterNat_iff: "star_n X @= star_n Y =
      (\<forall>r>0. {n. norm (X n - Y n) < r} : FreeUltrafilterNat)"
apply (subst approx_minus_iff)
apply (rule mem_infmal_iff [THEN subst])
apply (simp add: star_n_diff)
apply (simp add: Infinitesimal_FreeUltrafilterNat_iff)
done

lemma approx_FreeUltrafilterNat_iff2: "star_n X @= star_n Y =
      (\<forall>m. {n. norm (X n - Y n) <
                  inverse(real(Suc m))} : FreeUltrafilterNat)"
apply (subst approx_minus_iff)
apply (rule mem_infmal_iff [THEN subst])
apply (simp add: star_n_diff)
apply (simp add: Infinitesimal_FreeUltrafilterNat_iff2)
done

lemma inj_starfun: "inj starfun"
apply (rule inj_onI)
apply (rule ext, rule ccontr)
apply (drule_tac x = "star_n (%n. xa)" in fun_cong)
apply (auto simp add: starfun star_n_eq_iff)
done

end


(*  Title:      ZF/WF.thy
    Author:     Tobias Nipkow and Lawrence C Paulson
    Copyright   1994  University of Cambridge

Derived first for transitive relations, and finally for arbitrary WF relations
via wf_trancl and trans_trancl.

It is difficult to derive this general case directly, using r^+ instead of
r.  In is_recfun, the two occurrences of the relation must have the same
form.  Inserting r^+ in the_recfun or wftrec yields a recursion rule with
r^+ -`` {a} instead of r-``{a}.  This recursion rule is stronger in
principle, but harder to use, especially to prove wfrec_eclose_eq in
epsilon.ML.  Expanding out the definition of wftrec in wfrec would yield
a mess.
*)

section\<open>Well-Founded Recursion\<close>

theory WF imports Trancl begin

definition
  wf           :: "i=>o"  where
    (*r is a well-founded relation*)
    "wf(r) == \<forall>Z. Z=0 | (\<exists>x\<in>Z. \<forall>y. <y,x>:r \<longrightarrow> ~ y \<in> Z)"

definition
  wf_on        :: "[i,i]=>o"                      ("wf[_]'(_')")  where
    (*r is well-founded on A*)
    "wf_on(A,r) == wf(r \<inter> A*A)"

definition
  is_recfun    :: "[i, i, [i,i]=>i, i] =>o"  where
    "is_recfun(r,a,H,f) == (f = (\<lambda>x\<in>r-``{a}. H(x, restrict(f, r-``{x}))))"

definition
  the_recfun   :: "[i, i, [i,i]=>i] =>i"  where
    "the_recfun(r,a,H) == (THE f. is_recfun(r,a,H,f))"

definition
  wftrec :: "[i, i, [i,i]=>i] =>i"  where
    "wftrec(r,a,H) == H(a, the_recfun(r,a,H))"

definition
  wfrec :: "[i, i, [i,i]=>i] =>i"  where
    (*public version.  Does not require r to be transitive*)
    "wfrec(r,a,H) == wftrec(r^+, a, %x f. H(x, restrict(f,r-``{x})))"

definition
  wfrec_on     :: "[i, i, i, [i,i]=>i] =>i"       ("wfrec[_]'(_,_,_')")  where
    "wfrec[A](r,a,H) == wfrec(r \<inter> A*A, a, H)"

subsection\<open>Well-Founded Relations\<close>

subsubsection\<open>Equivalences between @{term wf} and @{term wf_on}\<close>

lemma wf_imp_wf_on: "wf(r) ==> wf[A](r)"
by (unfold wf_def wf_on_def, force)

lemma wf_on_imp_wf: "[|wf[A](r); r \<subseteq> A*A|] ==> wf(r)"
by (simp add: wf_on_def subset_Int_iff)

lemma wf_on_field_imp_wf: "wf[field(r)](r) ==> wf(r)"
by (unfold wf_def wf_on_def, fast)

lemma wf_iff_wf_on_field: "wf(r) \<longleftrightarrow> wf[field(r)](r)"
by (blast intro: wf_imp_wf_on wf_on_field_imp_wf)

lemma wf_on_subset_A: "[| wf[A](r);  B<=A |] ==> wf[B](r)"
by (unfold wf_on_def wf_def, fast)

lemma wf_on_subset_r: "[| wf[A](r); s<=r |] ==> wf[A](s)"
by (unfold wf_on_def wf_def, fast)

lemma wf_subset: "[|wf(s); r<=s|] ==> wf(r)"
by (simp add: wf_def, fast)

subsubsection\<open>Introduction Rules for @{term wf_on}\<close>

text\<open>If every non-empty subset of @{term A} has an @{term r}-minimal element
   then we have @{term "wf[A](r)"}.\<close>
lemma wf_onI:
 assumes prem: "!!Z u. [| Z<=A;  u \<in> Z;  \<forall>x\<in>Z. \<exists>y\<in>Z. <y,x>:r |] ==> False"
 shows         "wf[A](r)"
apply (unfold wf_on_def wf_def)
apply (rule equals0I [THEN disjCI, THEN allI])
apply (rule_tac Z = Z in prem, blast+)
done

text\<open>If @{term r} allows well-founded induction over @{term A}
   then we have @{term "wf[A](r)"}.   Premise is equivalent to
  @{prop "!!B. \<forall>x\<in>A. (\<forall>y. <y,x>: r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B ==> A<=B"}\<close>
lemma wf_onI2:
 assumes prem: "!!y B. [| \<forall>x\<in>A. (\<forall>y\<in>A. <y,x>:r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B;   y \<in> A |]
                       ==> y \<in> B"
 shows         "wf[A](r)"
apply (rule wf_onI)
apply (rule_tac c=u in prem [THEN DiffE])
  prefer 3 apply blast
 apply fast+
done

subsubsection\<open>Well-founded Induction\<close>

text\<open>Consider the least @{term z} in @{term "domain(r)"} such that
  @{term "P(z)"} does not hold...\<close>
lemma wf_induct_raw:
    "[| wf(r);
        !!x.[| \<forall>y. <y,x>: r \<longrightarrow> P(y) |] ==> P(x) |]
     ==> P(a)"
apply (unfold wf_def)
apply (erule_tac x = "{z \<in> domain(r). ~ P(z)}" in allE)
apply blast
done

lemmas wf_induct = wf_induct_raw [rule_format, consumes 1, case_names step, induct set: wf]

text\<open>The form of this rule is designed to match \<open>wfI\<close>\<close>
lemma wf_induct2:
    "[| wf(r);  a \<in> A;  field(r)<=A;
        !!x.[| x \<in> A;  \<forall>y. <y,x>: r \<longrightarrow> P(y) |] ==> P(x) |]
     ==>  P(a)"
apply (erule_tac P="a \<in> A" in rev_mp)
apply (erule_tac a=a in wf_induct, blast)
done

lemma field_Int_square: "field(r \<inter> A*A) \<subseteq> A"
by blast

lemma wf_on_induct_raw [consumes 2, induct set: wf_on]:
    "[| wf[A](r);  a \<in> A;
        !!x.[| x \<in> A;  \<forall>y\<in>A. <y,x>: r \<longrightarrow> P(y) |] ==> P(x)
     |]  ==>  P(a)"
apply (unfold wf_on_def)
apply (erule wf_induct2, assumption)
apply (rule field_Int_square, blast)
done

lemmas wf_on_induct =
  wf_on_induct_raw [rule_format, consumes 2, case_names step, induct set: wf_on]

text\<open>If @{term r} allows well-founded induction
   then we have @{term "wf(r)"}.\<close>
lemma wfI:
    "[| field(r)<=A;
        !!y B. [| \<forall>x\<in>A. (\<forall>y\<in>A. <y,x>:r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B;  y \<in> A|]
               ==> y \<in> B |]
     ==>  wf(r)"
apply (rule wf_on_subset_A [THEN wf_on_field_imp_wf])
apply (rule wf_onI2)
 prefer 2 apply blast
apply blast
done

subsection\<open>Basic Properties of Well-Founded Relations\<close>

lemma wf_not_refl: "wf(r) ==> <a,a> \<notin> r"
by (erule_tac a=a in wf_induct, blast)

lemma wf_not_sym [rule_format]: "wf(r) ==> \<forall>x. <a,x>:r \<longrightarrow> <x,a> \<notin> r"
by (erule_tac a=a in wf_induct, blast)

(* @{term"[| wf(r);  <a,x> \<in> r;  ~P ==> <x,a> \<in> r |] ==> P"} *)
lemmas wf_asym = wf_not_sym [THEN swap]

lemma wf_on_not_refl: "[| wf[A](r); a \<in> A |] ==> <a,a> \<notin> r"
by (erule_tac a=a in wf_on_induct, assumption, blast)

lemma wf_on_not_sym [rule_format]:
     "[| wf[A](r);  a \<in> A |] ==> \<forall>b\<in>A. <a,b>:r \<longrightarrow> <b,a>\<notin>r"
apply (erule_tac a=a in wf_on_induct, assumption, blast)
done

lemma wf_on_asym:
     "[| wf[A](r);  ~Z ==> <a,b> \<in> r;
         <b,a> \<notin> r ==> Z; ~Z ==> a \<in> A; ~Z ==> b \<in> A |] ==> Z"
by (blast dest: wf_on_not_sym)

(*Needed to prove well_ordI.  Could also reason that wf[A](r) means
  wf(r \<inter> A*A);  thus wf( (r \<inter> A*A)^+ ) and use wf_not_refl *)
lemma wf_on_chain3:
     "[| wf[A](r); <a,b>:r; <b,c>:r; <c,a>:r; a \<in> A; b \<in> A; c \<in> A |] ==> P"
apply (subgoal_tac "\<forall>y\<in>A. \<forall>z\<in>A. <a,y>:r \<longrightarrow> <y,z>:r \<longrightarrow> <z,a>:r \<longrightarrow> P",
       blast)
apply (erule_tac a=a in wf_on_induct, assumption, blast)
done

text\<open>transitive closure of a WF relation is WF provided
  @{term A} is downward closed\<close>
lemma wf_on_trancl:
    "[| wf[A](r);  r-``A \<subseteq> A |] ==> wf[A](r^+)"
apply (rule wf_onI2)
apply (frule bspec [THEN mp], assumption+)
apply (erule_tac a = y in wf_on_induct, assumption)
apply (blast elim: tranclE, blast)
done

lemma wf_trancl: "wf(r) ==> wf(r^+)"
apply (simp add: wf_iff_wf_on_field)
apply (rule wf_on_subset_A)
 apply (erule wf_on_trancl)
 apply blast
apply (rule trancl_type [THEN field_rel_subset])
done

text\<open>@{term "r-``{a}"} is the set of everything under @{term a} in @{term r}\<close>

lemmas underI = vimage_singleton_iff [THEN iffD2]
lemmas underD = vimage_singleton_iff [THEN iffD1]

subsection\<open>The Predicate @{term is_recfun}\<close>

lemma is_recfun_type: "is_recfun(r,a,H,f) ==> f \<in> r-``{a} -> range(f)"
apply (unfold is_recfun_def)
apply (erule ssubst)
apply (rule lamI [THEN rangeI, THEN lam_type], assumption)
done

lemmas is_recfun_imp_function = is_recfun_type [THEN fun_is_function]

lemma apply_recfun:
    "[| is_recfun(r,a,H,f); <x,a>:r |] ==> f`x = H(x, restrict(f,r-``{x}))"
apply (unfold is_recfun_def)
  txt\<open>replace f only on the left-hand side\<close>
apply (erule_tac P = "%x. t(x) = u" for t u in ssubst)
apply (simp add: underI)
done

lemma is_recfun_equal [rule_format]:
     "[| wf(r);  trans(r);  is_recfun(r,a,H,f);  is_recfun(r,b,H,g) |]
      ==> <x,a>:r \<longrightarrow> <x,b>:r \<longrightarrow> f`x=g`x"
apply (frule_tac f = f in is_recfun_type)
apply (frule_tac f = g in is_recfun_type)
apply (simp add: is_recfun_def)
apply (erule_tac a=x in wf_induct)
apply (intro impI)
apply (elim ssubst)
apply (simp (no_asm_simp) add: vimage_singleton_iff restrict_def)
apply (rule_tac t = "%z. H (x, z)" for x in subst_context)
apply (subgoal_tac "\<forall>y\<in>r-``{x}. \<forall>z. <y,z>:f \<longleftrightarrow> <y,z>:g")
 apply (blast dest: transD)
apply (simp add: apply_iff)
apply (blast dest: transD intro: sym)
done

lemma is_recfun_cut:
     "[| wf(r);  trans(r);
         is_recfun(r,a,H,f);  is_recfun(r,b,H,g);  <b,a>:r |]
      ==> restrict(f, r-``{b}) = g"
apply (frule_tac f = f in is_recfun_type)
apply (rule fun_extension)
  apply (blast dest: transD intro: restrict_type2)
 apply (erule is_recfun_type, simp)
apply (blast dest: transD intro: is_recfun_equal)
done

subsection\<open>Recursion: Main Existence Lemma\<close>

lemma is_recfun_functional:
     "[| wf(r); trans(r); is_recfun(r,a,H,f); is_recfun(r,a,H,g) |]  ==>  f=g"
by (blast intro: fun_extension is_recfun_type is_recfun_equal)

lemma the_recfun_eq:
    "[| is_recfun(r,a,H,f);  wf(r);  trans(r) |] ==> the_recfun(r,a,H) = f"
apply (unfold the_recfun_def)
apply (blast intro: is_recfun_functional)
done

(*If some f satisfies is_recfun(r,a,H,-) then so does the_recfun(r,a,H) *)
lemma is_the_recfun:
    "[| is_recfun(r,a,H,f);  wf(r);  trans(r) |]
     ==> is_recfun(r, a, H, the_recfun(r,a,H))"
by (simp add: the_recfun_eq)

lemma unfold_the_recfun:
     "[| wf(r);  trans(r) |] ==> is_recfun(r, a, H, the_recfun(r,a,H))"
apply (rule_tac a=a in wf_induct, assumption)
apply (rename_tac a1)
apply (rule_tac f = "\<lambda>y\<in>r-``{a1}. wftrec (r,y,H)" in is_the_recfun)
  apply typecheck
apply (unfold is_recfun_def wftrec_def)
  \<comment>\<open>Applying the substitution: must keep the quantified assumption!\<close>
apply (rule lam_cong [OF refl])
apply (drule underD)
apply (fold is_recfun_def)
apply (rule_tac t = "%z. H(x, z)" for x in subst_context)
apply (rule fun_extension)
  apply (blast intro: is_recfun_type)
 apply (rule lam_type [THEN restrict_type2])
  apply blast
 apply (blast dest: transD)
apply atomize
apply (frule spec [THEN mp], assumption)
apply (subgoal_tac "<xa,a1> \<in> r")
 apply (drule_tac x1 = xa in spec [THEN mp], assumption)
apply (simp add: vimage_singleton_iff
                 apply_recfun is_recfun_cut)
apply (blast dest: transD)
done

subsection\<open>Unfolding @{term "wftrec(r,a,H)"}\<close>

lemma the_recfun_cut:
     "[| wf(r);  trans(r);  <b,a>:r |]
      ==> restrict(the_recfun(r,a,H), r-``{b}) = the_recfun(r,b,H)"
by (blast intro: is_recfun_cut unfold_the_recfun)

(*NOT SUITABLE FOR REWRITING: it is recursive!*)
lemma wftrec:
    "[| wf(r);  trans(r) |] ==>
          wftrec(r,a,H) = H(a, \<lambda>x\<in>r-``{a}. wftrec(r,x,H))"
apply (unfold wftrec_def)
apply (subst unfold_the_recfun [unfolded is_recfun_def])
apply (simp_all add: vimage_singleton_iff [THEN iff_sym] the_recfun_cut)
done

subsubsection\<open>Removal of the Premise @{term "trans(r)"}\<close>

(*NOT SUITABLE FOR REWRITING: it is recursive!*)
lemma wfrec:
    "wf(r) ==> wfrec(r,a,H) = H(a, \<lambda>x\<in>r-``{a}. wfrec(r,x,H))"
apply (unfold wfrec_def)
apply (erule wf_trancl [THEN wftrec, THEN ssubst])
 apply (rule trans_trancl)
apply (rule vimage_pair_mono [THEN restrict_lam_eq, THEN subst_context])
 apply (erule r_into_trancl)
apply (rule subset_refl)
done

(*This form avoids giant explosions in proofs.  NOTE USE OF == *)
lemma def_wfrec:
    "[| !!x. h(x)==wfrec(r,x,H);  wf(r) |] ==>
     h(a) = H(a, \<lambda>x\<in>r-``{a}. h(x))"
apply simp
apply (elim wfrec)
done

lemma wfrec_type:
    "[| wf(r);  a \<in> A;  field(r)<=A;
        !!x u. [| x \<in> A;  u \<in> Pi(r-``{x}, B) |] ==> H(x,u) \<in> B(x)
     |] ==> wfrec(r,a,H) \<in> B(a)"
apply (rule_tac a = a in wf_induct2, assumption+)
apply (subst wfrec, assumption)
apply (simp add: lam_type underD)
done

lemma wfrec_on:
 "[| wf[A](r);  a \<in> A |] ==>
         wfrec[A](r,a,H) = H(a, \<lambda>x\<in>(r-``{a}) \<inter> A. wfrec[A](r,x,H))"
apply (unfold wf_on_def wfrec_on_def)
apply (erule wfrec [THEN trans])
apply (simp add: vimage_Int_square cons_subset_iff)
done

text\<open>Minimal-element characterization of well-foundedness\<close>
lemma wf_eq_minimal:
     "wf(r) \<longleftrightarrow> (\<forall>Q x. x \<in> Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. <y,z>:r \<longrightarrow> y\<notin>Q))"
by (unfold wf_def, blast)

end