(* Title:      Octonions.thy
   Author:     Angeliki Koutsoukou-Argyraki, University of Cambridge
   Date:       September 2018
*)
section\<open>Theory of Octonions\<close>
theory Octonions
  imports Cross_Product_7
begin

subsection\<open>Basic definitions\<close>

text\<open>As with the complex numbers, coinduction is convenient.\<close>

codatatype octo =
  Octo (Ree: real) (Im1: real) (Im2: real) (Im3: real) (Im4: real)
       (Im5: real) (Im6: real) (Im7: real)

lemma octo_eqI [intro?]:
  "\<lbrakk>Ree x = Ree y; Im1 x = Im1 y; Im2 x = Im2 y; Im3 x = Im3 y;
    Im4 x = Im4 y;Im5 x = Im5 y;  Im6 x = Im6 y; Im7 x = Im7 y\<rbrakk> \<Longrightarrow> x = y"
  by (rule octo.expand) simp

lemma octo_eq_iff:
  "x = y \<longleftrightarrow> Ree x = Ree y \<and> Im1 x = Im1 y \<and> Im2 x = Im2 y \<and> Im3 x = Im3 y \<and>
             Im4 x = Im4 y \<and> Im5 x = Im5 y \<and> Im6 x = Im6 y  \<and> Im7 x = Im7 y"
  by (auto intro: octo.expand)

context
begin

primcorec octo_e0 :: octo ("e0")
where "Ree e0 = 1" | "Im1 e0 = 0" | "Im2 e0 = 0" | "Im3 e0 = 0"
  | "Im4 e0 = 0" | "Im5 e0 = 0" | "Im6 e0 = 0" | "Im7 e0 = 0"

primcorec octo_e1 :: octo  ("e1")
  where "Ree e1 = 0" | "Im1 e1 = 1" | "Im2 e1 = 0" | "Im3 e1 = 0"
  | "Im4 e1 = 0" | "Im5 e1 = 0" | "Im6 e1 = 0" | "Im7 e1 = 0"

primcorec octo_e2 :: octo  ("e2")
  where "Ree e2 = 0" | "Im1 e2 = 0" | "Im2 e2 = 1" | "Im3 e2 = 0"
  | "Im4 e2 = 0" | "Im5 e2 = 0" | "Im6 e2 = 0" | "Im7 e2 = 0"

primcorec octo_e3 :: octo ("e3")
  where "Ree e3 = 0" | "Im1 e3 = 0" | "Im2 e3 = 0" | "Im3 e3 = 1"
  | "Im4 e3 = 0" | "Im5 e3 = 0" | "Im6 e3 = 0" | "Im7 e3 = 0"

primcorec octo_e4 :: octo ("e4")
  where "Ree e4 = 0" | "Im1 e4 = 0" | "Im2 e4 = 0" | "Im3 e4 = 0"
  | "Im4 e4 = 1" | "Im5 e4 = 0" | "Im6 e4 = 0" | "Im7 e4 = 0"

primcorec octo_e5 :: octo ("e5")
  where "Ree e5 = 0" | "Im1 e5 = 0" | "Im2 e5 = 0" | "Im3 e5 = 0"
  | "Im4 e5 = 0" | "Im5 e5 = 1" | "Im6 e5 = 0" | "Im7 e5 = 0"

primcorec octo_e6 :: octo ("e6")
  where "Ree e6 = 0" | "Im1 e6 = 0" | "Im2 e6 = 0" | "Im3 e6 = 0"
  | "Im4 e6 = 0" | "Im5 e6 = 0" | "Im6 e6 = 1" | "Im7 e6 = 0"

primcorec octo_e7 :: octo ("e7")
  where "Ree e7 = 0" | "Im1 e7 = 0" | "Im2 e7 = 0" | "Im3 e7 = 0"
  | "Im4 e7 = 0" | "Im5 e7 = 0" | "Im6 e7 = 0" | "Im7 e7 = 1"
end

subsection \<open>Addition and Subtraction: An Abelian Group\<close>

instantiation octo :: ab_group_add

begin

primcorec zero_octo
  where "Ree 0 = 0" |"Im1 0 = 0" | "Im2 0 = 0" | "Im3 0 = 0"
 |"Im4 0 = 0" | "Im5 0 = 0" | "Im6 0 = 0" | "Im7 0 = 0"

primcorec plus_octo
  where
    "Ree (x + y) = Ree x + Ree y"
  | "Im1 (x + y) = Im1 x + Im1 y"
  | "Im2 (x + y) = Im2 x + Im2 y"
  | "Im3 (x + y) = Im3 x + Im3 y"
  | "Im4 (x + y) = Im4 x + Im4 y"
  | "Im5 (x + y) = Im5 x + Im5 y"
  | "Im6 (x + y) = Im6 x + Im6 y"
  | "Im7 (x + y) = Im7 x + Im7 y"

primcorec uminus_octo
  where
    "Ree (- x) = - Ree x"
  | "Im1 (- x) = - Im1 x"
  | "Im2 (- x) = - Im2 x"
  | "Im3 (- x) = - Im3 x"
  | "Im4 (- x) = - Im4 x"
  | "Im5 (- x) = - Im5 x"
  | "Im6 (- x) = - Im6 x"
  | "Im7 (- x) = - Im7 x"

primcorec minus_octo
  where
    "Ree (x - y) = Ree x - Ree y"
  | "Im1 (x - y) = Im1 x - Im1 y"
  | "Im2 (x - y) = Im2 x - Im2 y"
  | "Im3 (x - y) = Im3 x - Im3 y"
  | "Im4 (x - y) = Im4 x - Im4 y"
  | "Im5 (x - y) = Im5 x - Im5 y"
  | "Im6 (x - y) = Im6 x - Im6 y"
  | "Im7 (x - y) = Im7 x - Im7 y"

instance
  by standard (simp_all add: octo_eq_iff)

end

lemma octo_eq_0_iff:
  "x = 0 \<longleftrightarrow> Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 +
               Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^ 2  = 0"
proof
  assume "(octo.Ree x)\<^sup>2 + (Im1 x)\<^sup>2 + (Im2 x)\<^sup>2 + (Im3 x)\<^sup>2 + (Im4 x)\<^sup>2 + (Im5 x)\<^sup>2 + (Im6 x)\<^sup>2
 + (Im7 x)\<^sup>2 = 0"
  then have "\<forall>qa. qa - x = qa"
    by (simp add: add_nonneg_eq_0_iff minus_octo.ctr)
  then show "x = 0"
    by simp
qed auto

subsection \<open>A Normed Vector Space\<close>

instantiation octo :: real_vector

begin

primcorec scaleR_octo
  where
    "Ree (scaleR r x) = r * Ree x"
  | "Im1 (scaleR r x) = r * Im1 x"
  | "Im2 (scaleR r x) = r * Im2 x"
  | "Im3 (scaleR r x) = r * Im3 x"
  | "Im4 (scaleR r x) = r * Im4 x"
  | "Im5 (scaleR r x) = r * Im5 x"
  | "Im6 (scaleR r x) = r * Im6 x"
  | "Im7 (scaleR r x) = r * Im7 x"

instance
  by standard (auto simp: octo_eq_iff distrib_left distrib_right  scaleR_add_right)

end

instantiation octo::one
begin
primcorec one_octo

  where
   "Ree 1 = 1" |  "Im1 1 = 0"  | "Im2 1 = 0" |  "Im3 1 = 0" |
   "Im4 1 = 0" |  "Im5 1 = 0"  | "Im6 1 = 0" | "Im7 1 = 0"

instance by standard
end

fun octo_proj
  where
    "octo_proj x 0 = ( Ree (x))"
  | "octo_proj x (Suc 0) = ( Im1(x))"
  | "octo_proj x (Suc (Suc 0)) = ( Im2 ( x))"
  | "octo_proj x (Suc (Suc (Suc 0))) = ( Im3( x))"
  | "octo_proj x (Suc (Suc (Suc (Suc 0)))) = ( Im4( x))"
  | "octo_proj x (Suc(Suc (Suc (Suc (Suc 0))))) = ( Im5( x))"
  | "octo_proj x (Suc(Suc (Suc (Suc (Suc (Suc 0)))))) = ( Im6( x))"
  | "octo_proj x (Suc( Suc(Suc (Suc (Suc (Suc (Suc 0))))))) = ( Im7( x))"

lemma octo_proj_add:
  assumes "i \<le> 7"
  shows "octo_proj (x+y) i = octo_proj x i + octo_proj y i"

proof -
  consider "i = 0" | "i = 1" | "i = 2" | "i = 3" | "i = 4" | "i = 5" | "i = 6" | "i = 7"
    using  assms by force

     then show ?thesis
    by cases (auto simp:  numeral_2_eq_2 numeral_3_eq_3 numeral_4_eq_4 numeral_5_eq_5
 numeral_6_eq_6  numeral_7_eq_7 numeral_7_eq_7)
qed

instantiation octo ::real_normed_vector
begin

definition  "norm x = sqrt ((Ree x)\<^sup>2 + (Im1 x)\<^sup>2 + (Im2 x)\<^sup>2 + (Im3 x)\<^sup>2  +
  (Im4 x)\<^sup>2 + (Im5 x)\<^sup>2 + (Im6 x)\<^sup>2+ (Im7 x)\<^sup>2  )" for x::octo

definition "sgn x = x /\<^sub>R norm x" for x :: octo

definition "dist x y = norm (x - y)" for x y :: octo

definition [code del]:
  "(uniformity :: (octo \<times> octo) filter) = (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"

definition [code del]:
  "open (U :: octo set) \<longleftrightarrow> (\<forall>x\<in>U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"

lemma norm_eq_L2: "norm x = L2_set (octo_proj x) {..7}"
  by (simp add: norm_octo_def L2_set_def eval_nat_numeral)

instance proof
  fix r :: real and x y :: octo and S :: "octo set"
  show "(norm x = 0) \<longleftrightarrow> (x = 0)"
    by (simp add: norm_octo_def octo_eq_iff add_nonneg_eq_0_iff)
  have eq: "L2_set (octo_proj (x + y)) {..7} = L2_set (\<lambda>i. octo_proj x i + octo_proj y i) {..7}"
    by (rule L2_set_cong) (auto simp: octo_proj_add)
  show "norm (x + y) \<le> norm x + norm y"
    by (simp add: norm_eq_L2 eq L2_set_triangle_ineq)
  show "norm (scaleR r x) = \<bar>r\<bar> * norm x"
    by (simp add: norm_octo_def octo_eq_iff
                  power_mult_distrib distrib_left [symmetric] real_sqrt_mult)
qed (rule sgn_octo_def dist_octo_def open_octo_def uniformity_octo_def)+

end

lemma norm_octo_squared:
  "norm x ^ 2 = Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 +
     Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^ 2"
  by (simp add: norm_octo_def)

instantiation octo :: real_inner
begin

definition inner_octo where
  "inner_octo x y = Ree x * Ree y + Im1 x * Im1 y + Im2 x * Im2 y + Im3 x * Im3 y
      + Im4 x * Im4 y + Im5 x * Im5 y + Im6 x * Im6 y +  Im7 x * Im7 y " for x y::octo

instance
  by standard (auto simp: inner_octo_def algebra_simps norm_octo_def
                          power2_eq_square octo_eq_iff add_nonneg_eq_0_iff)

end

lemma octo_inner_1 [simp]: "inner 1 x = Ree x"
 and octo_inner_1_right [simp]: "inner x 1 = Ree x"
  unfolding inner_octo_def by simp_all

lemma octo_inner_e1_left [simp]: "inner e1 x = Im1 x"
 and octo_inner_e1_right [simp]: "inner x e1 = Im1 x"
  unfolding inner_octo_def by simp_all

lemma octo_inner_e2_left [simp]: "inner e2 x = Im2 x"
  and octo_inner_e2_right [simp]: "inner x e2 = Im2 x"
  unfolding inner_octo_def by simp_all

lemma octo_inner_e3_left [simp]: "inner e3 x = Im3 x"
 and  octo_inner_e3_right [simp]: "inner x e3 = Im3 x"
  unfolding inner_octo_def by simp_all

lemma octo_inner_e4_left [simp]: "inner e4 x  = Im4 x"
 and octo_inner_e4_right [simp]: "inner x e4 = Im4 x"
  unfolding inner_octo_def by simp_all

lemma octo_inner_e5_left [simp]: "inner e5 x  = Im5 x"
 and  octo_inner_e5_right [simp]: "inner x e5 = Im5 x"
  unfolding inner_octo_def by simp_all

lemma octo_inner_e6_left [simp]: "inner e6 x  = Im6 x"
 and octo_inner_e6_right [simp]: "inner x e6 = Im6 x"
  unfolding inner_octo_def by simp_all

lemma octo_inner_e7_left [simp]: "inner e7 x  = Im7 x"
 and octo_inner_e7_right [simp]: "inner x e7 = Im7 x"
  unfolding inner_octo_def by simp_all

lemma octo_norm_pow_2_inner: "(norm x) ^ 2 = inner x x " for x::octo
  by (simp add: dot_square_norm)

lemma octo_norm_property:
  "inner x y = (1/2)* ((norm(x+y))^2 - (norm(x))^2 - (norm(y))^2) " for x y ::octo
  by (simp add: dot_norm norm_octo_def)

subsection \<open>The Octonionic product and related properties and lemmas\<close>

text\<open>The multiplication is defined following one of the 480 equivalent multiplication tables
in an analogy to the definition of the 7D cross product. \<close>

instantiation octo :: times
begin

