section \<open>Distance of Paths\<close>

theory Distance imports CFG begin

context CFG begin

inductive distance :: "'node \<Rightarrow> 'node \<Rightarrow> nat \<Rightarrow> bool"
where distanceI:
  "\<lbrakk>n -as\<rightarrow>\<^sub>\<iota>* n'; length as = x; \<forall>as'. n -as'\<rightarrow>\<^sub>\<iota>* n' \<longrightarrow> x \<le> length as'\<rbrakk>
  \<Longrightarrow> distance n n' x"

lemma every_path_distance:
  assumes "n -as\<rightarrow>\<^sub>\<iota>* n'"
  obtains x where "distance n n' x" and "x \<le> length as"
proof(atomize_elim)
  show "\<exists>x. distance n n' x \<and> x \<le> length as"
  proof(cases "\<exists>as'. n -as'\<rightarrow>\<^sub>\<iota>* n' \<and>
                     (\<forall>asx. n -asx\<rightarrow>\<^sub>\<iota>* n' \<longrightarrow> length as' \<le> length asx)")
    case True
    then obtain as'
      where "n -as'\<rightarrow>\<^sub>\<iota>* n' \<and> (\<forall>asx. n -asx\<rightarrow>\<^sub>\<iota>* n' \<longrightarrow> length as' \<le> length asx)"
      by blast
    hence "n -as'\<rightarrow>\<^sub>\<iota>* n'" and all:"\<forall>asx. n -asx\<rightarrow>\<^sub>\<iota>* n' \<longrightarrow> length as' \<le> length asx"
      by simp_all
    hence "distance n n' (length as')" by(fastforce intro:distanceI)
    from \<open>n -as\<rightarrow>\<^sub>\<iota>* n'\<close> all have "length as' \<le> length as" by fastforce
    with \<open>distance n n' (length as')\<close> show ?thesis by blast
  next
    case False
    hence all:"\<forall>as'. n -as'\<rightarrow>\<^sub>\<iota>* n' \<longrightarrow> (\<exists>asx. n -asx\<rightarrow>\<^sub>\<iota>* n' \<and> length as' > length asx)"
      by fastforce
    have "wf (measure length)" by simp
    from \<open>n -as\<rightarrow>\<^sub>\<iota>* n'\<close> have "as \<in> {as. n -as\<rightarrow>\<^sub>\<iota>* n'}" by simp
    with \<open>wf (measure length)\<close> obtain as' where "as' \<in> {as. n -as\<rightarrow>\<^sub>\<iota>* n'}"
      and notin:"\<And>as''. (as'',as') \<in> (measure length) \<Longrightarrow> as'' \<notin> {as. n -as\<rightarrow>\<^sub>\<iota>* n'}"
      by(erule wfE_min)
    from \<open>as' \<in> {as. n -as\<rightarrow>\<^sub>\<iota>* n'}\<close> have "n -as'\<rightarrow>\<^sub>\<iota>* n'" by simp
    with all obtain asx where "n -asx\<rightarrow>\<^sub>\<iota>* n'"
      and "length as' > length asx"
      by blast
    with notin have  "asx \<notin> {as. n -as\<rightarrow>\<^sub>\<iota>* n'}" by simp
    hence "\<not> n -asx\<rightarrow>\<^sub>\<iota>* n'" by simp
    with \<open>n -asx\<rightarrow>\<^sub>\<iota>* n'\<close> have False by simp
    thus ?thesis by simp
  qed
qed

lemma distance_det:
  "\<lbrakk>distance n n' x; distance n n' x'\<rbrakk> \<Longrightarrow> x = x'"
apply(erule distance.cases)+ apply clarsimp
apply(erule_tac x="asa" in allE) apply(erule_tac x="as" in allE)
by simp

lemma only_one_SOME_dist_edge:
  assumes "valid_edge a" and "intra_kind(kind a)" and "distance (targetnode a) n' x"
  shows "\<exists>!a'. sourcenode a = sourcenode a' \<and> distance (targetnode a') n' x \<and>
               valid_edge a' \<and> intra_kind(kind a') \<and>
               targetnode a' = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                              distance (targetnode a') n' x \<and>
                                              valid_edge a' \<and> intra_kind(kind a') \<and>
                                              targetnode a' = nx)"
proof(rule ex_ex1I)
  show "\<exists>a'. sourcenode a = sourcenode a' \<and>
             distance (targetnode a') n' x \<and> valid_edge a' \<and> intra_kind(kind a') \<and>
             targetnode a' = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                            distance (targetnode a') n' x \<and>
                                            valid_edge a' \<and> intra_kind(kind a') \<and>
                                            targetnode a' = nx)"
  proof -
    have "(\<exists>a'. sourcenode a = sourcenode a' \<and>
                distance (targetnode a') n' x \<and> valid_edge a' \<and> intra_kind(kind a') \<and>
                targetnode a' = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                               distance (targetnode a') n' x \<and>
                                               valid_edge a' \<and> intra_kind(kind a') \<and>
                                               targetnode a' = nx)) =
      (\<exists>nx. \<exists>a'. sourcenode a = sourcenode a' \<and> distance (targetnode a') n' x \<and>
                 valid_edge a' \<and> intra_kind(kind a') \<and> targetnode a' = nx)"
      apply(unfold some_eq_ex[of "\<lambda>nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
        distance (targetnode a') n' x \<and> valid_edge a' \<and> intra_kind(kind a') \<and>
        targetnode a' = nx"])
      by simp
    also have "\<dots>"
      using \<open>valid_edge a\<close> \<open>intra_kind(kind a)\<close> \<open>distance (targetnode a) n' x\<close>
      by blast
    finally show ?thesis .
  qed
next
  fix a' ax
  assume "sourcenode a = sourcenode a' \<and>
    distance (targetnode a') n' x \<and> valid_edge a' \<and> intra_kind(kind a') \<and>
    targetnode a' = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                   distance (targetnode a') n' x \<and>
                                   valid_edge a' \<and> intra_kind(kind a') \<and>
                                   targetnode a' = nx)"
    and "sourcenode a = sourcenode ax \<and>
    distance (targetnode ax) n' x \<and> valid_edge ax \<and> intra_kind(kind ax) \<and>
    targetnode ax = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                   distance (targetnode a') n' x \<and>
                                   valid_edge a' \<and> intra_kind(kind a') \<and>
                                   targetnode a' = nx)"
  thus "a' = ax" by(fastforce intro!:edge_det)
qed

lemma distance_successor_distance:
  assumes "distance n n' x" and "x \<noteq> 0"
  obtains a where "valid_edge a" and "n = sourcenode a" and "intra_kind(kind a)"
  and "distance (targetnode a) n' (x - 1)"
  and "targetnode a = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                     distance (targetnode a') n' (x - 1) \<and>
                                     valid_edge a' \<and> intra_kind(kind a') \<and>
                                     targetnode a' = nx)"
