theory Optimizing
imports Semantics_Ternary
begin

section\<open>Optimizing\<close>

subsection\<open>Removing Shadowed Rules\<close>
text\<open>Note: there is no executable code for rmshadow at the moment\<close>

text\<open>Assumes: @{term "simple_ruleset"}\<close>
fun rmshadow :: "('a, 'p) match_tac \<Rightarrow> 'a rule list \<Rightarrow> 'p set \<Rightarrow> 'a rule list" where
  "rmshadow _ [] _ = []" |
  "rmshadow \<gamma> ((Rule m a)#rs) P = (if (\<forall>p\<in>P. \<not> matches \<gamma> m a p)
    then
      rmshadow \<gamma> rs P
    else
      (Rule m a) # (rmshadow \<gamma> rs {p \<in> P. \<not> matches \<gamma> m a p}))"
(*needs a ruleset without log and empty*)

subsubsection\<open>Soundness\<close>
  lemma rmshadow_sound:
    "simple_ruleset rs \<Longrightarrow> p \<in> P \<Longrightarrow> approximating_bigstep_fun \<gamma> p (rmshadow \<gamma> rs P) = approximating_bigstep_fun \<gamma> p rs"
  proof(induction rs arbitrary: P)
  case Nil thus ?case by simp
  next
  case (Cons r rs)
    let ?fw="approximating_bigstep_fun \<gamma>" --"firewall semantics"
    let ?rm="rmshadow \<gamma>"
    let ?match="matches \<gamma> (get_match r) (get_action r)"
    let ?set="{p \<in> P. \<not> ?match p}"
    from Cons.IH Cons.prems have IH: "?fw p (?rm rs P) = ?fw p rs" by (simp add: simple_ruleset_def)
    from Cons.IH[of "?set"] Cons.prems have IH': "p \<in> ?set \<Longrightarrow> ?fw p (?rm rs ?set) = ?fw p rs" by (simp add: simple_ruleset_def)
    from Cons show ?case
      proof(cases "\<forall>p\<in>P. \<not> ?match p") --"the if-condition of rmshadow"
      case True
        from True have 1: "?rm (r#rs) P = ?rm rs P"
          apply(cases r)
          apply(rename_tac m a)
          apply(clarify)
          apply(simp)
          done
        from True Cons.prems have "?fw p (r # rs) = ?fw p rs"
          apply(cases r)
          apply(rename_tac m a)
          apply(simp add: fun_eq_iff)
          apply(clarify)
          apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
          apply(simp)
          done
        from this IH have "?fw p (?rm rs P) = ?fw p (r#rs) " by simp
        thus "?fw p (?rm (r#rs) P) = ?fw p (r#rs) " using 1 by simp
      next
      case False --"else"
        have "?fw p (r # (?rm rs ?set)) = ?fw p (r # rs)"
          proof(cases "p \<in> ?set")
            case True
              from True IH' show "?fw p (r # (?rm rs ?set)) = ?fw p (r#rs)"
                apply(cases r)
                apply(rename_tac m a)
                apply(simp add: fun_eq_iff)
                apply(clarify)
                apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
                apply(simp)
                done
            next
            case False
              from False Cons.prems have "?match p" by simp
              from Cons.prems have "get_action r = Accept \<or> get_action r = Drop" by(simp add: simple_ruleset_def)
              from this \<open>?match p\<close>show "?fw p (r # (?rm rs ?set)) = ?fw p (r#rs)"
                apply(cases r)
                apply(rename_tac m a)
                apply(simp add: fun_eq_iff)
                apply(clarify)
                apply(rename_tac s)
                apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
                apply(simp split:action.split)
                apply fast
                done
          qed
        from False this show ?thesis
          apply(cases r)
          apply(rename_tac m a)
          apply(simp add: fun_eq_iff)
          apply(clarify)
          apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
          apply(simp)
          done
    qed
  qed

subsection\<open>Removing rules which cannot apply\<close>

fun rmMatchFalse :: "'a rule list \<Rightarrow> 'a rule list" where
  "rmMatchFalse [] = []" |
  "rmMatchFalse ((Rule (MatchNot MatchAny) _)#rs) = rmMatchFalse rs" |
  "rmMatchFalse (r#rs) = r # rmMatchFalse rs"

lemma rmMatchFalse_correct: "approximating_bigstep_fun \<gamma> p (rmMatchFalse rs) s = approximating_bigstep_fun \<gamma> p rs s"
  proof-
    { fix m::"'a match_expr" and a and rs
      assume assm: "m \<noteq> MatchNot MatchAny"
      have "rmMatchFalse (Rule m a # rs) = Rule m a # (rmMatchFalse rs)" (is ?hlp)
      proof(cases m)
        case (MatchNot mexpr) with assm show ?hlp by(cases mexpr) simp_all
        qed(simp_all)
    } note rmMatchFalse_helper=this
  show ?thesis
    proof(induction \<gamma> p rs s rule: approximating_bigstep_fun_induct)
      case Empty thus ?case by(simp)
      next
      case Decision thus ?case by(metis Decision_approximating_bigstep_fun)
      next
      case (Nomatch \<gamma> p m a) thus ?case
        by(cases "m = MatchNot MatchAny") (simp_all add: rmMatchFalse_helper)
      next
      case (Match \<gamma> p m a rs)
        from Match(1) have "m \<noteq> MatchNot MatchAny" using bunch_of_lemmata_about_matches(3) by fast
        with Match rmMatchFalse_helper show ?case by(simp split:action.split)
    qed
  qed

text\<open>We can stop after a default rule (a rule which matches anything) is observed.\<close>
fun cut_off_after_match_any :: "'a rule list \<Rightarrow> 'a rule list" where
  "cut_off_after_match_any [] = []" |
  "cut_off_after_match_any (Rule m a # rs) =
    (if m = MatchAny \<and> (a = Accept \<or> a = Drop \<or> a = Reject)
     then [Rule m a] else Rule m a # cut_off_after_match_any rs)"

lemma cut_off_after_match_any:
  "approximating_bigstep_fun \<gamma> p (cut_off_after_match_any rs) s = approximating_bigstep_fun \<gamma> p rs s"
  apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
  apply(induction \<gamma> p rs s rule: approximating_bigstep_fun.induct)
    apply(simp; fail)
   apply(simp; fail)
  by(simp split: action.split action.split_asm add: bunch_of_lemmata_about_matches(2))

lemma cut_off_after_match_any_simplers: "simple_ruleset rs \<Longrightarrow> simple_ruleset (cut_off_after_match_any rs)"
  by(induction rs rule: cut_off_after_match_any.induct) (simp_all add: simple_ruleset_def)

lemma cut_off_after_match_any_preserve_matches:
  "\<forall> r \<in> set rs. P (get_match r) \<Longrightarrow> \<forall> r \<in> set (cut_off_after_match_any rs). P (get_match r)"
  apply(induction rs rule: cut_off_after_match_any.induct)
   apply(simp; fail)
  by(auto simp add: simple_ruleset_def)

end


theory Submission
  imports Defs
begin

definition A\<^sub>0 :: "entry list"  where
  "A\<^sub>0 = [None, Some Odd, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged]"

definition A\<^sub>1 :: "entry list"  where
  "A\<^sub>1 = [None, Unchanged, Some Odd, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Some Either, Unchanged]"

definition A\<^sub>2 :: "entry list"  where
  "A\<^sub>2 = [None, Unchanged, Unchanged, Some Odd, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Some Either]"

definition A\<^sub>3 :: "entry list"  where
  "A\<^sub>3 = [None, Unchanged, Unchanged, Unchanged, Some Even, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged]"

definition A\<^sub>4 :: "entry list"  where
  "A\<^sub>4 = [None, Unchanged, Unchanged, Unchanged, Unchanged, Some Even, Unchanged, Unchanged, Unchanged, Unchanged]"

definition A\<^sub>5 :: "entry list"  where
  "A\<^sub>5 = [None, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Some Odd, Unchanged, Unchanged, Unchanged]"

definition A\<^sub>6 :: "entry list"  where
  "A\<^sub>6 = [None, Unchanged, Unchanged, Unchanged, Unchanged, Some Even, Unchanged, Unchanged, Unchanged, Unchanged]"

definition A\<^sub>7 :: "entry list"  where
  "A\<^sub>7 = [None, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Some Even, Unchanged, Unchanged, Unchanged]"

definition A\<^sub>8 :: "entry list"  where
  "A\<^sub>8 = [None, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Some Either, Unchanged, Unchanged]"

definition A\<^sub>9 :: "entry list"  where
  "A\<^sub>9 = [None, Unchanged, Unchanged, Some Odd, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Some Either]"

(*
r := 1; {A0}
{A1} WHILE b DO {A2} (
r := r * 2;{A3}
IF b THEN {A4}
r := r - 1{A5}
ELSE {A6}
r := r + 2{A7}
{A8}
){A9}
*)

hide_const (open) None Some

instantiation bounds :: order
begin

definition less_eq_bounds where
"x \<le> y = (case (x, y) of (B x, B y) \<Rightarrow> x \<subseteq> y)"

definition less_bounds where
"x < y = (case (x, y) of (B x, B y) \<Rightarrow> x \<subset> y)"

instance
proof (standard, goal_cases)
  case (1 x y)
  then show ?case unfolding less_bounds_def less_eq_bounds_def by(fastforce split: bounds.splits)
next
  case (2 x)
  then show ?case unfolding less_eq_bounds_def by(simp split: bounds.splits)
next
  case (3 x y z)
  then show ?case unfolding less_eq_bounds_def by(fastforce split: bounds.splits)
next
  case (4 x y)
  then show ?case unfolding less_eq_bounds_def by(fastforce split: bounds.splits)
qed

end

(* Abst_Int0 -------------------- START --------------------*)
class semilattice_sup_top = semilattice_sup + order_top

instance "fun" :: (type, semilattice_sup_top) semilattice_sup_top ..

instantiation option :: (order)order
begin

fun less_eq_option where
"Some x \<le> Some y = (x \<le> y)" |
"None \<le> y = True" |
"Some _ \<le> None = False"

definition less_option where "x < (y::'a option) = (x \<le> y \<and> \<not> y \<le> x)"

lemma le_None[simp]: "(x \<le> None) = (x = None)"
by (cases x) simp_all

lemma Some_le[simp]: "(Some x \<le> u) = (\<exists>y. u = Some y \<and> x \<le> y)"
by (cases u) auto

instance
proof (standard, goal_cases)
  case 1 show ?case by(rule less_option_def)
next
  case (2 x) show ?case by(cases x, simp_all)
next
  case (3 x y z) thus ?case by(cases z, simp, cases y, simp, cases x, auto)
next
  case (4 x y) thus ?case by(cases y, simp, cases x, auto)
qed

end

instantiation option :: (sup)sup
begin

fun sup_option where
"Some x \<squnion> Some y = Some(x \<squnion> y)" |
"None \<squnion> y = y" |
"x \<squnion> None = x"

lemma sup_None2[simp]: "x \<squnion> None = x"
by (cases x) simp_all

instance ..

end

instantiation option :: (semilattice_sup_top)semilattice_sup_top
begin

definition top_option where "\<top> = Some \<top>"

instance
proof (standard, goal_cases)
  case (4 a) show ?case by(cases a, simp_all add: top_option_def)
next
  case (1 x y) thus ?case by(cases x, simp, cases y, simp_all)
next
  case (2 x y) thus ?case by(cases y, simp, cases x, simp_all)
next
  case (3 x y z) thus ?case by(cases z, simp, cases y, simp, cases x, simp_all)
qed

end

instantiation option :: (order)order_bot
begin

definition bot_option :: "'a option" where
"\<bottom> = None"

instance
proof (standard, goal_cases)
  case 1 thus ?case by(auto simp: bot_option_def)
qed

end

definition bot :: "com \<Rightarrow> 'a option acom" where
"bot c = annotate (\<lambda>p. None) c"

lemma bot_least: "strip C = c \<Longrightarrow> bot c \<le> C"
by(auto simp: bot_def less_eq_acom_def)

lemma strip_bot[simp]: "strip(bot c) = c"
by(simp add: bot_def)

subsubsection "Pre-fixpoint iteration"

definition pfp :: "(('a::order) \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
"pfp f = while_option (\<lambda>x. \<not> f x \<le> x) f"

lemma pfp_pfp: assumes "pfp f x0 = Some x" shows "f x \<le> x"
using while_option_stop[OF assms[simplified pfp_def]] by simp

lemma while_least:
fixes q :: "'a::order"
assumes "\<forall>x\<in>L.\<forall>y\<in>L. x \<le> y \<longrightarrow> f x \<le> f y" and "\<forall>x. x \<in> L \<longrightarrow> f x \<in> L"
and "\<forall>x \<in> L. b \<le> x" and "b \<in> L" and "f q \<le> q" and "q \<in> L"
and "while_option P f b = Some p"
shows "p \<le> q"
using while_option_rule[OF _  assms(7)[unfolded pfp_def],
                        where P = "%x. x \<in> L \<and> x \<le> q"]
by (metis assms(1-6) order_trans)

lemma pfp_bot_least:
assumes "\<forall>x\<in>{C. strip C = c}.\<forall>y\<in>{C. strip C = c}. x \<le> y \<longrightarrow> f x \<le> f y"
and "\<forall>C. C \<in> {C. strip C = c} \<longrightarrow> f C \<in> {C. strip C = c}"
and "f C' \<le> C'" "strip C' = c" "pfp f (bot c) = Some C"
shows "C \<le> C'"
by(rule while_least[OF assms(1,2) _ _ assms(3) _ assms(5)[unfolded pfp_def]])
  (simp_all add: assms(4) bot_least)

lemma pfp_inv:
  "pfp f x = Some y \<Longrightarrow> (\<And>x. P x \<Longrightarrow> P(f x)) \<Longrightarrow> P x \<Longrightarrow> P y"
unfolding pfp_def by (blast intro: while_option_rule)

lemma strip_pfp:
assumes "\<And>x. g(f x) = g x" and "pfp f x0 = Some x" shows "g x = g x0"
using pfp_inv[OF assms(2), where P = "%x. g x = g x0"] assms(1) by simp

subsubsection "Abstract Interpretation"

definition \<gamma>_fun :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'b)set" where
"\<gamma>_fun \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(F x)}"

fun \<gamma>_option :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a option \<Rightarrow> 'b set" where
"\<gamma>_option \<gamma> None = {}" |
"\<gamma>_option \<gamma> (Some a) = \<gamma> a"

text\<open>The interface for abstract values:\<close>

locale Val_semilattice =
fixes \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
  assumes mono_gamma: "a \<le> b \<Longrightarrow> \<gamma> a \<le> \<gamma> b"
  and gamma_Top[simp]: "\<gamma> \<top> = UNIV"
fixes num' :: "ereal \<Rightarrow> 'av"
and plus' :: "'av \<Rightarrow> 'av \<Rightarrow> 'av"
  assumes gamma_num': "Some i \<in> \<gamma>(num' i)"
  and gamma_plus': "i1 \<in> \<gamma> a1 \<Longrightarrow> i2 \<in> \<gamma> a2 \<Longrightarrow> j = (
   case (i1, i2) of
     (None, _) \<Rightarrow> None
   | (_, None) \<Rightarrow> None
   | (Some PInfty, Some MInfty) \<Rightarrow> None
   | (Some MInfty, Some PInfty) \<Rightarrow> None
   | (Some v\<^sub>1, Some v\<^sub>2) \<Rightarrow> Some (v\<^sub>1 + v\<^sub>2)
  ) \<Longrightarrow> j \<in> \<gamma>(plus' a1 a2)"

instantiation acom :: (type) vars
begin

definition "vars_acom = vars o strip"

instance ..

end

lemma finite_Cvars: "finite(vars(C::'a acom))"
by(simp add: vars_acom_def)
(* Abst_Int0 --------------------- END ---------------------*)

(* Abst_Int1 -------------------- START --------------------*)

type_synonym 'a st_rep = "(vname * 'a) list"