definition times_octo :: "[octo, octo] \<Rightarrow> octo"
  where
    "(a * b) =  (let
    t0 = Ree a * Ree b - Im1 a * Im1 b - Im2 a * Im2 b- Im3 a * Im3 b
          - Im4 a * Im4 b  - Im5 a * Im5 b - Im6 a * Im6 b  -Im7 a * Im7 b ;
    t1 =  Ree a * Im1 b +   Im1 a * Ree b + Im2 a * Im4 b +Im3 a * Im7 b -
          Im4 a * Im2  b  +Im5 a * Im6 b - Im6 a * Im5 b - Im7 a * Im3 b ;
    t2 =  Ree a *  Im2 b - Im1 a * Im4 b+ Im2 a  * Ree b + Im3 a * Im5 b
          + Im4 a * Im1 b  - Im5 a * Im3 b + Im6 a * Im7 b - Im7 a *Im6 b  ;
    t3 =  Ree a * Im3 b -Im1 a * Im7 b -Im2 a *Im5 b +Im3 a * Ree b + Im4 a * Im6 b
         +  Im5 a *Im2 b  - Im6 a * Im4 b + Im7 a * Im1 b ;
    t4 = Ree a * Im4 b + Im1 a * Im2 b - Im2 a * Im1 b -Im3 a * Im6 b + Im4 a * Ree b
        +Im5 a * Im7 b +Im6 a * Im3 b -Im7 a * Im5 b ;
    t5 = Ree a * Im5 b - Im1 a * Im6 b +Im2 a * Im3 b -Im3 a * Im2 b -Im4 a * Im7 b
         +Im5 a * Ree b  +Im6 a * Im1 b + Im7 a  * Im4 b;
    t6 = Ree a * Im6 b + Im1 a * Im5 b - Im2 a * Im7 b +Im3 a * Im4 b - Im4 a * Im3 b
        -Im5 a * Im1 b + Im6 a * Ree b + Im7 a * Im2 b  ;
    t7 = Ree a * Im7 b + Im1 a * Im3 b +Im2 a * Im6 b - Im3 a * Im1 b + Im4 a * Im5 b
          -Im5 a * Im4 b - Im6 a * Im2 b +Im7 a * Ree b
  in Octo t0 t1 t2 t3 t4 t5 t6 t7)"

instance by standard

end

instantiation octo ::inverse
begin

primcorec inverse_octo
  where
    "Ree (inverse x) = Ree x / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2
      +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2   )"
  | "Im1 (inverse x) = - (Im1 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2
             +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2)"
  | "Im2 (inverse x) = - (Im2 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2
   +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2 )"
  | "Im3 (inverse x) = - (Im3 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2
     +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2    )"
  | "Im4 (inverse x) = - (Im4 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2
        +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2    )"
  | "Im5 (inverse x) = - (Im5 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2
   +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2)"
  | "Im6 (inverse x) = - (Im6 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2
       +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2    )"
  | "Im7 (inverse x) = - (Im7 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2
     +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2    )"

definition "x div y = x  * ( inverse y)" for x y :: octo

instance by standard

end

lemma octo_mult_components:
  "Ree (x *  y ) =  Ree x *  Ree y - Im1 x * Im1 y -  Im2 x * Im2 y - Im3 x * Im3 y
   - Im4 x * Im4 y - Im5 x * Im5 y - Im6 x * Im6 y-  Im7 x * Im7 y"
  "Im1 (x  *  y )  =  Ree x * Im1 y +   Im1 x * Ree y + Im2 x * Im4 y +Im3 x * Im7 y -
     Im4 x * Im2 y    +Im5 x * Im6 y - Im6 x * Im5 y - Im7 x * Im3 y "
   " Im2 (x  *  y )  =  Ree x *  Im2 y - Im1 x * Im4 y+ Im2 x  * Ree y + Im3 x * Im5 y
          + Im4 x * Im1 y  - Im5 x * Im3 y + Im6 x * Im7 y - Im7 x *Im6 y  "
   " Im3 (x * y ) =  Ree x * Im3 y -Im1 x * Im7 y -Im2 x *Im5 y +Im3 x * Ree y + Im4 x * Im6 y
         +  Im5 x *Im2 y  - Im6 x * Im4 y + Im7 x * Im1 y "
   "Im4  (x *y ) =  Ree x * Im4 y + Im1 x * Im2 y - Im2 x * Im1 y -Im3 x * Im6 y + Im4 x * Ree y
        +Im5 x * Im7 y +Im6 x * Im3 y -Im7 x * Im5 y  "
   "Im5  (x * y ) = Ree x * Im5 y - Im1 x * Im6 y +Im2 x * Im3 y -Im3 x * Im2 y -Im4 x * Im7 y
         +Im5 x * Ree y  +Im6 x * Im1 y + Im7 x  * Im4 y  "
   " Im6  (x *  y) = Ree x * Im6 y + Im1 x * Im5 y - Im2 x * Im7 y +Im3 x * Im4 y - Im4 x * Im3 y
        -Im5 x * Im1 y + Im6 x * Ree y + Im7 x * Im2 y   "
    "Im7 (x * y)  = Ree x * Im7 y + Im1 x * Im3 y +Im2 x * Im6 y - Im3 x * Im1 y + Im4 x * Im5 y
   -Im5 x * Im4 y - Im6 x * Im2 y +Im7 x * Ree y  "
 unfolding times_octo_def by auto

lemma octo_distrib_left :
  "a * (b + c) = a * b + a * c" for a b c ::octo
  unfolding times_octo_def  plus_octo_def minus_octo_def uminus_octo_def scaleR_octo_def
  by (simp add: octo_eq_iff octo_mult_components algebra_simps)

lemma octo_distrib_right :
  "(b + c) * a = b * a + c * a" for a b c ::octo
  unfolding times_octo_def  plus_octo_def minus_octo_def uminus_octo_def scaleR_octo_def
  by (simp add: octo_eq_iff octo_mult_components algebra_simps)

lemma multiplicative_norm_octo: "norm (x * y) = norm x * norm y" for x y ::octo
proof -
  have "norm (x * y) ^ 2 = norm x ^ 2 * norm y ^ 2"
    unfolding norm_octo_squared octo_mult_components by algebra
  also have "... = (norm x * norm y) ^ 2"
    by (simp add: power_mult_distrib)
  finally show ?thesis by simp
qed

lemma mult_1_right_octo [simp]: "x * 1 = (x :: octo)"
 and mult_1_left_octo [simp]: "1 * x = (x :: octo)"
  by (simp_all add: times_octo_def)

instance octo :: power ..

lemma power2_eq_square_octo: "x ^ 2 = (x * x :: octo)"
  by (simp add: numeral_2_eq_2 times_octo_def)

lemma octo_product_alternative_left: "x * (x * y) = (x * x :: octo) * y"
  unfolding octo_eq_iff octo_mult_components by algebra

lemma octo_product_flexible: "(x * y) * x = x * (y * x :: octo)"
  unfolding octo_eq_iff octo_mult_components by algebra

lemma octo_power_commutes: "x ^ y * x = x * (x ^ y :: octo)"
  by (induction y) (simp_all add: octo_product_flexible)

lemma octo_product_noncommutative: "\<not>(\<forall>x y::octo. (x * y = y * x))"

  using inverse_1 left_inverse mult_not_zero octo.sel(8) octo_e4.sel(2)
  octo_e4.sel(3)   octo_e4.sel(5)  octo_e5.sel(1) octo_e5.sel(2)
  octo_e5.sel(3) octo_e5.sel(5) octo_e5.sel(6) octo_e5.sel(8) times_octo_def
  by smt

lemma octo_product_nonassociative :
  "\<not>(\<forall> x y z::octo. x * (y * z) = (x * y) * z)"
proof-
  define x where "x = Octo 1 0 0 0 1 0 0 0"
  define y where "y = Octo 1 3 0 0 0 1 0 0"
  define z where "z = Octo 0 1 0 1 1 1 0 0"
  have "x * (y * z) \<noteq> (x * y) * z"
    by (simp add: octo_eq_iff octo_mult_components x_def y_def z_def)
  thus ?thesis by blast
qed

subsection \<open>Embedding of the Reals into the Octonions\<close>

definition octo_of_real :: "real \<Rightarrow>  octo"
  where "octo_of_real r = scaleR r 1"

definition octo_of_nat :: "nat \<Rightarrow>  octo"
  where "octo_of_nat r = scaleR r 1"

definition octo_of_int :: "int \<Rightarrow>  octo"
  where "octo_of_int r = scaleR r 1"

lemma octo_of_nat_sel [simp]:
  "Ree (octo_of_nat x) = of_nat x" "Im1 (octo_of_nat x) = 0" "Im2 (octo_of_nat x) = 0"
  "Im3 (octo_of_nat x) = 0" "Im4 (octo_of_nat x) = 0" "Im5 (octo_of_nat x) = 0"
  "Im6 (octo_of_nat x) = 0" "Im7 (octo_of_nat x) = 0"
  by (simp_all add: octo_of_nat_def)

lemma octo_of_real_sel [simp]:
  "Ree (octo_of_real x) = x" "Im1 (octo_of_real x) = 0" "Im2 (octo_of_real x) = 0"
  "Im3 (octo_of_real x) = 0" "Im4 (octo_of_real x) = 0" "Im5 (octo_of_real x) = 0"
  "Im6 (octo_of_real x) = 0" "Im7 (octo_of_real x) = 0"
  by (simp_all add: octo_of_real_def)

lemma octo_of_int_sel [simp]:
  "Ree (octo_of_int x) = of_int x" "Im1 (octo_of_int x) = 0" "Im2 (octo_of_int x) = 0"
  "Im3 (octo_of_int x) = 0" "Im4 (octo_of_int x) = 0" "Im5 (octo_of_int x) = 0"
  "Im6 (octo_of_int x) = 0" "Im7 (octo_of_int x) = 0"
  by (simp_all add: octo_of_int_def)

lemma scaleR_conv_octo_of_real: "scaleR r x = octo_of_real r * x"
  by (simp add: octo_eq_iff octo_mult_components octo_of_real_def)

lemma octo_of_real_0 [simp]: "octo_of_real 0 = 0"
  by (simp add: octo_of_real_def)

lemma octo_of_real_1 [simp]: "octo_of_real 1 = 1"
  by (simp add: octo_of_real_def)

lemma octo_of_real_add [simp]: "octo_of_real (x + y) = octo_of_real x + octo_of_real y"
  by (simp add: octo_of_real_def scaleR_left_distrib)

lemma octo_of_real_minus [simp]: "octo_of_real (- x) = - octo_of_real x"
  by (simp add: octo_of_real_def)

lemma octo_of_real_diff [simp]: "octo_of_real (x - y) = octo_of_real x - octo_of_real y"
  by (simp add: octo_of_real_def scaleR_left_diff_distrib)

lemma octo_of_real_mult [simp]: "octo_of_real (x * y) = octo_of_real x * octo_of_real y"
  using octo_of_real_def
  by (metis scaleR_conv_octo_of_real scaleR_scaleR)

lemma octo_of_real_sum[simp]: "octo_of_real (sum f s) = (\<Sum>x\<in>s. octo_of_real (f x))"
  by (induct s rule: infinite_finite_induct) auto

lemma octo_of_real_eq_iff [simp]: "octo_of_real x = octo_of_real y \<longleftrightarrow> x = y"
  using octo_of_real_def
  by (simp add: octo_of_real_def one_octo.code zero_octo.code)

lemmas octo_of_real_eq_0_iff [simp] = octo_of_real_eq_iff [of _ 0, simplified]
lemmas octo_of_real_eq_1_iff [simp] = octo_of_real_eq_iff [of _ 1, simplified]

lemma minus_octo_of_real_eq_octo_of_real_iff [simp]: "-octo_of_real x = octo_of_real y \<longleftrightarrow> -x = y"
  using octo_of_real_eq_iff[of "-x" y] by (simp only: octo_of_real_minus)

lemma octo_of_real_eq_minus_of_real_iff [simp]: "octo_of_real x = -octo_of_real y \<longleftrightarrow> x = -y"
  using octo_of_real_eq_iff[of x "-y"] by (simp only: octo_of_real_minus)

lemma octo_of_real_of_nat_eq [simp]: "octo_of_real (of_nat x) = octo_of_nat x"
  unfolding octo_of_real_def
  by (simp add: octo_of_nat_def)

lemma octo_of_real_of_int_eq [simp]: "octo_of_real (of_int z) = octo_of_int z"
 unfolding octo_of_real_def
  by (simp add: octo_of_int_def)

lemma octo_of_int_of_nat:  "octo_of_int (of_nat n) = octo_of_nat n"
  by (simp add: octo_eq_iff)

lemma octo_of_nat_add [simp]: "octo_of_nat (a + b) = octo_of_nat a + octo_of_nat b"
  and octo_of_nat_mult [simp]: "octo_of_nat (a * b) = octo_of_nat a * octo_of_nat b"
  and octo_of_nat_diff [simp]: "b \<le> a \<Longrightarrow> octo_of_nat (a - b) = octo_of_nat a - octo_of_nat b"
  and octo_of_nat_0 [simp]: "octo_of_nat 0 = 0"
  and octo_of_nat_1 [simp]: "octo_of_nat 1 = 1"
  and octo_of_nat_Suc_0 [simp]: "octo_of_nat (Suc 0) = 1"
  by (simp_all add: octo_eq_iff octo_mult_components)

lemma octo_of_int_add [simp]: "octo_of_int (a + b) = octo_of_int a + octo_of_int b"
  and octo_of_int_mult [simp]: "octo_of_int (a * b) = octo_of_int a * octo_of_int b"
  and octo_of_int_diff [simp]: "b \<le> a \<Longrightarrow> octo_of_int (a - b) = octo_of_int a - octo_of_int b"
  and octo_of_int_0 [simp]: "octo_of_int 0 = 0"
  and octo_of_int_1 [simp]: "octo_of_int 1 = 1"
  by (simp_all add: octo_eq_iff octo_mult_components)

instance octo :: numeral ..

lemma numeral_octo_conv_of_nat: "numeral x = octo_of_nat (numeral x)"
proof (induction x)
  case(Bit0 x)
  have "numeral x+ numeral x = octo_of_nat(numeral x+ numeral x)"
    unfolding Bit0.IH octo_of_nat_add ..
  thus ?case by (simp add: numeral_Bit0)
next
 case(Bit1 x)
  have "numeral x+ numeral x + numeral num.One=
octo_of_nat (numeral x + numeral x + numeral num.One)"
    unfolding Bit1.IH octo_of_nat_add by simp
  thus ?case by (simp add: numeral_Bit1)
