section \<open>Formalization of an efficient Hermite normal form algorithm\<close>

text \<open>We formalize a version of the Hermite normal form algorithm based on reductions modulo
the determinant. This avoids the growth of the intermediate coefficients.\<close>

subsection \<open>Implementation of the algorithm using generic modulo operation\<close>

text \<open>Exception on generic modulo: currently in Hermite-reduce-above, ordinary div/mod is used,
  since that is our choice for the complete set of residues.\<close>

theory HNF_Mod_Det_Algorithm
  imports
    Jordan_Normal_Form.Gauss_Jordan_IArray_Impl
    Show.Show_Instances
    Jordan_Normal_Form.Determinant_Impl
    Jordan_Normal_Form.Show_Matrix
    LLL_Basis_Reduction.LLL_Certification
    Smith_Normal_Form.SNF_Algorithm_Euclidean_Domain
    Smith_Normal_Form.SNF_Missing_Lemmas
    Uniqueness_Hermite_JNF
    Matrix_Change_Row
begin

subsubsection \<open>Echelon form algorithm\<close>

fun make_first_column_positive :: "int mat \<Rightarrow> int mat" where
  "make_first_column_positive A = (
       Matrix.mat (dim_row A) (dim_col A) \<comment> \<open> Create a matrix of the same dimensions \<close>
          (\<lambda>(i,j). if A $$(i,0) < 0 then - A $$(i,j) else A $$(i,j)
            )
  )"

locale mod_operation =
  fixes generic_mod :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "gmod" 70)
    and generic_div :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "gdiv" 70)
begin

text \<open>Version for reducing all elements\<close>

fun reduce :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int mat \<Rightarrow> int mat" where
  "reduce a b D A = (let Aaj = A$$(a,0); Abj = A $$ (b,0)
  in
  if Aaj = 0 then A else
  case euclid_ext2 Aaj Abj of (p,q,u,v,d) \<Rightarrow> \<comment> \<open> p*Aaj + q * Abj = d, u = - Abj/d, v = Aaj/d \<close>
       Matrix.mat (dim_row A) (dim_col A) \<comment> \<open> Create a matrix of the same dimensions \<close>
          (\<lambda>(i,k). if i = a then let r = (p*A$$(a,k) + q*A$$(b,k)) in
                              if k = 0 then if D dvd r then D else r else r gmod D \<comment> \<open> Row a is multiplied by p and added row b multiplied by q, modulo D\<close>
                   else if i = b then let r = u * A$$(a,k) + v * A$$(b,k) in
                               if k = 0 then r else r gmod D \<comment> \<open> Row b is multiplied by v and added row a multiplied by u, modulo D\<close>
                   else A$$(i,k)  \<comment> \<open> All the other rows remain unchanged\<close>
            )
  )"

text \<open>Version for reducing, with abs-checking\<close>

fun reduce_abs :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int mat \<Rightarrow> int mat" where
  "reduce_abs a b D A = (let Aaj = A$$(a,0); Abj = A $$ (b,0)
  in
  if Aaj = 0 then A else
  case euclid_ext2 Aaj Abj of (p,q,u,v,d) \<Rightarrow> \<comment> \<open> p*Aaj + q * Abj = d, u = - Abj/d, v = Aaj/d \<close>
       Matrix.mat (dim_row A) (dim_col A) \<comment> \<open> Create a matrix of the same dimensions \<close>
          (\<lambda>(i,k). if i = a then let r = (p*A$$(a,k) + q*A$$(b,k)) in
                            if abs r > D then if k = 0 \<and> D dvd r then D else r gmod D else r
                   else if i = b then let r = u * A$$(a,k) + v * A$$(b,k) in
                              if abs r > D then r gmod D else r
                   else A$$(i,k)  \<comment> \<open> All the other rows remain unchanged\<close>
            )
  )"

definition reduce_impl :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int mat \<Rightarrow> int mat" where
  "reduce_impl a b D A = (let
    row_a = Matrix.row A a;
    Aaj = row_a $v 0
  in
  if Aaj = 0 then A else let
    row_b = Matrix.row A b;
    Abj = row_b $v 0 in
  case euclid_ext2 Aaj Abj of (p,q,u,v,d) \<Rightarrow>
    let row_a' = (\<lambda> k ak. let r = (p * ak + q * row_b $v k) in
              if k = 0 then if D dvd r then D else r else r gmod D);
        row_b' = (\<lambda> k bk. let r = u * row_a $v k + v * bk in
                               if k = 0 then r else r gmod D)
     in change_row a row_a' (change_row b row_b' A)
  )"

definition reduce_abs_impl :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int mat \<Rightarrow> int mat" where
  "reduce_abs_impl a b D A = (let
    row_a = Matrix.row A a;
    Aaj = row_a $v 0
  in
  if Aaj = 0 then A else let
    row_b = Matrix.row A b;
    Abj = row_b $v 0 in
  case euclid_ext2 Aaj Abj of (p,q,u,v,d) \<Rightarrow>
    let row_a' = (\<lambda> k ak. let r = (p * ak + q * row_b $v k) in
              if abs r > D then if k = 0 \<and> D dvd r then D else r gmod D else r);
        row_b' = (\<lambda> k bk. let r = u * row_a $v k + v * bk in
                                if abs r > D then r gmod D else r)
     in change_row a row_a' (change_row b row_b' A)
  )"

lemma reduce_impl: "a < nr \<Longrightarrow> b < nr \<Longrightarrow> 0 < nc \<Longrightarrow> a \<noteq> b \<Longrightarrow> A \<in> carrier_mat nr nc
  \<Longrightarrow> reduce_impl a b D A = reduce a b D A"
  unfolding reduce_impl_def reduce.simps Let_def
  apply (intro if_cong[OF _ refl], force)
  apply (intro prod.case_cong refl, force)
  apply (intro eq_matI, auto)
  done

lemma reduce_abs_impl: "a < nr \<Longrightarrow> b < nr \<Longrightarrow> 0 < nc \<Longrightarrow> a \<noteq> b \<Longrightarrow> A \<in> carrier_mat nr nc
  \<Longrightarrow> reduce_abs_impl a b D A = reduce_abs a b D A"
  unfolding reduce_abs_impl_def reduce_abs.simps Let_def
  apply (intro if_cong[OF _ refl], force)
  apply (intro prod.case_cong refl, force)
  apply (intro eq_matI, auto)
  done

(* This functions reduce the elements below the position (a,0), given a list of positions
   of non-zero positions as input*)
fun reduce_below :: "nat \<Rightarrow> nat list \<Rightarrow> int \<Rightarrow> int mat \<Rightarrow> int mat"
where "reduce_below a [] D A = A"
  | "reduce_below a (x # xs) D A = reduce_below a xs D (reduce a x D A)"

fun reduce_below_impl :: "nat \<Rightarrow> nat list \<Rightarrow> int \<Rightarrow> int mat \<Rightarrow> int mat"
where "reduce_below_impl a [] D A = A"
  | "reduce_below_impl a (x # xs) D A = reduce_below_impl a xs D (reduce_impl a x D A)"

lemma reduce_impl_carrier[simp,intro]: "A \<in> carrier_mat m n \<Longrightarrow> reduce_impl a b D A \<in> carrier_mat m n"
  unfolding reduce_impl_def Let_def by (auto split: prod.splits)

lemma reduce_below_impl: "a < nr \<Longrightarrow> 0 < nc \<Longrightarrow> (\<And> b. b \<in> set bs \<Longrightarrow> b < nr) \<Longrightarrow> a \<notin> set bs
  \<Longrightarrow> A \<in> carrier_mat nr nc \<Longrightarrow> reduce_below_impl a bs D A = reduce_below a bs D A"
proof (induct bs arbitrary: A)
  case (Cons b bs A)
  show ?case by (simp del: reduce.simps,
      subst reduce_impl[of _ nr _ nc],
      (insert Cons, auto simp del: reduce.simps)[5],
      rule Cons(1), insert Cons(2-), auto simp: Let_def split: prod.splits)
qed simp

fun reduce_below_abs :: "nat \<Rightarrow> nat list \<Rightarrow> int \<Rightarrow> int mat \<Rightarrow> int mat"
where "reduce_below_abs a [] D A = A"
  | "reduce_below_abs a (x # xs) D A = reduce_below_abs a xs D (reduce_abs a x D A)"

fun reduce_below_abs_impl :: "nat \<Rightarrow> nat list \<Rightarrow> int \<Rightarrow> int mat \<Rightarrow> int mat"
where "reduce_below_abs_impl a [] D A = A"
  | "reduce_below_abs_impl a (x # xs) D A = reduce_below_abs_impl a xs D (reduce_abs_impl a x D A)"

lemma reduce_abs_impl_carrier[simp,intro]: "A \<in> carrier_mat m n \<Longrightarrow> reduce_abs_impl a b D A \<in> carrier_mat m n"
  unfolding reduce_abs_impl_def Let_def by (auto split: prod.splits)

lemma reduce_abs_below_impl: "a < nr \<Longrightarrow> 0 < nc \<Longrightarrow> (\<And> b. b \<in> set bs \<Longrightarrow> b < nr) \<Longrightarrow> a \<notin> set bs
  \<Longrightarrow> A \<in> carrier_mat nr nc \<Longrightarrow> reduce_below_abs_impl a bs D A = reduce_below_abs a bs D A"
proof (induct bs arbitrary: A)
  case (Cons b bs A)
  show ?case by (simp del: reduce_abs.simps,
      subst reduce_abs_impl[of _ nr _ nc],
      (insert Cons, auto simp del: reduce_abs.simps)[5],
      rule Cons(1), insert Cons(2-), auto simp: Let_def split: prod.splits)
qed simp

text \<open>This function outputs a matrix in echelon form via reductions modulo the determinant\<close>

