(*
    Title:      Dim_Formula.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
    Maintainer: Jose Divasón <jose.divasonm at unirioja.es>
*)

section "Rank Nullity Theorem of Linear Algebra"

theory Dim_Formula
  imports Fundamental_Subspaces
begin

context vector_space
begin

subsection\<open>Previous results\<close>

text\<open>Linear dependency is a monotone property, based on the
  monotonocity of linear independence:\<close>

lemma dependent_mono:
  assumes d:"dependent A"
  and A_in_B: "A \<subseteq> B"
  shows  "dependent B"
  using independent_mono [OF _ A_in_B] d by auto

text\<open>Given a finite independent set, a linear combination of its
  elements equal to zero is possible only if every coefficient is zero:\<close>

lemma scalars_zero_if_independent:
  assumes fin_A: "finite A"
  and ind: "independent A"
  and sum: "(\<Sum>x\<in>A. scale (f x) x) = 0"
  shows "\<forall>x \<in> A. f x = 0"
  using fin_A ind local.dependent_finite sum by blast

end

context finite_dimensional_vector_space
begin

text\<open>In an finite dimensional vector space, every independent set is finite, and
  thus @{thm [display ]scalars_zero_if_independent [no_vars]} holds:\<close>

corollary scalars_zero_if_independent_euclidean:
  assumes ind: "independent A"
    and sum: "(\<Sum>x\<in>A. scale (f x) x) = 0"
  shows "\<forall>x \<in> A. f x = 0"
  using finiteI_independent ind scalars_zero_if_independent sum by blast

end

text\<open>The following lemma states that every linear form is injective over the
  elements which define the basis of the range of the linear form.
  This property is applied later over the elements of an arbitrary
  basis which are not in the basis of the nullifier or kernel set
  (\emph{i.e.}, the candidates to be the basis of the range space
  of the linear form).\<close>

text\<open>Thanks to this result, it can be concluded that the cardinal
  of the elements of a basis which do not belong to the kernel
  of a linear form @{term "f::'a => 'b"} is equal to the cardinal
  of the set obtained when applying @{term "f::'a => 'b"} to such elements.\<close>

text\<open>The application of this lemma is not usually found in the pencil and paper
  proofs of the ``rank nullity theorem'', but will be crucial to know that,
  being @{term "f::'a => 'b"} a linear form from a finite dimensional
  vector space @{term "V"} to a vector space @{term "V'"},
  and given a basis @{term "B::'a set"} of @{term "ker f"},
  when @{term "B"} is completed up to a basis of @{term "V::'a set"}
  with a set @{term "W::'a set"}, the cardinal of this set is
  equal to the cardinal of its range set:\<close>

context vector_space
begin

lemma inj_on_extended:
  assumes lf: "Vector_Spaces.linear scaleB scaleC f"
  and f: "finite C"
  and ind_C: "independent C"
  and C_eq: "C = B \<union> W"
  and disj_set: "B \<inter> W = {}"
  and span_B: "{x. f x = 0} \<subseteq> span B"
  shows "inj_on f W"
  \<comment> \<open>The proof is carried out by reductio ad absurdum\<close>
proof (unfold inj_on_def, rule+, rule ccontr)
  interpret lf: Vector_Spaces.linear scaleB scaleC f using lf by simp
  \<comment> \<open>Some previous consequences of the premises that are used later:\<close>
  have fin_B: "finite B" using finite_subset [OF _ f] C_eq by simp
  have ind_B: "independent B" and ind_W: "independent W"
    using independent_mono[OF ind_C] C_eq by simp_all
  \<comment> \<open>The proof starts here; we assume that there exist two different elements\<close>
  \<comment> \<open>with the same image:\<close>
  fix x::'b and y::'b
  assume x: "x \<in> W" and y: "y \<in> W" and f_eq: "f x = f y" and x_not_y: "x \<noteq> y"
  have fin_yB: "finite (insert y B)" using fin_B by simp
  have "f (x - y) = 0" by (metis diff_self f_eq lf.diff)
  hence "x - y \<in> {x. f x = 0}" by simp
  hence "\<exists>g. (\<Sum>v\<in>B. scale (g v) v) = (x - y)" using span_B
    unfolding span_finite [OF fin_B] by force
  then obtain g where sum: "(\<Sum>v\<in>B. scale (g v) v) = (x - y)" by blast
  \<comment> \<open>We define one of the elements as a linear combination of the second
      element and the ones in $B$\<close>
  define h :: "'b \<Rightarrow> 'a" where "h a = (if a = y then 1 else g a)" for a
  have "x = y + (\<Sum>v\<in>B. scale (g v) v)" using sum by auto
  also have "... = scale (h y) y  + (\<Sum>v\<in>B. scale (g v) v)" unfolding h_def by simp
  also have "... = scale (h y) y + (\<Sum>v\<in>B. scale (h v) v)"
    apply (unfold add_left_cancel, rule sum.cong)
    using y h_def empty_iff disj_set by auto
  also have "... = (\<Sum>v\<in>(insert y B). scale (h v) v)"
    by (rule sum.insert[symmetric], rule fin_B)
       (metis (lifting) IntI disj_set empty_iff y)
  finally have x_in_span_yB: "x \<in> span (insert y B)"
    unfolding span_finite[OF fin_yB] by auto
  \<comment> \<open>We have that a subset of elements of $C$ is linearly dependent\<close>
  have dep: "dependent (insert x (insert y B))"
    by (unfold dependent_def, rule bexI [of _ x])
       (metis Diff_insert_absorb Int_iff disj_set empty_iff insert_iff
         x x_in_span_yB x_not_y, simp)
  \<comment> \<open>Therefore, the set $C$ is also dependent:\<close>
  hence "dependent C" using C_eq x y
    by (metis Un_commute Un_upper2 dependent_mono insert_absorb insert_subset)
  \<comment> \<open>This yields the contradiction, since $C$ is independent:\<close>
  thus False using ind_C by contradiction
qed
end

subsection\<open>The proof\<close>

text\<open>Now the rank nullity theorem can be proved; given any linear form
  @{term "f::'a => 'b"}, the sum of the dimensions of its kernel and
  range subspaces is equal to the dimension of the source vector space.\<close>

text\<open>The statement of the ``rank nullity theorem for linear algebra'', as
  well as its proof, follow the ones on~\cite{AX97}. The proof is the
  traditional one found in the literature. The theorem is also named
  ``fundamental theorem of linear algebra'' in some texts (for instance,
  in~\cite{GO10}).\<close>

context finite_dimensional_vector_space
begin

theorem rank_nullity_theorem:
  assumes l: "Vector_Spaces.linear scale scaleC f"
  shows "dimension = dim {x. f x = 0} + vector_space.dim scaleC (range f)"
proof -
  \<comment> \<open>For convenience we define abbreviations for the universe set, $V$,
    and the kernel of $f$\<close>
  interpret l: Vector_Spaces.linear scale scaleC f by fact
  define V :: "'b set" where "V = UNIV"
  define ker_f where "ker_f = {x. f x = 0}"
  \<comment> \<open>The kernel is a proper subspace:\<close>
  have sub_ker: "subspace {x. f x = 0}" using l.subspace_kernel .
  \<comment> \<open>The kernel has its proper basis, $B$:\<close>
  obtain B where B_in_ker: "B \<subseteq> {x. f x = 0}"
    and independent_B: "independent B"
    and ker_in_span:"{x. f x = 0} \<subseteq> span B"
    and card_B: "card B = dim {x. f x = 0}" using basis_exists by blast
  \<comment> \<open>The space $V$ has a (finite dimensional) basis, $C$:\<close>
  obtain C where B_in_C: "B \<subseteq> C" and C_in_V: "C \<subseteq> V"
    and independent_C: "independent C"
    and span_C: "V = span C"
    unfolding V_def
    by (metis independent_B extend_basis_superset independent_extend_basis span_extend_basis span_superset)
  \<comment> \<open>The basis of $V$, $C$, can be decomposed in the disjoint union of the
      basis of the kernel, $B$, and its complementary set, $C - B$\<close>
  have C_eq: "C = B \<union> (C - B)" by (rule Diff_partition [OF B_in_C, symmetric])
  have eq_fC: "f ` C = f ` B \<union> f ` (C - B)"
    by (subst C_eq, unfold image_Un, simp)
  \<comment> \<open>The basis $C$, and its image, are finite, since $V$ is finite-dimensional\<close>
  have finite_C: "finite C"
    using finiteI_independent[OF independent_C] .
  have finite_fC: "finite (f ` C)" by (rule finite_imageI [OF finite_C])
  \<comment> \<open>The basis $B$ of the kernel of $f$, and its image, are also finite\<close>
  have finite_B: "finite B" by (rule rev_finite_subset [OF finite_C B_in_C])
  have finite_fB: "finite (f ` B)" by (rule finite_imageI[OF finite_B])
  \<comment> \<open>The set $C - B$ is also finite\<close>
  have finite_CB: "finite (C - B)" by (rule finite_Diff [OF finite_C, of B])
  have dim_ker_le_dim_V:"dim (ker_f) \<le> dim V"
    using dim_subset [of ker_f V] unfolding V_def by simp
  \<comment> \<open>Here it starts the proof of the theorem: the sets $B$ and
      $C - B$ must be proven to be bases, respectively, of the kernel
      of $f$ and its range\<close>
  show ?thesis
  proof -
    have "dimension = dim V" unfolding V_def dim_UNIV dimension_def
      by (metis basis_card_eq_dim dimension_def independent_Basis span_Basis top_greatest)
    also have "dim V = dim C" unfolding span_C dim_span ..
    also have "... = card C"
      using basis_card_eq_dim [of C C, OF _ span_superset independent_C] by simp
    also have "... = card (B \<union> (C - B))" using C_eq by simp
    also have "... = card B + card (C-B)"
      by (rule card_Un_disjoint[OF finite_B finite_CB], fast)
    also have "... = dim ker_f + card (C-B)" unfolding ker_f_def card_B ..
    \<comment> \<open>Now it has to be proved that the elements of $C - B$ are a basis of
      the range of $f$\<close>
    also have "... = dim ker_f + l.vs2.dim (range f)"
    proof (unfold add_left_cancel)
      define W where "W = C - B"
      have finite_W: "finite W" unfolding W_def using finite_CB .
      have finite_fW: "finite (f ` W)" using finite_imageI[OF finite_W] .
      have "card W = card (f ` W)"
        by (rule card_image [symmetric], rule inj_on_extended[OF l, of C B], rule finite_C)
          (rule independent_C,unfold W_def, subst C_eq, rule refl, simp, rule ker_in_span)
      also have "... = l.vs2.dim (range f)"
        \<comment> \<open>The image set of $W$ is independent and its span contains the range
             of $f$, so it is a basis of the range:\<close>
      proof (rule l.vs2.basis_card_eq_dim)
        \<comment> \<open>1. The image set of $W$ generates the range of $f$:\<close>
        show "range f \<subseteq> l.vs2.span (f ` W)"
        proof (unfold l.vs2.span_finite [OF finite_fW], auto)
          \<comment> \<open>Given any element $v$ in $V$, its image can be expressed as a
            linear combination of elements of the image by $f$ of $C$:\<close>
          fix v :: 'b
          have fV_span: "f ` V \<subseteq> l.vs2.span  (f ` C)"
            by (simp add: span_C l.span_image)
          have "\<exists>g. (\<Sum>x\<in>f`C. scaleC (g x) x) = f v"
            using fV_span unfolding V_def
            using l.vs2.span_finite[OF finite_fC]
            by (metis (no_types, lifting) V_def rangeE rangeI span_C l.span_image)
          then obtain g where fv: "f v = (\<Sum>x\<in>f ` C. scaleC (g x) x)" by metis
              \<comment> \<open>We recall that $C$ is equal to $B$ union $(C - B)$, and $B$
            is the basis of the kernel; thus, the image of the elements of
            $B$ will be equal to zero:\<close>
          have zero_fB: "(\<Sum>x\<in>f ` B. scaleC (g x) x) = 0"
            using B_in_ker by (auto intro!: sum.neutral)
          have zero_inter: "(\<Sum>x\<in>(f ` B \<inter> f ` W). scaleC (g x) x) = 0"
            using B_in_ker by (auto intro!: sum.neutral)
          have "f v = (\<Sum>x\<in>f ` C. scaleC (g x) x)" using fv .
          also have "... = (\<Sum>x\<in>(f ` B \<union> f ` W).  scaleC (g x) x)"
            using eq_fC W_def by simp
          also have "... =
              (\<Sum>x\<in>f ` B. scaleC (g x) x) + (\<Sum>x\<in>f ` W. scaleC (g x) x)
                - (\<Sum>x\<in>(f ` B \<inter> f ` W). scaleC (g x) x)"
            using sum_Un [OF finite_fB finite_fW] by simp
          also have "... = (\<Sum>x\<in>f ` W. scaleC (g x) x)"
            unfolding zero_fB zero_inter by simp
              \<comment> \<open>We have proved that the image set of $W$ is a generating set
              of the range of $f$\<close>
          finally show "f v \<in> range (\<lambda>u. \<Sum>v\<in>f ` W. scaleC (u v) v)" by auto
        qed
          \<comment> \<open>2. The image set of $W$ is linearly independent:\<close>
        show "l.vs2.independent (f ` W)"
          using finite_fW
        proof (rule l.vs2.independent_if_scalars_zero)
          \<comment> \<open>Every linear combination (given by $g x$) of the elements of
           the image set of $W$ equal to zero, requires every coefficient to
           be zero:\<close>
          fix g :: "'c => 'a" and w :: 'c
          assume sum: "(\<Sum>x\<in>f ` W. scaleC (g x) x) = 0" and w: "w \<in> f ` W"
          have "0 = (\<Sum>x\<in>f ` W. scaleC (g x) x)" using sum by simp
          also have "... = sum ((\<lambda>x. scaleC (g x) x) \<circ> f) W"
            by (rule sum.reindex, rule inj_on_extended[OF l, of C B])
              (unfold W_def, rule finite_C, rule independent_C, rule C_eq, simp,
                rule ker_in_span)
          also have "... = (\<Sum>x\<in>W. scaleC ((g \<circ> f) x) (f x))" unfolding o_def ..
          also have "... = f (\<Sum>x\<in>W. scale ((g \<circ> f) x) x)"
            unfolding l.sum[symmetric] l.scale[symmetric] by simp
          finally have f_sum_zero:"f (\<Sum>x\<in>W. scale ((g \<circ> f) x) x) = 0" by (rule sym)
          hence "(\<Sum>x\<in>W. scale ((g \<circ> f) x) x) \<in> ker_f" unfolding ker_f_def by simp
          hence "\<exists>h. (\<Sum>v\<in>B. scale (h v) v) = (\<Sum>x\<in>W. scale ((g \<circ> f) x) x)"
            using span_finite[OF finite_B] using ker_in_span
            unfolding ker_f_def by force
          then obtain h where
            sum_h: "(\<Sum>v\<in>B. scale (h v) v) = (\<Sum>x\<in>W. scale ((g \<circ> f) x) x)" by blast
          define t where "t a = (if a \<in> B then h a else - ((g \<circ> f) a))" for a
          have "0 = (\<Sum>v\<in>B. scale (h v) v) + - (\<Sum>x\<in>W. scale ((g \<circ> f) x) x)"
            using sum_h by simp
          also have "... =  (\<Sum>v\<in>B. scale (h v) v) + (\<Sum>x\<in>W. - (scale ((g \<circ> f) x) x))"
            unfolding sum_negf ..
          also have "... = (\<Sum>v\<in>B. scale (t v) v) + (\<Sum>x\<in>W. -(scale((g \<circ> f) x) x))"
            unfolding add_right_cancel unfolding t_def by simp
          also have "... =  (\<Sum>v\<in>B. scale (t v) v) + (\<Sum>x\<in>W. scale (t x) x)"
            by (unfold add_left_cancel t_def W_def, rule sum.cong) simp+
          also have "... = (\<Sum>v\<in>B \<union> W. scale (t v) v)"
            by (rule sum.union_inter_neutral [symmetric], rule finite_B, rule finite_W)
              (simp add: W_def)
          finally have "(\<Sum>v\<in>B \<union> W. scale (t v) v) = 0" by simp
          hence coef_zero: "\<forall>x\<in>B \<union> W. t x = 0"
            using C_eq scalars_zero_if_independent [OF finite_C independent_C]
            unfolding W_def by simp
          obtain y where w_fy: "w = f y " and y_in_W: "y \<in> W" using w by fast
          have "- g w = t y"
            unfolding t_def w_fy using y_in_W unfolding W_def by simp
          also have "... = 0" using coef_zero y_in_W unfolding W_def by simp
          finally show "g w = 0" by simp
        qed
      qed auto
      finally show "card (C - B) = l.vs2.dim (range f)" unfolding W_def .
    qed
    finally show ?thesis unfolding V_def ker_f_def unfolding dim_UNIV .
  qed
