theory Cartan
imports "HOL-Complex_Analysis.Complex_Analysis"

begin

section\<open>First Cartan Theorem\<close>

text\<open>Ported from HOL Light. See
      Gianni Ciolli, Graziano Gentili, Marco Maggesi.
      A Certified Proof of the Cartan Fixed Point Theorems.
      J Automated Reasoning (2011) 47:319--336    DOI 10.1007/s10817-010-9198-6\<close>

lemma deriv_left_inverse:
  assumes "f holomorphic_on S" and "g holomorphic_on T"
      and "open S" and "open T"
      and "f ` S \<subseteq> T"
      and [simp]: "\<And>z. z \<in> S \<Longrightarrow> g (f z) = z"
      and "w \<in> S"
    shows "deriv f w * deriv g (f w) = 1"
proof -
  have "deriv f w * deriv g (f w) = deriv g (f w) * deriv f w"
    by (simp add: algebra_simps)
  also have "... = deriv (g o f) w"
    using assms
    by (metis analytic_on_imp_differentiable_at analytic_on_open deriv_chain image_subset_iff)
  also have "... = deriv id w"
    apply (rule complex_derivative_transform_within_open [where s=S])
    apply (rule assms holomorphic_on_compose_gen holomorphic_intros)+
    apply simp
    done
  also have "... = 1"
    using higher_deriv_id [of 1] by simp
  finally show ?thesis .
qed

lemma Cauchy_higher_deriv_bound:
    assumes holf: "f holomorphic_on (ball z r)"
        and contf: "continuous_on (cball z r) f"
        and "0 < r" and "0 < n"
        and fin : "\<And>w. w \<in> ball z r \<Longrightarrow> f w \<in> ball y B0"
      shows "norm ((deriv ^^ n) f z) \<le> (fact n) * B0 / r^n"
proof -
  have "0 < B0" using \<open>0 < r\<close> fin [of z]
    by (metis ball_eq_empty ex_in_conv fin not_less)
  have le_B0: "\<And>w. cmod (w - z) \<le> r \<Longrightarrow> cmod (f w - y) \<le> B0"
    apply (rule continuous_on_closure_norm_le [of "ball z r" "\<lambda>w. f w - y"])
    apply (auto simp: \<open>0 < r\<close>  dist_norm norm_minus_commute)
    apply (rule continuous_intros contf)+
    using fin apply (simp add: dist_commute dist_norm less_eq_real_def)
    done
  have "(deriv ^^ n) f z = (deriv ^^ n) (\<lambda>w. f w) z - (deriv ^^ n) (\<lambda>w. y) z"
    using \<open>0 < n\<close> by simp
  also have "... = (deriv ^^ n) (\<lambda>w. f w - y) z"
    by (rule higher_deriv_diff [OF holf, symmetric]) (auto simp: \<open>0 < r\<close> holomorphic_on_const)
  finally have "(deriv ^^ n) f z = (deriv ^^ n) (\<lambda>w. f w - y) z" .
  have contf': "continuous_on (cball z r) (\<lambda>u. f u - y)"
    by (rule contf continuous_intros)+
  have holf': "(\<lambda>u. (f u - y)) holomorphic_on (ball z r)"
    by (simp add: holf holomorphic_on_diff holomorphic_on_const)
  define a where "a = (2 * pi)/(fact n)"
  have "0 < a"  by (simp add: a_def)
  have "B0/r^(Suc n)*2 * pi * r = a*((fact n)*B0/r^n)"
    using \<open>0 < r\<close> by (simp add: a_def divide_simps)
  have der_dif: "(deriv ^^ n) (\<lambda>w. f w - y) z = (deriv ^^ n) f z"
    using \<open>0 < r\<close> \<open>0 < n\<close>
    by (auto simp: higher_deriv_diff [OF holf holomorphic_on_const])
  have "norm ((2 * of_real pi * \<i>)/(fact n) * (deriv ^^ n) (\<lambda>w. f w - y) z)
        \<le> (B0/r^(Suc n)) * (2 * pi * r)"
    apply (rule has_contour_integral_bound_circlepath [of "(\<lambda>u. (f u - y)/(u - z)^(Suc n))" _ z])
    using Cauchy_has_contour_integral_higher_derivative_circlepath [OF contf' holf']
    using \<open>0 < B0\<close> \<open>0 < r\<close>
    apply (auto simp: norm_divide norm_mult norm_power divide_simps le_B0)
    done
  then show ?thesis
    using \<open>0 < r\<close>
    by (auto simp: norm_divide norm_mult norm_power field_simps der_dif le_B0)
qed

lemma higher_deriv_comp_lemma:
    assumes s: "open s" and holf: "f holomorphic_on s"
        and "z \<in> s"
        and t: "open t" and holg: "g holomorphic_on t"
        and fst: "f ` s \<subseteq> t"
        and n: "i \<le> n"
        and dfz: "deriv f z = 1" and zero: "\<And>i. \<lbrakk>1 < i; i \<le> n\<rbrakk> \<Longrightarrow> (deriv ^^ i) f z = 0"
      shows "(deriv ^^ i) (g o f) z = (deriv ^^ i) g (f z)"
using n holg
proof (induction i arbitrary: g)
  case 0 then show ?case by simp
next
  case (Suc i)
  have "g \<circ> f holomorphic_on s" using "Suc.prems" holf
    using fst  by (simp add: holomorphic_on_compose_gen image_subset_iff)
  then have 1: "deriv (g \<circ> f) holomorphic_on s"
    by (simp add: holomorphic_deriv s)
  have dg: "deriv g holomorphic_on t"
    using Suc.prems by (simp add: Suc.prems(2) holomorphic_deriv t)
  then have "deriv g holomorphic_on f ` s"
    using fst  by (simp add: holomorphic_on_subset image_subset_iff)
  then have dgf: "(deriv g o f) holomorphic_on s"
    by (simp add: holf holomorphic_on_compose)
  then have 2: "(\<lambda>w. (deriv g o f) w * deriv f w) holomorphic_on s"
    by (blast intro: holomorphic_intros holomorphic_on_compose holf s)
  have "(deriv ^^ i) (deriv (g o f)) z = (deriv ^^ i) (\<lambda>w. deriv g (f w) * deriv f w) z"
    apply (rule higher_deriv_transform_within_open [OF 1 2 [unfolded o_def] s \<open>z \<in> s\<close>])
    apply (rule deriv_chain)
    using holf Suc.prems fst apply (auto simp: holomorphic_on_imp_differentiable_at s t)
    done
  also have "... = (\<Sum>j=0..i. of_nat(i choose j) * (deriv ^^ j) (\<lambda>w. deriv g (f w)) z * (deriv ^^ (i - j)) (deriv f) z)"
    apply (rule higher_deriv_mult [OF dgf [unfolded o_def] _ s \<open>z \<in> s\<close>])
    by (simp add: holf holomorphic_deriv s)
  also have "... = (\<Sum>j=i..i. of_nat(i choose j) * (deriv ^^ j) (\<lambda>w. deriv g (f w)) z * (deriv ^^ Suc (i - j)) f z)"
  proof -
    have *: "(deriv ^^ j) (\<lambda>w. deriv g (f w)) z = 0"  if "j < i" and nz: "(deriv ^^ (i - j)) (deriv f) z \<noteq> 0" for j
    proof -
      have "1 < Suc (i - j)" "Suc (i - j) \<le> n"
        using \<open>j < i\<close> \<open>Suc i \<le> n\<close> by auto
      then show ?thesis  by (metis comp_def funpow.simps(2) funpow_swap1 zero nz)
    qed
    then show ?thesis
      apply (simp only: funpow_Suc_right o_def)
      apply (rule comm_monoid_add_class.sum.mono_neutral_right, auto)
      done
  qed
  also have "... = (deriv ^^ i) (deriv g) (f z)"
    using Suc.IH [OF _ dg] Suc.prems by (simp add: dfz)
  finally show ?case
    by (simp only: funpow_Suc_right o_def)
qed

lemma higher_deriv_comp_iter_lemma:
    assumes s: "open s" and holf: "f holomorphic_on s"
        and fss: "f ` s \<subseteq> s"
        and "z \<in> s" and [simp]: "f z = z"
        and n: "i \<le> n"
        and dfz: "deriv f z = 1" and zero: "\<And>i. \<lbrakk>1 < i; i \<le> n\<rbrakk> \<Longrightarrow> (deriv ^^ i) f z = 0"
      shows "(deriv ^^ i) (f^^m) z = (deriv ^^ i) f z"
proof -
  have holfm: "(f^^m) holomorphic_on s" for m
    apply (induction m, simp add: holomorphic_on_ident)
    apply (simp only: funpow_Suc_right holomorphic_on_compose_gen [OF holf _ fss])
    done
  show ?thesis using n
  proof (induction m)
    case 0 with dfz show ?case
      by (auto simp: zero)
  next
    case (Suc m)
    have "(deriv ^^ i) (f ^^ m \<circ> f) z = (deriv ^^ i) (f ^^ m) (f z)"
      using Suc.prems holfm \<open>z \<in> s\<close> dfz fss higher_deriv_comp_lemma holf s zero by blast
    also have "... = (deriv ^^ i) f z"
      by (simp add: Suc)
    finally show ?case
      by (simp only: funpow_Suc_right)
  qed
qed

lemma higher_deriv_iter_top_lemma:
    assumes s: "open s" and holf: "f holomorphic_on s"
        and fss: "f ` s \<subseteq> s"
        and "z \<in> s" and [simp]: "f z = z"
        and dfz [simp]: "deriv f z = 1"
        and n: "1 < n" "\<And>i. \<lbrakk>1 < i; i < n\<rbrakk> \<Longrightarrow> (deriv ^^ i) f z = 0"
      shows "(deriv ^^ n) (f ^^ m) z = m * (deriv ^^ n) f z"
using n
proof (induction n arbitrary: m)
  case 0 then show ?case by simp
next
  case (Suc n)
  have [simp]: "(f^^m) z = z" for m
    by (induction m) auto
  have fms_sb: "(f^^m) ` s \<subseteq> s" for m
    apply (induction m)
    using fss
    apply force+
    done
  have holfm: "(f^^m) holomorphic_on s" for m
    apply (induction m, simp add: holomorphic_on_ident)
    apply (simp only: funpow_Suc_right holomorphic_on_compose_gen [OF holf _ fss])
    done
  then have holdfm: "deriv (f ^^ m) holomorphic_on s" for m
    by (simp add: holomorphic_deriv s)
  have holdffm: "(\<lambda>z. deriv f ((f ^^ m) z)) holomorphic_on s" for m
    apply (rule holomorphic_on_compose_gen [where g="deriv f" and t=s, unfolded o_def])
    using s \<open>z \<in> s\<close> holfm holf fms_sb by (auto intro: holomorphic_intros)
  have f_cd_w: "\<And>w. w \<in> s \<Longrightarrow> f field_differentiable at w"
    using holf holomorphic_on_imp_differentiable_at s by blast
  have f_cd_mw: "\<And>m w. w \<in> s \<Longrightarrow> (f^^m) field_differentiable at w"
    using holfm holomorphic_on_imp_differentiable_at s by auto
  have der_fm [simp]: "deriv (f ^^ m) z = 1" for m
    apply (induction m, simp add: deriv_ident)
    apply (subst funpow_Suc_right)
    apply (subst deriv_chain)
    using \<open>z \<in> s\<close> holfm holomorphic_on_imp_differentiable_at s f_cd_w apply auto
    done
  note Suc(3) [simp]
  note n_Suc = Suc
  show ?case
  proof (induction m)
    case 0 with n_Suc show ?case
      by (metis Zero_not_Suc funpow_simps_right(1) higher_deriv_id lambda_zero nat_neq_iff of_nat_0)
  next
    case (Suc m)
    have deriv_nffm: "(deriv ^^ n) (deriv f o (f ^^ m)) z = (deriv ^^ n) (deriv f) ((f ^^ m) z)"
      apply (rule higher_deriv_comp_lemma [OF s holfm \<open>z \<in> s\<close> s _ fms_sb order_refl])
      using \<open>z \<in> s\<close> fss higher_deriv_comp_iter_lemma holf holf holomorphic_deriv s
        apply auto
      done
    have "deriv (f ^^ m \<circ> f) holomorphic_on s"
      by (metis funpow_Suc_right holdfm)
    moreover have "(\<lambda>w. deriv f ((f ^^ m) w) * deriv (f ^^ m) w) holomorphic_on s"
      by (rule holomorphic_on_mult [OF holdffm holdfm])
    ultimately have "(deriv ^^ n) (deriv (f ^^ m \<circ> f)) z = (deriv ^^ n) (\<lambda>w. deriv f ((f ^^ m) w) * deriv (f ^^ m) w) z"
      apply (rule higher_deriv_transform_within_open [OF _ _ s \<open>z \<in> s\<close>])
      by (metis comp_funpow deriv_chain f_cd_mw f_cd_w fms_sb funpow_swap1 image_subset_iff o_id)
    also have "... =
          (\<Sum>i=0..n. of_nat(n choose i) * (deriv ^^ i) (\<lambda>w. deriv f ((f ^^ m) w)) z *
                     (deriv ^^ (n - i)) (deriv (f ^^ m)) z)"
      by (rule higher_deriv_mult [OF holdffm holdfm s \<open>z \<in> s\<close>])
    also have "... = (\<Sum>i \<in> {0,n}. of_nat(n choose i) * (deriv ^^ i) (\<lambda>w. deriv f ((f ^^ m) w)) z *
                     (deriv ^^ (n - i)) (deriv (f ^^ m)) z)"
    proof -
      have *: "(deriv ^^ i) (\<lambda>w. deriv f ((f ^^ m) w)) z = 0"  if "i \<le> n" "0 < i" "i \<noteq> n" and nz: "(deriv ^^ (n - i)) (deriv (f ^^ m)) z \<noteq> 0" for i
      proof -
        have less: "1 < Suc (n-i)" and le: "Suc (n-i) \<le> n"
          using that by auto
        have "(deriv ^^ (Suc (n - i))) (f ^^ m) z = (deriv ^^(Suc (n - i))) f z"
          apply (rule higher_deriv_comp_iter_lemma [OF s holf fss \<open>z \<in> s\<close> \<open>f z = z\<close> le dfz])
          by simp
        also have "... = 0"
          using n_Suc(3) less le le_imp_less_Suc by blast
        finally have "(deriv ^^ (Suc (n - i))) (f ^^ m) z = 0" .
        then show ?thesis by (simp add: funpow_swap1 nz)
      qed
      show ?thesis
        by (rule comm_monoid_add_class.sum.mono_neutral_right) (auto simp: *)
    qed
    also have "... = of_nat (Suc m) * (deriv ^^ n) (deriv f) z"
      apply (subst Groups_Big.comm_monoid_add_class.sum.insert)
      apply (simp_all add: deriv_nffm [unfolded o_def] of_nat_Suc [of 0] del: of_nat_Suc)
      using n_Suc(2) Suc
      apply (auto simp del: funpow.simps simp: algebra_simps funpow_simps_right)
      done
    finally have "(deriv ^^ n) (deriv (f ^^ m \<circ> f)) z = of_nat (Suc m) * (deriv ^^ n) (deriv f) z" .
    then show ?case
      apply (simp only: funpow_Suc_right)
      apply (simp add: o_def del: of_nat_Suc)
      done
  qed