proof(atomize_elim)
  show "\<exists>a. valid_edge a \<and> n = sourcenode a \<and> intra_kind(kind a) \<and>
    distance (targetnode a) n' (x - 1) \<and>
    targetnode a = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                  distance (targetnode a') n' (x - 1) \<and>
                                  valid_edge a' \<and> intra_kind(kind a') \<and>
                                  targetnode a' = nx)"
  proof(rule ccontr)
    assume "\<not> (\<exists>a. valid_edge a \<and> n = sourcenode a \<and> intra_kind(kind a) \<and>
                   distance (targetnode a) n' (x - 1) \<and>
                   targetnode a = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                                 distance (targetnode a') n' (x - 1) \<and>
                                                 valid_edge a' \<and> intra_kind(kind a') \<and>
                                                 targetnode a' = nx))"
    hence imp:"\<forall>a. valid_edge a \<and> n = sourcenode a \<and> intra_kind(kind a) \<and>
                   targetnode a = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                                 distance (targetnode a') n' (x - 1) \<and>
                                                 valid_edge a' \<and> intra_kind(kind a') \<and>
                                                 targetnode a' = nx)
                 \<longrightarrow> \<not> distance (targetnode a) n' (x - 1)" by blast
    from \<open>distance n n' x\<close> obtain as where "n -as\<rightarrow>\<^sub>\<iota>* n'" and "x = length as"
      and all:"\<forall>as'. n -as'\<rightarrow>\<^sub>\<iota>* n' \<longrightarrow> x \<le> length as'"
      by(auto elim:distance.cases)
    from \<open>n -as\<rightarrow>\<^sub>\<iota>* n'\<close> have "n -as\<rightarrow>* n'" and "\<forall>a \<in> set as. intra_kind(kind a)"
      by(simp_all add:intra_path_def)
    from this \<open>x = length as\<close> all imp show False
    proof(induct rule:path.induct)
      case (empty_path n)
      from \<open>x = length []\<close> \<open>x \<noteq> 0\<close> show False by simp
    next
      case (Cons_path n'' as n' a n)
      note imp = \<open>\<forall>a. valid_edge a \<and> n = sourcenode a \<and> intra_kind (kind a) \<and>
                      targetnode a = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                                 distance (targetnode a') n' (x - 1) \<and>
                                                 valid_edge a' \<and> intra_kind(kind a') \<and>
                                                 targetnode a' = nx)
                    \<longrightarrow> \<not> distance (targetnode a) n' (x - 1)\<close>
      note all = \<open>\<forall>as'. n -as'\<rightarrow>\<^sub>\<iota>* n' \<longrightarrow> x \<le> length as'\<close>
      from \<open>\<forall>a\<in>set (a#as). intra_kind (kind a)\<close>
      have "intra_kind (kind a)" and "\<forall>a\<in>set as. intra_kind (kind a)"
        by simp_all
      from \<open>n'' -as\<rightarrow>* n'\<close> \<open>\<forall>a\<in>set as. intra_kind (kind a)\<close>
      have "n'' -as\<rightarrow>\<^sub>\<iota>* n'" by(simp add:intra_path_def)
      then obtain y where "distance n'' n' y"
        and "y \<le> length as" by(erule every_path_distance)
      from \<open>distance n'' n' y\<close> obtain as' where "n'' -as'\<rightarrow>\<^sub>\<iota>* n'"
        and "y = length as'" by(auto elim:distance.cases)
      hence "n'' -as'\<rightarrow>* n'" and "\<forall>a\<in>set as'. intra_kind (kind a)"
        by(simp_all add:intra_path_def)
      show False
      proof(cases "y < length as")
        case True
        from \<open>valid_edge a\<close> \<open>sourcenode a = n\<close> \<open>targetnode a = n''\<close> \<open>n'' -as'\<rightarrow>* n'\<close>
        have "n -a#as'\<rightarrow>* n'" by -(rule path.Cons_path)
        with \<open>\<forall>a\<in>set as'. intra_kind (kind a)\<close> \<open>intra_kind (kind a)\<close>
        have "n -a#as'\<rightarrow>\<^sub>\<iota>* n'" by(simp add:intra_path_def)
        with all have "x \<le> length (a#as')" by blast
        with \<open>x = length (a#as)\<close> True \<open>y = length as'\<close> show False by simp
      next
        case False
        with \<open>y \<le> length as\<close> \<open>x = length (a#as)\<close> have "y = x - 1" by simp
        from \<open>targetnode a = n''\<close> \<open>distance n'' n' y\<close>
        have "distance (targetnode a) n' y" by simp
        with \<open>valid_edge a\<close> \<open>intra_kind(kind a)\<close>
        obtain a' where "sourcenode a = sourcenode a'"
          and "distance (targetnode a') n' y" and "valid_edge a'"
          and "intra_kind(kind a')"
          and "targetnode a' = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                              distance (targetnode a') n' y \<and>
                                              valid_edge a' \<and> intra_kind(kind a') \<and>
                                              targetnode a' = nx)"
          by(auto dest:only_one_SOME_dist_edge)
        with imp \<open>sourcenode a = n\<close> \<open>y = x - 1\<close> show False by fastforce
      qed
    qed
  qed
qed

end

end


(*  Title:      JinjaThreads/MM/Orders.thy
    Author:     Andreas Lochbihler
*)

section \<open>Orders as predicates\<close>

theory Orders
imports
  Main
begin

subsection \<open>Preliminaries\<close>

text \<open>transfer @{term "refl_on"} et al. from @{theory HOL.Relation} to predicates\<close>

abbreviation refl_onP :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where "refl_onP A r \<equiv> refl_on A {(x, y). r x y}"

abbreviation reflP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where "reflP == refl_onP UNIV"

abbreviation symP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where "symP r \<equiv> sym {(x, y). r x y}"

abbreviation total_onP :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where "total_onP A r \<equiv> total_on A {(x, y). r x y}"

abbreviation irreflP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where "irreflP r == irrefl {(x, y). r x y}"

definition irreflclp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_\<^sup>\<noteq>\<^sup>\<noteq>" [1000] 1000)
where "r\<^sup>\<noteq>\<^sup>\<noteq> a b = (r a b \<and> a \<noteq> b)"

definition porder_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where "porder_on A r \<longleftrightarrow> refl_onP A r \<and> transp r \<and> antisymp r"

definition torder_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where "torder_on A r \<longleftrightarrow> porder_on A r \<and> total_onP A r"

definition order_consistent :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
where "order_consistent r s \<longleftrightarrow> (\<forall>a a'. r a a' \<and> s a' a \<longrightarrow> a = a')"

definition restrictP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "|`" 110)
where "(r |` A) a b \<longleftrightarrow> r a b \<and> a \<in> A \<and> b \<in> A"

definition inv_imageP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool"
where [iff]: "inv_imageP r f a b \<longleftrightarrow> r (f a) (f b)"

lemma refl_onPI: "(\<And>a a'. r a a' \<Longrightarrow> a \<in> A \<and> a' \<in> A) \<Longrightarrow> (\<And>a. a : A \<Longrightarrow> r a a) \<Longrightarrow> refl_onP A r"
by(rule refl_onI)(auto)

lemma refl_onPD: "refl_onP A r ==> a : A ==> r a a"
by(drule (1) refl_onD)(simp)

lemma refl_onPD1: "refl_onP A r ==> r a b ==> a : A"
by(erule refl_onD1)(simp)

lemma refl_onPD2: "refl_onP A r ==> r a b ==> b : A"
by(erule refl_onD2)(simp)

lemma refl_onP_Int: "refl_onP A r ==> refl_onP B s ==> refl_onP (A \<inter> B) (\<lambda>a a'. r a a' \<and> s a a')"
by(drule (1) refl_on_Int)(simp add: split_def inf_fun_def inf_set_def)

lemma refl_onP_Un: "refl_onP A r ==> refl_onP B s ==> refl_onP (A \<union> B) (\<lambda>a a'. r a a' \<or> s a a')"
by(drule (1) refl_on_Un)(simp add: split_def sup_fun_def sup_set_def)

lemma refl_onP_empty[simp]: "refl_onP {} (\<lambda>a a'. False)"
unfolding split_def by simp

lemma refl_onP_tranclp:
  assumes "refl_onP A r"
  shows "refl_onP A r^++"
proof(rule refl_onPI)
  fix a a'
  assume "r^++ a a'"
  thus "a \<in> A \<and> a' \<in> A"
    by(induct)(blast intro: refl_onPD1[OF assms] refl_onPD2[OF assms])+
next
  fix a
  assume "a \<in> A"
  from refl_onPD[OF assms this] show "r^++ a a" ..
qed

lemma irreflPI: "(\<And>a. \<not> r a a) \<Longrightarrow> irreflP r"
unfolding irrefl_def by blast

lemma irreflPE:
  assumes "irreflP r"
  obtains "\<forall>a. \<not> r a a"
using assms unfolding irrefl_def by blast

lemma irreflPD: "\<lbrakk> irreflP r; r a a \<rbrakk> \<Longrightarrow> False"
unfolding irrefl_def by blast

lemma irreflclpD:
  "r\<^sup>\<noteq>\<^sup>\<noteq> a b \<Longrightarrow> r a b \<and> a \<noteq> b"
by(simp add: irreflclp_def)

lemma irreflclpI [intro!]:
  "\<lbrakk> r a b; a \<noteq> b \<rbrakk> \<Longrightarrow> r\<^sup>\<noteq>\<^sup>\<noteq> a b"
by(simp add: irreflclp_def)

lemma irreflclpE [elim!]:
  assumes "r\<^sup>\<noteq>\<^sup>\<noteq> a b"
  obtains "r a b" "a \<noteq> b"
using assms by(simp add: irreflclp_def)

lemma transPI: "(\<And>x y z. \<lbrakk> r x y; r y z \<rbrakk> \<Longrightarrow> r x z) \<Longrightarrow> transp r"
  by (fact transpI)

lemma transPD: "\<lbrakk>transp r; r x y; r y z \<rbrakk> \<Longrightarrow> r x z"
  by (fact transpD)

lemma transP_tranclp: "transp r^++"
  by (fact trans_trancl [to_pred])

lemma antisymPI: "(\<And>x y. \<lbrakk> r x y; r y x \<rbrakk> \<Longrightarrow> x = y) \<Longrightarrow> antisymp r"
  by (fact antisympI)

lemma antisymPD: "\<lbrakk> antisymp r; r a b; r b a \<rbrakk> \<Longrightarrow> a = b"
  by (fact antisympD)

lemma antisym_subset:
  "\<lbrakk> antisymp r; \<And>a a'. s a a' \<Longrightarrow> r a a' \<rbrakk> \<Longrightarrow> antisymp s"
  by (blast intro: antisymp_less_eq [of s r])

lemma symPI: "(\<And>x y. r x y \<Longrightarrow> r y x) \<Longrightarrow> symP r"
by(rule symI)(blast)

lemma symPD: "\<lbrakk> symP r; r x y \<rbrakk> \<Longrightarrow> r y x"
by(blast dest: symD)

subsection \<open>Easy properties\<close>

lemma porder_onI:
  "\<lbrakk> refl_onP A r; antisymp r; transp r \<rbrakk> \<Longrightarrow> porder_on A r"
unfolding porder_on_def by blast

lemma porder_onE:
  assumes "porder_on A r"
  obtains "refl_onP A r" "antisymp r" "transp r"
using assms unfolding porder_on_def by blast

lemma torder_onI:
  "\<lbrakk> porder_on A r; total_onP A r \<rbrakk> \<Longrightarrow> torder_on A r"
unfolding torder_on_def by blast

lemma torder_onE:
  assumes "torder_on A r"
  obtains "porder_on A r" "total_onP A r"
using assms unfolding torder_on_def by blast

lemma total_onI:
  "(\<And>x y. \<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x, y) \<in> r \<or> x = y \<or> (y, x) \<in> r) \<Longrightarrow> total_on A r"
unfolding total_on_def by blast

lemma total_onPI:
  "(\<And>x y. \<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> r x y \<or> x = y \<or> r y x) \<Longrightarrow> total_onP A r"
by(rule total_onI) simp

lemma total_onD:
  "\<lbrakk> total_on A r; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x, y) \<in> r \<or> x = y \<or> (y, x) \<in> r"
unfolding total_on_def by blast

lemma total_onPD:
  "\<lbrakk> total_onP A r; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> r x y \<or> x = y \<or> r y x"
by(drule (2) total_onD) blast

subsection \<open>Order consistency\<close>

lemma order_consistentI:
  "(\<And>a a'. \<lbrakk> r a a'; s a' a \<rbrakk> \<Longrightarrow> a = a') \<Longrightarrow> order_consistent r s"
unfolding order_consistent_def by blast

lemma order_consistentD:
  "\<lbrakk> order_consistent r s; r a a'; s a' a \<rbrakk> \<Longrightarrow> a = a'"
unfolding order_consistent_def by blast

lemma order_consistent_subset:
  "\<lbrakk> order_consistent r s; \<And>a a'. r' a a' \<Longrightarrow> r a a'; \<And>a a'. s' a a' \<Longrightarrow> s a a' \<rbrakk> \<Longrightarrow> order_consistent r' s'"
by(blast intro: order_consistentI order_consistentD)

lemma order_consistent_sym:
  "order_consistent r s \<Longrightarrow> order_consistent s r"
by(blast intro: order_consistentI dest: order_consistentD)

lemma total_on_refl_on_consistent_into:
  assumes r: "total_onP A r" "refl_onP A r"
  and consist: "order_consistent r s"
  and x: "x \<in> A" and y: "y \<in> A" and s: "s x y"
  shows "r x y"
proof(cases "x = y")
  case True
  with r x y show ?thesis by(blast intro: refl_onPD)
next
  case False
  with r x y have "r x y \<or> r y x" by(blast dest: total_onD)
  thus ?thesis
  proof
    assume "r y x"
    with s consist have "x = y" by(blast dest: order_consistentD)
    with False show ?thesis by(contradiction)
  qed
qed

lemma porder_torder_tranclpE [consumes 5, case_names base step]:
  assumes r: "porder_on A r"
  and s: "torder_on B s"
  and consist: "order_consistent r s"
  and B_subset_A: "B \<subseteq> A"
  and trancl: "(\<lambda>a b. r a b \<or> s a b)^++ x y"
  obtains "r x y"
        | u v where "r x u" "s u v" "r v y"
proof(atomize_elim)
  from r have "refl_onP A r" "transp r" by(blast elim: porder_onE)+
  from s have "refl_onP B s" "total_onP B s" "transp s"
    by(blast elim: torder_onE porder_onE)+

  from trancl show "r x y \<or> (\<exists>u v. r x u \<and> s u v \<and> r v y)"
  proof(induct)
    case (base y)
    thus ?case
    proof
      assume "s x y"
      with s have "x \<in> B" "y \<in> B"
        by(blast elim: torder_onE porder_onE dest: refl_onPD1 refl_onPD2)+
      with B_subset_A have "x \<in> A" "y \<in> A" by blast+
      with refl_onPD[OF \<open>refl_onP A r\<close>, of x] refl_onPD[OF \<open>refl_onP A r\<close>, of y] \<open>s x y\<close>
      show ?thesis by(iprover)
    next
      assume "r x y"
      thus ?thesis ..
    qed
  next
    case (step y z)
    note IH = \<open>r x y \<or> (\<exists>u v. r x u \<and> s u v \<and> r v y)\<close>
    from \<open>r y z \<or> s y z\<close> show ?case
    proof
      assume "s y z"
      with \<open>refl_onP B s\<close> have "y \<in> B" "z \<in> B"
        by(blast dest: refl_onPD2 refl_onPD1)+
      from IH show ?thesis
      proof
        assume "r x y"
        moreover from \<open>z \<in> B\<close> B_subset_A r have "r z z"
          by(blast elim: porder_onE dest: refl_onPD)
        ultimately show ?thesis using \<open>s y z\<close> by blast
      next
        assume "\<exists>u v. r x u \<and> s u v \<and> r v y"
        then obtain u v where "r x u" "s u v" "r v y" by blast
        from \<open>refl_onP B s\<close> \<open>s u v\<close> have "v \<in> B" by(rule refl_onPD2)
        with \<open>total_onP B s\<close> \<open>refl_onP B s\<close> order_consistent_sym[OF consist]
        have "s v y" using \<open>y \<in> B\<close> \<open>r v y\<close>
          by(rule total_on_refl_on_consistent_into)
        with \<open>transp s\<close> have "s v z" using \<open>s y z\<close> by(rule transPD)
        with \<open>transp s\<close> \<open>s u v\<close> have "s u z" by(rule transPD)
        moreover from \<open>z \<in> B\<close> B_subset_A have "z \<in> A" ..
        with \<open>refl_onP A r\<close> have "r z z" by(rule refl_onPD)
        ultimately show ?thesis using \<open>r x u\<close> by blast
      qed
    next
      assume "r y z"
      with IH show ?thesis
        by(blast intro: transPD[OF \<open>transp r\<close>])
    qed
  qed
qed

lemma torder_on_porder_on_consistent_tranclp_antisym:
  assumes r: "porder_on A r"
  and s: "torder_on B s"
  and consist: "order_consistent r s"
  and B_subset_A: "B \<subseteq> A"
  shows "antisymp (\<lambda>x y. r x y \<or> s x y)^++"
proof(rule antisymPI)
  fix x y
  let ?rs = "\<lambda>x y. r x y \<or> s x y"
  assume "?rs^++ x y" "?rs^++ y x"
  from r have "antisymp r" "transp r" by(blast elim: porder_onE)+
  from s have "total_onP B s" "refl_onP B s" "transp s" "antisymp s"
    by(blast elim: torder_onE porder_onE)+

  from r s consist B_subset_A \<open>?rs^++ x y\<close>
  show "x = y"
  proof(cases rule: porder_torder_tranclpE)
    case base
    from r s consist B_subset_A \<open>?rs^++ y x\<close>
    show ?thesis
    proof(cases rule: porder_torder_tranclpE)
      case base
      with \<open>antisymp r\<close> \<open>r x y\<close> show ?thesis by(rule antisymPD)
    next
      case (step u v)
      from \<open>r v x\<close> \<open>r x y\<close> \<open>r y u\<close> have "r v u" by(blast intro: transPD[OF \<open>transp r\<close>])
      with consist have "v = u" using \<open>s u v\<close> by(rule order_consistentD)
      with \<open>r y u\<close> \<open>r v x\<close> have "r y x" by(blast intro: transPD[OF \<open>transp r\<close>])
      with \<open>r x y\<close> show ?thesis by(rule antisymPD[OF \<open>antisymp r\<close>])
    qed
  next
    case (step u v)
    from r s consist B_subset_A \<open>?rs^++ y x\<close>
    show ?thesis
    proof(cases rule: porder_torder_tranclpE)
      case base
      from \<open>r v y\<close> \<open>r y x\<close> \<open>r x u\<close> have "r v u" by(blast intro: transPD[OF \<open>transp r\<close>])
      with order_consistent_sym[OF consist] \<open>s u v\<close>
      have "u = v" by(rule order_consistentD)
      with \<open>r v y\<close> \<open>r x u\<close> have "r x y" by(blast intro: transPD[OF \<open>transp r\<close>])
      thus ?thesis using \<open>r y x\<close> by(rule antisymPD[OF \<open>antisymp r\<close>])
    next
      case (step u' v')
      note r_into_s = total_on_refl_on_consistent_into[OF \<open>total_onP B s\<close> \<open>refl_onP B s\<close> order_consistent_sym[OF consist]]
      from \<open>refl_onP B s\<close> \<open>s u v\<close> \<open>s u' v'\<close>
      have "u \<in> B" "v \<in> B" "u' \<in> B" "v' \<in> B" by(blast dest: refl_onPD1 refl_onPD2)+
      from \<open>r v' x\<close> \<open>r x u\<close> have "r v' u" by(rule transPD[OF \<open>transp r\<close>])
      with \<open>v' \<in> B\<close> \<open>u \<in> B\<close> have "s v' u" by(rule r_into_s)
      also note \<open>s u v\<close>
      also (transPD[OF \<open>transp s\<close>])
      from \<open>r v y\<close> \<open>r y u'\<close> have "r v u'" by(rule transPD[OF \<open>transp r\<close>])
      with \<open>v \<in> B\<close> \<open>u' \<in> B\<close> have "s v u'" by(rule r_into_s)
      finally (transPD[OF \<open>transp s\<close>])
      have "v' = u'" using \<open>s u' v'\<close> by(rule antisymPD[OF \<open>antisymp s\<close>])
      moreover with \<open>s v u'\<close> \<open>s v' u\<close> have "s v u" by(blast intro: transPD[OF \<open>transp s\<close>])
      with \<open>s u v\<close> have "u = v" by(rule antisymPD[OF \<open>antisymp s\<close>])
      ultimately have "r x y" "r y x" using \<open>r x u\<close> \<open>r v y\<close> \<open>r y u'\<close> \<open>r v' x\<close>
        by(blast intro: transPD[OF \<open>transp r\<close>])+
      thus ?thesis by(rule antisymPD[OF \<open>antisymp r\<close>])
    qed
  qed
qed

lemma porder_on_torder_on_tranclp_porder_onI:
  assumes r: "porder_on A r"
  and s: "torder_on B s"
  and consist: "order_consistent r s"
  and subset: "B \<subseteq> A"
  shows "porder_on A (\<lambda>a b. r a b \<or> s a b)^++"
proof(rule porder_onI)
  let ?rs = "\<lambda>a b. r a b \<or> s a b"
  from r have "refl_onP A r" by(rule porder_onE)
  moreover from s have "refl_onP B s" by(blast elim: torder_onE porder_onE)
  ultimately have "refl_onP (A \<union> B) ?rs" by(rule refl_onP_Un)
  also from subset have "A \<union> B = A" by blast
  finally show "refl_onP A ?rs^++" by(rule refl_onP_tranclp)

  show "transp ?rs^++" by(rule transP_tranclp)

  from r s consist subset show "antisymp ?rs^++"
    by (rule torder_on_porder_on_consistent_tranclp_antisym)
qed

lemma porder_on_sub_torder_on_tranclp_porder_onI:
  assumes r: "porder_on A r"
  and s: "torder_on B s"
  and consist: "order_consistent r s"
  and t: "\<And>x y. t x y \<Longrightarrow> s x y"
  and subset: "B \<subseteq> A"
  shows "porder_on A (\<lambda>x y. r x y \<or> t x y)^++"
proof(rule porder_onI)
  let ?rt = "\<lambda>x y. r x y \<or> t x y"
  let ?rs = "\<lambda>x y. r x y \<or> s x y"
  from r s consist subset have "antisymp ?rs^++"
    by(rule torder_on_porder_on_consistent_tranclp_antisym)
  thus "antisymp ?rt^++"
  proof(rule antisym_subset)
    fix x y
    assume "?rt^++ x y" thus "?rs^++ x y"
      by(induct)(blast intro: tranclp.r_into_trancl t tranclp.trancl_into_trancl t)+
  qed

  from s have "refl_onP B s" by(blast elim: porder_onE torder_onE)
  { fix x y
    assume "t x y"
    hence "s x y" by(rule t)
    hence "x \<in> B" "y \<in> B"
      by(blast dest: refl_onPD1[OF \<open>refl_onP B s\<close>] refl_onPD2[OF \<open>refl_onP B s\<close>])+
    with subset have "x \<in> A" "y \<in> A" by blast+ }
  note t_reflD = this

  from r have "refl_onP A r" by(rule porder_onE)
  show "refl_onP A ?rt^++"
  proof(rule refl_onPI)
    fix a a'
    assume "?rt^++ a a'"
    thus "a \<in> A \<and> a' \<in> A"
      by(induct)(auto dest: refl_onPD1[OF \<open>refl_onP A r\<close>] refl_onPD2[OF \<open>refl_onP A r\<close>] t_reflD)
  next
    fix a
    assume "a \<in> A"
    with \<open>refl_onP A r\<close> have "r a a" by(rule refl_onPD)
    thus "?rt^++ a a" by(blast intro: tranclp.r_into_trancl)
  qed

  show "transp ?rt^++" by(rule transP_tranclp)
qed

subsection \<open>Order restrictions\<close>

lemma restrictPI [intro!, simp]:
  "\<lbrakk> r a b; a \<in> A; b \<in> A \<rbrakk> \<Longrightarrow> (r |` A) a b"
unfolding restrictP_def by simp

lemma restrictPE [elim!]:
  assumes "(r |` A) a b"
  obtains "r a b" "a \<in> A" "b \<in> A"
using assms unfolding restrictP_def by simp

lemma restrictP_empty [simp]: "R |` {} = (\<lambda>_ _. False)"
by(simp add: restrictP_def[abs_def])

lemma refl_on_restrictPI:
  "refl_onP A r \<Longrightarrow> refl_onP (A \<inter> B) (r |` B)"
by(rule refl_onPI)(blast dest: refl_onPD1 refl_onPD2 refl_onPD)+

lemma refl_on_restrictPI':
  "\<lbrakk> refl_onP A r; B = A \<inter> C \<rbrakk> \<Longrightarrow> refl_onP B (r |` C)"
by(simp add: refl_on_restrictPI)

lemma antisym_restrictPI:
  "antisymp r \<Longrightarrow> antisymp (r |` A)"
by(rule antisymPI)(blast dest: antisymPD)

lemma trans_restrictPI:
  "transp r \<Longrightarrow> transp (r |` A)"
by(rule transPI)(blast dest: transPD)

lemma porder_on_restrictPI:
  "porder_on A r \<Longrightarrow> porder_on (A \<inter> B) (r |` B)"
by(blast elim: porder_onE intro: refl_on_restrictPI antisym_restrictPI trans_restrictPI porder_onI)

lemma porder_on_restrictPI':
  "\<lbrakk> porder_on A r; B = A \<inter> C \<rbrakk> \<Longrightarrow> porder_on B (r |` C)"
by(simp add: porder_on_restrictPI)

lemma total_on_restrictPI:
  "total_onP A r \<Longrightarrow> total_onP (A \<inter> B) (r |` B)"
by(blast intro: total_onPI dest: total_onPD)

lemma total_on_restrictPI':
  "\<lbrakk> total_onP A r; B = A \<inter> C \<rbrakk> \<Longrightarrow> total_onP B (r |` C)"
by(simp add: total_on_restrictPI)

lemma torder_on_restrictPI:
  "torder_on A r \<Longrightarrow> torder_on (A \<inter> B) (r |` B)"
by(blast elim: torder_onE intro: torder_onI porder_on_restrictPI total_on_restrictPI)

lemma torder_on_restrictPI':
  "\<lbrakk> torder_on A r; B = A \<inter> C \<rbrakk> \<Longrightarrow> torder_on B (r |` C)"
by(simp add: torder_on_restrictPI)

lemma restrictP_commute:
  fixes r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  shows "r |` A |` B = r |` B |` A"
by(blast intro!: ext)

lemma restrictP_subsume2:
  fixes r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes "B \<subseteq> A"
  shows "r |` A |` B = r |` B"
using assms by(blast intro!: ext)

lemma restrictP_idem [simp]:
  fixes r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  shows "r |` A |` A = r |` A"
by(simp add: restrictP_subsume1)

subsection \<open>Maximal elements w.r.t. a total order\<close>

definition max_torder :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
where "max_torder r a b = (if Domainp r a \<and> Domainp r b then if r a b then b else a
  else if a = b then a else SOME a. \<not> Domainp r a)"

lemma refl_on_DomainD: "refl_on A r \<Longrightarrow> A = Domain r"
by(auto simp add: Domain_unfold dest: refl_onD refl_onD1)

lemma refl_onP_DomainPD: "refl_onP A r \<Longrightarrow> A = {a. Domainp r a}"
by(drule refl_on_DomainD) auto

lemma semilattice_max_torder:
  assumes tot: "torder_on A r"
  shows "semilattice (max_torder r)"
proof -
  from tot have as: "antisymp r"
    and to: "total_onP A r"
    and trans: "transp r"
    and refl: "refl_onP A r"
    by(auto elim: torder_onE porder_onE)
  from refl have "{a. Domainp r a} = A" by (rule refl_onP_DomainPD[symmetric])
  from this [symmetric] have "domain": "\<And>a. Domainp r a \<longleftrightarrow> a \<in> A" by simp
  show ?thesis
  proof
    fix x y z
    show "max_torder r (max_torder r x y) z = max_torder r x (max_torder r y z)"
    proof (cases "x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z")
      case True
      have *: "\<And>a b. a \<noteq> b \<Longrightarrow> max_torder r a b = (if Domainp r a \<and> Domainp r b then
        if r a b then b else a else SOME a. \<not> Domainp r a)"
        by (auto simp add: max_torder_def)
      with True show ?thesis
        apply (simp only: max_torder_def "domain")
        apply (auto split!: if_splits)
        apply (blast dest: total_onPD [OF to] transPD [OF trans] antisymPD [OF as] refl_onPD1 [OF refl] refl_onPD2 [OF refl] someI [where P="\<lambda>a. a \<notin> A"])+
        done
    next
      have max_torder_idem: "\<And>a. max_torder r a a = a" by (simp add: max_torder_def)
      case False then show ?thesis
        apply (auto simp add: max_torder_idem)
        apply (auto simp add: max_torder_def "domain" dest: someI [where P="\<lambda>a. a \<notin> A"])
        done
    qed
  next
    fix x y
    show "max_torder r x y = max_torder r y x"
      by (auto simp add: max_torder_def "domain" dest: total_onPD [OF to] antisymPD [OF as])
  next
    fix x
    show "max_torder r x x = x"
      by (simp add: max_torder_def)
  qed