qed

end

subsection\<open>The rank nullity theorem for matrices\<close>

text\<open>The proof of the theorem for matrices
  is direct, as a consequence of the ``rank nullity theorem''.\<close>

lemma rank_nullity_theorem_matrices:
  fixes A::"'a::{field}^'cols::{finite, wellorder}^'rows"
  shows "ncols A = vec.dim (null_space A) + vec.dim (col_space A)"
  using vec.rank_nullity_theorem[OF matrix_vector_mul_linear_gen, of A]
  apply (subst (2 3) matrix_of_matrix_vector_mul [of A, symmetric])
  unfolding null_space_eq_ker[OF matrix_vector_mul_linear_gen]
  unfolding col_space_eq_range [OF matrix_vector_mul_linear_gen]
  unfolding vec.dimension_def ncols_def card_cart_basis
  by simp

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section \<open>\isaheader{Indices of Sets}\<close>
theory SetIndex
imports
  "../spec/MapSpec"
  "../spec/SetSpec"
begin
text_raw \<open>\label{thy:SetIndex}\<close>

text \<open>
  This theory defines an indexing operation that builds an index from a set
  and an indexing function.

  Here, index is a map from indices to all values of the set with that index.
\<close>

subsection "Indexing by Function"

definition index :: "('a \<Rightarrow> 'i) \<Rightarrow> 'a set \<Rightarrow> 'i \<Rightarrow> 'a set"
  where "index f s i == { x\<in>s . f x = i }"

lemma indexI: "\<lbrakk> x\<in>s; f x = i \<rbrakk> \<Longrightarrow> x\<in>index f s i" by (unfold index_def) auto
lemma indexD:
  "x\<in>index f s i \<Longrightarrow> x\<in>s"
  "x\<in>index f s i \<Longrightarrow> f x = i"
  by (unfold index_def) auto

lemma index_iff[simp]: "x\<in>index f s i \<longleftrightarrow> x\<in>s \<and> f x = i" by (simp add: index_def)

subsection "Indexing by Map"

definition index_map :: "('a \<Rightarrow> 'i) \<Rightarrow> 'a set \<Rightarrow> 'i \<rightharpoonup> 'a set"
  where "index_map f s i == let s=index f s i in if s={} then None else Some s"

definition im_\<alpha> where "im_\<alpha> im i == case im i of None \<Rightarrow> {} | Some s \<Rightarrow> s"

lemma index_map_correct: "im_\<alpha> (index_map f s) = index f s"
  apply (rule ext)
  apply (unfold index_def index_map_def im_\<alpha>_def)
  apply auto
  done

subsection "Indexing by Maps and Sets from the Isabelle Collections Framework"
text \<open>
  In this theory, we define the generic algorithm as constants outside any locale,
  but prove the correctness lemmas inside a locale that assumes correctness of all
  prerequisite functions.
  Finally, we export the correctness lemmas from the locale.
\<close>

locale index_loc =
  m: StdMap m_ops +
  s: StdSet s_ops
  for m_ops :: "('i,'s,'m,'more1) map_ops_scheme"
  and s_ops :: "('x,'s,'more2) set_ops_scheme"
