section \<open>Uniqueness of Hermite normal form in JNF\<close>

text \<open>This theory contains the proof of the uniqueness theorem of the Hermite normal form in JNF,
moved from HOL Analysis.\<close>

theory Uniqueness_Hermite_JNF
  imports
  Hermite.Hermite
  Uniqueness_Hermite
  Smith_Normal_Form.SNF_Missing_Lemmas
  Smith_Normal_Form.Mod_Type_Connect
  Smith_Normal_Form.Finite_Field_Mod_Type_Connection
begin

hide_const (open) residues

text \<open>We first define some properties that currently exist in HOL Analysis, but not in
JNF, namely a predicate for being in echelon form, another one for being in Hermite normal form,
definition of a row of zeros up to a concrete position, and so on.\<close>

definition is_zero_row_upt_k_JNF :: "nat  => nat =>'a::{zero} mat => bool"
  where "is_zero_row_upt_k_JNF i k A = (\<forall>j. j < k \<longrightarrow> A $$ (i,j) = 0)"

definition is_zero_row_JNF :: "nat =>'a::{zero} mat  => bool"
  where "is_zero_row_JNF i A =  (\<forall>j<dim_col A. A $$ (i, j) = 0)"

lemma echelon_form_def':
"echelon_form A = (
    (\<forall>i. is_zero_row i A \<longrightarrow> \<not> (\<exists>j. j>i \<and> \<not> is_zero_row j A))
    \<and>
    (\<forall>i j. i<j \<and> \<not> (is_zero_row i A) \<and> \<not> (is_zero_row j A)
          \<longrightarrow> ((LEAST n. A $ i $ n \<noteq> 0) < (LEAST n. A $ j $ n \<noteq> 0))))"
  unfolding echelon_form_def echelon_form_upt_k_def unfolding is_zero_row_def by auto

definition
  echelon_form_JNF :: "'a::{bezout_ring} mat \<Rightarrow> bool"
  where
  "echelon_form_JNF A = (
    (\<forall>i<dim_row A. is_zero_row_JNF i A \<longrightarrow> \<not> (\<exists>j. j < dim_row A \<and> j>i \<and> \<not> is_zero_row_JNF j A))
    \<and>
    (\<forall>i j. i<j \<and> j<dim_row A \<and> \<not> (is_zero_row_JNF i A) \<and> \<not> (is_zero_row_JNF j A)
          \<longrightarrow> ((LEAST n. A $$ (i, n) \<noteq> 0) < (LEAST n. A $$ (j, n) \<noteq> 0))))"

text \<open>Now, we connect the existing definitions in HOL Analysis to the ones just defined in JNF by
means of transfer rules.\<close>

context includes lifting_syntax
begin

lemma HMA_is_zero_row_mod_type[transfer_rule]:
  "((Mod_Type_Connect.HMA_I) ===> (Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'n :: mod_type ^ 'm :: mod_type \<Rightarrow> _)
    ===> (=)) is_zero_row_JNF is_zero_row"
proof (intro rel_funI, goal_cases)
  case (1 i i' A A')
  note ii' = "1"(1)[transfer_rule]
  note AA' = "1"(2)[transfer_rule]
  have "(\<forall>j<dim_col A. A $$ (i, j) = 0) = (\<forall>j. A' $h i' $h j = 0)"
  proof (rule;rule+)
    fix j'::'n assume Aij_0: "\<forall>j<dim_col A. A $$ (i, j) = 0"
    define j where "j = mod_type_class.to_nat j'"
    have [transfer_rule]: "Mod_Type_Connect.HMA_I j j'" unfolding Mod_Type_Connect.HMA_I_def j_def by auto
    have A_ij0': "A $$ (i,j) = 0" using Aij_0 unfolding j_def
      by (metis AA' Mod_Type_Connect.HMA_M_def Mod_Type_Connect.from_hma\<^sub>m_def
          dim_col_mat(1) mod_type_class.to_nat_less_card)
    hence "index_hma A' i' j' = 0" by transfer
    thus "A' $h i' $h j' = 0" unfolding index_hma_def by simp
  next
    fix j assume 1: "\<forall>j'. A' $h i' $h j' = 0" and 2: "j < dim_col A"
    define j'::'n where "j' = mod_type_class.from_nat j"
    have [transfer_rule]: "Mod_Type_Connect.HMA_I j j'" unfolding Mod_Type_Connect.HMA_I_def j'_def
      using Mod_Type.to_nat_from_nat_id[of j, where ?'a = 'n] 2
      using AA' Mod_Type_Connect.dim_col_transfer_rule by force
    have "A' $h i' $h j' = 0" using 1 by auto
    hence "index_hma A' i' j' = 0" unfolding index_hma_def by simp
    thus "A $$ (i, j) = 0" by transfer
  qed
  thus ?case unfolding is_zero_row_def' is_zero_row_JNF_def by auto
qed

lemma HMA_echelon_form_mod_type[transfer_rule]:
  "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a ::bezout_ring ^ 'n :: mod_type ^ 'm :: mod_type \<Rightarrow> _) ===> (=))
  echelon_form_JNF echelon_form"