function FindPreHNF :: "bool \<Rightarrow> int \<Rightarrow> int mat \<Rightarrow> int mat"
  where "FindPreHNF abs_flag D A =
  (let m = dim_row A; n = dim_col A in
  if m < 2 \<or> n = 0 then A else \<comment> \<open> No operations are carried out if m = 1 \<close>
  let non_zero_positions = filter (\<lambda>i. A $$ (i,0) \<noteq> 0) [1..<dim_row A];
         A' = (if A$$(0,0) \<noteq> 0 then A
              else let i = non_zero_positions ! 0  \<comment> \<open> Select the first non-zero position below the first element\<close>
                   in swaprows 0 i A
              );
        Reduce = (if abs_flag then reduce_below_abs else reduce_below)
    in
      if n < 2 then Reduce 0 non_zero_positions D A'  \<comment> \<open> If n = 1, then we have to reduce the column \<close>
    else
      let
        (A_UL,A_UR,A_DL,A_DR) = split_block (Reduce 0 non_zero_positions D (make_first_column_positive A')) 1 1;
        sub_PreHNF = FindPreHNF abs_flag D A_DR in
        four_block_mat A_UL A_UR A_DL sub_PreHNF)"
  by pat_completeness auto

termination
proof (relation "Wellfounded.measure (\<lambda>(abs_flag,D,A). dim_col A)")
  show "wf (Wellfounded.measure (\<lambda>(abs_flag,D, A). dim_col A))" by auto
  fix abs_flag D A m n nz A' R xd A'_UL y A'_UR ya A'_DL A'_DR
  assume m: "m = dim_row A" and n:"n = dim_col A"
    and m2: "\<not> (m < 2 \<or> n = 0)" and nz_def: "nz = filter (\<lambda>i. A $$ (i, 0) \<noteq> 0) [1..<dim_row A] "
    and A'_def: "A' = (if A $$ (0, 0) \<noteq> 0 then A else let i = nz ! 0 in swaprows 0 i A)"
    and R_def: "R = (if abs_flag then reduce_below_abs else reduce_below)"
    and n2: "\<not> n < 2" and "xd = split_block (R 0 nz D (make_first_column_positive A')) 1 1"
    and "(A'_UL, y) = xd" and "(A'_UR, ya) = y" and "(A'_DL, A'_DR) = ya"
  hence A'_split: "(A'_UL, A'_UR, A'_DL, A'_DR)
        = split_block (R 0 nz D (make_first_column_positive A')) 1 1" by force
  have dr_mk1: "dim_row (make_first_column_positive A) = dim_row A" for A by auto
  have dr_mk2: "dim_col (make_first_column_positive A) = dim_col A" for A by auto
  have r1: "reduce_below a xs D A \<in> carrier_mat m n" if "A \<in> carrier_mat m n" for A a xs
    using that by (induct a xs D A rule: reduce_below.induct, auto simp add: Let_def euclid_ext2_def)
  hence R: "(reduce_below 0 nz D (make_first_column_positive A')) \<in> carrier_mat m n"
    using A'_def m n
    by (metis carrier_matI index_mat_swaprows(2,3) dr_mk1 dr_mk2)
  have "reduce_below_abs a xs D A \<in> carrier_mat m n" if "A \<in> carrier_mat m n" for A a xs
    using that by (induct a xs D A rule: reduce_below_abs.induct, auto simp add: Let_def euclid_ext2_def)
  hence R2: "(reduce_below_abs 0 nz D (make_first_column_positive A')) \<in> carrier_mat m n"
    using A'_def m n
    by (metis carrier_matI index_mat_swaprows(2,3) dr_mk1 dr_mk2)

  have "A'_DR \<in> carrier_mat (m-1) (n-1)"
    by (cases abs_flag; rule split_block(4)[OF A'_split[symmetric]],insert m2 n2 m n R_def R R2, auto)
  thus "((abs_flag, D, A'_DR),abs_flag, D, A) \<in> Wellfounded.measure (\<lambda>(abs_flag,D, A). dim_col A)" using n2 m2 n m by auto
qed

lemma FindPreHNF_code: "FindPreHNF abs_flag D A =
  (let m = dim_row A; n = dim_col A in
  if m < 2 \<or> n = 0 then A else
  let non_zero_positions = filter (\<lambda>i. A $$ (i,0) \<noteq> 0) [1..<dim_row A];
         A' = (if A$$(0,0) \<noteq> 0 then A
              else let i = non_zero_positions ! 0 in swaprows 0 i A
              );
         Reduce_impl = (if abs_flag then reduce_below_abs_impl else reduce_below_impl)
    in
      if n < 2 then Reduce_impl 0 non_zero_positions D A'
    else
      let
        (A_UL,A_UR,A_DL,A_DR) = split_block (Reduce_impl 0 non_zero_positions D (make_first_column_positive A')) 1 1;
        sub_PreHNF = FindPreHNF abs_flag D A_DR in
        four_block_mat A_UL A_UR A_DL sub_PreHNF)"  (is "?lhs = ?rhs")
proof -
  let ?f = "\<lambda>R. (if dim_row A < 2 \<or> dim_col A = 0 then A else if dim_col A < 2
          then R 0 (filter (\<lambda>i. A $$ (i, 0) \<noteq> 0) [1..<dim_row A]) D
  (if A $$ (0, 0) \<noteq> 0 then A else swaprows 0 (filter (\<lambda>i. A $$ (i, 0) \<noteq> 0) [1..<dim_row A] ! 0) A)
  else case split_block (R 0 (filter (\<lambda>i. A $$ (i, 0) \<noteq> 0) [1..<dim_row A]) D
    (make_first_column_positive (if A $$ (0, 0) \<noteq> 0 then A else
      swaprows 0 (filter (\<lambda>i. A $$ (i, 0) \<noteq> 0) [1..<dim_row A] ! 0) A))) 1 1 of
  (A_UL, A_UR, A_DL, A_DR) \<Rightarrow> four_block_mat A_UL A_UR A_DL (FindPreHNF abs_flag D A_DR))"
  have M_carrier: "make_first_column_positive (if A $$ (0, 0) \<noteq> 0 then A
    else swaprows 0 (filter (\<lambda>i. A $$ (i, 0) \<noteq> 0) [1..<dim_row A] ! 0) A)
    \<in> carrier_mat (dim_row A) (dim_col A)"
    by (smt (z3) index_mat_swaprows(2) index_mat_swaprows(3) make_first_column_positive.simps mat_carrier)
  have *: "0 \<notin> set (filter (\<lambda>i. A $$ (i, 0) \<noteq> 0) [1..<dim_row A])" by simp
  have "?lhs = ?f (if abs_flag then reduce_below_abs else reduce_below)"
    unfolding FindPreHNF.simps[of abs_flag D A] Let_def by presburger
  also have "... = ?rhs"
  proof (cases abs_flag)
    case True
    have "?f (if abs_flag then reduce_below_abs else reduce_below) = ?f reduce_below_abs"
      using True by presburger
    also have "... = ?f reduce_below_abs_impl"
      by ((intro if_cong refl prod.case_cong arg_cong[of _ _ "\<lambda> x. split_block x 1 1"];
       (subst reduce_abs_below_impl[where nr = "dim_row A" and nc = "dim_col A"])), (auto)[9])
       (insert M_carrier *, blast+)
    also have "... = ?f (if abs_flag then reduce_below_abs_impl else reduce_below_impl)"
      using True by presburger
    finally show ?thesis using True unfolding FindPreHNF.simps[of abs_flag D A] Let_def by blast
  next
    case False
    have "?f (if abs_flag then reduce_below_abs else reduce_below) = ?f reduce_below"
      using False by presburger
    also have "... = ?f reduce_below_impl"
      by ((intro if_cong refl prod.case_cong arg_cong[of _ _ "\<lambda> x. split_block x 1 1"];
       (subst reduce_below_impl[where nr = "dim_row A" and nc = "dim_col A"])), (auto)[9])
       (insert M_carrier *, blast+)
    also have "... = ?f (if abs_flag then reduce_below_abs_impl else reduce_below_impl)"
      using False by presburger
    finally show ?thesis using False unfolding FindPreHNF.simps[of abs_flag D A] Let_def by blast
  qed
  finally show ?thesis by blast
qed
end

declare mod_operation.FindPreHNF_code[code]
declare mod_operation.reduce_below_impl.simps[code]
declare mod_operation.reduce_impl_def[code]
declare mod_operation.reduce_below_abs_impl.simps[code]
declare mod_operation.reduce_abs_impl_def[code]

subsubsection \<open>From echelon form to Hermite normal form\<close>

text \<open>From here on, we define functions to transform a matrix in echelon form into its Hermite
normal form. Essentially, we are defining the functions that are available in the AFP entry Hermite
(which uses HOL Analysis + mod-type) in the JNF matrix representation.\<close>

(*Find the first nonzero element of row l (A is upper triangular)*)
definition find_fst_non0_in_row :: "nat \<Rightarrow> int mat \<Rightarrow> nat option" where
  "find_fst_non0_in_row l A = (let is = [l ..< dim_col A];
    Ais = filter (\<lambda>j. A $$ (l, j) \<noteq> 0) is
    in case Ais of [] \<Rightarrow> None | _ \<Rightarrow> Some (Ais!0))"

primrec Hermite_reduce_above
where "Hermite_reduce_above (A::int mat) 0 i j = A"
    | "Hermite_reduce_above A (Suc n) i j = (let
    Aij = A $$ (i,j);
    Anj = A $$ (n,j)
    in
    Hermite_reduce_above (addrow (- (Anj div Aij)) n i A) n i j)"

definition Hermite_of_row_i :: "int mat \<Rightarrow> nat \<Rightarrow> int mat"
  where "Hermite_of_row_i A i = (
  case find_fst_non0_in_row i A of None \<Rightarrow> A | Some j \<Rightarrow>
    let Aij = A $$(i,j) in
    if Aij < 0 then Hermite_reduce_above (multrow i (-1) A) i i j
    else Hermite_reduce_above A i i j)"

primrec Hermite_of_list_of_rows
  where
 "Hermite_of_list_of_rows A [] = A" |
 "Hermite_of_list_of_rows A (a#xs) = Hermite_of_list_of_rows (Hermite_of_row_i A a) xs"

text \<open>We combine the previous functions to assemble the algorithm\<close>

definition (in mod_operation) "Hermite_mod_det abs_flag A =
  (let m = dim_row A; n = dim_col A;
   D = abs(det_int A);
   A' = A @\<^sub>r D \<cdot>\<^sub>m 1\<^sub>m n;
   E = FindPreHNF abs_flag D A';
   H = Hermite_of_list_of_rows E [0..<m+n]
  in mat_of_rows n (map (Matrix.row H) [0..<m]))"

subsubsection \<open>Some examples of execution\<close>

declare mod_operation.Hermite_mod_det_def[code]

value "let B = mat_of_rows_list 4 ([[0,3,1,4],[7,1,0,0],[8,0,19,16],[2,0,0,3::int]]) in
  show (mod_operation.Hermite_mod_det (mod) True B)"

(*
sage: import sage.matrix.matrix_integer_dense_hnf as matrix_integer_dense_hnf
sage: A = matrix(ZZ, [[0,3,1,4],[7,1,0,0],[8,0,19,16],[2,0,0,3]])
sage: A
[ 0  3  1  4]
[ 7  1  0  0]
[ 8  0 19 16]
[ 2  0  0  3]
sage:  H, U = matrix_integer_dense_hnf.hnf_with_transformation(A); H
[   1    0    0  672]
[   0    1    0  660]
[   0    0    1  706]
[   0    0    0 1341]
sage:
*)

value "let B = mat_of_rows_list 7 ([
[  1,  17, -41,  -1,   1,   0,  0],
[  0,  -1,   2,   0,  -6,   2,   1],
[  9,   2,   1,   1,  -2,   2,  -5],
[ -1,  -3,  -1,   0,  -9,   0,   0],
[  9,  -1,  -9,   0,   0,   0,   1],
[  1,  -1,   1,   0,   1,  -8,   0],
[  1,  -1,   0,  -2,  -1,  -1,   0::int]]) in
  show (mod_operation.Hermite_mod_det (mod) True B)"

(*
sage: import sage.matrix.matrix_integer_dense_hnf as matrix_integer_dense_hnf
sage: A = random_matrix(ZZ,7,7); A
[  1  17 -41  -1   1   0   0]
[  0  -1   2   0  -6   2   1]
[  9   2   1   1  -2   2  -5]
[ -1  -3  -1   0  -9   0   0]
[  9  -1  -9   0   0   0   1]
[  1  -1   1   0   1  -8   0]
[  1  -1   0  -2  -1  -1   0]
sage: H, U = matrix_integer_dense_hnf.hnf_with_transformation(A); H
[     1      0      0      0      0      1 191934]
[     0      1      0      0      0      0 435767]
[     0      0      1      0      0      1 331950]
[     0      0      0      1      0      0 185641]
[     0      0      0      0      1      0  38022]
[     0      0      0      0      0      2 477471]
[     0      0      0      0      0      0 565304]
*)

end


theory Poincare_Perpendicular
  imports Poincare_Lines_Axis_Intersections
begin

(* ------------------------------------------------------------------ *)
section\<open>H-perpendicular h-lines in the Poincar\'e model\<close>
(* ------------------------------------------------------------------ *)

definition perpendicular_to_x_axis_cmat :: "complex_mat \<Rightarrow> bool" where
 [simp]: "perpendicular_to_x_axis_cmat H \<longleftrightarrow> (let (A, B, C, D) = H in is_real B)"

lift_definition perpendicular_to_x_axis_clmat :: "circline_mat \<Rightarrow> bool" is perpendicular_to_x_axis_cmat
  done

lift_definition perpendicular_to_x_axis :: "circline \<Rightarrow> bool" is perpendicular_to_x_axis_clmat
  by transfer auto

lemma perpendicular_to_x_axis:
  assumes "is_poincare_line H"
  shows "perpendicular_to_x_axis H \<longleftrightarrow> perpendicular x_axis H"
  using assms
  unfolding perpendicular_def
proof (transfer, transfer)
  fix H
  assume hh: "hermitean H \<and> H \<noteq> mat_zero" "is_poincare_line_cmat H"
  obtain A B C D where *: "H = (A, B, C, D)"
    by (cases H, auto)
  hence "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2" "H = (A, B, cnj B, A)"
    using hermitean_elems[of A B C D] hh
    by auto
  thus "perpendicular_to_x_axis_cmat H =
        (cos_angle_cmat (of_circline_cmat x_axis_cmat) (of_circline_cmat H) = 0)"
    using cmod_square[of B] cmod_square[of A]
    by simp
qed

lemma perpendicular_to_x_axis_y_axis:
  assumes "perpendicular_to_x_axis (poincare_line 0\<^sub>h (of_complex z))" "z \<noteq> 0"
  shows "is_imag z"
  using assms
  by (transfer, transfer, simp)

lemma wlog_perpendicular_axes:
  assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "z \<in> unit_disc"
  assumes perpendicular: "is_poincare_line H1" "is_poincare_line H2" "perpendicular H1 H2"
  assumes "z \<in> circline_set H1 \<inter> circline_set H2" "u \<in> circline_set H1" "v \<in> circline_set H2"
  assumes axes: "\<And> x y. \<lbrakk>is_real x; 0 \<le> Re x; Re x < 1; is_imag y; 0 \<le> Im y; Im y < 1\<rbrakk> \<Longrightarrow> P 0\<^sub>h (of_complex x) (of_complex y)"
  assumes moebius: "\<And> M u v w. \<lbrakk>unit_disc_fix M; u \<in> unit_disc; v \<in> unit_disc; w \<in> unit_disc; P (moebius_pt M u) (moebius_pt M v) (moebius_pt M w) \<rbrakk> \<Longrightarrow> P u v w"
  assumes conjugate: "\<And> u v w. \<lbrakk>u \<in> unit_disc; v \<in> unit_disc; w \<in> unit_disc; P (conjugate u) (conjugate v) (conjugate w) \<rbrakk> \<Longrightarrow> P u v w"
  shows "P z u v"