qed auto

lemma numeral_octo_sel [simp]:
  "Ree (numeral n) = numeral n" "Im1 (numeral n) = 0" "Im2 (numeral n) = 0"
  "Im3 (numeral n) = 0" "Im4 (numeral n) = 0" "Im5 (numeral n) = 0"
  "Im6 (numeral n) = 0" "Im7 (numeral n) = 0"
  by (simp_all add: numeral_octo_conv_of_nat)

lemma octo_of_real_numeral [simp]: "octo_of_real (numeral w) = numeral w"
  by (simp add: numeral_octo_conv_of_nat octo_of_real_def octo_of_nat_def)

lemma octo_of_real_neg_numeral [simp]: "octo_of_real (- numeral w) = - numeral w"
  by simp

lemma octo_of_real_times_commute: "octo_of_real r * q = q * octo_of_real r"
  using octo_of_real_def times_octo_def by simp

lemma octo_of_real_times_conv_scaleR: "octo_of_real x * y = scaleR x y"
  by (simp add: octo_eq_iff octo_mult_components)

lemma octo_mult_scaleR_left: "(r *\<^sub>R x) * y = r *\<^sub>R (x * y :: octo)"
  by (simp add: octo_eq_iff octo_mult_components algebra_simps)

lemma octo_mult_scaleR_right: "x * (r *\<^sub>R y) = r *\<^sub>R (x * y :: octo)"
  by (simp add: octo_eq_iff octo_mult_components algebra_simps)

lemma scaleR_octo_of_real [simp]: "scaleR r (octo_of_real s) = octo_of_real (r * s)"
  by (simp add: octo_of_real_def)

lemma octo_of_real_times_left_commute: "octo_of_real r * (x * q) = x * (octo_of_real r * q)"
  unfolding octo_of_real_times_conv_scaleR by (simp add: octo_mult_scaleR_right)

lemma nonzero_octo_of_real_inverse:
  "x \<noteq> 0 \<Longrightarrow> octo_of_real (inverse x) = inverse (octo_of_real x :: octo)"
  by (simp add: octo_eq_iff power2_eq_square divide_simps)

lemma octo_of_real_inverse [simp]:
  "octo_of_real (inverse x) = inverse (octo_of_real x )"
  by (simp add: octo_eq_iff power2_eq_square divide_simps)

lemma nonzero_octo_of_real_divide:
  "y \<noteq> 0 \<Longrightarrow> octo_of_real (x / y) = (octo_of_real x / octo_of_real y ::octo)"
   by (simp add: divide_inverse divide_octo_def)

lemma octo_of_real_divide [simp]:
  "octo_of_real (x / y) = (octo_of_real x / octo_of_real y :: octo)"
  using divide_inverse divide_octo_def octo_of_real_def octo_of_real_inverse
  by (metis octo_of_real_mult)

lemma octo_of_real_inverse_collapse [simp]:
  assumes "c \<noteq> 0"
  shows   "octo_of_real c * octo_of_real (inverse c) = 1"
          "octo_of_real (inverse c) * octo_of_real c = 1"
  using assms by (simp_all add: octo_eq_iff octo_mult_components power2_eq_square)

lemma octo_divide_numeral:
  fixes x::octo shows "x / numeral y = x /\<^sub>R numeral y"
  using octo_of_real_times_commute[of "inverse (numeral y)"]
  by (simp add: scaleR_conv_octo_of_real divide_octo_def flip: octo_of_real_numeral)

lemma octo_divide_numeral_sel [simp]:
  "Ree (x / numeral w) = Ree x / numeral w"
  "Im1 (x / numeral w) = Im1 x / numeral w"
  "Im2 (x / numeral w) = Im2 x / numeral w"
  "Im3 (x / numeral w) = Im3 x / numeral w"
  "Im4 (x / numeral w) = Im4 x / numeral w"
  "Im5 (x / numeral w) = Im5 x / numeral w"
  "Im6 (x / numeral w) = Im6 x / numeral w"
  "Im7 (x / numeral w) = Im7 x / numeral w"
  unfolding octo_divide_numeral by simp_all

lemma octo_norm_units [simp]:
  "norm octo_e1 = 1" "norm (e2::octo) = 1" "norm (e3::octo) = 1"
  "norm (e4::octo) = 1 "  "norm (e5::octo) = 1"   "norm (e6::octo) = 1" "norm (e7::octo) = 1"
  by (auto simp: norm_octo_def)

lemma e1_nz [simp]: "e1 \<noteq> 0"
  and e2_nz [simp]: "e2 \<noteq> 0"
  and e3_nz [simp]: "e3 \<noteq> 0"
  and e4_nz [simp]: "e4 \<noteq> 0"
  and e5_nz [simp]: "e5 \<noteq> 0"
  and e6_nz [simp]: "e6 \<noteq> 0"
  and e7_nz [simp]: "e7 \<noteq> 0"
  by (simp_all add: octo_eq_iff)

subsection \<open>"Expansion" into the traditional notation\<close>

lemma octo_unfold:
   "q = (Ree q) *\<^sub>R e0 + (Im1 q) *\<^sub>R e1 + (Im2 q) *\<^sub>R e2 + (Im3 q) *\<^sub>R e3
      + (Im4 q) *\<^sub>R e4 + (Im5 q) *\<^sub>R e5 + (Im6 q) *\<^sub>R e6 + (Im7 q) *\<^sub>R  e7"
  by (simp add: octo_eq_iff)

lemma octo_trad: "Octo x y z w u v q g =
     x *\<^sub>R e0 + y *\<^sub>R e1 +  z *\<^sub>R e2  +  w *\<^sub>R e3  +  u *\<^sub>R e4 +  v *\<^sub>R e5 +  q *\<^sub>R e6  +  g*\<^sub>R e7 "
  by (simp add: octo_eq_iff)

lemma octo_of_real_eq_Octo: "octo_of_real a = Octo a 0 0 0 0 0 0 0 "
  by (simp add: octo_eq_iff)

lemma e1_squared [simp]: "e1 ^ 2 = -1"
  and e2_squared [simp]: "e2 ^ 2 = -1"
  and e3_squared [simp]: "e3 ^ 2 = -1"
  and e4_squared [simp]: "e4 ^ 2 = -1"
  and e5_squared [simp]: "e5 ^ 2 = -1"
  and e6_squared [simp]: "e6 ^ 2 = -1"
  and e7_squared [simp]: "e7 ^ 2 = -1"
  by (simp_all add: octo_eq_iff power2_eq_square_octo octo_mult_components)

lemma inverse_e1 [simp]: "inverse e1 = -e1"
  and inverse_e2 [simp]: "inverse e2 = -e2"
  and inverse_e3 [simp]: "inverse e3 = -e3"
  and inverse_e4 [simp]: "inverse e4 = -e4"
  and inverse_e5 [simp]: "inverse e5 = -e5"
  and inverse_e6 [simp]: "inverse e6 = -e6"
  and inverse_e7 [simp]: "inverse e7 = -e7"
  by (simp_all add: octo_eq_iff)

subsection \<open>Conjugate of an octonion and related properties.\<close>

primcorec cnj :: "octo \<Rightarrow> octo"
  where
    "Ree (cnj z) = Ree z"
  | "Im1 (cnj z) = - Im1 z"
  | "Im2 (cnj z) = - Im2 z"
  | "Im3 (cnj z) = - Im3 z"
  | "Im4 (cnj z) = - Im4 z"
  | "Im5 (cnj z) = - Im5 z"
  | "Im6 (cnj z) = - Im6 z"
  | "Im7 (cnj z) = - Im7 z"

lemma cnj_cancel_iff [simp]: "cnj x = cnj y \<longleftrightarrow> x = y"

proof
  show "cnj x = cnj y \<Longrightarrow> x = y"
    by (simp add: octo_eq_iff)
qed auto

lemma cnj_of_real [simp]: "cnj(octo_of_real x) = octo_of_real x"
  using  octo_eq_iff
  by (simp add: octo_of_real_eq_Octo)

lemma cnj_zero [simp]: "cnj 0 = 0"
  by (simp add: octo_eq_iff)

lemma cnj_zero_iff [iff]: "cnj z = 0 \<longleftrightarrow> z = 0"
 using cnj_cnj   by (metis cnj_zero)

lemma cnj_one [simp]: "cnj 1 = 1"
  by (simp add: octo_eq_iff)

lemma cnj_one_iff [simp]: "cnj z = 1 \<longleftrightarrow> z = 1"
  by (simp add: octo_eq_iff)

lemma octo_norm_cnj [simp]: "norm(cnj q) = norm q"
  by (simp add: norm_octo_def)

lemma cnj_add [simp]: "cnj (x + y) = cnj x + cnj y"
  using  octo_eq_iff inner_real_def of_real_0 of_real_inner_1  by simp

lemma cnj_sum [simp]: "cnj (sum f S) = (\<Sum>x\<in>S. cnj (f x))"
  by (induct S rule: infinite_finite_induct) auto

lemma cnj_diff [simp]: "cnj (x - y) = cnj x - cnj y"
  using  octo_eq_iff
  by (metis add.commute add_left_cancel cnj_add diff_add_cancel)

lemma cnj_minus [simp]: "cnj (- x) = - cnj x"
  using  octo_eq_iff  cnj_cnj by auto

lemma cnj_inverse [simp]: "cnj (inverse x) = inverse (cnj x)" for x y ::octo
  using  octo_eq_iff inner_real_def real_inner_1_right  by auto

lemma cnj_mult [simp]: "cnj (x * y) = cnj y * cnj x" for x y ::octo
  using octo_eq_iff  times_octo_def octo_mult_components cnj_cnj
 mult_not_zero nonzero_inverse_mult_distrib  by simp

lemma cnj_divide [simp]: "cnj (x / y) = (inverse (cnj y) ) *  cnj x"
  for x y ::octo
  unfolding  divide_octo_def times_octo_def
  using cnj_inverse cnj_mult octo_mult_components  by (metis times_octo_def)

lemma cnj_power [simp]: "cnj (x ^ y) = (cnj x) ^ y"  for x::octo
  by (induction y) (simp_all add: octo_power_commutes)

lemma cnj_of_nat [simp]: "cnj (octo_of_nat x) = octo_of_nat( x)"
   using cnj_of_real octo_of_real_of_nat_eq by metis

lemma cnj_of_int [simp]: "cnj (octo_of_int x) = octo_of_nat( x)"
   using  octo_of_real_def  octo_of_real_of_int_eq  octo_of_int_def octo_of_nat_def
   cnj_of_real by auto

lemma cnj_neg_numeral [simp]: "cnj (- numeral x) = - numeral x"
   by (simp add: numeral_octo_conv_of_nat)

lemma cnj_scaleR [simp]: "cnj (scaleR r x) = scaleR r (cnj x)"
   using octo_eq_iff inner_real_def ln_one of_real_inner_1 by simp

lemma cnj_units [simp]: "cnj e1 = -e1" "cnj e2 = -e2" "cnj e3 = -e3"
 "cnj e4 = -e4"   "cnj e5 = -e5"   "cnj e6 = -e6"  "cnj e7 = -e7"
  by (simp_all add: octo_eq_iff)

lemma cnj_eq_of_real: "cnj q = octo_of_real x \<longleftrightarrow> q = octo_of_real x"
proof
  show "cnj q = octo_of_real x \<Longrightarrow> q = octo_of_real x"
    by (metis cnj_of_real cnj_cnj)
qed auto

lemma octo_trad_cnj : "cnj q = (Ree q) *\<^sub>R e0 - (Im1 q) *\<^sub>R e1 - (Im2 q)*\<^sub>R e2  - (Im3 q) *\<^sub>R e3  -
 (Im4 q) *\<^sub>R e4 -  (Im5 q) *\<^sub>R e5 -  (Im6 q) *\<^sub>R e6  -  (Im7 q)*\<^sub>R e7 " for q::octo
  using cnj_cnj octo_unfold octo_trad cnj_def Octonions.cnj.code by auto

lemma octonion_conjugate_property:
  "cnj x = -(1/6) *\<^sub>R (x + (e1 * x) *  e1  +  (e2 * x) * e2 +  (e3 * x) * e3 +
     (e4 * x) * e4 + (e5 * x) * e5 +  ( e6 * x) * e6 + (e7 * x) * e7)"
  by (simp add: octo_eq_iff octo_mult_components)

lemma octo_add_cnj: "q + cnj q = 2 *\<^sub>R (Ree q) *\<^sub>R e0" "cnj q + q = (2*\<^sub>R (Ree q)*\<^sub>R e0)"
  by (simp_all add: octo_eq_iff)

lemma octo_add_cnj1: "q + cnj q = octo_of_real (2*\<^sub>R (Ree q))"
                     "cnj q + q = octo_of_real (2*\<^sub>R (Ree q))"
  by (auto simp: octo_eq_iff octo_mult_components)

lemma octo_subtract_cnj:
  "q - cnj q = 2 *\<^sub>R (Im1 q *\<^sub>R e1 + Im2 q *\<^sub>R e2 + Im3 q *\<^sub>R e3 +
                     Im4 q *\<^sub>R e4 + Im5 q *\<^sub>R e5 + Im6 q*\<^sub>R e6 + Im7 q *\<^sub>R e7)"
  by (simp add: octo_eq_iff)

lemma octo_mult_cnj_commute: "cnj x * x = x * cnj x"
  using times_octo_def by auto

lemma octo_cnj_mult_conv_norm: "cnj x * x = octo_of_real (norm x) ^ 2"
  by (simp add: octo_eq_iff octo_mult_components norm_octo_def power2_eq_square
           flip: octo_of_real_power)

lemma octo_mult_cnj_conv_norm: "x * cnj x = octo_of_real (norm x) ^ 2"
  by (simp add: octo_eq_iff octo_mult_components norm_octo_def power2_eq_square
           flip: octo_of_real_power)

lemma octo_mult_cnj_conv_norm_aux: "octo_of_real (norm x ^ 2) = x * cnj x "
  using octo_mult_cnj_conv_norm[of x] by (simp add: octo_mult_cnj_commute)