qed

text\<open>Should be proved for n-dimensional vectors of complex numbers\<close>
theorem first_Cartan_dim_1:
    assumes holf: "f holomorphic_on s"
        and "open s" "connected s" "bounded s"
        and fss: "f ` s \<subseteq> s"
        and "z \<in> s" and [simp]: "f z = z"
        and dfz [simp]: "deriv f z = 1"
        and "w \<in> s"
      shows "f w = w"
proof -
  obtain c where "0 < c" and c: "s \<subseteq> ball z c"
    using \<open>bounded s\<close> bounded_subset_ballD by blast
  obtain r where "0 < r" and r: "cball z r \<subseteq> s"
    using \<open>z \<in> s\<close> open_contains_cball \<open>open s\<close> by blast
  then have bzr: "ball z r \<subseteq> s" using ball_subset_cball by blast
  have fms_sb: "(f^^m) ` s \<subseteq> s" for m
    apply (induction m)
    using fss apply force+
    done
  have holfm: "(f^^m) holomorphic_on s" for m
    apply (induction m, simp add: holomorphic_on_ident)
    apply (simp only: funpow_Suc_right holomorphic_on_compose_gen [OF holf _ fss])
    done
  have *: "(deriv ^^ n) f z = (deriv ^^ n) id z" for n
  proof -
    consider "n = 0" | "n = 1" | "1 < n" by arith
    then show ?thesis
    proof cases
      assume "n = 0" then show ?thesis by force
    next
      assume "n = 1" then show ?thesis by force
    next
      assume n1: "n > 1"
      then have "(deriv ^^ n) f z = 0"
      proof (induction n rule: less_induct)
        case (less n)
        have le: "real m * cmod ((deriv ^^ n) f z) \<le> fact n * c / r ^ n" if "m\<noteq>0" for m
        proof -
          have holfm': "(f ^^ m) holomorphic_on ball z r"
            using holfm bzr holomorphic_on_subset by blast
          then have contfm': "continuous_on (cball z r) (f ^^ m)"
            using \<open>cball z r \<subseteq> s\<close> holfm holomorphic_on_imp_continuous_on holomorphic_on_subset by blast
          have "real m * cmod ((deriv ^^ n) f z) = cmod (real m * (deriv ^^ n) f z)"
            by (simp add: norm_mult)
          also have "... = cmod ((deriv ^^ n) (f ^^ m) z)"
            apply (subst higher_deriv_iter_top_lemma [OF \<open>open s\<close> holf fss \<open>z \<in> s\<close> \<open>f z = z\<close> dfz])
            using less apply auto
            done
          also have "... \<le> fact n * c / r ^ n"
            apply (rule Cauchy_higher_deriv_bound [OF holfm' contfm' \<open>0 < r\<close>, where y=z])
            using less.prems apply linarith
            using fms_sb c r ball_subset_cball
            apply blast
            done
          finally show ?thesis .
        qed
        have "cmod ((deriv ^^ n) f z) = 0"
          apply (rule real_archimedian_rdiv_eq_0 [where c = "(fact n) * c / r ^ n"])
          apply simp
          using \<open>0 < r\<close> \<open>0 < c\<close>
          apply (simp add: divide_simps)
          apply (blast intro: le)
          done
        then show ?case by simp
      qed
      with n1 show ?thesis by simp
    qed
  qed
  have "f w = id w"
    by (rule holomorphic_fun_eq_on_connected
                 [OF holf holomorphic_on_id \<open>open s\<close> \<open>connected s\<close> * \<open>z \<in> s\<close> \<open>w \<in> s\<close>])
  also have "... = w" by simp
  finally show ?thesis .
qed

text\<open>Second Cartan Theorem.\<close>

lemma Cartan_is_linear:
  assumes holf: "f holomorphic_on s"
      and "open s" and "connected s"
      and "0 \<in> s"
      and ins: "\<And>u z. \<lbrakk>norm u = 1; z \<in> s\<rbrakk> \<Longrightarrow> u * z \<in> s"
      and feq: "\<And>u z. \<lbrakk>norm u = 1; z \<in> s\<rbrakk> \<Longrightarrow> f (u * z) = u * f z"
    shows "\<exists>c. \<forall>z \<in> s. f z = c * z"
proof -
  have [simp]: "f 0 = 0"
    using feq [of "-1" 0] assms by simp
  have uneq: "u^n * (deriv ^^ n) f (u * z) = u * (deriv ^^ n) f z"
       if "norm u = 1" "z \<in> s" for n u z
  proof -
    have holfuw: "(\<lambda>w. f (u * w)) holomorphic_on s"
      apply (rule holomorphic_on_compose_gen [OF _ holf, unfolded o_def])
      using that ins by (auto simp: holomorphic_on_linear)
    have hol_d_fuw: "(deriv ^^ n) (\<lambda>w. u * f w) holomorphic_on s" for n
      by (rule holomorphic_higher_deriv holomorphic_intros holf assms)+
    have *: "(deriv ^^ n) (\<lambda>w. u * f w) z = u * (deriv ^^ n) f z" if "z \<in> s" for z
    using that
    proof (induction n arbitrary: z)
      case 0 then show ?case by simp
    next
      case (Suc n)
      have "deriv ((deriv ^^ n) (\<lambda>w. u * f w)) z = deriv (\<lambda>w. u * (deriv ^^ n) f w) z"
        apply (rule complex_derivative_transform_within_open [OF hol_d_fuw])
        apply (auto intro!: holomorphic_higher_deriv holomorphic_intros assms Suc)
        done
      also have "... = u * deriv ((deriv ^^ n) f) z"
        apply (rule deriv_cmult)
        using Suc \<open>open s\<close> holf holomorphic_higher_deriv holomorphic_on_imp_differentiable_at by blast
      finally show ?case by simp
    qed
    have "(deriv ^^ n) (\<lambda>w. f (u * w)) z = u ^ n * (deriv ^^ n) f (u * z)"
      apply (rule higher_deriv_compose_linear [OF holf \<open>open s\<close> \<open>open s\<close>])
      apply (simp add: that)
      apply (simp add: ins that)
      done
    moreover have "(deriv ^^ n) (\<lambda>w. f (u * w)) z = u * (deriv ^^ n) f z"
      apply (subst higher_deriv_transform_within_open [OF holfuw, of "\<lambda>w. u * f w"])
      apply (rule holomorphic_intros holf assms that)+
      apply blast
      using * \<open>z \<in> s\<close> apply blast
      done
    ultimately show ?thesis by metis
  qed
  have dnf0: "(deriv ^^ n) f 0 = 0" if len: "2 \<le> n" for n
  proof -
    have **: "z = 0" if "\<And>u::complex. norm u = 1 \<Longrightarrow> u ^ n * z = u * z" for z
    proof -
      have "\<exists>u::complex. norm u = 1 \<and> u ^ n \<noteq> u"
        using complex_not_root_unity [of "n-1"] len
        apply (simp add: algebra_simps le_diff_conv2, clarify)
        apply (rule_tac x=u in exI)
        apply (subst (asm) power_diff)
        apply auto
        done
      with that show ?thesis
        by auto
    qed
    show ?thesis
      apply (rule **)
      using uneq [OF _ \<open>0 \<in> s\<close>]
      by force
  qed
  show ?thesis
    apply (rule_tac x = "deriv f 0" in exI, clarify)
    apply (rule holomorphic_fun_eq_on_connected [OF holf _ \<open>open s\<close> \<open>connected s\<close> _ \<open>0 \<in> s\<close>])
    using dnf0 apply (auto simp: holomorphic_on_linear)
    done
qed

text\<open>Should be proved for n-dimensional vectors of complex numbers\<close>
theorem second_Cartan_dim_1:
  assumes holf: "f holomorphic_on ball 0 r"
      and holg: "g holomorphic_on ball 0 r"
      and [simp]: "f 0 = 0" and [simp]: "g 0 = 0"
      and ballf: "\<And>z. z \<in> ball 0 r \<Longrightarrow> f z \<in> ball 0 r"
      and ballg: "\<And>z. z \<in> ball 0 r \<Longrightarrow> g z \<in> ball 0 r"
      and fg: "\<And>z. z \<in> ball 0 r \<Longrightarrow> f (g z) = z"
      and gf: "\<And>z. z \<in> ball 0 r \<Longrightarrow> g (f z) = z"
      and "0 < r"
    shows "\<exists>t. \<forall>z \<in> ball 0 r. g z = exp(\<i> * of_real t) * z"
proof -
  have c_le_1: "c \<le> 1"
    if "0 \<le> c" "\<And>x. 0 \<le> x \<Longrightarrow> x < r \<Longrightarrow> c * x < r" for c
  proof -
    have rst: "\<And>r s t::real. 0 = r \<or> s/r < t \<or> r < 0 \<or> \<not> s < r * t"
      by (metis (no_types) mult_less_cancel_left_disj nonzero_mult_div_cancel_left times_divide_eq_right)
    { assume "\<not> r < c \<and> c * (c * (c * (c * r))) < 1"
     then have "1 \<le> c \<Longrightarrow> (\<exists>r. \<not> 1 < r \<and> \<not> r < c)"
          using \<open>0 \<le> c\<close> by (metis (full_types) less_eq_real_def mult.right_neutral mult_left_mono not_less)
      then have "\<not> 1 < c \<or> \<not> 1 \<le> c"
        by linarith }
    moreover
    { have "\<not> 0 \<le> r / c \<Longrightarrow> \<not> 1 \<le> c"
          using \<open>0 < r\<close> by force
      then have "1 < c \<Longrightarrow> \<not> 1 \<le> c"
        using rst \<open>0 < r\<close> that
        by (metis div_by_1 frac_less2 less_le_trans mult.commute not_le order_refl pos_divide_le_eq zero_less_one) }
    ultimately show ?thesis
      by (metis (no_types) linear not_less)
  qed
  have ugeq: "u * g z = g (u * z)" if nou: "norm u = 1" and z: "z \<in> ball 0 r" for u z
  proof -
    have [simp]: "u \<noteq> 0" using that by auto
    have hol1: "(\<lambda>a. f (u * g a) / u) holomorphic_on ball 0 r"
      apply (rule holomorphic_intros)
      apply (rule holomorphic_on_compose_gen [OF _ holf, unfolded o_def])
      apply (rule holomorphic_intros holg)+
      using nou ballg
      apply (auto simp: dist_norm norm_mult holomorphic_on_const)
      done
    have cdf: "f field_differentiable at 0"
      using \<open>0 < r\<close> holf holomorphic_on_imp_differentiable_at by auto
    have cdg: "g field_differentiable at 0"
      using \<open>0 < r\<close> holg holomorphic_on_imp_differentiable_at by auto
    have cd_fug: "(\<lambda>a. f (u * g a)) field_differentiable at 0"
      apply (rule field_differentiable_compose [where g=f and f = "\<lambda>a. (u * g a)", unfolded o_def])
      apply (rule derivative_intros)+
      using cdf cdg
      apply auto
      done
    have "deriv g 0 = deriv g (f 0)"
      by simp
    then have "deriv f 0 * deriv g 0 = 1"
      by (metis open_ball \<open>0 < r\<close> ballf centre_in_ball deriv_left_inverse gf holf holg image_subsetI)
    then have equ: "deriv f 0 * deriv (\<lambda>a. u * g a) 0 = u"
      by (simp add: cdg deriv_cmult)
    have der1: "deriv (\<lambda>a. f (u * g a) / u) 0 = 1"
      apply (simp add: field_class.field_divide_inverse deriv_cmult_right [OF cd_fug])
      apply (subst deriv_chain [where g=f and f = "\<lambda>a. (u * g a)", unfolded o_def])
      apply (rule derivative_intros cdf cdg | simp add: equ)+
      done
    have fugeq: "\<And>w. w \<in> ball 0 r \<Longrightarrow> f (u * g w) / u = w"
      apply (rule first_Cartan_dim_1 [OF hol1, where z=0])
      apply (simp_all add: \<open>0 < r\<close>)
      apply (auto simp: der1)
      using nou ballf ballg
      apply (simp add: dist_norm norm_mult norm_divide)
      done
    have "f(u * g z) = u * z"
      by (metis \<open>u \<noteq> 0\<close> fugeq nonzero_mult_div_cancel_left z times_divide_eq_right)
    also have "... = f (g (u * z))"
      by (metis (no_types, lifting) fg mem_ball_0 mult_cancel_right2 norm_mult nou z)
    finally have "f(u * g z) = f (g (u * z))" .
    then have "g (f (u * g z)) = g (f (g (u * z)))"
      by simp
    then show ?thesis
      apply (subst (asm) gf)
      apply (simp add: dist_norm norm_mult nou)
      using ballg mem_ball_0 z apply blast
      apply (subst (asm) gf)
      apply (simp add: dist_norm norm_mult nou)
      apply (metis ballg mem_ball_0 mult.left_neutral norm_mult nou z, simp)
      done
  qed
  obtain c where c: "\<And>z. z \<in> ball 0 r \<Longrightarrow> g z = c * z"
    apply (rule exE [OF Cartan_is_linear [OF holg]])
    apply (simp_all add: \<open>0 < r\<close> ugeq)
    apply (auto simp: dist_norm norm_mult)
    done
  have gr2: "g (f (r/2)) = c * f(r/2)"
    apply (rule c) using \<open>0 < r\<close> ballf mem_ball_0 by force
  then have "norm c > 0"
    using \<open>0 < r\<close>
    by simp (metis \<open>f 0 = 0\<close> c dist_commute fg mem_ball mult_zero_left perfect_choose_dist)
  then have [simp]: "c \<noteq> 0" by auto
  have xless: "x < r * cmod c" if "0 \<le> x" "x < r" for x
  proof -
    have "x = norm (g (f (of_real x)))"
    proof -
      have "r > cmod (of_real x)"
        by (simp add: that)
      then have "complex_of_real x \<in> ball 0 r"
        using mem_ball_0 by blast
      then show ?thesis
        using gf \<open>0 \<le> x\<close> by force
    qed
    then show ?thesis
      apply (rule ssubst)
      apply (subst c)
      apply (rule ballf)
      using ballf [of x] that
      apply (auto simp: norm_mult dist_0_norm)
      done
  qed
  have 11: "1 / norm c \<le> 1"
    apply (rule c_le_1)
    using xless apply (auto simp: divide_simps)
    done
  have "\<lbrakk>0 \<le> x; x < r\<rbrakk> \<Longrightarrow> cmod c * x < r" for x
    using c [of x] ballg [of x] by (auto simp: norm_mult dist_0_norm)
    then have "norm c \<le> 1"
    by (force intro: c_le_1)
  moreover have "1 \<le> norm c"
    using 11 by simp
  ultimately have "norm c = 1"  by (rule antisym)
  with complex_norm_eq_1_exp c show ?thesis
    by metis
