(*
   Authors: Asta Halkjær From & Jørgen Villadsen, DTU Compute
*)

chapter \<open>Formalizing Wajsberg's Axioms for Propositional Logic\<close>

theory System_W imports Main begin

text \<open>All references are to Alonzo Church (1956): Introduction to Mathematical Logic\<close>

section \<open>Syntax / Axiomatics / Semantics\<close>

datatype form = Falsity (\<open>\<bottom>\<close>) | Pro nat | Imp form form (infix \<open>\<rightarrow>\<close> 0)

text \<open>Wajsberg 1937 building on work by Frege, Tarski and Bernays [Church page 159]\<close>

inductive Axiomatics (\<open>\<turnstile>\<close>) where
  \<open>\<turnstile> q\<close> if \<open>\<turnstile> p\<close> and \<open>\<turnstile> (p \<rightarrow> q)\<close> |
  \<open>\<turnstile> (p \<rightarrow> (q \<rightarrow> p))\<close> |
  \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close> |
  \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> p) \<rightarrow> p)\<close> |
  \<open>\<turnstile> (\<bottom> \<rightarrow> p)\<close>

abbreviation Truth (\<open>\<top>\<close>) where \<open>\<top> \<equiv> (\<bottom> \<rightarrow> \<bottom>)\<close>

theorem \<open>\<turnstile> \<top>\<close> using Axiomatics.intros(5) .

primrec semantics (infix \<open>\<Turnstile>\<close> 0) where
  \<open>(I \<Turnstile> \<bottom>) = False\<close> |
  \<open>(I \<Turnstile> (Pro n)) = I n\<close> |
  \<open>(I \<Turnstile> (p \<rightarrow> q)) = (if I \<Turnstile> p then I \<Turnstile> q else True)\<close>

theorem \<open>I \<Turnstile> p\<close> if \<open>\<turnstile> p\<close> using that by induct auto

definition \<open>valid p \<equiv> \<forall>I. (I \<Turnstile> p)\<close>

theorem \<open>valid p = \<turnstile> p\<close> oops \<comment> \<open>Proof at end\<close>

abbreviation (input) \<open>Neg p \<equiv> (p \<rightarrow> \<bottom>)\<close>

lemmas MP = Axiomatics.intros(1)
lemmas Imp1 = Axiomatics.intros(2)
lemmas Tran = Axiomatics.intros(3)
lemmas Clas = Axiomatics.intros(4)
lemmas Expl = Axiomatics.intros(5)

section \<open>Soundness\<close>

theorem soundness: \<open>\<turnstile> p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: Axiomatics.induct) auto

section \<open>Derived Rules\<close>

lemma Chu1: \<open>\<turnstile> ((p \<rightarrow> (p \<rightarrow> q)) \<rightarrow> (p \<rightarrow> q))\<close>
  by (meson Tran Clas MP)

lemma Chu2: \<open>\<turnstile> (p \<rightarrow> ((p \<rightarrow> q) \<rightarrow> q))\<close>
  by (meson Chu1 Imp1 Tran MP)

lemma Chu3: \<open>\<turnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close>
  by (meson Chu2 Tran MP)