lemma octo_norm_conj: "octo_of_real ( inner x y) = (1/2) *\<^sub>R (x * (cnj y) + y * (cnj x))"
  by (simp add: octo_eq_iff octo_mult_components inner_octo_def)

lemma octo_inverse_cnj: "inverse x = cnj x /\<^sub>R (norm x ^ 2)"
  by (auto simp: octo_eq_iff norm_octo_def field_simps)

lemma inverse_octo_1: "x \<noteq> 0 \<Longrightarrow> x * inverse x = (1 :: octo)"
  by (simp add: octo_mult_scaleR_right octo_mult_cnj_conv_norm_aux [symmetric]
                divide_simps octo_inverse_cnj
           del: octo_of_real_power)

lemma inverse_octo_1_sym: "x \<noteq> 0 \<Longrightarrow> inverse x * x = (1 :: octo)"
  by (metis cnj_cnj cnj_inverse cnj_mult cnj_one cnj_zero inverse_octo_1)

lemma inverse_0_octo [simp]: "inverse 0 = (0 :: octo)"
  by (simp add: octo_eq_iff)

lemma inverse_octo_commutes: "inverse x * x = x * (inverse x :: octo)"
  by (cases "x = 0") (simp_all add: inverse_octo_1 inverse_octo_1_sym)

lemma octo_inverse_mult: "inverse (x * y) = inverse y * inverse x" for x y::octo
proof-
  have "inverse (x * y) = (cnj y * cnj x) /\<^sub>R (norm (x * y) ^ 2)"
     by (simp add: octo_inverse_cnj)
   also have "\<dots> = (cnj y /\<^sub>R norm y ^ 2) * (cnj x /\<^sub>R norm x ^ 2)"
     by (simp add: octo_mult_scaleR_left octo_mult_scaleR_right multiplicative_norm_octo
                   power2_eq_square)
   also have "\<dots> = inverse y * inverse x"
     by (simp add: octo_inverse_cnj)
   finally show ?thesis .
qed

lemma octo_inverse_eq_cnj: "norm q = 1 \<Longrightarrow> inverse q = cnj q" for q::octo
  by (simp add: octo_inverse_cnj)

lemma octo_in_Reals_if_Re: fixes q ::real shows " Ree( octo_of_real(q)) = q"
  by simp

lemma octo_in_Reals_if_Re_con: assumes "Ree (octo_of_real q) = q"
  shows "q \<in> Reals"
  by (metis Reals_of_real inner_real_def mult.right_neutral of_real_inner_1)

lemma octo_in_Reals_if_cnj: fixes q:: real shows " cnj( octo_of_real( q)) = octo_of_real q"
  by simp

lemma octo_in_Reals_if_cnj_con: assumes " cnj( octo_of_real( q)) = octo_of_real q"
  shows "q \<in> Reals "
   by (metis Reals_of_real inner_real_def mult.right_neutral of_real_inner_1)

lemma norm_power2: "norm q ^ 2 = Ree (cnj q * q)"
  by (simp add: octo_mult_components norm_octo_def power2_eq_square)

lemma norm_power2_cnj: "norm q ^ 2 = Ree (q * cnj q)"
  by (simp add: octo_mult_components norm_octo_def power2_eq_square)

lemma octo_norm_imaginary: "Ree x = 0 \<Longrightarrow> x * x = -(octo_of_real (norm x))\<^sup>2"
  by (simp add: octo_eq_iff octo_mult_components norm_octo_def power2_eq_square
           flip: octo_of_real_power octo_of_real_mult)

subsection\<open> Linearity and continuity of the components.\<close>

lemma bounded_linear_Ree: "bounded_linear Ree"
  and bounded_linear_Im1: "bounded_linear Im1"
  and bounded_linear_Im2: "bounded_linear Im2"
  and bounded_linear_Im3: "bounded_linear Im3"
  and bounded_linear_Im4: "bounded_linear Im4"
  and bounded_linear_Im5: "bounded_linear Im5"
  and bounded_linear_Im6: "bounded_linear Im6"
  and bounded_linear_Im7: "bounded_linear Im7"
  by (simp_all add: bounded_linear_intro [where K=1] norm_octo_def real_le_rsqrt add.assoc)

lemmas Cauchy_Ree = bounded_linear.Cauchy [OF bounded_linear_Ree]
lemmas Cauchy_Im1 = bounded_linear.Cauchy [OF bounded_linear_Im1]
lemmas Cauchy_Im2 = bounded_linear.Cauchy [OF bounded_linear_Im2]
lemmas Cauchy_Im3 = bounded_linear.Cauchy [OF bounded_linear_Im3]
lemmas Cauchy_Im4 = bounded_linear.Cauchy [OF bounded_linear_Im4]
lemmas Cauchy_Im5 = bounded_linear.Cauchy [OF bounded_linear_Im5]
lemmas Cauchy_Im6 = bounded_linear.Cauchy [OF bounded_linear_Im6]
lemmas Cauchy_Im7 = bounded_linear.Cauchy [OF bounded_linear_Im7]

lemmas tendsto_Re [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Ree]
lemmas tendsto_Im1 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im1]
lemmas tendsto_Im2 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im2]
lemmas tendsto_Im3 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im3]
lemmas tendsto_Im4 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im4]
lemmas tendsto_Im5 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im5]
lemmas tendsto_Im6 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im6]
lemmas tendsto_Im7 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im7]

lemmas isCont_Ree [simp] = bounded_linear.isCont [OF bounded_linear_Ree]
lemmas isCont_Im1 [simp] = bounded_linear.isCont [OF bounded_linear_Im1]
lemmas isCont_Im2 [simp] = bounded_linear.isCont [OF bounded_linear_Im2]
lemmas isCont_Im3 [simp] = bounded_linear.isCont [OF bounded_linear_Im3]
lemmas isCont_Im4 [simp] = bounded_linear.isCont [OF bounded_linear_Im4]
lemmas isCont_Im5 [simp] = bounded_linear.isCont [OF bounded_linear_Im5]
lemmas isCont_Im6 [simp] = bounded_linear.isCont [OF bounded_linear_Im6]
lemmas isCont_Im7 [simp] = bounded_linear.isCont [OF bounded_linear_Im7]

lemmas continuous_Ree [simp] = bounded_linear.continuous [OF bounded_linear_Ree]
lemmas continuous_Im1 [simp] = bounded_linear.continuous [OF bounded_linear_Im1]
lemmas continuous_Im2 [simp] = bounded_linear.continuous [OF bounded_linear_Im2]
lemmas continuous_Im3 [simp] = bounded_linear.continuous [OF bounded_linear_Im3]
lemmas continuous_Im4 [simp] = bounded_linear.continuous [OF bounded_linear_Im4]
lemmas continuous_Im5 [simp] = bounded_linear.continuous [OF bounded_linear_Im5]
lemmas continuous_Im6 [simp] = bounded_linear.continuous [OF bounded_linear_Im6]
lemmas continuous_Im7 [simp] = bounded_linear.continuous [OF bounded_linear_Im7]

lemmas continuous_on_Ree [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Ree]
lemmas continuous_on_Im1 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im1]
lemmas continuous_on_Im2 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im2]
lemmas continuous_on_Im3 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im3]
lemmas continuous_on_Im4 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im4]
lemmas continuous_on_Im5 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im5]
lemmas continuous_on_Im6 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im6]
lemmas continuous_on_Im7 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im7]

lemmas has_derivative_Ree [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Ree]
lemmas has_derivative_Im1 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im1]
lemmas has_derivative_Im2 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im2]
lemmas has_derivative_Im3 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im3]
lemmas has_derivative_Im4 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im4]
lemmas has_derivative_Im5 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im5]
lemmas has_derivative_Im6 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im6]
lemmas has_derivative_Im7 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im7]

lemmas sums_Ree = bounded_linear.sums [OF bounded_linear_Ree]
lemmas sums_Im1 = bounded_linear.sums [OF bounded_linear_Im1]
lemmas sums_Im2 = bounded_linear.sums [OF bounded_linear_Im2]
lemmas sums_Im3 = bounded_linear.sums [OF bounded_linear_Im3]
lemmas sums_Im4 = bounded_linear.sums [OF bounded_linear_Im4]
lemmas sums_Im5 = bounded_linear.sums [OF bounded_linear_Im5]
lemmas sums_Im6 = bounded_linear.sums [OF bounded_linear_Im6]
lemmas sums_Im7 = bounded_linear.sums [OF bounded_linear_Im7]

subsubsection\<open> Octonionic-specific theorems about sums.                                \<close>

lemma Ree_sum [simp]: "Ree (sum f S) = sum (\<lambda>x.  Ree(f x)) S"
  and Im1_sum [simp]: "Im1 (sum f S) = sum (\<lambda>x. Im1 (f x)) S"
  and Im2_sum [simp]: "Im2 (sum f S) = sum (\<lambda>x. Im2 (f x)) S"
  and Im3_sum [simp]: "Im3 (sum f S) = sum (\<lambda>x. Im3 (f x)) S"
  and Im4_sum [simp]: "Im4 (sum f S) = sum (\<lambda>x. Im4 (f x)) S"
  and Im5_sum [simp]: "Im5 (sum f S) = sum (\<lambda>x. Im5 (f x)) S"
  and Im6_sum [simp]: "Im6 (sum f S) = sum (\<lambda>x. Im6 (f x)) S"
  and Im7_sum [simp]: "Im7 (sum f S) = sum (\<lambda>x. Im7 (f x)) S"
  by (induct S rule: infinite_finite_induct; simp)+

subsubsection\<open> Bound results for real and imaginary components of limits.                \<close>

lemma Ree_tendsto_upperbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. octo.Ree (f x) \<le> b; net \<noteq> bot\<rbrakk> \<Longrightarrow> Ree limit \<le> b"
  by (blast intro: tendsto_upperbound [OF tendsto_Re])

lemma Im1_tendsto_upperbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. Im1 (f x) \<le> b; net \<noteq> bot\<rbrakk> \<Longrightarrow> Im1 limit \<le> b"
  by (blast intro: tendsto_upperbound [OF tendsto_Im1])

lemma Im2_tendsto_upperbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. Im2 (f x) \<le> b; net \<noteq> bot\<rbrakk> \<Longrightarrow> Im2 limit \<le> b"
  by (blast intro: tendsto_upperbound [OF tendsto_Im2])

lemma Im4_tendsto_upperbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. Im4 (f x) \<le> b; net \<noteq> bot\<rbrakk> \<Longrightarrow> Im4 limit \<le> b"
  by (blast intro: tendsto_upperbound [OF tendsto_Im4])

lemma Im5_tendsto_upperbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. Im5 (f x) \<le> b; net \<noteq> bot\<rbrakk> \<Longrightarrow> Im5 limit \<le> b"
  by (blast intro: tendsto_upperbound [OF tendsto_Im5])

lemma Im6_tendsto_upperbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. Im6 (f x) \<le> b; net \<noteq> bot\<rbrakk> \<Longrightarrow> Im6 limit \<le> b"
  by (blast intro: tendsto_upperbound [OF tendsto_Im6])

lemma Im7_tendsto_upperbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. Im7 (f x) \<le> b; net \<noteq> bot\<rbrakk> \<Longrightarrow> Im7 limit \<le> b"
  by (blast intro: tendsto_upperbound [OF tendsto_Im7])

lemma Ree_tendsto_lowerbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. b \<le> octo.Ree (f x); net \<noteq> bot\<rbrakk> \<Longrightarrow> b \<le> Ree limit"
  by (blast intro: tendsto_lowerbound [OF tendsto_Re])

lemma Im1_tendsto_lowerbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. b \<le> Im1 (f x); net \<noteq> bot\<rbrakk> \<Longrightarrow> b \<le> Im1 limit"
  by (blast intro: tendsto_lowerbound [OF tendsto_Im1])

lemma Im2_tendsto_lowerbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. b \<le> Im2 (f x); net \<noteq> bot\<rbrakk> \<Longrightarrow> b \<le> Im2 limit"
  by (blast intro: tendsto_lowerbound [OF tendsto_Im2])

lemma Im3_tendsto_lowerbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. b \<le> Im3 (f x); net \<noteq> bot\<rbrakk> \<Longrightarrow> b \<le> Im3 limit"
  by (blast intro: tendsto_lowerbound [OF tendsto_Im3])

lemma Im4_tendsto_lowerbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. b \<le> Im4 (f x); net \<noteq> bot\<rbrakk> \<Longrightarrow> b \<le> Im4 limit"
  by (blast intro: tendsto_lowerbound [OF tendsto_Im4])

lemma Im5_tendsto_lowerbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. b \<le> Im5 (f x); net \<noteq> bot\<rbrakk> \<Longrightarrow> b \<le> Im5 limit"
  by (blast intro: tendsto_lowerbound [OF tendsto_Im5])

lemma Im6_tendsto_lowerbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. b \<le> Im6 (f x); net \<noteq> bot\<rbrakk> \<Longrightarrow> b \<le> Im6 limit"
  by (blast intro: tendsto_lowerbound [OF tendsto_Im6])

lemma Im7_tendsto_lowerbound:
   "\<lbrakk>(f \<longlongrightarrow> limit) net; \<forall>\<^sub>F x in net. b \<le> Im7 (f x); net \<noteq> bot\<rbrakk> \<Longrightarrow> b \<le> Im7 limit"
  by (blast intro: tendsto_lowerbound [OF tendsto_Im7])

lemma octo_of_real_continuous [continuous_intros]:
  "continuous net f \<Longrightarrow> continuous net (\<lambda>x. octo_of_real (f x))"
  by (auto simp: octo_of_real_def intro: continuous_intros)

lemma octo_of_real_continuous_on [continuous_intros]:
  "continuous_on S f \<Longrightarrow> continuous_on S (\<lambda>x. octo_of_real (f x))"
  by (auto simp: octo_of_real_def intro: continuous_intros)

