theory Huffman_Nuns
imports "../Nunchaku"
begin

declare Int_Un_distrib [simp]
        Int_Un_distrib2 [simp]
        max.absorb1 [simp]
        max.absorb2 [simp]

datatype 'a tree =
  Leaf nat 'a
| InnerNode nat "('a tree)" "('a tree)"

type_synonym 'a forest = "'a tree list"

primrec alphabet :: "'a tree \<Rightarrow> 'a \<Rightarrow> bool" where
"alphabet (Leaf w a) b = (a = b)" |
"alphabet (InnerNode w t1 t2) a = (alphabet t1 a \<or> alphabet t2 a)"

primrec alphabetF :: "'a forest \<Rightarrow> 'a \<Rightarrow> bool" where
"alphabetF [] _ = False" |
"alphabetF (t # ts) a = (alphabet t a \<or> alphabetF ts a)"

lemma exists_in_alphabet:
"\<exists>a. alphabet t a"
by (induct t) auto

primrec consistent :: "'a tree \<Rightarrow> bool" where
"consistent (Leaf w a) = True" |
"consistent (InnerNode w t1 t2) =
     (consistent t1 \<and> consistent t2 \<and> (\<forall>a. \<not> alphabet t1 a \<or> \<not> alphabet t2 a))"

primrec consistentF :: "'a forest \<Rightarrow> bool" where
"consistentF [] = True" |
"consistentF (t # ts) =
     (consistent t \<and> consistentF ts \<and> (\<forall>a. \<not> alphabet t a \<or> \<not> alphabetF ts a))"

lemma tree_induct_consistent [consumes 1, case_names base step1 step2 step3]:
"\<lbrakk>consistent t;
  \<And>wb b a. P (Leaf wb b) a;
  \<And>w t1 t2 a.
     \<lbrakk>consistent t1; consistent t2; (\<forall>a. \<not> alphabet t1 a \<or> alphabet t2 a);
      alphabet t1 a; \<not> alphabet t2 a; P t1 a; P t2 a\<rbrakk> \<Longrightarrow>
     P (InnerNode w t1 t2) a;
  \<And>w t1 t2 a.
     \<lbrakk>consistent t1; consistent t2; (\<forall>a. \<not> alphabet t1 a \<or> alphabet t2 a);
      ~ alphabet t1 a; alphabet t2 a; P t1 a; P t2 a\<rbrakk> \<Longrightarrow>
     P (InnerNode w t1 t2) a;
  \<And>w t1 t2 a.
     \<lbrakk>consistent t1; consistent t2; (\<forall>a. \<not> alphabet t1 a \<or> alphabet t2 a);
      ~ alphabet t1 a; ~ alphabet t2 a; P t1 a; P t2 a\<rbrakk> \<Longrightarrow>
     P (InnerNode w t1 t2) a\<rbrakk> \<Longrightarrow>
 P t a"
sorry

primrec depth :: "'a tree \<Rightarrow> 'a \<Rightarrow> nat" where
"depth (Leaf w b) a = 0" |
"depth (InnerNode w t1 t2) a =
     (if alphabet t1 a then Suc (depth t1 a)
      else if alphabet t2 a then Suc (depth t2 a)
      else 0)"

primrec height :: "'a tree \<Rightarrow> nat" where
"height (Leaf w a) = 0" |
"height (InnerNode w t1 t2) = Suc (max (height t1) (height t2))"

lemma "height t \<noteq> Suc (Suc (Suc (Suc 0)))"
nxunchaku[overlord]

primrec heightF :: "'a forest \<Rightarrow> nat" where
"heightF [] = 0" |
"heightF (t # ts) = max (height t) (heightF ts)"

lemma depth_le_height:
"depth t a \<le> height t"
by (induct t) auto

lemma exists_at_height:
"consistent t \<Longrightarrow> \<exists>a. alphabet t a \<and> depth t a = height t"
sorry

lemma depth_max_heightE_left [elim!]:
"\<lbrakk>depth t1 a = max (height t1) (height t2);
  \<lbrakk>depth t1 a = height t1; height t1 \<ge> height t2\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow>
 P"
by (cut_tac t = t1 and a = a in depth_le_height) simp

lemma depth_max_heightE_right [elim!]:
"\<lbrakk>depth t2 a = max (height t1) (height t2);
  \<lbrakk>depth t2 a = height t2; height t2 \<ge> height t1\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow>
 P"
by (cut_tac t = t2 and a = a in depth_le_height) simp

lemma height_gt_0_alphabet_eq_imp_height_gt_0:
assumes "height t > 0" "consistent t" "\<forall>a. alphabet t a = alphabet u a"
shows "height u > 0"
sorry

primrec freq :: "'a tree \<Rightarrow> 'a \<Rightarrow> nat" where
"freq (Leaf w a) b = (if b = a then w else 0)" |
"freq (InnerNode w t1 t2) b = (freq t1 b + freq t2 b)"

primrec freqF :: "'a forest \<Rightarrow> 'a \<Rightarrow> nat" where
"freqF [] = (\<lambda>b. 0)" |
"freqF (t # ts) = (\<lambda>b. freq t b + freqF ts b)"

lemma notin_alphabet_imp_freq_0 [simp]:
"~ alphabet t a \<Longrightarrow> freq t a = 0"
by (induct t) simp+

lemma notin_alphabetF_imp_freqF_0 [simp]:
"~ alphabetF ts a \<Longrightarrow> freqF ts a = 0"
by (induct ts) simp+

lemma freq_0_right [simp]:
"\<lbrakk>\<forall>a. ~ alphabet t1 a \<or> \<not> alphabet t2 a; alphabet t1 a\<rbrakk> \<Longrightarrow> freq t2 a = 0"
by (auto intro: notin_alphabet_imp_freq_0 simp: disjoint_iff_not_equal)

lemma freq_0_left [simp]:
"\<lbrakk>\<forall>a. ~ alphabet t1 a \<or> \<not> alphabet t2 a; alphabet t2 a\<rbrakk> \<Longrightarrow> freq t1 a = 0"
sorry

lemma heightF_0_imp_Leaf_freqF_in_set:
"\<lbrakk>consistentF ts; heightF ts = 0; alphabetF ts a\<rbrakk> \<Longrightarrow>
 Leaf (freqF ts a) a \<in> set ts"
sorry

primrec weight :: "'a tree \<Rightarrow> nat" where
"weight (Leaf w a) = w" |
"weight (InnerNode w t1 t2) = weight t1 + weight t2"

(*<*)
lemma weight_eq_Sum_freq:
"consistent t \<Longrightarrow> weight t = (\<Sum>a \<in> UNIV. freq t a)"
sorry

primrec cost :: "'a tree \<Rightarrow> nat" where
"cost (Leaf w a) = 0" |
"cost (InnerNode w t1 t2) = weight t1 + cost t1 + weight t2 + cost t2"

(*<*)
theorem cost_eq_Sum_freq_mult_depth:
"consistent t \<Longrightarrow> cost t = (\<Sum>a \<in> UNIV. freq t a * depth t a)"
(*>*)
sorry

lemma height_0_imp_cost_0 [simp]:
"height t = 0 \<Longrightarrow> cost t = 0"
by (case_tac t) simp+

definition optimum :: "'a tree \<Rightarrow> bool" where
"optimum t \<equiv>
     \<forall>u. consistent u \<longrightarrow> (ALL x. alphabet t x = alphabet u x) \<longrightarrow> (ALL x. freq t x = freq u x) \<longrightarrow>
         cost t \<le> cost u"

primrec cachedWeight :: "'a tree \<Rightarrow> nat" where
"cachedWeight (Leaf w a) = w" |
"cachedWeight (InnerNode w t1 t2) = w"

lemma height_0_imp_cachedWeight_eq_weight [simp]:
"height t = 0 \<Longrightarrow> cachedWeight t = weight t"
by (case_tac t) simp+

definition uniteTrees :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"uniteTrees t1 t2 \<equiv> InnerNode (cachedWeight t1 + cachedWeight t2) t1 t2"

lemma freq_uniteTrees [simp]:
"freq (uniteTrees t1 t2) = (\<lambda>a. freq t1 a + freq t2 a)"
by (simp add: uniteTrees_def)

