header{* Modular and Distributive Lattices *}

(*
    Author: Viorel Preoteasa
*)

theory Modular_Distrib_Lattice
imports Lattice_Prop
begin

text {*
The main result of this theory is the fact that a lattice is distributive
if and only if it satisfies the following property:
*}

term "(\<forall> x y z . x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<Longrightarrow> x = y)"

text{*
This result was proved by Bergmann in \cite{bergmann:1929}. The formalization
presented here is based on \cite{birkhoff:1967,burris:sankappanavar:1981}.
*}

class modular_lattice = lattice +
  assumes modular: "x \<le> y \<Longrightarrow>  x \<squnion> (y \<sqinter> z) = y \<sqinter> (x \<squnion> z)"

context distrib_lattice begin
subclass modular_lattice
  apply unfold_locales
  by (simp add: inf_sup_distrib inf_absorb2)
end

context lattice begin
definition
  "d_aux a b c = (a \<sqinter> b) \<squnion> (b \<sqinter> c) \<squnion> (c \<sqinter> a)"

lemma d_b_c_a: "d_aux b c a = d_aux a b c"
  by (metis d_aux_def sup.assoc sup_commute)

lemma d_c_a_b: "d_aux c a b = d_aux a b c"
  by (metis d_aux_def sup.assoc sup_commute)

definition
  "e_aux a b c = (a \<squnion> b) \<sqinter> (b \<squnion> c) \<sqinter> (c \<squnion> a)"

lemma e_b_c_a: "e_aux b c a = e_aux a b c"
  apply (simp add: e_aux_def)
  apply (rule antisym)
  by (simp_all add: sup_commute)

lemma e_c_a_b: "e_aux c a b = e_aux a b c"
  apply (simp add: e_aux_def)
  apply (rule antisym)
  by (simp_all add: sup_commute)

definition
  "a_aux a b c = (a \<sqinter> (e_aux a b c)) \<squnion> (d_aux a b c)"

definition
  "b_aux a b c = (b \<sqinter> (e_aux a b c)) \<squnion> (d_aux a b c)"

definition
  "c_aux a b c = (c \<sqinter> (e_aux a b c)) \<squnion> (d_aux a b c)"

lemma b_a: "b_aux a b c = a_aux b c a"
  by (simp add: a_aux_def b_aux_def e_b_c_a d_b_c_a)

lemma c_a: "c_aux a b c = a_aux c a b"
  by (simp add: a_aux_def c_aux_def e_c_a_b d_c_a_b)

lemma [simp]: "b_aux a b c \<le> e_aux a b c"
  apply (unfold b_a)
  apply (subst e_b_c_a [THEN sym])
  by simp

lemma [simp]: "c_aux a b c \<le> e_aux a b c"
  apply (unfold c_a)
  apply (subst e_c_a_b [THEN sym])
  by simp

lemma [simp]: "d_aux a b c \<le> a_aux a b c"
  by (simp add: a_aux_def e_aux_def d_aux_def)

lemma [simp]: "d_aux a b c \<le> b_aux a b c"
  apply (unfold b_a)
  apply (subst d_b_c_a [THEN sym])
  by simp

lemma [simp]: "d_aux a b c \<le> c_aux a b c"
  apply (unfold c_a)
  apply (subst d_c_a_b [THEN sym])
  by simp

lemma a_meet_e: "a \<sqinter> (e_aux a b c) = a \<sqinter> (b \<squnion> c)"
  apply (simp add: e_aux_def)
  apply (rule antisym)
  apply simp_all
  apply (rule_tac y = "(a \<squnion> b) \<sqinter> (b \<squnion> c) \<sqinter> (c \<squnion> a)" in order_trans)
  apply (rule inf_le2)
  by simp

lemma b_meet_e: "b \<sqinter> (e_aux a b c) = b \<sqinter> (c \<squnion> a)"
  by (simp add: a_meet_e [THEN sym] e_b_c_a)

lemma c_meet_e: "c \<sqinter> (e_aux a b c) = c \<sqinter> (a \<squnion> b)"
  by (simp add: a_meet_e [THEN sym] e_c_a_b)

lemma a_join_d: "a \<squnion> d_aux a b c = a \<squnion> (b \<sqinter> c)"
  apply (simp add: d_aux_def)
  apply (rule antisym)
  apply simp_all
  apply (rule_tac y = "a \<sqinter> b \<squnion> b \<sqinter> c \<squnion> c \<sqinter> a" in order_trans)
  by simp_all

lemma b_join_d: "b \<squnion> d_aux a b c = b \<squnion> (c \<sqinter> a)"
  by (simp add: a_join_d [THEN sym] d_b_c_a)

end

context lattice begin
definition
  "no_distrib a b c = (a \<sqinter> b \<squnion> c \<sqinter> a < a \<sqinter> (b \<squnion> c))"

definition
  "incomp x y = (\<not> x \<le> y \<and> \<not> y \<le> x)"

definition
  "N5_lattice a b c = (a \<sqinter> c = b \<sqinter> c \<and> a < b \<and> a \<squnion> c = b \<squnion> c)"

definition
  "M5_lattice a b c = (a \<sqinter> b = b \<sqinter> c \<and> c \<sqinter> a = b \<sqinter> c \<and> a \<squnion> b = b \<squnion> c \<and> c \<squnion> a = b \<squnion> c \<and> a \<sqinter> b < a \<squnion> b)"

lemma M5_lattice_incomp: "M5_lattice a b c \<Longrightarrow> incomp a b"
  apply (simp add: M5_lattice_def incomp_def)
  apply safe
  apply (simp_all add: inf_absorb1 inf_absorb2 )
  apply (simp_all add: sup_absorb1 sup_absorb2 )
  apply (subgoal_tac "c \<sqinter> (b \<squnion> c) = c")
  apply simp
  apply (subst sup_commute)
  by simp
end

context modular_lattice begin

lemma a_meet_d: "a \<sqinter> (d_aux a b c) = (a \<sqinter> b) \<squnion> (c \<sqinter> a)"
  proof -
    have "a \<sqinter> (d_aux a b c) = a \<sqinter> ((a \<sqinter> b) \<squnion> (b \<sqinter> c) \<squnion> (c \<sqinter> a))" by (simp add: d_aux_def)
    also have "... = a \<sqinter> (a \<sqinter> b \<squnion> c \<sqinter> a \<squnion> b \<sqinter> c)" by (simp add: sup_assoc, simp add: sup_commute)
    also have "... = (a \<sqinter> b \<squnion> c \<sqinter> a) \<squnion> (a \<sqinter> (b \<sqinter> c))" by (simp add: modular)
    also have "... = (a \<sqinter> b) \<squnion> (c \<sqinter> a)" by (rule antisym, simp_all, rule_tac y = "a \<sqinter> b" in order_trans, simp_all)
    finally show ?thesis by simp
  qed

lemma b_meet_d: "b \<sqinter> (d_aux a b c) = (b \<sqinter> c) \<squnion> (a \<sqinter> b)"
  by (simp add: a_meet_d [THEN sym] d_b_c_a)

lemma c_meet_d: "c \<sqinter> (d_aux a b c) = (c \<sqinter> a) \<squnion> (b \<sqinter> c)"
  by (simp add: a_meet_d [THEN sym] d_c_a_b)

lemma d_less_e: "no_distrib a b c \<Longrightarrow> d_aux a b c < e_aux a b c"
  apply (subst less_le)
  apply(case_tac "d_aux a b c = e_aux a b c")
  apply simp_all
  apply (simp add: no_distrib_def a_meet_e [THEN sym] a_meet_d [THEN sym])
  apply (rule_tac y = "a_aux a b c" in order_trans)
  by simp_all

lemma a_meet_b_eq_d: " d_aux a b c \<le> e_aux a b c \<Longrightarrow> a_aux a b c \<sqinter> b_aux a b c = d_aux a b c"
  proof -
    assume d_less_e: " d_aux a b c \<le> e_aux a b c"
    have "(a \<sqinter> e_aux a b c \<squnion> d_aux a b c) \<sqinter> (b \<sqinter> e_aux a b c \<squnion> d_aux a b c) = (b \<sqinter> e_aux a b c \<squnion>  d_aux a b c) \<sqinter> (d_aux a b c \<squnion> a \<sqinter> e_aux a b c)"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = d_aux a b c \<squnion> ((b \<sqinter> e_aux a b c \<squnion> d_aux a b c) \<sqinter> (a \<sqinter> e_aux a b c))"
      by (simp add: modular)
    also have "\<dots> = d_aux a b c \<squnion> (d_aux a b c \<squnion> e_aux a b c \<sqinter> b) \<sqinter> (a \<sqinter> e_aux a b c)"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = d_aux a b c \<squnion> (e_aux a b c \<sqinter> (d_aux a b c \<squnion> b)) \<sqinter> (a \<sqinter> e_aux a b c)"
      by (cut_tac d_less_e, simp add: modular [THEN sym] less_le)
    also have "\<dots> =  d_aux a b c \<squnion> ((a \<sqinter> e_aux a b c) \<sqinter> (e_aux a b c \<sqinter> (b \<squnion> d_aux a b c)))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> e_aux a b c \<sqinter> (b \<squnion> d_aux a b c))" by (simp add: inf_assoc)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> e_aux a b c \<sqinter> (b \<squnion> (c \<sqinter> a)))" by (simp add: b_join_d)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> (b \<squnion> c) \<sqinter> (b \<squnion> (c \<sqinter> a)))" by (simp add: a_meet_e)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> ((b \<squnion> c) \<sqinter> (b \<squnion> (c \<sqinter> a))))" by (simp add: inf_assoc)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> (b \<squnion> ((b \<squnion> c) \<sqinter> (c \<sqinter> a))))" by (simp add: modular)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> (b \<squnion> (c \<sqinter> a)))" by (simp add: inf_absorb2)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> ((c \<sqinter> a) \<squnion> b))" by (simp add: sup_commute inf_commute)
    also have "\<dots> = d_aux a b c \<squnion> ((c \<sqinter> a) \<squnion> (a \<sqinter> b))" by (simp add: modular)
    also have "\<dots> = d_aux a b c"
      by (rule antisym, simp_all add: d_aux_def)
    finally show ?thesis by (simp add: a_aux_def b_aux_def)
  qed

lemma b_meet_c_eq_d: " d_aux a b c \<le> e_aux a b c \<Longrightarrow> b_aux a b c \<sqinter> c_aux a b c = d_aux a b c"
  apply (subst b_a)
  apply (subgoal_tac "c_aux a b c = b_aux b c a")
  apply simp
  apply (subst a_meet_b_eq_d)
  by (simp_all add: c_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma c_meet_a_eq_d: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> c_aux a b c \<sqinter> a_aux a b c = d_aux a b c"
  apply (subst c_a)
  apply (subgoal_tac "a_aux a b c = b_aux c a b")
  apply simp
  apply (subst a_meet_b_eq_d)
  by (simp_all add: a_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma a_def_equiv: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> a_aux a b c = (a \<squnion> d_aux a b c) \<sqinter> e_aux a b c"
  apply (simp add: a_aux_def)
  apply (subst inf_commute)
  apply (subst sup_commute)
  apply (simp add: modular)
  by (simp add: inf_commute sup_commute)

lemma b_def_equiv: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> b_aux a b c = (b \<squnion> d_aux a b c) \<sqinter> e_aux a b c"
  apply (cut_tac a = b and b = c and c = a in a_def_equiv)
  by (simp_all add: d_b_c_a e_b_c_a b_a)

lemma c_def_equiv: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> c_aux a b c = (c \<squnion> d_aux a b c) \<sqinter> e_aux a b c"
  apply (cut_tac a = c and b = a and c = b in a_def_equiv)
  by (simp_all add: d_c_a_b e_c_a_b c_a)

lemma a_join_b_eq_e: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> a_aux a b c \<squnion> b_aux a b c = e_aux a b c"
  proof -
    assume d_less_e: " d_aux a b c \<le> e_aux a b c"
    have "((a \<squnion> d_aux a b c) \<sqinter> e_aux a b c) \<squnion> ((b \<squnion> d_aux a b c) \<sqinter> e_aux a b c) = ((b \<squnion> d_aux a b c) \<sqinter> e_aux a b c) \<squnion> (e_aux a b c \<sqinter> (a \<squnion> d_aux a b c))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = e_aux a b c \<sqinter> (((b \<squnion> d_aux a b c) \<sqinter> e_aux a b c) \<squnion> (a \<squnion> d_aux a b c))"
      by (simp add: modular)
    also have "\<dots> = e_aux a b c \<sqinter> ((e_aux a b c \<sqinter> (d_aux a b c \<squnion> b)) \<squnion> (a \<squnion> d_aux a b c))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = e_aux a b c \<sqinter> ((d_aux a b c \<squnion> (e_aux a b c \<sqinter> b)) \<squnion> (a \<squnion> d_aux a b c))"
      by (cut_tac d_less_e, simp add: modular)
    also have "\<dots> = e_aux a b c \<sqinter> ((a \<squnion> d_aux a b c) \<squnion> (d_aux a b c \<squnion> (b \<sqinter> e_aux a b c)))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> d_aux a b c \<squnion> (b \<sqinter> e_aux a b c))" by (simp add: sup_assoc)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> d_aux a b c \<squnion> (b \<sqinter> (c \<squnion> a)))" by (simp add: b_meet_e)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> (b \<sqinter> c) \<squnion> (b \<sqinter> (c \<squnion> a)))" by (simp add: a_join_d)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> ((b \<sqinter> c) \<squnion> (b \<sqinter> (c \<squnion> a))))" by (simp add: sup_assoc)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> (b \<sqinter> ((b \<sqinter> c) \<squnion> (c \<squnion> a))))" by (simp add: modular)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> (b \<sqinter> (c \<squnion> a)))" by (simp add: sup_absorb2)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> ((c \<squnion> a) \<sqinter> b))" by (simp add: sup_commute inf_commute)
    also have "\<dots> = e_aux a b c \<sqinter> ((c \<squnion> a) \<sqinter> (a \<squnion> b))" by (simp add: modular)
    also have "\<dots> = e_aux a b c"
      by (rule antisym, simp_all, simp_all add: e_aux_def)
    finally show ?thesis by (cut_tac d_less_e, simp add: a_def_equiv b_def_equiv)
  qed