proof (intro rel_funI, goal_cases)
  case (1 A A')
  note AA' = "1"(1)[transfer_rule]
  have 1: "(\<forall>i<dim_row A. is_zero_row_JNF i A \<longrightarrow> \<not> (\<exists>j < dim_row A. j>i \<and> \<not> is_zero_row_JNF j A))
    = (\<forall>i. is_zero_row i A' \<longrightarrow> \<not> (\<exists>j>i. \<not> is_zero_row j A'))"
  proof (auto)
    fix i' j' assume 1: "\<forall>i<dim_row A. is_zero_row_JNF i A \<longrightarrow> (\<forall>j>i. j < dim_row A \<longrightarrow> is_zero_row_JNF j A)"
      and 2: "is_zero_row i' A'" and 3: "i' < j'"
    let ?i = "Mod_Type.to_nat i'"
    let ?j = "Mod_Type.to_nat j'"
    have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I ?i i'" and jj'[transfer_rule]: "Mod_Type_Connect.HMA_I ?j j'"
      unfolding Mod_Type_Connect.HMA_I_def by auto
    have "is_zero_row_JNF ?i A" using 2 by transfer'
    hence "is_zero_row_JNF ?j A" using 1 3 to_nat_mono
      by (metis AA' Mod_Type_Connect.HMA_M_def Mod_Type_Connect.from_hma\<^sub>m_def
          dim_row_mat(1) mod_type_class.to_nat_less_card)
    thus "is_zero_row j' A'" by transfer'
  next
    fix i j assume 1: "\<forall>i'. is_zero_row i' A' \<longrightarrow> (\<forall>j'>i'. is_zero_row j' A')"
      and 2: "is_zero_row_JNF i A" and 3: "i < j" and 4: "j<dim_row A"
    let ?i' = "Mod_Type.from_nat i::'m"
    let ?j' = "Mod_Type.from_nat j::'m"
    have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'"
      unfolding Mod_Type_Connect.HMA_I_def using Mod_Type.to_nat_from_nat_id[of i]
      using 3 4 AA' Mod_Type_Connect.dim_row_transfer_rule less_trans by fastforce
    have jj'[transfer_rule]: "Mod_Type_Connect.HMA_I j ?j'"
      unfolding Mod_Type_Connect.HMA_I_def  using Mod_Type.to_nat_from_nat_id[of j]
      using 3 4 AA' Mod_Type_Connect.dim_row_transfer_rule less_trans by fastforce
    have "is_zero_row ?i' A'" using 2 by transfer
    moreover have "?i' < ?j'" using 3 4 AA' Mod_Type_Connect.dim_row_transfer_rule from_nat_mono by fastforce
    ultimately have "is_zero_row ?j' A'" using 1 3 by auto
    thus "is_zero_row_JNF j A" by transfer
  qed
  have 2: "((\<forall>i j. i<j \<and> \<not> (is_zero_row i A') \<and> \<not> (is_zero_row j A')
    \<longrightarrow> ((LEAST n. A' $h i $h n \<noteq> 0) < (LEAST n. A' $h j $h n \<noteq> 0))))
    = (\<forall>i j. i<j \<and> j<dim_row A \<and> \<not> (is_zero_row_JNF i A) \<and> \<not> (is_zero_row_JNF j A)
    \<longrightarrow> ((LEAST n. A $$ (i, n) \<noteq> 0) < (LEAST n. A $$ (j, n) \<noteq> 0)))"
  proof (auto)
    fix i j assume 1: "\<forall>i' j'. i' < j' \<and> \<not> is_zero_row i' A' \<and> \<not> is_zero_row j' A'
      \<longrightarrow> (LEAST n'. A' $h i' $h n' \<noteq> 0) < (LEAST n'. A' $h j' $h n' \<noteq> 0)"
      and ij: "i < j" and j: "j < dim_row A" and i0: "\<not> is_zero_row_JNF i A"
      and j0: "\<not> is_zero_row_JNF j A"
    let ?i' = "Mod_Type.from_nat i::'m"
    let ?j' = "Mod_Type.from_nat j::'m"
    have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'"
      unfolding Mod_Type_Connect.HMA_I_def using Mod_Type.to_nat_from_nat_id[of i]
      using ij j AA' Mod_Type_Connect.dim_row_transfer_rule less_trans by fastforce
    have jj'[transfer_rule]: "Mod_Type_Connect.HMA_I j ?j'"
      unfolding Mod_Type_Connect.HMA_I_def  using Mod_Type.to_nat_from_nat_id[of j]
      using ij j AA' Mod_Type_Connect.dim_row_transfer_rule less_trans by fastforce
    have i'0: "\<not> is_zero_row ?i' A'" using i0 by transfer
    have j'0: "\<not> is_zero_row ?j' A'" using j0 by transfer
    have i'j': "?i' < ?j'"
      using AA' Mod_Type_Connect.dim_row_transfer_rule from_nat_mono ij j by fastforce
    have l1l2: "(LEAST n'. A' $h ?i' $h n' \<noteq> 0) < (LEAST n'. A' $h ?j' $h n' \<noteq> 0)"
      using 1 i'0 j'0 i'j' by auto
    define l1 where "l1 = (LEAST n'. A' $h ?i' $h n' \<noteq> 0)"
    define l2 where "l2 = (LEAST n'. A' $h ?j' $h n' \<noteq> 0)"
    let ?least_n1 = "Mod_Type.to_nat l1"
    let ?least_n2 = "Mod_Type.to_nat l2"
    have l1[transfer_rule]: "Mod_Type_Connect.HMA_I ?least_n1 l1" and [transfer_rule]: "Mod_Type_Connect.HMA_I ?least_n2 l2"
      unfolding Mod_Type_Connect.HMA_I_def by auto
    have "(LEAST n. A $$ (i, n) \<noteq> 0) = ?least_n1"
    proof (rule Least_equality)
      obtain n' where n'1: "A $$ (i,n') \<noteq> 0" and n'2: "n'<dim_col A"
        using i0 unfolding is_zero_row_JNF_def by auto
      let ?n' = "Mod_Type.from_nat n'::'n"
      have n'n'[transfer_rule]: "Mod_Type_Connect.HMA_I n' ?n'"
        unfolding Mod_Type_Connect.HMA_I_def using Mod_Type.to_nat_from_nat_id n'2
        using AA' Mod_Type_Connect.dim_col_transfer_rule by fastforce
      have "index_hma A' ?i' ?n' \<noteq> 0" using n'1 by transfer
      hence A'i'n': "A' $h ?i' $h ?n' \<noteq> 0" unfolding index_hma_def by simp
      have least_le_n': "(LEAST n. A $$ (i, n) \<noteq> 0)  \<le> n'" by (simp add: Least_le n'1)
      have l1_le_n': "l1 \<le> ?n'" by (simp add: A'i'n' Least_le l1_def)
      have "A $$ (i, ?least_n1) = index_hma A' ?i' l1" by (transfer, simp)
      also have "... = A' $h mod_type_class.from_nat i $h l1" unfolding index_hma_def by simp
      also have "... \<noteq> 0" unfolding l1_def by (metis (mono_tags, lifting) LeastI i'0 is_zero_row_def')
      finally show "A $$ (i, mod_type_class.to_nat l1) \<noteq> 0" .
      fix y assume Aiy: "A $$ (i, y) \<noteq> 0"
      let ?y' = "Mod_Type.from_nat y::'n"
      show "Mod_Type.to_nat l1 \<le> y"
      proof (cases "y\<le>n'")
        case True
        hence y: "y < dim_col A" using n'2 by auto
        have yy'[transfer_rule]: "Mod_Type_Connect.HMA_I y ?y'" unfolding Mod_Type_Connect.HMA_I_def
          apply (rule Mod_Type.to_nat_from_nat_id[symmetric])
          using y Mod_Type_Connect.dim_col_transfer_rule[OF AA'] by auto
        have "Mod_Type.to_nat l1 \<le> Mod_Type.to_nat ?y'"
        proof (rule to_nat_mono')
          have "index_hma A' ?i' ?y' \<noteq> 0" using Aiy by transfer
          hence "A' $h ?i' $h ?y' \<noteq> 0" unfolding index_hma_def by simp
          thus "l1 \<le> ?y'" unfolding l1_def by (simp add: Least_le)
        qed
          then show ?thesis by (metis Mod_Type_Connect.HMA_I_def yy')
        next
          case False
          hence "n' < y" by auto
          then show ?thesis
            by (metis False Mod_Type_Connect.HMA_I_def dual_order.trans l1_le_n' linear n'n' to_nat_mono')
        qed
      qed
      moreover have "(LEAST n. A $$ (j, n) \<noteq> 0) = ?least_n2"
      proof (rule Least_equality)
        obtain n' where n'1: "A $$ (j,n') \<noteq> 0" and n'2: "n'<dim_col A"
        using j0 unfolding is_zero_row_JNF_def by auto
      let ?n' = "Mod_Type.from_nat n'::'n"
      have n'n'[transfer_rule]: "Mod_Type_Connect.HMA_I n' ?n'"
        unfolding Mod_Type_Connect.HMA_I_def using Mod_Type.to_nat_from_nat_id n'2
        using AA' Mod_Type_Connect.dim_col_transfer_rule by fastforce
      have "index_hma A' ?j' ?n' \<noteq> 0" using n'1 by transfer
      hence A'i'n': "A' $h ?j' $h ?n' \<noteq> 0" unfolding index_hma_def by simp
      have least_le_n': "(LEAST n. A $$ (j, n) \<noteq> 0)  \<le> n'" by (simp add: Least_le n'1)
      have l1_le_n': "l2 \<le> ?n'" by (simp add: A'i'n' Least_le l2_def)
      have "A $$ (j, ?least_n2) = index_hma A' ?j' l2" by (transfer, simp)
      also have "... = A' $h ?j' $h l2" unfolding index_hma_def by simp
      also have "... \<noteq> 0" unfolding l2_def by (metis (mono_tags, lifting) LeastI j'0 is_zero_row_def')
      finally show "A $$ (j, mod_type_class.to_nat l2) \<noteq> 0" .
      fix y assume Aiy: "A $$ (j, y) \<noteq> 0"
      let ?y' = "Mod_Type.from_nat y::'n"
      show "Mod_Type.to_nat l2 \<le> y"
      proof (cases "y\<le>n'")
        case True
        hence y: "y < dim_col A" using n'2 by auto
        have yy'[transfer_rule]: "Mod_Type_Connect.HMA_I y ?y'" unfolding Mod_Type_Connect.HMA_I_def
          apply (rule Mod_Type.to_nat_from_nat_id[symmetric])
          using y Mod_Type_Connect.dim_col_transfer_rule[OF AA'] by auto
        have "Mod_Type.to_nat l2 \<le> Mod_Type.to_nat ?y'"
        proof (rule to_nat_mono')
          have "index_hma A' ?j' ?y' \<noteq> 0" using Aiy by transfer
          hence "A' $h ?j' $h ?y' \<noteq> 0" unfolding index_hma_def by simp
          thus "l2 \<le> ?y'" unfolding l2_def by (simp add: Least_le)
        qed
          then show ?thesis by (metis Mod_Type_Connect.HMA_I_def yy')
        next
          case False
          hence "n' < y" by auto
          then show ?thesis
            by (metis False Mod_Type_Connect.HMA_I_def dual_order.trans l1_le_n' linear n'n' to_nat_mono')
        qed
      qed
      ultimately show "(LEAST n. A $$ (i, n) \<noteq> 0) < (LEAST n. A $$ (j, n) \<noteq> 0)"
        using l1l2 unfolding l1_def l2_def by (simp add: to_nat_mono)
    next
      fix i' j' assume 1: "\<forall>i j. i < j \<and> j < dim_row A \<and> \<not> is_zero_row_JNF i A \<and> \<not> is_zero_row_JNF j A
      \<longrightarrow> (LEAST n. A $$ (i, n) \<noteq> 0) < (LEAST n. A $$ (j, n) \<noteq> 0)"
       and i'j': "i' < j'" and i': "\<not> is_zero_row i' A'" and j': "\<not> is_zero_row j' A'"
      let ?i = "Mod_Type.to_nat i'"
      let ?j = "Mod_Type.to_nat j'"
      have [transfer_rule]: "Mod_Type_Connect.HMA_I ?i i'"
        and [transfer_rule]: "Mod_Type_Connect.HMA_I ?j j'"
        unfolding Mod_Type_Connect.HMA_I_def by auto
      have i: "\<not> is_zero_row_JNF ?i A" using i' by transfer'
      have j: "\<not> is_zero_row_JNF ?j A" using j' by transfer'
      have ij: "?i < ?j" using i'j' to_nat_mono by blast
      have j_dim_row: "?j < dim_row A"
        using AA' Mod_Type_Connect.dim_row_transfer_rule mod_type_class.to_nat_less_card by fastforce
      have least_ij: "(LEAST n. A $$ (?i, n) \<noteq> 0) < (LEAST n. A $$ (?j, n) \<noteq> 0)"
        using i j ij j_dim_row 1 by auto
      define l1 where "l1 = (LEAST n'. A $$ (?i, n') \<noteq> 0)"
      define l2 where "l2 = (LEAST n'. A $$ (?j, n') \<noteq> 0)"
      let ?least_n1 = "Mod_Type.from_nat l1::'n"
      let ?least_n2 = "Mod_Type.from_nat l2::'n"
      have l1_dim_col: "l1 < dim_col A"
        by (smt is_zero_row_JNF_def j l1_def leI le_less_trans least_ij less_trans not_less_Least)
      have l2_dim_col: "l2 < dim_col A"
        by (metis (mono_tags, lifting) Least_le is_zero_row_JNF_def j l2_def le_less_trans)
      have [transfer_rule]: "Mod_Type_Connect.HMA_I l1 ?least_n1" unfolding Mod_Type_Connect.HMA_I_def
        using AA' Mod_Type_Connect.dim_col_transfer_rule l1_dim_col Mod_Type.to_nat_from_nat_id
        by fastforce
      have [transfer_rule]: "Mod_Type_Connect.HMA_I l2 ?least_n2" unfolding Mod_Type_Connect.HMA_I_def
        using AA' Mod_Type_Connect.dim_col_transfer_rule l2_dim_col Mod_Type.to_nat_from_nat_id
        by fastforce
      have "(LEAST n. A' $h i' $h n \<noteq> 0) = ?least_n1"
      proof (rule Least_equality)
        obtain n' where n'1: "A' $h i' $h n' \<noteq> 0" using i' unfolding is_zero_row_def' by auto
        have "A' $h i' $h ?least_n1 = index_hma A' i' ?least_n1" unfolding index_hma_def by simp
        also have "... = A$$ (?i, l1)"  by (transfer, simp)
        also have "... \<noteq> 0" by (metis (mono_tags, lifting) LeastI i is_zero_row_JNF_def l1_def)
        finally show "A' $h i' $h ?least_n1 \<noteq> 0" .
      next
        fix y assume y: "A' $h i' $h y \<noteq> 0"
        let ?y' = "Mod_Type.to_nat y"
        have [transfer_rule]: "Mod_Type_Connect.HMA_I ?y' y" unfolding Mod_Type_Connect.HMA_I_def by simp
        have "?least_n1 \<le> Mod_Type.from_nat ?y'"
        proof (unfold l1_def, rule from_nat_mono')
          show "Mod_Type.to_nat y < CARD('n)" by (simp add: mod_type_class.to_nat_less_card)
          have *: "A $$ (mod_type_class.to_nat i', mod_type_class.to_nat y) \<noteq> 0"
            using y[unfolded index_hma_def[symmetric]] by transfer'
          show "(LEAST n'. A $$ (mod_type_class.to_nat i', n') \<noteq> 0) \<le> mod_type_class.to_nat y"
            by (rule Least_le, simp add: *)
        qed
        also have "... = y" by simp
        finally show "?least_n1 \<le> y" .
      qed
      moreover have "(LEAST n. A' $h j' $h n \<noteq> 0) = ?least_n2"
      proof (rule Least_equality)
        obtain n' where n'1: "A' $h j' $h n' \<noteq> 0" using j' unfolding is_zero_row_def' by auto
        have "A' $h j' $h ?least_n2 = index_hma A' j' ?least_n2" unfolding index_hma_def by simp
        also have "... = A$$ (?j, l2)"  by (transfer, simp)
        also have "... \<noteq> 0" by (metis (mono_tags, lifting) LeastI j is_zero_row_JNF_def l2_def)
        finally show "A' $h j' $h ?least_n2 \<noteq> 0" .
      next
        fix y assume y: "A' $h j' $h y \<noteq> 0"
        let ?y' = "Mod_Type.to_nat y"
        have [transfer_rule]: "Mod_Type_Connect.HMA_I ?y' y" unfolding Mod_Type_Connect.HMA_I_def by simp
        have "?least_n2 \<le> Mod_Type.from_nat ?y'"
        proof (unfold l2_def, rule from_nat_mono')
          show "Mod_Type.to_nat y < CARD('n)" by (simp add: mod_type_class.to_nat_less_card)
          have *: "A $$ (mod_type_class.to_nat j', mod_type_class.to_nat y) \<noteq> 0"
            using y[unfolded index_hma_def[symmetric]] by transfer'
          show "(LEAST n'. A $$ (mod_type_class.to_nat j', n') \<noteq> 0) \<le> mod_type_class.to_nat y"
            by (rule Least_le, simp add: *)
        qed
        also have "... = y" by simp
        finally show "?least_n2 \<le> y" .
      qed
      ultimately show "(LEAST n. A' $h i' $h n \<noteq> 0) < (LEAST n. A' $h j' $h n \<noteq> 0)" using least_ij
        unfolding l1_def l2_def
        using AA' Mod_Type_Connect.dim_col_transfer_rule from_nat_mono l2_def l2_dim_col
        by fastforce
    qed
   show ?case unfolding echelon_form_JNF_def echelon_form_def' using 1 2 by auto
qed

definition Hermite_JNF :: "'a::{bezout_ring_div,normalization_semidom} set \<Rightarrow> ('a \<Rightarrow> 'a set) \<Rightarrow> 'a mat \<Rightarrow> bool"
  where "Hermite_JNF associates residues A = (
  Complete_set_non_associates associates \<and> (Complete_set_residues residues) \<and> echelon_form_JNF A
  \<and> (\<forall>i<dim_row A. \<not> is_zero_row_JNF i A \<longrightarrow> A $$ (i, LEAST n. A $$ (i, n) \<noteq> 0) \<in> associates)
  \<and> (\<forall>i<dim_row A. \<not> is_zero_row_JNF i A \<longrightarrow> (\<forall>j. j<i \<longrightarrow> A $$ (j, (LEAST n. A $$ (i, n) \<noteq> 0))
     \<in> residues (A $$ (i,(LEAST n. A $$ (i,n) \<noteq> 0)))
  )))"

lemma HMA_LEAST[transfer_rule]:
  assumes AA': "(Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'n :: mod_type ^ 'm :: mod_type \<Rightarrow> _) A A'"
  and ii': "Mod_Type_Connect.HMA_I i i'" and zero_i: "\<not> is_zero_row_JNF i A"
shows "Mod_Type_Connect.HMA_I (LEAST n. A $$ (i, n) \<noteq> 0) (LEAST n. index_hma A' i' n \<noteq> 0)"
proof -
  define l where "l = (LEAST n'. A' $h i' $h n' \<noteq> 0)"
  let ?least_n2 = "Mod_Type.to_nat l"
  note AA'[transfer_rule] ii'[transfer_rule]
  have [transfer_rule]: "Mod_Type_Connect.HMA_I ?least_n2 l"
    by (simp add: Mod_Type_Connect.HMA_I_def)
  have zero_i': "\<not> is_zero_row i' A'" using zero_i by transfer
  have "(LEAST n. A $$ (i, n) \<noteq> 0) = ?least_n2"
      proof (rule Least_equality)
        obtain n' where n'1: "A $$ (i,n') \<noteq> 0" and n'2: "n'<dim_col A"
        using zero_i unfolding is_zero_row_JNF_def by auto
      let ?n' = "Mod_Type.from_nat n'::'n"
      have n'n'[transfer_rule]: "Mod_Type_Connect.HMA_I n' ?n'"
        unfolding Mod_Type_Connect.HMA_I_def using Mod_Type.to_nat_from_nat_id n'2
        using AA' Mod_Type_Connect.dim_col_transfer_rule by fastforce
      have "index_hma A' i' ?n' \<noteq> 0" using n'1 by transfer
      hence A'i'n': "A' $h i' $h ?n' \<noteq> 0" unfolding index_hma_def by simp
      have least_le_n': "(LEAST n. A $$ (i, n) \<noteq> 0)  \<le> n'" by (simp add: Least_le n'1)
      have l1_le_n': "l \<le> ?n'" by (simp add: A'i'n' Least_le l_def)
      have "A $$ (i, ?least_n2) = index_hma A' i' l" by (transfer, simp)
      also have "... = A' $h i' $h l" unfolding index_hma_def by simp
      also have "... \<noteq> 0" unfolding l_def by (metis (mono_tags) A'i'n' LeastI)
      finally show "A $$ (i, mod_type_class.to_nat l) \<noteq> 0" .
      fix y assume Aiy: "A $$ (i, y) \<noteq> 0"
      let ?y' = "Mod_Type.from_nat y::'n"
      show "Mod_Type.to_nat l \<le> y"
      proof (cases "y\<le>n'")
        case True
        hence y: "y < dim_col A" using n'2 by auto
        have yy'[transfer_rule]: "Mod_Type_Connect.HMA_I y ?y'" unfolding Mod_Type_Connect.HMA_I_def
          apply (rule Mod_Type.to_nat_from_nat_id[symmetric])
          using y Mod_Type_Connect.dim_col_transfer_rule[OF AA'] by auto
        have "Mod_Type.to_nat l \<le> Mod_Type.to_nat ?y'"
        proof (rule to_nat_mono')
          have "index_hma A' i' ?y' \<noteq> 0" using Aiy by transfer
          hence "A' $h i' $h ?y' \<noteq> 0" unfolding index_hma_def by simp
          thus "l \<le> ?y'" unfolding l_def by (simp add: Least_le)
        qed
          then show ?thesis by (metis Mod_Type_Connect.HMA_I_def yy')
        next
          case False
          hence "n' < y" by auto
          then show ?thesis
            by (metis False Mod_Type_Connect.HMA_I_def dual_order.trans l1_le_n' linear n'n' to_nat_mono')
        qed
      qed
      thus ?thesis unfolding Mod_Type_Connect.HMA_I_def l_def index_hma_def by auto
qed

lemma element_least_not_zero_eq_HMA_JNF:
  fixes A':: "'a :: comm_ring_1 ^ 'n :: mod_type ^ 'm :: mod_type"
  assumes AA': "Mod_Type_Connect.HMA_M A A'" and jj': "Mod_Type_Connect.HMA_I j j'"
    and ii': "Mod_Type_Connect.HMA_I i i'" and zero_i': "\<not> is_zero_row i' A'"
  shows "A $$ (j, LEAST n. A $$ (i, n) \<noteq> 0) = A' $h j' $h (LEAST n. A' $h i' $h n \<noteq> 0)"
proof -
  note AA'[transfer_rule] jj'[transfer_rule] ii'[transfer_rule]
  have [transfer_rule]: "Mod_Type_Connect.HMA_I (LEAST n. A $$ (i, n) \<noteq> 0) (LEAST n. index_hma A' i' n \<noteq> 0)"
    by (rule HMA_LEAST[OF AA' ii'], insert zero_i', transfer, simp)
  have "A' $h j' $h (LEAST n. A' $h i' $h n \<noteq> 0) = index_hma A' j' (LEAST n. index_hma A' i' n \<noteq> 0)"
    unfolding index_hma_def by simp
  also have "... = A $$ (j, LEAST n. A $$ (i, n) \<noteq> 0)" by (transfer', simp)
  finally show ?thesis by simp
qed

lemma HMA_Hermite[transfer_rule]:
  shows "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: {bezout_ring_div,normalization_semidom} ^ 'n :: mod_type ^ 'm :: mod_type \<Rightarrow> _) ===> (=))
  (Hermite_JNF associates residues) (Hermite associates residues)"
proof (intro rel_funI, goal_cases)
  case (1 A A')
  note AA' = "1"(1)[transfer_rule]
  have 1: "echelon_form A' = echelon_form_JNF A" by (transfer, simp)
  have 2: "(\<forall>i<dim_row A. \<not> is_zero_row_JNF i A \<longrightarrow> A $$ (i, LEAST n. A $$ (i, n) \<noteq> 0) \<in> associates) =
  (\<forall>i. \<not> is_zero_row i A' \<longrightarrow> A' $h i $h (LEAST n. A' $h i $h n \<noteq> 0) \<in> associates)" (is "?lhs = ?rhs")
  proof
    assume lhs: "?lhs"
    show "?rhs"
    proof (rule allI, rule impI)
      fix i' assume zero_i': "\<not> is_zero_row i' A'"
      let ?i = "Mod_Type.to_nat i'"
      have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I ?i i'" unfolding Mod_Type_Connect.HMA_I_def by simp
      have [simp]: "?i < dim_row A" using Mod_Type.to_nat_less_card[of i']
        using AA' Mod_Type_Connect.dim_row_transfer_rule by fastforce
      have zero_i: "\<not> is_zero_row_JNF ?i A" using zero_i' by transfer
      have [transfer_rule]: "Mod_Type_Connect.HMA_I (LEAST n. A $$ (?i, n) \<noteq> 0) (LEAST n. index_hma A' i' n \<noteq> 0)"
        by (rule HMA_LEAST[OF AA' ii'], insert zero_i', transfer, simp)
      have "A' $h i' $h (LEAST n. A' $h i' $h n \<noteq> 0) = A $$ (?i, LEAST n. A $$ (?i, n) \<noteq> 0)"
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' ii' ii' zero_i', symmetric])
      also have "... \<in> associates" using lhs zero_i by simp
      finally show "A' $h i' $h (LEAST n. A' $h i' $h n \<noteq> 0) \<in> associates" .
    qed
  next
    assume rhs: "?rhs"
    show "?lhs"
    proof (rule allI, rule impI, rule impI)
      fix i assume zero_i: "\<not> is_zero_row_JNF i A" and i: "i < dim_row A"
      let ?i' = "Mod_Type.from_nat i :: 'm"
      have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'" unfolding Mod_Type_Connect.HMA_I_def
        using Mod_Type.to_nat_from_nat_id AA' Mod_Type_Connect.dim_row_transfer_rule i by fastforce
      have zero_i': "\<not> is_zero_row ?i' A'" using zero_i by transfer
      have "A $$ (i, LEAST n. A $$ (i, n) \<noteq> 0) = A' $h ?i' $h (LEAST n. A' $h ?i' $h n \<noteq> 0)"
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' ii' ii' zero_i'])
      also have "... \<in> associates" using rhs zero_i' i by simp
      finally show "A $$ (i, LEAST n. A $$ (i, n) \<noteq> 0) \<in> associates" .
    qed
  qed
  have 3: "(\<forall>i<dim_row A. \<not> is_zero_row_JNF i A \<longrightarrow> (\<forall>j<i. A $$ (j, LEAST n. A $$ (i, n) \<noteq> 0)
            \<in> residues (A $$ (i, LEAST n. A $$ (i, n) \<noteq> 0)))) =
            (\<forall>i. \<not> is_zero_row i A' \<longrightarrow> (\<forall>j<i. A' $h j $h (LEAST n. A' $h i $h n \<noteq> 0)
            \<in> residues (A' $h i $h (LEAST n. A' $h i $h n \<noteq> 0))))" (is "?lhs = ?rhs")
  proof
    assume lhs: "?lhs"
    show "?rhs"
    proof (rule allI, rule impI, rule allI, rule impI)
      fix i' j' :: 'm
      assume zero_i': "\<not> is_zero_row i' A'" and j'i': "j' < i'"
      let ?i = "Mod_Type.to_nat i'"
      have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I ?i i'" unfolding Mod_Type_Connect.HMA_I_def by simp
      have i: "?i < dim_row A"
        using AA' Mod_Type_Connect.dim_row_transfer_rule mod_type_class.to_nat_less_card
        by fastforce
      have zero_i: "\<not> is_zero_row_JNF ?i A" using zero_i' by transfer'
      let ?j = "Mod_Type.to_nat j'"
      have jj'[transfer_rule]: "Mod_Type_Connect.HMA_I ?j j'" unfolding Mod_Type_Connect.HMA_I_def by simp
      have ji: "?j<?i" using j'i' to_nat_mono by blast
      have eq1: "A $$ (?j, LEAST n. A $$ (?i, n) \<noteq> 0) = A' $h j' $h (LEAST n. A' $h i' $h n \<noteq> 0)"
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' jj' ii' zero_i'])
      have eq2: "A $$ (?i, LEAST n. A $$ (?i, n) \<noteq> 0) = A' $h i' $h (LEAST n. A' $h i' $h n \<noteq> 0)"
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' ii' ii' zero_i'])
      show "A' $h j' $h (LEAST n. A' $h i' $h n \<noteq> 0) \<in> residues (A' $h i' $h (LEAST n. A' $h i' $h n \<noteq> 0))"
        using lhs eq1 eq2 ji i zero_i by fastforce
    qed
  next
    assume rhs: "?rhs"
    show "?lhs"
    proof (safe)
      fix i j assume i: "i < dim_row A" and zero_i: "\<not> is_zero_row_JNF i A" and ji: "j < i"
      let ?i' = "Mod_Type.from_nat i :: 'm"
      have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'" unfolding Mod_Type_Connect.HMA_I_def
        using Mod_Type.to_nat_from_nat_id AA' Mod_Type_Connect.dim_row_transfer_rule i by fastforce
      have zero_i': "\<not> is_zero_row ?i' A'" using zero_i by transfer
      let ?j' = "Mod_Type.from_nat j :: 'm"
      have j'i': "?j' < ?i'" using AA' Mod_Type_Connect.dim_row_transfer_rule from_nat_mono i ji
        by fastforce
      have jj'[transfer_rule]: "Mod_Type_Connect.HMA_I j ?j'" unfolding Mod_Type_Connect.HMA_I_def
        using Mod_Type.to_nat_from_nat_id[of j, where ?'a='m] AA'
          Mod_Type_Connect.dim_row_transfer_rule[OF AA'] j'i' i ji by auto
      have zero_i': "\<not> is_zero_row ?i' A'" using zero_i by transfer
      have eq1: "A $$ (j, LEAST n. A $$ (i, n) \<noteq> 0) = A' $h ?j' $h (LEAST n. A' $h ?i' $h n \<noteq> 0)"
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' jj' ii' zero_i'])
      have eq2: "A $$ (i, LEAST n. A $$ (i, n) \<noteq> 0) = A' $h ?i' $h (LEAST n. A' $h ?i' $h n \<noteq> 0)"
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' ii' ii' zero_i'])
      show "A $$ (j, LEAST n. A $$ (i, n) \<noteq> 0) \<in> residues (A $$ (i, LEAST n. A $$ (i, n) \<noteq> 0))"
        using rhs eq1 eq2 j'i' i zero_i' by fastforce
    qed
  qed
  show "Hermite_JNF associates residues A = Hermite associates residues A'"
    unfolding Hermite_def Hermite_JNF_def
    using 1 2 3 by auto
qed

corollary HMA_Hermite2[transfer_rule]:
  shows "((=) ===> (=) ===> (Mod_Type_Connect.HMA_M :: _
  \<Rightarrow> 'a :: {bezout_ring_div,normalization_semidom} ^ 'n :: mod_type ^ 'm :: mod_type \<Rightarrow> _) ===> (=))
  (Hermite_JNF) (Hermite)"
  by (simp add: HMA_Hermite rel_funI)

text \<open>Once the definitions of both libraries are connected, we start to move the theorem about
the uniqueness of the Hermite normal form (stated in HOL Analysis, named @{text "Hermite_unique"})
to JNF.\<close>

text \<open>Using the previous transfer rules, we get an statement in JNF. However, the matrices
have @{text "CARD('n::mod_type)"} rows and columns. We want to get rid of that type variable and
just state that they are of dimension $n \times n$ (expressed via the predicate @{text "carrier_mat"}\<close>

lemma Hermite_unique_JNF':
  fixes A::"'a::{bezout_ring_div,normalization_euclidean_semiring,unique_euclidean_ring} mat"
  assumes "A \<in> carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "P \<in> carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "H \<in> carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "Q \<in> carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "K \<in> carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat A" and "invertible_mat P"
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K"
proof -
  define A' where "A' = (Mod_Type_Connect.to_hma\<^sub>m A :: 'a ^'n :: mod_type ^'n :: mod_type)"
  define P' where "P' = (Mod_Type_Connect.to_hma\<^sub>m P :: 'a ^'n :: mod_type ^'n :: mod_type)"
  define H' where "H' = (Mod_Type_Connect.to_hma\<^sub>m H :: 'a ^'n :: mod_type ^'n :: mod_type)"
  define Q' where "Q' = (Mod_Type_Connect.to_hma\<^sub>m Q :: 'a ^'n :: mod_type ^'n :: mod_type)"
  define K' where "K' = (Mod_Type_Connect.to_hma\<^sub>m K :: 'a ^'n :: mod_type ^'n :: mod_type)"
  have AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'" unfolding Mod_Type_Connect.HMA_M_def using assms A'_def by auto
  have PP'[transfer_rule]: "Mod_Type_Connect.HMA_M P P'" unfolding Mod_Type_Connect.HMA_M_def using assms P'_def by auto
  have HH'[transfer_rule]: "Mod_Type_Connect.HMA_M H H'" unfolding Mod_Type_Connect.HMA_M_def using assms H'_def by auto
  have QQ'[transfer_rule]: "Mod_Type_Connect.HMA_M Q Q'" unfolding Mod_Type_Connect.HMA_M_def using assms Q'_def by auto
  have KK'[transfer_rule]: "Mod_Type_Connect.HMA_M K K'" unfolding Mod_Type_Connect.HMA_M_def using assms K'_def by auto
  have A_PH: "A' = P' ** H'" using assms by transfer
  moreover have A_QK: "A' = Q' ** K'" using assms by transfer
  moreover have inv_A: "invertible A'" using assms by transfer
  moreover have inv_P: "invertible P'" using assms by transfer
  moreover have inv_Q: "invertible Q'" using assms by transfer
  moreover have H: "Hermite associates res H'" using assms by transfer
  moreover have K: "Hermite associates res K'" using assms by transfer
  ultimately have "H' = K'" using Hermite_unique by blast
  thus "H=K" by transfer
qed

text \<open>Since the @{text "mod_type"} restriction relies on many things, the shortcut is to use
the @{text "mod_ring"} typedef developed in the Berlekamp-Zassenhaus development.
This type definition allows us to apply local type definitions easily.
Since @{text "mod_ring"} is just an instance of @{text "mod_type"}, it is straightforward to
obtain the following lemma, where @{text "CARD('n::mod_type)"} has now been substituted by
@{text "CARD('n::nontriv mod_ring)"}\<close>

corollary Hermite_unique_JNF_with_nontriv_mod_ring:
  fixes A::"'a::{bezout_ring_div,normalization_euclidean_semiring,unique_euclidean_ring} mat"
  assumes "A \<in> carrier_mat CARD('n) CARD('n::nontriv mod_ring)"
    "P \<in> carrier_mat CARD('n) CARD('n)"
    "H \<in> carrier_mat CARD('n) CARD('n)"
    "Q \<in> carrier_mat CARD('n) CARD('n)"
    "K \<in> carrier_mat CARD('n) CARD('n)"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat A" and "invertible_mat P"
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K" using Hermite_unique_JNF' assms by (smt CARD_mod_ring)

text \<open>Now, we assume in a context that there exists a type text @{text "'b"} of cardinality $n$
and we prove inside this context the lemma.\<close>

context
  fixes n::nat
  assumes local_typedef: "\<exists>(Rep :: ('b \<Rightarrow> int)) Abs. type_definition Rep Abs {0..<n :: int}"
  and p: "n>1"
begin

private lemma type_to_set:
  shows "class.nontriv TYPE('b)" (is ?a) and "n=CARD('b)" (is ?b)
proof -
  from local_typedef obtain Rep::"('b \<Rightarrow> int)" and Abs
    where t: "type_definition Rep Abs {0..<n :: int}" by auto
  have "card (UNIV :: 'b set) = card {0..<n}" using t type_definition.card by fastforce
  also have "... = n" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using p by auto
qed

lemma Hermite_unique_JNF_aux:
  fixes A::"'a::{bezout_ring_div,normalization_euclidean_semiring,unique_euclidean_ring} mat"
  assumes "A \<in> carrier_mat n n"
    "P \<in> carrier_mat n n"
    "H \<in> carrier_mat n n"
    "Q \<in> carrier_mat n n "
    "K \<in> carrier_mat n n"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat A" and "invertible_mat P"
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K"
  using Hermite_unique_JNF_with_nontriv_mod_ring[unfolded CARD_mod_ring,
      internalize_sort "'n::nontriv", where ?'a='b]
  unfolding type_to_set(2)[symmetric] using type_to_set(1) assms by blast
end

text \<open>Now, we cancel the local type definition of the previous context.
Since the @{text "mod_type"} restriction imposes the type to have cardinality greater than 1,
the cases $n=0$ and $n=1$ must be proved separately (they are trivial)\<close>

lemma Hermite_unique_JNF:
  fixes A::"'a::{bezout_ring_div,normalization_euclidean_semiring,unique_euclidean_ring} mat"
  assumes A: "A \<in> carrier_mat n n" and P: "P \<in> carrier_mat n n" and H: "H \<in> carrier_mat n n"
   and Q: "Q \<in> carrier_mat n n" and K: "K \<in> carrier_mat n n"
 assumes A_PH: "A = P * H" and A_QK: "A = Q * K"
   and inv_A: "invertible_mat A" and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q"
   and HNF_H: "Hermite_JNF associates res H" and HNF_K: "Hermite_JNF associates res K"
  shows "H = K"
proof (cases "n=0 \<or> n=1")
  case True note zero_or_one = True
  show ?thesis
  proof (cases "n=0")
    case True
    then show ?thesis using assms by auto
  next
    case False
    have CS_A: "Complete_set_non_associates associates" using HNF_H unfolding Hermite_JNF_def by simp
    have H: "H \<in> carrier_mat 1 1" and K: "K\<in> carrier_mat 1 1" using False zero_or_one assms by auto
    have det_P_dvd_1: "Determinant.det P dvd 1" using invertible_iff_is_unit_JNF inv_P P by blast
    have det_Q_dvd_1: "Determinant.det Q dvd 1" using invertible_iff_is_unit_JNF inv_Q Q by blast
    have PH_QK: "Determinant.det P * Determinant.det H = Determinant.det Q * Determinant.det K"
      using Determinant.det_mult assms by metis
    hence "Determinant.det P * H $$ (0,0) = Determinant.det Q * K $$ (0,0)"
      by (metis H K determinant_one_element)
    obtain u where uH_K: "u * H $$(0,0) = K $$ (0,0)" and unit_u: "is_unit u"
      by (metis (no_types, opaque_lifting) H K PH_QK algebraic_semidom_class.dvd_mult_unit_iff det_P_dvd_1
          det_Q_dvd_1 det_singleton dvdE dvd_mult_cancel_left mult.commute mult.right_neutral one_dvd)
    have H00_not_0: "H $$ (0,0) \<noteq> 0"
      by (metis A A_PH Determinant.det_mult False H P determinant_one_element inv_A
          invertible_iff_is_unit_JNF mult_not_zero not_is_unit_0 zero_or_one)
    hence LEAST_H: "(LEAST n. H $$ (0,n) \<noteq> 0) = 0" by simp
    have H00: "H $$ (0,0) \<in> associates" using HNF_H LEAST_H H H00_not_0
      unfolding Hermite_JNF_def is_zero_row_JNF_def by auto
    have K00_not_0: "K $$ (0,0) \<noteq> 0"
      by (metis A A_QK Determinant.det_mult False K Q determinant_one_element inv_A
          invertible_iff_is_unit_JNF mult_not_zero not_is_unit_0 zero_or_one)
    hence LEAST_K: "(LEAST n. K $$ (0,n) \<noteq> 0) = 0" by simp
    have K00: "K $$ (0,0) \<in> associates" using HNF_K LEAST_K K K00_not_0
      unfolding Hermite_JNF_def is_zero_row_JNF_def by auto
    have ass_H00_K00: "normalize (H $$ (0,0)) = normalize (K $$ (0,0))"
      by (metis normalize_mult_unit_left uH_K unit_u)
    have H00_eq_K00: "H $$ (0,0) = K $$ (0,0)"
      using in_Ass_not_associated[OF CS_A H00 K00] ass_H00_K00 by auto
    show ?thesis by (rule eq_matI, insert H K H00_eq_K00, auto)
  qed
next
  case False
  hence "{0..<int n} \<noteq> {}" by auto
  moreover have "n>1" using False by simp
  ultimately show ?thesis using Hermite_unique_JNF_aux[cancel_type_definition] assms by metis (*Cancel local type definition*)
qed

end

text \<open>From here on, we apply the same approach to move the new generalized statement about
the uniqueness Hermite normal form, i.e., the version restricted to integer matrices, but imposing
invertibility over the rationals.\<close>

(*TODO: move to Mod_Type_Connect in SNF development.
  There are two definitions of map_matrix, one in HMA_Connect and one in Finite_Cartesian_Product,
  but they are the same.*)
lemma HMA_map_matrix [transfer_rule]:
  "((=) ===> Mod_Type_Connect.HMA_M ===> Mod_Type_Connect.HMA_M) map_mat map_matrix"
  unfolding map_vector_def map_matrix_def[abs_def] map_mat_def[abs_def]
    Mod_Type_Connect.HMA_M_def Mod_Type_Connect.from_hma\<^sub>m_def
  by auto

lemma Hermite_unique_generalized_JNF':
  fixes A::"int mat"
  assumes "A \<in> carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "P \<in> carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "H \<in> carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "Q \<in> carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "K \<in> carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat (map_mat rat_of_int A)" and "invertible_mat P"
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K"
proof -
  define A' where "A' = (Mod_Type_Connect.to_hma\<^sub>m A :: int ^'n :: mod_type ^'n :: mod_type)"
  define P' where "P' = (Mod_Type_Connect.to_hma\<^sub>m P :: int ^'n :: mod_type ^'n :: mod_type)"
  define H' where "H' = (Mod_Type_Connect.to_hma\<^sub>m H :: int ^'n :: mod_type ^'n :: mod_type)"
  define Q' where "Q' = (Mod_Type_Connect.to_hma\<^sub>m Q :: int ^'n :: mod_type ^'n :: mod_type)"
  define K' where "K' = (Mod_Type_Connect.to_hma\<^sub>m K :: int ^'n :: mod_type ^'n :: mod_type)"
  have AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'" unfolding Mod_Type_Connect.HMA_M_def using assms A'_def by auto
  have PP'[transfer_rule]: "Mod_Type_Connect.HMA_M P P'" unfolding Mod_Type_Connect.HMA_M_def using assms P'_def by auto
  have HH'[transfer_rule]: "Mod_Type_Connect.HMA_M H H'" unfolding Mod_Type_Connect.HMA_M_def using assms H'_def by auto
  have QQ'[transfer_rule]: "Mod_Type_Connect.HMA_M Q Q'" unfolding Mod_Type_Connect.HMA_M_def using assms Q'_def by auto
  have KK'[transfer_rule]: "Mod_Type_Connect.HMA_M K K'" unfolding Mod_Type_Connect.HMA_M_def using assms K'_def by auto
  have A_PH: "A' = P' ** H'" using assms by transfer
  moreover have A_QK: "A' = Q' ** K'" using assms by transfer
  moreover have inv_A: "invertible (map_matrix rat_of_int A')" using assms by transfer
  moreover have "invertible (Finite_Cartesian_Product.map_matrix rat_of_int A')"
    using inv_A unfolding Finite_Cartesian_Product.map_matrix_def map_matrix_def map_vector_def
    by simp
  moreover have inv_P: "invertible P'" using assms by transfer
  moreover have inv_Q: "invertible Q'" using assms by transfer
  moreover have H: "Hermite associates res H'" using assms by transfer
  moreover have K: "Hermite associates res K'" using assms by transfer
  ultimately have "H' = K'" using Hermite_unique_generalized by blast
  thus "H=K" by transfer
qed

corollary Hermite_unique_generalized_JNF_with_nontriv_mod_ring:
  fixes A::"int mat"
  assumes "A \<in> carrier_mat CARD('n) CARD('n::nontriv mod_ring)"
    "P \<in> carrier_mat CARD('n) CARD('n)"
    "H \<in> carrier_mat CARD('n) CARD('n)"
    "Q \<in> carrier_mat CARD('n) CARD('n)"
    "K \<in> carrier_mat CARD('n) CARD('n)"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat (map_mat rat_of_int A)" and "invertible_mat P"
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K" using Hermite_unique_generalized_JNF' assms by (smt CARD_mod_ring)

context
  fixes p::nat
  assumes local_typedef: "\<exists>(Rep :: ('b \<Rightarrow> int)) Abs. type_definition Rep Abs {0..<p :: int}"
  and p: "p>1"
begin

private lemma type_to_set2:
  shows "class.nontriv TYPE('b)" (is ?a) and "p=CARD('b)" (is ?b)
proof -
  from local_typedef obtain Rep::"('b \<Rightarrow> int)" and Abs
    where t: "type_definition Rep Abs {0..<p :: int}" by auto
  have "card (UNIV :: 'b set) = card {0..<p}" using t type_definition.card by fastforce
  also have "... = p" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using p by auto
qed

lemma Hermite_unique_generalized_JNF_aux:
  fixes A::"int mat"
  assumes "A \<in> carrier_mat p p"
    "P \<in> carrier_mat p p"
    "H \<in> carrier_mat p p"
    "Q \<in> carrier_mat p p"
    "K \<in> carrier_mat p p"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat (map_mat rat_of_int A)" and "invertible_mat P"
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K"
  using Hermite_unique_generalized_JNF_with_nontriv_mod_ring[unfolded CARD_mod_ring,
      internalize_sort "'n::nontriv", where ?'a='b]
  unfolding type_to_set2(2)[symmetric] using type_to_set2(1) assms by blast
end

lemma HNF_unique_generalized_JNF:
  fixes A::"int mat"
  assumes A: "A \<in> carrier_mat n n" and P: "P \<in> carrier_mat n n" and H: "H \<in> carrier_mat n n"
   and Q: "Q \<in> carrier_mat n n" and K: "K \<in> carrier_mat n n"
 assumes A_PH: "A = P * H" and A_QK: "A = Q * K"
   and inv_A: "invertible_mat (map_mat rat_of_int A)" and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q"
   and HNF_H: "Hermite_JNF associates res H" and HNF_K: "Hermite_JNF associates res K"
  shows "H = K"
proof (cases "n=0 \<or> n=1")
  case True note zero_or_one = True
  show ?thesis
  proof (cases "n=0")
    case True
    then show ?thesis using assms by auto
  next
    let ?RAT = "map_mat rat_of_int"
    case False
    hence n: "n=1" using zero_or_one by auto
    have CS_A: "Complete_set_non_associates associates" using HNF_H unfolding Hermite_JNF_def by simp
    have H: "H \<in> carrier_mat 1 1" and K: "K\<in> carrier_mat 1 1" using False zero_or_one assms by auto
    have det_P_dvd_1: "Determinant.det P dvd 1" using invertible_iff_is_unit_JNF inv_P P by blast
    have det_Q_dvd_1: "Determinant.det Q dvd 1" using invertible_iff_is_unit_JNF inv_Q Q by blast
    have PH_QK: "Determinant.det P * Determinant.det H = Determinant.det Q * Determinant.det K"
      using Determinant.det_mult assms by metis
    hence "Determinant.det P * H $$ (0,0) = Determinant.det Q * K $$ (0,0)"
      by (metis H K determinant_one_element)
    obtain u where uH_K: "u * H $$(0,0) = K $$ (0,0)" and unit_u: "is_unit u"
      by (metis (no_types, opaque_lifting) H K PH_QK algebraic_semidom_class.dvd_mult_unit_iff det_P_dvd_1
          det_Q_dvd_1 det_singleton dvdE dvd_mult_cancel_left mult.commute mult.right_neutral one_dvd)
    have H00_not_0: "H $$ (0,0) \<noteq> 0"
    proof -
      have "?RAT A = ?RAT P * ?RAT H" using A_PH
        using P H n of_int_hom.mat_hom_mult by blast
      hence "det (?RAT H) \<noteq> 0"
        by (metis A Determinant.det_mult False H P inv_A invertible_iff_is_unit_JNF
            map_carrier_mat mult_eq_0_iff not_is_unit_0 zero_or_one)
      thus ?thesis
        using H determinant_one_element by force
    qed
    hence LEAST_H: "(LEAST n. H $$ (0,n) \<noteq> 0) = 0" by simp
    have H00: "H $$ (0,0) \<in> associates" using HNF_H LEAST_H H H00_not_0
      unfolding Hermite_JNF_def is_zero_row_JNF_def by auto
    have K00_not_0: "K $$ (0,0) \<noteq> 0"
    proof -
      have "?RAT A = ?RAT Q * ?RAT K" using A_QK
        using Q K n of_int_hom.mat_hom_mult by blast
      hence "det (?RAT K) \<noteq> 0"
        by (metis A Determinant.det_mult False Q K inv_A invertible_iff_is_unit_JNF
            map_carrier_mat mult_eq_0_iff not_is_unit_0 zero_or_one)
      thus ?thesis
        using K determinant_one_element by force
    qed
    hence LEAST_K: "(LEAST n. K $$ (0,n) \<noteq> 0) = 0" by simp
    have K00: "K $$ (0,0) \<in> associates" using HNF_K LEAST_K K K00_not_0
      unfolding Hermite_JNF_def is_zero_row_JNF_def by auto
    have ass_H00_K00: "normalize (H $$ (0,0)) = normalize (K $$ (0,0))"
      by (metis normalize_mult_unit_left uH_K unit_u)
    have H00_eq_K00: "H $$ (0,0) = K $$ (0,0)"
      using in_Ass_not_associated[OF CS_A H00 K00] ass_H00_K00 by auto
    show ?thesis by (rule eq_matI, insert H K H00_eq_K00, auto)
  qed
next
  case False
  hence "{0..<int n} \<noteq> {}" by auto
  moreover have "n>1" using False by simp
  ultimately show ?thesis
    using Hermite_unique_generalized_JNF_aux[cancel_type_definition] assms by metis (*Cancel local type definition*)
qed

end


section{*\label{sec_ListProp}List Operations. Permutations and Substitutions*}

theory ListProp imports Main "~~/src/HOL/Library/Permutation"
begin

lemma perm_mset: "perm x y = (mset x = mset y)"
  by (simp add: mset_eq_perm)

lemma perm_tp: "perm (x@y) (y@x)"
  by (simp add: perm_mset union_commute)

  lemma perm_union_left: "perm x z \<Longrightarrow> perm (x @ y) (z @ y)"
    by (simp add: perm_mset)

  lemma perm_union_right: "perm x z \<Longrightarrow> perm (y @ x) (y @ z)"
    by (simp add: perm_mset)

  lemma perm_trans: "perm x y \<Longrightarrow> perm y z \<Longrightarrow> perm x z"
    by (simp add: perm_mset)

  lemma perm_sym: "perm x y \<Longrightarrow> perm y x"
    by (simp add: perm_mset)

  lemma perm_length: "perm u v \<Longrightarrow> length u = length v"
    by (metis perm_mset size_mset)

   lemma perm_set_eq: "perm x y \<Longrightarrow> set x = set y"
     by (metis perm_mset set_mset_mset)

     lemma perm_empty[simp]: "(perm [] v) = (v = [])" and "(perm v []) = (v = [])"
       by (simp_all add: perm_mset)

      lemma perm_refl[simp]: "perm x x"
        by (simp add: perm_mset)

  lemma dist_perm: "\<And> y . distinct x \<Longrightarrow> perm x y \<Longrightarrow> distinct y"
    by (metis card_distinct distinct_card mset_eq_setD perm_mset perm_length )

      lemma split_perm: "perm (a # x) x' = (\<exists> y y' . x' = y @ a # y' \<and> perm x (y @ y'))"
        apply safe
        apply (subgoal_tac "\<exists> y y' .  x' = y @ a # y'")
        apply safe
        apply (rule_tac x = y in exI)
        apply (rule_tac x = y' in exI, simp_all)
          apply (simp add: perm_mset)
        apply (drule perm_set_eq)
        apply (simp add: set_eq_iff)
        using split_list apply fastforce
          by (simp add: perm_mset)

  fun subst:: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> 'a" where
    "subst [] [] c = c" |
    "subst (a#x) (b#y) c = (if a = c then b else subst x y c)" |
    "subst x y c = undefined"

  lemma subst_notin [simp]: "\<And> y . length x = length y \<Longrightarrow> a \<notin> set x \<Longrightarrow> subst x y a = a"
    apply (induction x, simp_all)
    by (metis Suc_length_conv subst.simps(2))

  lemma subst_cons_a:"\<And> y . distinct x \<Longrightarrow> a \<notin> set x \<Longrightarrow> b \<notin> set x \<Longrightarrow> length x = length y \<Longrightarrow>  subst (a # x) (b # y) c =  (subst x y (subst [a] [b] c))"
    by simp

  lemma subst_eq: "subst x x y = y"
    apply (induct x)
    by (auto)

  fun Subst :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "Subst x y [] = []" |
    "Subst x y (a # z) = subst x y a # (Subst x y z)"

  lemma Subst_empty[simp]: "Subst [] [] y = y"
    apply (induct y)
    by (auto)

  (*todo: make simp*)
  lemma Subst_eq: "Subst x x y = y"
    apply (induction y)
    by (simp_all add: subst_eq)

  lemma Subst_append: "Subst a b (x@y) = Subst a b x @ Subst a b y"
    by (induction x, simp_all)

  lemma Subst_notin[simp]: "a \<notin> set z \<Longrightarrow> Subst (a # x) (b # y) z = Subst x y z"
    by (induction z, simp_all)

  lemma Subst_all[simp]: "\<And> v . distinct u \<Longrightarrow>length u = length v \<Longrightarrow> Subst u v u = v"
    apply (induction u, simp_all)
    by (case_tac v, simp_all)

  lemma Subst_inex[simp]: "\<And> b. set a \<inter> set x = {} \<Longrightarrow> length a = length b \<Longrightarrow> Subst a b x = x"
    apply (induction a, simp_all)
    by (metis Subst_notin Suc_length_conv)

  lemma set_Subst: "set (Subst [a] [b] x) = (if a \<in> set x then (set x - {a}) \<union> {b} else set x)"
    apply (induction x)
    by auto

  lemma distinct_Subst: "distinct (b#x) \<Longrightarrow> distinct (Subst [a] [b] x)"
    apply (induction x)
    apply simp_all
    by (auto simp add: set_Subst)

  lemma inter_Subst: "distinct(b#y) \<Longrightarrow> set x \<inter> set y = {} \<Longrightarrow> b \<notin> set x \<Longrightarrow> set x \<inter> set (Subst [a] [b] y) = {}"
    apply (induction y)
    by simp_all

  lemma incl_Subst: "distinct(b#x) \<Longrightarrow> set y \<subseteq> set x \<Longrightarrow> set (Subst [a] [b] y) \<subseteq> set (Subst [a] [b] x)"
    apply safe
    apply (simp add: set_Subst less_eq_set_def le_fun_def, auto)
    apply (case_tac "a \<in> set y", simp_all)
    apply (metis DiffE Diff_insert_absorb UnE singletonI)
    by meson

  lemma subst_in_set: "\<And>y. length x = length y \<Longrightarrow> a \<in> set x \<Longrightarrow> subst x y a \<in> set y"
    apply (induction x, auto)
    apply (case_tac y, simp_all)
    by (case_tac y, simp_all)

  lemma Subst_set_incl: "length x = length y \<Longrightarrow> set z \<subseteq> set x \<Longrightarrow> set (Subst x y z) \<subseteq> set y"
    apply (induction z, auto)
    by (simp add: subst_in_set)

  lemma subst_not_in: "\<And> y . a \<notin> set x' \<Longrightarrow> length x = length y \<Longrightarrow> length x' = length y' \<Longrightarrow> subst (x @ x') (y @ y') a = subst x y a"
    apply (induction x, simp_all)
    by (case_tac y, simp_all)

  lemma subst_not_in_b: "\<And> y . a \<notin> set x \<Longrightarrow> length x = length y \<Longrightarrow> length x' = length y' \<Longrightarrow> subst (x @ x') (y @ y') a = subst x' y' a"
    apply (induction x, simp_all)
    by (case_tac y, simp_all, auto)

  lemma Subst_not_in: "set x' \<inter> set z = {} \<Longrightarrow> length x = length y \<Longrightarrow> length x' = length y' \<Longrightarrow> Subst (x @ x') (y @ y') z = Subst x y z"
    apply (induction z, simp_all)
    by (simp add: subst_not_in)

  lemma Subst_not_in_a: "set x \<inter> set z = {} \<Longrightarrow> length x = length y \<Longrightarrow> length x' = length y' \<Longrightarrow> Subst (x @ x') (y @ y') z = Subst x' y' z"
    apply (induction z, simp_all)
    by (simp add: subst_not_in_b)

  lemma subst_cancel_right [simp]: "\<And> y z . set x \<inter> set y = {} \<Longrightarrow> length y = length z \<Longrightarrow> subst (x @ y) (x @ z) a = subst y z a"
    by (induction x, simp_all, safe, simp)

  lemma Subst_cancel_right: "set x \<inter> set y = {} \<Longrightarrow> length y = length z \<Longrightarrow> Subst (x @ y) (x @ z) w = Subst y z w"
    by (induction w, simp_all)

  lemma subst_cancel_left [simp]: "\<And> y z . set x \<inter> set z = {} \<Longrightarrow> length x = length y \<Longrightarrow> subst (x @ z) (y @ z) a = subst x y a"
    apply (induction x, simp_all, safe, simp)
    apply (simp add: subst_eq)
    by (case_tac y, simp_all)

  lemma Subst_cancel_left: "set x \<inter> set z = {} \<Longrightarrow> length x = length y \<Longrightarrow> Subst (x @ z) (y @ z) w = Subst x y w"
    by (induction w, simp_all)

  lemma Subst_cancel_right_a: "a \<notin>  set y \<Longrightarrow> length y = length z \<Longrightarrow> Subst (a # y) (a # z) w = Subst y z w"
    apply (cut_tac x = "[a]" in Subst_cancel_right)
    by (simp_all)

  lemma subst_subst_id [simp]: "\<And> y . a \<in> set y \<Longrightarrow> distinct x \<Longrightarrow> length x = length y \<Longrightarrow> subst x y (subst y x a) = a"
    apply (induction x, simp_all)
    apply (case_tac y, simp_all, auto)
    by (simp add: subst_in_set)

  lemma Subst_Subst_id[simp]: "set z \<subseteq> set y \<Longrightarrow> distinct x \<Longrightarrow> length x = length y \<Longrightarrow> Subst x y (Subst y x z) = z"
    by (induction z, simp_all)

  lemma Subst_cons_aux_a: "set x \<inter> set y = {} \<Longrightarrow> distinct y \<Longrightarrow> length y = length z \<Longrightarrow> Subst (x @ y) (x @ z) y = z"
    apply (induction x)
    by simp_all

  lemma Subst_set_empty [simp]: "set z \<inter> set x = {} \<Longrightarrow> length x = length y \<Longrightarrow> Subst x y z = z"
    by (induction z, simp_all)

  lemma length_Subst[simp]: "length (Subst x y z) = length z"
    by (induction z, simp_all)

  lemma subst_Subst: "\<And> y y' . length y = length y' \<Longrightarrow> a \<in> set w \<Longrightarrow> subst w (Subst y y' w) a = subst y y' a"
    by (induction w, simp_all, auto)

  lemma Subst_Subst: "length y = length y' \<Longrightarrow> set z \<subseteq> set w \<Longrightarrow> Subst w (Subst y y' w) z = Subst y y' z"
    by (induction z, simp_all add: subst_Subst)

  (*to sort*)

  primrec listinter :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "\<otimes>" 60) where
    "[] \<otimes> y = []" |
    "(a # x) \<otimes> y = (if a \<in> set y then a # (x \<otimes> y) else x \<otimes> y)"

  lemma inter_filter: "x \<otimes> y = filter (\<lambda> a . a \<in> set y) x"
    by (induction x, simp_all)

  lemma inter_append: "set y \<inter> set z = {} \<Longrightarrow> perm (x \<otimes> (y @ z)) ((x \<otimes> y) @ (x \<otimes> z))"
    apply (induction x, simp_all add: perm_mset)
    apply safe
    by blast

  lemma append_inter: "(x @ y) \<otimes> z = (x \<otimes> z) @ (y \<otimes> z)"
    by (induction x, simp_all)

  lemma notin_inter [simp]: "a \<notin> set x \<Longrightarrow> a \<notin> set (x \<otimes> y)"
    by (induction x, simp_all)

  lemma distinct_inter: "distinct x \<Longrightarrow> distinct (x \<otimes> y)"
    by (induction x, simp_all)

  lemma set_inter: "set (x \<otimes> y) = set x \<inter> set y"
    by (induction x, simp_all)

  primrec diff :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "\<ominus>" 52) where
    "[] \<ominus> y = []" |
    "(a # x) \<ominus> y = (if a \<in> set y then x \<ominus> y else a # (x \<ominus> y))"

  lemma diff_filter: "x \<ominus> y = filter (\<lambda> a . a \<notin> set y) x"
    by (induction x, simp_all)

  lemma diff_distinct: "set x \<inter> set y = {} \<Longrightarrow> (y \<ominus> x) = y"
    by (induction y, simp_all)

  lemma set_diff: "set (x \<ominus> y) = set x - set y"
    by (induction x, simp_all, auto)

  lemma distinct_diff: "distinct x \<Longrightarrow> distinct (x \<ominus> y)"
    by (induction x, simp_all add: set_diff)

  definition addvars :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "\<oplus>" 55) where
    "addvars x y = x @ (y \<ominus> x)"

  lemma addvars_distinct: "set x \<inter> set y = {} \<Longrightarrow> x \<oplus> y = x @ y"
    by (simp add: addvars_def diff_distinct)

  lemma set_addvars: "set (x \<oplus> y) = set x \<union> set y"
    by (simp add: addvars_def set_diff)

  lemma distinct_addvars: "distinct x \<Longrightarrow> distinct y \<Longrightarrow> distinct (x \<oplus> y)"
    apply (simp add: addvars_def, induction x, simp_all)
    apply (simp add: distinct_diff)
    by (simp add: Diff_Int_distrib distinct_diff set_diff)

  lemma mset_inter_diff: "mset oa = mset (oa \<otimes> ia) + mset (oa \<ominus> (oa \<otimes> ia))"
    apply (simp add: inter_filter diff_filter)
    by (metis (mono_tags, lifting) filter_cong mset_compl_union)

  lemma diff_inter_left: "(x \<ominus> (x \<otimes> y)) = (x \<ominus> y)"
    apply (simp add: diff_filter inter_filter)
    by (metis (no_types, lifting) filter_cong)

  lemma diff_inter_right: "(x \<ominus> (y \<otimes> x)) = (x \<ominus> y)"
    apply (simp add: diff_filter inter_filter)
    by (metis (no_types, lifting) filter_cong)

  lemma addvars_minus: "(x \<oplus> y) \<ominus> z = (x \<ominus> z) \<oplus> (y \<ominus> z)"
    apply (simp add: diff_filter addvars_def)
    by (metis)

  lemma addvars_assoc: "x \<oplus> y \<oplus> z = x \<oplus> (y \<oplus> z)"
    apply (simp add: addvars_def diff_filter)
    by metis

  lemma diff_sym: "(x \<ominus> y \<ominus> z) = (x \<ominus> z \<ominus> y)"
    apply (simp add: diff_filter)
    by metis

  lemma diff_union: "(x \<ominus> y @ z) = (x \<ominus> y \<ominus> z)"
    by (simp add: diff_filter)

  lemma diff_notin: "set x \<inter> set z = {} \<Longrightarrow> (x \<ominus> (y \<ominus> z)) = (x \<ominus> y)"
    apply (simp add: diff_filter disjoint_iff_not_equal)
    by (metis (no_types, lifting) filter_cong)

  lemma union_diff: "x @ y \<ominus> z = ((x \<ominus> z) @ (y \<ominus> z))"
    by (simp add: diff_filter)

  lemma diff_inter_empty: "set x \<inter> set y = {} \<Longrightarrow> x \<ominus> y \<otimes> z = x"
    apply (simp add: diff_filter inter_filter)
    by (metis (no_types, lifting) disjoint_iff_not_equal filter_True)

  lemma inter_diff_empty: "set x \<inter> set z = {} \<Longrightarrow> x \<otimes> (y \<ominus> z) = (x \<otimes> y)"
    apply (simp add: diff_filter inter_filter)
    by (metis (no_types, lifting) disjoint_iff_not_equal filter_cong)

  lemma inter_diff_distrib: "(x \<ominus> y) \<otimes> z = ((x \<otimes> z) \<ominus> (y \<otimes> z))"
    apply (simp add: diff_filter inter_filter)
    by (metis)

  lemma diff_emptyset: "x \<ominus> [] = x"
    by (simp add: diff_filter)

  lemma diff_eq: "x \<ominus> x = []"
    by (simp add: diff_filter)

  lemma diff_subset: "set x \<subseteq> set y \<Longrightarrow> x \<ominus> y = []"
    by (metis Diff_eq_empty_iff set_diff set_empty)

  lemma empty_inter: "set x \<inter> set y = {} \<Longrightarrow> x \<otimes> y = []"
    by (metis set_empty set_inter)

  lemma empty_inter_diff: "set x \<inter> set y = {} \<Longrightarrow> x \<otimes> (y \<ominus> z) = []"
    apply (simp add: inter_filter diff_filter)
    by (metis (no_types, lifting) disjoint_iff_not_equal filter_False)

  lemma inter_addvars_empty: "set x \<inter> set z = {} \<Longrightarrow> x \<otimes> y @ z = x \<otimes> y"
    apply (simp add: inter_filter)
    by (metis (no_types, lifting) disjoint_iff_not_equal filter_cong)

  lemma diff_disjoint: "set x \<inter> set y = {} \<Longrightarrow> x \<ominus> y = x"
    by (metis diff_distinct inter_filter inter_set_filter set_inter)

      lemma addvars_empty[simp]: "x \<oplus> [] = x"
        by (simp add: addvars_def)

      lemma empty_addvars[simp]: "[] \<oplus> x = x"
        apply (induction x, simp_all)
        by (simp add: addvars_def)

  lemma distrib_diff_addvars: "x \<ominus> (y @ z) = ((x \<ominus> y) \<otimes> (x \<ominus> z))"
    apply (simp add: diff_filter inter_filter)
    by (metis diff_filter diff_inter_left filter_True filter_filter inter_diff_distrib inter_filter inter_set_filter set_inter)

  lemma inter_subset: "x \<otimes> (x \<ominus> y) = (x \<ominus> y)"
    by (metis diff_emptyset diff_union distrib_diff_addvars)

  lemma diff_cancel: "x \<ominus> y \<ominus> (z \<ominus> y) = (x \<ominus> y \<ominus> z)"
    by (simp add: diff_notin inf_commute set_diff)

  lemma diff_cancel_set: "set x \<inter> set u = {} \<Longrightarrow> x \<ominus> y \<ominus> (z \<ominus> u) = (x \<ominus> y \<ominus> z)"
    by (metis diff_notin diff_sym)

  lemma inter_subset_l1: "\<And> y. distinct x \<Longrightarrow> length y = 1 \<Longrightarrow> set y \<subseteq> set x \<Longrightarrow> x \<otimes> y = y"
    apply (induction x, simp_all)
    apply safe
    apply (metis (no_types, lifting) Diff_insert_absorb Int_insert_left_if0 Suc_length_conv empty_inter empty_iff inf.orderE inf_commute length_0_conv list.set(1) list.simps(15) singletonD subset_insert_iff)
    by auto

  lemma perm_diff_left_inter: "perm (x \<ominus> y) (((x \<ominus> y) \<otimes> z) @ ((x \<ominus> y) \<ominus> z))"
    apply (simp add: diff_filter inter_filter perm_mset)
    by (metis filter_filter mset_compl_union)

  lemma perm_diff_right_inter: "perm (x \<ominus> y) (((x \<ominus> y) \<ominus> z) @ ((x \<ominus> y) \<otimes> z))"
    by (metis perm_mset perm_diff_left_inter perm_tp)

  lemma perm_switch_aux_a: "perm x ((x \<ominus> y) @ (x \<otimes> y))"
    by (metis diff_emptyset perm_diff_right_inter)

  lemma perm_switch_aux_b: "perm (x @ (y \<ominus> x)) ((x \<ominus> y) @ (x \<otimes> y) @ (y \<ominus> x))"
    by (metis perm_switch_aux_a append_assoc mset_append perm_mset)

  lemma perm_switch_aux_c: "distinct x \<Longrightarrow> distinct y \<Longrightarrow> perm ((y \<otimes> x) @ (y \<ominus> x)) y"
    by (metis perm_switch_aux_a perm_mset perm_tp)

  lemma perm_switch_aux_d: "distinct x \<Longrightarrow> distinct y \<Longrightarrow> perm (x \<otimes> y) (y \<otimes> x)"
    by (metis distinct_inter inf.commute perm_mset set_eq_iff_mset_eq_distinct set_inter)

  lemma perm_switch_aux_e: "distinct x \<Longrightarrow> distinct y \<Longrightarrow> perm ((x \<otimes> y) @ (y \<ominus> x)) ((y \<otimes> x) @ (y \<ominus> x))"
    by (simp add: perm_union_left perm_switch_aux_d)

  lemma perm_switch_aux_f: "distinct x \<Longrightarrow> distinct y \<Longrightarrow> perm ((x \<otimes> y) @ (y \<ominus> x)) y"
    apply (cut_tac x="((x \<otimes> y) @ (y \<ominus> x))"  and y ="((y \<otimes> x) @ (y \<ominus> x))" and z="y" in perm_trans)
      apply (simp add: perm_switch_aux_e)
      apply (simp add: perm_switch_aux_d)
    apply (simp add: perm_switch_aux_c)
    by simp

  lemma perm_switch_aux_h: "distinct x \<Longrightarrow> distinct y \<Longrightarrow> perm ((x \<ominus> y) @ (x \<otimes> y) @ (y \<ominus> x)) ((x \<ominus> y) @ y)"
    by (simp add: perm_union_right perm_switch_aux_f)

  lemma perm_switch: "distinct x \<Longrightarrow> distinct y \<Longrightarrow> perm (x @ (y \<ominus> x)) ((x \<ominus> y) @ y)"
    apply (cut_tac x="(x @ (y \<ominus> x))"  and y ="((x \<ominus> y) @ (x \<otimes> y) @ (y \<ominus> x))" and z="((x \<ominus> y) @ y)" in perm_trans)
      apply (simp add: perm_switch_aux_b)
      using perm_switch_aux_h apply blast
    by simp

  lemma perm_aux_a: "distinct x \<Longrightarrow> distinct y \<Longrightarrow> x \<otimes> y = x \<Longrightarrow> perm (x @ (y \<ominus> x)) y"
    apply (cut_tac x=x and y=y in perm_switch_aux_f)
    by (simp_all)
      lemma ZZZ_a: "x \<oplus> (y \<ominus> x) = (x \<oplus> y)"
        apply (simp add: addvars_def)
        by (induction y, simp_all)

      lemma ZZZ_b: "set (y \<otimes> z) \<inter> set x = {} \<Longrightarrow> (x \<ominus> (y \<ominus> z) \<ominus> (z \<ominus> y)) = (x \<ominus> y \<ominus> z)"
        by (induction x, simp_all add: set_diff set_inter)

      lemma subst_subst: "\<And> y z . a \<in> set z \<Longrightarrow> distinct x \<Longrightarrow> length x = length y \<Longrightarrow> length z = length x
        \<Longrightarrow> subst x y (subst z x a) = subst z y a"
        apply (induction x, simp_all)
        apply (case_tac y, simp_all)
        apply (case_tac z, simp_all, auto)
        by (simp add: subst_in_set)

      lemma Subst_Subst_a: "set u \<subseteq> set z \<Longrightarrow> distinct x \<Longrightarrow> length x = length y \<Longrightarrow> length z = length x
      \<Longrightarrow> Subst x y (Subst z x u) = (Subst z y u)"
        apply (induction u, simp_all)
        apply (case_tac y, simp_all)
        by (rule subst_subst,simp_all)
      lemma subst_in: "\<And> x' . length x = length x' \<Longrightarrow> a \<in> set x \<Longrightarrow> subst (x @ y) (x' @ y') a = subst x x' a"
        apply (induction x, simp_all)
        by (case_tac x', auto)

      lemma subst_switch: "\<And> x' . set x \<inter> set y = {} \<Longrightarrow> length x = length x' \<Longrightarrow> length y = length y'
        \<Longrightarrow> subst (x @ y) (x' @ y') a = subst (y @ x) (y' @ x') a"
        apply (induction x, simp_all)
        apply (case_tac x', simp_all, safe)
        apply (simp add: subst_not_in_b)
        apply (case_tac "a \<in> set y", simp_all)
        apply (simp add: subst_in)
        by (simp add: subst_not_in_b)

      lemma Subst_switch: "set x \<inter> set y = {} \<Longrightarrow> length x = length x' \<Longrightarrow> length y = length y'
        \<Longrightarrow> Subst (x @ y) (x'@ y') z = Subst (y @ x) (y'@ x') z"
        apply (induction z, simp_all)
        by (subst subst_switch, simp_all)

      lemma subst_comp: "\<And> x' . set x \<inter> set y = {} \<Longrightarrow> set x' \<inter> set y = {} \<Longrightarrow> length x = length x'
        \<Longrightarrow> length y = length y' \<Longrightarrow> subst (x @ y) (x' @ y') a = subst y y' (subst x x' a)"
        apply (induction x, simp_all)
        by (case_tac x', simp_all)

      lemma Subst_comp: "set x \<inter> set y = {} \<Longrightarrow> set x' \<inter> set y = {} \<Longrightarrow> length x = length x'
      \<Longrightarrow> length y = length y' \<Longrightarrow> Subst (x @ y) (x' @ y') z = Subst y y' (Subst x x' z)"
        by (induction z, simp_all add: subst_comp)

      lemma set_subst: "\<And> u' . length u = length u' \<Longrightarrow> subst u u' a \<in> set u' \<union> ({a} - set u)"
        apply (induction u, simp_all)
        by (case_tac u', simp_all, auto)

      lemma set_Subst_a: "length u = length u' \<Longrightarrow> set (Subst u u' z) \<subseteq> set u' \<union> (set z - set u)"
        apply (induction z, simp_all)
        by (cut_tac u = u and u' = u' and a  = a in set_subst, simp_all, auto)

      lemma set_SubstI: "length u = length u' \<Longrightarrow> set u' \<union> (set z - set u) \<subseteq> X \<Longrightarrow> set (Subst u u' z) \<subseteq> X"
        apply (rule_tac y = "set u' \<union> (set z - set u)" in order_trans)
        by (rule set_Subst_a, simp_all)

  lemma not_in_set_diff: "a \<notin> set x \<Longrightarrow> x \<ominus> ys @ a # zs = x \<ominus> ys @ zs"
    by (induction x, auto)

      lemma [simp]: "(x \<ominus> y \<ominus> (y \<ominus> z)) = (x \<ominus> y)"
        by (induction x, simp_all, auto simp add: set_diff)

      lemma [simp]: "(x \<ominus> y \<ominus> (y \<ominus> z \<ominus> z')) = (x \<ominus> y)"
        by (induction x, simp_all, auto simp add: set_diff)

      lemma diff_addvars: "x \<ominus> (y \<oplus> z) = (x \<ominus> y \<ominus> z)"
        by (induction x, auto simp add: set_diff set_addvars)

      lemma diff_redundant_a: "x \<ominus> y \<ominus> z \<ominus> (y \<ominus> u) = (x \<ominus> y \<ominus> z)"
        by (induction x, simp_all add: set_diff)

      lemma diff_redundant_b: "x \<ominus> y \<ominus> z \<ominus> (z \<ominus> u) = (x \<ominus> y \<ominus> z)"
        by (induction x, simp_all add: set_diff)

      lemma diff_redundant_c: "x \<ominus> y \<ominus> z \<ominus> (y \<ominus> u \<ominus> v) = (x \<ominus> y \<ominus> z)"
        by (induction x, simp_all add: set_diff)

      lemma diff_redundant_d: "x \<ominus> y \<ominus> z \<ominus> (z \<ominus> u \<ominus> v) = (x \<ominus> y \<ominus> z)"
        by (induction x, simp_all add: set_diff)

   lemma set_list_empty: "set x = {} \<Longrightarrow> x = []"
      by (induction x, simp_all)

    lemma [simp]: "(x \<ominus> x \<otimes> y) \<otimes> (y \<ominus> x \<otimes> y) = []"
      apply (rule set_list_empty)
      by (simp add: set_inter set_diff, auto)

    lemma [simp]: "set x \<inter> set (y \<ominus> x) = {}"
      by (simp add: set_diff)

lemma [simp]:" distinct x \<Longrightarrow> distinct y \<Longrightarrow> set x \<subseteq> set y \<Longrightarrow> perm (x @ (y \<ominus> x)) y"
  by (metis append_Nil diff_subset perm_switch)

    lemma [simp]: "perm x y \<Longrightarrow> set x \<subseteq> set y"
      by (simp add: perm_set_eq)
    lemma [simp]: "perm x y \<Longrightarrow> set y \<subseteq> set x"
      by (simp add: perm_set_eq)

    lemma [simp]: "set (x \<ominus> y) \<subseteq> set x"
      by (auto simp add: set_diff)

      lemma perm_diff[simp]: "\<And> x' . perm x x' \<Longrightarrow> perm y y' \<Longrightarrow> perm (x \<ominus> y) (x' \<ominus> y')"
        apply (induction x, simp_all)
        apply (frule_tac x = y and y = y' in perm_set_eq, simp)
        apply (simp add: split_perm union_diff)
        apply auto
        apply (simp_all add: union_diff)
        apply (metis union_diff)
        by (metis union_diff)

    lemma [simp]: "perm x x' \<Longrightarrow> perm y y' \<Longrightarrow> perm (x @ y) (x' @ y')"
      by (simp add: perm_mset)

    lemma [simp]: "perm x x' \<Longrightarrow> perm y y' \<Longrightarrow> perm (x \<oplus> y) (x' \<oplus> y')"
      by (simp add: addvars_def)

    thm distinct_diff

declare distinct_diff [simp]
  (*
    declare perm_set_eq [simp]
*)
    lemma [simp]: "\<And> x' . perm x x' \<Longrightarrow> perm y y' \<Longrightarrow> perm (x \<otimes> y) (x' \<otimes> y')"
      apply (induction x, simp_all, safe)
      apply (simp add: split_perm, safe, simp_all)
      apply (rule_tac x = "ya \<otimes> y'" in exI)
      apply (rule_tac x = "y'a \<otimes> y'" in exI)
      apply (simp add: append_inter)
      apply (subgoal_tac "perm (x \<otimes> y) ((ya @ y'a) \<otimes> y')")
      apply (subst (asm) append_inter, simp_all add: perm_set_eq)

      apply (simp add: split_perm, safe, simp_all)
      apply (subgoal_tac "perm (x \<otimes> y) ((ya @ y'a) \<otimes> y')")
      apply (subst (asm) append_inter, simp add: append_inter)
      by simp

    declare distinct_inter [simp]

    lemma perm_ops: "perm x x' \<Longrightarrow> perm y y' \<Longrightarrow> f = (\<otimes>) \<or> f = (\<ominus>) \<or> f = (\<oplus>) \<Longrightarrow> perm (f x y) (f x' y')"
      apply safe
      by (simp_all)

    lemma [simp]: "perm x' x \<Longrightarrow> perm y' y \<Longrightarrow> f = (\<otimes>) \<or> f = (\<ominus>) \<or> f = (\<oplus>) \<Longrightarrow> perm (f x y) (f x' y')"
      by (rule_tac x = x and y = y and x' = x' and y' = y' in perm_ops, unfold perm_mset, simp_all)

    lemma [simp]: "perm x x' \<Longrightarrow> perm y' y \<Longrightarrow> f = (\<otimes>) \<or> f = (\<ominus>) \<or> f = (\<oplus>) \<Longrightarrow> perm (f x y) (f x' y')"
      by (rule_tac x = x and y = y and x' = x' and y' = y' in perm_ops, unfold perm_mset, simp_all)

    lemma [simp]: "perm x' x \<Longrightarrow> perm y y' \<Longrightarrow> f = (\<otimes>) \<or> f = (\<ominus>) \<or> f = (\<oplus>) \<Longrightarrow> perm (f x y) (f x' y')"
      by (rule_tac x = x and y = y and x' = x' and y' = y' in perm_ops, unfold perm_mset, simp_all)

      lemma diff_cons: "(x \<ominus> (a # y)) = (x \<ominus> [a] \<ominus> y)"
        by (induction x, simp_all)

    lemma [simp]: "x \<oplus> y \<oplus> x = x \<oplus> y"
        apply (simp add: addvars_def)
        by (simp add: diff_eq diff_union)

      lemma  subst_subst_inv: "\<And> y . distinct y \<Longrightarrow> length x = length y \<Longrightarrow> a \<in> set x \<Longrightarrow> subst y x (subst x y a) = a"
        by (induction x, auto)

      lemma Subst_Subst_inv: "distinct y \<Longrightarrow> length x = length y \<Longrightarrow> set z \<subseteq> set x \<Longrightarrow> Subst y x (Subst x y z) = z"
        apply (induction z)
        by (simp_all add: subst_subst_inv)

      (*move*)
      lemma perm_append: "perm x x' \<Longrightarrow> perm y y' \<Longrightarrow> perm (x @ y) (x' @ y')"
        by (simp add: perm_mset)

      lemma "x' = y @ a # y' \<Longrightarrow> perm x (y @ y') \<Longrightarrow> perm (a # x) x'"
        by (simp add: perm_mset)

      lemma perm_diff_eq: "perm y y' \<Longrightarrow> (x \<ominus> y) = (x \<ominus> y')"
        apply (drule perm_set_eq)
        by (induction x, auto)

      lemma [simp]: "A \<inter> B = {} \<Longrightarrow> x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> False"
        by auto
      lemma [simp]: "A \<inter> B = {} \<Longrightarrow> x \<in> A \<Longrightarrow> x \<notin> B"
        by auto

      lemma [simp]: "B \<inter> A = {} \<Longrightarrow> x \<in> A \<Longrightarrow> x \<notin> B"
        by auto
      lemma [simp]: "B \<inter> A = {} \<Longrightarrow> x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> False"
        by auto

lemma distinct_perm_set_eq: "distinct x \<Longrightarrow> distinct y \<Longrightarrow> perm x y = (set x = set y)"
  by (simp add: perm_mset set_eq_iff_mset_eq_distinct)

      lemma set_perm: "distinct x \<Longrightarrow> distinct y \<Longrightarrow> set x = set y \<Longrightarrow> perm x y"
        by (simp add: distinct_perm_set_eq)

      lemma distinct_perm_switch: "distinct x \<Longrightarrow> distinct y \<Longrightarrow> perm (x \<oplus> y) (y \<oplus> x)"
        apply (simp add: addvars_def)
        by (rule set_perm, simp_all add: set_diff, auto)
lemma listinter_diff: "(x \<otimes> y) \<ominus> z = (x \<ominus> z) \<otimes> (y \<ominus> z)"
  apply (induction x, simp_all)
  by (simp add: set_diff)

lemma set_listinter: "set y = set z \<Longrightarrow> x \<otimes> y = x \<otimes> z"
  by (induction x, simp_all)

lemma AAA_c: "a \<notin> set x \<Longrightarrow> x \<ominus> [a] = x"
  by (induction x, simp_all, auto)

lemma distinct_perm_cons: "distinct x \<Longrightarrow> perm (a # y) x \<Longrightarrow> perm y (x \<ominus> [a])"
  apply (rule set_perm)
    apply (meson dist_perm distinct.simps(2) perm_sym)
   apply simp
  proof -
    assume a1: "distinct x"
  assume a2: "perm (a # y) x"
  then have "set (a # y) = set x"
    by (meson perm_set_eq)
  then show "set y = set (x \<ominus> [a])"
    using a2 a1 by (metis (no_types) AAA_c diff.simps(2) dist_perm distinct.simps(2) list.set_intros(1) perm_sym set_diff)
qed

lemma listinter_empty[simp]: " y \<otimes> [] = []"
  by (induction y, simp_all)

lemma subsetset_inter: "set x \<subseteq> set y \<Longrightarrow> (x \<otimes> y) = x"
  by (induction x, auto)

lemma addvars_addsame: "x \<oplus> y \<oplus> (x \<ominus> z) = x \<oplus> y"
  by (metis ListProp.diff_eq ZZZ_a addvars_empty diff_addvars)

lemma ZZZ: "x \<ominus> x \<oplus> y = []"
  by (simp add: ListProp.diff_eq diff_addvars)

lemma perm_dist_mem: "distinct x \<Longrightarrow> a \<in> set x \<Longrightarrow> perm (a # (x \<ominus> [a])) x"
  by (metis Diff_iff distinct.simps(2) distinct_diff empty_set insert_Diff list.set(2) list.set_intros(1) set_diff set_perm)

lemma addvars_diff: "b # (x \<oplus> (z \<ominus> [b])) = (b # x) \<oplus> z"
proof -
  have "z \<ominus> [b] \<ominus> b # x = z \<ominus> [b] \<ominus> [] \<ominus> [b] \<ominus> x \<ominus> []"
    by (metis diff_cons diff_emptyset)
    then have f1: "x @ (z \<ominus> [b] \<ominus> b # x) = x \<oplus> (z \<ominus> [b] \<ominus> b # x)"
      by (metis (no_types) ZZZ_a addvars_def diff_cons)
    have "z \<ominus> [b] \<ominus> b # x = z \<ominus> [b] \<ominus> x \<ominus> [b]"
      by (metis (no_types) diff_cons diff_sym)
    then show ?thesis
      using f1 by (metis (no_types) addvars_def append.simps(2) diff_cons)
  qed

lemma perm_cons: "a \<in> set y \<Longrightarrow> distinct y \<Longrightarrow> perm x (y \<ominus> [a]) \<Longrightarrow> perm (a # x) y"
  apply (rule set_perm, simp_all add: set_diff perm_set_eq, safe)
  using dist_perm distinct_diff perm_sym by blast

end


(*  Title:      HOL/Fun_Def.thy
    Author:     Alexander Krauss, TU Muenchen
*)

section \<open>Function Definitions and Termination Proofs\<close>

theory Fun_Def
  imports Basic_BNF_LFPs Partial_Function SAT
  keywords
    "function" "termination" :: thy_goal_defn and
    "fun" "fun_cases" :: thy_defn
begin

subsection \<open>Definitions with default value\<close>

definition THE_default :: "'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a"
  where "THE_default d P = (if (\<exists>!x. P x) then (THE x. P x) else d)"

lemma THE_defaultI': "\<exists>!x. P x \<Longrightarrow> P (THE_default d P)"
  by (simp add: theI' THE_default_def)

lemma THE_default1_equality: "\<exists>!x. P x \<Longrightarrow> P a \<Longrightarrow> THE_default d P = a"
  by (simp add: the1_equality THE_default_def)

lemma THE_default_none: "\<not> (\<exists>!x. P x) \<Longrightarrow> THE_default d P = d"
  by (simp add: THE_default_def)

lemma fundef_ex1_existence:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  shows "G x (f x)"
  apply (simp only: f_def)
  apply (rule THE_defaultI')
  apply (rule ex1)
  done

lemma fundef_ex1_uniqueness:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  assumes elm: "G x (h x)"
  shows "h x = f x"
  by (auto simp add: f_def ex1 elm THE_default1_equality[symmetric])

lemma fundef_ex1_iff:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  shows "(G x y) = (f x = y)"
  by (auto simp add: ex1 f_def THE_default1_equality THE_defaultI')

lemma fundef_default_value:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes graph: "\<And>x y. G x y \<Longrightarrow> D x"
  assumes "\<not> D x"
  shows "f x = d x"
proof -
  have "\<not>(\<exists>y. G x y)"
  proof
    assume "\<exists>y. G x y"
    then have "D x" using graph ..
    with \<open>\<not> D x\<close> show False ..
  qed
  then have "\<not>(\<exists>!y. G x y)" by blast
  then show ?thesis
    unfolding f_def by (rule THE_default_none)
qed

definition in_rel_def[simp]: "in_rel R x y \<equiv> (x, y) \<in> R"

lemma wf_in_rel: "wf R \<Longrightarrow> wfP (in_rel R)"
  by (simp add: wfP_def)

ML_file \<open>Tools/Function/function_core.ML\<close>
ML_file \<open>Tools/Function/mutual.ML\<close>
ML_file \<open>Tools/Function/pattern_split.ML\<close>
ML_file \<open>Tools/Function/relation.ML\<close>
ML_file \<open>Tools/Function/function_elims.ML\<close>

method_setup relation = \<open>
  Args.term >> (fn t => fn ctxt => SIMPLE_METHOD' (Function_Relation.relation_infer_tac ctxt t))
\<close> "prove termination using a user-specified wellfounded relation"

ML_file \<open>Tools/Function/function.ML\<close>
ML_file \<open>Tools/Function/pat_completeness.ML\<close>

method_setup pat_completeness = \<open>
  Scan.succeed (SIMPLE_METHOD' o Pat_Completeness.pat_completeness_tac)
\<close> "prove completeness of (co)datatype patterns"

ML_file \<open>Tools/Function/fun.ML\<close>
ML_file \<open>Tools/Function/induction_schema.ML\<close>

method_setup induction_schema = \<open>
  Scan.succeed (CONTEXT_TACTIC oo Induction_Schema.induction_schema_tac)
\<close> "prove an induction principle"

subsection \<open>Measure functions\<close>

inductive is_measure :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
  where is_measure_trivial: "is_measure f"

named_theorems measure_function "rules that guide the heuristic generation of measure functions"
ML_file \<open>Tools/Function/measure_functions.ML\<close>

lemma measure_size[measure_function]: "is_measure size"
  by (rule is_measure_trivial)

lemma measure_fst[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (fst p))"
  by (rule is_measure_trivial)

lemma measure_snd[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (snd p))"
  by (rule is_measure_trivial)

ML_file \<open>Tools/Function/lexicographic_order.ML\<close>

method_setup lexicographic_order = \<open>
  Method.sections clasimp_modifiers >>
  (K (SIMPLE_METHOD o Lexicographic_Order.lexicographic_order_tac false))
\<close> "termination prover for lexicographic orderings"

subsection \<open>Congruence rules\<close>

lemma let_cong [fundef_cong]: "M = N \<Longrightarrow> (\<And>x. x = N \<Longrightarrow> f x = g x) \<Longrightarrow> Let M f = Let N g"
  unfolding Let_def by blast

lemmas [fundef_cong] =
  if_cong image_cong
  bex_cong ball_cong imp_cong map_option_cong Option.bind_cong

lemma split_cong [fundef_cong]:
  "(\<And>x y. (x, y) = q \<Longrightarrow> f x y = g x y) \<Longrightarrow> p = q \<Longrightarrow> case_prod f p = case_prod g q"
  by (auto simp: split_def)

lemma comp_cong [fundef_cong]: "f (g x) = f' (g' x') \<Longrightarrow> (f \<circ> g) x = (f' \<circ> g') x'"
  by (simp only: o_apply)

subsection \<open>Simp rules for termination proofs\<close>

declare
  trans_less_add1[termination_simp]
  trans_less_add2[termination_simp]
  trans_le_add1[termination_simp]
  trans_le_add2[termination_simp]
  less_imp_le_nat[termination_simp]
  le_imp_less_Suc[termination_simp]

lemma size_prod_simp[termination_simp]: "size_prod f g p = f (fst p) + g (snd p) + Suc 0"
  by (induct p) auto

subsection \<open>Decomposition\<close>

lemma less_by_empty: "A = {} \<Longrightarrow> A \<subseteq> B"
  and union_comp_emptyL: "A O C = {} \<Longrightarrow> B O C = {} \<Longrightarrow> (A \<union> B) O C = {}"
  and union_comp_emptyR: "A O B = {} \<Longrightarrow> A O C = {} \<Longrightarrow> A O (B \<union> C) = {}"
  and wf_no_loop: "R O R = {} \<Longrightarrow> wf R"
  by (auto simp add: wf_comp_self [of R])

subsection \<open>Reduction pairs\<close>

definition "reduction_pair P \<longleftrightarrow> wf (fst P) \<and> fst P O snd P \<subseteq> fst P"

lemma reduction_pairI[intro]: "wf R \<Longrightarrow> R O S \<subseteq> R \<Longrightarrow> reduction_pair (R, S)"
  by (auto simp: reduction_pair_def)

lemma reduction_pair_lemma:
  assumes rp: "reduction_pair P"
  assumes "R \<subseteq> fst P"
  assumes "S \<subseteq> snd P"
  assumes "wf S"
  shows "wf (R \<union> S)"
proof -
  from rp \<open>S \<subseteq> snd P\<close> have "wf (fst P)" "fst P O S \<subseteq> fst P"
    unfolding reduction_pair_def by auto
  with \<open>wf S\<close> have "wf (fst P \<union> S)"
    by (auto intro: wf_union_compatible)
  moreover from \<open>R \<subseteq> fst P\<close> have "R \<union> S \<subseteq> fst P \<union> S" by auto
  ultimately show ?thesis by (rule wf_subset)
qed

definition "rp_inv_image = (\<lambda>(R,S) f. (inv_image R f, inv_image S f))"

lemma rp_inv_image_rp: "reduction_pair P \<Longrightarrow> reduction_pair (rp_inv_image P f)"
  unfolding reduction_pair_def rp_inv_image_def split_def by force

subsection \<open>Concrete orders for SCNP termination proofs\<close>

definition "pair_less = less_than <*lex*> less_than"
definition "pair_leq = pair_less\<^sup>="
definition "max_strict = max_ext pair_less"
definition "max_weak = max_ext pair_leq \<union> {({}, {})}"
definition "min_strict = min_ext pair_less"
definition "min_weak = min_ext pair_leq \<union> {({}, {})}"

lemma wf_pair_less[simp]: "wf pair_less"
  by (auto simp: pair_less_def)

lemma total_pair_less [iff]: "total_on A pair_less" and trans_pair_less [iff]: "trans pair_less"
  by (auto simp: total_on_def pair_less_def)

text \<open>Introduction rules for \<open>pair_less\<close>/\<open>pair_leq\<close>\<close>
lemma pair_leqI1: "a < b \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
  and pair_leqI2: "a \<le> b \<Longrightarrow> s \<le> t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
  and pair_lessI1: "a < b  \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
  and pair_lessI2: "a \<le> b \<Longrightarrow> s < t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
  by (auto simp: pair_leq_def pair_less_def)

lemma pair_less_iff1 [simp]: "((x,y), (x,z)) \<in> pair_less \<longleftrightarrow> y<z"
  by (simp add: pair_less_def)

text \<open>Introduction rules for max\<close>
lemma smax_emptyI: "finite Y \<Longrightarrow> Y \<noteq> {} \<Longrightarrow> ({}, Y) \<in> max_strict"
  and smax_insertI:
    "y \<in> Y \<Longrightarrow> (x, y) \<in> pair_less \<Longrightarrow> (X, Y) \<in> max_strict \<Longrightarrow> (insert x X, Y) \<in> max_strict"
  and wmax_emptyI: "finite X \<Longrightarrow> ({}, X) \<in> max_weak"
  and wmax_insertI:
    "y \<in> YS \<Longrightarrow> (x, y) \<in> pair_leq \<Longrightarrow> (XS, YS) \<in> max_weak \<Longrightarrow> (insert x XS, YS) \<in> max_weak"
  by (auto simp: max_strict_def max_weak_def elim!: max_ext.cases)

text \<open>Introduction rules for min\<close>
lemma smin_emptyI: "X \<noteq> {} \<Longrightarrow> (X, {}) \<in> min_strict"
  and smin_insertI:
    "x \<in> XS \<Longrightarrow> (x, y) \<in> pair_less \<Longrightarrow> (XS, YS) \<in> min_strict \<Longrightarrow> (XS, insert y YS) \<in> min_strict"
  and wmin_emptyI: "(X, {}) \<in> min_weak"
  and wmin_insertI:
    "x \<in> XS \<Longrightarrow> (x, y) \<in> pair_leq \<Longrightarrow> (XS, YS) \<in> min_weak \<Longrightarrow> (XS, insert y YS) \<in> min_weak"
  by (auto simp: min_strict_def min_weak_def min_ext_def)

text \<open>Reduction Pairs.\<close>

lemma max_ext_compat:
  assumes "R O S \<subseteq> R"
  shows "max_ext R O (max_ext S \<union> {({}, {})}) \<subseteq> max_ext R"
proof -
  have "\<And>X Y Z. (X, Y) \<in> max_ext R \<Longrightarrow> (Y, Z) \<in> max_ext S \<Longrightarrow> (X, Z) \<in> max_ext R"
  proof -
    fix X Y Z
    assume "(X,Y)\<in>max_ext R"
      "(Y, Z)\<in>max_ext S"
    then have *: "finite X" "finite Y" "finite Z" "Y\<noteq>{}" "Z\<noteq>{}"
      "(\<And>x. x\<in>X \<Longrightarrow> \<exists>y\<in>Y. (x, y)\<in>R)"
      "(\<And>y. y\<in>Y \<Longrightarrow> \<exists>z\<in>Z. (y, z)\<in>S)"
      by (auto elim: max_ext.cases)
    moreover have "\<And>x. x\<in>X \<Longrightarrow> \<exists>z\<in>Z. (x, z)\<in>R"
    proof -
      fix x
      assume "x\<in>X"
      then obtain y where 1: "y\<in>Y" "(x, y)\<in>R"
        using * by auto
      then obtain z where "z\<in>Z" "(y, z)\<in>S"
        using * by auto
      then show "\<exists>z\<in>Z. (x, z)\<in>R"
        using assms 1 by (auto elim: max_ext.cases)
    qed
    ultimately show "(X,Z)\<in>max_ext R"
      by auto
  qed
  then show "max_ext R O (max_ext S \<union> {({}, {})}) \<subseteq> max_ext R"
    by auto
qed

lemma max_rpair_set: "reduction_pair (max_strict, max_weak)"
  unfolding max_strict_def max_weak_def
  apply (intro reduction_pairI max_ext_wf)
   apply simp
  apply (rule max_ext_compat)
  apply (auto simp: pair_less_def pair_leq_def)
  done

lemma min_ext_compat:
  assumes "R O S \<subseteq> R"
  shows "min_ext R O (min_ext S \<union> {({},{})}) \<subseteq> min_ext R"
proof -
  have "\<And>X Y Z z. \<forall>y\<in>Y. \<exists>x\<in>X. (x, y) \<in> R \<Longrightarrow> \<forall>z\<in>Z. \<exists>y\<in>Y. (y, z) \<in> S
  \<Longrightarrow> z \<in> Z \<Longrightarrow> \<exists>x\<in>X. (x, z) \<in> R"
  proof -
    fix X Y Z z
    assume *: "\<forall>y\<in>Y. \<exists>x\<in>X. (x, y) \<in> R"
      "\<forall>z\<in>Z. \<exists>y\<in>Y. (y, z) \<in> S"
      "z\<in>Z"
    then obtain y' where 1: "y'\<in>Y" "(y', z) \<in> S"
      by auto
    then obtain x' where 2: "x'\<in>X" "(x', y') \<in> R"
      using * by auto
    show "\<exists>x\<in>X. (x, z) \<in> R"
      using 1 2 assms by auto
  qed
  then show ?thesis
    using assms by (auto simp: min_ext_def)
qed

lemma min_rpair_set: "reduction_pair (min_strict, min_weak)"
  unfolding min_strict_def min_weak_def
  apply (intro reduction_pairI min_ext_wf)
   apply simp
  apply (rule min_ext_compat)
  apply (auto simp: pair_less_def pair_leq_def)
  done

subsection \<open>Yet another induction principle on the natural numbers\<close>

lemma nat_descend_induct [case_names base descend]:
  fixes P :: "nat \<Rightarrow> bool"
  assumes H1: "\<And>k. k > n \<Longrightarrow> P k"
  assumes H2: "\<And>k. k \<le> n \<Longrightarrow> (\<And>i. i > k \<Longrightarrow> P i) \<Longrightarrow> P k"
  shows "P m"
  using assms by induction_schema (force intro!: wf_measure [of "\<lambda>k. Suc n - k"])+

subsection \<open>Tool setup\<close>

ML_file \<open>Tools/Function/termination.ML\<close>
ML_file \<open>Tools/Function/scnp_solve.ML\<close>
ML_file \<open>Tools/Function/scnp_reconstruct.ML\<close>
ML_file \<open>Tools/Function/fun_cases.ML\<close>

ML_val \<comment> \<open>setup inactive\<close>
\<open>
  Context.theory_map (Function_Common.set_termination_prover
    (K (ScnpReconstruct.decomp_scnp_tac [ScnpSolve.MAX, ScnpSolve.MIN, ScnpSolve.MS])))
\<close>

end