theory ClosedFormsBounds
  imports "GeneralRegexBound" "ClosedForms"
begin
lemma alts_ders_lambda_shape_ders:
  shows "\<forall>r \<in> set (map (\<lambda>r. rders_simp r ( s)) rs ). \<exists>r1 \<in> set rs. r = rders_simp r1 s"
  by (simp add: image_iff)

lemma rlist_bound:
  assumes "\<forall>r \<in> set rs. rsize r \<le> N"
  shows "rsizes rs \<le> N * (length rs)"
  using assms
  apply(induct rs)
  apply simp
  by simp

lemma alts_closed_form_bounded:
  assumes "\<forall>r \<in> set rs. \<forall>s. rsize (rders_simp r s) \<le> N"
  shows "rsize (rders_simp (RALTS rs) s) \<le> max (Suc (N * (length rs))) (rsize (RALTS rs))"
proof (cases s)
  case Nil
  then show "rsize (rders_simp (RALTS rs) s) \<le> max (Suc (N * length rs)) (rsize (RALTS rs))"
    by simp
next
  case (Cons a s)

  from assms have "\<forall>r \<in> set (map (\<lambda>r. rders_simp r (a # s)) rs ). rsize r \<le> N"
    by (metis alts_ders_lambda_shape_ders)
  then have a: "rsizes (map (\<lambda>r. rders_simp r (a # s)) rs ) \<le> N *  (length rs)"
    by (metis length_map rlist_bound)

  have "rsize (rders_simp (RALTS rs) (a # s))
          = rsize (rsimp (RALTS (map (\<lambda>r. rders_simp r (a # s)) rs)))"
    by (metis alts_closed_form_variant list.distinct(1))
  also have "... \<le> rsize (RALTS (map (\<lambda>r. rders_simp r (a # s)) rs))"
    using rsimp_mono by blast
  also have "... = Suc (rsizes (map (\<lambda>r. rders_simp r (a # s)) rs))"
    by simp
  also have "... \<le> Suc (N * (length rs))"
    using a by blast
  finally have "rsize (rders_simp (RALTS rs) (a # s)) \<le> max (Suc (N * length rs)) (rsize (RALTS rs))"
    by auto
  then show ?thesis using local.Cons by simp
qed

lemma alts_simp_ineq_unfold:
  shows "rsize (rsimp (RALTS rs)) \<le> Suc (rsizes (rdistinct (rflts (map rsimp rs)) {}))"
  using rsimp_aalts_smaller by auto

lemma rdistinct_mono_list:
  shows "rsizes (rdistinct (x5 @ rs) rset) \<le> rsizes x5 + rsizes (rdistinct  rs ((set x5 ) \<union> rset))"
  apply(induct x5 arbitrary: rs rset)
   apply simp
  apply(case_tac "a \<in> rset")
   apply simp
   apply (simp add: add.assoc insert_absorb trans_le_add2)
  apply simp
  by (metis Un_insert_right)

lemma flts_size_reduction_alts:
  assumes a: "\<And>noalts_set alts_set corr_set.
           (\<forall>r\<in>noalts_set. \<forall>xs. r \<noteq> RALTS xs) \<and>
           (\<forall>a\<in>alts_set. \<exists>xs. a = RALTS xs \<and> set xs \<subseteq> corr_set) \<Longrightarrow>
           Suc (rsizes (rdistinct (rflts rs) (noalts_set \<union> corr_set)))
           \<le> Suc (rsizes (rdistinct rs (insert RZERO (noalts_set \<union> alts_set))))"
 and b: "\<forall>r\<in>noalts_set. \<forall>xs. r \<noteq> RALTS xs"
 and c: "\<forall>a\<in>alts_set. \<exists>xs. a = RALTS xs \<and> set xs \<subseteq> corr_set"
 and d: "a = RALTS x5"
 shows "rsizes (rdistinct (rflts (a # rs)) (noalts_set \<union> corr_set))
           \<le> rsizes (rdistinct (a # rs) (insert RZERO (noalts_set \<union> alts_set)))"

  apply(case_tac "a \<in> alts_set")
  using a b c d
   apply simp
   apply(subgoal_tac "set x5 \<subseteq> corr_set")
  apply(subst rdistinct_concat)
  apply auto[1]
    apply presburger
   apply fastforce
  using a b c d
  apply (subgoal_tac "a \<notin> noalts_set")
  prefer 2
  apply blast
  apply simp
  apply(subgoal_tac "rsizes (rdistinct (x5 @ rflts rs) (noalts_set \<union> corr_set))
                   \<le> rsizes x5 + rsizes (rdistinct (rflts rs) ((set x5) \<union> (noalts_set \<union> corr_set)))")
  prefer 2
  using rdistinct_mono_list apply presburger
  apply(subgoal_tac "insert (RALTS x5) (noalts_set \<union> alts_set) = noalts_set \<union> (insert (RALTS x5) alts_set)")
   apply(simp only:)
  apply(subgoal_tac "rsizes x5 + rsizes (rdistinct (rflts rs) (noalts_set \<union> (corr_set \<union> (set x5)))) \<le>
           rsizes x5 + rsizes (rdistinct rs (insert RZERO (noalts_set \<union> insert (RALTS x5) alts_set)))")

  apply (simp add: Un_left_commute inf_sup_aci(5))
   apply(subgoal_tac "rsizes (rdistinct (rflts rs) (noalts_set \<union> (corr_set \<union> set x5))) \<le>
                    rsizes (rdistinct rs (insert RZERO (noalts_set \<union> insert (RALTS x5) alts_set)))")
    apply linarith
   apply(subgoal_tac "\<forall>r \<in> insert (RALTS x5) alts_set. \<exists>xs1.( r = RALTS xs1 \<and> set xs1 \<subseteq> corr_set \<union> set x5)")
    apply presburger
   apply (meson insert_iff sup.cobounded2 sup.coboundedI1)
  by blast

lemma flts_vs_nflts1:
  assumes "\<forall>r \<in> noalts_set. \<forall>xs. r \<noteq> RALTS xs"
  and "\<forall>a \<in> alts_set. (\<exists>xs. a = RALTS xs \<and> set xs \<subseteq> corr_set)"
  shows "rsizes (rdistinct (rflts rs) (noalts_set \<union> corr_set))
         \<le> rsizes (rdistinct rs (insert RZERO (noalts_set \<union> alts_set)))"
  using assms
    apply(induct rs arbitrary: noalts_set alts_set corr_set)
   apply simp
  apply(case_tac a)
       apply(case_tac "RZERO \<in> noalts_set")
        apply simp
       apply(subgoal_tac "RZERO \<notin> alts_set")
        apply simp
       apply fastforce
      apply(case_tac "RONE \<in> noalts_set")
       apply simp
      apply(subgoal_tac "RONE \<notin> alts_set")
  prefer 2
  apply fastforce
      apply(case_tac "RONE \<in> corr_set")
       apply(subgoal_tac "rflts (a # rs) = RONE # rflts rs")
        apply(simp only:)
        apply(subgoal_tac "rdistinct (RONE # rflts rs) (noalts_set \<union> corr_set) =
                           rdistinct (rflts rs) (noalts_set \<union> corr_set)")
         apply(simp only:)
  apply(subgoal_tac "rdistinct (RONE # rs) (insert RZERO (noalts_set \<union> alts_set)) =
                     RONE # (rdistinct rs (insert RONE (insert RZERO (noalts_set \<union> alts_set)))) ")
          apply(simp only:)
  apply(subgoal_tac "rdistinct (rflts rs) (noalts_set \<union> corr_set) =
                     rdistinct (rflts rs) (insert RONE (noalts_set \<union> corr_set))")
  apply (simp only:)
  apply(subgoal_tac "insert RONE (noalts_set \<union> corr_set) = (insert RONE noalts_set) \<union> corr_set")
            apply(simp only:)
  apply(subgoal_tac "insert RONE (insert RZERO (noalts_set \<union> alts_set)) =
                     insert RZERO ((insert RONE noalts_set) \<union> alts_set)")
             apply(simp only:)
  apply(subgoal_tac "rsizes (rdistinct rs (insert RZERO (insert RONE noalts_set \<union> alts_set)))
                   \<le>  rsizes (RONE # rdistinct rs (insert RZERO (insert RONE noalts_set \<union> alts_set)))")
  apply (smt (verit, ccfv_threshold) dual_order.trans insertE rrexp.distinct(17))
  apply (metis (no_types, opaque_lifting)  le_add_same_cancel2 list.simps(9) sum_list.Cons zero_le)
            apply fastforce
           apply fastforce
  apply (metis Un_iff insert_absorb)
         apply (metis UnE insertE insert_is_Un rdistinct.simps(2) rrexp.distinct(1))
        apply (meson UnCI rdistinct.simps(2))
  using rflts.simps(4) apply presburger
      apply simp
      apply(subgoal_tac "insert RONE (noalts_set \<union> corr_set) = (insert RONE noalts_set) \<union> corr_set")
        apply(simp only:)
  apply (metis Un_insert_left insertE rrexp.distinct(17))
      apply fastforce
     apply(case_tac "a \<in> noalts_set")
      apply simp
  apply(subgoal_tac "a \<notin> alts_set")
      prefer 2
      apply blast
  apply(case_tac "a \<in> corr_set")
      apply(subgoal_tac "noalts_set \<union> corr_set = insert a ( noalts_set  \<union> corr_set)")
  prefer 2
  apply fastforce
      apply(simp only:)
      apply(subgoal_tac "rsizes (rdistinct (a # rs) (insert RZERO ((insert a noalts_set) \<union> alts_set))) \<le>
              rsizes (rdistinct (a # rs) (insert RZERO (noalts_set \<union> alts_set)))")

       apply(subgoal_tac  "rsizes (rdistinct (rflts (a # rs)) ((insert a noalts_set) \<union> corr_set)) \<le>
              rsizes (rdistinct (a # rs) (insert RZERO ((insert a noalts_set) \<union> alts_set)))")
  apply fastforce
       apply simp
  apply(subgoal_tac "(insert a (noalts_set \<union> alts_set)) = (insert a noalts_set) \<union> alts_set")
        apply(simp only:)
        apply(subgoal_tac "noalts_set \<union> corr_set = (insert a noalts_set) \<union> corr_set")
          apply(simp only:)
  apply (metis insertE nonalt.simps(1) nonalt.simps(4))
        apply blast

  apply fastforce
  apply force
      apply simp
  apply (metis Un_insert_left insertE nonalt.simps(1) nonalt.simps(4))
    apply(case_tac "a \<in> noalts_set")
     apply simp
  apply(subgoal_tac "a \<notin> alts_set")
      prefer 2
      apply blast
  apply(case_tac "a \<in> corr_set")
      apply(subgoal_tac "noalts_set \<union> corr_set = insert a ( noalts_set  \<union> corr_set)")
  prefer 2
  apply fastforce
      apply(simp only:)
      apply(subgoal_tac "rsizes (rdistinct (a # rs) (insert RZERO ((insert a noalts_set) \<union> alts_set))) \<le>
             rsizes (rdistinct (a # rs) (insert RZERO (noalts_set \<union> alts_set)))")

       apply(subgoal_tac "rsizes (rdistinct (rflts (a # rs)) ((insert a noalts_set) \<union> corr_set)) \<le>
          rsizes (rdistinct (a # rs) (insert RZERO ((insert a noalts_set) \<union> alts_set)))")
  apply fastforce
       apply simp
  apply(subgoal_tac "(insert a (noalts_set \<union> alts_set)) = (insert a noalts_set) \<union> alts_set")
        apply(simp only:)
        apply(subgoal_tac "noalts_set \<union> corr_set = (insert a noalts_set) \<union> corr_set")
  apply(simp only:)

         apply (metis insertE rrexp.distinct(31))
  apply blast
  apply fastforce
  apply force
     apply simp

    apply (metis Un_insert_left insertE rrexp.distinct(31))

  using Suc_le_mono flts_size_reduction_alts apply presburger
     apply(case_tac "a \<in> noalts_set")
      apply simp
  apply(subgoal_tac "a \<notin> alts_set")
      prefer 2
      apply blast
  apply(case_tac "a \<in> corr_set")
      apply(subgoal_tac "noalts_set \<union> corr_set = insert a ( noalts_set  \<union> corr_set)")
  prefer 2
  apply fastforce
      apply(simp only:)
      apply(subgoal_tac "rsizes (rdistinct (a # rs) (insert RZERO ((insert a noalts_set) \<union> alts_set))) \<le>
               rsizes (rdistinct (a # rs) (insert RZERO (noalts_set \<union> alts_set)))")

       apply(subgoal_tac "rsizes (rdistinct (rflts (a # rs)) ((insert a noalts_set) \<union> corr_set)) \<le>
          rsizes (rdistinct (a # rs) (insert RZERO ((insert a noalts_set) \<union> alts_set)))")
  apply fastforce
       apply simp
  apply(subgoal_tac "(insert a (noalts_set \<union> alts_set)) = (insert a noalts_set) \<union> alts_set")
        apply(simp only:)
        apply(subgoal_tac "noalts_set \<union> corr_set = (insert a noalts_set) \<union> corr_set")
       apply(simp only:)
  apply (metis insertE rrexp.distinct(37))

        apply blast

  apply fastforce
  apply force
     apply simp
   apply (metis Un_insert_left insert_iff rrexp.distinct(37))
  apply(case_tac "a \<in> noalts_set")
      apply simp
  apply(subgoal_tac "a \<notin> alts_set")
     prefer 2
      apply blast
  apply(case_tac "a \<in> corr_set")
      apply(subgoal_tac "noalts_set \<union> corr_set = insert a ( noalts_set  \<union> corr_set)")
  prefer 2
  apply fastforce
   apply(simp only:)
   apply(subgoal_tac "rsizes (rdistinct (a # rs) (insert RZERO ((insert a noalts_set) \<union> alts_set))) \<le>
               rsizes (rdistinct (a # rs) (insert RZERO (noalts_set \<union> alts_set)))")

       apply(subgoal_tac "rsizes (rdistinct (rflts (a # rs)) ((insert a noalts_set) \<union> corr_set)) \<le>
          rsizes (rdistinct (a # rs) (insert RZERO ((insert a noalts_set) \<union> alts_set)))")
  apply fastforce
       apply simp
  apply(subgoal_tac "(insert a (noalts_set \<union> alts_set)) = (insert a noalts_set) \<union> alts_set")
        apply(simp only:)
        apply(subgoal_tac "noalts_set \<union> corr_set = (insert a noalts_set) \<union> corr_set")
       apply(simp only:)
  apply (metis insertE nonalt.simps(1) nonalt.simps(7))
  apply blast
  apply blast
  apply force
  apply(auto)
  by (metis Un_insert_left insert_iff rrexp.distinct(39))

lemma flts_vs_nflts:
  assumes "\<forall>r \<in> noalts_set. \<forall>xs. r \<noteq> RALTS xs"
  and "\<forall>a \<in> alts_set. (\<exists>xs. a = RALTS xs \<and> set xs \<subseteq> corr_set)"
  shows "rsizes (rdistinct (rflts rs) (noalts_set \<union> corr_set))
         \<le> rsizes (rdistinct rs (insert RZERO (noalts_set \<union> alts_set)))"
  by (simp add: assms flts_vs_nflts1)

lemma distinct_simp_ineq_general:
  assumes "rsimp ` no_simp = has_simp" "finite no_simp"
  shows "rsizes (rdistinct (map rsimp rs) has_simp) \<le> rsizes (rdistinct rs no_simp)"
  using assms
  apply(induct rs no_simp arbitrary: has_simp rule: rdistinct.induct)
  apply simp
  apply(auto)
  using add_le_mono rsimp_mono by presburger

lemma larger_acc_smaller_distinct_res0:
  assumes "ss \<subseteq> SS"
  shows "rsizes (rdistinct rs SS) \<le> rsizes (rdistinct rs ss)"
  using assms
  apply(induct rs arbitrary: ss SS)
   apply simp
  by (metis distinct_early_app1 rdistinct_smaller)

lemma without_flts_ineq:
  shows "rsizes (rdistinct (rflts rs) {}) \<le> rsizes (rdistinct rs {})"
proof -
  have "rsizes (rdistinct (rflts rs) {}) \<le>  rsizes (rdistinct rs (insert RZERO {}))"
    by (metis empty_iff flts_vs_nflts sup_bot_left)
  also have "... \<le>  rsizes (rdistinct rs {})"
    by (simp add: larger_acc_smaller_distinct_res0)
  finally show ?thesis
    by blast
qed

lemma distinct_simp_ineq:
  shows "rsizes (rdistinct (map rsimp rs) {}) \<le> rsizes (rdistinct rs {})"
  using distinct_simp_ineq_general by blast

lemma alts_simp_control:
  shows "rsize (rsimp (RALTS rs)) \<le> Suc (rsizes (rdistinct rs {}))"
proof -
  have "rsize (rsimp (RALTS rs)) \<le> Suc (rsizes (rdistinct (rflts (map rsimp rs)) {}))"
     using alts_simp_ineq_unfold by auto
   moreover have "\<dots> \<le> Suc (rsizes (rdistinct (map rsimp rs) {}))"
    using without_flts_ineq by blast
  ultimately show "rsize (rsimp (RALTS rs)) \<le> Suc (rsizes (rdistinct rs {}))"
    by (meson Suc_le_mono distinct_simp_ineq le_trans)
qed

lemma larger_acc_smaller_distinct_res:
  shows "rsizes (rdistinct rs (insert a ss)) \<le> rsizes (rdistinct rs ss)"
  by (simp add: larger_acc_smaller_distinct_res0 subset_insertI)

lemma triangle_inequality_distinct:
  shows "rsizes (rdistinct (a # rs) ss) \<le> rsize a + rsizes (rdistinct rs ss)"
  apply(case_tac "a \<in> ss")
   apply simp
  by (simp add: larger_acc_smaller_distinct_res)

lemma distinct_list_size_len_bounded:
  assumes "\<forall>r \<in> set rs. rsize r \<le> N" "length rs \<le> lrs"
  shows "rsizes rs \<le> lrs * N "
  using assms
  by (metis rlist_bound dual_order.trans mult.commute mult_le_mono1)

lemma rdistinct_same_set:
  shows "r \<in> set rs \<longleftrightarrow> r \<in> set (rdistinct rs {})"
  apply(induct rs)
   apply simp
  by (metis rdistinct_set_equality)

(* distinct_list_rexp_up_to_certain_size_bouded_by_set_enumerating_up_to_that_size *)
lemma distinct_list_rexp_upto:
  assumes "\<forall>r\<in> set rs. (rsize r) \<le> N"
  shows "rsizes (rdistinct rs {}) \<le> (card (sizeNregex N)) * N"

  apply(subgoal_tac "distinct (rdistinct rs {})")
  prefer 2
  using rdistinct_does_the_job apply blast
  apply(subgoal_tac "length (rdistinct rs {}) \<le> card (sizeNregex N)")
  apply(rule distinct_list_size_len_bounded)
  using assms
  apply (meson rdistinct_same_set)
   apply blast
  apply(subgoal_tac "\<forall>r \<in> set (rdistinct rs {}). rsize r \<le> N")
   prefer 2
  using assms
   apply (meson rdistinct_same_set)
  apply(subgoal_tac "length (rdistinct rs {}) = card (set (rdistinct rs {}))")
   prefer 2
  apply (simp add: distinct_card)
  apply(simp)
  by (metis card_mono finite_size_n mem_Collect_eq sizeNregex_def subsetI)

lemma star_control_bounded:
  assumes "\<forall>s. rsize (rders_simp r s) \<le> N"
  shows "rsizes (rdistinct (map (\<lambda>s1. RSEQ (rders_simp r s1) (RSTAR r)) (star_updates s r [[c]])) {})
     \<le> (card (sizeNregex (Suc (N + rsize (RSTAR r))))) * (Suc (N + rsize (RSTAR r)))"
  by (smt (verit) add_Suc_shift add_mono_thms_linordered_semiring(3) assms distinct_list_rexp_upto image_iff list.set_map plus_nat.simps(2) rsize.simps(5))

lemma star_closed_form_bounded:
  assumes "\<forall>s. rsize (rders_simp r s) \<le> N"
  shows "rsize (rders_simp (RSTAR r) s) \<le>
           max ((Suc (card (sizeNregex (Suc (N + rsize (RSTAR r))))) * (Suc (N + rsize (RSTAR r))))) (rsize (RSTAR r))"
proof(cases s)
  case Nil
  then show "rsize (rders_simp (RSTAR r) s)
    \<le> max (Suc (card (sizeNregex (Suc (N + rsize (RSTAR r))))) * Suc (N + rsize (RSTAR r))) (rsize (RSTAR r))"
    by simp
next
  case (Cons a list)
  then have "rsize (rders_simp (RSTAR r) s) =
    rsize (rsimp (RALTS ((map (\<lambda>s1. RSEQ (rders_simp r s1) (RSTAR r)) (star_updates list r [[a]])))))"
    using star_closed_form by fastforce
  also have "... \<le> Suc (rsizes (rdistinct (map (\<lambda>s1. RSEQ (rders_simp r s1) (RSTAR r)) (star_updates list r [[a]])) {}))"
    using alts_simp_control by blast
  also have "... \<le> Suc (card (sizeNregex (Suc (N + rsize (RSTAR r))))) * (Suc (N + rsize (RSTAR r)))"
    using star_control_bounded[OF assms] by (metis add_mono le_add1 mult_Suc plus_1_eq_Suc)
  also have "... \<le> max (Suc (card (sizeNregex (Suc (N + rsize (RSTAR r))))) * Suc (N + rsize (RSTAR r))) (rsize (RSTAR r))"
    by simp
  finally show ?thesis by simp
qed

thm ntimes_closed_form

thm rsize.simps

lemma nupdates_snoc:
  shows " (nupdates (xs @ [x]) r optlist) = nupdate x r (nupdates xs r optlist)"
  by (simp add: nupdates_append)

lemma nupdate_elems:
  shows "\<forall>opt \<in> set (nupdate c r optlist). opt = None \<or> (\<exists>s n. opt = Some (s, n))"
  using nonempty_string.cases by auto

lemma nupdates_elems:
  shows "\<forall>opt \<in> set (nupdates s r optlist). opt = None \<or> (\<exists>s n. opt = Some (s, n))"
  by (meson nonempty_string.cases)

lemma opterm_optlist_result_shape:
  shows "\<forall>r' \<in> set (map (optermsimp r) optlist). r' = RZERO \<or> (\<exists>s m. r' = RSEQ (rders_simp r s) (RNTIMES r m))"
  apply(induct optlist)
   apply simp
  apply(case_tac a)
  apply simp+
  by fastforce

lemma opterm_optlist_result_shape2:
  shows "\<And>optlist. \<forall>r' \<in> set (map (optermsimp r) optlist). r' = RZERO \<or> (\<exists>s m. r' = RSEQ (rders_simp r s) (RNTIMES r m))"
  using opterm_optlist_result_shape by presburger

lemma nupdate_n_leq_n:
  shows "\<forall>r \<in> set (nupdate c' r [Some ([c], n)]). r = None \<or>( \<exists>s' m. r = Some (s', m) \<and> m \<le> n)"
  apply(case_tac n)
   apply simp
  apply simp
  done
(*
lemma nupdate_induct_leqn:
  shows "\<lbrakk>\<forall>opt \<in> set optlist. opt = None \<or> (\<exists>s' m. opt = Some(s', m) \<and> m \<le> n) \<rbrakk> \<Longrightarrow>
       \<forall>opt \<in> set (nupdate c' r optlist). opt = None \<or> (\<exists>s' m. opt = Some (s', m) \<and> m \<le> n)"
  apply (case_tac optlist)
   apply simp
  apply(case_tac a)
   apply simp
  sledgehammer
*)

lemma nupdates_n_leq_n:
  shows "\<forall>r \<in> set (nupdates s r [Some ([c], n)]). r = None \<or>( \<exists>s' m. r = Some (s', m) \<and> m \<le> n)"
  apply(induct s rule: rev_induct)
   apply simp
  apply(subst nupdates_append)
  by (metis nupdates_elems_leqn nupdates_snoc)

lemma ntimes_closed_form_list_elem_shape:
  shows "\<forall>r' \<in> set (map (optermsimp r) (nupdates s r [Some ([c], n)])).
r' = RZERO \<or> (\<exists>s' m. r' = RSEQ (rders_simp r s') (RNTIMES r m) \<and> m \<le> n)"
  apply(insert opterm_optlist_result_shape2)
  apply(case_tac s)
   apply(auto)
  apply (metis rders_simp_one_char)
  by (metis case_prod_conv nupdates.simps(2) nupdates_n_leq_n option.simps(4) option.simps(5))

lemma ntimes_trivial1:
  shows "rsize RZERO \<le> N + rsize (RNTIMES r n)"
  by simp

lemma ntimes_trivial20:
  shows "m \<le> n \<Longrightarrow> rsize (RNTIMES r m) \<le> rsize (RNTIMES r n)"
  by simp

lemma ntimes_trivial2:
  assumes "\<forall>s. rsize (rders_simp r s) \<le> N"
  shows "    r' = RSEQ (rders_simp r s1) (RNTIMES r m) \<and> m \<le> n
       \<Longrightarrow> rsize r' \<le> Suc (N + rsize (RNTIMES r n))"
  apply simp
  by (simp add: add_mono_thms_linordered_semiring(1) assms)

lemma ntimes_closed_form_list_elem_bounded:
  assumes "\<forall>s. rsize (rders_simp r s) \<le> N"
  shows "\<forall>r' \<in>  set  (map (optermsimp r) (nupdates s r [Some ([c], n)])). rsize r' \<le> Suc (N + rsize (RNTIMES r n))"
  apply(rule ballI)
  apply(subgoal_tac  "r' = RZERO \<or> (\<exists>s' m. r' = RSEQ (rders_simp r s') (RNTIMES r m) \<and> m \<le> n)")
  prefer 2
  using ntimes_closed_form_list_elem_shape apply blast
  apply(case_tac "r' = RZERO")
  using le_SucI ntimes_trivial1 apply presburger
  apply(subgoal_tac "\<exists>s1 m. r' = RSEQ (rders_simp r s1) (RNTIMES r m) \<and> m \<le> n")
  apply(erule exE)+
  using assms ntimes_trivial2 apply presburger
  by blast

lemma P_holds_after_distinct:
  assumes "\<forall>r \<in> set rs. P r"
  shows "\<forall>r \<in> set (rdistinct rs rset). P r"
  by (simp add: assms rdistinct_set_equality1)

lemma ntimes_control_bounded:
  assumes "\<forall>s. rsize (rders_simp r s) \<le> N"
  shows "rsizes (rdistinct (map (optermsimp r) (nupdates s r [Some ([c], n)])) {})
     \<le> (card (sizeNregex (Suc (N + rsize (RNTIMES r n))))) * (Suc (N + rsize (RNTIMES r n)))"
  apply(subgoal_tac "\<forall>r' \<in> set (rdistinct (map (optermsimp r) (nupdates s r [Some ([c], n)])) {}).
          rsize r' \<le> Suc (N + rsize (RNTIMES r n))")
   apply (meson distinct_list_rexp_upto rdistinct_same_set)
  apply(subgoal_tac "\<forall>r' \<in> set (map (optermsimp r) (nupdates s r [Some ([c], n)])). rsize r' \<le> Suc (N + rsize (RNTIMES r n))")
   apply (simp add: rdistinct_set_equality)
  by (metis assms nat_le_linear not_less_eq_eq ntimes_closed_form_list_elem_bounded)

lemma ntimes_closed_form_bounded0:
  assumes "\<forall>s. rsize (rders_simp r s) \<le> N"
  shows " (rders_simp (RNTIMES r 0) s)  = RZERO \<or> (rders_simp (RNTIMES r 0) s)  = RNTIMES r 0
           "
  apply(induct s)
   apply simp
  by (metis always0 list.simps(3) rder.simps(7) rders.simps(2) rders_simp_same_simpders rsimp.simps(3))

lemma ntimes_closed_form_bounded1:
  assumes "\<forall>s. rsize (rders_simp r s) \<le> N"
  shows " rsize (rders_simp (RNTIMES r 0) s) \<le> max (rsize  RZERO) (rsize (RNTIMES r 0))"

  by (metis assms max.cobounded1 max.cobounded2 ntimes_closed_form_bounded0)

lemma self_smaller_than_bound:
  shows "\<forall>s. rsize (rders_simp r s) \<le> N \<Longrightarrow> rsize r \<le> N"
  apply(drule_tac x = "[]" in spec)
  apply simp
  done

lemma ntimes_closed_form_bounded_nil_aux:
  shows "max (rsize  RZERO) (rsize (RNTIMES r 0)) = 1 + rsize r"
  by auto

lemma ntimes_closed_form_bounded_nil:
  assumes "\<forall>s. rsize (rders_simp r s) \<le> N"
  shows " rsize (rders_simp (RNTIMES r 0) s) \<le> 1 + rsize r"
  using assms ntimes_closed_form_bounded1 by auto

lemma ntimes_ineq1:
  shows "(rsize (RNTIMES r n)) \<ge> 1 + rsize r"
  by simp

lemma ntimes_ineq2:
  shows "1 + rsize r \<le>
max ((Suc (card (sizeNregex (Suc (N + rsize (RNTIMES r n))))) * (Suc (N + rsize (RNTIMES r n))))) (rsize (RNTIMES r n))"
  by (meson le_max_iff_disj ntimes_ineq1)

lemma ntimes_closed_form_bounded:
  assumes "\<forall>s. rsize (rders_simp r s) \<le> N"
  shows "rsize (rders_simp (RNTIMES r (Suc n)) s) \<le>
           max ((Suc (card (sizeNregex (Suc (N + rsize (RNTIMES r n))))) * (Suc (N + rsize (RNTIMES r n))))) (rsize (RNTIMES r n))"
proof(cases s)
  case Nil
  then show "rsize (rders_simp (RNTIMES r (Suc n)) s)
    \<le> max (Suc (card (sizeNregex (Suc (N + rsize (RNTIMES r n))))) * Suc (N + rsize (RNTIMES r n))) (rsize (RNTIMES r n))"
    by simp
next
  case (Cons a list)

  then have "rsize (rders_simp (RNTIMES r (Suc n)) s) =
             rsize (rsimp (RALTS ((map (optermsimp r)    (nupdates list r [Some ([a], n)])))))"
    using ntimes_closed_form by fastforce
  also have "... \<le> Suc (rsizes (rdistinct ((map (optermsimp r) (nupdates list r [Some ([a], n)]))) {}))"
    using alts_simp_control by blast
  also have "... \<le> Suc (card (sizeNregex (Suc (N + rsize (RNTIMES r n))))) * (Suc (N + rsize (RNTIMES r n)))"
    using ntimes_control_bounded[OF assms]
    by (metis add_mono le_add1 mult_Suc plus_1_eq_Suc)
  also have "... \<le> max (Suc (card (sizeNregex (Suc (N + rsize (RNTIMES r n))))) * Suc (N + rsize (RNTIMES r n))) (rsize (RNTIMES r n))"
    by simp
  finally show ?thesis by simp
qed

lemma ntimes_closed_form_boundedA:
  assumes "\<forall>s. rsize (rders_simp r s) \<le> N"
  shows "\<exists>N'. \<forall>s. rsize (rders_simp (RNTIMES r n) s) \<le> N'"
  apply(case_tac n)
  using assms ntimes_closed_form_bounded_nil apply blast
  using assms ntimes_closed_form_bounded by blast

lemma star_closed_form_nonempty_bounded:
  assumes "\<forall>s. rsize (rders_simp r s) \<le> N" and "s \<noteq> []"
  shows "rsize (rders_simp (RSTAR r) s) \<le>
            ((Suc (card (sizeNregex (Suc (N + rsize (RSTAR r))))) * (Suc (N + rsize (RSTAR r))))) "
proof(cases s)
  case Nil
  then show ?thesis
    using local.Nil by fastforce
next
  case (Cons a list)
  then have "rsize (rders_simp (RSTAR r) s) =
    rsize (rsimp (RALTS ((map (\<lambda>s1. RSEQ (rders_simp r s1) (RSTAR r)) (star_updates list r [[a]])))))"
    using star_closed_form by fastforce
  also have "... \<le> Suc (rsizes (rdistinct (map (\<lambda>s1. RSEQ (rders_simp r s1) (RSTAR r)) (star_updates list r [[a]])) {}))"
    using alts_simp_control by blast
  also have "... \<le> Suc (card (sizeNregex (Suc (N + rsize (RSTAR r))))) * (Suc (N + rsize (RSTAR r)))"
    by (smt (z3) add_mono_thms_linordered_semiring(1) assms(1) le_add1 map_eq_conv mult_Suc plus_1_eq_Suc star_control_bounded)
  also have "... \<le> max (Suc (card (sizeNregex (Suc (N + rsize (RSTAR r))))) * Suc (N + rsize (RSTAR r))) (rsize (RSTAR r))"
    by simp
  finally show ?thesis by simp
qed

lemma seq_estimate_bounded:
  assumes "\<forall>s. rsize (rders_simp r1 s) \<le> N1"
      and "\<forall>s. rsize (rders_simp r2 s) \<le> N2"
  shows
    "rsizes (rdistinct (RSEQ (rders_simp r1 s) r2 # map (rders_simp r2) (vsuf s r1)) {})
       \<le> (Suc (N1 + (rsize r2)) + (N2 * card (sizeNregex N2)))"
proof -
  have a: "rsizes (rdistinct (map (rders_simp r2) (vsuf s r1)) {}) \<le> N2 * card (sizeNregex N2)"
    by (metis assms(2) distinct_list_rexp_upto ex_map_conv mult.commute)

  have "rsizes (rdistinct (RSEQ (rders_simp r1 s) r2 # map (rders_simp r2) (vsuf s r1)) {}) \<le>
          rsize (RSEQ (rders_simp r1 s) r2) + rsizes (rdistinct (map (rders_simp r2) (vsuf s r1)) {})"
    using triangle_inequality_distinct by blast
  also have "... \<le> rsize (RSEQ (rders_simp r1 s) r2) + N2 * card (sizeNregex N2)"
    by (simp add: a)
  also have "... \<le> Suc (N1 + (rsize r2) + N2 * card (sizeNregex N2))"
    by (simp add: assms(1))
  finally show ?thesis
    by force
qed

lemma seq_closed_form_bounded2:
  assumes "\<forall>s. rsize (rders_simp r1 s) \<le> N1"
  and     "\<forall>s. rsize (rders_simp r2 s) \<le> N2"
shows "rsize (rders_simp (RSEQ r1 r2) s)
          \<le> max (2 + N1 + (rsize r2) + (N2 * card (sizeNregex N2))) (rsize (RSEQ r1 r2))"
proof(cases s)
  case Nil
  then show "rsize (rders_simp (RSEQ r1 r2) s)
     \<le> max (2 + N1 + (rsize r2) + (N2 * card (sizeNregex N2))) (rsize (RSEQ r1 r2))"
    by simp
next
  case (Cons a list)
  then have "rsize (rders_simp (RSEQ r1 r2) s) =
    rsize (rsimp (RALTS ((RSEQ (rders_simp r1 s) r2) # (map (rders_simp r2) (vsuf s r1)))))"
    using seq_closed_form_variant by (metis list.distinct(1))
  also have "... \<le> Suc (rsizes (rdistinct (RSEQ (rders_simp r1 s) r2 # map (rders_simp r2) (vsuf s r1)) {}))"
    using alts_simp_control by blast
  also have "... \<le> 2 + N1 + (rsize r2) + (N2 * card (sizeNregex N2))"
  using seq_estimate_bounded[OF assms] by auto
  ultimately show "rsize (rders_simp (RSEQ r1 r2) s)
       \<le> max (2 + N1 + (rsize r2) + N2 * card (sizeNregex N2)) (rsize (RSEQ r1 r2))"
    by auto
qed

lemma rders_simp_bounded:
  shows "\<exists>N. \<forall>s. rsize (rders_simp r s) \<le> N"
  apply(induct r)
  apply(rule_tac x = "Suc 0 " in exI)
  using three_easy_cases0 apply force
  using three_easy_cases1 apply blast
  using three_easy_casesC apply blast
  apply(erule exE)+
  apply(rule exI)
  apply(rule allI)
  apply(rule seq_closed_form_bounded2)
  apply(assumption)
  apply(assumption)
  apply (metis alts_closed_form_bounded size_list_estimation')
  using star_closed_form_bounded apply blast
  using ntimes_closed_form_boundedA by blast

unused_thms
export_code rders_simp rsimp rder in Scala module_name Example

end


theory CJ_DDL imports Main            (* Christoph Benzmüller & Xavier Parent & Ali Farjami, 2018  *)

begin (* DDL: Dyadic Deontic Logic by Carmo and Jones *)
 typedecl i (*type for possible worlds*)
 type_synonym \<tau> = "(i\<Rightarrow>bool)"
 type_synonym \<gamma> = "\<tau>\<Rightarrow>\<tau>"
 type_synonym \<rho> = "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>"

 consts av::"i\<Rightarrow>\<tau>" pv::"i\<Rightarrow>\<tau>" ob::"\<tau>\<Rightarrow>(\<tau>\<Rightarrow>bool)" (*accessibility relations*)
            cw::i (*current world*)

 axiomatization where
  ax_3a: "\<forall>w.\<exists>x. av(w)(x)" and ax_4a: "\<forall>w x. av(w)(x) \<longrightarrow> pv(w)(x)" and ax_4b: "\<forall>w. pv(w)(w)" and
  ax_5a: "\<forall>X.\<not>ob(X)(\<lambda>x. False)" and
  ax_5b: "\<forall>X Y Z. (\<forall>w. ((Y(w) \<and> X(w)) \<longleftrightarrow> (Z(w) \<and> X(w)))) \<longrightarrow> (ob(X)(Y) \<longleftrightarrow> ob(X)(Z))" and
  ax_5ca: "\<forall>X \<beta>. ((\<forall>Z. \<beta>(Z) \<longrightarrow> ob(X)(Z)) \<and> (\<exists>Z. \<beta>(Z))) \<longrightarrow>
      (((\<exists>y. ((\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))(y) \<and> X(y))) \<longrightarrow> ob(X)(\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))))" and
  ax_5c: "\<forall>X Y Z. (((\<exists>w. (X(w) \<and> Y(w) \<and> Z(w))) \<and>  ob(X)(Y)  \<and>  ob(X)(Z))  \<longrightarrow>  ob(X)(\<lambda>w. Y(w) \<and> Z(w)))" and
  ax_5d: "\<forall>X Y Z. ((\<forall>w. Y(w) \<longrightarrow> X(w)) \<and> ob(X)(Y) \<and> (\<forall>w. X(w) \<longrightarrow> Z(w)))
                   \<longrightarrow> ob(Z)(\<lambda>w. (Z(w) \<and> \<not>X(w)) \<or> Y(w))" and
  ax_5e: "\<forall>X Y Z. ((\<forall>w. Y(w) \<longrightarrow> X(w)) \<and> ob(X)(Z) \<and> (\<exists>w. Y(w) \<and> Z(w))) \<longrightarrow> ob(Y)(Z)"

 abbreviation ddlneg::\<gamma> ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>A \<equiv> \<lambda>w. \<not>A(w)"
 abbreviation ddland::\<rho> (infixr"\<^bold>\<and>"51) where "A\<^bold>\<and>B \<equiv> \<lambda>w. A(w)\<and>B(w)"
 abbreviation ddlor::\<rho> (infixr"\<^bold>\<or>"50) where "A\<^bold>\<or>B \<equiv> \<lambda>w. A(w)\<or>B(w)"
 abbreviation ddlimp::\<rho> (infixr"\<^bold>\<rightarrow>"49) where "A\<^bold>\<rightarrow>B \<equiv> \<lambda>w. A(w)\<longrightarrow>B(w)"
 abbreviation ddlequiv::\<rho> (infixr"\<^bold>\<leftrightarrow>"48) where "A\<^bold>\<leftrightarrow>B \<equiv> \<lambda>w. A(w)\<longleftrightarrow>B(w)"
 abbreviation ddlbox::\<gamma> ("\<^bold>\<box>") where "\<^bold>\<box>A \<equiv> \<lambda>w.\<forall>v. A(v)"  (*A = (\<lambda>w. True)*)
 abbreviation ddlboxa::\<gamma> ("\<^bold>\<box>\<^sub>a") where "\<^bold>\<box>\<^sub>aA \<equiv> \<lambda>w. (\<forall>x. av(w)(x) \<longrightarrow> A(x))"  (*in all actual worlds*)
 abbreviation ddlboxp::\<gamma> ("\<^bold>\<box>\<^sub>p") where "\<^bold>\<box>\<^sub>pA \<equiv> \<lambda>w. (\<forall>x. pv(w)(x) \<longrightarrow> A(x))" (*in all potential worlds*)
 abbreviation ddldia::\<gamma> ("\<^bold>\<diamond>") where "\<^bold>\<diamond>A \<equiv> \<^bold>\<not>\<^bold>\<box>(\<^bold>\<not>A)"
 abbreviation ddldiaa::\<gamma> ("\<^bold>\<diamond>\<^sub>a") where "\<^bold>\<diamond>\<^sub>aA \<equiv> \<^bold>\<not>\<^bold>\<box>\<^sub>a(\<^bold>\<not>A)"
 abbreviation ddldiap::\<gamma> ("\<^bold>\<diamond>\<^sub>p") where "\<^bold>\<diamond>\<^sub>pA \<equiv> \<^bold>\<not>\<^bold>\<box>\<^sub>p(\<^bold>\<not>A)"
 abbreviation ddlo::\<rho> ("\<^bold>O\<^bold>\<langle>_\<^bold>|_\<^bold>\<rangle>"[52]53) where "\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<equiv> \<lambda>w. ob(A)(B)"  (*it ought to be \<psi>, given \<phi> *)
 abbreviation ddloa::\<gamma>  ("\<^bold>O\<^sub>a") where "\<^bold>O\<^sub>aA \<equiv> \<lambda>w. ob(av(w))(A) \<and> (\<exists>x. av(w)(x) \<and> \<not>A(x))" (*actual obligation*)
 abbreviation ddlop::\<gamma>  ("\<^bold>O\<^sub>p") where "\<^bold>O\<^sub>pA \<equiv> \<lambda>w. ob(pv(w))(A) \<and> (\<exists>x. pv(w)(x) \<and> \<not>A(x))"  (*primary obligation*)
 abbreviation ddltop::\<tau> ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
 abbreviation ddlbot::\<tau> ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"

(*Possibilist Quantification.*)
 abbreviation ddlforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
 abbreviation ddlforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
 abbreviation ddlexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
 abbreviation ddlexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

 abbreviation ddlvalid::"\<tau> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>"[7]105) where "\<lfloor>A\<rfloor> \<equiv> \<forall>w. A w"   (*Global validity*)
 abbreviation ddlvalidcw::"\<tau> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) where "\<lfloor>A\<rfloor>\<^sub>l \<equiv> A cw" (*Local validity (in cw)*)

(* A is obliagtory *)
 abbreviation ddlobl::\<gamma> ("\<^bold>\<circle><_>") where "\<^bold>\<circle><A> \<equiv>  \<^bold>O\<^bold>\<langle>A\<^bold>|\<^bold>\<top>\<^bold>\<rangle>"  (*New syntax: A is obligatory.*)

(* Consistency *)
lemma True nitpick [satisfy,user_axioms,show_all,format=3] oops
end


(*  Title:      FOLP/ex/Classical.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

Classical First-Order Logic.
*)

theory Classical
imports FOLP
begin

schematic_lemma "?p : (P --> Q | R) --> (P-->Q) | (P-->R)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*If and only if*)
schematic_lemma "?p : (P<->Q) <-> (Q<->P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

schematic_lemma "?p : ~ (P <-> ~P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*Sample problems from
  F. J. Pelletier,
  Seventy-Five Problems for Testing Automatic Theorem Provers,
  J. Automated Reasoning 2 (1986), 191-216.
  Errata, JAR 4 (1988), 236-236.

The hardest problems -- judging by experience with several theorem provers,
including matrix ones -- are 34 and 43.
*)

text "Pelletier's examples"
(*1*)
schematic_lemma "?p : (P-->Q)  <->  (~Q --> ~P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*2*)
schematic_lemma "?p : ~ ~ P  <->  P"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*3*)
schematic_lemma "?p : ~(P-->Q) --> (Q-->P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*4*)
schematic_lemma "?p : (~P-->Q)  <->  (~Q --> P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*5*)
schematic_lemma "?p : ((P|Q)-->(P|R)) --> (P|(Q-->R))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*6*)
schematic_lemma "?p : P | ~ P"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*7*)
schematic_lemma "?p : P | ~ ~ ~ P"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*8.  Peirce's law*)
schematic_lemma "?p : ((P-->Q) --> P)  -->  P"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*9*)
schematic_lemma "?p : ((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*10*)
schematic_lemma "?p : (Q-->R) & (R-->P&Q) & (P-->Q|R) --> (P<->Q)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*11.  Proved in each direction (incorrectly, says Pelletier!!)  *)
schematic_lemma "?p : P<->P"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*12.  "Dijkstra's law"*)
schematic_lemma "?p : ((P <-> Q) <-> R)  <->  (P <-> (Q <-> R))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*13.  Distributive law*)
schematic_lemma "?p : P | (Q & R)  <-> (P | Q) & (P | R)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*14*)
schematic_lemma "?p : (P <-> Q) <-> ((Q | ~P) & (~Q|P))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*15*)
schematic_lemma "?p : (P --> Q) <-> (~P | Q)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*16*)
schematic_lemma "?p : (P-->Q) | (Q-->P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*17*)
schematic_lemma "?p : ((P & (Q-->R))-->S) <-> ((~P | Q | S) & (~P | ~R | S))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Classical Logic: examples with quantifiers"

schematic_lemma "?p : (ALL x. P(x) & Q(x)) <-> (ALL x. P(x))  &  (ALL x. Q(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

schematic_lemma "?p : (EX x. P-->Q(x))  <->  (P --> (EX x. Q(x)))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

schematic_lemma "?p : (EX x. P(x)-->Q)  <->  (ALL x. P(x)) --> Q"
  by (tactic "fast_tac @{context} FOLP_cs 1")

schematic_lemma "?p : (ALL x. P(x)) | Q  <->  (ALL x. P(x) | Q)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problems requiring quantifier duplication"

(*Needs multiple instantiation of ALL.*)
schematic_lemma "?p : (ALL x. P(x)-->P(f(x)))  &  P(d)-->P(f(f(f(d))))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

(*Needs double instantiation of the quantifier*)
schematic_lemma "?p : EX x. P(x) --> P(a) & P(b)"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

schematic_lemma "?p : EX z. P(z) --> (ALL x. P(x))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Hard examples with quantifiers"

text "Problem 18"
schematic_lemma "?p : EX y. ALL x. P(y)-->P(x)"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 19"
schematic_lemma "?p : EX x. ALL y z. (P(y)-->Q(z)) --> (P(x)-->Q(x))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 20"
schematic_lemma "?p : (ALL x y. EX z. ALL w. (P(x)&Q(y)-->R(z)&S(w)))
    --> (EX x y. P(x) & Q(y)) --> (EX z. R(z))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 21"
schematic_lemma "?p : (EX x. P-->Q(x)) & (EX x. Q(x)-->P) --> (EX x. P<->Q(x))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 22"
schematic_lemma "?p : (ALL x. P <-> Q(x))  -->  (P <-> (ALL x. Q(x)))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 23"
schematic_lemma "?p : (ALL x. P | Q(x))  <->  (P | (ALL x. Q(x)))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 24"
schematic_lemma "?p : ~(EX x. S(x)&Q(x)) & (ALL x. P(x) --> Q(x)|R(x)) &
     (~(EX x. P(x)) --> (EX x. Q(x))) & (ALL x. Q(x)|R(x) --> S(x))
    --> (EX x. P(x)&R(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 25"
schematic_lemma "?p : (EX x. P(x)) &
       (ALL x. L(x) --> ~ (M(x) & R(x))) &
       (ALL x. P(x) --> (M(x) & L(x))) &
       ((ALL x. P(x)-->Q(x)) | (EX x. P(x)&R(x)))
   --> (EX x. Q(x)&P(x))"
  oops

text "Problem 26"
schematic_lemma "?u : ((EX x. p(x)) <-> (EX x. q(x))) &
     (ALL x. ALL y. p(x) & q(y) --> (r(x) <-> s(y)))
  --> ((ALL x. p(x)-->r(x)) <-> (ALL x. q(x)-->s(x)))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 27"
schematic_lemma "?p : (EX x. P(x) & ~Q(x)) &
              (ALL x. P(x) --> R(x)) &
              (ALL x. M(x) & L(x) --> P(x)) &
              ((EX x. R(x) & ~ Q(x)) --> (ALL x. L(x) --> ~ R(x)))
          --> (ALL x. M(x) --> ~L(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 28.  AMENDED"
schematic_lemma "?p : (ALL x. P(x) --> (ALL x. Q(x))) &
        ((ALL x. Q(x)|R(x)) --> (EX x. Q(x)&S(x))) &
        ((EX x. S(x)) --> (ALL x. L(x) --> M(x)))
    --> (ALL x. P(x) & L(x) --> M(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 29.  Essentially the same as Principia Mathematica *11.71"
schematic_lemma "?p : (EX x. P(x)) & (EX y. Q(y))
    --> ((ALL x. P(x)-->R(x)) & (ALL y. Q(y)-->S(y))   <->
         (ALL x y. P(x) & Q(y) --> R(x) & S(y)))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 30"
schematic_lemma "?p : (ALL x. P(x) | Q(x) --> ~ R(x)) &
        (ALL x. (Q(x) --> ~ S(x)) --> P(x) & R(x))
    --> (ALL x. S(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 31"
schematic_lemma "?p : ~(EX x. P(x) & (Q(x) | R(x))) &
        (EX x. L(x) & P(x)) &
        (ALL x. ~ R(x) --> M(x))
    --> (EX x. L(x) & M(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 32"
schematic_lemma "?p : (ALL x. P(x) & (Q(x)|R(x))-->S(x)) &
        (ALL x. S(x) & R(x) --> L(x)) &
        (ALL x. M(x) --> R(x))
    --> (ALL x. P(x) & M(x) --> L(x))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 33"
schematic_lemma "?p : (ALL x. P(a) & (P(x)-->P(b))-->P(c))  <->
     (ALL x. (~P(a) | P(x) | P(c)) & (~P(a) | ~P(b) | P(c)))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 35"
schematic_lemma "?p : EX x y. P(x,y) -->  (ALL u v. P(u,v))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 36"
schematic_lemma
"?p : (ALL x. EX y. J(x,y)) &
      (ALL x. EX y. G(x,y)) &
      (ALL x y. J(x,y) | G(x,y) --> (ALL z. J(y,z) | G(y,z) --> H(x,z)))
  --> (ALL x. EX y. H(x,y))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 37"
schematic_lemma "?p : (ALL z. EX w. ALL x. EX y.
           (P(x,z)-->P(y,w)) & P(y,z) & (P(y,w) --> (EX u. Q(u,w)))) &
        (ALL x z. ~P(x,z) --> (EX y. Q(y,z))) &
        ((EX x y. Q(x,y)) --> (ALL x. R(x,x)))
    --> (ALL x. EX y. R(x,y))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 39"
schematic_lemma "?p : ~ (EX x. ALL y. F(y,x) <-> ~F(y,y))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 40.  AMENDED"
schematic_lemma "?p : (EX y. ALL x. F(x,y) <-> F(x,x)) -->
              ~(ALL x. EX y. ALL z. F(z,y) <-> ~ F(z,x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 41"
schematic_lemma "?p : (ALL z. EX y. ALL x. f(x,y) <-> f(x,z) & ~ f(x,x))
          --> ~ (EX z. ALL x. f(x,z))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 44"
schematic_lemma "?p : (ALL x. f(x) -->
              (EX y. g(y) & h(x,y) & (EX y. g(y) & ~ h(x,y))))  &
              (EX x. j(x) & (ALL y. g(y) --> h(x,y)))
              --> (EX x. j(x) & ~f(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problems (mainly) involving equality or functions"

text "Problem 48"
schematic_lemma "?p : (a=b | c=d) & (a=c | b=d) --> a=d | b=c"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 50"
(*What has this to do with equality?*)
schematic_lemma "?p : (ALL x. P(a,x) | (ALL y. P(x,y))) --> (EX x. ALL y. P(x,y))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 56"
schematic_lemma
 "?p : (ALL x. (EX y. P(y) & x=f(y)) --> P(x)) <-> (ALL x. P(x) --> P(f(x)))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 57"
schematic_lemma
"?p : P(f(a,b), f(b,c)) & P(f(b,c), f(a,c)) &
      (ALL x y z. P(x,y) & P(y,z) --> P(x,z))    -->   P(f(a,b), f(a,c))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 58  NOT PROVED AUTOMATICALLY"
schematic_lemma
  notes f_cong = subst_context [where t = f]
  shows "?p : (ALL x y. f(x)=g(y)) --> (ALL x y. f(f(x))=f(g(y)))"
  by (tactic {* fast_tac @{context} (FOLP_cs addSIs [@{thm f_cong}]) 1 *})

text "Problem 59"
schematic_lemma "?p : (ALL x. P(x) <-> ~P(f(x))) --> (EX x. P(x) & ~P(f(x)))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 60"
schematic_lemma "?p : ALL x. P(x,f(x)) <-> (EX y. (ALL z. P(z,y) --> P(z,f(x))) & P(x,y))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

end


(*
  Title:    HOL/Library/Complex_Order.thy
  Author:   Dominique Unruh, University of Tartu

  Instantiation of complex numbers as an ordered set.
*)

theory Complex_Order
  imports Complex_MainRLT
begin

instantiation complex :: order begin

definition \<open>x < y \<longleftrightarrow> Re x < Re y \<and> Im x = Im y\<close>
definition \<open>x \<le> y \<longleftrightarrow> Re x \<le> Re y \<and> Im x = Im y\<close>

instance
  apply standard
  by (auto simp: less_complex_def less_eq_complex_def complex_eq_iff)
end

lemma nonnegative_complex_is_real: \<open>(x::complex) \<ge> 0 \<Longrightarrow> x \<in> \<real>\<close>
  by (simp add: complex_is_Real_iff less_eq_complex_def)

lemma complex_is_real_iff_compare0: \<open>(x::complex) \<in> \<real> \<longleftrightarrow> x \<le> 0 \<or> x \<ge> 0\<close>
  using complex_is_Real_iff less_eq_complex_def by auto

instance complex :: ordered_comm_ring
  apply standard
  by (auto simp: less_complex_def less_eq_complex_def complex_eq_iff mult_left_mono mult_right_mono)

instance complex :: ordered_real_vector
  apply standard
  by (auto simp: less_complex_def less_eq_complex_def mult_left_mono mult_right_mono)

instance complex :: ordered_cancel_comm_semiring
  by standard

end


(* Author: Lei Yu, University of Cambridge
   Author: Fabian Hellauer
           Fabian Immler
*)

section \<open>Proofs of Properties about Floating Point Arithmetic\<close>

theory IEEE_Properties
imports IEEE
begin

subsection \<open>Theorems derived from definitions\<close>

lemma valof_eq:
  "valof x =
    (if exponent x = 0
       then (- 1) ^ sign x * (2 / 2 ^ bias TYPE(('a, 'b) float)) *
            (real (fraction x) / 2 ^ LENGTH('b))
       else (- 1) ^ sign x * (2 ^ exponent x / 2 ^ bias TYPE(('a, 'b) float)) *
            (1 + real (fraction x) / 2 ^ LENGTH('b)))"
  for x::"('a, 'b) float"
  unfolding Let_def
  by transfer (auto simp: bias_def divide_simps unat_eq_0)

lemma exponent_le [simp]:
  \<open>exponent a \<le> mask LENGTH('a)\<close> for a :: \<open>('a, _) float\<close>
  by transfer (auto simp add: of_nat_mask_eq intro: word_unat_less_le split: prod.split)

lemma exponent_not_less [simp]:
  \<open>\<not> mask LENGTH('a) < IEEE.exponent a\<close> for a :: \<open>('a, _) float\<close>
  by (simp add: not_less)

lemma infinity_simps:
  "sign (plus_infinity::('e, 'f)float) = 0"
  "sign (minus_infinity::('e, 'f)float) = 1"
  "exponent (plus_infinity::('e, 'f)float) = emax TYPE(('e, 'f)float)"
  "exponent (minus_infinity::('e, 'f)float) = emax TYPE(('e, 'f)float)"
  "fraction (plus_infinity::('e, 'f)float) = 0"
  "fraction (minus_infinity::('e, 'f)float) = 0"
  subgoal by transfer auto
  subgoal by transfer auto
  subgoal by transfer (simp add: emax_def mask_eq_exp_minus_1)
  subgoal by transfer (simp add: emax_def mask_eq_exp_minus_1)
  subgoal by transfer auto
  subgoal by transfer auto
  done

lemma zero_simps:
  "sign (0::('e, 'f)float) = 0"
  "sign (- 0::('e, 'f)float) = 1"
  "exponent (0::('e, 'f)float) = 0"
  "exponent (- 0::('e, 'f)float) = 0"
  "fraction (0::('e, 'f)float) = 0"
  "fraction (- 0::('e, 'f)float) = 0"
  subgoal by transfer auto
  subgoal by transfer auto
  subgoal by transfer auto
  subgoal by transfer auto
  subgoal by transfer auto
  subgoal by transfer auto
  done

lemma emax_eq: "emax x = 2 ^ LENGTH('e) - 1"
  for x::"('e, 'f)float itself"
  by (simp add: emax_def unsigned_minus_1_eq_mask mask_eq_exp_minus_1)

lemma topfloat_simps:
  "sign (topfloat::('e, 'f)float) = 0"
  "exponent (topfloat::('e, 'f)float) = emax TYPE(('e, 'f)float) - 1"
  "fraction (topfloat::('e, 'f)float) = 2 ^ (fracwidth TYPE(('e, 'f)float)) - 1"
  and bottomfloat_simps:
  "sign (bottomfloat::('e, 'f)float) = 1"
  "exponent (bottomfloat::('e, 'f)float) = emax TYPE(('e, 'f)float) - 1"
  "fraction (bottomfloat::('e, 'f)float) = 2 ^ (fracwidth TYPE(('e, 'f)float)) - 1"
  subgoal by transfer simp
  subgoal by transfer (simp add: emax_eq take_bit_minus_small_eq nat_diff_distrib nat_power_eq)
  subgoal by transfer (simp add: unsigned_minus_1_eq_mask mask_eq_exp_minus_1)
  subgoal by transfer simp
  subgoal by transfer (simp add: emax_eq take_bit_minus_small_eq nat_diff_distrib nat_power_eq)
  subgoal by transfer (simp add: unsigned_minus_1_eq_mask mask_eq_exp_minus_1)
  done

lemmas float_defs =
  is_finite_def is_infinity_def is_zero_def is_nan_def
  is_normal_def is_denormal_def valof_eq
  less_eq_float_def less_float_def
  flt_def fgt_def fle_def fge_def feq_def
  fcompare_def
  infinity_simps
  zero_simps
  topfloat_simps
  bottomfloat_simps
  float_eq_def

lemma float_cases: "is_nan a \<or> is_infinity a \<or> is_normal a \<or> is_denormal a \<or> is_zero a"
  by (auto simp add: float_defs not_less le_less emax_def unsigned_minus_1_eq_mask)

lemma float_cases_finite: "is_nan a \<or> is_infinity a \<or> is_finite a"
  by (simp add: float_cases is_finite_def)

lemma float_zero1[simp]: "is_zero 0"
  unfolding float_defs
  by transfer auto

lemma float_zero2[simp]: "is_zero (- x) \<longleftrightarrow> is_zero x"
  unfolding float_defs
  by transfer auto

lemma emax_pos[simp]: "0 < emax x" "emax x \<noteq> 0"
  by (auto simp: emax_def)

text \<open>The types of floating-point numbers are mutually distinct.\<close>
lemma float_distinct:
  "\<not> (is_nan a \<and> is_infinity a)"
  "\<not> (is_nan a \<and> is_normal a)"
  "\<not> (is_nan a \<and> is_denormal a)"
  "\<not> (is_nan a \<and> is_zero a)"
  "\<not> (is_infinity a \<and> is_normal a)"
  "\<not> (is_infinity a \<and> is_denormal a)"
  "\<not> (is_infinity a \<and> is_zero a)"
  "\<not> (is_normal a \<and> is_denormal a)"
  "\<not> (is_denormal a \<and> is_zero a)"
  by (auto simp: float_defs)

lemma denormal_imp_not_zero: "is_denormal f \<Longrightarrow> \<not>is_zero f"
  by (simp add: is_denormal_def is_zero_def)

lemma normal_imp_not_zero: "is_normal f \<Longrightarrow> \<not>is_zero f"
  by (simp add: is_normal_def is_zero_def)

lemma normal_imp_not_denormal: "is_normal f \<Longrightarrow> \<not>is_denormal f"
  by (simp add: is_normal_def is_denormal_def)

lemma denormal_zero[simp]: "\<not>is_denormal 0" "\<not>is_denormal minus_zero"
  using denormal_imp_not_zero float_zero1 float_zero2 by blast+

lemma normal_zero[simp]: "\<not>is_normal 0" "\<not>is_normal minus_zero"
  using normal_imp_not_zero float_zero1 float_zero2 by blast+

lemma float_distinct_finite: "\<not> (is_nan a \<and> is_finite a)" "\<not>(is_infinity a \<and> is_finite a)"
  by (auto simp: float_defs)

lemma finite_infinity: "is_finite a \<Longrightarrow> \<not> is_infinity a"
  by (auto simp: float_defs)

text \<open>For every real number, the floating-point numbers closest to it always exist.\<close>
lemma is_closest_exists:
  fixes v :: "('e, 'f)float \<Rightarrow> real"
    and s :: "('e, 'f)float set"
  assumes finite: "finite s"
    and non_empty: "s \<noteq> {}"
  shows "\<exists>a. is_closest v s x a"
  using finite non_empty
proof (induct s rule: finite_induct)
  case empty
  then show ?case by simp
next
  case (insert z s)
  show ?case
  proof (cases "s = {}")
    case True
    then have "is_closest v (insert z s) x z"
      by (auto simp: is_closest_def)
    then show ?thesis by metis
  next
    case False
    then obtain a where a: "is_closest v s x a"
      using insert by metis
    then show ?thesis
    proof (cases "\<bar>v a - x\<bar>" "\<bar>v z - x\<bar>" rule: le_cases)
      case le
      then show ?thesis
        by (metis insert_iff a is_closest_def)
    next
      case ge
      have "\<forall>b. b \<in> s \<longrightarrow> \<bar>v a - x\<bar> \<le> \<bar>v b - x\<bar>"
        by (metis a is_closest_def)
      then have "\<forall>b. b \<in> insert z s \<longrightarrow> \<bar>v z - x\<bar> \<le> \<bar>v b - x\<bar>"
        by (metis eq_iff ge insert_iff order.trans)
      then show ?thesis using is_closest_def a
        by (metis insertI1)
    qed
  qed
qed

lemma closest_is_everything:
  fixes v :: "('e, 'f)float \<Rightarrow> real"
    and s :: "('e, 'f)float set"
  assumes finite: "finite s"
    and non_empty: "s \<noteq> {}"
  shows "is_closest v s x (closest v p s x) \<and>
    ((\<exists>b. is_closest v s x b \<and> p b) \<longrightarrow> p (closest v p s x))"
  unfolding closest_def
  by (rule someI_ex) (metis assms is_closest_exists [of s v x])

lemma closest_in_set:
  fixes v :: "('e, 'f)float \<Rightarrow> real"
  assumes "finite s" and "s \<noteq> {}"
  shows "closest v p s x \<in> s"
  by (metis assms closest_is_everything is_closest_def)

lemma closest_is_closest_finite:
  fixes v :: "('e, 'f)float \<Rightarrow> real"
  assumes "finite s" and "s \<noteq> {}"
  shows "is_closest v s x (closest v p s x)"
  by (metis closest_is_everything assms)

instance float::(len, len) finite proof qed (transfer, simp)

lemma closest_is_closest:
  fixes v :: "('e, 'f)float \<Rightarrow> real"
  assumes "s \<noteq> {}"
  shows "is_closest v s x (closest v p s x)"
  by (rule closest_is_closest_finite) (auto simp: assms)

subsection \<open>Properties about ordering and bounding\<close>

text \<open>Lifting of non-exceptional comparisons.\<close>
lemma float_lt [simp]:
  assumes "is_finite a" "is_finite b"
  shows "a < b \<longleftrightarrow> valof a < valof b"
proof
  assume "valof a < valof b"
  moreover have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms by (auto simp: finite_nan finite_infinity)
  ultimately have "fcompare a b = Lt"
    by (auto simp add: is_infinity_def is_nan_def valof_def fcompare_def)
  then show "a < b" by (auto simp: float_defs)
next
  assume "a < b"
  then have lt: "fcompare a b = Lt"
    by (simp add: float_defs)
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms by (auto simp: finite_nan finite_infinity)
  then show "valof a < valof b"
    using lt assms
    by (simp add: fcompare_def is_nan_def is_infinity_def valof_def split: if_split_asm)
qed

lemma float_eq [simp]:
  assumes "is_finite a" "is_finite b"
  shows "a \<doteq> b \<longleftrightarrow> valof a = valof b"
proof
  assume *: "valof a = valof b"
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms float_distinct_finite by auto
  with * have "fcompare a b = Eq"
    by (auto simp add: is_infinity_def is_nan_def valof_def fcompare_def)
  then show "a \<doteq> b" by (auto simp: float_defs)
next
  assume "a \<doteq> b"
  then have eq: "fcompare a b = Eq"
    by (simp add: float_defs)
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms float_distinct_finite by auto
  then show "valof a = valof b"
    using eq assms
    by (simp add: fcompare_def is_nan_def is_infinity_def valof_def split: if_split_asm)
qed

lemma float_le [simp]:
  assumes "is_finite a" "is_finite b"
  shows "a \<le> b \<longleftrightarrow> valof a \<le> valof b"
proof -
  have "a \<le> b \<longleftrightarrow>  a < b \<or> a \<doteq> b"
    by (auto simp add: float_defs)
  then show ?thesis
    by (auto simp add: assms)
qed

text \<open>Reflexivity of equality for non-NaNs.\<close>
lemma float_eq_refl [simp]: "a \<doteq> a \<longleftrightarrow> \<not> is_nan a"
  by (auto simp: float_defs)

text \<open>Properties about Ordering.\<close>
lemma float_lt_trans: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite c \<Longrightarrow> a < b \<Longrightarrow> b < c \<Longrightarrow> a < c"
  by (auto simp: le_trans)

lemma float_le_less_trans: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite c \<Longrightarrow> a \<le> b \<Longrightarrow> b < c \<Longrightarrow> a < c"
  by (auto simp: le_trans)

lemma float_le_trans: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite c \<Longrightarrow> a \<le> b \<Longrightarrow> b \<le> c \<Longrightarrow> a \<le> c"
  by (auto simp: le_trans)

lemma float_le_neg: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> \<not> a < b \<longleftrightarrow> b \<le> a"
  by auto

text \<open>Properties about bounding.\<close>

lemma float_le_infinity [simp]: "\<not> is_nan a \<Longrightarrow> a \<le> plus_infinity"
  unfolding float_defs
  by auto

lemma zero_le_topfloat[simp]: "0 \<le> topfloat" "- 0 \<le> topfloat"
  by (auto simp: float_defs field_simps power_gt1_lemma of_nat_diff mask_eq_exp_minus_1)

lemma LENGTH_contr:
  "Suc 0 < LENGTH('e) \<Longrightarrow> 2 ^ LENGTH('e::len) \<le> Suc (Suc 0) \<Longrightarrow> False"
  by (metis le_antisym len_gt_0 n_less_equal_power_2 not_less_eq numeral_2_eq_2 one_le_numeral
      self_le_power)

lemma valof_topfloat: "valof (topfloat::('e, 'f)float) = largest TYPE(('e, 'f)float)"
  if "LENGTH('e) > 1"
  using that LENGTH_contr
  by (auto simp add: emax_eq largest_def divide_simps float_defs of_nat_diff mask_eq_exp_minus_1)

lemma float_frac_le: "fraction a \<le> 2^LENGTH('f) - 1"
  for a::"('e, 'f)float"
  unfolding float_defs
  using less_Suc_eq_le
  by transfer fastforce

lemma float_exp_le: "is_finite a \<Longrightarrow> exponent a \<le> emax TYPE(('e, 'f)float) - 1"
  for a::"('e, 'f)float"
  unfolding float_defs
  by auto

lemma float_sign_le: "(-1::real)^(sign a) = 1 \<or> (-1::real)^(sign a) = -1"
  by (metis neg_one_even_power neg_one_odd_power)

lemma exp_less: "a \<le> b \<Longrightarrow> (2::real)^a \<le> 2^b" for a b :: nat
  by auto

lemma div_less: "a \<le> b \<and> c > 0 \<Longrightarrow> a/c \<le> b/c" for a b c :: "'a::linordered_field"
  by (metis divide_le_cancel less_asym)

lemma finite_topfloat: "is_finite topfloat"
  unfolding float_defs
  by auto

lemmas float_leI = float_le[THEN iffD2]

lemma factor_minus: "x * a - x = x * (a - 1)"
  for x a::"'a::comm_semiring_1_cancel"
  by (simp add: algebra_simps)

lemma real_le_power_numeral_diff: "real a \<le> numeral b ^ n - 1 \<longleftrightarrow> a \<le> numeral b ^ n - 1"
  by (metis (mono_tags, lifting) of_nat_1 of_nat_diff of_nat_le_iff of_nat_numeral
      one_le_numeral one_le_power semiring_1_class.of_nat_power)

definition denormal_exponent::"('e, 'f)float itself \<Rightarrow> int" where
  "denormal_exponent x = 1 - (int (LENGTH('f)) + int (bias TYPE(('e, 'f)float)))"

definition normal_exponent::"('e, 'f)float \<Rightarrow> int" where
  "normal_exponent x = int (exponent x) - int (bias TYPE(('e, 'f)float)) - int (LENGTH('f))"

definition denormal_mantissa::"('e, 'f)float \<Rightarrow> int" where
  "denormal_mantissa x = (-1::int)^sign x * int (fraction x)"

definition normal_mantissa::"('e, 'f)float \<Rightarrow> int" where
  "normal_mantissa x = (-1::int)^sign x * (2^LENGTH('f) + int (fraction x))"

lemma unat_one_word_le: "unat a \<le> Suc 0" for a::"1 word"
  using unat_lt2p[of a]
  by auto

lemma one_word_le: "a \<le> 1" for a::"1 word"
  by (auto simp: word_le_nat_alt unat_one_word_le)

lemma sign_cases[case_names pos neg]:
  obtains "sign x = 0" | "sign x = 1"
proof cases
  assume "sign x = 0"
  then show ?thesis ..
next
  assume "sign x \<noteq> 0"
  have "sign x \<le> 1"
    by transfer (auto simp: unat_one_word_le)
  then have "sign x = 1" using \<open>sign x \<noteq> 0\<close>
    by auto
  then show ?thesis ..
qed

lemma is_infinity_cases:
  assumes "is_infinity x"
  obtains "x = plus_infinity" | "x = minus_infinity"
proof (cases rule: sign_cases[of x])
  assume "sign x = 0"
  then have "x = plus_infinity" using assms
    apply (unfold float_defs)
    apply transfer
    apply (auto simp add: unat_eq_of_nat emax_def of_nat_mask_eq)
    done
  then show ?thesis ..
next
  assume "sign x = 1"
  then have "x = minus_infinity" using assms
    apply (unfold float_defs)
    apply transfer
    apply (auto simp add: unat_eq_of_nat emax_def of_nat_mask_eq)
    done
  then show ?thesis ..
qed

lemma is_zero_cases:
  assumes "is_zero x"
  obtains "x = 0" | "x = - 0"
proof (cases rule: sign_cases[of x])
  assume "sign x = 0"
  then have "x = 0" using assms
    unfolding float_defs
    by transfer (auto simp: emax_def unat_eq_0)
  then show ?thesis ..
next
  assume "sign x = 1"
  then have "x = minus_zero" using assms
    unfolding float_defs
    by transfer (auto simp: emax_def unat_eq_of_nat)
  then show ?thesis ..
qed

lemma minus_minus_float[simp]: "- (-f) = f" for f::"('e, 'f)float"
  by transfer auto

lemma sign_minus_float: "sign (-f) = (1 - sign f)" for f::"('e, 'f)float"
  by transfer (auto simp: unat_eq_1 one_word_le unat_sub)

lemma exponent_uminus[simp]: "exponent (- f) = exponent f" by transfer auto
lemma fraction_uminus[simp]: "fraction (- f) = fraction f" by transfer auto

lemma is_normal_minus_float[simp]: "is_normal (-f) = is_normal f" for f::"('e, 'f)float"
  by (auto simp: is_normal_def)

lemma is_denormal_minus_float[simp]: "is_denormal (-f) = is_denormal f" for f::"('e, 'f)float"
  by (auto simp: is_denormal_def)

lemma bitlen_normal_mantissa:
  "bitlen (abs (normal_mantissa x)) = Suc LENGTH('f)" for x::"('e, 'f)float"
proof -
  have "fraction x < 2 ^ LENGTH('f)"
    using float_frac_le[of x]
    by (metis One_nat_def Suc_pred le_imp_less_Suc pos2 zero_less_power)
  moreover have "- int (fraction x) \<le> 2 ^ LENGTH('f)"
    using negative_zle_0 order_trans zero_le_numeral zero_le_power by blast
  ultimately show ?thesis
    by (cases x rule: sign_cases)
      (auto simp: bitlen_le_iff_power bitlen_ge_iff_power nat_add_distrib
        normal_mantissa_def intro!: antisym)
qed

lemma less_int_natI: "x < y" if "0 \<le> x" "nat x < nat y"
  using that by arith

lemma normal_exponent_bounds_int:
  "2 - 2 ^ (LENGTH('e) - 1) - int LENGTH('f) \<le> normal_exponent x"
  "normal_exponent x \<le> 2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1"
  if "is_normal x"
  for x::"('e, 'f)float"
  using that
   apply (auto simp add: normal_exponent_def is_normal_def emax_eq bias_def diff_le_eq diff_less_eq
    mask_eq_exp_minus_1 of_nat_diff simp flip: zless_nat_eq_int_zless power_Suc)
  apply (simp flip: power_Suc mask_eq_exp_minus_1 add: nat_mask_eq)
  apply (simp add: mask_eq_exp_minus_1)
  done

lemmas of_int_leI = of_int_le_iff[THEN iffD2]

lemma normal_exponent_bounds_real:
  "2 - 2 ^ (LENGTH('e) - 1) - real LENGTH('f) \<le> normal_exponent x"
  "normal_exponent x \<le> 2 ^ (LENGTH('e) - 1) - real LENGTH('f) - 1"
  if "is_normal x"
  for x::"('e, 'f)float"
  subgoal by (rule order_trans[OF _ of_int_leI[OF normal_exponent_bounds_int(1)[OF that]]]) auto
  subgoal by (rule order_trans[OF of_int_leI[OF normal_exponent_bounds_int(2)[OF that]]]) auto
  done

lemma float_eqI:
  "x = y" if "sign x = sign y" "fraction x = fraction y" "exponent x = exponent y"
  using that by transfer (auto simp add: word_unat_eq_iff)

lemma float_induct[induct type:float, case_names normal denormal neg zero infinity nan]:
  fixes a::"('e, 'f)float"
  assumes normal:
    "\<And>x. is_normal x \<Longrightarrow> valof x = normal_mantissa x * 2 powr normal_exponent x \<Longrightarrow> P x"
  assumes denormal:
    "\<And>x. is_denormal x \<Longrightarrow>
      valof x = denormal_mantissa x * 2 powr denormal_exponent TYPE(('e, 'f)float) \<Longrightarrow>
      P x"
  assumes zero: "P 0" "P minus_zero"
  assumes infty: "P plus_infinity" "P minus_infinity"
  assumes nan: "\<And>x. is_nan x \<Longrightarrow> P x"
  shows "P a"
proof -
  from float_cases[of a]
  consider "is_nan a" | "is_infinity a" | "is_normal a" | "is_denormal a" | "is_zero a" by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis by (rule nan)
  next
    case 2
    then consider "a = plus_infinity" | "a = minus_infinity" by (rule is_infinity_cases)
    then show ?thesis
      by cases (auto intro: infty)
  next
    case hyps: 3
    from hyps have "valof a = normal_mantissa a * 2 powr normal_exponent a"
      by (cases a rule: sign_cases)
        (auto simp: valof_eq normal_mantissa_def normal_exponent_def is_normal_def
          powr_realpow[symmetric] powr_diff powr_add field_simps)
    from hyps this show ?thesis
      by (rule normal)
  next
    case hyps: 4
    from hyps have "valof a = denormal_mantissa a * 2 powr denormal_exponent TYPE(('e, 'f)float)"
      by (cases a rule: sign_cases)
        (auto simp: valof_eq denormal_mantissa_def denormal_exponent_def is_denormal_def
          powr_realpow[symmetric] powr_diff powr_add field_simps)
    from hyps this show ?thesis
      by (rule denormal)
  next
    case 5
    then consider "a = 0" | "a = minus_zero" by (rule is_zero_cases)
    then show ?thesis
      by cases (auto intro: zero)
  qed
qed

lemma infinite_infinity[simp]: "\<not> is_finite plus_infinity" "\<not> is_finite minus_infinity"
  by (auto simp: is_finite_def is_normal_def infinity_simps is_denormal_def is_zero_def)

lemma nan_not_finite[simp]: "is_nan x \<Longrightarrow> \<not> is_finite x"
  using float_distinct_finite(1) by blast

lemma valof_nonneg:
  "valof x \<ge> 0" if "sign x = 0" for x::"('e, 'f)float"
  by (auto simp: valof_eq that)

lemma valof_nonpos:
  "valof x \<le> 0" if "sign x = 1" for x::"('e, 'f)float"
  using that
  by (auto simp: valof_eq is_finite_def)

lemma real_le_intI: "x \<le> y" if "floor x \<le> floor y" "x \<in> \<int>" for x y::real
  using that(2,1)
  by (induction rule: Ints_induct) (auto elim!: Ints_induct simp: le_floor_iff)

lemma real_of_int_le_2_powr_bitlenI:
  "real_of_int x \<le> 2 powr n - 1" if "bitlen (abs x) \<le> m" "m \<le> n"
proof -
  have "real_of_int x \<le> abs (real_of_int x)" by simp
  also have "\<dots> < 2 powr (bitlen (abs x))"
    by (rule abs_real_le_2_powr_bitlen)
  finally have "real_of_int x \<le> 2 powr (bitlen (abs x)) - 1"
    by (auto simp: powr_real_of_int bitlen_nonneg intro!: real_le_intI)
  also have "\<dots> \<le> 2 powr m - 1"
    by (simp add: that)
  also have "\<dots> \<le> 2 powr n - 1"
    by (simp add: that)
  finally show ?thesis .
qed

lemma largest_eq:
  "largest TYPE(('e, 'f)float) =
    (2 ^ (LENGTH('f) + 1) - 1) * 2 powr real_of_int (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)"
proof -
  have "2 ^ LENGTH('e) - 1 - 1 = (2::nat) ^ LENGTH('e) - 2"
    by arith
  then have "largest TYPE(('e, 'f)float) =
    (2 ^ (LENGTH('f) + 1) - 1) *
    2 powr (real (2 ^ LENGTH('e) - 2) + 1 - real (2 ^ (LENGTH('e) - 1)) - LENGTH('f))"
    by (auto simp add: largest_def emax_eq bias_def powr_minus field_simps powr_diff powr_add of_nat_diff
      mask_eq_exp_minus_1 simp flip: powr_realpow)
  also
  have "2 ^ LENGTH('e) \<ge> (2::nat)"
    by (simp add: self_le_power)
  then have "(real (2 ^ LENGTH('e) - 2) + 1 - real (2 ^ (LENGTH('e) - 1)) - LENGTH('f)) =
    (real (2 ^ LENGTH('e)) - 2 ^ (LENGTH('e) - 1) - LENGTH('f)) - 1"
    by (auto simp add: of_nat_diff)
  also have "real (2 ^ LENGTH('e)) = 2 ^ LENGTH('e)" by auto
  also have "(2 ^ LENGTH('e) - 2 ^ (LENGTH('e) - 1) - real LENGTH('f) - 1) =
    real_of_int ((2 ^ (LENGTH('e) - 1) - int (LENGTH('f)) - 1))"
    by (simp, subst power_Suc[symmetric], simp)
  finally show ?thesis by simp
qed

lemma bitlen_denormal_mantissa:
  "bitlen (abs (denormal_mantissa x)) \<le> LENGTH('f)" for x::"('e, 'f)float"
proof -
  have "fraction x < 2 ^ LENGTH('f)"
    using float_frac_le[of x]
    by (metis One_nat_def Suc_pred le_imp_less_Suc pos2 zero_less_power)
  moreover have "- int (fraction x) \<le> 2 ^ LENGTH('f)"
    using negative_zle_0 order_trans zero_le_numeral zero_le_power by blast
  ultimately show ?thesis
    by (cases x rule: sign_cases)
      (auto simp: bitlen_le_iff_power denormal_mantissa_def intro!: antisym)
qed

lemma float_le_topfloat:
  fixes a::"('e, 'f)float"
  assumes "is_finite a" "LENGTH('e) > 1"
  shows "a \<le> topfloat"
  using assms(1)
proof (induction a rule: float_induct)
  case (normal x)
  note normal(2)
  also have "real_of_int (normal_mantissa x) * 2 powr real_of_int (normal_exponent x) \<le>
    (2 powr (LENGTH('f) + 1) - 1) * 2 powr (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)"
    using normal_exponent_bounds_real(2)[OF \<open>is_normal x\<close>]
    by (auto intro!: mult_mono real_of_int_le_2_powr_bitlenI
        simp: bitlen_normal_mantissa powr_realpow[symmetric] ge_one_powr_ge_zero)
  also have "\<dots> = largest TYPE(('e, 'f) IEEE.float)"
    unfolding largest_eq
    by (auto simp: powr_realpow powr_add)
  also have "\<dots> = valof (topfloat::('e, 'f) float)"
    using assms
    by (simp add: valof_topfloat)
  finally show ?case
    by (intro float_leI normal finite_topfloat)
next
  case (denormal x)
  note denormal(2)
  also
  have "3 \<le> 2 powr (1 + real (LENGTH('e) - Suc 0))"
  proof -
    have "3 \<le> 2 powr (2::real)" by simp
    also have "\<dots> \<le> 2 powr (1 + real (LENGTH('e) - Suc 0))"
      using assms
      by (subst powr_le_cancel_iff) auto
    finally show ?thesis .
  qed
  then have "real_of_int (denormal_mantissa x) * 2 powr real_of_int (denormal_exponent TYPE(('e, 'f)float)) \<le>
    (2 powr (LENGTH('f) + 1) - 1) * 2 powr (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)"
    using bitlen_denormal_mantissa[of x]
    by (auto intro!: mult_mono real_of_int_le_2_powr_bitlenI
        simp: bitlen_normal_mantissa powr_realpow[symmetric] ge_one_powr_ge_zero mask_eq_exp_minus_1
        denormal_exponent_def bias_def powr_mult_base of_nat_diff)
  also have "\<dots> \<le> largest TYPE(('e, 'f) IEEE.float)"
    unfolding largest_eq
    by (rule mult_mono)
      (auto simp: powr_realpow powr_add power_Suc[symmetric] simp del: power_Suc)
  also have "\<dots> = valof (topfloat::('e, 'f) float)"
    using assms
    by (simp add: valof_topfloat)
  finally show ?case
    by (intro float_leI denormal finite_topfloat)
qed auto

lemma float_val_le_largest:
  "valof a \<le> largest TYPE(('e, 'f)float)"
  if "is_finite a" "LENGTH('e) > 1"
  for a::"('e, 'f)float"
  by (metis that finite_topfloat float_le float_le_topfloat valof_topfloat)

lemma float_val_lt_threshold:
  "valof a < threshold TYPE(('e, 'f)float)"
  if "is_finite a" "LENGTH('e) > 1"
  for a::"('e, 'f)float"
proof -
  have "valof a \<le> largest TYPE(('e, 'f)float)"
    by (rule float_val_le_largest [OF that])
  also have "\<dots> < threshold TYPE(('e, 'f)float)"
    by (auto simp: largest_def threshold_def divide_simps)
  finally show ?thesis .
qed

subsection \<open>Algebraic properties about basic arithmetic\<close>

text \<open>Commutativity of addition.\<close>
lemma
  assumes "is_finite a" "is_finite b"
  shows float_plus_comm_eq: "a + b = b + a"
    and float_plus_comm: "is_finite (a + b) \<Longrightarrow> (a + b) \<doteq> (b + a)"
proof -
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms by (auto simp: finite_nan finite_infinity)
  then show "a + b = b + a"
    by (simp add: float_defs fadd_def plus_float_def add.commute)
  then show "is_finite (a + b) \<Longrightarrow> (a + b) \<doteq> (b + a)"
    by (metis float_eq)
qed

text \<open>The floating-point number a falls into the same category as the negation of \<open>a\<close>.\<close>
lemma is_zero_uminus[simp]: "is_zero (- a) \<longleftrightarrow> is_zero a"
  by (simp add: is_zero_def)

lemma is_infinity_uminus [simp]: "is_infinity (- a) = is_infinity a"
  by (simp add: is_infinity_def)

lemma is_finite_uminus[simp]: "is_finite (- a) \<longleftrightarrow> is_finite a"
  by (simp add: is_finite_def)

lemma is_nan_uminus[simp]: "is_nan (- a) \<longleftrightarrow> is_nan a"
  by (simp add: is_nan_def)

text \<open>The sign of a and the sign of a's negation is different.\<close>
lemma float_neg_sign: "(sign a) \<noteq> (sign (- a))"
  by (cases a rule: sign_cases) (auto simp: sign_minus_float)

lemma valof_uminus:
  assumes "is_finite a"
  shows "valof (- a) = - valof a" (is "?L = ?R")
  by (cases a rule: sign_cases)  (auto simp: valof_eq sign_minus_float)

text \<open>Showing \<open>a + (- b) = a - b\<close>.\<close>
lemma float_neg_add:
  "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite (a - b) \<Longrightarrow> valof a + valof (- b) = valof a - valof b"
  by (simp add: valof_uminus)

lemma float_plus_minus:
  assumes "is_finite a" "is_finite b" "is_finite (a - b)"
  shows "(a + - b) \<doteq> (a - b)"
proof -
  have nab: "\<not> is_nan a" "\<not> is_nan (- b)" "\<not> is_infinity a" "\<not> is_infinity (-  b)"
    using assms by (auto simp: finite_nan finite_infinity)
  have "a - b = (zerosign
        (if is_zero a \<and> is_zero b \<and> sign a \<noteq> sign b then (sign a) else 0)
        (round To_nearest (valof a - valof b)))"
    using nab
    by (auto simp: minus_float_def fsub_def)
  also have "\<dots> =
    (zerosign
        (if is_zero a \<and> is_zero (- b) \<and> sign a = sign (- b) then sign a else 0)
        (round To_nearest (valof a + valof (- b))))"
    using assms
    by (simp add: float_neg_sign1 float_neg_add)
  also have "\<dots> = a + - b"
    using nab by (auto simp: float_defs fadd_def plus_float_def)
  finally show ?thesis
    using assms by (metis float_eq)
qed

lemma finite_bottomfloat: "is_finite bottomfloat"
  by (simp add: finite_topfloat)

lemma bottomfloat_eq_m_largest: "valof (bottomfloat::('e, 'f)float) = - largest TYPE(('e, 'f)float)"
  if "LENGTH('e) > 1"
  using that
  by (auto simp: valof_topfloat valof_uminus finite_topfloat)

lemma float_val_ge_bottomfloat: "valof a \<ge> valof (bottomfloat::('e, 'f)float)"
  if "LENGTH('e) > 1" "is_finite a"
  for a::"('e,'f)float"
proof -
  have "- a \<le> topfloat"
    using that
    by (auto intro: float_le_topfloat)
  then show ?thesis
    using that
    by (auto simp: valof_uminus finite_topfloat)
qed

lemma float_ge_bottomfloat: "is_finite a \<Longrightarrow> a \<ge> bottomfloat"
  if "LENGTH('e) > 1" "is_finite a"
  for a::"('e,'f)float"
  by (metis finite_bottomfloat float_le float_val_ge_bottomfloat that)

lemma float_val_ge_largest:
  fixes a::"('e,'f)float"
  assumes "LENGTH('e) > 1" "is_finite a"
  shows "valof a \<ge> - largest TYPE(('e,'f)float)"
proof -
  have "- largest TYPE(('e,'f)float) = valof (bottomfloat::('e,'f)float)"
    using assms
    by (simp add: bottomfloat_eq_m_largest)
  also have "\<dots> \<le> valof a"
    using assms by (simp add: float_val_ge_bottomfloat)
  finally show ?thesis .
qed

lemma float_val_gt_threshold:
  fixes a::"('e,'f)float"
  assumes "LENGTH('e) > 1" "is_finite a"
  shows "valof a > - threshold TYPE(('e,'f)float)"
proof -
  have largest: "valof a \<ge> -largest TYPE(('e,'f)float)"
    using assms by (metis float_val_ge_largest)
  then have "-largest TYPE(('e,'f)float) > - threshold TYPE(('e,'f)float)"
    by (auto simp: bias_def threshold_def largest_def divide_simps)
  then show ?thesis
    by (metis largest less_le_trans)
qed

text \<open>Showing \<open>abs (- a) = abs a\<close>.\<close>
lemma float_abs [simp]: "\<not> is_nan a \<Longrightarrow> abs (- a) = abs a"
  by (metis IEEE.abs_float_def float_neg_sign1 minus_minus_float zero_simps(1))

lemma neg_zerosign: "- (zerosign s a) = zerosign (1 - s) (- a)"
  by (auto simp: zerosign_def)

subsection \<open>Properties about Rounding Errors\<close>

definition error :: "('e, 'f)float itself \<Rightarrow> real \<Rightarrow> real"
  where "error _ x = valof (round To_nearest x::('e, 'f)float) - x"

lemma bound_at_worst_lemma:
  fixes a::"('e, 'f)float"
  assumes threshold: "\<bar>x\<bar> < threshold TYPE(('e, 'f)float)"
  assumes finite: "is_finite a"
  shows "\<bar>valof (round To_nearest x::('e, 'f)float) - x\<bar> \<le> \<bar>valof a - x\<bar>"
proof -
  have *: "(round To_nearest x::('e,'f)float) =
      closest valof (\<lambda>a. even (fraction a)) {a. is_finite a} x"
    using threshold finite
    by auto
  have "is_closest (valof) {a. is_finite a} x (round To_nearest x::('e,'f)float)"
    using is_finite_nonempty
    unfolding *
    by (intro closest_is_closest) auto
  then show ?thesis
    using finite is_closest_def by (metis mem_Collect_eq)
qed

lemma error_at_worst_lemma:
  fixes a::"('e, 'f)float"
  assumes threshold: "\<bar>x\<bar> < threshold TYPE(('e, 'f)float)"
    and "is_finite a"
  shows "\<bar>error TYPE(('e, 'f)float) x\<bar> \<le> \<bar>valof a - x\<bar> "
  unfolding error_def
  by (rule bound_at_worst_lemma; fact)

lemma error_is_zero [simp]:
  fixes a::"('e, 'f)float"
  assumes "is_finite a" "1 < LENGTH('e)"
  shows "error TYPE(('e, 'f)float) (valof a) = 0"
proof -
  have "\<bar>valof a\<bar> < threshold TYPE(('e, 'f)float)"
    by (metis abs_less_iff minus_less_iff float_val_gt_threshold float_val_lt_threshold assms)
  then show ?thesis
    by (metis abs_le_zero_iff abs_zero diff_self error_at_worst_lemma assms(1))
qed

lemma is_finite_zerosign[simp]: "is_finite (zerosign s a) \<longleftrightarrow> is_finite a"
  by (auto simp: zerosign_def is_finite_def)

lemma is_finite_closest: "is_finite (closest (v::_\<Rightarrow>real) p {a. is_finite a} x)"
  using closest_is_closest[OF is_finite_nonempty, of v x p]
  by (auto simp: is_closest_def)

lemma defloat_float_zerosign_round_finite:
  assumes threshold: "\<bar>x\<bar> < threshold TYPE(('e, 'f)float)"
  shows "is_finite (zerosign s (round To_nearest x::('e, 'f)float))"
proof -
  have "(round To_nearest x::('e, 'f)float) =
      (closest valof (\<lambda>a. even (fraction a)) {a. is_finite a} x)"
    using threshold by (metis (full_types) abs_less_iff leD le_minus_iff round.simps(1))
  then have "is_finite (round To_nearest x::('e, 'f)float)"
    by (metis is_finite_closest)
  then show ?thesis
    using is_finite_zerosign by auto
qed

lemma valof_zero[simp]: "valof 0 = 0" "valof minus_zero = 0"
  by (auto simp add: zerosign_def valof_eq zero_simps)

lemma signzero_zero:
  "is_zero a \<Longrightarrow> valof (zerosign s a) = 0"
  by (auto simp add: zerosign_def)

lemma val_zero: "is_zero a \<Longrightarrow> valof a = 0"
  by (cases a rule: is_zero_cases) auto

lemma float_add:
  fixes a b::"('e, 'f)float"
  assumes "is_finite a"
    and "is_finite b"
    and threshold: "\<bar>valof a + valof b\<bar> < threshold TYPE(('e, 'f)float)"
  shows finite_float_add: "is_finite (a + b)"
    and error_float_add:  "valof (a + b) = valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b)"
proof -
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms float_distinct_finite by auto
  then have ab: "(a + b) =
    (zerosign
      (if is_zero a \<and> is_zero b \<and> sign a = sign b then (sign a) else 0)
      (round To_nearest (valof a + valof b)))"
    using assms by (auto simp add: float_defs fadd_def plus_float_def)
  then show "is_finite ((a + b))"
    by (metis threshold defloat_float_zerosign_round_finite)
  have val_ab: "valof (a + b) =
    valof (zerosign
      (if is_zero a \<and> is_zero b \<and> sign a = sign b then (sign a) else 0)
      (round To_nearest (valof a + valof b)::('e, 'f)float))"
    by (auto simp: ab is_infinity_def is_nan_def valof_def)
  show "valof (a + b) = valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b)"
  proof (cases "is_zero (round To_nearest (valof a + valof b)::('e, 'f)float)")
    case True
    have "valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b) =
        valof (round To_nearest (valof a + valof b)::('e, 'f)float)"
      unfolding error_def
      by simp
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False
    then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

lemma float_sub:
  fixes a b::"('e, 'f)float"
  assumes "is_finite a"
    and "is_finite b"
    and threshold: "\<bar>valof a - valof b\<bar> < threshold TYPE(('e, 'f)float)"
  shows finite_float_sub: "is_finite (a - b)"
    and error_float_sub: "valof (a - b) = valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b)"
proof -
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms by (auto simp: finite_nan finite_infinity)
  then have ab: "a - b =
    (zerosign
      (if is_zero a \<and> is_zero b \<and> sign a \<noteq> sign b then sign a else 0)
      (round To_nearest (valof a - valof b)))"
    using assms by (auto simp add: float_defs fsub_def minus_float_def)
  then show "is_finite (a - b)"
   by (metis threshold defloat_float_zerosign_round_finite)
  have val_ab: "valof (a - b) =
    valof (zerosign
      (if is_zero a \<and> is_zero b \<and> sign a \<noteq> sign b then sign a else 0)
      (round To_nearest (valof a - valof b)::('e, 'f)float))"
    by (auto simp: ab is_infinity_def is_nan_def valof_def)
  show "valof (a - b) = valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b)"
  proof (cases "is_zero (round To_nearest (valof a - valof b)::('e, 'f)float)")
    case True
    have "valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b) =
        valof (round To_nearest (valof a - valof b)::('e, 'f)float)"
      unfolding error_def by simp
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False
    then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

lemma float_mul:
  fixes a b::"('e, 'f)float"
  assumes "is_finite a"
    and "is_finite b"
    and threshold: "\<bar>valof a * valof b\<bar> < threshold TYPE(('e, 'f)float)"
  shows finite_float_mul: "is_finite (a * b)"
    and error_float_mul: "valof (a * b) = valof a * valof b + error TYPE(('e, 'f)float) (valof a * valof b)"
proof -
  have non: "\<not> is_nan a" "\<not> is_nan b" "\<not> is_infinity a" "\<not> is_infinity b"
    using assms float_distinct_finite by auto
  then have ab: "a * b =
    (zerosign (of_bool (sign a \<noteq> sign b))
      (round To_nearest (valof a * valof b)::('e, 'f)float))"
    using assms by (auto simp: float_defs fmul_def times_float_def)
  then show "is_finite (a * b)"
    by (metis threshold defloat_float_zerosign_round_finite)
  have val_ab: "valof (a * b) =
      valof (zerosign (of_bool (sign a \<noteq> sign b))
        (round To_nearest (valof a * valof b)::('e, 'f)float))"
    by (auto simp: ab float_defs of_bool_def)
  show "valof (a * b) = valof a * valof b + error TYPE(('e, 'f)float) (valof a * valof b)"
  proof (cases "is_zero (round To_nearest (valof a * valof b)::('e, 'f)float)")
    case True
    have "valof a * valof b + error TYPE(('e, 'f)float)  (valof a * valof b) =
        valof (round To_nearest (valof a * valof b)::('e, 'f)float)"
      unfolding error_def
      by simp
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

lemma float_div:
  fixes a b::"('e, 'f)float"
  assumes "is_finite a"
    and "is_finite b"
    and not_zero: "\<not> is_zero b"
    and threshold: "\<bar>valof a / valof b\<bar> < threshold TYPE(('e, 'f)float)"
  shows finite_float_div: "is_finite (a / b)"
    and error_float_div: "valof (a / b) = valof a / valof b + error TYPE(('e, 'f)float) (valof a / valof b)"
proof -
  have ab: "a / b =
    (zerosign (of_bool (sign a \<noteq> sign b))
      (round To_nearest (valof a / valof b)))"
     using assms
     by (simp add: divide_float_def fdiv_def finite_infinity finite_nan not_zero float_defs [symmetric])
  then show "is_finite (a / b)"
    by (metis threshold defloat_float_zerosign_round_finite)
  have val_ab: "valof (a / b) =
      valof (zerosign (of_bool (sign a \<noteq> sign b))
        (round To_nearest (valof a / valof b))::('e, 'f)float)"
    by (auto simp: ab float_defs of_bool_def)
  show "valof (a / b) = valof a / valof b + error TYPE(('e, 'f)float)  (valof a / valof b)"
  proof (cases "is_zero (round To_nearest (valof a / valof b)::('e, 'f)float)")
    case True
    have "valof a / valof b + error TYPE(('e, 'f)float) (valof a / valof b) =
        valof (round To_nearest (valof a / valof b)::('e, 'f)float)"
      unfolding error_def
      by simp
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

lemma valof_one[simp]: "valof (1 :: ('e, 'f) float) = of_bool (LENGTH('e) > 1)"
  apply transfer
  apply (auto simp add: bias_def unat_mask_eq simp flip: mask_eq_exp_minus_1)
  apply (simp add: mask_eq_exp_minus_1)
  done

end


section\<open>A pointed version of DC\<close>
theory Pointed_DC imports ZF.AC

begin
txt\<open>This proof of DC is from Moschovakis "Notes on Set Theory"\<close>

consts dc_witness :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i"
primrec
  wit0   : "dc_witness(0,A,a,s,R) = a"
  witrec :"dc_witness(succ(n),A,a,s,R) = s`{x\<in>A. \<langle>dc_witness(n,A,a,s,R),x\<rangle>\<in>R }"

lemma witness_into_A [TC]:
  assumes "a\<in>A"
    "(\<forall>X . X\<noteq>0 \<and> X\<subseteq>A \<longrightarrow> s`X\<in>X)"
    "\<forall>y\<in>A. {x\<in>A. \<langle>y,x\<rangle>\<in>R } \<noteq> 0" "n\<in>nat"
  shows "dc_witness(n, A, a, s, R)\<in>A"
  using \<open>n\<in>nat\<close>
proof(induct n)
  case 0
  then show ?case using \<open>a\<in>A\<close> by simp
next
  case (succ x)
  then
  show ?case using assms by auto
qed

lemma witness_related :
  assumes "a\<in>A"
    "(\<forall>X . X\<noteq>0 \<and> X\<subseteq>A \<longrightarrow> s`X\<in>X)"
    "\<forall>y\<in>A. {x\<in>A. \<langle>y,x\<rangle>\<in>R } \<noteq> 0" "n\<in>nat"
  shows "\<langle>dc_witness(n, A, a, s, R),dc_witness(succ(n), A, a, s, R)\<rangle>\<in>R"
proof -
  from assms
  have "dc_witness(n, A, a, s, R)\<in>A" (is "?x \<in> A")
    using witness_into_A[of _ _ s R n] by simp
  with assms
  show ?thesis by auto
qed

lemma witness_funtype:
  assumes "a\<in>A"
    "(\<forall>X . X\<noteq>0 \<and> X\<subseteq>A \<longrightarrow> s`X\<in>X)"
    "\<forall>y\<in>A. {x\<in>A. \<langle>y,x\<rangle>\<in>R } \<noteq> 0"
  shows "(\<lambda>n\<in>nat. dc_witness(n, A, a, s, R)) \<in> nat \<rightarrow> A" (is "?f \<in> _ \<rightarrow> _")
proof -
  have "?f \<in> nat \<rightarrow> {dc_witness(n, A, a, s, R). n\<in>nat}" (is "_ \<in> _ \<rightarrow> ?B")
    using lam_funtype assms by simp
  then
  have "?B \<subseteq> A"
    using witness_into_A assms by auto
  with \<open>?f \<in> _\<close>
  show ?thesis
    using fun_weaken_type
    by simp
qed

lemma witness_to_fun:   assumes "a\<in>A"
  "(\<forall>X . X\<noteq>0 \<and> X\<subseteq>A \<longrightarrow> s`X\<in>X)"
  "\<forall>y\<in>A. {x\<in>A. \<langle>y,x\<rangle>\<in>R } \<noteq> 0"
shows "\<exists>f \<in> nat\<rightarrow>A. \<forall>n\<in>nat. f`n =dc_witness(n,A,a,s,R)"
  using assms bexI[of _ "\<lambda>n\<in>nat. dc_witness(n,A,a,s,R)"] witness_funtype
  by simp

theorem pointed_DC  :
  assumes "(\<forall>x\<in>A. \<exists>y\<in>A. \<langle>x,y\<rangle>\<in> R)"
  shows "\<forall>a\<in>A. (\<exists>f \<in> nat\<rightarrow>A. f`0 = a \<and> (\<forall>n \<in> nat. \<langle>f`n,f`succ(n)\<rangle>\<in>R))"
proof -
  have 0:"\<forall>y\<in>A. {x \<in> A . \<langle>y, x\<rangle> \<in> R} \<noteq> 0"
    using assms by auto
  from AC_func_Pow[of A]
  obtain g
    where 1: "g \<in> Pow(A) - {0} \<rightarrow> A"
      "\<forall>X. X \<noteq> 0 \<and> X \<subseteq> A \<longrightarrow> g ` X \<in> X"
    by auto
  let ?f ="\<lambda>a.\<lambda>n\<in>nat. dc_witness(n,A,a,g,R)"
  {
    fix a
    assume "a\<in>A"
    from \<open>a\<in>A\<close>
    have f0: "?f(a)`0 = a" by simp
    with \<open>a\<in>A\<close>
    have "\<langle>?f(a) ` n, ?f(a) ` succ(n)\<rangle> \<in> R" if "n\<in>nat" for n
      using witness_related[OF \<open>a\<in>A\<close> 1(2) 0] beta that by simp
    then
    have "\<exists>f\<in>nat \<rightarrow> A. f ` 0 = a \<and> (\<forall>n\<in>nat. \<langle>f ` n, f ` succ(n)\<rangle> \<in> R)" (is "\<exists>x\<in>_ .?P(x)")
      using f0 witness_funtype 0 1 \<open>a\<in>_\<close> by blast
  }
  then show ?thesis by auto
qed

lemma aux_DC_on_AxNat2 : "\<forall>x\<in>A\<times>nat. \<exists>y\<in>A. \<langle>x,\<langle>y,succ(snd(x))\<rangle>\<rangle> \<in> R \<Longrightarrow>
                  \<forall>x\<in>A\<times>nat. \<exists>y\<in>A\<times>nat. \<langle>x,y\<rangle> \<in> {\<langle>a,b\<rangle>\<in>R. snd(b) = succ(snd(a))}"
  by (rule ballI, erule_tac x="x" in ballE, simp_all)

lemma infer_snd : "c\<in> A\<times>B \<Longrightarrow> snd(c) = k \<Longrightarrow> c=\<langle>fst(c),k\<rangle>"
  by auto

corollary DC_on_A_x_nat :
  assumes "(\<forall>x\<in>A\<times>nat. \<exists>y\<in>A. \<langle>x,\<langle>y,succ(snd(x))\<rangle>\<rangle> \<in> R)" "a\<in>A"
  shows "\<exists>f \<in> nat\<rightarrow>A. f`0 = a \<and> (\<forall>n \<in> nat. \<langle>\<langle>f`n,n\<rangle>,\<langle>f`succ(n),succ(n)\<rangle>\<rangle>\<in>R)" (is "\<exists>x\<in>_.?P(x)")
proof -
  let ?R'="{\<langle>a,b\<rangle>\<in>R. snd(b) = succ(snd(a))}"
  from assms(1)
  have "\<forall>x\<in>A\<times>nat. \<exists>y\<in>A\<times>nat. \<langle>x,y\<rangle> \<in> ?R'"
    using aux_DC_on_AxNat2 by simp
  with \<open>a\<in>_\<close>
  obtain f where
    F:"f\<in>nat\<rightarrow>A\<times>nat" "f ` 0 = \<langle>a,0\<rangle>"  "\<forall>n\<in>nat. \<langle>f ` n, f ` succ(n)\<rangle> \<in> ?R'"
    using pointed_DC[of "A\<times>nat" ?R'] by blast
  let ?f="\<lambda>x\<in>nat. fst(f`x)"
  from F
  have "?f\<in>nat\<rightarrow>A" "?f ` 0 = a" by auto
  have 1:"n\<in> nat \<Longrightarrow> f`n= \<langle>?f`n, n\<rangle>" for n
  proof(induct n set:nat)
    case 0
    then show ?case using F by simp
  next
    case (succ x)
    then
    have "\<langle>f`x, f`succ(x)\<rangle> \<in> ?R'" "f`x \<in> A\<times>nat" "f`succ(x)\<in>A\<times>nat"
      using F by simp_all
    then
    have "snd(f`succ(x)) = succ(snd(f`x))" by simp
    with succ \<open>f`x\<in>_\<close>
    show ?case using infer_snd[OF \<open>f`succ(_)\<in>_\<close>] by auto
  qed
  have "\<langle>\<langle>?f`n,n\<rangle>,\<langle>?f`succ(n),succ(n)\<rangle>\<rangle> \<in> R" if "n\<in>nat" for n
    using that 1[of "succ(n)"] 1[OF \<open>n\<in>_\<close>] F(3) by simp
  with \<open>f`0=\<langle>a,0\<rangle>\<close>
  show ?thesis using rev_bexI[OF \<open>?f\<in>_\<close>] by simp
qed

lemma aux_sequence_DC :
  assumes "\<forall>x\<in>A. \<forall>n\<in>nat. \<exists>y\<in>A. \<langle>x,y\<rangle> \<in> S`n"
    "R={\<langle>\<langle>x,n\<rangle>,\<langle>y,m\<rangle>\<rangle> \<in> (A\<times>nat)\<times>(A\<times>nat). \<langle>x,y\<rangle>\<in>S`m }"
  shows "\<forall> x\<in>A\<times>nat . \<exists>y\<in>A. \<langle>x,\<langle>y,succ(snd(x))\<rangle>\<rangle> \<in> R"
  using assms Pair_fst_snd_eq by auto

lemma aux_sequence_DC2 : "\<forall>x\<in>A. \<forall>n\<in>nat. \<exists>y\<in>A. \<langle>x,y\<rangle> \<in> S`n \<Longrightarrow>
        \<forall>x\<in>A\<times>nat. \<exists>y\<in>A. \<langle>x,\<langle>y,succ(snd(x))\<rangle>\<rangle> \<in> {\<langle>\<langle>x,n\<rangle>,\<langle>y,m\<rangle>\<rangle>\<in>(A\<times>nat)\<times>(A\<times>nat). \<langle>x,y\<rangle>\<in>S`m }"
  by auto

lemma sequence_DC:
  assumes "\<forall>x\<in>A. \<forall>n\<in>nat. \<exists>y\<in>A. \<langle>x,y\<rangle> \<in> S`n"
  shows "\<forall>a\<in>A. (\<exists>f \<in> nat\<rightarrow>A. f`0 = a \<and> (\<forall>n \<in> nat. \<langle>f`n,f`succ(n)\<rangle>\<in>S`succ(n)))"
  by (rule ballI,insert assms,drule aux_sequence_DC2, drule DC_on_A_x_nat, auto)

end