proof-
  have "\<forall> v H1 H2. is_poincare_line H1 \<and> is_poincare_line H2 \<and> perpendicular H1 H2 \<and>
                   z \<in> circline_set H1 \<inter> circline_set H2 \<and> u \<in> circline_set H1 \<and> v \<in> circline_set H2 \<and> v \<in> unit_disc \<longrightarrow> P z u v" (is "?P z u")
  proof (rule wlog_x_axis[where P="?P"])
    fix x
    assume x: "is_real x" "Re x \<ge> 0" "Re x < 1"
    have "of_complex x \<in> unit_disc"
      using x
      by (simp add: cmod_eq_Re)

    show "?P 0\<^sub>h (of_complex x)"
    proof safe
      fix v H1 H2
      assume "v \<in> unit_disc"
      then obtain y where y: "v = of_complex y"
        using inf_or_of_complex[of v]
        by auto

      assume 1: "is_poincare_line H1" "is_poincare_line H2" "perpendicular H1 H2"
      assume 2: "0\<^sub>h \<in> circline_set H1" "0\<^sub>h \<in> circline_set H2" "of_complex x \<in> circline_set H1" "v \<in> circline_set H2"

      show "P 0\<^sub>h (of_complex x) v"
      proof (cases "of_complex x = 0\<^sub>h")
        case True
        show "P 0\<^sub>h (of_complex x) v"
        proof (cases "v = 0\<^sub>h")
          case True
          thus ?thesis
            using \<open>of_complex x = 0\<^sub>h\<close>
            using axes[of 0 0]
            by simp
        next
          case False
          show ?thesis
          proof (rule wlog_rotation_to_positive_y_axis)
            show "v \<in> unit_disc" "v \<noteq> 0\<^sub>h"
              by fact+
          next
            fix y
            assume "is_imag y" "0 < Im y" "Im y < 1"
            thus "P 0\<^sub>h (of_complex x) (of_complex y)"
              using x axes[of x y]
              by simp
          next
            fix \<phi> u
            assume "u \<in> unit_disc" "u \<noteq> 0\<^sub>h"
                   "P 0\<^sub>h (of_complex x) (moebius_pt (moebius_rotation \<phi>) u)"
            thus "P 0\<^sub>h (of_complex x) u"
              using \<open>of_complex x = 0\<^sub>h\<close>
              using moebius[of "moebius_rotation \<phi>"  "0\<^sub>h" "0\<^sub>h" u]
              by simp
          qed
        qed
      next
        case False
        hence *: "poincare_line 0\<^sub>h (of_complex x) = x_axis"
          using x poincare_line_0_real_is_x_axis[of "of_complex x"]
          unfolding circline_set_x_axis
          by auto
        hence "H1 = x_axis"
          using unique_poincare_line[of "0\<^sub>h" "of_complex x" H1] 1 2
          using \<open>of_complex x \<in> unit_disc\<close> False
          by simp
        have "is_imag y"
        proof (cases "y = 0")
          case True
          thus ?thesis
            by simp
        next
          case False
          hence "0\<^sub>h \<noteq> of_complex y"
            using of_complex_zero_iff[of y]
            by metis
          hence "H2 = poincare_line 0\<^sub>h (of_complex y)"
            using 1 2 \<open>v \<in> unit_disc\<close>
            using unique_poincare_line[of "0\<^sub>h" "of_complex y" H2] y
            by simp
          thus ?thesis
            using 1 \<open>H1 = x_axis\<close>
            using perpendicular_to_x_axis_y_axis[of y] False
            using perpendicular_to_x_axis[of H2]
            by simp
        qed
        show "P 0\<^sub>h (of_complex x) v"
        proof (cases "Im y \<ge> 0")
          case True
          thus ?thesis
            using axes[of x y] x y \<open>is_imag y\<close> \<open>v \<in> unit_disc\<close>
            by (simp add: cmod_eq_Im)
        next
          case False
          show ?thesis
          proof (rule conjugate)
            have "Im (cnj y) < 1"
              using \<open>v \<in> unit_disc\<close> y \<open>is_imag y\<close> eq_minus_cnj_iff_imag[of y]
              by (simp add: cmod_eq_Im)
            thus "P (conjugate 0\<^sub>h) (conjugate (of_complex x)) (conjugate v)"
              using \<open>is_real x\<close> eq_cnj_iff_real[of x] y \<open>is_imag y\<close>
              using axes[OF x, of "cnj y"] False
              by simp
            show "0\<^sub>h \<in> unit_disc" "of_complex x \<in> unit_disc" "v \<in> unit_disc"
              by (simp, fact+)
          qed
        qed
      qed
    qed
  next
    show "z \<in> unit_disc" "u \<in> unit_disc"
      by fact+
  next
    fix M u v
    assume *: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc"
    assume **: "?P (moebius_pt M u) (moebius_pt M v)"
    show "?P u v"
    proof safe
      fix w H1 H2
      assume ***: "is_poincare_line H1" "is_poincare_line H2" "perpendicular H1 H2"
                  "u \<in> circline_set H1" "u \<in> circline_set H2"
                  "v \<in> circline_set H1" "w \<in> circline_set H2" "w \<in> unit_disc"
      thus "P u v w"
        using moebius[of M u v w] *
        using **[rule_format, of "moebius_circline M H1" "moebius_circline M H2" "moebius_pt M w"]
        by simp
    qed
  qed
  thus ?thesis
    using assms
    by blast
qed

lemma wlog_perpendicular_foot:
  assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc" "z \<in> unit_disc"
  assumes perpendicular: "u \<noteq> v" "is_poincare_line H" "perpendicular (poincare_line u v) H"
  assumes "z \<in> circline_set (poincare_line u v) \<inter> circline_set H" "w \<in> circline_set H"
  assumes axes: "\<And> u v w. \<lbrakk>is_real u; 0 < Re u; Re u < 1; is_real v; -1 < Re v; Re v < 1; Re u \<noteq> Re v; is_imag w; 0 \<le> Im w; Im w < 1\<rbrakk> \<Longrightarrow> P 0\<^sub>h (of_complex u) (of_complex v) (of_complex w)"
  assumes moebius: "\<And> M z u v w. \<lbrakk>unit_disc_fix M; u \<in> unit_disc; v \<in> unit_disc; w \<in> unit_disc; z \<in> unit_disc; P (moebius_pt M z) (moebius_pt M u) (moebius_pt M v) (moebius_pt M w) \<rbrakk> \<Longrightarrow> P z u v w"
  assumes conjugate: "\<And> z u v w. \<lbrakk>u \<in> unit_disc; v \<in> unit_disc; w \<in> unit_disc; P (conjugate z) (conjugate u) (conjugate v) (conjugate w) \<rbrakk> \<Longrightarrow> P z u v w"
  assumes perm: "P z v u w \<Longrightarrow> P z u v w"
  shows "P z u v w"