lemma of_real_continuous_iff: "continuous net (\<lambda>x. octo_of_real (f x)) \<longleftrightarrow> continuous net f"
proof safe
  assume "continuous net (\<lambda>x. octo_of_real (f x))"
  hence "continuous net (\<lambda>x. Ree (octo_of_real (f x)))"
    by (rule continuous_Ree)
  thus "continuous net f" by simp
qed (auto intro: continuous_intros)

lemma of_real_continuous_on_iff:
   "continuous_on S (\<lambda>x. octo_of_real(f x)) \<longleftrightarrow> continuous_on S f"
proof safe
  assume "continuous_on S (\<lambda>x. octo_of_real (f x))"
  hence "continuous_on S (\<lambda>x. Ree (octo_of_real (f x)))"
    by (rule continuous_on_Ree)
  thus "continuous_on S f" by simp
qed (auto intro: continuous_intros)

subsection\<open>Octonions for describing 7D isometries\<close>

subsubsection\<open>The \<open>HIm\<close> operator\<close>

definition HIm :: "octo \<Rightarrow> real^7" where
  "HIm q \<equiv> vector[Im1 q, Im2 q, Im3 q, Im4 q, Im5 q, Im6 q, Im7 q]"

lemma HIm_Octo: "HIm (Octo w x y z u v q g) = vector[x,y,z, u, v, q, g]"
  by (simp add: HIm_def)

lemma him_eq: "HIm a = HIm b \<longleftrightarrow> Im1 a = Im1 b \<and> Im2 a = Im2 b \<and> Im3 a = Im3 b
 \<and> Im4 a = Im4 b \<and> Im5 a = Im5 b \<and> Im6 a = Im6 b \<and> Im7 a = Im7 b"

  by (metis HIm_def vector_7)

lemma him_of_real [simp]: "HIm(octo_of_real a) = 0"
 by (simp add:octo_of_real_eq_Octo HIm_Octo vec_eq_iff vector_def)

lemma him_0 [simp]: "HIm 0 = 0"
 by (metis him_of_real octo_of_real_0)

lemma him_1 [simp]: "HIm 1 = 0"
 using HIm_def him_0 by auto

lemma him_cnj: "HIm(cnj q) = - HIm q"
  by (simp add: HIm_def vec_eq_iff vector_def)

lemma him_mult_left [simp]: "HIm (a *\<^sub>R q) = a  *\<^sub>R HIm q"
  by (simp add: HIm_def vec_eq_iff vector_def)

lemma him_mult_right [simp]: "HIm (q * octo_of_real a) = HIm q * of_real a"
 by (metis Octonions.scaleR_conv_octo_of_real Real_Vector_Spaces.scaleR_conv_of_real
 him_mult_left octo_of_real_times_commute semiring_normalization_rules(7))

lemma him_add [simp]: "HIm (x + y) = HIm x + HIm y"
 and  him_minus [simp]: "HIm (-x) = - HIm x"
 and  him_diff [simp]: "HIm (x - y) = HIm x - HIm y"
  by (simp_all add: HIm_def vec_eq_iff vector_def)

lemma him_sum [simp]: "HIm (sum f S) = (\<Sum>x\<in>S. HIm (f x))"
  by (induct S rule: infinite_finite_induct) auto

lemma linear_him: "linear HIm"
  by (simp add: linearI)

subsubsection\<open>The \<open>Hv\<close> operator\<close>

definition Hv :: "real^7 \<Rightarrow> octo" where
  "Hv v \<equiv> Octo 0 (v$1) (v$2) (v$3) (v$4) (v$5) (v$6) (v$7)  "

lemma Hv_sel [simp]:
  "Ree (Hv v) = 0" "Im1 (Hv v) = v $ 1" "Im2 (Hv v) = v $ 2" "Im3 (Hv v) = v $ 3"
  "Im4 (Hv v) = v $ 4" "Im5 (Hv v) = v $ 5" "Im6 (Hv v) = v $ 6" "Im7 (Hv v) = v $ 7"
  by (simp_all add: Hv_def)

lemma hv_vec: "Hv(vec r) = Octo 0 r r r r r r r "
  by (simp add: Hv_def)

lemma hv_eq_zero [simp]: "Hv v = 0 \<longleftrightarrow> v = 0"
  by (simp add: octo_eq_iff vec_eq_iff) (metis exhaust_7)

lemma hv_zero [simp]: "Hv 0 = 0"
  by simp

lemma hv_vector [simp]: "Hv(vector[x,y,z,u,v,q,g]) = Octo 0 x y z u v q g"
  by (simp add: Hv_def)

lemma hv_basis:
  "Hv(axis 1 1) = e1" "Hv(axis 2 1) = e2" "Hv(axis 3 1) = e3"
  "Hv(axis 4 1) = e4" "Hv(axis 5 1) = e5" "Hv(axis 6 1) = e6"  "Hv(axis 7 1) = e7"
  by (simp_all add: octo_eq_iff)

lemma hv_add [simp]: "Hv(x + y) = Hv x + Hv y"
  by (simp add: Hv_def octo_eq_iff)

lemma hv_minus [simp]: "Hv(-x) = -Hv x"
  by (simp add: Hv_def octo_eq_iff)

lemma hv_diff [simp]: "Hv(x - y) = Hv x - Hv y"
  by (simp add: Hv_def octo_eq_iff)

lemma hv_cmult [simp]:
 "Hv(scaleR a   x) = scaleR a  ( Hv x)"
  by (simp add: Hv_def octo_eq_iff)

lemma hv_sum [simp]: "Hv (sum f S) = (\<Sum>x\<in>S. Hv (f x))"
  by (induct S rule: infinite_finite_induct) auto

lemma hv_inj: "Hv x = Hv y \<longleftrightarrow> x = y"
  by (simp add: Hv_def octo_eq_iff vec_eq_iff) (metis (full_types) exhaust_7)

lemma linear_hv: "linear Hv"
  using octo_of_real_def by (simp add: linearI)

lemma him_hv [simp]: "HIm(Hv x) = x"
  using HIm_def hv_inj octo_eq_iff by fastforce

lemma cnj_hv [simp]: "cnj(Hv v) = -Hv v"
  by (simp add: octo_eq_iff)

lemma hv_him: "Hv(HIm q) = Octo 0 (Im1 q) (Im2 q) (Im3 q)  (Im4 q) (Im5 q) (Im6 q)  (Im7 q)  "
  by (simp add: HIm_def)

lemma hv_him_eq: "Hv(HIm q) = q \<longleftrightarrow> Ree q = 0"
  by (simp add: hv_him octo_eq_iff)

lemma dot_hv [simp]: "Hv u \<bullet> Hv v = u \<bullet> v"
  by (simp add: Hv_def inner_octo_def inner_vec_def sum_7)

lemma norm_hv [simp]: "norm (Hv v) = norm v"
  by (simp add: norm_eq)

subsubsection\<open>Related basic identities \<close>

lemma mult_hv_eq_cross_dot: "Hv x * Hv y = Hv(x  \<times>\<^sub>7 y) - octo_of_real (inner x y)"
  by (simp add: octo_eq_iff inner_octo_def cross7_components octo_mult_components
                inner_vec_def sum_7)

lemma octonion_identity1_cross7 :
  "Hv (x \<times>\<^sub>7 y) = (1/2) *\<^sub>R (Hv x * Hv y - Hv y * Hv x)"
  by (simp add: octo_eq_iff octo_mult_components cross7_components)

lemma octonion_identity2_cross7:
  "Hv (x \<times>\<^sub>7 (y \<times>\<^sub>7 z) + y \<times>\<^sub>7 (z \<times>\<^sub>7 x) + z \<times>\<^sub>7 (x \<times>\<^sub>7 y)) =
     -(3/2) *\<^sub>R ((Hv x * Hv y) * Hv z - Hv x * (Hv y * Hv z))"
  unfolding octo_eq_iff octo_mult_components cross7_components Hv_sel scaleR_octo.sel
            vector_add_component minus_octo.sel mult_zero_left mult_zero_right add_0_left
            add_0_right diff_0 diff_0_right
  by algebra

subsection\<open> Representing orthogonal transformations as conjugation or congruence with an octonion.\<close>

lemma HIm_nth [simp]:
  "HIm x $ 1 = Im1 x" "HIm x $ 2 = Im2 x" "HIm x $ 3 = Im3 x"  "HIm x $ 4 = Im4 x"
  "HIm x $ 5 = Im5 x" "HIm x $ 6 = Im6 x" "HIm x $ 7 = Im7 x"
  by (simp_all add: HIm_def)

lemma orthogonal_transformation_octo_congruence:
  assumes "norm q = 1"
  shows "orthogonal_transformation (\<lambda>x. HIm(cnj q * Hv x * q))"
proof -
  have nq: "(Ree q)\<^sup>2 + (Im1 q)\<^sup>2 + (Im2 q)\<^sup>2 + (Im3 q)\<^sup>2 + (Im4 q)\<^sup>2 + (Im5 q)\<^sup>2 + (Im6 q)\<^sup>2 + (Im7 q)\<^sup>2 = 1"
    using assms norm_octo_def by auto
  have "Vector_Spaces.linear (*\<^sub>R) (*\<^sub>R) (\<lambda>x. HIm (Octonions.cnj q * Hv x * q))"
    by unfold_locales (simp_all add: octo_distrib_left octo_distrib_right
                                     octo_mult_scaleR_left octo_mult_scaleR_right)
  moreover have "HIm (Octonions.cnj q * Hv v * q) \<bullet> HIm (Octonions.cnj q * Hv w * q) =
                   ((Ree q)\<^sup>2 + (Im1 q)\<^sup>2 + (Im2 q)\<^sup>2 + (Im3 q)\<^sup>2+ (Im4 q)\<^sup>2 + (Im5 q)\<^sup>2 + (Im6 q)\<^sup>2 +
                   (Im7 q)\<^sup>2)^2 * (v \<bullet> w)" for v w
    unfolding octo_mult_components cnj.sel Hv_sel inner_vec_def sum_7 HIm_nth inner_real_def
    by algebra
  ultimately show ?thesis
    by (simp add: orthogonal_transformation_def linear_def nq)
qed

lemma orthogonal_transformation_octo_conjugation:
  assumes "q \<noteq> 0"
  shows "orthogonal_transformation (\<lambda>x. HIm (inverse q * Hv x * q))"
proof -
  obtain c d where eq: "q = octo_of_real c * d" and 1: "norm d = 1"
  proof
    show 1: "q = octo_of_real (norm q) * (inverse (octo_of_real (norm q)) * q)"
      using assms norm_eq_zero right_inverse multiplicative_norm_octo
      by (metis Octonions.scaleR_conv_octo_of_real octo_of_real_inverse scaleR_one scaleR_scaleR)
    show "norm (inverse (octo_of_real (norm q)) * q) = 1"
      using assms 1  norm_octo_def norm_mult inverse_octo_1 inverse_octo_1_sym
      nonzero_octo_of_real_inverse  octo_inverse_eq_cnj
      cnj_of_real mult_cancel_left2 multiplicative_norm_octo
      norm_eq_zero norm_octo_squared norm_power2_cnj octo_mult_cnj_conv_norm power2_eq_square_octo
      by metis
   qed
  have "c \<noteq> 0"
    using assms eq by (metis Octonions.scaleR_conv_octo_of_real scale_zero_left)

  then have "HIm (Octonions.cnj d * Hv x * d) =
               HIm (inverse (octo_of_real c * d) * Hv x * (octo_of_real c * d))" for x
  proof(simp add: flip: octo_inverse_eq_cnj [OF 1] of_real_inverse)
    assume "c \<noteq> 0"
    then have "inverse d = inverse d * inverse (c *\<^sub>R 1) * c *\<^sub>R 1"
      using octo_of_real_def octo_of_real_inverse octo_of_real_inverse_collapse(1)
            octo_of_real_times_commute octo_of_real_times_left_commute by force
    then have "inverse d * Hv x * d = inverse (c *\<^sub>R 1 * d) * Hv x * c *\<^sub>R (d * 1)"
      by (metis (no_types) mult_1_right_octo octo_inverse_mult octo_mult_scaleR_left
                           octo_mult_scaleR_right)
    then show
      "HIm (inverse d * Hv x * d) = HIm (inverse (octo_of_real c * d) * Hv x * (octo_of_real c * d))"
      using octo_mult_scaleR_right octo_of_real_def octo_of_real_times_commute by presburger
  qed

  then show ?thesis
    using orthogonal_transformation_octo_congruence [OF 1]
    by (simp add: eq)
qed

unbundle no_cross7_syntax

bundle octonion_syntax
begin

notation octo_e0 ("e0")
notation octo_e1 ("e1")
notation octo_e2 ("e2")
notation octo_e3 ("e3")
notation octo_e4 ("e4")
notation octo_e5 ("e5")
notation octo_e6 ("e6")
notation octo_e7 ("e7")

end

bundle no_octonion_syntax
begin

no_notation octo_e0 ("e0")
no_notation octo_e1 ("e1")
no_notation octo_e2 ("e2")
no_notation octo_e3 ("e3")
no_notation octo_e4 ("e4")
no_notation octo_e5 ("e5")
no_notation octo_e6 ("e6")
no_notation octo_e7 ("e7")

end

unbundle no_octonion_syntax
hide_const (open) Octonions.cnj

end


(*  Title:      HOL/Induct/PropLog.thy
    Author:     Tobias Nipkow
    Copyright   1994  TU Muenchen & University of Cambridge
*)

section \<open>Meta-theory of propositional logic\<close>

theory PropLog imports MainRLT begin

text \<open>
  Datatype definition of propositional logic formulae and inductive
  definition of the propositional tautologies.

  Inductive definition of propositional logic.  Soundness and
  completeness w.r.t.\ truth-tables.

  Prove: If \<open>H |= p\<close> then \<open>G |= p\<close> where \<open>G \<in>
  Fin(H)\<close>
\<close>

subsection \<open>The datatype of propositions\<close>

datatype 'a pl =
  false |
  var 'a ("#_" [1000]) |
  imp "'a pl" "'a pl" (infixr "->" 90)