qed

end


theory clique
  imports Main
begin

text \<open>Formalise the polynomial-time reduction between vertex cover,
clique and independent set\<close>

section \<open>definitions\<close>

type_synonym 'a graph = "'a set \<times> ('a set set)"

definition invar :: "'a graph => bool" where
"invar g = (
    let (V, E) = g in (\<forall>s \<in> E. (\<forall>x \<in> s. x \<in> V) \<and> card s = 2)
)"

fun vertex_cover :: "'a graph => 'a set => bool" where
"vertex_cover g s = (
    let (_, E) = g in (\<forall>s1 \<in> E. \<exists>x \<in> s1. x \<in> s)
)"

fun clique :: "'a graph => 'a set => bool" where
"clique g s = (
    let (_, E) = g in (\<forall>a \<in> s. \<forall> b \<in> s. a \<noteq> b \<longrightarrow> {a, b} \<in> E)
)"

fun vc_to_clique :: "'a graph => 'a graph" where
"vc_to_clique g = (
    let (V, E) = g in (V, {s. \<exists>a \<in> V. \<exists>b \<in> V. s = {a, b} \<and> s \<notin> E \<and> a \<noteq> b})
)"

fun T_vc_to_clique :: "'a graph => nat" where
"T_vc_to_clique (V, E) = card {s. \<exists>a \<in> V. \<exists>b \<in> V. s = {a, b} \<and> s \<notin> E \<and> a \<noteq> b}"

section \<open>proofs of invariant, correctness and polynomial time\<close>

theorem invar_vc_to_clique : "invar (V, E) \<Longrightarrow> invar (vc_to_clique (V, E))"
by (auto simp add: invar_def)

theorem vc_clique_correct:
assumes "invar (V, E)"
shows "clique (vc_to_clique (V, E)) (V - s) = vertex_cover (V, E) s"
proof
  have 1:"\<forall>a. {a} \<notin> E" using assms invar_def by force
  from assms have prems: "\<forall>s \<in> E. (\<forall>x \<in> s. x \<in> V)" "\<forall>s \<in> E. \<exists>a \<in> V. \<exists> b \<in> V. s = {a, b}"
  apply (auto simp: invar_def) by (metis card_2_iff insert_iff)

  assume "clique (vc_to_clique (V, E)) (V - s)"
  hence "\<forall>a \<in> V-s. \<forall>b \<in> V-s. a \<noteq> b \<longrightarrow> {a, b} \<in> {s. \<exists>a\<in>V. \<exists>b\<in>V. s = {a, b} \<and> s \<notin> E \<and> a \<noteq> b}" by simp
  hence "\<forall>a \<in> V-s. \<forall>b \<in> V-s. a \<noteq> b \<longrightarrow> {a, b} \<notin> E" by auto
  hence "\<forall>a \<in> V-s. \<forall>b \<in> V-s. {a, b} \<notin> E" using 1 by force
  hence "\<forall>s1 \<in> E. \<exists>a b. s1 = {a, b} \<and> (a \<notin> V-s \<or> b \<notin> V-s)"
  using prems(2) doubleton_eq_iff by fast
  hence "\<forall>s1 \<in> E. \<exists>a \<in> s1. a \<notin> V-s"
  by auto
  hence "\<forall>s1 \<in> E. \<exists>a \<in> s1. a \<in> s"
  using prems(1) by simp
  thus "vertex_cover (V, E) s" by simp

next
  assume "vertex_cover (V, E) s"
  hence "\<forall>s1 \<in> E. \<exists>a \<in> s1. a \<in> s" by simp
  hence "\<forall>s1 \<in> E. \<exists>a \<in> s1. a \<notin> V-s" by auto
  hence "\<forall>a \<in>V-s. \<forall>b \<in>V-s. a \<noteq> b \<longrightarrow> {a, b} \<notin> E" by fast
  thus "clique (vc_to_clique (V, E)) (V - s)" by auto
qed

lemma aux0 :
assumes "finite A" "x \<in> A"
shows "card {s. \<exists>a\<in>A. s={x, a} \<and> a \<noteq> x} = card A - 1"
using assms proof (induction A rule: remove_induct)
case empty
  then show ?case by simp
next
  case infinite
  then show ?case by simp
next
  case (remove A)

  hence 0:"\<forall>y \<in> A - {x}. card {s. \<exists>a\<in>A - {y}. s = {x, a} \<and> a \<noteq> x} = card (A - {y}) - 1"
  by auto

  have "\<forall>y \<in> A - {x}. {s. \<exists>a\<in>A. s = {x, a} \<and> a \<noteq> x} = insert {x, y} {s. \<exists>a\<in>A - {y}. s = {x, a} \<and> a \<noteq> x}"
  by auto

  moreover have "\<forall>y \<in> A - {x}. {x, y} \<notin> {s. \<exists>a\<in>A - {y}. s = {x, a} \<and> a \<noteq> x}"
  by auto

  ultimately have 1:"\<forall>y \<in> A - {x}. card {s. \<exists>a\<in>A. s = {x, a} \<and> a \<noteq> x} = card {s. \<exists>a\<in>A - {y}. s = {x, a} \<and> a \<noteq> x} + 1"
    using remove by simp

  from 0 1 have "\<forall>y \<in> A - {x}. card {s. \<exists>a\<in>A. s = {x, a} \<and> a \<noteq> x} = card (A - {y}) - 1 + 1" by simp

  hence 3: "\<forall>y \<in> A - {x}. card {s. \<exists>a\<in>A. s = {x, a} \<and> a \<noteq> x} = card (A) - 1"
     by (metis (no_types, lifting) One_nat_def add.right_neutral add_Suc_right card_Diff_singleton
     card_Suc_Diff1 finite_insert insert_Diff_single insert_iff remove.prems(1) remove.prems(2))

  from 3 show ?case apply auto by (metis card_le_Suc0_iff_eq remove.prems(1))

qed

lemma aux:
assumes "finite V"
shows "card {s. \<exists>a \<in> V. \<exists>b \<in> V. s = {a, b} \<and> a \<noteq> b} = card V * (card V - 1) div 2"
using assms proof (induction V rule: finite_remove_induct)
  case empty
  then show ?case by auto
next
  case (remove A)
  have "\<forall>x \<in> A. {s. \<exists>a\<in>A - {x}. \<exists>b\<in>A - {x}. s = {a, b} \<and> a \<noteq> b} =
  {s. \<exists>a\<in>A. \<exists>b\<in>A. s = {a, b} \<and> a \<noteq> b} - {s. \<exists>a\<in>A. s={x, a} \<and> a \<noteq> x}" by auto

  hence "\<forall>x \<in> A. {s. \<exists>a\<in>A. \<exists>b\<in>A. s = {a, b} \<and> a \<noteq> b} =
    {s. \<exists>a\<in>A - {x}. \<exists>b\<in>A - {x}. s = {a, b} \<and> a \<noteq> b} \<union> {s. \<exists>a\<in>A. s={x, a} \<and> a \<noteq> x}"
    by auto

  moreover have "\<forall>x \<in> A. finite {s. \<exists>a\<in>A - {x}. \<exists>b\<in>A - {x}. s = {a, b} \<and> a \<noteq> b}"
  using remove by simp

  moreover have "\<forall>x \<in> A. finite {s. \<exists>a\<in>A. s={x, a} \<and> a \<noteq> x}" using remove by simp

  moreover have "\<forall>x \<in> A. {s. \<exists>a\<in>A - {x}. \<exists>b\<in>A - {x}. s = {a, b} \<and> a \<noteq> b}
    \<inter> {s. \<exists>a\<in>A. s={x, a} \<and> a \<noteq> x} = {}" by auto

  ultimately have "\<forall>x \<in> A. card {s. \<exists>a\<in>A. \<exists>b\<in>A. s = {a, b} \<and> a \<noteq> b}
    = card {s. \<exists>a\<in>A - {x}. \<exists>b\<in>A - {x}. s = {a, b} \<and> a \<noteq> b} + card {s. \<exists>a\<in>A. s={x, a} \<and> a \<noteq> x}"

  using card_Un_disjoint by fastforce

  hence "\<forall>x \<in> A. card {s. \<exists>a\<in>A. \<exists>b\<in>A. s = {a, b} \<and> a \<noteq> b}
    = card (A - {x}) * (card (A - {x}) - 1) div 2 + (card A - 1)"
  using aux0 remove by fastforce

  hence "\<forall>x \<in> A. card {s. \<exists>a\<in>A. \<exists>b\<in>A. s = {a, b} \<and> a \<noteq> b}
    = (card A - 1) * (card A - 2) div 2 + (card A - 1)"
 by (metis (no_types, lifting) card_Diff_singleton diff_diff_left nat_1_add_1)

  hence "\<forall>x \<in> A. card {s. \<exists>a\<in>A. \<exists>b\<in>A. s = {a, b} \<and> a \<noteq> b}
    = ((card A - 1) * (card A - 2) + (card A - 1) * 2) div 2"
    by simp

  hence "\<forall>x \<in> A. card {s. \<exists>a\<in>A. \<exists>b\<in>A. s = {a, b} \<and> a \<noteq> b}
    = card A * (card A - 1) div 2"
    by (metis (no_types, lifting) One_nat_def cancel_comm_monoid_add_class.diff_cancel
     card_0_eq distrib_left le_add_diff_inverse2 less_Suc0 less_Suc_eq
     linorder_not_less mult.commute mult_zero_right one_add_one plus_1_eq_Suc remove.hyps(1) remove.hyps(2))

  then show ?case by auto
qed

theorem vc_to_clique_polynomial : "\<lbrakk>invar (V, E); finite E; finite V\<rbrakk>
\<Longrightarrow> T_vc_to_clique (V, E) = card V * (card V -1) div 2 - card E"
proof-

assume assms: "invar (V, E)" "finite E" "finite V"
hence "\<forall>s \<in> E. \<exists>a \<in> V. \<exists> b \<in> V. s = {a, b} \<and> a \<noteq> b"
apply (auto simp add: invar_def) by (metis card_2_iff insert_iff)

hence 1: "E \<subseteq> {s. \<exists>a \<in> V. \<exists>b \<in> V. s = {a, b} \<and> a \<noteq> b}" by auto

have "{s. \<exists>a \<in> V. \<exists>b \<in> V. s = {a, b} \<and> s \<notin> E \<and> a \<noteq> b}
  = {s. \<exists>a \<in> V. \<exists>b \<in> V. s = {a, b} \<and> a \<noteq> b} - E" by auto
from card_Diff_subset[OF assms(2) 1] this
have "card {s. \<exists>a \<in> V. \<exists>b \<in> V. s = {a, b} \<and> s \<notin> E \<and> a \<noteq> b} =
card {s. \<exists>a \<in> V. \<exists>b \<in> V. s = {a, b} \<and> a \<noteq> b} - card E" by argo
also have "... = card V * (card V - 1) div 2 - card E" by (auto simp add: aux[OF assms(3)])
finally show ?thesis by simp

qed

section \<open>independent set\<close>

fun independent_set :: "'a graph => 'a set => bool" where
"independent_set g s = (
  let (V, E) = g in
    (\<forall>a \<in>s. \<forall>b \<in>s. a \<noteq> b \<longrightarrow> {a, b} \<notin> E)
)"

text \<open>constant reduction from independet set to vertex cover\<close>
fun is_to_vc :: "'a graph => 'a graph" where
"is_to_vc g = g"

fun T_is_to_vc :: "'a graph => nat" where
"T_is_to_vc _ = 1"

theorem is_to_vc_correct:
assumes "invar (V, E)"
shows "independent_set (V, E) s = vertex_cover (is_to_vc (V, E)) (V-s)"
proof
  from assms have prems: "\<forall>s \<in> E. (\<forall>x \<in> s. x \<in> V)" "\<forall>s \<in> E. \<exists>a \<in> V. \<exists> b \<in> V. s = {a, b}"
  apply (auto simp: invar_def) by (metis card_2_iff insert_iff)

  assume "independent_set (V, E) s"
  hence "\<forall>a \<in>s. \<forall>b \<in>s. a \<noteq> b \<longrightarrow> {a, b} \<notin> E" by simp
  hence "(\<forall>a \<in>s. \<forall>b \<in>s.  {a, b} \<notin> E)" using assms by (force simp add: invar_def)
  hence "\<forall>s1 \<in>E. \<exists>a b. s1 = {a, b} \<and> (a \<notin> s \<or> b \<notin> s)"
  using prems(2) by metis
  hence "\<forall>s1 \<in>E. \<exists>a \<in>s1. a\<notin>s" by auto
  hence "\<forall>s1 \<in>E. \<exists>a \<in>s1. a \<in> V-s" using prems(1) by simp
  then show "vertex_cover (is_to_vc (V, E)) (V-s)" by simp

next
  assume "vertex_cover (is_to_vc (V, E)) (V-s)"
  hence "\<forall>s1 \<in>E. \<exists>a \<in>s1. a \<in>V-s" by simp
  hence "\<forall>s1 \<in>E. \<exists>a \<in>s1. a \<in> V-s" by auto
  hence "\<forall>a \<in>s. \<forall>b \<in>s. a \<noteq> b \<longrightarrow> {a, b} \<notin> E" by fastforce
  then show "independent_set (V, E) s" by simp
qed

theorem is_to_vc_polynomial: "T_is_to_vc g = 1" by simp

text \<open>reduction from clique to independent set\<close>

fun clique_to_is :: "'a graph => 'a graph" where
"clique_to_is g = (
    let (V, E) = g in (V, {s. \<exists>a \<in> V. \<exists>b \<in> V. s = {a, b} \<and> s \<notin> E \<and> a \<noteq> b})
)"

fun T_clique_to_is :: "'a graph => nat" where
"T_clique_to_is (V, E) = card {s. \<exists>a \<in> V. \<exists>b \<in> V. s = {a, b} \<and> s \<notin> E \<and> a \<noteq> b}"