fun fun_rep :: "('a::top) st_rep \<Rightarrow> vname \<Rightarrow> 'a" where
"fun_rep [] = (\<lambda>x. \<top>)" |
"fun_rep ((x,a)#ps) = (fun_rep ps) (x := a)"

lemma fun_rep_map_of[code]: \<comment> \<open>original def is too slow\<close>
  "fun_rep ps = (%x. case map_of ps x of None \<Rightarrow> \<top> | Some a \<Rightarrow> a)"
by(induction ps rule: fun_rep.induct) auto

definition eq_st :: "('a::top) st_rep \<Rightarrow> 'a st_rep \<Rightarrow> bool" where
"eq_st S1 S2 = (fun_rep S1 = fun_rep S2)"

declare [[typedef_overloaded]] \<comment> \<open>allow quotient types to depend on classes\<close>

quotient_type 'a st = "('a::top) st_rep" / eq_st
morphisms rep_st St
by (metis eq_st_def equivpI reflpI sympI transpI)

lift_definition update :: "('a::top) st \<Rightarrow> vname \<Rightarrow> 'a \<Rightarrow> 'a st"
  is "\<lambda>ps x a. (x,a)#ps"
by(auto simp: eq_st_def)

lift_definition "fun" :: "('a::top) st \<Rightarrow> vname \<Rightarrow> 'a" is fun_rep
by(simp add: eq_st_def)

definition show_st :: "vname set \<Rightarrow> ('a::top) st \<Rightarrow> (vname * 'a)set" where
"show_st X S = (\<lambda>x. (x, fun S x)) ` X"

definition "show_acom C = map_acom (map_option (show_st (vars(strip C)))) C"
definition "show_acom_opt = map_option show_acom"

lemma fun_update[simp]: "fun (update S x y) = (fun S)(x:=y)"
by transfer auto

definition \<gamma>_st :: "(('a::top) \<Rightarrow> 'b set) \<Rightarrow> 'a st \<Rightarrow> (vname \<Rightarrow> 'b) set" where
"\<gamma>_st \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(fun F x)}"

instantiation st :: (order_top) order
begin

definition less_eq_st_rep :: "'a st_rep \<Rightarrow> 'a st_rep \<Rightarrow> bool" where
"less_eq_st_rep ps1 ps2 =
  ((\<forall>x \<in> set(map fst ps1) \<union> set(map fst ps2). fun_rep ps1 x \<le> fun_rep ps2 x))"

lemma less_eq_st_rep_iff:
  "less_eq_st_rep r1 r2 = (\<forall>x. fun_rep r1 x \<le> fun_rep r2 x)"
apply(auto simp: less_eq_st_rep_def fun_rep_map_of split: option.split)
apply (metis Un_iff map_of_eq_None_iff option.distinct(1))
apply (metis Un_iff map_of_eq_None_iff option.distinct(1))
done

corollary less_eq_st_rep_iff_fun:
  "less_eq_st_rep r1 r2 = (fun_rep r1 \<le> fun_rep r2)"
by (metis less_eq_st_rep_iff le_fun_def)

lift_definition less_eq_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> bool" is less_eq_st_rep
by(auto simp add: eq_st_def less_eq_st_rep_iff)

definition less_st where "F < (G::'a st) = (F \<le> G \<and> \<not> G \<le> F)"

instance
proof (standard, goal_cases)
  case 1 show ?case by(rule less_st_def)
next
  case 2 show ?case by transfer (auto simp: less_eq_st_rep_def)
next
  case 3 thus ?case by transfer (metis less_eq_st_rep_iff order_trans)
next
  case 4 thus ?case
    by transfer (metis less_eq_st_rep_iff eq_st_def fun_eq_iff antisym)
qed

end

lemma le_st_iff: "(F \<le> G) = (\<forall>x. fun F x \<le> fun G x)"
by transfer (rule less_eq_st_rep_iff)

fun map2_st_rep :: "('a::top \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a st_rep \<Rightarrow> 'a st_rep \<Rightarrow> 'a st_rep" where
"map2_st_rep f [] ps2 = map (%(x,y). (x, f \<top> y)) ps2" |
"map2_st_rep f ((x,y)#ps1) ps2 =
  (let y2 = fun_rep ps2 x
   in (x,f y y2) # map2_st_rep f ps1 ps2)"

lemma fun_rep_map2_rep[simp]: "f \<top> \<top> = \<top> \<Longrightarrow>
  fun_rep (map2_st_rep f ps1 ps2) = (\<lambda>x. f (fun_rep ps1 x) (fun_rep ps2 x))"
apply(induction f ps1 ps2 rule: map2_st_rep.induct)
apply(simp add: fun_rep_map_of map_of_map fun_eq_iff split: option.split)
apply(fastforce simp: fun_rep_map_of fun_eq_iff split:option.splits)
done

instantiation st :: (semilattice_sup_top) semilattice_sup_top
begin

lift_definition sup_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> 'a st" is "map2_st_rep (\<squnion>)"
by (simp add: eq_st_def)

lift_definition top_st :: "'a st" is "[]" .

instance
proof (standard, goal_cases)
  case 1 show ?case by transfer (simp add:less_eq_st_rep_iff)
next
  case 2 show ?case by transfer (simp add:less_eq_st_rep_iff)
next
  case 3 thus ?case by transfer (simp add:less_eq_st_rep_iff)
next
  case 4 show ?case by transfer (simp add:less_eq_st_rep_iff fun_rep_map_of)
qed

end

lemma fun_top: "fun \<top> = (\<lambda>x. \<top>)"
by transfer simp

lemma mono_update[simp]:
  "a1 \<le> a2 \<Longrightarrow> S1 \<le> S2 \<Longrightarrow> update S1 x a1 \<le> update S2 x a2"
by transfer (auto simp add: less_eq_st_rep_def)

lemma mono_fun: "S1 \<le> S2 \<Longrightarrow> fun S1 x \<le> fun S2 x"
by transfer (simp add: less_eq_st_rep_iff)

locale Gamma_semilattice = Val_semilattice where \<gamma>=\<gamma>
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
begin

abbreviation \<gamma>\<^sub>s :: "'av st \<Rightarrow> state set"
where "\<gamma>\<^sub>s == \<gamma>_st \<gamma>"

abbreviation \<gamma>\<^sub>o :: "'av st option \<Rightarrow> state set"
where "\<gamma>\<^sub>o == \<gamma>_option \<gamma>\<^sub>s"

abbreviation \<gamma>\<^sub>c :: "'av st option acom \<Rightarrow> state set acom"
where "\<gamma>\<^sub>c == map_acom \<gamma>\<^sub>o"

lemma gamma_s_top[simp]: "\<gamma>\<^sub>s \<top> = UNIV"
by(auto simp: \<gamma>_st_def fun_top)

lemma gamma_o_Top[simp]: "\<gamma>\<^sub>o \<top> = UNIV"
by (simp add: top_option_def)

lemma mono_gamma_s: "f \<le> g \<Longrightarrow> \<gamma>\<^sub>s f \<subseteq> \<gamma>\<^sub>s g"
by(simp add:\<gamma>_st_def le_st_iff subset_iff) (metis mono_gamma subsetD)

lemma mono_gamma_o:
  "S1 \<le> S2 \<Longrightarrow> \<gamma>\<^sub>o S1 \<subseteq> \<gamma>\<^sub>o S2"
by(induction S1 S2 rule: less_eq_option.induct)(simp_all add: mono_gamma_s)

lemma mono_gamma_c: "C1 \<le> C2 \<Longrightarrow> \<gamma>\<^sub>c C1 \<le> \<gamma>\<^sub>c C2"
by (simp add: less_eq_acom_def mono_gamma_o size_annos anno_map_acom size_annos_same[of C1 C2])

lemma in_gamma_option_iff:
  "x \<in> \<gamma>_option r u \<longleftrightarrow> (\<exists>u'. u = Some u' \<and> x \<in> r u')"
by (cases u) auto

end

text\<open>Abstract interpretation over type \<open>st\<close> instead of functions.\<close>

context Gamma_semilattice
begin

fun aval' :: "aexp \<Rightarrow> 'av st \<Rightarrow> 'av" where
"aval' (N i) S = num' i" |
"aval' (V x) S = fun S x" |
"aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"

lemma aval'_correct: "s \<in> \<gamma>\<^sub>s S \<Longrightarrow> aval a s \<in> \<gamma>(aval' a S)"
by (induction a) (auto simp: gamma_num' gamma_plus' \<gamma>_st_def)

lemma gamma_Step_subcomm: fixes C1 C2 :: "'a::semilattice_sup acom"
  assumes "!!x e S. f1 x e (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (f2 x e S)"
          "!!b S. g1 b (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (g2 b S)"
  shows "Step f1 g1 (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (Step f2 g2 S C)"
proof(induction C arbitrary: S)
qed (auto simp: assms intro!: mono_gamma_o sup_ge1 sup_ge2)

lemma in_gamma_update: "\<lbrakk> s \<in> \<gamma>\<^sub>s S; i \<in> \<gamma> a \<rbrakk> \<Longrightarrow> s(x := i) \<in> \<gamma>\<^sub>s(update S x a)"
by(simp add: \<gamma>_st_def)

end

locale Abs_Int = Gamma_semilattice where \<gamma>=\<gamma>
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
begin