proof-
  obtain m n where mn: "m = u \<or> m = v" "n = u \<or> n = v" "m \<noteq> n" "m \<noteq> z"
    using \<open>u \<noteq> v\<close>
    by auto

  have "n \<in> circline_set (poincare_line z m)"
    using \<open>z \<in> circline_set (poincare_line u v) \<inter> circline_set H\<close>
    using mn
    using unique_poincare_line[of z m "poincare_line u v", symmetric] in_disc
    by auto

  have "\<forall> n. n \<in> unit_disc \<and> m \<noteq> n \<and> n \<in> circline_set (poincare_line z m) \<and> m \<noteq> z \<longrightarrow> P z m n w" (is "?Q z m w")
  proof (rule wlog_perpendicular_axes[where P="?Q"])
    show "is_poincare_line (poincare_line u v)"
      using \<open>u \<noteq> v\<close>
      by auto
  next
    show "is_poincare_line H"
      by fact
  next
    show "m \<in> unit_disc" "m \<in> circline_set (poincare_line u v)"
      using mn in_disc
      by auto
  next
    show "w \<in> unit_disc" "z \<in> unit_disc"
      by fact+
  next
    show "z \<in> circline_set (poincare_line u v) \<inter> circline_set H"
      by fact
  next
    show "perpendicular (poincare_line u v) H"
      by fact
  next
    show "w \<in> circline_set H"
      by fact
  next
    fix x y
    assume xy: "is_real x" "0 \<le> Re x" "Re x < 1" "is_imag y" "0 \<le> Im y" "Im y < 1"
    show "?Q 0\<^sub>h (of_complex x) (of_complex y)"
    proof safe
      fix n
      assume "n \<in> unit_disc" "of_complex x \<noteq> n"
      assume "n \<in> circline_set (poincare_line 0\<^sub>h (of_complex x))" "of_complex x \<noteq> 0\<^sub>h"
      hence "n \<in> circline_set x_axis"
        using poincare_line_0_real_is_x_axis[of "of_complex x"] xy
        by (auto simp add: circline_set_x_axis)
      then obtain n' where n': "n = of_complex n'"
        using inf_or_of_complex[of n] \<open>n \<in> unit_disc\<close>
        by auto
      hence "is_real n'"
        using \<open>n \<in> circline_set x_axis\<close>
        using of_complex_inj
        unfolding circline_set_x_axis
        by auto
      hence "-1 < Re n'" "Re n' < 1"
        using \<open>n \<in> unit_disc\<close> n'
        by (auto simp add: cmod_eq_Re)

      have "Re n' \<noteq> Re x"
        using complex.expand[of n' x] \<open>is_real n'\<close> \<open>is_real x\<close> \<open>of_complex x \<noteq> n\<close> n'
        by auto

      have "Re x > 0"
        using xy \<open>of_complex x \<noteq> 0\<^sub>h\<close>
        by (cases "Re x = 0", auto simp add: complex.expand)

      show "P 0\<^sub>h (of_complex x) n (of_complex y)"
        using axes[of x n' y] xy n' \<open>Re x > 0\<close> \<open>is_real n'\<close> \<open>-1 < Re n'\<close> \<open>Re n' < 1\<close> \<open>Re n' \<noteq> Re x\<close>
        by simp
    qed
  next
    fix M u v w
    assume 1: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
    assume 2: "?Q (moebius_pt M u) (moebius_pt M v) (moebius_pt M w)"
    show "?Q u v w"
    proof safe
      fix n
      assume "n \<in> unit_disc" "v \<noteq> n" "n \<in> circline_set (poincare_line u v)" "v \<noteq> u"
      thus "P u v n w"
        using moebius[of M v n w u] 1 2[rule_format, of "moebius_pt M n"]
        by fastforce
    qed
  next
    fix u v w
    assume 1: "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
    assume 2: "?Q (conjugate u) (conjugate v) (conjugate w)"
    show "?Q u v w"
    proof safe
      fix n
      assume "n \<in> unit_disc" "v \<noteq> n" "n \<in> circline_set (poincare_line u v)" "v \<noteq> u"
      thus "P u v n w"
        using conjugate[of v n w u] 1 2[rule_format, of "conjugate n"]
        using conjugate_inj
        by auto
    qed
  qed
  thus ?thesis
    using mn in_disc \<open>n \<in> circline_set (poincare_line z m)\<close> perm
    by auto
qed

lemma perpendicular_to_x_axis_intersects_x_axis:
  assumes "is_poincare_line H" "perpendicular_to_x_axis H"
  shows "intersects_x_axis H"
  using assms hermitean_elems
  by (transfer, transfer, auto simp add: cmod_eq_Re)

lemma perpendicular_intersects:
  assumes "is_poincare_line H1" "is_poincare_line H2"
  assumes "perpendicular H1 H2"
  shows "\<exists> z. z \<in> unit_disc \<and> z \<in> circline_set H1 \<inter> circline_set H2" (is "?P' H1 H2")
proof-
  have "\<forall> H2. is_poincare_line H2 \<and> perpendicular H1 H2 \<longrightarrow> ?P' H1 H2" (is "?P H1")
  proof (rule wlog_line_x_axis)
    show "?P x_axis"
    proof safe
      fix H2
      assume "is_poincare_line H2" "perpendicular x_axis H2"
      thus "\<exists>z. z \<in> unit_disc \<and> z \<in> circline_set x_axis \<inter> circline_set H2"
        using perpendicular_to_x_axis[of H2]
        using perpendicular_to_x_axis_intersects_x_axis[of H2]
        using intersects_x_axis_iff[of H2]
        by auto
    qed
  next
    fix M
    assume "unit_disc_fix M"
    assume *: "?P (moebius_circline M H1)"
    show "?P H1"
    proof safe
      fix H2
      assume "is_poincare_line H2" "perpendicular H1 H2"
      then obtain z where "z \<in> unit_disc" "z \<in> circline_set (moebius_circline M H1) \<and> z \<in> circline_set (moebius_circline M H2)"
        using *[rule_format, of "moebius_circline M H2"] \<open>unit_disc_fix M\<close>
        by auto
      thus "\<exists>z. z \<in> unit_disc \<and> z \<in> circline_set H1 \<inter> circline_set H2"
        using \<open>unit_disc_fix M\<close>
        by (rule_tac x="moebius_pt (-M) z" in exI)
           (metis IntI add.inverse_inverse circline_set_moebius_circline_iff moebius_pt_comp_inv_left uminus_moebius_def unit_disc_fix_discI unit_disc_fix_moebius_uminus)
    qed
  next
    show "is_poincare_line H1"
      by fact
  qed
  thus ?thesis
    using assms
    by auto
qed

definition calc_perpendicular_to_x_axis_cmat :: "complex_vec \<Rightarrow> complex_mat" where
 [simp]: "calc_perpendicular_to_x_axis_cmat z =
     (let (z1, z2) = z
       in if z1*cnj z2 + z2*cnj z1 = 0 then
          (0, 1, 1, 0)
       else
          let A = z1*cnj z2 + z2*cnj z1;
              B = -(z1*cnj z1 + z2*cnj z2)
           in (A, B, B, A)
     )"

lift_definition calc_perpendicular_to_x_axis_clmat :: "complex_homo_coords \<Rightarrow> circline_mat" is calc_perpendicular_to_x_axis_cmat
  by (auto simp add: hermitean_def mat_adj_def mat_cnj_def Let_def split: if_split_asm)

lift_definition calc_perpendicular_to_x_axis :: "complex_homo \<Rightarrow> circline" is calc_perpendicular_to_x_axis_clmat
proof (transfer)
  fix z w
  assume "z \<noteq> vec_zero" "w \<noteq> vec_zero"
  obtain z1 z2 w1 w2 where zw: "z = (z1, z2)" "w = (w1, w2)"
    by (cases z, cases w, auto)
  assume "z \<approx>\<^sub>v w"
  then obtain k where *: "k \<noteq> 0" "w1 = k*z1" "w2 = k*z2"
    using zw
    by auto
  have "w1 * cnj w2 + w2 * cnj w1 = (k * cnj k) * (z1 * cnj z2 + z2 * cnj z1)"
    using *
    by (auto simp add: field_simps)
  moreover
  have "w1 * cnj w1 + w2 * cnj w2 = (k * cnj k) * (z1 * cnj z1 + z2 * cnj z2)"
    using *
    by (auto simp add: field_simps)
  ultimately
  show "circline_eq_cmat (calc_perpendicular_to_x_axis_cmat z) (calc_perpendicular_to_x_axis_cmat w)"
    using zw *
    apply (auto simp add: Let_def)
    apply (rule_tac x="Re (k * cnj k)" in exI, auto simp add: complex.expand field_simps)
    done
qed

lemma calc_perpendicular_to_x_axis:
  assumes "z \<noteq> of_complex 1" "z \<noteq> of_complex (-1)"
  shows "z \<in> circline_set (calc_perpendicular_to_x_axis z) \<and>
         is_poincare_line (calc_perpendicular_to_x_axis z) \<and>
         perpendicular_to_x_axis (calc_perpendicular_to_x_axis z)"
  using assms
  unfolding circline_set_def perpendicular_def
proof (simp, transfer, transfer)
  fix z :: complex_vec
  obtain z1 z2 where z: "z = (z1, z2)"
    by (cases z, auto)
  assume **: "\<not> z \<approx>\<^sub>v of_complex_cvec 1" "\<not> z \<approx>\<^sub>v of_complex_cvec (- 1)"
  show "on_circline_cmat_cvec (calc_perpendicular_to_x_axis_cmat z) z \<and>
        is_poincare_line_cmat (calc_perpendicular_to_x_axis_cmat z) \<and>
        perpendicular_to_x_axis_cmat (calc_perpendicular_to_x_axis_cmat z)"
  proof (cases "z1*cnj z2 + z2*cnj z1 = 0")
    case True
    thus ?thesis
      using z
      by (simp add: vec_cnj_def hermitean_def mat_adj_def mat_cnj_def mult.commute)
  next
    case False
    hence "z2 \<noteq> 0"
      using z
      by auto
    hence "Re (z2 * cnj z2) \<noteq> 0"
      using \<open>z2 \<noteq> 0\<close>
      by (auto simp add: complex.expand)

    have "z1 \<noteq> -z2 \<and> z1 \<noteq> z2"
    proof (rule ccontr)
      assume "\<not> ?thesis"
      hence "z \<approx>\<^sub>v of_complex_cvec 1 \<or> z \<approx>\<^sub>v of_complex_cvec (-1)"
        using z \<open>z2 \<noteq> 0\<close>
        by auto
      thus False
        using **
        by auto
    qed

    let ?A = "z1*cnj z2 + z2*cnj z1" and ?B = "-(z1*cnj z1 + z2*cnj z2)"
    have "Re(z1*cnj z1 + z2*cnj z2) \<ge> 0"
      by auto
    hence "Re ?B \<le> 0"
      by (smt uminus_complex.simps(1))
    hence "abs (Re ?B) = - Re ?B"
      by auto
    also have "... = (Re z1)\<^sup>2 + (Im z1)\<^sup>2 + (Re z2)\<^sup>2 + (Im z2)\<^sup>2"
      by (simp add: power2_eq_square[symmetric])
    also have "... > abs (Re ?A)"
    proof (cases "Re ?A \<ge> 0")
      case False
      have "(Re z1 + Re z2)\<^sup>2 + (Im z1 + Im z2)\<^sup>2 > 0"
        using \<open>z1 \<noteq> -z2 \<and> z1 \<noteq> z2\<close>
        by (metis add.commute add.inverse_unique complex_neq_0 plus_complex.code plus_complex.simps)
      thus ?thesis
        using False
        by (simp add: power2_sum power2_eq_square field_simps)
    next
      case True
      have "(Re z1 - Re z2)\<^sup>2 + (Im z1 - Im z2)\<^sup>2 > 0"
        using \<open>z1 \<noteq> -z2 \<and> z1 \<noteq> z2\<close>
        by (meson complex_eq_iff right_minus_eq sum_power2_gt_zero_iff)
      thus ?thesis
        using True
        by (simp add: power2_sum power2_eq_square field_simps)
    qed
    finally
    have "abs (Re ?B) > abs (Re ?A)"
      .
    moreover
    have "cmod ?B = abs (Re ?B)" "cmod ?A = abs (Re ?A)"
      by (simp_all add: cmod_eq_Re)
    ultimately
    have "(cmod ?B)\<^sup>2 > (cmod ?A)\<^sup>2"
      by (smt power2_le_imp_le)
    thus ?thesis
      using z False
      by (simp_all add: Let_def hermitean_def mat_adj_def mat_cnj_def cmod_eq_Re vec_cnj_def field_simps)
  qed
qed

lemma ex_perpendicular:
  assumes "is_poincare_line H" "z \<in> unit_disc"
  shows "\<exists> H'. is_poincare_line H' \<and> perpendicular H H' \<and> z \<in> circline_set H'" (is "?P' H z")
proof-
  have "\<forall> z. z \<in> unit_disc \<longrightarrow> ?P' H z" (is "?P H")
  proof (rule wlog_line_x_axis)
    show "?P x_axis"
    proof safe
      fix z
      assume "z \<in> unit_disc"
      then have "z \<noteq> of_complex 1" "z \<noteq> of_complex (-1)"
        by auto
      thus "?P' x_axis z"
        using \<open>z \<in> unit_disc\<close>
        using calc_perpendicular_to_x_axis[of z] perpendicular_to_x_axis
        by (rule_tac x = "calc_perpendicular_to_x_axis z" in exI, auto)
    qed
  next
    fix M
    assume "unit_disc_fix M"
    assume *: "?P (moebius_circline M H)"
    show "?P H"
    proof safe
      fix z
      assume "z \<in> unit_disc"
      hence "moebius_pt M z \<in> unit_disc"
        using \<open>unit_disc_fix M\<close>
        by auto
      then obtain H' where *: "is_poincare_line H'" "perpendicular (moebius_circline M H) H'" "moebius_pt M z \<in> circline_set H'"
        using *
        by auto
      have h: "H = moebius_circline (-M) (moebius_circline M H)"
        by auto
      show "?P' H z"
        using * \<open>unit_disc_fix M\<close>
        apply (subst h)
        apply (rule_tac x="moebius_circline (-M) H'" in exI)
        apply (simp del: moebius_circline_comp_inv_left)
        done
    qed
  qed fact
  thus ?thesis
    using assms
    by simp
qed

lemma ex_perpendicular_foot:
  assumes "is_poincare_line H" "z \<in> unit_disc"
  shows "\<exists> H'. is_poincare_line H' \<and> z \<in> circline_set H' \<and> perpendicular H H' \<and>
              (\<exists> z' \<in> unit_disc. z' \<in> circline_set H' \<inter> circline_set H)"
  using assms
  using ex_perpendicular[OF assms]
  using perpendicular_intersects[of H]
  by blast

lemma Pythagoras:
  assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc" "v \<noteq> w"
  assumes "distinct[u, v, w] \<longrightarrow> perpendicular (poincare_line u v) (poincare_line u w)"
  shows "cosh (poincare_distance v w) = cosh (poincare_distance u v) * cosh (poincare_distance u w)" (is "?P' u v w")
proof (cases "distinct [u, v, w]")
  case False
  thus "?thesis"
    using in_disc
    by (auto simp add: poincare_distance_sym)
next
  case True
  have "distinct [u, v, w] \<longrightarrow> ?P' u v w" (is "?P u v w")
  proof (rule wlog_perpendicular_axes[where P="?P"])
    show "is_poincare_line (poincare_line u v)" "is_poincare_line (poincare_line u w)"
      using \<open>distinct [u, v, w]\<close>
      by simp_all
  next
    show "perpendicular (poincare_line u v) (poincare_line u w)"
      using True assms
      by simp
  next
    show "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
      by fact+
  next
    show "v \<in> circline_set (poincare_line u v)" "w \<in> circline_set (poincare_line u w)"
         "u \<in> circline_set (poincare_line u v) \<inter> circline_set (poincare_line u w)"
      using \<open>distinct [u, v, w]\<close>
      by auto
  next
    fix x y
    assume x: "is_real x" "0 \<le> Re x" "Re x < 1"
    assume y: "is_imag y" "0 \<le> Im y" "Im y < 1"

    have "of_complex x \<in> unit_disc" "of_complex y \<in> unit_disc"
      using x y
      by (simp_all add: cmod_eq_Re cmod_eq_Im)

    show "?P 0\<^sub>h (of_complex x) (of_complex y)"
    proof
      assume "distinct [0\<^sub>h, of_complex x, of_complex y]"
      hence "x \<noteq> 0" "y \<noteq> 0"
        by auto

      let ?den1 = "1 - (cmod x)\<^sup>2" and ?den2 = "1 - (cmod y)\<^sup>2"
      have "?den1 > 0" "?den2 > 0"
        using x y
        by (simp_all add: cmod_eq_Re cmod_eq_Im abs_square_less_1)

      let ?d1 = "1 + 2 * (cmod x)\<^sup>2 / ?den1"
      have "cosh (poincare_distance 0\<^sub>h (of_complex x)) = ?d1"
        using \<open>?den1 > 0\<close>
        using poincare_distance_formula[of "0\<^sub>h" "of_complex x"] \<open>of_complex x \<in> unit_disc\<close>
        by simp

      moreover

      let ?d2 = "1 + 2 * (cmod y)\<^sup>2 / ?den2"
      have "cosh (poincare_distance 0\<^sub>h (of_complex y)) = ?d2"
        using \<open>?den2 > 0\<close> \<open>of_complex y \<in> unit_disc\<close>
        using poincare_distance_formula[of "0\<^sub>h" "of_complex y"]
        by simp

      moreover
      let ?den = "?den1 * ?den2"
      let ?d3 = "1 + 2 * (cmod (x - y))\<^sup>2 / ?den"
      have "cosh (poincare_distance (of_complex x) (of_complex y)) = ?d3"
        using \<open>of_complex x \<in> unit_disc\<close> \<open>of_complex y \<in> unit_disc\<close>
        using \<open>?den1 > 0\<close> \<open>?den2 > 0\<close>
        using poincare_distance_formula[of "of_complex x" "of_complex y"]
        by simp
      moreover
      have "?d1 * ?d2 = ?d3"
      proof-
        have "?d3 = ((1 - (cmod x)\<^sup>2) * (1 - (cmod y)\<^sup>2) + 2 * (cmod (x - y))\<^sup>2) / ?den"
          using \<open>?den1 > 0\<close> \<open>?den2 > 0\<close>
          by (subst add_num_frac, simp, simp)
        also have "... = (Re ((1 - x * cnj x) * (1 - y * cnj y) + 2 * (x - y)*cnj (x - y)) / ?den)"
          using \<open>is_real x\<close> \<open>is_imag y\<close>
          by ((subst cmod_square)+, simp)
        also have "... = Re (1 + x * cnj x * y * cnj y
                               + x * cnj x - 2 * y * cnj x - 2 * x * cnj y + y * cnj y) / ?den"
          by (simp add: field_simps)
        also have "... = Re ((1 + y * cnj y) * (1 + x * cnj x)) / ?den"
          using \<open>is_real x\<close> \<open>is_imag y\<close>
          by (simp add: field_simps)
        finally
        show ?thesis
          using \<open>?den1 > 0\<close> \<open>?den2 > 0\<close>
          apply (subst add_num_frac, simp)
          apply (subst add_num_frac, simp)
          apply simp
          apply (subst cmod_square)+
          apply (simp add: field_simps)
          done
      qed
      ultimately
      show "?P' 0\<^sub>h (of_complex x) (of_complex y)"
        by simp
    qed
  next
    fix M u v w
    assume 1: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
    assume 2: "?P (moebius_pt M u) (moebius_pt M v) (moebius_pt M w)"
    show "?P u v w"
      using 1 2
      by auto
  next
    fix u v w
    assume 1:  "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
    assume 2: "?P (conjugate u) (conjugate v) (conjugate w)"
    show "?P u v w"
      using 1 2
      by (auto simp add: conjugate_inj)
  qed
  thus ?thesis
    using True
    by simp
qed

end


chapter \<open>Square Root Upper and Lower Bounds\<close>

theory Sqrt_Bounds
imports Bounds_Lemmas
        "HOL-Library.Sum_of_Squares"

begin

text\<open>Covers all bounds used in sqrt-upper.ax, sqrt-lower.ax and sqrt-extended.ax.\<close>

section\<open>Upper bounds\<close>

primrec sqrtu :: "[real,nat] \<Rightarrow> real" where
  "sqrtu x 0 = (x+1)/2"
| "sqrtu x (Suc n) = (sqrtu x n + x/sqrtu x n) / 2"

lemma sqrtu_upper: "x \<le> sqrtu x n ^ 2"
proof (induction n)
  case 0 show ?case
    apply (simp add: power2_eq_square)
    apply (sos "(((A<0 * R<1) + (R<1 * (R<1 * [~1*x + 1]^2))))")
    done
next
  case (Suc n)
  have xy: "\<And>y. \<lbrakk>x \<le> y * y; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * (2 * (y * y)) \<le> x * x + y * (y * (y * y))"
    by (sos "(((((A<0 * A<1) * R<1) + ((A<0 * R<1) * (R<1 * [~1*y^2 + x]^2)))) &
                   ((((A<0 * A<1) * R<1) + ((A<0 * R<1) * (R<1 * [~1*y^2 + x]^2)))))")
  show ?case using Suc
    by (auto simp: power2_eq_square algebra_simps divide_simps xy)
qed

lemma sqrtu_numeral:
  "sqrtu x (numeral n) = (sqrtu x (pred_numeral n) + x/sqrtu x (pred_numeral n)) / 2"
  by (simp add: numeral_eq_Suc)

lemma sqrtu_gt_0: "x \<ge> 0 \<Longrightarrow> sqrtu x n > 0"
apply (induct n)
apply (auto simp: field_simps)
by (metis add_strict_increasing2 mult_zero_left not_real_square_gt_zero)

theorem gen_sqrt_upper: "0 \<le> x \<Longrightarrow> sqrt x \<le> sqrtu x n"
using real_sqrt_le_mono [OF sqrtu_upper [of x n]]
by auto (metis abs_of_nonneg dual_order.strict_iff_order sqrtu_gt_0)

lemma sqrt_upper_bound_0:
  assumes "x \<ge> 0" shows "sqrt x \<le> (x+1)/2" (is "_ \<le> ?rhs")
proof -
  have "sqrt x \<le> sqrtu x 0"
    by (metis assms gen_sqrt_upper)
  also have "... = ?rhs"
    by (simp add: divide_simps)
  finally show ?thesis .
qed

lemma sqrt_upper_bound_1:
  assumes "x \<ge> 0" shows "sqrt x \<le> (1/4)*(x^2+6*x+1) / (x+1)" (is "_ \<le> ?rhs")
proof -
  have "sqrt x \<le> sqrtu x 1"
    by (metis assms gen_sqrt_upper)
  also have "... = ?rhs"
    by (simp add: divide_simps) algebra
  finally show ?thesis .
qed

lemma sqrtu_2_eq:
   "sqrtu x 2 = (1/8)*(x^4 + 28*x^3 + 70*x^2 + 28*x + 1) / ((x + 1)*(x^2 + 6*x + 1))"
  by (simp add: sqrtu_numeral divide_simps) algebra

lemma sqrt_upper_bound_2:
  assumes "x \<ge> 0"
    shows "sqrt x \<le> (1/8)*(x^4 + 28*x^3 + 70*x^2 + 28*x + 1) / ((x + 1)*(x^2 + 6*x + 1))"
  by (metis assms gen_sqrt_upper sqrtu_2_eq)

lemma sqrtu_4_eq:
   "x \<ge> 0 \<Longrightarrow>
    sqrtu x 4 = (1/32)*(225792840*x^6+64512240*x^5+601080390*x^8+471435600*x^7+496*x+1+35960*x^2+906192*x^3+10518300*x^4+x^16+906192*x^13+10518300*x^12+496*x^15+35960*x^14+471435600*x^9+225792840*x^10+64512240*x^11)
             / ((x+1)*(x^2+6*x+1)*(x^4+28*x^3+70*x^2+28*x+1)*(1820*x^6+8008*x^5+x^8+120*x^7+120*x+1+1820*x^2+8008*x^3+12870*x^4))"
  by (simp add: sqrtu_numeral divide_simps add_nonneg_eq_0_iff) algebra

lemma sqrt_upper_bound_4:
  assumes "x \<ge> 0"
    shows "sqrt x \<le> (1/32)*(225792840*x^6+64512240*x^5+601080390*x^8+471435600*x^7+496*x+1+35960*x^2+906192*x^3+10518300*x^4+x^16+906192*x^13+10518300*x^12+496*x^15+35960*x^14+471435600*x^9+225792840*x^10+64512240*x^11)
             / ((x+1)*(x^2+6*x+1)*(x^4+28*x^3+70*x^2+28*x+1)*(1820*x^6+8008*x^5+x^8+120*x^7+120*x+1+1820*x^2+8008*x^3+12870*x^4))"
  by (metis assms gen_sqrt_upper sqrtu_4_eq)

lemma gen_sqrt_upper_scaled:
  assumes "0 \<le> x" "0 < u"
    shows "sqrt x \<le> sqrtu (x*u^2) n / u"
proof -
  have "sqrt x = sqrt x * sqrt (u^2) / u"
    using assms
    by simp
  also have "... = sqrt (x*u^2) / u"
    by (metis real_sqrt_mult)
  also have "... \<le> sqrtu (x*u^2) n / u"
    using assms
    by (simp add: divide_simps) (metis gen_sqrt_upper zero_le_mult_iff zero_le_power2)
  finally show ?thesis .
qed

lemma sqrt_upper_bound_2_small:
  assumes "0 \<le> x"
    shows "sqrt x \<le> (1/32)*(65536*x^4 + 114688*x^3 + 17920*x^2 + 448*x + 1) / ((16*x + 1)*(256*x^2 + 96*x + 1))"
apply (rule order_trans [OF gen_sqrt_upper_scaled [of x 4 2] eq_refl])
using assms
apply (auto simp: sqrtu_2_eq )
apply (simp add: divide_simps)
apply algebra
done

lemma sqrt_upper_bound_2_large:
  assumes "0 \<le> x"
    shows "sqrt x \<le> (1/32)*(65536 + 114688*x + 17920*x^2 + 448*x^3 + x^4) / ((x + 16)*(256 + 96*x + x^2))"
apply (rule order_trans [OF gen_sqrt_upper_scaled [of x "1/4" 2] eq_refl])
using assms
apply (auto simp: sqrtu_2_eq )
apply (simp add: divide_simps)
apply algebra
done

section\<open>Lower bounds\<close>

lemma sqrt_lower_bound_id:
  assumes "0 \<le> x" "x \<le> 1"
    shows "x \<le> sqrt x"
proof -
  have "x^2 \<le> x" using assms
    by (metis one_le_numeral power_decreasing power_one_right)
  then show ?thesis
    by (metis real_le_rsqrt)
qed

definition sqrtl :: "[real,nat] \<Rightarrow> real" where
  "sqrtl x n = x/sqrtu x n"

lemma sqrtl_lower: "0 \<le> x \<Longrightarrow> sqrtl x n ^ 2 \<le> x"
  unfolding sqrtl_def using sqrtu_upper [of x n]
  by (auto simp: power2_eq_square divide_simps mult_left_mono)

theorem gen_sqrt_lower:  "0 \<le> x \<Longrightarrow> sqrtl x n \<le> sqrt x"
using real_sqrt_le_mono [OF sqrtl_lower [of x n]]
by auto

lemma sqrt_lower_bound_0:
  assumes "x \<ge> 0" shows "2*x/(x+1) \<le> sqrt x" (is "?lhs \<le> _")
proof -
  have "?lhs = sqrtl x 0"
    by (simp add: sqrtl_def)
  also have "... \<le> sqrt x"
    by (metis assms gen_sqrt_lower)
  finally show ?thesis .
qed

lemma sqrt_lower_bound_1:
  assumes "x \<ge> 0" shows "4*x*(x+1) / (x^2+6*x+1) \<le> sqrt x" (is "?lhs \<le> _")
proof -
  have "?lhs = sqrtl x 1" using assms
    by (simp add: sqrtl_def power_eq_if algebra_simps divide_simps)
  also have "... \<le> sqrt x"
    by (metis assms gen_sqrt_lower)
  finally show ?thesis .
qed

lemma sqrt_lower_bound_2:
  assumes "x \<ge> 0"
    shows "8*x*(x + 1)*(x^2 + 6*x + 1) / (x^4 + 28*x^3 + 70*x^2 + 28*x + 1) \<le> sqrt x"
  by (metis assms sqrtl_2_eq gen_sqrt_lower)

lemma sqrtl_4_eq: "x \<ge> 0 \<Longrightarrow>
  sqrtl x 4
    = (32*x*(x+1)*(x^2+6*x+1)*(x^4+28*x^3+70*x^2+28*x+1)*(1820*x^6+8008*x^5+x^8+120*x^7+120*x+1+1820*x^2+8008*x^3+12870*x^4))
    / (225792840*x^6+64512240*x^5+601080390*x^8+471435600*x^7+496*x+1+35960*x^2+906192*x^3+10518300*x^4+x^16+906192*x^13+10518300*x^12+496*x^15+35960*x^14+471435600*x^9+225792840*x^10+64512240*x^11)"
  using sqrtu_gt_0 [of x 4]
  by (simp add: sqrtl_def sqrtu_4_eq)

lemma sqrt_lower_bound_4:
  assumes "x \<ge> 0"
    shows "(32*x*(x+1)*(x^2+6*x+1)*(x^4+28*x^3+70*x^2+28*x+1)*(1820*x^6+8008*x^5+x^8+120*x^7+120*x+1+1820*x^2+8008*x^3+12870*x^4))
           / (225792840*x^6+64512240*x^5+601080390*x^8+471435600*x^7+496*x+1+35960*x^2+906192*x^3+10518300*x^4+x^16+906192*x^13+10518300*x^12+496*x^15+35960*x^14+471435600*x^9+225792840*x^10+64512240*x^11)
           \<le> sqrt x"
  by (metis assms sqrtl_4_eq gen_sqrt_lower)

lemma gen_sqrt_lower_scaled:
  assumes "0 \<le> x" "0 < u"
    shows "sqrtl (x*u^2) n / u \<le> sqrt x"
proof -
  have "sqrtl (x*u^2) n / u \<le> sqrt (x*u^2) / u"
    using assms
    by (simp add: divide_simps) (metis gen_sqrt_lower zero_le_mult_iff zero_le_power2)
  also have "... = sqrt x * sqrt (u^2) / u"
    by (metis real_sqrt_mult)
  also have "... = sqrt x"
    using assms
    by simp
  finally show ?thesis .
qed

lemma sqrt_lower_bound_2_small:
  assumes "0 \<le> x"
    shows "32*x*(16*x + 1)*(256*x^2 + 96*x + 1) / (65536*x^4 + 114688*x^3 + 17920*x^2 + 448*x + 1) \<le> sqrt x"
apply (rule order_trans [OF eq_refl gen_sqrt_lower_scaled [of x 4 2]])
using assms
apply (auto simp: sqrtl_2_eq )
apply (simp add: divide_simps)
apply algebra
done

lemma sqrt_lower_bound_2_large:
  assumes "0 \<le> x"
    shows "32*x*(x + 16)*(x^2 + 96*x + 256) / (x^4 + 448*x^3 + 17920*x^2 + 114688*x + 65536) \<le> sqrt x"
apply (rule order_trans [OF eq_refl gen_sqrt_lower_scaled [of x "1/4" 2]])
using assms
apply (auto simp: sqrtl_2_eq)
apply (simp add: divide_simps)
done

end


(*  Title:      HOL/Algebra/Sym_Groups.thy
    Author:     Paulo Emílio de Vilhena
*)

theory Sym_Groups
  imports Cycles Solvable_Groups

begin

section \<open>Symmetric Groups\<close>

subsection \<open>Definitions\<close>

abbreviation inv' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a)"
  where "inv' f \<equiv> Hilbert_Choice.inv f"

definition sym_group :: "nat \<Rightarrow> (nat \<Rightarrow> nat) monoid"
  where "sym_group n = \<lparr> carrier = { p. p permutes {1..n} }, mult = (\<circ>), one = id \<rparr>"

definition alt_group :: "nat \<Rightarrow> (nat \<Rightarrow> nat) monoid"
  where "alt_group n = (sym_group n) \<lparr> carrier := { p. p permutes {1..n} \<and> evenperm p } \<rparr>"

definition sign_img :: "int monoid"
  where "sign_img = \<lparr> carrier = { -1, 1 }, mult = (*), one = 1 \<rparr>"

subsection \<open>Basic Properties\<close>

lemma sym_group_carrier: "p \<in> carrier (sym_group n) \<longleftrightarrow> p permutes {1..n}"
  unfolding sym_group_def by simp

lemma sym_group_mult: "mult (sym_group n) = (\<circ>)"
  unfolding sym_group_def by simp

lemma sym_group_one: "one (sym_group n) = id"
  unfolding sym_group_def by simp

lemma sym_group_carrier': "p \<in> carrier (sym_group n) \<Longrightarrow> permutation p"
  unfolding sym_group_carrier permutation_permutes by auto

lemma alt_group_carrier: "p \<in> carrier (alt_group n) \<longleftrightarrow> p permutes {1..n} \<and> evenperm p"
  unfolding alt_group_def by auto

lemma alt_group_mult: "mult (alt_group n) = (\<circ>)"
  unfolding alt_group_def using sym_group_mult by simp

lemma alt_group_one: "one (alt_group n) = id"
  unfolding alt_group_def using sym_group_one by simp

lemma alt_group_carrier': "p \<in> carrier (alt_group n) \<Longrightarrow> permutation p"
  unfolding alt_group_carrier permutation_permutes by auto

lemma sym_group_is_group: "group (sym_group n)"
  using permutes_inv permutes_inv_o(2)
  by (auto intro!: groupI
         simp add: sym_group_def permutes_compose
                   permutes_id comp_assoc, blast)

lemma sign_img_is_group: "group sign_img"
  unfolding sign_img_def by (unfold_locales, auto simp add: Units_def)

lemma sym_group_inv_closed:
  assumes "p \<in> carrier (sym_group n)" shows "inv' p \<in> carrier (sym_group n)"
  using assms permutes_inv sym_group_def by auto

lemma alt_group_inv_closed:
  assumes "p \<in> carrier (alt_group n)" shows "inv' p \<in> carrier (alt_group n)"
  using evenperm_inv[OF alt_group_carrier'] permutes_inv assms alt_group_carrier by auto

lemma sym_group_inv_equality [simp]:
  assumes "p \<in> carrier (sym_group n)" shows "inv\<^bsub>(sym_group n)\<^esub> p = inv' p"
proof -
  have "inv' p \<circ> p = id"
    using assms permutes_inv_o(2) sym_group_def by auto
  hence "(inv' p) \<otimes>\<^bsub>(sym_group n)\<^esub> p = one (sym_group n)"
    by (simp add: sym_group_def)
  thus ?thesis  using group.inv_equality[OF sym_group_is_group]
    by (simp add: assms sym_group_inv_closed)
qed

lemma sign_is_hom: "sign \<in> hom (sym_group n) sign_img"
  unfolding hom_def sign_img_def sym_group_mult using sym_group_carrier'[of _ n]
  by (auto simp add: sign_compose, meson sign_def)

lemma sign_group_hom: "group_hom (sym_group n) sign_img sign"
  using group_hom.intro[OF sym_group_is_group sign_img_is_group] sign_is_hom
  by (simp add: group_hom_axioms_def)

lemma sign_is_surj:
  assumes "n \<ge> 2" shows "sign ` (carrier (sym_group n)) = carrier sign_img"
proof -
  have "swapidseq (Suc 0) (Fun.swap (1 :: nat) 2 id)"
    using comp_Suc[OF id, of "1 :: nat" "2"] by auto
  hence "sign (Fun.swap (1 :: nat) 2 id) = (-1 :: int)"
    by (simp add: sign_swap_id)
  moreover have "Fun.swap (1 :: nat) 2 id \<in> carrier (sym_group n)" and "id \<in> carrier (sym_group n)"
    using assms permutes_swap_id[of "1 :: nat" "{1..n}" 2] permutes_id
    unfolding sym_group_carrier by auto
  ultimately have "carrier sign_img \<subseteq> sign ` (carrier (sym_group n))"
    using sign_id mk_disjoint_insert unfolding sign_img_def by fastforce
  moreover have "sign ` (carrier (sym_group n)) \<subseteq> carrier sign_img"
    using sign_is_hom unfolding hom_def by auto
  ultimately show ?thesis
    by blast
qed

lemma alt_group_is_sign_kernel:
  "carrier (alt_group n) = kernel (sym_group n) sign_img sign"
  unfolding alt_group_def sym_group_def sign_img_def kernel_def sign_def by auto

lemma alt_group_is_subgroup: "subgroup (carrier (alt_group n)) (sym_group n)"
  using group_hom.subgroup_kernel[OF sign_group_hom]
  unfolding alt_group_is_sign_kernel by blast

lemma alt_group_is_group: "group (alt_group n)"
  using group.subgroup_imp_group[OF sym_group_is_group alt_group_is_subgroup]
  by (simp add: alt_group_def)

lemma sign_iso:
  assumes "n \<ge> 2" shows "(sym_group n) Mod (carrier (alt_group n)) \<cong> sign_img"
  using group_hom.FactGroup_iso[OF sign_group_hom sign_is_surj[OF assms]]
  unfolding alt_group_is_sign_kernel .

lemma alt_group_inv_equality:
  assumes "p \<in> carrier (alt_group n)" shows "inv\<^bsub>(alt_group n)\<^esub> p = inv' p"
proof -
  have "inv' p \<circ> p = id"
    using assms permutes_inv_o(2) alt_group_def by auto
  hence "(inv' p) \<otimes>\<^bsub>(alt_group n)\<^esub> p = one (alt_group n)"
    by (simp add: alt_group_def sym_group_def)
  thus ?thesis  using group.inv_equality[OF alt_group_is_group]
    by (simp add: assms alt_group_inv_closed)
qed

lemma sym_group_card_carrier: "card (carrier (sym_group n)) = fact n"
  using card_permutations[of "{1..n}" n] unfolding sym_group_def by simp

lemma alt_group_card_carrier:
  assumes "n \<ge> 2" shows "2 * card (carrier (alt_group n)) = fact n"
proof -
  have "card (rcosets\<^bsub>sym_group n\<^esub> (carrier (alt_group n))) = 2"
    using iso_same_card[OF sign_iso[OF assms]] unfolding FactGroup_def sign_img_def by auto
  thus ?thesis
    using group.lagrange[OF sym_group_is_group alt_group_is_subgroup, of n]
    unfolding order_def sym_group_card_carrier by simp
qed

subsection \<open>Transposition Sequences\<close>

text \<open>In order to prove that the Alternating Group can be generated by 3-cycles, we need
      a stronger decomposition of permutations as transposition sequences than the one
      proposed at Permutations.thy. \<close>

inductive swapidseq_ext :: "'a set \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where
    empty:  "swapidseq_ext {} 0 id"
  | single: "\<lbrakk> swapidseq_ext S n p; a \<notin> S \<rbrakk> \<Longrightarrow> swapidseq_ext (insert a S) n p"
  | comp:   "\<lbrakk> swapidseq_ext S n p; a \<noteq> b \<rbrakk> \<Longrightarrow>
               swapidseq_ext (insert a (insert b S)) (Suc n) ((Fun.swap a b id) \<circ> p)"

lemma swapidseq_ext_finite:
  assumes "swapidseq_ext S n p" shows "finite S"
  using assms by (induction) (auto)

lemma swapidseq_ext_zero:
  assumes "finite S" shows "swapidseq_ext S 0 id"
  using assms empty by (induct set: "finite", fastforce, simp add: single)

lemma swapidseq_ext_imp_swapidseq:
  assumes "swapidseq_ext S n p" shows "swapidseq n p"
  using assms by (induction, simp, simp, meson comp_Suc)

lemma swapidseq_ext_zero_imp_id:
  assumes "swapidseq_ext S 0 p" shows "p = id"
proof -
  have "\<lbrakk> swapidseq_ext S n p; n = 0 \<rbrakk> \<Longrightarrow> p = id" for n
    by (induction rule: swapidseq_ext.induct, auto)
  thus ?thesis
    using assms by simp
qed

lemma swapidseq_ext_finite_expansion:
  assumes "finite B" and "swapidseq_ext A n p" shows "swapidseq_ext (A \<union> B) n p"
  using assms
proof (induct set: "finite", simp)
  case (insert b B) show ?case
    using insert single[OF insert(3), of b] by (metis Un_insert_right insert_absorb)
qed

lemma swapidseq_ext_backwards:
  assumes "swapidseq_ext A (Suc n) p"
  shows "\<exists>a b A' p'. a \<noteq> b \<and> A = (insert a (insert b A')) \<and>
                     swapidseq_ext A' n p' \<and> p = (Fun.swap a b id) \<circ> p'"
proof -
  { fix A n k and p :: "'a \<Rightarrow> 'a"
    assume "swapidseq_ext A n p" "n = Suc k"
    hence "\<exists>a b A' p'. a \<noteq> b \<and> A = (insert a (insert b A')) \<and>
                       swapidseq_ext A' k p' \<and> p = (Fun.swap a b id) \<circ> p'"
    proof (induction, simp)
      case single thus ?case
        by (metis Un_insert_right insert_iff insert_is_Un swapidseq_ext.single)
    next
      case comp thus ?case
        by blast
    qed }
  thus ?thesis
    using assms by simp
qed

lemma swapidseq_ext_backwards':
  assumes "swapidseq_ext A (Suc n) p"
  shows "\<exists>a b A' p'. a \<in> A \<and> b \<in> A \<and> a \<noteq> b \<and> swapidseq_ext A n p' \<and> p = (Fun.swap a b id) \<circ> p'"
  using swapidseq_ext_backwards[OF assms] swapidseq_ext_finite_expansion
  by (metis Un_insert_left assms insertI1 sup.idem sup_commute swapidseq_ext_finite)

lemma swapidseq_ext_endswap:
  assumes "swapidseq_ext S n p" "a \<noteq> b"
  shows "swapidseq_ext (insert a (insert b S)) (Suc n) (p \<circ> (Fun.swap a b id))"
  using assms
proof (induction n arbitrary: S p a b)
  case 0 hence "p = id"
    using swapidseq_ext_zero_imp_id by blast
  thus ?case
    using 0 by (metis comp_id id_comp swapidseq_ext.comp)
next
  case (Suc n)
  then obtain c d S' and p' :: "'a \<Rightarrow> 'a"
    where cd: "c \<noteq> d" and S: "S = (insert c (insert d S'))" "swapidseq_ext S' n p'"
      and p: "p = (Fun.swap c d id) \<circ> p'"
    using swapidseq_ext_backwards[OF Suc(2)] by blast
  hence "swapidseq_ext (insert a (insert b S')) (Suc n) (p' \<circ> (Fun.swap a b id))"
    by (simp add: Suc.IH Suc.prems(2))
  hence "swapidseq_ext (insert c (insert d (insert a (insert b S')))) (Suc (Suc n))
                 ((Fun.swap c d id) \<circ> p' \<circ> (Fun.swap a b id))"
    by (metis cd fun.map_comp swapidseq_ext.comp)
  thus ?case
    by (metis S(1) p insert_commute)
qed

lemma swapidseq_ext_extension:
  assumes "swapidseq_ext A n p" and "swapidseq_ext B m q" and "A \<inter> B = {}"
  shows "swapidseq_ext (A \<union> B) (n + m) (p \<circ> q)"
  using assms(1,3)
proof (induction, simp add: assms(2))
  case single show ?case
    using swapidseq_ext.single[OF single(3)] single(2,4) by auto
next
  case comp show ?case
    using swapidseq_ext.comp[OF comp(3,2)] comp(4)
    by (metis Un_insert_left add_Suc insert_disjoint(1) o_assoc)
qed

lemma swapidseq_ext_of_cycles:
  assumes "cycle cs" shows "swapidseq_ext (set cs) (length cs - 1) (cycle_of_list cs)"
  using assms
proof (induct cs rule: cycle_of_list.induct)
  case (1 i j cs) show ?case
    using comp[OF 1(1), of i j] 1(2) by (simp add: o_def)
next
  case "2_1" show ?case
    by (simp, metis eq_id_iff empty)
next
  case ("2_2" v) show ?case
    using single[OF empty, of v] by (simp, metis eq_id_iff)
qed

lemma cycle_decomp_imp_swapidseq_ext:
  assumes "cycle_decomp S p" shows "\<exists>n. swapidseq_ext S n p"
  using assms
proof (induction)
  case empty show ?case
    using swapidseq_ext.empty by blast
next
  case (comp I p cs)
  then obtain m where m: "swapidseq_ext I m p" by blast
  hence "swapidseq_ext (set cs) (length cs - 1) (cycle_of_list cs)"
    using comp.hyps(2) swapidseq_ext_of_cycles by blast
  thus ?case using swapidseq_ext_extension m
    using comp.hyps(3) by blast
qed

lemma swapidseq_ext_of_permutation:
  assumes "p permutes S" and "finite S" shows "\<exists>n. swapidseq_ext S n p"
  using cycle_decomp_imp_swapidseq_ext[OF cycle_decomposition[OF assms]] .

lemma split_swapidseq_ext:
  assumes "k \<le> n" and "swapidseq_ext S n p"
  obtains q r U V where "swapidseq_ext U (n - k) q" and "swapidseq_ext V k r" and "p = q \<circ> r" and "U \<union> V = S"
proof -
  from assms
  have "\<exists>q r U V. swapidseq_ext U (n - k) q \<and> swapidseq_ext V k r \<and> p = q \<circ> r \<and> U \<union> V = S"
   (is "\<exists>q r U V. ?split k q r U V")
  proof (induct k rule: inc_induct)
    case base thus ?case
      by (metis diff_self_eq_0 id_o sup_bot.left_neutral empty)
  next
    case (step m)
    then obtain q r U V
      where q: "swapidseq_ext U (n - Suc m) q" and r: "swapidseq_ext V (Suc m) r"
        and p: "p = q \<circ> r" and S: "U \<union> V = S"
      by blast
    obtain a b r' V'
      where "a \<noteq> b" and r': "V = (insert a (insert b V'))" "swapidseq_ext V' m r'" "r = (Fun.swap a b id) \<circ> r'"
      using swapidseq_ext_backwards[OF r] by blast
    have "swapidseq_ext (insert a (insert b U)) (n - m) (q \<circ> (Fun.swap a b id))"
      using swapidseq_ext_endswap[OF q \<open>a \<noteq> b\<close>] step(2) by (metis Suc_diff_Suc)
    hence "?split m (q \<circ> (Fun.swap a b id)) r' (insert a (insert b U)) V'"
      using r' S unfolding p by fastforce
    thus ?case by blast
  qed
  thus ?thesis
    using that by blast
qed

subsection \<open>Unsolvability of Symmetric Groups\<close>

text \<open>We show that symmetric groups (\<^term>\<open>sym_group n\<close>) are unsolvable for \<^term>\<open>n \<ge> 5\<close>.\<close>

abbreviation three_cycles :: "nat \<Rightarrow> (nat \<Rightarrow> nat) set"
  where "three_cycles n \<equiv>
           { cycle_of_list cs | cs. cycle cs \<and> length cs = 3 \<and> set cs \<subseteq> {1..n} }"

lemma stupid_lemma:
  assumes "length cs = 3" shows "cs = [ (cs ! 0), (cs ! 1), (cs ! 2) ]"
  using assms by (auto intro!: nth_equalityI)
    (metis Suc_lessI less_2_cases not_less_eq nth_Cons_0
           nth_Cons_Suc numeral_2_eq_2 numeral_3_eq_3)

lemma three_cycles_incl: "three_cycles n \<subseteq> carrier (alt_group n)"
proof
  fix p assume "p \<in> three_cycles n"
  then obtain cs where cs: "p = cycle_of_list cs" "cycle cs" "length cs = 3" "set cs \<subseteq> {1..n}"
    by auto
  obtain a b c where cs_def: "cs = [ a, b, c ]"
    using stupid_lemma[OF cs(3)] by auto
  have "swapidseq (Suc (Suc 0)) ((Fun.swap a b id) \<circ> (Fun.swap b c id))"
    using comp_Suc[OF comp_Suc[OF id], of b c a b] cs(2) unfolding cs_def by simp
  hence "evenperm p"
    using cs(1) unfolding cs_def by (simp add: evenperm_unique)
  thus "p \<in> carrier (alt_group n)"
    using permutes_subset[OF cycle_permutes cs(4)]
    unfolding alt_group_carrier cs(1) by simp
qed

lemma alt_group_carrier_as_three_cycles:
  "carrier (alt_group n) = generate (alt_group n) (three_cycles n)"
proof -
  interpret A: group "alt_group n"
    using alt_group_is_group by simp

  show ?thesis
  proof
    show "generate (alt_group n) (three_cycles n) \<subseteq> carrier (alt_group n)"
      using A.generate_subgroup_incl[OF three_cycles_incl A.subgroup_self] .
  next
    show "carrier (alt_group n) \<subseteq> generate (alt_group n) (three_cycles n)"
    proof
      { fix q :: "nat \<Rightarrow> nat" and a b c
        assume "a \<noteq> b" "b \<noteq> c" "{ a, b, c } \<subseteq> {1..n}"
        have "cycle_of_list [a, b, c] \<in> generate (alt_group n) (three_cycles n)"
        proof (cases)
          assume "c = a"
          hence "cycle_of_list [ a, b, c ] = id"
            by (simp add: swap_commute)
          thus "cycle_of_list [ a, b, c ] \<in> generate (alt_group n) (three_cycles n)"
            using one[of "alt_group n"] unfolding alt_group_one by simp
        next
          assume "c \<noteq> a"
          have "distinct [a, b, c]"
            using \<open>a \<noteq> b\<close> and \<open>b \<noteq> c\<close> and \<open>c \<noteq> a\<close> by auto
          with \<open>{ a, b, c } \<subseteq> {1..n}\<close>
          show "cycle_of_list [ a, b, c ] \<in> generate (alt_group n) (three_cycles n)"
            by (intro incl, fastforce)
        qed } note aux_lemma1 = this

      { fix S :: "nat set" and q :: "nat \<Rightarrow> nat"
        assume seq: "swapidseq_ext S (Suc (Suc 0)) q" and S: "S \<subseteq> {1..n}"
        have "q \<in> generate (alt_group n) (three_cycles n)"
        proof -
          obtain a b q' where ab: "a \<noteq> b" "a \<in> S" "b \<in> S"
            and q': "swapidseq_ext S (Suc 0) q'" "q = (Fun.swap a b id) \<circ> q'"
            using swapidseq_ext_backwards'[OF seq] by auto
          obtain c d where cd: "c \<noteq> d" "c \<in> S" "d \<in> S"
            and q: "q = (Fun.swap a b id) \<circ> (Fun.swap c d id)"
            using swapidseq_ext_backwards'[OF q'(1)]
                  swapidseq_ext_zero_imp_id
            unfolding q'(2)
            by fastforce

          consider (eq) "b = c" | (ineq) "b \<noteq> c" by auto
          thus ?thesis
          proof cases
            case eq then have "q = cycle_of_list [ a, b, d ]"
              unfolding q by simp
            moreover have "{ a, b, d } \<subseteq> {1..n}"
              using ab cd S by blast
            ultimately show ?thesis
              using aux_lemma1[OF ab(1)] cd(1) eq by simp
          next
            case ineq
            hence "q = cycle_of_list [ a, b, c ] \<circ> cycle_of_list [ b, c, d ]"
              unfolding q by (simp add: comp_swap)
            moreover have "{ a, b, c } \<subseteq> {1..n}" and "{ b, c, d } \<subseteq> {1..n}"
              using ab cd S by blast+
            ultimately show ?thesis
              using eng[OF aux_lemma1[OF ab(1) ineq] aux_lemma1[OF ineq cd(1)]]
              unfolding alt_group_mult by simp
          qed
        qed } note aux_lemma2 = this

      fix p assume "p \<in> carrier (alt_group n)" then have p: "p permutes {1..n}" "evenperm p"
        unfolding alt_group_carrier by auto
      obtain m where m: "swapidseq_ext {1..n} m p"
        using swapidseq_ext_of_permutation[OF p(1)] by auto
      have "even m"
        using swapidseq_ext_imp_swapidseq[OF m] p(2) evenperm_unique by blast
      then obtain k where k: "m = 2 * k"
        by auto
      show "p \<in> generate (alt_group n) (three_cycles n)"
        using m unfolding k
      proof (induct k arbitrary: p)
        case 0 then have "p = id"
          using swapidseq_ext_zero_imp_id by simp
        show ?case
          using generate.one[of "alt_group n" "three_cycles n"]
          unfolding alt_group_one \<open>p = id\<close> .
      next
        case (Suc m)
        have arith: "2 * (Suc m) - (Suc (Suc 0)) = 2 * m" and "Suc (Suc 0) \<le> 2 * Suc m"
          by auto
        then obtain q r U V
          where q: "swapidseq_ext U (2 * m) q" and r: "swapidseq_ext V (Suc (Suc 0)) r"
            and p: "p = q \<circ> r" and UV: "U \<union> V = {1..n}"
          using split_swapidseq_ext[OF _ Suc(2), of "Suc (Suc 0)"] unfolding arith by metis
        have "swapidseq_ext {1..n} (2 * m) q"
          using UV q swapidseq_ext_finite_expansion[OF swapidseq_ext_finite[OF r] q] by simp
        thus ?case
          using eng[OF Suc(1) aux_lemma2[OF r], of q] UV unfolding alt_group_mult p by blast
      qed
    qed
  qed
qed

theorem derived_alt_group_const:
  assumes "n \<ge> 5" shows "derived (alt_group n) (carrier (alt_group n)) = carrier (alt_group n)"
proof
  show "derived (alt_group n) (carrier (alt_group n)) \<subseteq> carrier (alt_group n)"
    using group.derived_in_carrier[OF alt_group_is_group] by simp
next
  { fix p assume "p \<in> three_cycles n" have "p \<in> derived (alt_group n) (carrier (alt_group n))"
    proof -
      obtain cs where cs: "p = cycle_of_list cs" "cycle cs" "length cs = 3" "set cs \<subseteq> {1..n}"
        using \<open>p \<in> three_cycles n\<close> by auto
      then obtain a b c where cs_def: "cs = [ a, b, c ]"
        using stupid_lemma[OF cs(3)] by blast
      have "card (set cs) = 3"
        using cs(2-3)
        by (simp add: distinct_card)

      have "set cs \<noteq> {1..n}"
        using assms cs(3) unfolding sym[OF distinct_card[OF cs(2)]] by auto
      then obtain d where d: "d \<notin> set cs" "d \<in> {1..n}"
        using cs(4) by blast

      hence "cycle (d # cs)" and "length (d # cs) = 4" and "card {1..n} = n"
        using cs(2-3) by auto
      hence "set (d # cs) \<noteq> {1..n}"
        using assms unfolding sym[OF distinct_card[OF \<open>cycle (d # cs)\<close>]]
        by (metis Suc_n_not_le_n eval_nat_numeral(3))
      then obtain e where e: "e \<notin> set (d # cs)" "e \<in> {1..n}"
        using d cs(4) by (metis insert_subset list.simps(15) subsetI subset_antisym)

      define q where "q = (Fun.swap d e id) \<circ> (Fun.swap b c id)"
      hence "bij q"
        by (simp add: bij_comp)
      moreover have "q b = c" and "q c = b"
        using d(1) e(1) unfolding q_def cs_def by simp+
      moreover have "q a = a"
        using d(1) e(1) cs(2) unfolding q_def cs_def by auto
      ultimately have "q \<circ> p \<circ> (inv' q) = cycle_of_list [ a, c, b ]"
        using conjugation_of_cycle[OF cs(2), of q]
        unfolding sym[OF cs(1)] unfolding cs_def by simp
      also have " ... = p \<circ> p"
        using cs(2) unfolding cs(1) cs_def
        by (auto, metis comp_id comp_swap swap_commute swap_triple)
      finally have "q \<circ> p \<circ> (inv' q) = p \<circ> p" .
      moreover have "bij p"
        unfolding cs(1) cs_def by (simp add: bij_comp)
      ultimately have p: "q \<circ> p \<circ> (inv' q) \<circ> (inv' p) = p"
        by (simp add: bijection.intro bijection.inv_comp_right comp_assoc)

      have "swapidseq (Suc (Suc 0)) q"
        using comp_Suc[OF comp_Suc[OF id], of b c d e] e(1) cs(2)  unfolding q_def cs_def by auto
      hence "evenperm q"
        using even_Suc_Suc_iff evenperm_unique by blast
      moreover have "q permutes { d, e, b, c }"
        unfolding q_def by (simp add: permutes_compose permutes_swap_id)
      hence "q permutes {1..n}"
        using cs(4) d(2) e(2) permutes_subset unfolding cs_def by fastforce
      ultimately have "q \<in> carrier (alt_group n)"
        unfolding alt_group_carrier by simp
      moreover have "p \<in> carrier (alt_group n)"
        using \<open>p \<in> three_cycles n\<close> three_cycles_incl by blast
      ultimately have "p \<in> derived_set (alt_group n) (carrier (alt_group n))"
        using p alt_group_inv_equality unfolding alt_group_mult
        by (metis (no_types, lifting) UN_iff singletonI)
      thus "p \<in> derived (alt_group n) (carrier (alt_group n))"
        unfolding derived_def by (rule incl)
    qed } note aux_lemma = this

  interpret A: group "alt_group n"
    using alt_group_is_group .

  have "generate (alt_group n) (three_cycles n) \<subseteq> derived (alt_group n) (carrier (alt_group n))"
    using A.generate_subgroup_incl[OF _ A.derived_is_subgroup] aux_lemma by (meson subsetI)
  thus "carrier (alt_group n) \<subseteq> derived (alt_group n) (carrier (alt_group n))"
    using alt_group_carrier_as_three_cycles by simp
qed

corollary alt_group_is_unsolvable:
  assumes "n \<ge> 5" shows "\<not> solvable (alt_group n)"
proof (rule ccontr)
  assume "\<not> \<not> solvable (alt_group n)"
  then obtain m where "(derived (alt_group n) ^^ m) (carrier (alt_group n)) = { id }"
    using group.solvable_iff_trivial_derived_seq[OF alt_group_is_group] unfolding alt_group_one by blast
  moreover have "(derived (alt_group n) ^^ m) (carrier (alt_group n)) = carrier (alt_group n)"
    using derived_alt_group_const[OF assms] by (induct m) (auto)
  ultimately have card_eq_1: "card (carrier (alt_group n)) = 1"
    by simp
  have ge_2: "n \<ge> 2"
    using assms by simp
  moreover have "2 = fact n"
    using alt_group_card_carrier[OF ge_2] unfolding card_eq_1
    by (metis fact_2 mult.right_neutral of_nat_fact)
  ultimately have "n = 2"
      by (metis antisym_conv fact_ge_self)
  thus False
    using assms by simp
qed

corollary sym_group_is_unsolvable:
  assumes "n \<ge> 5" shows "\<not> solvable (sym_group n)"
proof -
  interpret Id: group_hom "alt_group n" "sym_group n" id
    using group.canonical_inj_is_hom[OF sym_group_is_group alt_group_is_subgroup] alt_group_def by simp
  show ?thesis
    using Id.inj_hom_imp_solvable alt_group_is_unsolvable[OF assms] by auto
qed

end


section "History Variables"

theory History
imports Simulations IOA_Automation
begin

text \<open>
The concept of unfolding of an IOA is taken from Lynch and Vaandrager's paper: "Forward
  and Backward Simulations Part 1: Untimed Systems".
\<close>

context IOA begin

context begin

private
definition ioa_unfolding :: "('s,'a)ioa \<Rightarrow> (('s,'a)execution,'a)ioa" where
  "ioa_unfolding a \<equiv> let
      start = {(s,[]) | s . s \<in> start a};
      trans = {(e,act,e') . (last_state e) \<midarrow>act\<midarrow>a\<longrightarrow> (last_state e')
        \<and> e' = cons_exec e (act, last_state e')}
    in
      \<lparr>ioa.asig = ioa.asig a, ioa.start = start, ioa.trans = trans\<rparr>"

private
lemma l1:"is_ref_map last_state (ioa_unfolding a) a"
proof -
  { fix e e' act
    assume "reachable (ioa_unfolding a) e" and tr:"e \<midarrow>act\<midarrow>(ioa_unfolding a) \<longrightarrow>e'"
    have "last_state e \<midarrow>act\<midarrow>a \<longrightarrow> last_state e'" using tr
      by (simp add:ioa_unfolding_def is_trans_def)
    hence "refines (last_state e, [(act, last_state e')]) e act e' a last_state"
      by (simp add:refines_def Let_def is_trans_def trace_def schedule_def filter_act_def trace_match_def) }
  thus ?thesis by (auto simp add:is_ref_map_def, simp add:ioa_unfolding_def, blast)
qed

private
definition hist_fwd_sim :: "('s,'a)ioa \<Rightarrow> 's \<Rightarrow> (('s,'a)execution set)" where
  "hist_fwd_sim a s \<equiv> {e . is_exec_of a e \<and> last_state e = s}"

private
lemma l2:"is_forward_sim (hist_fwd_sim a) a (ioa_unfolding a)"
proof -
  text "The base case"
  { fix s assume "s \<in> start a"
    hence "hist_fwd_sim a s \<inter> start (ioa_unfolding a) \<noteq> {}"
    by (auto simp add: hist_fwd_sim_def ioa_unfolding_def is_exec_of_def Int_def) }
  moreover
  { fix s s' t act
    assume "s' \<in> hist_fwd_sim a s" and "s \<midarrow>act\<midarrow>a\<longrightarrow> t" and "reachable a s"
    define t' where  "t' \<equiv> cons_exec s' (act,t)"
    define e where "e \<equiv> (s',[(act,t')])"
    have tr:"s' \<midarrow>act\<midarrow>(ioa_unfolding a)\<longrightarrow> t'" and next_in_image:"t' \<in> hist_fwd_sim a t"
    proof -
      show "s' \<midarrow>act\<midarrow>(ioa_unfolding a)\<longrightarrow> t'" using \<open>s \<midarrow>act\<midarrow>a\<longrightarrow> t\<close> t'_def \<open>s' \<in> hist_fwd_sim a s\<close>
        by (simp add:is_trans_def ioa_unfolding_def cons_exec_def hist_fwd_sim_def)
      show "t' \<in> hist_fwd_sim a t" using \<open>s' \<in> hist_fwd_sim a s\<close> t'_def \<open>s \<midarrow>act\<midarrow>a\<longrightarrow> t\<close>
        by (simp add:hist_fwd_sim_def) (metis IOA.cons_exec_def IOA.is_exec_of_def IOA.last_state.simps(2) IOA.trans_from_last_state fst_conv snd_conv)
    qed
    have is_exec:"is_exec_frag_of (ioa_unfolding a) e" using tr
      by (metis IOA.is_exec_frag_of.simps(2) fst_conv snd_conv e_def)
    have fst:"fst e = s'" and last:"last_state e = t'" by (auto simp add:e_def)
    have trace_match:"trace_match (ioa_unfolding a) act e"
      by (auto simp add:trace_match_def Let_def ioa_unfolding_def traces_simps e_def)
    note next_in_image is_exec fst last trace_match }
  ultimately show ?thesis unfolding is_forward_sim_def by metis
qed

private
lemma traces_ioa_unfolding:"traces (ioa_unfolding a) = traces a" using l1 l2 ref_map_soundness forward_sim_soundness
by (metis (no_types, lifting) ioa.select_convs(1) ioa_unfolding_def set_eq_subset)

definition add_history :: "('s,'a)ioa \<Rightarrow> ('s \<Rightarrow> 'h \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> 'h) \<Rightarrow> ('s \<Rightarrow> 'h) \<Rightarrow> ('s\<times>'h,'a)ioa"
  \<comment> \<open> @{term add_history} can be used to add hitory state to an IOA, and the theorem below
    stipulates that no new traces are introduced by the operation.\<close>
  where "add_history a f f\<^sub>0 \<equiv> let
      start = {(s,h) . s \<in> start a \<and> h = f\<^sub>0 s};
      trans = {((s,h),act,(s',h')) .  s \<midarrow>act\<midarrow>a\<longrightarrow> s' \<and> h' = f s h act s'}
    in
      \<lparr>ioa.asig = ioa.asig a, ioa.start = start, ioa.trans = trans\<rparr>"

private
definition hist_ref_map :: "('s \<Rightarrow> 'h \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> 'h) \<Rightarrow> ('s \<Rightarrow> 'h) \<Rightarrow> ('s,'a)execution \<Rightarrow> 's\<times>'h" where
  "hist_ref_map f f\<^sub>0 e \<equiv> foldr (\<lambda> (a, s') (s, h) . (s', f s h a s'))
    (snd e) (fst e, f\<^sub>0 (fst e))"

private
lemma l5:"fst (hist_ref_map f f\<^sub>0 e) = last_state e"
proof (induct e rule:last_state.induct)
  case 1 thus ?case by (auto simp add:hist_ref_map_def)
next
  case (2 s p ps)
  thus ?case apply (auto simp add:hist_ref_map_def) by (metis (no_types, lifting) fstI prod.case_eq_if)
qed

private
lemma l6:
  assumes "e' = cons_exec e (a,s)"
  shows "let hs = \<lambda> e . hist_ref_map f f\<^sub>0 e in hs e' = (s, f (last_state e) (snd (hs e)) a s)"
nitpick[verbose,  card 'a = 2, card 'b = 2, card 'c = 2, card "('b \<times> 'a) list" = 30, card "'a \<times> 'c" = 4, expect=none]
using assms
proof (induct "snd e")
  case Nil thus ?case by (simp add:hist_ref_map_def cons_exec_def, cases e, cases e', auto)
next
  case (Cons x xs) thus ?case by (simp add:hist_ref_map_def cons_exec_def, cases e, cases e', auto)
    (metis (no_types, lifting) case_prod_beta fstI)
qed

private
lemma l4:"is_ref_map (hist_ref_map f f\<^sub>0) (ioa_unfolding a) (add_history a f f\<^sub>0)"
apply (auto simp only:is_ref_map_def)
    apply(simp add: ioa_unfolding_def hist_ref_map_def add_history_def)
    (* base case discharged *)
  subgoal premises prems for fst_e snd_e fst_e' snd_e' act
  proof -
    let ?e = "(hist_ref_map f f\<^sub>0 (fst_e, snd_e), [(act, hist_ref_map f f\<^sub>0 (fst_e', snd_e'))])"
    show ?thesis using prems
    apply (intro exI[where ?x="?e"])
    apply (auto simp add:refines_def)
        defer
        apply (simp add:hist_ref_map_def is_trans_def trace_match_def ioa_unfolding_def add_history_def Let_def traces_simps)
      apply (rm_reachable)
      subgoal premises prems
      proof -
        from prems have 1:"(fst_e', snd_e') = cons_exec (fst_e, snd_e) (act, last_state (fst_e', snd_e'))"
        and 2:"last_state (fst_e, snd_e) \<midarrow>act\<midarrow>a\<longrightarrow> last_state (fst_e', snd_e')"
          by (simp_all add:ioa_unfolding_def is_trans_def)
        from 1 have 3:"fst_e = fst_e'" by (simp add:cons_exec_def)
        from 1 2 3 l6[of "(fst_e', snd_e')" "(fst_e, snd_e)" act "last_state (fst_e', snd_e')" f f\<^sub>0] show ?thesis
        apply (simp add:add_history_def is_trans_def Let_def, cases "hist_ref_map f f\<^sub>0 (fst_e', snd_e)", auto)
            apply (metis fst_conv l5)
          apply (metis fst_conv l5)
        done
      qed
    done
  qed
done

private
lemma l3:"traces (ioa_unfolding a) \<subseteq> IOA.traces (add_history a f f\<^sub>0)"
using l4 ref_map_soundness
by (metis (no_types, lifting) add_history_def ioa.select_convs(1) ioa_unfolding_def)

theorem hist_soundness:"IOA.traces a \<subseteq> IOA.traces (add_history a f f\<^sub>0)"
using traces_ioa_unfolding l3 by fast

end

end

end


text\<open> 4 Nov 2021: Two lemmas for Homework 09 in CS 511 \<close>
text\<open> In the first lemma A1, your task to remove the invocation of the
      pre-defined method 'blast' by an equivalent sequence of 'apply' steps \<close>
text\<open> In the second lemma B1, your task is to shorten the given proof \<close>

theory HW09
  imports Main
begin

text \<open> Exercise 1 on the last page of Lecture Slides 28, Analytic Tableaux
       Part I  \<close>

lemma A1 : " (\<forall>x. \<forall>y. \<forall>z. P(x,y) \<and> P(y,z) \<longrightarrow> P(x,z)) \<and> (\<forall>x. \<forall>y. P(x,y) \<longrightarrow> P(y,x))
            \<Longrightarrow> \<forall>x. \<forall>y. \<forall>z. P(x,y) \<and> P(z,y) \<longrightarrow> P(x,z) "
  apply (erule conjE)
  apply (rule allI)+
  apply (rule impI)
  apply (erule conjE)
  apply (erule_tac x= "x" in allE)
  apply (erule_tac x= "z" in allE)
  apply (erule_tac x= "y" in allE)
  apply (erule_tac x= "y" in allE)
  apply (erule_tac x= "z" in allE)
  apply (erule impE)
   apply assumption
  apply (erule impE)
   apply (rule conjI)
  apply assumption+
  done

text \<open> Exercise 2 on the last page of Lecture Slides 28, Analytic Tableaux
       Part I  \<close>
lemma B1 : "(\<forall>x. Q(a,x,x)) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow>
    Q(x,s(y),s(z))) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow> Q(y,x,z)) \<Longrightarrow> \<exists> x. Q( s(s(a)), s(s(s(a))), x)"
  apply (erule conjE)
  apply (erule conjE)
  apply (rule exI)
  apply (erule allE)
  apply (erule allE)
  apply (erule allE)
  apply (frule_tac x="a" in spec)
  apply (frule spec)
  apply (frule spec)
  apply (frule spec)
  apply (erule allE)
  apply (frule spec)
  apply (frule spec)
  apply (erule allE)+
  apply (erule impE)
   apply (erule mp)
   apply assumption
  apply (erule mp)+
  apply assumption
  done

text \<open> Below is a proof of lemma B2 consisting of 26 'apply' steps. It includes many
       unnecessary steps. For full credit, produce a proof with at most 20 'apply' steps. \<close>
lemma B2 : "(\<forall>x. Q(a,x,x)) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow>
    Q(x,s(y),s(z))) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow> Q(y,x,z)) \<Longrightarrow> \<exists> x. Q( s(s(a)), s(s(s(a))), x)"
  apply (erule conjE)
  apply (erule conjE)
  apply (rule_tac x="s(s(s(s(s(a)))))" in exI)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="a" in allE)
  apply (frule_tac x="a" in spec)
  apply (frule_tac x="s(a)" in spec)
  apply (frule_tac x="s(s(a))" in spec)
  apply (erule_tac x="s(s(s(a)))" in allE)
  apply (frule_tac x="s(a)" in spec)
  apply (frule_tac x="s(s(a))" in spec)
  apply (erule_tac x="s(s(s(a)))" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="s(s(s(a)))" in allE)
  apply (erule_tac x="s(s(s(s(a))))" in allE)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="a" in allE)
  apply (erule impE)
   apply (erule mp)
   apply assumption
  apply (erule mp)
  apply (erule mp)
  apply assumption
  done

end