theorem clique_to_is_correct :
assumes "invar (V, E)" "s \<subseteq> V"
shows "clique (V, E) s = independent_set (clique_to_is (V, E)) s"
using assms apply (auto simp add: invar_def) apply metis by blast

theorem clique_to_is_polynomial : "\<lbrakk>invar (V, E); finite E; finite v\<rbrakk>
\<Longrightarrow> T_clique_to_is (V, E) = card V * (card V -1) div 2 - card E"
using vc_to_clique_polynomial by auto

theorem threeway_reduction_correct:
assumes "invar (V, E)" "s \<subseteq> V"
shows "clique (V, E) s = vertex_cover (is_to_vc (clique_to_is (V, E))) (V - s)"
proof-

have "clique (V, E) s = independent_set (clique_to_is (V, E)) s"
 using clique_to_is_correct assms by blast

also have "... = vertex_cover (is_to_vc (clique_to_is (V, E))) (V - s)"
 using is_to_vc_correct assms
by (metis (mono_tags, lifting) clique_to_is.elims invar_vc_to_clique prod.simps(2) vc_to_clique.simps)

finally show ?thesis  by simp
qed

end


section "Stack Proofs"

theory Stack_Proof
imports Stack_Aux RTD_Util
begin

lemma push_list [simp]: "list (push x stack) = x # list stack"
  by(cases stack) auto

lemma pop_list [simp]: "list (pop stack) = tl (list stack)"
  by(induction stack rule: pop.induct) auto

lemma first_list [simp]: "\<not> is_empty stack \<Longrightarrow> first stack = hd (list stack)"
  by(induction stack rule: first.induct) auto

lemma list_empty: "list stack = [] \<longleftrightarrow> is_empty stack"
  by(induction stack rule: is_empty_stack.induct) auto

lemma list_not_empty: "list stack  \<noteq> [] \<longleftrightarrow> \<not> is_empty stack"
  by(induction stack rule: is_empty_stack.induct) auto

lemma list_empty_2 [simp]: "\<lbrakk>list stack \<noteq> []; is_empty stack\<rbrakk> \<Longrightarrow> False"
  by (simp add: list_empty)

lemma list_not_empty_2 [simp]:"\<lbrakk>list stack = []; \<not> is_empty stack\<rbrakk> \<Longrightarrow> False"
  by (simp add: list_empty)

lemma list_empty_size: "list stack = [] \<longleftrightarrow> size stack = 0"
  by(induction stack) auto

lemma list_not_empty_size:"list stack \<noteq> [] \<longleftrightarrow> 0 < size stack"
  by(induction stack) auto

lemma list_empty_size_2 [simp]: "\<lbrakk>list stack \<noteq> []; size stack = 0\<rbrakk> \<Longrightarrow> False"
  by (simp add: list_empty_size)

lemma list_not_empty_size_2 [simp]:"\<lbrakk>list stack = []; 0 < size stack\<rbrakk> \<Longrightarrow> False"
  by (simp add: list_empty_size)

lemma size_push [simp]: "size (push x stack) = Suc (size stack)"
  by(cases stack) auto

lemma size_pop [simp]: "size (pop stack) = size stack - Suc 0"
  by(induction stack rule: pop.induct) auto

lemma size_empty: "size (stack :: 'a stack) = 0 \<longleftrightarrow> is_empty stack"
  by(induction stack rule: is_empty_stack.induct) auto

lemma size_not_empty: "size (stack :: 'a stack) > 0 \<longleftrightarrow> \<not> is_empty stack"
  by(induction stack rule: is_empty_stack.induct) auto

lemma size_empty_2[simp]: "\<lbrakk>size (stack :: 'a stack) = 0; \<not>is_empty stack\<rbrakk> \<Longrightarrow> False"
  by (simp add: size_empty)

lemma size_not_empty_2[simp]: "\<lbrakk>0 < size (stack :: 'a stack); is_empty stack\<rbrakk> \<Longrightarrow> False"
  by (simp add: size_not_empty)

lemma size_list_length [simp]: "length (list stack) = size stack"
  by(cases stack) auto

lemma first_pop [simp]: "\<not> is_empty stack \<Longrightarrow> first stack # list (pop stack) = list stack"
  by(induction stack rule: pop.induct) auto

lemma push_not_empty [simp]: "\<lbrakk>\<not> is_empty stack; is_empty (push x stack)\<rbrakk> \<Longrightarrow> False"
  by(induction x stack rule: push.induct) auto

lemma pop_list_length [simp]: "\<not> is_empty stack
   \<Longrightarrow> Suc (length (list (pop stack))) = length (list stack)"
  by(induction stack rule: pop.induct) auto

lemma first_take: "\<not>is_empty stack \<Longrightarrow> [first stack] = take 1 (list stack)"
  by (simp add: list_empty)

