theory codegen
imports Main
begin

datatype 'a queue = AQueue "'a list" "'a list"

definition empty :: "'a queue" where
  "empty = AQueue [] []"

primrec enqueue :: "'a \<Rightarrow> 'a queue \<Rightarrow> 'a queue" where
 "enqueue x (AQueue xs ys) = AQueue (x # xs) ys"

fun lookup :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup [] x = None" |
"lookup ((a,b) # ps) x = (if a = x then Some b else lookup ps x )"

fun dequeue :: "'a queue \<Rightarrow> 'a option \<times> 'a queue" where
"dequeue (AQueue [] []) = (None, AQueue [] [])"
| "dequeue (AQueue xs (y # ys)) = (Some y, AQueue xs ys)"
| "dequeue (AQueue xs []) =
  (case (rev xs) of y # ys \<Rightarrow> (Some y, AQueue [] ys))"

export_code empty dequeue enqueue in Scala
module_name codegen file "codegen.scala"

class semigroup =
fixes mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<otimes>" 70)
assumes assoc: "(x\<otimes>y)\<otimes>z = x\<otimes>(y\<otimes>z)"

class zero = fixes zero :: 'a ("0")
class one = fixes one :: 'a ("1")
hide_const (open) zero one

class monoid = semigroup +
fixes neutral :: 'a ("1")
assumes neutl: "1 \<otimes> x = x"
and neutr: "x \<otimes> 1 = x "

instantiation nat::monoid
begin

primrec mult_nat where
"0 \<otimes> n = (0::nat)"
| "Suc m \<otimes> n = n + m \<otimes> n"

definition neutral_nat where "1 = Suc 0"

lemma add_mult_distrib:
fixes n m q::nat
shows (n+m)\<otimes>q = n\<otimes>q + m\<otimes>q
by (induct n) simp_all

instance proof
fix m n q::nat
show m\<otimes>n\<otimes> = m\<otimes>(n\<otimes>q)
 by (induct m) (simp_all add: add_mult_distrib)
show 1\<otimes>n=n
 by (simp add: neutral-nat_def)
show m\<otimes>1=m
 by (induct m) (simp_all add: neutral-nat_def)

end

end


section \<open>Termination heuristics\<close>
text_raw \<open>\label{sec:termination}\<close>

theory Termination
  imports "../Dict_Construction"
begin

text \<open>
  As indicated in the introduction, the newly-defined functions must be proven terminating. In
  general, we cannot reuse the original termination proof, as the following example illustrates:
\<close>

fun f :: "nat \<Rightarrow> nat" where
"f 0 = 0" |
"f (Suc n) = f n"

text \<open>
  The invocation of @{theory_text \<open>declassify f\<close>} would fail, because @{const f}'s code equations
  are not terminating.

  Hence, in the general case where users have modified the code equations, we need to fall back
  to an (automated) attempt to prove termination.

  In the remainder of this section, we will illustrate the special case where the user has not
  modified the code equations, i.e., the original termination proof should ``morally'' be still
  applicable. For this, we will perform the dictionary construction manually.
\<close>

\<comment> \<open>Some ML incantations to ensure that the dictionary types are present\<close>
local_setup \<open>Class_Graph.ensure_class @{class plus} #> snd\<close>
local_setup \<open>Class_Graph.ensure_class @{class zero} #> snd\<close>

fun sum_list :: "'a::{plus,zero} list \<Rightarrow> 'a" where
"sum_list [] = 0" |
"sum_list (x # xs) = x + sum_list xs"

text \<open>
  The above function carries two distinct class constraints, which are translated into two
  dictionary parameters:
\<close>

function sum_list' where
"sum_list' d_plus d_zero [] = Groups_zero__class_zero__field d_zero" |
"sum_list' d_plus d_zero (x # xs) = Groups_plus__class_plus__field d_plus x (sum_list' d_plus d_zero xs)"
by pat_completeness auto

text \<open>
  Now, we need to carry out the termination proof of @{const sum_list'}. The @{theory_text function}
  package analyzes the function definition and discovers one recursive call. In pseudo-notation:

  @{text [display] \<open>(d_plus, d_zero, x # xs) \<leadsto> (d_plus, d_zero, xs)\<close>}

  The result of this analysis is captured in the inductive predicate @{const sum_list'_rel}. Its
  introduction rules look as follows:
\<close>

thm sum_list'_rel.intros
\<comment> \<open>@{thm sum_list'_rel.intros}\<close>

text \<open>Compare this to the relation for @{const sum_list}:\<close>

thm sum_list_rel.intros
\<comment> \<open>@{thm sum_list_rel.intros}\<close>

text \<open>
  Except for the additional (unchanging) dictionary arguments, these relations are more or less
  equivalent to each other. There is an important difference, though: @{const sum_list_rel} has
  sort constraints, @{const sum_list'_rel} does not. (This will become important later on.)
\<close>

context
  notes [[show_sorts]]
begin

term sum_list_rel
\<comment> \<open>@{typ \<open>'a::{plus,zero} list \<Rightarrow> 'a::{plus,zero} list \<Rightarrow> bool\<close>}\<close>

term sum_list'_rel
\<comment> \<open>@{typ \<open>'a::type Groups_plus__dict \<times> 'a::type Groups_zero__dict \<times> 'a::type list \<Rightarrow> 'a::type Groups_plus__dict \<times> 'a::type Groups_zero__dict \<times> 'a::type list \<Rightarrow> bool\<close>}\<close>

end

text \<open>
  Let us know discuss the rough concept of the termination proof for @{const sum_list'}. The goal is
  to show that @{const sum_list'_rel} is well-founded. Usually, this is proved by specifying a
  \<^emph>\<open>measure function\<close> that
  \<^enum> maps the arguments to natural numbers
  \<^enum> decreases for each recursive call.
\<close>
text \<open>
  Here, however, we want to instead show that each recursive call in @{const sum_list'} has a
  corresponding recursive call in @{const sum_list}. In other words, we want to show that the
  existing proof of well-foundedness of @{const sum_list_rel} can be lifted to a proof of
  well-foundedness of @{const sum_list'_rel}. This is what the theorem
  @{thm [source=true] wfP_simulate_simple} states:

  @{thm [display=true] wfP_simulate_simple}

  Given any well-founded relation \<open>r\<close> and a function \<open>g\<close> that maps function arguments from \<open>r'\<close> to
  \<open>r\<close>, we can deduce that \<open>r'\<close> is also well-founded.

  For our example, we need to provide a function \<open>g\<close> of type
  @{typ \<open>'b Groups_plus__dict \<times> 'b Groups_zero__dict \<times> 'b list \<Rightarrow> 'a list\<close>}.
  Because the dictionary parameters are not changing, they can safely be dropped by \<open>g\<close>.
  However, because of the sort constraint in @{const sum_list_rel}, the term @{term "snd \<circ> snd"}
  is not a well-typed instantiation for \<open>g\<close>.

  Instead (this is where the heuristic comes in), we assume that the original function
  @{const sum_list} is parametric, i.e., termination does not depend on the elements of the list
  passed to it, but only on the structure of the list. Additionally, we assume that all involved
  type classes have at least one instantiation.

  With this in mind, we can use @{term "map (\<lambda>_. undefined) \<circ> snd \<circ> snd"} as \<open>g\<close>:
\<close>

thm wfP_simulate_simple[where
  r = sum_list_rel and
  r' = sum_list'_rel and
  g = "map (\<lambda>_. undefined) \<circ> snd \<circ> snd"]

text \<open>
  Finally, we can prove the termination of @{const sum_list'}.
\<close>

termination sum_list'
proof -
  have "wfP sum_list'_rel"
  proof (rule wfP_simulate_simple)
    \<comment> \<open>We first need to obtain the well-foundedness theorem for @{const sum_list_rel} from the ML
        guts of the @{theory_text function} package.\<close>
    show "wfP sum_list_rel"
      apply (rule accp_wfPI)
      apply (tactic \<open>resolve_tac @{context} [Function.get_info @{context} @{term sum_list} |> #totality |> the] 1\<close>)
      done

    define g :: "'b Groups_plus__dict \<times> 'b Groups_zero__dict \<times> 'b list \<Rightarrow> 'c::{plus,zero} list" where
      "g = map (\<lambda>_. undefined) \<circ> snd \<circ> snd"

    \<comment> \<open>Prove the simulation of @{const sum_list'_rel} by @{const sum_list_rel} by rule induction.\<close>
    show "sum_list_rel (g x) (g y)" if "sum_list'_rel x y" for x y
      using that
      proof (induction x y rule: sum_list'_rel.induct)
        case (1 d_plus d_zero x xs)
        show ?case
          \<comment> \<open>Unfold the constituent parts of @{term g}:\<close>
          apply (simp only: g_def comp_apply snd_conv list.map)
          \<comment> \<open>Use the corresponding introduction rule of @{const sum_list_rel} and hope for the best:\<close>
          apply (rule sum_list_rel.intros(1))
          done
      qed
  qed

  \<comment> \<open>This is the goal that the @{theory_text function} package expects.\<close>
  then show "\<forall>x. sum_list'_dom x"
    by (rule wfP_implies_dom)
qed

text \<open>This can be automated with a special tactic:\<close>

experiment
begin

termination sum_list'
  apply (tactic \<open>
    Transfer_Termination.termination_tac
      (Function.get_info @{context} @{term sum_list'})
      (Function.get_info @{context} @{term sum_list})
      @{context}
      1\<close>; fail)
  done

end

text \<open>
  A similar technique can be used for making functions defined in locales executable when, for some
  reason, the definition of a ``defs'' locale is not feasible.
\<close>

locale foo =
  fixes A :: "nat"
  assumes "A > 0"
begin

fun f where
"f 0 = A" |
"f (Suc n) = Suc (f n)"

\<comment> \<open>We carry out this proof in the locale for simplicity; a real implementation would probably
    have to set up a local theory properly.\<close>
lemma f_total: "wfP f_rel"
apply (rule accp_wfPI)
apply (tactic \<open>resolve_tac @{context} [Function.get_info @{context} @{term f} |> #totality |> the] 1\<close>)
done

end

\<comment> \<open>The dummy interpretation serves the same purpose as the assumption that class constraints have
    at least one instantiation.\<close>
interpretation dummy: foo 1 by standard simp

function f' where
"f' A 0 = A" |
"f' A (Suc n) = Suc (f' A n)"
by pat_completeness auto

termination f'
  apply (rule wfP_implies_dom)
  apply (rule wfP_simulate_simple[where g = "snd"])
   apply (rule dummy.f_total)
  subgoal for x y
    apply (induction x y rule: f'_rel.induct)
    subgoal
     apply (simp only: snd_conv)
     apply (rule dummy.f_rel.intros)
     done
    done
  done

text \<open>Automatic:\<close>

experiment
begin

termination f'
  apply (tactic \<open>
    Transfer_Termination.termination_tac
      (Function.get_info @{context} @{term f'})
      (Function.get_info @{context} @{term dummy.f})
      @{context}
      1\<close>; fail)
  done

end

end


section \<open>State for SM\<close>
theory SM_State
imports
  "HOL-Library.Word"
  "HOL-Library.Multiset"
  "Word_Lib.Typedef_Morphisms"
  SM_Syntax
begin

section \<open>Values\<close>
  text \<open>The primitive values are fixed-size signed integers\<close>
  type_synonym word_size = 32   \<comment> \<open>Word size\<close>
  type_synonym signed = "word_size Word.word"  \<comment> \<open>Signed integer\<close>

  text \<open>Currently, we only have signed integer values.
    This may change if we extend the language, and allow,
    i.e., channel pointers, pids or process references\<close>
  type_synonym val = signed  \<comment> \<open>Value type\<close>

section \<open>Configurations\<close>
  type_synonym valuation = "ident \<rightharpoonup> val"

  record local_state =
    variables :: valuation

  record global_state =
    variables :: valuation

  text \<open>The effect of actions is on focused states\<close>
  type_synonym focused_state = "local_state \<times> global_state"

section \<open>Utilities\<close>
  abbreviation "word_len \<equiv> LENGTH(word_size)"
  abbreviation "signeds \<equiv> sints (LENGTH(word_size))"

  definition min_signed :: int where "min_signed \<equiv> -(2^(word_len - 1))"
  definition max_signed :: int where "max_signed \<equiv> 2^(word_len - 1) - 1"

  definition signed_of_int :: "int \<Rightarrow> signed"
    where "signed_of_int i \<equiv> word_of_int i"

  definition int_of_signed :: "signed \<Rightarrow> int"
    where "int_of_signed i == sint i"

  lemma si_inv[simp]: "signed_of_int (int_of_signed i) = i"
    unfolding signed_of_int_def int_of_signed_def
    by simp

  lemma int_of_signed_in_range[simp]:
    "int_of_signed i \<ge> min_signed"
    "int_of_signed i \<le> max_signed"
    unfolding int_of_signed_def min_signed_def max_signed_def
    apply -
    apply (rule sint_ge)
    using sint_lt[of i]
    by simp

  lemma is_inv[simp]:
    "\<lbrakk> i\<ge>min_signed; i\<le>max_signed \<rbrakk> \<Longrightarrow> (int_of_signed (signed_of_int i)) = i"
    by (simp add: signed_take_bit_int_eq_self min_signed_def max_signed_def int_of_signed_def signed_of_int_def signed_of_int)

  primrec val_of_bool :: "bool \<Rightarrow> val" where
    "val_of_bool False = 0" | "val_of_bool True = 1"

  definition bool_of_val :: "val \<Rightarrow> bool" where
    "bool_of_val v \<equiv> v\<noteq>0"

  lemma bool_of_val_invs[simp]:
    "bool_of_val (val_of_bool b) = b"
    "val_of_bool (bool_of_val v) = (if v=0 then 0 else 1)"
    unfolding bool_of_val_def
    by (cases b) auto

end


section \<open>Matrix Exponential\<close>
theory Matrix_Exponential
imports
  "../ODE_Numerics"
begin

lemma field_differentiable_bound:\<comment> \<open>TODO: generalize @{thm field_differentiable_bound}\<close>
  fixes s :: "'a::real_normed_field set"
  assumes cvs: "convex s"
      and df:  "\<And>z. z \<in> s \<Longrightarrow> (f has_field_derivative f' z) (at z within s)"
      and dn:  "\<And>z. z \<in> s \<Longrightarrow> norm (f' z) \<le> B"
      and "x \<in> s"  "y \<in> s"
    shows "norm(f x - f y) \<le> B * norm(x - y)"
  apply (rule differentiable_bound [OF cvs])
  apply (rule ballI, erule df [unfolded has_field_derivative_def])
  apply (rule ballI, rule onorm_le, simp add: norm_mult mult_right_mono dn)
  apply fact
  apply fact
  done

lemma field_Taylor:\<comment> \<open>TODO: generalize @{thm complex_Taylor}\<close>
  assumes s: "convex s"
      and f: "\<And>i x. x \<in> s \<Longrightarrow> i \<le> n \<Longrightarrow> (f i has_field_derivative f (Suc i) x) (at x within s)"
      and B: "\<And>x. x \<in> s \<Longrightarrow> norm (f (Suc n) x) \<le> B"
      and w: "w \<in> s"
      and z: "z \<in> s"
    shows "norm(f 0 z - (\<Sum>i\<le>n. f i w * (z-w) ^ i / (fact i)))
          \<le> B * norm(z - w)^(Suc n) / fact n"
proof -
  have wzs: "closed_segment w z \<subseteq> s" using assms
    by (metis convex_contains_segment)
  { fix u
    assume "u \<in> closed_segment w z"
    then have "u \<in> s"
      by (metis wzs subsetD)
    have "(\<Sum>i\<le>n. f i u * (- of_nat i * (z-u)^(i - 1)) / (fact i) +
                      f (Suc i) u * (z-u)^i / (fact i)) =
              f (Suc n) u * (z-u) ^ n / (fact n)"
    proof (induction n)
      case 0 show ?case by simp
    next
      case (Suc n)
      have "(\<Sum>i\<le>Suc n. f i u * (- of_nat i * (z-u) ^ (i - 1)) / (fact i) +
                             f (Suc i) u * (z-u) ^ i / (fact i)) =
           f (Suc n) u * (z-u) ^ n / (fact n) +
           f (Suc (Suc n)) u * ((z-u) * (z-u) ^ n) / (fact (Suc n)) -
           f (Suc n) u * ((1 + of_nat n) * (z-u) ^ n) / (fact (Suc n))"
        using Suc by simp
      also have "... = f (Suc (Suc n)) u * (z-u) ^ Suc n / (fact (Suc n))"
      proof -
        have "(fact(Suc n)) *
             (f(Suc n) u *(z-u) ^ n / (fact n) +
               f(Suc(Suc n)) u *((z-u) *(z-u) ^ n) / (fact(Suc n)) -
               f(Suc n) u *((1 + of_nat n) *(z-u) ^ n) / (fact(Suc n))) =
            ((fact(Suc n)) *(f(Suc n) u *(z-u) ^ n)) / (fact n) +
            ((fact(Suc n)) *(f(Suc(Suc n)) u *((z-u) *(z-u) ^ n)) / (fact(Suc n))) -
            ((fact(Suc n)) *(f(Suc n) u *(of_nat(Suc n) *(z-u) ^ n))) / (fact(Suc n))"
          by (simp add: algebra_simps del: fact_Suc)
        also have "... = ((fact (Suc n)) * (f (Suc n) u * (z-u) ^ n)) / (fact n) +
                         (f (Suc (Suc n)) u * ((z-u) * (z-u) ^ n)) -
                         (f (Suc n) u * ((1 + of_nat n) * (z-u) ^ n))"
          by (simp del: fact_Suc)
        also have "... = (of_nat (Suc n) * (f (Suc n) u * (z-u) ^ n)) +
                         (f (Suc (Suc n)) u * ((z-u) * (z-u) ^ n)) -
                         (f (Suc n) u * ((1 + of_nat n) * (z-u) ^ n))"
          by (simp only: fact_Suc of_nat_mult ac_simps) simp
        also have "... = f (Suc (Suc n)) u * ((z-u) * (z-u) ^ n)"
          by (simp add: algebra_simps)
        finally show ?thesis
        by (simp add: mult_left_cancel [where c = "(fact (Suc n))", THEN iffD1] del: fact_Suc)
      qed
      finally show ?case .
    qed
    then have "((\<lambda>v. (\<Sum>i\<le>n. f i v * (z - v)^i / (fact i)))
                has_field_derivative f (Suc n) u * (z-u) ^ n / (fact n))
               (at u within s)"
      apply (intro derivative_eq_intros)
      apply (blast intro: assms \<open>u \<in> s\<close>)
      apply (rule refl)+
      apply (auto simp: field_simps)
      done
  } note sum_deriv = this
  { fix u
    assume u: "u \<in> closed_segment w z"
    then have us: "u \<in> s"
      by (metis wzs subsetD)
    have "norm (f (Suc n) u) * norm (z - u) ^ n \<le> norm (f (Suc n) u) * norm (u - z) ^ n"
      by (metis norm_minus_commute order_refl)
    also have "... \<le> norm (f (Suc n) u) * norm (z - w) ^ n"
      by (metis mult_left_mono norm_ge_zero power_mono segment_bound [OF u])
    also have "... \<le> B * norm (z - w) ^ n"
      by (metis norm_ge_zero zero_le_power mult_right_mono  B [OF us])
    finally have "norm (f (Suc n) u) * norm (z - u) ^ n \<le> B * norm (z - w) ^ n" .
  } note cmod_bound = this
  have "(\<Sum>i\<le>n. f i z * (z - z) ^ i / (fact i)) = (\<Sum>i\<le>n. (f i z / (fact i)) * 0 ^ i)"
    by simp
  also have "\<dots> = f 0 z / (fact 0)"
    by (subst sum_zero_power) simp
  finally have "norm (f 0 z - (\<Sum>i\<le>n. f i w * (z - w) ^ i / (fact i)))
                \<le> norm ((\<Sum>i\<le>n. f i w * (z - w) ^ i / (fact i)) -
                        (\<Sum>i\<le>n. f i z * (z - z) ^ i / (fact i)))"
    by (simp add: norm_minus_commute)
  also have "... \<le> B * norm (z - w) ^ n / (fact n) * norm (w - z)"
    apply (rule field_differentiable_bound
      [where f' = "\<lambda>w. f (Suc n) w * (z - w)^n / (fact n)"
         and s = "closed_segment w z", OF convex_closed_segment])
    apply (auto simp: ends_in_segment DERIV_subset [OF sum_deriv wzs]
                  norm_divide norm_mult norm_power divide_le_cancel cmod_bound)
    done
  also have "...  \<le> B * norm (z - w) ^ Suc n / (fact n)"
    by (simp add: algebra_simps norm_minus_commute)
  finally show ?thesis .
qed

lemma Taylor_exp:\<comment> \<open>TODO: generalize @{thm Taylor_exp}\<close>
  fixes z::"'a::{banach,real_normed_field}"
  shows "norm (exp z - (\<Sum>i\<le>n. z ^ i / fact i)) \<le> exp (norm z) * (norm z * norm z ^ n) / fact n"
proof (rule field_Taylor[of _ n "\<lambda>k. exp" "exp (norm z)" 0 z, simplified])
  show "convex (closed_segment 0 z)"
    by (rule convex_closed_segment [of 0 z])
next
  fix k x
  assume "x \<in> closed_segment 0 z" "k \<le> n"
  show "(exp has_field_derivative exp x) (at x within closed_segment 0 z)"
    using DERIV_exp DERIV_subset by blast
next
  fix x
  assume x: "x \<in> closed_segment 0 z"
  have "norm (exp x) \<le> exp (norm x)"
    by (rule norm_exp)
  also have "norm x \<le> norm z"
    using x by (auto simp: closed_segment_def intro!: mult_left_le_one_le)
  finally show "norm (exp x) \<le> exp (norm z)"
    by simp
next
  show "0 \<in> closed_segment 0 z"
    by (auto simp: closed_segment_def)
next
  show "z \<in> closed_segment 0 z"
    apply (simp add: closed_segment_def scaleR_conv_of_real)
    using of_real_1 zero_le_one by blast
qed

lemma norm_blinop_componentwise:
  fixes A::"'a::euclidean_space blinop"
  shows "norm A \<le> (\<Sum>i\<in>Basis. norm (A i))"
  apply transfer
  including blinfun.lifting
  apply transfer
  apply (rule onorm_componentwise, assumption)
  done

end


section\<open>Finite Sets\<close>
text\<open>Here we define the operations on the \texttt{fset} datatype in terms of lists rather than sets.
This allows the Scala implementation to skip a case match each time, which makes for cleaner and
slightly faster code.\<close>

theory Code_Target_FSet
  imports "Extended_Finite_State_Machines.FSet_Utils"
begin

code_datatype fset_of_list

declare FSet.fset_of_list.rep_eq [code]

lemma fprod_code [code]:
  "fprod (fset_of_list xs) (fset_of_list ys) = fset_of_list (remdups [(x, y). x \<leftarrow> xs, y \<leftarrow> ys])"
  apply (simp add: fprod_def fset_of_list_def fset_both_sides Abs_fset_inverse)
  by auto

lemma fminus_fset_filter [code]:
  "fset_of_list A -  xs = fset_of_list (remdups (filter (\<lambda>x. x |\<notin>| xs) A))"
  by auto

lemma sup_fset_fold [code]:
  "(fset_of_list f1) |\<union>| (fset_of_list f2) = fset_of_list (remdups (f1@f2))"
  by simp

lemma bot_fset [code]: "{||} = fset_of_list []"
  by simp

lemma finsert [code]:
  "finsert a (fset_of_list as) = fset_of_list (List.insert a as)"
  by (simp add: List.insert_def finsert_absorb fset_of_list_elem)

lemma ffilter_filter [code]:
  "ffilter f (fset_of_list as) = fset_of_list (List.filter f (remdups as))"
  by simp

lemma fimage_map [code]:
  "fimage f (fset_of_list as) = fset_of_list (List.map f (remdups as))"
  by simp

lemma ffUnion_fold [code]:
  "ffUnion (fset_of_list as) = fold (|\<union>|) as {||}"
  by (simp add: fold_union_ffUnion)

lemma fmember [code]: "a |\<in>| (fset_of_list as) = List.member as a"
  by (simp add: fset_of_list_elem member_def)

lemma fthe_elem [code]: "fthe_elem (fset_of_list [x]) = x"
  by simp

lemma size [code]: "size (fset_of_list as) = length (remdups as)"
proof(induct as)
  case Nil
  then show ?case
    by simp
next
  case (Cons a as)
  then show ?case
    by (simp add: fset_of_list.rep_eq insert_absorb)
qed

lemma fMax_fold [code]: "fMax (fset_of_list (a#as)) = fold max as a"
  by (metis Max.set_eq_fold fMax.F.rep_eq fset_of_list.rep_eq)

lemma fremove_code [code]:
  "fremove a (fset_of_list A) = fset_of_list (filter (\<lambda>x. x \<noteq> a) A)"
  apply (simp add: fremove_def minus_fset_def ffilter_def fset_both_sides Abs_fset_inverse fset_of_list.rep_eq)
  by auto

lemma fsubseteq [code]:
  "(fset_of_list l) |\<subseteq>| A = List.list_all (\<lambda>x. x |\<in>| A) l"
  by (induct l, auto)

lemma fsum_fold [code]: "fSum (fset_of_list l) = fold (+) (remdups l) 0"
proof(induct l)
case Nil
then show ?case
  by (simp add: fsum.F.rep_eq fSum_def)
next
  case (Cons a l)
  then show ?case
    apply simp
    apply standard
     apply (simp add: finsert_absorb fset_of_list_elem)
    by (simp add: add.commute fold_plus_sum_list_rev fset_of_list.rep_eq fsum.F.rep_eq fSum_def)
qed

lemma code_fset_eq [code]:
  "HOL.equal X (fset_of_list Y) \<longleftrightarrow> size X = length (remdups Y) \<and> (\<forall>x |\<in>| X. List.member Y x)"
  apply (simp only: HOL.equal_class.equal_eq fset_eq_alt)
  apply (simp only: size)
  using fmember by fastforce

lemma code_fsubset [code]:
  "s |\<subset>| s' = (s |\<subseteq>| s' \<and> size s < size s')"
  apply standard
   apply (simp only: size_fsubset)
  by auto

lemma code_fset [code]: "fset (fset_of_list l) = fold insert l {}"
  using fset_of_list.rep_eq union_set_fold by fastforce

lemma code_fBall [code]: "fBall (fset_of_list l) f = list_all f l"
  by (simp add: Ball_set fBall.rep_eq fset_of_list.rep_eq)

lemma code_fBex [code]: "fBex (fset_of_list l) f = list_ex f l"
  by (meson Bex_set fBexE fset_of_list_elem rev_fBexI)

definition "nativeSort = sort"
code_printing constant nativeSort \<rightharpoonup> (Scala) "_.sortWith((Orderings.less))"

lemma [code]: "sorted_list_of_set (set l) = nativeSort (remdups l)"
  by (simp add: nativeSort_def sorted_list_of_set_sort_remdups)

lemma [code]: "fMin (fset_of_list (h#t)) = hd (nativeSort (h#t))"
  by (metis fMin_Min hd_sort_Min list.distinct(1) nativeSort_def)

lemma sorted_Max_Cons:
  "l \<noteq> [] \<Longrightarrow>
   sorted (a#l) \<Longrightarrow>
   Max (set (a#l)) = Max (set l)"
  using eq_iff by fastforce

lemma sorted_Max:
  "l \<noteq> [] \<Longrightarrow>
   sorted l \<Longrightarrow>
   Max (set l) = hd (rev l)"
proof(induct l)
  case Nil
  then show ?case by simp
next
  case (Cons a l)
  then show ?case
    by (metis sorted_Max_Cons Max_singleton hd_rev last.simps list.set(1) list.simps(15) sorted_simps(2))
qed

lemma [code]: "fMax (fset_of_list (h#t)) = last (nativeSort (h#t))"
  by (metis Max.set_eq_fold fMax_fold hd_rev list.simps(3) nativeSort_def set_empty2 set_sort sorted_Max sorted_sort)

definition "list_max l = fold max l"
code_printing constant list_max \<rightharpoonup> (Scala) "_.par.fold((_))(Orderings.max)"

lemma [code]: "fMax (fset_of_list (h#t)) = list_max t h"
  by (metis fMax_fold list_max_def)

definition "list_min l = fold min l"
code_printing constant list_min \<rightharpoonup> (Scala) "_.par.fold((_))(Orderings.min)"

lemma [code]: "fMin (fset_of_list (h#t)) = list_min t h"
  by (metis fMin_fold list_min_def)

lemma fis_singleton_code [code]: "fis_singleton s = (size s = 1)"
  apply (simp add: fis_singleton_def is_singleton_def)
  by (simp add: card_Suc_eq)

end


(*  Title:      HOL/HOLCF/Compact_Basis.thy
    Author:     Brian Huffman
*)

section {* A compact basis for powerdomains *}

theory Compact_Basis
imports Universal
begin

default_sort bifinite

subsection {* A compact basis for powerdomains *}

definition "pd_basis = {S::'a compact_basis set. finite S \<and> S \<noteq> {}}"

typedef 'a pd_basis = "pd_basis :: 'a compact_basis set set"
  unfolding pd_basis_def
  apply (rule_tac x="{arbitrary}" in exI)
  apply simp
  done

lemma finite_Rep_pd_basis [simp]: "finite (Rep_pd_basis u)"
by (insert Rep_pd_basis [of u, unfolded pd_basis_def]) simp

lemma Rep_pd_basis_nonempty [simp]: "Rep_pd_basis u \<noteq> {}"
by (insert Rep_pd_basis [of u, unfolded pd_basis_def]) simp

text {* The powerdomain basis type is countable. *}

lemma pd_basis_countable: "\<exists>f::'a pd_basis \<Rightarrow> nat. inj f"
proof -
  obtain g :: "'a compact_basis \<Rightarrow> nat" where "inj g"
    using compact_basis.countable ..
  hence image_g_eq: "\<And>A B. g ` A = g ` B \<longleftrightarrow> A = B"
    by (rule inj_image_eq_iff)
  have "inj (\<lambda>t. set_encode (g ` Rep_pd_basis t))"
    by (simp add: inj_on_def set_encode_eq image_g_eq Rep_pd_basis_inject)
  thus ?thesis by - (rule exI)
  (* FIXME: why doesn't ".." or "by (rule exI)" work? *)
qed

subsection {* Unit and plus constructors *}

definition
  PDUnit :: "'a compact_basis \<Rightarrow> 'a pd_basis" where
  "PDUnit = (\<lambda>x. Abs_pd_basis {x})"

definition
  PDPlus :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> 'a pd_basis" where
  "PDPlus t u = Abs_pd_basis (Rep_pd_basis t \<union> Rep_pd_basis u)"

lemma Rep_PDUnit:
  "Rep_pd_basis (PDUnit x) = {x}"
unfolding PDUnit_def by (rule Abs_pd_basis_inverse) (simp add: pd_basis_def)

lemma Rep_PDPlus:
  "Rep_pd_basis (PDPlus u v) = Rep_pd_basis u \<union> Rep_pd_basis v"
unfolding PDPlus_def by (rule Abs_pd_basis_inverse) (simp add: pd_basis_def)

lemma PDUnit_inject [simp]: "(PDUnit a = PDUnit b) = (a = b)"
unfolding Rep_pd_basis_inject [symmetric] Rep_PDUnit by simp

lemma PDPlus_assoc: "PDPlus (PDPlus t u) v = PDPlus t (PDPlus u v)"
unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_assoc)

lemma PDPlus_commute: "PDPlus t u = PDPlus u t"
unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_commute)

lemma PDPlus_absorb: "PDPlus t t = t"
unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_absorb)

lemma pd_basis_induct1:
  assumes PDUnit: "\<And>a. P (PDUnit a)"
  assumes PDPlus: "\<And>a t. P t \<Longrightarrow> P (PDPlus (PDUnit a) t)"
  shows "P x"
apply (induct x, unfold pd_basis_def, clarify)
apply (erule (1) finite_ne_induct)
apply (cut_tac a=x in PDUnit)
apply (simp add: PDUnit_def)
apply (drule_tac a=x in PDPlus)
apply (simp add: PDUnit_def PDPlus_def
  Abs_pd_basis_inverse [unfolded pd_basis_def])
done

lemma pd_basis_induct:
  assumes PDUnit: "\<And>a. P (PDUnit a)"
  assumes PDPlus: "\<And>t u. \<lbrakk>P t; P u\<rbrakk> \<Longrightarrow> P (PDPlus t u)"
  shows "P x"
apply (induct x rule: pd_basis_induct1)
apply (rule PDUnit, erule PDPlus [OF PDUnit])
done

subsection {* Fold operator *}

definition
  fold_pd ::
    "('a compact_basis \<Rightarrow> 'b::type) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a pd_basis \<Rightarrow> 'b"
  where "fold_pd g f t = semilattice_set.F f (g ` Rep_pd_basis t)"

lemma fold_pd_PDUnit:
  assumes "semilattice f"
  shows "fold_pd g f (PDUnit x) = g x"
proof -
  from assms interpret semilattice_set f by (rule semilattice_set.intro)
  show ?thesis by (simp add: fold_pd_def Rep_PDUnit)
qed

lemma fold_pd_PDPlus:
  assumes "semilattice f"
  shows "fold_pd g f (PDPlus t u) = f (fold_pd g f t) (fold_pd g f u)"
proof -
  from assms interpret semilattice_set f by (rule semilattice_set.intro)
  show ?thesis by (simp add: image_Un fold_pd_def Rep_PDPlus union)
qed

end


theory Mod_type
  imports
    "HOL-Library.Numeral_Type"
    Enum_mod
begin find_theorems "CARD (_)"

class class_mod_type = zero + one + plus + times + uminus + minus + ord + enum +
  fixes Rep :: "'a \<Rightarrow> int"
  and Abs :: "int \<Rightarrow> 'a"
  assumes type: "type_definition Rep Abs {0..< int CARD('a)}"
  and size1: "1 < CARD('a)"
  and zero_def: "0 = Abs 0"
  and one_def:  "1 = Abs 1"
  and add_def:  "x + y = Abs ((Rep x + Rep y) mod int CARD('a))"
  and mult_def: "x * y = Abs ((Rep x * Rep y) mod int CARD('a))"
  and diff_def: "x - y = Abs ((Rep x - Rep y) mod int CARD('a))"
  and minus_def: "- x = Abs ((- Rep x) mod int CARD('a))"
  and less_def: "x < y = (Rep x < Rep y)"
  and less_eq_def: "x \<le> y = (Rep x \<le> Rep y)"
begin

lemma Rep_in: "Rep x \<in> {0::int..<int CARD('a)}"
  by (meson local.type type_definition.Rep)

lemma Abs_Rep_inverse: "Abs (Rep x) = x"
  by (rule type_definition.Rep_inverse [of _ _ "{0::int..<int CARD('a)}"])
   (rule local.type)

lemma Rep_Abs_inverse: assumes y: "y \<in> {0::int..<int CARD('a)}"
  shows "Rep (Abs y) = y"
  by (rule type_definition.Abs_inverse [of Rep Abs "{0::int..<int CARD('a)}"])
   (rule local.type, rule y)

lemmas definitions =
  zero_def one_def add_def mult_def minus_def diff_def

lemma Rep_less_n: "Rep x < int CARD ('a)"
  by (rule type_definition.Rep [OF type, simplified, THEN conjunct2])

lemma Rep_le_n: "Rep x \<le> int CARD ('a)"
  by (rule Rep_less_n [THEN order_less_imp_le])

lemma Rep_inject_sym: "x = y \<longleftrightarrow> Rep x = Rep y"
  by (rule type_definition.Rep_inject [OF type, symmetric])

lemma Rep_inverse: "Abs (Rep x) = x"
  by (rule type_definition.Rep_inverse [OF type])

lemma Abs_inverse: "m \<in> {0..<int CARD ('a)} \<Longrightarrow> Rep (Abs m) = m"
  by (rule type_definition.Abs_inverse [OF type])

lemma Rep_Abs_mod: "Rep (Abs (m mod int CARD ('a))) = m mod int CARD ('a)"
  by (simp add: Abs_inverse pos_mod_conj [OF size0])

lemma Rep_Abs_0: "Rep (Abs 0) = 0"
  using Abs_inverse [of 0] using size0 by simp

lemma Rep_0: "Rep 0 = 0"
  by (simp add: zero_def Rep_Abs_0)

lemma Rep_Abs_1: "Rep (Abs 1) = 1"
  using Abs_inverse [of 1] using size1 by simp

lemma Rep_1: "Rep 1 = 1"
  by (simp add: one_def Rep_Abs_1)

lemma Rep_mod: "Rep x mod (int CARD('a)) = Rep x"
  by (meson Rep_in mod_pos_pos_trivial ord_class.atLeastLessThan_iff)

lemmas Rep_simps =
  Rep_inject_sym Rep_inverse Rep_Abs_mod Rep_mod Rep_Abs_0 Rep_Abs_1

lemma bij_betw_univ_range: "bij_betw Rep UNIV {0..< int CARD('a)}"
  unfolding bij_betw_def unfolding inj_def
  by (meson Rep_inject_sym type type_definition.Rep_range)

lemma inj_on_Abs: "inj_on Abs {0..<int CARD('a)}"
  unfolding inj_on_def
  by (metis Abs_inverse)

lemma range_Abs: "range Abs = UNIV"
  unfolding surj_def
  by (metis Rep_inverse)

lemma bij_betw_range_univ: "bij_betw Abs {0..<int CARD('a)} UNIV"
  unfolding bij_betw_def using inj_on_Abs range_Abs
  by (metis local.type type_definition.univ)

definition to_int :: "'a => int"
  where "to_int = Rep"

definition from_int :: "int => 'a"
  where "from_int x = Abs (x mod int CARD ('a))"

lemma inj_to_int: "inj to_int"
  by (simp add: Rep_inject_sym inj_on_def to_int_def)

lemma range_to_int: "range (to_int::'a \<Rightarrow> int) = {0..<int CARD('a)}"
  by (simp add: bij_betw_imp_surj_on bij_betw_univ_range to_int_def)

lemma bij_betw_range_univ_to_int: "bij_betw to_int UNIV {0 ..<int CARD('a)}"
  unfolding bij_betw_def
  using inj_to_int range_to_int by blast

lemma inj_on_from_int: "inj_on from_int {0..<int CARD('a)}"
  by (metis (mono_tags, lifting) Rep_Abs_inverse Rep_mod from_int_def inj_onI)

lemma range_from_int: "range (from_int::int \<Rightarrow> 'a) = (UNIV::'a set)"
proof (unfold surj_def, rule)
  fix y::'a
  show "\<exists>x::int. y = from_int x"
    apply (rule exI [of _ "Rep y"])
    apply (unfold from_int_def)
    using Rep_inverse Rep_mod by presburger
qed

lemma bij_betw_range_univ_from_int: "bij_betw from_int {0..<int CARD('a)} UNIV"
  unfolding bij_betw_def
  using inj_on_from_int range_from_int
  by (metis Abs_inverse Rep_mod from_int_def image_cong local.type type_definition.univ)

lemma finite_univ: "finite (UNIV::'a set)"
  using Finite_Set.bij_betw_finite [OF bij_betw_univ_range]
  using Set_Interval.finite_atLeastZeroLessThan_int [of "int CARD('a)"] by blast

subclass finite
  by (intro_classes) (rule finite_univ)

subclass linorder
  apply (unfold class.linorder_def class.linorder_axioms_def
    class.order_def class.order_axioms_def class.preorder_def less_def less_eq_def,
    intro conjI)
  apply auto [1]
  apply simp
  apply simp
   apply (simp add: Rep_inject_sym)
  by auto

end

end


(*  Title:      HOL/MicroJava/DFA/SemilatAlg.thy
    Author:     Gerwin Klein
    Copyright   2002 Technische Universitaet Muenchen
*)

section \<open>More on Semilattices\<close>

theory SemilatAlg
imports Typing_Framework Product
begin

definition lesubstep_type :: "(nat \<times> 's) list \<Rightarrow> 's ord \<Rightarrow> (nat \<times> 's) list \<Rightarrow> bool"
                    ("(_ /\<le>|_| _)" [50, 0, 51] 50) where
  "x \<le>|r| y \<equiv> \<forall>(p,s) \<in> set x. \<exists>s'. (p,s') \<in> set y \<and> s <=_r s'"

primrec plusplussub :: "'a list \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" ("(_ /++'__ _)" [65, 1000, 66] 65) where
  "[] ++_f y = y"
| "(x#xs) ++_f y = xs ++_f (x +_f y)"

definition bounded :: "'s step_type \<Rightarrow> nat \<Rightarrow> bool" where
"bounded step n == \<forall>p<n. \<forall>s. \<forall>(q,t)\<in>set(step p s). q<n"

definition pres_type :: "'s step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool" where
"pres_type step n A == \<forall>s\<in>A. \<forall>p<n. \<forall>(q,s')\<in>set (step p s). s' \<in> A"

definition mono :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool" where
"mono r step n A ==
 \<forall>s p t. s \<in> A \<and> p < n \<and> s <=_r t \<longrightarrow> step p s \<le>|r| step p t"

lemma pres_typeD:
  "\<lbrakk> pres_type step n A; s\<in>A; p<n; (q,s')\<in>set (step p s) \<rbrakk> \<Longrightarrow> s' \<in> A"
  by (unfold pres_type_def, blast)

lemma monoD:
  "\<lbrakk> mono r step n A; p < n; s\<in>A; s <=_r t \<rbrakk> \<Longrightarrow> step p s \<le>|r| step p t"
  by (unfold mono_def, blast)

lemma boundedD:
  "\<lbrakk> bounded step n; p < n; (q,t) \<in> set (step p xs) \<rbrakk> \<Longrightarrow> q < n"
  by (unfold bounded_def, blast)

lemma lesubstep_type_refl [simp, intro]:
  "(\<And>x. x <=_r x) \<Longrightarrow> x \<le>|r| x"
  by (unfold lesubstep_type_def) auto

lemma lesub_step_typeD:
  "a \<le>|r| b \<Longrightarrow> (x,y) \<in> set a \<Longrightarrow> \<exists>y'. (x, y') \<in> set b \<and> y <=_r y'"
  by (unfold lesubstep_type_def) blast

lemma list_update_le_listI [rule_format]:
  "set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> xs <=[r] ys \<longrightarrow> p < size xs \<longrightarrow>
   x <=_r ys!p \<longrightarrow> semilat(A,r,f) \<longrightarrow> x\<in>A \<longrightarrow>
   xs[p := x +_f xs!p] <=[r] ys"
  apply (unfold Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  done

lemma plusplus_closed: assumes "semilat (A, r, f)" shows
  "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> x ++_f y \<in> A" (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P" proof (induct x)
    show "\<And>y. y \<in> A \<Longrightarrow> [] ++_f y \<in> A" by simp
    fix y x xs
    assume y: "y \<in> A" and xs: "set (x#xs) \<subseteq> A"
    assume IH: "\<And>y. \<lbrakk> set xs \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> xs ++_f y \<in> A"
    from xs obtain x: "x \<in> A" and xs': "set xs \<subseteq> A" by simp
    from x y have "(x +_f y) \<in> A" ..
    with xs' have "xs ++_f (x +_f y) \<in> A" by (rule IH)
    thus "(x#xs) ++_f y \<in> A" by simp
  qed
qed

lemma (in Semilat) pp_ub2:
 "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y <=_r x ++_f y"
proof (induct x)
  from semilat show "\<And>y. y <=_r [] ++_f y" by simp

  fix y a l
  assume y:  "y \<in> A"
  assume "set (a#l) \<subseteq> A"
  then obtain a: "a \<in> A" and x: "set l \<subseteq> A" by simp
  assume "\<And>y. \<lbrakk>set l \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y <=_r l ++_f y"
  hence IH: "\<And>y. y \<in> A \<Longrightarrow> y <=_r l ++_f y" using x .

  from a y have "y <=_r a +_f y" ..
  also from a y have "a +_f y \<in> A" ..
  hence "(a +_f y) <=_r l ++_f (a +_f y)" by (rule IH)
  finally have "y <=_r l ++_f (a +_f y)" .
  thus "y <=_r (a#l) ++_f y" by simp
qed

  fix y s ls
  assume "set (s#ls) \<subseteq> A"
  then obtain s: "s \<in> A" and ls: "set ls \<subseteq> A" by simp
  assume y: "y \<in> A"

  assume
    "\<And>y. \<lbrakk>set ls \<subseteq> A; y \<in> A; x \<in> set ls\<rbrakk> \<Longrightarrow> x <=_r ls ++_f y"
  hence IH: "\<And>y. x \<in> set ls \<Longrightarrow> y \<in> A \<Longrightarrow> x <=_r ls ++_f y" using ls .

  assume "x \<in> set (s#ls)"
  then obtain xls: "x = s \<or> x \<in> set ls" by simp
  moreover {
    assume xs: "x = s"
    from s y have "s <=_r s +_f y" ..
    also from s y have "s +_f y \<in> A" ..
    with ls have "(s +_f y) <=_r ls ++_f (s +_f y)" by (rule pp_ub2)
    finally have "s <=_r ls ++_f (s +_f y)" .
    with xs have "x <=_r ls ++_f (s +_f y)" by simp
  }
  moreover {
    assume "x \<in> set ls"
    hence "\<And>y. y \<in> A \<Longrightarrow> x <=_r ls ++_f y" by (rule IH)
    moreover from s y have "s +_f y \<in> A" ..
    ultimately have "x <=_r ls ++_f (s +_f y)" .
  }
  ultimately
  have "x <=_r ls ++_f (s +_f y)" by blast
  thus "x <=_r (s#ls) ++_f y" by simp
qed

lemma (in Semilat) pp_lub:
  assumes z: "z \<in> A"
  shows
  "\<And>y. y \<in> A \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> \<forall>x \<in> set xs. x <=_r z \<Longrightarrow> y <=_r z \<Longrightarrow> xs ++_f y <=_r z"
proof (induct xs)
  fix y assume "y <=_r z" thus "[] ++_f y <=_r z" by simp
next
  fix y l ls assume y: "y \<in> A" and "set (l#ls) \<subseteq> A"
  then obtain l: "l \<in> A" and ls: "set ls \<subseteq> A" by auto
  assume "\<forall>x \<in> set (l#ls). x <=_r z"
  then obtain lz: "l <=_r z" and lsz: "\<forall>x \<in> set ls. x <=_r z" by auto
  assume "y <=_r z" with lz have "l +_f y <=_r z" using l y z ..
  moreover
  from l y have "l +_f y \<in> A" ..
  moreover
  assume "\<And>y. y \<in> A \<Longrightarrow> set ls \<subseteq> A \<Longrightarrow> \<forall>x \<in> set ls. x <=_r z \<Longrightarrow> y <=_r z
          \<Longrightarrow> ls ++_f y <=_r z"
  ultimately
  have "ls ++_f (l +_f y) <=_r z" using ls lsz by -
  thus "(l#ls) ++_f y <=_r z" by simp
qed

lemma ub1':
  assumes "semilat (A, r, f)"
  shows "\<lbrakk>\<forall>(p,s) \<in> set S. s \<in> A; y \<in> A; (a,b) \<in> set S\<rbrakk>
  \<Longrightarrow> b <=_r map snd [(p', t')\<leftarrow>S. p' = a] ++_f y"
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)

  let "b <=_r ?map ++_f y" = ?thesis

  assume "y \<in> A"
  moreover
  assume "\<forall>(p,s) \<in> set S. s \<in> A"
  hence "set ?map \<subseteq> A" by auto
  moreover
  assume "(a,b) \<in> set S"
  hence "b \<in> set ?map" by (induct S, auto)
  ultimately
  show ?thesis by - (rule pp_ub1)
qed

lemma plusplus_empty:
  "\<forall>s'. (q, s') \<in> set S \<longrightarrow> s' +_f ss ! q = ss ! q \<Longrightarrow>
   (map snd [(p', t') \<leftarrow> S. p' = q] ++_f ss ! q) = ss ! q"
  by (induct S) auto

end


section "Equivalence of denotational and type system views"

theory EquivDenotInterTypes
  imports InterTypeSystem DeclSemAsDenot DenotLam5
begin

fun V :: "ty \<Rightarrow> val" and Vf :: "funty \<Rightarrow> (val \<times> val) list" where
  "V (TNat n) = VNat n" |
  "V (TFun f) = VFun (Vf f)" |
  "Vf (A \<rightarrow> B) = [(V A, V B)]" |
  "Vf (A \<sqinter> B) = Vf A @ Vf B" |
  "Vf \<top> = []"

fun Venv :: "tyenv \<Rightarrow> env" where
  "Venv [] = []" |
  "Venv ((x,A)#\<Gamma>) = (x,V A)#Venv \<Gamma>"

function T :: "val \<Rightarrow> ty" and Tf :: "(val \<times> val) list \<Rightarrow> funty" where
  "T (VNat n) = TNat n" |
  "T (VFun t) = TFun (Tf t)" |
  "Tf [] = \<top>" |
  "Tf ((v1,v2)#t) = (T v1 \<rightarrow> T v2) \<sqinter> Tf t"
  by pat_completeness auto
termination T by size_change

fun Tenv :: "env \<Rightarrow> tyenv" where
  "Tenv [] = []" |
  "Tenv ((x,v)#\<rho>) = (x,T v)#Tenv \<rho>"

lemma sub_inter_left1: "A <:: C \<Longrightarrow> A \<sqinter> B <:: C"
  apply (subgoal_tac "A \<sqinter> B <:: A")
   apply (rule sub_trans) apply assumption apply assumption
  apply blast
  done

lemma sub_inter_left2: "B <:: C \<Longrightarrow> A \<sqinter> B <:: C"
  apply (subgoal_tac "A \<sqinter> B <:: B")
   apply (rule sub_trans) apply assumption apply assumption
  apply blast
  done

lemma vf_nil[simp]: "Vf (Tf []) = []" by simp

lemma vf_cons[simp]: "Vf (Tf ((v,v')#t)) = (V (T v), V (T v'))#(Vf (Tf t))" by simp

proposition vt_id: shows "V (T v) = v" and "Vf (Tf t) = t"
  by (induction rule: T_Tf.induct) force+

lemma lookup_tenv:
  "lookup \<rho> x = Some v \<Longrightarrow> lookup (Tenv \<rho>) x = Some (T v)"
  by (induction \<rho> arbitrary: x v) force+

proposition table_mem_sub:
  "(v, v') \<in> set t \<Longrightarrow> Tf t <:: (T v) \<rightarrow> (T v')"
proof (induction t arbitrary: v v')
  case Nil
  then show ?case by auto
next
  case (Cons p t)
  show ?case
  proof (cases p)
    case (Pair v1 v2)
    with Cons show ?thesis
      apply simp
      apply (erule disjE)
       apply force
      apply (subgoal_tac "Tf t <:: T v \<rightarrow> T v'") prefer 2 apply blast
      apply (rule sub_inter_left2) apply assumption done
  qed
qed

lemma Tf_top: "Tf t <:: \<top>"
proof (induction t)
  case Nil
  then show ?case by auto
next
  case (Cons p t)
  with sub_inter_left2 show ?case by (cases p) auto
qed

lemma le_sub_flip_aux:
  "\<forall> v v' t t'. n = val_size v + val_size v' + fun_size t + fun_size t' \<longrightarrow>
   (v \<sqsubseteq> v' \<longrightarrow> T v' <: T v) \<and> (t \<lesssim> t' \<longrightarrow> Tf t' <:: Tf t)"
proof (induction n rule: nat_less_induct)
  case (1 n)
  show ?case apply clarify apply (rule conjI) apply clarify prefer 2 apply clarify
     prefer 2
  proof -
    fix v::val and v' t t' assume n: "n = val_size v + val_size v' + fun_size t + fun_size t'"
      and v_vp: "v \<sqsubseteq> v'"
    show "T v' <: T v"
    proof (cases v)
      case (VNat n1)
      from VNat v_vp have vp: "v' = VNat n1" by auto
      from VNat vp show ?thesis apply simp using sub_refl by blast
    next
      case (VFun t1)
      from VFun v_vp obtain t2 where vp: "v' = VFun t2" and t1_t2: "t1 \<lesssim> t2" by auto
      let ?m = "val_size (VNat 0) + val_size (VNat 0) + fun_size t1 + fun_size t2"
      from 1 t1_t2 n VFun vp have t2_t1: "Tf t2 <:: Tf t1"
        apply simp
        apply (erule_tac x="?m" in allE)
        apply (erule impE) apply force apply simp apply (erule_tac x="VNat 0" in allE)
        apply (erule_tac x="VNat 0" in allE)
        apply (erule_tac x="t1" in allE)
        apply (erule_tac x="t2" in allE) apply auto done
      from t2_t1 VFun vp show ?thesis by auto
    qed
  next
    fix v v' t t' assume n: "n = val_size v + val_size v' + fun_size t + fun_size t'"
      and t_tp: "t \<lesssim> t'"
    show "Tf t' <:: Tf t"
    proof (cases t)
      case Nil
      from Nil have "Tf t = \<top>" by simp
      then show ?thesis using Tf_top by auto
    next
      case (Cons a t1)
      show ?thesis
      proof (cases a)
        case (Pair v1 v2)
        from Cons Pair show ?thesis apply simp
        proof
          from Cons Pair have v12: "(v1,v2) \<in> set t" by auto
          from t_tp v12 obtain v3 v4 where v34: "(v3,v4) \<in> set t'" and
            v13: "v1 \<sqsubseteq> v3" and v31: "v3 \<sqsubseteq> v1" and v24: "v2 \<sqsubseteq> v4" and v42: "v4 \<sqsubseteq> v2" by blast
          have Tv3_Tv1: "T v3 \<approx> T v1"
          proof -
            let ?m = "val_size v1 + val_size v3"
            from v12 have sv1: "val_size v1 < fun_size t" using val_size_mem_l by auto
            from v34 have sv3: "val_size v3 < fun_size t'" using val_size_mem_l by auto
            from 1 v13 n sv1 sv3 have Tv31: "T v3 <: T v1"
              apply (erule_tac x="?m" in allE) apply (erule impE) apply force
              apply (erule_tac x=v1 in allE) apply (erule_tac x=v3 in allE)
              apply (erule_tac x="[]" in allE)apply (erule_tac x="[]" in allE)
              apply (erule impE) defer apply blast apply simp
              done
            from 1 v31 n sv1 sv3 have Tv13: "T v1 <: T v3"
              apply (erule_tac x="?m" in allE) apply (erule impE) apply force
              apply (erule_tac x=v3 in allE) apply (erule_tac x=v1 in allE)
              apply (erule_tac x="[]" in allE) apply (erule_tac x="[]" in allE) apply auto done
            from Tv13 Tv31 show ?thesis unfolding ty_eq_def by blast
          qed
          have Tv4_Tv2: "T v4 \<approx> T v2"
          proof -
            let ?m = "val_size v2 + val_size v4"
            from v12 have sv2: "val_size v2 < fun_size t" using val_size_mem_r by auto
            from v34 have sv4: "val_size v4 < fun_size t'" using val_size_mem_r by auto
            from 1 v42 n sv2 sv4 have Tv2_v4: "T v2 <: T v4"
              apply (erule_tac x="?m" in allE) apply (erule impE) apply force
              apply (erule_tac x=v4 in allE) apply (erule_tac x=v2 in allE)
              apply (erule_tac x="[]" in allE) apply (erule_tac x="[]" in allE)
              apply (erule impE) defer apply blast apply simp
              done
            from 1 v24 n sv2 sv4 have Tv4_v2: "T v4 <: T v2"
              apply (erule_tac x="?m" in allE) apply (erule impE) apply force
              apply (erule_tac x=v2 in allE) apply (erule_tac x=v4 in allE)
              apply (erule_tac x="[]" in allE) apply (erule_tac x="[]" in allE)
              apply (erule impE) defer apply blast apply simp
              done
            from Tv2_v4 Tv4_v2 show ?thesis unfolding ty_eq_def by blast
          qed
          from Tv3_Tv1 Tv4_Tv2 have T34_T12: "T v3 \<rightarrow> T v4 <:: T v1 \<rightarrow> T v2"
            unfolding ty_eq_def by blast
          from v34 have tp_T34: "Tf t' <:: T v3 \<rightarrow> T v4" using table_mem_sub by blast
          from tp_T34 T34_T12 show "Tf t' <:: T v1 \<rightarrow> T v2" by (rule sub_trans)
        next
          let ?m = "fun_size t' + fun_size t1"
          from Cons Pair t_tp have t1_tp: "t1 \<lesssim> t'" by auto
          from 1 n t1_tp Cons Pair
          show "Tf t' <:: Tf t1"
            apply (erule_tac x="?m" in allE) apply (erule impE) apply force
            apply (erule_tac x="VNat 0" in allE) apply (erule_tac x="VNat 0" in allE)
            apply (erule_tac x="t1" in allE) apply (erule_tac x="t'" in allE)
            apply auto done
          qed
      qed
    qed
  qed
qed

proposition le_sub_flip: "v \<sqsubseteq> v' \<Longrightarrow> T v' <: T v" using le_sub_flip_aux by blast

lemma le_sub_fun_flip: "t \<lesssim> t' \<Longrightarrow> Tf t' <:: Tf t" using le_sub_flip_aux by blast

lemma Tf_append: "Tf (t1 @ t2) <:: Tf t1 \<sqinter> Tf t2"
proof (induction t1)
  case Nil
  then show ?case
    apply simp apply (rule sub_inter_r) using Tf_top apply blast
    apply (rule fsub_refl) done
next
  case (Cons a t1)
  then show ?case
    apply (case_tac a) apply simp apply (rule sub_inter_r) apply (rule sub_inter_r)
      apply (rule sub_inter_left1) apply (rule fsub_refl) apply (rule sub_inter_left2)
     apply (subgoal_tac "Tf t1 \<sqinter> Tf t2 <:: Tf t1") prefer 2 apply (rule sub_inter_left1)
      apply (rule fsub_refl) apply (rule sub_trans) apply assumption apply assumption
    apply (rule sub_inter_left2) apply (subgoal_tac "Tf t1 \<sqinter> Tf t2 <:: Tf t2")
     prefer 2 apply (rule sub_inter_left2)
     apply (rule fsub_refl) apply (rule sub_trans) apply assumption apply assumption done
qed

lemma append_Tf: "Tf t1 \<sqinter> Tf t2 <:: Tf (t1 @ t2)"
proof (induction t1)
  case Nil
  then show ?case apply simp apply (rule sub_inter_left2) apply (rule fsub_refl) done
next
  case (Cons p t1)
  then show ?case
    apply (cases p) apply simp apply (rule sub_inter_r)
     apply (rule sub_inter_left1) apply (rule sub_inter_left1) apply (rule fsub_refl)
    apply (rename_tac v1 v2)
    apply (subgoal_tac "((T v1 \<rightarrow> T v2) \<sqinter> Tf t1) \<sqinter> Tf t2 <:: Tf t1 \<sqinter> Tf t2")
     prefer 2 apply (rule sub_inter_r) apply (rule sub_inter_left1)
      apply (rule sub_inter_left2) apply (rule fsub_refl)
     apply (rule sub_inter_left2) apply (rule fsub_refl)
    apply (rule sub_trans) apply assumption apply assumption done
qed

proposition tv_id: shows "T (V A) \<approx> A" and "Tf (Vf F) \<simeq> F"
proof (induction rule: V_Vf.induct)
  case (1 n)
  then show ?case apply (simp add: ty_eq_def) apply (rule sub_refl) done
next
  case (2 f)
  then show ?case
    apply (simp add: ty_eq_def) apply (rule conjI) apply (rule sub_funty)
    using le_sub_flip fty_eq_def apply blast
    apply (rule sub_funty) using le_sub_flip fty_eq_def apply blast
    done
next
  case (3 A B)
  then show ?case
    apply (simp add: fty_eq_def) apply(rule conjI) apply (rule sub_inter_left1)
    using ty_eq_def apply blast
    apply (rule sub_inter_r) using ty_eq_def apply blast
    apply blast done
next
  case (4 A B)
  then show ?case
    using fty_eq_def apply simp apply (rule conjI) apply (rule sub_inter_r)
      apply (subgoal_tac "Tf (Vf A @ Vf B) <:: Tf (Vf A) \<sqinter> Tf (Vf B)")
       prefer 2 using Tf_append apply simp
      apply (subgoal_tac "Tf (Vf A) \<sqinter> Tf (Vf B) <:: A")
       apply (rule sub_trans) apply assumption apply assumption
      apply (rule sub_inter_left1) apply blast
     apply (subgoal_tac "Tf (Vf A @ Vf B) <:: Tf (Vf A) \<sqinter> Tf (Vf B)")
      prefer 2 using Tf_append apply simp
     apply (subgoal_tac "Tf (Vf A) \<sqinter> Tf (Vf B) <:: B")
      apply (rule sub_trans) apply assumption apply assumption
     apply (rule sub_inter_left2) apply blast
    apply (subgoal_tac "Tf (Vf A) \<sqinter> Tf (Vf B) <:: Tf (Vf A @ Vf B)")
     prefer 2 apply (rule append_Tf)
    apply (subgoal_tac "A \<sqinter> B <:: Tf (Vf A) \<sqinter> Tf (Vf B)")
     apply (rule sub_trans) apply blast
     apply blast apply (rule sub_inter_r) apply (rule sub_inter_left1) apply blast
    apply (rule sub_inter_left2) apply blast done
next
  case 5
  then show ?case  using fty_eq_def by auto
qed

lemma denot_lam_implies_ts:
  assumes et: "\<forall> v \<rho>. v \<in> E e \<rho> \<longrightarrow> Tenv \<rho> \<turnstile> e : T v" and
       fe: "\<forall>v1 v2. (v1, v2) \<in> set f \<longrightarrow> v2 \<in> E e ((x, v1) # \<rho>)"
  shows "Tenv \<rho> \<turnstile> ELam x e : TFun (Tf f)"
  using et fe
proof (induction f)
  case Nil
  then show ?case by auto
next
  case (Cons a f)
  then show ?case
  proof (cases a)
    case (Pair v v')
    {
      assume 1: "Tenv \<rho> \<turnstile> ELam x e : TFun (Tf f)" and
        2: "\<forall>v \<rho>. v \<in> E e \<rho> \<longrightarrow> Tenv \<rho> \<turnstile> e : T v" and
        3: "\<forall>v1 v2.
          (v1 = v \<and> v2 = v' \<longrightarrow> v' \<in> E e ((x, v) # \<rho>)) \<and>
          ((v1, v2) \<in> set f \<longrightarrow> v2 \<in> E e ((x, v1) # \<rho>))"
      from 3 have 4: "v' \<in> E e ((x,v)#\<rho>)" by simp
      from 2 4 have 5: "Tenv ((x,v)#\<rho>) \<turnstile> e : T v'"
        apply (erule_tac x=v' in allE) apply (erule_tac x="(x,v)#\<rho>" in allE) apply simp done
      from 5 have "(x, T v) # Tenv \<rho> \<turnstile> e : T v'" by simp
    }
    from Cons Pair this show ?thesis
      apply simp apply (rule wt_inter) apply (rule wt_lam) apply blast apply blast done
  qed
qed

theorem denot_implies_ts:
  assumes ve: "v \<in> E e \<rho>" shows "Tenv \<rho> \<turnstile> e : T v"
  using ve
proof (induction e arbitrary: v \<rho>)
  case (EVar x)
  then show ?case
    apply simp apply (erule exE) apply (erule conjE)
    apply (subgoal_tac "lookup (Tenv \<rho>) x = Some (T v')")
     prefer 2 apply (rule lookup_tenv) apply assumption
    apply (rule wt_sub) apply blast
    apply (rule le_sub_flip) apply assumption
    done
next
  case (ENat x)
  then show ?case by auto
next
  case (ELam x e)
  then show ?case
    apply simp apply clarify apply simp
    apply (rule denot_lam_implies_ts)
     apply blast apply blast done
next
  case (EApp e1 e2)
  then show ?case
    apply simp apply clarify
    apply (subgoal_tac "Tenv \<rho> \<turnstile> e1 : T (VFun f)")
     prefer 2 apply assumption apply (subgoal_tac "Tf f <:: T v2' \<rightarrow> T v3'")
     prefer 2 apply (rule table_mem_sub) apply assumption
    apply (subgoal_tac "Tenv \<rho> \<turnstile> EApp e1 e2 : T v3'") apply (rule wt_sub)
      apply assumption
     apply (rule le_sub_flip) apply assumption
    apply (subgoal_tac "Tenv \<rho> \<turnstile> e1 : TFun (T v2' \<rightarrow> T v3')") prefer 2
     apply (rule wt_sub) apply assumption apply simp apply (rule sub_funty) apply assumption
    apply (rule wt_app) apply assumption
    apply (subgoal_tac "Tenv \<rho> \<turnstile> e2 : T v2") prefer 2 apply assumption
    apply (rule wt_sub) apply assumption apply (rule le_sub_flip) apply assumption  done
next
  case (EPrim f e1 e2)
  then show ?case
    apply simp apply clarify
    apply (subgoal_tac "Tenv \<rho> \<turnstile> e1 : T (VNat n1)") prefer 2 apply assumption
    apply (subgoal_tac "Tenv \<rho> \<turnstile> e2 : T (VNat n2)") prefer 2 apply assumption
    apply force done
next
  case (EIf e1 e2 e3)
  then show ?case
    apply simp apply clarify
    apply (subgoal_tac "Tenv \<rho> \<turnstile> e1 : T (VNat n)") prefer 2 apply assumption
    apply (case_tac n) apply simp
     apply (subgoal_tac "Tenv \<rho> \<turnstile> e3 : T v") prefer 2 apply assumption
     apply blast
    apply simp
    apply (subgoal_tac "Tenv \<rho> \<turnstile> e2 : T v") prefer 2 apply assumption
    apply (rule wt_ifnz) apply assumption apply simp apply assumption done
qed

lemma venv_lookup: assumes lx: "lookup \<Gamma> x = Some A" shows "lookup (Venv \<Gamma>) x = Some (V A)"
  using lx
proof (induction \<Gamma> arbitrary: A)
  case Nil
  then show ?case by auto
next
  case (Cons b \<Gamma>)
  obtain x' B where "b = (x',B)" by (cases b) auto
  with Cons show ?case by (cases "x = x'") auto
qed

lemma append_fun_equiv: "\<lbrakk> t1' \<sim> t1; t2' \<sim> t2 \<rbrakk> \<Longrightarrow> t1' @ t2' \<sim> t1 @ t2"
  apply (simp add: val_eq_def fun_eq_def)
  using append_fun_le apply blast
  done

lemma append_eq_symm: "t2 @ t1 \<sim> t1 @ t2"
  unfolding fun_eq_def val_eq_def apply (rule conjI)
   apply (rule append_leq_symm)
  apply (rule append_leq_symm)
  done

lemma sub_le_flip: "(A <: B \<longrightarrow> V B \<sqsubseteq> V A) \<and> (f1 <:: f2 \<longrightarrow> (Vf f2) \<lesssim> (Vf f1))"
proof (induction rule: subtype_fsubtype.induct)
  case (sub_trans T1 T2 T3)
  then show ?case using fun_le_trans by blast
qed force+

theorem ts_implies_denot:
  assumes wte: "\<Gamma> \<turnstile> e : A" shows "V A \<in> E e (Venv \<Gamma>)"
  using wte
proof (induction \<Gamma> e A rule: wt.induct)
  case (wt_var \<Gamma> x T)
  then show ?case
    apply simp
    apply (subgoal_tac "lookup (Venv \<Gamma>) x = Some (V T)")
     prefer 2 apply (rule venv_lookup)
     apply assumption
    apply (rule_tac x="V T" in exI)
    apply force
    done
next
  case (wt_sub \<Gamma> e A B)
  then show ?case
    apply (subgoal_tac "V B \<sqsubseteq> V A")
     prefer 2 using sub_le_flip apply blast
    apply (rule e_sub)
     apply auto
    done
qed fastforce+

end


theory solved_case_10_and_11
  imports
    ODE_Solve_Keyword
begin

(* This solves \<open>ode_cert "\<lambda> (t::real) x. 1/(2*x-1)" "{t. t> 0}"\<close>*)
lemma "((\<lambda> t.((t :: real) * arcsin(t) + (C0::real) + (t^2 * -1 + 1) powr (1/2))) solves_ode (\<lambda>t x. arcsin t)) {-1<..<1} \<real>"
  apply ode_cert
   apply (smt mult_less_cancel_right2 mult_minus_left)
  apply simp
proof -
  have "\<And>x. - 1 < x \<and> x < 1 \<Longrightarrow> x * inverse (sqrt (1 - x\<^sup>2)) = (1 - x * x) powr (1 / 2) * x / ( abs(1 - x * x) )"
    apply (simp add: power2_eq_square powr_half_sqrt square_le_1)
    apply (smt divide_inverse power2_eq_square powr_half_sqrt real_divide_square_eq real_sqrt_mult_self square_le_1)
    done
  thus "\<And>x. - 1 < x \<and> x < 1 \<Longrightarrow> x * inverse (sqrt (1 - x\<^sup>2)) = (1 - x * x) powr (1 / 2) * x / (1 - x * x)"
    by (smt power2_eq_square square_le_1)
qed

(*This solves \<open>ode_cert "\<lambda> (t::real) x. t powr (sqrt 2)" "{0<..}"\<close>*)
theorem "((\<lambda>t. 2 powr (1 / 2) * (t :: real) * t powr 2 powr (1 / 2) * inverse ((2 powr (1 / 2) + 2) ^ 1) +(C0 :: real)) solves_ode (\<lambda>t x. t powr sqrt 2)) {0<..} \<real>"
  apply ode_cert
    apply (smt powr_gt_zero)
   apply (rule has_vector_derivative_eq_rhs)
    apply (rule derivative_intros; (simp add: field_simps)?)+
   apply (simp add: field_simps)+
  apply (simp add: powr_half_sqrt)
  apply (metis add.commute add_pos_pos distrib_right less_numeral_extra(3) mult.commute nonzero_mult_div_cancel_right real_sqrt_gt_0_iff zero_less_numeral)
  done

end


section \<open>ZF sets corresponding to $\mathbb{R}$ and $\mathbb{C}$ and the cardinality of the contimuum\<close>

theory General_Cardinals
  imports ZFC_Typeclasses "HOL-Analysis.Continuum_Not_Denumerable"

begin

subsection \<open>Making the embedding from the type class explicit\<close>

definition V_of :: "'a::embeddable \<Rightarrow> V"
  where "V_of \<equiv> SOME f. inj f"

lemma inj_V_of: "inj V_of"
  unfolding V_of_def by (metis embeddable_class.ex_inj some_eq_imp)

declare inv_f_f [OF inj_V_of, simp]

lemma inv_V_of_image_eq [simp]: "inv V_of ` (V_of ` X) = X"
  by (auto simp: image_comp)

lemma infinite_V_of: "infinite (UNIV::'a set) \<Longrightarrow> infinite (range (V_of::'a::embeddable\<Rightarrow>V))"
  using finite_imageD inj_V_of by blast

lemma countable_V_of: "countable (range (V_of::'a::countable\<Rightarrow>V))"
  by blast

lemma elts_set_V_of: "small X \<Longrightarrow> elts (ZFC_in_HOL.set (V_of ` X)) \<approx> X"
  by (metis inj_V_of inj_eq inj_on_def inj_on_image_eqpoll_self replacement set_of_elts small_iff)

lemma V_of_image_times: "V_of ` (X \<times> Y) \<approx> (V_of ` X) \<times> (V_of ` Y)"
proof -
  have "V_of ` (X \<times> Y) \<approx> X \<times> Y"
    by (meson inj_V_of inj_eq inj_onI inj_on_image_eqpoll_self)
  also have "\<dots> \<approx> (V_of ` X) \<times> (V_of ` Y)"
    by (metis eqpoll_sym inj_V_of inj_eq inj_onI inj_on_image_eqpoll_self times_eqpoll_cong)
  finally show ?thesis .
qed

subsection \<open>The cardinality of the continuum\<close>

definition "Real_set \<equiv> ZFC_in_HOL.set (range (V_of::real\<Rightarrow>V))"
definition "Complex_set \<equiv> ZFC_in_HOL.set (range (V_of::complex\<Rightarrow>V))"
definition "C_continuum \<equiv> vcard Real_set"

lemma V_of_Real_set: "bij_betw V_of (UNIV::real set) (elts Real_set)"
  by (simp add: Real_set_def bij_betw_def inj_V_of)

lemma uncountable_Real_set: "uncountable (elts Real_set)"
  using V_of_Real_set countable_iff_bij uncountable_UNIV_real by blast

lemma "Card C_continuum"
  by (simp add: C_continuum_def Card_def)

lemma C_continuum_ge: "C_continuum \<ge> \<aleph>1"
  by (metis C_continuum_def Ord_\<omega>1 Ord_cardinal Ord_linear2 countable_iff_vcard_less1
            uncountable_Real_set)

lemma V_of_Complex_set: "bij_betw V_of (UNIV::complex set) (elts Complex_set)"
  by (simp add: Complex_set_def bij_betw_def inj_V_of)

lemma uncountable_Complex_set: "uncountable (elts Complex_set)"
  using V_of_Complex_set countableI_bij2 uncountable_UNIV_complex by blast

lemma Complex_vcard: "vcard Complex_set = C_continuum"
proof -
  define emb1 where "emb1 \<equiv> V_of o complex_of_real o inv V_of"
  have "elts Real_set \<approx> elts Complex_set"
  proof (rule lepoll_antisym)
    show "elts Real_set \<lesssim> elts Complex_set"
      unfolding lepoll_def
    proof (intro conjI exI)
      show "inj_on emb1 (elts Real_set)"
        unfolding emb1_def Real_set_def
        by (simp add: inj_V_of inj_compose inj_of_real inj_on_imageI)
      show "emb1 ` elts Real_set \<subseteq> elts Complex_set"
        by (simp add: emb1_def Real_set_def Complex_set_def image_subset_iff)
    qed
    define emb2 where "emb2 \<equiv> (\<lambda>z. (V_of (Re z), V_of (Im z))) o inv V_of"
    have "elts Complex_set \<lesssim> elts Real_set \<times> elts Real_set"
      unfolding lepoll_def
    proof (intro conjI exI)
      show "inj_on emb2 (elts Complex_set)"
        unfolding emb2_def Complex_set_def inj_on_def
        by (simp add: complex.expand inj_V_of inj_eq)
      show "emb2 ` elts Complex_set \<subseteq> elts Real_set \<times> elts Real_set"
        by (simp add: emb2_def Real_set_def Complex_set_def image_subset_iff)
    qed
    also have "\<dots>  \<approx> elts Real_set"
      by (simp add: infinite_times_eqpoll_self uncountable_Real_set uncountable_infinite)
    finally show "elts Complex_set \<lesssim> elts Real_set" .
  qed
  then show ?thesis
    by (simp add: C_continuum_def cardinal_cong)
qed

lemma gcard_Union_le_cmult:
  assumes "small U" and \<kappa>: "\<And>x. x \<in> U \<Longrightarrow> gcard x \<le> \<kappa>" and sm: "\<And>x. x \<in> U \<Longrightarrow> small x"
  shows "gcard (\<Union>U) \<le> gcard U \<otimes> \<kappa>"
proof -
  have "\<exists>f. f \<in> x \<rightarrow> elts \<kappa> \<and> inj_on f x" if "x \<in> U" for x
    using \<kappa> [OF that] gcard_le_lepoll by (metis image_subset_iff_funcset lepoll_def sm that)
  then obtain \<phi> where \<phi>: "\<And>x. x \<in> U \<Longrightarrow> (\<phi> x) \<in> x \<rightarrow> elts \<kappa> \<and> inj_on (\<phi> x) x"
    by metis
  define u where "u \<equiv> \<lambda>y. @x. x \<in> U \<and> y \<in> x"
  have u: "u y \<in> U \<and> y \<in>  (u y)" if "y \<in> \<Union>( U)" for y
    unfolding u_def using that by (fast intro!: someI2)
  define \<psi> where "\<psi> \<equiv> \<lambda>y. (u y, \<phi> (u y) y)"
  have U: "elts (gcard U) \<approx> U"
    using assms by (simp add: gcard_eqpoll)
   have "\<Union>U \<lesssim> U \<times> elts \<kappa>"
    unfolding lepoll_def
  proof (intro exI conjI)
    show "inj_on \<psi> (\<Union> U)"
      using \<phi> u by (smt (verit) \<psi>_def inj_on_def prod.inject)
    show "\<psi> ` \<Union> U \<subseteq> U \<times> elts \<kappa>"
      using \<phi> u by (auto simp: \<psi>_def)
  qed
  also have "\<dots>  \<approx> elts (gcard U \<otimes> \<kappa>)"
    using U elts_cmult eqpoll_sym eqpoll_trans times_eqpoll_cong by blast
  finally have " (\<Union>U) \<lesssim> elts (gcard U \<otimes> \<kappa>)" .
  then show ?thesis
    by (metis cardinal_idem cmult_def gcard_eq_vcard lepoll_imp_gcard_le small_elts)
qed

lemma gcard_Times [simp]: "gcard (X \<times> Y) = gcard X \<otimes> gcard Y"
proof (cases "small X \<and> small Y")
  case True
  have "elts (gcard (X \<times> Y)) \<approx> X \<times> Y"
    by (simp add: True gcard_eqpoll)
  also have "... \<approx> elts (gcard X) \<times> elts (gcard Y)"
    by (simp add: True eqpoll_sym gcard_eqpoll times_eqpoll_cong)
  also have "... \<approx> elts (gcard X \<otimes> gcard Y)"
    by (simp add: elts_cmult eqpoll_sym)
  finally show ?thesis
    using Card_cardinal_eq cmult_def gcardinal_cong by force
next
  case False
  have "gcard (X \<times> Y) = 0"
    by (metis False Times_empty gcard_big_0 gcard_empty_0 small_Times_iff)
  then show ?thesis
    by (metis False cmult_0 cmult_commute gcard_big_0)
qed

subsection \<open>Countable and uncountable sets\<close>

lemma countable_iff_g_le_Aleph0:
  assumes "small X"
  shows "countable X \<longleftrightarrow> gcard X \<le> \<aleph>0"
proof -
  have "countable X \<longleftrightarrow> X \<lesssim> elts \<omega>"
    by (simp add: \<omega>_def countable_iff_lepoll inj_ord_of_nat)
  also have "... \<longleftrightarrow> gcard X \<le> \<aleph>0"
    using Card_\<omega> Card_def assms gcard_le_lepoll lepoll_imp_gcard_le by fastforce
  finally show ?thesis .
qed

lemma countable_imp_g_le_Aleph0: "countable X \<Longrightarrow> gcard X \<le> \<aleph>0"
  by (meson countable countable_iff_g_le_Aleph0)

lemma finite_iff_g_le_Aleph0: "small X \<Longrightarrow> finite X \<longleftrightarrow> gcard X < \<aleph>0"
  by (metis Aleph_0 eqpoll_finite_iff finite_iff_less_Aleph0 gcard_eq_vcard gcard_eqpoll gcardinal_cong)

lemma finite_imp_g_le_Aleph0: "finite X \<Longrightarrow> gcard X < \<aleph>0"
  by (meson finite_iff_g_le_Aleph0 finite_imp_small)

lemma countable_infinite_gcard: "countable X \<and> infinite X \<longleftrightarrow> gcard X = \<aleph>0"
proof -
  have "gcard X = \<omega>"
    if "countable X" and "infinite X"
    using that countable countable_imp_g_le_Aleph0 finite_iff_g_le_Aleph0 less_V_def by auto
  moreover have "countable X" if "gcard X = \<omega>"
    by (metis Aleph_0 countable_iff_g_le_Aleph0 dual_order.refl gcard_big_0 omega_nonzero that)
  moreover have False if "gcard X = \<omega>" and "finite X"
    by (metis Aleph_0 dual_order.irrefl finite_iff_g_le_Aleph0 finite_imp_small that)
  ultimately show ?thesis
    by auto
qed

lemma uncountable_gcard: "small X \<Longrightarrow> uncountable X \<longleftrightarrow> gcard X > \<aleph>0"
  by (simp add: Card_is_Ord Ord_not_le countable_iff_g_le_Aleph0)

lemma uncountable_gcard_ge: "small X \<Longrightarrow> uncountable X \<longleftrightarrow> gcard X \<ge> \<aleph>1"
  by (simp add: uncountable_gcard csucc_le_Card_iff one_V_def)

lemma subset_smaller_gcard:
  assumes \<kappa>: "\<kappa> \<le> gcard X" "Card \<kappa>"
  obtains Y where "Y \<subseteq> X" "gcard Y = \<kappa>"
proof (cases "small X")
  case True
  then have "elts \<kappa> \<lesssim> X"
    by (meson assms(1) eqpoll_imp_lepoll gcard_eqpoll lepoll_trans less_eq_V_def subset_imp_lepoll)
  then obtain Y where "Y \<subseteq> X" "elts \<kappa> \<approx> Y"
    by (metis bij_betw_def eqpoll_def lepoll_def)
  then show ?thesis
    using Card_def \<open>Card \<kappa>\<close> gcardinal_cong that by force
next
  case False
  with assms show ?thesis
    by (metis antisym gcard_big_0 le_0 order_refl that)
qed

lemma Real_gcard: "gcard (UNIV::real set) = C_continuum"
  by (metis C_continuum_def V_of_Real_set bij_betw_def gcard_eq_vcard gcard_image)

lemma Complex_gcard: "gcard (UNIV::complex set) = C_continuum"
  by (metis Complex_vcard V_of_Complex_set bij_betw_def gcard_eq_vcard gcard_image)

end


header {* Trivia *}

(*<*)
theory Trivia
imports Main
begin
(*>*)

lemma measure_induct2:
fixes meas :: "'a \<Rightarrow> 'b \<Rightarrow> nat"
assumes "\<And>x1 x2. (\<And>y1 y2. meas y1 y2 < meas x1 x2 \<Longrightarrow> S y1 y2) \<Longrightarrow> S x1 x2"
shows "S x1 x2"
proof-
  let ?m = "\<lambda> x1x2. meas (fst x1x2) (snd x1x2)" let ?S = "\<lambda> x1x2. S (fst x1x2) (snd x1x2)"
  have "?S (x1,x2)"
  apply(rule measure_induct[of ?m ?S])
  using assms by (metis fst_conv snd_conv)
  thus ?thesis by auto
qed

text{* Right cons: *}

abbreviation Rcons (infix "##" 70) where "xs ## x \<equiv> xs @ [x]"

lemma two_singl_Rcons: "[a,b] = [a] ## b" by auto

(*<*)
end
(*>*)


theory ex_2_5
  imports Main
begin
fun sum_upto::"nat \<Rightarrow> nat" where
"sum_upto 0 = 0" |
"sum_upto (Suc n) = sum_upto n + (Suc n)"

theorem sum_upto[simp]:"sum_upto n = n * (n + 1) div 2"
  apply (induction n)
  by (auto)
end