definition "step' = Step
  (\<lambda>x e S. case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(update S x (aval' e S)))
  (\<lambda>b S. S)"

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI c = pfp (step' \<top>) (bot c)"

lemma strip_step'[simp]: "strip(step' S C) = strip C"
by(simp add: step'_def)

text\<open>Correctness:\<close>

lemma step_step': "step (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' S C)"
unfolding step_def step'_def
by(rule gamma_Step_subcomm)
  (auto simp: intro!: aval'_correct in_gamma_update split: option.splits)

lemma AI_correct: "AI c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
proof(simp add: CS_def AI_def)
  assume 1: "pfp (step' \<top>) (bot c) = Some C"
  have pfp': "step' \<top> C \<le> C" by(rule pfp_pfp[OF 1])
  have 2: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"  \<comment> \<open>transfer the pfp'\<close>
  proof(rule order_trans)
    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' \<top> C)" by(rule step_step')
    show "... \<le> \<gamma>\<^sub>c C" by (metis mono_gamma_c[OF pfp'])
  qed
  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp[OF _ 1] step'_def)
  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 2])
  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
qed

end

subsubsection "Monotonicity"

locale Abs_Int_mono = Abs_Int +
assumes mono_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> plus' a1 a2 \<le> plus' b1 b2"
begin

lemma mono_aval': "S1 \<le> S2 \<Longrightarrow> aval' e S1 \<le> aval' e S2"
by(induction e) (auto simp: mono_plus' mono_fun)

theorem mono_step': "S1 \<le> S2 \<Longrightarrow> C1 \<le> C2 \<Longrightarrow> step' S1 C1 \<le> step' S2 C2"
unfolding step'_def
by(rule mono2_Step) (auto simp: mono_aval' split: option.split)

lemma mono_step'_top: "C \<le> C' \<Longrightarrow> step' \<top> C \<le> step' \<top> C'"
by (metis mono_step' order_refl)

lemma AI_least_pfp: assumes "AI c = Some C" "step' \<top> C' \<le> C'" "strip C' = c"
shows "C \<le> C'"
by(rule pfp_bot_least[OF _ _ assms(2,3) assms(1)[unfolded AI_def]])
  (simp_all add: mono_step'_top)

end

subsubsection "Termination"

locale Measure1 =
fixes m :: "'av::order_top \<Rightarrow> nat"
fixes h :: "nat"
assumes h: "m x \<le> h"
begin

definition m_s :: "'av st \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>s") where
"m_s S X = (\<Sum> x \<in> X. m(fun S x))"

lemma m_s_h: "finite X \<Longrightarrow> m_s S X \<le> h * card X"
by(simp add: m_s_def) (metis mult.commute of_nat_id sum_bounded_above[OF h])

definition m_o :: "'av st option \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>o") where
"m_o opt X = (case opt of None \<Rightarrow> h * card X + 1 | Some S \<Rightarrow> m_s S X)"

lemma m_o_h: "finite X \<Longrightarrow> m_o opt X \<le> (h*card X + 1)"
  by(auto simp add: m_o_def m_s_h le_SucI split: option.split dest:m_s_h)

definition m_c :: "'av st option acom \<Rightarrow> nat" ("m\<^sub>c") where
"m_c C = sum_list (map (\<lambda>a. m_o a (vars C)) (annos C))"

text\<open>Upper complexity bound:\<close>

lemma m_c_h: "m_c C \<le> size(annos C) * (h * card(vars C) + 1)"
proof-
  let ?X = "vars C" let ?n = "card ?X" let ?a = "size(annos C)"
  have "m_c C = (\<Sum>i<?a. m_o (annos C ! i) ?X)"
    by(simp add: m_c_def sum_list_sum_nth atLeast0LessThan)
  also have "\<dots> \<le> (\<Sum>i<?a. h * ?n + 1)"
    apply(rule sum_mono) using m_o_h[OF finite_Cvars] by simp
  also have "\<dots> = ?a * (h * ?n + 1)" by simp
  finally show ?thesis .
qed

end

fun top_on_st :: "'a::order_top st \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>s") where
"top_on_st S X = (\<forall>x\<in>X. fun S x = \<top>)"

fun top_on_opt :: "'a::order_top st option \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>o") where
"top_on_opt (Some S)  X = top_on_st S X" |
"top_on_opt None X = True"

definition top_on_acom :: "'a::order_top st option acom \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>c") where
"top_on_acom C X = (\<forall>a \<in> set(annos C). top_on_opt a X)"

lemma top_on_top: "top_on_opt (\<top>::_ st option) X"
by(auto simp: top_option_def fun_top)

lemma top_on_bot: "top_on_acom (bot c) X"
by(auto simp add: top_on_acom_def bot_def)

lemma top_on_post: "top_on_acom C X \<Longrightarrow> top_on_opt (post C) X"
by(simp add: top_on_acom_def post_in_annos)

lemma top_on_acom_simps:
  "top_on_acom (SKIP {Q}) X = top_on_opt Q X"
  "top_on_acom (x ::= e {Q}) X = top_on_opt Q X"
  "top_on_acom (C1;;C2) X = (top_on_acom C1 X \<and> top_on_acom C2 X)"
  "top_on_acom (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) X =
   (top_on_opt P1 X \<and> top_on_acom C1 X \<and> top_on_opt P2 X \<and> top_on_acom C2 X \<and> top_on_opt Q X)"
  "top_on_acom ({I} WHILE b DO {P} C {Q}) X =
   (top_on_opt I X \<and> top_on_acom C X \<and> top_on_opt P X \<and> top_on_opt Q X)"
by(auto simp add: top_on_acom_def)

lemma top_on_sup:
  "top_on_opt o1 X \<Longrightarrow> top_on_opt o2 X \<Longrightarrow> top_on_opt (o1 \<squnion> o2 :: _ st option) X"
apply(induction o1 o2 rule: sup_option.induct)
apply(auto)
by transfer simp

lemma top_on_Step: fixes C :: "('a::semilattice_sup_top)st option acom"
assumes "!!x e S. \<lbrakk>top_on_opt S X; x \<notin> X; vars e \<subseteq> -X\<rbrakk> \<Longrightarrow> top_on_opt (f x e S) X"
        "!!b S. top_on_opt S X \<Longrightarrow> vars b \<subseteq> -X \<Longrightarrow> top_on_opt (g b S) X"
shows "\<lbrakk> vars C \<subseteq> -X; top_on_opt S X; top_on_acom C X \<rbrakk> \<Longrightarrow> top_on_acom (Step f g S C) X"
proof(induction C arbitrary: S)
qed (auto simp: top_on_acom_simps vars_acom_def top_on_post top_on_sup assms)

locale Measure = Measure1 +
assumes m2: "x < y \<Longrightarrow> m x > m y"
begin

lemma m1: "x \<le> y \<Longrightarrow> m x \<ge> m y"
by(auto simp: le_less m2)

lemma m_s2_rep: assumes "finite(X)" and "S1 = S2 on -X" and "\<forall>x. S1 x \<le> S2 x" and "S1 \<noteq> S2"
shows "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))"
proof-
  from assms(3) have 1: "\<forall>x\<in>X. m(S1 x) \<ge> m(S2 x)" by (simp add: m1)
  from assms(2,3,4) have "\<exists>x\<in>X. S1 x < S2 x"
    by(simp add: fun_eq_iff) (metis Compl_iff le_neq_trans)
  hence 2: "\<exists>x\<in>X. m(S1 x) > m(S2 x)" by (metis m2)
  from sum_strict_mono_ex1[OF \<open>finite X\<close> 1 2]
  show "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))" .
qed

lemma m_s2: "finite(X) \<Longrightarrow> fun S1 = fun S2 on -X
  \<Longrightarrow> S1 < S2 \<Longrightarrow> m_s S1 X > m_s S2 X"
apply(auto simp add: less_st_def m_s_def)
apply (transfer fixing: m)
apply(simp add: less_eq_st_rep_iff eq_st_def m_s2_rep)
done

lemma m_o2: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 < o2 \<Longrightarrow> m_o o1 X > m_o o2 X"
proof(induction o1 o2 rule: less_eq_option.induct)
  case 1 thus ?case by (auto simp: m_o_def m_s2 less_option_def)
next
  case 2 thus ?case by(auto simp: m_o_def less_option_def le_imp_less_Suc m_s_h)
next
  case 3 thus ?case by (auto simp: less_option_def)
qed

lemma m_o1: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 \<le> o2 \<Longrightarrow> m_o o1 X \<ge> m_o o2 X"
  by(auto simp: le_less m_o2)

(* this lemma is from Abs_Int0:
lemma le_iff_le_annos: "C1 \<le> C2 \<longleftrightarrow>
  strip C1 = strip C2 \<and> (\<forall> i<size(annos C1). annos C1 ! i \<le> annos C2 ! i)"
by(simp add: less_eq_acom_def anno_def)
*)

(*
lemma m_c2: "top_on_acom C1 (-vars C1) \<Longrightarrow> top_on_acom C2 (-vars C2) \<Longrightarrow>
  C1 < C2 \<Longrightarrow> m_c C1 > m_c C2"
proof(auto simp add: le_iff_le_annos size_annos_same[of C1 C2] vars_acom_def less_acom_def)
  let ?X = "vars(strip C2)"
  assume top: "top_on_acom C1 (- vars(strip C2))"  "top_on_acom C2 (- vars(strip C2))"
  and strip_eq: "strip C1 = strip C2"
  and 0: "\<forall>i<size(annos C2). annos C1 ! i \<le> annos C2 ! i"
  hence 1: "\<forall>i<size(annos C2). m_o (annos C1 ! i) ?X \<ge> m_o (annos C2 ! i) ?X"
    apply (auto simp: all_set_conv_all_nth vars_acom_def top_on_acom_def)
    by (metis finite_cvars m_o1 size_annos_same2)
  fix i assume i: "i < size(annos C2)" "\<not> annos C2 ! i \<le> annos C1 ! i"
  have topo1: "top_on_opt (annos C1 ! i) (- ?X)"
    using i(1) top(1) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
  have topo2: "top_on_opt (annos C2 ! i) (- ?X)"
    using i(1) top(2) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
  from i have "m_o (annos C1 ! i) ?X > m_o (annos C2 ! i) ?X" (is "?P i")
    by (metis 0 less_option_def m_o2[OF finite_cvars topo1] topo2)
  hence 2: "\<exists>i < size(annos C2). ?P i" using \<open>i < size(annos C2)\<close> by blast
  have "(\<Sum>i<size(annos C2). m_o (annos C2 ! i) ?X)
         < (\<Sum>i<size(annos C2). m_o (annos C1 ! i) ?X)"
    apply(rule sum_strict_mono_ex1) using 1 2 by (auto)
  thus ?thesis
    by(simp add: m_c_def vars_acom_def strip_eq sum_list_sum_nth atLeast0LessThan size_annos_same[OF strip_eq])
qed
*)

end

locale Abs_Int_measure =
  Abs_Int_mono where \<gamma>=\<gamma> + Measure where m=m
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set" and m :: "'av \<Rightarrow> nat"
begin

lemma top_on_step': "\<lbrakk> top_on_acom C (-vars C) \<rbrakk> \<Longrightarrow> top_on_acom (step' \<top> C) (-vars C)"
unfolding step'_def
by(rule top_on_Step)
  (auto simp add: top_option_def fun_top split: option.splits)
(*
lemma AI_Some_measure: "\<exists>C. AI c = Some C"
unfolding AI_def
apply(rule pfp_termination[where I = "\<lambda>C. top_on_acom C (- vars C)" and m="m_c"])
apply(simp_all add: m_c2 mono_step'_top bot_least top_on_bot)
using top_on_step' apply(auto simp add: vars_acom_def)
done
*)

end
(* Abst_Int1 --------------------- END ---------------------*)

instantiation bounds :: semilattice_sup_top
begin

definition sup_bounds where
  "sup_bounds x y = (case (x, y) of (B xs, B ys) \<Rightarrow> B (xs \<union> ys))"

definition top_bounds where
  "top_bounds = B {NegInf, PosInf, NaN, Real}"

instance
proof (standard, goal_cases)
  case (1 x y)
  then show ?case unfolding sup_bounds_def less_eq_bounds_def by(simp split: bounds.splits)
next
  case (2 y x)
  then show ?case unfolding sup_bounds_def less_eq_bounds_def by(simp split: bounds.splits)
next
  case (3 y x z)
  then show ?case unfolding sup_bounds_def less_eq_bounds_def by(simp split: bounds.splits)
next
  case (4 a)
  then show ?case
    unfolding top_bounds_def less_eq_bounds_def
    apply(simp split: bounds.splits)
    using bound.exhaust by blast
qed
end

fun \<gamma>_bounds :: "bounds \<Rightarrow> val set"  where
  "\<gamma>_bounds (B b) =
    (if PosInf \<in> b then {Some PInfty} else {})
    \<union> (if NegInf \<in> b then {Some MInfty} else {})
    \<union> (if Real \<in> b then {si. \<exists>i\<in>UNIV-{PInfty, MInfty}. si = Some i} else {})
    \<union> (if NaN \<in> b then {None} else {})"

lemma \<gamma>_bounds_excl:
  assumes "a = \<gamma>_bounds (B b)"
  shows "NaN \<notin> b \<Longrightarrow> None \<notin> a"
        "PosInf \<notin> b \<Longrightarrow> (Some PInfty) \<notin> a"
        "NegInf \<notin> b \<Longrightarrow> (Some MInfty) \<notin> a"
        "Real \<notin> b \<Longrightarrow> i \<noteq> PInfty \<Longrightarrow> i \<noteq> MInfty \<Longrightarrow> (Some i) \<notin> a"
  using assms by auto

lemma \<gamma>_bounds_incl:
  assumes "a = \<gamma>_bounds (B b)"
  shows "NaN \<in> b \<Longrightarrow> None \<in> a"
        "PosInf \<in> b \<Longrightarrow> (Some PInfty) \<in> a"
        "NegInf \<in> b \<Longrightarrow> (Some MInfty) \<in> a"
        "Real \<in> b \<Longrightarrow> i \<noteq> PInfty \<Longrightarrow> i \<noteq> MInfty \<Longrightarrow> (Some i) \<in> a"
  using assms by auto

lemma \<gamma>_bounds_backwards:
  assumes "a = \<gamma>_bounds (B b)"
  shows "None \<in> a \<Longrightarrow> NaN \<in> b"
        "(Some PInfty) \<in> a \<Longrightarrow> PosInf \<in> b"
        "(Some MInfty) \<in> a \<Longrightarrow> NegInf \<in> b"
        "(Some i) \<in> a \<Longrightarrow> i \<noteq> PInfty \<Longrightarrow> i \<noteq> MInfty \<Longrightarrow> Real \<in> b"
  using \<gamma>_bounds_excl(1) assms apply blast
  using \<gamma>_bounds_excl(2) assms apply blast
  using \<gamma>_bounds_excl(3) assms apply blast
  using \<gamma>_bounds_excl(4) assms by blast

definition num_bounds :: "ereal \<Rightarrow> bounds"  where
  "num_bounds er = B {(case er of
      PInfty \<Rightarrow> PosInf
    | MInfty => NegInf
    | _ \<Rightarrow> Real)}"

fun plus_bound_helper :: "bound \<Rightarrow> bound \<Rightarrow> bound" where
  "plus_bound_helper NaN _ = NaN" |
  "plus_bound_helper _ NaN = NaN" |
  "plus_bound_helper NegInf PosInf = NaN" |
  "plus_bound_helper PosInf NegInf = NaN" |
  "plus_bound_helper NegInf NegInf = NegInf" |
  "plus_bound_helper NegInf Real = NegInf" |
  "plus_bound_helper PosInf PosInf = PosInf" |
  "plus_bound_helper PosInf Real = PosInf" |
  "plus_bound_helper Real NegInf = NegInf" |
  "plus_bound_helper Real PosInf = PosInf" |
  "plus_bound_helper Real Real = Real"

fun plus_bounds :: "bounds \<Rightarrow> bounds \<Rightarrow> bounds"  where
  "plus_bounds (B b1) (B b2) = B {x. \<exists>bb1\<in>b1. \<exists>bb2\<in>b2. x = plus_bound_helper bb1 bb2}"