lemma first_take_tl [simp]: "0 < size big
   \<Longrightarrow> (first big # take count (tl (list big))) = take (Suc count) (list big)"
  by(induction big rule: Stack.first.induct) auto

lemma first_take_pop [simp]: "\<lbrakk>\<not>is_empty stack; 0 < x\<rbrakk>
   \<Longrightarrow> first stack # take (x - Suc 0) (list (pop stack)) = take x (list stack)"
  by(induction stack rule: pop.induct) (auto simp: take_Cons')

lemma first_hd: "first stack = hd (list stack)"
  by(induction stack rule: first.induct)(auto simp: hd_def)

lemma pop_tl [simp]: "list (pop stack) = tl (list stack)"
  by(induction stack rule: pop.induct) auto

lemma pop_drop: "list (pop stack) = drop 1 (list stack)"
  by (simp add: drop_Suc)

lemma popN_drop [simp]: "list ((pop ^^ n) stack) = drop n (list stack)"
  by(induction n)(auto simp: drop_Suc tl_drop)

lemma popN_size [simp]: "size ((pop ^^ n) stack) = (size stack) - n"
 by(induction n) auto

lemma take_first: "\<lbrakk>0 < size s1; 0 < size s2; take (size s1) (list s2) = take (size s2) (list s1)\<rbrakk>
    \<Longrightarrow> first s1 = first s2"
  by(induction s1 rule: first.induct; induction s2 rule: first.induct) auto

end


(*  Title:      The Second Isomorphism Theorem for Groups
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory SndIsomorphismGrp
imports
    "HOL-Algebra.Coset"
    Secondary_Sylow.SubgroupConjugation
begin

section \<open>The Second Isomorphism Theorem for Groups\<close>

subsection \<open>Preliminaries\<close>

lemma (in group) triv_subgroup:
  shows "subgroup {\<one>} G"
unfolding subgroup_def by auto

lemma (in group) triv_normal_subgroup:
  shows "{\<one>} \<lhd> G"
unfolding normal_def normal_axioms_def l_coset_def r_coset_def
using is_group triv_subgroup by auto

lemma (in group) normal_restrict_supergroup:
  assumes SsubG:"subgroup S G"
  assumes Nnormal:"N \<lhd> G"
  assumes "N \<subseteq> S"
  shows "N \<lhd> (G\<lparr>carrier := S\<rparr>)"
proof -
  interpret Sgrp: group "G\<lparr>carrier := S\<rparr>" using SsubG by (rule subgroup_imp_group)
  show ?thesis
  proof(rule Sgrp.normalI)
    show "subgroup N (G\<lparr>carrier := S\<rparr>)" using assms is_group by (metis subgroup.subgroup_of_subset normal_inv_iff)
  next
    from SsubG have "S \<subseteq> carrier G" by (rule subgroup.subset)
    thus "\<forall>x\<in>carrier (G\<lparr>carrier := S\<rparr>). N #>\<^bsub>G\<lparr>carrier := S\<rparr>\<^esub> x = x <#\<^bsub>G\<lparr>carrier := S\<rparr>\<^esub> N"
      using Nnormal unfolding normal_def normal_axioms_def l_coset_def r_coset_def by fastforce
  qed
qed

text \<open>As this is maybe the best place this fits in: Factorizing by the trivial subgroup
is an isomorphism.\<close>

lemma (in group) trivial_factor_iso:
  shows "the_elem \<in> iso (G Mod {\<one>}) G"
proof -
  have "group_hom G G (\<lambda>x. x)" unfolding group_hom_def group_hom_axioms_def hom_def using is_group by simp
  moreover have "(\<lambda>x. x) ` carrier G = carrier G" by simp
  moreover have "kernel G G (\<lambda>x. x) = {\<one>}" unfolding kernel_def by auto
  ultimately show ?thesis using group_hom.FactGroup_iso_set by force
qed

text \<open>And the dual theorem to the previous one: Factorizing by the group itself gives the trivial group\<close>

lemma (in group) self_factor_iso:
  shows "(\<lambda>X. the_elem ((\<lambda>x. \<one>) ` X)) \<in> iso (G Mod (carrier G)) (G\<lparr> carrier := {\<one>} \<rparr>)"
proof -
  have "group (G\<lparr>carrier := {\<one>}\<rparr>)" by (metis subgroup_imp_group triv_subgroup)
  hence "group_hom G (G\<lparr>carrier := {\<one>}\<rparr>) (\<lambda>x. \<one>)" unfolding group_hom_def group_hom_axioms_def hom_def using is_group by auto
  moreover have "(\<lambda>x. \<one>) ` carrier G = carrier (G\<lparr>carrier := {\<one>}\<rparr>)" by auto
  moreover have "kernel G (G\<lparr>carrier := {\<one>}\<rparr>) (\<lambda>x. \<one>) = carrier G" unfolding kernel_def by auto
  ultimately show ?thesis using group_hom.FactGroup_iso_set by force
qed

text \<open>This theory provides a proof of the second isomorphism theorems for groups.
The theorems consist of several facts about normal subgroups.\<close>

text \<open>The first lemma states that whenever we have a subgroup @{term S} and
a normal subgroup @{term H} of a group @{term G}, their intersection is normal
in @{term G}\<close>

locale second_isomorphism_grp = normal +
  fixes S::"'a set"
  assumes subgrpS:"subgroup S G"

context second_isomorphism_grp
begin

interpretation groupS: group "G\<lparr>carrier := S\<rparr>"
using subgrpS by (metis subgroup_imp_group)

lemma normal_subgrp_intersection_normal:
  shows "S \<inter> H \<lhd> (G\<lparr>carrier := S\<rparr>)"
proof(auto simp: groupS.normal_inv_iff)
  from subgrpS is_subgroup have "\<And>x. x \<in> {S, H} \<Longrightarrow> subgroup x G" by auto
  hence "subgroup (\<Inter> {S, H}) G" using subgroups_Inter by blast
  hence "subgroup (S \<inter> H) G" by auto
  moreover have "S \<inter> H \<subseteq> S" by simp
  ultimately show "subgroup (S \<inter> H) (G\<lparr>carrier := S\<rparr>)" using is_group subgroup.subgroup_of_subset subgrpS by metis
next
  fix g h
  assume g:"g \<in> S" and hH:"h \<in> H" and hS:"h \<in> S" {
    from g hH subgrpS show "g \<otimes> h \<otimes> inv\<^bsub>G\<lparr>carrier := S\<rparr>\<^esub> g \<in> H" by (metis inv_op_closed2 subgroup.mem_carrier m_inv_consistent)
  } {
    from g hS subgrpS show "g \<otimes> h \<otimes> inv\<^bsub>G\<lparr>carrier := S\<rparr>\<^esub> g \<in> S" by (metis subgroup.m_closed subgroup.m_inv_closed m_inv_consistent)
  }
qed

lemma normal_set_mult_subgroup:
  shows "subgroup (H <#> S) G"
proof(rule subgroupI)
  show "H <#> S \<subseteq> carrier G" by (metis setmult_subset_G subgroup.subset subgrpS subset)
next
  have "\<one> \<in> H" "\<one> \<in> S" using is_subgroup subgrpS subgroup.one_closed by auto
  hence "\<one> \<otimes> \<one> \<in> H <#> S" unfolding set_mult_def by blast
  thus "H <#> S \<noteq> {}" by auto
next
  fix g
  assume g:"g \<in> H <#> S"
  then obtain h s where h:"h \<in> H" and s:"s \<in> S" and ghs:"g = h \<otimes> s" unfolding set_mult_def by auto
  hence "s \<in> carrier G" by (metis subgroup.mem_carrier subgrpS)
  with h ghs obtain h' where h':"h' \<in> H" and "g = s \<otimes> h'" using coset_eq unfolding r_coset_def l_coset_def by auto
  with s have "inv g = (inv h') \<otimes> (inv s)" by (metis inv_mult_group mem_carrier subgroup.mem_carrier subgrpS)
  moreover from h' s subgrpS have "inv h' \<in> H" "inv s \<in> S" using subgroup.m_inv_closed m_inv_closed by auto
  ultimately show "inv g \<in> H <#> S" unfolding set_mult_def by auto
next
  fix g g'
  assume g:"g \<in> H <#> S" and h:"g' \<in> H <#> S"
  then obtain h h' s s' where hh'ss':"h \<in> H" "h' \<in> H" "s \<in> S" "s' \<in> S" and "g = h \<otimes> s" and "g' = h' \<otimes> s'" unfolding set_mult_def by auto
  hence "g \<otimes> g' = (h \<otimes> s) \<otimes> (h' \<otimes> s')" by metis
  also from hh'ss' have inG:"h \<in> carrier G" "h' \<in> carrier G" "s \<in> carrier G" "s' \<in> carrier G" using subgrpS mem_carrier subgroup.mem_carrier by force+
  hence "(h \<otimes> s) \<otimes> (h' \<otimes> s') = h \<otimes> (s \<otimes> h') \<otimes> s'" using m_assoc by auto
  also from hh'ss' inG obtain h'' where h'':"h'' \<in> H" and "s \<otimes> h' = h'' \<otimes> s"using coset_eq unfolding r_coset_def l_coset_def by fastforce
  hence "h \<otimes> (s \<otimes> h') \<otimes> s' = h \<otimes> (h'' \<otimes> s) \<otimes> s'" by simp
  also from h'' inG have "... = (h \<otimes> h'') \<otimes> (s \<otimes> s')" using m_assoc mem_carrier by auto
  finally have "g \<otimes> g' = h \<otimes> h'' \<otimes> (s \<otimes> s')".
  moreover with h'' hh'ss' have "... \<in> H <#> S" unfolding set_mult_def using subgrpS subgroup.m_closed by fastforce
  ultimately show "g \<otimes> g' \<in> H <#> S" by simp
qed

lemma oneH:"\<one> \<in> H" by (metis is_subgroup subgroup.one_closed)

lemma H_contained_in_set_mult:
  shows "H \<subseteq> H <#> S"
proof auto
  have "\<one> \<in> S" by (metis subgroup.one_closed subgrpS)
  fix x
  assume x:"x \<in> H"
  with \<open>\<one> \<in> S\<close> have "x \<otimes> \<one> \<in> H <#> S" unfolding set_mult_def by force
  with x show  "x \<in> H <#> S" by (metis mem_carrier r_one)
qed

lemma S_contained_in_set_mult:
  shows "S \<subseteq> H <#> S"
proof auto
  fix s
  assume s:"s \<in> S"
  with oneH have "\<one> \<otimes> s \<in> H <#> S" unfolding set_mult_def by force
  with s show "s \<in> H <#> S" using subgrpS subgroup.mem_carrier l_one by force
qed

lemma normal_intersection_hom:
  shows "group_hom (G\<lparr>carrier := S\<rparr>) ((G\<lparr>carrier := H <#> S\<rparr>) Mod H) (\<lambda>g. H #> g)"
proof (auto del: equalityI simp: group_hom_def group_hom_axioms_def hom_def groupS.is_group)
  have  gr:"group (G\<lparr>carrier := H <#> S\<rparr>)" by (metis normal_set_mult_subgroup subgroup_imp_group)
  moreover have "H \<subseteq> H <#> S" by (rule H_contained_in_set_mult)
  moreover have "subgroup (H <#> S) G" by (metis normal_set_mult_subgroup)
  ultimately have "H \<lhd> (G\<lparr>carrier := H <#> S\<rparr>)" using normal_restrict_supergroup by (metis inv_op_closed2 is_subgroup normal_inv_iff)
  with gr show "group ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)" by (metis normal.factorgroup_is_group)
next
  fix g
  assume g: "g \<in> S"
  with subgrpS have "\<one> \<otimes> g \<in> H <#> S" unfolding set_mult_def by fastforce
  with g have "g \<in> H <#> S" by (metis l_one subgroup.mem_carrier subgrpS)
  thus "H #> g \<in> carrier ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)" unfolding FactGroup_def RCOSETS_def r_coset_def by auto
next
  show "\<And>x y. \<lbrakk>x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> H #> x \<otimes> y = H #> x <#> (H #> y)"
    using normal.rcos_sum normal_axioms subgroup.mem_carrier subgrpS by fastforce
qed

lemma normal_intersection_hom_kernel:
  shows "kernel (G\<lparr>carrier := S\<rparr>) ((G\<lparr>carrier := H <#> S\<rparr>) Mod H) (\<lambda>g. H #> g) = H \<inter> S"
proof -
  have "kernel (G\<lparr>carrier := S\<rparr>) ((G\<lparr>carrier := H <#> S\<rparr>) Mod H) (\<lambda>g. H #> g)
                 = {g \<in> S. H #> g = \<one>\<^bsub>(G\<lparr>carrier := H <#> S\<rparr>) Mod H\<^esub>}" unfolding kernel_def by auto
  also have "... = {g \<in> S. H #> g = H}" unfolding FactGroup_def by auto
  also have "... = {g \<in> S. g \<in> H}" by (metis coset_eq is_subgroup lcoset_join2 rcos_self subgroup.mem_carrier subgrpS)
  also have "... = H \<inter> S" by auto
  finally show ?thesis.
qed

lemma normal_intersection_hom_surj:
  shows "(\<lambda>g. H #> g) ` carrier (G\<lparr>carrier := S\<rparr>) = carrier ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)"
proof auto
  fix g
  assume "g \<in> S"
  hence "g \<in> H <#> S" using S_contained_in_set_mult by auto
  thus "H #> g \<in> carrier ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)" unfolding FactGroup_def RCOSETS_def r_coset_def by auto
next
  fix x
  assume "x \<in> carrier (G\<lparr>carrier := H <#> S\<rparr> Mod H)"
  then obtain h s where h:"h \<in> H" and s:"s \<in> S" and "x = H #> (h \<otimes> s)"
    unfolding FactGroup_def RCOSETS_def r_coset_def set_mult_def by auto
  hence "x = (H #> h) #> s" by (metis h s coset_mult_assoc mem_carrier subgroup.mem_carrier subgrpS subset)
  also have "... = H #> s" by (metis h is_group rcos_const)
  finally have "x = H #> s".
  with s show "x \<in> (#>) H ` S" by simp
qed

text \<open>Finally we can prove the actual isomorphism theorem:\<close>

theorem normal_intersection_quotient_isom:
  shows "(\<lambda>X. the_elem ((\<lambda>g. H #> g) ` X)) \<in> iso ((G\<lparr>carrier := S\<rparr>) Mod (H \<inter> S)) (((G\<lparr>carrier := H <#> S\<rparr>)) Mod H)"
using normal_intersection_hom_kernel[symmetric] normal_intersection_hom normal_intersection_hom_surj
by (metis group_hom.FactGroup_iso_set)

end

end


theory Lecture14
imports Main
begin

primrec myappend :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"myappend Nil ys = ys" |
"myappend (Cons x xs) ys = Cons x (myappend xs ys)"

lemma  "myappend xs (myappend ys zs) = myappend (myappend xs ys) zs"
apply (induct xs)
apply simp
apply simp
done

lemma  myappend_assoc: "myappend xs (myappend ys zs) = myappend (myappend xs ys) zs"
proof (induction xs)
  case Nil then show ?case by simp
next
  case (Cons x xs) then show ?case by simp
qed

lemma myappend_Nil: "myappend xs Nil = xs"
proof (induction xs)
  case Nil thus ?case  by simp
next
  case (Cons x xs) thus ?case by simp
qed

primrec myreverse :: "'a list \<Rightarrow> 'a list" where
"myreverse Nil = Nil" |
"myreverse (Cons x xs) = myappend (myreverse xs) (Cons x Nil)"

lemma myreverse_myreverse: "myreverse(myreverse xs) = xs"
apply (induct xs)
apply simp
apply simp
(* stuck: need to speculate a lemma *)
oops

lemma speculated_myreverse:
  "myreverse(myappend xs ys) = myappend (myreverse ys) (myreverse xs)"
proof (induction xs)
  case Nil then show ?case by (simp add: myappend_Nil)
next
  case (Cons x xs) then show ?case by (simp add:myappend_assoc)
qed

(* A detailed proof to match the one given in the lecture *)

lemma myreverse_myreverse: "myreverse(myreverse xs) = xs"
proof (induct xs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  then have "myreverse (myreverse (x # xs)) = myreverse(myappend (myreverse xs) (Cons x Nil))"
       by simp
  moreover have "\<dots> = myappend (Cons x Nil) (myreverse(myreverse xs))"
      by (simp add: speculated_myreverse)
  moreover have "\<dots> = Cons x (myappend Nil (myreverse(myreverse xs)))"
      by simp
  moreover have "\<dots> = Cons x (myreverse(myreverse xs))"
      by simp
  moreover have "\<dots> = Cons x xs" using Cons.hyps by blast
  ultimately show ?case by simp
qed

(* Simpler proof -- as one would normally do it*)
lemma myreverse_myreverse2: "myreverse(myreverse xs) = xs"
proof (induct xs)
  case Nil thus ?case by simp
next
  case (Cons x xs) thus ?case by (simp add: speculated_myreverse)
qed

end


(*  Title:       Category theory using Isar and Locales
    Author:      Greg O'Keefe, June, July, August 2003
    License: LGPL
*)

header {* Categories *}

theory Cat
imports "~~/src/HOL/Library/FuncSet"
begin

subsection {* Definitions *}

record ('o, 'a) category =
  ob :: "'o set" ("Ob\<index>"  70)
  ar :: "'a set" ("Ar\<index>"  70)
  dom :: "'a \<Rightarrow> 'o" ("Dom\<index> _" [81] 70)
  cod :: "'a \<Rightarrow> 'o" ("Cod\<index> _" [81] 70)
  id :: "'o \<Rightarrow> 'a" ("Id\<index> _" [81] 80)
  comp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "\<bullet>\<index>" 60)

definition
  hom :: "[('o,'a,'m) category_scheme, 'o, 'o] \<Rightarrow> 'a set"
    ("Hom\<index> _ _" [81,81] 80) where
  "hom CC A B = { f. f\<in>ar CC & dom CC f = A & cod CC f = B }"

locale category =
  fixes CC (structure)
  assumes dom_object [intro]:
  "f \<in> Ar \<Longrightarrow> Dom f \<in> Ob"
  and cod_object [intro]:
  "f \<in> Ar \<Longrightarrow> Cod f \<in> Ob"
  and id_left [simp]:
  "f \<in> Ar \<Longrightarrow> Id (Cod f) \<bullet> f = f"
  and id_right [simp]:
  "f \<in> Ar \<Longrightarrow> f \<bullet> Id (Dom f) = f"
  and id_hom [intro]:
  "A \<in> Ob \<Longrightarrow> Id A \<in> Hom A A"
  and comp_types [intro]:
  "\<And>A B C. (comp CC) : (Hom B C) \<rightarrow> (Hom A B) \<rightarrow> (Hom A C)"
  and comp_associative [simp]:
  "f \<in> Ar \<Longrightarrow> g \<in> Ar \<Longrightarrow> h \<in> Ar
  \<Longrightarrow> Cod h = Dom g \<Longrightarrow> Cod g = Dom f
  \<Longrightarrow> f \<bullet> (g \<bullet> h) = (f \<bullet> g) \<bullet> h"

subsection {* Lemmas *}

lemma (in category) homI:
  assumes "f \<in> Ar" and "Dom f = A" and "Cod f = B"
  shows "f \<in> Hom A B"
  using assms by (auto simp add: hom_def)

lemma (in category) id_dom_cod:
  assumes "A \<in> Ob"
  shows "Dom (Id A) = A" and "Cod (Id A) = A"
proof-
  from `A \<in> Ob` have 1: "Id A \<in> Hom A A" ..
  then show "Dom (Id A) = A" and "Cod (Id A) = A"
    by (simp_all add: hom_def)
qed

lemma (in category) compI [intro]:
  assumes f: "f \<in> Ar" and g: "g \<in> Ar" and "Cod f = Dom g"
  shows "g \<bullet> f \<in> Ar"
  and "Dom (g \<bullet> f) = Dom f"
  and "Cod (g \<bullet> f) = Cod g"
proof-
  have "f \<in> Hom (Dom f) (Cod f)" using f by (simp add: hom_def)
  with `Cod f = Dom g` have f_homset: "f \<in> Hom (Dom f) (Dom g)" by simp
  have g_homset: "g \<in> Hom (Dom g) (Cod g)" using g by (simp add: hom_def)
  have "(op \<bullet>) : Hom (Dom g) (Cod g) \<rightarrow> Hom (Dom f) (Dom g) \<rightarrow> Hom (Dom f) (Cod g)" ..
  from this and g_homset
  have "(op \<bullet>) g \<in> Hom (Dom f) (Dom g) \<rightarrow> Hom (Dom f) (Cod g)"
    by (rule funcset_mem)
  from this and f_homset
  have gf_homset: "g \<bullet> f \<in> Hom (Dom f) (Cod g)"
    by (rule funcset_mem)
  thus "g \<bullet> f \<in> Ar"
    by (simp add: hom_def)
  from gf_homset show "Dom (g \<bullet> f) = Dom f" and "Cod (g \<bullet> f) = Cod g"
    by (simp_all add: hom_def)
qed

end


section\<open>Repeat finitely Until it Stabilizes\<close>
theory Repeat_Stabilize
imports Main
begin

text\<open>Repeating something a number of times\<close>

text\<open>Iterating a function at most @{term n} times (first parameter) until it stabilizes.\<close>
fun repeat_stabilize :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
  "repeat_stabilize 0 _ v = v" |
  "repeat_stabilize (Suc n) f v = (let v_new = f v in if v = v_new then v else repeat_stabilize n f v_new)"

lemma repeat_stabilize_funpow: "repeat_stabilize n f v = (f^^n) v"
  proof(induction n arbitrary: v)
  case (Suc n)
    have "f v = v \<Longrightarrow> (f^^n) v = v" by(induction n) simp_all
    with Suc show ?case by(simp add: Let_def funpow_swap1)
  qed(simp)

lemma repeat_stabilize_induct: "(P m) \<Longrightarrow> (\<And>m. P m \<Longrightarrow> P (f m)) \<Longrightarrow> P (repeat_stabilize n f m)"
  apply(simp add: repeat_stabilize_funpow)
  apply(induction n)
   by(simp)+

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_HSortIsSort
  imports "../../Test_Base"
begin

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

datatype Heap = Node "Heap" "int" "Heap" | Nil

fun toHeap :: "int list => Heap list" where
  "toHeap (nil2) = nil2"
| "toHeap (cons2 y z) = cons2 (Node Nil y Nil) (toHeap z)"

fun insert :: "int => int list => int list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if x <= z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "int list => int list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

fun hpairwise :: "Heap list => Heap list" where
  "hpairwise (nil2) = nil2"
| "hpairwise (cons2 p (nil2)) = cons2 p (nil2)"
| "hpairwise (cons2 p (cons2 q qs)) =
     cons2 (hmerge p q) (hpairwise qs)"

(*fun did not finish the proof*)
function hmerging :: "Heap list => Heap" where
  "hmerging (nil2) = Nil"
| "hmerging (cons2 p (nil2)) = p"
| "hmerging (cons2 p (cons2 z x2)) =
     hmerging (hpairwise (cons2 p (cons2 z x2)))"
  by pat_completeness auto

fun toHeap2 :: "int list => Heap" where
  "toHeap2 x = hmerging (toHeap x)"

(*fun did not finish the proof*)
function toList :: "Heap => int list" where
  "toList (Node p y q) = cons2 y (toList (hmerge p q))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hsort :: "int list => int list" where
  "hsort x = toList (toHeap2 x)"

theorem property0 :
  "((hsort xs) = (isort xs))"
  oops

end


theory Lab3_Theory
imports Main
begin

(* Topic: Recursion, induction and counterexamples *)

(*
  replace :: Old \<Rightarrow> New \<Rightarrow> List \<Rightarrow> List'
  Replaces all occurences of Old in List with New.
*)
primrec replace :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "replace x y [] = []"
  | "replace x y (z#zs) = (if z = x then y else z)#(replace x y zs)"

value "replace 1 0 [1, 1, 2] :: int list"

(*
  del1 :: Item \<Rightarrow> List \<Rightarrow> List'
  Deletes first occurence of Item in List.
*)
primrec del1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "del1 x [] = []"
  | "del1 x (y#ys) = (if y = x then ys else y#(del1 x ys))"

value "del1 1 [0, 0, 1, 1] :: int list"

(*
  delall :: Item \<Rightarrow> List \<Rightarrow> List'
  Deletes all occurences of Item in List.
*)
primrec delall :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "delall x [] = []"
  | "delall x (y#ys) = (if y = x then (delall x ys) else y#(delall x ys))"

value "delall 0 [1, 1, 0, 0, 1] :: int list"

export_code replace delall del1
  in Haskell module_name App file "haskabelle"

(* Вариант 3: 3 и 5
    3: theorem "del1 x (del1 y zs) = del1 y (del1 x zs)"
    5: theorem "del1 y (replace x y xs) = del1 x xs"
*)

(*
  prove
  e.g.:
    List = [0, 0, 1, 2]
    del1 0 (del1 1 List) = del1 1 (del1 0 List) = [2]
*)
theorem [simp]: "del1 x (del1 y zs) = del1 y (del1 x zs)"
  apply(induct_tac zs)
  apply auto
done

(*
  fail to prove
  e.g.:
    List = [0, 0, 1, 1]
    LHS: del1 1 (replace 0 1 List) = [1, 1, 1]
    RHS: del1 0 List = [0, 1, 1]
    [1, 1, 1] \<noteq> [0, 1, 1]
*)
theorem "del1 y (replace x y xs) = del1 x xs"
  apply(induct_tac xs)
  apply auto
  quickcheck 1
  quickcheck 2
  quickcheck 3
oops


theory MultiAssets
imports Semantics
begin

section "Assets"

text "We represent Multi-token assets as a function from Token to natural numbers."
(*
TODO: I want to replace Asset definition with
typedef Assets = "{assets. (\<forall> t v. fmlookup assets t = Some v \<longrightarrow> v > 0)} :: ((Token, nat) fmap) set

but I need to solve this issue https://isabelle.zulipchat.com/#narrow/stream/238552-Beginner-Questions/topic/Is.20it.20possible.20to.20create.20a.20typedef.20.20of.20a.20typedef.3F/near/340510660
*)

typedef Assets = "{assets :: Token \<Rightarrow> nat. True}"
  by auto

setup_lifting type_definition_Assets

text
"
The \<^emph>\<open>asset\<close> definition allows us to create a single-token asset
"
lift_definition asset :: "Token \<Rightarrow> nat \<Rightarrow> Assets"
  is "\<lambda>tok val. \<lambda>t. if t = tok then val else 0"
  by simp

text
"
The \<^emph>\<open>assetValue\<close> definition allow us to obtain how many \<^emph>\<open>tokens\<close> (for a particular token)
are in the Assets
"
lift_definition assetValue :: "Token \<Rightarrow> Assets \<Rightarrow> nat" is
  "\<lambda>t a. a t" .

lemma assetValueOfSingleAsset [simp] : "assetValue tok (asset tok b) = b"
  by transfer simp

lemma assetValueOfDifferentToken [simp] : "tok1 \<noteq> tok2 \<Longrightarrow> assetValue tok1 (asset tok2 b) = 0"
  by transfer simp

lemma assetsEqByValue: "a = b \<longleftrightarrow> (\<forall> tok. assetValue tok a = assetValue tok b)"
  by transfer auto

subsection "Ordering"
text "
We define partial order for assets instead of total order because we cannot compare values of different tokens.
"

text "We need to define order because Assets can't be negative, so we can only simplify things like
\<^term>\<open>a + (b - a) = b\<close> if \<^term>\<open>a \<le> b\<close>.
"
instantiation Assets :: ord
begin
  lift_definition less_eq_Assets :: "Assets \<Rightarrow> Assets \<Rightarrow> bool"
    is "\<lambda>a b. \<forall>t. a t \<le> b t" .

  lift_definition less_Assets :: "Assets \<Rightarrow> Assets \<Rightarrow> bool"
    is "\<lambda>a b. (\<forall>rt. a rt \<le> b rt) \<and> (\<exists> st. a st < b st)" .

  instance ..
end

instantiation Assets :: preorder
begin
  instance proof
   fix a b c :: Assets
   show "a \<le> a"
     by transfer simp
   show "a \<le> b \<Longrightarrow> b \<le> c \<Longrightarrow> a \<le> c"
     using le_trans by transfer blast
   show "a < b = ( a \<le> b \<and> \<not>  b \<le> a)"
     by transfer (metis leD leI)
  qed
end

instantiation Assets :: order
begin
  instance proof
    fix a b :: Assets
    show "a \<le> b \<Longrightarrow>  b \<le> a \<Longrightarrow> a = b"
      using le_antisym by transfer blast
  qed
end

text "If we create a single asset from a multi-asset, then the single asset is going to be lower or
equal to the multi-asset"
lemma singleAsset_leq_than_asset: "asset t (assetValue t a) \<le> a"
  by transfer simp

subsection "Arithmetic"

instantiation Assets :: zero
begin
  lift_definition zero_Assets :: Assets
    is "\<lambda>_. 0"
    by simp

  instance ..
end

text "Creating a single asset with 0 tokens is the same as creating the zero_Assets"
lemma assetZero [simp] : "asset tok 0 = 0"
  by transfer auto

text "If we try to create a single asset from a negative integer is also the same as creating the zero_Assets"
corollary assetOfNegInt [simp] : "(i :: int) \<le> 0 \<Longrightarrow> asset t (nat i) = 0"
  by simp

text "Trying to count the amount of tokens of the zero_Assets is 0"
lemma assetValueOfZero [simp] : "assetValue t 0 = 0"
  by transfer simp

instantiation Assets :: plus
begin
  lift_definition plus_Assets :: "Assets \<Rightarrow> Assets \<Rightarrow> Assets"
    is "\<lambda>x y. \<lambda>tok. x tok + y tok"
    by auto

  instance ..
end

lemma assetsDistributesPlus : "asset tok (a + b) = asset tok a + asset tok b"
  by transfer auto

lemma assetsJoinPlus : "asset tok a + asset tok b = asset tok (a + b)"
  by (simp add: assetsDistributesPlus)

lemma assetValue_distrib : "assetValue tok (a + b) = assetValue tok a + assetValue tok b"
  by transfer auto

instantiation Assets :: minus
begin
  lift_definition minus_Assets :: "Assets \<Rightarrow> Assets \<Rightarrow> Assets"
    is "\<lambda>x y. \<lambda>tok. x tok - y tok"
    by auto

  instance ..
end

lemma assetsDistributesMinus : "asset tok (a - b) = asset tok a - asset tok b"
  by transfer auto

instantiation Assets :: semigroup_add
begin
  instance proof
    fix a b c :: Assets
    show "(a + b) + c = a + (b + c)"
      by transfer (simp add: Groups.ab_semigroup_add_class.add_ac(1))
  qed
end

instantiation Assets :: ab_semigroup_add
begin
  instance proof
    fix a b :: Assets
    show "a + b = b + a"
      by transfer (simp add: Groups.ab_semigroup_add_class.add.commute)
  qed
end

instantiation Assets :: monoid_add
begin
  instance proof
    fix a :: Assets
    show "0 + a = a"
      by transfer auto
    show "a + 0 = a"
      by transfer auto
  qed
end

(* TODO: This should be included by monoid_add, but for some reason I cannot delete it *)
instantiation Assets :: comm_monoid_add
begin
  instance by standard simp
end

instantiation Assets :: cancel_ab_semigroup_add
begin
  instance proof
    fix a b c :: Assets
    show "a + b - a = b"
      by transfer force
    show "a - b - c = a - (b + c)"
      using diff_diff_left by transfer presburger
  qed
end

instantiation Assets :: comm_monoid_diff
begin
  instance proof
    fix a :: Assets
    show "0 - a = 0"
      by transfer simp
  qed
end

instantiation Assets :: ordered_ab_semigroup_add
begin
  instance proof
    fix a b c :: Assets
    show "a \<le> b \<Longrightarrow> c + a \<le> c + b"
      by transfer simp
  qed
end

instantiation Assets :: ordered_ab_semigroup_add_imp_le
begin
  instance proof
    fix a b c :: Assets
    show "c + a \<le> c + b \<Longrightarrow> a \<le> b"
      by transfer simp
  qed
end

instantiation Assets :: canonically_ordered_monoid_add
begin
  instance proof
    fix a b :: Assets
    (* TODO: See how to make this proof structured *)
    have "a \<le> b \<Longrightarrow> \<exists>c. b = a + c"
     apply transfer
      subgoal for a2 b2
        apply (subgoal_tac  "\<And> x. a2 x \<le> b2 x \<Longrightarrow> b2 x = a2 x + (b2 x - a2 x)")
         apply fast
        by simp
      done
    also have "\<exists>c. b = a + c \<Longrightarrow> a \<le> b"
      by transfer auto
    then show "(a \<le> b) = (\<exists>c. b = a + c)"
      using calculation by blast
  qed
end

instantiation Assets :: ordered_cancel_comm_monoid_diff
begin
  instance by standard
end

end


theory CS_Ch3
imports Main
begin

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a1 a2) = (case (asimp_const a1, asimp_const a2) of
  (N n1, N n2) \<Rightarrow> N (n1+n2) |
  (b1, b2) \<Rightarrow> Plus b1 b2)"

lemma "aval (asimp_const a) s = aval a s"
apply(induction a)
apply(auto split: aexp.split)
done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i1) (N i2) = N (i1 + i2)" |
"plus (N i) a = (if i = 0 then a else Plus (N i) a)" |
"plus a (N i) = (if i = 0 then a else Plus a (N i))" |
"plus a1 a2 = Plus a1 a2"

lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply(auto)
done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

lemma "aval (asimp a) s = aval a s"
apply(induction a)
apply(auto simp add: aval_plus)
done

(* 3.1 *)

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N a) = True" |
"optimal (V x) = True" |
"optimal (Plus (N a) (N b)) = False" |
"optimal (Plus a b) = (optimal a \<and> optimal b)"

lemma "optimal (asimp_const a)"
apply(induction a)
apply(auto split: aexp.split)
done

(* 3.2 *)

(* If you view this as a rewriting system that is designed to work only in conjunction
   with full_asimp, the structure of this function makes sense. We apply full_asimp recursively,
   so this function can look as few layers deep as it wants into the expression and full_asimp will
   glue it together. That is, its correctness can be inductively proven. *)
fun full_plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"full_plus (N i1) (N i2) = N (i1 + i2)" |
"full_plus (N i1) (Plus a (N i2)) = Plus a (N (i1 + i2))" |
"full_plus (Plus a (N i1)) (N i2) = Plus a (N (i1 + i2))" |
"full_plus a (Plus b (N i1)) = Plus (Plus a b) (N i1)" |
"full_plus (Plus a (N i1)) b = Plus (Plus a b) (N i1)" |
"full_plus (N i) a = (if i = 0 then a else Plus (N i) a)" |
"full_plus a (N i) = (if i = 0 then a else Plus a (N i))" |
"full_plus a1 a2 = Plus a1 a2"

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp (N a) = N a" |
"full_asimp (V x) = V x" |
"full_asimp (Plus a b) = full_plus (full_asimp a) (full_asimp b)"

lemma aval_full_plus: "aval (full_plus a b) s = aval a s + aval b s"
apply(induction rule: full_plus.induct)
apply(auto)
done

lemma "aval (full_asimp a) s = aval a s"
apply(induction a)
apply(auto simp add: aval_full_plus)
done

(* 3.3 *)

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (N i1) = N i1" |
"subst x a (V y) = (if x = y then a else (V y))" |
"subst x a (Plus b1 b2) = Plus (subst x a b1) (subst x a b2)"

lemma subst_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
apply(induction e)
apply(auto)
done

lemma "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
apply(induction e)
apply(auto)
done

(* 3.4 is a separate theory, CS_Ch3_Ex4 *)

(* 3.5 *)
datatype aexp2 = N2 int | V2 vname | Plus2 aexp2 aexp2 | PostIncr2 vname | Div2 aexp2 aexp2
fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state) option" where
"aval2 (N2 i) s = Some (i, s)" |
"aval2 (V2 x) s = Some (s x, s)" |
"aval2 (Plus2 a b) s = (case (aval2 a s) of Some (a', s') \<Rightarrow>
  (case (aval2 b s') of Some (b', s'') \<Rightarrow> Some (a' + b', s'') | None \<Rightarrow> None) | None \<Rightarrow> None)" |