primrec insortTree :: "'a tree \<Rightarrow> 'a forest \<Rightarrow> 'a forest" where
"insortTree u [] = [u]" |
"insortTree u (t # ts) =
     (if cachedWeight u \<le> cachedWeight t then u # t # ts
                                         else t # insortTree u ts)"

lemma length_insortTree [simp]:
"length (insortTree t ts) = length ts + 1"
by (induct ts) simp+

lemma insortTree_ne_Nil [simp]:
"insortTree t ts \<noteq> []"
by (case_tac ts) simp+

lemma freqF_insortTree [simp]:
"freqF (insortTree t ts) = (\<lambda>a. freq t a + freqF ts a)"
by (induct ts) (simp add: ext)+

lemma heightF_insortTree [simp]:
"heightF (insortTree t ts) = max (height t) (heightF ts)"
by (induct ts) auto

fun huffman :: "'a forest \<Rightarrow> 'a tree" where
"huffman [t] = t" |
"huffman (t1 # t2 # ts) = huffman (insortTree (uniteTrees t1 t2) ts)"

theorem freq_huffman [simp]:
"ts \<noteq> [] \<Longrightarrow> freq (huffman ts) = freqF ts"
by (induct ts rule: huffman.induct) (auto simp: ext)

fun sibling :: "'a tree \<Rightarrow> 'a \<Rightarrow> 'a" where
"sibling (Leaf wb b) a = a" |
"sibling (InnerNode w (Leaf wb b) (Leaf wc c)) a =
     (if a = b then c else if a = c then b else a)" |
"sibling (InnerNode w (InnerNode X L R) t2) a =
     (if alphabet (InnerNode X L R) a then sibling (InnerNode X L R) a
      else if alphabet t2 a then sibling t2 a
      else a)" |
"sibling (InnerNode w (Leaf wb b) (InnerNode X L R)) a =
     (if alphabet (Leaf wb b) a then sibling (Leaf wb b) a
      else if alphabet (InnerNode X L R) a then sibling (InnerNode X L R) a
      else a)"

lemma notin_alphabet_imp_sibling_id [simp]:
"~ alphabet t a \<Longrightarrow> sibling t a = a"
sorry

lemma height_0_imp_sibling_id [simp]:
"height t = 0 \<Longrightarrow> sibling t a = a"
by (case_tac t) simp+

lemma height_gt_0_in_alphabet_imp_sibling_left [simp]:
"\<lbrakk>height t1 > 0; alphabet t1 a\<rbrakk> \<Longrightarrow>
 sibling (InnerNode w t1 t2) a = sibling t1 a"
by (case_tac t1) simp+

lemma height_gt_0_in_alphabet_imp_sibling_right [simp]:
"\<lbrakk>height t2 > 0; alphabet t1 a\<rbrakk> \<Longrightarrow>
 sibling (InnerNode w t1 t2) a = sibling t1 a"
sorry

lemma height_gt_0_notin_alphabet_imp_sibling_left [simp]:
"\<lbrakk>height t1 > 0; ~ alphabet t1 a\<rbrakk> \<Longrightarrow>
 sibling (InnerNode w t1 t2) a = sibling t2 a"
by (case_tac t1) simp+

lemma height_gt_0_notin_alphabet_imp_sibling_right [simp]:
"\<lbrakk>height t2 > 0; ~ alphabet t1 a\<rbrakk> \<Longrightarrow>
 sibling (InnerNode w t1 t2) a = sibling t2 a"
sorry

lemma either_height_gt_0_imp_sibling [simp]:
"height t1 > 0 \<or> height t2 > 0 \<Longrightarrow>
 sibling (InnerNode w t1 t2) a =
     (if alphabet t1 a then sibling t1 a else sibling t2 a)"
by auto

lemma in_alphabet_imp_sibling_in_alphabet:
"alphabet t a \<Longrightarrow> alphabet t (sibling t a)"
by (induct t a rule: sibling.induct) auto

lemma sibling_ne_imp_sibling_in_alphabet:
"sibling t a \<noteq> a \<Longrightarrow> alphabet t (sibling t a)"
by (metis notin_alphabet_imp_sibling_id in_alphabet_imp_sibling_in_alphabet)

lemma sibling_sibling_id [simp]:
"consistent t \<Longrightarrow> sibling t (sibling t a) = a"
sorry

lemma sibling_reciprocal:
"\<lbrakk>consistent t; sibling t a = b\<rbrakk> \<Longrightarrow> sibling t b = a"
by auto

lemma depth_height_imp_sibling_ne:
"\<lbrakk>consistent t; depth t a = height t; height t > 0; alphabet t a\<rbrakk> \<Longrightarrow>
 sibling t a \<noteq> a"
by (induct t a rule: sibling_induct_consistent) auto

lemma depth_sibling [simp]:
"consistent t \<Longrightarrow> depth t (sibling t a) = depth t a"
by (induct t a rule: sibling_induct_consistent) simp+

primrec swapLeaves :: "'a tree \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a tree" where
"swapLeaves (Leaf wc c) wa a wb b =
     (if c = a then Leaf wb b else if c = b then Leaf wa a else Leaf wc c)" |
"swapLeaves (InnerNode w t1 t2) wa a wb b =
     InnerNode w (swapLeaves t1 wa a wb b) (swapLeaves t2 wa a wb b)"

(* GOOD EXAMPLES *)

lemma "swapLeaves t wa a wa a = t"
(*
nunchaku[overlord, debug]
*)
oops

lemma "swapLeaves t (freq t a) a (freq t a) a = t"
(*
nunchaku[overlord, debug]
*)
oops

lemma "consistent t \<Longrightarrow> swapLeaves t (freq t a) a (freq t a) a = t"
(*
nunchaku[overlord, debug]
*)
oops

lemma swapLeaves_id_when_notin_alphabet [simp]:
"~ alphabet t a \<Longrightarrow> ~ alphabet t b \<Longrightarrow> swapLeaves t w a w' b = t"
(* nunchaku[debug, overlord] *)
sorry

lemma swapLeaves_id [simp]:
"consistent t \<Longrightarrow> swapLeaves t (freq t a) a (freq t a) a = t"
by (induct t a rule: tree_induct_consistent) simp+

primrec setFreq :: "'a tree \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a tree" where
"setFreq (Leaf wc c) wa a =
     (if c = a then Leaf wa a else Leaf wc c)" |
"setFreq (InnerNode w t1 t2) wa a =
     InnerNode w (setFreq t1 wa a) (setFreq t2 wa a)"

lemma alphabet_swapLeaves:
"alphabet t a \<Longrightarrow> alphabet (setFreq t wa a) a"
apply (induct t)
apply auto[1]
by (induct t) auto

lemma consistent_swapLeaves [simp]:
"consistent t \<Longrightarrow> consistent (swapLeaves t wa a wb b)"
by (induct t) (auto simp: alphabet_swapLeaves)

lemma depth_swapLeaves_neither [simp]:
"\<lbrakk>consistent t; c \<noteq> a; c \<noteq> b\<rbrakk> \<Longrightarrow> depth (swapLeaves t wa a wb b) c = depth t c"
(*nunchaku[debug, overlord]*)
by (induct t a rule: tree_induct_consistent) (auto simp: alphabet_swapLeaves)

lemma height_swapLeaves [simp]:
"height (swapLeaves t wa a wb b) = height t"
by (induct t) simp+

lemma freq_swapLeaves [simp]:
"\<lbrakk>consistent t; a \<noteq> b\<rbrakk> \<Longrightarrow>
 freq (swapLeaves t wa a wb b) =
     (\<lambda>c. if c = a then if alphabet t b then wa else 0
          else if c = b then if alphabet t a then wb else 0
          else freq t c)"
apply (rule ext)
apply (induct t)
by auto

lemma weight_swapLeaves:
"\<lbrakk>consistent t; a \<noteq> b\<rbrakk> \<Longrightarrow>
 if alphabet t a then
   if alphabet t b then
     weight (swapLeaves t wa a wb b) + freq t a + freq t b =
         weight t + wa + wb
   else
     weight (swapLeaves t wa a wb b) + freq t a = weight t + wb
 else
   if alphabet t b then
     weight (swapLeaves t wa a wb b) + freq t b = weight t + wa
   else
     weight (swapLeaves t wa a wb b) = weight t"
proof (induct t a rule: tree_induct_consistent)
  case base thus ?case by clarsimp
next
  case (step1 w t1 t2 a) show ?case
  proof cases
    assume "alphabet t1 b"
    moreover hence "~ alphabet t2 b" using step1 by auto
    ultimately show ?case using step1 by simp
  next
    assume "~ alphabet t1 b" thus ?case using step1 by auto
  qed
next
  case (step2 w t1 t2 a) show ?case
  proof cases
    assume "alphabet t1 b"
    moreover hence "~ alphabet t2 b" using step2 by auto
    ultimately show ?case using step2 by simp
  next
    assume "~ alphabet t1 b" thus ?case using step2 by auto
  qed
next
  case (step3 w t1 t2 a) show ?case
  proof cases
    assume "alphabet t1 b"
    moreover hence "~ alphabet t2 b" using step3 by auto
    ultimately show ?case using step3 by simp
  next
    assume "~ alphabet t1 b" thus ?case using step3 by auto
  qed
qed

lemma cost_swapLeaves:
"\<lbrakk>consistent t; a \<noteq> b\<rbrakk> \<Longrightarrow>
 if alphabet t a then
   if alphabet t b then
     cost (swapLeaves t wa a wb b) + freq t a * depth t a
     + freq t b * depth t b =
         cost t + wa * depth t b + wb * depth t a
   else
     cost (swapLeaves t wa a wb b) + freq t a * depth t a =
         cost t + wb * depth t a
 else
   if alphabet t b then
     cost (swapLeaves t wa a wb b) + freq t b * depth t b =
         cost t + wa * depth t b
   else
     cost (swapLeaves t wa a wb b) = cost t"
proof (induct t)
  case Leaf show ?case by simp
next
  case (InnerNode w t1 t2)
  note c = `consistent (InnerNode w t1 t2)`
  note hyps = InnerNode
  have w1: "if alphabet t1 a then
              if alphabet t1 b then
                weight (swapLeaves t1 wa a wb b) + freq t1 a + freq t1 b =
                    weight t1 + wa + wb
                  else
                weight (swapLeaves t1 wa a wb b) + freq t1 a = weight t1 + wb
            else
              if alphabet t1 b then
                weight (swapLeaves t1 wa a wb b) + freq t1 b = weight t1 + wa
              else
                weight (swapLeaves t1 wa a wb b) = weight t1" using hyps
    by (simp add: weight_swapLeaves)
  have w2: "if alphabet t2 a then
              if alphabet t2 b then
                weight (swapLeaves t2 wa a wb b) + freq t2 a + freq t2 b =
                    weight t2 + wa + wb
              else
                weight (swapLeaves t2 wa a wb b) + freq t2 a = weight t2 + wb
            else
              if alphabet t2 b then
                weight (swapLeaves t2 wa a wb b) + freq t2 b = weight t2 + wa
              else
                weight (swapLeaves t2 wa a wb b) = weight t2" using hyps
    by (simp add: weight_swapLeaves)
  show ?case
  proof cases
    assume a1: "alphabet t1 a"
    hence a2: "~ alphabet t2 a" using c by auto
    show ?case
    proof cases
      assume b1: "alphabet t1 b"
      hence "~ alphabet t2 b" using c by auto
      thus ?case using a1 a2 b1 w1 w2 hyps by simp
    next
      assume b1: "~ alphabet t1 b" show ?case
      proof cases
        assume "alphabet t2 b" thus ?case using a1 a2 b1 w1 w2 hyps by simp
      next
        assume "~ alphabet t2 b" thus ?case using a1 a2 b1 w1 w2 hyps by simp
      qed
    qed
  next
    assume a1: "~ alphabet t1 a" show ?case
    proof cases
      assume a2: "alphabet t2 a" show ?case
      proof cases
        assume b1: "alphabet t1 b"
        hence "~ alphabet t2 b" using c by auto
        thus ?case using a1 a2 b1 w1 w2 hyps by simp
      next
        assume b1: "~ alphabet t1 b" show ?case
        proof cases
          assume "alphabet t2 b" thus ?case using a1 a2 b1 w1 w2 hyps by simp
        next
          assume "~ alphabet t2 b" thus ?case using a1 a2 b1 w1 w2 hyps by simp
        qed
      qed
    next
      assume a2: "~ alphabet t2 a" show ?case
      proof cases
        assume b1: "alphabet t1 b"
        hence "~ alphabet t2 b" using c by auto
        thus ?case using a1 a2 b1 w1 w2 hyps by simp
      next
        assume b1: "~ alphabet t1 b" show ?case
        proof cases
          assume "alphabet t2 b" thus ?case using a1 a2 b1 w1 w2 hyps by simp
        next
          assume "~ alphabet t2 b" thus ?case using a1 a2 b1 w1 w2 hyps by simp
        qed
      qed
    qed
  qed
qed

lemma sibling_swapLeaves_sibling [simp]:
"\<lbrakk>consistent t; sibling t b \<noteq> b; a \<noteq> b\<rbrakk> \<Longrightarrow>
 sibling (swapLeaves t wa a ws (sibling t b)) a = b"
proof (induct t)
  case Leaf thus ?case by simp
next
  case (InnerNode w t1 t2)
  note hyps = InnerNode
  show ?case
  proof (cases "height t1 = 0")
    case True
    note h1 = True
    show ?thesis
    proof (cases t1)
      case (Leaf wc c)
      note l1 = Leaf
      show ?thesis
      proof (cases "height t2 = 0")
        case True
        note h2 = True
        show ?thesis
        proof (cases t2)
          case Leaf thus ?thesis using l1 hyps by auto metis+
        next
          case InnerNode thus ?thesis using h2 by simp
        qed
      next
        case False
        note h2 = False
        show ?thesis
        proof cases
          assume "c = b" thus ?thesis using l1 h2 hyps by simp
        next
          assume "c \<noteq> b"
          have "sibling t2 alphabet t2 b" using `c \<noteq> b` l1 h2 hyps
            by (simp add: sibling_ne_imp_sibling_in_alphabet)
          thus ?thesis using `c \<noteq> b` l1 h2 hyps by auto
        qed
      qed
    next
      case InnerNode thus ?thesis using h1 by simp
    qed
  next
    case False
    note h1 = False
    show ?thesis
    proof (cases "height t2 = 0")
      case True
      note h2 = True
      show ?thesis
      proof (cases t2)
        case (Leaf wd d)
        note l2 = Leaf
        show ?thesis
        proof cases
          assume "d = b" thus ?thesis using h1 l2 hyps by simp
        next
          assume "d \<noteq> b" show ?thesis
          proof (cases "alphabet t1 b")
            case True
            hence "sibling t1 alphabet t1 b" using `d \<noteq> b` h1 l2 hyps
              by (simp add: sibling_ne_imp_sibling_in_alphabet)
            thus ?thesis using True `d \<noteq> b` h1 l2 hyps
              by (simp add: alphabet_swapLeaves)
          next
            case False thus ?thesis using `d \<noteq> b` l2 hyps by simp
          qed
        qed
      next
        case InnerNode thus ?thesis using h2 by simp
      qed
    next
      case False
      note h2 = False
      show ?thesis
      proof (cases "alphabet t1 b")
        case True thus ?thesis using h1 h2 hyps by auto
      next
        case False
        note b1 = False
        show ?thesis
        proof (cases "alphabet t2 b")
          case True thus ?thesis using b1 h1 h2 hyps
            by (auto simp: in_alphabet_imp_sibling_in_alphabet
                           alphabet_swapLeaves)
        next
          case False thus ?thesis using b1 h1 h2 hyps by simp
        qed
      qed
    qed
  qed
qed

definition swapSyms :: "'a tree \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a tree" where
"swapSyms t a b \<equiv> swapLeaves t (freq t a) a (freq t b) b"

lemma swapSyms_id [simp]:
"consistent t \<Longrightarrow> swapSyms t a a = t"
by (simp add: swapSyms_def)

lemma alphabet_swapSyms [simp]:
"\<lbrakk>alphabet t a; alphabet t b\<rbrakk> \<Longrightarrow> alphabet (swapSyms t a b) x = alphabet t x"
by (simp add: swapSyms_def alphabet_swapLeaves)

lemma consistent_swapSyms [simp]:
"consistent t \<Longrightarrow> consistent (swapSyms t a b)"
by (simp add: swapSyms_def)

lemma depth_swapSyms_neither [simp]:
"\<lbrakk>consistent t; c \<noteq> a; c \<noteq> b\<rbrakk> \<Longrightarrow>
 depth (swapSyms t a b) c = depth t c"
by (simp add: swapSyms_def)

lemma freq_swapSyms [simp]:
"\<lbrakk>consistent t; alphabet t a; alphabet t b\<rbrakk> \<Longrightarrow>
 freq (swapSyms t a b) = freq t"
by (case_tac "a = b") (simp add: swapSyms_def ext)+

lemma cost_swapSyms:
assumes "consistent t" "alphabet t a" "alphabet t b"
shows "cost (swapSyms t a b) + freq t a * depth t a + freq t b * depth t b =
           cost t + freq t a * depth t b + freq t b * depth t a"
proof cases
  assume "a = b" thus ?thesis using assms by simp
next
  assume "a \<noteq> b"
  moreover hence "cost (swapLeaves t (freq t a) a (freq t b) b)
                      + freq t a * depth t a + freq t b * depth t b =
                  cost t + freq t a * depth t b + freq t b * depth t a"
    using assms by (simp add: cost_swapLeaves)
  ultimately show ?thesis using assms by (simp add: swapSyms_def)
qed

lemma le_le_imp_sum_mult_le_sum_mult:
"\<lbrakk>i \<le> j; m \<le> (n::nat)\<rbrakk> \<Longrightarrow> i * n + j * m \<le> i * m + j * n"
apply (subgoal_tac "i * m + i * (n - m) + j * m \<le> i * m + j * m + j * (n - m)")
 apply (simp add: diff_mult_distrib2)
by simp

lemma cost_swapSyms_le:
assumes "consistent t" "alphabet t a" "alphabet t b" "freq t a \<le> freq t b"
        "depth t a \<le> depth t b"
shows "cost (swapSyms t a b) \<le> cost t"
proof -
  let ?aabb = "freq t a * depth t a + freq t b * depth t b"
  let ?abba = "freq t a * depth t b + freq t b * depth t a"
  have "?abba \<le> ?aabb" using assms(4-5)
    by (rule le_le_imp_sum_mult_le_sum_mult)
  have "cost (swapSyms t a b) + ?aabb = cost t + ?abba" using assms(1-3)
    by (simp add: cost_swapSyms add.assoc [THEN sym])
  also have "\<dots> \<le> cost t + ?aabb" using `?abba \<le> ?aabb` by simp
  finally show ?thesis using assms(4-5) by simp
qed

lemma sibling_swapSyms_sibling [simp]:
"\<lbrakk>consistent t; sibling t b \<noteq> b; a \<noteq> b\<rbrakk> \<Longrightarrow>
 sibling (swapSyms t a (sibling t b)) a = b"
by (simp add: swapSyms_def)

lemma sibling_swapSyms_other_sibling [simp]:
"\<lbrakk>consistent t; sibling t b \<noteq> a; sibling t b \<noteq> b; a \<noteq> b\<rbrakk> \<Longrightarrow>
 sibling (swapSyms t a b) (sibling t b) = a"
by (metis consistent_swapSyms sibling_swapSyms_sibling sibling_reciprocal)

definition swapFourSyms :: "'a tree \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a tree" where
"swapFourSyms t a b c d \<equiv>
     if a = d then swapSyms t b c
     else if b = c then swapSyms t a d
     else swapSyms (swapSyms t a c) b d"

lemma alphabet_swapFourSyms [simp]:
"\<lbrakk>alphabet t a; alphabet t b; alphabet t c; alphabet t d'\<rbrakk> \<Longrightarrow>
 alphabet (swapFourSyms t a b c d) x = alphabet t x"
by (simp add: swapFourSyms_def)

lemma consistent_swapFourSyms [simp]:
"consistent t \<Longrightarrow> consistent (swapFourSyms t a b c d)"
by (simp add: swapFourSyms_def)

lemma freq_swapFourSyms [simp]:
"\<lbrakk>consistent t; alphabet t a; alphabet t b; alphabet t c;
  alphabet t d\<rbrakk> \<Longrightarrow>
 freq (swapFourSyms t a b c d) = freq t"
by (auto simp: swapFourSyms_def)

lemma sibling_swapFourSyms_when_4th_is_sibling:
assumes "consistent t" "alphabet t a" "alphabet t b" "alphabet t c"
        "a \<noteq> b" "sibling t c \<noteq> c"
shows "sibling (swapFourSyms t a b c (sibling t c)) a = b"
proof (cases "a \<noteq> sibling t c \<and> b \<noteq> c")
  case True show ?thesis
  proof -
    let ?d = "sibling t c"
    let ?ts = "swapFourSyms t a b c ?d"
    have abba: "(sibling ?ts a = b) = (sibling ?ts b = a)" using `consistent t`
      by (metis consistent_swapFourSyms sibling_reciprocal)
    have s: "sibling t c = sibling (swapSyms t a c) a" using True assms
      by (metis sibling_reciprocal sibling_swapSyms_sibling)
    have "sibling ?ts b = sibling (swapSyms t a c) ?d" using s True assms
      by (auto simp: swapFourSyms_def)
    also have "\<dots> = a" using True assms
      by (metis sibling_reciprocal sibling_swapSyms_other_sibling
          swapLeaves_id swapSyms_def)
    finally have "sibling ?ts b = a" .
    with abba show ?thesis ..
  qed
next
  case False thus ?thesis using assms
    by (auto intro: sibling_reciprocal simp: swapFourSyms_def)
qed

fun mergeSibling :: "'a tree \<Rightarrow> 'a \<Rightarrow> 'a tree" where
"mergeSibling (Leaf wb b) a = Leaf wb b" |
"mergeSibling (InnerNode w (Leaf wb b) (Leaf wc c)) a =
     (if a = b \<or> a = c then Leaf (wb + wc) a
      else InnerNode w (Leaf wb b) (Leaf wc c))" |
"mergeSibling (InnerNode w t1 t2) a =
     InnerNode w (mergeSibling t1 a) (mergeSibling t2 a)"

lemmas mergeSibling_induct_consistent = sibling_induct_consistent

lemma notin_alphabet_imp_mergeSibling_id [simp]:
"~ alphabet t a \<Longrightarrow> mergeSibling t a = t"
by (induct t a rule: mergeSibling.induct) simp+

lemma height_gt_0_imp_mergeSibling_left [simp]:
"height t1 > 0 \<Longrightarrow>
 mergeSibling (InnerNode w t1 t2) a =
     InnerNode w (mergeSibling t1 a) (mergeSibling t2 a)"
by (case_tac t1) simp+

lemma height_gt_0_imp_mergeSibling_right [simp]:
"height t2 > 0 \<Longrightarrow>
 mergeSibling (InnerNode w t1 t2) a =
     InnerNode w (mergeSibling t1 a) (mergeSibling t2 a)"
by (case_tac t2) simp+

lemma either_height_gt_0_imp_mergeSibling [simp]:
"height t1 > 0 \<or> height t2 > 0 \<Longrightarrow>
 mergeSibling (InnerNode w t1 t2) a =
     InnerNode w (mergeSibling t1 a) (mergeSibling t2 a)"
by auto

lemma alphabet_mergeSibling [simp]:
"\<lbrakk>consistent t; alphabet t a\<rbrakk> \<Longrightarrow>
 alphabet (mergeSibling t a) = (alphabet t - {sibling t a}) \<union> {a}"
by (induct t a rule: mergeSibling_induct_consistent) auto

lemma consistent_mergeSibling [simp]:
"consistent t \<Longrightarrow> consistent (mergeSibling t a)"
by (induct t a rule: mergeSibling_induct_consistent) auto

lemma freq_mergeSibling:
"\<lbrakk>consistent t; alphabet t a; sibling t a \<noteq> a\<rbrakk> \<Longrightarrow>
 freq (mergeSibling t a) =
     (\<lambda>c. if c = a then freq t a + freq t (sibling t a)
          else if c = sibling t a then 0
          else freq t c)"
by (induct t a rule: mergeSibling_induct_consistent)
   (auto simp: fun_eq_iff)

lemma weight_mergeSibling [simp]:
"weight (mergeSibling t a) = weight t"
by (induct t a rule: mergeSibling.induct) simp+

lemma cost_mergeSibling:
"\<lbrakk>consistent t; sibling t a \<noteq> a\<rbrakk> \<Longrightarrow>
 cost (mergeSibling t a) + freq t a + freq t (sibling t a) = cost t"
by (induct t a rule: mergeSibling_induct_consistent) auto

primrec splitLeaf :: "'a tree \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a tree" where
"splitLeaf (Leaf wc c) wa a wb b =
     (if c = a then InnerNode wc (Leaf wa a) (Leaf wb b) else Leaf wc c)" |
"splitLeaf (InnerNode w t1 t2) wa a wb b =
     InnerNode w (splitLeaf t1 wa a wb b) (splitLeaf t2 wa a wb b)"

primrec splitLeafF :: "'a forest \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a forest" where
"splitLeafF [] wa a wb b = []" |
"splitLeafF (t # ts) wa a wb b =
     splitLeaf t wa a wb b # splitLeafF ts wa a wb b"

lemma notin_alphabet_imp_splitLeaf_id [simp]:
"~ alphabet t a \<Longrightarrow> splitLeaf t wa a wb b = t"
by (induct t) simp+

lemma notin_alphabetF_imp_splitLeafF_id [simp]:
"a \<notin> alphabetF ts \<Longrightarrow> splitLeafF ts wa a wb b = ts"
by (induct ts) simp+

lemma alphabet_splitLeaf [simp]:
"alphabet (splitLeaf t wa a wb b) =
     (if alphabet t a then alphabet t \<union> {b} else alphabet t)"
by (induct t) simp+

lemma consistent_splitLeaf [simp]:
"\<lbrakk>consistent t; ~ alphabet t b\<rbrakk> \<Longrightarrow> consistent (splitLeaf t wa a wb b)"
by (induct t) auto

lemma freq_splitLeaf [simp]:
"\<lbrakk>consistent t; ~ alphabet t b\<rbrakk> \<Longrightarrow>
 freq (splitLeaf t wa a wb b) =
     (if alphabet t a then
        (\<lambda>c. if c = a then wa else if c = b then wb else freq t c)
      else
        freq t)"
by (induct t b rule: tree_induct_consistent) (rule ext, auto)+

lemma weight_splitLeaf [simp]:
"\<lbrakk>consistent t; alphabet t a; freq t a = wa + wb\<rbrakk> \<Longrightarrow>
 weight (splitLeaf t wa a wb b) = weight t"
by (induct t a rule: tree_induct_consistent) simp+

lemma cost_splitLeaf [simp]:
"\<lbrakk>consistent t; alphabet t a; freq t a = wa + wb\<rbrakk> \<Longrightarrow>
 cost (splitLeaf t wa a wb b) = cost t + wa + wb"
by (induct t a rule: tree_induct_consistent) simp+

fun sortedByWeight :: "'a forest \<Rightarrow> bool" where
"sortedByWeight [] = True" |
"sortedByWeight [t] = True" |
"sortedByWeight (t1 # t2 # ts) =
     (weight t1 \<le> weight t2 \<and> sortedByWeight (t2 # ts))"

lemma sortedByWeight_Cons_imp_sortedByWeight:
"sortedByWeight (t # ts) \<Longrightarrow> sortedByWeight ts"
by (case_tac ts) simp+

lemma sortedByWeight_Cons_imp_forall_weight_ge:
"sortedByWeight (t # ts) \<Longrightarrow> \<forall>u \<in> set ts. weight u \<ge> weight t"
proof (induct ts arbitrary: t)
  case Nil thus ?case by simp
next
  case (Cons u us) thus ?case by simp (metis le_trans)
qed

lemma sortedByWeight_insortTree:
"\<lbrakk>sortedByWeight ts; height t = 0; heightF ts = 0\<rbrakk> \<Longrightarrow>
 sortedByWeight (insortTree t ts)"
by (induct ts rule: sortedByWeight.induct) auto

definition minima :: "'a tree \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
"minima t a b \<equiv>
     alphabet t a \<and> alphabet t b \<and> a \<noteq> b \<and> freq t a \<le> freq t b
     \<and> (\<forall>alphabet t c. c \<noteq> a \<longrightarrow> c \<noteq> b \<longrightarrow>
                         freq t c \<ge> freq t a \<and> freq t c \<ge> freq t b)"

lemma cost_swapFourSyms_le:
assumes "consistent t" "minima t a b" "alphabet t c" "alphabet t d"
        "depth t c = height t" "depth t d = height t" "c \<noteq> d"
shows "cost (swapFourSyms t a b c d) \<le> cost t"
proof -
  note lems = swapFourSyms_def minima_def cost_swapSyms_le depth_le_height
  show ?thesis
  proof (cases "a \<noteq> d \<and> b \<noteq> c")
    case True show ?thesis
    proof cases
      assume "a = c" show ?thesis
      proof cases
        assume "b = d" thus ?thesis using `a = c` True assms
          by (simp add: lems)
      next
        assume "b \<noteq> d" thus ?thesis using `a = c` True assms
          by (simp add: lems)
      qed
    next
      assume "a \<noteq> c" show ?thesis
      proof cases
        assume "b = d" thus ?thesis using `a \<noteq> c` True assms
          by (simp add: lems)
      next
        assume "b \<noteq> d"
        have "cost (swapFourSyms t a b c d) \<le> cost (swapSyms t a c)"
          using `b \<noteq> d` `a \<noteq> c` True assms by (clarsimp simp: lems)
        also have "\<dots> \<le> cost t" using `b \<noteq> d` `a \<noteq> c` True assms
          by (clarsimp simp: lems)
        finally show ?thesis .
      qed
    qed
  next
    case False thus ?thesis using assms by (clarsimp simp: lems)
  qed
qed

lemma twice_freq_le_imp_minima:
"\<lbrakk>\<forall>alphabet t c. wa \<le> freq t c \<and> wb \<le> freq t c;
  alphabet u = alphabet t \<union> {b}; alphabet u a; a \<noteq> b;
  freq u = (\<lambda>c. if c = a then wa else if c = b then wb else freq t c);
  wa \<le> wb\<rbrakk> \<Longrightarrow>
 minima u a b"
by (simp add: minima_def)

lemma optimum_splitLeaf:
assumes "consistent t" "optimum t" "alphabet t a" "~ alphabet t b"
        "freq t a = wa + wb" "\<forall>alphabet t c. freq t c \<ge> wa \<and> freq t c \<ge> wb"
        "wa \<le> wb"
shows "optimum (splitLeaf t wa a wb b)"
proof (unfold optimum_def, clarify)
  fix u
  let ?t' = "splitLeaf t wa a wb b"
  assume cu: "consistent u"
         and au: "alphabet ?t' = alphabet u"
         and fu: "freq ?t' = freq u"
  show "cost ?t' \<le> cost u"
  proof (cases "height ?t' = 0")
    case True thus ?thesis by simp
  next
    case False
    hence hu: "height u > 0" using au assms
      by (auto intro: height_gt_0_alphabet_eq_imp_height_gt_0)
    have aa: "alphabet u a" using au assms by fastforce
    have ab: "alphabet u b" using au assms by fastforce
    have ab: "a \<noteq> b" using assms by blast
    from exists_at_height [OF cu]
    obtain c where ac: "alphabet u c" and dc: "depth u c = height u" ..
    let ?d = "sibling u c"
    have dc: "?d \<noteq> c" using dc cu hu ac by (metis depth_height_imp_sibling_ne)
    have ad: "?alphabet u d" using dc
      by (rule sibling_ne_imp_sibling_in_alphabet)
    have dd: "depth u ?d = height u" using dc cu by simp

    let ?u' = "swapFourSyms u a b c ?d"
    have cu': "consistent ?u'" using cu by simp
    have au': "alphabet ?u' = alphabet u" using aa ab ac ad au by simp
    have fu': "freq ?u' = freq u" using aa ab ac ad cu fu by simp
    have sa: "sibling ?u' a = b" using cu aa ab ac ab dc
      by (rule sibling_swapFourSyms_when_4th_is_sibling)

    let ?v = "mergeSibling ?u' a"
    have cv: "consistent ?v" using cu' by simp
    have av: "alphabet ?v = alphabet t" using sa cu' au' aa au assms by auto
    have fv: "freq ?v = freq t"
      using sa cu' au' fu' fu [THEN sym] ab au [THEN sym] assms
      by (simp add: freq_mergeSibling ext)

    have "cost ?t' = cost t + wa + wb" using assms by simp
    also have "\<dots> \<le> cost ?v + wa + wb" using cv av fv `optimum t`
      by (simp add: optimum_def)
    also have "\<dots> = cost ?u'"
      proof -
        have "cost ?v + freq ?u' a + freq ?u' (sibling ?u' a) = cost ?u'"
          using cu' sa assms by (subst cost_mergeSibling) auto
        moreover have "wa = freq ?u' a" "wb = freq ?u' b"
          using fu' fu [THEN sym] assms by clarsimp+
        ultimately show ?thesis using sa by simp
      qed
    also have "\<dots> \<le> cost u"
      proof -
        have "minima u a b" using au fu assms
          by (subst twice_freq_le_imp_minima) auto
        with cu show ?thesis using ac ad dc dd dc [THEN not_sym]
          by (rule cost_swapFourSyms_le)
      qed
    finally show ?thesis .
  qed
qed

lemma cachedWeight_splitLeaf [simp]:
"cachedWeight (splitLeaf t wa a wb b) = cachedWeight t"
by (case_tac t) simp+

lemma splitLeafF_insortTree_when_in_alphabet_left [simp]:
"\<lbrakk>alphabet t a; consistent t; a \<notin> alphabetF ts; freq t a = wa + wb\<rbrakk> \<Longrightarrow>
 splitLeafF (insortTree t ts) wa a wb b = insortTree (splitLeaf t wa a wb b) ts"
by (induct ts) simp+

lemma splitLeafF_insortTree_when_in_alphabetF_tail [simp]:
"\<lbrakk>a \<in> alphabetF ts; consistentF ts; ~ alphabet t a; freqF ts a = wa + wb\<rbrakk> \<Longrightarrow>
 splitLeafF (insortTree t ts) wa a wb b =
     insortTree t (splitLeafF ts wa a wb b)"
proof (induct ts)
  case Nil thus ?case by simp
next
  case (Cons u us) show ?case
  proof (cases "alphabet u a")
    case True
    moreover hence "a \<notin> alphabetF us" using Cons by auto
    ultimately show ?thesis using Cons by auto
  next
    case False thus ?thesis using Cons by simp
  qed
qed

lemma splitLeaf_huffman_commute:
"\<lbrakk>consistentF ts; ts \<noteq> []; a \<in> alphabetF ts; freqF ts a = wa + wb\<rbrakk> \<Longrightarrow>
 splitLeaf (huffman ts) wa a wb b = huffman (splitLeafF ts wa a wb b)"
proof (induct ts rule: huffman.induct)
  case 3 thus ?case by simp
next
  case (1 t) thus ?case by simp
next
  case (2 t1 t2 ts)
  note hyps = 2
  show ?case
  proof (cases "alphabet t1 a")
    case True
    moreover hence "~ alphabet t2 a" "a \<notin> alphabetF ts" using hyps by auto
    ultimately show ?thesis using hyps by (simp add: uniteTrees_def)
  next
    case False
    note a1 = False
    show ?thesis
    proof (cases "alphabet t2 a")
      case True
      moreover hence "a \<notin> alphabetF ts" using hyps by auto
      ultimately show ?thesis using a1 hyps by (simp add: uniteTrees_def)
    next
      case False
      thus ?thesis using a1 hyps by simp
    qed
  qed
qed

lemma max_0_imp_0 [simp]:
"(max x y = (0::nat)) = (x = 0 \<and> y = 0)"
by auto

fun even and odd where
  "even 0 = True"
| "odd 0 = False"
| "even (Suc n) = odd n"
| "odd (Suc n) = even n"

lemma "even m"
nunchaku[overlord]

lemma "optimum (InnerNode (Suc (Suc 0)) (Leaf (Suc 0) a) (Leaf (Suc 0) a))"
unfolding optimum_def
nxunchaku[overlord, timeout = 60]

theorem optimum_huffman:
"(* \<lbrakk>consistentF ts; (* heightF ts' = 0; *) sortedByWeight ts; ts \<noteq> []\<rbrakk> \<Longrightarrow> *)
 optimum (huffman [])"
unfolding optimum_def
apply auto
(* quickcheck *)
oops
nunchxaku[overlord, timeout = 60]
(* nunchaku[overlord] *)

proof (induct ts rule: length_induct)
  case (1 ts)
  note hyps = 1
  show ?case
  proof (cases ts)
    case Nil thus ?thesis using `ts \<noteq> []` by fast
  next
    case (Cons ta ts')
    note ts = Cons
    show ?thesis
    proof (cases ts')
      case Nil thus ?thesis using ts hyps by (simp add: optimum_def)
    next
      case (Cons tb ts'')
      note ts' = Cons
      show ?thesis
      proof (cases ta)
        case (Leaf wa a)
        note la = Leaf
        show ?thesis
        proof (cases tb)
          case (Leaf wb b)
          note lb = Leaf
          show ?thesis
          proof -
            let ?us = "insortTree (uniteTrees ta tb) ts''"
            let ?us' = "insortTree (Leaf (wa + wb) a) ts''"
            let ?ts = "splitLeaf (huffman ?us') wa a wb b"
            have e1: "huffman ts = huffman ?us" using ts' ts by simp
            have e2: "huffman ?us = ?ts" using la lb ts' ts hyps
              by (auto simp: splitLeaf_huffman_commute uniteTrees_def)

            have "optimum (huffman ?us')" using la ts' ts hyps
              by (drule_tac x = ?us' in spec)
                 (auto dest: sortedByWeight_Cons_imp_sortedByWeight
                       simp: sortedByWeight_insortTree)
            hence "optimum ?ts" using la lb ts' ts hyps
              apply simp
              apply (rule optimum_splitLeaf)
              by (auto dest!: heightF_0_imp_Leaf_freqF_in_set
                              sortedByWeight_Cons_imp_forall_weight_ge)
            thus "optimum (huffman ts)" using e1 e2 by simp
          qed
        next
          case InnerNode thus ?thesis using ts' ts hyps by simp
        qed
      next
        case InnerNode thus ?thesis using ts' ts hyps by simp
      qed
    qed
  qed
qed

end


(*  Title:      FOL/ex/Locale_Test/Locale_Test1.thy
    Author:     Clemens Ballarin, TU Muenchen

Test environment for the locale implementation.
*)

theory Locale_Test1
imports FOL
begin

typedecl int
instance int :: "term" ..

consts plus :: "int => int => int" (infixl "+" 60)
  zero :: int ("0")
  minus :: "int => int" ("- _")

axiomatization where
  int_assoc: "(x + y::int) + z = x + (y + z)" and
  int_zero: "0 + x = x" and
  int_minus: "(-x) + x = 0" and
  int_minus2: "-(-x) = x"

section {* Inference of parameter types *}

locale param1 = fixes p
print_locale! param1

locale param2 = fixes p :: 'b
print_locale! param2

(*
locale param_top = param2 r for r :: "'b :: {}"
  Fails, cannot generalise parameter.
*)

locale param3 = fixes p (infix ".." 50)
print_locale! param3

locale param4 = fixes p :: "'a => 'a => 'a" (infix ".." 50)
print_locale! param4

subsection {* Incremental type constraints *}

locale constraint1 =
  fixes  prod (infixl "**" 65)
  assumes l_id: "x ** y = x"
  assumes assoc: "(x ** y) ** z = x ** (y ** z)"
print_locale! constraint1

locale constraint2 =
  fixes p and q
  assumes "p = q"
print_locale! constraint2

section {* Inheritance *}

locale semi =
  fixes prod (infixl "**" 65)
  assumes assoc: "(x ** y) ** z = x ** (y ** z)"
print_locale! semi thm semi_def

locale lgrp = semi +
  fixes one and inv
  assumes lone: "one ** x = x"
    and linv: "inv(x) ** x = one"
print_locale! lgrp thm lgrp_def lgrp_axioms_def

locale add_lgrp = semi "op ++" for sum (infixl "++" 60) +
  fixes zero and neg
  assumes lzero: "zero ++ x = x"
    and lneg: "neg(x) ++ x = zero"
print_locale! add_lgrp thm add_lgrp_def add_lgrp_axioms_def

locale rev_lgrp = semi "%x y. y ++ x" for sum (infixl "++" 60)
print_locale! rev_lgrp thm rev_lgrp_def

locale hom = f: semi f + g: semi g for f and g
print_locale! hom thm hom_def

locale perturbation = semi + d: semi "%x y. delta(x) ** delta(y)" for delta
print_locale! perturbation thm perturbation_def

locale pert_hom = d1: perturbation f d1 + d2: perturbation f d2 for f d1 d2
print_locale! pert_hom thm pert_hom_def

text {* Alternative expression, obtaining nicer names in @{text "semi f"}. *}
locale pert_hom' = semi f + d1: perturbation f d1 + d2: perturbation f d2 for f d1 d2
print_locale! pert_hom' thm pert_hom'_def

section {* Syntax declarations *}

locale logic =
  fixes land (infixl "&&" 55)
    and lnot ("-- _" [60] 60)
  assumes assoc: "(x && y) && z = x && (y && z)"
    and notnot: "-- (-- x) = x"
begin

definition lor (infixl "||" 50) where
  "x || y = --(-- x && -- y)"

end
print_locale! logic

locale use_decl = l: logic + semi "op ||"
print_locale! use_decl thm use_decl_def

locale extra_type =
  fixes a :: 'a
    and P :: "'a => 'b => o"
begin

definition test :: "'a => o" where
  "test(x) <-> (ALL b. P(x, b))"

end

term extra_type.test thm extra_type.test_def

interpretation var?: extra_type "0" "%x y. x = 0" .

thm var.test_def

text {* Under which circumstances term syntax remains active. *}

locale "syntax" =
  fixes p1 :: "'a => 'b"
    and p2 :: "'b => o"
begin

definition d1 :: "'a => o" where "d1(x) <-> ~ p2(p1(x))"
definition d2 :: "'b => o" where "d2(x) <-> ~ p2(x)"

thm d1_def d2_def

end

thm syntax.d1_def syntax.d2_def

locale syntax' = "syntax" p1 p2 for p1 :: "'a => 'a" and p2 :: "'a => o"
begin

thm d1_def d2_def  (* should print as "d1(?x) <-> ..." and "d2(?x) <-> ..." *)

ML {*
  fun check_syntax ctxt thm expected =
    let
      val obtained =
        Print_Mode.setmp [] (Display.string_of_thm (Config.put show_markup false ctxt)) thm;
    in
      if obtained <> expected
      then error ("Theorem syntax '" ^ obtained ^ "' obtained, but '" ^ expected ^ "' expected.")
      else ()
    end;
*}

declare [[show_hyps]]

ML {*
  check_syntax @{context} @{thm d1_def} "d1(?x) <-> ~ p2(p1(?x))";
  check_syntax @{context} @{thm d2_def} "d2(?x) <-> ~ p2(?x)";
*}

end

locale syntax'' = "syntax" p3 p2 for p3 :: "'a => 'b" and p2 :: "'b => o"
begin

thm d1_def d2_def
  (* should print as "syntax.d1(p3, p2, ?x) <-> ..." and "d2(?x) <-> ..." *)

ML {*
  check_syntax @{context} @{thm d1_def} "syntax.d1(p3, p2, ?x) <-> ~ p2(p3(?x))";
  check_syntax @{context} @{thm d2_def} "d2(?x) <-> ~ p2(?x)";
*}

end

section {* Foundational versions of theorems *}

thm logic.assoc
thm logic.lor_def

section {* Defines *}

locale logic_def =
  fixes land (infixl "&&" 55)
    and lor (infixl "||" 50)
    and lnot ("-- _" [60] 60)
  assumes assoc: "(x && y) && z = x && (y && z)"
    and notnot: "-- (-- x) = x"
  defines "x || y == --(-- x && -- y)"
begin

thm lor_def

lemma "x || y = --(-- x && --y)"
  by (unfold lor_def) (rule refl)

end

(* Inheritance of defines *)

locale logic_def2 = logic_def
begin

lemma "x || y = --(-- x && --y)"
  by (unfold lor_def) (rule refl)

end

section {* Notes *}

(* A somewhat arcane homomorphism example *)

definition semi_hom where
  "semi_hom(prod, sum, h) <-> (ALL x y. h(prod(x, y)) = sum(h(x), h(y)))"

lemma semi_hom_mult:
  "semi_hom(prod, sum, h) ==> h(prod(x, y)) = sum(h(x), h(y))"
  by (simp add: semi_hom_def)

locale semi_hom_loc = prod: semi prod + sum: semi sum
  for prod and sum and h +
  assumes semi_homh: "semi_hom(prod, sum, h)"
  notes semi_hom_mult = semi_hom_mult [OF semi_homh]

thm semi_hom_loc.semi_hom_mult
(* unspecified, attribute not applied in backgroud theory !!! *)

lemma (in semi_hom_loc) "h(prod(x, y)) = sum(h(x), h(y))"
  by (rule semi_hom_mult)

(* Referring to facts from within a context specification *)

lemma
  assumes x: "P <-> P"
  notes y = x
  shows True ..

section {* Theorem statements *}

lemma (in lgrp) lcancel:
  "x ** y = x ** z <-> y = z"
proof
  assume "x ** y = x ** z"
  then have "inv(x) ** x ** y = inv(x) ** x ** z" by (simp add: assoc)
  then show "y = z" by (simp add: lone linv)
qed simp
print_locale! lgrp

locale rgrp = semi +
  fixes one and inv
  assumes rone: "x ** one = x"
    and rinv: "x ** inv(x) = one"
begin

lemma rcancel:
  "y ** x = z ** x <-> y = z"
proof
  assume "y ** x = z ** x"
  then have "y ** (x ** inv(x)) = z ** (x ** inv(x))"
    by (simp add: assoc [symmetric])
  then show "y = z" by (simp add: rone rinv)
qed simp

end
print_locale! rgrp

subsection {* Patterns *}

lemma (in rgrp)
  assumes "y ** x = z ** x" (is ?a)
  shows "y = z" (is ?t)
proof -
  txt {* Weird proof involving patterns from context element and conclusion. *}
  {
    assume ?a
    then have "y ** (x ** inv(x)) = z ** (x ** inv(x))"
      by (simp add: assoc [symmetric])
    then have ?t by (simp add: rone rinv)
  }
  note x = this
  show ?t by (rule x [OF `?a`])
qed

section {* Interpretation between locales: sublocales *}

sublocale lgrp < right: rgrp
print_facts
proof unfold_locales
  {
    fix x
    have "inv(x) ** x ** one = inv(x) ** x" by (simp add: linv lone)
    then show "x ** one = x" by (simp add: assoc lcancel)
  }
  note rone = this
  {
    fix x
    have "inv(x) ** x ** inv(x) = inv(x) ** one"
      by (simp add: linv lone rone)
    then show "x ** inv(x) = one" by (simp add: assoc lcancel)
  }
qed

(* effect on printed locale *)

print_locale! lgrp

(* use of derived theorem *)

lemma (in lgrp)
  "y ** x = z ** x <-> y = z"
  apply (rule rcancel)
  done

(* circular interpretation *)

sublocale rgrp < left: lgrp
proof unfold_locales
  {
    fix x
    have "one ** (x ** inv(x)) = x ** inv(x)" by (simp add: rinv rone)
    then show "one ** x = x" by (simp add: assoc [symmetric] rcancel)
  }
  note lone = this
  {
    fix x
    have "inv(x) ** (x ** inv(x)) = one ** inv(x)"
      by (simp add: rinv lone rone)
    then show "inv(x) ** x = one" by (simp add: assoc [symmetric] rcancel)
  }
qed

(* effect on printed locale *)

print_locale! rgrp
print_locale! lgrp

(* Duality *)

locale order =
  fixes less :: "'a => 'a => o" (infix "<<" 50)
  assumes refl: "x << x"
    and trans: "[| x << y; y << z |] ==> x << z"

sublocale order < dual: order "%x y. y << x"
  apply unfold_locales apply (rule refl) apply (blast intro: trans)
  done

print_locale! order  (* Only two instances of order. *)

locale order' =
  fixes less :: "'a => 'a => o" (infix "<<" 50)
  assumes refl: "x << x"
    and trans: "[| x << y; y << z |] ==> x << z"

locale order_with_def = order'
begin

definition greater :: "'a => 'a => o" (infix ">>" 50) where
  "x >> y <-> y << x"

end

sublocale order_with_def < dual: order' "op >>"
  apply unfold_locales
  unfolding greater_def
  apply (rule refl) apply (blast intro: trans)
  done

print_locale! order_with_def
(* Note that decls come after theorems that make use of them. *)

(* locale with many parameters ---
   interpretations generate alternating group A5 *)

locale A5 =
  fixes A and B and C and D and E
  assumes eq: "A <-> B <-> C <-> D <-> E"

sublocale A5 < 1: A5 _ _ D E C
print_facts
  using eq apply (blast intro: A5.intro) done

sublocale A5 < 2: A5 C _ E _ A
print_facts
  using eq apply (blast intro: A5.intro) done

sublocale A5 < 3: A5 B C A _ _
print_facts
  using eq apply (blast intro: A5.intro) done

(* Any even permutation of parameters is subsumed by the above. *)

print_locale! A5

(* Free arguments of instance *)

locale trivial =
  fixes P and Q :: o
  assumes Q: "P <-> P <-> Q"
begin

lemma Q_triv: "Q" using Q by fast

end

sublocale trivial < x: trivial x _
  apply unfold_locales using Q by fast

print_locale! trivial

context trivial begin thm x.Q [where ?x = True] end

sublocale trivial < y: trivial Q Q
  by unfold_locales
  (* Succeeds since previous interpretation is more general. *)

print_locale! trivial  (* No instance for y created (subsumed). *)

subsection {* Sublocale, then interpretation in theory *}

interpretation int?: lgrp "op +" "0" "minus"
proof unfold_locales
qed (rule int_assoc int_zero int_minus)+

thm int.assoc int.semi_axioms

interpretation int2?: semi "op +"
  by unfold_locales  (* subsumed, thm int2.assoc not generated *)

ML {* (Global_Theory.get_thms @{theory} "int2.assoc";
    raise Fail "thm int2.assoc was generated")
  handle ERROR _ => ([]:thm list); *}

thm int.lone int.right.rone
  (* the latter comes through the sublocale relation *)

subsection {* Interpretation in theory, then sublocale *}

interpretation fol: logic "op +" "minus"
  by unfold_locales (rule int_assoc int_minus2)+

locale logic2 =
  fixes land (infixl "&&" 55)
    and lnot ("-- _" [60] 60)
  assumes assoc: "(x && y) && z = x && (y && z)"
    and notnot: "-- (-- x) = x"
begin

definition lor (infixl "||" 50) where
  "x || y = --(-- x && -- y)"

end

sublocale logic < two: logic2
  by unfold_locales (rule assoc notnot)+

thm fol.two.assoc

subsection {* Declarations and sublocale *}

locale logic_a = logic
locale logic_b = logic

sublocale logic_a < logic_b
  by unfold_locales

subsection {* Interpretation *}

subsection {* Rewrite morphism *}

locale logic_o =
  fixes land (infixl "&&" 55)
    and lnot ("-- _" [60] 60)
  assumes assoc_o: "(x && y) && z <-> x && (y && z)"
    and notnot_o: "-- (-- x) <-> x"
begin

definition lor_o (infixl "||" 50) where
  "x || y <-> --(-- x && -- y)"

end

interpretation x: logic_o "op &" "Not"
  where bool_logic_o: "x.lor_o(x, y) <-> x | y"
proof -
  show bool_logic_o: "PROP logic_o(op &, Not)" by unfold_locales fast+
  show "logic_o.lor_o(op &, Not, x, y) <-> x | y"
    by (unfold logic_o.lor_o_def [OF bool_logic_o]) fast
qed

thm x.lor_o_def bool_logic_o

lemma lor_triv: "z <-> z" ..

lemma (in logic_o) lor_triv: "x || y <-> x || y" by fast

thm lor_triv [where z = True] (* Check strict prefix. *)
  x.lor_triv

subsection {* Inheritance of rewrite morphisms *}

locale reflexive =
  fixes le :: "'a => 'a => o" (infix "\<sqsubseteq>" 50)
  assumes refl: "x \<sqsubseteq> x"
begin

definition less (infix "\<sqsubset>" 50) where "x \<sqsubset> y <-> x \<sqsubseteq> y & x ~= y"

end

axiomatization
  gle :: "'a => 'a => o" and gless :: "'a => 'a => o" and
  gle' :: "'a => 'a => o" and gless' :: "'a => 'a => o"
where
  grefl: "gle(x, x)" and gless_def: "gless(x, y) <-> gle(x, y) & x ~= y" and
  grefl': "gle'(x, x)" and gless'_def: "gless'(x, y) <-> gle'(x, y) & x ~= y"

text {* Setup *}

locale mixin = reflexive
begin
lemmas less_thm = less_def
end

interpretation le: mixin gle where "reflexive.less(gle, x, y) <-> gless(x, y)"
proof -
  show "mixin(gle)" by unfold_locales (rule grefl)
  note reflexive = this[unfolded mixin_def]
  show "reflexive.less(gle, x, y) <-> gless(x, y)"
    by (simp add: reflexive.less_def[OF reflexive] gless_def)
qed

text {* Rewrite morphism propagated along the locale hierarchy *}

locale mixin2 = mixin
begin
lemmas less_thm2 = less_def
end

interpretation le: mixin2 gle
  by unfold_locales

thm le.less_thm2  (* rewrite morphism applied *)
lemma "gless(x, y) <-> gle(x, y) & x ~= y"
  by (rule le.less_thm2)

text {* Rewrite morphism does not leak to a side branch. *}

locale mixin3 = reflexive
begin
lemmas less_thm3 = less_def
end

interpretation le: mixin3 gle
  by unfold_locales

thm le.less_thm3  (* rewrite morphism not applied *)
lemma "reflexive.less(gle, x, y) <-> gle(x, y) & x ~= y" by (rule le.less_thm3)

text {* Rewrite morphism only available in original context *}

locale mixin4_base = reflexive

locale mixin4_mixin = mixin4_base

interpretation le: mixin4_mixin gle
  where "reflexive.less(gle, x, y) <-> gless(x, y)"
proof -
  show "mixin4_mixin(gle)" by unfold_locales (rule grefl)
  note reflexive = this[unfolded mixin4_mixin_def mixin4_base_def mixin_def]
  show "reflexive.less(gle, x, y) <-> gless(x, y)"
    by (simp add: reflexive.less_def[OF reflexive] gless_def)
qed

locale mixin4_copy = mixin4_base
begin
lemmas less_thm4 = less_def
end

locale mixin4_combined = le1: mixin4_mixin le' + le2: mixin4_copy le for le' le
begin
lemmas less_thm4' = less_def
end

interpretation le4: mixin4_combined gle' gle
  by unfold_locales (rule grefl')

thm le4.less_thm4' (* rewrite morphism not applied *)
lemma "reflexive.less(gle, x, y) <-> gle(x, y) & x ~= y"
  by (rule le4.less_thm4')

text {* Inherited rewrite morphism applied to new theorem *}

locale mixin5_base = reflexive

locale mixin5_inherited = mixin5_base

interpretation le5: mixin5_base gle
  where "reflexive.less(gle, x, y) <-> gless(x, y)"
proof -
  show "mixin5_base(gle)" by unfold_locales
  note reflexive = this[unfolded mixin5_base_def mixin_def]
  show "reflexive.less(gle, x, y) <-> gless(x, y)"
    by (simp add: reflexive.less_def[OF reflexive] gless_def)
qed

interpretation le5: mixin5_inherited gle
  by unfold_locales

lemmas (in mixin5_inherited) less_thm5 = less_def

thm le5.less_thm5  (* rewrite morphism applied *)
lemma "gless(x, y) <-> gle(x, y) & x ~= y"
  by (rule le5.less_thm5)

text {* Rewrite morphism pushed down to existing inherited locale *}

locale mixin6_base = reflexive

locale mixin6_inherited = mixin5_base

interpretation le6: mixin6_base gle
  by unfold_locales
interpretation le6: mixin6_inherited gle
  by unfold_locales
interpretation le6: mixin6_base gle
  where "reflexive.less(gle, x, y) <-> gless(x, y)"
proof -
  show "mixin6_base(gle)" by unfold_locales
  note reflexive = this[unfolded mixin6_base_def mixin_def]
  show "reflexive.less(gle, x, y) <-> gless(x, y)"
    by (simp add: reflexive.less_def[OF reflexive] gless_def)
qed

lemmas (in mixin6_inherited) less_thm6 = less_def

thm le6.less_thm6  (* mixin applied *)
lemma "gless(x, y) <-> gle(x, y) & x ~= y"
  by (rule le6.less_thm6)

text {* Existing rewrite morphism inherited through sublocale relation *}

locale mixin7_base = reflexive

locale mixin7_inherited = reflexive

interpretation le7: mixin7_base gle
  where "reflexive.less(gle, x, y) <-> gless(x, y)"
proof -
  show "mixin7_base(gle)" by unfold_locales
  note reflexive = this[unfolded mixin7_base_def mixin_def]
  show "reflexive.less(gle, x, y) <-> gless(x, y)"
    by (simp add: reflexive.less_def[OF reflexive] gless_def)
qed

interpretation le7: mixin7_inherited gle
  by unfold_locales

lemmas (in mixin7_inherited) less_thm7 = less_def

thm le7.less_thm7  (* before, rewrite morphism not applied *)
lemma "reflexive.less(gle, x, y) <-> gle(x, y) & x ~= y"
  by (rule le7.less_thm7)

sublocale mixin7_inherited < mixin7_base
  by unfold_locales

lemmas (in mixin7_inherited) less_thm7b = less_def

thm le7.less_thm7b  (* after, mixin applied *)
lemma "gless(x, y) <-> gle(x, y) & x ~= y"
  by (rule le7.less_thm7b)

text {* This locale will be interpreted in later theories. *}

locale mixin_thy_merge = le: reflexive le + le': reflexive le' for le le'

subsection {* Rewrite morphisms in sublocale *}

text {* Simulate a specification of left groups where unit and inverse are defined
  rather than specified.  This is possible, but not in FOL, due to the lack of a
  selection operator. *}

axiomatization glob_one and glob_inv
  where glob_lone: "prod(glob_one(prod), x) = x"
    and glob_linv: "prod(glob_inv(prod, x), x) = glob_one(prod)"

locale dgrp = semi
begin

definition one where "one = glob_one(prod)"

lemma lone: "one ** x = x"
  unfolding one_def by (rule glob_lone)

definition inv where "inv(x) = glob_inv(prod, x)"

lemma linv: "inv(x) ** x = one"
  unfolding one_def inv_def by (rule glob_linv)

end

sublocale lgrp < "def": dgrp
  where one_equation: "dgrp.one(prod) = one" and inv_equation: "dgrp.inv(prod, x) = inv(x)"
proof -
  show "dgrp(prod)" by unfold_locales
  from this interpret d: dgrp .
  -- Unit
  have "dgrp.one(prod) = glob_one(prod)" by (rule d.one_def)
  also have "... = glob_one(prod) ** one" by (simp add: rone)
  also have "... = one" by (simp add: glob_lone)
  finally show "dgrp.one(prod) = one" .
  -- Inverse
  then have "dgrp.inv(prod, x) ** x = inv(x) ** x" by (simp add: glob_linv d.linv linv)
  then show "dgrp.inv(prod, x) = inv(x)" by (simp add: rcancel)
qed

print_locale! lgrp

context lgrp begin

text {* Equations stored in target *}

lemma "dgrp.one(prod) = one" by (rule one_equation)
lemma "dgrp.inv(prod, x) = inv(x)" by (rule inv_equation)

text {* Rewrite morphisms applied *}

lemma "one = glob_one(prod)" by (rule one_def)
lemma "inv(x) = glob_inv(prod, x)" by (rule inv_def)

end

text {* Interpreted versions *}

lemma "0 = glob_one (op +)" by (rule int.def.one_def)
lemma "- x = glob_inv(op +, x)" by (rule int.def.inv_def)

text {* Roundup applies rewrite morphisms at declaration level in DFS tree *}

locale roundup = fixes x assumes true: "x <-> True"

sublocale roundup \<subseteq> sub: roundup x where "x <-> True & True"
  apply unfold_locales apply (simp add: true) done
lemma (in roundup) "True & True <-> True" by (rule sub.true)

section {* Interpretation in named contexts *}

locale container
begin
interpretation private!: roundup True by unfold_locales rule
lemmas true_copy = private.true
end

context container begin
ML {* (Context.>> (fn generic => let val context = Context.proof_of generic
  val _ = Proof_Context.get_thms context "private.true" in generic end);
  raise Fail "thm private.true was persisted")
  handle ERROR _ => ([]:thm list); *}
thm true_copy
end

section {* Interpretation in proofs *}

lemma True
proof
  interpret "local": lgrp "op +" "0" "minus"
    by unfold_locales  (* subsumed *)
  {
    fix zero :: int
    assume "!!x. zero + x = x" "!!x. (-x) + x = zero"
    then interpret local_fixed: lgrp "op +" zero "minus"
      by unfold_locales
    thm local_fixed.lone
    print_dependencies! lgrp "op +" 0 minus + lgrp "op +" zero minus
  }
  assume "!!x zero. zero + x = x" "!!x zero. (-x) + x = zero"
  then interpret local_free: lgrp "op +" zero "minus" for zero
    by unfold_locales
  thm local_free.lone [where ?zero = 0]
qed

lemma True
proof
  {
    fix pand and pnot and por
    assume passoc: "!!x y z. pand(pand(x, y), z) <-> pand(x, pand(y, z))"
      and pnotnot: "!!x. pnot(pnot(x)) <-> x"
      and por_def: "!!x y. por(x, y) <-> pnot(pand(pnot(x), pnot(y)))"
    interpret loc: logic_o pand pnot
      where por_eq: "!!x y. logic_o.lor_o(pand, pnot, x, y) <-> por(x, y)"  (* FIXME *)
    proof -
      show logic_o: "PROP logic_o(pand, pnot)" using passoc pnotnot by unfold_locales
      fix x y
      show "logic_o.lor_o(pand, pnot, x, y) <-> por(x, y)"
        by (unfold logic_o.lor_o_def [OF logic_o]) (rule por_def [symmetric])
    qed
    print_interps logic_o
    have "!!x y. por(x, y) <-> pnot(pand(pnot(x), pnot(y)))" by (rule loc.lor_o_def)
  }
qed

end


header {*  Preliminaries  *}

theory Preliminaries
imports Main "../LatticeProperties/Complete_Lattice_Prop"
  "../LatticeProperties/Conj_Disj"
begin

notation
  less_eq (infix "\<sqsubseteq>" 50) and
  less (infix "\<sqsubset>" 50) and
  inf (infixl "\<sqinter>" 70) and
  sup (infixl "\<squnion>" 65) and
  top ("\<top>") and
  bot ("\<bottom>") and
  Inf ("\<Sqinter>_" [900] 900) and
  Sup ("\<Squnion>_" [900] 900)

subsection {*Simplification Lemmas*}

declare fun_upd_idem[simp]

lemma simp_eq_emptyset:
  "(X = {}) = (\<forall> x. x \<notin> X)"
  by blast

lemma mono_comp: "mono f \<Longrightarrow> mono g \<Longrightarrow> mono (f o g)"
  by (unfold mono_def) auto

text {*Some lattice simplification rules*}

lemma inf_bot_bot: (* FIXME *)
  "(x::'a::{semilattice_inf,order_bot}) \<sqinter> \<bottom> = \<bottom>"
  apply (rule antisym)
  by auto

end


(*
  Authors: J. Divasón, R. Thiemann, A. Yamada, O. Kunčar
*)

subsection \<open>Transfer rules to convert theorems from JNF to HMA and vice-versa.\<close>

theory HMA_Connect
imports
  Jordan_Normal_Form.Spectral_Radius
  "HOL-Analysis.Determinants"
  "HOL-Analysis.Cartesian_Euclidean_Space"
  Bij_Nat
  Cancel_Card_Constraint
  "HOL-Eisbach.Eisbach"
begin

text \<open>Prefer certain constants and lemmas without prefix.\<close>

hide_const (open) Matrix.mat
hide_const (open) Matrix.row
hide_const (open) Determinant.det

lemmas mat_def = Finite_Cartesian_Product.mat_def
lemmas det_def = Determinants.det_def
lemmas row_def = Finite_Cartesian_Product.row_def

notation vec_index (infixl "$v" 90)
notation vec_nth (infixl "$h" 90)

text \<open>Forget that @{typ "'a mat"}, @{typ "'a Matrix.vec"}, and @{typ "'a poly"}
  have been defined via lifting\<close>

(* TODO: add to end of matrix theory, stores lifting + transfer setup *)
lifting_forget vec.lifting
lifting_forget mat.lifting

lifting_forget poly.lifting

text \<open>Some notions which we did not find in the HMA-world.\<close>
definition eigen_vector :: "'a::comm_ring_1 ^ 'n ^ 'n \<Rightarrow> 'a ^ 'n \<Rightarrow> 'a \<Rightarrow> bool" where
  "eigen_vector A v ev = (v \<noteq> 0 \<and> A *v v = ev *s v)"

definition eigen_value :: "'a :: comm_ring_1 ^ 'n ^ 'n \<Rightarrow> 'a \<Rightarrow> bool" where
  "eigen_value A k = (\<exists> v. eigen_vector A v k)"

definition similar_matrix_wit
  :: "'a :: semiring_1 ^ 'n ^ 'n \<Rightarrow> 'a ^ 'n ^ 'n \<Rightarrow> 'a ^ 'n ^ 'n \<Rightarrow> 'a ^ 'n ^ 'n \<Rightarrow> bool" where
  "similar_matrix_wit A B P Q = (P ** Q = mat 1 \<and> Q ** P = mat 1 \<and> A = P ** B ** Q)"

definition similar_matrix
  :: "'a :: semiring_1 ^ 'n ^ 'n \<Rightarrow> 'a ^ 'n ^ 'n \<Rightarrow> bool" where
  "similar_matrix A B = (\<exists> P Q. similar_matrix_wit A B P Q)"

definition spectral_radius :: "complex ^ 'n ^ 'n \<Rightarrow> real" where
  "spectral_radius A = Max { norm ev | v ev. eigen_vector A v ev}"

definition Spectrum :: "'a :: field ^ 'n ^ 'n \<Rightarrow> 'a set" where
  "Spectrum A = Collect (eigen_value A)"

definition vec_elements_h :: "'a ^ 'n \<Rightarrow> 'a set" where
  "vec_elements_h v = range (vec_nth v)"

lemma vec_elements_h_def': "vec_elements_h v = {v $h i | i. True}"
  unfolding vec_elements_h_def by auto

definition elements_mat_h :: "'a ^ 'nc ^ 'nr \<Rightarrow> 'a set" where
  "elements_mat_h A = range (\<lambda> (i,j). A $h i $h j)"

lemma elements_mat_h_def': "elements_mat_h A = {A $h i $h j | i j. True}"
  unfolding elements_mat_h_def by auto

definition map_vector :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ^'n \<Rightarrow> 'b ^'n" where
  "map_vector f v \<equiv> \<chi> i. f (v $h i)"

definition map_matrix :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ^ 'n ^ 'm \<Rightarrow> 'b ^ 'n ^ 'm" where
  "map_matrix f A \<equiv> \<chi> i. map_vector f (A $h i)"

definition normbound :: "'a :: real_normed_field ^ 'nc ^ 'nr \<Rightarrow> real \<Rightarrow> bool" where
  "normbound A b \<equiv> \<forall> x \<in> elements_mat_h A. norm x \<le> b"

lemma spectral_radius_ev_def: "spectral_radius A = Max (norm ` (Collect (eigen_value A)))"
  unfolding spectral_radius_def eigen_value_def[abs_def]
  by (rule arg_cong[where f = Max], auto)

lemma elements_mat: "elements_mat A = {A $$ (i,j) | i j. i < dim_row A \<and> j < dim_col A}"
  unfolding elements_mat_def by force

definition vec_elements :: "'a Matrix.vec \<Rightarrow> 'a set"
  where "vec_elements v = set [v $ i. i <- [0 ..< dim_vec v]]"

lemma vec_elements: "vec_elements v = { v $ i | i. i < dim_vec v}"
  unfolding vec_elements_def by auto

(* TODO: restore a bundle, for e.g., for matrix_impl *)
context includes vec.lifting
begin
end

definition from_hma\<^sub>v :: "'a ^ 'n  \<Rightarrow> 'a Matrix.vec" where
  "from_hma\<^sub>v v = Matrix.vec CARD('n) (\<lambda> i. v $h from_nat i)"

definition from_hma\<^sub>m :: "'a ^ 'nc ^ 'nr \<Rightarrow> 'a Matrix.mat" where
  "from_hma\<^sub>m a = Matrix.mat CARD('nr) CARD('nc) (\<lambda> (i,j). a $h from_nat i $h from_nat j)"

definition to_hma\<^sub>v :: "'a Matrix.vec \<Rightarrow> 'a ^ 'n" where
  "to_hma\<^sub>v v = (\<chi> i. v $v to_nat i)"

definition to_hma\<^sub>m :: "'a Matrix.mat \<Rightarrow> 'a ^ 'nc  ^ 'nr " where
  "to_hma\<^sub>m a = (\<chi> i j. a $$ (to_nat i, to_nat j))"

declare vec_lambda_eta[simp]

lemma to_hma_from_hma\<^sub>v[simp]: "to_hma\<^sub>v (from_hma\<^sub>v v) = v"
  by (auto simp: to_hma\<^sub>v_def from_hma\<^sub>v_def to_nat_less_card)

lemma from_hma_to_hma\<^sub>v[simp]:
  "v \<in> carrier_vec (CARD('n)) \<Longrightarrow> from_hma\<^sub>v (to_hma\<^sub>v v :: 'a ^ 'n) = v"
  by (auto simp: to_hma\<^sub>v_def from_hma\<^sub>v_def to_nat_from_nat_id)

lemma from_hma_to_hma\<^sub>m[simp]:
  "A \<in> carrier_mat (CARD('nr)) (CARD('nc)) \<Longrightarrow> from_hma\<^sub>m (to_hma\<^sub>m A :: 'a ^ 'nc  ^ 'nr) = A"
  by (auto simp: to_hma\<^sub>m_def from_hma\<^sub>m_def to_nat_from_nat_id)

lemma from_hma\<^sub>v_inj[simp]: "from_hma\<^sub>v x = from_hma\<^sub>v y \<longleftrightarrow> x = y"
  by (intro iffI, insert to_hma_from_hma\<^sub>v[of x], auto)

lemma from_hma\<^sub>m_inj[simp]: "from_hma\<^sub>m x = from_hma\<^sub>m y \<longleftrightarrow> x = y"
  by(intro iffI, insert to_hma_from_hma\<^sub>m[of x], auto)

definition HMA_V :: "'a Matrix.vec \<Rightarrow> 'a ^ 'n  \<Rightarrow> bool" where
  "HMA_V = (\<lambda> v w. v = from_hma\<^sub>v w)"

definition HMA_M :: "'a Matrix.mat \<Rightarrow> 'a ^ 'nc  ^ 'nr  \<Rightarrow> bool" where
  "HMA_M = (\<lambda> a b. a = from_hma\<^sub>m b)"

definition HMA_I :: "nat \<Rightarrow> 'n :: finite \<Rightarrow> bool" where
  "HMA_I = (\<lambda> i a. i = to_nat a)"

context includes lifting_syntax
begin

lemma Domainp_HMA_V [transfer_domain_rule]:
  "Domainp (HMA_V :: 'a Matrix.vec \<Rightarrow> 'a ^ 'n \<Rightarrow> bool) = (\<lambda> v. v \<in> carrier_vec (CARD('n )))"
  by(intro ext iffI, insert from_hma_to_hma\<^sub>v[symmetric], auto simp: from_hma\<^sub>v_def HMA_V_def)

lemma Domainp_HMA_M [transfer_domain_rule]:
  "Domainp (HMA_M :: 'a Matrix.mat \<Rightarrow> 'a ^ 'nc  ^ 'nr  \<Rightarrow> bool)
  = (\<lambda> A. A \<in> carrier_mat CARD('nr) CARD('nc))"
  by (intro ext iffI, insert from_hma_to_hma\<^sub>m[symmetric], auto simp: from_hma\<^sub>m_def HMA_M_def)

lemma Domainp_HMA_I [transfer_domain_rule]:
  "Domainp (HMA_I :: nat \<Rightarrow> 'n :: finite \<Rightarrow> bool) = (\<lambda> i. i < CARD('n))" (is "?l = ?r")
proof (intro ext)
  fix i :: nat
  show "?l i = ?r i"
    unfolding HMA_I_def Domainp_iff
    by (auto intro: exI[of _ "from_nat i"] simp: to_nat_from_nat_id to_nat_less_card)
qed

lemma bi_unique_HMA_V [transfer_rule]: "bi_unique HMA_V" "left_unique HMA_V" "right_unique HMA_V"
  unfolding HMA_V_def bi_unique_def left_unique_def right_unique_def by auto

lemma bi_unique_HMA_M [transfer_rule]: "bi_unique HMA_M" "left_unique HMA_M" "right_unique HMA_M"
  unfolding HMA_M_def bi_unique_def left_unique_def right_unique_def by auto

lemma bi_unique_HMA_I [transfer_rule]: "bi_unique HMA_I" "left_unique HMA_I" "right_unique HMA_I"
  unfolding HMA_I_def bi_unique_def left_unique_def right_unique_def by auto

lemma right_total_HMA_V [transfer_rule]: "right_total HMA_V"
  unfolding HMA_V_def right_total_def by simp

lemma right_total_HMA_M [transfer_rule]: "right_total HMA_M"
  unfolding HMA_M_def right_total_def by simp

lemma right_total_HMA_I [transfer_rule]: "right_total HMA_I"
  unfolding HMA_I_def right_total_def by simp

lemma HMA_V_index [transfer_rule]: "(HMA_V ===> HMA_I ===> (=)) ($v) ($h)"
  unfolding rel_fun_def HMA_V_def HMA_I_def from_hma\<^sub>v_def
  by (auto simp: to_nat_less_card)

text \<open>We introduce the index function to have pointwise access to
  HMA-matrices by a constant. Otherwise, the transfer rule
  with @{term "\<lambda> A i j. A $h i $h j"} instead of index is not applicable.\<close>

definition "index_hma A i j \<equiv> A $h i $h j"

lemma HMA_M_index [transfer_rule]:
  "(HMA_M ===> HMA_I ===> HMA_I ===> (=)) (\<lambda> A i j. A $$ (i,j)) index_hma"
  by (intro rel_funI, simp add: index_hma_def to_nat_less_card HMA_M_def HMA_I_def from_hma\<^sub>m_def)

lemma HMA_V_0 [transfer_rule]: "HMA_V (0\<^sub>v CARD('n)) (0 :: 'a :: zero ^ 'n)"
  unfolding HMA_V_def from_hma\<^sub>v_def by auto

lemma HMA_M_0 [transfer_rule]:
  "HMA_M (0\<^sub>m CARD('nr) CARD('nc)) (0 :: 'a :: zero ^ 'nc  ^ 'nr )"
  unfolding HMA_M_def from_hma\<^sub>m_def by auto

lemma HMA_M_1[transfer_rule]:
  "HMA_M (1\<^sub>m (CARD('n))) (mat 1 :: 'a::{zero,one}^'n^'n)"
  unfolding HMA_M_def
  by (auto simp add: mat_def from_hma\<^sub>m_def from_nat_inj)

lemma from_hma\<^sub>v_add: "from_hma\<^sub>v v + from_hma\<^sub>v w = from_hma\<^sub>v (v + w)"
  unfolding from_hma\<^sub>v_def by auto

lemma HMA_V_add [transfer_rule]: "(HMA_V ===> HMA_V ===> HMA_V) (+) (+) "
  unfolding rel_fun_def HMA_V_def
  by (auto simp: from_hma\<^sub>v_add)

lemma from_hma\<^sub>v_diff: "from_hma\<^sub>v v - from_hma\<^sub>v w = from_hma\<^sub>v (v - w)"
  unfolding from_hma\<^sub>v_def by auto

lemma HMA_V_diff [transfer_rule]: "(HMA_V ===> HMA_V ===> HMA_V) (-) (-)"
  unfolding rel_fun_def HMA_V_def
  by (auto simp: from_hma\<^sub>v_diff)

lemma from_hma\<^sub>m_add: "from_hma\<^sub>m a + from_hma\<^sub>m b = from_hma\<^sub>m (a + b)"
  unfolding from_hma\<^sub>m_def by auto

lemma HMA_M_add [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (+) (+) "
  unfolding rel_fun_def HMA_M_def
  by (auto simp: from_hma\<^sub>m_add)

lemma from_hma\<^sub>m_diff: "from_hma\<^sub>m a - from_hma\<^sub>m b = from_hma\<^sub>m (a - b)"
  unfolding from_hma\<^sub>m_def by auto

lemma HMA_M_diff [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (-) (-) "
  unfolding rel_fun_def HMA_M_def
  by (auto simp: from_hma\<^sub>m_diff)

lemma scalar_product: fixes v :: "'a :: semiring_1 ^ 'n "
  shows "scalar_prod (from_hma\<^sub>v v) (from_hma\<^sub>v w) = scalar_product v w"
  unfolding scalar_product_def scalar_prod_def from_hma\<^sub>v_def dim_vec
  by (simp add: sum.reindex[OF inj_to_nat, unfolded range_to_nat])

lemma [simp]:
  "from_hma\<^sub>v (y :: 'a ^ 'n) \<in> carrier_vec (CARD('n))"
  "dim_vec (from_hma\<^sub>v (y :: 'a ^ 'n)) = CARD('n)"
  unfolding from_hma\<^sub>v_def by simp_all

declare rel_funI [intro!]

lemma HMA_scalar_prod [transfer_rule]:
  "(HMA_V ===> HMA_V ===> (=)) scalar_prod scalar_product"
  by (auto simp: HMA_V_def scalar_product)

lemma HMA_row [transfer_rule]: "(HMA_I ===> HMA_M ===> HMA_V) (\<lambda> i a. Matrix.row a i) row"
  unfolding HMA_M_def HMA_I_def HMA_V_def
  by (auto simp: from_hma\<^sub>m_def from_hma\<^sub>v_def to_nat_less_card row_def)

lemma HMA_col [transfer_rule]: "(HMA_I ===> HMA_M ===> HMA_V) (\<lambda> i a. col a i) column"
  unfolding HMA_M_def HMA_I_def HMA_V_def
  by (auto simp: from_hma\<^sub>m_def from_hma\<^sub>v_def to_nat_less_card column_def)

definition mk_mat :: "('i \<Rightarrow> 'j \<Rightarrow> 'c) \<Rightarrow> 'c^'j^'i" where
  "mk_mat f = (\<chi> i j. f i j)"

definition mk_vec :: "('i \<Rightarrow> 'c) \<Rightarrow> 'c^'i" where
  "mk_vec f = (\<chi> i. f i)"

lemma HMA_M_mk_mat[transfer_rule]: "((HMA_I ===> HMA_I ===> (=)) ===> HMA_M)
  (\<lambda> f. Matrix.mat (CARD('nr)) (CARD('nc)) (\<lambda> (i,j). f i j))
  (mk_mat :: (('nr \<Rightarrow> 'nc \<Rightarrow> 'a) \<Rightarrow> 'a^'nc^'nr))"
proof-
  {
    fix x y i j
    assume id: "\<forall> (ya :: 'nr) (yb :: 'nc). (x (to_nat ya) (to_nat yb) :: 'a) = y ya yb"
       and i: "i < CARD('nr)" and j: "j < CARD('nc)"
    from to_nat_from_nat_id[OF i] to_nat_from_nat_id[OF j] id[rule_format, of "from_nat i" "from_nat j"]
    have "x i j = y (from_nat i) (from_nat j)" by auto
  }
  thus ?thesis
    unfolding rel_fun_def mk_mat_def HMA_M_def HMA_I_def from_hma\<^sub>m_def by auto
qed

lemma HMA_M_mk_vec[transfer_rule]: "((HMA_I ===> (=)) ===> HMA_V)
  (\<lambda> f. Matrix.vec (CARD('n)) (\<lambda> i. f i))
  (mk_vec :: (('n \<Rightarrow> 'a) \<Rightarrow> 'a^'n))"
proof-
  {
    fix x y i
    assume id: "\<forall> (ya :: 'n). (x (to_nat ya) :: 'a) = y ya"
       and i: "i < CARD('n)"
    from to_nat_from_nat_id[OF i] id[rule_format, of "from_nat i"]
    have "x i = y (from_nat i)" by auto
  }
  thus ?thesis
    unfolding rel_fun_def mk_vec_def HMA_V_def HMA_I_def from_hma\<^sub>v_def by auto
qed

lemma mat_mult_scalar: "A ** B = mk_mat (\<lambda> i j. scalar_product (row i A) (column j B))"
  unfolding vec_eq_iff matrix_matrix_mult_def scalar_product_def mk_mat_def
  by (auto simp: row_def column_def)

lemma mult_mat_vec_scalar: "A *v v = mk_vec (\<lambda> i. scalar_product (row i A) v)"
  unfolding vec_eq_iff matrix_vector_mult_def scalar_product_def mk_mat_def mk_vec_def
  by (auto simp: row_def column_def)

lemma dim_row_transfer_rule:
  "HMA_M A (A' :: 'a ^ 'nc ^ 'nr) \<Longrightarrow> (=) (dim_row A) (CARD('nr))"
  unfolding HMA_M_def by auto

lemma dim_col_transfer_rule:
  "HMA_M A (A' :: 'a ^ 'nc ^ 'nr) \<Longrightarrow> (=) (dim_col A) (CARD('nc))"
  unfolding HMA_M_def by auto

lemma HMA_M_mult [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) ((*)) ((**))"
proof -
  {
    fix A B :: "'a :: semiring_1 mat" and A' :: "'a ^ 'n  ^ 'nr" and B' :: "'a ^ 'nc ^ 'n"
    assume 1[transfer_rule]: "HMA_M A A'" "HMA_M B B'"
    note [transfer_rule] = dim_row_transfer_rule[OF 1(1)] dim_col_transfer_rule[OF 1(2)]
    have "HMA_M (A * B) (A' ** B')"
      unfolding times_mat_def mat_mult_scalar
      by (transfer_prover_start, transfer_step+, transfer, auto)
  }
  thus ?thesis by blast
qed

lemma HMA_M_mult_vec [transfer_rule]: "(HMA_M ===> HMA_V ===> HMA_V) ((*\<^sub>v)) ((*v))"
proof -
  {
    fix A :: "'a :: semiring_1 mat" and v :: "'a Matrix.vec"
      and A' :: "'a ^ 'nc  ^ 'nr" and v' :: "'a ^ 'nc"
    assume 1[transfer_rule]: "HMA_M A A'" "HMA_V v v'"
    note [transfer_rule] = dim_row_transfer_rule
    have "HMA_V (A *\<^sub>v v) (A' *v v')"
      unfolding mult_mat_vec_def mult_mat_vec_scalar
      by (transfer_prover_start, transfer_step+, transfer, auto)
  }
  thus ?thesis by blast
qed

lemma HMA_det [transfer_rule]: "(HMA_M ===> (=)) Determinant.det
  (det :: 'a :: comm_ring_1 ^ 'n ^ 'n \<Rightarrow> 'a)"
proof -
  {
    fix a :: "'a ^ 'n ^ 'n"
    let ?tn = "to_nat :: 'n :: finite \<Rightarrow> nat"
    let ?fn = "from_nat :: nat \<Rightarrow> 'n"
    let ?zn = "{0..< CARD('n)}"
    let ?U = "UNIV :: 'n set"
    let ?p1 = "{p. p permutes ?zn}"
    let ?p2 = "{p. p permutes ?U}"
    let ?f= "\<lambda> p i. if i \<in> ?U then ?fn (p (?tn i)) else i"
    let ?g = "\<lambda> p i. ?fn (p (?tn i))"
    have fg: "\<And> a b c. (if a \<in> ?U then b else c) = b" by auto
    have "?p2 = ?f ` ?p1"
      by (rule permutes_bij', auto simp: to_nat_less_card to_nat_from_nat_id)
    hence id: "?p2 = ?g ` ?p1" by simp
    have inj_g: "inj_on ?g ?p1"
      unfolding inj_on_def
    proof (intro ballI impI ext, auto)
      fix p q i
      assume p: "p permutes ?zn" and q: "q permutes ?zn"
        and id: "(\<lambda> i. ?fn (p (?tn i))) = (\<lambda> i. ?fn (q (?tn i)))"
      {
        fix i
        from permutes_in_image[OF p] have pi: "p (?tn i) < CARD('n)" by (simp add: to_nat_less_card)
        from permutes_in_image[OF q] have qi: "q (?tn i) < CARD('n)" by (simp add: to_nat_less_card)
        from fun_cong[OF id] have "?fn (p (?tn i))  = from_nat (q (?tn i))" .
        from arg_cong[OF this, of ?tn] have "p (?tn i) = q (?tn i)"
          by (simp add: to_nat_from_nat_id pi qi)
      } note id = this
      show "p i = q i"
      proof (cases "i < CARD('n)")
        case True
        hence "?tn (?fn i) = i" by (simp add: to_nat_from_nat_id)
        from id[of "?fn i", unfolded this] show ?thesis .
      next
        case False
        thus ?thesis using p q unfolding permutes_def by simp
      qed
    qed
    have mult_cong: "\<And> a b c d. a = b \<Longrightarrow> c = d \<Longrightarrow> a * c = b * d" by simp
    have "sum (\<lambda> p.
      signof p * (\<Prod>i\<in>?zn. a $h ?fn i $h ?fn (p i))) ?p1
      = sum (\<lambda> p. of_int (sign p) * (\<Prod>i\<in>UNIV. a $h i $h p i)) ?p2"
      unfolding id sum.reindex[OF inj_g]
    proof (rule sum.cong[OF refl], unfold mem_Collect_eq o_def, rule mult_cong)
      fix p
      assume p: "p permutes ?zn"
      let ?q = "\<lambda> i. ?fn (p (?tn i))"
      from id p have q: "?q permutes ?U" by auto
      from p have pp: "permutation p" unfolding permutation_permutes by auto
      let ?ft = "\<lambda> p i. ?fn (p (?tn i))"
      have fin: "finite ?zn" by simp
      have "sign p = sign ?q \<and> p permutes ?zn"
      proof (induct rule: permutes_induct[OF fin _ _ p])
        case 1
        show ?case by (auto simp: sign_id[unfolded id_def] permutes_id[unfolded id_def])
      next
        case (2 a b p)
        let ?sab = "Fun.swap a b id"
        let ?sfab = "Fun.swap (?fn a) (?fn b) id"
        have p_sab: "permutation ?sab" by (rule permutation_swap_id)
        have p_sfab: "permutation ?sfab" by (rule permutation_swap_id)
        from 2(3) have IH1: "p permutes ?zn" and IH2: "sign p = sign (?ft p)" by auto
        have sab_perm: "?sab permutes ?zn" using 2(1-2) by (rule permutes_swap_id)
        from permutes_compose[OF IH1 this] have perm1: "?sab o p permutes ?zn" .
        from IH1 have p_p1: "p \<in> ?p1" by simp
        hence "?ft p \<in> ?ft ` ?p1" by (rule imageI)
        from this[folded id] have "?ft p permutes ?U" by simp
        hence p_ftp: "permutation (?ft p)" unfolding permutation_permutes by auto
        {
          fix a b
          assume a: "a \<in> ?zn" and b: "b \<in> ?zn"
          hence "(?fn a = ?fn b) = (a = b)" using 2(1-2)
            by (auto simp: from_nat_inj)
        } note inj = this
        from inj[OF 2(1-2)] have id2: "sign ?sfab = sign ?sab" unfolding sign_swap_id by simp
        have id: "?ft (Fun.swap a b id \<circ> p) = Fun.swap (?fn a) (?fn b) id \<circ> ?ft p"
        proof
          fix c
          show "?ft (Fun.swap a b id \<circ> p) c = (Fun.swap (?fn a) (?fn b) id \<circ> ?ft p) c"
          proof (cases "p (?tn c) = a \<or> p (?tn c) = b")
            case True
            thus ?thesis by (cases, auto simp add: o_def swap_def)
          next
            case False
            hence neq: "p (?tn c) \<noteq> a" "p (?tn c) \<noteq> b" by auto
            have pc: "p (?tn c) \<in> ?zn" unfolding permutes_in_image[OF IH1]
              by (simp add: to_nat_less_card)
            from neq[folded inj[OF pc 2(1)] inj[OF pc 2(2)]]
            have "?fn (p (?tn c)) \<noteq> ?fn a" "?fn (p (?tn c)) \<noteq> ?fn b" .
            with neq show ?thesis by (auto simp: o_def swap_def)
          qed
        qed
        show ?case unfolding IH2 id sign_compose[OF p_sab 2(5)] sign_compose[OF p_sfab p_ftp] id2
          by (rule conjI[OF refl perm1])
      qed
      thus "signof p = of_int (sign ?q)" unfolding signof_def sign_def by auto
      show "(\<Prod>i = 0..<CARD('n). a $h ?fn i $h ?fn (p i)) =
           (\<Prod>i\<in>UNIV. a $h i $h ?q i)" unfolding
           range_to_nat[symmetric] prod.reindex[OF inj_to_nat]
        by (rule prod.cong[OF refl], unfold o_def, simp)
    qed
  }
  thus ?thesis unfolding HMA_M_def
    by (auto simp: from_hma\<^sub>m_def Determinant.det_def det_def)
qed

lemma HMA_mat[transfer_rule]: "((=) ===> HMA_M) (\<lambda> k. k \<cdot>\<^sub>m 1\<^sub>m CARD('n))
  (Finite_Cartesian_Product.mat :: 'a::semiring_1 \<Rightarrow> 'a^'n^'n)"
  unfolding Finite_Cartesian_Product.mat_def[abs_def] rel_fun_def HMA_M_def
  by (auto simp: from_hma\<^sub>m_def from_nat_inj)

lemma HMA_mat_minus[transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M)
  (\<lambda> A B. A + map_mat uminus B) ((-) :: 'a :: group_add ^'nc^'nr \<Rightarrow> 'a^'nc^'nr \<Rightarrow> 'a^'nc^'nr)"
  unfolding rel_fun_def HMA_M_def from_hma\<^sub>m_def by auto

definition mat2matofpoly where "mat2matofpoly A = (\<chi> i j. [: A $ i $ j :])"

definition charpoly where charpoly_def: "charpoly A = det (mat (monom 1 (Suc 0)) - mat2matofpoly A)"

definition erase_mat :: "'a :: zero ^ 'nc ^ 'nr \<Rightarrow> 'nr \<Rightarrow> 'nc \<Rightarrow> 'a ^ 'nc ^ 'nr"
  where "erase_mat A i j = (\<chi> i'. \<chi>  j'. if i' = i \<or> j' = j then 0 else A $ i' $ j')"

definition sum_UNIV_type :: "('n :: finite \<Rightarrow> 'a :: comm_monoid_add) \<Rightarrow> 'n itself \<Rightarrow> 'a" where
  "sum_UNIV_type f _ = sum f UNIV"

definition sum_UNIV_set :: "(nat \<Rightarrow> 'a :: comm_monoid_add) \<Rightarrow> nat \<Rightarrow> 'a" where
  "sum_UNIV_set f n = sum f {..<n}"

definition HMA_T :: "nat \<Rightarrow> 'n :: finite itself \<Rightarrow> bool" where
  "HMA_T n _ = (n = CARD('n))"

lemma HMA_mat2matofpoly[transfer_rule]: "(HMA_M ===> HMA_M) (\<lambda>x. map_mat (\<lambda>a. [:a:]) x) mat2matofpoly"
  unfolding rel_fun_def HMA_M_def from_hma\<^sub>m_def mat2matofpoly_def by auto

lemma HMA_char_poly [transfer_rule]:
  "((HMA_M :: ('a:: comm_ring_1 mat \<Rightarrow> 'a^'n^'n \<Rightarrow> bool)) ===> (=)) char_poly charpoly"
proof -
  {
    fix A :: "'a mat" and A' :: "'a^'n^'n"
    assume [transfer_rule]: "HMA_M A A'"
    hence [simp]: "dim_row A = CARD('n)" by (simp add: HMA_M_def)
    have [simp]: "monom 1 (Suc 0) = [:0, 1 :: 'a :]"
      by (simp add: monom_Suc)
    have [simp]: "map_mat uminus (map_mat (\<lambda>a. [:a:]) A) = map_mat (\<lambda>a. [:-a:]) A"
      by (rule eq_matI, auto)
    have "char_poly A = charpoly A'"
      unfolding char_poly_def[abs_def] char_poly_matrix_def charpoly_def[abs_def]
      by (transfer, simp)
  }
  thus ?thesis by blast
qed

lemma HMA_eigen_vector [transfer_rule]: "(HMA_M ===> HMA_V ===> (=)) eigenvector eigen_vector"
proof -
  {
    fix A :: "'a mat" and v :: "'a Matrix.vec"
    and A' :: "'a ^ 'n ^ 'n" and v' :: "'a ^ 'n" and k :: 'a
    assume 1[transfer_rule]: "HMA_M A A'" and 2[transfer_rule]: "HMA_V v v'"
    hence [simp]: "dim_row A = CARD('n)" "dim_vec v = CARD('n)" by (auto simp add: HMA_V_def HMA_M_def)
    have [simp]: "v \<in> carrier_vec CARD('n)" using 2 unfolding HMA_V_def by simp
    have "eigenvector A v = eigen_vector A' v'"
      unfolding eigenvector_def[abs_def] eigen_vector_def[abs_def]
      by (transfer, simp)
  }
  thus ?thesis by blast
qed

lemma HMA_eigen_value [transfer_rule]: "(HMA_M ===> (=) ===> (=)) eigenvalue eigen_value"
proof -
  {
    fix A :: "'a mat" and A' :: "'a ^ 'n  ^ 'n" and k
    assume 1[transfer_rule]: "HMA_M A A'"
    hence [simp]: "dim_row A = CARD('n)" by (simp add: HMA_M_def)
    note [transfer_rule] = dim_row_transfer_rule[OF 1(1)]
    have "(eigenvalue A k) = (eigen_value A' k)"
      unfolding eigenvalue_def[abs_def] eigen_value_def[abs_def]
      by (transfer, auto simp add: eigenvector_def)
  }
  thus ?thesis by blast
qed

lemma HMA_spectral_radius [transfer_rule]:
  "(HMA_M ===> (=)) Spectral_Radius.spectral_radius spectral_radius"
  unfolding Spectral_Radius.spectral_radius_def[abs_def] spectrum_def
    spectral_radius_ev_def[abs_def]
  by transfer_prover

lemma HMA_elements_mat[transfer_rule]: "((HMA_M :: ('a mat \<Rightarrow> 'a ^ 'nc ^ 'nr \<Rightarrow> bool))  ===> (=))
  elements_mat elements_mat_h"
proof -
  {
    fix y :: "'a ^ 'nc ^ 'nr" and i j :: nat
    assume i: "i < CARD('nr)" and j: "j < CARD('nc)"
    hence "from_hma\<^sub>m y $$ (i, j) \<in> range (\<lambda>(i, ya). y $h i $h ya)"
      using to_nat_from_nat_id[OF i] to_nat_from_nat_id[OF j] by (auto simp: from_hma\<^sub>m_def)
  }
  moreover
  {
    fix y :: "'a ^ 'nc ^ 'nr" and a b
    have "\<exists>i j. y $h a $h b = from_hma\<^sub>m y $$ (i, j) \<and> i < CARD('nr) \<and> j < CARD('nc)"
      unfolding from_hma\<^sub>m_def
      by (rule exI[of _ "Bij_Nat.to_nat a"], rule exI[of _ "Bij_Nat.to_nat b"], auto
        simp: to_nat_less_card)
  }
  ultimately show ?thesis
    unfolding elements_mat[abs_def] elements_mat_h_def[abs_def] HMA_M_def
    by auto
qed

lemma HMA_vec_elements[transfer_rule]: "((HMA_V :: ('a Matrix.vec \<Rightarrow> 'a ^ 'n \<Rightarrow> bool))  ===> (=))
  vec_elements vec_elements_h"
proof -
  {
    fix y :: "'a ^ 'n" and i :: nat
    assume i: "i < CARD('n)"
    hence "from_hma\<^sub>v y $ i \<in> range (vec_nth y)"
      using to_nat_from_nat_id[OF i] by (auto simp: from_hma\<^sub>v_def)
  }
  moreover
  {
    fix y :: "'a ^ 'n" and a
    have "\<exists>i. y $h a = from_hma\<^sub>v y $ i \<and> i < CARD('n)"
      unfolding from_hma\<^sub>v_def
      by (rule exI[of _ "Bij_Nat.to_nat a"], auto simp: to_nat_less_card)
  }
  ultimately show ?thesis
    unfolding vec_elements[abs_def] vec_elements_h_def[abs_def] rel_fun_def HMA_V_def
    by auto
qed

lemma norm_bound_elements_mat: "norm_bound A b = (\<forall> x \<in> elements_mat A. norm x \<le> b)"
  unfolding norm_bound_def elements_mat by auto

lemma HMA_normbound [transfer_rule]:
  "((HMA_M :: 'a :: real_normed_field mat \<Rightarrow> 'a ^ 'nc ^ 'nr \<Rightarrow> bool) ===> (=) ===> (=))
  norm_bound normbound"
  unfolding normbound_def[abs_def] norm_bound_elements_mat[abs_def]
  by (transfer_prover)

lemma HMA_map_matrix [transfer_rule]:
  "((=) ===> HMA_M ===> HMA_M) map_mat map_matrix"
  unfolding map_vector_def map_matrix_def[abs_def] map_mat_def[abs_def] HMA_M_def from_hma\<^sub>m_def
  by auto

lemma HMA_transpose_matrix [transfer_rule]:
  "(HMA_M ===> HMA_M) transpose_mat transpose"
  unfolding transpose_mat_def transpose_def HMA_M_def from_hma\<^sub>m_def by auto

lemma HMA_map_vector [transfer_rule]:
  "((=) ===> HMA_V ===> HMA_V) map_vec map_vector"
  unfolding map_vector_def[abs_def] map_vec_def[abs_def] HMA_V_def from_hma\<^sub>v_def
  by auto

lemma HMA_similar_mat_wit [transfer_rule]:
  "((HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'n ^ 'n \<Rightarrow> _) ===> HMA_M ===> HMA_M ===> HMA_M ===> (=))
  similar_mat_wit similar_matrix_wit"
proof (intro rel_funI, goal_cases)
  case (1 a A b B c C d D)
  note [transfer_rule] = this
  hence id: "dim_row a = CARD('n)" by (auto simp: HMA_M_def)
  have *: "(c * d = 1\<^sub>m (dim_row a) \<and> d * c = 1\<^sub>m (dim_row a) \<and> a = c * b * d) =
    (C ** D = mat 1 \<and> D ** C = mat 1 \<and> A = C ** B ** D)" unfolding id
    by (transfer, simp)
  show ?case unfolding similar_mat_wit_def Let_def similar_matrix_wit_def *
    using 1 by (auto simp: HMA_M_def)
qed

lemma HMA_similar_mat [transfer_rule]:
  "((HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'n ^ 'n \<Rightarrow> _) ===> HMA_M ===> (=))
  similar_mat similar_matrix"
proof (intro rel_funI, goal_cases)
  case (1 a A b B)
  note [transfer_rule] = this
  hence id: "dim_row a = CARD('n)" by (auto simp: HMA_M_def)
  {
    fix c d
    assume "similar_mat_wit a b c d"
    hence "{c,d} \<subseteq> carrier_mat CARD('n) CARD('n)" unfolding similar_mat_wit_def id Let_def by auto
  } note * = this
  show ?case unfolding similar_mat_def similar_matrix_def
    by (transfer, insert *, blast)
qed

lemma HMA_spectrum[transfer_rule]: "(HMA_M ===> (=)) spectrum Spectrum"
  unfolding spectrum_def[abs_def] Spectrum_def[abs_def]
  by transfer_prover

lemma HMA_M_erase_mat[transfer_rule]: "(HMA_M ===> HMA_I ===> HMA_I ===> HMA_M) mat_erase erase_mat"
  unfolding mat_erase_def[abs_def] erase_mat_def[abs_def]
  by (auto simp: HMA_M_def HMA_I_def from_hma\<^sub>m_def to_nat_from_nat_id intro!: eq_matI)

lemma HMA_M_sum_UNIV[transfer_rule]:
  "((HMA_I ===> (=)) ===> HMA_T ===> (=)) sum_UNIV_set sum_UNIV_type"
  unfolding rel_fun_def
proof (clarify, rename_tac f fT n nT)
  fix f and fT :: "'b \<Rightarrow> 'a" and n and nT :: "'b itself"
  assume f: "\<forall>x y. HMA_I x y \<longrightarrow> f x = fT y"
    and n: "HMA_T n nT"
  let ?f = "from_nat :: nat \<Rightarrow> 'b"
  let ?t = "to_nat :: 'b \<Rightarrow> nat"
  from n[unfolded HMA_T_def] have n: "n = CARD('b)" .
  from to_nat_from_nat_id[where 'a = 'b, folded n]
  have tf: "i < n \<Longrightarrow> ?t (?f i) = i" for i by auto
  have "sum_UNIV_set f n = sum f (?t ` ?f ` {..<n})"
    unfolding sum_UNIV_set_def
    by (rule arg_cong[of _ _ "sum f"], insert tf, force)
  also have "\<dots> = sum (f \<circ> ?t) (?f ` {..<n})"
    by (rule sum.reindex, insert tf n, auto simp: inj_on_def)
  also have "?f ` {..<n} = UNIV"
    using range_to_nat[where 'a = 'b, folded n] by force
  also have "sum (f \<circ> ?t) UNIV = sum fT UNIV"
  proof (rule sum.cong[OF refl])
    fix i :: 'b
    show "(f \<circ> ?t) i = fT i" unfolding o_def
      by (rule f[rule_format], auto simp: HMA_I_def)
  qed
  also have "\<dots> = sum_UNIV_type fT nT"
    unfolding sum_UNIV_type_def ..
  finally show "sum_UNIV_set f n = sum_UNIV_type fT nT" .
qed
end

text \<open>Setup a method to easily convert theorems from JNF into HMA.\<close>

method transfer_hma uses rule = (
  (fold index_hma_def)?, (* prepare matrix access for transfer *)
  transfer,
  rule rule,
  (unfold carrier_vec_def carrier_mat_def)?,
  auto)

text \<open>Now it becomes easy to transfer results which are not yet proven in HMA, such as:\<close>

lemma matrix_add_vect_distrib: "(A + B) *v v = A *v v + B *v v"
  by (transfer_hma rule: add_mult_distrib_mat_vec)

lemma matrix_vector_right_distrib: "M *v (v + w) = M *v v + M *v w"
  by (transfer_hma rule: mult_add_distrib_mat_vec)

lemma matrix_vector_right_distrib_diff: "(M :: 'a :: ring_1 ^ 'nr ^ 'nc) *v (v - w) = M *v v - M *v w"
  by (transfer_hma rule: mult_minus_distrib_mat_vec)

lemma eigen_value_root_charpoly:
  "eigen_value A k \<longleftrightarrow> poly (charpoly (A :: 'a :: field ^ 'n ^ 'n)) k = 0"
  by (transfer_hma rule: eigenvalue_root_char_poly)

lemma finite_spectrum: fixes A :: "'a :: field ^ 'n ^ 'n"
  shows "finite (Collect (eigen_value A))"
  by (transfer_hma rule: card_finite_spectrum(1)[unfolded spectrum_def])

lemma non_empty_spectrum: fixes A :: "complex ^ 'n ^ 'n"
  shows "Collect (eigen_value A) \<noteq> {}"
  by (transfer_hma rule: spectrum_non_empty[unfolded spectrum_def])

lemma eigen_value_transpose: "eigen_value (transpose A :: 'a :: field ^ 'n ^ 'n) v = eigen_value A v"
  unfolding eigen_value_root_charpoly charpoly_transpose by simp

lemma matrix_diff_vect_distrib: "(A - B) *v v = A *v v - B *v (v :: 'a :: ring_1 ^ 'n)"
  by (transfer_hma rule: minus_mult_distrib_mat_vec)

lemma similar_matrix_charpoly: "similar_matrix A B \<Longrightarrow> charpoly A = charpoly B"
  by (transfer_hma rule: char_poly_similar)

lemma pderiv_char_poly_erase_mat: fixes A :: "'a :: idom ^ 'n ^ 'n"
  shows "monom 1 1 * pderiv (charpoly A) = sum (\<lambda> i. charpoly (erase_mat A i i)) UNIV"
proof -
  let ?A = "from_hma\<^sub>m A"
  let ?n = "CARD('n)"
  have tA[transfer_rule]: "HMA_M ?A A" unfolding HMA_M_def by simp
  have tN[transfer_rule]: "HMA_T ?n TYPE('n)" unfolding HMA_T_def by simp
  have A: "?A \<in> carrier_mat ?n ?n" unfolding from_hma\<^sub>m_def by auto
  have id: "sum (\<lambda> i. charpoly (erase_mat A i i)) UNIV =
    sum_UNIV_type (\<lambda> i. charpoly (erase_mat A i i)) TYPE('n)"
    unfolding sum_UNIV_type_def ..
  show ?thesis unfolding id
    by (transfer, insert pderiv_char_poly_mat_erase[OF A], simp add: sum_UNIV_set_def)
qed

lemma degree_monic_charpoly: fixes A :: "'a :: comm_ring_1 ^ 'n ^ 'n"
  shows "degree (charpoly A) = CARD('n) \<and> monic (charpoly A)"
proof (transfer, goal_cases)
  case 1
  from degree_monic_char_poly[OF 1] show ?case by auto
qed

end