lemma plus_bounds_incl:
  assumes "plus_bounds (B b1) (B b2) = (B b3)"
      and "b1 \<noteq> {}"
      and "b2 \<noteq> {}"
    shows
      "NaN \<in> b1 \<Longrightarrow> NaN \<in> b3"
      "NaN \<in> b2 \<Longrightarrow> NaN \<in> b3"
      "NegInf \<in> b1 \<Longrightarrow> PosInf \<in> b2 \<Longrightarrow> NaN \<in> b3"
      "PosInf \<in> b1 \<Longrightarrow> NegInf \<in> b2 \<Longrightarrow> NaN \<in> b3"
      "NegInf \<in> b1 \<Longrightarrow> NegInf \<in> b2 \<Longrightarrow> NegInf \<in> b3"
      "NegInf \<in> b1 \<Longrightarrow> Real \<in> b2 \<Longrightarrow> NegInf \<in> b3"
      "PosInf \<in> b1 \<Longrightarrow> PosInf \<in> b2 \<Longrightarrow> PosInf \<in> b3"
      "PosInf \<in> b1 \<Longrightarrow> Real \<in> b2 \<Longrightarrow> PosInf \<in> b3"
      "Real \<in> b1 \<Longrightarrow> NegInf \<in> b2 \<Longrightarrow> NegInf \<in> b3"
      "Real \<in> b1 \<Longrightarrow> PosInf \<in> b2 \<Longrightarrow> PosInf \<in> b3"
      "Real \<in> b1 \<Longrightarrow> Real \<in> b2 \<Longrightarrow> Real \<in> b3"
  using assms proof-
    show "NaN \<in> b2 \<Longrightarrow> NaN \<in> b3"
    proof-
      assume "NaN \<in> b2"
      obtain e where "e\<in>b1" using assms(2) by auto
      then have "plus_bound_helper e NaN = NaN"
        using plus_bound_helper.elims by blast
      then show "NaN \<in> b3"
        using \<open>NaN \<in> b2\<close> \<open>e \<in> b1\<close> assms(1) by fastforce
    qed
  qed(auto| fastforce)+

global_interpretation Val_semilattice
  where \<gamma> = \<gamma>_bounds and num' = num_bounds and plus' = plus_bounds
proof (standard, goal_cases)
  case (1 a b)
  then show ?case
    unfolding less_eq_bounds_def by(simp split: bounds.splits, blast)
next
  case 2
  then show ?case unfolding top_bounds_def by auto
next
  case (3 i)
  then show ?case unfolding num_bounds_def by(cases i, auto)
next
  case (4 i1 a1 i2 a2 j)
  obtain b\<^sub>1 where b1_def: "a1 = B b\<^sub>1"
    using \<gamma>_bounds.cases by auto
  then have "b\<^sub>1 \<noteq> {}" using 4(1) by auto
  obtain b\<^sub>2 where b2_def: "a2 = B b\<^sub>2"
    using \<gamma>_bounds.cases by auto
  then have "b\<^sub>2 \<noteq> {}" using 4(2) by auto
  obtain pb where pb_def: "B pb = plus_bounds a1 a2"
      using \<gamma>_bounds.cases by metis
  show ?case
  proof(cases i1)
    case None
    with 4 have "j = None" by simp
    with 4(1) have "NaN \<in> b\<^sub>1"
      using \<gamma>_bounds_backwards None b1_def by blast
    then have "NaN \<in> pb"
      using \<open>b\<^sub>1 \<noteq> {}\<close> \<open>b\<^sub>2 \<noteq> {}\<close> b1_def b2_def pb_def plus_bounds_incl(1) by auto
    then have "None \<in> \<gamma>_bounds (plus_bounds a1 a2)"
      using pb_def \<gamma>_bounds_incl by metis
    with \<open>j = None\<close> show ?thesis by simp
  next
    case (Some e1)
    then have i1_def: "i1 = Some e1" by simp
    then show ?thesis
    using 4 proof(cases i2)
      case None
      with 4 Some have "j = None" by(auto split: ereal.splits)
      with 4(2) have "NaN \<in> b\<^sub>2"
        using \<gamma>_bounds_backwards None b2_def by blast
      then have "NaN \<in> pb"
      using \<open>b\<^sub>1 \<noteq> {}\<close> \<open>b\<^sub>2 \<noteq> {}\<close> b1_def b2_def pb_def plus_bounds_incl(2) by auto
    then have "None \<in> \<gamma>_bounds (plus_bounds a1 a2)"
      using pb_def \<gamma>_bounds_incl by metis
      with \<open>j = None\<close> show ?thesis by simp
    next
      case (Some e2)
      then have i2_def: "i2 = Some e2" by simp
      then show ?thesis
      proof(cases e1)
        case (real r1)
        then have e1_def: "e1 = ereal r1" by simp
        with i1_def i2_def e1_def 4(3) have j_is_some: "j = Some (e1 + e2)" by simp
        have "Real \<in> b\<^sub>1"
            using 4(1) \<gamma>_bounds_excl(4) b1_def e1_def i1_def by blast
        show ?thesis
        proof(cases e2)
          case (real r2)
          then have "Real \<in> b\<^sub>2"
            using 4(2) \<gamma>_bounds_excl(4) b2_def i2_def by blast
          with \<open>Real \<in> b\<^sub>1\<close> have "Real \<in> pb"
            by (simp add: \<open>b\<^sub>1 \<noteq> {}\<close> \<open>b\<^sub>2 \<noteq> {}\<close> b1_def b2_def pb_def plus_bounds_incl(11))
          moreover have "e1 + e2 \<noteq> PInfty"
            by (simp add: e1_def real)
          moreover have "e1 + e2 \<noteq> MInfty"
            by (simp add: e1_def real)
          ultimately show ?thesis using j_is_some \<gamma>_bounds_incl(4) pb_def by metis
        next
          case PInf
          then have "PosInf \<in> b\<^sub>2"
            unfolding infinity_ereal_def using 4(2) \<gamma>_bounds_excl(2) b2_def i2_def by blast
          with \<open>Real \<in> b\<^sub>1\<close> have "PosInf \<in> pb"
            by (simp add: \<open>b\<^sub>1 \<noteq> {}\<close> \<open>b\<^sub>2 \<noteq> {}\<close> b1_def b2_def pb_def plus_bounds_incl(10))
          moreover from j_is_some PInf have "j = Some PInfty" by fastforce
          ultimately show ?thesis unfolding infinity_ereal_def using \<gamma>_bounds_incl(2) pb_def by metis
        next
          case MInf
          then have "NegInf \<in> b\<^sub>2"
            unfolding infinity_ereal_def using 4(2) \<gamma>_bounds_excl(3) b2_def i2_def
            by (metis uminus_ereal.simps(2))
          with \<open>Real \<in> b\<^sub>1\<close> have "NegInf \<in> pb"
            by (simp add: \<open>b\<^sub>1 \<noteq> {}\<close> \<open>b\<^sub>2 \<noteq> {}\<close> b1_def b2_def pb_def plus_bounds_incl(9))
          moreover from j_is_some MInf have "j = Some MInfty"
            by (simp add: real)
          ultimately show ?thesis unfolding infinity_ereal_def using \<gamma>_bounds_incl(3) pb_def by metis
        qed
      next
        case PInf
        then have e1_def: "e1 = PInfty" by simp
        have "PosInf \<in> b\<^sub>1"
          using 4(1) \<gamma>_bounds_backwards(2) b1_def e1_def i1_def by blast
        then show ?thesis
        proof(cases e2)
          case (real r)
          then have "Real \<in> b\<^sub>2"
            using 4(2) \<gamma>_bounds_excl(4) b2_def i2_def by blast
          with \<open>PosInf \<in> b\<^sub>1\<close> have "PosInf \<in> pb"
            by (simp add: \<open>b\<^sub>1 \<noteq> {}\<close> \<open>b\<^sub>2 \<noteq> {}\<close> b1_def b2_def pb_def plus_bounds_incl(8))
          moreover from 4(3) have "j = Some PInfty"
            by (simp add: e1_def i1_def i2_def real)
          ultimately show ?thesis
            by (metis \<gamma>_bounds_incl(2) pb_def)
        next
          case PInf
          then have "PosInf \<in> b\<^sub>2"
            unfolding infinity_ereal_def using 4(2) \<gamma>_bounds_backwards(2) b2_def i2_def by blast
          with \<open>PosInf \<in> b\<^sub>1\<close> have "PosInf \<in> pb"
            using \<open>b\<^sub>1 \<noteq> {}\<close> \<open>b\<^sub>2 \<noteq> {}\<close> b1_def b2_def pb_def plus_bounds_incl(7) by auto
          moreover from 4(3) have "j = Some PInfty"
            by (simp add: e1_def i1_def i2_def PInf)
          ultimately show ?thesis
            by (metis \<gamma>_bounds_incl(2) pb_def)
        next
          case MInf
          then have "NegInf \<in> b\<^sub>2"
            unfolding infinity_ereal_def using 4(2) \<gamma>_bounds_excl(3) b2_def i2_def
            by (metis uminus_ereal.simps(2))
          with \<open>PosInf \<in> b\<^sub>1\<close> have "NaN \<in> pb"
            using \<open>b\<^sub>1 \<noteq> {}\<close> \<open>b\<^sub>2 \<noteq> {}\<close> b1_def b2_def pb_def plus_bounds_incl(4) by auto
          moreover from 4(3) have "j = None"
            by (simp add: e1_def i1_def i2_def MInf)
          ultimately show ?thesis
            by (metis \<gamma>_bounds_incl(1) pb_def)
        qed
      next
        case MInf
        then have e1_def: "e1 = MInfty" by simp
        have "NegInf \<in> b\<^sub>1"
          using 4(1) \<gamma>_bounds_backwards(3) b1_def e1_def i1_def by blast
        then show ?thesis
        proof(cases e2)
          case (real r)
          then have "Real \<in> b\<^sub>2"
            using 4(2) \<gamma>_bounds_excl(4) b2_def i2_def by blast
          with \<open>NegInf \<in> b\<^sub>1\<close> have "NegInf \<in> pb"
            by (simp add: \<open>b\<^sub>1 \<noteq> {}\<close> \<open>b\<^sub>2 \<noteq> {}\<close> b1_def b2_def pb_def plus_bounds_incl(6))
          moreover from 4(3) have "j = Some MInfty"
            by (simp add: e1_def i1_def i2_def real)
          ultimately show ?thesis
            by (metis \<gamma>_bounds_incl(3) pb_def)
        next
          case PInf
          then have "PosInf \<in> b\<^sub>2"
            unfolding infinity_ereal_def using 4(2) \<gamma>_bounds_backwards(2) b2_def i2_def by blast
          with \<open>NegInf \<in> b\<^sub>1\<close> have "NaN \<in> pb"
            using \<open>b\<^sub>1 \<noteq> {}\<close> \<open>b\<^sub>2 \<noteq> {}\<close> b1_def b2_def pb_def plus_bounds_incl(3) by auto
          moreover from 4(3) have "j = None"
            by (simp add: e1_def i1_def i2_def PInf)
          ultimately show ?thesis
            by (metis \<gamma>_bounds_incl(1) pb_def)
        next
          case MInf
          then have "NegInf \<in> b\<^sub>2"
            unfolding infinity_ereal_def using 4(2) \<gamma>_bounds_excl(3) b2_def i2_def
            by (metis uminus_ereal.simps(2))
          with \<open>NegInf \<in> b\<^sub>1\<close> have "NegInf \<in> pb"
            using \<open>b\<^sub>1 \<noteq> {}\<close> \<open>b\<^sub>2 \<noteq> {}\<close> b1_def b2_def pb_def plus_bounds_incl(5) by auto
          moreover from 4(3) have "j = Some MInfty"
            by (simp add: e1_def i1_def i2_def MInf)
          ultimately show ?thesis
            by (metis \<gamma>_bounds_incl(3) pb_def)
        qed
      qed
    qed
  qed
qed

global_interpretation Abs_Int
where \<gamma> = \<gamma>_bounds and num' = num_bounds and plus' = plus_bounds
defines aval_bounds = aval' and step_bounds = step' and AI_bounds = AI
  ..

global_interpretation Abs_Int_mono
  where \<gamma> = \<gamma>_bounds and num' = num_bounds and plus' = plus_bounds
proof (standard, goal_cases)
  case (1 a1 b1 a2 b2)
  then show ?case unfolding less_eq_bounds_def by(cases a1;cases b1;cases a2;cases b2, auto)
qed

fun m_bounds :: "bounds \<Rightarrow> nat"  where
  "m_bounds (B s) = card ({NegInf, PosInf, NaN, Real} - s)"

abbreviation h_bounds :: nat where
  "h_bounds \<equiv> 4"

global_interpretation Abs_Int_measure
where \<gamma> = \<gamma>_bounds and num' = num_bounds and plus' = plus_bounds
and m = m_bounds and h = h_bounds
proof (standard, goal_cases)
  case (1 x)
  let ?u = "{NegInf, PosInf, NaN, Real}"
  obtain s where "x = B s"
    using \<gamma>_bounds.cases by auto
  have "(UNIV - s) \<subseteq> ?u"
    using bound.exhaust by blast
  moreover have "finite ?u" by simp
  ultimately have "card (?u - s) \<le> card ?u" using card_mono[of ?u "?u - s"] by blast
  moreover have "card ?u = 4" by simp
  ultimately show ?case by (simp add: \<open>x = B s\<close>)
next
  case (2 x y)
  let ?u = "{NegInf, PosInf, NaN, Real}"
  have "finite ?u" by simp
  obtain xs where "x = B xs"
    using \<gamma>_bounds.cases by auto
  have "xs \<subseteq> ?u"
    using bound.exhaust by blast
  with \<open>finite ?u\<close> have "finite xs"
    using rev_finite_subset by blast
  obtain ys where "y = B ys"
    using \<gamma>_bounds.cases by auto
  let ?u = "{NegInf, PosInf, NaN, Real}"
  have "ys \<subseteq> ?u"
    using bound.exhaust by blast
  with \<open>finite ?u\<close> have "finite ys"
    using rev_finite_subset by blast
  from \<open>x < y\<close> have "xs \<subset> ys"
    unfolding less_bounds_def by(auto simp: \<open>x = B xs\<close> \<open>y = B ys\<close> psubsetD)
  then have "card xs < card ys"
    by (simp add: \<open>finite ys\<close> psubset_card_mono)
  moreover
  from \<open>xs \<subset> ys\<close> \<open>ys \<subseteq> ?u\<close>have "xs \<subset> ?u" by auto
  with \<open>finite ?u\<close> have "card xs < card ?u" using psubset_card_mono[of ?u xs] by fastforce
  then have "card ?u - card ys < card ?u - card xs"
    using diff_less_mono2[of "card xs" "card ys" "card ?u"] calculation by blast
  thm card_Diff_subset[of xs ?u]
  with \<open>finite xs\<close> \<open>finite ys\<close> \<open>xs \<subseteq> ?u\<close> \<open>ys \<subseteq> ?u\<close> have "card (?u - ys) < card (?u - xs)"
    using card_Diff_subset[of xs ?u] card_Diff_subset[of ys ?u] by simp
  then show ?case by(simp add: \<open>x = B xs\<close> \<open>y = B ys\<close>)