subsection \<open>The proof system\<close>

inductive thms :: "['a pl set, 'a pl] => bool"  (infixl "|-" 50)
  for H :: "'a pl set"
where
  H: "p\<in>H ==> H |- p"
| K: "H |- p->q->p"
| S: "H |- (p->q->r) -> (p->q) -> p->r"
| DN: "H |- ((p->false) -> false) -> p"
| MP: "[| H |- p->q; H |- p |] ==> H |- q"

subsection \<open>The semantics\<close>

subsubsection \<open>Semantics of propositional logic.\<close>

primrec eval :: "['a set, 'a pl] => bool"  ("_[[_]]" [100,0] 100)
where
  "tt[[false]] = False"
| "tt[[#v]] = (v \<in> tt)"
| eval_imp: "tt[[p->q]] = (tt[[p]] --> tt[[q]])"

text \<open>
  A finite set of hypotheses from \<open>t\<close> and the \<open>Var\<close>s in
  \<open>p\<close>.
\<close>

primrec hyps :: "['a pl, 'a set] => 'a pl set"
where
  "hyps false  tt = {}"
| "hyps (#v)   tt = {if v \<in> tt then #v else #v->false}"
| "hyps (p->q) tt = hyps p tt Un hyps q tt"

subsubsection \<open>Logical consequence\<close>

text \<open>
  For every valuation, if all elements of \<open>H\<close> are true then so
  is \<open>p\<close>.
\<close>

definition sat :: "['a pl set, 'a pl] => bool"  (infixl "|=" 50)
  where "H |= p = (\<forall>tt. (\<forall>q\<in>H. tt[[q]]) --> tt[[p]])"

subsection \<open>Proof theory of propositional logic\<close>

lemma thms_mono: "G<=H ==> thms(G) <= thms(H)"
apply (rule predicate1I)
apply (erule thms.induct)
apply (auto intro: thms.intros)
done

lemma thms_I: "H |- p->p"
  \<comment> \<open>Called \<open>I\<close> for Identity Combinator, not for Introduction.\<close>
by (best intro: thms.K thms.S thms.MP)

subsubsection \<open>Weakening, left and right\<close>

lemma weaken_left: "[| G \<subseteq> H;  G|-p |] ==> H|-p"
  \<comment> \<open>Order of premises is convenient with \<open>THEN\<close>\<close>
  by (erule thms_mono [THEN predicate1D])

lemma weaken_left_insert: "G |- p \<Longrightarrow> insert a G |- p"
by (rule weaken_left) (rule subset_insertI)

lemma weaken_left_Un1: "G |- p \<Longrightarrow> G \<union> B |- p"
by (rule weaken_left) (rule Un_upper1)

lemma weaken_left_Un2: "G |- p \<Longrightarrow> A \<union> G |- p"
by (rule weaken_left) (rule Un_upper2)

lemma weaken_right: "H |- q ==> H |- p->q"
by (fast intro: thms.K thms.MP)

subsubsection \<open>The deduction theorem\<close>

theorem deduction: "insert p H |- q  ==>  H |- p->q"
apply (induct set: thms)
apply (fast intro: thms_I thms.H thms.K thms.S thms.DN
                   thms.S [THEN thms.MP, THEN thms.MP] weaken_right)+
done

subsubsection \<open>The cut rule\<close>

lemma cut: "insert p H |- q \<Longrightarrow> H |- p \<Longrightarrow> H |- q"
by (rule thms.MP) (rule deduction)

lemma thms_falseE: "H |- false \<Longrightarrow> H |- q"
by (rule thms.MP, rule thms.DN) (rule weaken_right)

lemma thms_notE: "H |- p -> false \<Longrightarrow> H |- p \<Longrightarrow> H |- q"
by (rule thms_falseE) (rule thms.MP)

subsubsection \<open>Soundness of the rules wrt truth-table semantics\<close>

theorem soundness: "H |- p ==> H |= p"
by (induct set: thms) (auto simp: sat_def)

subsection \<open>Completeness\<close>

subsubsection \<open>Towards the completeness proof\<close>

lemma false_imp: "H |- p->false ==> H |- p->q"
apply (rule deduction)
apply (metis H insert_iff weaken_left_insert thms_notE)
done

lemma imp_false:
    "[| H |- p;  H |- q->false |] ==> H |- (p->q)->false"
apply (rule deduction)
apply (metis H MP insert_iff weaken_left_insert)
done

lemma hyps_thms_if: "hyps p tt |- (if tt[[p]] then p else p->false)"
  \<comment> \<open>Typical example of strengthening the induction statement.\<close>
apply simp
apply (induct p)
apply (simp_all add: thms_I thms.H)
apply (blast intro: weaken_left_Un1 weaken_left_Un2 weaken_right
                    imp_false false_imp)
done

lemma sat_thms_p: "{} |= p ==> hyps p tt |- p"
  \<comment> \<open>Key lemma for completeness; yields a set of assumptions
        satisfying \<open>p\<close>\<close>
unfolding sat_def
by (metis (full_types) empty_iff hyps_thms_if)

text \<open>
  For proving certain theorems in our new propositional logic.
\<close>

declare deduction [intro!]
declare thms.H [THEN thms.MP, intro]

text \<open>
  The excluded middle in the form of an elimination rule.
\<close>

lemma thms_excluded_middle: "H |- (p->q) -> ((p->false)->q) -> q"
apply (rule deduction [THEN deduction])
apply (rule thms.DN [THEN thms.MP], best intro: H)
done

lemma thms_excluded_middle_rule:
    "[| insert p H |- q;  insert (p->false) H |- q |] ==> H |- q"
  \<comment> \<open>Hard to prove directly because it requires cuts\<close>
by (rule thms_excluded_middle [THEN thms.MP, THEN thms.MP], auto)

subsection\<open>Completeness -- lemmas for reducing the set of assumptions\<close>

text \<open>
  For the case \<^prop>\<open>hyps p t - insert #v Y |- p\<close> we also have \<^prop>\<open>hyps p t - {#v} \<subseteq> hyps p (t-{v})\<close>.
\<close>

lemma hyps_Diff: "hyps p (t-{v}) <= insert (#v->false) ((hyps p t)-{#v})"
by (induct p) auto