"aval2 (PostIncr2 x) s = Some (s x, s(x := (s x) + 1))" |
"aval2 (Div2 a b) s = (case (aval2 b s) of Some (b', s') \<Rightarrow> (if b' = 0 then None else Some (
  case (aval2 a s') of Some (a', s'') \<Rightarrow> (a' div b', s''))) | None \<Rightarrow> None)"

lemma "aval2 (Div2 (N2 3) (Plus2 (N2 1) (V2 ''x''))) (\<lambda>x. -1) = None"
apply(auto)
done

lemma "case aval2 (Div2 (N2 3) (PostIncr2 ''x'')) (\<lambda>x. 1) of Some (a, b) \<Rightarrow> (a = 3 \<and> b(''x'') = 2) | None \<Rightarrow> False"
apply(auto)
done

(* 3.6 *)

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp
fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
"lval (Nl i) s = i" |
"lval (Vl x) s = s x" |
"lval (Plusl a b) s = lval a s + lval b s" |
"lval (LET x val body) s = lval body (s(x := lval val s))"

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl i) = (N i)" |
"inline (Vl x) = (V x)" |
"inline (Plusl a b) = Plus (inline a) (inline b)" |
"inline (LET x val body) = subst x (inline val) (inline body)"

lemma "lval e s = aval (inline e) s"
apply(induction e arbitrary: s)
apply(auto simp add: subst_lemma)
done

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and b\<^sub>1 b\<^sub>2 = And b\<^sub>1 b\<^sub>2"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (aexp.N n\<^sub>1) (aexp.N n\<^sub>2) = Bc (n\<^sub>1 < n\<^sub>2)" |
"less a\<^sub>1 a\<^sub>2 = Less a\<^sub>1 a\<^sub>2"

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not (bsimp b)" |
"bsimp (And b\<^sub>1 b\<^sub>2) = and (bsimp b\<^sub>1) (bsimp b\<^sub>2)" |
"bsimp (Less a\<^sub>1 a\<^sub>2) = less (asimp a\<^sub>1) (asimp a\<^sub>2)"

(* 3.7 *)

fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq a b = And (Not (Less a b)) (Not (Less b a))"

lemma "bval (Eq a b) s = (aval a s = aval b s)"
apply(auto)
done

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le a b = Not (And (Not (Less a b)) (Not (Eq a b)))"

lemma "bval (Le a b) s = (aval a s \<le> aval b s)"
apply(auto)
done