qed

end


theory ARMv8_State
  imports Main
begin

section \<open>State Encoding\<close>

datatype ('v,'r) var = Reg 'r | Glb 'v
record ('v,'a) state_rec = st :: "'a \<Rightarrow> 'v"

type_synonym ('v,'r,'a) state = "('v,('v,'r) var,'a) state_rec_scheme"
type_synonym ('v,'a) gstate = "('v,'v,'a) state_rec_scheme"

type_synonym ('v,'r,'a) pred = "('v,'r,'a) state set"
type_synonym ('v,'a) gpred = "('v,'a) gstate set"

type_synonym ('v,'r,'a) trel = "('v,'r,'a) state rel"
type_synonym ('v,'a) grel = "('v,'a) gstate rel"

type_synonym ('v,'r,'a) trans = "('v,'r,'a) pred \<Rightarrow> ('v,'r,'a) pred"
type_synonym ('v,'r,'a) rtrans = "('v,'r,'a) trel \<Rightarrow> ('v,'r,'a) trel"

type_synonym ('v,'r,'a) auxfn = "('v,('v,'r) var,'a) state_rec_scheme \<Rightarrow> 'a"

definition glb
  where "glb m \<equiv> \<lparr> st = (\<lambda>v. st m (Glb v)), \<dots> = more m \<rparr>"

definition rg :: "('v,'r,'a) state \<Rightarrow> ('r \<Rightarrow> 'v)"
  where "rg m \<equiv> \<lambda>v. st m (Reg v)"

definition aux
  where "aux m \<equiv> more m"

text \<open>Domain of register variables\<close>
abbreviation locals
  where "locals \<equiv> Reg ` UNIV"

text \<open>Domain of register variables\<close>
abbreviation globals
  where "globals \<equiv> Glb ` UNIV"

section \<open>Write Operations\<close>

definition st_upd :: "('v,'a,'b) state_rec_scheme \<Rightarrow> 'a \<Rightarrow> 'v \<Rightarrow> ('v,'a,'b) state_rec_scheme"
  where "st_upd m a b = m \<lparr> st := ((st m) (a := b)) \<rparr>"

definition aux_upd :: "('v,'r,'a) state_rec_scheme \<Rightarrow> (('v,'r,'a) state_rec_scheme \<Rightarrow> 'a) \<Rightarrow> ('v,'r,'a) state_rec_scheme"
  where "aux_upd m f \<equiv> m\<lparr>state_rec.more := f m\<rparr>"

nonterminal updbinds and updbind

syntax
  "_updbindm" :: "'a \<Rightarrow> 'a \<Rightarrow> updbind"            ("(2_ :=\<^sub>s/ _)")
  "_updbinda" :: "'a \<Rightarrow> updbind"                  ("(2aux:/ _)")
  ""         :: "updbind \<Rightarrow> updbinds"             ("_")
  "_updbinds":: "updbind \<Rightarrow> updbinds \<Rightarrow> updbinds" ("_,/ _")
  "_Update"  :: "'a \<Rightarrow> updbinds \<Rightarrow> 'a"            ("_/'((_)')" [1000, 0] 900)

translations
  "_Update f (_updbinds b bs)" \<rightleftharpoons> "_Update (_Update f b) bs"
  "f(x:=\<^sub>sy)" \<rightleftharpoons> "CONST st_upd f x y"
  "f(aux: y)" \<rightleftharpoons> "CONST aux_upd f y"

section \<open>Simp Lemmas\<close>

lemma aux_nop [simp]:
  "m(aux:aux) = m"
  by (auto simp: aux_def aux_upd_def)

lemma aux_st [simp]:
  "st (m(aux: e)) = st m"
  by (auto simp: aux_upd_def)

lemma [simp]:
  "st (m(v :=\<^sub>s e)) = (st m)(v := e)"
  by (auto simp: st_upd_def)

lemma [simp]:
  "more (m(r :=\<^sub>s e)) = more m"
  by (auto simp: st_upd_def)

lemma [simp]:
  "more (m(aux: e)) = e m"
  by (auto simp: aux_upd_def)

lemma [simp]:
  "rg (m(Glb x :=\<^sub>s e)) = rg m"
  by (auto simp: rg_def st_upd_def)

lemma [simp]:
  "rg (m(Reg x :=\<^sub>s e)) = (rg m)(x := e)"
  by (auto simp: st_upd_def rg_def)

lemma [simp]:
  "glb (m(Reg r :=\<^sub>s e)) = glb m"
  by (auto simp: glb_def st_upd_def)

lemma [simp]:
  "glb (m(Reg r :=\<^sub>s e, aux: f)) = glb (m(aux: \<lambda>m. f(m(Reg r :=\<^sub>s e))))"
  by (auto simp: aux_def glb_def)

lemma [simp]:
  "st m (Reg x) = rg m x"
  by (auto simp: rg_def)

lemma [simp]:
  "glb (m(Reg x :=\<^sub>s e)) = glb m"
  by (auto simp: glb_def st_upd_def)

lemma [simp]:
  "aux (m(Reg x :=\<^sub>s e)) = aux m"
  by (auto simp: aux_def st_upd_def)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |                 August 2007               |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_T_domain
imports CSP_F_domain
begin

(*=======================================================*
                 make 'a domF from 'a domT
     (this theory is not important and can be removed)
 *=======================================================*)

definition
  traces_to_failures :: "'a domT => 'a setF"
  where
  traces_to_failures_def :
    "traces_to_failures T ==
        {f. (EX s. (EX X. f = (s ^^^ <Tick>, X)) & s ^^^ <Tick> :t T) |
            (EX s X. f = (s, X) & noTick s & s ^^^ <Tick> :t T & X <= Evset)}f"

(*********************************************************
                        setF
 *********************************************************)

(* F2 *)

lemma traces_to_failures_in_setF:
  "{f. (EX s. (EX X. f = (s ^^^ <Tick>, X)) & s ^^^ <Tick> :t T) |
            (EX s X. f = (s, X) & noTick s & s ^^^ <Tick> :t T & X <= Evset)} : setF"
by (auto simp add: setF_def HC_F2_def)

(* in *)

lemma in_traces_to_failures:
  "(s, X) :f traces_to_failures T =
            ((EX t. s = t ^^^ <Tick> & t ^^^ <Tick> :t T) |
             (noTick s & s ^^^ <Tick> :t T & X <= Evset))"
apply (simp add: memF_def)
apply (simp add: traces_to_failures_def)
apply (simp add: Abs_setF_inverse traces_to_failures_in_setF)
done

(*********************************************************
                        domF
 *********************************************************)

(* T2 *)

lemma traces_to_failures_T2 :
   "HC_T2 (T, traces_to_failures T)"
apply (simp add: HC_T2_def)
apply (simp add: in_traces_to_failures)
apply (auto)
apply (rule memT_prefix_closed, simp)
apply (simp add: prefix_def)
apply (rule_tac x="<Tick>" in exI)
apply (simp)
done

(* F3 *)

lemma traces_to_failures_F3 :
   "HC_F3 (T, traces_to_failures T)"
apply (simp add: HC_F3_def)
apply (simp add: in_traces_to_failures)
apply (auto)
apply (case_tac "x = Tick")
 apply (drule_tac x="Tick" in spec)
 apply (simp)
 apply (simp add: Evset_def)
done

(* T3_F4 *)

lemma traces_to_failures_T3_F4 :
   "HC_T3_F4 (T, traces_to_failures T)"
apply (simp add: HC_T3_F4_def)
apply (simp add: in_traces_to_failures)
apply (auto)
done

(*** traces_to_failures_domF ***)

lemma traces_to_failures_domF[simp]: "(T, traces_to_failures T) : domF"
apply (simp add: domF_iff)
apply (simp add: traces_to_failures_T2)
apply (simp add: traces_to_failures_F3)
apply (simp add: traces_to_failures_T3_F4)
done

(*********************************************************
                        relation
 *********************************************************)

lemma traces_to_failures_EX: "ALL T. EX F. T = fstF F"
apply (rule)
apply (rule_tac x="(T ,, traces_to_failures T)" in exI)
apply (simp add: pairF_fstF)
done

lemma traces_to_failures_subset:
   "T1 <= T2 ==> traces_to_failures T1 <= traces_to_failures T2"
apply (rule)
apply (simp add: in_traces_to_failures)
apply (auto)
done

lemma traces_to_failures_refF:
   "T1 <= T2 ==> EX F1 F2. T1 = fstF F1 & T2 = fstF F2 & F1 <= F2"
apply (simp add: subdomF_decompo)
apply (rule_tac x="(T1 ,, traces_to_failures T1)" in exI)
apply (simp add: pairF_fstF)
apply (rule_tac x="(T2 ,, traces_to_failures T2)" in exI)
apply (simp add: pairF_fstF)
apply (simp add: pairF_sndF)
apply (simp add: traces_to_failures_subset)
done

(*** fun ***)

lemma traces_to_failures_fun_EX: "ALL Tf. EX Ff. Tf = fstF o Ff"
apply (simp add: fun_eq_iff)
apply (rule)
apply (rule_tac x="(%x. (Tf x ,, traces_to_failures (Tf x)))" in exI)
apply (simp add: pairF_fstF)
done

lemma traces_to_failures_fun_refF:
   "Tf1 <= Tf2 ==> EX Ff1 Ff2. Tf1 = fstF o Ff1 & Tf2 = fstF o Ff2 & Ff1 <= Ff2"
apply (rule_tac x="(%x. (Tf1 x ,, traces_to_failures (Tf1 x)))" in exI)
apply (rule_tac x="(%x. (Tf2 x ,, traces_to_failures (Tf2 x)))" in exI)
apply (simp add: fun_eq_iff)
apply (simp add: pairF_fstF)
apply (simp add: order_prod_def)
apply (rule)
apply (simp add: subdomF_decompo)
apply (simp add: pairF_fstF)
apply (simp add: pairF_sndF)
apply (simp add: traces_to_failures_subset)
done

end


(*  Title:      ZF/AC/DC.thy
    Author:     Krzysztof Grabczewski

The proofs concerning the Axiom of Dependent Choice.
*)

theory DC
imports AC_Equiv Hartog Cardinal_aux
begin

lemma RepFun_lepoll: "Ord(a) \<Longrightarrow> {P(b). b \<in> a} \<lesssim> a"
  unfolding lepoll_def
apply (rule_tac x = "\<lambda>z \<in> RepFun (a,P) . \<mu> i. z=P (i) " in exI)
apply (rule_tac d="\<lambda>z. P (z)" in lam_injective)
 apply (fast intro!: Least_in_Ord)
apply (rule sym)
apply (fast intro: LeastI Ord_in_Ord)
done

text\<open>Trivial in the presence of AC, but here we need a wellordering of X\<close>
lemma image_Ord_lepoll: "\<lbrakk>f \<in> X->Y; Ord(X)\<rbrakk> \<Longrightarrow> f``X \<lesssim> X"
  unfolding lepoll_def
apply (rule_tac x = "\<lambda>x \<in> f``X. \<mu> y. f`y = x" in exI)
apply (rule_tac d = "\<lambda>z. f`z" in lam_injective)
apply (fast intro!: Least_in_Ord apply_equality, clarify)
apply (rule LeastI)
 apply (erule apply_equality, assumption+)
apply (blast intro: Ord_in_Ord)
done

lemma range_subset_domain:
      "\<lbrakk>R \<subseteq> X*X;   \<And>g. g \<in> X \<Longrightarrow> \<exists>u. \<langle>g,u\<rangle> \<in> R\<rbrakk>
       \<Longrightarrow> range(R) \<subseteq> domain(R)"
by blast

lemma cons_fun_type: "g \<in> n->X \<Longrightarrow> cons(\<langle>n,x\<rangle>, g) \<in> succ(n) -> cons(x, X)"
  unfolding succ_def
apply (fast intro!: fun_extend elim!: mem_irrefl)
done

lemma cons_fun_type2:
     "\<lbrakk>g \<in> n->X; x \<in> X\<rbrakk> \<Longrightarrow> cons(\<langle>n,x\<rangle>, g) \<in> succ(n) -> X"
by (erule cons_absorb [THEN subst], erule cons_fun_type)

lemma cons_image_n: "n \<in> nat \<Longrightarrow> cons(\<langle>n,x\<rangle>, g)``n = g``n"
by (fast elim!: mem_irrefl)

lemma cons_val_n: "g \<in> n->X \<Longrightarrow> cons(\<langle>n,x\<rangle>, g)`n = x"
by (fast intro!: apply_equality elim!: cons_fun_type)

lemma cons_image_k: "k \<in> n \<Longrightarrow> cons(\<langle>n,x\<rangle>, g)``k = g``k"
by (fast elim: mem_asym)

lemma cons_val_k: "\<lbrakk>k \<in> n; g \<in> n->X\<rbrakk> \<Longrightarrow> cons(\<langle>n,x\<rangle>, g)`k = g`k"
by (fast intro!: apply_equality consI2 elim!: cons_fun_type apply_Pair)

lemma domain_cons_eq_succ: "domain(f)=x \<Longrightarrow> domain(cons(\<langle>x,y\<rangle>, f)) = succ(x)"
by (simp add: domain_cons succ_def)

lemma restrict_cons_eq: "g \<in> n->X \<Longrightarrow> restrict(cons(\<langle>n,x\<rangle>, g), n) = g"
apply (simp add: restrict_def Pi_iff)
apply (blast intro: elim: mem_irrefl)
done

lemma succ_in_succ: "\<lbrakk>Ord(k); i \<in> k\<rbrakk> \<Longrightarrow> succ(i) \<in> succ(k)"
apply (rule Ord_linear [of "succ(i)" "succ(k)", THEN disjE])
apply (fast elim: Ord_in_Ord mem_irrefl mem_asym)+
done

lemma restrict_eq_imp_val_eq:
      "\<lbrakk>restrict(f, domain(g)) = g; x \<in> domain(g)\<rbrakk>
       \<Longrightarrow> f`x = g`x"
by (erule subst, simp add: restrict)

lemma domain_eq_imp_fun_type: "\<lbrakk>domain(f)=A; f \<in> B->C\<rbrakk> \<Longrightarrow> f \<in> A->C"
by (frule domain_of_fun, fast)

lemma ex_in_domain: "\<lbrakk>R \<subseteq> A * B; R \<noteq> 0\<rbrakk> \<Longrightarrow> \<exists>x. x \<in> domain(R)"
by (fast elim!: not_emptyE)

definition
  DC  :: "i \<Rightarrow> o"  where
    "DC(a) \<equiv> \<forall>X R. R \<subseteq> Pow(X)*X  \<and>
                    (\<forall>Y \<in> Pow(X). Y \<prec> a \<longrightarrow> (\<exists>x \<in> X. \<langle>Y,x\<rangle> \<in> R))
                    \<longrightarrow> (\<exists>f \<in> a->X. \<forall>b<a. <f``b,f`b> \<in> R)"

definition
  DC0 :: o  where
    "DC0 \<equiv> \<forall>A B R. R \<subseteq> A*B \<and> R\<noteq>0 \<and> range(R) \<subseteq> domain(R)
                    \<longrightarrow> (\<exists>f \<in> nat->domain(R). \<forall>n \<in> nat. <f`n,f`succ(n)>:R)"

definition
  ff  :: "[i, i, i, i] \<Rightarrow> i"  where
    "ff(b, X, Q, R) \<equiv>
           transrec(b, \<lambda>c r. THE x. first(x, {x \<in> X. <r``c, x> \<in> R}, Q))"

locale DC0_imp =
  fixes XX and RR and X and R

  assumes all_ex: "\<forall>Y \<in> Pow(X). Y \<prec> nat \<longrightarrow> (\<exists>x \<in> X. \<langle>Y, x\<rangle> \<in> R)"

  defines XX_def: "XX \<equiv> (\<Union>n \<in> nat. {f \<in> n->X. \<forall>k \<in> n. <f``k, f`k> \<in> R})"
     and RR_def:  "RR \<equiv> {\<langle>z1,z2\<rangle>:XX*XX. domain(z2)=succ(domain(z1))
                                       \<and> restrict(z2, domain(z1)) = z1}"
begin

(* ********************************************************************** *)
(* DC \<Longrightarrow> DC(omega)                                                       *)
(*                                                                        *)
(* The scheme of the proof:                                               *)
(*                                                                        *)
(* Assume DC. Let R and X satisfy the premise of DC(omega).               *)
(*                                                                        *)
(* Define XX and RR as follows:                                           *)
(*                                                                        *)
(*       XX = (\<Union>n \<in> nat. {f \<in> n->X. \<forall>k \<in> n. <f``k, f`k> \<in> R})           *)
(*       f RR g iff domain(g)=succ(domain(f)) \<and>                           *)
(*              restrict(g, domain(f)) = f                                *)
(*                                                                        *)
(* Then RR satisfies the hypotheses of DC.                                *)
(* So applying DC:                                                        *)
(*                                                                        *)
(*       \<exists>f \<in> nat->XX. \<forall>n \<in> nat. f`n RR f`succ(n)                        *)
(*                                                                        *)
(* Thence                                                                 *)
(*                                                                        *)
(*       ff = {<n, f`succ(n)`n>. n \<in> nat}                                 *)
(*                                                                        *)
(* is the desired function.                                               *)
(*                                                                        *)
(* ********************************************************************** *)

lemma lemma1_1: "RR \<subseteq> XX*XX"
by (unfold RR_def, fast)

lemma lemma1_2: "RR \<noteq> 0"
  unfolding RR_def XX_def
apply (rule all_ex [THEN ballE])
apply (erule_tac [2] notE [OF _ empty_subsetI [THEN PowI]])
apply (erule_tac impE [OF _ nat_0I [THEN n_lesspoll_nat]])
apply (erule bexE)
apply (rule_tac a = "<0, {\<langle>0, x\<rangle>}>" in not_emptyI)
apply (rule CollectI)
apply (rule SigmaI)
apply (rule nat_0I [THEN UN_I])
apply (simp (no_asm_simp) add: nat_0I [THEN UN_I])
apply (rule nat_1I [THEN UN_I])
apply (force intro!: singleton_fun [THEN Pi_type]
             simp add: singleton_0 [symmetric])
apply (simp add: singleton_0)
done

lemma lemma1_3: "range(RR) \<subseteq> domain(RR)"
  unfolding RR_def XX_def
apply (rule range_subset_domain, blast, clarify)
apply (frule fun_is_rel [THEN image_subset, THEN PowI,
                         THEN all_ex [THEN bspec]])
apply (erule impE[OF _ lesspoll_trans1[OF image_Ord_lepoll
                                          [OF _ nat_into_Ord] n_lesspoll_nat]],
       assumption+)
apply (erule bexE)
apply (rule_tac x = "cons (\<langle>n,x\<rangle>, g) " in exI)
apply (rule CollectI)
apply (force elim!: cons_fun_type2
             simp add: cons_image_n cons_val_n cons_image_k cons_val_k)
apply (simp add: domain_of_fun succ_def restrict_cons_eq)
done

lemma lemma2:
     "\<lbrakk>\<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  n \<in> nat\<rbrakk>
      \<Longrightarrow> \<exists>k \<in> nat. f`succ(n) \<in> k -> X \<and> n \<in> k
                  \<and> <f`succ(n)``n, f`succ(n)`n> \<in> R"
apply (induct_tac "n")
apply (drule apply_type [OF _ nat_1I])
apply (drule bspec [OF _ nat_0I])
apply (simp add: XX_def, safe)
apply (rule rev_bexI, assumption)
apply (subgoal_tac "0 \<in> y", force)
apply (force simp add: RR_def
             intro: ltD elim!: nat_0_le [THEN leE])
(** LEVEL 7, other subgoal **)
apply (drule bspec [OF _ nat_succI], assumption)
apply (subgoal_tac "f ` succ (succ (x)) \<in> succ (k) ->X")
apply (drule apply_type [OF _ nat_succI [THEN nat_succI]], assumption)
apply (simp (no_asm_use) add: XX_def RR_def)
apply safe
apply (frule_tac a="succ(k)" in domain_of_fun [symmetric, THEN trans],
       assumption)
apply (frule_tac a=y in domain_of_fun [symmetric, THEN trans],
       assumption)
apply (fast elim!: nat_into_Ord [THEN succ_in_succ]
            dest!: bspec [OF _ nat_into_Ord [THEN succ_in_succ]])
apply (drule domain_of_fun)
apply (simp add: XX_def RR_def, clarify)
apply (blast dest: domain_of_fun [symmetric, THEN trans] )
done

lemma lemma3_1:
     "\<lbrakk>\<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  m \<in> nat\<rbrakk>
      \<Longrightarrow>  {f`succ(x)`x. x \<in> m} = {f`succ(m)`x. x \<in> m}"
apply (subgoal_tac "\<forall>x \<in> m. f`succ (m) `x = f`succ (x) `x")
apply simp
apply (induct_tac "m", blast)
apply (rule ballI)
apply (erule succE)
 apply (rule restrict_eq_imp_val_eq)
  apply (drule bspec [OF _ nat_succI], assumption)
  apply (simp add: RR_def)
 apply (drule lemma2, assumption+)
 apply (fast dest!: domain_of_fun)
apply (drule_tac x = xa in bspec, assumption)
apply (erule sym [THEN trans, symmetric])
apply (rule restrict_eq_imp_val_eq [symmetric])
 apply (drule bspec [OF _ nat_succI], assumption)
 apply (simp add: RR_def)
apply (drule lemma2, assumption+)
apply (blast dest!: domain_of_fun
             intro: nat_into_Ord OrdmemD [THEN subsetD])
done

lemma lemma3:
     "\<lbrakk>\<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  m \<in> nat\<rbrakk>
      \<Longrightarrow> (\<lambda>x \<in> nat. f`succ(x)`x) `` m = f`succ(m)``m"
apply (erule natE, simp)
apply (subst image_lam)
 apply (fast elim!: OrdmemD [OF nat_succI Ord_nat])
apply (subst lemma3_1, assumption+)
 apply fast
apply (fast dest!: lemma2
            elim!: image_fun [symmetric, OF _ OrdmemD [OF _ nat_into_Ord]])
done

end

theorem DC0_imp_DC_nat: "DC0 \<Longrightarrow> DC(nat)"
apply (unfold DC_def DC0_def, clarify)
apply (elim allE)
apply (erule impE)
   (*these three results comprise Lemma 1*)
apply (blast intro!: DC0_imp.lemma1_1 [OF DC0_imp.intro] DC0_imp.lemma1_2 [OF DC0_imp.intro] DC0_imp.lemma1_3 [OF DC0_imp.intro])
apply (erule bexE)
apply (rule_tac x = "\<lambda>n \<in> nat. f`succ (n) `n" in rev_bexI)
 apply (rule lam_type, blast dest!: DC0_imp.lemma2 [OF DC0_imp.intro] intro: fun_weaken_type)
apply (rule oallI)
apply (frule DC0_imp.lemma2 [OF DC0_imp.intro], assumption)
  apply (blast intro: fun_weaken_type)
 apply (erule ltD)
(** LEVEL 11: last subgoal **)
apply (subst DC0_imp.lemma3 [OF DC0_imp.intro], assumption+)
  apply (fast elim!: fun_weaken_type)
 apply (erule ltD)
apply (force simp add: lt_def)
done

(* ************************************************************************
   DC(omega) \<Longrightarrow> DC

   The scheme of the proof:

   Assume DC(omega). Let R and x satisfy the premise of DC.

   Define XX and RR as follows:

    XX = (\<Union>n \<in> nat. {f \<in> succ(n)->domain(R). \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})

    RR = {\<langle>z1,z2\<rangle>:Fin(XX)*XX.
           (domain(z2)=succ(\<Union>f \<in> z1. domain(f)) \<and>
            (\<forall>f \<in> z1. restrict(z2, domain(f)) = f)) |
           (\<not> (\<exists>g \<in> XX. domain(g)=succ(\<Union>f \<in> z1. domain(f)) \<and>
                        (\<forall>f \<in> z1. restrict(g, domain(f)) = f)) \<and>
            z2={\<langle>0,x\<rangle>})}

   Then XX and RR satisfy the hypotheses of DC(omega).
   So applying DC:

         \<exists>f \<in> nat->XX. \<forall>n \<in> nat. f``n RR f`n

   Thence

         ff = {<n, f`n`n>. n \<in> nat}

   is the desired function.

************************************************************************* *)

lemma singleton_in_funs:
 "x \<in> X \<Longrightarrow> {\<langle>0,x\<rangle>} \<in>
            (\<Union>n \<in> nat. {f \<in> succ(n)->X. \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})"
apply (rule nat_0I [THEN UN_I])
apply (force simp add: singleton_0 [symmetric]
             intro!: singleton_fun [THEN Pi_type])
done

locale imp_DC0 =
  fixes XX and RR and x and R and f and allRR
  defines XX_def: "XX \<equiv> (\<Union>n \<in> nat.
                      {f \<in> succ(n)->domain(R). \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})"
      and RR_def:
         "RR \<equiv> {\<langle>z1,z2\<rangle>:Fin(XX)*XX.
                  (domain(z2)=succ(\<Union>f \<in> z1. domain(f))
                    \<and> (\<forall>f \<in> z1. restrict(z2, domain(f)) = f))
                  | (\<not> (\<exists>g \<in> XX. domain(g)=succ(\<Union>f \<in> z1. domain(f))
                     \<and> (\<forall>f \<in> z1. restrict(g, domain(f)) = f)) \<and> z2={\<langle>0,x\<rangle>})}"
      and allRR_def:
        "allRR \<equiv> \<forall>b<nat.
                   <f``b, f`b> \<in>
                    {\<langle>z1,z2\<rangle>\<in>Fin(XX)*XX. (domain(z2)=succ(\<Union>f \<in> z1. domain(f))
                                    \<and> (\<Union>f \<in> z1. domain(f)) = b
                                    \<and> (\<forall>f \<in> z1. restrict(z2,domain(f)) = f))}"
begin

lemma lemma4:
     "\<lbrakk>range(R) \<subseteq> domain(R);  x \<in> domain(R)\<rbrakk>
      \<Longrightarrow> RR \<subseteq> Pow(XX)*XX \<and>
             (\<forall>Y \<in> Pow(XX). Y \<prec> nat \<longrightarrow> (\<exists>x \<in> XX. \<langle>Y,x\<rangle>:RR))"
apply (rule conjI)
apply (force dest!: FinD [THEN PowI] simp add: RR_def)
apply (rule impI [THEN ballI])
apply (drule Finite_Fin [OF lesspoll_nat_is_Finite PowD], assumption)
apply (case_tac
       "\<exists>g \<in> XX. domain (g) =
             succ(\<Union>f \<in> Y. domain(f)) \<and> (\<forall>f\<in>Y. restrict(g, domain(f)) = f)")
apply (simp add: RR_def, blast)
apply (safe del: domainE)
  unfolding XX_def RR_def
apply (rule rev_bexI, erule singleton_in_funs)
apply (simp add: nat_0I [THEN rev_bexI] cons_fun_type2)
done

lemma UN_image_succ_eq:
     "\<lbrakk>f \<in> nat->X; n \<in> nat\<rbrakk>
      \<Longrightarrow> (\<Union>x \<in> f``succ(n). P(x)) =  P(f`n) \<union> (\<Union>x \<in> f``n. P(x))"