begin
  \<comment> \<open>Mapping indices to abstract indices\<close>
  definition ci_\<alpha>' where
    "ci_\<alpha>' ci i == case m.\<alpha> ci i of None \<Rightarrow> None | Some s \<Rightarrow> Some (s.\<alpha> s)"

  definition "ci_\<alpha> == im_\<alpha> \<circ> ci_\<alpha>'"

  definition ci_invar where
    "ci_invar ci == m.invar ci \<and> (\<forall>i s. m.\<alpha> ci i = Some s \<longrightarrow> s.invar s)"

  lemma ci_impl_minvar: "ci_invar m \<Longrightarrow> m.invar m" by (unfold ci_invar_def) auto

  definition is_index :: "('x \<Rightarrow> 'i) \<Rightarrow> 'x set \<Rightarrow> 'm \<Rightarrow> bool"
  where
    "is_index f s idx == ci_invar idx \<and> ci_\<alpha>' idx = index_map f s"

  lemma is_index_invar: "is_index f s idx \<Longrightarrow> ci_invar idx"
    by (simp add: is_index_def)

  lemma is_index_correct: "is_index f s idx \<Longrightarrow> ci_\<alpha> idx = index f s"
    by (simp only: is_index_def index_map_def ci_\<alpha>_def)
       (simp add: index_map_correct)

  definition lookup :: "'i \<Rightarrow> 'm \<Rightarrow> 's" where
    "lookup i m == case m.lookup i m of None \<Rightarrow> (s.empty ()) | Some s \<Rightarrow> s"

  lemma lookup_invar': "ci_invar m \<Longrightarrow> s.invar (lookup i m)"
    apply (unfold ci_invar_def lookup_def)
    apply (auto split: option.split simp add: m.lookup_correct s.empty_correct)
    done

  lemma lookup_correct:
    assumes I[simp, intro!]: "is_index f s idx"
    shows
      "s.\<alpha> (lookup i idx) = index f s i"
      "s.invar (lookup i idx)"
  proof goal_cases
    case 2 thus ?case using I by (simp add: is_index_def lookup_invar')
  next
    case 1
    have [simp, intro!]: "m.invar idx"
      using ci_impl_minvar[OF is_index_invar[OF I]]
      by simp
    thus ?case
    proof (cases "m.lookup i idx")
      case None
      hence [simp]: "m.\<alpha> idx i = None" by (simp add: m.lookup_correct)
      from is_index_correct[OF I] have "index f s i = ci_\<alpha> idx i" by simp
      also have "\<dots> = {}" by (simp add: ci_\<alpha>_def ci_\<alpha>'_def im_\<alpha>_def)
      finally show ?thesis by (simp add: lookup_def None s.empty_correct)
    next
      case (Some si)
      hence [simp]: "m.\<alpha> idx i = Some si" by (simp add: m.lookup_correct)
      from is_index_correct[OF I] have "index f s i = ci_\<alpha> idx i" by simp
      also have "\<dots> = s.\<alpha> si" by (simp add: ci_\<alpha>_def ci_\<alpha>'_def im_\<alpha>_def)
      finally show ?thesis by (simp add: lookup_def Some s.empty_correct)
    qed
  qed

end

locale build_index_loc = index_loc m_ops s_ops +
  t: StdSet t_ops
  for m_ops :: "('i,'s,'m,'more1) map_ops_scheme"
  and s_ops :: "('x,'s,'more3) set_ops_scheme"
  and t_ops :: "('x,'t,'more2) set_ops_scheme"
begin

  text "Building indices"
  definition idx_build_stepfun :: "('x \<Rightarrow> 'i) \<Rightarrow> 'x \<Rightarrow> 'm \<Rightarrow> 'm" where
    "idx_build_stepfun f x m ==
      let i=f x in
        (case m.lookup i m of
          None \<Rightarrow> m.update i (s.ins x (s.empty ())) m |
          Some s \<Rightarrow> m.update i (s.ins x s) m
      )"

  definition idx_build :: "('x \<Rightarrow> 'i) \<Rightarrow> 't \<Rightarrow> 'm" where
    "idx_build f t == t.iterate t (idx_build_stepfun f) (m.empty ())"

  lemma idx_build_correct:
    assumes I: "t.invar t"
    shows "ci_\<alpha>' (idx_build f t) = index_map f (t.\<alpha> t)" (is ?T1) and
    [simp]: "ci_invar (idx_build f t)" (is ?T2)
  proof -
    have "t.invar t \<Longrightarrow>
      ci_\<alpha>' (idx_build f t) = index_map f (t.\<alpha> t) \<and> ci_invar (idx_build f t)"
      apply (unfold idx_build_def)
      apply (rule_tac
          I="\<lambda>it m. ci_\<alpha>' m = index_map f (t.\<alpha> t - it) \<and> ci_invar m"
          in t.iterate_rule_P)
      apply assumption
      apply (simp add: ci_invar_def m.empty_correct)
      apply (rule ext)
      apply (unfold ci_\<alpha>'_def index_map_def index_def)[1]
      apply (simp add: m.empty_correct)
      defer
      apply simp
      apply (rule conjI)
      defer
      apply (unfold idx_build_stepfun_def)[1]
      apply (auto
        simp add: ci_invar_def m.update_correct m.lookup_correct
                  s.empty_correct s.ins_correct Let_def
        split: option.split) [1]

      apply (rule ext)
    proof goal_cases
      case prems: (1 x it m i)
      hence INV[simp, intro!]: "m.invar m" by (simp add: ci_invar_def)
      from prems have
        INVS[simp, intro]: "!!q s. m.\<alpha> m q = Some s \<Longrightarrow> s.invar s"
        by (simp add: ci_invar_def)

      show ?case proof (cases "i=f x")
        case [simp]: True
        show ?thesis proof (cases "m.\<alpha> m (f x)")
          case [simp]: None
          hence "idx_build_stepfun f x m = m.update i (s.ins x (s.empty ())) m"
            apply (unfold idx_build_stepfun_def)
            apply (simp add: m.update_correct m.lookup_correct s.empty_correct)
            done
          hence "ci_\<alpha>' (idx_build_stepfun f x m) i = Some {x}"
            by (simp add: m.update_correct
                          s.ins_correct s.empty_correct ci_\<alpha>'_def)
          also {
            have "None = ci_\<alpha>' m (f x)"
              by (simp add: ci_\<alpha>'_def)
            also from prems(4) have "\<dots> = index_map f (t.\<alpha> t - it) i" by simp
            finally have E: "{xa \<in> t.\<alpha> t - it. f xa = i} = {}"
              by (simp add: index_map_def index_def split: if_split_asm)
            moreover have
              "{xa \<in> t.\<alpha> t - (it - {x}). f xa = i}
               = {xa \<in> t.\<alpha> t - it. f xa = i} \<union> {x}"
              using prems(2,3) by auto
            ultimately have "Some {x} = index_map f (t.\<alpha> t - (it - {x})) i"
              by (unfold index_map_def index_def) auto
          } finally show ?thesis .
        next
          case [simp]: (Some ss)
          hence [simp, intro!]: "s.invar ss" by (simp del: Some)
          hence "idx_build_stepfun f x m = m.update (f x) (s.ins x ss) m"
            by (unfold idx_build_stepfun_def)
               (simp add: m.update_correct m.lookup_correct)
          hence "ci_\<alpha>' (idx_build_stepfun f x m) i = Some (insert x (s.\<alpha> ss))"
            by (simp add: m.update_correct s.ins_correct ci_\<alpha>'_def)
          also {
              have "Some (s.\<alpha> ss) = ci_\<alpha>' m (f x)"
                by (simp add: ci_\<alpha>'_def)
            also from prems(4) have "\<dots> = index_map f (t.\<alpha> t - it) i" by simp
            finally have E: "{xa \<in> t.\<alpha> t - it. f xa = i} = s.\<alpha> ss"
              by (simp add: index_map_def index_def split: if_split_asm)
            moreover have
              "{xa \<in> t.\<alpha> t - (it - {x}). f xa = i}
               = {xa \<in> t.\<alpha> t - it. f xa = i} \<union> {x}"
              using prems(2,3) by auto
            ultimately have
              "Some (insert x (s.\<alpha> ss)) = index_map f (t.\<alpha> t - (it - {x})) i"
              by (unfold index_map_def index_def) auto
          }
          finally show ?thesis .
        qed
      next
        case False hence C: "i\<noteq>f x" "f x\<noteq>i" by simp_all
        have "ci_\<alpha>' (idx_build_stepfun f x m) i = ci_\<alpha>' m i"
          apply (unfold ci_\<alpha>'_def idx_build_stepfun_def)
          apply (simp
            split: option.split_asm option.split
            add: Let_def m.lookup_correct m.update_correct
                 s.ins_correct s.empty_correct C)
          done
        also from prems(4) have "ci_\<alpha>' m i = index_map f (t.\<alpha> t - it) i"
          by simp
        also have
          "{xa \<in> t.\<alpha> t - (it - {x}). f xa = i} = {xa \<in> t.\<alpha> t - it. f xa = i}"
          using prems(2,3) C by auto
        hence "index_map f (t.\<alpha> t - it) i = index_map f (t.\<alpha> t - (it-{x})) i"
          by (unfold index_map_def index_def) simp
        finally show ?thesis .
      qed
    qed
    with I show ?T1 ?T2 by auto
  qed

  lemma idx_build_is_index:
    "t.invar t \<Longrightarrow> is_index f (t.\<alpha> t) (idx_build f t)"
    by (simp add: idx_build_correct index_map_correct ci_\<alpha>_def is_index_def)

end

end


text\<open> 8 October 2021: Exercise for Homework Assignment 06 in CS 511 \<close>
text\<open> Your task to remove the invocation of the pre-defined method blast,
      by an equivalent sequence of 'apply' steps \<close>
text\<open> This is a continuation of the Isabelle exercise you did for
      Homework Assignment 05, and inspired by the exercise on page 32
      in Lecture Slides 11 "Quantified Propositional Logic" \<close>

theory HW06_solution
  imports Main
begin

(* The following is a theorem of QPL. Note that "=" means the same as "\<longleftrightarrow>" *)
theorem "(\<exists>y. (y = Phi) \<and> (y \<or> Psi1) \<and> (y \<or> Psi2)) \<longleftrightarrow> (Phi \<or> Psi1) \<and> (Phi \<or> Psi2)"
	apply(rule iffI)
	 apply (erule exE)
	 apply(erule conjE)+
	apply (erule disjE)+
		 apply (erule iffE)+
		 apply (erule impE)
		  apply assumption
		 apply (rule conjI)
		  apply(rule disjI1)
		  apply assumption
		 apply (rule disjI1)
		 apply assumption
		apply (erule iffE)
		apply (erule impE)
		 apply assumption
		apply (rule conjI)
		 apply (rule disjI1)
		 apply assumption
		apply (rule disjI1)
		apply assumption
	 apply (rule conjI)
	  apply (rule disjI2)
	  apply assumption
	 apply (erule disjE)
	  apply(erule iffE)
	  apply (erule impE)
	   apply assumption
	  apply(rule disjI1)
	  apply assumption
	 apply (rule disjI2)
	 apply assumption
	apply (erule conjE)
	apply (erule disjE)
	 apply (rule exI)
	 apply (rule conjI)
	  apply (rule iffI)
	   apply assumption
	  apply assumption
	 apply (erule disjE)
	  apply (rule conjI)
	   apply (rule disjI1)+
	   apply assumption
	  apply (rule disjI1)+
	  apply assumption
	 apply (rule conjI)
	  apply (rule disjI1)+
	  apply assumption
	 apply (rule disjI1)+
	 apply assumption
	 apply(rule exI)
	 apply(rule conjI)
	  apply (rule iffI)
	   apply assumption+
	apply (rule conjI)
	 apply (erule disjE)
	  apply (rule disjI1)
	  apply assumption
	 apply (rule disjI2)
	 apply assumption
	apply (erule disjE)
	 apply (rule disjI1)
	 apply assumption
	apply (rule disjI2)
	apply assumption
  done
end


(*  Title:      statecharts/CTL/Kripke.thy

    Author:     Steffen Helke, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

header {* Kripke Structures and CTL *}
theory Kripke
imports Main
begin

definition
  Kripke :: "['s set,
              's set,
              ('s * 's) set,
              ('s ~=> 'a set)]
             => bool" where

  "Kripke S S0 R L =
                (S0 \<subseteq> S \<and>
                 R <= S \<times> S \<and>
                 (Domain R) = S \<and>
                 (dom L) = S)"

lemma Kripke_EmptySet:
 "({@x. True}, {@x. True},{(@x. True, @x. True)}, empty(@x. True \<mapsto> {@x. True})) \<in>
   {(S,S0,R,L) | S S0 R L. Kripke S S0 R L}"
by (unfold Kripke_def Domain_unfold, auto)

definition
  "kripke =
    {(S,S0,T,L) |
        (S::('s set))
        (S0::('s set))
        (T::(('s * 's) set))
        (L::('s ~=> ('a  set))).
                      Kripke S S0 T L}"

typedef ('s,'a) kripke =
    "kripke :: ('s set * 's set * ('s * 's) set * ('s ~=> 'a set)) set"
  unfolding kripke_def
  apply (rule exI)
  apply (rule Kripke_EmptySet)
  done

definition
  Statuses :: "('s,'a) kripke => 's set" where
  "Statuses = fst o Rep_kripke"

definition
   InitStatuses :: "('s,'a) kripke  => 's set" where
  "InitStatuses == fst o snd o Rep_kripke"

definition
   StepRel :: "('s,'a) kripke => ('s * 's) set" where
  "StepRel == fst o snd o snd o Rep_kripke"

definition
   LabelFun :: "('s,'a) kripke => ('s ~=> 'a set)" where
  "LabelFun == snd o snd o snd o Rep_kripke"

definition
   Paths :: "[('s,'a) kripke, 's] =>
             (nat => 's) set" where
  "Paths M S == { p . S = p (0::nat) \<and> (ALL i. (p i, p (i+1)) \<in> (StepRel M))}"

datatype ('s,'a) ctl =  Atom "'a"
                          | AND "('s,'a) ctl" "('s,'a) ctl"
                          | OR  "('s,'a) ctl" "('s,'a) ctl"
                          | IMPLIES "('s,'a) ctl" "('s,'a) ctl"
                          | CAX "('s,'a) ctl"
                          | AF  "('s,'a) ctl"
                          | AG  "('s,'a) ctl"
                          | AU  "('s,'a) ctl" "('s,'a) ctl"
                          | AR  "('s,'a) ctl" "('s,'a) ctl"

primrec
   eval_ctl :: "[('s,'a) kripke, 's, ('s,'a) ctl] => bool"  ("_,_ |=c= _" [92,91,90]90)
   where
     "(M,S |=c= (Atom P))        = (P \<in> the ((LabelFun M) S))"
   | "(M,S |=c= (AND F1 F2))     = ((M,S |=c= F1) \<and> (M,S |=c= F2))"
   | "(M,S |=c= (OR F1 F2))      = ((M,S |=c= F1) \<or> (M,S |=c= F2))"
   | "(M,S |=c= (IMPLIES F1 F2)) = ((M,S |=c= F1) \<longrightarrow> (M,S |=c= F2))"
   | "(M,S |=c= (CAX F))         = (\<forall> T. (S,T) \<in> (StepRel M) \<longrightarrow> (M,T |=c= F))"
   | "(M,S |=c= (AF F))          = (\<forall> P \<in> Paths M S. \<exists> i. (M,(P i) |=c= F))"
   | "(M,S |=c= (AG F))          = (\<forall> P \<in> Paths M S. \<forall> i. (M,(P i) |=c= F))"
   | "(M,S |=c= (AU F G))        = (\<forall> P \<in> Paths M S.
                                     \<exists> i. (M,(P i) |=c= G) \<and>
                                       (\<forall> j. j < i \<longrightarrow> (M,(P j) |=c= F)))"
   | "(M,S |=c= (AR F G))        = (\<forall> P \<in> Paths M S.
                                     \<forall> i. (M,(P i) |=c= G) \<or>
                                       (\<exists> j. j < i \<and> (M,(P j) |=c= F)))"

end


theory Listi
imports Main
        Naturals
begin

datatype NL = Nil | Cons Nat NL
datatype 'a List = LNil | LCons 'a "'a List"

fun len :: "NL \<Rightarrow> Nat" where
  "len Nil = Z"
| "len (Cons _ as) = S (len as)"

fun app :: "NL \<Rightarrow> NL \<Rightarrow> NL" where
  "app Nil         ts = ts"
| "app (Cons r rs) ts = Cons r (app rs ts)"

fun rev :: "NL \<Rightarrow> NL" where
  "rev Nil = Nil"
| "rev (Cons r ts) = app (rev ts) (Cons r Nil)"

fun qrev :: "NL \<Rightarrow> NL \<Rightarrow> NL" where
  "qrev Nil         a = a"
| "qrev (Cons b bs) a = qrev bs (Cons b a)"

fun take :: "Nat \<Rightarrow> NL \<Rightarrow> NL" where
  "take Z     _           = Nil"
| "take _     Nil         = Nil"
| "take (S n) (Cons t ts) = Cons t (take n ts)"

fun drop :: "Nat \<Rightarrow> NL \<Rightarrow> NL" where
  "drop Z     ts          = ts"
| "drop _     Nil         = Nil"
| "drop (S n) (Cons t ts) = drop n ts"

fun count :: "Nat \<Rightarrow> NL \<Rightarrow> Nat" where
  "count _ Nil = Z"
| "count n (Cons t ts) = (if eqN n t then S (count n ts) else count n ts)"

fun elem :: "Nat \<Rightarrow> NL \<Rightarrow> bool" where
  "elem _ Nil = False"
| "elem r (Cons t ts) = (if eqN r t then True else elem r ts)"

(* maybe remove *)
fun head :: "NL \<Rightarrow> Nat" where
  "head (Cons t _) = t"

fun last :: "NL \<Rightarrow> Nat" where
  "last (Cons t Nil) = t"
| "last (Cons _ ts)  = last ts"
(* till here (?) *)

fun init :: "NL \<Rightarrow> NL" where
  "init Nil          = Nil"
| "init (Cons _ Nil) = Nil"
| "init (Cons t ts)  = Cons t (init ts)"

fun tail :: "NL \<Rightarrow> NL" where
  "tail Nil         = Nil"
| "tail (Cons _ ts) = ts"

fun maps :: "(Nat \<Rightarrow> Nat) \<Rightarrow> NL \<Rightarrow> NL" where
  "maps _ Nil = Nil"
| "maps f (Cons a as) = Cons (f a) (maps f as)"

fun zip :: "NL \<Rightarrow> NL \<Rightarrow> (Nat * Nat) List" where
  "zip Nil _   = LNil"
| "zip _   Nil = LNil"
| "zip (Cons t ts) (Cons r rs) = LCons (t,r) (zip ts rs)"

fun notNil :: "NL \<Rightarrow> bool" where
  "notNil Nil = False"
| "notNil _   = True"

fun null2:: "NL \<Rightarrow> bool" where
  "null2 Nil = True"
| "null2 _   = False"

fun rotate :: "Nat \<Rightarrow> NL \<Rightarrow> NL" where
  "rotate Z     xs          = xs"
| "rotate (S n) (Cons x xs) = rotate n (app xs (Cons x Nil))"
| "rotate n     Nil         = Nil"

fun intersperse :: "Nat \<Rightarrow> NL \<Rightarrow> NL" where
  "intersperse x Nil = Nil"
| "intersperse x (Cons y Nil) = Cons y Nil"
| "intersperse x (Cons y ys) = Cons y (Cons x (intersperse x ys))"

fun insert :: "Nat \<Rightarrow> NL \<Rightarrow> NL" where
  "insert r Nil         = Cons r Nil"
| "insert r (Cons t ts) = (if leq r t then Cons r (Cons t ts) else (Cons t (insert r ts)))"

(*hipster drop take app*)

(*hipster_cond notNil tail app*)

fun id :: "'a \<Rightarrow> 'a" where "id x = x"
fun remDrop :: "Nat \<Rightarrow> NL \<Rightarrow> Nat" where "remDrop n ts = len (drop n ts)"

lemma example : "len b = len a \<Longrightarrow> app (zip a b) (zip c d) = zip (app a c) (app b d)"
apply(induction a b  rule: zip.induct)
apply (simp_all)
by (metis Nat.distinct(1) app.simps(1) len.simps(2) List.exhaust)

lemma eg2 : "leq (S n) (len ts) \<Longrightarrow> (drop n ts) \<noteq> Nil"
apply (induction n ts rule: drop.induct)
apply simp_all
oops

ML \<open>
fun inductable_things_in_term thry t =
    let val _ = @{print} (Hipster_Utils.frees_of t)
        val _ = @{print} (Term.strip_all_vars t)
        fun lookup thy s = case (Datatype.get_info thy s) of
               NONE => NONE
             | SOME di => SOME (#induct di);
      fun datatype_chk (Type(tn,_)) = Basics.is_some (lookup thry tn)
        | datatype_chk _ = false;
    in List.partition (datatype_chk o snd) ((Hipster_Utils.frees_of t) @ (Term.strip_all_vars t)) end;

  val prop = @{term "len b = len a \<Longrightarrow> app (zip a b) (zip c d) = zip (app a c) (app b d)"};
  val th' = (Goal.init o (Thm.cterm_of @{theory})) ((Syntax.read_prop @{context}) "len b = len a \<Longrightarrow> app (zip a b) (zip c d) = zip (app a c) (app b d)");

  inductable_things_in_term @{theory} prop;
  fun reP uu = case uu of
        Var (_,t)       => (*let val _ = @{print} "Var" in t end*) t
      | (t$_)           => (*let val _ = @{print} "$" in reP t end*) reP t
      | (Abs (_, t, _)) => (*let val _ = @{print} "Abs" in t end*) t
      | (Free (_, t))   => t; (* TODO: Bound, Const *)

  @{thm "drop.induct"};
  (Thm.concl_of @{thm "drop.induct"});
  (HOLogic.dest_Trueprop (Thm.concl_of @{thm "drop.induct"}));
  @{term "case x of 0 \<Rightarrow> 0 | Suc y \<Rightarrow> y"};
  @{term "P y x"};
  (reP(HOLogic.dest_Trueprop (Thm.concl_of @{thm "drop.induct"})));
  val ump = binder_types (reP(HOLogic.dest_Trueprop (Thm.concl_of @{thm "drop.induct"})));
  val tumf = fastype_of @{term "Cons Z Nil"};
  hd (tl ump) = tumf;
  fastype_of1 ([],@{term "Cons Z Nil"});
  Type.could_match(hd (tl ump), tumf);
\<close>

ML \<open>
  val rdrop = @{thm "drop.induct"}
  val eg2 = @{term "leq (S n) (len ts) \<Longrightarrow> (drop n ts) \<noteq> Nil"}
  val th2 = (Goal.init o (Thm.cterm_of @{theory})) ((Syntax.read_prop @{context}) "leq (S n) (len ts) \<Longrightarrow> (drop n ts) \<noteq> Nil")
  fun argTyps r = binder_types (reP (HOLogic.dest_Trueprop (Thm.concl_of ( r)))) (* types of pred P args *)
  (*val _ = @{print} (prems_of th')
  val _ = @{print} (length (prems_of @{thm "len.induct"}));
  val _ = @{print}((concl_of th'));
  val bist = fst (inductable_things_in_term (Thm.theory_of_thm th') (concl_of th'))*)
  val vars = fst (inductable_things_in_term (Thm.theory_of_thm th') (Library.nth (prems_of th') 0))
  val _ = @{print} vars
  fun ruleVars r  vs = map fst (filter (fn v => exists (fn tr => Type.could_match (tr,snd v)) (argTyps r)) vs)
  fun filter_matching t vs = filter (fn v => Type.could_match (t, snd v)) vs
  fun rulSss r = map (fn t => filter_matching t vars) (argTyps r)
  fun ruleSets r vs = map (fn rv => filter (fn av => Type.could_unify (rv, snd av)) vs) (argTyps r)
  fun paired [] = []
    | paired (v::vs) = map (fn w => [v,w]) vs @ paired vs
  val indvars = map (fn v => [v]) (ruleVars rdrop vars) @ paired (ruleVars rdrop vars)
  fun nonreptup [] = []
    | nonreptup (vs:: vss) = fold (fn v => fn acc => acc @ (map (fn ts => v::ts) (nonreptup (map (filter (fn t => not (v = t))) vss)))) vs [] @ nonreptup vss
  fun instance_rule (vs::vss) (_::ts) = List.concat (map (fn v => [v] :: map (fn stuff => v::stuff) (instance_rule vss ts)) vs)
    | instance_rule _ _ = []
  val nonrepR = nonreptup (ruleSets rdrop vars);
  ruleSets rdrop vars;
  ruleSets @{thm "zip.induct"} vars;
  ruleSets @{thm "app.induct"} vars;
  val vs2 = fst (inductable_things_in_term (Thm.theory_of_thm th2) (Library.nth (prems_of th2) 0));
  ruleSets rdrop vs2;
  val instanceDrop = instance_rule (ruleSets rdrop vs2) (argTyps rdrop);
  val instanceZip = instance_rule (ruleSets @{thm "zip.induct"} vars) (argTyps @{thm "zip.induct"});
  val instanceApp = instance_rule (ruleSets @{thm "app.induct"} vars) (argTyps @{thm "app.induct"});
  ruleSets @{thm "maps.induct"} vs2;

  fun var_typ_ord ((x,t1),(y,t2)) =
       (case fast_string_ord (x,y) of
          EQUAL => (if Term_Ord.typ_ord (t1,t2) = EQUAL then EQUAL else raise Type.TYPE_MATCH)
        | LESS => LESS
        | GREATER => GREATER)

  val merge_n_instances = fold (fn ws => fn bss => Ord_List.insert (dict_ord var_typ_ord) ws bss)
(*Ord_List.insert Term_Ord.term_ord t frees*) (*| indexBins v [[[]]] = [[[v]], [[]]]*)
  fun index_bins v (bin1s::bin0s::binss) =
        let val new1s = map (fn is0 => is0@[v] (*v::is0*)) bin0s
            val all1s = merge_n_instances new1s bin1s (*fold (fn ws => fn bss => Ord_List.insert (dict_ord var_typ_ord) ws bss) new1s bin1s*)
        in
           all1s :: index_bins v (bin0s::binss)
        end
    | index_bins _ [[[]]] = [[[]]]
    | index_bins _ _ = [];
  index_bins (hd vs2) ([]::(index_bins (hd vs2) [[], [[]]]));

  fun zipWith f xs ys = ListPair.foldr (fn (a, b, cs) => f(a, b)::cs) [] (xs, ys)
  val tesz = zipWith (op +) [1,2,3] [1,2];

  fun merge_bins xss yss = zipWith (fn (xs,ys) => merge_n_instances ys xs) xss yss (*(xs::xss) (ys::yss) = (xs@ys)::merge_bins xss yss*)

  fun foldl1 _ nil = raise Empty
    | foldl1 f (x::xs) = fold f xs x

  fun fix_nth_arg (t::ts) xs bins =
        let fun update_types v = map (fn t' => if Term_Ord.typ_ord (t,t') = EQUAL then snd v else t') ts
            fun into_bins v = index_bins v ([]::bins)
            val vars = filter (fn v => Type.could_match (t, snd v)) xs
            val all_bins = map (fn v => fix_nth_arg (update_types v) xs (into_bins v)) vars
       in if null all_bins then fix_nth_arg ts xs bins else foldl1 merge_bins all_bins end
    | fix_nth_arg [] _ bins = bins

  val tesq = fix_nth_arg (argTyps rdrop) vs2 [[[]]]
  val tesz = fix_nth_arg (argTyps @{thm "zip.induct"}) (vars) [[[]]];
  val tesa = fix_nth_arg (argTyps @{thm "app.induct"}) (vars) [[[]]];
  length tesz;
  length (nth tesz 0);
  val tesm = fix_nth_arg (argTyps @{thm "maps.induct"}) (vars) [[[]]];

\<close>

end


(*  Title:    HOL/Analysis/Generalised_Binomial_Theorem.thy
    Author:   Manuel Eberl, TU München
*)

section \<open>Generalised Binomial Theorem\<close>

text \<open>
  The proof of the Generalised Binomial Theorem and related results.
  We prove the generalised binomial theorem for complex numbers, following the proof at:
  \<^url>\<open>https://proofwiki.org/wiki/Binomial_Theorem/General_Binomial_Theorem\<close>
\<close>

theory Generalised_Binomial_Theorem
imports
  Complex_Main
  Complex_Transcendental
  Summation_Tests
begin

lemma gbinomial_ratio_limit:
  fixes a :: "'a :: real_normed_field"
  assumes "a \<notin> \<nat>"
  shows "(\<lambda>n. (a gchoose n) / (a gchoose Suc n)) \<longlonglongrightarrow> -1"
proof (rule Lim_transform_eventually)
  let ?f = "\<lambda>n. inverse (a / of_nat (Suc n) - of_nat n / of_nat (Suc n))"
  from eventually_gt_at_top[of "0::nat"]
    show "eventually (\<lambda>n. ?f n = (a gchoose n) /(a gchoose Suc n)) sequentially"
  proof eventually_elim
    fix n :: nat assume n: "n > 0"
    then obtain q where q: "n = Suc q" by (cases n) blast
    let ?P = "\<Prod>i=0..<n. a - of_nat i"
    from n have "(a gchoose n) / (a gchoose Suc n) = (of_nat (Suc n) :: 'a) *
                   (?P / (\<Prod>i=0..n. a - of_nat i))"
      by (simp add: gbinomial_prod_rev atLeastLessThanSuc_atLeastAtMost)
    also from q have "(\<Prod>i=0..n. a - of_nat i) = ?P * (a - of_nat n)"
      by (simp add: prod.atLeast0_atMost_Suc atLeastLessThanSuc_atLeastAtMost)
    also have "?P / \<dots> = (?P / ?P) / (a - of_nat n)" by (rule divide_divide_eq_left[symmetric])
    also from assms have "?P / ?P = 1" by auto
    also have "of_nat (Suc n) * (1 / (a - of_nat n)) =
                   inverse (inverse (of_nat (Suc n)) * (a - of_nat n))" by (simp add: field_simps)
    also have "inverse (of_nat (Suc n)) * (a - of_nat n) = a / of_nat (Suc n) - of_nat n / of_nat (Suc n)"
      by (simp add: field_simps del: of_nat_Suc)
    finally show "?f n = (a gchoose n) / (a gchoose Suc n)" by simp
  qed

  have "(\<lambda>n. norm a / (of_nat (Suc n))) \<longlonglongrightarrow> 0"
    unfolding divide_inverse
    by (intro tendsto_mult_right_zero LIMSEQ_inverse_real_of_nat)
  hence "(\<lambda>n. a / of_nat (Suc n)) \<longlonglongrightarrow> 0"
    by (subst tendsto_norm_zero_iff[symmetric]) (simp add: norm_divide del: of_nat_Suc)
  hence "?f \<longlonglongrightarrow> inverse (0 - 1)"
    by (intro tendsto_inverse tendsto_diff LIMSEQ_n_over_Suc_n) simp_all
  thus "?f \<longlonglongrightarrow> -1" by simp
qed

lemma conv_radius_gchoose:
  fixes a :: "'a :: {real_normed_field,banach}"
  shows "conv_radius (\<lambda>n. a gchoose n) = (if a \<in> \<nat> then \<infinity> else 1)"
proof (cases "a \<in> \<nat>")
  assume a: "a \<in> \<nat>"
  have "eventually (\<lambda>n. (a gchoose n) = 0) sequentially"
    using eventually_gt_at_top[of "nat \<lfloor>norm a\<rfloor>"]
    by eventually_elim (insert a, auto elim!: Nats_cases simp: binomial_gbinomial[symmetric])
  from conv_radius_cong'[OF this] a show ?thesis by simp
next
  assume a: "a \<notin> \<nat>"
  from tendsto_norm[OF gbinomial_ratio_limit[OF this]]
    have "conv_radius (\<lambda>n. a gchoose n) = 1"
    by (intro conv_radius_ratio_limit_nonzero[of _ 1]) (simp_all add: norm_divide)
  with a show ?thesis by simp
qed

theorem gen_binomial_complex:
  fixes z :: complex
  assumes "norm z < 1"
  shows   "(\<lambda>n. (a gchoose n) * z^n) sums (1 + z) powr a"
proof -
  define K where "K = 1 - (1 - norm z) / 2"
  from assms have K: "K > 0" "K < 1" "norm z < K"
     unfolding K_def by (auto simp: field_simps intro!: add_pos_nonneg)
  let ?f = "\<lambda>n. a gchoose n" and ?f' = "diffs (\<lambda>n. a gchoose n)"
  have summable_strong: "summable (\<lambda>n. ?f n * z ^ n)" if "norm z < 1" for z using that
    by (intro summable_in_conv_radius) (simp_all add: conv_radius_gchoose)
  with K have summable: "summable (\<lambda>n. ?f n * z ^ n)" if "norm z < K" for z using that by auto
  hence summable': "summable (\<lambda>n. ?f' n * z ^ n)" if "norm z < K" for z using that
    by (intro termdiff_converges[of _ K]) simp_all

  define f f' where [abs_def]: "f z = (\<Sum>n. ?f n * z ^ n)" "f' z = (\<Sum>n. ?f' n * z ^ n)" for z
  {
    fix z :: complex assume z: "norm z < K"
    from summable_mult2[OF summable'[OF z], of z]
      have summable1: "summable (\<lambda>n. ?f' n * z ^ Suc n)" by (simp add: mult_ac)
    hence summable2: "summable (\<lambda>n. of_nat n * ?f n * z^n)"
      unfolding diffs_def by (subst (asm) summable_Suc_iff)

    have "(1 + z) * f' z = (\<Sum>n. ?f' n * z^n) + (\<Sum>n. ?f' n * z^Suc n)"
      unfolding f_f'_def using summable' z by (simp add: algebra_simps suminf_mult)
    also have "(\<Sum>n. ?f' n * z^n) = (\<Sum>n. of_nat (Suc n) * ?f (Suc n) * z^n)"
      by (intro suminf_cong) (simp add: diffs_def)
    also have "(\<Sum>n. ?f' n * z^Suc n) = (\<Sum>n. of_nat n * ?f n * z ^ n)"
      using summable1 suminf_split_initial_segment[OF summable1] unfolding diffs_def
      by (subst suminf_split_head, subst (asm) summable_Suc_iff) simp_all
    also have "(\<Sum>n. of_nat (Suc n) * ?f (Suc n) * z^n) + (\<Sum>n. of_nat n * ?f n * z^n) =
                 (\<Sum>n. a * ?f n * z^n)"
      by (subst gbinomial_mult_1, subst suminf_add)
         (insert summable'[OF z] summable2,
          simp_all add: summable_powser_split_head algebra_simps diffs_def)
    also have "\<dots> = a * f z" unfolding f_f'_def
      by (subst suminf_mult[symmetric]) (simp_all add: summable[OF z] mult_ac)
    finally have "a * f z = (1 + z) * f' z" by simp
  } note deriv = this

  have [derivative_intros]: "(f has_field_derivative f' z) (at z)" if "norm z < of_real K" for z
    unfolding f_f'_def using K that
    by (intro termdiffs_strong[of "?f" K z] summable_strong) simp_all
  have "f 0 = (\<Sum>n. if n = 0 then 1 else 0)" unfolding f_f'_def by (intro suminf_cong) simp
  also have "\<dots> = 1" using sums_single[of 0 "\<lambda>_. 1::complex"] unfolding sums_iff by simp
  finally have [simp]: "f 0 = 1" .

  have "\<exists>c. \<forall>z\<in>ball 0 K. f z * (1 + z) powr (-a) = c"
  proof (rule has_field_derivative_zero_constant)
    fix z :: complex assume z': "z \<in> ball 0 K"
    hence z: "norm z < K" by simp
    with K have nz: "1 + z \<noteq> 0" by (auto dest!: minus_unique)
    from z K have "norm z < 1" by simp
    hence "(1 + z) \<notin> \<real>\<^sub>\<le>\<^sub>0" by (cases z) (auto simp: Complex_eq complex_nonpos_Reals_iff)
    hence "((\<lambda>z. f z * (1 + z) powr (-a)) has_field_derivative
              f' z * (1 + z) powr (-a) - a * f z * (1 + z) powr (-a-1)) (at z)" using z
      by (auto intro!: derivative_eq_intros)
    also from z have "a * f z = (1 + z) * f' z" by (rule deriv)
    finally show "((\<lambda>z. f z * (1 + z) powr (-a)) has_field_derivative 0) (at z within ball 0 K)"
      using nz by (simp add: field_simps powr_diff at_within_open[OF z'])
  qed simp_all
  then obtain c where c: "\<And>z. z \<in> ball 0 K \<Longrightarrow> f z * (1 + z) powr (-a) = c" by blast
  from c[of 0] and K have "c = 1" by simp
  with c[of z] have "f z = (1 + z) powr a" using K
    by (simp add: powr_minus field_simps dist_complex_def)
  with summable K show ?thesis unfolding f_f'_def by (simp add: sums_iff)
qed

lemma gen_binomial_complex':
  fixes x y :: real and a :: complex
  assumes "\<bar>x\<bar> < \<bar>y\<bar>"
  shows   "(\<lambda>n. (a gchoose n) * of_real x^n * of_real y powr (a - of_nat n)) sums
               of_real (x + y) powr a" (is "?P x y")
proof -
  {
    fix x y :: real assume xy: "\<bar>x\<bar> < \<bar>y\<bar>" "y \<ge> 0"
    hence "y > 0" by simp
    note xy = xy this
    from xy have "(\<lambda>n. (a gchoose n) * of_real (x / y) ^ n) sums (1 + of_real (x / y)) powr a"
        by (intro gen_binomial_complex) (simp add: norm_divide)
    hence "(\<lambda>n. (a gchoose n) * of_real (x / y) ^ n * y powr a) sums
               ((1 + of_real (x / y)) powr a * y powr a)"
      by (rule sums_mult2)
    also have "(1 + complex_of_real (x / y)) = complex_of_real (1 + x/y)" by simp
    also from xy have "\<dots> powr a * of_real y powr a = (\<dots> * y) powr a"
      by (subst powr_times_real[symmetric]) (simp_all add: field_simps)
    also from xy have "complex_of_real (1 + x / y) * complex_of_real y = of_real (x + y)"
      by (simp add: field_simps)
    finally have "?P x y" using xy by (simp add: field_simps powr_diff powr_nat)
  } note A = this

  show ?thesis
  proof (cases "y < 0")
    assume y: "y < 0"
    with assms have xy: "x + y < 0" by simp
    with assms have "\<bar>-x\<bar> < \<bar>-y\<bar>" "-y \<ge> 0" by simp_all
    note A[OF this]
    also have "complex_of_real (-x + -y) = - complex_of_real (x + y)" by simp
    also from xy assms have "... powr a = (-1) powr -a * of_real (x + y) powr a"
      by (subst powr_neg_real_complex) (simp add: abs_real_def split: if_split_asm)
    also {
      fix n :: nat
      from y have "(a gchoose n) * of_real (-x) ^ n * of_real (-y) powr (a - of_nat n) =
                       (a gchoose n) * (-of_real x / -of_real y) ^ n * (- of_real y) powr a"
        by (subst power_divide) (simp add: powr_diff powr_nat)
      also from y have "(- of_real y) powr a = (-1) powr -a * of_real y powr a"
        by (subst powr_neg_real_complex) simp
      also have "-complex_of_real x / -complex_of_real y = complex_of_real x / complex_of_real y"
        by simp
      also have "... ^ n = of_real x ^ n / of_real y ^ n" by (simp add: power_divide)
      also have "(a gchoose n) * ... * ((-1) powr -a * of_real y powr a) =
                   (-1) powr -a * ((a gchoose n) * of_real x ^ n * of_real y powr (a - n))"
        by (simp add: algebra_simps powr_diff powr_nat)
      finally have "(a gchoose n) * of_real (- x) ^ n * of_real (- y) powr (a - of_nat n) =
                      (-1) powr -a * ((a gchoose n) * of_real x ^ n * of_real y powr (a - of_nat n))" .
    }
    note sums_cong[OF this]
    finally show ?thesis by (simp add: sums_mult_iff)
  qed (insert A[of x y] assms, simp_all add: not_less)
qed

lemma gen_binomial_complex'':
  fixes x y :: real and a :: complex
  assumes "\<bar>y\<bar> < \<bar>x\<bar>"
  shows   "(\<lambda>n. (a gchoose n) * of_real x powr (a - of_nat n) * of_real y ^ n) sums
               of_real (x + y) powr a"
  using gen_binomial_complex'[OF assms] by (simp add: mult_ac add.commute)

lemma gen_binomial_real:
  fixes z :: real
  assumes "\<bar>z\<bar> < 1"
  shows   "(\<lambda>n. (a gchoose n) * z^n) sums (1 + z) powr a"
proof -
  from assms have "norm (of_real z :: complex) < 1" by simp
  from gen_binomial_complex[OF this]
    have "(\<lambda>n. (of_real a gchoose n :: complex) * of_real z ^ n) sums
              (of_real (1 + z)) powr (of_real a)" by simp
  also have "(of_real (1 + z) :: complex) powr (of_real a) = of_real ((1 + z) powr a)"
    using assms by (subst powr_of_real) simp_all
  also have "(of_real a gchoose n :: complex) = of_real (a gchoose n)" for n
    by (simp add: gbinomial_prod_rev)
  hence "(\<lambda>n. (of_real a gchoose n :: complex) * of_real z ^ n) =
           (\<lambda>n. of_real ((a gchoose n) * z ^ n))" by (intro ext) simp
  finally show ?thesis by (simp only: sums_of_real_iff)
qed

lemma gen_binomial_real':
  fixes x y a :: real
  assumes "\<bar>x\<bar> < y"
  shows   "(\<lambda>n. (a gchoose n) * x^n * y powr (a - of_nat n)) sums (x + y) powr a"
proof -
  from assms have "y > 0" by simp
  note xy = this assms
  from assms have "\<bar>x / y\<bar> < 1" by simp
  hence "(\<lambda>n. (a gchoose n) * (x / y) ^ n) sums (1 + x / y) powr a"
    by (rule gen_binomial_real)
  hence "(\<lambda>n. (a gchoose n) * (x / y) ^ n * y powr a) sums ((1 + x / y) powr a * y powr a)"
    by (rule sums_mult2)
  with xy show ?thesis
    by (simp add: field_simps powr_divide powr_diff powr_realpow)
qed

lemma one_plus_neg_powr_powser:
  fixes z s :: complex
  assumes "norm (z :: complex) < 1"
  shows "(\<lambda>n. (-1)^n * ((s + n - 1) gchoose n) * z^n) sums (1 + z) powr (-s)"
    using gen_binomial_complex[OF assms, of "-s"] by (simp add: gbinomial_minus)

lemma gen_binomial_real'':
  fixes x y a :: real
  assumes "\<bar>y\<bar> < x"
  shows   "(\<lambda>n. (a gchoose n) * x powr (a - of_nat n) * y^n) sums (x + y) powr a"
  using gen_binomial_real'[OF assms] by (simp add: mult_ac add.commute)

lemma sqrt_series':
  "\<bar>z\<bar> < a \<Longrightarrow> (\<lambda>n. ((1/2) gchoose n) * a powr (1/2 - real_of_nat n) * z ^ n) sums
                  sqrt (a + z :: real)"
  using gen_binomial_real''[of z a "1/2"] by (simp add: powr_half_sqrt)

lemma sqrt_series:
  "\<bar>z\<bar> < 1 \<Longrightarrow> (\<lambda>n. ((1/2) gchoose n) * z ^ n) sums sqrt (1 + z)"
  using gen_binomial_real[of z "1/2"] by (simp add: powr_half_sqrt)

end


section \<open>Iteration \label{S:iteration}\<close>

theory Iteration
imports
  Galois_Connections
  CRA
begin

subsection \<open>Possibly infinite iteration\<close>

text \<open>
  Iteration of finite or infinite steps can be defined using a least fixed point.
\<close>

(* hide_fact (open) Random_Sequence.iter_def *)

locale finite_or_infinite_iteration = seq_distrib + upper_galois_connections
begin

definition
  iter :: "'a \<Rightarrow> 'a" ("_\<^sup>\<omega>" [103] 102) (* this can be entered as \sup\circ *)
where
  "c\<^sup>\<omega> \<equiv> lfp (\<lambda> x. nil \<sqinter> c;x)"

lemma iter_step_mono: "mono (\<lambda> x. nil \<sqinter> c;x)"
  by (meson inf_mono order_refl seq_mono_right mono_def)

text \<open>
  This fixed point definition leads to the two core iteration lemmas:
  folding and induction.
\<close>

theorem iter_unfold: "c\<^sup>\<omega> = nil \<sqinter> c;c\<^sup>\<omega>"
  using iter_def iter_step_mono lfp_unfold by auto

lemma iter_induct_nil: "nil \<sqinter> c;x \<sqsubseteq> x \<Longrightarrow> c\<^sup>\<omega> \<sqsubseteq> x"
  by (simp add: iter_def lfp_lowerbound)

lemma iter0: "c\<^sup>\<omega> \<sqsubseteq> nil"
  by (metis iter_unfold sup.orderI sup_inf_absorb)

lemma iter1: "c\<^sup>\<omega> \<sqsubseteq> c"
  by (metis inf_le2 iter0 iter_unfold order.trans seq_mono_right seq_nil_right)

lemma iter2 [simp]: "c\<^sup>\<omega>;c\<^sup>\<omega> = c\<^sup>\<omega>"
proof (rule antisym)
  show "c\<^sup>\<omega>;c\<^sup>\<omega> \<sqsubseteq> c\<^sup>\<omega>" using iter0 seq_mono_right by fastforce
next
  have a: "nil \<sqinter> c;c\<^sup>\<omega>;c\<^sup>\<omega> \<sqsubseteq> nil \<sqinter> c;c\<^sup>\<omega> \<sqinter> c;c\<^sup>\<omega>;c\<^sup>\<omega>"
    by (metis inf_greatest inf_le2 inf_mono iter0 order_refl seq_distrib_left.seq_mono_right seq_distrib_left_axioms seq_nil_right)
  then have b: "\<dots> = c\<^sup>\<omega> \<sqinter> c;c\<^sup>\<omega>;c\<^sup>\<omega>" using iter_unfold by auto
  then have c: "\<dots> = (nil \<sqinter> c;c\<^sup>\<omega>);c\<^sup>\<omega>" by (simp add: inf_seq_distrib)
  thus "c\<^sup>\<omega> \<sqsubseteq> c\<^sup>\<omega>;c\<^sup>\<omega>" using a iter_induct_nil iter_unfold seq_assoc by auto
qed

lemma iter_mono: "c \<sqsubseteq> d \<Longrightarrow> c\<^sup>\<omega> \<sqsubseteq> d\<^sup>\<omega>"
proof -
  assume "c \<sqsubseteq> d"
  then have "nil \<sqinter> c;d\<^sup>\<omega> \<sqsubseteq> d;d\<^sup>\<omega>" by (metis inf.absorb_iff2 inf_left_commute inf_seq_distrib)
  then have "nil \<sqinter> c;d\<^sup>\<omega> \<sqsubseteq> d\<^sup>\<omega>" by (metis inf.bounded_iff inf_sup_ord(1) iter_unfold)
  thus ?thesis by (simp add: iter_induct_nil)
qed

lemma iter_abort: "\<bottom> = nil\<^sup>\<omega>"
  by (simp add: antisym iter_induct_nil)

lemma nil_iter: "\<top>\<^sup>\<omega> = nil"
   by (metis (no_types) inf_top.right_neutral iter_unfold seq_top)
(*
lemma iter_conj_distrib:
  assumes nil: "c \<sqsubseteq> nil"
    and repeat: "c \<sqsubseteq> c ; c"
  shows "c \<iinter> d\<^sup>\<omega> \<sqsubseteq> (c \<iinter> d)\<^sup>\<omega>"
proof (unfold iter_def)
  def F \<equiv> "(\<lambda> x. c \<iinter> x)"
  def G \<equiv> "(\<lambda> x. nil \<sqinter> d;x)"
  def H \<equiv> "(\<lambda> x. nil \<sqinter> ((c \<iinter> d);x))"

  have FG: "F \<circ> G = (\<lambda> x. c \<iinter> (nil \<sqinter> d;x))"  by (metis comp_def F_def G_def)
  have HF: "H \<circ> F = (\<lambda> x. (nil \<sqinter> (c \<iinter> d);(c \<iinter> x)))" by (metis comp_def H_def F_def)

  have "F (lfp G) \<sqsubseteq> lfp H"
  proof (rule fusion_lfp_leq)
    show "mono H" by (simp add: H_def iter_step_mono)
  next
    show "dist_over_sup F" by (simp add: F_def conj_Sup_distrib)
  next
    fix x
    have "c \<iinter> (nil \<sqinter> d;x) = (c \<iinter> nil) \<sqinter> (c \<iinter> d;x)" by (metis inf_conj_distrib conj_commute)
    also have "... \<sqsubseteq> nil \<sqinter> (c \<iinter> d;x)" by (metis conjunction_sup inf_mono_left le_iff_sup nil)
    also have "... \<sqsubseteq> nil \<sqinter> (c;c \<iinter> d;x)" by (metis inf_conj_distrib inf.absorb_iff2 inf_mono_right repeat)
    also have "... \<sqsubseteq> nil \<sqinter> (c \<iinter> d);(c \<iinter> x)" by (meson inf_mono_right sequential_interchange)
    finally show "(F \<circ> G) x \<sqsubseteq> (H \<circ> F) x" by (simp add: FG HF)
  qed

  then show "c \<iinter> lfp(\<lambda>x. nil \<sqinter> d ; x) \<sqsubseteq> lfp (\<lambda>x. nil \<sqinter> (c \<iinter> d) ; x)" using F_def G_def H_def by simp
qed

lemma iter_conj_distrib1: "c\<^sup>\<omega> \<iinter> d\<^sup>\<omega> \<sqsubseteq> (c\<^sup>\<omega> \<iinter> d)\<^sup>\<omega>"
  by (simp add: iter0 iter_conj_distrib)

lemma iter_conj_distrib2: "c\<^sup>\<omega> \<iinter> d\<^sup>\<omega> \<sqsubseteq> (c \<iinter> d)\<^sup>\<omega>"
proof -
  have a: "c\<^sup>\<omega> \<sqsubseteq> c" by (metis iter1)
  have b: "c\<^sup>\<omega> \<iinter> d\<^sup>\<omega> \<sqsubseteq> (c\<^sup>\<omega> \<iinter> d)\<^sup>\<omega>" by (metis iter_conj_distrib1)
  have "c\<^sup>\<omega> \<iinter> d \<sqsubseteq> c \<iinter> d" by (metis a conj_mono order.refl)
  thus ?thesis using a b by (metis refine_trans iter_mono)
qed
*)
end

subsection \<open>Finite iteration\<close>

text \<open>
  Iteration of a finite number of steps (Kleene star) is defined
  using the greatest fixed point.
\<close>

locale finite_iteration = seq_distrib + lower_galois_connections
begin

definition
  fiter :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100)
where
  "c\<^sup>\<star> \<equiv> gfp (\<lambda> x. nil \<sqinter> c;x)"

lemma fin_iter_step_mono: "mono (\<lambda> x. nil \<sqinter> c;x)"
  by (meson inf_mono order_refl seq_mono_right mono_def)

text \<open>
  This definition leads to the two core iteration lemmas:
  folding and induction.
\<close>

lemma fiter_unfold: "c\<^sup>\<star> = nil \<sqinter> c;c\<^sup>\<star>"
  using fiter_def gfp_unfold fin_iter_step_mono by auto

lemma fiter_induct_nil: "x \<sqsubseteq> nil \<sqinter> c;x \<Longrightarrow> x \<sqsubseteq> c\<^sup>\<star>"
  by (simp add: fiter_def gfp_upperbound)

lemma fiter0: "c\<^sup>\<star> \<sqsubseteq> nil"
  by (metis fiter_unfold inf.cobounded1)

lemma fiter1: "c\<^sup>\<star> \<sqsubseteq> c"
  by (metis fiter0 fiter_unfold inf_le2 order.trans seq_mono_right seq_nil_right)

lemma fiter_induct_eq: "c\<^sup>\<star>;d = gfp (\<lambda> x. c;x \<sqinter> d)"
proof -
  define F where "F = (\<lambda> x. x;d)"
  define G where "G = (\<lambda> x. nil \<sqinter> c;x)"
  define H where "H = (\<lambda> x. c;x \<sqinter> d)"

  have FG: "F \<circ> G = (\<lambda> x. c;x;d \<sqinter> d)" by (simp add: F_def G_def comp_def inf_commute inf_seq_distrib)
  have HF: "H \<circ> F = (\<lambda> x. c;x;d \<sqinter> d)" by (metis comp_def seq_assoc H_def F_def)

  have adjoint: "dist_over_inf F" using Inf_seq_distrib F_def by simp
  have monoH: "mono H"
    by (metis H_def inf_mono_left monoI seq_distrib_left.seq_mono_right seq_distrib_left_axioms)
  have monoG: "mono G" by (metis G_def inf_mono_right mono_def seq_mono_right)
  have "\<forall> x. ((F \<circ> G) x = (H \<circ> F) x)" using FG HF by simp
  then have "F (gfp G) = gfp H" using adjoint monoG monoH fusion_gfp_eq by blast
  then have "(gfp (\<lambda> x. nil \<sqinter> c;x));d = gfp (\<lambda> x. c;x \<sqinter> d)" using F_def G_def H_def inf_commute by simp
  thus ?thesis by (metis fiter_def)
qed

theorem fiter_induct: "x \<sqsubseteq> d \<sqinter> c;x \<Longrightarrow> x \<sqsubseteq> c\<^sup>\<star>;d"
proof -
  assume "x \<sqsubseteq> d \<sqinter> c;x"
  then have "x \<sqsubseteq> c;x \<sqinter> d" using inf_commute by simp
  then have "x \<sqsubseteq> gfp (\<lambda> x. c;x \<sqinter> d)" by (simp add: gfp_upperbound)
  thus ?thesis by (metis (full_types) fiter_induct_eq)
qed

lemma fiter2 [simp]: "c\<^sup>\<star>;c\<^sup>\<star> = c\<^sup>\<star>"
proof -
  have lr: "c\<^sup>\<star>;c\<^sup>\<star> \<sqsubseteq> c\<^sup>\<star>" using fiter0 seq_mono_right seq_nil_right by fastforce
  have rl: "c\<^sup>\<star> \<sqsubseteq> c\<^sup>\<star>;c\<^sup>\<star>" by (metis fiter_induct fiter_unfold inf.right_idem order_refl)
  thus ?thesis by (simp add: antisym lr)
qed

lemma fiter3 [simp]: "(c\<^sup>\<star>)\<^sup>\<star> = c\<^sup>\<star>"
  by (metis dual_order.refl fiter0 fiter1 fiter2 fiter_induct inf.commute inf_absorb1 seq_nil_right)

lemma fiter_mono: "c \<sqsubseteq> d \<Longrightarrow> c\<^sup>\<star> \<sqsubseteq> d\<^sup>\<star>"
proof -
  assume "c \<sqsubseteq> d"
  then have "c\<^sup>\<star> \<sqsubseteq> nil \<sqinter> d;c\<^sup>\<star>" by (metis fiter0 fiter1 fiter2 inf.bounded_iff refine_trans seq_mono_left)
  thus ?thesis  by (metis seq_nil_right fiter_induct)
qed

end

subsection \<open>Infinite iteration\<close>

text \<open>
  Iteration of infinite number of steps can be defined
  using a least fixed point.
\<close>

locale infinite_iteration = seq_distrib + lower_galois_connections
begin

definition
  infiter :: "'a  \<Rightarrow> 'a" ("_\<^sup>\<infinity>" [105] 106)
where
  "c\<^sup>\<infinity> \<equiv> lfp (\<lambda> x. c;x)"

lemma infiter_step_mono: "mono (\<lambda> x. c;x)"
  by (meson inf_mono order_refl seq_mono_right mono_def)

text \<open>
  This definition leads to the two core iteration lemmas:
  folding and induction.
\<close>

theorem infiter_unfold: "c\<^sup>\<infinity> = c;c\<^sup>\<infinity>"
  using infiter_def infiter_step_mono lfp_unfold by auto

lemma infiter_induct: "c;x \<sqsubseteq> x \<Longrightarrow> c\<^sup>\<infinity> \<sqsubseteq> x"
  by (simp add: infiter_def lfp_lowerbound)

theorem infiter_unfold_any: "c\<^sup>\<infinity> = (c \<^sup>;^ i) ; c\<^sup>\<infinity>"
proof (induct i)
  case 0
  thus ?case by simp
next
  case (Suc i)
  thus ?case using infiter_unfold seq_assoc seq_power_Suc by auto
qed

lemma infiter_annil: "c\<^sup>\<infinity>;x = c\<^sup>\<infinity>"
proof -
  have "\<forall>a. (\<bottom>::'a) \<sqsubseteq> a"
    by auto
  thus ?thesis
    by (metis (no_types) eq_iff inf.cobounded2 infiter_induct infiter_unfold inf_sup_ord(1) seq_assoc seq_bot weak_seq_inf_distrib seq_nil_right)
qed

end

subsection \<open>Combined iteration\<close>

text \<open>
  The three different iteration operators can be combined to show that
  finite iteration refines finite-or-infinite iteration.
\<close>

locale iteration = finite_or_infinite_iteration + finite_iteration +
                   infinite_iteration
begin

lemma refine_iter: "c\<^sup>\<omega> \<sqsubseteq> c\<^sup>\<star>"
  by (metis seq_nil_right order.refl iter_unfold fiter_induct)

lemma iter_absorption [simp]: "(c\<^sup>\<omega>)\<^sup>\<star> = c\<^sup>\<omega>"
proof (rule antisym)
  show "(c\<^sup>\<omega>)\<^sup>\<star> \<sqsubseteq> c\<^sup>\<omega>" by (metis fiter1)
next
  show "c\<^sup>\<omega> \<sqsubseteq> (c\<^sup>\<omega>)\<^sup>\<star>" by (metis fiter1 fiter_induct inf_left_idem iter2 iter_unfold seq_nil_right sup.cobounded2 sup.orderE sup_commute)
qed

lemma infiter_inf_top: "c\<^sup>\<infinity> = c\<^sup>\<omega> ; \<top>"
proof -
  have lr: "c\<^sup>\<infinity> \<sqsubseteq> c\<^sup>\<omega> ; \<top>"
  proof -
    have "c ; (c\<^sup>\<omega> ; \<top>) = nil ; \<top> \<sqinter> c ; c\<^sup>\<omega> ; \<top>"
      using semigroup.assoc seq.semigroup_axioms by fastforce
    then show ?thesis
      by (metis (no_types) eq_refl finite_or_infinite_iteration.iter_unfold
         finite_or_infinite_iteration_axioms infiter_induct
         seq_distrib_right.inf_seq_distrib seq_distrib_right_axioms)
  qed
  have rl: "c\<^sup>\<omega> ; \<top> \<sqsubseteq> c\<^sup>\<infinity>"
    by (metis inf_le2 infiter_annil infiter_unfold iter_induct_nil seq_mono_left)
  thus ?thesis using antisym_conv lr by blast
qed

lemma infiter_fiter_top:
  shows "c\<^sup>\<infinity> \<sqsubseteq> c\<^sup>\<star> ; \<top>"
  by (metis eq_iff fiter_induct inf_top_left infiter_unfold)

lemma inf_ref_infiter: "c\<^sup>\<omega> \<sqsubseteq> c\<^sup>\<infinity>"
  using infiter_unfold iter_induct_nil by auto

end

end


(*<*)
theory ex11_tmpl
imports
    "HOL-Data_Structures.Leftist_Heap"
begin
(*>*)
text {* \ExerciseSheet{11}{22.~6.~2018} *}

text \<open>
  \Exercise{Insert for Leftist Heap}

  \<^item> Define a function to directly insert an element into a leftist heap.
    Do not construct an intermediate heap like insert via merge does!

  \<^item> Show that your function is correct

  \<^item> Define a timing function for your insert function, and show that it is
    linearly bounded by the rank of the tree.
\<close>

fun lh_insert :: "'a::ord \<Rightarrow> 'a lheap \<Rightarrow> 'a lheap"
  where
  "lh_insert _ _ = undefined"

lemma mset_lh_insert: "mset_tree (lh_insert x t) = mset_tree t + {# x #}"
  sorry

lemma "heap t \<Longrightarrow> heap (lh_insert x t)"
  sorry

lemma "ltree t \<Longrightarrow> ltree (lh_insert x t)"
  sorry

fun t_lh_insert :: "'a::ord \<Rightarrow> 'a lheap \<Rightarrow> nat"
  where
  "t_lh_insert _ _ = undefined"

lemma "t_lh_insert x t \<le> rank t + 1"
  sorry

text \<open>
  \Exercise{Bootstrapping a Priority Queue}

  Given a generic priority queue implementation with
  \<open>O(1)\<close> \<open>empty\<close>, \<open>is_empty\<close> operations, \<open>O(f\<^sub>1 n)\<close> insert,
  and \<open>O(f\<^sub>2 n)\<close> \<open>get_min\<close> and \<open>del_min\<close> operations.

  Derive an implementation with \<open>O(1)\<close> \<open>get_min\<close>, and the
  asymptotic complexities of the other operations unchanged!

  Hint: Store the current minimal element! As you know nothing
    about \<open>f\<^sub>1\<close> and \<open>f\<^sub>2\<close>, you must not use \<open>get_min/del_min\<close>
    in your new \<open>insert\<close> operation, and vice versa!
\<close>

text \<open>For technical reasons, you have to define the new implementations type
      outside the locale!\<close>
datatype ('a,'s) bs_pq = PUT_CONSTRUCTORS_HERE

locale Bs_Priority_Queue =
  orig: Priority_Queue where
    empty = orig_empty and
    is_empty = orig_is_empty and
    insert = orig_insert and
    get_min = orig_get_min and
    del_min = orig_del_min and
    invar = orig_invar and
    mset = orig_mset
  for orig_empty orig_is_empty orig_insert orig_get_min orig_del_min orig_invar
  and orig_mset :: "'s \<Rightarrow> 'a::linorder multiset"
begin
  text \<open>In here, the original implementation is available with the prefix \<open>orig\<close>, e.g. \<close>
  term orig_empty term orig_invar
  thm orig.invar_empty

  definition empty :: "('a,'s) bs_pq"
    where "empty = undefined"

  fun is_empty :: "('a,'s) bs_pq \<Rightarrow> bool"
    where
    "is_empty _ \<longleftrightarrow> undefined"

  fun insert :: "'a \<Rightarrow> ('a,'s) bs_pq \<Rightarrow> ('a,'s) bs_pq"
    where
    "insert _ _ = undefined"

  fun get_min :: "('a,'s) bs_pq \<Rightarrow> 'a"
    where
    "get_min _ = undefined"

  fun del_min :: "('a,'s) bs_pq \<Rightarrow> ('a,'s) bs_pq"
    where
    "del_min _ = undefined"

  fun invar :: "('a,'s) bs_pq \<Rightarrow> bool"
    where
    "invar _ = undefined"

  fun mset :: "('a,'s) bs_pq \<Rightarrow> 'a multiset"
    where
    "mset _ = undefined"

  lemmas [simp] = orig.is_empty orig.mset_get_min orig.mset_del_min
    orig.mset_insert orig.mset_empty
    orig.invar_empty orig.invar_insert orig.invar_del_min

  text \<open>Show that your new implementation satisfies the priority queue interface!\<close>
  sublocale Priority_Queue empty is_empty insert get_min del_min invar mset
    apply unfold_locales
  proof goal_cases
    case 1
    then show ?case sorry
  next
    case (2 q) -- \<open>and so on\<close>
    oops

end

text\<open>
\Homework{Heap}{29.~6.~2018}

A binary tree can be encoded as an array \<open>[a\<^sub>1,...,a\<^sub>n]\<close>, such that
the parent of node \<open>a\<^sub>i\<close> is node \<open>a\<^sub>(\<^sub>i \<^sub>d\<^sub>i\<^sub>v \<^sub>2\<^sub>)\<close>.

Thus, for a heap, each node is greater than or equal to its parent:
\<close>

definition parent :: "nat \<Rightarrow> nat" where "parent i \<equiv> (i+1) div 2 - 1"
definition is_heap :: "'a::linorder list \<Rightarrow> bool"
  where "is_heap h \<equiv> \<forall>i<length h. h!i \<ge> h!parent i"

text \<open>A heap with a single defect at index \<open>j\<close> is characterized as follows:
  The heap property holds for all elements except \<open>j\<close>,
  and the children of \<open>j\<close> must also be greater than their grand-parent.
\<close>
definition is_heap_except :: "nat \<Rightarrow> 'a::linorder list \<Rightarrow> bool" where
  "is_heap_except j h \<equiv>
      (\<forall>i<length h. i\<noteq>j \<longrightarrow> h!i \<ge> h!(parent i))
    \<and> (\<forall>i<length h. parent i = j \<longrightarrow> h!i \<ge> h!(parent j))"

text \<open>
  The function \<open>sift_up\<close> corrects a single defect in a heap by
  iterated swapping of the defect with its parent, until the heap property
  is restored.
\<close>

definition "swap i j h \<equiv> h[i:=h!j, j:=h!i]"

(* Required for termination proof of sift_up *)
lemma parent_less[simp]: "i\<noteq>0 \<Longrightarrow> parent i < i"
  by (auto simp: parent_def)

fun sift_up where
  "sift_up h 0 = h"
| "sift_up h i = (
    if h!i \<ge> h!parent i then h
    else sift_up (swap i (parent i) h) (parent i))"

text \<open>Show that @{const sift_up} restores the heap
  and preserves the multiset of elements in the heap\<close>

lemma sift_up_restore_heap:
  "is_heap_except j h \<Longrightarrow> j<length h \<Longrightarrow> is_heap (sift_up h j)"
  sorry

lemma sift_up_mset: "j<length h \<Longrightarrow> mset (sift_up h j) = mset h"
  sorry

text \<open>For \textbf{3 bonus points}, add an empty, insert, and get-min
  function to the heap implementation, and prove their essential properties.
\<close>

definition emp :: "'a::linorder list" where "emp \<equiv> undefined"
definition get_min :: "'a::linorder list \<Rightarrow> 'a" where "get_min h \<equiv> undefined"
definition ins :: "'a::linorder \<Rightarrow> 'a list \<Rightarrow> 'a list" where "ins x h = undefined"

lemma invar_empty: "is_heap emp" sorry

lemma mset_empty: "mset emp = {#}" sorry

lemma mset_get_min: "is_heap h \<Longrightarrow> mset h \<noteq> {#} \<Longrightarrow> get_min h = Min_mset (mset h)" sorry

lemma invar_ins: "is_heap h \<Longrightarrow> is_heap (ins x h)" sorry

lemma mset_ins: "mset (ins x h) = mset h + {#x#}" sorry

(*<*)
end
(*>*)


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

section \<open>The cpo of disjoint sums\<close>

theory Sum_Cpo
imports HOLCF
begin

subsection \<open>Ordering on sum type\<close>

instantiation sum :: (below, below) below
begin

definition below_sum_def:
  "x \<sqsubseteq> y \<equiv> case x of
         Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> a \<sqsubseteq> b | Inr b \<Rightarrow> False) |
         Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> False | Inr b \<Rightarrow> a \<sqsubseteq> b)"

instance ..
end

lemma Inl_below_Inl [simp]: "Inl x \<sqsubseteq> Inl y \<longleftrightarrow> x \<sqsubseteq> y"
unfolding below_sum_def by simp

lemma Inr_below_Inr [simp]: "Inr x \<sqsubseteq> Inr y \<longleftrightarrow> x \<sqsubseteq> y"
unfolding below_sum_def by simp

lemma Inl_below_Inr [simp]: "\<not> Inl x \<sqsubseteq> Inr y"
unfolding below_sum_def by simp

lemma Inr_below_Inl [simp]: "\<not> Inr x \<sqsubseteq> Inl y"
unfolding below_sum_def by simp

lemma Inl_mono: "x \<sqsubseteq> y \<Longrightarrow> Inl x \<sqsubseteq> Inl y"
by simp

lemma Inr_mono: "x \<sqsubseteq> y \<Longrightarrow> Inr x \<sqsubseteq> Inr y"
by simp

lemma Inl_belowE: "\<lbrakk>Inl a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (cases x, simp_all)

lemma Inr_belowE: "\<lbrakk>Inr a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (cases x, simp_all)

lemmas sum_below_elims = Inl_belowE Inr_belowE

lemma sum_below_cases:
  "\<lbrakk>x \<sqsubseteq> y;
    \<And>a b. \<lbrakk>x = Inl a; y = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R;
    \<And>a b. \<lbrakk>x = Inr a; y = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk>
      \<Longrightarrow> R"
by (cases x, safe elim!: sum_below_elims, auto)

subsection \<open>Sum type is a complete partial order\<close>

instance sum :: (po, po) po
proof
  fix x :: "'a + 'b"
  show "x \<sqsubseteq> x"
    by (induct x, simp_all)
next
  fix x y :: "'a + 'b"
  assume "x \<sqsubseteq> y" and "y \<sqsubseteq> x" thus "x = y"
    by (induct x, auto elim!: sum_below_elims intro: below_antisym)
next
  fix x y z :: "'a + 'b"
  assume "x \<sqsubseteq> y" and "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
    by (induct x, auto elim!: sum_below_elims intro: below_trans)
qed

lemma monofun_inv_Inl: "monofun (\<lambda>p. THE a. p = Inl a)"
by (rule monofunI, erule sum_below_cases, simp_all)

lemma monofun_inv_Inr: "monofun (\<lambda>p. THE b. p = Inr b)"
by (rule monofunI, erule sum_below_cases, simp_all)

lemma sum_chain_cases:
  assumes Y: "chain Y"
  assumes A: "\<And>A. \<lbrakk>chain A; Y = (\<lambda>i. Inl (A i))\<rbrakk> \<Longrightarrow> R"
  assumes B: "\<And>B. \<lbrakk>chain B; Y = (\<lambda>i. Inr (B i))\<rbrakk> \<Longrightarrow> R"
  shows "R"
 apply (cases "Y 0")
  apply (rule A)
   apply (rule ch2ch_monofun [OF monofun_inv_Inl Y])
  apply (rule ext)
  apply (cut_tac j=i in chain_mono [OF Y le0], simp)
  apply (erule Inl_belowE, simp)
 apply (rule B)
  apply (rule ch2ch_monofun [OF monofun_inv_Inr Y])
 apply (rule ext)
 apply (cut_tac j=i in chain_mono [OF Y le0], simp)
 apply (erule Inr_belowE, simp)
done

lemma is_lub_Inl: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inl (S i)) <<| Inl x"
 apply (rule is_lubI)
  apply (rule ub_rangeI)
  apply (simp add: is_lub_rangeD1)
 apply (frule ub_rangeD [where i=arbitrary])
 apply (erule Inl_belowE, simp)
 apply (erule is_lubD2)
 apply (rule ub_rangeI)
 apply (drule ub_rangeD, simp)
done

lemma is_lub_Inr: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inr (S i)) <<| Inr x"
 apply (rule is_lubI)
  apply (rule ub_rangeI)
  apply (simp add: is_lub_rangeD1)
 apply (frule ub_rangeD [where i=arbitrary])
 apply (erule Inr_belowE, simp)
 apply (erule is_lubD2)
 apply (rule ub_rangeI)
 apply (drule ub_rangeD, simp)
done

instance sum :: (cpo, cpo) cpo
 apply intro_classes
 apply (erule sum_chain_cases, safe)
  apply (rule exI)
  apply (rule is_lub_Inl)
  apply (erule cpo_lubI)
 apply (rule exI)
 apply (rule is_lub_Inr)
 apply (erule cpo_lubI)
done

subsection \<open>Continuity of \emph{Inl}, \emph{Inr}, and case function\<close>

lemma cont_Inl: "cont Inl"
by (intro contI is_lub_Inl cpo_lubI)

lemma cont_Inr: "cont Inr"
by (intro contI is_lub_Inr cpo_lubI)

lemmas cont2cont_Inl [simp, cont2cont] = cont_compose [OF cont_Inl]
lemmas cont2cont_Inr [simp, cont2cont] = cont_compose [OF cont_Inr]

lemmas ch2ch_Inl [simp] = ch2ch_cont [OF cont_Inl]
lemmas ch2ch_Inr [simp] = ch2ch_cont [OF cont_Inr]

lemmas lub_Inl = cont2contlubE [OF cont_Inl, symmetric]
lemmas lub_Inr = cont2contlubE [OF cont_Inr, symmetric]

lemma cont_case_sum1:
  assumes f: "\<And>a. cont (\<lambda>x. f x a)"
  assumes g: "\<And>b. cont (\<lambda>x. g x b)"
  shows "cont (\<lambda>x. case y of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
by (induct y, simp add: f, simp add: g)

lemma cont_case_sum2: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (case_sum f g)"
apply (rule contI)
apply (erule sum_chain_cases)
apply (simp add: cont2contlubE [OF cont_Inl, symmetric] contE)
apply (simp add: cont2contlubE [OF cont_Inr, symmetric] contE)
done

lemma cont2cont_case_sum:
  assumes f1: "\<And>a. cont (\<lambda>x. f x a)" and f2: "\<And>x. cont (\<lambda>a. f x a)"
  assumes g1: "\<And>b. cont (\<lambda>x. g x b)" and g2: "\<And>x. cont (\<lambda>b. g x b)"
  assumes h: "cont (\<lambda>x. h x)"
  shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
apply (rule cont_apply [OF h])
apply (rule cont_case_sum2 [OF f2 g2])
apply (rule cont_case_sum1 [OF f1 g1])
done

lemma cont2cont_case_sum' [simp, cont2cont]:
  assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
  assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
  assumes h: "cont (\<lambda>x. h x)"
  shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
using assms by (simp add: cont2cont_case_sum prod_cont_iff)

text \<open>Continuity of map function.\<close>

lemma map_sum_eq: "map_sum f g = case_sum (\<lambda>a. Inl (f a)) (\<lambda>b. Inr (g b))"
by (rule ext, case_tac x, simp_all)

lemma cont2cont_map_sum [simp, cont2cont]:
  assumes f: "cont (\<lambda>(x, y). f x y)"
  assumes g: "cont (\<lambda>(x, y). g x y)"
  assumes h: "cont (\<lambda>x. h x)"
  shows "cont (\<lambda>x. map_sum (\<lambda>y. f x y) (\<lambda>y. g x y) (h x))"
using assms by (simp add: map_sum_eq prod_cont_iff)

subsection \<open>Compactness and chain-finiteness\<close>

lemma compact_Inl: "compact a \<Longrightarrow> compact (Inl a)"
apply (rule compactI2)
apply (erule sum_chain_cases, safe)
apply (simp add: lub_Inl)
apply (erule (2) compactD2)
apply (simp add: lub_Inr)
done

lemma compact_Inr: "compact a \<Longrightarrow> compact (Inr a)"
apply (rule compactI2)
apply (erule sum_chain_cases, safe)
apply (simp add: lub_Inl)
apply (simp add: lub_Inr)
apply (erule (2) compactD2)
done

lemma compact_Inl_rev: "compact (Inl a) \<Longrightarrow> compact a"
unfolding compact_def
by (drule adm_subst [OF cont_Inl], simp)

lemma compact_Inr_rev: "compact (Inr a) \<Longrightarrow> compact a"
unfolding compact_def
by (drule adm_subst [OF cont_Inr], simp)

lemma compact_Inl_iff [simp]: "compact (Inl a) = compact a"
by (safe elim!: compact_Inl compact_Inl_rev)

lemma compact_Inr_iff [simp]: "compact (Inr a) = compact a"
by (safe elim!: compact_Inr compact_Inr_rev)

instance sum :: (chfin, chfin) chfin
apply intro_classes
apply (erule compact_imp_max_in_chain)
apply (case_tac "\<Squnion>i. Y i", simp_all)
done

instance sum :: (discrete_cpo, discrete_cpo) discrete_cpo
by intro_classes (simp add: below_sum_def split: sum.split)

subsection \<open>Using sum types with fixrec\<close>

definition
  "match_Inl = (\<Lambda> x k. case x of Inl a \<Rightarrow> k\<cdot>a | Inr b \<Rightarrow> Fixrec.fail)"

definition
  "match_Inr = (\<Lambda> x k. case x of Inl a \<Rightarrow> Fixrec.fail | Inr b \<Rightarrow> k\<cdot>b)"

lemma match_Inl_simps [simp]:
  "match_Inl\<cdot>(Inl a)\<cdot>k = k\<cdot>a"
  "match_Inl\<cdot>(Inr b)\<cdot>k = Fixrec.fail"
unfolding match_Inl_def by simp_all

lemma match_Inr_simps [simp]:
  "match_Inr\<cdot>(Inl a)\<cdot>k = Fixrec.fail"
  "match_Inr\<cdot>(Inr b)\<cdot>k = k\<cdot>b"
unfolding match_Inr_def by simp_all

setup \<open>
  Fixrec.add_matchers
    [ (\<^const_name>\<open>Inl\<close>, \<^const_name>\<open>match_Inl\<close>),
      (\<^const_name>\<open>Inr\<close>, \<^const_name>\<open>match_Inr\<close>) ]
\<close>

subsection \<open>Disjoint sum is a predomain\<close>

definition
  "encode_sum_u =
    (\<Lambda>(up\<cdot>x). case x of Inl a \<Rightarrow> sinl\<cdot>(up\<cdot>a) | Inr b \<Rightarrow> sinr\<cdot>(up\<cdot>b))"

definition
  "decode_sum_u = sscase\<cdot>(\<Lambda>(up\<cdot>a). up\<cdot>(Inl a))\<cdot>(\<Lambda>(up\<cdot>b). up\<cdot>(Inr b))"

lemma decode_encode_sum_u [simp]: "decode_sum_u\<cdot>(encode_sum_u\<cdot>x) = x"
unfolding decode_sum_u_def encode_sum_u_def
by (case_tac x, simp, rename_tac y, case_tac y, simp_all)

lemma encode_decode_sum_u [simp]: "encode_sum_u\<cdot>(decode_sum_u\<cdot>x) = x"
unfolding decode_sum_u_def encode_sum_u_def
apply (case_tac x, simp)
apply (rename_tac a, case_tac a, simp, simp)
apply (rename_tac b, case_tac b, simp, simp)
done

text \<open>A deflation combinator for making unpointed types\<close>

definition udefl :: "udom defl \<rightarrow> udom u defl"
  where "udefl = defl_fun1 (strictify\<cdot>up) (fup\<cdot>ID) ID"

lemma ep_pair_strictify_up:
  "ep_pair (strictify\<cdot>up) (fup\<cdot>ID)"
apply (rule ep_pair.intro)
apply (simp add: strictify_conv_if)
apply (case_tac y, simp, simp add: strictify_conv_if)
done

lemma cast_udefl:
  "cast\<cdot>(udefl\<cdot>t) = strictify\<cdot>up oo cast\<cdot>t oo fup\<cdot>ID"
unfolding udefl_def by (simp add: cast_defl_fun1 ep_pair_strictify_up)

definition sum_liftdefl :: "udom u defl \<rightarrow> udom u defl \<rightarrow> udom u defl"
  where "sum_liftdefl = (\<Lambda> a b. udefl\<cdot>(ssum_defl\<cdot>(u_liftdefl\<cdot>a)\<cdot>(u_liftdefl\<cdot>b)))"

lemma u_emb_bottom: "u_emb\<cdot>\<bottom> = \<bottom>"
by (rule pcpo_ep_pair.e_strict [unfolded pcpo_ep_pair_def, OF ep_pair_u])

(*
definition sum_liftdefl :: "udom u defl \<rightarrow> udom u defl \<rightarrow> udom u defl"
  where "sum_liftdefl = defl_fun2 (u_map\<cdot>emb oo strictify\<cdot>up)
    (fup\<cdot>ID oo u_map\<cdot>prj) ssum_map"
*)

instantiation sum :: (predomain, predomain) predomain
begin

definition
  "liftemb = (strictify\<cdot>up oo ssum_emb) oo
    (ssum_map\<cdot>(u_emb oo liftemb)\<cdot>(u_emb oo liftemb) oo encode_sum_u)"

definition
  "liftprj = (decode_sum_u oo ssum_map\<cdot>(liftprj oo u_prj)\<cdot>(liftprj oo u_prj))
    oo (ssum_prj oo fup\<cdot>ID)"

definition
  "liftdefl (t::('a + 'b) itself) = sum_liftdefl\<cdot>LIFTDEFL('a)\<cdot>LIFTDEFL('b)"

instance proof
  show "ep_pair liftemb (liftprj :: udom u \<rightarrow> ('a + 'b) u)"
    unfolding liftemb_sum_def liftprj_sum_def
    by (intro ep_pair_comp ep_pair_ssum_map ep_pair_u predomain_ep
      ep_pair_ssum ep_pair_strictify_up, simp add: ep_pair.intro)
  show "cast\<cdot>LIFTDEFL('a + 'b) = liftemb oo (liftprj :: udom u \<rightarrow> ('a + 'b) u)"
    unfolding liftemb_sum_def liftprj_sum_def liftdefl_sum_def
    by (simp add: sum_liftdefl_def cast_udefl cast_ssum_defl cast_u_liftdefl
      cast_liftdefl cfcomp1 ssum_map_map u_emb_bottom)
qed

end

subsection \<open>Configuring domain package to work with sum type\<close>

lemma liftdefl_sum [domain_defl_simps]:
  "LIFTDEFL('a::predomain + 'b::predomain) =
    sum_liftdefl\<cdot>LIFTDEFL('a)\<cdot>LIFTDEFL('b)"
by (rule liftdefl_sum_def)

abbreviation map_sum'
  where "map_sum' f g \<equiv> Abs_cfun (map_sum (Rep_cfun f) (Rep_cfun g))"

lemma map_sum_ID [domain_map_ID]: "map_sum' ID ID = ID"
by (simp add: ID_def cfun_eq_iff map_sum.identity id_def)

lemma deflation_map_sum [domain_deflation]:
  "\<lbrakk>deflation d1; deflation d2\<rbrakk> \<Longrightarrow> deflation (map_sum' d1 d2)"
apply standard
apply (induct_tac x, simp_all add: deflation.idem)
apply (induct_tac x, simp_all add: deflation.below)
done

lemma encode_sum_u_map_sum:
  "encode_sum_u\<cdot>(u_map\<cdot>(map_sum' f g)\<cdot>(decode_sum_u\<cdot>x))
    = ssum_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>g)\<cdot>x"
apply (induct x, simp add: decode_sum_u_def encode_sum_u_def)
apply (case_tac x, simp, simp add: decode_sum_u_def encode_sum_u_def)
apply (case_tac y, simp, simp add: decode_sum_u_def encode_sum_u_def)
done

lemma isodefl_sum [domain_isodefl]:
  fixes d :: "'a::predomain \<rightarrow> 'a"
  assumes "isodefl' d1 t1" and "isodefl' d2 t2"
  shows "isodefl' (map_sum' d1 d2) (sum_liftdefl\<cdot>t1\<cdot>t2)"
using assms unfolding isodefl'_def liftemb_sum_def liftprj_sum_def
apply (simp add: sum_liftdefl_def cast_udefl cast_ssum_defl cast_u_liftdefl)
apply (simp add: cfcomp1 encode_sum_u_map_sum)
apply (simp add: ssum_map_map u_emb_bottom)
done

setup \<open>
  Domain_Take_Proofs.add_rec_type (\<^type_name>\<open>sum\<close>, [true, true])
\<close>

end