text \<open>
  For the case \<^prop>\<open>hyps p t - insert (#v -> Fls) Y |- p\<close> we also have
  \<^prop>\<open>hyps p t-{#v->Fls} \<subseteq> hyps p (insert v t)\<close>.
\<close>

lemma hyps_insert: "hyps p (insert v t) <= insert (#v) (hyps p t-{#v->false})"
by (induct p) auto

text \<open>Two lemmas for use with \<open>weaken_left\<close>\<close>

lemma insert_Diff_same: "B-C <= insert a (B-insert a C)"
by fast

lemma insert_Diff_subset2: "insert a (B-{c}) - D <= insert a (B-insert c D)"
by fast

text \<open>
  The set \<^term>\<open>hyps p t\<close> is finite, and elements have the form
  \<^term>\<open>#v\<close> or \<^term>\<open>#v->Fls\<close>.
\<close>

lemma hyps_finite: "finite(hyps p t)"
by (induct p) auto

lemma hyps_subset: "hyps p t <= (UN v. {#v, #v->false})"
by (induct p) auto

lemma Diff_weaken_left: "A \<subseteq> C \<Longrightarrow> A - B |- p \<Longrightarrow> C - B |- p"
  by (rule Diff_mono [OF _ subset_refl, THEN weaken_left])

subsubsection \<open>Completeness theorem\<close>

text \<open>
  Induction on the finite set of assumptions \<^term>\<open>hyps p t0\<close>.  We
  may repeatedly subtract assumptions until none are left!
\<close>

lemma completeness_0_lemma:
    "{} |= p ==> \<forall>t. hyps p t - hyps p t0 |- p"
apply (rule hyps_subset [THEN hyps_finite [THEN finite_subset_induct]])
 apply (simp add: sat_thms_p, safe)
 txt\<open>Case \<open>hyps p t-insert(#v,Y) |- p\<close>\<close>
 apply (iprover intro: thms_excluded_middle_rule
                     insert_Diff_same [THEN weaken_left]
                     insert_Diff_subset2 [THEN weaken_left]
                     hyps_Diff [THEN Diff_weaken_left])
txt\<open>Case \<open>hyps p t-insert(#v -> false,Y) |- p\<close>\<close>
 apply (iprover intro: thms_excluded_middle_rule
                     insert_Diff_same [THEN weaken_left]
                     insert_Diff_subset2 [THEN weaken_left]
                     hyps_insert [THEN Diff_weaken_left])
done

text\<open>The base case for completeness\<close>
lemma completeness_0:  "{} |= p ==> {} |- p"
  by (metis Diff_cancel completeness_0_lemma)

text\<open>A semantic analogue of the Deduction Theorem\<close>
lemma sat_imp: "insert p H |= q ==> H |= p->q"
by (auto simp: sat_def)

theorem completeness: "finite H ==> H |= p ==> H |- p"
apply (induct arbitrary: p rule: finite_induct)
 apply (blast intro: completeness_0)
apply (iprover intro: sat_imp thms.H insertI1 weaken_left_insert [THEN thms.MP])
done

theorem syntax_iff_semantics: "finite H ==> (H |- p) = (H |= p)"
by (blast intro: soundness completeness)

end


(*
  Goal verification framework
  - Logic
*)

\<comment> \<open>This theory sets up syntax, semantics and a sequent for classical logic with no quantifiers.
    The type for an extension is arbitrary to allow reuse in different logic languages to be defined.\<close>

theory Gvf_Logic imports Main begin

section \<open>Syntax\<close>

\<comment> \<open>The usual infix operators are in bold to avoid conflict with Isabelle's built-in operators.\<close>
datatype 'a \<Phi>\<^sub>P = Atom (the_atom: 'a) | F (\<open>\<^bold>\<bottom>\<close>) | Negation \<open>'a \<Phi>\<^sub>P\<close> (\<open>\<^bold>\<not>\<close>) |
                 Implication \<open>'a \<Phi>\<^sub>P\<close> \<open>'a \<Phi>\<^sub>P\<close> (infixr \<open>\<^bold>\<longrightarrow>\<close> 60) |
                 Disjunction \<open>'a \<Phi>\<^sub>P\<close> \<open>'a \<Phi>\<^sub>P\<close> (infixl \<open>\<^bold>\<or>\<close> 70) |
                 Conjunction \<open>'a \<Phi>\<^sub>P\<close> \<open>'a \<Phi>\<^sub>P\<close> (infixl \<open>\<^bold>\<and>\<close> 80)
\<comment> \<open>'a is a type variable for the type of the extension.
    An element of this type is parsed to the constructor for Atom.
    The Boolean operators take one (or two) formula(s) as input (parsing on the type variable).\<close>

\<comment> \<open>Define a type for propositional logic formulas using string symbols.\<close>
type_synonym \<Phi>\<^sub>L = \<open>string \<Phi>\<^sub>P\<close>

\<comment> \<open>Bi-implication is defined from conjunction and implication.\<close>
abbreviation Equiv\<^sub>P :: \<open>'a \<Phi>\<^sub>P \<Rightarrow> 'a \<Phi>\<^sub>P \<Rightarrow> 'a \<Phi>\<^sub>P\<close> (infix \<open>\<^bold>\<longleftrightarrow>\<close> 60) where
  \<open>P \<^bold>\<longleftrightarrow> Q \<equiv> (P \<^bold>\<longrightarrow> Q) \<^bold>\<and> (Q \<^bold>\<longrightarrow> P)\<close>

abbreviation Truth\<^sub>L :: \<open>'a \<Phi>\<^sub>P\<close> (\<open>\<^bold>\<top>\<close>)
  where \<open>\<^bold>\<top> \<equiv> \<^bold>\<not> \<^bold>\<bottom>\<close>

\<comment> \<open>Example.\<close>
value \<open>P \<^bold>\<longrightarrow> (P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> Q\<close>

section \<open>Semantics\<close>

\<comment> \<open>The semantics function takes an interpretation and a formula and returns a Boolean.\<close>
primrec semantics\<^sub>P :: \<open>('a \<Rightarrow> bool) \<Rightarrow> 'a \<Phi>\<^sub>P \<Rightarrow> bool\<close> where
  \<open>semantics\<^sub>P f (Atom x) = f x\<close> |
  \<open>semantics\<^sub>P f \<^bold>\<bottom> = False\<close> |
  \<open>semantics\<^sub>P f (\<^bold>\<not> p) = (\<not>semantics\<^sub>P f p)\<close> |
  \<open>semantics\<^sub>P f (p \<^bold>\<longrightarrow> q) = (semantics\<^sub>P f p \<longrightarrow> semantics\<^sub>P f q)\<close> |
  \<open>semantics\<^sub>P f (p \<^bold>\<or> q) = (semantics\<^sub>P f p \<or> semantics\<^sub>P f q)\<close> |
  \<open>semantics\<^sub>P f (p \<^bold>\<and> q) = (semantics\<^sub>P f p \<and> semantics\<^sub>P f q)\<close>
\<comment> \<open>The interpretation f is a function from elements of type 'a to Booleans.
    In the case of Atom the value is looked up and returned.
    In case of a Boolean operator, we can exploit Isabelle's built-in operators.
    This could also be achieved by proper coding of if-then structures.\<close>

\<comment> \<open>Example (holds for any f, P and Q).\<close>
lemma \<open>semantics\<^sub>P f (P \<^bold>\<longrightarrow> (P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> Q)\<close> by simp

\<comment> \<open>Entailment.\<close>
abbreviation entails :: \<open>'a \<Phi>\<^sub>P list \<Rightarrow> 'a \<Phi>\<^sub>P list \<Rightarrow> bool\<close> (infix \<open>\<Turnstile>\<^sub>P#\<close> 50) where
  \<open>\<Gamma> \<Turnstile>\<^sub>P# \<Delta> \<equiv> (\<forall>f. (\<forall>p\<in>set \<Gamma>. semantics\<^sub>P f p) \<longrightarrow> (\<exists>p\<in>set \<Delta>. semantics\<^sub>P f p))\<close>
\<comment> \<open>L entails R if, for all interpretations, all formulas in L true implies at least one in R true.\<close>

\<comment> \<open>Example.\<close>
lemma \<open>[ P ] \<Turnstile>\<^sub>P# [ P, Q ]\<close> by simp

\<comment> \<open>Entailment for a singleton on rhs.\<close>
abbreviation entails_singleton :: \<open>'a \<Phi>\<^sub>P list \<Rightarrow> 'a \<Phi>\<^sub>P \<Rightarrow> bool\<close> (infix \<open>\<^bold>\<Turnstile>\<^sub>P\<close> 50) where
  \<open>\<Gamma> \<^bold>\<Turnstile>\<^sub>P \<Phi> \<equiv> (\<forall>f. (\<forall>p\<in>set \<Gamma>. semantics\<^sub>P f p) \<longrightarrow> semantics\<^sub>P f \<Phi>)\<close>

abbreviation entails_all_singleton :: \<open>'a \<Phi>\<^sub>P \<Rightarrow> bool\<close> (\<open>\<Turnstile>\<^sub>P\<close>) where
  \<open>\<Turnstile>\<^sub>P \<Phi> \<equiv> (\<forall>f. semantics\<^sub>P f \<Phi>)\<close>

\<comment> \<open>Not derive contradiction\<close>
lemma not_contradict: \<open>\<exists>f. \<forall>p\<in>set P. semantics\<^sub>P f p \<Longrightarrow> \<not> P \<^bold>\<Turnstile>\<^sub>P \<^bold>\<bottom>\<close> by simp

\<comment> \<open>Example.\<close>
lemma \<open>[ P \<^bold>\<and> Q ] \<^bold>\<Turnstile>\<^sub>P P\<close> by simp

\<comment> \<open>Example.\<close>
lemma \<open>Q \<noteq> P \<longrightarrow> \<not> [ Atom Q ] \<^bold>\<Turnstile>\<^sub>P Atom P\<close> by auto

\<comment> \<open>Weakening of assumptions for entailment\<close>
lemma weakening_entailment: \<open>set \<Sigma>' \<subseteq> set \<Sigma> \<longrightarrow> \<Sigma>' \<Turnstile>\<^sub>P# \<Gamma> \<longrightarrow> \<Sigma> \<Turnstile>\<^sub>P# \<Gamma>\<close> by blast

\<comment> \<open>Example.\<close>
lemma \<open>[ P\<^sub>1, P\<^sub>2 ] \<Turnstile>\<^sub>P# [ Q ] \<longrightarrow> [ P\<^sub>1, P\<^sub>2, P\<^sub>3 ] \<Turnstile>\<^sub>P# [ Q ]\<close> using weakening_entailment by simp

section \<open>Sequent calculus\<close>

abbreviation append_new :: \<open>'a list \<Rightarrow> 'a list \<Rightarrow> 'a list\<close> where
  \<open>append_new L R \<equiv> L @ (filter (\<lambda>x. x \<notin> set L) R)\<close>

type_synonym 'a gen_rules = \<open>'a \<Phi>\<^sub>P list \<Rightarrow> 'a \<Phi>\<^sub>P list \<Rightarrow> bool\<close>

\<comment> \<open>Generic sequent calculus proof system.\<close>
inductive gen_sc :: \<open>'a gen_rules option \<Rightarrow> 'a \<Phi>\<^sub>P list \<Rightarrow> 'a \<Phi>\<^sub>P list \<Rightarrow> bool\<close> where
  \<comment> \<open>Base axiom\<close>
  Axiom:  \<open>p \<in> set \<Gamma> \<Longrightarrow> p \<in> set \<Delta> \<Longrightarrow> gen_sc R \<Gamma> \<Delta>\<close> |
  \<comment> \<open>Logical non-branching\<close>
  L_Neg:  \<open>gen_sc R \<Gamma> (p # \<Delta>) \<Longrightarrow> gen_sc R ((\<^bold>\<not> p) # \<Gamma>) \<Delta>\<close> |
  R_Neg:  \<open>gen_sc R (p # \<Gamma>) \<Delta> \<Longrightarrow> gen_sc R \<Gamma> ((\<^bold>\<not> p) # \<Delta>)\<close> |
  R_Imp:  \<open>gen_sc R (p # \<Gamma>) (q # \<Delta>) \<Longrightarrow> gen_sc R \<Gamma> ((p \<^bold>\<longrightarrow> q) # \<Delta>)\<close> |
  R_Or:   \<open>gen_sc R \<Gamma> (p # q # \<Delta>) \<Longrightarrow> gen_sc R \<Gamma> ((p \<^bold>\<or> q) # \<Delta>)\<close> |
  L_And:  \<open>gen_sc R (p # q # \<Gamma>) \<Delta> \<Longrightarrow> gen_sc R ((p \<^bold>\<and> q) # \<Gamma>) \<Delta>\<close> |
  \<comment> \<open>Logical branching\<close>
  R_And:  \<open>gen_sc R \<Gamma> (p # \<Delta>) \<Longrightarrow> gen_sc R \<Gamma> (q # \<Delta>) \<Longrightarrow> gen_sc R \<Gamma> ((p \<^bold>\<and> q) # \<Delta>)\<close> |
  L_Or:   \<open>gen_sc R (p # \<Gamma>) \<Delta> \<Longrightarrow> gen_sc R (q # \<Gamma>) \<Delta> \<Longrightarrow> gen_sc R ((p \<^bold>\<or> q) # \<Gamma>) \<Delta>\<close> |
  L_Imp:  \<open>gen_sc R \<Gamma> (p # \<Delta>) \<Longrightarrow> gen_sc R (q # \<Gamma>) \<Delta> \<Longrightarrow> gen_sc R ((p \<^bold>\<longrightarrow> q) # \<Gamma>) \<Delta>\<close> |
  \<comment> \<open>Cut\<close>
  Cut:    \<open>gen_sc R \<Gamma> (p # \<Delta>) \<Longrightarrow> gen_sc R (p # \<Sigma>) \<Pi> \<Longrightarrow> gen_sc R (append_new \<Gamma> \<Sigma>) (append_new \<Delta> \<Pi>)\<close> |
  \<comment> \<open>Weakening\<close>
  L_W:    \<open>gen_sc R \<Gamma> \<Delta> \<Longrightarrow> gen_sc R (\<Sigma> @ \<Gamma>) \<Delta>\<close> |
  R_W:    \<open>gen_sc R \<Gamma> \<Delta> \<Longrightarrow> gen_sc R \<Gamma> (\<Pi> @ \<Delta>)\<close> |
  \<comment> \<open>Shift\<close>
  L_Shift: \<open>gen_sc R (rotate1 \<Gamma>) \<Delta> \<Longrightarrow> gen_sc R \<Gamma> \<Delta>\<close> |
  R_Shift: \<open>gen_sc R \<Gamma> (rotate1 \<Delta>) \<Longrightarrow> gen_sc R \<Gamma> \<Delta>\<close> |
  \<comment> \<open>Generic\<close>
  Gen:    \<open>R \<noteq> None \<Longrightarrow> the R \<Gamma> \<Delta> \<Longrightarrow> gen_sc R \<Gamma> \<Delta>\<close>

lemma weakening_h:
  assumes \<open>gen_sc R \<Gamma> \<Delta>\<close>
  shows \<open>gen_sc R (p # \<Gamma>) \<Delta>\<close> \<open>gen_sc R \<Gamma> (p # \<Delta>)\<close>
proof -
  from L_W have \<open>gen_sc R ([p] @ \<Gamma>) \<Delta>\<close> using assms by blast
  then show \<open>gen_sc R (p # \<Gamma>) \<Delta>\<close> by simp
  from R_W have \<open>gen_sc R \<Gamma> ([p] @ \<Delta>)\<close> using assms by blast
  then show \<open>gen_sc R \<Gamma> (p # \<Delta>)\<close> by simp
qed

lemma gen_sc_None: \<open>gen_sc R \<Gamma> \<Delta> \<Longrightarrow> R = None \<Longrightarrow> gen_sc R' \<Gamma> \<Delta>\<close>
proof (induct rule: gen_sc.induct)
  case (Axiom R \<Gamma> p \<Delta>)
  with gen_sc.Axiom show ?case by auto
next
  case (L_Neg R \<Gamma> \<Delta> p)
  with gen_sc.L_Neg show ?case by simp
next
  case (R_Neg R \<Gamma> p \<Delta>)
  with gen_sc.R_Neg show ?case by simp
next
  case (R_Imp R \<Gamma> p \<Delta> q)
  with gen_sc.R_Imp show ?case by simp
next
  case (R_Or R \<Gamma> \<Delta> p q)
  with gen_sc.R_Or show ?case by simp
next
  case (L_And R \<Gamma> p q \<Delta>)
  with gen_sc.L_And show ?case by simp
next
  case (R_And R \<Gamma> \<Delta> p q)
  with gen_sc.R_And show ?case by simp
next
  case (L_Or R \<Gamma> p \<Delta> q)
  with gen_sc.L_Or show ?case by simp
next
  case (L_Imp R \<Gamma> \<Delta> p q)
  with gen_sc.L_Imp show ?case by simp
next
  case (Cut R \<Gamma> p \<Delta> \<Sigma> \<Pi>)
  with gen_sc.Cut show ?case by simp
next
  case (L_W R \<Gamma> \<Delta> \<Sigma>)
  with gen_sc.L_W show ?case by simp
next
  case (R_W R \<Gamma> \<Delta> \<Pi>)
  with gen_sc.R_W show ?case by simp
next
  case (Gen r \<Gamma> \<Delta>)
  with gen_sc.Gen show ?case by simp
next
  case (L_Shift R \<Gamma> \<Delta>)
  with gen_sc.L_Shift show ?case by simp
next
  case (R_Shift R \<Gamma> \<Delta>)
  with gen_sc.R_Shift show ?case by simp
qed

abbreviation sequent_calculus :: \<open>'a \<Phi>\<^sub>P list \<Rightarrow> 'a \<Phi>\<^sub>P list \<Rightarrow> bool\<close> (infix \<open>\<turnstile>\<^sub>P#\<close> 40) where
  \<open>\<Gamma> \<turnstile>\<^sub>P# \<Delta> \<equiv> gen_sc None \<Gamma> \<Delta>\<close>

\<comment> \<open>Example.\<close>
lemma \<open>[ P \<^bold>\<and> Q ] \<turnstile>\<^sub>P# [ P ]\<close>
proof -
  from Axiom[where p=P] have \<open>[ P, Q ] \<turnstile>\<^sub>P# [ P ]\<close> by simp
  then show ?thesis using L_And by force
qed

\<comment> \<open>Notation for empty lhs and singleton rhs.\<close>
abbreviation provable :: \<open>'a \<Phi>\<^sub>P \<Rightarrow> bool\<close> (\<open>\<turnstile>\<^sub>P _\<close> 40) where
  \<open>\<turnstile>\<^sub>P p \<equiv> [] \<turnstile>\<^sub>P# [ p ]\<close>

\<comment> \<open>Modus ponens\<close>
lemma gen_sc_mp: \<open>gen_sc R \<Gamma> [ p \<^bold>\<longrightarrow> q ] \<Longrightarrow> gen_sc R \<Gamma> [ p ] \<Longrightarrow> gen_sc R \<Gamma> [ q ]\<close>
proof -
  assume \<open>gen_sc R \<Gamma> [ p \<^bold>\<longrightarrow> q ]\<close>
  moreover assume \<open>gen_sc R \<Gamma> [ p ]\<close>
  with weakening_h(2) have \<open>gen_sc R \<Gamma> [q, p]\<close> by auto
  with R_Shift have \<open>gen_sc R \<Gamma> [p, q]\<close> by force
  from Axiom[where p=q] have \<open>gen_sc R (q # \<Gamma>) [ q ]\<close> by simp
  with \<open>gen_sc R \<Gamma> [p, q]\<close> have \<open>gen_sc R ((p \<^bold>\<longrightarrow> q) # \<Gamma>) [ q ]\<close> using L_Imp by blast
  ultimately show \<open>gen_sc R \<Gamma> [ q ]\<close> using Cut by fastforce
qed

\<comment> \<open>Example single-step.\<close>
lemma \<open>\<turnstile>\<^sub>P P \<^bold>\<longrightarrow> (P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> Q\<close>
proof -
  from R_Imp have \<open>[] \<turnstile>\<^sub>P# [ P \<^bold>\<longrightarrow> (P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> Q ]\<close>
    if \<open>[ P ] \<turnstile>\<^sub>P# [ (P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> Q ]\<close> using that by blast
  with R_Imp have ?thesis
    if \<open>[ P \<^bold>\<longrightarrow> Q, P ] \<turnstile>\<^sub>P# [ Q ]\<close> using that by fastforce
  with L_Imp have ?thesis
    if  \<open>[ P ] \<turnstile>\<^sub>P# [ P, Q ]\<close>
    and \<open>[ Q, P ] \<turnstile>\<^sub>P# [ Q ]\<close> using that by fastforce
  moreover have \<open>[ P ] \<turnstile>\<^sub>P# [ P, Q ]\<close> using Axiom[where p=P] by simp
  moreover have \<open>([ Q, P ]) \<turnstile>\<^sub>P# [ Q ]\<close> using Axiom[where p=Q] by simp
  ultimately show ?thesis by simp
qed
\<comment> \<open>The hassle of manually proving even simple formulas calls for an implementation of proof tactics.
    The deep embedding of the logic means that trivial formulas cannot be proved using Isabelle's
    vast knowledge about logic formulas, however I am not sure if there is a good way around this.\<close>

section \<open>Misc.\<close>

lemma neg_imp: \<open>\<turnstile>\<^sub>P (p \<^bold>\<longrightarrow> \<^bold>\<not> q) \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> \<^bold>\<not> p\<close>
proof -
  from R_Imp have ?thesis
    if \<open>[ p \<^bold>\<longrightarrow> \<^bold>\<not> q ] \<turnstile>\<^sub>P# [ q \<^bold>\<longrightarrow> \<^bold>\<not> p ]\<close> using that by blast
  with R_Imp have ?thesis
    if \<open>[ q, p \<^bold>\<longrightarrow> \<^bold>\<not> q ] \<turnstile>\<^sub>P# [ \<^bold>\<not> p ]\<close> using that by blast
  with R_Neg have ?thesis
    if \<open>[ p, q, p \<^bold>\<longrightarrow> \<^bold>\<not> q ] \<turnstile>\<^sub>P# []\<close> using that by fastforce
  moreover have \<open>rotate1 (rotate1 [ p, q, p \<^bold>\<longrightarrow> \<^bold>\<not> q ]) = [ p \<^bold>\<longrightarrow> \<^bold>\<not> q, p, q ]\<close> by simp
  ultimately have ?thesis
    if \<open>[ p \<^bold>\<longrightarrow> \<^bold>\<not> q, p, q ] \<turnstile>\<^sub>P# []\<close> using that L_Shift by metis
  with L_Imp have ?thesis
    if \<open>[ p, q ] \<turnstile>\<^sub>P# [ p ]\<close> and \<open>[ \<^bold>\<not> q, p, q ] \<turnstile>\<^sub>P# []\<close> using that by blast
  with L_Neg have ?thesis
    if \<open>[ p, q ] \<turnstile>\<^sub>P# [ p ]\<close> and \<open>[ p, q ] \<turnstile>\<^sub>P# [ q ]\<close> using that by blast
  with Axiom[where p=p] Axiom[where p=q] show ?thesis by simp
qed

\<comment> \<open>Proofs about the formulas that are not entailed are in general harder, so the idea is to collect
    a number of proofs in a small library as we encounter the need to complete such proofs.\<close>
lemma neq_ext_not_entail:
  assumes \<open>x \<noteq> y\<close>
  shows   \<open>\<not> [ Atom x ] \<^bold>\<Turnstile>\<^sub>P Atom y\<close>
  using assms by auto

fun distinct_ground_atoms_aux :: \<open>'a \<Phi>\<^sub>P list \<Rightarrow> 'a list \<Rightarrow> bool\<close> where
  \<open>distinct_ground_atoms_aux (Atom p # L) P = distinct_ground_atoms_aux L (p#P)\<close> |
  \<open>distinct_ground_atoms_aux (\<^bold>\<not> (Atom p) # L) P = (p \<notin> set P \<and> distinct_ground_atoms_aux L P)\<close> |
  \<open>distinct_ground_atoms_aux _ _ = False\<close>

fun distinct_ground_atoms :: \<open>'a \<Phi>\<^sub>P list \<Rightarrow> bool\<close> where
  \<open>distinct_ground_atoms L = distinct_ground_atoms_aux L []\<close>

section \<open>Soundness\<close>

\<comment> \<open>Proving the formula implies that it is valid. Because the sequent calculus is based on the use
    of multisets, whereas the semantics is based on regular sets, a conversion is required.
    In general going from multisets to sets is more clean due to the former always being finite.\<close>

\<comment> \<open>The soundness theorem.\<close>
lemma soundness\<^sub>P': \<open>gen_sc R \<Gamma> \<Delta> \<Longrightarrow> R = None \<Longrightarrow> \<Gamma> \<Turnstile>\<^sub>P# \<Delta>\<close>
proof (induct rule: gen_sc.induct)
  case (Cut R \<Gamma> \<Delta> p \<Sigma> \<Pi>)
  then show ?case by fastforce
qed auto

theorem soundness\<^sub>P: \<open>\<Gamma> \<turnstile>\<^sub>P# \<Delta> \<Longrightarrow> \<Gamma> \<Turnstile>\<^sub>P# \<Delta>\<close>
  using soundness\<^sub>P' by blast

end


theory T20
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


(*  Title:      HOL/Isar_Examples/Drinker.thy
    Author:     Makarius
*)

section \<open>The Drinker's Principle\<close>

theory Drinker
imports Main
begin

text \<open>Here is another example of classical reasoning: the Drinker's
  Principle says that for some person, if he is drunk, everybody else
  is drunk!

  We first prove a classical part of de-Morgan's law.\<close>

lemma de_Morgan:
  assumes "\<not> (\<forall>x. P x)"
  shows "\<exists>x. \<not> P x"
proof (rule classical)
  assume "\<not> (\<exists>x. \<not> P x)"
  have "\<forall>x. P x"
  proof
    fix x show "P x"
    proof (rule classical)
      assume "\<not> P x"
      then have "\<exists>x. \<not> P x" ..
      with \<open>\<not> (\<exists>x. \<not> P x)\<close> show ?thesis by contradiction
    qed
  qed
  with \<open>\<not> (\<forall>x. P x)\<close> show ?thesis by contradiction
qed

theorem Drinker's_Principle: "\<exists>x. drunk x \<longrightarrow> (\<forall>x. drunk x)"
proof cases
  fix a assume "\<forall>x. drunk x"
  then have "drunk a \<longrightarrow> (\<forall>x. drunk x)" ..
  then show ?thesis ..
next
  assume "\<not> (\<forall>x. drunk x)"
  then have "\<exists>x. \<not> drunk x" by (rule de_Morgan)
  then obtain a where a: "\<not> drunk a" ..
  have "drunk a \<longrightarrow> (\<forall>x. drunk x)"
  proof
    assume "drunk a"
    with a show "\<forall>x. drunk x" by contradiction
  qed
  then show ?thesis ..
qed

end


theory Submission
  imports Defs
begin

lemma setcompr_eq_image2:
  "{f x y | x y. P x y} = (\<lambda>(x, y). f x y) ` {(x, y). P x y}" for f
  using setcompr_eq_image[where f = "(\<lambda>(x, y). f x y)" and P = "\<lambda>(x, y). P x y"] by simp

lemma finite_aux1:
  "finite {(x, y). x \<le> y \<and> y < (n :: nat)}"
  by (rule finite_subset[where B = "{(x, y). x < n \<and> y < (n :: nat)}"]) auto

context
  fixes a :: "nat \<Rightarrow> int" \<comment> \<open>The input array\<close>
  fixes n :: nat \<comment> \<open>The length of @{term a}\<close>
  assumes n_gt_0: "n > 0"
begin

definition max_sum_subseq where
  "max_sum_subseq = Max {\<Sum>k=i..j. a k | i j. i \<le> j \<and> j < n}"

definition sum_upto where
  "sum_upto j = Max {\<Sum>k=i..j. a k | i. i \<le> j}"

lemma sum_upto_in:
  "sum_upto j \<in> {\<Sum>k=i..j. a k | i. i \<le> j}"
  unfolding sum_upto_def by (intro Max_in) auto

lemma max_sum_subseq_Max_sum_upto':
  "max_sum_subseq = Max {sum_upto j | j. j < n}" (is "?l = ?r")
proof (rule antisym)
  show "?r \<le> ?l"
    unfolding max_sum_subseq_def
  proof (rule Max_mono)
    show "{sum_upto j | j. j < n} \<subseteq> {\<Sum>k=i..j. a k | i j. i \<le> j \<and> j < n}"
      unfolding sum_upto_def
    proof clarsimp
      fix j :: nat
      assume \<open>j < n\<close>
      have "Max {sum a {i..j} |i. i \<le> j} \<in> {sum a {i..j} |i. i \<le> j}"
        by (rule Max_in) auto
      with \<open>j < n\<close> show \<open>\<exists>i j'.
           Max {sum a {i..j} |i. i \<le> j} = sum a {i..j'} \<and> i \<le> j' \<and> j' < n\<close>
        by auto
    qed
    show \<open>{sum_upto j |j. j < n} \<noteq> {}\<close>
      using n_gt_0 by auto
  next
    show \<open>finite {sum a {i..j} |i j. i \<le> j \<and> j < n}\<close>
      by (subst setcompr_eq_image2, rule finite_imageI, rule finite_aux1)
  qed
  show "?l \<le> ?r"
  proof -
    from n_gt_0 have "max_sum_subseq \<in> {\<Sum>k=i..j. a k | i j. i \<le> j \<and> j < n}"
      unfolding max_sum_subseq_def apply (intro Max_in)
      apply  (subst setcompr_eq_image2, rule finite_imageI, rule finite_aux1)
       apply auto
      done
    then obtain i j where "i \<le> j" "j < n" "max_sum_subseq = (\<Sum>k=i..j. a k)"
      by auto
    then have "max_sum_subseq \<le> sum_upto j"
      unfolding sum_upto_def by (intro Max_ge) auto
    with \<open>j < n\<close> show "max_sum_subseq \<le> ?r"
      by (elim order.trans, intro Max_ge, auto)
  qed
qed

lemma sum_upto_rec':
  "sum_upto (Suc j) = (if sum_upto j > 0 then sum_upto j + a (j + 1) else a (j + 1))" (is "?l = ?r")
proof (rule antisym)
  obtain i0 i1 where
    "sum_upto j = (\<Sum>k=i0..j. a k)" "?l = (\<Sum>k=i1..j + 1. a k)" "i0 \<le> j" "i1 \<le> j + 1"
    using sum_upto_in[of j] sum_upto_in[of "Suc j"] by auto
  from \<open>i0 \<le> j\<close> show "?r \<le> ?l"
    unfolding \<open>sum_upto j = _\<close> unfolding sum_upto_def
    by (intro Max_ge, simp)
       (smt (z3) Suc_eq_plus1 le_imp_less_Suc less_le_not_le mem_Collect_eq not_le
         sum.nat_ivl_Suc' sum.ub_add_nat)
  show "?l \<le> ?r"
  proof (cases "i1 = j + 1")
    case True
    then show ?thesis
      using \<open>?l = _\<close> by auto
  next
    case False
    with \<open>i1 \<le> j + 1\<close> have "i1 \<le> j"
      by auto
    then have "?l = (\<Sum>k=i1..j. a k) + a (j + 1)"
      unfolding \<open>?l = _\<close> by simp
    also from \<open>i1 \<le> j\<close> False have "\<dots> \<le> sum_upto j + a (j + 1)"
      unfolding sum_upto_def by (intro add_right_mono Max_ge) auto
    finally show ?thesis
      by auto
  qed
qed

lemma sum_upto_0:
  "sum_upto 0 = a 0"
  unfolding sum_upto_def by auto

function f where
  "f i s m = (
    if i \<ge> n then m
    else
    let s' = (if s > 0 then s + a i else a i) in
    f (i + 1) s' (max s' m)
  )
  "
  by auto
termination
  by (relation "measure (\<lambda>(i, _, _). n - i)"; simp)

lemmas [simp del] = f.simps

definition
  "max_upto i = Max {sum_upto j | j. j < i}"

lemma max_upto_rec:
  "max_upto (Suc i) = max (sum_upto i) (max_upto i)" if "i > 0"
proof -
  have *: "j < Suc i \<longleftrightarrow> (j < i \<or> j = i)" for j
    by auto
  show ?thesis
    using that unfolding max_upto_def
    by (subst Max_insert[symmetric]) (auto simp: * intro: arg_cong[where f= Max])
qed

lemma f_invariant:
  "f i (sum_upto (i - 1)) (max_upto i) = max_upto n" if "0 < i" "i \<le> n"
  using that
proof (induction "n - i" arbitrary: i)
  case 0
  then show ?case
    unfolding max_sum_subseq_Max_sum_upto' by (subst f.simps) simp
next
  case (Suc x)
  from Suc.hyps(1)[of "i + 1"] Suc.hyps(2-) Suc.prems have 1:
    "f (i + 1) (sum_upto i) (max_upto (i + 1)) = max_upto n"
    by simp
  from \<open>i > 0\<close> obtain i' where "i = Suc i'"
    by (metis Suc_pred)
  from Suc.prems have 2:
    "sum_upto i = (if sum_upto (i - 1) > 0 then sum_upto (i - 1) + a i else a i)"
    unfolding \<open>i = _\<close> by (subst sum_upto_rec'; simp)
  from \<open>i > 0\<close> have 3: "max_upto (i + 1) = max (sum_upto i) (max_upto i)"
    by (simp add: max_upto_rec)
  from Suc.prems show ?case
    apply (subst f.simps)
    apply (auto simp: Let_def)
    unfolding 1[symmetric] 2 3
    by simp+
qed

lemma max_sum_subseq_max_upto':
  "max_sum_subseq = max_upto n"
  unfolding max_upto_def max_sum_subseq_Max_sum_upto' ..

lemma max_upto_1:
  "max_upto (Suc 0) = a 0"
  unfolding max_upto_def by (simp add: sum_upto_0)

theorem max_sum_subseq_compute':
  "max_sum_subseq = f 1 (a 0) (a 0)"
  using n_gt_0 unfolding max_sum_subseq_max_upto'
  by (subst f_invariant[symmetric, where i = 1]; simp add: sum_upto_0 max_upto_1)

lemma f_eq:
  "Defs.f a n i x y = Submission.f a n i x y" if "n > 0"
  by (induction i x y rule: f.induct) (simp add: f.simps that)

end

theorem max_sum_subseq_Max_sum_upto:
  "n > 0 \<Longrightarrow> Defs.max_sum_subseq a n = Max {Defs.sum_upto a j | j. j < n}"
  using max_sum_subseq_Max_sum_upto'
  by (simp only: Defs.max_sum_subseq_def Defs.sum_upto_def max_sum_subseq_def sum_upto_def)

theorem sum_upto_rec:
  "(n :: nat) > 0
  \<Longrightarrow> Defs.sum_upto a (Suc j) =
      (if Defs.sum_upto a j > 0 then Defs.sum_upto a j + a (j + 1) else a (j + 1))"
  using sum_upto_rec' by (simp only: Defs.sum_upto_def sum_upto_def)

theorem max_sum_subseq_compute:
  "n > 0 \<Longrightarrow> Defs.max_sum_subseq a n = Defs.f a n 1 (a 0) (a 0)"
  using max_sum_subseq_compute' by (simp only: Defs.max_sum_subseq_def max_sum_subseq_def f_eq)

end