by (simp add: image_fun OrdmemD)

lemma UN_image_succ_eq_succ:
     "\<lbrakk>(\<Union>x \<in> f``n. P(x)) = y; P(f`n) = succ(y);
         f \<in> nat -> X; n \<in> nat\<rbrakk> \<Longrightarrow> (\<Union>x \<in> f``succ(n). P(x)) = succ(y)"
by (simp add: UN_image_succ_eq, blast)

lemma apply_domain_type:
     "\<lbrakk>h \<in> succ(n) -> D;  n \<in> nat; domain(h)=succ(y)\<rbrakk> \<Longrightarrow> h`y \<in> D"
by (fast elim: apply_type dest!: trans [OF sym domain_of_fun])

lemma image_fun_succ:
     "\<lbrakk>h \<in> nat -> X; n \<in> nat\<rbrakk> \<Longrightarrow> h``succ(n) = cons(h`n, h``n)"
by (simp add: image_fun OrdmemD)

lemma f_n_type:
     "\<lbrakk>domain(f`n) = succ(k); f \<in> nat -> XX;  n \<in> nat\<rbrakk>
      \<Longrightarrow> f`n \<in> succ(k) -> domain(R)"
  unfolding XX_def
apply (drule apply_type, assumption)
apply (fast elim: domain_eq_imp_fun_type)
done

lemma f_n_pairs_in_R [rule_format]:
     "\<lbrakk>h \<in> nat -> XX;  domain(h`n) = succ(k);  n \<in> nat\<rbrakk>
      \<Longrightarrow> \<forall>i \<in> k. <h`n`i, h`n`succ(i)> \<in> R"
  unfolding XX_def