(* 3.8 *)
datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 b) s = b" |
"ifval (If a b c) s = (if ifval a s then ifval b s else ifval c s)" |
"ifval (Less2 a b) s = (aval a s < aval b s)"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
"b2ifexp (Less a b) = (Less2 a b)" |
"b2ifexp (Not a) = If (b2ifexp a) (Bc2 False) (Bc2 True)" |
"b2ifexp (And a b) = If (b2ifexp a) (b2ifexp b) (Bc2 False)" |
"b2ifexp (Bc b) = Bc2 b"

lemma "bval b s = ifval (b2ifexp b) s"
apply(induction b)
apply(auto)
done

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
"if2bexp (Bc2 b) = Bc b" |
"if2bexp (If c t f) = And (Not (And (if2bexp c) (Not (if2bexp t)))) (Not (And (Not (if2bexp c)) (Not (if2bexp f))))" |
"if2bexp (Less2 a b) = Less a b"

lemma "ifval i s = bval (if2bexp i) s"
apply(induction i)
apply(auto)
done

(* 3.9 *)

datatype pbexp = VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x) s = s x" |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b\<^sub>1 b\<^sub>2) s = (pbval b\<^sub>1 s \<and> pbval b\<^sub>2 s)" |
"pbval (OR b\<^sub>1 b\<^sub>2) s = (pbval b\<^sub>1 s \<or> pbval b\<^sub>2 s)"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
"is_nnf (VAR x) = True" |
"is_nnf (NOT (VAR x)) = True" |
"is_nnf (NOT y) = False" |
"is_nnf (OR a b) = (is_nnf a \<and> is_nnf b)" |
"is_nnf (AND a b) = (is_nnf a \<and> is_nnf b)"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
"nnf (VAR x) = VAR x" |
"nnf (NOT (VAR x)) = (NOT (VAR x))" |
"nnf (NOT (AND a b)) = OR (nnf (NOT a)) (nnf (NOT b))" |
"nnf (NOT (OR a b)) = AND (nnf (NOT a)) (nnf (NOT b))" |
"nnf (NOT (NOT b)) = nnf b " |
"nnf (AND a b) = AND (nnf a) (nnf b)" |
"nnf (OR a b) = OR (nnf a) (nnf b)"

lemma "is_nnf (nnf b)"
apply(induction b rule: nnf.induct)
apply(auto)
done