qed

lemma max_torder_ge_conv_disj:
  assumes tot: "torder_on A r" and x: "x \<in> A" and y: "y \<in> A"
  shows "r z (max_torder r x y) \<longleftrightarrow> r z x \<or> r z y"
proof -
  from tot have as: "antisymp r"
    and to: "total_onP A r"
    and trans: "transp r"
    and refl: "refl_onP A r"
    by(auto elim: torder_onE porder_onE)
  from refl have "{a. Domainp r a} = A" by (rule refl_onP_DomainPD[symmetric])
  from this [symmetric] have "domain": "\<And>a. Domainp r a \<longleftrightarrow> a \<in> A" by simp
  show ?thesis using x y
    by(simp add: max_torder_def "domain")(blast dest: total_onPD[OF to] transPD[OF trans])
qed

definition Max_torder :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a"
where
  "Max_torder r = semilattice_set.F (max_torder r)"

context
  fixes A r
  assumes tot: "torder_on A r"
begin

lemma semilattice_set:
  "semilattice_set (max_torder r)"
  by (rule semilattice_set.intro, rule semilattice_max_torder) (fact tot)

lemma domain:
  "Domainp r a \<longleftrightarrow> a \<in> A"
proof -
  from tot have "{a. Domainp r a} = A"
    by (auto elim: torder_onE porder_onE dest: refl_onP_DomainPD [symmetric])
  from this [symmetric] show ?thesis by simp
qed

lemma Max_torder_in_Domain:
  assumes B: "finite B" "B \<noteq> {}" "B \<subseteq> A"
  shows "Max_torder r B \<in> A"
proof -
  interpret Max_torder: semilattice_set "max_torder r"
  rewrites
    "semilattice_set.F (max_torder r) = Max_torder r"
    by (fact semilattice_set Max_torder_def [symmetric])+
  show ?thesis using B
    by (induct rule: finite_ne_induct) (simp_all add: max_torder_def "domain")
qed

lemma Max_torder_in_set:
  assumes B: "finite B" "B \<noteq> {}" "B \<subseteq> A"
  shows "Max_torder r B \<in> B"
proof -
  interpret Max_torder: semilattice_set "max_torder r"
  rewrites
    "semilattice_set.F (max_torder r) = Max_torder r"
    by (fact semilattice_set Max_torder_def [symmetric])+
  show ?thesis using B
    by (induct rule: finite_ne_induct) (auto simp add: max_torder_def "domain")
qed

lemma Max_torder_above_iff:
  assumes B: "finite B" "B \<noteq> {}" "B \<subseteq> A"
  shows "r x (Max_torder r B) \<longleftrightarrow> (\<exists>a\<in>B. r x a)"
proof -
  interpret Max_torder: semilattice_set "max_torder r"
  rewrites
    "semilattice_set.F (max_torder r) = Max_torder r"
    by (fact semilattice_set Max_torder_def [symmetric])+
  from B show ?thesis
    by (induct rule: finite_ne_induct) (simp_all add: max_torder_ge_conv_disj [OF tot] Max_torder_in_Domain)