apply (drule apply_type, assumption)
apply (elim UN_E CollectE)
apply (drule domain_of_fun [symmetric, THEN trans], assumption, simp)
done

lemma restrict_cons_eq_restrict:
     "\<lbrakk>restrict(h, domain(u))=u;  h \<in> n->X;  domain(u) \<subseteq> n\<rbrakk>
      \<Longrightarrow> restrict(cons(\<langle>n, y\<rangle>, h), domain(u)) = u"
  unfolding restrict_def
apply (simp add: restrict_def Pi_iff)
apply (erule sym [THEN trans, symmetric])
apply (blast elim: mem_irrefl)
done

lemma all_in_image_restrict_eq:
     "\<lbrakk>\<forall>x \<in> f``n. restrict(f`n, domain(x))=x;
         f \<in> nat -> XX;
         n \<in> nat;  domain(f`n) = succ(n);
         (\<Union>x \<in> f``n. domain(x)) \<subseteq> n\<rbrakk>
      \<Longrightarrow> \<forall>x \<in> f``succ(n). restrict(cons(<succ(n),y>, f`n), domain(x)) = x"
apply (rule ballI)
apply (simp add: image_fun_succ)
apply (drule f_n_type, assumption+)
apply (erule disjE)
 apply (simp add: domain_of_fun restrict_cons_eq)
apply (blast intro!: restrict_cons_eq_restrict)
done

lemma simplify_recursion:
     "\<lbrakk>\<forall>b<nat. <f``b, f`b> \<in> RR;
         f \<in> nat -> XX; range(R) \<subseteq> domain(R); x \<in> domain(R)\<rbrakk>
      \<Longrightarrow> allRR"
  unfolding RR_def allRR_def
apply (rule oallI, drule ltD)
apply (erule nat_induct)
apply (drule_tac x=0 in ospec, blast intro: Limit_has_0)
apply (force simp add: singleton_fun [THEN domain_of_fun] singleton_in_funs)
(*induction step*) (** LEVEL 5 **)
(*prevent simplification of \<not>\<exists> to \<forall>\<not> *)
apply (simp only: separation split)
apply (drule_tac x="succ(xa)" in ospec, blast intro: ltI)
apply (elim conjE disjE)
apply (force elim!: trans subst_context
             intro!: UN_image_succ_eq_succ)
apply (erule notE)
apply (simp add: XX_def UN_image_succ_eq_succ)
apply (elim conjE bexE)
apply (drule apply_domain_type, assumption+)
apply (erule domainE)+
apply (frule f_n_type)
apply (simp add: XX_def, assumption+)
apply (rule rev_bexI, erule nat_succI)
apply (rename_tac m i j y z)
apply (rule_tac x = "cons(<succ(m), z>, f`m)" in bexI)
prefer 2 apply (blast intro: cons_fun_type2)
apply (rule conjI)
prefer 2 apply (fast del: ballI subsetI
                 elim: trans [OF _ subst_context, THEN domain_cons_eq_succ]
                       subst_context
                       all_in_image_restrict_eq [simplified XX_def]
                       trans equalityD1)
(*one remaining subgoal*)
apply (rule ballI)
apply (erule succE)
(** LEVEL 25 **)
 apply (simp add: cons_val_n cons_val_k)
(*assumption+ will not perform the required backtracking!*)
apply (drule f_n_pairs_in_R [simplified XX_def, OF _ domain_of_fun],
       assumption, assumption, assumption)
apply (simp add: nat_into_Ord [THEN succ_in_succ] succI2 cons_val_k)
done

lemma lemma2:
     "\<lbrakk>allRR; f \<in> nat->XX; range(R) \<subseteq> domain(R); x \<in> domain(R); n \<in> nat\<rbrakk>
      \<Longrightarrow> f`n \<in> succ(n) -> domain(R) \<and> (\<forall>i \<in> n. <f`n`i, f`n`succ(i)>:R)"
  unfolding allRR_def
apply (drule ospec)
apply (erule ltI [OF _ Ord_nat])
apply (erule CollectE, simp)
apply (rule conjI)
prefer 2 apply (fast elim!: f_n_pairs_in_R trans subst_context)
  unfolding XX_def
apply (fast elim!: trans [THEN domain_eq_imp_fun_type] subst_context)
done

lemma lemma3:
     "\<lbrakk>allRR; f \<in> nat->XX; n\<in>nat; range(R) \<subseteq> domain(R);  x \<in> domain(R)\<rbrakk>
      \<Longrightarrow> f`n`n = f`succ(n)`n"
apply (frule lemma2 [THEN conjunct1, THEN domain_of_fun], assumption+)
  unfolding allRR_def
apply (drule ospec)
apply (drule ltI [OF nat_succI Ord_nat], assumption, simp)
apply (elim conjE ballE)
apply (erule restrict_eq_imp_val_eq [symmetric], force)
apply (simp add: image_fun OrdmemD)
done

end

theorem DC_nat_imp_DC0: "DC(nat) \<Longrightarrow> DC0"
  unfolding DC_def DC0_def
apply (intro allI impI)
apply (erule asm_rl conjE ex_in_domain [THEN exE] allE)+
apply (erule impE [OF _ imp_DC0.lemma4], assumption+)
apply (erule bexE)
apply (drule imp_DC0.simplify_recursion, assumption+)
apply (rule_tac x = "\<lambda>n \<in> nat. f`n`n" in bexI)
apply (rule_tac [2] lam_type)
apply (erule_tac [2] apply_type [OF imp_DC0.lemma2 [THEN conjunct1] succI1])
apply (rule ballI)
apply (frule_tac n="succ(n)" in imp_DC0.lemma2,
       (assumption|erule nat_succI)+)
apply (drule imp_DC0.lemma3, auto)
done

(* ********************************************************************** *)
(* \<forall>K. Card(K) \<longrightarrow> DC(K) \<Longrightarrow> WO3                                       *)
(* ********************************************************************** *)

lemma fun_Ord_inj:
      "\<lbrakk>f \<in> a->X;  Ord(a);
          \<And>b c. \<lbrakk>b<c; c \<in> a\<rbrakk> \<Longrightarrow> f`b\<noteq>f`c\<rbrakk>
       \<Longrightarrow> f \<in> inj(a, X)"
apply (unfold inj_def, simp)
apply (intro ballI impI)
apply (rule_tac j=x in Ord_in_Ord [THEN Ord_linear_lt], assumption+)
apply (blast intro: Ord_in_Ord, auto)
apply (atomize, blast dest: not_sym)
done

lemma value_in_image: "\<lbrakk>f \<in> X->Y; A \<subseteq> X; a \<in> A\<rbrakk> \<Longrightarrow> f`a \<in> f``A"
by (fast elim!: image_fun [THEN ssubst])

lemma lesspoll_lemma: "\<lbrakk>\<not> A \<prec> B; C \<prec> B\<rbrakk> \<Longrightarrow> A - C \<noteq> 0"
  unfolding lesspoll_def
apply (fast dest!: Diff_eq_0_iff [THEN iffD1, THEN subset_imp_lepoll]
            intro!: eqpollI elim: notE
            elim!: eqpollE lepoll_trans)
done

theorem DC_WO3: "(\<forall>K. Card(K) \<longrightarrow> DC(K)) \<Longrightarrow> WO3"
  unfolding DC_def WO3_def
apply (rule allI)
apply (case_tac "A \<prec> Hartog (A)")
apply (fast dest!: lesspoll_imp_ex_lt_eqpoll
            intro!: Ord_Hartog leI [THEN le_imp_subset])
apply (erule allE impE)+
apply (rule Card_Hartog)
apply (erule_tac x = A in allE)
apply (erule_tac x = "{\<langle>z1,z2\<rangle> \<in> Pow (A) *A . z1 \<prec> Hartog (A) \<and> z2 \<notin> z1}"
                 in allE)
apply simp
apply (erule impE, fast elim: lesspoll_lemma [THEN not_emptyE])
apply (erule bexE)
apply (rule Hartog_lepoll_selfE)
apply (rule lepoll_def [THEN def_imp_iff, THEN iffD2])
apply (rule exI, rule fun_Ord_inj, assumption, rule Ord_Hartog)
apply (drule value_in_image)
apply (drule OrdmemD, rule Ord_Hartog, assumption+, erule ltD)
apply (drule ospec)
apply (blast intro: ltI Ord_Hartog, force)
done

(* ********************************************************************** *)
(* WO1 \<Longrightarrow> \<forall>K. Card(K) \<longrightarrow> DC(K)                                       *)
(* ********************************************************************** *)

lemma images_eq:
     "\<lbrakk>\<forall>x \<in> A. f`x=g`x; f \<in> Df->Cf; g \<in> Dg->Cg; A \<subseteq> Df; A \<subseteq> Dg\<rbrakk>
      \<Longrightarrow> f``A = g``A"
apply (simp (no_asm_simp) add: image_fun)
done

lemma lam_images_eq:
     "\<lbrakk>Ord(a); b \<in> a\<rbrakk> \<Longrightarrow> (\<lambda>x \<in> a. h(x))``b = (\<lambda>x \<in> b. h(x))``b"
apply (rule images_eq)
    apply (rule ballI)
    apply (drule OrdmemD [THEN subsetD], assumption+)
    apply simp
   apply (fast elim!: RepFunI OrdmemD intro!: lam_type)+
done

lemma lam_type_RepFun: "(\<lambda>b \<in> a. h(b)) \<in> a -> {h(b). b \<in> a}"
by (fast intro!: lam_type RepFunI)

lemma lemmaX:
     "\<lbrakk>\<forall>Y \<in> Pow(X). Y \<prec> K \<longrightarrow> (\<exists>x \<in> X. \<langle>Y, x\<rangle> \<in> R);
         b \<in> K; Z \<in> Pow(X); Z \<prec> K\<rbrakk>
      \<Longrightarrow> {x \<in> X. \<langle>Z,x\<rangle> \<in> R} \<noteq> 0"
by blast

lemma WO1_DC_lemma:
     "\<lbrakk>Card(K); well_ord(X,Q);
         \<forall>Y \<in> Pow(X). Y \<prec> K \<longrightarrow> (\<exists>x \<in> X. \<langle>Y, x\<rangle> \<in> R); b \<in> K\<rbrakk>
      \<Longrightarrow> ff(b, X, Q, R) \<in> {x \<in> X. <(\<lambda>c \<in> b. ff(c, X, Q, R))``b, x> \<in> R}"
apply (rule_tac P = "b \<in> K" in impE, (erule_tac [2] asm_rl)+)
apply (rule_tac i=b in Card_is_Ord [THEN Ord_in_Ord, THEN trans_induct],
       assumption+)
apply (rule impI)
apply (rule ff_def [THEN def_transrec, THEN ssubst])
apply (erule the_first_in, fast)
apply (simp add: image_fun [OF lam_type_RepFun subset_refl])
apply (erule lemmaX, assumption)
 apply (blast intro: Card_is_Ord OrdmemD [THEN subsetD])
apply (blast intro: lesspoll_trans1 in_Card_imp_lesspoll RepFun_lepoll)
done

theorem WO1_DC_Card: "WO1 \<Longrightarrow> \<forall>K. Card(K) \<longrightarrow> DC(K)"
  unfolding DC_def WO1_def
apply (rule allI impI)+
apply (erule allE exE conjE)+
apply (rule_tac x = "\<lambda>b \<in> K. ff (b, X, Ra, R) " in bexI)
 apply (simp add: lam_images_eq [OF Card_is_Ord ltD])
 apply (fast elim!: ltE WO1_DC_lemma [THEN CollectD2])
apply (rule_tac lam_type)
apply (rule WO1_DC_lemma [THEN CollectD1], assumption+)
done

end


