theory STL_sample
  imports STL Code_Real_Approx_By_Float_2

begin

fun recurs_exist_list :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "recurs_exist_list P [] = False"
| "recurs_exist_list P (x#xs) = (P x \<or> recurs_exist_list P xs)"

lemma recurs_exist_list_equiv:"(\<exists>n<length t. P (t!n)) = (recurs_exist_list P t)"
proof (induct t)
  case Nil
  then show ?case
    by auto
  case (Cons x xs)
  then show ?case
  proof (cases "P x")
    case True
    then show ?thesis
      by force
  next
    case False
    then show ?thesis
    proof (cases "recurs_exist_list P xs")
      case True
      then show ?thesis
        using Cons
        by force
    next
      case False
      then show ?thesis
        using Cons \<open>\<not>(P x)\<close>
        by (metis in_set_conv_nth recurs_exist_list.simps(2) set_ConsD)
    qed
  qed
qed

lemma recurse_length_until:
  fixes P P' :: "'a \<Rightarrow> bool" and t :: "'a list"
  assumes "length t > 0"
  shows "(\<exists>n<length t. P (t!n) \<and> (\<forall>n'\<le>n. P' (t!n')))
    = ((P (t!0) \<and> P' (t!0)) \<or> (P' (t!0) \<and> (\<lambda>t. \<exists>n<length t. P (t!n) \<and> (\<forall>n'\<le>n. P' (t!n'))) (drop 1 t)))"
proof -
  obtain x xs where x:"t = x#xs"
    using assms Suc_pred' length_Suc_conv
    by meson
  then show ?thesis
  proof (cases "P x")
    case True
    then show ?thesis
      using x
      by auto
  next
    case False
    {assume 1:"\<exists>n<length (x#xs). P ((x#xs)!n) \<and> (\<forall>n'\<le>n. P' ((x#xs)!n'))"
      then have "P' ((x#xs)!0)"
        using False
        by blast
      have "\<exists>n<length (x#xs). n>0 \<and> P ((x#xs)!n) \<and> (\<forall>n'\<le>n. P' ((x#xs)!n'))"
        using 1 False nth_Cons_0 zero_less_iff_neq_zero
        by metis
      then have "\<exists>n<length xs. P (xs!n) \<and> (\<forall>n'\<le>n. P' (xs!n'))"
        using Suc_pred' length_Cons linorder_not_le not_less_eq nth_Cons_Suc
        by metis
      then have "((P ((x#xs)!0) \<and> P' ((x#xs)!0)) \<or> (P' ((x#xs)!0) \<and> (\<lambda>t. \<exists>n<length t. P (t!n) \<and> (\<forall>n'\<le>n. P' (t!n'))) (drop 1 (x#xs))))"
        using \<open>P' ((x#xs)!0)\<close>
        by auto}
    then have onew:"\<exists>n<length (x#xs). P ((x#xs)!n) \<and> (\<forall>n'\<le>n. P' ((x#xs)!n'))
        \<Longrightarrow> ((P ((x#xs)!0) \<and> P' ((x#xs)!0)) \<or> (P' ((x#xs)!0) \<and> (\<lambda>t. \<exists>n<length t. P (t!n) \<and> (\<forall>n'\<le>n. P' (t!n'))) (drop 1 (x#xs))))"
      by blast
    {assume 2:"((P ((x#xs)!0) \<and> P' ((x#xs)!0)) \<or> (P' ((x#xs)!0) \<and> (\<lambda>t. \<exists>n<length t. P (t!n) \<and> (\<forall>n'\<le>n. P' (t!n'))) (drop 1 (x#xs))))"
      then have "\<exists>n<length (x#xs). P ((x#xs)!n) \<and> (\<forall>n'\<le>n. P' ((x#xs)!n'))"
      proof (cases "P ((x#xs)!0) \<and> P' ((x#xs)!0)")
        case True
        then show ?thesis
          by blast
      next
        case False
        then have "(P' ((x#xs)!0) \<and> (\<lambda>t. \<exists>n<length t. P (t!n) \<and> (\<forall>n'\<le>n. P' (t!n'))) xs)"
          using 2
          by auto
        then show ?thesis
          using Suc_pred' bot_nat_0.not_eq_extremum length_Cons linorder_not_le not_less_eq
            nth_Cons_Suc
          by (metis (no_types, opaque_lifting))
      qed}
    then show ?thesis
      using onew x
      by blast
  qed
qed

lemma recurse_length:
  fixes P :: "'a \<Rightarrow> bool" and t :: "'a list"
  assumes "length t > 0"
  shows "(\<exists>n<length t. P (t!n)) = (P (t!0) \<or> (\<lambda>t. \<exists>n<length t. P (t!n)) (drop 1 t))"
  using recurse_length_until [where ?P'="\<lambda>x. True"] assms
  by auto

lemma recurse_length_release_alt:
  fixes foo bar :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
  assumes "\<And>t P P'. foo P P' t = (\<exists>n<length t. P (t!n) \<and> (\<forall>n'\<le>n. P' (t!n')))" and "\<And>P P'. bar P P' [] = False"
    and "\<And>x xs P P'. bar P P' (x#xs) = ((P x \<and> P' x) \<or> ((P' x) \<and> bar P P' xs))"
  shows "\<And>P P' xs. foo P P' xs = bar P P' xs"
proof -
  {fix xs :: "'a list"
    have "\<And>P P'. foo P P' xs = bar P P' xs"
    proof (induct xs)
      case Nil
      then show ?case
        using assms
        by simp
    next
      case (Cons x xs)
      then show ?case
      proof (cases "P x")
        case True
        then show ?thesis
          using assms
          by auto
      next
        case False
        {assume 1:"foo P P' (x#xs)"
          then have "P' x"
            using assms(1)
            by auto
          then have "\<exists>n<length (x#xs). n>0 \<and> P ((x#xs)!n) \<and> (\<forall>n'\<le>n. P' ((x#xs)!n'))"
            using 1 assms(1) False nth_Cons_0 zero_less_iff_neq_zero
            by metis
          then have "\<exists>n<length xs. P (xs!n) \<and> (\<forall>n'\<le>n. P' (xs!n'))"
            using Suc_pred' length_Cons linorder_not_le not_less_eq nth_Cons_Suc
            by metis
          then have "foo P P' xs"
            using assms(1)
            by blast
          then have "((P ((x#xs)!0) \<and> P' ((x#xs)!0)) \<or> (P' ((x#xs)!0) \<and> bar P P' xs))"
            using Cons \<open>P' x\<close>
            by simp
          then have "bar P P' (x#xs)"
            using assms(3)
            by simp}
        then have onew:"foo P P' (x#xs) \<Longrightarrow> bar P P' (x#xs)"
          by blast
        {assume 2:"bar P P' (x#xs)"
          then have "((P ((x#xs)!0) \<and> P' ((x#xs)!0)) \<or> (P' ((x#xs)!0) \<and> bar P P' xs))"
            using assms(3)
            by simp
          then have "\<exists>n<length (x#xs). P ((x#xs)!n) \<and> (\<forall>n'\<le>n. P' ((x#xs)!n'))"
          proof (cases "P ((x#xs)!0) \<and> P' ((x#xs)!0)")
            case True
            then show ?thesis
              by blast
          next
            case False
            then have "(P' ((x#xs)!0) \<and> bar P P' xs)"
              using 2 assms(3)
              by auto
            then have "(P' ((x#xs)!0) \<and> (\<exists>n<length xs. P (xs!n) \<and> (\<forall>n'\<le>n. P' (xs!n'))))"
              using Cons assms(1)
              by blast
            then show ?thesis
              using Suc_pred' bot_nat_0.not_eq_extremum length_Cons linorder_not_le not_less_eq
                nth_Cons_Suc
              by (metis (no_types, opaque_lifting))
          qed
          then have "foo P P' (x#xs)"
            using assms(1)
            by blast}
        then show ?thesis
          using onew
          by blast
      qed
    qed}
  then show "\<And>P P' xs. foo P P' xs = bar P P' xs"
    by simp
qed

lemma recurse_length_alt:
  fixes foo bar :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
  assumes "\<And>P t. foo P t = (\<exists>n<length t. P (t!n))" and "\<And>P. bar P [] = False"
    and "\<And>P x xs. bar P (x#xs) = (P x \<or> bar P xs)"
  shows "\<And>P xs. foo P xs = bar P xs"
proof -
  {fix P :: "'a \<Rightarrow> bool" and xs :: "'a list"
    have "foo P xs = bar P xs"
    proof (induct xs)
      case Nil
      then show ?case
        using assms
        by force
    next
      case (Cons y ys)
      then show ?case
        using assms One_nat_def drop0 drop_Suc_Cons length_greater_0_conv list.discI nth_Cons_0
          recurse_length
        by (metis (no_types, lifting))
    qed}
  then show "\<And>P xs. foo P xs = bar P xs"
    by simp
qed

lemma recurse_length_all:
  fixes foo bar :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
  assumes "\<And>t P. foo P t = (\<forall>n<length t. P (t!n))" and "\<And>P. bar P [] = True"
    and "\<And>x xs P. bar P (x#xs) = (P x \<and> bar P xs)"
  shows "foo P xs = bar P xs"
proof (induct xs)
  case Nil
  then show ?case
    using assms
    by force
next
  case (Cons x xs)
  then show ?case
    using assms less_Suc_eq_0_disj length_Cons nth_Cons_0 nth_Cons_Suc
    by (smt (verit))
qed

lemma recurse_length_alt_Pdep:
  fixes foo bar :: "('a list \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  assumes "\<And>P t t'. foo P t t' = (\<exists>n<length t. (P t') (t!n))" and "\<And>P t'. bar P [] t' = False"
    and "\<And>P x xs t'. bar P (x#xs) t' = ((P t') x \<or> bar P xs t')"
  shows "foo P xs t' = bar P xs t'"
proof (induct xs)
  case Nil
  then show ?case
    using assms
    by simp
next
  case (Cons y ys)
  then show ?case
    using assms One_nat_def drop0 drop_Suc_Cons length_greater_0_conv list.discI nth_Cons_0
      recurse_length
    by (metis (no_types, lifting))
qed

fun recurs_exist_list_Pdep :: "('a list \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "recurs_exist_list_Pdep P [] t = False"
| "recurs_exist_list_Pdep P (x#xs) t = ((P t) x \<or> recurs_exist_list_Pdep P xs t)"

fun recurs_all_list :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "recurs_all_list P [] = True"
| "recurs_all_list P (x#xs) = (P x \<and> recurs_all_list P xs)"

fun recurs_exist_list_Pdep_real :: "('a list \<Rightarrow> 'a \<Rightarrow> real) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> real \<Rightarrow> real" where
  "recurs_exist_list_Pdep_real P [] t \<gamma> = -1"
| "recurs_exist_list_Pdep_real P (x#xs) t \<gamma> = Max_gamma_comp \<gamma> (recurs_exist_list_Pdep_real P xs t \<gamma>) ((P t) x)"

fun recurs_release :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "recurs_release P P' [] = False"
| "recurs_release P P' (x#xs) = ((P x \<and> P' x) \<or> ((P' x) \<and> recurs_release P P' xs))"

fun recurs_release_real :: "('a \<Rightarrow> real \<Rightarrow> real) \<Rightarrow> ('a \<Rightarrow> real \<Rightarrow> real) \<Rightarrow> 'a list \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real" where
  "recurs_release_real P P' [] \<gamma> E = -(abs E)"
| "recurs_release_real P P' (x#xs) \<gamma> E = (Max_gamma_comp \<gamma> (Min_gamma_comp \<gamma> (P x \<gamma>) (P' x \<gamma>))
      (Min_gamma_comp \<gamma> (P' x \<gamma>) (recurs_release_real P P' xs \<gamma> (P x \<gamma>))))"

lemma recurs_release_real_sound_0:
  assumes "\<And>z. Pr z 0 > 0 \<longrightarrow> P z" "\<And>z. Pr z 0 < 0 \<longrightarrow> \<not>(P z)"
      "\<And>z. P'r z 0 > 0 \<longrightarrow> P' z" "\<And>z. P'r z 0 < 0 \<longrightarrow> \<not>(P' z)"
  shows "(recurs_release_real Pr P'r t 0 E > 0 \<longrightarrow> recurs_release P P' t)"
      "recurs_release_real Pr P'r t 0 E < 0 \<longrightarrow> \<not>(recurs_release P P' t)"
proof (induct t arbitrary: E)
  case Nil
  then show "\<And>E. (recurs_release_real Pr P'r [] 0 E > 0 \<longrightarrow> recurs_release P P' [])"
      "\<And>E. recurs_release_real Pr P'r [] 0 E < 0 \<longrightarrow> \<not>(recurs_release P P' [])"
    by simp+
next
  case (Cons x xs)
  have 1:"\<And>E. recurs_release_real Pr P'r (x#xs) 0 E = (max (min (Pr x 0) (P'r x 0))
    (min (P'r x 0) (recurs_release_real Pr P'r xs 0 (Pr x 0))))"
    by force
  then show "\<And>E. recurs_release_real Pr P'r (x#xs) 0 E > 0 \<longrightarrow> recurs_release P P' (x#xs)"
    using Cons assms(1,3) recurs_release.simps(2)
    by (smt (verit))
  then show "\<And>E. recurs_release_real Pr P'r (x#xs) 0 E < 0 \<longrightarrow> \<not>(recurs_release P P' (x#xs))"
    using Cons assms(2,4) recurs_release.simps(2) 1
    by (smt (verit))
qed

lemma recurs_release_real_const_bel0:
  assumes "\<And>z. \<forall>x\<le>0. P z x = P z 0" "\<And>z. \<forall>x\<le>0. P' z x = P' z 0"
  shows "\<And>z. \<forall>\<gamma>\<le>0. recurs_release_real P P' t \<gamma> (P z \<gamma>) = recurs_release_real P P' t 0 (P z 0)"
proof (induct t)
  case Nil
  then show ?case
    using assms(1) recurs_release_real.simps(1)
    by metis
next
  case (Cons x xs)
  then show ?case
    using assms Max_gamma_const_bel0 Min_gamma_const_bel0 Max_gamma_comp_eq Min_gamma_comp_eq
      recurs_release_real.simps(2) recurs_release_real.elims
    by (smt (verit, ccfv_SIG))
qed

lemma recurs_release_real_const_bel0_const:
  assumes "\<And>z. \<forall>x\<le>0. P z x = P z 0" "\<And>z. \<forall>x\<le>0. P' z x = P' z 0"
  shows "\<And>z. \<forall>\<gamma>\<le>0. recurs_release_real P P' t \<gamma> E = recurs_release_real P P' t 0 E"
proof (induct t)
  case Nil
  then show ?case
    using assms(1) recurs_release_real.simps(1)
    by metis
next
  case (Cons x xs)
  then show ?case
    using assms Max_gamma_const_bel0 Min_gamma_const_bel0 Max_gamma_comp_eq Min_gamma_comp_eq
      recurs_release_real.simps(2) recurs_release_real.elims
    by (smt (verit, ccfv_SIG))
qed

lemma recurs_release_real_cont_0_var:
  assumes "\<And>z. isCont (P z) 0" "\<And>z. isCont (P' z) 0"
    "\<And>z. \<forall>x\<le>0. P z x = P z 0" "\<And>z. \<forall>x\<le>0. P' z x = P' z 0"
  shows "\<And>x. isCont (\<lambda>\<gamma>. recurs_release_real P P' t \<gamma> (P x \<gamma>)) 0"
proof (induct t)
  case Nil
  then show ?case
    using recurs_release_real.simps(1) assms
    by auto
next
  case (Cons y ys)
  then have 1:"isCont (P' y) 0" "isCont (\<lambda>\<gamma>. recurs_release_real P P' ys \<gamma> (P y \<gamma>)) 0"
    "(\<forall>x\<le>0. P' y x = P' y 0)"
    "isCont (P y) 0" "(\<forall>x\<le>0. P y x = P y 0)"
    using assms
    by blast+
  have 11:"\<forall>x\<le>0. recurs_release_real P P' ys x (P y x) = recurs_release_real P P' ys 0 (P y 0)"
    using assms recurs_release_real_const_bel0
    by meson
  have 2:"isCont (\<lambda>\<gamma>. Min_gamma_comp \<gamma> (P' y \<gamma>) (recurs_release_real P P' ys \<gamma> (P y \<gamma>))) 0"
    using 1(1-3) 11 Min_gamma_chain_cont_0 Min_gamma_comp_eq
    by presburger
  then have 3:"isCont (\<lambda>\<gamma>. Min_gamma_comp \<gamma> (P y \<gamma>) (P' y \<gamma>)) 0"
    using 1(1,3-5) Min_gamma_chain_cont_0 Min_gamma_comp_eq
    by presburger
  have "\<forall>\<gamma>\<le>0. Min_gamma_comp \<gamma> (P y \<gamma>) (P' y \<gamma>) = Min_gamma_comp 0 (P y 0) (P' y 0)"
      "\<forall>\<gamma>\<le>0. Min_gamma_comp \<gamma> (P' y \<gamma>) (recurs_release_real P P' ys \<gamma> (P y \<gamma>)) = Min_gamma_comp 0 (P' y 0) (recurs_release_real P P' ys 0 (P y 0))"
    using Min_gamma_const_bel0 1(3,5) Min_gamma_comp_eq 11
    by presburger+
  then have "isCont (\<lambda>\<gamma>. Max_gamma \<gamma> (Min_gamma_comp \<gamma> (P y \<gamma>) (P' y \<gamma>))
    (Min_gamma_comp \<gamma> (P' y \<gamma>) (recurs_release_real P P' ys \<gamma> (P y \<gamma>)))) 0"
    using 1 2 3 Max_gamma_chain_cont_0
    by blast
  then show ?case
    using Max_gamma_comp_eq
    by simp
qed

lemma recurs_release_real_cont_0:
  assumes "\<And>z. isCont (P z) 0" "\<And>z. isCont (P' z) 0"
    "\<And>z. \<forall>x\<le>0. P z x = P z 0" "\<And>z. \<forall>x\<le>0. P' z x = P' z 0"
  shows "\<And>x. isCont (\<lambda>\<gamma>. recurs_release_real P P' t \<gamma> E) 0"
proof (induct t)
  case Nil then show ?case by simp
next
  case (Cons y ys)
  then have 1:"isCont (P' y) 0"
    "(\<forall>x\<le>0. P' y x = P' y 0)"
    "isCont (P y) 0" "(\<forall>x\<le>0. P y x = P y 0)"
    using assms
    by blast+
  then have 12:"isCont (\<lambda>\<gamma>. recurs_release_real P P' ys \<gamma> (P y \<gamma>)) 0"
    using recurs_release_real_cont_0_var assms
    by (metis (mono_tags))
  have 11:"\<forall>x\<le>0. recurs_release_real P P' ys x (P y x) = recurs_release_real P P' ys 0 (P y 0)"
    using assms recurs_release_real_const_bel0
    by meson
  have 2:"isCont (\<lambda>\<gamma>. Min_gamma_comp \<gamma> (P' y \<gamma>) (recurs_release_real P P' ys \<gamma> (P y \<gamma>))) 0"
    using 1(1-2) 11 12 Min_gamma_chain_cont_0 Min_gamma_comp_eq
    by presburger
  then have 3:"isCont (\<lambda>\<gamma>. Min_gamma_comp \<gamma> (P y \<gamma>) (P' y \<gamma>)) 0"
    using 1 Min_gamma_chain_cont_0 Min_gamma_comp_eq
    by presburger
  have "\<forall>\<gamma>\<le>0. Min_gamma_comp \<gamma> (P y \<gamma>) (P' y \<gamma>) = Min_gamma_comp 0 (P y 0) (P' y 0)"
      "\<forall>\<gamma>\<le>0. Min_gamma_comp \<gamma> (P' y \<gamma>) (recurs_release_real P P' ys \<gamma> (P y \<gamma>)) = Min_gamma_comp 0 (P' y 0) (recurs_release_real P P' ys 0 (P y 0))"
    using Min_gamma_const_bel0 1 Min_gamma_comp_eq 11
    by presburger+
  then have "isCont (\<lambda>\<gamma>. Max_gamma \<gamma> (Min_gamma_comp \<gamma> (P y \<gamma>) (P' y \<gamma>))
    (Min_gamma_comp \<gamma> (P' y \<gamma>) (recurs_release_real P P' ys \<gamma> (P y \<gamma>)))) 0"
    using 1 2 3 Max_gamma_chain_cont_0
    by blast
  then show ?case
    using Max_gamma_comp_eq
    by simp
qed

lemma recurs_exist_list_Pdep_real_sound_0:
  assumes "\<And>t x. P t x > 0 \<longrightarrow> P' t x" "\<And>t x. P t x < 0 \<longrightarrow> \<not>(P' t x)"
  shows "(recurs_exist_list_Pdep_real P xs t 0 > 0) \<longrightarrow> (recurs_exist_list_Pdep P' xs t)"
      "(recurs_exist_list_Pdep_real P xs t 0 < 0) \<longrightarrow> \<not>(recurs_exist_list_Pdep P' xs t)"
proof (induct xs)
  case Nil
  then show "(recurs_exist_list_Pdep_real P [] t 0 > 0) \<longrightarrow> (recurs_exist_list_Pdep P' [] t)"
    by auto
  then show "(recurs_exist_list_Pdep_real P [] t 0 < 0) \<longrightarrow> \<not>(recurs_exist_list_Pdep P' [] t)"
    by simp
next
  case (Cons y ys)
  then show "(recurs_exist_list_Pdep_real P (y#ys) t 0 > 0) \<longrightarrow> (recurs_exist_list_Pdep P' (y#ys) t)"
    using assms
    by fastforce
  then show "(recurs_exist_list_Pdep_real P (y#ys) t 0 < 0) \<longrightarrow> \<not>(recurs_exist_list_Pdep P' (y#ys) t)"
    using Cons assms
    by force
qed

fun recurs_all_list_real :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> real \<Rightarrow> real" where
  "recurs_all_list_real P [] \<gamma> = 1"
| "recurs_all_list_real P (x#xs) \<gamma> = Min_gamma_comp \<gamma> (if P x then 1 else -1) (recurs_all_list_real P xs \<gamma>)"

fun valid_constraints :: "real \<Rightarrow> (real \<times> 'v) list \<Rightarrow> 'v constraint \<Rightarrow> bool" where
"valid_constraints p t (cMu f ct r) = (p\<in>set (map fst t))"
| "valid_constraints p t (cNot c) = (valid_constraints p t c)"
| "valid_constraints p t (cAnd c1 c2) = (valid_constraints p t c1 \<and> valid_constraints p t c2)"
| "valid_constraints p t (cUntil x y c1 c2) = (x \<ge> 0 \<and> y \<ge> 0)"

definition valid_signal :: "(real \<times> 'v) list \<Rightarrow> bool" where
"valid_signal xs = sorted_wrt (<) (map fst xs)"

(*
definition first_time :: "(real \<times> 'v) list \<Rightarrow> real" where
"first_time xs = Min (set (map fst xs))"

definition at_time :: "real \<Rightarrow> (real \<times> 'v) list \<Rightarrow> real" where
"at_time p xs = Min (set (filter (\<lambda>x. x\<ge>p) (map fst xs)))"

definition next_time :: "real \<Rightarrow> (real \<times> 'v) list \<Rightarrow> real" where
"next_time p xs = Min (set (filter (\<lambda>x. x>p) (map fst xs)))"
*)

fun find_time :: "(real \<times> 'v) list \<Rightarrow> real \<Rightarrow> 'v" where
"find_time [] r = undefined"
| "find_time (x#xs) r = (if fst x = r then snd x else find_time xs r)"

(*
lemma signal_induct:
  "P (first_time xs) \<Longrightarrow> (\<And>p. P p \<Longrightarrow> P (next_time p xs)) \<Longrightarrow> (\<And>p. p\<in>set(map fst xs) \<Longrightarrow> P p)"
proof (induct xs rule: list.induct)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then show ?case
  proof (cases "fst x = first_time (x#xs)")
    case True
    then have "P (first_time (x#xs))"
      using Cons
      by blast
    then have "\<And>p. p\<in>set(map fst xs) \<Longrightarrow> P p"
      using Cons
*)

fun evals :: "real \<Rightarrow> (real \<times> 'v) list \<Rightarrow> 'v constraint \<Rightarrow> bool" where
"evals p t (cMu f ct r) = (if (recurs_exist_list (\<lambda>z. fst z = p) t) then (f ct (find_time t p) > r) else False)"
| "evals p t (cNot c) = (\<not>(evals p t c))"
| "evals p t (cAnd c1 c2) = ((evals p t c1) \<and> (evals p t c2))"
| "evals p t (cUntil x y c1 c2)
  = recurs_release (\<lambda>z. fst z \<ge> p+x \<and> fst z \<le> p+y \<and> evals (fst z) t c2) (\<lambda>z. evals (fst z) t c1 \<or> fst z < p) t"

lemma equiv_Until_semantics:
  fixes t :: "(real\<times>'v) list" and p x y :: real
    and c1 c2 :: "'v constraint"
  shows "((\<exists>p'\<ge>p+x. p'\<le>p+y \<and> (\<exists>n<length t. fst (t!n) = p') \<and> evals p' t c2
    \<and> (\<forall>p''. p''\<ge>p\<and>p''\<le>p'\<and> (\<exists>n<length t. fst (t!n) = p'') \<longrightarrow> evals p'' t c1))) = (\<exists>n<length t. (\<lambda>z. fst z \<ge> p+x \<and> fst z \<le> p+y
      \<and> evals (fst z) t c2 \<and> (\<forall>m<length t. (\<lambda>z'. evals (fst z') t c1
        \<or> fst z' < p \<or> fst z' > (fst z)) (t!m))) (t!n))"
  by (smt (verit))

lemma equiv_Until_semantics_2:
  fixes t :: "(real\<times>'v) list" and p x y :: real
    and c1 c2 :: "'v constraint"
  assumes "valid_signal t" "x>0" "y>0"
  shows "((\<exists>p'\<ge>p+x. p'\<le>p+y \<and> (\<exists>n<length t. fst (t!n) = p') \<and> evals p' t c2
    \<and> (\<forall>p''. p''\<ge>p\<and>p''\<le>p'\<and> (\<exists>n<length t. fst (t!n) = p'') \<longrightarrow> evals p'' t c1)))
    = (\<exists>n<length t. fst (t!n) \<ge> p+x \<and> fst (t!n) \<le> p+y \<and> evals (fst (t!n)) t c2
      \<and> (\<forall>m\<le>n. evals (fst (t!m)) t c1 \<or> fst (t!m) < p))"
proof -
  have "\<And>P. \<And>n::nat. n<length t \<Longrightarrow> (\<forall>m<length t. P (t!m) \<or> m > n) = (\<forall>m\<le>n. P (t!m))"
    by (meson dual_order.trans linorder_not_less)
  then have 0:"\<And>P P'. (\<exists>n<length t. P' (t!n) \<and> (\<forall>m<length t. P (t!m) \<or> m > n))
      = (\<exists>n<length t. P' (t!n) \<and> (\<forall>m\<le>n. P (t!m)))"
    by blast
  have 1:"((\<exists>p'\<ge>p+x. p'\<le>p+y \<and> (\<exists>n<length t. fst (t!n) = p') \<and> evals p' t c2
    \<and> (\<forall>p''. p''\<ge>p\<and>p''\<le>p'\<and> (\<exists>n<length t. fst (t!n) = p'') \<longrightarrow> evals p'' t c1)))
    = (\<exists>n<length t. fst (t!n) \<ge> p+x \<and> fst (t!n) \<le> p+y
      \<and> evals (fst (t!n)) t c2 \<and>
        (\<forall>m<length t. evals (fst (t!m)) t c1
        \<or> fst (t!m) < p \<or> fst (t!m) > (fst (t!n))))"
  proof -
    have "\<forall>n<length t. fst (t!n) \<ge> p \<longrightarrow> ((\<forall>m<length t. evals (fst (t!m)) t c1
        \<or> fst (t!m) < p \<or> fst (t!m) > (fst (t!n))) \<longrightarrow> evals (fst (t!n)) t c1)"
      by fastforce
    then show ?thesis
      using assms(2) equiv_Until_semantics
      by (smt (verit))
  qed
  then show ?thesis
  proof -
    have "\<forall>n<length t. (\<forall>m>n. m<length t \<longrightarrow> fst (t!m) > fst (t!n))"
      using assms(1) valid_signal_def length_map nth_map sorted_wrt_iff_nth_less
      by metis
    then have "\<forall>n<length t. (\<forall>m<length t. (m>n) = (fst (t!m) > fst (t!n)))"
      using linorder_neq_iff order_less_asym'
      by metis
    then have "((\<exists>p'\<ge>p+x. p'\<le>p+y \<and> (\<exists>n<length t. fst (t!n) = p') \<and> evals p' t c2
    \<and> (\<forall>p''. p''\<ge>p\<and>p''\<le>p'\<and> (\<exists>n<length t. fst (t!n) = p'') \<longrightarrow> evals p'' t c1)))
    = (\<exists>n<length t. fst (t!n) \<ge> p+x \<and> fst (t!n) \<le> p+y
      \<and> evals (fst (t!n)) t c2 \<and>
        (\<forall>m<length t. evals (fst (t!m)) t c1
        \<or> fst (t!m) < p \<or> m > n))"
      using 1
      by blast
    then show ?thesis
      using 0 [where ?P'="\<lambda>z. fst z \<ge> p+x \<and> fst z \<le> p+y
      \<and> evals (fst z) t c2" and ?P="\<lambda>z. evals (fst z) t c1 \<or> fst z < p"]
      by presburger
  qed
qed

lemma recurse_evals_Until_equiv:
  fixes p x y :: real and t :: "(real\<times>'v) list"
  assumes "valid_signal t" "x>0" "y>0"
  shows "evals p t (cUntil x y c1 c2)
      = ((\<exists>p'\<ge>p+x. p'\<le>p+y \<and> (\<exists>n<length t. fst (t!n) = p') \<and> evals p' t c2
    \<and> (\<forall>p''. p''\<ge>p\<and>p''\<le>p'\<and> (\<exists>n<length t. fst (t!n) = p'') \<longrightarrow> evals p'' t c1)))"
proof -
  have "evals p t (cUntil x y c1 c2)
      = (\<exists>n<length t. fst (t!n) \<ge> p+x \<and> fst (t!n) \<le> p+y \<and> evals (fst (t!n)) t c2
        \<and> (\<forall>m\<le>n. fst (t!m) < p \<or> evals (fst (t!m)) t c1))"
    using recurse_length_release_alt [where ?foo="\<lambda>P P' t. (\<exists>n<length t. P (t ! n) \<and> (\<forall>n'\<le>n. P' (t ! n')))"
      and ?bar="recurs_release" and ?xs="t" and ?P="\<lambda>z. fst z \<ge> p+x \<and> fst z \<le> p+y \<and> evals (fst z) t c2"
      and ?P'="\<lambda>z. evals (fst z) t c1 \<or> fst z < p"] evals.simps(4) [where ?p="p" and ?t="t"
        and ?c1.0="c1" and ?c2.0="c2" and ?x="x" and ?y="y"]
    by auto
  then show ?thesis
    using equiv_Until_semantics_2 [where ?x="x" and ?y="y" and ?t="t" and ?p="p" and ?c1.0="c1" and ?c2.0="c2"]
      assms
    by auto
qed

lemma cTrue_valid_constraints:
  "valid_constraints p t cTrue = (p\<in>set (map fst t))"
  using cTrue_def valid_constraints.simps(1)
  by metis

lemma cTrue_evals:"evals p t cTrue = (\<exists>n<length t. fst (t!n) = p)"
  using cTrue_def evals.simps(1) zero_less_one recurs_exist_list_equiv
  by (metis (mono_tags, lifting))

lemma cOr_valid_constraints:
  "valid_constraints p t (cOr c1 c2) = (valid_constraints p t c1 \<and> valid_constraints p t c2)"
  using cOr_def valid_constraints.simps(2,3)
  by metis

lemma cOr_evals:"evals p t (cOr c1 c2) = (evals p t c1 \<or> evals p t c2)"
  using cOr_def evals.simps(2,3)
  by metis

lemma cImplies_valid_constraints:
  "valid_constraints p t (cImplies c1 c2) = (valid_constraints p t c1 \<and> valid_constraints p t c2)"
  using cImplies_def cOr_def valid_constraints.simps(2,3)
  by metis

lemma cImplies_evals:"evals p t (cImplies c1 c2) = (evals p t c1 \<longrightarrow> evals p t c2)"
  using cOr_evals cImplies_def evals.simps(2)
  by metis

lemma cEventually_valid_constraints:
  "valid_constraints p t (cEventually x y c) = (x\<ge>0 \<and> y\<ge>0)"
  using cEventually_def valid_constraints.simps(4)
  by metis

lemma cEventually_evals:
  assumes "x>0" "y>0" "valid_signal t"
  shows "evals p t (cEventually x y c) = (\<exists>p'\<ge>p+x. p'\<le>p+y \<and> (\<exists>n<length t. fst (t!n) = p') \<and> evals p' t c)"
  using evals.simps(4) cTrue_evals cEventually_def length_map nth_map nth_mem recurse_evals_Until_equiv assms
  by (smt (verit))

lemma cAlways_valid_constraints: "valid_constraints p t (cAlways x y c) = (x\<ge>0 \<and> y\<ge>0)"
  using cAlways_def valid_constraints.simps(2) cEventually_valid_constraints
  by metis

lemma cAlways_evals:
  assumes "x>0" "y>0" "valid_signal t"
  shows "evals p t (cAlways x y c) =
  (\<forall>p'. p'\<ge>p+x\<and>p'\<le>p+y\<and> (\<exists>n<length t. fst (t!n) = p') \<longrightarrow> evals p' t c)"
proof -
  have "evals p t (cAlways x y c) = evals p t (cNot (cEventually x y (cNot c)))"
    using cAlways_def
    by metis
  then have "evals p t (cAlways x y c) = (\<not>(\<exists>p'\<ge>p + x. p' \<le> p + y \<and> (\<exists>n<length t. fst (t ! n) = p') \<and> evals p' t (cNot c)))"
    using cEventually_evals evals.simps(2) assms
    by metis
  then have "evals p t (cAlways x y c) = (\<forall>p'\<ge>p + x. \<not>(p' \<le> p + y \<and> (\<exists>n<length t. fst (t ! n) = p') \<and> evals p' t (cNot c)))"
    by blast
  then have "evals p t (cAlways x y c) = (\<forall>p'\<ge>p + x. \<not>(p' \<le> p + y \<and> (\<exists>n<length t. fst (t ! n) = p') \<and> \<not>(evals p' t c)))"
    using evals.simps(2)
    by simp
  then show ?thesis
    by blast
qed

(* definition clip_timeline :: "real \<Rightarrow> real \<Rightarrow> (real\<times>'v) list \<Rightarrow> (real\<times>'v) list" where
"clip_timeline x y t = sort_key (\<lambda>z. fst z) (filter (\<lambda>z. fst z \<ge> x \<and> fst z \<le> y) t)"

lemma tst:"length t > 0 \<longrightarrow> (sort_key id t)!0 = Min (set t)"
proof -
  {assume "length t > 0"
    then have fin:"finite (set t) \<and> set t \<noteq> {}"
      by blast
    have "sorted (sort_key id t)"
      by (metis list.map_id sorted_sort_key)
    have "(sort_key id t)!0 = Min (set t)"
    proof (rule ccontr)
      assume "(sort_key id t)!0 \<noteq> Min (set t)"
      then have "\<exists>n\<in>(set t). n < (sort_key id t)!0"
        using fin Min_in Min_le \<open>0 < length t\<close> finite_has_minimal length_sort linorder_not_le
          nth_mem set_sort
        by metis
      then show False
        using \<open>sorted (sort_key id t)\<close> in_set_conv_nth linorder_not_le not_less_zero set_sort
          sorted_nth_mono
        by metis
    qed}
  then show ?thesis
    by simp
qed

lemma clip_timeline_0:
  assumes "\<exists>n<length t. fst (t!n) \<ge> x \<and> fst (t!n) \<le> y"
  shows "fst ((clip_timeline x y t)!0) = Min (set (filter (\<lambda>z. z\<ge>x \<and> z\<le>y) (map fst t)))"
proof -
  have "set (filter (\<lambda>z. z\<ge>x \<and> z\<le>y) (map fst t)) = {r. r \<in> set (map fst t) \<and> r\<ge>x \<and> r\<le>y}"
    by force
  then have "finite (set (filter (\<lambda>z. z\<ge>x \<and> z\<le>y) (map fst t)))
      \<and> (set (filter (\<lambda>z. z\<ge>x \<and> z\<le>y) (map fst t))) \<noteq> {}"
    using assms
    by fastforce
  then have "Min (set (filter (\<lambda>z. z\<ge>x \<and> z\<le>y) (map fst t))) \<in> set (filter (\<lambda>z. z\<ge>x \<and> z\<le>y) (map fst t))"
    using Min_in
    by blast
  then have "\<forall>n<length (clip_timeline x y t). fst ((clip_timeline x y t)!0) \<le> fst ((clip_timeline x y t)!n)"
    using clip_timeline_def sort_key_def
    oops
*)

fun robust :: "real \<Rightarrow> (real \<times> 'v) list \<Rightarrow> 'v constraint \<Rightarrow> real \<Rightarrow> real" where
"robust p t (cMu f ct r) \<gamma> = (if (recurs_exist_list (\<lambda>z. fst z = p) t) then f ct (find_time t p) - r else -1)"
| "robust p t (cNot c) \<gamma> = - (robust p t c \<gamma>)"
| "robust p t (cAnd c1 c2) \<gamma> = Min_gamma_comp \<gamma> (robust p t c1 \<gamma>) (robust p t c2 \<gamma>)"
| "robust p t (cUntil x y c1 c2) \<gamma> = recurs_release_real
    (\<lambda>z \<gamma>. Min_gamma_comp \<gamma> (fst z - (p+x)) (Min_gamma_comp \<gamma> ((p+y) - fst z) (robust (fst z) t c2 \<gamma>)))
    (\<lambda>z \<gamma>. Max_gamma_comp \<gamma> (robust (fst z) t c1 \<gamma>) (p-fst z)) t \<gamma> (-1)"

lemma robust_sound_0:
  shows "\<And>p. (robust p t c 0 > 0) \<longrightarrow> (evals p t c)"
       "\<And>p. (robust p t c 0 < 0) \<longrightarrow> \<not>(evals p t c)"
proof (induct c)
  case (cMu f ct r)
  then show "\<And>p. (robust p t (cMu f ct r) 0 > 0) \<longrightarrow> (evals p t (cMu f ct r))"
       "\<And>p. (robust p t (cMu f ct r) 0 < 0) \<longrightarrow> \<not>(evals p t (cMu f ct r))"
    using recurs_exist_list_equiv
    by auto+
next
  case (cNot c)
  then show "\<And>p. (robust p t (cNot c) 0 > 0) \<longrightarrow> (evals p t (cNot c))"
       "\<And>p. (robust p t (cNot c) 0 < 0) \<longrightarrow> \<not>(evals p t (cNot c))"
    by force+
next
  case (cAnd c1 c2)
  then show "\<And>p. (robust p t (cAnd c1 c2) 0 > 0) \<longrightarrow> (evals p t (cAnd c1 c2))"
       "\<And>p. (robust p t (cAnd c1 c2) 0 < 0) \<longrightarrow> \<not>(evals p t (cAnd c1 c2))"
     apply simp
  proof -
    {fix p :: real
      assume "(robust p t (cAnd c1 c2) 0 < 0)"
      then have "\<not>(evals p t (cAnd c1 c2))"
        using cAnd
        by force}
    then show "\<And>p. (robust p t (cAnd c1 c2) 0 < 0) \<longrightarrow> \<not>(evals p t (cAnd c1 c2))"
      by blast
  qed
next
  case (cUntil x y c1 c2)
  then show "\<And>p. (robust p t (cUntil x y c1 c2) 0 > 0) \<longrightarrow> (evals p t (cUntil x y c1 c2))"
       "\<And>p. (robust p t (cUntil x y c1 c2) 0 < 0) \<longrightarrow> \<not>(evals p t (cUntil x y c1 c2))"
    unfolding evals.simps(4) robust.simps(4)
  proof -
    have U1:"\<And>p z. Min_gamma_comp 0 (fst z - (p+x)) (Min_gamma_comp 0 (p+y - fst z) (robust (fst z) t c2 0)) > 0
      \<longrightarrow> fst z \<ge> p+x \<and> fst z \<le> p+y \<and> evals (fst z) t c2"
    proof -
      {fix z :: "(real\<times>'v)" and p :: real
        assume "Min_gamma_comp 0 (fst z - (p+x)) (Min_gamma_comp 0 (p+y - fst z) (robust (fst z) t c2 0)) > 0"
        then have "(fst z - (p+x))>0 \<and> (p+y-fst z) > 0 \<and> (robust (fst z) t c2 0) > 0"
          by force
        then have "fst z \<ge> p+x \<and> fst z \<le> p+y \<and> evals (fst z) t c2"
          using cUntil
          by auto}
      then show "\<And>p z. Min_gamma_comp 0 (fst z - (p+x)) (Min_gamma_comp 0 (p+y - fst z) (robust (fst z) t c2 0)) > 0
      \<longrightarrow> fst z \<ge> p+x \<and> fst z \<le> p+y \<and> evals (fst z) t c2"
        by blast
    qed
    have U2:"\<And>p z. Min_gamma_comp 0 (fst z - (p+x)) (Min_gamma_comp 0 (p+y - fst z) (robust (fst z) t c2 0)) < 0
      \<longrightarrow> \<not>(fst z \<ge> p+x \<and> fst z \<le> p+y \<and> evals (fst z) t c2)"
    proof -
      {fix z :: "(real\<times>'v)" and p :: real
        assume "Min_gamma_comp 0 (fst z - (p+x)) (Min_gamma_comp 0 (p+y - fst z) (robust (fst z) t c2 0)) < 0"
        then have "(fst z - (p+x)) < 0 \<or> (p+y-fst z) < 0 \<or> (robust (fst z) t c2 0) < 0"
          by auto
        then have "\<not>(fst z \<ge> p+x \<and> fst z \<le> p+y \<and> evals (fst z) t c2)"
          using cUntil
          by auto}
      then show "\<And>p z. Min_gamma_comp 0 (fst z - (p+x)) (Min_gamma_comp 0 (p+y - fst z) (robust (fst z) t c2 0)) < 0
      \<longrightarrow> \<not>(fst z \<ge> p+x \<and> fst z \<le> p+y \<and> evals (fst z) t c2)"
        by blast
    qed
    have U3:"\<And>p z. Max_gamma_comp 0 (robust (fst z) t c1 0) (p-fst z) > 0
      \<longrightarrow> evals (fst z) t c1 \<or> fst z < p"
    proof -
      {fix z :: "(real\<times>'v)" and p :: real
        assume "Max_gamma_comp 0 (robust (fst z) t c1 0) (p-fst z) > 0"
        then have "(robust (fst z) t c1 0) > 0 \<or> (p-fst z) > 0"
          by auto
        then have "(evals (fst z) t c1 \<or> fst z < p)"
          using cUntil
          by auto}
      then show "\<And>p z. Max_gamma_comp 0 (robust (fst z) t c1 0) (p-fst z) > 0
      \<longrightarrow> evals (fst z) t c1 \<or> fst z < p"
        by blast
    qed
    have U4:"\<And>p z. Max_gamma_comp 0 (robust (fst z) t c1 0) (p-fst z) < 0
      \<longrightarrow> \<not>(evals (fst z) t c1 \<or> fst z < p)"
    proof -
      {fix z :: "(real\<times>'v)" and p :: real
        assume "Max_gamma_comp 0 (robust (fst z) t c1 0) (p-fst z) < 0"
        then have "(robust (fst z) t c1 0) < 0 \<and> (p-fst z) < 0"
          by auto
        then have "\<not>(evals (fst z) t c1 \<or> fst z < p)"
          using cUntil
          by simp}
      then show "\<And>p z. Max_gamma_comp 0 (robust (fst z) t c1 0) (p-fst z) < 0
      \<longrightarrow> \<not>(evals (fst z) t c1 \<or> fst z < p)"
        by blast
    qed
    then show "(\<And>p. 0 < recurs_release_real
               (\<lambda>z \<gamma>. Min_gamma_comp \<gamma> (fst z - (p + x)) (Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>)))
               (\<lambda>z \<gamma>. Max_gamma_comp \<gamma> (robust (fst z) t c1 \<gamma>) (p - fst z)) t 0 (-1) \<longrightarrow>
          recurs_release (\<lambda>z. p + x \<le> fst z \<and> fst z \<le> p + y \<and> evals (fst z) t c2) (\<lambda>z. evals (fst z) t c1 \<or> fst z < p)
           t)"
       "(\<And>p. recurs_release_real
           (\<lambda>z \<gamma>. Min_gamma_comp \<gamma> (fst z - (p + x)) (Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>)))
           (\<lambda>z \<gamma>. Max_gamma_comp \<gamma> (robust (fst z) t c1 \<gamma>) (p - fst z)) t 0 (-1)
          < 0 \<longrightarrow>
          \<not> recurs_release (\<lambda>z. p + x \<le> fst z \<and> fst z \<le> p + y \<and> evals (fst z) t c2)
              (\<lambda>z. evals (fst z) t c1 \<or> fst z < p) t)"
    proof -
      {fix p :: real
        have "0 < recurs_release_real
               (\<lambda>z \<gamma>. Min_gamma_comp \<gamma> (fst z - (p + x)) (Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>)))
               (\<lambda>z \<gamma>. Max_gamma_comp \<gamma> (robust (fst z) t c1 \<gamma>) (p - fst z)) t 0 (-1) \<longrightarrow>
          recurs_release (\<lambda>z. p + x \<le> fst z \<and> fst z \<le> p + y \<and> evals (fst z) t c2) (\<lambda>z. evals (fst z) t c1 \<or> fst z < p)
           t"
          "recurs_release_real
           (\<lambda>z \<gamma>. Min_gamma_comp \<gamma> (fst z - (p + x)) (Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>)))
           (\<lambda>z \<gamma>. Max_gamma_comp \<gamma> (robust (fst z) t c1 \<gamma>) (p - fst z)) t 0 (-1)
          < 0 \<longrightarrow>
          \<not> recurs_release (\<lambda>z. p + x \<le> fst z \<and> fst z \<le> p + y \<and> evals (fst z) t c2)
              (\<lambda>z. evals (fst z) t c1 \<or> fst z < p) t"
          using U1 U2 U3 U4 recurs_release_real_sound_0
            [where ?Pr="\<lambda>z \<gamma>. Min_gamma_comp \<gamma> (fst z - (p + x)) (Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>))"
              and ?P'r="\<lambda>z \<gamma>. Max_gamma_comp \<gamma> (robust (fst z) t c1 \<gamma>) (p - fst z)"
              and ?P="\<lambda>z. p + x \<le> fst z \<and> fst z \<le> p + y \<and> evals (fst z) t c2"
              and ?P'="\<lambda>z. evals (fst z) t c1 \<or> fst z < p" and ?t="t"]
          by blast+}
      then show "(\<And>p. 0 < recurs_release_real
                   (\<lambda>z \<gamma>. Min_gamma_comp \<gamma> (fst z - (p + x)) (Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>)))
                   (\<lambda>z \<gamma>. Max_gamma_comp \<gamma> (robust (fst z) t c1 \<gamma>) (p - fst z)) t 0 (-1) \<longrightarrow>
              recurs_release (\<lambda>z. p + x \<le> fst z \<and> fst z \<le> p + y \<and> evals (fst z) t c2) (\<lambda>z. evals (fst z) t c1 \<or> fst z < p)
               t)"
           "(\<And>p. recurs_release_real
               (\<lambda>z \<gamma>. Min_gamma_comp \<gamma> (fst z - (p + x)) (Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>)))
               (\<lambda>z \<gamma>. Max_gamma_comp \<gamma> (robust (fst z) t c1 \<gamma>) (p - fst z)) t 0 (-1)
              < 0 \<longrightarrow>
              \<not> recurs_release (\<lambda>z. p + x \<le> fst z \<and> fst z \<le> p + y \<and> evals (fst z) t c2)
                  (\<lambda>z. evals (fst z) t c1 \<or> fst z < p) t)"
        by blast+
    qed
  qed
qed

lemma robust_const_bel0:
  shows "\<And>p. \<forall>\<gamma>\<le>0. robust p t c \<gamma> = robust p t c 0"
proof (induct c)
  case (cMu f r)
  then show ?case
    by simp
next
  case (cNot c)
  then show ?case
    using robust.simps(2)
    by metis
next
  case (cAnd c1 c2)
  then show ?case
    using Min_gamma_const_bel0 Min_gamma_comp_eq robust.simps(3)
    by metis
next
  case (cUntil x y c1 c2)
  then have "\<And>z. \<forall>\<gamma>\<le>0. Min_gamma_comp \<gamma> (fst z - (p + x)) (Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>))
        = Min_gamma_comp 0 (fst z - (p + x)) (Min_gamma_comp 0 (p + y - fst z) (robust (fst z) t c2 0))"
      "\<And>z. \<forall>\<gamma>\<le>0. Max_gamma_comp \<gamma> (robust (fst z) t c1 \<gamma>) (p - fst z)
        = Max_gamma_comp 0 (robust (fst z) t c1 0) (p - fst z)"
    using Min_gamma_const_bel0 Min_gamma_comp_eq Max_gamma_const_bel0 Max_gamma_comp_eq
    by metis+
  then show ?case
    using robust.simps(4) recurs_release_real_const_bel0_const [where ?t="t"
      and ?P="\<lambda>z \<gamma>. Min_gamma_comp \<gamma> (fst z - (p + x)) (Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>))"
      and ?P'="\<lambda>z \<gamma>. Max_gamma_comp \<gamma> (robust (fst z) t c1 \<gamma>) (p - fst z)" and ?E="-1"]
    by auto
qed

lemma robust_cont_0:
  shows "\<And>p. isCont (robust p t c) 0"
proof (induct c)
  case (cMu f r)
  then show ?case
    by simp
next
  case (cNot c)
  then show ?case
    by simp
next
  case (cAnd c1 c2)
  then have "\<forall>\<gamma>\<le>0. robust p t c1 \<gamma> = robust p t c1 0"
    "\<forall>x\<le>0. robust p t c2 x = robust p t c2 0"
    using robust_const_bel0
    by force+
  then show ?case
    using cAnd Min_gamma_chain_cont_0 [where ?f="robust p t c1" and ?g="robust p t c2"] Min_gamma_comp_eq
    by fastforce
next
  case (cUntil x y c1 c2)
  {fix p :: real
    let ?P="\<lambda>z \<gamma>. Min_gamma_comp \<gamma> (fst z - (p + x)) (Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>))"
    let ?P'="\<lambda>z \<gamma>. Max_gamma_comp \<gamma> (robust (fst z) t c1 \<gamma>) (p - fst z)"
    {fix z :: "(real\<times>'v)"
      have 1:"\<forall>\<gamma>\<le>0. robust (fst z) t c1 \<gamma> = robust (fst z) t c1 0"
          "\<forall>\<gamma>\<le>0. robust (fst z) t c2 \<gamma> = robust (fst z) t c2 0"
        using robust_const_bel0 recurs_release_real.simps robust.simps(4)
        by blast+
      then have 3:"isCont (?P' z) 0"
        using cUntil Max_gamma_chain_cont_0 [where ?f="robust (fst z) t c1" and ?g="\<lambda>\<gamma>. p - fst z"]
          Max_gamma_comp_eq
        by fastforce
      then have 4:"\<forall>\<gamma>\<le>0. ?P' z \<gamma> = ?P' z 0"
        using Max_gamma_const_bel0 Max_gamma_comp_eq 1
        by presburger
      then have 5:"\<forall>\<gamma>\<le>0. ?P z \<gamma> = ?P z 0"
        using 1 Min_gamma_const_bel0 Min_gamma_comp_eq
        by presburger
      have 2:"isCont (\<lambda>\<gamma>. Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>)) 0"
        using 1 cUntil Min_gamma_chain_cont_0 [where ?g="robust (fst z) t c2" and ?f="\<lambda>\<gamma>. p + y - fst z"]
          Min_gamma_comp_eq
        by fastforce
      have "\<forall>\<gamma>\<le>0. Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>) = Min_gamma_comp 0 (p + y - fst z) (robust (fst z) t c2 0)"
        using 1 Min_gamma_const_bel0 Min_gamma_comp_eq
        by presburger
      then have "isCont (?P z) 0" "isCont (?P' z) 0" "\<forall>\<gamma>\<le>0. ?P' z \<gamma> = ?P' z 0"
        using 2 cUntil Min_gamma_chain_cont_0 [where ?f="\<lambda>\<gamma>. fst z-(p+x)" and ?g="\<lambda>\<gamma>. Min_gamma_comp \<gamma> (p + y - fst z) (robust (fst z) t c2 \<gamma>)"]
          Min_gamma_comp_eq 3 4
        by fastforce+
      then have "isCont (?P z) 0" "isCont (?P' z) 0" "\<forall>\<gamma>\<le>0. ?P' z \<gamma> = ?P' z 0" "\<forall>\<gamma>\<le>0. ?P z \<gamma> = ?P z 0"
        using 5
        by blast+}
    then have "isCont (\<lambda>\<gamma>. recurs_release_real ?P ?P' t \<gamma> (-1)) 0"
      using recurs_release_real_cont_0 [where ?P="?P" and ?P'="?P'" and ?t="t"]
      by blast}
  then show ?case
    using robust.simps(4)
    by auto
qed

lemma robust_sound:
  assumes "robust p t c \<midarrow>0\<rightarrow> x"
  shows "x>0 \<longrightarrow> evals p t c"
    "x<0 \<longrightarrow> \<not>evals p t c"
  using robust_cont_0 robust_sound_0 LIM_unique assms continuous_within
  by blast+

definition evalsb :: "real \<Rightarrow> ((real\<times>'v) list) list \<Rightarrow> 'v constraint \<Rightarrow> bool list" where
"evalsb p T c = map (\<lambda>t. evals p t c) T"

definition robustb :: "real \<Rightarrow> ((real\<times>'v) list) list \<Rightarrow> 'v constraint \<Rightarrow> real \<Rightarrow> real list" where
"robustb p T c \<gamma> = map (\<lambda>t. robust p t c \<gamma>) T"

lemma robustb_sound:
  assumes "\<forall>n<length T. (\<lambda>\<gamma>. (robustb p T c \<gamma>)!n) \<midarrow>0\<rightarrow> X!n"
  shows "\<forall>n<length T. (X!n) > 0 \<longrightarrow> (evalsb p T c)!n"
    "\<forall>n<length T. (X!n) < 0 \<longrightarrow> \<not>((evalsb p T c)!n)"
proof -
  {fix n :: nat
    assume "n<length T"
    then have "(\<lambda>\<gamma>. (robustb p T c \<gamma>)!n) \<midarrow>0\<rightarrow> robust p (T!n) c 0"
      using robustb_def robust_cont_0 LIM_cong continuous_at nth_map
      by (smt (verit))}
  then have "\<forall>n<length T. X!n = robust p (T!n) c 0"
    using assms LIM_unique
    by blast
  then show "\<forall>n<length T. (X!n) > 0 \<longrightarrow> (evalsb p T c)!n"
    "\<forall>n<length T. (X!n) < 0 \<longrightarrow> \<not>((evalsb p T c)!n)"
  using robust_sound_0 robustb_def evalsb_def LIM_cong nth_map
  by metis+
qed

fun nthint :: "'a list \<Rightarrow> int \<Rightarrow> 'a" where
"nthint [] n = undefined"
| "nthint (x # xs) n = (if eqint n 0 then x else nthint xs ((absint n)-1))"

fun Feval :: "cterm \<Rightarrow> real list \<Rightarrow> real" where
"Feval (Get n) xs = nthint xs n"
| "Feval (Add c1 c2) xs = Feval c1 xs + Feval c2 xs"
| "Feval (Mult c1 c2) xs = Feval c1 xs * Feval c2 xs"
| "Feval (Uminus c) xs = -1 * (Feval c xs)"
| "Feval (Divide c1 c2) xs = Feval c1 xs / Feval c2 xs"

fun constraintright :: "real list constraint \<Rightarrow> bool" where
"constraintright (cMu f ct r) = (f = Feval)"
| "constraintright (cNot c) = constraintright c"
| "constraintright (cAnd c1 c2) = (constraintright c1 \<and> constraintright c2)"
| "constraintright (cUntil x y c1 c2) = (constraintright c1 \<and> constraintright c2)"

typedef rconstraint = "{c. constraintright c}"
  morphisms to_constraint to_rconstraint
  using constraintright.simps(1)
  by blast

declare to_constraint_inverse [simp]
  to_rconstraint_inverse [simp]

setup_lifting type_definition_rconstraint

lift_definition revals :: "real \<Rightarrow> (real\<times>real list) list \<Rightarrow> rconstraint \<Rightarrow> bool" is evals .

lift_definition rrobust :: "real \<Rightarrow> (real \<times>real list) list \<Rightarrow> rconstraint \<Rightarrow> real \<Rightarrow> real" is robust .

lemma rrobust_sound:
  fixes p :: real and t :: "(real\<times>real list) list" and c :: rconstraint and x :: real
  assumes "rrobust p t c \<midarrow>0\<rightarrow> x"
  shows "x>0 \<longrightarrow> revals p t c"
    "x<0 \<longrightarrow> \<not>revals p t c"
proof -
  have "robust p t (to_constraint c) \<midarrow>0\<rightarrow> x"
    using assms
    by (simp add: rrobust.rep_eq)
  then have "x>0 \<longrightarrow> evals p t (to_constraint c)"
    "x<0 \<longrightarrow> \<not>evals p t (to_constraint c)"
    using robust_sound
    by blast+
  then show "x>0 \<longrightarrow> revals p t c"
    "x<0 \<longrightarrow> \<not>revals p t c"
    by (simp add: revals.rep_eq)+
qed

(* Type constructors for code generation *)
definition mkGet :: "int \<Rightarrow> cterm" where
"mkGet n = Get n"

definition mkAdd :: "cterm \<Rightarrow> cterm \<Rightarrow> cterm" where
"mkAdd ct1 ct2 = Add ct1 ct2"

definition mkMult :: "cterm \<Rightarrow> cterm \<Rightarrow> cterm" where
"mkMult ct1 ct2 = Mult ct1 ct2"

definition mkUminus :: "cterm \<Rightarrow> cterm" where
"mkUminus ct = Uminus ct"

definition mkDivide :: "cterm \<Rightarrow> cterm \<Rightarrow> cterm" where
"mkDivide ct1 ct2 = Divide ct1 ct2"

definition mkMu :: "(cterm \<Rightarrow> 'v \<Rightarrow> real) \<Rightarrow> cterm \<Rightarrow> real \<Rightarrow> 'v constraint" where
  "mkMu f ct r = cMu f ct r"

definition mkNot :: "'v constraint \<Rightarrow> 'v constraint" where
  "mkNot c = cNot c"

definition mkAnd :: "'v constraint \<Rightarrow> 'v constraint \<Rightarrow> 'v constraint" where
  "mkAnd c1 c2 = cAnd c1 c2"

definition mkUntil :: "real \<Rightarrow> real \<Rightarrow> 'v constraint \<Rightarrow> 'v constraint \<Rightarrow> 'v constraint" where
  "mkUntil x y c1 c2 = cUntil x y c1 c2"

export_code mkGet mkAdd mkMult mkUminus mkDivide mkMu mkNot mkAnd mkUntil evals robust Feval
 in OCaml
  module_name STLLoss

end


theory Abstract_Formula
imports
  Main
  "~~/src/HOL/Library/FSet"
  "~~/src/HOL/Library/Stream"
  Indexed_FSet
begin

text \<open>
The following locale describes an abstract interface for a set of formulas, without fixing the
concret shape, or set of variables.

The variables mentioned in this locale are only the @{emph \<open>locally fixed constants\<close>} occuring in
formulas, e.g.\@ in the introduction rule for the universal quantifier. Normal variables are not
something we care about at this point; they are handled completely abstractly by the abstract notion
of a substitution.
\<close>

locale Abstract_Formulas =
  -- \<open>Variables can be renamed injectively\<close>
  fixes freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
  -- \<open>A variable-changing function can be mapped over a formula\<close>
  fixes renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('form \<Rightarrow> 'form)"
  -- \<open>The set of variables occurring in a formula\<close>
  fixes lconsts :: "'form \<Rightarrow> 'var set"
  -- \<open>A closed formula has no variables, and substitions do not affect it.\<close>
  fixes closed :: "'form \<Rightarrow> bool"
  -- \<open>A substitution can be applied to a formula.\<close>
  fixes subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
  -- \<open>The set of variables occurring (in the image) of a substitution.\<close>
  fixes subst_lconsts :: "'subst \<Rightarrow> 'var set"
  -- \<open>A variable-changing function can be mapped over a substitution\<close>
  fixes subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
  -- \<open>A most generic formula, can be substitutied to anything.\<close>
  fixes anyP :: "'form"

  assumes freshenLC_eq_iff[simp]: "freshenLC a v = freshenLC a' v' \<longleftrightarrow> a = a' \<and> v = v'"
  assumes lconsts_renameLCs: "lconsts (renameLCs p f) = p ` lconsts f"
  assumes rename_closed: "lconsts f = {} \<Longrightarrow> renameLCs p f = f"
  assumes subst_closed: "closed f \<Longrightarrow> subst s f = f"
  assumes closed_no_lconsts: "closed f \<Longrightarrow> lconsts f = {}"
  assumes fv_subst: "lconsts (subst s f) \<subseteq> lconsts f \<union> subst_lconsts s"
  assumes rename_rename: "renameLCs p1 (renameLCs p2 f) = renameLCs (p1 \<circ> p2) f"
  assumes rename_subst: "renameLCs p (subst s f) = subst (subst_renameLCs p s) (renameLCs p f)"
  assumes renameLCs_cong: "(\<And> x. x \<in> lconsts f \<Longrightarrow> f1 x = f2 x) \<Longrightarrow> renameLCs f1 f = renameLCs f2 f"
  assumes subst_renameLCs_cong: "(\<And> x. x \<in> subst_lconsts s \<Longrightarrow> f1 x = f2 x) \<Longrightarrow> subst_renameLCs f1 s = subst_renameLCs f2 s"
  assumes subst_lconsts_subst_renameLCs: "subst_lconsts (subst_renameLCs p s) = p ` subst_lconsts s"
  assumes lconsts_anyP: "lconsts anyP = {}"
  assumes empty_subst: "\<exists> s. (\<forall> f. subst s f = f) \<and> subst_lconsts s = {}"
  assumes anyP_is_any: "\<exists> s. subst s anyP = f"
begin
  definition freshen :: "nat \<Rightarrow> 'form \<Rightarrow> 'form" where
    "freshen n = renameLCs (freshenLC n)"

  definition empty_subst :: "'subst" where
    "empty_subst = (SOME s. (\<forall> f. subst s f = f) \<and> subst_lconsts s = {})"

  lemma empty_subst_spec:
    "(\<forall> f. subst empty_subst f = f) \<and> subst_lconsts empty_subst = {}"
    unfolding empty_subst_def using empty_subst by (rule someI_ex)
  lemma subst_empty_subst[simp]: "subst empty_subst f = f"
    by (metis empty_subst_spec)
  lemma subst_lconsts_empty_subst[simp]: "subst_lconsts empty_subst = {}"
    by (metis empty_subst_spec)

  lemma lconsts_freshen: "lconsts (freshen a f) = freshenLC a ` lconsts f"
    unfolding freshen_def by (rule lconsts_renameLCs)

  lemma freshen_closed: "lconsts f = {} \<Longrightarrow> freshen a f = f"
    unfolding freshen_def by (rule rename_closed)

  lemma closed_eq:
    assumes "closed f1"
    assumes "closed f2"
    shows "subst s1 (freshen a1 f1) = subst s2 (freshen a2 f2) \<longleftrightarrow> f1 = f2"
  using assms
    by (auto simp add: closed_no_lconsts freshen_def lconsts_freshen subst_closed rename_closed)

  lemma freshenLC_range_eq_iff[simp]: "freshenLC a v \<in> range (freshenLC a') \<longleftrightarrow> a = a'"
    by auto

  definition rerename :: "'var set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('var \<Rightarrow> 'var) \<Rightarrow> ('var \<Rightarrow> 'var)" where
    "rerename V from to f x = (if x \<in> freshenLC from ` V then freshenLC to (inv (freshenLC from) x) else f x)"

  lemma inj_freshenLC[simp]: "inj (freshenLC i)"
    by (rule injI) simp

  lemma rerename_freshen[simp]: "x \<in> V \<Longrightarrow> rerename  V i (isidx is) f (freshenLC i x) = freshenLC (isidx is) x"
    unfolding rerename_def by simp

  lemma range_rerename: "range (rerename V  from to f) \<subseteq> freshenLC to ` V \<union> range f"
    by (auto simp add: rerename_def split: if_splits)

  lemma rerename_noop:
      "x \<notin> freshenLC from ` V  \<Longrightarrow> rerename V from to f x = f x"
    by (auto simp add: rerename_def split: if_splits)

  lemma rerename_rename_noop:
      "freshenLC from ` V \<inter> lconsts form  = {}  \<Longrightarrow> renameLCs (rerename V from to f) form = renameLCs f form"
      by (intro renameLCs_cong rerename_noop) auto

  lemma rerename_subst_noop:
      "freshenLC from ` V \<inter> subst_lconsts s  = {}  \<Longrightarrow> subst_renameLCs (rerename V from to f) s = subst_renameLCs f s"
      by (intro subst_renameLCs_cong rerename_noop) auto
end
end


(*  Title:      ZF/Constructible/Normal.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Closed Unbounded Classes and Normal Functions\<close>

theory Normal imports ZF begin

text\<open>
One source is the book

Frank R. Drake.
\emph{Set Theory: An Introduction to Large Cardinals}.
North-Holland, 1974.
\<close>

subsection \<open>Closed and Unbounded (c.u.) Classes of Ordinals\<close>

definition
  Closed :: "(i=>o) => o" where
    "Closed(P) == \<forall>I. I \<noteq> 0 \<longrightarrow> (\<forall>i\<in>I. Ord(i) \<and> P(i)) \<longrightarrow> P(\<Union>(I))"

definition
  Unbounded :: "(i=>o) => o" where
    "Unbounded(P) == \<forall>i. Ord(i) \<longrightarrow> (\<exists>j. i<j \<and> P(j))"

definition
  Closed_Unbounded :: "(i=>o) => o" where
    "Closed_Unbounded(P) == Closed(P) \<and> Unbounded(P)"

subsubsection\<open>Simple facts about c.u. classes\<close>

lemma ClosedI:
     "[| !!I. [| I \<noteq> 0; \<forall>i\<in>I. Ord(i) \<and> P(i) |] ==> P(\<Union>(I)) |]
      ==> Closed(P)"
by (simp add: Closed_def)

lemma ClosedD:
     "[| Closed(P); I \<noteq> 0; !!i. i\<in>I ==> Ord(i); !!i. i\<in>I ==> P(i) |]
      ==> P(\<Union>(I))"
by (simp add: Closed_def)

lemma UnboundedD:
     "[| Unbounded(P);  Ord(i) |] ==> \<exists>j. i<j \<and> P(j)"
by (simp add: Unbounded_def)

lemma Closed_Unbounded_imp_Unbounded: "Closed_Unbounded(C) ==> Unbounded(C)"
by (simp add: Closed_Unbounded_def)

text\<open>The universal class, V, is closed and unbounded.
      A bit odd, since C. U. concerns only ordinals, but it's used below!\<close>
theorem Closed_Unbounded_V [simp]: "Closed_Unbounded(\<lambda>x. True)"
by (unfold Closed_Unbounded_def Closed_def Unbounded_def, blast)

text\<open>The class of ordinals, \<^term>\<open>Ord\<close>, is closed and unbounded.\<close>
theorem Closed_Unbounded_Ord   [simp]: "Closed_Unbounded(Ord)"
by (unfold Closed_Unbounded_def Closed_def Unbounded_def, blast)

text\<open>The class of limit ordinals, \<^term>\<open>Limit\<close>, is closed and unbounded.\<close>
theorem Closed_Unbounded_Limit [simp]: "Closed_Unbounded(Limit)"
apply (simp add: Closed_Unbounded_def Closed_def Unbounded_def Limit_Union,
       clarify)
apply (rule_tac x="i++nat" in exI)
apply (blast intro: oadd_lt_self oadd_LimitI Limit_has_0)
done

text\<open>The class of cardinals, \<^term>\<open>Card\<close>, is closed and unbounded.\<close>
theorem Closed_Unbounded_Card  [simp]: "Closed_Unbounded(Card)"
apply (simp add: Closed_Unbounded_def Closed_def Unbounded_def)
apply (blast intro: lt_csucc Card_csucc)
done

subsubsection\<open>The intersection of any set-indexed family of c.u. classes is
      c.u.\<close>

text\<open>The constructions below come from Kunen, \emph{Set Theory}, page 78.\<close>
locale cub_family =
  fixes P and A
  fixes next_greater \<comment> \<open>the next ordinal satisfying class \<^term>\<open>A\<close>\<close>
  fixes sup_greater  \<comment> \<open>sup of those ordinals over all \<^term>\<open>A\<close>\<close>
  assumes closed:    "a\<in>A ==> Closed(P(a))"
      and unbounded: "a\<in>A ==> Unbounded(P(a))"
      and A_non0: "A\<noteq>0"
  defines "next_greater(a,x) == \<mu> y. x<y \<and> P(a,y)"
      and "sup_greater(x) == \<Union>a\<in>A. next_greater(a,x)"

text\<open>Trivial that the intersection is closed.\<close>
lemma (in cub_family) Closed_INT: "Closed(\<lambda>x. \<forall>i\<in>A. P(i,x))"
by (blast intro: ClosedI ClosedD [OF closed])

text\<open>All remaining effort goes to show that the intersection is unbounded.\<close>

lemma (in cub_family) Ord_sup_greater:
     "Ord(sup_greater(x))"
by (simp add: sup_greater_def next_greater_def)

lemma (in cub_family) Ord_next_greater:
     "Ord(next_greater(a,x))"
by (simp add: next_greater_def)

text\<open>\<^term>\<open>next_greater\<close> works as expected: it returns a larger value
and one that belongs to class \<^term>\<open>P(a)\<close>.\<close>
lemma (in cub_family) next_greater_lemma:
     "[| Ord(x); a\<in>A |] ==> P(a, next_greater(a,x)) \<and> x < next_greater(a,x)"
apply (simp add: next_greater_def)
apply (rule exE [OF UnboundedD [OF unbounded]])
  apply assumption+
apply (blast intro: LeastI2 lt_Ord2)
done

lemma (in cub_family) next_greater_in_P:
     "[| Ord(x); a\<in>A |] ==> P(a, next_greater(a,x))"
by (blast dest: next_greater_lemma)

lemma (in cub_family) next_greater_gt:
     "[| Ord(x); a\<in>A |] ==> x < next_greater(a,x)"
by (blast dest: next_greater_lemma)

lemma (in cub_family) sup_greater_gt:
     "Ord(x) ==> x < sup_greater(x)"
apply (simp add: sup_greater_def)
apply (insert A_non0)
apply (blast intro: UN_upper_lt next_greater_gt Ord_next_greater)
done

lemma (in cub_family) next_greater_le_sup_greater:
     "a\<in>A ==> next_greater(a,x) \<le> sup_greater(x)"
apply (simp add: sup_greater_def)
apply (blast intro: UN_upper_le Ord_next_greater)
done

lemma (in cub_family) omega_sup_greater_eq_UN:
     "[| Ord(x); a\<in>A |]
      ==> sup_greater^\<omega> (x) =
          (\<Union>n\<in>nat. next_greater(a, sup_greater^n (x)))"
apply (simp add: iterates_omega_def)
apply (rule le_anti_sym)
apply (rule le_implies_UN_le_UN)
apply (blast intro: leI next_greater_gt Ord_iterates Ord_sup_greater)
txt\<open>Opposite bound:
@{subgoals[display,indent=0,margin=65]}
\<close>
apply (rule UN_least_le)
apply (blast intro: Ord_iterates Ord_sup_greater)
apply (rule_tac a="succ(n)" in UN_upper_le)
apply (simp_all add: next_greater_le_sup_greater)
apply (blast intro: Ord_iterates Ord_sup_greater)
done

lemma (in cub_family) P_omega_sup_greater:
     "[| Ord(x); a\<in>A |] ==> P(a, sup_greater^\<omega> (x))"
apply (simp add: omega_sup_greater_eq_UN)
apply (rule ClosedD [OF closed])
apply (blast intro: ltD, auto)
apply (blast intro: Ord_iterates Ord_next_greater Ord_sup_greater)
apply (blast intro: next_greater_in_P Ord_iterates Ord_sup_greater)
done

lemma (in cub_family) omega_sup_greater_gt:
     "Ord(x) ==> x < sup_greater^\<omega> (x)"
apply (simp add: iterates_omega_def)
apply (rule UN_upper_lt [of 1], simp_all)
 apply (blast intro: sup_greater_gt)
apply (blast intro: Ord_iterates Ord_sup_greater)
done

lemma (in cub_family) Unbounded_INT: "Unbounded(\<lambda>x. \<forall>a\<in>A. P(a,x))"
apply (unfold Unbounded_def)
apply (blast intro!: omega_sup_greater_gt P_omega_sup_greater)
done

lemma (in cub_family) Closed_Unbounded_INT:
     "Closed_Unbounded(\<lambda>x. \<forall>a\<in>A. P(a,x))"
by (simp add: Closed_Unbounded_def Closed_INT Unbounded_INT)

theorem Closed_Unbounded_INT:
    "(!!a. a\<in>A ==> Closed_Unbounded(P(a)))
     ==> Closed_Unbounded(\<lambda>x. \<forall>a\<in>A. P(a, x))"
apply (case_tac "A=0", simp)
apply (rule cub_family.Closed_Unbounded_INT [OF cub_family.intro])
apply (simp_all add: Closed_Unbounded_def)
done

lemma Int_iff_INT2:
     "P(x) \<and> Q(x)  \<longleftrightarrow>  (\<forall>i\<in>2. (i=0 \<longrightarrow> P(x)) \<and> (i=1 \<longrightarrow> Q(x)))"
by auto

theorem Closed_Unbounded_Int:
     "[| Closed_Unbounded(P); Closed_Unbounded(Q) |]
      ==> Closed_Unbounded(\<lambda>x. P(x) \<and> Q(x))"
apply (simp only: Int_iff_INT2)
apply (rule Closed_Unbounded_INT, auto)
done

subsection \<open>Normal Functions\<close>

definition
  mono_le_subset :: "(i=>i) => o" where
    "mono_le_subset(M) == \<forall>i j. i\<le>j \<longrightarrow> M(i) \<subseteq> M(j)"

definition
  mono_Ord :: "(i=>i) => o" where
    "mono_Ord(F) == \<forall>i j. i<j \<longrightarrow> F(i) < F(j)"

definition
  cont_Ord :: "(i=>i) => o" where
    "cont_Ord(F) == \<forall>l. Limit(l) \<longrightarrow> F(l) = (\<Union>i<l. F(i))"

definition
  Normal :: "(i=>i) => o" where
    "Normal(F) == mono_Ord(F) \<and> cont_Ord(F)"

subsubsection\<open>Immediate properties of the definitions\<close>

lemma NormalI:
     "[|!!i j. i<j ==> F(i) < F(j);  !!l. Limit(l) ==> F(l) = (\<Union>i<l. F(i))|]
      ==> Normal(F)"
by (simp add: Normal_def mono_Ord_def cont_Ord_def)

lemma mono_Ord_imp_Ord: "[| Ord(i); mono_Ord(F) |] ==> Ord(F(i))"
apply (auto simp add: mono_Ord_def)
apply (blast intro: lt_Ord)
done

lemma mono_Ord_imp_mono: "[| i<j; mono_Ord(F) |] ==> F(i) < F(j)"
by (simp add: mono_Ord_def)

lemma Normal_imp_Ord [simp]: "[| Normal(F); Ord(i) |] ==> Ord(F(i))"
by (simp add: Normal_def mono_Ord_imp_Ord)

lemma Normal_imp_cont: "[| Normal(F); Limit(l) |] ==> F(l) = (\<Union>i<l. F(i))"
by (simp add: Normal_def cont_Ord_def)

lemma Normal_imp_mono: "[| i<j; Normal(F) |] ==> F(i) < F(j)"
by (simp add: Normal_def mono_Ord_def)

lemma Normal_increasing:
  assumes i: "Ord(i)" and F: "Normal(F)" shows"i \<le> F(i)"
using i
proof (induct i rule: trans_induct3)
  case 0 thus ?case by (simp add: subset_imp_le F)
next
  case (succ i)
  hence "F(i) < F(succ(i))" using F
    by (simp add: Normal_def mono_Ord_def)
  thus ?case using succ.hyps
    by (blast intro: lt_trans1)
next
  case (limit l)
  hence "l = (\<Union>y<l. y)"
    by (simp add: Limit_OUN_eq)
  also have "... \<le> (\<Union>y<l. F(y))" using limit
    by (blast intro: ltD le_implies_OUN_le_OUN)
  finally have "l \<le> (\<Union>y<l. F(y))" .
  moreover have "(\<Union>y<l. F(y)) \<le> F(l)" using limit F
    by (simp add: Normal_imp_cont lt_Ord)
  ultimately show ?case
    by (blast intro: le_trans)
qed

subsubsection\<open>The class of fixedpoints is closed and unbounded\<close>

text\<open>The proof is from Drake, pages 113--114.\<close>

lemma mono_Ord_imp_le_subset: "mono_Ord(F) ==> mono_le_subset(F)"
apply (simp add: mono_le_subset_def, clarify)
apply (subgoal_tac "F(i)\<le>F(j)", blast dest: le_imp_subset)
apply (simp add: le_iff)
apply (blast intro: lt_Ord2 mono_Ord_imp_Ord mono_Ord_imp_mono)
done

text\<open>The following equation is taken for granted in any set theory text.\<close>
lemma cont_Ord_Union:
     "[| cont_Ord(F); mono_le_subset(F); X=0 \<longrightarrow> F(0)=0; \<forall>x\<in>X. Ord(x) |]
      ==> F(\<Union>(X)) = (\<Union>y\<in>X. F(y))"
apply (frule Ord_set_cases)
apply (erule disjE, force)
apply (thin_tac "X=0 \<longrightarrow> Q" for Q, auto)
 txt\<open>The trival case of \<^term>\<open>\<Union>X \<in> X\<close>\<close>
 apply (rule equalityI, blast intro: Ord_Union_eq_succD)
 apply (simp add: mono_le_subset_def UN_subset_iff le_subset_iff)
 apply (blast elim: equalityE)
txt\<open>The limit case, \<^term>\<open>Limit(\<Union>X)\<close>:
@{subgoals[display,indent=0,margin=65]}
\<close>
apply (simp add: OUN_Union_eq cont_Ord_def)
apply (rule equalityI)
txt\<open>First inclusion:\<close>
 apply (rule UN_least [OF OUN_least])
 apply (simp add: mono_le_subset_def, blast intro: leI)
txt\<open>Second inclusion:\<close>
apply (rule UN_least)
apply (frule Union_upper_le, blast, blast)
apply (erule leE, drule ltD, elim UnionE)
 apply (simp add: OUnion_def)
 apply blast+
done

lemma Normal_Union:
     "[| X\<noteq>0; \<forall>x\<in>X. Ord(x); Normal(F) |] ==> F(\<Union>(X)) = (\<Union>y\<in>X. F(y))"
apply (simp add: Normal_def)
apply (blast intro: mono_Ord_imp_le_subset cont_Ord_Union)
done

lemma Normal_imp_fp_Closed: "Normal(F) ==> Closed(\<lambda>i. F(i) = i)"
apply (simp add: Closed_def ball_conj_distrib, clarify)
apply (frule Ord_set_cases)
apply (auto simp add: Normal_Union)
done

lemma iterates_Normal_increasing:
     "[| n\<in>nat;  x < F(x);  Normal(F) |]
      ==> F^n (x) < F^(succ(n)) (x)"
apply (induct n rule: nat_induct)
apply (simp_all add: Normal_imp_mono)
done

lemma Ord_iterates_Normal:
     "[| n\<in>nat;  Normal(F);  Ord(x) |] ==> Ord(F^n (x))"
by (simp)

text\<open>THIS RESULT IS UNUSED\<close>
lemma iterates_omega_Limit:
     "[| Normal(F);  x < F(x) |] ==> Limit(F^\<omega> (x))"
apply (frule lt_Ord)
apply (simp add: iterates_omega_def)
apply (rule increasing_LimitI)
   \<comment> \<open>this lemma is @{thm increasing_LimitI [no_vars]}\<close>
 apply (blast intro: UN_upper_lt [of "1"]   Normal_imp_Ord
                     Ord_iterates lt_imp_0_lt
                     iterates_Normal_increasing, clarify)
apply (rule bexI)
 apply (blast intro: Ord_in_Ord [OF Ord_iterates_Normal])
apply (rule UN_I, erule nat_succI)
apply (blast intro:  iterates_Normal_increasing Ord_iterates_Normal
                     ltD [OF lt_trans1, OF succ_leI, OF ltI])
done

lemma iterates_omega_fixedpoint:
     "[| Normal(F); Ord(a) |] ==> F(F^\<omega> (a)) = F^\<omega> (a)"
apply (frule Normal_increasing, assumption)
apply (erule leE)
 apply (simp_all add: iterates_omega_triv [OF sym])  (*for subgoal 2*)
apply (simp add:  iterates_omega_def Normal_Union)
apply (rule equalityI, force simp add: nat_succI)
txt\<open>Opposite inclusion:
@{subgoals[display,indent=0,margin=65]}
\<close>
apply clarify
apply (rule UN_I, assumption)
apply (frule iterates_Normal_increasing, assumption, assumption, simp)
apply (blast intro: Ord_trans ltD Ord_iterates_Normal Normal_imp_Ord [of F])
done

lemma iterates_omega_increasing:
     "[| Normal(F); Ord(a) |] ==> a \<le> F^\<omega> (a)"
apply (unfold iterates_omega_def)
apply (rule UN_upper_le [of 0], simp_all)
done

lemma Normal_imp_fp_Unbounded: "Normal(F) ==> Unbounded(\<lambda>i. F(i) = i)"
apply (unfold Unbounded_def, clarify)
apply (rule_tac x="F^\<omega> (succ(i))" in exI)
apply (simp add: iterates_omega_fixedpoint)
apply (blast intro: lt_trans2 [OF _ iterates_omega_increasing])
done

theorem Normal_imp_fp_Closed_Unbounded:
     "Normal(F) ==> Closed_Unbounded(\<lambda>i. F(i) = i)"
by (simp add: Closed_Unbounded_def Normal_imp_fp_Closed
              Normal_imp_fp_Unbounded)

subsubsection\<open>Function \<open>normalize\<close>\<close>

text\<open>Function \<open>normalize\<close> maps a function \<open>F\<close> to a
      normal function that bounds it above.  The result is normal if and
      only if \<open>F\<close> is continuous: succ is not bounded above by any
      normal function, by @{thm [source] Normal_imp_fp_Unbounded}.
\<close>
definition
  normalize :: "[i=>i, i] => i" where
    "normalize(F,a) == transrec2(a, F(0), \<lambda>x r. F(succ(x)) \<union> succ(r))"

lemma Ord_normalize [simp, intro]:
     "[| Ord(a); !!x. Ord(x) ==> Ord(F(x)) |] ==> Ord(normalize(F, a))"
apply (induct a rule: trans_induct3)
apply (simp_all add: ltD def_transrec2 [OF normalize_def])
done

lemma normalize_increasing:
  assumes ab: "a < b" and F: "!!x. Ord(x) ==> Ord(F(x))"
  shows "normalize(F,a) < normalize(F,b)"
proof -
  { fix x
    have "Ord(b)" using ab by (blast intro: lt_Ord2)
    hence "x < b \<Longrightarrow> normalize(F,x) < normalize(F,b)"
    proof (induct b arbitrary: x rule: trans_induct3)
      case 0 thus ?case by simp
    next
      case (succ b)
      thus ?case
        by (auto simp add: le_iff def_transrec2 [OF normalize_def] intro: Un_upper2_lt F)
    next
      case (limit l)
      hence sc: "succ(x) < l"
        by (blast intro: Limit_has_succ)
      hence "normalize(F,x) < normalize(F,succ(x))"
        by (blast intro: limit elim: ltE)
      hence "normalize(F,x) < (\<Union>j<l. normalize(F,j))"
        by (blast intro: OUN_upper_lt lt_Ord F sc)
      thus ?case using limit
        by (simp add: def_transrec2 [OF normalize_def])
    qed
  } thus ?thesis using ab .
qed

theorem Normal_normalize:
     "(!!x. Ord(x) ==> Ord(F(x))) ==> Normal(normalize(F))"
apply (rule NormalI)
apply (blast intro!: normalize_increasing)
apply (simp add: def_transrec2 [OF normalize_def])
done

theorem le_normalize:
  assumes a: "Ord(a)" and coF: "cont_Ord(F)" and F: "!!x. Ord(x) ==> Ord(F(x))"
  shows "F(a) \<le> normalize(F,a)"
using a
proof (induct a rule: trans_induct3)
  case 0 thus ?case by (simp add: F def_transrec2 [OF normalize_def])
next
  case (succ a)
  thus ?case
    by (simp add: def_transrec2 [OF normalize_def] Un_upper1_le F )
next
  case (limit l)
  thus ?case using F coF [unfolded cont_Ord_def]
    by (simp add: def_transrec2 [OF normalize_def] le_implies_OUN_le_OUN ltD)
qed

subsection \<open>The Alephs\<close>
text \<open>This is the well-known transfinite enumeration of the cardinal
numbers.\<close>

definition
  Aleph :: "i => i"  (\<open>\<aleph>_\<close> [90] 90) where
    "Aleph(a) == transrec2(a, nat, \<lambda>x r. csucc(r))"

lemma Card_Aleph [simp, intro]:
     "Ord(a) ==> Card(Aleph(a))"
apply (erule trans_induct3)
apply (simp_all add: Card_csucc Card_nat Card_is_Ord
                     def_transrec2 [OF Aleph_def])
done

lemma Aleph_increasing:
  assumes ab: "a < b" shows "Aleph(a) < Aleph(b)"
proof -
  { fix x
    have "Ord(b)" using ab by (blast intro: lt_Ord2)
    hence "x < b \<Longrightarrow> Aleph(x) < Aleph(b)"
    proof (induct b arbitrary: x rule: trans_induct3)
      case 0 thus ?case by simp
    next
      case (succ b)
      thus ?case
        by (force simp add: le_iff def_transrec2 [OF Aleph_def]
                  intro: lt_trans lt_csucc Card_is_Ord)
    next
      case (limit l)
      hence sc: "succ(x) < l"
        by (blast intro: Limit_has_succ)
      hence "\<aleph> x < (\<Union>j<l. \<aleph>j)" using limit
        by (blast intro: OUN_upper_lt Card_is_Ord ltD lt_Ord)
      thus ?case using limit
        by (simp add: def_transrec2 [OF Aleph_def])
    qed
  } thus ?thesis using ab .
qed

theorem Normal_Aleph: "Normal(Aleph)"
apply (rule NormalI)
apply (blast intro!: Aleph_increasing)
apply (simp add: def_transrec2 [OF Aleph_def])
done

end


(*  Title:      HOL/MicroJava/BV/Semilat.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Semilattices.
*)

chapter \<open>Bytecode Verifier \label{cha:bv}\<close>

section \<open>Semilattices\<close>

theory Semilat
imports Main "HOL-Library.While_Combinator"
begin

type_synonym 'a ord    = "'a \<Rightarrow> 'a \<Rightarrow> bool"
type_synonym 'a binop  = "'a \<Rightarrow> 'a \<Rightarrow> 'a"
type_synonym 'a sl     = "'a set \<times> 'a ord \<times> 'a binop"

definition lesub :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  where "lesub x r y \<longleftrightarrow> r x y"

definition lesssub :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  where "lesssub x r y \<longleftrightarrow> lesub x r y \<and> x \<noteq> y"

definition plussub :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c"
  where "plussub x f y = f x y"

notation (ASCII)
  "lesub"  ("(_ /<='__ _)" [50, 1000, 51] 50) and
  "lesssub"  ("(_ /<'__ _)" [50, 1000, 51] 50) and
  "plussub"  ("(_ /+'__ _)" [65, 1000, 66] 65)

notation
  "lesub"  ("(_ /\<sqsubseteq>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "lesssub"  ("(_ /\<sqsubset>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "plussub"  ("(_ /\<squnion>\<^bsub>_\<^esub> _)" [65, 0, 66] 65)

(* allow \<sub> instead of \<bsub>..\<esub> *)
abbreviation (input)
  lesub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubseteq>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubseteq>\<^sub>r y == x \<sqsubseteq>\<^bsub>r\<^esub> y"

abbreviation (input)
  lesssub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubset>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubset>\<^sub>r y == x \<sqsubset>\<^bsub>r\<^esub> y"

abbreviation (input)
  plussub1 :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^sub>_ _)" [65, 1000, 66] 65)
  where "x \<squnion>\<^sub>f y == x \<squnion>\<^bsub>f\<^esub> y"

definition ord :: "('a \<times> 'a) set \<Rightarrow> 'a ord"
where
  "ord r = (\<lambda>x y. (x,y) \<in> r)"

definition order :: "'a ord \<Rightarrow> bool"
where
  "order r \<longleftrightarrow> (\<forall>x. x \<sqsubseteq>\<^sub>r x) \<and> (\<forall>x y. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r x \<longrightarrow> x=y) \<and> (\<forall>x y z. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<sqsubseteq>\<^sub>r z)"

definition top :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool"
where
  "top r T \<longleftrightarrow> (\<forall>x. x \<sqsubseteq>\<^sub>r T)"

definition acc :: "'a ord \<Rightarrow> bool"
where
  "acc r \<longleftrightarrow> wf {(y,x). x \<sqsubset>\<^sub>r y}"

definition closed :: "'a set \<Rightarrow> 'a binop \<Rightarrow> bool"
where
  "closed A f \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. x \<squnion>\<^sub>f y \<in> A)"

definition semilat :: "'a sl \<Rightarrow> bool"
where
  "semilat = (\<lambda>(A,r,f). order r \<and> closed A f \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z))"

definition is_ub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "is_ub r x y u \<longleftrightarrow> (x,u)\<in>r \<and> (y,u)\<in>r"

definition is_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "is_lub r x y u \<longleftrightarrow> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z)\<in>r)"

definition some_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
where
  "some_lub r x y = (SOME z. is_lub r x y z)"

locale Semilat =
  fixes A :: "'a set"
  fixes r :: "'a ord"
  fixes f :: "'a binop"
  assumes semilat: "semilat (A, r, f)"

lemma order_refl [simp, intro]: "order r \<Longrightarrow> x \<sqsubseteq>\<^sub>r x"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_antisym: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_trans: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (unfold order_def) blast (*>*)

lemma order_less_irrefl [intro, simp]: "order r \<Longrightarrow> \<not> x \<sqsubset>\<^sub>r x"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma order_less_trans: "\<lbrakk> order r; x \<sqsubset>\<^sub>r y; y \<sqsubset>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubset>\<^sub>r z"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma topD [simp, intro]: "top r T \<Longrightarrow> x \<sqsubseteq>\<^sub>r T"
  (*<*) by (simp add: top_def) (*>*)

lemma top_le_conv [simp]: "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T \<sqsubseteq>\<^sub>r x) = (x = T)"
  (*<*) by (blast intro: order_antisym) (*>*)

lemma semilat_Def:
"semilat(A,r,f) \<longleftrightarrow> order r \<and> closed A f \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (unfold semilat_def) clarsimp (*>*)

lemma (in Semilat) orderI [simp, intro]: "order r"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma (in Semilat) closedI [simp, intro]: "closed A f"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma closedD: "\<lbrakk> closed A f; x\<in>A; y\<in>A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (unfold closed_def) blast (*>*)

lemma closed_UNIV [simp]: "closed UNIV f"
  (*<*) by (simp add: closed_def) (*>*)

lemma (in Semilat) closed_f [simp, intro]: "\<lbrakk>x \<in> A; y \<in> A\<rbrakk>  \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (simp add: closedD [OF closedI]) (*>*)

lemma (in Semilat) refl_r [intro, simp]: "x \<sqsubseteq>\<^sub>r x" by simp

lemma (in Semilat) antisym_r [intro?]: "\<lbrakk> x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (rule order_antisym) auto (*>*)

lemma (in Semilat) trans_r [trans, intro?]: "\<lbrakk>x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z\<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (auto intro: order_trans) (*>*)

lemma (in Semilat) ub1 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) ub2 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) lub [simp, intro?]:
  "\<lbrakk> x \<sqsubseteq>\<^sub>r z; y \<sqsubseteq>\<^sub>r z; x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) plus_le_conv [simp]:
  "\<lbrakk> x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> (x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z) = (x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (blast intro: ub1 ub2 lub order_trans) (*>*)

lemma (in Semilat) le_iff_plus_unchanged:
  assumes "x \<in> A" and "y \<in> A"
  shows "x \<sqsubseteq>\<^sub>r y \<longleftrightarrow> x \<squnion>\<^sub>f y = y" (is "?P \<longleftrightarrow> ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub2)
next
  assume ?Q
  then have "y = x \<squnion>\<^bsub>f\<^esub> y" by simp
  moreover from assms have "x \<sqsubseteq>\<^bsub>r\<^esub> x \<squnion>\<^bsub>f\<^esub> y" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) le_iff_plus_unchanged2:
  assumes "x \<in> A" and "y \<in> A"
  shows "x \<sqsubseteq>\<^sub>r y \<longleftrightarrow> y \<squnion>\<^sub>f x = y" (is "?P \<longleftrightarrow> ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub1)
next
  assume ?Q
  then have "y = y \<squnion>\<^bsub>f\<^esub> x" by simp
  moreover from assms have "x \<sqsubseteq>\<^bsub>r\<^esub> y \<squnion>\<^bsub>f\<^esub> x" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) plus_assoc [simp]:
  assumes a: "a \<in> A" and b: "b \<in> A" and c: "c \<in> A"
  shows "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) = a \<squnion>\<^sub>f b \<squnion>\<^sub>f c"
(*<*)
proof -
  from a b have ab: "a \<squnion>\<^sub>f b \<in> A" ..
  from this c have abc: "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<in> A" ..
  from b c have bc: "b \<squnion>\<^sub>f c \<in> A" ..
  from a this have abc': "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<in> A" ..

  show ?thesis
  proof
    show "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c"
    proof -
      from a b have "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "a<": "a \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from a b have "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from ab c have "c<": "c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "b<" "c<" b c abc have "b \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "a<" this a bc abc show ?thesis ..
    qed
    show "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)"
    proof -
      from b c have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from b c have "c \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "c<": "c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from a bc have "a<": "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from "a<" "b<" a b abc' have "a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from this "c<" ab c abc' show ?thesis ..
    qed
  qed
qed
(*>*)

lemma (in Semilat) plus_com_lemma:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a"
(*<*)
proof -
  assume a: "a \<in> A" and b: "b \<in> A"
  from b a have "a \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover from b a have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover note a b
  moreover from b a have "b \<squnion>\<^sub>f a \<in> A" ..
  ultimately show ?thesis ..
qed
(*>*)

lemma (in Semilat) plus_commutative:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b = b \<squnion>\<^sub>f a"
  (*<*) by(blast intro: order_antisym plus_com_lemma) (*>*)

lemma is_lubD:
  "is_lub r x y u \<Longrightarrow> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z) \<in> r)"
  (*<*) by (simp add: is_lub_def) (*>*)

lemma is_ubI:
  "\<lbrakk> (x,u) \<in> r; (y,u) \<in> r \<rbrakk> \<Longrightarrow> is_ub r x y u"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_ubD:
  "is_ub r x y u \<Longrightarrow> (x,u) \<in> r \<and> (y,u) \<in> r"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_lub_bigger1 [iff]:
  "is_lub (r^* ) x y y = ((x,y)\<in>r^* )"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast
done
(*>*)

lemma is_lub_bigger2 [iff]:
  "is_lub (r^* ) x y x = ((y,x)\<in>r^* )"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast
done
(*>*)

lemma extend_lub:
  "\<lbrakk> single_valued r; is_lub (r^* ) x y u; (x',x) \<in> r \<rbrakk>
  \<Longrightarrow> \<exists>v. is_lub (r^* ) x' y v"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply (case_tac "(y,x) \<in> r^*")
 apply (case_tac "(y,x') \<in> r^*")
  apply blast
 apply (blast elim: converse_rtranclE dest: single_valuedD)
apply (rule exI)
apply (rule conjI)
 apply (blast intro: converse_rtrancl_into_rtrancl dest: single_valuedD)
apply (blast intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl
             elim: converse_rtranclE dest: single_valuedD)
done
(*>*)

lemma single_valued_has_lubs [rule_format]:
  "\<lbrakk> single_valued r; (x,u) \<in> r^* \<rbrakk> \<Longrightarrow> (\<forall>y. (y,u) \<in> r^* \<longrightarrow>
  (\<exists>z. is_lub (r^* ) x y z))"
(*<*)
apply (erule converse_rtrancl_induct)
 apply clarify
 apply (erule converse_rtrancl_induct)
  apply blast
 apply (blast intro: converse_rtrancl_into_rtrancl)
apply (blast intro: extend_lub)
done
(*>*)

lemma some_lub_conv:
  "\<lbrakk> acyclic r; is_lub (r^* ) x y u \<rbrakk> \<Longrightarrow> some_lub (r^* ) x y = u"
(*<*)
apply (simp only: some_lub_def is_lub_def)
apply (rule someI2)
 apply (simp only: is_lub_def)
apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
done
(*>*)

lemma is_lub_some_lub:
  "\<lbrakk> single_valued r; acyclic r; (x,u)\<in>r^*; (y,u)\<in>r^* \<rbrakk>
  \<Longrightarrow> is_lub (r^* ) x y (some_lub (r^* ) x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: some_lub_conv) (*>*)

subsection\<open>An executable lub-finder\<close>

definition exec_lub :: "('a * 'a) set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a binop"
where
  "exec_lub r f x y = while (\<lambda>z. (x,z) \<notin> r\<^sup>*) f y"

lemma exec_lub_refl: "exec_lub r f T T = T"
by (simp add: exec_lub_def while_unfold)

lemma acyclic_single_valued_finite:
 "\<lbrakk>acyclic r; single_valued r; (x,y) \<in> r\<^sup>*\<rbrakk>
  \<Longrightarrow> finite (r \<inter> {a. (x, a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})"
(*<*)
apply(erule converse_rtrancl_induct)
 apply(rule_tac B = "{}" in finite_subset)
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply simp
apply(rename_tac x x')
apply(subgoal_tac "r \<inter> {a. (x,a) \<in> r\<^sup>*} \<times> {b. (b,y) \<in> r\<^sup>*} =
                   insert (x,x') (r \<inter> {a. (x', a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})")
 apply simp
apply(blast intro:converse_rtrancl_into_rtrancl
            elim:converse_rtranclE dest:single_valuedD)
done
(*>*)

lemma exec_lub_conv:
  "\<lbrakk> acyclic r; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y; is_lub (r\<^sup>*) x y u \<rbrakk> \<Longrightarrow>
  exec_lub r f x y = u"
(*<*)
apply(unfold exec_lub_def)
apply(rule_tac P = "\<lambda>z. (y,z) \<in> r\<^sup>* \<and> (z,u) \<in> r\<^sup>*" and
               r = "(r \<inter> {(a,b). (y,a) \<in> r\<^sup>* \<and> (b,u) \<in> r\<^sup>*})^-1" in while_rule)
    apply(blast dest: is_lubD is_ubD)
   apply(erule conjE)
   apply(erule_tac z = u in converse_rtranclE)
    apply(blast dest: is_lubD is_ubD)
   apply(blast dest:rtrancl_into_rtrancl)
  apply(rename_tac s)
  apply(subgoal_tac "is_ub (r\<^sup>*) x y s")
   prefer 2 apply(simp add:is_ub_def)
  apply(subgoal_tac "(u, s) \<in> r\<^sup>*")
   prefer 2 apply(blast dest:is_lubD)
  apply(erule converse_rtranclE)
   apply blast
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply(rule finite_acyclic_wf)
  apply simp
  apply(erule acyclic_single_valued_finite)
   apply(blast intro:single_valuedI)
  apply(simp add:is_lub_def is_ub_def)
 apply simp
 apply(erule acyclic_subset)
 apply blast
apply simp
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
 apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
done
(*>*)

lemma is_lub_exec_lub:
  "\<lbrakk> single_valued r; acyclic r; (x,u):r^*; (y,u):r^*; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y \<rbrakk>
  \<Longrightarrow> is_lub (r^* ) x y (exec_lub r f x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: exec_lub_conv) (*>*)

end


section \<open>Stochastic Vectors and Probability Mass Functions\<close>

text \<open>We prove that over a finite type, stochastic vectors and probability
  mass functions are essentially the same thing: one can convert between both
  representations.\<close>

theory Stochastic_Vector_PMF
  imports Stochastic_Matrix
  "HOL-Probability.Probability_Mass_Function"
begin

lemma sigma_algebra_UNIV_finite[simp]: "sigma_algebra (UNIV :: 'a :: finite set) UNIV"
proof (unfold_locales, goal_cases)
  case (4 a b)
  show ?case by (intro exI[of _ "{a-b}"], auto)
qed auto

definition measure_of_st_vec' :: "'a st_vec \<Rightarrow> 'a :: finite set \<Rightarrow> ennreal" where
  "measure_of_st_vec' x I = sum (\<lambda> i. st_vec x $ i) I"

lemma positive_measure_of_st_vec'[simp]: "positive A (measure_of_st_vec' x)"
  unfolding measure_of_st_vec'_def positive_def by auto

lemma measure_space_measure_of_st_vec': "measure_space UNIV UNIV (measure_of_st_vec' x)"
  unfolding measure_space_def
proof (simp, simp add: countably_additive_def measure_of_st_vec'_def disjoint_family_on_def,
  clarify, goal_cases)
  case (1 A)
  let ?x = "st_vec x"
  define N where "N = {i. A i \<noteq> {}}"
  let ?A = "\<Union>(A ` N)"
  have "finite B \<Longrightarrow> B \<subseteq> ?A \<Longrightarrow> \<exists> K. finite K \<and> K \<subseteq> N \<and> B \<subseteq> \<Union>(A ` K)" for B
  proof (induct rule: finite_induct)
    case (insert b B)
    from insert(3-4) obtain K where K: "finite K" "K \<subseteq> N" "B \<subseteq> \<Union>(A ` K)" by auto
    from insert(4) obtain a where a: "a \<in> N" "b \<in> A a" by auto
    show ?case by (intro exI[of _ "insert a K"], insert a K, auto)
  qed auto
  from this[OF _ subset_refl] obtain K where *: "finite K" "K \<subseteq> N" "\<Union>(A ` K) = ?A" by auto
  {
    assume "K \<subset> N"
    then obtain n where **: "n \<in> N" "n \<notin> K" by auto
    from this[unfolded N_def] obtain a where a: "a \<in> A n" by auto
    with ** * obtain k where ***: "k \<in> K" "a \<in> A k" by force
    from ** *** have "n \<noteq> k" by auto
    from 1[rule_format, OF this] have "A n \<inter> A k = {}" by auto
    with *** a have False by auto
  }
  with * have fin: "finite N" by auto
  have id: "\<Union>(A ` UNIV) = ?A" unfolding N_def by auto
  show "(\<Sum>i. ennreal (sum (($h) ?x) (A i))) =
    ennreal (sum (($h) ?x) (\<Union>(A ` UNIV)))" unfolding id
    apply (subst suminf_finite[OF fin], (auto simp: N_def)[1])
    apply (subst sum_ennreal, (insert non_neg_vec_st_vec[of x], auto simp: non_neg_vec_def intro!: sum_nonneg)[1])
    apply (rule arg_cong[of _ _ ennreal])
    apply (subst sum.UNION_disjoint[OF fin], insert 1, auto)
    done
qed

context begin
setup_lifting type_definition_measure

lift_definition measure_of_st_vec :: "'a st_vec \<Rightarrow> 'a :: finite measure" is
  "\<lambda> x. (UNIV, UNIV, measure_of_st_vec' x)"
  by (auto simp: measure_space_measure_of_st_vec')

lemma sets_measure_of_st_vec[simp]: "sets (measure_of_st_vec x) = UNIV"
  unfolding sets_def by (transfer, auto)

lemma space_measure_of_st_vec[simp]: "space (measure_of_st_vec x) = UNIV"
  unfolding space_def by (transfer, auto)

lemma emeasure_measure_of_st_vec[simp]: "emeasure (measure_of_st_vec x) I =
  sum (\<lambda> i. st_vec x $ i) I"
  unfolding emeasure_def by (transfer', auto simp: measure_of_st_vec'_def)

lemma prob_space_measure_of_st_vec: "prob_space (measure_of_st_vec x)"
  by (unfold_locales, intro exI[of _ UNIV], auto, transfer, auto simp: stoch_vec_def)
end

lift_definition st_vec_of_pmf :: "'i :: finite pmf \<Rightarrow> 'i st_vec" is
  "\<lambda> pmF. vec_lambda (pmf pmF)"
proof (intro conjI, goal_cases)
  case (2 pmF)
  show "stoch_vec (vec_lambda (pmf pmF))"
    unfolding stoch_vec_def
    apply auto
    apply (unfold measure_pmf_UNIV[of pmF, symmetric])
    by (simp add: measure_pmf_conv_infsetsum)
qed (auto simp: non_neg_vec_def stoch_vec_def)

context pmf_as_measure
begin
lift_definition pmf_of_st_vec :: "'a :: finite st_vec \<Rightarrow> 'a pmf" is measure_of_st_vec
proof (goal_cases)
  case (1 x)
  show ?case
    by (auto simp: prob_space_measure_of_st_vec measure_def)
      (rule AE_I[where N = "{i. st_vec x $ i = 0}"], auto)
qed

lemma st_vec_st_vec_of_pmf[simp]:
  "st_vec (st_vec_of_pmf x) $ i = pmf x i"
  by (simp add: st_vec_of_pmf.rep_eq)

lemma pmf_pmf_of_st_vec[simp]: "pmf (pmf_of_st_vec x) i = st_vec x $ i"
  by (transfer, auto simp: measure_def)

lemma st_vec_of_pmf_pmf_of_st_vec[simp]: "st_vec_of_pmf (pmf_of_st_vec x) = x"
proof -
  have "st_vec (st_vec_of_pmf (pmf_of_st_vec x)) = st_vec x"
    unfolding vec_eq_iff by auto
  thus ?thesis using st_vec_inject by blast
qed

lemma pmf_of_st_vec_inj: "(pmf_of_st_vec x = pmf_of_st_vec y) = (x = y)"
  by (metis st_vec_of_pmf_pmf_of_st_vec)
end
end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_36
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun z :: "'a list => 'a list => 'a list" where
  "z (nil2) y2 = y2"
| "z (cons2 z2 xs) y2 = cons2 z2 (z xs y2)"

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

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

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

theorem property0 :
  "((elem x2 y2) ==> (elem x2 (z y2 z2)))"
  apply(induction y2, auto)
  apply(case_tac "y x2 x1", auto)
  done

end


(*
  File:     Range_Search.thy
  Author:   Martin Rau, TU München
*)

section \<open>Range Searching\<close>

theory Range_Search
imports
  KDTree
begin

text\<open>
  Given two \<open>k\<close>-dimensional points \<open>p\<^sub>0\<close> and \<open>p\<^sub>1\<close> which bound the search space, the search should
  return only the points which satisfy the following criteria:

  For every point p in the resulting set: \newline
  \hspace{1cm}  For every axis @{term "k"}: \newline
  \hspace{2cm}    @{term "p\<^sub>0$k \<le> p$k \<and> p$k \<le> p\<^sub>1$k"} \newline

  For a \<open>2\<close>-d tree a query corresponds to selecting all the points in the rectangle that
  has \<open>p\<^sub>0\<close> and \<open>p\<^sub>1\<close> as its defining edges.
\<close>

subsection \<open>Rectangle Definition\<close>

lemma cbox_point_def:
  fixes p\<^sub>0 :: "('k::finite) point"
  shows "cbox p\<^sub>0 p\<^sub>1 = { p. \<forall>k. p\<^sub>0$k \<le> p$k \<and> p$k \<le> p\<^sub>1$k }"
proof -
  have "cbox p\<^sub>0 p\<^sub>1 = { p. \<forall>k. p\<^sub>0 \<bullet> axis k 1 \<le> p \<bullet> axis k 1 \<and> p \<bullet> axis k 1 \<le> p\<^sub>1 \<bullet> axis k 1 }"
    unfolding cbox_def using axis_inverse by auto
  also have "... = { p. \<forall>k. p\<^sub>0$k \<bullet> 1 \<le> p$k \<bullet> 1 \<and> p$k \<bullet> 1 \<le> p\<^sub>1$k \<bullet> 1 }"
    using inner_axis[of _ _ 1] by (smt Collect_cong)
  also have "... = { p. \<forall>k. p\<^sub>0$k \<le> p$k \<and> p$k \<le> p\<^sub>1$k }"
    by simp
  finally show ?thesis .
qed

subsection \<open>Search Function\<close>

fun search :: "('k::finite) point \<Rightarrow> 'k point \<Rightarrow> 'k kdt \<Rightarrow> 'k point set" where
  "search p\<^sub>0 p\<^sub>1 (Leaf p) = (if p \<in> cbox p\<^sub>0 p\<^sub>1 then { p } else {})"
| "search p\<^sub>0 p\<^sub>1 (Node k v l r) = (
    if v < p\<^sub>0$k then
      search p\<^sub>0 p\<^sub>1 r
    else if p\<^sub>1$k < v then
      search p\<^sub>0 p\<^sub>1 l
    else
      search p\<^sub>0 p\<^sub>1 l \<union> search p\<^sub>0 p\<^sub>1 r
  )"

subsection \<open>Auxiliary Lemmas\<close>

lemma l_empty:
  assumes "invar (Node k v l r)" "v < p\<^sub>0$k"
  shows "set_kdt l \<inter> cbox p\<^sub>0 p\<^sub>1 = {}"
proof -
  have "\<forall>p \<in> set_kdt l. p$k < p\<^sub>0$k"
    using assms by auto
  hence "\<forall>p \<in> set_kdt l. p \<notin> cbox p\<^sub>0 p\<^sub>1"
    using cbox_point_def leD by blast
  thus ?thesis by blast
qed

lemma r_empty:
  assumes "invar (Node k v l r)" "p\<^sub>1$k < v"
  shows "set_kdt r \<inter> cbox p\<^sub>0 p\<^sub>1 = {}"
proof -
  have "\<forall>p \<in> set_kdt r. p\<^sub>1$k < p$k"
    using assms by auto
  hence "\<forall>p \<in> set_kdt r. p \<notin> cbox p\<^sub>0 p\<^sub>1"
    using cbox_point_def leD by blast
  thus ?thesis by blast
qed

subsection \<open>Main Theorem\<close>

theorem search_cbox:
  assumes "invar kdt"
  shows "search p\<^sub>0 p\<^sub>1 kdt = set_kdt kdt \<inter> cbox p\<^sub>0 p\<^sub>1"
  using assms l_empty r_empty by (induction kdt) (auto, blast+)

end


(*  Title:      HOL/HOLCF/ex/Fix2.thy
    Author:     Franz Regensburger

Show that fix is the unique least fixed-point operator.
From axioms gix1_def,gix2_def it follows that fix = gix
*)

theory Fix2
imports HOLCF
begin

axiomatization
  gix :: "('a->'a)->'a" where
  gix1_def: "F$(gix$F) = gix$F" and
  gix2_def: "F$y=y ==> gix$F << y"

lemma lemma1: "fix = gix"
apply (rule cfun_eqI)
apply (rule below_antisym)
apply (rule fix_least)
apply (rule gix1_def)
apply (rule gix2_def)
apply (rule fix_eq [symmetric])
done

lemma lemma2: "gix$F=lub(range(%i. iterate i$F$UU))"
apply (rule lemma1 [THEN subst])
apply (rule fix_def2)
done

end


theory ex210
  imports Main
begin
datatype tree0 = Leaf | Node "tree0" "tree0"

value "Node Leaf Leaf"

fun nodes::"tree0 \<Rightarrow> nat" where
  "nodes Leaf = 1"|
  "nodes (Node l r) = Suc(nodes l + nodes r)"

fun explode::"nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
  "explode 0 t = t"|
  "explode (Suc n) t = explode n (Node t t)"

value "nodes (explode (Suc (Suc 0)) (Node Leaf Leaf))"
value "2^(Suc (Suc 0)) * (nodes (Node Leaf Leaf)) + 2^(Suc (Suc 0)) -1"

lemma ex210: "(nodes (explode n t)) = 2^n * (nodes t) + 2^n -1"
  apply(induction n arbitrary: t)
   apply(auto simp add:algebra_simps)
  done

end