qed

end

lemma Max_torder_above:
  assumes tot: "torder_on A r"
  and "finite B" "a \<in> B" "B \<subseteq> A"
  shows "r a (Max_torder r B)"
proof -
  from tot have refl: "refl_onP A r" by(auto elim: torder_onE porder_onE)
  with \<open>a \<in> B\<close> \<open>B \<subseteq> A\<close> have "r a a" by(blast dest: refl_onPD[OF refl])
  from \<open>a \<in> B\<close> have "B \<noteq> {}" by auto
  from Max_torder_above_iff [OF tot \<open>finite B\<close> this \<open>B \<subseteq> A\<close>, of a] \<open>r a a\<close> \<open>a \<in> B\<close>
  show ?thesis by blast
qed

lemma inv_imageP_id [simp]: "inv_imageP R id = R"
by(simp add: fun_eq_iff)

lemma inv_into_id [simp]: "a \<in> A \<Longrightarrow> inv_into A id a = a"
by (metis f_inv_into_f id_apply image_id)

end


(*  Title:      HOL/MicroJava/DFA/Kildall.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section \<open>Kildall's Algorithm \label{sec:Kildall}\<close>

theory Kildall
imports SemilatAlg "HOL-Library.While_Combinator"
begin

primrec propa :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> nat set \<Rightarrow> 's list * nat set" where
  "propa f []      ss w = (ss,w)"
| "propa f (q'#qs) ss w = (let (q,t) = q';
                               u = t +_f ss!q;
                               w' = (if u = ss!q then w else insert q w)
                           in propa f qs (ss[q := u]) w')"

definition iter :: "'s binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat set \<Rightarrow> 's list \<times> nat set" where
  "iter f step ss w == while (%(ss,w). w \<noteq> {})
       (%(ss,w). let p = SOME p. p \<in> w
                 in propa f (step p (ss!p)) ss (w-{p}))
       (ss,w)"

definition unstables :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat set" where
"unstables r step ss == {p. p < size ss \<and> \<not>stable r step ss p}"

definition kildall :: "'s ord \<Rightarrow> 's binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 's list" where
"kildall r f step ss == fst(iter f step ss (unstables r step ss))"

primrec merges :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> 's list" where
  "merges f []      ss = ss"
| "merges f (p'#ps) ss = (let (p,s) = p' in merges f ps (ss[p := s +_f ss!p]))"

lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]