(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
header {* \isaheader{Tries without invariants} *}
theory Trie imports
  Trie_Impl
begin

(*<*)

subsection {* Abstract type definition *}

typedef ('key, 'val) trie =
  "{t :: ('key, 'val) Trie_Impl.trie. trie_invar t}"
  morphisms impl_of Trie
proof
  show "Trie_Impl.empty \<in> ?trie" by(simp)
qed

lemma trie_invar_impl_of [simp, intro]: "trie_invar (impl_of t)"
using impl_of[of t] by simp

lemma Trie_impl_of [code abstype]: "Trie (impl_of t) = t"
by(rule impl_of_inverse)

subsection {* Primitive operations *}

definition empty :: "('key, 'val) trie"
where "empty = Trie (Trie_Impl.empty)"

definition update :: "'key list \<Rightarrow> 'val \<Rightarrow> ('key, 'val) trie \<Rightarrow> ('key, 'val) trie"
where "update ks v t = Trie (Trie_Impl.update (impl_of t) ks v)"

definition delete :: "'key list \<Rightarrow> ('key, 'val) trie \<Rightarrow> ('key, 'val) trie"
where "delete ks t = Trie (Trie_Impl.delete (impl_of t) ks)"

definition lookup :: "('key, 'val) trie \<Rightarrow> 'key list \<Rightarrow> 'val option"
where "lookup t = Trie_Impl.lookup (impl_of t)"

definition isEmpty :: "('key, 'val) trie \<Rightarrow> bool"
where "isEmpty t = Trie_Impl.isEmpty (impl_of t)"

definition iteratei :: "('key, 'val) trie \<Rightarrow> ('key list \<times> 'val, '\<sigma>) set_iterator"
where "iteratei t = set_iterator_image trie_reverse_key (Trie_Impl.iteratei (impl_of t))"

lemma iteratei_code[code] :
  "iteratei t c f = Trie_Impl.iteratei (impl_of t) c (\<lambda>(ks, v). f (rev ks, v))"
unfolding iteratei_def set_iterator_image_alt_def
apply (subgoal_tac "(\<lambda>x. f (trie_reverse_key x)) = (\<lambda>(ks, v). f (rev ks, v))")
apply (auto simp add: trie_reverse_key_def)
done

lemma impl_of_empty [code abstract]: "impl_of empty = Trie_Impl.empty"
by(simp add: empty_def Trie_inverse)

lemma impl_of_update [code abstract]: "impl_of (update ks v t) = Trie_Impl.update (impl_of t) ks v"
by(simp add: update_def Trie_inverse trie_invar_update)

lemma impl_of_delete [code abstract]: "impl_of (delete ks t) = Trie_Impl.delete (impl_of t) ks"
by(simp add: delete_def Trie_inverse trie_invar_delete)

subsection {* Correctness of primitive operations *}

lemma lookup_empty [simp]: "lookup empty = Map.empty"
by(simp add: lookup_def empty_def Trie_inverse)

lemma lookup_update [simp]: "lookup (update ks v t) = (lookup t)(ks \<mapsto> v)"
by(simp add: lookup_def update_def Trie_inverse trie_invar_update lookup_update')

lemma lookup_delete [simp]: "lookup (delete ks t) = (lookup t)(ks := None)"
by(simp add: lookup_def delete_def Trie_inverse trie_invar_delete lookup_delete')

lemma isEmpty_lookup: "isEmpty t \<longleftrightarrow> lookup t = Map.empty"
by(simp add: isEmpty_def lookup_def isEmpty_lookup_empty)

lemma finite_dom_lookup: "finite (dom (lookup t))"
by(simp add: lookup_def finite_dom_trie_lookup)

lemma iteratei_correct:
  "map_iterator (iteratei m) (lookup m)"
proof -
  note it_base = Trie_Impl.trie_iteratei_correct [of "impl_of m"]
  show ?thesis
    unfolding iteratei_def lookup_def
    apply (rule set_iterator_image_correct [OF it_base])
    apply (simp_all add: set_eq_iff image_iff inj_on_def)
  done
qed

subsection {* Type classes *}

instantiation trie :: (equal, equal) equal begin

definition "equal_class.equal (t :: ('a, 'b) trie) t' = (impl_of t = impl_of t')"

instance
proof
qed(simp add: equal_trie_def impl_of_inject)
end

hide_const (open) empty lookup update delete iteratei isEmpty

end


(* Author: Lukas Bulwahn, TU Muenchen *)

section {* Depth-Limited Sequences with failure element *}

theory Limited_Sequence
imports Lazy_Sequence
begin

subsection {* Depth-Limited Sequence *}

type_synonym 'a dseq = "natural \<Rightarrow> bool \<Rightarrow> 'a lazy_sequence option"

definition empty :: "'a dseq"
where
  "empty = (\<lambda>_ _. Some Lazy_Sequence.empty)"

definition single :: "'a \<Rightarrow> 'a dseq"
where
  "single x = (\<lambda>_ _. Some (Lazy_Sequence.single x))"

definition eval :: "'a dseq \<Rightarrow> natural \<Rightarrow> bool \<Rightarrow> 'a lazy_sequence option"
where
  [simp]: "eval f i pol = f i pol"

definition yield :: "'a dseq \<Rightarrow> natural \<Rightarrow> bool \<Rightarrow> ('a \<times> 'a dseq) option"
where
  "yield f i pol = (case eval f i pol of
    None \<Rightarrow> None
  | Some s \<Rightarrow> (map_option \<circ> apsnd) (\<lambda>r _ _. Some r) (Lazy_Sequence.yield s))"

definition map_seq :: "('a \<Rightarrow> 'b dseq) \<Rightarrow> 'a lazy_sequence \<Rightarrow> 'b dseq"
where
  "map_seq f xq i pol = map_option Lazy_Sequence.flat
    (Lazy_Sequence.those (Lazy_Sequence.map (\<lambda>x. f x i pol) xq))"

lemma map_seq_code [code]:
  "map_seq f xq i pol = (case Lazy_Sequence.yield xq of
    None \<Rightarrow> Some Lazy_Sequence.empty
  | Some (x, xq') \<Rightarrow> (case eval (f x) i pol of
      None \<Rightarrow> None
    | Some yq \<Rightarrow> (case map_seq f xq' i pol of
        None \<Rightarrow> None
      | Some zq \<Rightarrow> Some (Lazy_Sequence.append yq zq))))"
  by (cases xq)
    (auto simp add: map_seq_def Lazy_Sequence.those_def lazy_sequence_eq_iff split: list.splits option.splits)

definition bind :: "'a dseq \<Rightarrow> ('a \<Rightarrow> 'b dseq) \<Rightarrow> 'b dseq"
where
  "bind x f = (\<lambda>i pol.
     if i = 0 then
       (if pol then Some Lazy_Sequence.empty else None)
     else
       (case x (i - 1) pol of
         None \<Rightarrow> None
       | Some xq \<Rightarrow> map_seq f xq i pol))"

definition union :: "'a dseq \<Rightarrow> 'a dseq \<Rightarrow> 'a dseq"
where
  "union x y = (\<lambda>i pol. case (x i pol, y i pol) of
      (Some xq, Some yq) \<Rightarrow> Some (Lazy_Sequence.append xq yq)
    | _ \<Rightarrow> None)"

definition if_seq :: "bool \<Rightarrow> unit dseq"
where
  "if_seq b = (if b then single () else empty)"

definition not_seq :: "unit dseq \<Rightarrow> unit dseq"
where
  "not_seq x = (\<lambda>i pol. case x i (\<not> pol) of
    None \<Rightarrow> Some Lazy_Sequence.empty
  | Some xq \<Rightarrow> (case Lazy_Sequence.yield xq of
      None \<Rightarrow> Some (Lazy_Sequence.single ())
    | Some _ \<Rightarrow> Some (Lazy_Sequence.empty)))"

definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a dseq \<Rightarrow> 'b dseq"
where
  "map f g = (\<lambda>i pol. case g i pol of
     None \<Rightarrow> None
   | Some xq \<Rightarrow> Some (Lazy_Sequence.map f xq))"

subsection {* Positive Depth-Limited Sequence *}

type_synonym 'a pos_dseq = "natural \<Rightarrow> 'a Lazy_Sequence.lazy_sequence"

definition pos_empty :: "'a pos_dseq"
where
  "pos_empty = (\<lambda>i. Lazy_Sequence.empty)"

definition pos_single :: "'a \<Rightarrow> 'a pos_dseq"
where
  "pos_single x = (\<lambda>i. Lazy_Sequence.single x)"

definition pos_bind :: "'a pos_dseq \<Rightarrow> ('a \<Rightarrow> 'b pos_dseq) \<Rightarrow> 'b pos_dseq"
where
  "pos_bind x f = (\<lambda>i. Lazy_Sequence.bind (x i) (\<lambda>a. f a i))"

definition pos_decr_bind :: "'a pos_dseq \<Rightarrow> ('a \<Rightarrow> 'b pos_dseq) \<Rightarrow> 'b pos_dseq"
where
  "pos_decr_bind x f = (\<lambda>i.
     if i = 0 then
       Lazy_Sequence.empty
     else
       Lazy_Sequence.bind (x (i - 1)) (\<lambda>a. f a i))"

definition pos_union :: "'a pos_dseq \<Rightarrow> 'a pos_dseq \<Rightarrow> 'a pos_dseq"
where
  "pos_union xq yq = (\<lambda>i. Lazy_Sequence.append (xq i) (yq i))"

definition pos_if_seq :: "bool \<Rightarrow> unit pos_dseq"
where
  "pos_if_seq b = (if b then pos_single () else pos_empty)"

definition pos_iterate_upto :: "(natural \<Rightarrow> 'a) \<Rightarrow> natural \<Rightarrow> natural \<Rightarrow> 'a pos_dseq"
where
  "pos_iterate_upto f n m = (\<lambda>i. Lazy_Sequence.iterate_upto f n m)"

definition pos_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a pos_dseq \<Rightarrow> 'b pos_dseq"
where
  "pos_map f xq = (\<lambda>i. Lazy_Sequence.map f (xq i))"

subsection {* Negative Depth-Limited Sequence *}

type_synonym 'a neg_dseq = "natural \<Rightarrow> 'a Lazy_Sequence.hit_bound_lazy_sequence"

definition neg_empty :: "'a neg_dseq"
where
  "neg_empty = (\<lambda>i. Lazy_Sequence.empty)"

definition neg_single :: "'a \<Rightarrow> 'a neg_dseq"
where
  "neg_single x = (\<lambda>i. Lazy_Sequence.hb_single x)"

definition neg_bind :: "'a neg_dseq \<Rightarrow> ('a \<Rightarrow> 'b neg_dseq) \<Rightarrow> 'b neg_dseq"
where
  "neg_bind x f = (\<lambda>i. hb_bind (x i) (\<lambda>a. f a i))"

definition neg_decr_bind :: "'a neg_dseq \<Rightarrow> ('a \<Rightarrow> 'b neg_dseq) \<Rightarrow> 'b neg_dseq"
where
  "neg_decr_bind x f = (\<lambda>i.
     if i = 0 then
       Lazy_Sequence.hit_bound
     else
       hb_bind (x (i - 1)) (\<lambda>a. f a i))"

definition neg_union :: "'a neg_dseq \<Rightarrow> 'a neg_dseq \<Rightarrow> 'a neg_dseq"
where
  "neg_union x y = (\<lambda>i. Lazy_Sequence.append (x i) (y i))"

definition neg_if_seq :: "bool \<Rightarrow> unit neg_dseq"
where
  "neg_if_seq b = (if b then neg_single () else neg_empty)"

definition neg_iterate_upto
where
  "neg_iterate_upto f n m = (\<lambda>i. Lazy_Sequence.iterate_upto (\<lambda>i. Some (f i)) n m)"

definition neg_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a neg_dseq \<Rightarrow> 'b neg_dseq"
where
  "neg_map f xq = (\<lambda>i. Lazy_Sequence.hb_map f (xq i))"

subsection {* Negation *}

definition pos_not_seq :: "unit neg_dseq \<Rightarrow> unit pos_dseq"
where
  "pos_not_seq xq = (\<lambda>i. Lazy_Sequence.hb_not_seq (xq (3 * i)))"

definition neg_not_seq :: "unit pos_dseq \<Rightarrow> unit neg_dseq"
where
  "neg_not_seq x = (\<lambda>i. case Lazy_Sequence.yield (x i) of
    None => Lazy_Sequence.hb_single ()
  | Some ((), xq) => Lazy_Sequence.empty)"

ML {*
signature LIMITED_SEQUENCE =
sig
  type 'a dseq = Code_Numeral.natural -> bool -> 'a Lazy_Sequence.lazy_sequence option
  val map : ('a -> 'b) -> 'a dseq -> 'b dseq
  val yield : 'a dseq -> Code_Numeral.natural -> bool -> ('a * 'a dseq) option
  val yieldn : int -> 'a dseq -> Code_Numeral.natural -> bool -> 'a list * 'a dseq
end;

structure Limited_Sequence : LIMITED_SEQUENCE =
struct

type 'a dseq = Code_Numeral.natural -> bool -> 'a Lazy_Sequence.lazy_sequence option

fun map f = @{code Limited_Sequence.map} f;

fun yield f = @{code Limited_Sequence.yield} f;

fun yieldn n f i pol = (case f i pol of
    NONE => ([], fn _ => fn _ => NONE)
  | SOME s => let val (xs, s') = Lazy_Sequence.yieldn n s in (xs, fn _ => fn _ => SOME s') end);

end;
*}

code_reserved Eval Limited_Sequence

hide_const (open) yield empty single eval map_seq bind union if_seq not_seq map
  pos_empty pos_single pos_bind pos_decr_bind pos_union pos_if_seq pos_iterate_upto pos_not_seq pos_map
  neg_empty neg_single neg_bind neg_decr_bind neg_union neg_if_seq neg_iterate_upto neg_not_seq neg_map

hide_fact (open) yield_def empty_def single_def eval_def map_seq_def bind_def union_def
  if_seq_def not_seq_def map_def
  pos_empty_def pos_single_def pos_bind_def pos_union_def pos_if_seq_def pos_iterate_upto_def pos_not_seq_def pos_map_def
  neg_empty_def neg_single_def neg_bind_def neg_union_def neg_if_seq_def neg_iterate_upto_def neg_not_seq_def neg_map_def

end