lemma b_join_c_eq_e: " d_aux a b c <= e_aux a b c \<Longrightarrow> b_aux a b c \<squnion> c_aux a b c = e_aux a b c"
  apply (subst b_a)
  apply (subgoal_tac "c_aux a b c = b_aux b c a")
  apply simp
  apply (subst a_join_b_eq_e)
  by (simp_all add: c_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma c_join_a_eq_e: "d_aux a b c <= e_aux a b c \<Longrightarrow> c_aux a b c \<squnion> a_aux a b c = e_aux a b c"
  apply (subst c_a)
  apply (subgoal_tac "a_aux a b c = b_aux c a b")
  apply simp
  apply (subst a_join_b_eq_e)
  by (simp_all add: a_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma "no_distrib a b c \<Longrightarrow> incomp a b"
  apply (simp add: no_distrib_def incomp_def)
  apply safe
  apply (simp add: inf_absorb1)
  apply (subgoal_tac "a \<squnion> c \<sqinter> a = a \<and> a \<sqinter> (b \<squnion> c) = a")
  apply simp
  apply safe
  apply (rule antisym)
  apply simp
  apply simp
  apply (rule antisym)
  apply simp_all
  apply (rule_tac y = b in order_trans)
  apply simp_all
  apply (simp add: inf_absorb2)
  apply (unfold modular [THEN sym])
  by (simp add: inf_commute)

lemma M5_modular: "no_distrib a b c \<Longrightarrow> M5_lattice (a_aux a b c) (b_aux a b c) (c_aux a b c)"
  apply (frule d_less_e)
  by (simp add: M5_lattice_def a_meet_b_eq_d b_meet_c_eq_d c_meet_a_eq_d a_join_b_eq_e b_join_c_eq_e c_join_a_eq_e)

lemma M5_modular_def: "M5_lattice a b c = (a \<sqinter> b = b \<sqinter> c \<and> c \<sqinter> a = b \<sqinter> c \<and> a \<squnion> b = b \<squnion> c \<and> c \<squnion> a = b \<squnion> c \<and> a \<sqinter> b < a \<squnion> b)"
  by (simp add: M5_lattice_def)

end

context lattice begin

lemma not_modular_N5: "(\<not> class.modular_lattice inf ((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) op < sup) =
   (\<exists> a b c::'a . N5_lattice a b c)"
  apply (subgoal_tac "class.lattice op \<sqinter> ((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) op < sup")
  apply (unfold N5_lattice_def class.modular_lattice_def class.modular_lattice_axioms_def)
  apply simp_all
  apply safe
  apply (subgoal_tac "x \<squnion> y \<sqinter> z < y \<sqinter> (x \<squnion> z)")
  apply (rule_tac x = "x \<squnion> y \<sqinter> z" in exI)
  apply (rule_tac x = "y \<sqinter> (x \<squnion> z)" in exI)
  apply (rule_tac x = z in exI)
  apply safe
  apply (rule antisym)
  apply simp
  apply (rule_tac y = "x \<squnion> y \<sqinter> z" in order_trans)
  apply simp_all
  apply (rule_tac y = "y \<sqinter> z" in order_trans)
  apply simp_all
  apply (rule antisym)
  apply simp_all
  apply (rule_tac y = "y \<sqinter> (x \<squnion> z)" in order_trans)
  apply simp_all
  apply (rule_tac y = "x \<squnion> z" in order_trans)
  apply simp_all
  apply (rule neq_le_trans)
  apply simp
  apply simp
  apply (rule_tac x = a in exI)
  apply (rule_tac x = b in exI)
  apply safe
  apply (simp add: less_le)
  apply (rule_tac x = c in exI)
  apply simp
  apply (simp add: less_le)
  apply safe
  apply (subgoal_tac "a \<squnion> a \<sqinter> c = b")
  apply (unfold sup_inf_absorb) [1]
  apply simp
  apply simp
  proof qed

lemma not_distrib_N5_M5: "(\<not> class.distrib_lattice op \<sqinter> ((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) op < op \<squnion>) =
   ((\<exists> a b c::'a . N5_lattice a b c) \<or> (\<exists> a b c::'a . M5_lattice a b c))"
  apply (unfold not_modular_N5 [THEN sym])
  proof
    assume A: "\<not> class.distrib_lattice op \<sqinter> ((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) op < op \<squnion>"
    have B: "\<exists> a b c:: 'a . (a \<sqinter> b) \<squnion> (a \<sqinter> c) < a \<sqinter> (b \<squnion> c)"
      apply (cut_tac A)
      apply (unfold  class.distrib_lattice_def)
      apply safe
      apply simp_all
      proof
        fix x y z::'a
        assume A: "\<forall>(a\<Colon>'a) (b\<Colon>'a) c\<Colon>'a. \<not> a \<sqinter> b \<squnion> a \<sqinter> c < a \<sqinter> (b \<squnion> c)"
        show "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
          apply (cut_tac A)
          apply (rule distrib_imp1)
          by (simp add: less_le)
      qed
    from B show "\<not> class.modular_lattice op \<sqinter> ((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) op < op \<squnion> \<or> (\<exists>a b c::'a. M5_lattice a b c)"
      proof (unfold disj_not1, safe)
        fix a b c::'a
        assume A: "a \<sqinter> b \<squnion> a \<sqinter> c < a \<sqinter> (b \<squnion> c)"
        assume B: "class.modular_lattice op \<sqinter> ((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) op < op \<squnion>"
        interpret modular: modular_lattice "op \<sqinter>" "((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool)" "op <" "op \<squnion>"
          by (fact B)

        have H: "M5_lattice (a_aux a b c) (b_aux a b c) (c_aux a b c)"
          apply (cut_tac a = a and b = b and c = c in  modular.M5_modular)
          apply (unfold no_distrib_def)
          by (simp_all add: A inf_commute)
        from H show "\<exists>a b c\<Colon>'a. M5_lattice a b c" by blast
     qed
   next
     assume A: "\<not> class.modular_lattice op \<sqinter> ((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) op < op \<squnion> \<or> (\<exists>(a\<Colon>'a) (b\<Colon>'a) c\<Colon>'a. M5_lattice a b c)"
     show "\<not> class.distrib_lattice op \<sqinter> ((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) op < op \<squnion>"
       apply (cut_tac A)
       apply safe
       apply (erule notE)
       apply unfold_locales
       apply (unfold class.distrib_lattice_def)
       apply (unfold class.distrib_lattice_axioms_def)
       apply safe
       apply (simp add: sup_absorb2)
       apply (frule M5_lattice_incomp)
       apply (unfold M5_lattice_def)
       apply (drule_tac x = a in spec)
       apply (drule_tac x = b in spec)
       apply (drule_tac x = c in spec)
       apply safe
       proof -
         fix a b c:: 'a
         assume A:"a \<squnion> b \<sqinter> c = (a \<squnion> b) \<sqinter> (a \<squnion> c)"
         assume B: "a \<sqinter> b = b \<sqinter> c"
         assume D: "a \<squnion> b = b \<squnion> c"
         assume E: "c \<squnion> a = b \<squnion> c"
         assume G: "incomp a b"
         have H: "a \<squnion> b \<sqinter> c = a" by (simp add: B [THEN sym] sup_absorb1)
         have I: "(a \<squnion> b) \<sqinter> (a \<squnion> c) = a \<squnion> b" by (cut_tac E, simp add: sup_commute D)
         have J: "a = a \<squnion> b" by (cut_tac A, simp add: H I)
         show False
           apply (cut_tac G J)
           apply (subgoal_tac "b \<le> a")
           apply (simp add: incomp_def)
           apply (rule_tac y = "a \<squnion> b" in order_trans)
           apply (rule sup_ge2)
           by simp
       qed
     qed

lemma distrib_not_N5_M5: "(class.distrib_lattice op \<sqinter> ((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) op < op \<squnion>) =
   ((\<forall> a b c::'a . \<not> N5_lattice a b c) \<and> (\<forall> a b c::'a . \<not> M5_lattice a b c))"
  apply (cut_tac not_distrib_N5_M5)
  by auto

lemma distrib_inf_sup_eq:
  "(class.distrib_lattice op \<sqinter> ((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) op < op \<squnion>) =
    (\<forall> x y z::'a . x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<longrightarrow> x = y)"
  apply safe
  proof -
    fix x y z:: 'a
    assume A: "class.distrib_lattice op \<sqinter> (op \<le> ::'a \<Rightarrow> 'a \<Rightarrow> bool) op < op \<squnion>"
    interpret distrib: distrib_lattice "op \<sqinter>" "op \<le> :: 'a \<Rightarrow> 'a \<Rightarrow> bool" "op <" "op \<squnion>"
      by (fact A)
    assume B: "x \<sqinter> z = y \<sqinter> z"
    assume C: "x \<squnion> z = y \<squnion> z"
    have "x = x \<sqinter> (x \<squnion> z)" by simp
    also have "\<dots> = x \<sqinter> (y \<squnion> z)" by (simp add: C)
    also have "\<dots> = (x \<sqinter> y) \<squnion> (x \<sqinter> z)" by (simp add: distrib.inf_sup_distrib)
    also have "\<dots> = (y \<sqinter> x) \<squnion> (y \<sqinter> z)" by (simp add: B inf_commute)
    also have "\<dots> = y \<sqinter> (x \<squnion> z)" by (simp add: distrib.inf_sup_distrib)
    also have "\<dots> = y" by (simp add: C)
    finally show "x = y" .
  next
    assume A: "(\<forall>x y z:: 'a. x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<longrightarrow> x = y)"
    have B: "!! x y z :: 'a. x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<Longrightarrow> x = y"
      by (cut_tac A, blast)
    show "class.distrib_lattice op \<sqinter> ((op \<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) op < op \<squnion>"
      apply (unfold distrib_not_N5_M5)
      apply safe
      apply (unfold N5_lattice_def)
      apply (cut_tac x = a and y = b and z = c in B)
      apply (simp_all)
      apply (unfold M5_lattice_def)
      apply (cut_tac x = a and y = b and z = c in B)
      by (simp_all add: inf_commute sup_commute)
 qed
end

class inf_sup_eq_lattice = lattice +
  assumes inf_sup_eq: "x \<sqinter> z = y \<sqinter> z \<Longrightarrow> x \<squnion> z = y \<squnion> z \<Longrightarrow> x = y"
begin
subclass distrib_lattice
  by (metis distrib_inf_sup_eq inf_sup_eq)
end

end


theory Optimized
  imports Defs
begin

(* Definitions *)

definition checker_suf :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool" where
  "checker_suf x x' xs y y' ys \<longleftrightarrow> (x = x' \<and> x = y' \<and> set xs \<subseteq> {x} \<and> set ys \<subseteq> {x}) \<or>
    (x \<noteq> x' \<and> x = y' \<and> y = x' \<and> set xs \<subseteq> {y} \<and> set ys \<subseteq> {y})"

lemma [code_unfold]: "set xs \<subseteq> {y} \<longleftrightarrow> list_all (\<lambda>x. x = y) xs"
  by (induction xs) auto

fun checker_go :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "checker_go _ [] [] = False"
| "checker_go z [x] [y] = (z = x)"
| "checker_go z (x # x' # xs) (y # y' # ys) = (if x \<noteq> z then False
    else if x = y then checker_go z (x' # xs) (y' # ys)
    else checker_suf x x' xs y y' ys)"
| "checker_go _ _ _ = False"

fun checker :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "checker [] [] = True"
| "checker (x # xs) (y # ys) = checker_go x (x # xs) (y # ys)"
| "checker _ _ = False"

definition judge :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "judge xs ys \<longleftrightarrow> xs \<noteq> ys \<and> length xs = length ys \<and> checker xs ys"

(* Task *)

theorem judge_correct: "judge xs ys \<longleftrightarrow> xs \<noteq> ys \<and> length xs = length ys \<and> all_proper_subseq xs ys"
  oops

(* Solution *)

lemma subseq_empty_iff[simp]:
  "xs \<sqsubseteq> [] \<longleftrightarrow> xs = []"
  by auto

lemma set_subseq: "xs \<sqsubseteq> ys \<Longrightarrow> x \<in> set xs \<Longrightarrow> x \<in> set ys"
  using notin_set_nthsI subseq_conv_nths
  by force

lemma repl_subseq:
  assumes "set ys \<subseteq> {y}"
  shows "xs \<sqsubseteq> ys \<longleftrightarrow> length xs \<le> length ys \<and> set xs \<subseteq> {y}"
proof (rule iffI)
  show "xs \<sqsubseteq> ys \<Longrightarrow> length xs \<le> length ys \<and> set xs \<subseteq> {y}"
    using assms list_emb_length set_subseq
    by (induction ys arbitrary: xs) force+
next
  show "length xs \<le> length ys \<and> set xs \<subseteq> {y} \<Longrightarrow> xs \<sqsubseteq> ys"
    using assms
  proof (induction xs arbitrary: ys)
    case (Cons x xs)
    then show ?case
      by (cases ys) auto
  qed auto
qed

lemma all_proper_subseq_singleI:
  assumes "set xs \<subseteq> {x}" "set ys \<subseteq> {x}" "length xs \<le> Suc (length ys)"
  shows "all_proper_subseq xs ys"
  unfolding all_proper_subseq_def strict_subseq_def
  by (meson Suc_leI assms leI le_antisym order.trans repl_subseq subseq_same_length)

lemma all_proper_subseqI: "(\<And>x xs'. x # xs' \<sqsubset> xs \<Longrightarrow> x # xs' \<sqsubseteq> ys) \<Longrightarrow> all_proper_subseq xs ys"
  by (auto simp: all_proper_subseq_def) (metis list.exhaust list_emb_Nil)

lemma all_proper_subseq_set:
  assumes "x \<noteq> y" "all_proper_subseq (x # ps) (y # ps)"
  shows "set ps \<subseteq> {x}"
  using assms
proof (induction ps)
  case (Cons p ps')
  have "x # ps' \<sqsubset> x # (p # ps')"
    by (auto simp: strict_subseq_def)
  then have p_def: "p = x"
    using Cons(2,3) list.sel(1)
    by (fastforce simp: all_proper_subseq_def)
  have "all_proper_subseq (x # ps') (y # ps')"
  proof (rule all_proper_subseqI)
    fix z zs
    assume sub: "z # zs \<sqsubset> x # ps'"
    then show "z # zs \<sqsubseteq> y # ps'"
    proof (cases "z = x")
      case True
      have "x # z # zs \<sqsubset> x # p # ps'"
        using sub
        by (auto simp: p_def strict_subseq_def)
      then have "x # z # zs \<sqsubseteq> y # x # ps'"
        using Cons(3) all_proper_subseq_def p_def
        by blast
      then show ?thesis
        by (auto simp: True)
    qed (meson list_emb_Cons strict_subseq_def subseq_Cons2_neq)
  qed
  then show ?case
    using p_def Cons
    by auto
qed auto

lemma all_proper_subseq_set':
  assumes "length xs = length ys" "x \<noteq> y" "all_proper_subseq (xs @ x # ps) (ys @ y # ps)"
  shows "set ps \<subseteq> {x}"
  using assms
proof (induction xs ys rule: list_induct2)
  case Nil
  then show ?case
    using all_proper_subseq_set
    by fastforce
next
  case (Cons z zs w ws)
  have "all_proper_subseq (zs @ x # ps) (ws @ y # ps)"
  proof (rule all_proper_subseqI)
    fix t ts
    assume "t # ts \<sqsubset> zs @ x # ps"
    then have "z # t # ts \<sqsubseteq> (w # ws) @ y # ps"
      using Cons(4)
      by (auto simp: all_proper_subseq_def strict_subseq_def)
    then show "t # ts \<sqsubseteq> ws @ y # ps"
      by (auto simp add: subseq_Cons' split: if_splits)
  qed
  then show ?case
    using Cons
    by auto
qed

lemma all_proper_subseq_Cons_eq:
  assumes "length xs = length ys" "x \<noteq> y" "all_proper_subseq (x # x' # xs) (y # y' # ys)"
  shows "y' # ys = x # xs"
proof -
  have "x # xs \<sqsubset> x # x' # xs"
    by (auto simp: strict_subseq_def)
  then have "x # xs \<sqsubseteq> y # y' # ys"
    using assms(2,3) subseq_Cons2_neq
    by (fastforce simp: all_proper_subseq_def)
  then show "y' # ys = x # xs"
    using assms(1,2) subseq_Cons2_neq subseq_same_length
    by fastforce
qed

lemma all_proper_subseq_eqD:
  assumes "x \<noteq> y" "all_proper_subseq (x # x # xs) (y # x # xs)"
  shows "set xs \<subseteq> {x}"
  using all_proper_subseq_set assms
  by fastforce

lemma all_proper_subseq_eq:
  assumes "length xs = length ys" "x \<noteq> y" "all_proper_subseq (x # x # xs) (y # y' # ys)"
  shows "x = y' \<and> set xs \<subseteq> {x} \<and> set ys \<subseteq> {x}"
proof -
  note y'_ys_def = all_proper_subseq_Cons_eq[OF assms]
  show ?thesis
    using all_proper_subseq_eqD[OF assms(2) assms(3)[unfolded y'_ys_def]] y'_ys_def
    by auto
qed

lemma checker_suf_eqD:
  assumes "length xs = length ys" "x \<noteq> y" "x = y'" "set xs \<subseteq> {x}" "set ys \<subseteq> {x}"
  shows "all_proper_subseq (x # x # xs) (y # y' # ys)"
proof -
  have ys_def: "ys = xs"
    using assms(1,4,5)
    by (induction xs ys rule: list_induct2) auto
  have "all_proper_subseq (x # x # xs) (y' # ys)"
    apply (rule all_proper_subseq_singleI)
    using assms(4)
    by (auto simp: assms(3) ys_def all_proper_subseq_def)
  then show ?thesis
    by (auto simp: all_proper_subseq_def)
qed

lemma all_proper_subseq_neqD:
  assumes "x \<noteq> y" "all_proper_subseq (x # x' # xs) (y # x # xs)" "x \<noteq> x'"
  shows "set xs \<subseteq> {x'}"
  using all_proper_subseq_set'[OF _ assms(3)[symmetric], of "[x]" "[y]" xs] assms
  by auto

lemma all_proper_subseq_neq:
  assumes "length xs = length ys" "x \<noteq> y" "all_proper_subseq (x # x' # xs) (y # y' # ys)" "x \<noteq> x'"
  shows "x = y' \<and> y = x' \<and> set xs \<subseteq> {y} \<and> set ys \<subseteq> {y}"
proof -
  note y'_ys_def = all_proper_subseq_Cons_eq[OF assms(1,2,3)]
  then have y'_def: "y' = x"
    by auto
  have "x' # xs \<sqsubset> x # x' # xs"
    by (auto simp: strict_subseq_def)
  then have y_def: "y = x'"
    using assms(3,4) subseq_Cons2_neq
    by (fastforce simp: y'_ys_def all_proper_subseq_def)
  have ys_def: "ys = xs"
    using y'_ys_def
    by auto
  show ?thesis
    using all_proper_subseq_neqD[OF assms(2) assms(3)[unfolded y'_ys_def] assms(4)]
    by (auto simp: y'_def y_def ys_def)
qed

lemma all_proper_subseq_singleI':
  assumes "set xs \<subseteq> {x'}"
  shows "all_proper_subseq (x # x' # xs) (x' # x # xs)"
proof (rule all_proper_subseqI)
  fix z zs
  assume sub: "z # zs \<sqsubset> x # x' # xs"
  show "z # zs \<sqsubseteq> x' # x # xs"
  proof (cases "z = x")
    case True
    have "zs \<sqsubseteq> xs"
      using sub repl_subseq[of "x' # xs"] assms
      by (auto simp: True strict_subseq_def repl_subseq[OF assms])
         (metis le_SucE length_Cons subseq_same_length)
    then show ?thesis
      by (auto simp: True)
  next
    case False
    then have "z # zs \<sqsubseteq> x' # xs"
      using sub
      by (auto simp: strict_subseq_def)
    then show ?thesis
      by (metis list_emb_Cons subseq_Cons2 subseq_Cons2' subseq_Cons2_neq)
  qed
qed

lemma checker_suf_neqD:
  assumes "length xs = length ys" "x \<noteq> y" "x \<noteq> x'" "set xs \<subseteq> {x'}" "set ys \<subseteq> {x'}"
  shows "all_proper_subseq (x # x' # xs) (x' # x # ys)"
proof -
  have ys_def: "ys = xs"
    using assms(1,4,5)
    by (induction xs ys rule: list_induct2) auto
  show "all_proper_subseq (x # x' # xs) (x' # x # ys)"
    unfolding ys_def
    by (rule all_proper_subseq_singleI'[OF assms(4)])
qed

lemma all_proper_subseq_ext:
  assumes "all_proper_subseq (x # xs') (y # ys')" "set ps \<subseteq> {x}"
  shows "all_proper_subseq (ps @ x # xs') (ps @ y # ys')"
proof -
  {
    fix zs
    assume sub: "zs \<sqsubset> ps @ x # xs'"
    then obtain ws ws' where split: "zs = ws @ ws'" "ws \<sqsubseteq> ps" "ws' \<sqsubseteq> x # xs'"
      using subseq_appendE[of zs ps "x # xs'"]
      by (auto simp: strict_subseq_def)
    then have "zs \<sqsubseteq> ps @ y # ys'"
      using assms(1)
    proof (cases "ws' = x # xs'")
      case True
      have "xs' \<sqsubseteq> y # ys'"
        using assms(1)
        by (auto simp: all_proper_subseq_def strict_subseq_def list_emb_Cons)
      moreover have "ws @ [x] \<sqsubseteq> ps"
        using sub
        by (auto simp: split(1) True strict_subseq_def repl_subseq[OF assms(2)])
           (meson assms(2) eq_iff not_less_eq_eq repl_subseq subseq_same_length)
      ultimately show ?thesis
        by (auto simp: split(1) True)
           (metis append.assoc append_Cons append_Nil list_emb_append_mono)
    qed (auto simp: split(1) all_proper_subseq_def strict_subseq_def list_emb_append_mono)
  }
  then show ?thesis
    by (auto simp: all_proper_subseq_def)
qed

lemma all_proper_subseq_cut:
  "all_proper_subseq (ps @ xs) (ps @ ys) \<Longrightarrow> all_proper_subseq xs ys"
  using subseq_append'
  by (auto simp: all_proper_subseq_def strict_subseq_def)

lemma subseq_rev: "xs \<sqsubseteq> ys \<Longrightarrow> rev xs \<sqsubseteq> rev ys"
  by (induction xs ys rule: list_emb.induct) auto

lemma all_proper_subseq_rev: "all_proper_subseq xs ys \<Longrightarrow> all_proper_subseq (rev xs) (rev ys)"
  by (auto simp: all_proper_subseq_def strict_subseq_def) (metis rev_swap subseq_rev)

lemma judge_correct_aux:
  assumes "xs \<noteq> ys" "length xs = length ys"
  shows "judge xs ys \<longleftrightarrow> all_proper_subseq xs ys"
proof -
  obtain ps x y xs' ys' where ps_def: "xs = ps @ x # xs'" "ys = ps @ y # ys'" "x \<noteq> y"
    using same_length_different[OF assms]
    by auto
  have len_xs'_ys': "length xs' = length ys'"
    using assms(2)
    by (auto simp: ps_def(1,2))
  show ?thesis
  proof (rule iffI)
    assume j: "judge xs ys"
    then have checker: "set ps \<subseteq> {x} \<and> checker_go x (x # xs') (y # ys')"
    proof (cases ps)
      case (Cons p ps')
      have checker: "checker_go p (ps @ x # xs') (ps @ y # ys')"
        using j
        by (auto simp: judge_def ps_def(1,2) Cons)
      have "checker_go p (x # xs') (y # ys') \<Longrightarrow> p = x"
        by (cases xs'; cases ys') (auto split: if_splits)
      then have "p = x"
        using checker
        by (induction ps rule: induct_list012) (auto split: if_splits)
      then show ?thesis
        using checker ps_def(3)
        by (induction ps rule: induct_list012) (auto split: if_splits)
    qed (auto simp: Nil judge_def ps_def(1,2))
    show "all_proper_subseq xs ys"
    proof (cases xs')
      case Nil
      have ys'_def: "ys' = []"
        using assms(2)
        by (auto simp: ps_def(1,2) Nil)
      have "all_proper_subseq (ps @ [x]) ps"
        apply (rule all_proper_subseq_singleI)
        using checker
        by auto
      then show ?thesis
        by (auto simp: ps_def(1,2) Nil ys'_def all_proper_subseq_def)
    next
      case (Cons x' xs'')
      obtain y' ys'' where ys'_def: "ys' = y' # ys''"
        using assms(2)
        by (cases ys') (auto simp: ps_def(1,2) Cons)
      have lens: "length xs'' = length ys''"
        using assms(2)
        by (auto simp: ps_def(1,2) Cons ys'_def)
      have "checker_suf x x' xs'' y y' ys''"
        using checker ps_def(3)
        by (auto simp: Cons ys'_def)
      then have "all_proper_subseq (x # x' # xs'') (y # y' # ys'')"
        using checker_suf_eqD[OF lens ps_def(3)] checker_suf_neqD[OF lens ps_def(3)]
        by (auto simp: checker_suf_def)
      then show ?thesis
        using all_proper_subseq_ext[OF _ conjunct1[OF checker]]
        by (auto simp: ps_def(1,2) Cons ys'_def)
    qed
  next
    assume all: "all_proper_subseq xs ys"
    have checker_go: "checker_go x (x # xs') (y # ys')"
      using assms(2)
    proof (cases xs')
      case (Cons x' xs'')
      obtain y' ys'' where ys'_def: "ys' = y' # ys''"
        using assms(2)
        by (cases ys') (auto simp: ps_def(1,2) Cons)
      have lens: "length xs'' = length ys''"
        using assms(2)
        by (auto simp: ps_def(1,2) Cons ys'_def)
      have all': "all_proper_subseq (x # x' # xs'') (y # y' # ys'')"
        using all_proper_subseq_cut all
        by (auto simp: ps_def(1,2) Cons ys'_def)
      have "checker_suf x x' xs'' y y' ys''"
        using all_proper_subseq_eq[OF lens ps_def(3)] all_proper_subseq_neq[OF lens ps_def(3)] all'
        by (cases "x = x'") (auto simp: checker_suf_def)
      then show ?thesis
        using ps_def(3)
        by (auto simp: Cons ys'_def)
    qed (auto simp: ps_def(1,2) Nil)
    have set_ps: "set ps \<subseteq> {x}"
      using all_proper_subseq_set'[OF _ ps_def(3), of "rev xs'" "rev ys'" "rev ps"]
        all_proper_subseq_rev len_xs'_ys' all
      by (fastforce simp: ps_def(1,2))
    have "checker xs ys"
      using checker_go
    proof (cases ps)
      case (Cons p ps')
      have p_def: "p = x"
        using set_ps
        by (auto simp: Cons)
      have "checker_go p xs ys"
        using checker_go set_ps
        unfolding ps_def(1,2) p_def
        by (induction ps rule: induct_list012) auto
      then show ?thesis
        by (auto simp: ps_def(1,2) Cons)
    qed (auto simp: ps_def(1,2))
    then show "judge xs ys"
      using assms
      by (auto simp: judge_def)
  qed
qed

theorem judge_correct: "judge xs ys \<longleftrightarrow> xs \<noteq> ys \<and> length xs = length ys \<and> all_proper_subseq xs ys"
  using judge_correct_aux
  by (auto simp: judge_def)

definition judge_string :: "string \<Rightarrow> string \<Rightarrow> bool" where
  "judge_string = judge"

export_code judge_string String.explode in OCaml module_name Judge file_prefix optimized

end


section\<open>List Product Helpers\<close>
theory List_Product_More
imports Main
begin

(*TODO: this definition could also go to Main*)
lemma List_product_concat_map: "List.product xs ys = concat (map (\<lambda>x. map (\<lambda>y. (x,y)) ys) xs)"
  by(induction xs) (simp)+

definition all_pairs :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
  "all_pairs xs \<equiv> concat (map (\<lambda>x. map (\<lambda>y. (x,y)) xs) xs)"

lemma all_pairs_list_product: "all_pairs xs = List.product xs xs"
  by(simp add: all_pairs_def List_product_concat_map)

lemma all_pairs: "\<forall> (x,y) \<in> (set xs \<times> set xs). (x,y) \<in> set (all_pairs xs)"
  by(simp add: all_pairs_list_product)

lemma all_pairs_set: "set (all_pairs xs) = set xs \<times> set xs"
  by(simp add: all_pairs_list_product)

end


(*  Title:      CTT/ex/Equality.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section "Equality reasoning by rewriting"

theory Equality
imports "../CTT"
begin

lemma split_eq: "p : Sum(A,B) \<Longrightarrow> split(p,pair) = p : Sum(A,B)"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply rew
done

lemma when_eq: "\<lbrakk>A type; B type; p : A+B\<rbrakk> \<Longrightarrow> when(p,inl,inr) = p : A + B"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply rew
done

(*in the "rec" formulation of addition, 0+n=n *)
lemma "p:N \<Longrightarrow> rec(p,0, \<lambda>y z. succ(y)) = p : N"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply rew
done

(*the harder version, n+0=n: recursive, uses induction hypothesis*)
lemma "p:N \<Longrightarrow> rec(p,0, \<lambda>y z. succ(z)) = p : N"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply hyp_rew
done

(*Associativity of addition*)
lemma "\<lbrakk>a:N; b:N; c:N\<rbrakk>
  \<Longrightarrow> rec(rec(a, b, \<lambda>x y. succ(y)), c, \<lambda>x y. succ(y)) =
    rec(a, rec(b, c, \<lambda>x y. succ(y)), \<lambda>x y. succ(y)) : N"
apply (NE a)
apply hyp_rew
done

(*Martin-Löf (1984) page 62: pairing is surjective*)
lemma "p : Sum(A,B) \<Longrightarrow> <split(p,\<lambda>x y. x), split(p,\<lambda>x y. y)> = p : Sum(A,B)"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply (tactic \<open>DEPTH_SOLVE_1 (rew_tac \<^context> [])\<close>) (*!!!!!!!*)
done

lemma "\<lbrakk>a : A; b : B\<rbrakk> \<Longrightarrow> (\<^bold>\<lambda>u. split(u, \<lambda>v w.<w,v>)) ` <a,b> = <b,a> : \<Sum>x:B. A"
apply rew
done

(*a contrived, complicated simplication, requires sum-elimination also*)
lemma "(\<^bold>\<lambda>f. \<^bold>\<lambda>x. f`(f`x)) ` (\<^bold>\<lambda>u. split(u, \<lambda>v w.<w,v>)) =
      \<^bold>\<lambda>x. x  :  \<Prod>x:(\<Sum>y:N. N). (\<Sum>y:N. N)"
apply (rule reduction_rls)
apply (rule_tac [3] intrL_rls)
apply (rule_tac [4] EqE)
apply (erule_tac [4] SumE)
(*order of unifiers is essential here*)
apply rew
done

end


theory Chapter08_2_Typechecking
imports Chapter08_1_Language
begin

inductive typecheck :: "type env => expr => type => bool"
where tc_var [simp]: "lookup gam x = Some t ==> typecheck gam (Var x) t"
    | tc_str [simp]: "typecheck gam (Str s) StrType"
    | tc_num [simp]: "typecheck gam (Num n) NumType"
    | tc_plus [simp]: "typecheck gam e1 NumType ==> typecheck gam e2 NumType ==>
                    typecheck gam (Plus e1 e2) NumType"
    | tc_times [simp]: "typecheck gam e1 NumType ==> typecheck gam e2 NumType ==>
                    typecheck gam (Times e1 e2) NumType"
    | tc_cat [simp]: "typecheck gam e1 StrType ==> typecheck gam e2 StrType ==>
                    typecheck gam (Cat e1 e2) StrType"
    | tc_len [simp]: "typecheck gam e StrType ==> typecheck gam (Len e) NumType"
    | tc_let [simp]: "typecheck gam e1 t1 ==> typecheck (extend gam t1) e2 t2 ==>
                    typecheck gam (Let e1 e2) t2"
    | tc_lam [simp]: "typecheck (extend gam t1) e t2 ==> typecheck gam (Lam t1 e) (Arrow t1 t2)"
    | tc_appl [simp]: "typecheck gam e1 (Arrow t2 t) ==> typecheck gam e2 t2 ==>
                    typecheck gam (Appl e1 e2) t"

inductive_cases [elim!]: "typecheck gam (Var x) t"
inductive_cases [elim!]: "typecheck gam (Str s) t"
inductive_cases [elim!]: "typecheck gam (Num n) t"
inductive_cases [elim!]: "typecheck gam (Plus e1 e2) t"
inductive_cases [elim!]: "typecheck gam (Times e1 e2) t"
inductive_cases [elim!]: "typecheck gam (Cat e1 e2) t"
inductive_cases [elim!]: "typecheck gam (Len e) t"
inductive_cases [elim!]: "typecheck gam (Let e1 e2) t"
inductive_cases [elim!]: "typecheck gam (Lam t1 e) t"
inductive_cases [elim!]: "typecheck gam (Appl e1 e2) t"

lemma [simp]: "typecheck (extend_at n gam t') e t ==> n in gam ==> typecheck gam e' t' ==>
                          typecheck gam (subst e' n e) t"
by (induction "extend_at n gam t'" e t arbitrary: n gam t' e' rule: typecheck.induct, fastforce+)

end


(*
Title: Strong-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Strongly_Secure_Skip_Assign
imports MWLf Parallel_Composition
begin

locale Strongly_Secure_Programs =
L : MWLf_semantics "E" "BMap"
+ SS: Strong_Security "MWLfSteps_det" "DA"
for E :: "('exp, 'id, 'val) Evalfunction"
and BMap :: "'val \<Rightarrow> bool"
and DA :: "('id, 'd::order) DomainAssignment"
begin

abbreviation USdBname ::"'d \<Rightarrow> ('exp, 'id) MWLfCom Bisimulation_type"
("\<approx>\<^bsub>_\<^esub>")
where "\<approx>\<^bsub>d\<^esub> \<equiv> USdB d"

abbreviation relatedbyUSdB :: "('exp,'id) MWLfCom list \<Rightarrow> 'd
  \<Rightarrow> ('exp,'id) MWLfCom list \<Rightarrow> bool" (infixr "\<approx>\<^bsub>_\<^esub>" 65)
where "V \<approx>\<^bsub>d\<^esub> V' \<equiv> (V,V') \<in> USdB d"

-- "define when two expressions are indistinguishable with respect to a domain d"
definition d_indistinguishable :: "'d::order \<Rightarrow> 'exp \<Rightarrow> 'exp \<Rightarrow> bool"
where
"d_indistinguishable d e1 e2 \<equiv>
  \<forall>m m'. ((m =\<^bsub>d\<^esub> m') \<longrightarrow> ((E e1 m) = (E e2 m')))"

abbreviation d_indistinguishable' :: "'exp \<Rightarrow> 'd::order \<Rightarrow> 'exp \<Rightarrow> bool"
( "(_ \<equiv>\<^bsub>_\<^esub> _)" )
where
"e1 \<equiv>\<^bsub>d\<^esub> e2 \<equiv> d_indistinguishable d e1 e2"

-- "symmetry of d-indistinguishable"
lemma d_indistinguishable_sym:
"e \<equiv>\<^bsub>d\<^esub> e' \<Longrightarrow> e' \<equiv>\<^bsub>d\<^esub> e"
by (simp add: d_indistinguishable_def d_equal_def, metis)

--"transitivity of d-indistinguishable"
lemma d_indistinguishable_trans:
"\<lbrakk> e \<equiv>\<^bsub>d\<^esub> e'; e' \<equiv>\<^bsub>d\<^esub> e'' \<rbrakk> \<Longrightarrow> e \<equiv>\<^bsub>d\<^esub> e''"
by (simp add: d_indistinguishable_def d_equal_def, metis)

theorem Strongly_Secure_Skip:
"[skip] \<approx>\<^bsub>d\<^esub> [skip]"
proof -
  def R0 \<equiv> "{(V::('exp,'id) MWLfCom list,V'::('exp,'id) MWLfCom list).
    V = [skip] \<and> V' = [skip]}"

  have uptoR0: "d_Bisimulation_Up_To_USdB d R0"
    proof (simp add: d_Bisimulation_Up_To_USdB_def, auto)
      show "sym R0" by (simp add: R0_def sym_def)
    next
      fix V V'
      assume "(V,V') \<in> R0"
      thus "length V = length V'"
        by (simp add: R0_def)
    next
      fix V V' i m1 m1' W m2
      assume inR0: "(V,V') \<in> R0"
      assume irange: "i < length V"
      assume step: "\<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle>"
      assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

      from inR0 have Vassump:
        "V = [skip] \<and> V' = [skip]"
        by (simp add: R0_def)

      with step irange have step1:
        "W = [] \<and> m2 = m1"
        by (simp, metis MWLf_semantics.MWLfSteps_det_cases(1))

      from Vassump irange obtain m2' where step2:
        "\<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>[],m2'\<rangle> \<and> m2' = m1'"
         by (simp, metis MWLfSteps_det.skip)

      with step1 dequal trivialpair_in_USdB show "\<exists>W' m2'.
        \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and>
        ((W,W') \<in> R0 \<or> W \<approx>\<^bsub>d\<^esub> W') \<and> m2 =\<^bsub>d\<^esub> m2'"
        by auto
   qed

   hence "R0 \<subseteq> (\<approx>\<^bsub>d\<^esub>)"
     by (rule Up_To_Technique)

   thus ?thesis
     by (simp add: R0_def)

qed

theorem Strongly_Secure_Assign:
  assumes d_indistinguishable_exp: "e \<equiv>\<^bsub>DA x\<^esub> e'"
  shows "[x := e] \<approx>\<^bsub>d\<^esub> [x := e']"
proof -
  def R0 \<equiv> "{(V,V'). \<exists>x e e'. V = [x := e] \<and> V' = [x := e'] \<and>
    e \<equiv>\<^bsub>DA x\<^esub> e'}"

  from d_indistinguishable_exp have inR0: "([x:=e],[x:=e']) \<in> R0"
    by (simp add: R0_def)

  have "d_Bisimulation_Up_To_USdB d R0"
    proof (simp add: d_Bisimulation_Up_To_USdB_def, auto)
      from d_indistinguishable_sym show "sym R0"
        by (simp add: R0_def sym_def, fastforce)
    next
      fix V V'
      assume "(V,V') \<in> R0"
      thus "length V = length V'"
        by (simp add: R0_def, auto)
    next
      fix V V' i m1 m1' W m2
      assume inR0: "(V,V') \<in> R0"
      assume irange: "i < length V"
      assume step: "\<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle>"
      assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

      from inR0 obtain x e e' where Vassump:
        "V = [x := e] \<and> V' = [x := e'] \<and>
        e \<equiv>\<^bsub>DA x\<^esub> e'"
        by (simp add: R0_def, auto)

      with step irange obtain v where step1:
        "E e m1 = v \<and> W = [] \<and> m2 = m1(x := v)"
        by (auto, metis MWLf_semantics.MWLfSteps_det_cases(2))

      from Vassump irange obtain m2' v' where step2:
        "E e' m1' = v' \<and> \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>[],m2'\<rangle> \<and> m2' = m1'(x := v')"
        by (auto, metis MWLfSteps_det.assign)

      with Vassump dequal step step1
      have dequalnext: "m1(x := v) =\<^bsub>d\<^esub> m1'(x := v')"
        by (simp add: d_equal_def d_indistinguishable_def, auto)

      with step1 step2 trivialpair_in_USdB show "\<exists>W' m2'.
        \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and> ((W,W') \<in> R0 \<or> W \<approx>\<^bsub>d\<^esub> W')
        \<and> m2 =\<^bsub>d\<^esub> m2'"
        by auto
   qed

   hence "R0 \<subseteq> (\<approx>\<^bsub>d\<^esub>)"
     by (rule Up_To_Technique)

   with inR0 show ?thesis
     by auto

qed

end

end


(*  Title:       Executable Matrix Operations on Matrices of Arbitrary Dimensions
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

(*
Copyright 2010 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

header {* Basic Operations on Matrices *}

theory Matrix_Arith
imports
  Utility
  Ordered_Semiring
begin

text {*
  This theory provides the operations of matrix addition, multiplication,
  and transposition as executable functions.
  Most properties are proven via pointwise equality of matrices.
*}

subsection {* types and well-formedness of vectors / matrices *}

type_synonym 'a vec = "'a list"
type_synonym 'a mat = "'a vec list" (* list of column-vectors *)

(* vector of given length *)
definition vec :: "nat \<Rightarrow> 'x vec \<Rightarrow> bool"
 where "vec n x = (length x = n)"

(* matrix of given number of rows and columns *)
definition mat :: "nat \<Rightarrow> nat \<Rightarrow> 'a mat \<Rightarrow> bool" where
 "mat nr nc m = (length m = nc \<and> Ball (set m) (vec nr))"

subsection {* definitions / algorithms *}

text {* note that these algorithms are generic in all basic definitions / operations
like 0 (ze) 1 (on) addition (pl) multiplication (ti) and in the dimension(s) of the matrix/vector.
Hence, many of these algorithms require these definitions/operations/sizes as arguments.
All indices start from 0.
*}

(* the 0 vector *)
definition vec0I :: "'a \<Rightarrow> nat \<Rightarrow> 'a vec" where
 "vec0I ze n = replicate n ze"

(* the 0 matrix *)
definition mat0I :: "'a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mat" where
  "mat0I ze nr nc = replicate nc (vec0I ze nr)"

(* the i-th unit vector of size n *)
definition vec1I :: "'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a vec"
  where "vec1I ze on n i \<equiv> replicate i ze @ on # replicate (n - 1 - i) ze"

(* the 1 matrix *)
definition mat1I :: "'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a mat"
  where "mat1I ze on n \<equiv> map (vec1I ze on n) [0 ..< n]"

(* vector addition *)
definition vec_plusI :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a vec \<Rightarrow> 'a vec \<Rightarrow> 'a vec" where
 "vec_plusI pl v w = map (\<lambda> xy. pl (fst xy) (snd xy)) (zip v w)"

(* matrix addition *)
definition mat_plusI :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat"
 where "mat_plusI pl m1 m2 = map (\<lambda> uv. vec_plusI pl (fst uv) (snd uv)) (zip m1 m2)"

(* scalar product *)
definition scalar_prodI :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a vec \<Rightarrow> 'a vec \<Rightarrow> 'a" where
 "scalar_prodI ze pl ti v w = foldr (\<lambda> (x,y) s. pl (ti x y) s) (zip v w) ze"

(* the m-th row of a matrix *)
definition row :: "'a mat \<Rightarrow> nat \<Rightarrow> 'a vec"
where "row m i \<equiv> map (\<lambda> w. w ! i) m"

(* the m-th column of a matrix *)
definition col :: "'a mat \<Rightarrow> nat \<Rightarrow> 'a vec"
where "col m i \<equiv> m ! i"

(* transposition of a matrix (number of rows of matrix has to be given since otherwise one
   could not compute transpose [] which might be [] or [[]] or [[], []], or ...) *)
fun transpose :: "nat \<Rightarrow> 'a mat \<Rightarrow> 'a mat"
 where "transpose nr [] = replicate nr []"
     | "transpose nr (v # m) = map (\<lambda> (vi,mi). (vi # mi)) (zip v (transpose nr m))"

(* matrix-vector multiplication, assumes the transposed matrix is given *)
definition matT_vec_multI :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a mat \<Rightarrow> 'a vec \<Rightarrow> 'a vec"
 where "matT_vec_multI ze pl ti m v = map (\<lambda> w. scalar_prodI ze pl ti w v) m"

(* matrix-matrix multiplication, number of rows of left matrix has to be given (as transpose is used) *)
definition mat_multI :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat"
where "mat_multI ze pl ti nr m1 m2 \<equiv> map (matT_vec_multI ze pl ti (transpose nr m1)) m2"

(* power of a square matrix *)
fun mat_powI :: "'a \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a mat \<Rightarrow> nat \<Rightarrow> 'a mat"
  where "mat_powI ze on pl ti n m 0 = mat1I ze on n"
      | "mat_powI ze on pl ti n m (Suc i) = mat_multI ze pl ti n (mat_powI ze on pl ti n m i) m"

definition sub_vec :: "nat \<Rightarrow> 'a vec \<Rightarrow> 'a vec"
where "sub_vec = take"

(* taking only the upper left sub matrix *)
definition sub_mat :: "nat \<Rightarrow> nat \<Rightarrow> 'a mat \<Rightarrow> 'a mat"
where "sub_mat nr nc m = map (sub_vec nr) (take nc m)"

(* map on vectors *)
definition vec_map :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a vec \<Rightarrow> 'a vec"
  where "vec_map = map"

(* map on matrices *)
definition mat_map :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a mat \<Rightarrow> 'a mat"
  where "mat_map f = map (vec_map f)"

subsection {* algorithms preserve dimensions *}

lemma vec0[simp,intro]: "vec nr (vec0I ze nr)"
  by (simp add: vec_def vec0I_def)

lemma replicate_prop:
  assumes "P x"
  shows "\<forall>y\<in>set (replicate n x). P y"
  using assms by (induct n) simp_all

lemma mat0[simp,intro]: "mat nr nc (mat0I ze nr nc)"
unfolding mat_def mat0I_def
using replicate_prop[of "vec nr" "vec0I ze nr" "nc"] by simp

lemma vec1[simp,intro]: assumes "i < nr" shows "vec nr (vec1I ze on nr i)"
unfolding vec_def vec1I_def using assms by auto

lemma mat1[simp,intro]: "mat nr nr (mat1I ze on nr)"
unfolding mat_def mat1I_def using vec1 by auto

lemma vec_plus[simp,intro]: "\<lbrakk>vec nr u; vec nr v\<rbrakk> \<Longrightarrow> vec nr (vec_plusI pl u v)"
using assms
unfolding vec_plusI_def vec_def
by auto

lemma mat_plus[simp,intro]: assumes "mat nr nc m1" and "mat nr nc m2" shows "mat nr nc (mat_plusI pl m1 m2)"
using assms
unfolding mat_def mat_plusI_def
proof (simp, induct nc arbitrary: m1 m2, simp)
  case (Suc nn)
  show ?case
  proof (cases m1)
    case Nil with Suc show ?thesis by auto
  next
    case (Cons v1 mm1) note oCons = this
    with Suc have l1: "length mm1 = nn" by auto
    show ?thesis
    proof (cases m2)
      case Nil with Suc show ?thesis by auto
    next
      case (Cons v2 mm2)
      with Suc have l2: "length mm2 = nn" by auto
      show ?thesis by (simp add: Cons oCons, intro conjI[OF vec_plus], (simp add: Cons oCons Suc)+, rule Suc, auto simp: Cons oCons Suc l1 l2)
    qed
  qed
qed

lemma vec_map[simp,intro]: "vec nr u \<Longrightarrow> vec nr (vec_map f u)"
using assms
unfolding vec_map_def vec_def
by auto

lemma mat_map[simp,intro]: "mat nr nc m \<Longrightarrow> mat nr nc (mat_map f m)"
using assms vec_map
unfolding mat_map_def mat_def
by auto

fun vec_fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a vec \<Rightarrow> 'b \<Rightarrow> 'b"
  where [code_unfold]: "vec_fold f = foldr f"

fun mat_fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a mat \<Rightarrow> 'b \<Rightarrow> 'b"
  where [code_unfold]: "mat_fold f = foldr (vec_fold f)"

lemma concat_mat: "mat nr nc m \<Longrightarrow>
  concat m = [ m ! i ! j. i \<leftarrow> [0 ..< nc], j \<leftarrow> [0 ..< nr] ]"
proof (induct m arbitrary: nc)
  case Nil
  thus ?case unfolding mat_def by auto
next
  case (Cons v m snc)
  from Cons(2) obtain nc where snc: "snc = Suc nc" and mat: "mat nr nc m" and v: "vec nr v"
    unfolding mat_def by (cases snc, auto)
  from v have nr: "nr = length v" unfolding vec_def by auto
  have v: "map (\<lambda> i. v ! i) [0 ..< nr] = v" unfolding nr map_nth by simp
  note IH = Cons(1)[OF mat]
  show ?case
    unfolding snc
    unfolding map_upt_Suc
    unfolding nth.simps nat.simps concat.simps
    unfolding IH v ..
qed

lemma row: assumes "mat nr nc m"
  and "i < nr"
  shows "vec nc (row m i)"
  using assms
  unfolding vec_def row_def mat_def
  by (auto simp: vec_def)

lemma col: assumes "mat nr nc m"
  and "i < nc"
  shows "vec nr (col m i)"
  using assms
  unfolding vec_def col_def mat_def
  by (auto simp: vec_def)

lemma transpose[simp,intro]: assumes "mat nr nc m"
  shows "mat nc nr (transpose nr m)"
using assms
proof (induct m arbitrary: nc)
  case (Cons v m)
  from `mat nr nc (v # m)` obtain ncc where nc: "nc = Suc ncc" by (cases nc, auto simp: mat_def)
  with Cons have wfRec: "mat ncc nr (transpose nr m)" unfolding mat_def by auto
  have "min nr (length (transpose nr m)) = nr" using wfRec unfolding mat_def by auto
  moreover have "Ball (set (transpose nr (v # m))) (vec nc)"
  proof -
    {
      fix a b
      assume mem: "(a,b) \<in> set (zip v (transpose nr m))"
      from mem have "b \<in> set (transpose nr m)" by (rule set_zip_rightD)
      with wfRec have "length b = ncc" unfolding mat_def using vec_def[of ncc] by auto
      hence "length (split op # (a,b)) = Suc ncc" by auto
    }
    thus ?thesis
      by (auto simp: vec_def nc)
  qed
  moreover from `mat nr nc (v # m)` have wfV: "length v = nr" unfolding mat_def by (simp add: vec_def)
  ultimately
  show ?case unfolding mat_def
    by (intro conjI, auto simp: wfV wfRec mat_def vec_def)
qed (simp add: mat_def vec_def set_replicate_conv_if)

lemma matT_vec_multI: assumes "mat nr nc m"
  shows "vec nc (matT_vec_multI ze pl ti m v)"
  unfolding matT_vec_multI_def
  using assms
  unfolding mat_def
  by (simp add: vec_def)

lemma mat_mult[simp,intro]: assumes wf1: "mat nr n m1"
  and wf2: "mat n nc m2"
  shows "mat nr nc (mat_multI ze pl ti nr m1 m2)"
using assms
unfolding mat_def mat_multI_def by (auto simp: matT_vec_multI[OF transpose[OF wf1]])

lemma mat_pow[simp,intro]: assumes "mat n n m"
  shows "mat n n (mat_powI ze on pl ti n m i)"
proof (induct i)
  case 0
  show ?case unfolding mat_powI.simps by (rule mat1)
next
  case (Suc i)
  show ?case unfolding mat_powI.simps
    by (rule mat_mult[OF Suc assms])
qed

lemma sub_vec[simp,intro]: assumes "vec nr v" and "sd \<le> nr"
  shows "vec sd (sub_vec sd v)"
using assms unfolding vec_def sub_vec_def by auto

lemma sub_mat[simp,intro]: assumes wf: "mat nr nc m" and sr: "sr \<le> nr" and sc: "sc \<le> nc"
  shows "mat sr sc (sub_mat sr sc m)"
using assms in_set_takeD[of _ sc m] sub_vec[OF _ sr] unfolding mat_def sub_mat_def by auto

subsection {* properties of algorithms which do not depend on properties of type of matrix *}

lemma mat0_index[simp]: assumes "i < nc" and "j < nr"
  shows "mat0I ze nr nc ! i ! j = ze"
unfolding mat0I_def vec0I_def using assms by auto

lemma mat0_row[simp]: assumes "i < nr"
  shows "row (mat0I ze nr nc) i = vec0I ze nc"
unfolding row_def mat0I_def vec0I_def
using assms by auto

lemma mat0_col[simp]: assumes "i < nc"
  shows "col (mat0I ze nr nc) i = vec0I ze nr"
unfolding mat0I_def col_def
using assms by auto

lemma vec1_index: assumes j: "j < n"
  shows "vec1I ze on n i ! j = (if i = j then on else ze)" (is "_ = ?r")
unfolding vec1I_def
proof -
  let ?l = "replicate i ze @ on # replicate (n - 1 - i) ze"
  have len: "length ?l > i" by auto
  have len2: "length (replicate i ze @ on # []) > i" by auto
  show "?l ! j = ?r"
  proof (cases "j = i")
    case True
    thus ?thesis by (simp add: nth_append)
  next
    case False
    show ?thesis
    proof (cases "j < i")
      case True
      thus ?thesis by (simp add: nth_append)
    next
      case False
      with `j \<noteq> i` have gt: "j > i" by auto
      from this have "\<exists> k. j = i + Suc k" by arith
      from this obtain k where k: "j = i + Suc k" by auto
      with j show ?thesis by (simp add: nth_append)
    qed
  qed
qed

lemma col_transpose_is_row[simp]:
  assumes wf: "mat nr nc m"
  and i: "i < nr"
  shows "col (transpose nr m) i = row m i"
using wf
proof (induct m arbitrary: nc)
  case (Cons v m)
  from `mat nr nc (v # m)` obtain ncc where nc: "nc = Suc ncc" and wf: "mat nr ncc m"  by (cases nc, auto simp: mat_def)
  from `mat nr nc (v # m)` nc have lengths: "(\<forall> w \<in> set m. length w = nr) \<and> length v = nr \<and> length m = ncc" unfolding mat_def by (auto simp: vec_def)
  from wf Cons have colRec: "col (transpose nr m) i = row m i" by auto
  hence simpme: "transpose nr m ! i = row m i" unfolding col_def by auto
  from wf have trans: "mat ncc nr (transpose nr m)" by (rule transpose)
  hence lengths2: "(\<forall> w \<in> set (transpose nr m). length w = ncc) \<and> length (transpose nr m) = nr" unfolding mat_def by (auto simp: vec_def)
  {
    fix j
    assume "j < length (col (transpose nr (v # m)) i)"
    hence "j < Suc ncc" by (simp add: col_def lengths2 lengths i)
    hence "col (transpose nr (v # m)) i ! j = row (v # m) i ! j"
      by (cases j, simp add: row_def col_def i lengths lengths2, simp add: row_def col_def i lengths lengths2 simpme)
  } note simpme = this
  show ?case by (rule nth_equalityI, simp add: col_def row_def lengths lengths2 i, intro allI impI, rule simpme)
qed (simp add: col_def row_def mat_def i)

lemma mat_col_eq:
  assumes wf1: "mat nr nc m1"
  and wf2: "mat nr nc m2"
  shows "(m1 = m2) = (\<forall> i < nc. col m1 i = col m2 i)" (is "?l = ?r")
proof
  assume ?l thus ?r by auto
next
  assume ?r show ?l
  proof (rule nth_equalityI)
    show "length m1 = length m2" using wf1 wf2 unfolding mat_def by auto
  next
    from `?r` show "\<forall> i < length m1. m1 ! i = m2 ! i" using wf1 unfolding col_def mat_def by auto
  qed
qed

lemma mat_col_eqI:
  assumes wf1: "mat nr nc m1"
  and wf2: "mat nr nc m2"
  and id: "\<And> i. i < nc \<Longrightarrow> col m1 i = col m2 i"
  shows "m1 = m2"
  unfolding mat_col_eq[OF wf1 wf2] using id by auto

lemma mat_eq:
  assumes wf1: "mat nr nc m1"
  and wf2: "mat nr nc m2"
  shows "(m1 = m2) = (\<forall> i < nc. \<forall> j < nr. m1 ! i ! j = m2 ! i ! j)" (is "?l = ?r")
proof
  assume ?l thus ?r by auto
next
  assume ?r show ?l
  proof (rule mat_col_eqI[OF wf1 wf2], unfold col_def)
    fix i
    assume i: "i < nc"
    show "m1 ! i = m2 ! i"
    proof (rule nth_equalityI)
      show "length (m1 ! i)  = length (m2 ! i)" using wf1 wf2 i unfolding mat_def by (auto simp: vec_def)
    next
      from `?r` i show "\<forall> j < length (m1 ! i). m1 ! i ! j = m2 ! i ! j" using wf1 wf2 unfolding mat_def by (auto simp: vec_def)
    qed
  qed
qed

lemma mat_eqI:
  assumes wf1: "mat nr nc m1"
  and wf2: "mat nr nc m2"
  and id: "\<And> i j. i < nc \<Longrightarrow> j < nr \<Longrightarrow> m1 ! i ! j = m2 ! i ! j"
  shows "m1 = m2"
  unfolding mat_eq[OF wf1 wf2] using id by auto

lemma vec_eq:
  assumes wf1: "vec n v1"
  and wf2: "vec n v2"
  shows "(v1 = v2) = (\<forall> i < n. v1 ! i = v2 ! i)" (is "?l = ?r")
proof
  assume ?l thus ?r by auto
next
  assume ?r show ?l
  proof (rule nth_equalityI)
    from wf1 wf2 show "length v1 = length v2" unfolding vec_def by simp
  next
    from `?r` wf1 show "\<forall> i < length v1. v1 ! i = v2 ! i" unfolding vec_def by simp
  qed
qed

lemma vec_eqI:
  assumes wf1: "vec n v1"
  and wf2: "vec n v2"
  and id: "\<And> i. i < n \<Longrightarrow> v1 ! i = v2 ! i"
  shows "v1 = v2"
  unfolding vec_eq[OF wf1 wf2] using id by auto

lemma row_col: assumes "mat nr nc m"
  and "i < nr" and "j < nc"
  shows "row m i ! j = col m j ! i"
using assms unfolding mat_def row_def col_def
  by auto

lemma col_index: assumes m: "mat nr nc m"
  and i: "i < nc"
  shows "col m i = map (\<lambda> j. m ! i ! j) [0 ..< nr]"
proof -
  from m[unfolded mat_def] i
  have nr: "nr = length (m ! i)" by (auto simp: vec_def)
  show ?thesis unfolding nr col_def
    by (rule map_nth[symmetric])
qed

lemma row_index: assumes m: "mat nr nc m"
  and i: "i < nr"
  shows "row m i = map (\<lambda> j. m ! j ! i) [0 ..< nc]"
proof -
  note rc = row_col[OF m i]
  from row[OF m i] have id: "length (row m i) = nc" unfolding vec_def by simp
  from map_nth[of "row m i"]
  have "row m i = map (\<lambda> j. row m i ! j) [0 ..< nc]" unfolding id by simp
  also have "... = map (\<lambda> j. m ! j ! i) [0 ..< nc]" using rc[unfolded col_def] by auto
  finally show ?thesis .
qed

lemma mat_row_eq:
  assumes wf1: "mat nr nc m1"
  and wf2: "mat nr nc m2"
  shows "(m1 = m2) = (\<forall> i < nr. row m1 i = row m2 i)" (is "?l = ?r")
proof
  assume ?l thus ?r by auto
next
  assume ?r show ?l
  proof (rule nth_equalityI)
    show "length m1 = length m2" using wf1 wf2 unfolding mat_def by auto
  next
    show "\<forall> i < length m1. m1 ! i = m2 ! i"
    proof (intro allI impI)
      fix i
      assume i: "i < length m1"
      show "m1 ! i = m2 ! i"
      proof (rule nth_equalityI)
        show "length (m1 ! i) = length (m2 ! i)" using wf1 wf2 i unfolding mat_def by (auto simp: vec_def)
      next
        show "\<forall> j < length (m1 ! i). m1 ! i ! j = m2 ! i ! j"
        proof (intro allI impI)
          fix j
          assume j: "j < length (m1 ! i)"
          from i j wf1 have i1: "i < nc" and j1: "j < nr" unfolding mat_def by (auto simp: vec_def)
          from `?r` j1 have "col m1 i ! j = col m2 i ! j"
            by (simp add: row_col[OF wf1 j1 i1, symmetric] row_col[OF wf2 j1 i1, symmetric])
          thus "m1 ! i ! j = m2 ! i ! j" unfolding col_def .
        qed
      qed
    qed
  qed
qed

lemma mat_row_eqI:
  assumes wf1: "mat nr nc m1"
  and wf2: "mat nr nc m2"
  and id: "\<And> i. i < nr \<Longrightarrow> row m1 i = row m2 i"
  shows "m1 = m2"
  unfolding mat_row_eq[OF wf1 wf2] using id by auto

lemma row_transpose_is_col[simp]:   assumes wf: "mat nr nc m"
  and i: "i < nc"
  shows "row (transpose nr m) i = col m i"
proof -
  have len: "length (row (transpose nr m) i) = length (col m i)"
    using transpose[OF wf]  wf i  unfolding row_def col_def mat_def by (auto simp: vec_def)
  show ?thesis
  proof (rule nth_equalityI[OF len], intro allI impI)
    fix j
    assume "j < length (row (transpose nr m) i)"
    hence j: "j < nr" using transpose[OF wf] wf i unfolding row_def col_def mat_def by (auto simp: vec_def)
    show "row (transpose nr m) i ! j = col m i ! j"
      by (simp only: row_col[OF transpose[OF wf] i j],
        simp only: col_transpose_is_row[OF wf j],
        simp only: row_col[OF wf j i])
  qed
qed

lemma matT_vec_mult_to_scalar:
  assumes "mat nr nc m"
  and "vec nr v"
  and "i < nc"
  shows "matT_vec_multI ze pl ti m v ! i = scalar_prodI ze pl ti (col m i) v"
unfolding matT_vec_multI_def using assms unfolding mat_def col_def by (auto simp: vec_def)

lemma mat_vec_mult_index:
  assumes wf: "mat nr nc m"
  and wfV: "vec nc v"
  and i: "i < nr"
  shows "matT_vec_multI ze pl ti (transpose nr m) v ! i = scalar_prodI ze pl ti (row m i) v"
by (simp only:matT_vec_mult_to_scalar[OF transpose[OF wf] wfV i],
  simp only: col_transpose_is_row[OF wf i])

lemma mat_mult_index[simp] :
  assumes wf1: "mat nr n m1"
  and wf2: "mat n nc m2"
  and i: "i < nr"
  and j: "j < nc"
  shows "mat_multI ze pl ti nr m1 m2 ! j ! i = scalar_prodI ze pl ti (row m1 i) (col m2 j)"
proof -
  have jlen: "j < length m2" using wf2 j unfolding mat_def by auto
  have wfj: "vec n (m2 ! j)" using jlen j wf2 unfolding mat_def by auto
  show ?thesis
    unfolding mat_multI_def
    by (simp add: jlen, simp only: mat_vec_mult_index[OF wf1 wfj i], unfold col_def, simp)
qed

lemma col_mat_mult_index :
  assumes wf1: "mat nr n m1"
  and wf2: "mat n nc m2"
  and j: "j < nc"
  shows "col (mat_multI ze pl ti nr m1 m2) j = map (\<lambda> i. scalar_prodI ze pl ti (row m1 i) (col m2 j)) [0 ..< nr]" (is "col ?l j = ?r")
proof -
  have wf12: "mat nr nc ?l" by (rule mat_mult[OF wf1 wf2])
  have len: "length (col ?l j) = length ?r" and nr: "length (col ?l j) = nr" using wf1 wf2 wf12 j unfolding mat_def col_def by (auto simp: vec_def)
  show ?thesis by (rule nth_equalityI[OF len], simp add: j nr, intro allI impI, unfold col_def, simp only:
    mat_mult_index[OF wf1 wf2 _ j], simp add: col_def)
qed

lemma row_mat_mult_index :
  assumes wf1: "mat nr n m1"
  and wf2: "mat n nc m2"
  and i: "i < nr"
  shows "row (mat_multI ze pl ti nr m1 m2) i = map (\<lambda> j. scalar_prodI ze pl ti (row m1 i) (col m2 j)) [0 ..< nc]" (is "row ?l i = ?r")
proof -
  have wf12: "mat nr nc ?l" by (rule mat_mult[OF wf1 wf2])
  hence lenL: "length ?l = nc" unfolding mat_def by simp
  have len: "length (row ?l i) = length ?r" and nc: "length (row ?l i) = nc" using wf1 wf2 wf12 i unfolding mat_def row_def by (auto simp: vec_def)
  show ?thesis by (rule nth_equalityI[OF len], simp add: i nc, intro allI impI, unfold row_def, simp add: lenL, simp only:
    mat_mult_index[OF wf1 wf2 i], simp add: row_def)
qed

lemma scalar_prod_cons:
  "scalar_prodI ze pl ti (a # as) (b # bs) = pl (ti a b) (scalar_prodI ze pl ti as bs)"
unfolding scalar_prodI_def by auto

lemma vec_plus_index[simp]:
  assumes wf1: "vec nr v1"
  and wf2: "vec nr v2"
  and i: "i < nr"
  shows "vec_plusI pl v1 v2 ! i = pl (v1 ! i)  (v2 ! i)"
using wf1 wf2 i
unfolding vec_def vec_plusI_def
proof (induct v1 arbitrary: i v2 nr, simp)
  case (Cons a v11)
  from Cons obtain b v22 where v2: "v2 = b # v22" by (cases v2, auto)
  from v2 Cons obtain nrr where nr: "nr = Suc nrr" by (force)
  from Cons show ?case
    by (cases i, simp add: v2, auto simp: v2 nr)
qed

lemma mat_map_index[simp]: assumes wf: "mat nr nc m" and i: "i < nc" and j: "j < nr"
  shows "mat_map f m ! i ! j = f (m ! i ! j)"
proof -
  from wf i have i: "i < length m" unfolding mat_def by auto
  with wf j have j: "j < length (m ! i)" unfolding mat_def by (auto simp: vec_def)
  have "mat_map f m ! i ! j = map (map f) m ! i ! j" unfolding mat_map_def vec_map_def by auto
  also have "\<dots> = map f (m ! i) ! j" using i by auto
  also have "\<dots> = f (m ! i ! j)" using j by auto
  finally show ?thesis .
qed

lemma mat_plus_index[simp]:
  assumes wf1: "mat nr nc m1"
  and wf2: "mat nr nc m2"
  and i: "i < nc"
  and j: "j < nr"
  shows "mat_plusI pl m1 m2 ! i ! j = pl (m1 ! i ! j) (m2 ! i ! j)"
using wf1 wf2 i
unfolding mat_plusI_def mat_def
proof (simp, induct m1 arbitrary: m2 i nc, simp)
  case (Cons v1 m11)
  from Cons obtain v2 m22 where m2: "m2 = v2 # m22" by (cases m2, auto)
  from m2 Cons obtain ncc where nc: "nc = Suc ncc" by force
  show ?case
  proof (cases i, simp add: m2, rule vec_plus_index[where nr = nr], (auto simp: Cons j m2)[3])
    case (Suc ii)
    with Cons show ?thesis using m2 nc by auto
  qed
qed

lemma col_mat_plus: assumes wf1: "mat nr nc m1"
  and wf2: "mat nr nc m2"
  and i: "i < nc"
  shows "col (mat_plusI pl m1 m2) i = vec_plusI pl (col m1 i) (col m2 i)"
using assms
unfolding mat_plusI_def col_def mat_def
proof (induct m1 arbitrary: m2 nc i, simp)
  case (Cons v m1)
  from Cons obtain v2 m22 where m2: "m2 = v2 # m22" by (cases m2, auto)
  from m2 Cons obtain ncc where nc: "nc = Suc ncc" by force
  show ?case
  proof (cases i, simp add: m2)
    case (Suc ii)
    with Cons show ?thesis using m2 nc by auto
  qed
qed

lemma transpose_index[simp]: assumes wf: "mat nr nc m"
  and i: "i < nr"
  and j: "j < nc"
  shows "transpose nr m ! i ! j = m ! j ! i"
proof -
  have "transpose nr m ! i ! j = col (transpose nr m) i ! j" unfolding col_def by simp
  also have "\<dots> = row m i ! j" using col_transpose_is_row[OF wf i] by simp
  also have "\<dots> = m ! j ! i" unfolding row_def using wf j unfolding mat_def by (auto simp: vec_def)
  finally show ?thesis .
qed

lemma transpose_mat_plus: assumes wf: "mat nr nc m1" "mat nr nc m2"
  shows "transpose nr (mat_plusI pl m1 m2) = mat_plusI pl (transpose nr m1) (transpose nr m2)" (is "?l = ?r")
proof (rule mat_eqI)
  fix i j
  assume i: "i < nr" and j: "j < nc"
  note [simp] = transpose_index[OF _ this] mat_plus_index[OF _ _ j i] mat_plus_index[OF _ _ this]
  show "?l ! i ! j = ?r ! i ! j" using wf by simp
qed (auto intro: wf)

lemma row_mat_plus: assumes wf1: "mat nr nc m1"
  and wf2: "mat nr nc m2"
  and i: "i < nr"
  shows "row (mat_plusI pl m1 m2) i = vec_plusI pl (row m1 i) (row m2 i)"
  by (
    simp only: col_transpose_is_row[OF mat_plus[OF wf1 wf2] i, symmetric],
    simp only: transpose_mat_plus[OF wf1 wf2],
    simp only: col_mat_plus[OF transpose[OF wf1] transpose[OF wf2] i],
    simp only: col_transpose_is_row[OF wf1 i],
    simp only: col_transpose_is_row[OF wf2 i])

lemma col_mat1: assumes "i < nr"
  shows "col (mat1I ze on nr) i = vec1I ze on nr i"
unfolding mat1I_def col_def using assms by auto

lemma mat1_index: assumes i: "i < n" and j: "j < n"
  shows "mat1I ze on n ! i ! j = (if i = j then on else ze)"
  by (simp add: col_mat1[OF i, simplified col_def] vec1_index[OF j])

lemma transpose_mat1: "transpose nr (mat1I ze on nr) = (mat1I ze on nr)" (is "?l = ?r")
proof (rule mat_eqI)
  fix i j
  assume i:"i < nr" and j: "j < nr"
  note [simp] = transpose_index[OF _ this] mat1_index[OF this] mat1_index[OF j i]
  show "?l ! i ! j = ?r ! i ! j" by auto
qed auto

lemma row_mat1: assumes i: "i < nr"
  shows "row (mat1I ze on nr) i = vec1I ze on nr i"
by (simp only: col_transpose_is_row[OF mat1 i, symmetric],
  simp only: transpose_mat1,
  simp only: col_mat1[OF i])

lemma sub_mat_index:
  assumes wf: "mat nr nc m"
  and sr: "sr \<le> nr"
  and sc: "sc \<le> nc"
  and j: "j < sr"
  and i: "i < sc"
  shows "sub_mat sr sc m ! i ! j = m ! i ! j"
proof -
  from assms have im: "i < length m" unfolding mat_def by auto
  from assms have jm: "j < length (m ! i)" unfolding mat_def by (auto simp: vec_def)
  have "sub_mat sr sc m ! i ! j = map (take sr) (take sc m) ! i ! j"
    unfolding sub_mat_def sub_vec_def by auto
  also have "\<dots> = take sr (m ! i) ! j" using i im by auto
  also have "\<dots> = m ! i ! j" using j jm by auto
  finally show ?thesis .
qed

subsection {* lemmas requiring properties of plus, times, ... *}

context plus
begin

abbreviation vec_plus :: "'a vec \<Rightarrow> 'a vec \<Rightarrow> 'a vec"
where "vec_plus \<equiv> vec_plusI plus"

abbreviation mat_plus :: "'a mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat"
where "mat_plus \<equiv> mat_plusI plus"
end

context semigroup_add
begin
lemma vec_plus_assoc: assumes vec: "vec nr u" "vec nr v" "vec nr w"
 shows "vec_plus u (vec_plus v w) = vec_plus (vec_plus u v) w"
proof (rule vec_eqI)
  fix i
  assume i: "i < nr"
  note [simp] = vec_plus_index[OF _ _ i]
  from vec
  show "vec_plus u (vec_plus v w) ! i = vec_plus (vec_plus u v) w ! i"
    by (auto simp: add.assoc)
qed (auto intro: vec)

lemma mat_plus_assoc: assumes wf: "mat nr nc m1" "mat nr nc m2" "mat nr nc m3"
  shows "mat_plus m1 (mat_plus m2 m3) = mat_plus (mat_plus m1 m2) m3" (is "?l = ?r")
proof (rule mat_eqI)
  fix i j
  assume "i < nc" "j < nr"
  note [simp] = mat_plus_index[OF _ _ this]
  show "?l ! i ! j = ?r ! i ! j" using wf by (simp add: add.assoc)
qed (auto simp: wf)
end

context ab_semigroup_add
begin
lemma vec_plus_comm: "vec_plus x y = vec_plus y x"
unfolding vec_plusI_def
proof (induct x arbitrary: y)
  case (Cons a x)
  thus ?case
    by (cases y, auto simp: add.commute)
qed simp

lemma mat_plus_comm: "mat_plus m1 m2 = mat_plus m2 m1"
unfolding mat_plusI_def
proof (induct m1 arbitrary: m2)
  case (Cons v m1) note oCons = this
  thus ?case
  proof (cases m2)
    case (Cons w m2a)
    hence "mat_plus (v # m1) m2 = vec_plus v w # mat_plus m1 m2a" by (auto simp: mat_plusI_def)
    also have "\<dots> = vec_plus w v # mat_plus m1 m2a" using vec_plus_comm by auto
    finally show ?thesis using Cons oCons by (auto simp: mat_plusI_def)
  qed simp
qed simp
end

context zero
begin
abbreviation vec0 :: "nat \<Rightarrow> 'a vec"
where "vec0 \<equiv> vec0I zero"

abbreviation mat0 :: "nat \<Rightarrow> nat \<Rightarrow> 'a mat"
where "mat0 \<equiv> mat0I zero"
end

context monoid_add
begin
lemma vec0_plus[simp]: assumes "vec nr u" shows "vec_plus (vec0 nr) u = u"
using assms
unfolding vec_def vec_plusI_def vec0I_def
proof (induct nr arbitrary: u)
 case (Suc nn) thus ?case by (cases u, auto)
qed simp

lemma plus_vec0[simp]: assumes "vec nr u" shows "vec_plus u (vec0 nr) = u"
using assms
unfolding vec_def vec_plusI_def vec0I_def
proof (induct nr arbitrary: u)
 case (Suc nn) thus ?case by (cases u, auto)
qed simp

lemma plus_mat0[simp]: assumes wf: "mat nr nc m" shows "mat_plus m (mat0 nr nc) = m" (is "?l = ?r")
proof (rule mat_eqI)
  fix i j
  assume "i < nc" "j < nr"
  note [simp] = mat_plus_index[OF _ _ this] mat0_index[OF this]
  show "?l ! i ! j = ?r ! i ! j" using wf by simp
qed (insert wf, auto)

lemma mat0_plus[simp]: assumes wf: "mat nr nc m" shows "mat_plus (mat0 nr nc) m = m" (is "?l = ?r")
proof (rule mat_eqI)
  fix i j
  assume "i < nc" "j < nr"
  note [simp] = mat_plus_index[OF _ _ this] mat0_index[OF this]
  show "?l ! i ! j = ?r ! i ! j" using wf by simp
qed (insert wf, auto)
end

context semiring_0
begin
abbreviation scalar_prod :: "'a vec \<Rightarrow> 'a vec \<Rightarrow> 'a"
where "scalar_prod \<equiv> scalar_prodI zero plus times"

abbreviation mat_mult :: "nat \<Rightarrow> 'a mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat"
where "mat_mult \<equiv> mat_multI zero plus times"

lemma scalar_prod: "scalar_prod v1 v2 = listsum (map (\<lambda>(x,y). x * y) (zip v1 v2))"
proof -
  obtain z where z: "zip v1 v2 = z" by auto
  show ?thesis unfolding scalar_prodI_def z
    by (induct z, auto)
qed

lemma scalar_prod_last: assumes "length v1 = length v2"
  shows "scalar_prod (v1 @ [x1]) (v2 @ [x2]) = x1 * x2 + scalar_prod v1 v2"
using assms
proof (induct v1 arbitrary: v2)
  case (Cons y1 w1)
  from Cons(2) obtain y2 w2 where v2: "v2 = Cons y2 w2" and len: "length w1 = length w2" by (cases v2, auto)
  from Cons(1)[OF len] have rec: "scalar_prod (w1 @ [x1]) (w2 @ [x2]) = x1 * x2 + scalar_prod w1 w2" .
  have "scalar_prod ((y1 # w1) @ [x1]) (v2 @ [x2]) =
    (y1 * y2 + x1 * x2) + scalar_prod w1 w2" by (simp add: scalar_prod_cons v2 rec add.assoc)
  also have "\<dots> = (x1 * x2 + y1 * y2) + scalar_prod w1 w2" using add.commute[of "x1 * x2"] by simp
  also have "\<dots> = x1 * x2 + (scalar_prod (y1 # w1) v2)" by (simp add: add.assoc scalar_prod_cons v2)
  finally show ?case .
qed (simp add: scalar_prodI_def)

lemma scalar_product_assoc:
  assumes wfm: "mat nr nc m"
  and wfr: "vec nr r"
  and wfc: "vec nc c"
  shows "scalar_prod (map (\<lambda>k. scalar_prod r (col m k)) [0..<nc]) c = scalar_prod r (map (\<lambda>k. scalar_prod (row m k) c) [0..<nr])"
using wfm wfc
unfolding col_def
proof (induct m arbitrary: nc c)
  case Nil
  hence nc: "nc = 0" unfolding mat_def by (auto)
  from wfr have nr: "nr = length r" unfolding vec_def by auto
  let ?term = "\<lambda> r :: 'a vec. zip r (map (\<lambda> k. zero) [0..<length r])"
  let ?fun = "\<lambda> (x,y). plus (times x y)"
  have "foldr ?fun (?term r) zero = zero"
  proof (induct r, simp)
    case (Cons d r)
    have "foldr ?fun (?term (d # r)) zero = foldr ?fun ( (d,zero) # ?term r) zero" by (simp only: map_replicate_trivial, simp)
    also have "\<dots> = zero" using Cons by simp
    finally show ?case .
  qed
  hence "zero = foldr ?fun (zip r (map (\<lambda> k. zero) [0..<nr])) zero" by (simp add: nr)
  with Nil nc show ?case
    by (simp add: scalar_prodI_def row_def)
next
  case (Cons v m)
  from this obtain ncc where nc: "nc = Suc ncc" and wf: "mat nr ncc m" unfolding mat_def by (auto simp: vec_def)
  from nc `vec nc c` obtain a cc where c: "c = a # cc" and wfc: "vec ncc cc" unfolding vec_def by (cases c, auto)
  have rec: "scalar_prod (map (\<lambda> k. scalar_prod r (m ! k)) [0..<ncc]) cc = scalar_prod r (map (\<lambda> k. scalar_prod (row m k) cc) [0..<nr])"
    by (rule Cons, rule wf, rule wfc)
  have id: "map (\<lambda>k. scalar_prod r ((v # m) ! k)) [0..<Suc ncc] = scalar_prod r v # map (\<lambda> k. scalar_prod r (m ! k)) [0..<ncc]" by (induct ncc, auto)
  from wfr have nr: "nr = length r" unfolding vec_def by auto
  with Cons have v: "length v = length r" unfolding mat_def by (auto simp: vec_def)
  have "\<forall> i < nr. vec ncc (row m i)" by (intro allI impI, rule row[OF wf], simp)
  obtain tm where tm: "tm = transpose nr m" by auto
  hence idk: "\<forall> k < length r. row m k = tm ! k" using col_transpose_is_row[OF wf] unfolding col_def by (auto simp: nr)
  hence idtm1: "map (\<lambda>k. scalar_prod (row m k) cc) [0..<length r] = map (\<lambda>k. scalar_prod (tm ! k) cc) [0..<length r]"
    and idtm2: "map (\<lambda>k. plus (times (v ! k) a) (scalar_prod (row m k) cc)) [0..<length r] = map (\<lambda>k. plus (times (v ! k) a) (scalar_prod (tm ! k) cc)) [0..<length r]" by auto
  from tm transpose[OF wf] have "mat ncc nr tm" by simp
  with nr have "length tm = length r" and  "(\<forall> i < length r. length (tm ! i) = ncc)" unfolding mat_def by (auto simp: vec_def)
  with v have main: "plus (times (scalar_prod r v) a) (scalar_prod r (map (\<lambda>k. scalar_prod (tm ! k) cc) [0..<length r])) =
    scalar_prod r (map (\<lambda>k. plus (times (v ! k) a) (scalar_prod (tm ! k) cc)) [0..<length r])"
  proof (induct r arbitrary: v tm)
    case Nil
    thus ?case by (auto simp: scalar_prodI_def row_def)
  next
    case (Cons b r)
    from this obtain c vv where v: "v = c # vv" and vvlen: "length vv = length r" by (cases v, auto)
    from Cons obtain u mm where tm: "tm = u # mm" and mmlen: "length mm = length r"  by (cases tm, auto)
    from Cons tm have argLen: "\<forall> i < length r. length (mm ! i) = ncc" by auto
    have rec: "plus (times (scalar_prod r vv) a) (scalar_prod r (map (\<lambda>k. scalar_prod (mm ! k) cc) [0..<length r])) =
     scalar_prod r (map (\<lambda>k. plus (times (vv ! k) a) (scalar_prod (mm ! k) cc)) [0..<length r])"
      (is "plus (times ?rv a) ?recl = ?recr")
      by (rule Cons, auto simp: vvlen mmlen argLen)
    have id: "map (\<lambda>k. scalar_prod ((u # mm) ! k) cc) [0..<length (b # r)] = scalar_prod u cc # map (\<lambda>k. scalar_prod (mm ! k) cc) [0..<length r]"
      by (simp, induct r, auto)
    have id2: "map (\<lambda>k. plus (times ((c # vv) ! k) a) (scalar_prod ((u # mm) ! k) cc)) [0..<length (b # r)] =
               (plus (times c a) (scalar_prod u cc)) #
               map (\<lambda>k. plus (times (vv ! k) a) (scalar_prod (mm ! k) cc)) [0..<length r]"
      by (simp, induct r, auto)
    show ?case proof (simp only: v tm, simp only: id, simp only: id2, simp only: scalar_prod_cons)
      let ?uc = "scalar_prod u cc"
      let ?bca = "times (times b c) a"
      have "plus (times (plus (times b c) ?rv) a) (plus (times b ?uc) ?recl) = plus (plus ?bca (times ?rv a)) (plus (times b ?uc) ?recl)"
        by (simp add: distrib_right)
      also have "\<dots> = plus (plus ?bca (times ?rv a)) (plus ?recl (times b ?uc))" by (simp add: add.commute)
      also have "\<dots> = plus ?bca (plus (plus (times ?rv a) ?recl) (times b ?uc))" by (simp add: add.assoc)
      also have "\<dots> = plus ?bca (plus ?recr (times b ?uc))" by (simp only: rec)
      also have "\<dots> = plus ?bca (plus (times b ?uc) ?recr)" by (simp add: add.commute)
      also have "\<dots> = plus (times b (plus (times c a) ?uc)) ?recr" by (simp add: distrib_left mult.assoc add.assoc)
      finally show "plus (times (plus (times b c) ?rv) a) (plus (times b ?uc) ?recl) = plus (times b (plus (times c a) ?uc)) ?recr" .
    qed
  qed
  show ?case
    by (simp only: c scalar_prod_cons, simp only: nc, simp only: id, simp only: scalar_prod_cons, simp only: rec, simp only: nr, simp only: idtm1 idtm2, simp only: main, simp only: idtm2[symmetric], simp add: row_def scalar_prod_cons)
qed

lemma mat_mult_assoc:
  assumes wf1: "mat nr n1 m1"
  and wf2: "mat n1 n2 m2"
  and wf3: "mat n2 nc m3"
  shows "mat_mult nr (mat_mult nr m1 m2) m3 = mat_mult nr m1 (mat_mult n1 m2 m3)" (is "?m12_3 = ?m1_23")
proof -
  note wf = wf1 wf2 wf3
  let ?m12 = "mat_mult nr m1 m2"
  let ?m23 = "mat_mult n1 m2 m3"
  from wf have
    wf12: "mat nr n2 ?m12" and
    wf23: "mat n1 nc ?m23" and
    wf1_23: "mat nr nc ?m1_23" and
    wf12_3: "mat nr nc ?m12_3" by auto
  show ?thesis
  proof (rule mat_col_eqI, unfold col_def)
    fix i
    assume i: "i < nc"
    with wf1_23 wf12_3 wf3 have len: "length (?m12_3 ! i) = length (?m1_23 ! i)" and ilen: "i < length m3" unfolding mat_def by (auto simp: vec_def)
    show "?m12_3 ! i = ?m1_23 ! i"
    proof (rule nth_equalityI[OF len], intro allI impI)
      fix j
      assume jlen: "j < length (?m12_3 ! i)"
      with wf12_3 i have j: "j < nr" unfolding mat_def by (auto simp: vec_def)
      show "?m12_3 ! i ! j = ?m1_23 ! i ! j"
        by (unfold mat_mult_index[OF wf12 wf3 j i]
              mat_mult_index[OF wf1 wf23 j i]
              row_mat_mult_index[OF wf1 wf2 j]
              col_mat_mult_index[OF wf2 wf3 i]
              scalar_product_assoc[OF wf2 row[OF wf1 j] col[OF wf3 i]], simp)
    qed
  qed (insert wf, auto)
qed

lemma mat_mult_assoc_n:
  assumes wf1: "mat n n m1"
  and wf2: "mat n n m2"
  and wf3: "mat n n m3"
  shows "mat_mult n (mat_mult n m1 m2) m3 = mat_mult n m1 (mat_mult n m2 m3)"
using assms
 by (rule mat_mult_assoc)

lemma scalar_left_zero: "scalar_prod (vec0 nn) v = zero"
  unfolding vec0I_def scalar_prodI_def
proof (induct nn arbitrary: v)
  case (Suc m)
  thus ?case by (cases v, auto)
qed simp

lemma scalar_right_zero: "scalar_prod v (vec0 nn) = zero"
  unfolding vec0I_def scalar_prodI_def
proof (induct v arbitrary: nn)
  case (Cons a vv)
  thus ?case by (cases nn, auto)
qed simp

lemma mat0_mult_left: assumes wf: "mat nc ncc m"
  shows "mat_mult nr (mat0 nr nc) m = (mat0 nr ncc)"
proof (rule mat_eqI)
  fix i j
  assume i: "i < ncc" and j: "j < nr"
  show "mat_mult nr (mat0 nr nc) m ! i ! j = mat0 nr ncc ! i ! j"
    by (unfold mat_mult_index[OF mat0 wf j i] mat0_index[OF i j] mat0_row[OF j] scalar_left_zero, simp)
qed (auto simp: wf)

lemma mat0_mult_right: assumes wf: "mat nr nc m"
  shows "mat_mult nr m (mat0 nc ncc) = (mat0 nr ncc)"
proof (rule mat_eqI)
  fix i j
  assume i: "i < ncc" and j: "j < nr"
  show "mat_mult nr m (mat0 nc ncc) ! i ! j = mat0 nr ncc ! i ! j"
    by (unfold mat_mult_index[OF wf mat0 j i] mat0_index[OF i j] mat0_col[OF i] scalar_right_zero, simp)
qed (insert wf, auto)

lemma scalar_vec_plus_distrib_right:
  assumes wf1: "vec nr u"
  assumes wf2: "vec nr v"
  assumes wf3: "vec nr w"
  shows "scalar_prod u (vec_plus v w) = plus (scalar_prod u v) (scalar_prod u w)"
using assms
unfolding vec_def scalar_prodI_def vec_plusI_def
proof (induct nr arbitrary: u v w)
  case (Suc n)
  from Suc obtain a uu where u: "u = a # uu" by (cases u, auto)
  from Suc obtain b vv where v: "v = b # vv" by (cases v, auto)
  from Suc obtain c ww where w: "w = c # ww" by (cases w, auto)
  from Suc u v w have lu: "length uu = n" and lv: "length vv = n" and lw: "length ww = n" by auto
  show ?case by (simp only: u v w, simp, simp only: Suc(1)[OF lu lv lw], simp add: add.commute[of _ "times a c"] distrib_left add.assoc[symmetric])
qed simp

lemma scalar_vec_plus_distrib_left:
  assumes wf1: "vec nr u"
  assumes wf2: "vec nr v"
  assumes wf3: "vec nr w"
  shows "scalar_prod (vec_plus u v) w = plus (scalar_prod u w) (scalar_prod v w)"
using assms
unfolding vec_def scalar_prodI_def vec_plusI_def
proof (induct nr arbitrary: u v w)
  case (Suc n)
  from Suc obtain a uu where u: "u = a # uu" by (cases u, auto)
  from Suc obtain b vv where v: "v = b # vv" by (cases v, auto)
  from Suc obtain c ww where w: "w = c # ww" by (cases w, auto)
  from Suc u v w have lu: "length uu = n" and lv: "length vv = n" and lw: "length ww = n" by auto
  show ?case by (simp only: u v w, simp, simp only: Suc(1)[OF lu lv lw], simp add: add.commute[of _ "times b c"] distrib_right add.assoc[symmetric])
qed simp

lemma mat_mult_plus_distrib_right:
  assumes wf1: "mat nr nc m1"
  and wf2: "mat nc ncc m2"
  and wf3: "mat nc ncc m3"
  shows "mat_mult nr m1 (mat_plus m2 m3) = mat_plus (mat_mult nr m1 m2) (mat_mult nr m1 m3)" (is "mat_mult nr m1 ?m23 = mat_plus ?m12 ?m13")
proof -
  note wf = wf1 wf2 wf3
  let ?m1_23 = "mat_mult nr m1 ?m23"
  let ?m12_13 = "mat_plus ?m12 ?m13"
  from wf have
    wf23: "mat nc ncc ?m23" and
    wf12: "mat nr ncc ?m12" and
    wf13: "mat nr ncc ?m13" and
    wf1_23: "mat nr ncc ?m1_23" and
    wf12_13: "mat nr ncc ?m12_13" by auto
  show ?thesis
  proof (rule mat_eqI)
    fix i j
    assume i: "i < ncc" and j: "j < nr"
    show "?m1_23 ! i ! j = ?m12_13 ! i ! j"
      by (unfold mat_mult_index[OF wf1 wf23 j i]
           mat_plus_index[OF wf12 wf13 i j]
           mat_mult_index[OF wf1 wf2 j i]
           mat_mult_index[OF wf1 wf3 j i]
           col_mat_plus[OF wf2 wf3 i],
        rule scalar_vec_plus_distrib_right[OF row[OF wf1 j] col[OF wf2 i] col[OF wf3 i]])
  qed (insert wf, auto)
qed

lemma mat_mult_plus_distrib_left:
  assumes wf1: "mat nr nc m1"
  and wf2: "mat nr nc m2"
  and wf3: "mat nc ncc m3"
  shows "mat_mult nr (mat_plus m1 m2) m3 = mat_plus (mat_mult nr m1 m3) (mat_mult nr m2 m3)" (is "mat_mult nr ?m12 _ = mat_plus ?m13 ?m23")
proof -
  note wf = wf1 wf2 wf3
  let ?m12_3 = "mat_mult nr ?m12 m3"
  let ?m13_23 = "mat_plus ?m13 ?m23"
  from wf have
    wf12: "mat nr nc ?m12" and
    wf13: "mat nr ncc ?m13" and
    wf23: "mat nr ncc ?m23" and
    wf12_3: "mat nr ncc ?m12_3" and
    wf13_23: "mat nr ncc ?m13_23" by auto
  show ?thesis
  proof (rule mat_eqI)
    fix i j
    assume i: "i < ncc" and j: "j < nr"
    show "?m12_3 ! i ! j = ?m13_23 ! i ! j"
      by (unfold mat_mult_index[OF wf12 wf3 j i]
           mat_plus_index[OF wf13 wf23 i j]
           mat_mult_index[OF wf1 wf3 j i]
           mat_mult_index[OF wf2 wf3 j i]
           row_mat_plus[OF wf1 wf2 j],
           rule scalar_vec_plus_distrib_left[OF row[OF wf1 j] row[OF wf2 j] col[OF wf3 i]])
  qed (insert wf, auto)
qed
end

context semiring_1
begin
abbreviation vec1 :: "nat \<Rightarrow> nat \<Rightarrow> 'a vec"
where "vec1 \<equiv> vec1I zero one"

abbreviation mat1 :: "nat \<Rightarrow> 'a mat"
where "mat1 \<equiv> mat1I zero one"

abbreviation mat_pow where "mat_pow \<equiv> mat_powI (0 :: 'a) 1 (op +) (op *)"

lemma scalar_left_one: assumes wf: "vec nn v"
  and i: "i < nn"
  shows "scalar_prod (vec1 nn i) v = v ! i"
  using assms
  unfolding vec1I_def vec_def
proof (induct nn arbitrary: v i)
  case (Suc n) note oSuc = this
  from this obtain a vv where v: "v = a # vv" and lvv: "length vv = n" by (cases v, auto)
  show ?case
  proof (cases i)
    case 0
    thus ?thesis using scalar_left_zero unfolding vec0I_def by (simp add: v scalar_prod_cons add.commute)
  next
    case (Suc ii)
    thus ?thesis using oSuc lvv v by (auto simp: scalar_prod_cons)
  qed
qed blast

lemma scalar_right_one: assumes wf: "vec nn v"
  and i: "i < nn"
  shows "scalar_prod v (vec1 nn i) = v ! i"
  using assms
  unfolding vec1I_def vec_def
proof (induct nn arbitrary: v i)
  case (Suc n) note oSuc = this
  from this obtain a vv where v: "v = a # vv" and lvv: "length vv = n" by (cases v, auto)
  show ?case
  proof (cases i)
    case 0
    thus ?thesis using scalar_right_zero unfolding vec0I_def by (simp add: v scalar_prod_cons add.commute)
  next
    case (Suc ii)
    thus ?thesis using oSuc lvv v by (auto simp: scalar_prod_cons)
  qed
qed blast

lemma mat1_mult_right: assumes wf: "mat nr nc m"
  shows "mat_mult nr m (mat1 nc) = m"
proof (rule mat_eqI)
  fix i j
  assume i: "i < nc" and j: "j < nr"
  show "mat_mult nr m (mat1 nc) ! i ! j = m ! i ! j"
    by (unfold mat_mult_index[OF wf mat1 j i]
     col_mat1[OF i]
     scalar_right_one[OF row[OF wf j] i]
     row_col[OF wf j i],
     unfold col_def, simp)
qed (insert wf, auto)

lemma mat1_mult_left: assumes wf: "mat nr nc m"
  shows "mat_mult nr (mat1 nr) m = m"
proof (rule mat_eqI)
  fix i j
  assume i: "i < nc" and j: "j < nr"
  show "mat_mult nr (mat1 nr) m ! i ! j = m ! i ! j"
    by (unfold mat_mult_index[OF mat1 wf j i]
      row_mat1[OF j]
      scalar_left_one[OF col[OF wf i] j], unfold col_def, simp)
qed (insert wf, auto)
end

declare vec0[simp del] mat0[simp del] vec0_plus[simp del] plus_vec0[simp del] plus_mat0[simp del]

subsection {* Connection to HOL-Algebra *}

definition mat_monoid :: "nat \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow> (('a :: {plus,zero}) mat,'b) monoid_scheme" where
  "mat_monoid nr nc b \<equiv> \<lparr>
    carrier = Collect (mat nr nc),
    mult = mat_plus,
    one = mat0 nr nc,
    \<dots> = b\<rparr>"

definition mat_ring :: "nat \<Rightarrow> 'b \<Rightarrow> (('a :: {plus,zero,times,one}) mat,'b) ring_scheme" where
  "mat_ring n b \<equiv> \<lparr>
    carrier = Collect (mat n n),
    mult = mat_mult n,
    one = mat1 n,
    zero = mat0 n n,
    add = mat_plus,
    \<dots> = b\<rparr>"

lemma mat_monoid: "monoid (mat_monoid nr nc b :: (('a :: monoid_add) mat,'b)monoid_scheme)"
  by (unfold_locales, auto simp: mat_plus_assoc mat_monoid_def plus_mat0)

lemma mat_group: "group (mat_monoid nr nc b :: (('a :: group_add) mat,'b)monoid_scheme)" (is "group ?G")
proof -
  interpret monoid ?G by (rule mat_monoid)
  {
    fix m :: "'a mat"
    assume wf: "mat nr nc m"
    let ?m' = "mat_map uminus m"
    have "\<exists> m'. mat nr nc m' \<and> mat_plus m' m = mat0 nr nc \<and> mat_plus m m' = mat0 nr nc"
    proof (rule exI[of _ ?m'], intro conjI mat_eqI)
      fix i j
      assume "i < nc" "j < nr"
      note [simp] = mat_plus_index[OF _ _ this] mat_map_index[OF _ this] mat0_index[OF this]
      show "mat_plus ?m' m ! i ! j = mat0 nr nc ! i ! j" using wf by simp
      show "mat_plus m ?m' ! i ! j = mat0 nr nc ! i ! j" using wf by simp
    qed (auto intro: wf)
  } note Units = this
  show ?thesis
    by (unfold_locales, auto simp: mat_monoid_def Units_def Units)
qed

lemma mat_comm_monoid:
  "comm_monoid (mat_monoid nr nc b :: (('a :: comm_monoid_add) mat,'b)monoid_scheme)" (is "comm_monoid ?G")
proof -
  interpret monoid ?G by (rule mat_monoid)
  show ?thesis
    by (unfold_locales, insert mat_plus_comm, auto simp: mat_monoid_def)
qed

lemma mat_comm_group:
  "comm_group (mat_monoid nr nc b :: (('a :: ab_group_add) mat,'b)monoid_scheme)" (is "comm_group ?G")
proof -
  interpret group ?G by (rule mat_group)
  interpret comm_monoid ?G by (rule mat_comm_monoid)
  show ?thesis ..
qed

lemma mat_abelian_monoid: "abelian_monoid (mat_ring n b :: (('a :: {comm_monoid_add,one,times}) mat,'b)ring_scheme)"
  unfolding mat_ring_def
  unfolding abelian_monoid_def using mat_comm_monoid[of n n, unfolded mat_monoid_def mat_ring_def]
  by simp

lemma mat_abelian_group: "abelian_group (mat_ring n b :: (('a :: {ab_group_add,one,times}) mat,'b)ring_scheme)"
  (is "abelian_group ?R")
proof -
  interpret abelian_monoid ?R by (rule mat_abelian_monoid)
  show ?thesis
  by (unfold_locales, rule group.Units, insert mat_group[of n n "()"],
    simp add: mat_monoid_def mat_ring_def)
qed

lemma mat_semiring: "semiring (mat_ring n b :: (('a :: semiring_1) mat,'b)ring_scheme)"
  (is "semiring ?R")
proof -
  interpret abelian_monoid ?R by (rule mat_abelian_monoid)
  show ?thesis
    by (unfold_locales, unfold mat_ring_def, insert
      mat_mult_assoc mat0_mult_left mat0_mult_right mat1_mult_left mat1_mult_right
      mat_mult_plus_distrib_left mat_mult_plus_distrib_right, auto)
qed

lemma mat_ring: "ring (mat_ring n b :: (('a :: ring_1) mat,'b)ring_scheme)"
  (is "ring ?R")
proof -
  interpret abelian_group ?R by (rule mat_abelian_group)
  show ?thesis
    by (unfold_locales, unfold mat_ring_def, insert
      mat_mult_assoc mat1_mult_left mat1_mult_right mat_mult_plus_distrib_left
      mat_mult_plus_distrib_right, auto)
qed

lemma mat_pow_ring_pow: assumes mat: "mat n n (m :: ('a :: semiring_1)mat)" shows "mat_pow n m k = m (^)\<^bsub>mat_ring n b\<^esub> k"
  (is "_ = m (^)\<^bsub>?C\<^esub> k")
proof -
  interpret semiring ?C by (rule mat_semiring)
  show ?thesis
    by (induct k, auto, auto simp: mat_ring_def)
qed

end


(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section \<open>Definition of Smith normal form in HOL Analysis\<close>

theory Smith_Normal_Form
  imports
    Hermite.Hermite
begin

subsection \<open>Definitions\<close>

text\<open>Definition of diagonal matrix\<close>

definition "isDiagonal_upt_k A k = (\<forall> a b. (to_nat a \<noteq> to_nat b \<and> (to_nat a < k \<or> (to_nat b < k))) \<longrightarrow> A $ a $ b = 0)"
definition "isDiagonal A = (\<forall> a b. to_nat a \<noteq> to_nat b \<longrightarrow> A $ a $ b = 0)"

lemma isDiagonal_intro:
  fixes A::"'a::{zero}^'cols::mod_type^'rows::mod_type"
  assumes "\<And>a::'rows. \<And>b::'cols. to_nat a = to_nat b"
  shows "isDiagonal A"
  using assms
  unfolding isDiagonal_def by auto

text\<open>Definition of Smith normal form up to position k. The element $A_{k-1,k-1}$
does not need to divide $A_{k,k}$ and $A_{k,k}$ could have non-zero entries above and below.\<close>

  definition "Smith_normal_form_upt_k A k =
  (
    (\<forall>a b. to_nat a = to_nat b \<and> to_nat a + 1 < k \<and> to_nat b + 1< k \<longrightarrow> A $ a $ b dvd A $ (a+1) $ (b+1))
    \<and> isDiagonal_upt_k A k
  )"

definition "Smith_normal_form A =
  (
    (\<forall>a b. to_nat a = to_nat b \<and> to_nat a + 1 < nrows A \<and> to_nat b + 1 < ncols A \<longrightarrow> A $ a $ b dvd A $ (a+1) $ (b+1))
    \<and> isDiagonal A
  )"

subsection \<open>Basic properties\<close>

lemma Smith_normal_form_min:
  "Smith_normal_form A = Smith_normal_form_upt_k A (min (nrows A) (ncols A))"
  unfolding Smith_normal_form_def Smith_normal_form_upt_k_def nrows_def ncols_def
  unfolding isDiagonal_upt_k_def isDiagonal_def
  by (auto, smt Suc_le_eq le_trans less_le min.boundedI not_less_eq_eq suc_not_zero
      to_nat_less_card to_nat_plus_one_less_card')

lemma Smith_normal_form_upt_k_0[simp]: "Smith_normal_form_upt_k A 0"
  unfolding Smith_normal_form_upt_k_def
  unfolding isDiagonal_upt_k_def isDiagonal_def
  by auto

lemma Smith_normal_form_upt_k_intro:
  assumes "(\<And>a b. to_nat a = to_nat b \<and> to_nat a + 1 < k \<and> to_nat b + 1< k \<Longrightarrow> A $ a $ b dvd A $ (a+1) $ (b+1))"
  and "(\<And>a b. (to_nat a \<noteq> to_nat b \<and> (to_nat a < k \<or> (to_nat b < k))) \<Longrightarrow> A $ a $ b = 0)"
shows "Smith_normal_form_upt_k A k"
  unfolding Smith_normal_form_upt_k_def
  unfolding isDiagonal_upt_k_def isDiagonal_def using assms by simp

lemma Smith_normal_form_upt_k_intro_alt:
  assumes "(\<And>a b. to_nat a = to_nat b \<and> to_nat a + 1 < k \<and> to_nat b + 1 < k \<Longrightarrow> A $ a $ b dvd A $ (a+1) $ (b+1))"
  and "isDiagonal_upt_k A k"
  shows "Smith_normal_form_upt_k A k"
  using assms
  unfolding Smith_normal_form_upt_k_def by auto

lemma Smith_normal_form_upt_k_condition1:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes "Smith_normal_form_upt_k A k"
  and "to_nat a = to_nat b" and " to_nat a + 1 < k" and "to_nat b + 1 < k "
  shows "A $ a $ b dvd A $ (a+1) $ (b+1)"
  using assms unfolding Smith_normal_form_upt_k_def by auto

lemma Smith_normal_form_upt_k_condition2:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes "Smith_normal_form_upt_k A k"
  and "to_nat a \<noteq> to_nat b" and "(to_nat a < k \<or> to_nat b < k)"
  shows "((A $ a) $ b) = 0"
  using assms unfolding Smith_normal_form_upt_k_def
  unfolding isDiagonal_upt_k_def isDiagonal_def by auto

lemma Smith_normal_form_upt_k1_intro:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes s: "Smith_normal_form_upt_k A k"
  and cond1: "A $ from_nat (k - 1) $ from_nat (k-1) dvd A $ (from_nat k) $ (from_nat k)"
  and cond2a: "\<forall>a. to_nat a > k \<longrightarrow> A $ a $ from_nat k = 0"
  and cond2b: "\<forall>b. to_nat b > k \<longrightarrow> A $ from_nat k $ b = 0"
shows "Smith_normal_form_upt_k A (Suc k)"
proof (rule Smith_normal_form_upt_k_intro)
  fix a::'rows and b::'cols
  assume a: "to_nat a \<noteq> to_nat b \<and> (to_nat a < Suc k \<or> to_nat b < Suc k)"
  show "A $ a $ b = 0"
    by (metis Smith_normal_form_upt_k_condition2 a
        assms(1) cond2a cond2b from_nat_to_nat_id less_SucE nat_neq_iff)
next
  fix a::'rows and b::'cols
  assume a: "to_nat a = to_nat b \<and> to_nat a + 1 < Suc k \<and> to_nat b + 1 < Suc k"
  show "A $ a $ b dvd A $ (a + 1) $ (b + 1)"
    by (metis (mono_tags, lifting) Smith_normal_form_upt_k_condition1 a add_diff_cancel_right' cond1
        from_nat_suc from_nat_to_nat_id less_SucE s)
qed

lemma Smith_normal_form_upt_k1_intro_diagonal:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes s: "Smith_normal_form_upt_k A k"
  and d: "isDiagonal A"
  and cond1: "A $ from_nat (k - 1) $ from_nat (k-1) dvd A $ (from_nat k) $ (from_nat k)"
shows "Smith_normal_form_upt_k A (Suc k)"
proof (rule Smith_normal_form_upt_k_intro)
  fix a::'rows and b::'cols
  assume a: "to_nat a = to_nat b \<and> to_nat a + 1 < Suc k \<and> to_nat b + 1 < Suc k"
  show "A $ a $ b dvd A $ (a + 1) $ (b + 1)"
    by (metis (mono_tags, lifting) Smith_normal_form_upt_k_condition1 a
        add_diff_cancel_right' cond1 from_nat_suc from_nat_to_nat_id less_SucE s)
next
  show "\<And>a b. to_nat a \<noteq> to_nat b \<and> (to_nat a < Suc k \<or> to_nat b < Suc k) \<Longrightarrow> A $ a $ b = 0"
    using d isDiagonal_def by blast
qed

end