lemma (in Semilat) nth_merges:
 "\<And>ss. \<lbrakk>p < length ss; ss \<in> list n A; \<forall>(p,t)\<in>set ps. p<n \<and> t\<in>A \<rbrakk> \<Longrightarrow>
  (merges f ps ss)!p = map snd [(p',t') \<leftarrow> ps. p'=p] ++_f ss!p"
  (is "\<And>ss. \<lbrakk>_; _; ?steptype ps\<rbrakk> \<Longrightarrow> ?P ss ps")
proof (induct ps)
  show "\<And>ss. ?P ss []" by simp

  fix ss p' ps'
  assume ss: "ss \<in> list n A"
  assume l:  "p < length ss"
  assume "?steptype (p'#ps')"
  then obtain a b where
    p': "p'=(a,b)" and ab: "a<n" "b\<in>A" and ps': "?steptype ps'"
    by (cases p') auto
  assume "\<And>ss. p< length ss \<Longrightarrow> ss \<in> list n A \<Longrightarrow> ?steptype ps' \<Longrightarrow> ?P ss ps'"
  from this [OF _ _ ps'] have IH: "\<And>ss. ss \<in> list n A \<Longrightarrow> p < length ss \<Longrightarrow> ?P ss ps'" .

  from ss ab
  have "ss[a := b +_f ss!a] \<in> list n A" by (simp add: closedD)
  moreover
  from calculation l
  have "p < length (ss[a := b +_f ss!a])" by simp
  ultimately
  have "?P (ss[a := b +_f ss!a]) ps'" by (rule IH)
  with p' l
  show "?P ss (p'#ps')" by simp
qed

(** merges **)

lemma length_merges [simp]: "size(merges f ps ss) = size ss"
  by (induct ps arbitrary: ss) auto

lemma (in Semilat) merges_preserves_type_lemma:
shows "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A)
          \<longrightarrow> merges f ps xs \<in> list n A"
apply (insert closedI)
apply (unfold closed_def)
apply (induct_tac ps)
 apply simp
apply clarsimp
done

lemma (in Semilat) merges_preserves_type [simp]:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A \<rbrakk>
  \<Longrightarrow> merges f ps xs \<in> list n A"
by (simp add: merges_preserves_type_lemma)

lemma (in Semilat) merges_incr_lemma:
 "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A) \<longrightarrow> xs <=[r] merges f ps xs"
apply (induct_tac ps)
 apply simp
apply simp
apply clarify
apply (rule order_trans)
  apply simp
 apply (erule list_update_incr)
  apply simp
 apply simp
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
done

lemma (in Semilat) merges_incr:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A \<rbrakk>
  \<Longrightarrow> xs <=[r] merges f ps xs"
  by (simp add: merges_incr_lemma)

lemma (in Semilat) merges_same_conv [rule_format]:
 "(\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x\<in>A) \<longrightarrow>
     (merges f ps xs = xs) = (\<forall>(p,x)\<in>set ps. x <=_r xs!p))"
  apply (induct_tac ps)
   apply simp
  apply clarsimp
  apply (rename_tac p x ps xs)
  apply (rule iffI)
   apply (rule context_conjI)
    apply (subgoal_tac "xs[p := x +_f xs!p] <=[r] xs")
     apply (drule_tac p = p in le_listD)
      apply simp
     apply simp
    apply (erule subst, rule merges_incr)
       apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
      apply clarify
      apply (rule conjI)
       apply simp
       apply (blast dest: boundedD)
      apply blast
   apply clarify
   apply (erule allE)
   apply (erule impE)
    apply assumption
   apply (drule bspec)
    apply assumption
   apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
   apply blast
  apply clarify
  apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
  done

lemma (in Semilat) list_update_le_listI [rule_format]:
  "set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> xs <=[r] ys \<longrightarrow> p < size xs \<longrightarrow>
   x <=_r ys!p \<longrightarrow> x\<in>A \<longrightarrow> xs[p := x +_f xs!p] <=[r] ys"
  apply(insert semilat)
  apply (unfold Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  done

lemma (in Semilat) merges_pres_le_ub:
  assumes "set ts <= A" and "set ss <= A"
    and "\<forall>(p,t)\<in>set ps. t <=_r ts!p \<and> t \<in> A \<and> p < size ts" and "ss <=[r] ts"
  shows "merges f ps ss <=[r] ts"
proof -
  { fix t ts ps
    have
    "\<And>qs. \<lbrakk>set ts <= A; \<forall>(p,t)\<in>set ps. t <=_r ts!p \<and> t \<in> A \<and> p< size ts \<rbrakk> \<Longrightarrow>
    set qs <= set ps  \<longrightarrow>
    (\<forall>ss. set ss <= A \<longrightarrow> ss <=[r] ts \<longrightarrow> merges f qs ss <=[r] ts)"
    apply (induct_tac qs)
     apply simp
    apply (simp (no_asm_simp))
    apply clarify
    apply (rotate_tac -2)
    apply simp
    apply (erule allE, erule impE, erule_tac [2] mp)
     apply (drule bspec, assumption)
     apply (simp add: closedD)
    apply (drule bspec, assumption)
    apply (simp add: list_update_le_listI)
    done
  } note this [dest]

  from assms show ?thesis by blast
qed

(** propa **)

lemma decomp_propa:
  "\<And>ss w. (\<forall>(q,t)\<in>set qs. q < size ss) \<Longrightarrow>
   propa f qs ss w =
   (merges f qs ss, {q. \<exists>t. (q,t)\<in>set qs \<and> t +_f ss!q \<noteq> ss!q} Un w)"
  apply (induct qs)
   apply simp
  apply (simp (no_asm))
  apply clarify
  apply simp
  apply (rule conjI)
   apply blast
  apply (simp add: nth_list_update)
  apply blast
  done

(** iter **)

lemma (in Semilat) stable_pres_lemma:
shows "\<lbrakk>pres_type step n A; bounded step n;
     ss \<in> list n A; p \<in> w; \<forall>q\<in>w. q < n;
     \<forall>q. q < n \<longrightarrow> q \<notin> w \<longrightarrow> stable r step ss q; q < n;
     \<forall>s'. (q,s') \<in> set (step p (ss ! p)) \<longrightarrow> s' +_f ss ! q = ss ! q;
     q \<notin> w \<or> q = p \<rbrakk>
  \<Longrightarrow> stable r step (merges f (step p (ss!p)) ss) q"
  apply (unfold stable_def)
  apply (subgoal_tac "\<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' \<in> A")
   prefer 2
   apply clarify
   apply (erule pres_typeD)
    prefer 3 apply assumption
    apply (rule listE_nth_in)
     apply assumption
    apply simp
   apply simp
  apply simp
  apply clarify
  apply (subst nth_merges)
       apply simp
       apply (blast dest: boundedD)
      apply assumption
     apply clarify
     apply (rule conjI)
      apply (blast dest: boundedD)
     apply (erule pres_typeD)
       prefer 3 apply assumption
      apply simp
     apply simp
apply(subgoal_tac "q < length ss")
prefer 2 apply simp
  apply (frule nth_merges [of q _ _ "step p (ss!p)"]) (* fixme: why does method subst not work?? *)
apply assumption
  apply clarify
  apply (rule conjI)
   apply (blast dest: boundedD)
  apply (erule pres_typeD)
     prefer 3 apply assumption
    apply simp
   apply simp
  apply (drule_tac P = "\<lambda>x. (a, b) \<in> set (step q x)" in subst)
   apply assumption

 apply (simp add: plusplus_empty)
 apply (cases "q \<in> w")
  apply simp
  apply (rule ub1')
     apply (rule semilat)
    apply clarify
    apply (rule pres_typeD)
       apply assumption
      prefer 3 apply assumption
     apply (blast intro: listE_nth_in dest: boundedD)
    apply (blast intro: pres_typeD dest: boundedD)
   apply (blast intro: listE_nth_in dest: boundedD)
  apply assumption

 apply simp
 apply (erule allE, erule impE, assumption, erule impE, assumption)
 apply (rule order_trans)
   apply simp
  defer
 apply (rule pp_ub2)(*
    apply assumption*)
   apply simp
   apply clarify
   apply simp
   apply (rule pres_typeD)
      apply assumption
     prefer 3 apply assumption
    apply (blast intro: listE_nth_in dest: boundedD)
   apply (blast intro: pres_typeD dest: boundedD)
  apply (blast intro: listE_nth_in dest: boundedD)
 apply blast
 done

lemma (in Semilat) merges_bounded_lemma:
 "\<lbrakk> mono r step n A; bounded step n;
    \<forall>(p',s') \<in> set (step p (ss!p)). s' \<in> A; ss \<in> list n A; ts \<in> list n A; p < n;
    ss <=[r] ts; \<forall>p. p < n \<longrightarrow> stable r step ts p \<rbrakk>
  \<Longrightarrow> merges f (step p (ss!p)) ss <=[r] ts"
  apply (unfold stable_def)
  apply (rule merges_pres_le_ub)
     apply simp
    apply simp
   prefer 2 apply assumption

  apply clarsimp
  apply (drule boundedD, assumption+)
  apply (erule allE, erule impE, assumption)
  apply (drule bspec, assumption)
  apply simp

  apply (drule monoD [of _ _ _ _ p "ss!p"  "ts!p"])
     apply assumption
    apply simp
   apply (simp add: le_listD)

  apply (drule lesub_step_typeD, assumption)
  apply clarify
  apply (drule bspec, assumption)
  apply simp
  apply (blast intro: order_trans)
  done

lemma termination_lemma:
  assumes semilat: "semilat (A, r, f)"
  shows "\<lbrakk> ss \<in> list n A; \<forall>(q,t)\<in>set qs. q<n \<and> t\<in>A; p\<in>w \<rbrakk> \<Longrightarrow>
  ss <[r] merges f qs ss \<or>
  merges f qs ss = ss \<and> {q. \<exists>t. (q,t)\<in>set qs \<and> t +_f ss!q \<noteq> ss!q} Un (w-{p}) < w" (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P" apply(insert semilat)
    apply (unfold lesssub_def)
    apply (simp (no_asm_simp) add: merges_incr)
    apply (rule impI)
    apply (rule merges_same_conv [THEN iffD1, elim_format])
    apply assumption+
    defer
    apply (rule sym, assumption)
    defer apply simp
    apply (subgoal_tac "\<forall>q t. \<not>((q, t) \<in> set qs \<and> t +_f ss ! q \<noteq> ss ! q)")
    apply (blast elim: equalityE)
    apply clarsimp
    apply (drule bspec, assumption)
    apply (drule bspec, assumption)
    apply clarsimp
    done
qed

lemma iter_properties[rule_format]:
  assumes semilat: "semilat (A, r, f)"
  shows "\<lbrakk> acc r ; pres_type step n A; mono r step n A;
     bounded step n; \<forall>p\<in>w0. p < n; ss0 \<in> list n A;
     \<forall>p<n. p \<notin> w0 \<longrightarrow> stable r step ss0 p \<rbrakk> \<Longrightarrow>
   iter f step ss0 w0 = (ss',w')
   \<longrightarrow>
   ss' \<in> list n A \<and> stables r step ss' \<and> ss0 <=[r] ss' \<and>
   (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow> ss' <=[r] ts)"
  (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P" apply(insert semilat)
apply (unfold iter_def stables_def)
apply (rule_tac P = "%(ss,w).
 ss \<in> list n A \<and> (\<forall>p<n. p \<notin> w \<longrightarrow> stable r step ss p) \<and> ss0 <=[r] ss \<and>
 (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow> ss <=[r] ts) \<and>
 (\<forall>p\<in>w. p < n)" and
 r = "{(ss',ss) . ss <[r] ss'} <*lex*> finite_psubset"
       in while_rule)

\<comment> \<open>Invariant holds initially:\<close>
apply (simp add:stables_def)

\<comment> \<open>Invariant is preserved:\<close>
apply(simp add: stables_def split_paired_all)
apply(rename_tac ss w)
apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
 prefer 2 apply (fast intro: someI)
apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
 prefer 2
 apply clarify
 apply (rule conjI)
  apply(clarsimp, blast dest!: boundedD)
 apply (erule pres_typeD)
  prefer 3
  apply assumption
  apply (erule listE_nth_in)
  apply simp
 apply simp
apply (subst decomp_propa)
 apply fast
apply simp
apply (rule conjI)
 apply (rule merges_preserves_type)
 apply blast
 apply clarify
 apply (rule conjI)
  apply(clarsimp, fast dest!: boundedD)
 apply (erule pres_typeD)
  prefer 3
  apply assumption
  apply (erule listE_nth_in)
  apply blast
 apply blast
apply (rule conjI)
 apply clarify
 apply (blast intro!: stable_pres_lemma)
apply (rule conjI)
 apply (blast intro!: merges_incr intro: le_list_trans)
apply (rule conjI)
 apply clarsimp
 apply (blast intro!: merges_bounded_lemma)
apply (blast dest!: boundedD)

\<comment> \<open>Postcondition holds upon termination:\<close>
apply(clarsimp simp add: stables_def split_paired_all)

\<comment> \<open>Well-foundedness of the termination relation:\<close>
apply (rule wf_lex_prod)
 apply (insert orderI [THEN acc_le_listI])
 apply (simp add: acc_def lesssub_def wfP_wf_eq [symmetric])
apply (rule wf_finite_psubset)

\<comment> \<open>Loop decreases along termination relation:\<close>
apply(simp add: stables_def split_paired_all)
apply(rename_tac ss w)
apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
 prefer 2 apply (fast intro: someI)
apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
 prefer 2
 apply clarify
 apply (rule conjI)
  apply(clarsimp, blast dest!: boundedD)
 apply (erule pres_typeD)
  prefer 3
  apply assumption
  apply (erule listE_nth_in)
  apply blast
 apply blast
apply (subst decomp_propa)
 apply blast
apply clarify
apply (simp del: listE_length
    add: lex_prod_def finite_psubset_def
         bounded_nat_set_is_finite)
apply (rule termination_lemma)
apply assumption+
defer
apply assumption
apply clarsimp
done

qed

lemma kildall_properties:
assumes semilat: "semilat (A, r, f)"
shows "\<lbrakk> acc r; pres_type step n A; mono r step n A;
     bounded step n; ss0 \<in> list n A \<rbrakk> \<Longrightarrow>
  kildall r f step ss0 \<in> list n A \<and>
  stables r step (kildall r f step ss0) \<and>
  ss0 <=[r] kildall r f step ss0 \<and>
  (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow>
                 kildall r f step ss0 <=[r] ts)"
  (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P"
    apply (unfold kildall_def)
    apply(case_tac "iter f step ss0 (unstables r step ss0)")
    apply(simp)
    apply (rule iter_properties)
            apply (simp_all add: unstables_def stable_def)
    apply (rule semilat)
    done
qed

lemma is_bcv_kildall:
assumes semilat: "semilat (A, r, f)"
shows "\<lbrakk> acc r; top r T; pres_type step n A; bounded step n; mono r step n A \<rbrakk>
  \<Longrightarrow> is_bcv r T step n A (kildall r f step)"
  (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P"
apply(unfold is_bcv_def wt_step_def)
apply(insert semilat kildall_properties[of A])
apply(simp add:stables_def)
apply clarify
apply(subgoal_tac "kildall r f step ss \<in> list n A")
 prefer 2 apply (simp(no_asm_simp))
apply (rule iffI)
 apply (rule_tac x = "kildall r f step ss" in bexI)
  apply (rule conjI)
   apply (blast)
  apply (simp  (no_asm_simp))
 apply(assumption)
apply clarify
apply(subgoal_tac "kildall r f step ss!p <=_r ts!p")
 apply simp
apply (blast intro!: le_listD less_lengthI)
done
qed

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Strassen's algorithm for matrix multiplication.\<close>

text \<open>We define the algorithm for arbitrary matrices over rings,
  where an alignment of the dimensions to even numbers will
  be performed throughout the algorithm.\<close>

theory Strassen_Algorithm
imports
  Matrix
begin

text \<open>With @{const four_block_mat} and @{const split_block} we can define Strassen's
  multiplication algorithm.\<close>

text \<open>We start with a simple heuristic on when to switch to the basic algorithm.\<close>

definition strassen_constant :: nat where
  [code_unfold]: "strassen_constant = 20"

definition "strassen_too_small A B \<equiv>
  dim_row A < strassen_constant \<or>
  dim_col A < strassen_constant \<or>
  dim_col B < strassen_constant"

text \<open>We have to make a case analysis on whether all dimensions are even.\<close>
definition "strassen_even A B \<equiv> even (dim_row A) \<and> even (dim_col A) \<and> even (dim_col B)"

text \<open>And then we can define the algorithm.\<close>

function strassen_mat_mult :: "'a :: ring mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
  "strassen_mat_mult A B = (let nr = dim_row A; n = dim_col A; nc = dim_col B in
    if strassen_too_small A B then A * B else
    if strassen_even A B then let
      nr2 = nr div 2;
      n2 = n div 2;
      nc2 = nc div 2;
      (A1,A2,A3,A4) = split_block A nr2 n2;
      (B1,B2,B3,B4) = split_block B n2 nc2;
      M1 = strassen_mat_mult (A1 + A4) (B1 + B4);
      M2 = strassen_mat_mult (A3 + A4) B1;
      M3 = strassen_mat_mult A1 (B2 - B4);
      M4 = strassen_mat_mult A4 (B3 - B1);
      M5 = strassen_mat_mult (A1 + A2) B4;
      M6 = strassen_mat_mult (A3 - A1) (B1 + B2);
      M7 = strassen_mat_mult (A2 - A4) (B3 + B4);
      C1 = M1 + M4 - M5 + M7;
      C2 = M3 + M5;
      C3 = M2 + M4;
      C4 = M1 - M2 + M3 + M6
    in four_block_mat C1 C2 C3 C4 else
    let
     nr' = (nr div 2) * 2;
     n' = (n div 2) * 2;
     nc' = (nc div 2) * 2;
     (A1,A2,A3,A4) = split_block A nr' n';
     (B1,B2,B3,B4) = split_block B n' nc';
     C1 = strassen_mat_mult A1 B1 + A2 * B3;
     C2 = A1 * B2 + A2 * B4;
     C3 = A3 * B1 + A4 * B3;
     C4 = A3 * B2 + A4 * B4
     in four_block_mat C1 C2 C3 C4)"
  by pat_completeness auto

text \<open>For termination, we use the following measure.\<close>

definition "strassen_measure \<equiv> \<lambda> (A,B). (dim_row A + dim_col A + dim_col B)
  + (dim_row A + dim_col A + dim_col B) + (if strassen_even A B then 0 else 1)"

lemma strassen_measure_add[simp]:
  "strassen_measure (A + B, C) = strassen_measure (B,C)"
  "strassen_measure (A, B + C) = strassen_measure (A,C)"
  "strassen_measure (A - B, C) = strassen_measure (B,C)"
  "strassen_measure (A, B - C) = strassen_measure (A,C)"
  "strassen_measure (- A, B) = strassen_measure (A,B)"
  "strassen_measure (A, - B) = strassen_measure (A,B)"
  unfolding strassen_measure_def strassen_even_def by auto

lemma strassen_measure_div_2: assumes "(A1, A2, A3, A4) = split_block A (dim_row A div 2) (dim_col A div 2)"
  "(B1, B2, B3, B4) = split_block B (dim_col A div 2) (dim_col B div 2)"
  and large: "\<not> strassen_too_small A B"
  shows
  "strassen_measure (A1,B4) < strassen_measure (A,B)"
  "strassen_measure (A1,B2) < strassen_measure (A,B)"
  "strassen_measure (A2,B4) < strassen_measure (A,B)"
  "strassen_measure (A3,B2) < strassen_measure (A,B)"
  "strassen_measure (A4,B1) < strassen_measure (A,B)"
  "strassen_measure (A4,B3) < strassen_measure (A,B)"
  "strassen_measure (A4,B4) < strassen_measure (A,B)"
proof -
  {
    fix Ai Bi
    assume Ai: "Ai \<in> {A1,A2,A3,A4}" and Bi: "Bi \<in> {B1,B2,B3,B4}"
    from large[unfolded strassen_too_small_def strassen_constant_def]
    have "\<not> dim_row A < 2" by auto
    with assms Ai Bi have Ar:
      "dim_row Ai < dim_row A"
      "dim_col Ai \<le> dim_col A"
      "dim_col Bi \<le> dim_col B"
      unfolding split_block_def Let_def by auto
    hence "strassen_measure (Ai,Bi) < strassen_measure (A,B)"
      unfolding strassen_measure_def split by auto
  }
  thus
    "strassen_measure (A1,B2) < strassen_measure (A,B)"
    "strassen_measure (A1,B4) < strassen_measure (A,B)"
    "strassen_measure (A2,B4) < strassen_measure (A,B)"
    "strassen_measure (A3,B2) < strassen_measure (A,B)"
    "strassen_measure (A4,B1) < strassen_measure (A,B)"
    "strassen_measure (A4,B3) < strassen_measure (A,B)"
    "strassen_measure (A4,B4) < strassen_measure (A,B)"
    by auto
qed

lemma strassen_measure_odd: assumes "(A1, A2, A3, A4) = split_block A ((dim_row A div 2) * 2) ((dim_col A div 2) * 2)"
  and "(B1, B2, B3, B4) = split_block B ((dim_col A div 2) * 2) ((dim_col B div 2) * 2)"
  and odd: "\<not> strassen_even A B"
  shows "strassen_measure (A1,B1) < strassen_measure (A,B)"
proof -
  from assms have Ar:
    "dim_row A1 < dim_row A \<or> dim_row A1 = dim_row A \<and> even (dim_row A)"
    unfolding split_block_def Let_def by auto presburger
  from assms have Ac:
    "dim_col A1 < dim_col A \<or> dim_col A1 = dim_col A \<and> even (dim_col A)"
    unfolding split_block_def Let_def by auto presburger
  from assms have Bc:
    "dim_col B1 < dim_col B \<or> dim_col B1 = dim_col B \<and> even (dim_col B)"
    unfolding split_block_def Let_def by auto presburger
  from Ar Ac Bc odd show ?thesis unfolding strassen_measure_def strassen_even_def split
    by (auto split: if_splits)
qed

termination by (relation "measure strassen_measure",
   auto elim: strassen_measure_div_2 strassen_measure_odd)

lemma strassen_mat_mult:
  "dim_col A = dim_row B \<Longrightarrow> strassen_mat_mult A B = A * B"
proof (induct A B rule: strassen_mat_mult.induct)
  case (1 A B)
  let ?nr = "dim_row A"
  let ?nc = "dim_col B"
  let ?n = "dim_col A"
  show ?case
  proof (cases "strassen_too_small A B")
    case False note large = this
    let ?smm = strassen_mat_mult
    note IH = 1(1-8)[OF refl refl refl False _ refl refl refl _ refl refl refl _ refl refl refl]
    show ?thesis
    proof (cases "strassen_even A B")
      case True
      note even = True[unfolded strassen_even_def]
      let ?nr2 = "?nr div 2"
      let ?n2 = "?n div 2"
      let ?nc2 = "?nc div 2"
      from even have nr: "?nr = ?nr2 + ?nr2" by presburger
      from even have n: "?n = ?n2 + ?n2" by presburger
      from even have nc: "?nc = ?nc2 + ?nc2" by presburger
      from 1(9) even have n': "dim_row B = ?n2 + ?n2"
        by auto
      obtain A1 A2 A3 A4 where splitA:
        "split_block A ?nr2 ?n2 = (A1,A2,A3,A4)" by (rule prod_cases4)
      obtain B1 B2 B3 B4 where splitB:
        "split_block B ?n2 ?nc2 = (B1,B2,B3,B4)" by (rule prod_cases4)
      note IH = IH(1-7)[OF True splitA[symmetric] splitB[symmetric] ]
      from split_block[OF splitA nr n]
      have blockA: "A = four_block_mat A1 A2 A3 A4"
        and A1: "A1 \<in> carrier_mat ?nr2 ?n2"
        and A2: "A2 \<in> carrier_mat ?nr2 ?n2"
        and A3: "A3 \<in> carrier_mat ?nr2 ?n2"
        and A4: "A4 \<in> carrier_mat ?nr2 ?n2"
        by blast+
      from split_block[OF splitB n' nc]
      have blockB: "B = four_block_mat B1 B2 B3 B4"
        and B1: "B1 \<in> carrier_mat ?n2 ?nc2"
        and B2: "B2 \<in> carrier_mat ?n2 ?nc2"
        and B3: "B3 \<in> carrier_mat ?n2 ?nc2"
        and B4: "B4 \<in> carrier_mat ?n2 ?nc2"
        by blast+
      note carr = A1 A2 A3 A4 B1 B2 B3 B4
      let ?M11 = "A1 + A4" let ?M12 = "B1 + B4"
      let ?M21 = "A3 + A4" let ?M22 = "B1"
      let ?M31 = "A1" let ?M32 = "B2 - B4"
      let ?M41 = "A4" let ?M42 = "B3 - B1"
      let ?M51 = "A1 + A2" let ?M52 = "B4"
      let ?M61 = "A3 - A1" let ?M62 = "B1 + B2"
      let ?M71 = "A2 - A4" let ?M72 = "B3 + B4"
      let ?M1 = "?smm ?M11 ?M12"
      let ?M2 = "?smm ?M21 ?M22"
      let ?M3 = "?smm ?M31 ?M32"
      let ?M4 = "?smm ?M41 ?M42"
      let ?M5 = "?smm ?M51 ?M52"
      let ?M6 = "?smm ?M61 ?M62"
      let ?M7 = "?smm ?M71 ?M72"
      let ?C1 = "?M1 + ?M4 - ?M5 + ?M7"
      let ?C2 = "?M3 + ?M5"
      let ?C3 = "?M2 + ?M4"
      let ?C4 = "?M1 - ?M2 + ?M3 + ?M6"
      have res: "?smm A B = four_block_mat ?C1 ?C2 ?C3 ?C4"
        using large True
        unfolding strassen_mat_mult.simps[of A B] Let_def splitA splitB split
        by auto
      have M1: "?M1 = ?M11 * ?M12"
        by (rule IH(1), insert carr, auto)
      note IH = IH(2-)[OF refl]
      have M2: "?M2 = ?M21 * ?M22"
        by (rule IH(1), insert carr, auto)
      note IH = IH(2-)[OF refl]
      have M3: "?M3 = ?M31 * ?M32"
        by (rule IH(1), insert carr, auto)
      note IH = IH(2-)[OF refl]
      have M4: "?M4 = ?M41 * ?M42"
        by (rule IH(1), insert carr, auto)
      note IH = IH(2-)[OF refl]
      have M5: "?M5 = ?M51 * ?M52"
        by (rule IH(1), insert carr, auto)
      note IH = IH(2-)[OF refl]
      have M6: "?M6 = ?M61 * ?M62"
        by (rule IH(1), insert carr, auto)
      note IH = IH(2-)[OF refl]
      have M7: "?M7 = ?M71 * ?M72"
        by (rule IH(1), insert carr, auto)
      note distr =
        add_mult_distrib_mat[of _ ?nr2 ?n2 _ _ ?nc2]
        minus_mult_distrib_mat[of _ ?nr2 ?n2 _ _ ?nc2]
        mult_add_distrib_mat[of _ ?nr2 ?n2 _ ?nc2]
        mult_minus_distrib_mat[of _ ?nr2 ?n2 _ ?nc2]
      note closed = add_carrier_mat[of _ ?nr2 ?nc2]
         uminus_carrier_iff_mat[of _ ?nr2 ?nc2]
      note ac = assoc_add_mat[of _ ?nr2 ?nc2] comm_add_mat[of _ ?nr2 ?nc2]
      show ?thesis unfolding res M1 M2 M3 M4 M5 M6 M7
        unfolding blockA blockB
          mult_four_block_mat[OF carr]
        by (rule cong_four_block_mat)
           (insert carr, auto simp: distr ac closed)
    next
      case False
      let ?nr2 = "?nr div 2 * 2" let ?nr2' = "?nr - ?nr2"
      let ?n2 = "?n div 2 * 2"   let ?n2' = "?n - ?n2"
      let ?nc2 = "?nc div 2 * 2" let ?nc2' = "?nc - ?nc2"
      have nr: "?nr = ?nr2 + ?nr2'" by presburger
      have n: "?n = ?n2 + ?n2'" by presburger
      have nc: "?nc = ?nc2 + ?nc2'" by presburger
      from 1(9) have n': "dim_row B = ?n2 + ?n2'" by auto
      obtain A1 A2 A3 A4 where splitA:
        "split_block A ?nr2 ?n2 = (A1,A2,A3,A4)" by (rule prod_cases4)
      obtain B1 B2 B3 B4 where splitB:
        "split_block B ?n2 ?nc2 = (B1,B2,B3,B4)" by (rule prod_cases4)
      note IH = IH(8)[OF False splitA[symmetric] splitB[symmetric]]
      from split_block[OF splitA nr n]
      have blockA: "A = four_block_mat A1 A2 A3 A4"
        and A1: "A1 \<in> carrier_mat ?nr2 ?n2"
        and A2: "A2 \<in> carrier_mat ?nr2 ?n2'"
        and A3: "A3 \<in> carrier_mat ?nr2' ?n2"
        and A4: "A4 \<in> carrier_mat ?nr2' ?n2'"
        by blast+
      from split_block[OF splitB n' nc]
      have blockB: "B = four_block_mat B1 B2 B3 B4"
        and B1: "B1 \<in> carrier_mat ?n2 ?nc2"
        and B2: "B2 \<in> carrier_mat ?n2 ?nc2'"
        and B3: "B3 \<in> carrier_mat ?n2' ?nc2"
        and B4: "B4 \<in> carrier_mat ?n2' ?nc2'"
        by blast+
      note carr = A1 A2 A3 A4 B1 B2 B3 B4
      from carr have "dim_col A1 = dim_row B1" by simp
      note IH = IH[OF this]
      have "?smm A B = four_block_mat
        (A1 * B1 + A2 * B3)
        (A1 * B2 + A2 * B4)
        (A3 * B1 + A4 * B3)
        (A3 * B2 + A4 * B4)"
        unfolding strassen_mat_mult.simps[of A B] Let_def
          splitA splitB split IH using large False by auto
      also have "\<dots> = A * B"
        unfolding blockA blockB
         mult_four_block_mat[OF carr] by simp
      finally show ?thesis by simp
    qed
  qed simp
qed

end


theory P07
imports Main
begin

datatype 'a NestedList  =  Elem 'a | List "('a NestedList) list"

fun p07_1 :: "'a NestedList \<Rightarrow> 'a list" where
"p07_1 (Elem val) =  [val]"|
"p07_1 (List ls) = concat (map p07_1 ls)"

lemma "p07_1 (Elem (5::nat)) = [5]" by simp

lemma "p07_1 (List [List [List [Elem (4::nat), Elem 5 , Elem 6] , List [Elem 3]  , Elem 1] , Elem 7 , List [Elem 8]])
      = [4,5,6,3,1,7,8]" by simp

theorem "p07_1 "


(*  Title:       Invariants.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

header "Reachability and Invariance"

theory Invariants
imports Lib TransitionSystems
begin

subsection Reachability

text \<open>
  A state is `reachable' under @{term I} if either it is the initial state, or it is the
  destination of a transition whose action satisfies @{term I} from a reachable state.
  The `standard' definition of reachability is recovered by setting @{term I} to @{term TT}.
\<close>

inductive_set reachable
  for A :: "('s, 'a) automaton"
  and I :: "'a \<Rightarrow> bool"
where
    reachable_init: "s \<in> init A \<Longrightarrow> s \<in> reachable A I"
  | reachable_step: "\<lbrakk> s \<in> reachable A I; (s, a, s') \<in> trans A; I a \<rbrakk> \<Longrightarrow> s' \<in> reachable A I"

inductive_cases reachable_icases: "s \<in> reachable A I"

lemma reachable_pair_induct [consumes, case_names init step]:
  assumes "(\<xi>, p) \<in> reachable A I"
      and "\<And>\<xi> p. (\<xi>, p) \<in> init A \<Longrightarrow> P \<xi> p"
      and "(\<And>\<xi> p \<xi>' p' a. \<lbrakk> (\<xi>, p) \<in> reachable A I; P \<xi> p;
                            ((\<xi>, p), a, (\<xi>', p')) \<in> trans A; I a \<rbrakk> \<Longrightarrow> P \<xi>' p')"
    shows "P \<xi> p"
  using assms(1) proof (induction "(\<xi>, p)" arbitrary: \<xi> p)
    fix \<xi> p
    assume "(\<xi>, p) \<in> init A"
    with assms(2) show "P \<xi> p" .
  next
    fix s a \<xi>' p'
    assume "s \<in> reachable A I"
       and tr: "(s, a, (\<xi>', p')) \<in> trans A"
       and "I a"
       and IH: "\<And>\<xi> p. s = (\<xi>, p) \<Longrightarrow> P \<xi> p"
    from this(1) obtain \<xi> p where "s = (\<xi>, p)"
                              and "(\<xi>, p) \<in> reachable A I"
      by (metis pair_collapse)
    note this(2)
    moreover from IH and \<open>s = (\<xi>, p)\<close> have "P \<xi> p" .
    moreover from tr and \<open>s = (\<xi>, p)\<close> have "((\<xi>, p), a, (\<xi>', p')) \<in> trans A" by simp
    ultimately show "P \<xi>' p'"
      using \<open>I a\<close> by (rule assms(3))
  qed

lemma reachable_weakenE [elim]:
  assumes "s \<in> reachable A P"
      and PQ: "\<And>a. P a \<Longrightarrow> Q a"
    shows "s \<in> reachable A Q"
  using assms(1)
  proof (induction)
    fix s assume "s \<in> init A"
    thus "s \<in> reachable A Q" ..
  next
    fix s a s'
    assume "s \<in> reachable A P"
       and "s \<in> reachable A Q"
       and "(s, a, s') \<in> trans A"
       and "P a"
    from \<open>P a\<close> have "Q a" by (rule PQ)
    with \<open>s \<in> reachable A Q\<close> and \<open>(s, a, s') \<in> trans A\<close> show "s' \<in> reachable A Q" ..
  qed

lemma reachable_weaken_TT [elim]:
  assumes "s \<in> reachable A I"
    shows "s \<in> reachable A TT"
  using assms by rule simp

lemma init_empty_reachable_empty:
  assumes "init A = {}"
    shows "reachable A I = {}"
  proof (rule ccontr)
    assume "reachable A I \<noteq> {}"
    then obtain s where "s \<in> reachable A I" by auto
    thus False
    proof (induction rule: reachable.induct)
      fix s
      assume "s \<in> init A"
      with \<open>init A = {}\<close> show False by simp
    qed
  qed

subsection Invariance

definition invariant
  :: "('s, 'a) automaton \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool"
  ("_ \<TTurnstile> (1'(_ \<rightarrow>')/ _)" [100, 0, 9] 8)
where
  "(A \<TTurnstile> (I \<rightarrow>) P) = (\<forall>s\<in>reachable A I. P s)"

abbreviation
  any_invariant
  :: "('s, 'a) automaton \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool"
  ("_ \<TTurnstile> _" [100, 9] 8)
where
  "(A \<TTurnstile> P) \<equiv> (A \<TTurnstile> (TT \<rightarrow>) P)"

lemma invariantI [intro]:
  assumes init: "\<And>s. s \<in> init A \<Longrightarrow> P s"
      and step: "\<And>s a s'. \<lbrakk> s \<in> reachable A I; P s; (s, a, s') \<in> trans A; I a \<rbrakk> \<Longrightarrow> P s'"
    shows "A \<TTurnstile> (I \<rightarrow>) P"
  unfolding invariant_def
  proof
       fix s
    assume "s \<in> reachable A I"
      thus "P s"
    proof induction
      fix s assume "s \<in> init A"
      thus "P s" by (rule init)
    next
      fix s a s'
      assume "s \<in> reachable A I"
         and "P s"
         and "(s, a, s') \<in> trans A"
         and "I a"
        thus "P s'" by (rule step)
    qed
  qed

lemma invariant_pairI [intro]:
  assumes init: "\<And>\<xi> p. (\<xi>, p) \<in> init A \<Longrightarrow> P (\<xi>, p)"
      and step: "\<And>\<xi> p \<xi>' p' a.
                   \<lbrakk> (\<xi>, p) \<in> reachable A I; P (\<xi>, p); ((\<xi>, p), a, (\<xi>', p')) \<in> trans A; I a \<rbrakk>
                   \<Longrightarrow> P (\<xi>', p')"
    shows "A \<TTurnstile> (I \<rightarrow>) P"
  using assms by auto

lemma invariant_arbitraryI:
  assumes "\<And>s. s \<in> reachable A I \<Longrightarrow> P s"
    shows "A \<TTurnstile> (I \<rightarrow>) P"
  using assms unfolding invariant_def by simp

lemma invariantD [dest]:
  assumes "A \<TTurnstile> (I \<rightarrow>) P"
      and "s \<in> reachable A I"
    shows "P s"
  using assms unfolding invariant_def by blast

lemma invariant_initE [elim]:
  assumes invP: "A \<TTurnstile> (I \<rightarrow>) P"
      and init: "s \<in> init A"
    shows "P s"
  proof -
    from init have "s \<in> reachable A I" ..
    with invP show ?thesis ..
  qed

lemma invariant_weakenE [elim]:
  fixes T \<sigma> P Q
  assumes invP: "A \<TTurnstile> (PI \<rightarrow>) P"
      and PQ:   "\<And>s. P s \<Longrightarrow> Q s"
      and QIPI: "\<And>a. QI a \<Longrightarrow> PI a"
    shows       "A \<TTurnstile> (QI \<rightarrow>) Q"
  proof
    fix s
    assume "s \<in> init A"
    with invP have "P s" ..
    thus "Q s" by (rule PQ)
  next
    fix s a s'
    assume "s \<in> reachable A QI"
       and "(s, a, s') \<in> trans A"
       and "QI a"
    from \<open>QI a\<close> have "PI a" by (rule QIPI)
    from \<open>s \<in> reachable A QI\<close> and QIPI have "s \<in> reachable A PI" ..
    hence "s' \<in> reachable A PI" using \<open>(s, a, s') \<in> trans A\<close> and \<open>PI a\<close> ..
    with invP have "P s'" ..
    thus "Q s'" by (rule PQ)
  qed

definition
  step_invariant
  :: "('s, 'a) automaton \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> (('s, 'a) transition \<Rightarrow> bool) \<Rightarrow> bool"
  ("_ \<TTurnstile>\<^sub>A (1'(_ \<rightarrow>')/ _)" [100, 0, 0] 8)
where
  "(A \<TTurnstile>\<^sub>A (I \<rightarrow>) P) = (\<forall>a. I a \<longrightarrow> (\<forall>s\<in>reachable A I. (\<forall>s'.(s, a, s') \<in> trans A \<longrightarrow> P (s, a, s'))))"

lemma invariant_restrict_inD [dest]:
  assumes "A \<TTurnstile> (TT \<rightarrow>) P"
    shows "A \<TTurnstile> (QI \<rightarrow>) P"
  using assms by auto

abbreviation
  any_step_invariant
  :: "('s, 'a) automaton \<Rightarrow> (('s, 'a) transition \<Rightarrow> bool) \<Rightarrow> bool"
  ("_ \<TTurnstile>\<^sub>A _" [100, 9] 8)
where
  "(A \<TTurnstile>\<^sub>A P) \<equiv> (A \<TTurnstile>\<^sub>A (TT \<rightarrow>) P)"

lemma step_invariant_true:
  "p \<TTurnstile>\<^sub>A (\<lambda>(s, a, s'). True)"
  unfolding step_invariant_def by simp

lemma step_invariantI [intro]:
  assumes *: "\<And>s a s'. \<lbrakk> s\<in>reachable A I; (s, a, s')\<in>trans A; I a \<rbrakk> \<Longrightarrow> P (s, a, s')"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
  unfolding step_invariant_def
  using assms by auto

lemma step_invariantD [dest]:
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
      and "s\<in>reachable A I"
      and "(s, a, s') \<in> trans A"
      and "I a"
    shows "P (s, a, s')"
  using assms unfolding step_invariant_def by blast

lemma step_invariantE [elim]:
    fixes T \<sigma> P I s a s'
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
      and "s\<in>reachable A I"
      and "(s, a, s') \<in> trans A"
      and "I a"
      and "P (s, a, s') \<Longrightarrow> Q"
    shows "Q"
  using assms by auto

lemma step_invariant_pairI [intro]:
  assumes *: "\<And>\<xi> p \<xi>' p' a.
              \<lbrakk> (\<xi>, p) \<in> reachable A I; ((\<xi>, p), a, (\<xi>', p')) \<in> trans A; I a \<rbrakk>
                                                       \<Longrightarrow> P ((\<xi>, p), a, (\<xi>', p'))"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
  using assms by auto

lemma step_invariant_arbitraryI:
  assumes "\<And>\<xi> p a \<xi>' p'. \<lbrakk> (\<xi>, p) \<in> reachable A I; ((\<xi>, p), a, (\<xi>', p')) \<in> trans A; I a \<rbrakk>
           \<Longrightarrow> P ((\<xi>, p), a, (\<xi>', p'))"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
  using assms by auto

lemma step_invariant_weakenE [elim!]:
  fixes T \<sigma> P Q
  assumes invP: "A \<TTurnstile>\<^sub>A (PI \<rightarrow>) P"
      and PQ:   "\<And>t. P t \<Longrightarrow> Q t"
      and QIPI: "\<And>a. QI a \<Longrightarrow> PI a"
    shows       "A \<TTurnstile>\<^sub>A (QI \<rightarrow>) Q"
  proof
    fix s a s'
    assume "s \<in> reachable A QI"
       and "(s, a, s') \<in> trans A"
       and "QI a"
    from \<open>QI a\<close> have "PI a" by (rule QIPI)
    from \<open>s \<in> reachable A QI\<close> have "s \<in> reachable A PI" using QIPI ..
    with invP have "P (s, a, s')" using \<open>(s, a, s') \<in> trans A\<close> \<open>PI a\<close> ..
    thus "Q (s, a, s')" by (rule PQ)
  qed

lemma step_invariant_weaken_with_invariantE [elim]:
  assumes pinv: "A \<TTurnstile> (I \<rightarrow>) P"
      and qinv: "A \<TTurnstile>\<^sub>A (I \<rightarrow>) Q"
      and wr: "\<And>s a s'. \<lbrakk> P s; P s'; Q (s, a, s'); I a \<rbrakk> \<Longrightarrow> R (s, a, s')"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) R"
  proof
    fix s a s'
    assume sr: "s \<in> reachable A I"
       and tr: "(s, a, s') \<in> trans A"
       and "I a"
    hence "s' \<in> reachable A I" ..
    with pinv have "P s'" ..
    from pinv and sr have "P s" ..
    from qinv sr tr \<open>I a\<close> have "Q (s, a, s')" ..
    with \<open>P s\<close> and \<open>P s'\<close> show "R (s, a, s')" using \<open>I a\<close> by (rule wr)
  qed

lemma step_to_invariantI:
  assumes sinv: "A \<TTurnstile>\<^sub>A (I \<rightarrow>) Q"
      and init: "\<And>s. s \<in> init A \<Longrightarrow> P s"
      and step: "\<And>s s' a.
                   \<lbrakk> s \<in> reachable A I;
                     P s;
                     Q (s, a, s');
                     I a \<rbrakk> \<Longrightarrow> P s'"
    shows "A \<TTurnstile> (I \<rightarrow>) P"
  proof
    fix s assume "s \<in> init A" thus "P s" by (rule init)
  next
    fix s s' a
    assume "s \<in> reachable A I"
       and "P s"
       and "(s, a, s') \<in> trans A"
       and "I a"
      show "P s'"
    proof -
      from sinv and \<open>s\<in>reachable A I\<close> and \<open>(s, a, s')\<in>trans A\<close> and \<open>I a\<close> have "Q (s, a, s')" ..
      with \<open>s\<in>reachable A I\<close> and \<open>P s\<close> show "P s'" using \<open>I a\<close> by (rule step)
    qed
  qed

end


text \<open>
Created 2021-09-10, by Anand Shetler
\<close>

theory CommAnd
  imports Main

begin

text\<open> Apply style \<close>
lemma lem_k_1 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
  apply (rule impI)
  apply (rule conjI)
  apply (erule conjE)
   apply assumption
  apply (erule conjE)
  apply assumption
  done

text\<open> Isar style, the proof illustrates the use of intermediate facts,
   once more with keywords 'from ... have ...' \<close>
lemma lem_l_1 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
proof
  assume a : "p \<and> q"
  from a have b : "p" by (rule conjE)     (* INTERMEDIATE fact *)
  from a have c : "q" by (rule conjE)     (* INTERMEDIATE fact *)
  from c b show "q \<and> p" by (rule conjI)   (* we must write 'from c b' not 'from b c' *)
qed

text\<open> Isar style, lem_l_1 again, with more abbreviations \<close>
lemma lem_l_2 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
proof
  assume a : "p \<and> q"
  from a have b : "p" ..
  from a have c : "q" ..
  from c b show "(q \<and> p)" ..
qed

text\<open> Isar style, lem_l_1 again, with nested proofs \<close>
lemma lem_l_3 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
proof
  assume a : "p \<and> q"
  from a show "q \<and> p"
  proof
    assume b : "p"
    assume c : "q"
    from c b show "q \<and> p" by (rule conjI)
  qed
qed

end


theory Nchoice
imports Assign
begin

subsection \<open>Generic operations\<close>
(*Generic operations without axiomas*)

locale abel_abel_semigroup = abel_semigroup +
  assumes idemp [ac_simps]: "a \<^bold>* a = a"

class nchoice =
  fixes nchoice :: "'a proc \<Rightarrow> 'a proc \<Rightarrow> 'a proc" (infixl "\<sqinter>" 70)
  assumes nch_assoc [algebra_simps, field_simps]: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
      and nch_commute [algebra_simps, field_simps]: "x \<sqinter> y = y \<sqinter> x"
      and nch_idemp [algebra_simps, field_simps]: "(x \<sqinter> x) = x"
      and nch_zero_left[simp] : "\<bottom> \<sqinter> a = \<bottom>"
      and nch_zero_right[simp] : "a \<sqinter> \<bottom> = \<bottom>"
      and nch_skip_left: " II \<sqinter> a = a"
      and nch_skip_right: "a \<sqinter>  II = a"
begin
sublocale ncho: semigroup nchoice
  by standard (fact nch_assoc)

sublocale ncho: abel_semigroup nchoice
  by standard (fact nch_commute)

declare ncho.left_commute [algebra_simps, field_simps]

sublocale ncho: abel_abel_semigroup nchoice
  by standard (fact nch_idemp)

lemmas ncho_ac = ncho.assoc ncho.commute ncho.left_commute  ncho.idemp

sublocale add: monoid nchoice  II
  by standard (fact nch_skip_left nch_skip_right)+

lemma zero_reorient: "a =  II  \<longleftrightarrow>  II = a"
  by (fact eq_commute)
end

(*LawA1_1,LawA1_2*)
class comm_monoid_nchoice = nchoice +
  assumes nchoice_II : " II \<sqinter> a = a"
begin
subclass nchoice ..

sublocale add: comm_monoid nchoice II
   by standard (simp add: ac_simps)
end

print_locale! comm_monoid_nchoice

subsection \<open>Generalized operations over a set\<close>

context comm_monoid_nchoice
begin
sublocale Nchoice: comm_monoid_set nchoice II
  defines Nchoice = Nchoice.F ..

abbreviation NChoice ("\<Sqinter>_" [1000] 999)
  where "\<Sqinter>A \<equiv> Nchoice (\<lambda>a. a) A"

print_locale! comm_monoid_nchoice

end

(***test***)
lemma nch_left_comm : "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
  by (simp add: ncho.commute ncho.left_commute)

lemma nch_left_idem : "x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
  by (metis nch_assoc nch_idemp)

lemma "((x \<sqinter> (x \<sqinter> y)) ;; Y:=B) ;; Z :=C = (x \<sqinter> y) ;; (Y:=B ;; Z :=C)"
  by (simp add: nch_left_idem serial_assoc)

lemma  "\<Sqinter>{x,y} =  \<Sqinter>{x,y,y}"
  by auto

lemma "(\<Sqinter>A \<sqinter> \<Sqinter>A) \<sqinter> \<Sqinter>C = \<Sqinter>A  \<sqinter> \<Sqinter>C"
  by (simp add: nch_idemp)

lemma LawA3_1_1:
  assumes "finite A" and "finite B"
  shows "\<Sqinter>(A \<union> B)  = \<Sqinter>(A-(A \<inter> B)) \<sqinter> \<Sqinter>(B-(A \<inter> B)) \<sqinter> \<Sqinter>(A \<inter> B)"
  by (metis Diff_Int2 Int_commute Nchoice.union_diff2 assms inf.idem)

lemma LawA3_1_2:
  assumes "finite A" and "finite B"
  shows "\<Sqinter>(A \<union> B)  = \<Sqinter>(A-(A \<inter> B)) \<sqinter> \<Sqinter>(B-(A \<inter> B)) \<sqinter> \<Sqinter>(A \<inter> B)  \<sqinter> \<Sqinter>(A \<inter> B)"
  by (simp add: LawA3_1_1 assms nch_left_idem ncho.commute)

lemma LawA3_1:
  assumes "finite A" and "finite B"
  shows "\<Sqinter>(A \<union> B)  = \<Sqinter>(A) \<sqinter> \<Sqinter>(B)"
  by (metis LawA3_1_1 LawA3_1_2 Nchoice.union_inter assms)

lemma "A = {x,y} \<Longrightarrow> \<Sqinter>(A) = x \<sqinter> y"
  by (simp add: Nchoice.insert_if ncho_ac(4))

class all_operater = serial + assi +  comm_monoid_nchoice +
  assumes serial_1: "\<forall>x \<in> A. \<Sqinter>(A) ;; y = \<Sqinter>{(x ;; y)}"
      and serial_2: "\<forall>y \<in> B. x ;; \<Sqinter>(B) = \<Sqinter>{(x ;; y)}"

declare all_operater.serial_1
declare all_operater.serial_2
(***why "class = xxx + xxxx + assumes" doesn't work?
theorem "\<forall>x \<in> A. \<Sqinter>(A) ;; y = \<Sqinter>{(x ;; y)}"
***)

end


(*  File:       Condorcet_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Condorcet Module\<close>

theory Condorcet_Module
  imports "Component_Types/Elimination_Module"
begin

text
\<open>This is the Condorcet module used by the Condorcet (voting) rule. The Condorcet
rule is a voting rule that implements the Condorcet criterion, i.e., it elects
the Condorcet winner if it exists, otherwise a tie remains between all
alternatives. The module implemented herein only rejects the alternatives not
elected by the voting rule, and defers the alternatives that would be elected
by the full voting rule.\<close>

subsection \<open>Definition\<close>

fun condorcet_score :: "'a Evaluation_Function" where
  "condorcet_score x A p =
    (if (condorcet_winner A p x) then 1 else 0)"

fun condorcet :: "'a Electoral_Module" where
  "condorcet A p = (max_eliminator condorcet_score) A p"

subsection \<open>Property\<close>

(* Condorcet score is Condorcet rating. *)
theorem condorcet_score_is_condorcet_rating: "condorcet_rating condorcet_score"
proof -
  have
    "\<forall>f.
      (\<not> condorcet_rating f \<longrightarrow>
          (\<exists>A rs a.
            condorcet_winner A rs a \<and>
              (\<exists>aa. \<not> f (aa::'a) A rs < f a A rs \<and> a \<noteq> aa \<and> aa \<in> A))) \<and>
        (condorcet_rating f \<longrightarrow>
          (\<forall>A rs a. condorcet_winner A rs a \<longrightarrow>
            (\<forall>aa. f aa A rs < f a A rs \<or> a = aa \<or> aa \<notin> A)))"
    unfolding condorcet_rating_def
    by (metis (mono_tags, hide_lams))
  thus ?thesis
    using cond_winner_unique condorcet_score.simps zero_less_one
    by (metis (no_types))
qed

theorem condorcet_is_dcc: "defer_condorcet_consistency condorcet"
unfolding defer_condorcet_consistency_def electoral_module_def
proof (safe)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    finA: "finite A" and
    profA: "profile A p"
  have "well_formed A (max_eliminator condorcet_score A p)"
    using finA profA electoral_module_def max_elim_sound
    by metis
  thus "well_formed A (condorcet A p)"
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    cwin_w: "condorcet_winner A p w" and
    finA: "finite A"
  have max_cscore_dcc:
    "defer_condorcet_consistency (max_eliminator condorcet_score)"
    using cr_eval_imp_dcc_max_elim
    by (simp add: condorcet_score_is_condorcet_rating)
  from defer_condorcet_consistency_def
  have
    "max_eliminator condorcet_score A p =
  ({},
  A - defer (max_eliminator condorcet_score) A p,
  {a \<in> A. condorcet_winner A p a})"
    using cwin_w finA max_cscore_dcc
    by (metis (no_types))
  thus
    "condorcet A p =
      ({},
       A - defer condorcet A p,
       {d \<in> A. condorcet_winner A p d})"
    by simp
qed

end


section "Partial States"

subsection \<open>Partial evaluation of expressions\<close>
theory Partial_Evaluation
imports AExp Vars
begin

type_synonym partstate = "(vname \<Rightarrow> val option)"

definition emb :: "partstate \<Rightarrow> state \<Rightarrow> state" where
   "emb ps s = (%v. (case (ps v) of (Some r) \<Rightarrow> r | None \<Rightarrow> s v))"

definition part :: "state \<Rightarrow> partstate" where
   "part s = (%v. Some (s v))"

lemma emb_part[simp]: "emb (part s) q = s" unfolding emb_def part_def by auto

lemma part_emb[simp]: "dom ps = UNIV \<Longrightarrow> part (emb ps q) = ps" unfolding emb_def part_def apply(rule ext)
  by (simp add: domD option.case_eq_if)

lemma dom_part[simp]: "dom (part s) = UNIV" unfolding part_def by auto

abbreviation optplus :: "int option \<Rightarrow> int option \<Rightarrow> int option"   where "optplus a b \<equiv> (case a of None \<Rightarrow> None | Some a' \<Rightarrow> (case b of None \<Rightarrow> None | Some b' \<Rightarrow> Some (a' + b'))) "
abbreviation opttimes :: "int option \<Rightarrow> int option \<Rightarrow> int option"   where "opttimes a b \<equiv> (case a of None \<Rightarrow> None | Some a' \<Rightarrow> (case b of None \<Rightarrow> None | Some b' \<Rightarrow> Some (a' * b'))) "
abbreviation optdiv :: "int option \<Rightarrow> int option \<Rightarrow> int option"   where "optdiv a b \<equiv> (case a of None \<Rightarrow> None | Some a' \<Rightarrow> (case b of None \<Rightarrow> None | Some b' \<Rightarrow> Some (a' div b'))) "

fun paval' :: "aexp \<Rightarrow> partstate \<Rightarrow> val option" where
"paval' (N n) s = Some n" |
"paval' (V x) s = s x" |
"paval' (Plus a\<^sub>1 a\<^sub>2) s = optplus (paval' a\<^sub>1 s)   (paval' a\<^sub>2 s)" |
"paval' (Times a\<^sub>1 a\<^sub>2) s = opttimes (paval' a\<^sub>1 s)   (paval' a\<^sub>2 s)" |
"paval' (Div a\<^sub>1 a\<^sub>2) s = optdiv (paval' a\<^sub>1 s)   (paval' a\<^sub>2 s)"

lemma "paval' a ps = Some v \<Longrightarrow> vars a \<subseteq> dom ps"
proof(induct a arbitrary: v)
  case (Plus a1 a2)
  from Plus(3) obtain v1 where 1: "paval' a1 ps = Some v1"
    by fastforce
  with Plus(3) obtain v2 where 2: "paval' a2 ps = Some v2"
    by fastforce
  from Plus(1)[OF 1] Plus(2)[OF 2] show ?case by auto
next
  case (Times a1 a2)
  from Times(3) obtain v1 where 1: "paval' a1 ps = Some v1"
    by fastforce
  with Times(3) obtain v2 where 2: "paval' a2 ps = Some v2"
    by fastforce
  from Times(1)[OF 1] Times(2)[OF 2] show ?case by auto
next
  case (Div a1 a2)
  from Div(3) obtain v1 where 1: "paval' a1 ps = Some v1"
    by fastforce
  with Div(3) obtain v2 where 2: "paval' a2 ps = Some v2"
    by fastforce
  from Div(1)[OF 1] Div(2)[OF 2] show ?case by auto
qed  (simp_all, blast)

lemma paval'_aval: "paval' a ps = Some v \<Longrightarrow> aval a (emb ps s) = v"
proof(induct a arbitrary: v)
  case (Plus a1 a2)
  from Plus(3) obtain v1 where 1: "paval' a1 ps = Some v1"
    by fastforce
  with Plus(3) obtain v2 where 2: "paval' a2 ps = Some v2"
    by fastforce
  from Plus(1)[OF 1] Plus(2)[OF 2] Plus(3) 1 2 show ?case by auto
next
  case (Times a1 a2)
  from Times(3) obtain v1 where 1: "paval' a1 ps = Some v1"
    by fastforce
  with Times(3) obtain v2 where 2: "paval' a2 ps = Some v2"
    by fastforce
  from Times(1)[OF 1] Times(2)[OF 2] Times(3) 1 2 show ?case by auto
next
  case (Div a1 a2)
  from Div(3) obtain v1 where 1: "paval' a1 ps = Some v1"
    by fastforce
  with Div(3) obtain v2 where 2: "paval' a2 ps = Some v2"
    by fastforce
  from Div(1)[OF 1] Div(2)[OF 2] Div(3) 1 2 show ?case by auto
qed (simp_all add: emb_def)

fun paval :: "aexp \<Rightarrow> partstate \<Rightarrow> val" where
"paval (N n) s = n" |
"paval (V x) s = the (s x)" |
"paval (Plus a\<^sub>1 a\<^sub>2) s = paval a\<^sub>1 s + paval a\<^sub>2 s" |
"paval (Times a\<^sub>1 a\<^sub>2) s = paval a\<^sub>1 s * paval a\<^sub>2 s" |
"paval (Div a\<^sub>1 a\<^sub>2) s = paval a\<^sub>1 s div paval a\<^sub>2 s"

lemma paval_aval: "vars a \<subseteq> dom ps \<Longrightarrow> paval a ps = aval a (\<lambda>v. case ps v of None \<Rightarrow> s v | Some r \<Rightarrow> r)"
  by (induct a, auto)

lemma paval'_paval: "vars a \<subseteq> dom ps \<Longrightarrow> paval' a ps = Some (paval a ps)"
  by (induct a, auto)

lemma paval_paval': "paval' a ps = Some v \<Longrightarrow> paval a ps = v"
proof(induct a arbitrary: v)
  case (Plus a1 a2)
  from Plus(3) obtain v1 where 1: "paval' a1 ps = Some v1"
    by fastforce
  with Plus(3) obtain v2 where 2: "paval' a2 ps = Some v2"
    by fastforce
  from Plus(1)[OF 1] Plus(2)[OF 2] Plus(3) 1 2 show ?case by auto
next
  case (Times a1 a2)
  from Times(3) obtain v1 where 1: "paval' a1 ps = Some v1"
    by fastforce
  with Times(3) obtain v2 where 2: "paval' a2 ps = Some v2"
    by fastforce
  from Times(1)[OF 1] Times(2)[OF 2] Times(3) 1 2 show ?case by auto
next
  case (Div a1 a2)
  from Div(3) obtain v1 where 1: "paval' a1 ps = Some v1"
    by fastforce
  with Div(3) obtain v2 where 2: "paval' a2 ps = Some v2"
    by fastforce
  from Div(1)[OF 1] Div(2)[OF 2] Div(3) 1 2 show ?case by auto
qed simp_all

fun pbval :: "bexp \<Rightarrow> partstate \<Rightarrow> bool" where
"pbval (Bc v) s = v" |
"pbval (Not b) s = (\<not> pbval b s)" |
"pbval (And b\<^sub>1 b\<^sub>2) s = (pbval b\<^sub>1 s \<and> pbval b\<^sub>2 s)" |
"pbval (Less a\<^sub>1 a\<^sub>2) s = (paval a\<^sub>1 s < paval a\<^sub>2 s)"

abbreviation optnot  where "optnot a \<equiv> (case a of None \<Rightarrow> None | Some a' \<Rightarrow> Some (~a'))"

abbreviation optand  where "optand a b \<equiv> (case a of None \<Rightarrow> None | Some a' \<Rightarrow> (case b of None \<Rightarrow> None | Some b' \<Rightarrow> Some (a' \<and> b'))) "
abbreviation optless   where "optless a b \<equiv> (case a of None \<Rightarrow> None | Some a' \<Rightarrow> (case b of None \<Rightarrow> None | Some b' \<Rightarrow> Some (a' < b'))) "

fun pbval' :: "bexp \<Rightarrow> partstate \<Rightarrow> bool option" where
"pbval' (Bc v) s = Some v" |
"pbval' (Not b) s = (optnot (pbval' b s))" |
"pbval' (And b\<^sub>1 b\<^sub>2) s = (optand (pbval' b\<^sub>1 s) (pbval' b\<^sub>2 s))" |
"pbval' (Less a\<^sub>1 a\<^sub>2) s = (optless (paval' a\<^sub>1 s) (paval' a\<^sub>2 s))"

lemma pbval'_pbval: "vars a \<subseteq> dom ps \<Longrightarrow> pbval' a ps = Some (pbval a ps)"
  apply(induct a) apply (auto simp: paval'_paval) done

lemma paval_aval_vars: "vars a \<subseteq> dom ps \<Longrightarrow> paval a ps = aval a (emb ps s)"
  apply(induct a) by(auto simp: emb_def)

lemma pbval_bval_vars: "vars b \<subseteq> dom ps \<Longrightarrow> pbval b ps = bval b (emb ps s)"
  apply(induct b) apply (simp_all)
  using paval_aval_vars[where s=s] by auto

lemma paval'dom: "paval' a ps = Some v \<Longrightarrow> vars a \<subseteq> dom ps"
proof (induct a arbitrary: v)
  case (Plus a1 a2)
  then show ?case apply auto
    apply fastforce
    by (metis (no_types, lifting) domD option.case_eq_if option.collapse subset_iff)
next
  case (Times a1 a2)
  then show ?case apply auto
    apply fastforce
    by (metis (no_types, lifting) domD option.case_eq_if option.collapse subset_iff)
next
  case (Div a1 a2)
  then show ?case apply auto
    apply fastforce
    by (metis (no_types, lifting) domD option.case_eq_if option.collapse subset_iff)
qed auto

end