lemma Chu4: \<open>\<turnstile> ((q \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  by (meson Chu3 Tran MP)

lemma Imp2: \<open>\<turnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  by (meson Chu4 Chu1 MP Chu3)

lemma Imp3: \<open>\<turnstile> (p \<rightarrow> p)\<close>
  by (meson Imp1 Tran Clas MP)

lemma Neg: \<open>\<turnstile> (((p \<rightarrow> \<bottom>) \<rightarrow> \<bottom>) \<rightarrow> p)\<close>
  by (meson Chu4 Clas Expl MP)

text \<open>Wajsberg 1939 building on work by Frege [Church page 163]\<close>

inductive FW (\<open>\<tturnstile>\<close>) where
  \<open>\<tturnstile> q\<close> if \<open>\<tturnstile> p\<close> and \<open>\<tturnstile> (p \<rightarrow> q)\<close> |
  \<open>\<tturnstile> (p \<rightarrow> (q \<rightarrow> p))\<close> |
  \<open>\<tturnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close> |
  \<open>\<tturnstile> (((p \<rightarrow> \<bottom>) \<rightarrow> \<bottom>) \<rightarrow> p)\<close>

theorem Axiomatics_FW: \<open>\<turnstile> p \<longleftrightarrow> \<tturnstile> p\<close>
proof
  have *: \<open>\<tturnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close> for p q r
    by (metis FW.intros(1-3))
  then have **: \<open>\<tturnstile> (((p \<rightarrow> q) \<rightarrow> p) \<rightarrow> p)\<close> for p q
    by (metis FW.intros(1-4))
  show \<open>\<turnstile> p\<close> if \<open>\<tturnstile> p\<close>
    using that by induct (use Imp1 Imp2 Neg Axiomatics.intros in meson)+
  show \<open>\<tturnstile> p\<close> if \<open>\<turnstile> p\<close>
    using that by induct (use * ** FW.intros in meson)+
qed

lemma Neg1: \<open>\<turnstile> (p \<rightarrow> (Neg p \<rightarrow> q))\<close>
  by (meson Chu3 Chu4 Expl MP)

lemma Neg2: \<open>\<turnstile> (Neg (p \<rightarrow> q) \<rightarrow> p)\<close>
  by (metis Neg1 Tran MP Neg)

lemma Neg3: \<open>\<turnstile> (Neg (p \<rightarrow> q) \<rightarrow> Neg q)\<close>
  by (metis Imp1 Tran MP)

primrec imply :: \<open>form list \<Rightarrow> form \<Rightarrow> form\<close> where
  \<open>imply [] q = q\<close>
| \<open>imply (p # ps) q = (p \<rightarrow> imply ps q)\<close>

lemma imply_head: \<open>\<turnstile> (imply (p # ps) p)\<close>
  by (induct ps) (simp add: Imp3, metis Imp1 Imp2 MP imply.simps(2))

lemma imply_Cons: \<open>\<turnstile> (imply ps q) \<Longrightarrow> \<turnstile> (imply (p # ps) q)\<close>
  by (metis Imp1 MP imply.simps(2))

lemma imply_mem: \<open>p \<in> set ps \<Longrightarrow> \<turnstile> (imply ps p)\<close>
  using imply_head imply_Cons by (induct ps) auto

lemma imply_MP: \<open>\<turnstile> (imply ps p \<rightarrow> (imply ps (p \<rightarrow> q) \<rightarrow> imply ps q))\<close>
proof (induct ps)
  case Nil
  then show ?case
    by (metis Imp1 Imp2 MP imply.simps(1))
next
  case (Cons r ps)
  then show ?case
  proof -
    have \<open>\<turnstile> ((r \<rightarrow> imply ps p) \<rightarrow> (r \<rightarrow> (imply ps (p \<rightarrow> q) \<rightarrow> imply ps q)))\<close>
      by (meson Cons.hyps Imp1 Imp2 MP)
    then have \<open>\<turnstile> ((r \<rightarrow> imply ps p) \<rightarrow> ((r \<rightarrow> imply ps (p \<rightarrow> q)) \<rightarrow> (r \<rightarrow> imply ps q)))\<close>
      by (meson Imp2 Tran MP)
    then show ?thesis
      by simp
  qed
qed

lemma imply_mp': \<open>\<turnstile> (imply ps p) \<Longrightarrow> \<turnstile> (imply ps (p \<rightarrow> q)) \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using imply_MP by (meson MP)

lemma add_imply: \<open>\<turnstile> q \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using imply_Cons by (induct ps) simp_all

lemma imply_append: \<open>imply (ps @ qs) r = imply ps (imply qs r)\<close>
  by (induct ps) simp_all

lemma imply_swap: \<open>\<turnstile> (imply (ps @ qs) r) \<Longrightarrow> \<turnstile> (imply (qs @ ps) r)\<close>
proof (induct qs arbitrary: ps)
  case (Cons q qs)
  then show ?case
    by (metis imply_Cons imply_head imply_mp' imply.simps(2) imply_append)
qed simp

lemma deduct: \<open>\<turnstile> (imply (p # ps) q) \<longleftrightarrow> \<turnstile> (imply ps (p \<rightarrow> q))\<close>
  using imply_swap by (metis imply.simps(1-2) imply_append)

theorem imply_weaken: \<open>\<turnstile> (imply ps q) \<Longrightarrow> set ps \<subseteq> set ps' \<Longrightarrow> \<turnstile> (imply ps' q)\<close>
proof (induct ps arbitrary: q)
  case (Cons p ps)
  note \<open>\<turnstile> (imply (p # ps) q)\<close>
  then have \<open>\<turnstile> (imply ps (p \<rightarrow> q))\<close>
    using deduct by blast
  then have \<open>\<turnstile> (imply ps' (p \<rightarrow> q))\<close>
    using Cons by simp
  then show ?case
    using Cons(3) by (meson imply_mem imply_mp' list.set_intros(1) subset_code(1))
qed (simp add: add_imply)

lemma cut: \<open>\<turnstile> (imply ps p) \<Longrightarrow> \<turnstile> (imply (p # ps) q) \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using deduct imply_mp' by blast

lemma imply4: \<open>\<turnstile> (imply (p # q # ps) r) \<Longrightarrow> \<turnstile> (imply (q # p # ps) r)\<close>
  by (metis Imp1 Imp2 MP imply.simps(2))

lemma cut': \<open>\<turnstile> (imply (p # ps) r) \<Longrightarrow> \<turnstile> (imply (q # ps) p) \<Longrightarrow> \<turnstile> (imply (q # ps) r)\<close>
  using imply_Cons cut imply4 by blast

lemma imply_lift: \<open>\<turnstile> (p \<rightarrow> q) \<Longrightarrow> \<turnstile> (imply ps p \<rightarrow> imply ps q)\<close>
proof (induct ps)
  case (Cons r ps)
  then show ?case
    by (metis MP Chu4 imply.simps(2))
qed simp

lemma Neg': \<open>\<turnstile> (imply ps (Neg (Neg p)) \<rightarrow> imply ps p)\<close>
  using Neg imply_lift by simp

lemma Boole: \<open>\<turnstile> (imply ((Neg p) # ps) \<bottom>) \<Longrightarrow> \<turnstile> (imply ps p)\<close>
  using deduct MP Neg' by blast

lemma imply_front: \<open>\<turnstile> (imply S p) \<Longrightarrow> set S - {q} \<subseteq> set S' \<Longrightarrow> \<turnstile> (imply (q # S') p)\<close>
  by (metis Diff_single_insert imply_weaken list.set(2))

section \<open>Consistent\<close>

definition consistent :: \<open>form set \<Rightarrow> bool\<close> where
  \<open>consistent S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> \<turnstile> (imply S' \<bottom>)\<close>

lemma UN_finite_bound:
  assumes \<open>finite A\<close> \<open>A \<subseteq> (\<Union>n. f n)\<close>
  shows \<open>\<exists>m :: nat. A \<subseteq> (\<Union>n \<le> m. f n)\<close>
  using assms
proof (induct rule: finite_induct)
  case (insert x A)
  then obtain m where \<open>A \<subseteq> (\<Union>n \<le> m. f n)\<close>
    by fast
  then have \<open>A \<subseteq> (\<Union>n \<le> (m + k). f n)\<close> for k
    by fastforce
  moreover obtain m' where \<open>x \<in> f m'\<close>
    using insert(4) by blast
  ultimately have \<open>{x} \<union> A \<subseteq> (\<Union>n \<le> m + m'. f n)\<close>
    by auto
  then show ?case
    by blast
qed simp

section \<open>Extension\<close>

primrec extend :: \<open>form set \<Rightarrow> (nat \<Rightarrow> form) \<Rightarrow> nat \<Rightarrow> form set\<close> where
  \<open>extend S f 0 = S\<close>
| \<open>extend S f (Suc n) =
    (if consistent ({f n} \<union> extend S f n)
     then {f n} \<union> extend S f n
     else extend S f n)\<close>

definition Extend :: \<open>form set \<Rightarrow> (nat \<Rightarrow> form) \<Rightarrow> form set\<close> where
  \<open>Extend S f \<equiv> \<Union>n. extend S f n\<close>

lemma Extend_subset: \<open>S \<subseteq> Extend S f\<close>
  unfolding Extend_def by (metis Union_upper extend.simps(1) range_eqI)

lemma extend_chain: \<open>extend S f n \<subseteq> extend S f (Suc n)\<close>
  by auto

lemma extend_bound: \<open>(\<Union>n \<le> m. extend S f n) = extend S f m\<close>
  by (induct m) (simp_all add: atMost_Suc)

lemma consistent_extend: \<open>consistent S \<Longrightarrow> consistent (extend S f n)\<close>
  by (induct n) simp_all

lemma consistent_Extend:
  assumes \<open>consistent S\<close>
  shows \<open>consistent (Extend S f)\<close>
  unfolding Extend_def
proof (rule ccontr)
  assume \<open>\<not> consistent (\<Union>n. extend S f n)\<close>
  then obtain S' where \<open>\<turnstile> (imply S' \<bottom>)\<close> \<open>set S' \<subseteq> (\<Union>n. extend S f n)\<close>
    unfolding consistent_def by blast
  then obtain m where \<open>set S' \<subseteq> (\<Union>n \<le> m. extend S f n)\<close>
    using UN_finite_bound by (metis List.finite_set)
  then have \<open>set S' \<subseteq> extend S f m\<close>
    using extend_bound by blast
  moreover have \<open>consistent (extend S f m)\<close>
    using assms consistent_extend by blast
  ultimately show False
    unfolding consistent_def using \<open>\<turnstile> (imply S' \<bottom>)\<close> by blast
qed

section \<open>Maximal\<close>

definition maximal :: \<open>form set \<Rightarrow> bool\<close> where
  \<open>maximal S \<equiv> \<forall>p. p \<notin> S \<longrightarrow> \<not> consistent ({p} \<union> S)\<close>

lemma maximal_Extend:
  assumes \<open>surj f\<close>
  shows \<open>maximal (Extend S f)\<close>
proof (rule ccontr)
  assume \<open>\<not> maximal (Extend S f)\<close>
  then obtain p where \<open>p \<notin> Extend S f\<close> \<open>consistent ({p} \<union> Extend S f)\<close>
    unfolding maximal_def using assms consistent_Extend by blast
  obtain n where n: \<open>f n = p\<close>
    using \<open>surj f\<close> unfolding surj_def by metis
  then have \<open>p \<notin> extend S f (Suc n)\<close>
    using \<open>p \<notin> Extend S f\<close> unfolding Extend_def by blast
  then have \<open>\<not> consistent ({p} \<union> extend S f n)\<close>
    using n by fastforce
  moreover have \<open>p \<notin> extend S f n\<close>
    using \<open>p \<notin> extend S f (Suc n)\<close> extend_chain by blast
  then have \<open>{p} \<union> extend S f n \<subseteq> {p} \<union> Extend S f\<close>
    unfolding Extend_def by blast
  ultimately have \<open>\<not> consistent ({p} \<union> Extend S f)\<close>
    unfolding consistent_def by fastforce
  then show False
    using \<open>consistent ({p} \<union> Extend S f)\<close> by blast
qed

section \<open>Hintikka\<close>

definition hintikka :: \<open>form set \<Rightarrow> bool\<close> where
  \<open>hintikka H \<equiv>
    \<bottom> \<notin> H \<and>
    (\<forall>n. Pro n \<in> H \<longrightarrow> (Neg (Pro n)) \<notin> H) \<and>
    (\<forall>p q. (p \<rightarrow> q) \<in> H \<longrightarrow> (Neg p) \<in> H \<or> q \<in> H) \<and>
    (\<forall>p q. (Neg (p \<rightarrow> q)) \<in> H \<longrightarrow> p \<in> H \<and> (Neg q) \<in> H)\<close>

abbreviation (input) \<open>model H n \<equiv> Pro n \<in> H\<close>

lemma hintikka_model: \<open>hintikka H \<Longrightarrow>
                        (p \<in> H \<longrightarrow> (model H \<Turnstile> p)) \<and> ((Neg p) \<in> H \<longrightarrow> \<not> (model H \<Turnstile> p))\<close>
  by (induct p) (simp; unfold hintikka_def, blast)+

lemma inconsistent_head:
  assumes \<open>maximal S\<close> \<open>consistent S\<close> \<open>p \<notin> S\<close>
  shows \<open>\<exists>S'. \<turnstile> (imply (p # S') \<bottom>) \<and> set S' \<subseteq> S\<close>
proof -
  obtain S' where S': \<open>\<turnstile> (imply S' \<bottom>)\<close> \<open>set S' \<subseteq> {p} \<union> S\<close> \<open>p \<in> set S'\<close>
    using assms unfolding maximal_def consistent_def by fast
  then obtain S'' where S'': \<open>\<turnstile> (imply (p # S'') \<bottom>)\<close> \<open>set S'' = set S' - {p}\<close>
    by (metis imply_front set_removeAll subset_refl)
  then show ?thesis
    using S'(2) by fast
qed

lemma hintikka_Extend:
  assumes \<open>maximal S\<close> \<open>consistent S\<close>
  shows \<open>hintikka S\<close>
  unfolding hintikka_def
proof safe
  assume \<open>\<bottom> \<in> S\<close>
  then show False
    using assms(2) imply_head unfolding consistent_def
    by (metis all_not_in_conv empty_set insert_subset list.simps(15) subsetI)
next
  fix n
  assume \<open>Pro n \<in> S\<close> \<open>(Neg (Pro n)) \<in> S\<close>
  moreover have \<open>\<turnstile> (imply [Pro n, Neg (Pro n)] \<bottom>)\<close>
    by (simp add: Neg1)
  ultimately show False
    using assms(2) unfolding consistent_def
    by (metis bot.extremum empty_set insert_subset list.set(2))
next
  fix p q
  assume *: \<open>(p \<rightarrow> q) \<in> S\<close> \<open>q \<notin> S\<close>
  then obtain Sq' where Sq': \<open>\<turnstile> (imply (q # Sq') \<bottom>)\<close> \<open>set Sq' \<subseteq> S\<close>
    using assms inconsistent_head by blast

  show \<open>(Neg p) \<in> S\<close>
  proof (rule ccontr)
    assume \<open>(Neg p) \<notin> S\<close>
    then obtain Sp' where Sp': \<open>\<turnstile> (imply ((Neg p) # Sp') \<bottom>)\<close> \<open>set Sp' \<subseteq> S\<close>
      using assms inconsistent_head by blast

    obtain S' where S': \<open>set S' = set Sp' \<union> set Sq'\<close>
      by (meson set_append)
    then have \<open>\<turnstile> (imply ((Neg p) # S') \<bottom>)\<close> \<open>\<turnstile> (imply (q # S') \<bottom>)\<close>
    proof -
      have \<open>set Sp' \<subseteq> set S'\<close>
        using S' by blast
      then show \<open>\<turnstile> (imply ((Neg p) # S') \<bottom>)\<close>
        by (metis Sp'(1) deduct imply_weaken)
      have \<open>set Sq' \<subseteq> set S'\<close>
        using S' by blast
      then show \<open>\<turnstile> (imply (q # S') \<bottom>)\<close>
        by (metis Sq'(1) deduct imply_weaken)
    qed
    then have \<open>\<turnstile> (imply ((p \<rightarrow> q) # S') \<bottom>)\<close>
      using Boole imply_Cons imply_head imply_mp' cut' by metis
    moreover have \<open>set ((p \<rightarrow> q) # S') \<subseteq> S\<close>
      using *(1) S' Sp'(2) Sq'(2) by auto
    ultimately show False
      using assms unfolding consistent_def by blast
  qed
next
  fix p q
  assume *: \<open>(Neg (p \<rightarrow> q)) \<in> S\<close>
  show \<open>p \<in> S\<close>
  proof (rule ccontr)
    assume \<open>p \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> (imply (p # S') \<bottom>)\<close> \<open>set S' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> (imply ((Neg (p \<rightarrow> q)) # S') p)\<close>
      using add_imply Neg2 deduct by blast
    ultimately have \<open>\<turnstile> (imply ((Neg (p \<rightarrow> q)) # S') \<bottom>)\<close>
      using cut' by blast
    moreover have \<open>set ((Neg (p \<rightarrow> q)) # S') \<subseteq> S\<close>
      using *(1) S'(2) by fastforce
    ultimately show False
      using assms unfolding consistent_def by blast
  qed
next
  fix p q
  assume *: \<open>(Neg (p \<rightarrow> q)) \<in> S\<close>
  show \<open>(Neg q) \<in> S\<close>
  proof (rule ccontr)
    assume \<open>(Neg q) \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> (imply ((Neg q) # S') \<bottom>)\<close> \<open>set S' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> (imply ((Neg (p \<rightarrow> q)) # S') (Neg q))\<close>
      using add_imply Neg3 deduct by blast
    ultimately have \<open>\<turnstile> (imply ((Neg (p \<rightarrow> q)) # S') \<bottom>)\<close>
      using cut' by blast
    moreover have \<open>set ((Neg (p \<rightarrow> q)) # S') \<subseteq> S\<close>
      using *(1) S'(2) by fastforce
    ultimately show False
      using assms unfolding consistent_def by blast
  qed
qed

section \<open>Countable Formulas\<close>

primrec diag :: \<open>nat \<Rightarrow> (nat \<times> nat)\<close> where
  \<open>diag 0 = (0, 0)\<close>
| \<open>diag (Suc n) =
     (let (x, y) = diag n
      in case y of
          0 \<Rightarrow> (0, Suc x)
        | Suc y \<Rightarrow> (Suc x, y))\<close>

theorem diag_le1: \<open>fst (diag (Suc n)) < Suc n\<close>
  by (induct n) (simp_all add: Let_def split_def split: nat.split)

theorem diag_le2: \<open>snd (diag (Suc (Suc n))) < Suc (Suc n)\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then show ?case
  proof (induct n')
    case 0
    then show ?case by simp
  next
    case (Suc _)
    then show ?case
      using diag_le1 by (simp add: Let_def split_def split: nat.split)
  qed
qed

theorem diag_le3: \<open>fst (diag n) = Suc x \<Longrightarrow> snd (diag n) < n\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then show ?case
  proof (induct n')
    case 0
    then show ?case by simp
  next
    case (Suc n'')
    then show ?case using diag_le2 by simp
  qed
qed

theorem diag_le4: \<open>fst (diag n) = Suc x \<Longrightarrow> x < n\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then have \<open>fst (diag (Suc n')) < Suc n'\<close>
    using diag_le1 by blast
  then show ?case using Suc by simp
qed

function undiag :: \<open>nat \<times> nat \<Rightarrow> nat\<close> where
  \<open>undiag (0, 0) = 0\<close>
| \<open>undiag (0, Suc y) = Suc (undiag (y, 0))\<close>
| \<open>undiag (Suc x, y) = Suc (undiag (x, Suc y))\<close>
  by pat_completeness auto
termination
  by (relation \<open>measure (\<lambda>(x, y). ((x + y) * (x + y + 1)) div 2 + x)\<close>) auto

theorem diag_undiag [simp]: \<open>diag (undiag (x, y)) = (x, y)\<close>
  by (induct rule: undiag.induct) simp_all

datatype btree = Leaf nat | Branch btree btree

function diag_btree :: \<open>nat \<Rightarrow> btree\<close> where
  \<open>diag_btree n = (case fst (diag n) of
       0 \<Rightarrow> Leaf (snd (diag n))
     | Suc x \<Rightarrow> Branch (diag_btree x) (diag_btree (snd (diag n))))\<close>
  by auto
termination
  by (relation \<open>measure id\<close>) (auto intro: diag_le3 diag_le4)

primrec undiag_btree :: \<open>btree \<Rightarrow> nat\<close> where
  \<open>undiag_btree (Leaf n) = undiag (0, n)\<close>
| \<open>undiag_btree (Branch t1 t2) = undiag (Suc (undiag_btree t1), undiag_btree t2)\<close>

theorem diag_undiag_btree [simp]: \<open>diag_btree (undiag_btree t) = t\<close>
  by (induct t) simp_all

declare diag_btree.simps [simp del] undiag_btree.simps [simp del]

fun form_of_btree :: \<open>btree \<Rightarrow> form\<close> where
  \<open>form_of_btree (Leaf 0) = Falsity\<close>
| \<open>form_of_btree (Branch (Leaf 0) (Leaf n)) = Pro n\<close>
| \<open>form_of_btree (Branch (Leaf (Suc 0)) (Branch t1 t2)) =
     Imp (form_of_btree t1) (form_of_btree t2)\<close>
| \<open>form_of_btree (Leaf (Suc _)) = undefined\<close>
| \<open>form_of_btree (Branch (Leaf 0) (Branch _ _)) = undefined\<close>
| \<open>form_of_btree (Branch (Leaf (Suc 0)) (Leaf _)) = undefined\<close>
| \<open>form_of_btree (Branch (Leaf (Suc (Suc _))) _) = undefined\<close>
| \<open>form_of_btree (Branch (Branch _ _) _) = undefined\<close>

primrec btree_of_form :: \<open>form \<Rightarrow> btree\<close> where
  \<open>btree_of_form Falsity = Leaf 0\<close>
| \<open>btree_of_form (Pro n) = Branch (Leaf 0) (Leaf n)\<close>
| \<open>btree_of_form (Imp p q) = Branch (Leaf (Suc 0))
     (Branch (btree_of_form p) (btree_of_form q))\<close>

definition diag_form :: \<open>nat \<Rightarrow> form\<close> where
  \<open>diag_form n = form_of_btree (diag_btree n)\<close>

definition undiag_form :: \<open>form \<Rightarrow> nat\<close> where
  \<open>undiag_form p = undiag_btree (btree_of_form p)\<close>

theorem diag_undiag_form [simp]: \<open>diag_form (undiag_form p) = p\<close>
  unfolding diag_form_def undiag_form_def by (induct p) simp_all

abbreviation \<open>from_nat \<equiv> diag_form\<close>
abbreviation \<open>to_nat \<equiv> undiag_form\<close>

lemma surj_from_nat: \<open>surj from_nat\<close>
  by (metis diag_undiag_form surj_def)

section \<open>Completeness\<close>

lemma imply_completeness:
  assumes valid: \<open>\<forall>I. list_all (\<lambda>q. (I \<Turnstile> q)) ps \<longrightarrow> (I \<Turnstile> p)\<close>
  shows \<open>\<turnstile> (imply ps p)\<close>
proof (rule ccontr)
  assume \<open>\<not> \<turnstile> (imply ps p)\<close>
  then have *: \<open>\<not> \<turnstile> (imply ((Neg p) # ps) \<bottom>)\<close>
    using Boole by blast

  let ?S = \<open>set ((Neg p) # ps)\<close>
  let ?H = \<open>Extend ?S from_nat\<close>

  have \<open>consistent ?S\<close>
    unfolding consistent_def using * imply_weaken by blast
  then have \<open>consistent ?H\<close> \<open>maximal ?H\<close>
    using consistent_Extend maximal_Extend surj_from_nat by blast+
  then have \<open>hintikka ?H\<close>
    using hintikka_Extend by blast

  have \<open>model ?H \<Turnstile> p\<close> if \<open>p \<in> ?S\<close> for p
    using that Extend_subset hintikka_model \<open>hintikka ?H\<close> by blast
  then have \<open>model ?H \<Turnstile> (Neg p)\<close> \<open>list_all (\<lambda>p. (model ?H \<Turnstile> p)) ps\<close>
    unfolding list_all_def by fastforce+
  then have \<open>model ?H \<Turnstile> p\<close>
    using valid by blast
  then show False
    using \<open>model ?H \<Turnstile> (Neg p)\<close> by simp
qed

theorem completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<turnstile> p\<close>
  using imply_completeness[where ps=\<open>[]\<close>] by simp

section \<open>Main Result\<close>

theorem main: \<open>valid p = \<turnstile> p\<close>
proof
  assume \<open>valid p\<close>
  with completeness show \<open>\<turnstile> p\<close>
    unfolding valid_def .
next
  assume \<open>\<turnstile> p\<close>
  with soundness show \<open>valid p\<close>
    unfolding valid_def by (intro allI)
qed

section \<open>Using Shortest Axiom for Implicational Logic - Łukasiewicz 1936/1937\<close>

text \<open>Łukasiewicz 1948 building on work by Wajsberg, Tarski and Bernays [Church page 159]\<close>

inductive WL (\<open>\<then>\<close>) where
  \<open>\<then> q\<close> if \<open>\<then> p\<close> and \<open>\<then> (p \<rightarrow> q)\<close> |
  \<open>\<then> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((r \<rightarrow> p) \<rightarrow> (s \<rightarrow> p)))\<close> |
  \<open>\<then> (\<bottom> \<rightarrow> p)\<close>

abbreviation (input) C :: \<open>form \<Rightarrow> form \<Rightarrow> form\<close> (\<open>C _ _\<close> [0, 0] 1) where \<open>(C p q) \<equiv> (p \<rightarrow> q)\<close>

lemma l1: \<open>\<then> (C C C p q r C C r p C s p)\<close>
  using WL.intros(2) .

lemma l2: \<open>\<then> (C C C C r p C s p C p q C r C p q)\<close>
  using l1 by (meson WL.intros(1))

lemma l3: \<open>\<then> (C C C r C p q C C r p C s p C t C C r p C s p)\<close>
  using l1 l2 by (meson WL.intros(1))

lemma l4: \<open>\<then> (C C C p q p C s p)\<close>
  using l3 l1 by (meson WL.intros(1))

lemma l5: \<open>\<then> (C C C s p C p q C r C p q)\<close>
  using l1 l4 by (meson WL.intros(1))

lemma l6: \<open>\<then> (C C C r C p q C s p C t C s p)\<close>
  using l1 l5 by (meson WL.intros(1))

lemma l7: \<open>\<then> (C C C t C s p C r C p q C u C r C p q)\<close>
  using l1 l6 by (meson WL.intros(1))

lemma l8: \<open>\<then> (C C C s q p C q p)\<close>
  using l7 l1 by (meson WL.intros(1))

lemma l9: \<open>\<then> (C r C C r p C s p)\<close>
  using l8 l1 by (meson WL.intros(1))

lemma l10: \<open>\<then> (C C C C C r q p C s p r C t r)\<close>
  using l1 l9 by (meson WL.intros(1))

lemma l11: \<open>\<then> (C C C t r C C C r q p C s p C u C C C r q p C s p)\<close>
  using l1 l10 by (meson WL.intros(1))

lemma l12: \<open>\<then> (C C C u C C C r q p C s p C t r C v C t r)\<close>
  using l1 l11 by (meson WL.intros(1))

lemma l13: \<open>\<then> (C C C v C t r C u C C C r q p C s p C w C u C C C r q p C s p)\<close>
  using l1 l12 by (meson WL.intros(1))

lemma l14: \<open>\<then> (C C C t r C s p C C C r q p C s p)\<close>
  using l13 l1 by (meson WL.intros(1))

lemma l15: \<open>\<then> (C C C r q C s p C C r p C s p)\<close>
  using l14 l1 by (meson WL.intros(1))

lemma l16: \<open>\<then> (C C r C s p C C C r q p C s p)\<close>
  using l15 l9 by (meson WL.intros(1))

lemma l17: \<open>\<then> (C C C C C p q r t C s p C C r p C s p)\<close>
  using l16 l1 by (meson WL.intros(1))

lemma l18: \<open>\<then> (C C C C r p C s p C C C p q r t C u C C C p q r t)\<close>
  using l1 l17 by (meson WL.intros(1))

lemma l19: \<open>\<then> (C C C C s p q C r p C C C p q r C s p)\<close>
  using l18 by (meson WL.intros(1))

lemma l20: \<open>\<then> (C C C C r p p C s p C C C p q r C s p)\<close>
  using l14 l19 by (meson WL.intros(1))

lemma l21: \<open>\<then> (C C C C p r q q C C q r C p r)\<close>
  using l20 l15 by (meson WL.intros(1))

lemma l22: \<open>\<then> (C p p)\<close>
  using l5 l4 by (meson WL.intros(1))

lemma l23: \<open>\<then> (C C C p q r C C r p p)\<close>
  using l20 l22 by (meson WL.intros(1))

lemma l24: \<open>\<then> (C r C C r p p)\<close>
  using l8 l23 by (meson WL.intros(1))

lemma l25: \<open>\<then> (C C p q C C C p r q q)\<close>
  using l15 l24 by (meson WL.intros(1))

lemma l26: \<open>\<then> (C C C C p q C C q r C p r C C C p r q q C C C p r q q)\<close>
  using l25 by (meson WL.intros(1))

lemma l27: \<open>\<then> (C p C q p)\<close>
  using l8 by (meson WL.intros(1))

lemma l28: \<open>\<then> (C C C p q p p)\<close>
  using l25 l22 by (meson WL.intros(1))

lemma l29: \<open>\<then> (C C p q C C q r C p r)\<close>
  using l21 l26 by (meson WL.intros(1))

theorem equivalence: \<open>\<then> p \<longleftrightarrow> \<turnstile> p\<close>
proof
  have *: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((r \<rightarrow> p) \<rightarrow> (s \<rightarrow> p)))\<close> for p q r s
    using completeness by simp
  show \<open>\<turnstile> p\<close> if \<open>\<then> p\<close>
    using that by induct (auto simp: * intro: Axiomatics.intros)
  show \<open>\<then> p\<close> if \<open>\<turnstile> p\<close>
    using that by induct (auto simp: l27 l28 l29 intro: WL.intros)
qed

end


theory Chapter4
imports "~~/src/HOL/IMP/ASM"
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

text{*
\section*{Chapter 4}

\exercise
Start from the data type of binary trees defined earlier:
*}

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

text{*
An @{typ "int tree"} is ordered if for every @{term "Node l i r"} in the tree,
@{text l} and @{text r} are ordered
and all values in @{text l} are @{text "< i"}
and all values in @{text r} are @{text "> i"}.
Define a function that returns the elements in a tree and one
the tests if a tree is ordered:
*}

fun set :: "'a tree \<Rightarrow> 'a set"  where
  "set Tip = {}" |
  "set (Node t1 n t2) = {n}\<union>(set t1)\<union>(set t2)"

value "set (Node (Node Tip 4 Tip) 7 (Node (Node Tip 7 Tip) (8::int) Tip))"

fun ord :: "int tree \<Rightarrow> bool"  where
  "ord Tip = True" |
  "ord (Node t1 n t2) = ((\<forall>y \<in> set t1. y \<le> n)\<and>(\<forall> y \<in> set t2. n \<le> y)\<and> ord t1 \<and> ord t2)"

value "ord (Node (Node Tip 2 Tip) 3 (Node (Node Tip 4 Tip) (5::int) Tip))"

text{* Hint: use quantifiers.

Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
while maintaining the order of the tree. If the element is already in the tree, the
same tree should be returned.
*}

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree"  where
  "ins m Tip = Node Tip m Tip" |
  "ins m (Node t1 n t2) =  (if m = n then Node t1 n t2
                            else if n > m then Node (ins m t1) n t2
                            else Node t1 n (ins m t2))"

value "ins 5  (Node (Node Tip 2 Tip) 3 (Node (Node Tip 4 Tip) (6::int) Tip))"
value "ord(ins 5  (Node (Node Tip 2 Tip) 3 (Node (Node Tip 4 Tip) (6::int) Tip)))"

text{* Prove correctness of @{const ins}: *}

lemma set_ins[simp]: "set(ins x t) = {x} \<union> set t"
  apply (induction t)
  apply auto
  done

theorem ord_ins: "ord t \<Longrightarrow> ord(ins i t)"
  apply (induction t arbitrary : i)
  apply auto
  done

text{*
\endexercise

\exercise
Formalize the following definition of palindromes
\begin{itemize}
\item The empty list and a singleton list are palindromes.
\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
\end{itemize}
as an inductive predicate
*}

inductive palindrome :: "'a list \<Rightarrow> bool" where
  "palindrome []" |
  "palindrome xs \<Longrightarrow> palindrome (a#xs@[a])"

text {* and prove *}

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
  apply (induction rule: palindrome.induct)
  apply simp_all
  done

text{*
\endexercise

\exercise
We could also have defined @{const star} as follows:
*}

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

text{*
The single @{text r} step is performer after rather than before the @{text star'}
steps. Prove
*}

text{*
You may need lemmas. Note that rule induction fails
if the assumption about the inductive predicate
is not the first assumption.
\endexercise

\exercise\label{exe:iter}
Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
all @{prop"i < n"}:
*}

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
 it0:"iter r 0 x x" |
 itS:"r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

text{*
Correct and prove the following claim:
*}

lemma "star r x y \<Longrightarrow> \<exists> n. iter r n x y"
  apply (induction rule: star.induct)
  apply (auto intro: it0 itS)
  done

text{*
\endexercise

\exercise\label{exe:cfg}
A context-free grammar can be seen as an inductive definition where each
nonterminal $A$ is an inductively defined predicate on lists of terminal
symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
For example, the production $S \to aSb$ can be viewed as the implication
@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
i.e., elements of some alphabet. The alphabet can be defined as a datatype:
*}

datatype alpha = a | b

text{*
If you think of @{const a} and @{const b} as ``@{text "("}'' and  ``@{text ")"}'',
the following two grammars both generate strings of balanced parentheses
(where $\varepsilon$ is the empty word):
\[
\begin{array}{r@ {\quad}c@ {\quad}l}
S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
T &\to& \varepsilon \quad\mid\quad TaTb
\end{array}
\]
Define them as inductive predicates and prove their equivalence:
*}

inductive S :: "alpha list \<Rightarrow> bool" where
  S0: "S []" |
  S1: "S w \<Longrightarrow> S (a # w @ [b])"|
  S2: "S w \<Longrightarrow> S x \<Longrightarrow> S (w @ x)"

inductive T :: "alpha list \<Rightarrow> bool" where
  T0: "T []" |
  T1: "T w \<Longrightarrow> T x \<Longrightarrow> T (w @ [a] @ x @ [b])"

lemma TS: "T w \<Longrightarrow> S w"
  apply (induction rule: T.induct)
  apply (auto intro: S0 S1 S2)
  done

lemma comm_T: "T x \<Longrightarrow> T w \<Longrightarrow> T (w @ x)"
  apply (induction rule: T.induct)
  apply (simp)
  apply (metis T1 append_assoc)
  done

lemma ST: "S w \<Longrightarrow> T w"
  apply (induction rule: S.induct)
  apply (simp add: T0)
  apply (metis T0 T1 append_Cons append_Nil)
  apply (auto intro: comm_T)
  done
corollary SeqT: "S w \<longleftrightarrow> T w"
  apply (auto simp add: TS ST)
  done

text{*
\endexercise
*}
(* your definition/proof here *)
text{*
\exercise
In Chapter 3 we defined a recursive evaluation function
@{text "aval ::"} @{typ "aexp \<Rightarrow> state \<Rightarrow> val"}.
Define an inductive evaluation predicate and prove that it agrees with
the recursive function:
*}

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
(* your definition/proof here *)

lemma aval_rel_aval: "aval_rel a s v \<Longrightarrow> aval a s = v"
(* your definition/proof here *)

lemma aval_aval_rel: "aval a s = v \<Longrightarrow> aval_rel a s v"
(* your definition/proof here *)

corollary "aval_rel a s v \<longleftrightarrow> aval a s = v"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Consider the stack machine from Chapter~3
and recall the concept of \concept{stack underflow}
from Exercise~\ref{exe:stack-underflow}.
Define an inductive predicate
*}

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
(* your definition/proof here *)

text{*
such that @{text "ok n is n'"} means that with any initial stack of length
@{text n} the instructions @{text "is"} can be executed
without stack underflow and that the final stack has length @{text n'}.

Using the introduction rules for @{const ok},
prove the following special cases: *}

lemma "ok 0 [LOAD x] (Suc 0)"
(* your definition/proof here *)

lemma "ok 0 [LOAD x, LOADI v, ADD] (Suc 0)"
(* your definition/proof here *)

lemma "ok (Suc (Suc 0)) [LOAD x, ADD, ADD, LOAD y] (Suc (Suc 0))"
(* your definition/proof here *)

text {* Prove that @{text ok} correctly computes the final stack size: *}

lemma "\<lbrakk>ok n is n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"
(* your definition/proof here *)

text {*
Prove that instruction sequences generated by @{text comp}
cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
some suitable value of @{text "?"}.
\endexercise
*}

end


theory Chapter2
imports Main
begin

text{*
\section*{Chapter 2}

\exercise
Use the \textbf{value} command to evaluate the following expressions:

 "1 + (2::nat)"
 "1 + (2::int)"
 "1 - (2::nat)"
 "1 - (2::int)"
 "[a,b] @ [c,d]"

\endexercise
*}

value  "1 + (2::nat)"

value "1 + (2::int)"

value "1 - (2::nat)"

value "1 - (2::int)"

value "[a,b] @ [c,d]"

text{*
\exercise

Recall the definition of our own addition function on @{typ nat}:
*}

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

text{*
Prove that @{const add} is associative and commutative.
You will need additional lemmas.
*}

lemma add_assoc : "add (add m n) p = add m (add n p)"
  apply (induction m)
  apply auto
  done

lemma add_aux1 [simp] : "n = add n 0"
  apply (induction n)
  apply auto
  done

lemma add_aux2 [simp] : "Suc (add n m) = add n (Suc m)"
  apply (induction n)
  apply auto
  done
lemma add_comm: "add m n = add n m"
  apply (induction m)
  apply auto
  done

text{* Define a recursive function *}

fun double :: "nat \<Rightarrow> nat" where
"double 0 = 0" |
"double (Suc n) = Suc (Suc (double n))"
text{* and prove that *}

lemma double_add: "double m = add m m"
  apply (induction m)
  apply auto
  done

text{*
\endexercise
*}

text{*
\exercise
Define a function that counts the number of occurrences of
an element in a list:
*}

fun count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
"count [] x = 0" |
"count (x#xs) y = (if x = y then (1+ count xs y) else (count xs y))"

text {*
Test your definition of @{term count} on some examples.
Prove the following inequality:
*}

theorem "count xs x \<le> length xs"
  apply (induction xs)
  apply auto
  done

text{*
\endexercise

\exercise
Define a function @{text snoc} that appends an element to the end of a list.
Do not use the existing append operator @{text "@"} for lists.
*}

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

text {*
Convince yourself on some test cases that your definition
of @{term snoc} behaves as expected.
With the help of @{text snoc} define a recursive function @{text reverse}
that reverses a list. Do not use the predefined function @{const rev}.
*}

value "snoc [1,2,3] (4::int)"

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse [] = []" |
  "reverse (x#xs) =  snoc (reverse xs) x"

text {*
Prove the following theorem. You will need an additional lemma.
*}

value "reverse [1,2,3,(4::int)]"
value "reverse [(4::int)]"

\exercise
The aim of this exercise is to prove the summation formula
\[ \sum_{i=0}^{n}i = \frac{n(n+1)}{2} \]
Define a recursive function @{text "sum_upto n = 0 + ... + n"}:
*}

fun sum_upto :: "nat \<Rightarrow> nat" where
  "sum_upto 0 = 0" |
  "sum_upto n = n + sum_upto (n-1)"

text {*
Now prove the summation formula by induction on @{text "n"}.
First, write a clear but informal proof by hand following the examples
in the main text. Then prove the same property in Isabelle:
*}

lemma "sum_upto n = n * (n+1) div 2"
  apply (induction n)
  apply auto
  done

text{*
\endexercise

\exercise
Starting from the type @{text "'a tree"} defined in the text, define
a function that collects all values in a tree in a list, in any order,
without removing duplicates.
*}
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
  "contents Tip = []" |
  "contents (Node l a r) = a#(contents l @ contents r)"

text{*
Then define a function that sums up all values in a tree of natural numbers
*}

fun sum_tree :: "nat tree \<Rightarrow> nat" where
  "sum_tree Tip = 0" |
  "sum_tree (Node l a r) = a + sum_tree l + sum_tree r"

text{* and prove *}

lemma "sum_tree t = sum_list(contents t)"
  apply (induction t)
  apply auto
  done

text{*
\endexercise

\exercise
Define a new type @{text "'a tree2"} of binary trees where values are also
stored in the leaves of the tree.  Also reformulate the
@{text mirror} function accordingly. Define two functions *}

datatype 'a tree2 = Tip 'a | Node "'a tree2" 'a "'a tree2"

fun mirror :: "'a tree2 \<Rightarrow> 'a tree2" where
  "mirror (Tip a) = Tip a" |
  "mirror (Node l a r) = Node (mirror r) a (mirror l)"

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
  "pre_order (Tip a) = [a]" |
  "pre_order (Node l a r) = a # (pre_order l @ pre_order r)"

fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
  "post_order (Tip a) = [a]" |
  "post_order (Node l a r) = (post_order l) @ (post_order r) @ [a]"

text{*
    3
   /\
  4  7
 /\  /\
1 2  0 4
*}

value "rev (post_order (Node (Node (Tip 1) 4 (Tip 2)) 3 (Node (Tip 0) 7 (Tip (4::int)))))"
value "pre_order (mirror (Node (Node (Tip 1) 4 (Tip 2)) 3 (Node (Tip 0) 7 (Tip (4::int)))))"

text{*
that traverse a tree and collect all stored values in the respective order in
a list. Prove *}

lemma "pre_order (mirror t) = rev (post_order t)"
  apply (induction t)
  apply auto
  done

text{*
\endexercise

\exercise
Define a recursive function
*}

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "intersperse a [] = [a]" |
  "intersperse a (x#xs) = x#a#(intersperse a xs)"

text{*
such that @{text "intersperse a [x\<^sub>1, ..., x\<^sub>n] = [x\<^sub>1, a, x\<^sub>2, a, ..., a, x\<^sub>n]"}.
Prove
*}

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction xs)
  apply auto
  done

text{*
\endexercise

\exercise
Write a tail-recursive variant of the @{text add} function on @{typ nat}:
*}

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "itadd 0 n = n" |
  "itadd (Suc m) n = itadd m (Suc n)"

text{*
Tail-recursive means that in the recursive case, @{const itadd} needs to call
itself directly: \mbox{@{term"itadd (Suc m) n"}} @{text"= itadd \<dots>"}.
Prove
*}

lemma "itadd m n = add m n"
  apply (induction m arbitrary:n)
  apply auto
  done

text{*
\endexercise

\exercise\label{exe:tree0}
Define a datatype @{text tree0} of binary tree skeletons which do not store
any information, neither in the inner nodes nor in the leaves.
Define a function that counts the number of all nodes (inner nodes and leaves)
in such a tree:
*}

datatype tree0 = Tip | Node tree0 tree0

fun nodes :: "tree0 \<Rightarrow> nat" where
 "nodes Tip = 1" |
 "nodes (Node l r) = 1 + (nodes l) + (nodes r)"

text {*
Consider the following recursive function:
*}

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t = t" |
"explode (Suc n) t = explode n (Node t t)"

text {*
Experiment how @{text explode} influences the size of a binary tree
and find an equation expressing the size of a tree after exploding it
(\noquotes{@{term [source] "nodes (explode n t)"}}) as a function
of @{term "nodes t"} and @{text n}. Prove your equation.
You may use the usual arithmetic operations including the exponentiation
operator ``@{text"^"}''. For example, \noquotes{@{prop [source] "2 ^ 2 = 4"}}.

Hint: simplifying with the list of theorems @{thm[source] algebra_simps}
takes care of common algebraic properties of the arithmetic operators.
\endexercise
*}

text{*
  /\
 /\ /\
*}
value "explode 1 (Node (Node Tip Tip) (Node Tip Tip))"

fun size_exp :: "tree0 \<Rightarrow> nat \<Rightarrow> nat" where
  "size_exp t k = 2^k*(nodes t) + (2^k-1)"

value "size_exp (Node (Node Tip Tip) (Node Tip Tip)) 4 =
  nodes (explode 4 (Node (Node Tip Tip) (Node Tip Tip)))"

lemma " nodes (explode n t) = size_exp t n "
  apply (induction n arbitrary:t)
  apply (auto simp add: algebra_simps)
  done
text{*

\exercise
Define arithmetic expressions in one variable over integers (type @{typ int})
as a data type:
*}

datatype exp = Var | Const int | Add exp exp | Mult exp exp

text{*
Define a function @{text eval} that evaluates an expression at some value:
*}

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "eval Var x = x" |
  "eval (Const a) x = a" |
  "eval (Add a b) x = eval a x + eval b x" |
  "eval (Mult a b) x = eval a x * eval b x"

text{*
For example, @{prop"eval (Add (Mult (Const 2) Var) (Const 3)) i = 2*i+3"}.

A polynomial can be represented as a list of coefficients, starting with
the constant. For example, @{term "[4, 2, -1, 3::int]"} represents the
polynomial $4 + 2x - x^2 + 3x^3$.
Define a function @{text evalp} that evaluates a polynomial at a given value:
*}

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "evalp [] a = 0" |
  "evalp (x # xs) a = x + a * evalp xs a"

value "evalp [4,2,-1,3::int] 2"

text{*
Define a function @{text coeffs} that transforms an expression into a polynomial.
This will require auxiliary functions.
*}

value "Add (Const (3::int)) (Mult (Const (3::int)) Var)"

(* Funciones auxiliares *)

fun suma :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"suma [] xs = xs" |
"suma xs [] = xs" |
"suma (x # xs) (y # ys) = (x + y) # suma xs ys"

fun escal_prod :: "int \<Rightarrow> int list \<Rightarrow> int list" where
"escal_prod k [] = []" |
"escal_prod k (x # xs) = k * x # escal_prod k xs"

fun mult :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"mult [] xs = []" |
"mult (x # xs) ys = suma (escal_prod x ys) (0 # mult xs ys)"

(* Función coeficientes *)

fun coeffs :: "exp \<Rightarrow> int list" where
"coeffs Var = [0, 1]" |
"coeffs (Const k) = [k]" |
"coeffs (Add p q) = suma (coeffs p) (coeffs q)" |
"coeffs (Mult p q) = mult (coeffs p) (coeffs q)"

value "coeffs (Add (Const (3::int)) (Mult (Const (3::int)) Var))"

text{*
Prove that @{text coeffs} preserves the value of the expression:
*}

lemma evalp_additive[simp]: "evalp (suma xs ys) a = evalp xs a + evalp ys a"
  apply (induction rule:suma.induct)
  apply (auto simp add:Int.int_distrib)
  done

lemma eval_preserves_mult[simp]: "evalp (escal_prod x ys) a = x * evalp ys a"
apply (induction ys)
apply (auto simp add:Int.int_distrib)
done

lemma evalp_multiplicative[simp]: "evalp (mult xs ys) a = (evalp xs a) * (evalp ys a)"
apply (induction xs)
apply (auto simp add:Int.int_distrib)
done

theorem evalp_coeffs: "evalp (coeffs e) x = eval e x"
  apply (induction e)
  apply auto
  done
text{*
Hint: consider the hint in Exercise~\ref{exe:tree0}.
\endexercise
*}

end


theory HW3
  imports Complex
begin

text {* 1(a): The product of an odd and even integer is even. *}

lemma "even (e::int) \<Longrightarrow> odd s \<Longrightarrow> even (e * s)"
proof-
  fix e:: int and s
  assume "even e"
  then obtain k where "2*k = e"
    using evenE by auto
  then have "e * s = (2*k)*s" by simp
  moreover have "\<dots> = 2 * (k*s)" by simp
  moreover have "even \<dots>" by auto
  ultimately show "even (e*s)" by auto
qed

text {* 1(b): If r is a rational number and p is an irrational number, then r+p is irrational. *}

lemma rewrite1:
  fixes q1 q2 r1 r2 :: int
  assumes n0: "q2 \<noteq>0" "r2\<noteq>0"
  shows "q1/q2-r1/r2 = (q1*r2-r1*q2)/(q2*r2)" (is ?goal)
proof -
  have "q1/q2 - r1/r2 = q1*r2 / (q2*r2) - (r1*q2)/(q2*r2)" using n0 by simp
  moreover have "\<dots> = (q1*r2-r1*q2)/(q2*r2)" by (simp add: diff_divide_distrib)
  ultimately show ?goal by linarith
qed

abbreviation rational :: "real \<Rightarrow> bool" where
  "rational n \<equiv> \<exists>(p::int) (q::int). n = p / q \<and> q\<noteq>0 "

lemma
  assumes r:"rational r"
    and p:" \<not>(rational p)"
  shows " \<not>(rational (r+p))"
proof
  from r obtain r1::int and r2::int where 1:"r = r1/r2" "r2\<noteq>0" using of_int_0 by blast
  assume "rational (r+p)"
  hence "rational (r1/r2+p)" using 1 by simp
  then obtain q1::int and q2::int where 2:"r1/r2+p = q1/q2" "q2\<noteq>0" using of_int_0 by blast
  hence "p = q1/q2-r1/r2" by simp
  hence "p = (q1*r2-r1*q2)/(q2*r2)" using `q2 \<noteq> 0` `r2 \<noteq> 0` rewrite1 by auto
  moreover have "(q2*r2)\<noteq>0" using `q2 \<noteq> 0` `r2 \<noteq> 0` by auto
  ultimately have "rational p" using of_int_0 by fastforce
  thus False using p by simp
qed

text {* 1(c): If r is a rational number and p is an irrational number, then rp is irrational*}
text {* To prove this, we need r\<noteq>0 *}

lemma
  assumes r: "rational r" and "r\<noteq>0"
    and p: "\<not>(rational p)"
  shows "\<not>(rational (r * p))"
proof
  from r obtain r1::int and r2::int where 1:"r = r1/r2" "r2\<noteq>0" using of_int_0 by blast
  hence "r1\<noteq>0" using `r\<noteq>0` by auto
  assume "rational (r*p)"
  hence "rational (r1*p/r2)" using 1 by simp
  then obtain q1::int and q2::int where 2:"r1*p/r2 = q1/q2" "q2\<noteq>0" using of_int_0 by blast
  hence "r1 * p / r2 * r2 = q1 / q2 * r2" by auto
  hence "r1 * p = q1 / q2 * r2" using 1 by auto
  hence "r1*p/r1 = q1/q2*r2/r1" using `q2 \<noteq> 0` `r2 \<noteq> 0` by auto
  hence "p = q1/q2*r2/r1" using `r1\<noteq>0` by auto
  hence "p = (q1*r2)/(q2*r1)" by auto
  moreover have "q2*r1 \<noteq> 0" using `q2\<noteq>0` `r1\<noteq>0` by auto
  ultimately have "rational p"
    using of_int_eq_0_iff by blast
  thus False using p by auto
qed

text {* 1(d): If 7x+9 is even, then x is odd *}

lemma
assumes 1: "even (7*x+9)" shows "odd (x::int)"
proof
  assume "even x"
  hence "even (7*x)" by auto
  hence "odd (7*x+9)" by auto
  thus False using 1 by auto
qed

text {* 1(e): For all real numbers, max(a, max(b,c)) = max(max(a,b), c) *}
lemma
  fixes a::real and b::real and c::real
  shows "max a (max b c) = max (max a b) c"
  by(unfold max_def, auto)

text {* 4: A \<union> (A \<inter> B) = A *}

lemma "A \<union> (A \<inter> B) = A"
proof
  show " A \<union> A \<inter> B \<subseteq> A"
  proof
    fix x assume "x \<in> A \<union> A \<inter> B"
    thus "x \<in> A" by auto
  qed
next
  text {* Similarly... *}
  show "A \<subseteq> A \<union> A \<inter> B" by auto
qed

text {* 5: *}

lemma "\<exists>x. \<forall>y. P x y \<longleftrightarrow> \<not>(P y y) \<Longrightarrow> False" (is "?A \<Longrightarrow> False")
proof-
  assume "?A"
  then obtain x where 1: "\<forall>y. P x y \<longleftrightarrow> \<not>(P y y)" by blast
  hence "P x x \<longleftrightarrow> \<not>(P x x)" by blast
  thus False by auto
qed


chapter\<open>The Theory of Binary Decision Trees (BDT) \<close>

theory   BDT
imports  Main
begin

type_synonym var = nat

type_synonym "interpretation" = "var \<Rightarrow> bool"

fun    list2interpretation :: "'a list \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"
where "list2interpretation [] d = (\<lambda> x. d)"
     |"list2interpretation (a # m) d = (\<lambda> x. case x of
                                     0 \<Rightarrow> a
                                   | Suc n \<Rightarrow>  list2interpretation m d n )"

(* definition  interpl where "interpl l = list2interpretation l True" *)
definition  Ifalse ("I\<^sub>\<bottom>") where "I\<^sub>\<bottom>  = (\<lambda> x::nat . False)"
definition  Itrue  ("I\<^sub>\<top>") where "I\<^sub>\<top>  = (\<lambda> x::nat . True)"

section\<open>Basic structures and notations\<close>

type_synonym atom = bool

datatype     bdt  = Atom  atom  | IF  var bdt bdt

text \<open> Notations \<close>

syntax        "_topt"  :: "bdt"   ("topt")
translations  "topt" == "(CONST Atom) (CONST True)"

syntax        "_bott"        :: "bdt"   ("bott")
translations  "bott" == "(CONST Atom) (CONST False)"

definition    var   where "var n = IF n topt bott"

subsection \<open> Semantics \<close>

fun "interpret":: "bdt \<Rightarrow> interpretation \<Rightarrow>  bool" ("I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>_\<rbrakk> _")
where "I\<^sub>b\<^sub>d\<^sub>t\<lbrakk>Atom a\<rbrakk> \<gamma> = a"
     |"I\<^sub>b\<^sub>d\<^sub>t\<lbrakk>IF x P Q\<rbrakk> \<gamma> = (if \<gamma> x then I\<^sub>b\<^sub>d\<^sub>t\<lbrakk>P\<rbrakk>\<gamma> else I\<^sub>b\<^sub>d\<^sub>t\<lbrakk>Q\<rbrakk>\<gamma>)"

(** tests *)
thm BDT.interpret.simps

definition Pt where "Pt \<equiv> (IF (0::nat) (IF 1 topt topt) (IF 1 topt topt))"

value "I\<^sub>\<bottom>"

value "I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>Pt\<rbrakk>  I\<^sub>\<bottom> "
value "I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>Pt\<rbrakk> I\<^sub>\<bottom>"
value "(I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>Pt\<rbrakk> (list2interpretation [True,False] True) )"
value "(I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>Pt\<rbrakk> (list2interpretation [False,True] False) )"

(* Trivial equality to be used for rewriting *)

lemma interpret_If :  "interpret  (IF x P Q) I =   (if I x then interpret P I
                                                           else interpret Q I)"
  by simp

lemma interpret_true [simp]:
  "I x \<Longrightarrow> interpret (IF x P Q) I  = interpret P I " by simp

lemma interpret_false [simp]:
  "\<not>I x \<Longrightarrow> interpret (IF x P Q) I = interpret Q I " by simp

section\<open> Logical operations on BDT \<close>

fun    neg :: "bdt \<Rightarrow> bdt"
where "neg (Atom a) =  Atom (\<not> a)"
     |"neg (IF x l r) = IF x (neg l) (neg r)"

find_theorems name:BDT.neg

lemma negt_corr : "I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>neg P\<rbrakk> I = (\<not> I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>P\<rbrakk> I)"
  apply(rule BDT.neg.induct)
  by auto

section\<open>BinaryCombination.\<close>

fun comb where
    comb_a_a  :"comb opn (Atom a) (Atom b)  = Atom (opn a b)"
   |comb_a_if :"comb opn (Atom a) (IF x l r) = IF x (comb opn (Atom a) l) (comb opn (Atom a) r)"
   |comb_if_a :"comb opn (IF x l r) (Atom b) = IF x (comb opn l (Atom b)) (comb opn r (Atom b))"
   |comb_if_if:"comb opn (IF x l r) (IF y l' r') =
                  (if x < y then  IF x (comb opn l (IF y l' r')) (comb opn r (IF y l' r'))
                            else if y < x then IF y (comb opn (IF x l r) l')(comb opn (IF x l r) r')
                                          else IF x (comb opn l l') (comb opn r r'))"
find_theorems name:comb

definition opn where "opn x y \<equiv> x \<or> y"

value "comb opn (Atom True) (Atom False)"

(*
Comparison with Coq: the following intuitive definition is not directly accepted
Fixpoint bint (t u: bdt) : bdt :=
  match t with
     Atomt a =>  match u with Atomt b => Atomt (op a b)
                           |  IFt x l r => IFt x (bint t l) (bint t r)
                 end
   | IFt x l r => match u with Atomt b => IFt x (bint l u) (bint r u)
                             |  IFt y l' r' => match nat_compare x y with
                                 Lt => IFt x (bint l u) (bint r u)
                                |Eq => IFt x (bint l l') (bint r r')
                                |Gt => IFt y (bint t l') (bint t r') end
                  end
  end.
*)

(* This works in Isabelle without splitting in two fixpoints.  *)

lemma comb_eq : "comb opn (IF x l r) (IF x l' r') = (IF x (comb opn l l') (comb opn r r'))"
  by(clarsimp)

lemma comb_le : "x < y \<Longrightarrow> comb opn (IF x l r) (IF y l' r')
                           = (IF x (comb opn l (IF y l' r')) (comb opn r (IF y l' r')))"
  by(simp)

lemma comb_ge : "y < x \<Longrightarrow> comb opn (IF x l r) (IF y l' r')
                           = IF y (comb opn (IF x l r) l') (comb opn (IF x l r) r')"
  by(simp)

(** Instantiation on standard boolean operations *)
definition "and"  where "and  = comb (\<and>)"
definition or     where "or   = comb (\<or>)"
definition impl   where "impl = comb (\<longrightarrow>)"

(** formula examples *)

definition p0   where "p0       = var 0"
definition p1   where "p1       = var 1"
definition P0   where "P0       = impl p0 p1"
definition P1   where "P1       = impl p1 P0"
definition dneg where "dneg P Q = impl (impl P Q) Q"
definition P2   where "P2       = dneg P0 p0"

value "P1"
value "P2"

(* examples for complicated proofs involving nested inductions ... *)
lemma comb_correct : "(I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>comb f P Q\<rbrakk> \<gamma>) = f (I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>P\<rbrakk> \<gamma>) (I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>Q\<rbrakk> \<gamma>)"
apply(rule_tac x=Q in spec)
apply(induct_tac P)
 apply(rule allI, rename_tac x Q, induct_tac Q)
 apply simp_all
apply(rename_tac "v" "x2" "x3")
apply(case_tac "\<gamma> v", simp_all)
 apply(rule allI)
 apply(rename_tac "v" "x2" "x3" "Q")
 apply(induct_tac Q)
  apply simp_all
 apply blast
apply(rule allI)
apply(rename_tac "v" "x2" "x3" "Q")
apply(induct_tac Q)
 apply simp_all
by blast

text\<open> ... and the same as structured proof \<close>

lemma comb_correct' : "(I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>comb f P Q\<rbrakk> I) = f (I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>P\<rbrakk> I) (I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>Q\<rbrakk> I)"
proof(induct P arbitrary: Q)
   case (Atom a) show ?case by(induct_tac Q, simp_all)
next
   fix v::nat fix P1 P2 Q
   assume hyp1 : "\<And>Q. interpret (comb f P1 Q) I  = f (interpret P1 I) (interpret Q I)"
   and    hyp2 : "\<And>Q. interpret (comb f P2 Q) I  = f (interpret P2 I) (interpret Q I)"
   show "interpret (comb f (IF v P1 P2) Q) I = f (interpret (IF v P1 P2) I ) (interpret Q I )"
        (is "?lhs = ?rhs")
     txt\<open>this is a pattern-matching against the above ``show'' defining @{term "?lhs"} \<close>
      apply simp
      proof(cases "I v", simp_all) txt\<open> you might try here @{command print_cases} to check the
                                        environment of local assumptions here ... \<close>
         case True show "?lhs = f (interpret P1 I ) (interpret Q I)"
            txt \<open> the fact @{thm True} is here just a name for the assumption @{term "I v"} \<close>
            apply(induct Q)
            apply(simp_all add: hyp1 hyp2 True)
            using True by blast
      next
         case False show "?lhs = f (interpret P2 I ) (interpret Q I)"
            apply(induct Q)
            apply(simp_all add: hyp1 hyp2 False)
            using False by blast
      qed
qed
text\<open> The advantages of this format are:
      \<^enum> proof and sub-proof structures were made explicit;
        if one sub-proof breaks during development, the other
        sub-proofs may still be valid. Structured proofs are therefore
        more stable under development as apply-style proofs, allow for a
        faster impact-analysis under change and
        can be evaluated in parallel --- the user profits even in short-term.
      \<^enum> The Isabelle community therefore encourages structured proofs.
      \<^enum> Major recurring proof patterns (induction with generalization,
        case-distinctions etc.) were made explicit which makes this
        proof format readable even for non-Isabelle users. (Well, sort of...)
      \<^enum> The notational burden to re-declare (abstractions of) the current proof state
        when entering a sub-proof can be alleviated by using case-notation and
        patterns from previous re-declarations. Note that the order of re-declaration
        is arbitrary.
\<close>

lemma or_correct   : "I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>or P Q\<rbrakk> \<gamma> = (I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>P\<rbrakk> \<gamma>  \<or> I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>Q\<rbrakk> \<gamma>)"
by (simp add: BDT.or_def comb_correct)

lemma and_correct  : "I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>and P Q\<rbrakk> \<gamma>  = (I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>P\<rbrakk> \<gamma>  \<and> I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>Q\<rbrakk> \<gamma> )"
by (simp add: BDT.and_def comb_correct)

lemma impl_correct : "I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>impl P Q\<rbrakk> \<gamma>  = (I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>P\<rbrakk> \<gamma>  \<longrightarrow> I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>Q\<rbrakk> \<gamma> )"
by (simp add: BDT.impl_def comb_correct)

primrec    exist\<^sub>v\<^sub>a\<^sub>r :: "var \<Rightarrow> bdt \<Rightarrow> bdt"
where     "exist\<^sub>v\<^sub>a\<^sub>r x (Atom a) = (Atom a)" (* x does not occur in t *)
         |"exist\<^sub>v\<^sub>a\<^sub>r x (IF y l r) = (if x < y then (IF y l r) (* x does not occur in t *)
                                            else if y > x then IF y (exist\<^sub>v\<^sub>a\<^sub>r x l) (exist\<^sub>v\<^sub>a\<^sub>r x r)
                                                          else or l r)"

text\<open>Hint: ``fun'' does not work here (at least not without providing a non-trivial termination
     ordering) since it chooses the lexicographic ordering as default ... \<close>

(** ordered n i t : all variables x in t are increasing on branches and i <= x < n *)

(* a completer: *)
inductive ordered :: "nat \<Rightarrow> nat \<Rightarrow> bdt \<Rightarrow> bool"
where     Oatom : "ordered x y (Atom a)"
         |Oif   : "i \<le> x \<and> x < n
                   \<Longrightarrow> ordered n x l
                   \<Longrightarrow> ordered n x r
                   \<Longrightarrow> ordered n i (IF x l r)"

(* or alternative: *)

fun ordered' :: "nat \<Rightarrow> nat \<Rightarrow> bdt \<Rightarrow> bool"
  where  "ordered' x y (Atom a) = True"
        |"ordered' n i (IF x l r) = (if i \<le> x \<and> x < n
                                      then ordered' n x l \<and> ordered' n x r
                                      else False)"

(* for fun *)
fun     fv :: "bdt \<Rightarrow> nat set"
where  "fv (Atom a) = {}"
      |"fv (IF x l r) = {x} \<union> fv l \<union> fv r"

lemma fv_neg : "fv(neg t) = fv t"
proof(induct t)
case (Atom x)
then show ?case by simp
next
  case (IF x1a t1 t2)
  then show ?case  by simp
qed

(* for fun *)
lemma fv_comb[simp]: "fv(comb f l r) = fv l \<union> fv r"
proof(induct l arbitrary: r)
  case (Atom x)
  then show ?case
     proof(induct r)
       case (Atom x)
       then show ?case by simp
     next
       case (IF x1a r1 r2)
       then show ?case by simp
     qed
next
  case (IF x1a l1 l2)
  then show ?case
     proof(induct r)
       case (Atom x)
       then show ?case by simp
     next
       case (IF x1b r1 r2)
       then show ?case
            apply(cases "x1a < x1b") apply simp apply blast
            apply(cases "x1b < x1a", simp_all)
            apply(simp add: Un_left_commute inf_sup_aci(6) insert_commute)
            by blast
     qed
   qed

find_theorems name:BDT
find_theorems name:BDT.neg
find_theorems name:BDT.ordered

lemma neg_ordered_inv : "ordered n i P \<Longrightarrow> ordered n i (neg P)"
  apply(induct P)
   apply(simp add: Oatom)
  by (smt bdt.inject(2) neg.simps(1) neg.simps(2) order.trans ordered.simps)
  sorry

lemma XXX : "ordered n x l \<Longrightarrow> ordered n x (comb f l (Atom a))"
  apply(rule neg.induct)
   apply(simp add : Oatom)
  sorry

lemma XXX' : "ordered n x r \<Longrightarrow> ordered n x (comb f (Atom a) r)"
  apply(induct r)
   apply (simp add: Oatom)
  sorry

lemma "ordered n i P \<Longrightarrow> ordered n i Q \<Longrightarrow> ordered n i (comb f P Q)"
  sorry
  (* difficult nested induction; one has to provide useful non-obvious geeralizations. *)

lemma "ordered n i t \<Longrightarrow> (x < i \<or> n <= x) \<Longrightarrow>  I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>t\<rbrakk> (I(x:= b)) = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>t\<rbrakk> I"
  sorry
(* a completer ; main structure: induction over ordered_ness or t. *)

lemma exists_correct :
"ordered n i t \<Longrightarrow> interpret (exist\<^sub>v\<^sub>a\<^sub>r x t) I
                   = ( (interpret  t ( I(x := True)) \<or> (interpret t ( I(x:= False)) )) )"
  sorry

(** * Using BDT to encode sets of states and do symbolic model-checking *)

(** We start from a (finite) problem where states depend on a set of boolean variables x0..x(n-1)
    Each state is represented as a formula over these variables corresponding to a bdt ordered between
    0 and n.
    Each set of states can also be represented by a formula over the same variables
    (takes the disjunction of all sets)

    The transition system is represented by a formula with 2n variables corresponding to the values
    before (x_i) and after (x_(n+i)).
       - A single transition between state Gi(x_0,..,x_(n-1)) and Gj(x_0,..,x_(n-1))
    becomes a formula T_(ij)(x_0,..,x_(2n-1))=G1(x_0,..,x_(n-1))/\G2(x_n,..,x_(2n-1))
    The transition system is a formula T(x_0,..,x_(2n-1))
    corresponding to the disjonction of all transitions.

    We can now compute a set of states leading to a set of situations R in k or less steps
        R_0=R
        R_(i+1)(x_0,..x_(n-1)) =
          R_i(x_0,..x_(n-1))\/exists xn,..,x_(2n-1), T(x_0,..,x_(2n-1))/\R_i(x_n,..x_(2n-1))
    We will reach a fixpoint after a finite number of steps that is a solution of our problems.

    Of course the efficiency of this method depends on a more efficient representation of bdt
    using reduced bdd,  sharing mechanisms and computation with memoization.
*)

end


theory Ex2_3
  imports Main
begin

datatype tree = Tp | Nd tree tree

primrec tips :: "tree \<Rightarrow> nat " where
  "tips Tp = 1"|
  "tips (Nd l r) = op + (tips l) (tips r)"

primrec height :: "tree \<Rightarrow> nat" where
  "height Tp = 0"|
  "height (Nd l r) = 1 +  max (height l) (height r)"

primrec cbt :: "nat \<Rightarrow> tree" where
  "cbt 0 = Tp"|
  "cbt (Suc n) = (let tmp = (cbt n) in Nd tmp tmp)"

primrec iscbt :: " (tree \<Rightarrow> 'a) \<Rightarrow> tree  \<Rightarrow> bool" where
  "iscbt f Tp = True"|
  "iscbt f (Nd l r) = (iscbt f l \<and> iscbt f r \<and> (f l = f r))"

lemma helper1 : "iscbt height t \<Longrightarrow>  tips t = 2 ^ height t" by  (induction t, simp_all)

lemma helper1_arith : fixes n::nat and m::nat shows  "((2 ^ n :: nat) = (2 ^ m)) = (n = m)" by simp

theorem main1 : "iscbt height t = iscbt tips t"
proof (induction t)
  case Tp
  then show ?case by simp
next
  case (Nd t1 t2)
  assume h1:"iscbt height t1 = iscbt tips t1"
    and h2:"iscbt height t2 = iscbt tips t2"
  show ?case
  proof (cases "iscbt height (Nd t1 t2)")
    case True
    assume c1:"iscbt height (Nd t1 t2)"
    show ?thesis
    proof (cases "iscbt tips (Nd t1 t2)")
      case True
      with c1 show ?thesis by simp
    next
      case False
      assume c2:"\<not> iscbt tips (Nd t1 t2)"
      from c1 have tmp:"height t1 = height t2" by simp
      from c1 have tmp2:"iscbt height t1" by simp
      from c1 have tmp3:"iscbt height t2" by simp
      then have tmp4:"tips t2 = 2 ^ height t2" by (rule helper1[of t2])

      have  "iscbt tips (Nd t1 t2) = (iscbt tips t1 \<and> iscbt tips t2 \<and> (tips t1 = tips t2))"  by simp
      also have "\<dots> = (iscbt height t1 \<and> iscbt height t2 \<and> (tips t1 = tips t2))" using h1 h2 by simp
      also have "\<dots> = (iscbt height t1 \<and> iscbt height t2 \<and> (2 ^ height t1 = tips t2 ))" using helper1[of t1]  tmp2  by simp
      also have "\<dots> = (iscbt height t1 \<and> iscbt height t2 \<and> (2 ^ height t1 = (2 ^ height t2 :: nat)))" by (subst tmp4, rule refl)
      also have  "\<dots> = (iscbt height t1 \<and> iscbt height t2 \<and> (height t1 = height t2 ))" by (simp add : helper1_arith)
      also have "\<dots> = True" using tmp tmp2 tmp3 by simp
      finally have False using c2 by simp
      then show ?thesis by (rule FalseE)
    qed
  next
    case False
    assume c1:"\<not> iscbt height (Nd t1 t2)"
    then show ?thesis
    proof (cases "iscbt tips (Nd t1 t2)")
      case True
      then show ?thesis using h1 h2 helper1 by simp
    next
      case False
      then show ?thesis using c1 by auto
    qed
  qed
qed

lemma helper1_tips : "tips t > 0 " by (induction t, simp_all)

lemma helper2 : "iscbt tips t \<Longrightarrow> size t = tips t  - 1"
proof (induction t)
  case Tp
  then show ?case by simp
next
  case (Nd t1 t2)
  assume hyp1:"iscbt tips t1 \<Longrightarrow> size t1 = tips t1 - 1"
    and hyp2:"iscbt tips t2 \<Longrightarrow> size t2 = tips t2 - 1"
    and hyp3:"iscbt tips (Nd t1 t2)"
  from hyp3 have tmp1:"iscbt tips t1" by simp
  from hyp3 have tmp2:"iscbt tips t2" by simp
  from tmp1 and hyp1 have tmp4:"size t1 = tips t1 - 1" by simp
  from tmp2 and hyp2 have tmp5:"size t2 = tips t2 - 1" by simp
  have "size (Nd t1 t2) = 1 + size t1 + size t2" by simp
  also  have "\<dots> = 1 + (tips t1 - 1) + (tips t2 - 1)" using tmp4 tmp5 by simp
  finally show ?case using helper1_tips
  by (metis One_nat_def Suc_pred add_Suc add_Suc_right add_cancel_right_left diff_Suc_1 tips.simps(2))
qed

theorem main2 :"iscbt tips t= iscbt size t"
proof (induction t)
  case Tp
  then show ?case by simp
next
  case (Nd t1 t2)
  assume hyp1:"iscbt tips t1 = iscbt size t1"
    and hyp2:"iscbt tips t2 = iscbt size t2"
  then show ?case using helper2 proof (cases "iscbt tips (Nd t1 t2)")
    case True
    assume c1:"iscbt tips (Nd t1 t2)"
    show ?thesis
    proof (cases "iscbt size (Nd t1 t2)")
      case True
      then show ?thesis using c1 by simp
    next
      case False
      then show ?thesis using hyp1 hyp2 helper2 by auto
    qed
  next
    case False
    assume c1:"\<not> iscbt tips (Nd t1 t2)"
    show ?thesis
    proof (cases "iscbt size (Nd t1 t2)")
      case True
      assume c2:"iscbt size (Nd t1 t2)"
      with  hyp1 have tmp1:"iscbt tips t1" by simp
      from c2 and hyp2 have tmp2:"iscbt tips t2" by simp

      have tmp3:"size t1 = tips t1 - 1" using tmp1 helper2 by simp
      have tmp4:"size t2 = tips t2 - 1" using tmp2 helper2 by simp

      have "size t1 = size t2" using c2 by simp

      with tmp3 tmp4 have "tips t1 - 1= tips t2 - 1" using c2  by simp
      hence "tips t1 = tips t2" using helper1_tips[of t1] helper1_tips[of t2] by simp
      then show  ?thesis using tmp1 tmp2 hyp1 hyp2 helper2 by simp
    next
      case False
      then show ?thesis using c1 by auto
    qed
  qed
qed

theorem main3 :"iscbt height t = iscbt size t" using main1 main2 by simp

theorem main4: "iscbt height (cbt n)"
  using [[simp_trace_new mode=full]]
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  assume hyp:"iscbt height (cbt n)"
  have " iscbt height (cbt (Suc n)) = iscbt height ((let tmp = (cbt n) in Nd tmp tmp))" by simp
  also have "\<dots> = iscbt height (Nd (cbt n) (cbt n))" by (simp only : Let_def)
  finally  show ?case using hyp by simp
qed

theorem "iscbt size (cbt n)" using main4 main3 by simp

theorem "iscbt tips (cbt n)" using main4 main1 by simp

theorem "iscbt f (cbt n)" by (induction n; simp add : Let_def)

theorem "iscbt height t \<Longrightarrow> t = (cbt (height t))"  by (induction t; simp add : Let_def)
thm cong
theorem "iscbt (\<lambda> x . True) \<noteq>  iscbt size"
proof (rule notI)
  assume h1:" iscbt (\<lambda>x. True) = iscbt size"
  let ?tmp = "Nd (Nd Tp Tp) Tp"
  have "?tmp = ?tmp" by (rule refl)
  with h1 have " iscbt (\<lambda>x. True) ?tmp = iscbt size ?tmp" by (rule cong)
  thus False by simp
qed

github-repos/isabelle/SvenWille-ExerciseSolutions_New/ExerciseSolutions_New-b8243e7a669846c64e2f5520dae88ff41265d233/Isabelle/2. Trees and other inductive data types/Ex2_3.thy


(* ---------------------------------------------------------------------------- *)
subsection \<open>Vectors and Matrices in $\mathbb{C}^2$\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Representing vectors and matrices of arbitrary dimensions pose a challenge in formal theorem
proving \<^cite>\<open>"harrison05"\<close>, but we only need to consider finite dimension spaces $\mathbb{C}^2$ and
$\mathbb{R}^3$.\<close>

theory Matrices
imports More_Complex Linear_Systems Quadratic
begin

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Vectors in $\mathbb{C}^2$\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Type of complex vector\<close>

type_synonym complex_vec = "complex \<times> complex"

definition vec_zero :: "complex_vec" where
  [simp]: "vec_zero = (0, 0)"

text \<open>Vector scalar multiplication\<close>

fun mult_sv :: "complex \<Rightarrow> complex_vec \<Rightarrow> complex_vec" (infixl "*\<^sub>s\<^sub>v" 100) where
  "k *\<^sub>s\<^sub>v (x, y) = (k*x, k*y)"

lemma fst_mult_sv [simp]:
  shows "fst (k *\<^sub>s\<^sub>v v) = k * fst v"
  by (cases v) simp

lemma snd_mult_sv [simp]:
  shows "snd (k *\<^sub>s\<^sub>v v) = k * snd v"
  by (cases v) simp

lemma mult_sv_mult_sv [simp]:
  shows "k1 *\<^sub>s\<^sub>v (k2 *\<^sub>s\<^sub>v v) = (k1*k2) *\<^sub>s\<^sub>v v"
  by (cases v) simp

lemma one_mult_sv [simp]:
  shows "1 *\<^sub>s\<^sub>v v =  v"
  by (cases v) simp

lemma mult_sv_ex_id1 [simp]:
  shows "\<exists> k::complex. k \<noteq> 0 \<and> k *\<^sub>s\<^sub>v v = v"
  by (rule_tac x=1 in exI, simp)

lemma mult_sv_ex_id2 [simp]:
  shows "\<exists> k::complex. k \<noteq> 0 \<and> v = k *\<^sub>s\<^sub>v v"
  by (rule_tac x=1 in exI, simp)

text \<open>Scalar product of two vectors\<close>

fun mult_vv :: "complex \<times> complex \<Rightarrow> complex \<times> complex \<Rightarrow> complex" (infixl "*\<^sub>v\<^sub>v" 100) where
 "(x, y) *\<^sub>v\<^sub>v (a, b) = x*a + y*b"

lemma mult_vv_commute:
  shows "v1 *\<^sub>v\<^sub>v v2 = v2 *\<^sub>v\<^sub>v v1"
  by (cases v1, cases v2) auto

lemma mult_vv_scale_sv1:
  shows "(k *\<^sub>s\<^sub>v v1) *\<^sub>v\<^sub>v v2 = k * (v1 *\<^sub>v\<^sub>v v2)"
  by (cases v1, cases v2) (auto simp add: field_simps)

lemma mult_vv_scale_sv2:
  shows "v1 *\<^sub>v\<^sub>v (k *\<^sub>s\<^sub>v v2) = k * (v1 *\<^sub>v\<^sub>v v2)"
  by (cases v1, cases v2) (auto simp add: field_simps)

text \<open>Conjugate vector\<close>

fun vec_map where
 "vec_map f (x, y) = (f x, f y)"

definition vec_cnj where
  "vec_cnj = vec_map cnj"

lemma vec_cnj_vec_cnj [simp]:
  shows "vec_cnj (vec_cnj v) = v"
  by (cases v) (simp add: vec_cnj_def)

lemma cnj_mult_vv:
  shows "cnj (v1 *\<^sub>v\<^sub>v v2) = (vec_cnj v1) *\<^sub>v\<^sub>v (vec_cnj v2)"
  by (cases v1, cases v2) (simp add: vec_cnj_def)

lemma vec_cnj_sv [simp]:
  shows "vec_cnj (k *\<^sub>s\<^sub>v A) = cnj k *\<^sub>s\<^sub>v vec_cnj A"
  by (cases A) (auto simp add: vec_cnj_def)

lemma scalsquare_vv_zero:
  shows "(vec_cnj v) *\<^sub>v\<^sub>v v = 0 \<longleftrightarrow> v = vec_zero"
  apply (cases v)
  apply (auto simp add: vec_cnj_def field_simps complex_mult_cnj_cmod power2_eq_square)
  apply (metis (no_types) norm_eq_zero of_real_0 of_real_add of_real_eq_iff of_real_mult sum_squares_eq_zero_iff)+
  done

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Matrices in $\mathbb{C}^2$\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Type of complex matrices\<close>

type_synonym complex_mat = "complex \<times> complex \<times> complex \<times> complex"

text \<open>Matrix scalar multiplication\<close>

fun mult_sm :: "complex \<Rightarrow> complex_mat \<Rightarrow> complex_mat" (infixl "*\<^sub>s\<^sub>m" 100) where
  "k *\<^sub>s\<^sub>m (a, b, c, d) = (k*a, k*b, k*c, k*d)"

lemma mult_sm_distribution [simp]:
  shows "k1 *\<^sub>s\<^sub>m (k2 *\<^sub>s\<^sub>m A) = (k1*k2) *\<^sub>s\<^sub>m A"
  by (cases A) auto

lemma mult_sm_neutral [simp]:
  shows "1 *\<^sub>s\<^sub>m A = A"
  by (cases A) auto

lemma mult_sm_inv_l:
  assumes "k \<noteq> 0" and "k *\<^sub>s\<^sub>m A = B"
  shows "A = (1/k) *\<^sub>s\<^sub>m B"
  using assms
  by auto

lemma mult_sm_ex_id1 [simp]:
  shows "\<exists> k::complex. k \<noteq> 0 \<and> k *\<^sub>s\<^sub>m M = M"
  by (rule_tac x=1 in exI, simp)

lemma mult_sm_ex_id2 [simp]:
  shows "\<exists> k::complex. k \<noteq> 0 \<and> M = k *\<^sub>s\<^sub>m M"
  by (rule_tac x=1 in exI, simp)

text \<open>Matrix addition and subtraction\<close>

definition mat_zero :: "complex_mat" where [simp]: "mat_zero = (0, 0, 0, 0)"

fun mat_plus :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex_mat" (infixl "+\<^sub>m\<^sub>m" 100) where
  "mat_plus (a1, b1, c1, d1) (a2, b2, c2, d2) = (a1+a2, b1+b2, c1+c2, d1+d2)"

fun mat_minus :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex_mat" (infixl "-\<^sub>m\<^sub>m" 100) where
  "mat_minus (a1, b1, c1, d1) (a2, b2, c2, d2) = (a1-a2, b1-b2, c1-c2, d1-d2)"

fun mat_uminus :: "complex_mat \<Rightarrow> complex_mat" where
  "mat_uminus (a, b, c, d) = (-a, -b, -c, -d)"

lemma nonzero_mult_real:
  assumes "A \<noteq> mat_zero" and "k \<noteq> 0"
  shows "k *\<^sub>s\<^sub>m A \<noteq> mat_zero"
  using assms
  by (cases A) simp

text \<open>Matrix multiplication.\<close>

fun mult_mm :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex_mat" (infixl "*\<^sub>m\<^sub>m" 100) where
  "(a1, b1, c1, d1) *\<^sub>m\<^sub>m (a2, b2, c2, d2) =
   (a1*a2 + b1*c2, a1*b2 + b1*d2, c1*a2+d1*c2, c1*b2+d1*d2)"

lemma mult_mm_assoc:
  shows "A *\<^sub>m\<^sub>m (B *\<^sub>m\<^sub>m C) = (A *\<^sub>m\<^sub>m B) *\<^sub>m\<^sub>m C"
  by (cases A, cases B, cases C) (auto simp add: field_simps)

lemma mult_assoc_5:
  shows "A *\<^sub>m\<^sub>m (B *\<^sub>m\<^sub>m C *\<^sub>m\<^sub>m D) *\<^sub>m\<^sub>m E = (A *\<^sub>m\<^sub>m B) *\<^sub>m\<^sub>m C *\<^sub>m\<^sub>m (D *\<^sub>m\<^sub>m E)"
  by (simp only: mult_mm_assoc)

lemma mat_zero_r [simp]:
  shows "A *\<^sub>m\<^sub>m mat_zero = mat_zero"
  by (cases A) simp

lemma mat_zero_l [simp]:
  shows "mat_zero *\<^sub>m\<^sub>m A = mat_zero"
  by (cases A) simp

definition eye :: "complex_mat" where
  [simp]: "eye = (1, 0, 0, 1)"

lemma mat_eye_l:
  shows "eye *\<^sub>m\<^sub>m A = A"
  by (cases A) auto

lemma mat_eye_r:
  shows "A *\<^sub>m\<^sub>m eye = A"
  by (cases A) auto

lemma mult_mm_sm [simp]:
  shows "A *\<^sub>m\<^sub>m (k *\<^sub>s\<^sub>m B) = k *\<^sub>s\<^sub>m (A *\<^sub>m\<^sub>m B)"
  by (cases A, cases B) (simp add: field_simps)

lemma mult_sm_mm [simp]:
  shows "(k *\<^sub>s\<^sub>m A) *\<^sub>m\<^sub>m B = k *\<^sub>s\<^sub>m (A *\<^sub>m\<^sub>m B)"
  by (cases A, cases B) (simp add: field_simps)

lemma mult_sm_eye_mm [simp]:
  shows "k *\<^sub>s\<^sub>m eye *\<^sub>m\<^sub>m A = k *\<^sub>s\<^sub>m A"
  by (cases A) simp

text \<open>Matrix determinant\<close>

fun mat_det where "mat_det (a, b, c, d) = a*d - b*c"

lemma mat_det_mult [simp]:
  shows "mat_det (A *\<^sub>m\<^sub>m B) = mat_det A * mat_det B"
  by (cases A, cases B) (auto simp add: field_simps)

lemma mat_det_mult_sm [simp]:
  shows "mat_det (k *\<^sub>s\<^sub>m A) = (k*k) * mat_det A"
  by (cases A) (auto simp add: field_simps)

text \<open>Matrix inverse\<close>

fun mat_inv :: "complex_mat \<Rightarrow> complex_mat" where
  "mat_inv (a, b, c, d) = (1/(a*d - b*c)) *\<^sub>s\<^sub>m (d, -b, -c, a)"

lemma mat_inv_r:
  assumes "mat_det A \<noteq> 0"
  shows "A *\<^sub>m\<^sub>m (mat_inv A) = eye"
  using assms
proof (cases A, auto simp add: field_simps)
  fix a b c d :: complex
  assume "a * (a * (d * d)) + b * (b * (c * c)) = a * (b * (c * (d * 2)))"
  hence "(a*d - b*c)*(a*d - b*c) = 0"
    by (auto simp add: field_simps)
  hence *: "a*d - b*c = 0"
    by auto
  assume "a*d \<noteq> b*c"
  with * show False
    by auto
qed

lemma mat_inv_l:
  assumes "mat_det A \<noteq> 0"
  shows "(mat_inv A) *\<^sub>m\<^sub>m A  = eye"
  using assms
proof (cases A, auto simp add: field_simps)
  fix a b c d :: complex
  assume "a * (a * (d * d)) + b * (b * (c * c)) = a * (b * (c * (d * 2)))"
  hence "(a*d - b*c)*(a*d - b*c) = 0"
    by (auto simp add: field_simps)
  hence *: "a*d - b*c = 0"
    by auto
  assume "a*d \<noteq> b*c"
  with * show False
    by auto
qed

lemma mat_det_inv:
  assumes "mat_det A \<noteq> 0"
  shows "mat_det (mat_inv A) = 1 / mat_det A"
proof-
  have "mat_det eye = mat_det A * mat_det (mat_inv A)"
    using mat_inv_l[OF assms, symmetric]
    by simp
  thus ?thesis
    using assms
    by (simp add: field_simps)
qed

lemma mult_mm_inv_l:
  assumes "mat_det A \<noteq> 0" and "A *\<^sub>m\<^sub>m B = C"
  shows "B = mat_inv A *\<^sub>m\<^sub>m C"
  using assms mat_eye_l[of B]
  by (auto simp add: mult_mm_assoc mat_inv_l)

lemma mult_mm_inv_r:
  assumes "mat_det B \<noteq> 0" and "A *\<^sub>m\<^sub>m B = C"
  shows "A = C *\<^sub>m\<^sub>m mat_inv B"
  using assms mat_eye_r[of A]
  by (auto simp add: mult_mm_assoc[symmetric] mat_inv_r)

lemma mult_mm_non_zero_l:
  assumes "mat_det A \<noteq> 0" and "B \<noteq> mat_zero"
  shows "A *\<^sub>m\<^sub>m B \<noteq> mat_zero"
  using assms mat_zero_r
  using mult_mm_inv_l[OF assms(1), of B mat_zero]
  by auto

lemma mat_inv_mult_mm:
  assumes "mat_det A \<noteq> 0" and "mat_det B \<noteq> 0"
  shows "mat_inv (A *\<^sub>m\<^sub>m B) = mat_inv B *\<^sub>m\<^sub>m mat_inv A"
  using assms
proof-
  have "(A *\<^sub>m\<^sub>m B) *\<^sub>m\<^sub>m (mat_inv B *\<^sub>m\<^sub>m mat_inv A) = eye"
    using assms
    by (metis mat_inv_r mult_mm_assoc mult_mm_inv_r)
  thus ?thesis
    using mult_mm_inv_l[of "A *\<^sub>m\<^sub>m B" "mat_inv B *\<^sub>m\<^sub>m mat_inv A" eye] assms mat_eye_r
    by simp
qed

lemma mult_mm_cancel_l:
  assumes "mat_det M \<noteq> 0"  "M *\<^sub>m\<^sub>m A = M *\<^sub>m\<^sub>m B"
  shows "A = B"
  using assms
  by (metis mult_mm_inv_l)

lemma mult_mm_cancel_r:
  assumes "mat_det M \<noteq> 0"  "A *\<^sub>m\<^sub>m M = B *\<^sub>m\<^sub>m M"
  shows "A = B"
  using assms
  by (metis mult_mm_inv_r)

lemma mult_mm_non_zero_r:
  assumes "A \<noteq> mat_zero" and "mat_det B \<noteq> 0"
  shows "A *\<^sub>m\<^sub>m B \<noteq> mat_zero"
  using assms mat_zero_l
  using mult_mm_inv_r[OF assms(2), of A mat_zero]
  by auto

lemma mat_inv_mult_sm:
  assumes "k \<noteq> 0"
  shows "mat_inv (k *\<^sub>s\<^sub>m A) = (1 / k) *\<^sub>s\<^sub>m mat_inv A"
proof-
  obtain a b c d where "A = (a, b, c, d)"
    by (cases A) auto
  thus ?thesis
    using assms
    by auto (subst mult.assoc[of k a "k*d"], subst mult.assoc[of k b "k*c"], subst right_diff_distrib[of k "a*(k*d)" "b*(k*c)", symmetric], simp, simp add: field_simps)+
qed

lemma mat_inv_inv [simp]:
  assumes "mat_det M \<noteq> 0"
  shows "mat_inv (mat_inv M) = M"
proof-
  have "mat_inv M *\<^sub>m\<^sub>m M = eye"
    using mat_inv_l[OF assms]
    by simp
  thus ?thesis
    using assms mat_det_inv[of M]
    using mult_mm_inv_l[of "mat_inv M" M eye] mat_eye_r
    by (auto simp del: eye_def)
qed

text \<open>Matrix transpose\<close>

fun mat_transpose where
  "mat_transpose (a, b, c, d) = (a, c, b, d)"

lemma mat_t_mat_t [simp]:
  shows "mat_transpose (mat_transpose A) = A"
  by (cases A) auto

lemma mat_t_mult_sm [simp]:
  shows "mat_transpose (k *\<^sub>s\<^sub>m A) = k *\<^sub>s\<^sub>m (mat_transpose A)"
  by (cases A) simp

lemma mat_t_mult_mm [simp]:
  shows "mat_transpose (A *\<^sub>m\<^sub>m B) = mat_transpose B *\<^sub>m\<^sub>m mat_transpose A"
  by (cases A, cases B) auto

lemma mat_inv_transpose:
  shows "mat_transpose (mat_inv M) = mat_inv (mat_transpose M)"
  by (cases M) auto

lemma mat_det_transpose [simp]:
  fixes M :: "complex_mat"
  shows "mat_det (mat_transpose M) = mat_det M"
  by (cases M) auto

text \<open>Diagonal matrices definition\<close>

fun mat_diagonal where
 "mat_diagonal (A, B, C, D) = (B = 0 \<and> C = 0)"

text \<open>Matrix conjugate\<close>

fun mat_map where
 "mat_map f (a, b, c, d) = (f a, f b, f c, f d)"

definition mat_cnj where
  "mat_cnj = mat_map cnj"

lemma mat_cnj_cnj [simp]:
  shows "mat_cnj (mat_cnj A) = A"
  unfolding mat_cnj_def
  by (cases A) auto

lemma mat_cnj_sm [simp]:
  shows "mat_cnj (k *\<^sub>s\<^sub>m A) = cnj k *\<^sub>s\<^sub>m (mat_cnj A)"
  by (cases A) (simp add: mat_cnj_def)

lemma mat_det_cnj [simp]:
  shows "mat_det (mat_cnj A) = cnj (mat_det A)"
  by (cases A) (simp add: mat_cnj_def)

lemma nonzero_mat_cnj:
  shows "mat_cnj A = mat_zero \<longleftrightarrow> A = mat_zero"
  by (cases A) (auto simp add: mat_cnj_def)

lemma mat_inv_cnj:
  shows "mat_cnj (mat_inv M) = mat_inv (mat_cnj M)"
  unfolding mat_cnj_def
  by (cases M) auto

text \<open>Matrix adjoint - the conjugate traspose matrix ($A^* = \overline{A^t}$)\<close>

definition mat_adj where
  "mat_adj A = mat_cnj (mat_transpose A)"

lemma mat_adj_mult_mm [simp]:
  shows "mat_adj (A *\<^sub>m\<^sub>m B) = mat_adj B *\<^sub>m\<^sub>m mat_adj A"
  by (cases A, cases B) (auto simp add: mat_adj_def mat_cnj_def)

lemma mat_adj_mult_sm [simp]:
  shows "mat_adj (k *\<^sub>s\<^sub>m A) = cnj k *\<^sub>s\<^sub>m mat_adj A"
  by (cases A) (auto simp add: mat_adj_def mat_cnj_def)

lemma mat_det_adj:
  shows "mat_det (mat_adj A) = cnj (mat_det A)"
  by (cases A) (auto simp add: mat_adj_def mat_cnj_def)

lemma mat_transpose_mat_cnj:
  shows "mat_transpose (mat_cnj A) = mat_adj A"
  by (cases A)  (auto simp add: mat_adj_def mat_cnj_def)

lemma mat_adj_adj [simp]:
  shows "mat_adj (mat_adj A) = A"
  unfolding mat_adj_def
  by (subst mat_transpose_mat_cnj) (simp add: mat_adj_def)

lemma mat_adj_eye [simp]:
  shows "mat_adj eye = eye"
  by (auto simp add: mat_adj_def mat_cnj_def)

text \<open>Matrix trace\<close>

fun mat_trace where
  "mat_trace (a, b, c, d) = a + d"

text \<open>Multiplication of matrix and a vector\<close>

fun mult_mv :: "complex_mat \<Rightarrow> complex_vec \<Rightarrow> complex_vec" (infixl "*\<^sub>m\<^sub>v" 100)  where
  "(a, b, c, d) *\<^sub>m\<^sub>v (x, y) = (x*a + y*b, x*c + y*d)"

fun mult_vm :: "complex_vec \<Rightarrow> complex_mat \<Rightarrow> complex_vec" (infixl "*\<^sub>v\<^sub>m" 100) where
  "(x, y) *\<^sub>v\<^sub>m (a, b, c, d)  = (x*a + y*c, x*b + y*d)"

lemma eye_mv_l [simp]:
  shows "eye *\<^sub>m\<^sub>v v = v"
  by (cases v) simp

lemma mult_mv_mv [simp]:
  shows "B *\<^sub>m\<^sub>v (A *\<^sub>m\<^sub>v v) = (B *\<^sub>m\<^sub>m A) *\<^sub>m\<^sub>v v"
  by (cases v, cases A, cases B) (auto simp add: field_simps)

lemma mult_vm_vm [simp]:
  shows "(v *\<^sub>v\<^sub>m A) *\<^sub>v\<^sub>m B = v *\<^sub>v\<^sub>m (A *\<^sub>m\<^sub>m B)"
  by (cases v, cases A, cases B) (auto simp add: field_simps)

lemma mult_mv_inv:
  assumes "x =  A *\<^sub>m\<^sub>v y" and "mat_det A \<noteq> 0"
  shows "y = (mat_inv A) *\<^sub>m\<^sub>v x"
  using assms
  by (cases y) (simp add: mat_inv_l)

lemma mult_vm_inv:
  assumes "x =  y *\<^sub>v\<^sub>m A" and "mat_det A \<noteq> 0"
  shows "y = x *\<^sub>v\<^sub>m (mat_inv A) "
  using assms
  by (cases y) (simp add: mat_inv_r)

lemma mult_mv_cancel_l:
  assumes "mat_det A \<noteq> 0" and "A *\<^sub>m\<^sub>v v = A *\<^sub>m\<^sub>v v'"
  shows "v = v'"
  using assms
  using mult_mv_inv
  by blast

lemma mult_vm_cancel_r:
  assumes "mat_det A \<noteq> 0" and "v *\<^sub>v\<^sub>m A = v' *\<^sub>v\<^sub>m A"
  shows "v = v'"
  using assms
  using mult_vm_inv
  by blast

lemma vec_zero_l [simp]:
  shows "A *\<^sub>m\<^sub>v vec_zero = vec_zero"
  by (cases A) simp

lemma vec_zero_r [simp]:
  shows "vec_zero *\<^sub>v\<^sub>m A = vec_zero"
  by (cases A) simp

lemma mult_mv_nonzero:
  assumes "v \<noteq> vec_zero" and "mat_det A \<noteq> 0"
  shows "A *\<^sub>m\<^sub>v v \<noteq> vec_zero"
  apply (rule ccontr)
  using assms mult_mv_inv[of vec_zero A v] mat_inv_l vec_zero_l
  by auto

lemma mult_vm_nonzero:
  assumes "v \<noteq> vec_zero" and "mat_det A \<noteq> 0"
  shows "v *\<^sub>v\<^sub>m A \<noteq> vec_zero"
  apply (rule ccontr)
  using assms mult_vm_inv[of vec_zero v A] mat_inv_r vec_zero_r
  by auto

lemma mult_sv_mv:
  shows "k *\<^sub>s\<^sub>v (A *\<^sub>m\<^sub>v v) = (A *\<^sub>m\<^sub>v (k *\<^sub>s\<^sub>v v))"
  by (cases A, cases v) (simp add: field_simps)

lemma mult_mv_mult_vm:
  shows "A *\<^sub>m\<^sub>v x = x *\<^sub>v\<^sub>m (mat_transpose A)"
  by (cases A, cases x) auto

lemma mult_mv_vv:
  shows "A *\<^sub>m\<^sub>v v1 *\<^sub>v\<^sub>v v2 = v1 *\<^sub>v\<^sub>v (mat_transpose A *\<^sub>m\<^sub>v v2)"
  by (cases v1, cases v2, cases A) (auto simp add: field_simps)

lemma mult_vv_mv:
  shows "x *\<^sub>v\<^sub>v (A *\<^sub>m\<^sub>v y)  = (x *\<^sub>v\<^sub>m A) *\<^sub>v\<^sub>v y"
  by (cases x, cases y, cases A) (auto simp add: field_simps)

lemma vec_cnj_mult_mv:
  shows "vec_cnj (A *\<^sub>m\<^sub>v x) =  (mat_cnj A) *\<^sub>m\<^sub>v (vec_cnj x)"
  by (cases A, cases x) (auto simp add: vec_cnj_def mat_cnj_def)

lemma vec_cnj_mult_vm:
  shows "vec_cnj (v *\<^sub>v\<^sub>m A) = vec_cnj v *\<^sub>v\<^sub>m mat_cnj A"
  unfolding vec_cnj_def mat_cnj_def
  by (cases A, cases v, auto)

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Eigenvalues and eigenvectors\<close>
(* ---------------------------------------------------------------------------- *)

definition eigenpair where
  [simp]: "eigenpair k v H \<longleftrightarrow> v \<noteq> vec_zero \<and> H *\<^sub>m\<^sub>v v = k *\<^sub>s\<^sub>v v"

definition eigenval where
  [simp]: "eigenval k H \<longleftrightarrow> (\<exists> v. v \<noteq> vec_zero \<and> H *\<^sub>m\<^sub>v v = k *\<^sub>s\<^sub>v v)"

lemma eigen_equation:
  shows "eigenval k H \<longleftrightarrow> k\<^sup>2 - mat_trace H * k + mat_det H = 0" (is "?lhs \<longleftrightarrow> ?rhs")
proof-
  obtain A B C D where HH: "H = (A, B, C, D)"
    by (cases H) auto
  show ?thesis
  proof
    assume ?lhs
    then obtain v where "v \<noteq> vec_zero" "H *\<^sub>m\<^sub>v v = k *\<^sub>s\<^sub>v v"
      unfolding eigenval_def
      by blast
    obtain v1 v2 where vv: "v = (v1, v2)"
      by (cases v) auto
    from \<open>H *\<^sub>m\<^sub>v v = k *\<^sub>s\<^sub>v v\<close> have "(H -\<^sub>m\<^sub>m (k *\<^sub>s\<^sub>m eye)) *\<^sub>m\<^sub>v v = vec_zero"
      using HH vv
      by (auto simp add: field_simps)
    hence "mat_det (H -\<^sub>m\<^sub>m (k *\<^sub>s\<^sub>m eye)) = 0"
      using \<open>v \<noteq> vec_zero\<close> vv HH
      using regular_homogenous_system[of "A - k" B C "D - k" v1 v2]
      unfolding det2_def
      by (auto simp add: field_simps)
    thus ?rhs
      using HH
      by (auto simp add: power2_eq_square field_simps)
  next
    assume ?rhs
    hence *: "mat_det (H -\<^sub>m\<^sub>m (k *\<^sub>s\<^sub>m eye)) = 0"
      using HH
      by (auto simp add: field_simps power2_eq_square)
    show ?lhs
    proof (cases "H -\<^sub>m\<^sub>m (k *\<^sub>s\<^sub>m eye) = mat_zero")
      case True
      thus ?thesis
        using HH
        by (auto) (rule_tac x=1 in exI, simp)
    next
      case False
      hence "(A - k \<noteq> 0 \<or> B \<noteq> 0) \<or> (D - k \<noteq> 0 \<or> C \<noteq> 0)"
        using HH
        by auto
      thus ?thesis
      proof
        assume "A - k \<noteq> 0 \<or> B \<noteq> 0"
        hence "C * B + (D - k) * (k - A) = 0"
          using * singular_system[of "A-k" "D-k" B C "(0, 0)" 0 0  "(B, k-A)"] HH
          by (auto simp add: field_simps)
        hence  "(B, k-A) \<noteq> vec_zero" "(H -\<^sub>m\<^sub>m (k *\<^sub>s\<^sub>m eye)) *\<^sub>m\<^sub>v (B, k-A) = vec_zero"
          using HH \<open>A - k \<noteq> 0 \<or> B \<noteq> 0\<close>
          by (auto simp add: field_simps)
        then obtain v where "v \<noteq> vec_zero \<and> (H -\<^sub>m\<^sub>m (k *\<^sub>s\<^sub>m eye)) *\<^sub>m\<^sub>v v = vec_zero"
          by blast
        thus ?thesis
          using HH
          unfolding eigenval_def
          by (rule_tac x="v" in exI) (case_tac v, simp add: field_simps)
      next
        assume "D - k \<noteq> 0 \<or> C \<noteq> 0"
        hence "C * B + (D - k) * (k - A) = 0"
          using * singular_system[of "D-k" "A-k" C B "(0, 0)" 0 0  "(C, k-D)"] HH
          by (auto simp add: field_simps)
        hence  "(k-D, C) \<noteq> vec_zero" "(H -\<^sub>m\<^sub>m (k *\<^sub>s\<^sub>m eye)) *\<^sub>m\<^sub>v (k-D, C) = vec_zero"
          using HH \<open>D - k \<noteq> 0 \<or> C \<noteq> 0\<close>
          by (auto simp add: field_simps)
        then obtain v where "v \<noteq> vec_zero \<and> (H -\<^sub>m\<^sub>m (k *\<^sub>s\<^sub>m eye)) *\<^sub>m\<^sub>v v = vec_zero"
          by blast
        thus ?thesis
          using HH
          unfolding eigenval_def
          by (rule_tac x="v" in exI) (case_tac v, simp add: field_simps)
      qed
    qed
  qed
qed

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Bilinear and Quadratic forms, Congruence, and Similarity\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Bilinear forms\<close>

definition bilinear_form where
  [simp]: "bilinear_form v1 v2 H = (vec_cnj v1) *\<^sub>v\<^sub>m H *\<^sub>v\<^sub>v v2"

lemma bilinear_form_scale_m:
  shows "bilinear_form v1 v2 (k *\<^sub>s\<^sub>m H) = k * bilinear_form v1 v2 H"
  by (cases v1, cases v2, cases H) (simp add: vec_cnj_def field_simps)

lemma bilinear_form_scale_v1:
  shows "bilinear_form (k *\<^sub>s\<^sub>v v1) v2 H = cnj k * bilinear_form v1 v2 H"
  by (cases v1, cases v2, cases H) (simp add: vec_cnj_def field_simps)

lemma bilinear_form_scale_v2:
  shows "bilinear_form  v1 (k *\<^sub>s\<^sub>v v2) H = k * bilinear_form v1 v2 H"
  by (cases v1, cases v2, cases H) (simp add: vec_cnj_def field_simps)

text \<open>Quadratic forms\<close>

definition quad_form where
  [simp]: "quad_form v H = (vec_cnj v) *\<^sub>v\<^sub>m H *\<^sub>v\<^sub>v v"

lemma quad_form_bilinear_form:
  shows "quad_form v H = bilinear_form v v H"
  by simp

lemma quad_form_scale_v:
  shows "quad_form (k *\<^sub>s\<^sub>v v) H = cor ((cmod k)\<^sup>2) * quad_form v H"
  using bilinear_form_scale_v1 bilinear_form_scale_v2
  by (simp add: complex_mult_cnj_cmod field_simps)

lemma quad_form_scale_m:
  shows "quad_form v (k *\<^sub>s\<^sub>m H) = k * quad_form v H"
  using bilinear_form_scale_m
  by simp

lemma cnj_quad_form [simp]:
  shows "cnj (quad_form z H) = quad_form z (mat_adj H)"
  by (cases H, cases z) (auto simp add: mat_adj_def mat_cnj_def vec_cnj_def field_simps)

text \<open>Matrix congruence\<close>

text \<open>Two matrices are congruent iff they represent the same quadratic form with respect to different
bases (for example if one circline can be transformed to another by a Möbius trasformation).\<close>

definition congruence where
  [simp]: "congruence M H \<equiv> mat_adj M *\<^sub>m\<^sub>m H *\<^sub>m\<^sub>m M"

lemma congruence_nonzero:
  assumes "H \<noteq> mat_zero" and "mat_det M \<noteq> 0"
  shows "congruence M H \<noteq> mat_zero"
  using assms
  unfolding congruence_def
  by (subst mult_mm_non_zero_r, subst mult_mm_non_zero_l) (auto simp add: mat_det_adj)

lemma congruence_congruence:
  shows "congruence M1 (congruence M2 H) = congruence (M2 *\<^sub>m\<^sub>m M1) H"
  unfolding congruence_def
  apply (subst mult_mm_assoc)
  apply (subst mult_mm_assoc)
  apply (subst mat_adj_mult_mm)
  apply (subst mult_mm_assoc)
  by simp

lemma congruence_eye [simp]:
  shows "congruence eye H = H"
  by (cases H) (simp add: mat_adj_def mat_cnj_def)

lemma congruence_congruence_inv [simp]:
  assumes "mat_det M \<noteq> 0"
  shows "congruence M (congruence (mat_inv M) H) = H"
  using assms congruence_congruence[of M "mat_inv M" H]
  using mat_inv_l[of M] mat_eye_l mat_eye_r
  unfolding congruence_def
  by (simp del: eye_def)

lemma congruence_inv:
  assumes "mat_det M \<noteq> 0" and "congruence M H = H'"
  shows "congruence (mat_inv M) H' = H"
  using assms
  using \<open>mat_det M \<noteq> 0\<close> mult_mm_inv_l[of "mat_adj M" "H *\<^sub>m\<^sub>m M" "H'"]
  using mult_mm_inv_r[of M "H" "mat_inv (mat_adj M) *\<^sub>m\<^sub>m H'"]
  by (simp add: mat_det_adj mult_mm_assoc mat_adj_inv)

lemma congruence_scale_m [simp]:
  shows "congruence M (k *\<^sub>s\<^sub>m H) = k *\<^sub>s\<^sub>m (congruence M H)"
  by (cases M, cases H) (auto simp add: mat_adj_def mat_cnj_def field_simps)

lemma inj_congruence:
  assumes "mat_det M \<noteq> 0" and "congruence M H = congruence M H'"
  shows "H = H'"
proof-
  have "H *\<^sub>m\<^sub>m M = H' *\<^sub>m\<^sub>m M "
    using assms
    using mult_mm_cancel_l[of "mat_adj M" "H *\<^sub>m\<^sub>m M" "H' *\<^sub>m\<^sub>m M"]
    by (simp add: mat_det_adj mult_mm_assoc)
  thus ?thesis
    using assms
    using mult_mm_cancel_r[of "M" "H" "H'"]
    by simp
qed

lemma mat_det_congruence [simp]:
  "mat_det (congruence M H) = (cor ((cmod (mat_det M))\<^sup>2)) * mat_det H"
  using complex_mult_cnj_cmod[of "mat_det M"]
  by (auto simp add: mat_det_adj field_simps)

lemma det_sgn_congruence [simp]:
  assumes "mat_det M \<noteq> 0"
  shows "sgn (mat_det (congruence M H)) = sgn (mat_det H)"
  using assms
  by (subst mat_det_congruence, auto simp add: sgn_mult power2_eq_square) (simp add: sgn_of_real)

lemma Re_det_sgn_congruence [simp]:
  assumes "mat_det M \<noteq> 0"
  shows "sgn (Re (mat_det (congruence M H))) = sgn (Re (mat_det H))"
proof-
  have *: "Re (mat_det (congruence M H)) = (cmod (mat_det M))\<^sup>2 * Re (mat_det H)"
    by (subst mat_det_congruence, subst Re_mult_real, rule Im_complex_of_real) (subst Re_complex_of_real, simp)
  show ?thesis
    using assms
    by (subst *) (auto simp add: sgn_mult)
qed

text \<open>Transforming a matrix $H$ by a regular matrix $M$ preserves its bilinear and quadratic forms.\<close>

lemma bilinear_form_congruence [simp]:
  assumes "mat_det M \<noteq> 0"
  shows "bilinear_form (M *\<^sub>m\<^sub>v v1) (M *\<^sub>m\<^sub>v v2) (congruence (mat_inv M) H) =
         bilinear_form v1 v2 H"
proof-
  have "mat_det (mat_adj M) \<noteq> 0"
    using assms
    by (simp add: mat_det_adj)
  show ?thesis
    unfolding bilinear_form_def congruence_def
    apply (subst mult_mv_mult_vm)
    apply (subst vec_cnj_mult_vm)
    apply (subst mat_adj_def[symmetric])
    apply (subst mult_vm_vm)
    apply (subst mult_vv_mv)
    apply (subst mult_vm_vm)
    apply (subst mat_adj_inv[OF \<open>mat_det M \<noteq> 0\<close>])
    apply (subst mult_assoc_5)
    apply (subst mat_inv_r[OF \<open>mat_det (mat_adj M) \<noteq> 0\<close>])
    apply (subst mat_inv_l[OF \<open>mat_det M \<noteq> 0\<close>])
    apply (subst mat_eye_l, subst mat_eye_r)
    by simp
qed

lemma quad_form_congruence [simp]:
  assumes "mat_det M \<noteq> 0"
  shows "quad_form (M *\<^sub>m\<^sub>v z) (congruence (mat_inv M) H) = quad_form z H"
  using bilinear_form_congruence[OF assms]
  by simp

text \<open>Similar matrices\<close>

text \<open>Two matrices are similar iff they represent the same linear operator with respect to (possibly)
different bases (e.g., if they represent the same Möbius transformation after changing the
coordinate system)\<close>

definition similarity where
  "similarity A M = mat_inv A *\<^sub>m\<^sub>m M *\<^sub>m\<^sub>m A"

lemma mat_det_similarity [simp]:
  assumes "mat_det A \<noteq> 0"
  shows "mat_det (similarity A M) = mat_det M"
  using assms
  unfolding similarity_def
  by (simp add: mat_det_inv)

lemma mat_trace_similarity [simp]:
  assumes "mat_det A \<noteq> 0"
  shows "mat_trace (similarity A M) = mat_trace M"
proof-
  obtain a b c d where AA: "A = (a, b, c, d)"
    by (cases A) auto
  obtain mA mB mC mD where MM: "M = (mA, mB, mC, mD)"
    by (cases M) auto
  have "mA * (a * d) / (a * d - b * c) + mD * (a * d) / (a * d - b * c) =
        mA + mD + mA * (b * c) / (a * d - b * c) + mD * (b * c) / (a * d - b * c)"
    using assms AA
    by (simp add: field_simps)
  thus ?thesis
    using AA MM
    by (simp add: field_simps similarity_def)
qed

lemma similarity_eye [simp]:
  shows "similarity eye M = M"
  unfolding similarity_def
  using mat_eye_l mat_eye_r
  by auto

lemma similarity_eye' [simp]:
  shows "similarity (1, 0, 0, 1) M = M"
  unfolding eye_def[symmetric]
  by (simp del: eye_def)

lemma similarity_comp [simp]:
  assumes "mat_det A1 \<noteq> 0" and "mat_det A2 \<noteq> 0"
  shows "similarity A1 (similarity A2 M) = similarity (A2*\<^sub>m\<^sub>mA1) M"
  using assms
  unfolding similarity_def
  by (simp add: mult_mm_assoc mat_inv_mult_mm)

lemma similarity_inv:
  assumes "similarity A M1 = M2" and "mat_det A \<noteq> 0"
  shows "similarity (mat_inv A) M2 = M1"
  using assms
  unfolding similarity_def
  by (metis mat_det_mult mult_mm_assoc mult_mm_inv_l mult_mm_inv_r mult_zero_left)

end