fun is_dnf :: "pbexp \<Rightarrow> bool" where
"is_dnf (VAR x) = True" |
(* since we assume NNF, we don't need to handle NOT *)
"is_dnf (NOT x) = True" |
"is_dnf (AND (OR _ _) _) = False" |
"is_dnf (AND _ (OR _ _)) = False" |
"is_dnf (AND a b) = (is_dnf a \<and> is_dnf b)" |
"is_dnf (OR a b) = (is_dnf a \<and> is_dnf b)"

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
"dnf_of_nnf (VAR x) = VAR x" |
"dnf_of_nnf (NOT x) = NOT x" |
"dnf_of_nnf (OR a b) = OR (dnf_of_nnf a) (dnf_of_nnf b)" |
"dnf_of_nnf (AND (OR o\<^sub>1 o\<^sub>2) a) = OR (AND o\<^sub>1 a) (AND o\<^sub>2 a)" |
"dnf_of_nnf (AND a (OR o\<^sub>1 o\<^sub>2)) = OR (AND o\<^sub>1 a) (AND o\<^sub>2 a)" |
"dnf_of_nnf (AND a b) = AND (dnf_of_nnf a) (dnf_of_nnf b)"

lemma "pbval (dnf_of_nnf b) s = pbval b s"
apply(induction b rule: dnf_of_nnf.induct)
apply(auto)
done

lemma "is_nnf b \<Longrightarrow> is_nnf (dnf_of_nnf b)"
apply(induction b rule: dnf_of_nnf.induct)
apply(auto)
done

datatype instr = LOADI val | LOAD vname | ADD
type_synonym stack = "val list"
abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk = Some (n # stk)" |
"exec1 (LOAD x) s stk = Some ((s x) # stk)" |
"exec1 ADD _ (h # h2 # rst) = Some ((h2 + h) # rst)" |
"exec1 ADD _ _ = None"

(* I tried using Option.bind etc but I can't seem to get anything proven when I'm using it.
   Expanding it manually works, though. Oh well. *)
fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some (stk)" |
"exec (i # is) s stk = (case (exec1 i s stk) of Some stk' \<Rightarrow> exec is s stk' | None \<Rightarrow> None)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"

(* I originally tried to formulate these lemmas like,
"case (exec is\<^sub>1 s stk) of Some stk' \<Rightarrow> exec (is\<^sub>1 @ is\<^sub>2) s stk = exec is\<^sub>2 s stk'
                        | None \<Rightarrow> exec (is\<^sub>1 @ is\<^sub>2) s stk = None"
but was unable to prove them. *)
lemma exec_append: "exec is\<^sub>1 s stk = Some stk' \<Longrightarrow> exec (is\<^sub>1 @ is\<^sub>2) s stk = exec is\<^sub>2 s stk'"
apply(induction is\<^sub>1 arbitrary: stk)
apply(auto split: option.split)
done

lemma "exec (comp a) s stk = Some (aval a s # stk)"
apply(induction a arbitrary: stk)
apply(auto simp add: exec_append)
done

(* 3.11 *)
type_synonym reg = nat
datatype reginstr = LDI int reg | LD vname reg | ADD reg reg

fun regexec1 :: "reginstr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"regexec1 (LDI v r) s file = file(r := v)" |
"regexec1 (LD x r) s file = file(r := s x)" |
"regexec1 (ADD r\<^sub>1 r\<^sub>2) s file = file(r\<^sub>1 := (file r\<^sub>1) + (file r\<^sub>2))"

fun regexec :: "reginstr list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"regexec [] s file = file" |
"regexec (i # is) s file = regexec is s (regexec1 i s file)"

fun regcomp :: "aexp \<Rightarrow> reg \<Rightarrow> reginstr list" where
"regcomp (N n) r = [LDI n r]" |
"regcomp (V x) r = [LD x r]" |
"regcomp (Plus e\<^sub>1 e\<^sub>2) r = regcomp e\<^sub>1 r @ regcomp e\<^sub>2 (r+1) @ [ADD r (r+1)]"

lemma regexec_append: "regexec (is\<^sub>1 @ is\<^sub>2) s file = regexec is\<^sub>2 s (regexec is\<^sub>1 s file)"
apply(induction is\<^sub>1 arbitrary: "file")
apply(auto)
done

lemma regcomp_dont_touch_small_regs: "q < r \<Longrightarrow> regexec (regcomp a r) s file q = file q"
apply(induction a arbitrary: r "file")
apply(auto simp add: regexec_append)
done

lemma "(regexec (regcomp a r) s file) r = aval a s"
apply(induction a arbitrary: s r "file")
apply(auto simp add: regexec_append regcomp_dont_touch_small_regs)
done

(* 3.12 *)
datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

fun exec10 :: "instr0 \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"exec10 (LDI0 val) s file = file(0 := val)" |
"exec10 (LD0 vname) s file = file(0 := s vname)" |
"exec10 (MV0 reg) s file = file(reg := file 0)" |
"exec10 (ADD0 reg) s file = file(0 := (file 0) + (file reg))"

fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"exec0 [] s file = file" |
"exec0 (i # is) s file = exec0 is s (exec10 i s file)"

fun comp0 :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
"comp0 (N n) r = [LDI0 n]" |
"comp0 (V x) r = [LD0 x]" |
"comp0 (Plus e\<^sub>1 e\<^sub>2) r = (comp0 e\<^sub>1 (r+1)) @ [MV0 (r+1)] @ (comp0 e\<^sub>2 (r+2)) @ [ADD0 (r+1)]"

lemma exec0_append: "exec0 (is\<^sub>1 @ is\<^sub>2) s file = exec0 is\<^sub>2 s (exec0 is\<^sub>1 s file)"
apply(induction is\<^sub>1 arbitrary: "file")
apply(auto)
done

lemma comp0_register_preservation: "0 \<noteq> q \<Longrightarrow> q < r \<Longrightarrow> exec0 (comp0 a r) s file q = file q"
apply(induction a arbitrary: r q "file")
apply(auto simp add: exec0_append)
done

lemma "exec0 (comp0 a r) s rs 0 = aval a s"
apply(induction a arbitrary: r s rs)
apply(auto simp add: exec0_append comp0_register_preservation)
done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_MSortBUPermutes
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(Nat list) list => (Nat list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu :: "(Nat list) list => Nat list" where
  "mergingbu (nil2) = nil2"
| "mergingbu (cons2 xs (nil2)) = xs"
| "mergingbu (cons2 xs (cons2 z x2)) =
     mergingbu (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu :: "Nat list => Nat list" where
  "msortbu x = mergingbu (map (% (y :: Nat) => cons2 y (nil2)) x)"

fun elem :: "'a => 'a list => bool" where
  "elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (msortbu xs) xs"
  oops

end


(*  Title:       HOL/Library/Quadratic_Discriminant.thy
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012

Originally from the AFP entry Tarskis_Geometry
*)

section "Roots of real quadratics"

theory Quadratic_Discriminant
imports Complex_MainRLT
begin

definition discrim :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real"
  where "discrim a b c \<equiv> b\<^sup>2 - 4 * a * c"

lemma complete_square:
  "a \<noteq> 0 \<Longrightarrow> a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> (2 * a * x + b)\<^sup>2 = discrim a b c"
by (simp add: discrim_def) algebra

lemma discriminant_negative:
  fixes a b c x :: real
  assumes "a \<noteq> 0"
    and "discrim a b c < 0"
  shows "a * x\<^sup>2 + b * x + c \<noteq> 0"
proof -
  have "(2 * a * x + b)\<^sup>2 \<ge> 0"
    by simp
  with \<open>discrim a b c < 0\<close> have "(2 * a * x + b)\<^sup>2 \<noteq> discrim a b c"
    by arith
  with complete_square and \<open>a \<noteq> 0\<close> show "a * x\<^sup>2 + b * x + c \<noteq> 0"
    by simp
qed

lemma plus_or_minus_sqrt:
  fixes x y :: real
  assumes "y \<ge> 0"
  shows "x\<^sup>2 = y \<longleftrightarrow> x = sqrt y \<or> x = - sqrt y"
proof
  assume "x\<^sup>2 = y"
  then have "sqrt (x\<^sup>2) = sqrt y"
    by simp
  then have "sqrt y = \<bar>x\<bar>"
    by simp
  then show "x = sqrt y \<or> x = - sqrt y"
    by auto
next
  assume "x = sqrt y \<or> x = - sqrt y"
  then have "x\<^sup>2 = (sqrt y)\<^sup>2 \<or> x\<^sup>2 = (- sqrt y)\<^sup>2"
    by auto
  with \<open>y \<ge> 0\<close> show "x\<^sup>2 = y"
    by simp
qed

lemma divide_non_zero:
  fixes x y z :: real
  assumes "x \<noteq> 0"
  shows "x * y = z \<longleftrightarrow> y = z / x"
proof
  show "y = z / x" if "x * y = z"
    using \<open>x \<noteq> 0\<close> that by (simp add: field_simps)
  show "x * y = z" if "y = z / x"
    using \<open>x \<noteq> 0\<close> that by simp
qed

lemma discriminant_nonneg:
  fixes a b c x :: real
  assumes "a \<noteq> 0"
    and "discrim a b c \<ge> 0"
  shows "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow>
    x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
    x = (-b - sqrt (discrim a b c)) / (2 * a)"
proof -
  from complete_square and plus_or_minus_sqrt and assms
  have "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow>
    (2 * a) * x + b = sqrt (discrim a b c) \<or>
    (2 * a) * x + b = - sqrt (discrim a b c)"
    by simp
  also have "\<dots> \<longleftrightarrow> (2 * a) * x = (-b + sqrt (discrim a b c)) \<or>
    (2 * a) * x = (-b - sqrt (discrim a b c))"
    by auto
  also from \<open>a \<noteq> 0\<close> and divide_non_zero [of "2 * a" x]
  have "\<dots> \<longleftrightarrow> x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
    x = (-b - sqrt (discrim a b c)) / (2 * a)"
    by simp
  finally show "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow>
    x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
    x = (-b - sqrt (discrim a b c)) / (2 * a)" .
qed

lemma discriminant_zero:
  fixes a b c x :: real
  assumes "a \<noteq> 0"
    and "discrim a b c = 0"
  shows "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> x = -b / (2 * a)"
  by (simp add: discriminant_nonneg assms)

theorem discriminant_iff:
  fixes a b c x :: real
  assumes "a \<noteq> 0"
  shows "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow>
    discrim a b c \<ge> 0 \<and>
    (x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
     x = (-b - sqrt (discrim a b c)) / (2 * a))"
proof
  assume "a * x\<^sup>2 + b * x + c = 0"
  with discriminant_negative and \<open>a \<noteq> 0\<close> have "\<not>(discrim a b c < 0)"
    by auto
  then have "discrim a b c \<ge> 0"
    by simp
  with discriminant_nonneg and \<open>a * x\<^sup>2 + b * x + c = 0\<close> and \<open>a \<noteq> 0\<close>
  have "x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
      x = (-b - sqrt (discrim a b c)) / (2 * a)"
    by simp
  with \<open>discrim a b c \<ge> 0\<close>
  show "discrim a b c \<ge> 0 \<and>
    (x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
     x = (-b - sqrt (discrim a b c)) / (2 * a))" ..
next
  assume "discrim a b c \<ge> 0 \<and>
    (x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
     x = (-b - sqrt (discrim a b c)) / (2 * a))"
  then have "discrim a b c \<ge> 0" and
    "x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
     x = (-b - sqrt (discrim a b c)) / (2 * a)"
    by simp_all
  with discriminant_nonneg and \<open>a \<noteq> 0\<close> show "a * x\<^sup>2 + b * x + c = 0"
    by simp
qed

lemma discriminant_nonneg_ex:
  fixes a b c :: real
  assumes "a \<noteq> 0"
    and "discrim a b c \<ge> 0"
  shows "\<exists> x. a * x\<^sup>2 + b * x + c = 0"
  by (auto simp: discriminant_nonneg assms)

lemma discriminant_pos_ex:
  fixes a b c :: real
  assumes "a \<noteq> 0"
    and "discrim a b c > 0"
  shows "\<exists>x y. x \<noteq> y \<and> a * x\<^sup>2 + b * x + c = 0 \<and> a * y\<^sup>2 + b * y + c = 0"
proof -
  let ?x = "(-b + sqrt (discrim a b c)) / (2 * a)"
  let ?y = "(-b - sqrt (discrim a b c)) / (2 * a)"
  from \<open>discrim a b c > 0\<close> have "sqrt (discrim a b c) \<noteq> 0"
    by simp
  then have "sqrt (discrim a b c) \<noteq> - sqrt (discrim a b c)"
    by arith
  with \<open>a \<noteq> 0\<close> have "?x \<noteq> ?y"
    by simp
  moreover from assms have "a * ?x\<^sup>2 + b * ?x + c = 0" and "a * ?y\<^sup>2 + b * ?y + c = 0"
    using discriminant_nonneg [of a b c ?x]
      and discriminant_nonneg [of a b c ?y]
    by simp_all
  ultimately show ?thesis
    by blast
qed

lemma discriminant_pos_distinct:
  fixes a b c x :: real
  assumes "a \<noteq> 0"
    and "discrim a b c > 0"
  shows "\<exists> y. x \<noteq> y \<and> a * y\<^sup>2 + b * y + c = 0"
proof -
  from discriminant_pos_ex and \<open>a \<noteq> 0\<close> and \<open>discrim a b c > 0\<close>
  obtain w and z where "w \<noteq> z"
    and "a * w\<^sup>2 + b * w + c = 0" and "a * z\<^sup>2 + b * z + c = 0"
    by blast
  show "\<exists>y. x \<noteq> y \<and> a * y\<^sup>2 + b * y + c = 0"
  proof (cases "x = w")
    case True
    with \<open>w \<noteq> z\<close> have "x \<noteq> z"
      by simp
    with \<open>a * z\<^sup>2 + b * z + c = 0\<close> show ?thesis
      by auto
  next
    case False
    with \<open>a * w\<^sup>2 + b * w + c = 0\<close> show ?thesis
      by auto
  qed
qed

lemma Rats_solution_QE:
  assumes "a \<in> \<rat>" "b \<in> \<rat>" "a \<noteq> 0"
  and "a*x^2 + b*x + c = 0"
  and "sqrt (discrim a b c) \<in> \<rat>"
  shows "x \<in> \<rat>"
using assms(1,2,5) discriminant_iff[THEN iffD1, OF assms(3,4)] by auto

lemma Rats_solution_QE_converse:
  assumes "a \<in> \<rat>" "b \<in> \<rat>"
  and "a*x^2 + b*x + c = 0"
  and "x \<in> \<rat>"
  shows "sqrt (discrim a b c) \<in> \<rat>"
proof -
  from assms(3) have "discrim a b c = (2*a*x+b)^2" unfolding discrim_def by algebra
  hence "sqrt (discrim a b c) = \<bar>2*a*x+b\<bar>" by (simp)
  thus ?thesis using \<open>a \<in> \<rat>\<close> \<open>b \<in> \<rat>\<close> \<open>x \<in> \<rat>\<close> by (simp)
qed

end


section \<open>Conjunctive and Disjunctive Functions\<close>

(*
    Author: Viorel Preoteasa
*)

theory Conj_Disj
imports Main
begin

text\<open>
This theory introduces the definitions and some properties for
conjunctive, disjunctive, universally conjunctive, and universally
disjunctive functions.
\<close>

locale conjunctive =
  fixes inf_b :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
  and inf_c :: "'c \<Rightarrow> 'c \<Rightarrow> 'c"
  and times_abc :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
begin

definition
  "conjunctive = {x . (\<forall> y z . times_abc x (inf_b y z) = inf_c (times_abc x y) (times_abc x z))}"

lemma conjunctiveI:
  assumes "(\<And>b c. times_abc a (inf_b b c) = inf_c (times_abc a b) (times_abc a c))"
  shows "a \<in> conjunctive"
  using assms by (simp add: conjunctive_def)

lemma conjunctiveD: "x \<in> conjunctive \<Longrightarrow> times_abc x (inf_b y z) = inf_c (times_abc x y) (times_abc x z)"
  by (simp add: conjunctive_def)

end

interpretation Apply: conjunctive "inf::'a::semilattice_inf \<Rightarrow> 'a \<Rightarrow> 'a"
  "inf::'b::semilattice_inf \<Rightarrow> 'b \<Rightarrow> 'b" "\<lambda> f . f"
  done

interpretation Comp: conjunctive "inf::('a::lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
  "inf::('a::lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" "(o)"
  done

lemma "Apply.conjunctive = Comp.conjunctive"
  apply (simp add: Apply.conjunctive_def Comp.conjunctive_def)
  apply safe
  apply (simp_all add: fun_eq_iff inf_fun_def)
  apply (drule_tac x = "\<lambda> u . y" in spec)
  apply (drule_tac x = "\<lambda> u . z" in spec)
  by simp

locale disjunctive =
  fixes sup_b :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
  and sup_c :: "'c \<Rightarrow> 'c \<Rightarrow> 'c"
  and times_abc :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
begin

definition
  "disjunctive = {x . (\<forall> y z . times_abc x (sup_b y z) = sup_c (times_abc x y) (times_abc x z))}"

lemma disjunctiveI:
  assumes "(\<And>b c. times_abc a (sup_b b c) = sup_c (times_abc a b) (times_abc a c))"
  shows "a \<in> disjunctive"
  using assms by (simp add: disjunctive_def)

lemma disjunctiveD: "x \<in> disjunctive \<Longrightarrow> times_abc x (sup_b y z) = sup_c (times_abc x y) (times_abc x z)"
  by (simp add: disjunctive_def)

end

interpretation Apply: disjunctive "sup::'a::semilattice_sup \<Rightarrow> 'a \<Rightarrow> 'a"
  "sup::'b::semilattice_sup \<Rightarrow> 'b \<Rightarrow> 'b" "\<lambda> f . f"
  done

interpretation Comp: disjunctive "sup::('a::lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
  "sup::('a::lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" "(o)"
  done

lemma apply_comp_disjunctive: "Apply.disjunctive = Comp.disjunctive"
  apply (simp add: Apply.disjunctive_def Comp.disjunctive_def)
  apply safe
  apply (simp_all add: fun_eq_iff sup_fun_def)
  apply (drule_tac x = "\<lambda> u . y" in spec)
  apply (drule_tac x = "\<lambda> u . z" in spec)
  by simp

locale Conjunctive =
  fixes Inf_b :: "'b set \<Rightarrow> 'b"
  and Inf_c :: "'c set \<Rightarrow> 'c"
  and times_abc :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
begin

definition
  "Conjunctive = {x . (\<forall> X . times_abc x (Inf_b X) = Inf_c ((times_abc x) ` X) )}"

lemma ConjunctiveI:
  assumes "\<And>A. times_abc a (Inf_b A) = Inf_c ((times_abc a) ` A)"
  shows "a \<in> Conjunctive"
  using assms by (simp add: Conjunctive_def)

lemma ConjunctiveD:
  assumes "a \<in> Conjunctive"
  shows "times_abc a (Inf_b A) = Inf_c ((times_abc a) ` A)"
  using assms by (simp add: Conjunctive_def)

end

interpretation Apply: Conjunctive Inf Inf "\<lambda> f . f"
  done

interpretation Comp: Conjunctive "Inf::(('a::complete_lattice \<Rightarrow> 'a) set) \<Rightarrow> ('a \<Rightarrow> 'a)"
  "Inf::(('a::complete_lattice \<Rightarrow> 'a) set) \<Rightarrow> ('a \<Rightarrow> 'a)" "(o)"
  done

lemma "Apply.Conjunctive = Comp.Conjunctive"
proof
  show "Apply.Conjunctive \<subseteq> (Comp.Conjunctive :: ('a \<Rightarrow> 'a) set)"
  proof
    fix f
    assume "f \<in> (Apply.Conjunctive :: ('a \<Rightarrow> 'a) set)"
    then have *: "f (Inf A) = (INF a\<in>A. f a)" for A
      by (auto dest!: Apply.ConjunctiveD)
    show "f \<in> (Comp.Conjunctive :: ('a \<Rightarrow> 'a) set)"
    proof (rule Comp.ConjunctiveI)
      fix G :: "('a \<Rightarrow> 'a) set"
      from * have "f (INF f\<in>G. f a) = Inf (f ` (\<lambda>f. f a) ` G)"
        for a :: 'a .
      then show "f \<circ> Inf G = Inf (comp f ` G)"
        by (simp add: fun_eq_iff image_comp)
    qed
  qed
  show "Comp.Conjunctive \<subseteq> (Apply.Conjunctive :: ('a \<Rightarrow> 'a) set)"
  proof
    fix f
    assume "f \<in> (Comp.Conjunctive :: ('a \<Rightarrow> 'a) set)"
    then have *: "f \<circ> Inf G = (INF g\<in>G. f \<circ> g)" for G :: "('a \<Rightarrow> 'a) set"
      by (auto dest!: Comp.ConjunctiveD)
    show "f \<in> (Apply.Conjunctive :: ('a \<Rightarrow> 'a) set)"
    proof (rule Apply.ConjunctiveI)
      fix A :: "'a set"
      from * have "f \<circ> (INF a\<in>A. (\<lambda>b :: 'a. a)) = Inf ((\<circ>) f ` (\<lambda>a b. a) ` A)" .
      then show "f (Inf A) = Inf (f ` A)"
        by (simp add: fun_eq_iff image_comp)
    qed
  qed
qed

locale Disjunctive =
  fixes Sup_b :: "'b set \<Rightarrow> 'b"
  and Sup_c :: "'c set \<Rightarrow> 'c"
  and times_abc :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
begin

definition
  "Disjunctive = {x . (\<forall> X . times_abc x (Sup_b X) = Sup_c ((times_abc x) ` X) )}"

lemma DisjunctiveI:
  assumes "\<And>A. times_abc a (Sup_b A) = Sup_c ((times_abc a) ` A)"
  shows "a \<in> Disjunctive"
  using assms by (simp add: Disjunctive_def)

lemma DisjunctiveD: "x \<in> Disjunctive \<Longrightarrow> times_abc x (Sup_b X) = Sup_c ((times_abc x) ` X)"
  by (simp add: Disjunctive_def)

end

interpretation Apply: Disjunctive Sup Sup "\<lambda> f . f"
  done

interpretation Comp: Disjunctive "Sup::(('a::complete_lattice \<Rightarrow> 'a) set) \<Rightarrow> ('a \<Rightarrow> 'a)"
  "Sup::(('a::complete_lattice \<Rightarrow> 'a) set) \<Rightarrow> ('a \<Rightarrow> 'a)" "(o)"
  done

lemma "Apply.Disjunctive = Comp.Disjunctive"
proof
  show "Apply.Disjunctive \<subseteq> (Comp.Disjunctive :: ('a \<Rightarrow> 'a) set)"
  proof
    fix f
    assume "f \<in> (Apply.Disjunctive :: ('a \<Rightarrow> 'a) set)"
    then have *: "f (Sup A) = (SUP a\<in>A. f a)" for A
      by (auto dest!: Apply.DisjunctiveD)
    show "f \<in> (Comp.Disjunctive :: ('a \<Rightarrow> 'a) set)"
    proof (rule Comp.DisjunctiveI)
      fix G :: "('a \<Rightarrow> 'a) set"
      from * have "f (SUP f\<in>G. f a) = Sup (f ` (\<lambda>f. f a) ` G)"
        for a :: 'a .
      then show "f \<circ> Sup G = Sup (comp f ` G)"
        by (simp add: fun_eq_iff image_comp)
    qed
  qed
  show "Comp.Disjunctive \<subseteq> (Apply.Disjunctive :: ('a \<Rightarrow> 'a) set)"
  proof
    fix f
    assume "f \<in> (Comp.Disjunctive :: ('a \<Rightarrow> 'a) set)"
    then have *: "f \<circ> Sup G = (SUP g\<in>G. f \<circ> g)" for G :: "('a \<Rightarrow> 'a) set"
      by (auto dest!: Comp.DisjunctiveD)
    show "f \<in> (Apply.Disjunctive :: ('a \<Rightarrow> 'a) set)"
    proof (rule Apply.DisjunctiveI)
      fix A :: "'a set"
      from * have "f \<circ> (SUP a\<in>A. (\<lambda>b :: 'a. a)) = Sup ((\<circ>) f ` (\<lambda>a b. a) ` A)" .
      then show "f (Sup A) = Sup (f ` A)"
        by (simp add: fun_eq_iff image_comp)
    qed
  qed
qed

lemma [simp]: "F \<in> Apply.conjunctive \<Longrightarrow> mono F"
  apply (simp add: Apply.conjunctive_def mono_def)
  apply safe
  apply (drule_tac x = "x" in spec)
  apply (drule_tac x = "y" in spec)
  apply (subgoal_tac "inf x y = x")
  apply simp
  apply (subgoal_tac "inf (F x) (F y) \<le> F y")
  apply simp
  apply (rule inf_le2)
  apply (rule antisym)
  by simp_all

lemma [simp]: "(F::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<in> Apply.Conjunctive \<Longrightarrow> F top = top"
  apply (simp add: Apply.Conjunctive_def)
  apply (drule_tac x="{}" in spec)
  by simp

lemma [simp]: "(F::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<in> Apply.Disjunctive \<Longrightarrow> F \<in> Apply.disjunctive"
  apply (simp add: Apply.Disjunctive_def Apply.disjunctive_def)
  apply safe
  apply (drule_tac x = "{y, z}" in spec)
  by simp

lemma [simp]: "F \<in> Apply.disjunctive \<Longrightarrow> mono F"
  apply (simp add: Apply.disjunctive_def mono_def)
  apply safe
  apply (drule_tac x = "x" in spec)
  apply (drule_tac x = "y" in spec)
  apply (subgoal_tac "sup x y = y")
  apply simp
  apply (subgoal_tac "F x \<le> sup (F x) (F y)")
  apply simp
  apply (rule sup_ge1)
  apply (rule antisym)
  apply simp
  by (rule sup_ge2)

lemma [simp]: "(F::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<in> Apply.Disjunctive \<Longrightarrow> F bot = bot"
  apply (simp add: Apply.Disjunctive_def)
  apply (drule_tac x="{}" in spec)
  by simp

lemma weak_fusion: "h \<in> Apply.Disjunctive \<Longrightarrow> mono f \<Longrightarrow> mono g \<Longrightarrow>
    h o f \<le> g o h \<Longrightarrow> h (lfp f) \<le> lfp g"
  apply (rule_tac P = "\<lambda> x . h x \<le> lfp g" in lfp_ordinal_induct, simp_all)
  apply (rule_tac y = "g (h S)" in order_trans)
  apply (simp add: le_fun_def)
  apply (rule_tac y = "g (lfp g)" in order_trans)
  apply (rule_tac f = g in monoD, simp_all)
  apply (simp add: lfp_unfold [symmetric])
  apply (simp add: Apply.DisjunctiveD)
  by (rule SUP_least, blast)

end