theory PF_Matching_Ternary
imports Iptables_Semantics.Ternary Iptables_Semantics.Matching_Ternary "../PF_Firewall_Common"
begin

(* adapted from Iptables_Semantics.Matching_Ternary *)

type_synonym 'packet unknown_match_tac="action \<Rightarrow> decision \<Rightarrow> 'packet \<Rightarrow> bool"

type_synonym ('a, 'packet) match_tac="(('a, 'packet) exact_match_tac \<times> 'packet unknown_match_tac)"

fun ternary_to_bool_unknown_match_tac :: "'packet unknown_match_tac \<Rightarrow> action \<Rightarrow> decision \<Rightarrow> 'packet \<Rightarrow> ternaryvalue \<Rightarrow> bool" where
  "ternary_to_bool_unknown_match_tac _ _ _ _ TernaryTrue = True" |
  "ternary_to_bool_unknown_match_tac _ _ _ _ TernaryFalse = False" |
  "ternary_to_bool_unknown_match_tac \<alpha> a d p TernaryUnknown = \<alpha> a d p"

text\<open>
Matching a packet and a rule:
\begin{enumerate}
  \item Translate @{typ "'a match_expr"} to ternary formula
  \item Evaluate this formula
  \item If @{const TernaryTrue}/@{const TernaryFalse}, return this value
  \item If @{const TernaryUnknown}, apply the @{typ "'a unknown_match_tac"} to get a Boolean result
\end{enumerate}
\<close>
definition matches :: "('a, 'packet) match_tac \<Rightarrow> 'a match_expr \<Rightarrow> action \<Rightarrow> decision \<Rightarrow> 'packet \<Rightarrow> bool" where
  "matches \<gamma> m a d p \<equiv> ternary_to_bool_unknown_match_tac (snd \<gamma>) a d p (ternary_ternary_eval (map_match_tac (fst \<gamma>) p m))"

text\<open>Alternative matches definitions, some more or less convenient\<close>

lemma matches_tuple: "matches (\<beta>, \<alpha>) m a d p = ternary_to_bool_unknown_match_tac \<alpha> a d p (ternary_ternary_eval (map_match_tac \<beta> p m))"
unfolding matches_def by simp

lemma matches_case: "matches \<gamma> m a d p \<longleftrightarrow> (case ternary_eval (map_match_tac (fst \<gamma>) p m) of None \<Rightarrow> (snd \<gamma>) a d p | Some b \<Rightarrow> b)"
unfolding matches_def ternary_eval_def
by (cases "(ternary_ternary_eval (map_match_tac (fst \<gamma>) p m))") auto

lemma matches_case_tuple: "matches (\<beta>, \<alpha>) m a d p \<longleftrightarrow> (case ternary_eval (map_match_tac \<beta> p m) of None \<Rightarrow> \<alpha> a d p | Some b \<Rightarrow> b)"
by (auto simp: matches_case split: option.splits)

lemma matches_case_ternaryvalue_tuple: "matches (\<beta>, \<alpha>) m a d p \<longleftrightarrow> (case ternary_ternary_eval (map_match_tac \<beta> p m) of
        TernaryUnknown \<Rightarrow> \<alpha> a d p |
        TernaryTrue \<Rightarrow> True |
        TernaryFalse \<Rightarrow> False)"
  by(simp split: option.split ternaryvalue.split add: matches_case ternary_to_bool_None ternary_eval_def)
(*use together: matches_case_ternaryvalue_tuple ternaryvalue.split *)

lemma matches_casesE:
  "matches (\<beta>, \<alpha>) m a d p \<Longrightarrow>
    (ternary_ternary_eval (map_match_tac \<beta> p m) = TernaryUnknown \<Longrightarrow> \<alpha> a d p \<Longrightarrow> P) \<Longrightarrow>
    (ternary_ternary_eval (map_match_tac \<beta> p m) = TernaryTrue \<Longrightarrow> P)
  \<Longrightarrow> P"
proof(induction m)
qed(auto split: option.split_asm simp: matches_case_tuple ternary_eval_def ternary_to_bool_bool_to_ternary elim: ternary_to_bool.elims)

text\<open>
Example: @{text "\<not> Unknown"} is as good as @{text Unknown}
\<close>
lemma "\<lbrakk> ternary_ternary_eval (map_match_tac \<beta> p expr) = TernaryUnknown \<rbrakk> \<Longrightarrow> matches (\<beta>, \<alpha>) expr a d p \<longleftrightarrow> matches (\<beta>, \<alpha>) (MatchNot expr) a d p"
by(simp add: matches_case_ternaryvalue_tuple)

lemma bunch_of_lemmata_about_matches:
  "matches \<gamma> (MatchAnd m1 m2) a d p \<longleftrightarrow> matches \<gamma> m1 a d p \<and> matches \<gamma> m2 a d p" (*split AND*)
  "matches \<gamma> MatchAny a d p" (*MatchAny is True*)
  "matches \<gamma> (MatchNot MatchAny) a d p \<longleftrightarrow> False" (*Not True*)
  "matches \<gamma> (MatchNot (MatchNot m)) a d p \<longleftrightarrow> matches \<gamma> m a d p" (*idempotence*)
proof(case_tac [!] \<gamma>)
qed (simp_all split: ternaryvalue.split add: matches_case_ternaryvalue_tuple)

lemma match_raw_bool:
  "matches (\<beta>, \<alpha>) (Match expr) a d p = (case ternary_to_bool (\<beta> expr p) of Some r \<Rightarrow> r | None \<Rightarrow> (\<alpha> a d p))" (*Match raw*)
by(simp_all split: ternaryvalue.split add: matches_case_ternaryvalue_tuple)
lemma match_raw_ternary:
  "matches (\<beta>, \<alpha>) (Match expr) a d p = (case (\<beta> expr p) of TernaryTrue \<Rightarrow> True | TernaryFalse \<Rightarrow> False | TernaryUnknown \<Rightarrow> (\<alpha> a d p))" (*Match raw explicit*)
by(simp_all split: ternaryvalue.split add: matches_case_ternaryvalue_tuple)

(*kind of the DeMorgan Rule for matches*)
lemma matches_DeMorgan: "matches \<gamma> (MatchNot (MatchAnd m1 m2)) a d p \<longleftrightarrow> (matches \<gamma> (MatchNot m1) a d p) \<or> (matches \<gamma> (MatchNot m2) a d p)"
by (cases \<gamma>) (simp split: ternaryvalue.split add: matches_case_ternaryvalue_tuple eval_ternary_DeMorgan)

subsection\<open>Ternary Matcher Algebra\<close>

lemma matches_and_comm: "matches \<gamma> (MatchAnd m m') a d p \<longleftrightarrow> matches \<gamma> (MatchAnd m' m) a d p"
apply(cases \<gamma>, rename_tac \<beta> \<alpha>, clarify)
by(simp add: matches_case_ternaryvalue_tuple eval_ternary_And_comm)

lemma matches_not_idem: "matches \<gamma> (MatchNot (MatchNot m)) a d p \<longleftrightarrow> matches \<gamma> m a d p"
by (fact bunch_of_lemmata_about_matches)

lemma MatchOr: "matches \<gamma> (MatchOr m1 m2) a d p \<longleftrightarrow> matches \<gamma> m1 a d p \<or> matches \<gamma> m2 a d p"
  by(simp add: MatchOr_def matches_DeMorgan matches_not_idem)

lemma MatchOr_MatchNot: "matches \<gamma> (MatchNot (MatchOr m1 m2)) a d p \<longleftrightarrow> matches \<gamma> (MatchNot m1) a d p \<and> matches \<gamma> (MatchNot m2) a d p"
  by(simp add: MatchOr_def matches_DeMorgan bunch_of_lemmata_about_matches)

lemma "(TernaryNot (map_match_tac \<beta> p (m))) = (map_match_tac \<beta> p (MatchNot m))"
by (metis map_match_tac.simps(2))

context
begin
  private lemma matches_simp1: "matches \<gamma> m a d p \<Longrightarrow> matches \<gamma> (MatchAnd m m') a d p \<longleftrightarrow> matches \<gamma> m' a d p"
    apply(cases \<gamma>, rename_tac \<beta> \<alpha>, clarify)
    apply(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple)
    done

  private lemma matches_simp11: "matches \<gamma> m a d p \<Longrightarrow> matches \<gamma> (MatchAnd m' m) a d p \<longleftrightarrow> matches \<gamma> m' a d p"
    by(simp_all add: matches_and_comm matches_simp1)

  private lemma matches_simp2: "matches \<gamma> (MatchAnd m m') a d p \<Longrightarrow> \<not> matches \<gamma> m a d p \<Longrightarrow> False"
    by (simp add: bunch_of_lemmata_about_matches)
  private lemma matches_simp22: "matches \<gamma> (MatchAnd m m') a d p \<Longrightarrow> \<not> matches \<gamma> m' a d p \<Longrightarrow> False"
    by (simp add: bunch_of_lemmata_about_matches)

  (*m simplifies to MatchUnknown*)
 private  lemma matches_simp3: "matches \<gamma> (MatchNot m) a d p \<Longrightarrow> matches \<gamma> m a d p \<Longrightarrow> (snd \<gamma>) a d p"
    apply(cases \<gamma>, rename_tac \<beta> \<alpha>, clarify)
    apply(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple)
    done
  private lemma "matches \<gamma> (MatchNot m) a d p \<Longrightarrow> matches \<gamma> m a d p \<Longrightarrow> (ternary_eval (map_match_tac (fst \<gamma>) p m)) = None"
    apply(cases \<gamma>, rename_tac \<beta> \<alpha>, clarify)
    apply(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple ternary_eval_def)
    done

  lemmas matches_simps = matches_simp1 matches_simp11
  lemmas matches_dest = matches_simp2 matches_simp22
end

lemma matches_iff_apply_f_generic: "ternary_ternary_eval (map_match_tac \<beta> p (f (\<beta>,\<alpha>) a m)) = ternary_ternary_eval (map_match_tac \<beta> p m) \<Longrightarrow> matches (\<beta>,\<alpha>) (f (\<beta>,\<alpha>) a m) a d p \<longleftrightarrow> matches (\<beta>,\<alpha>) m a d p"
  by(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple)

lemma matches_iff_apply_f: "ternary_ternary_eval (map_match_tac \<beta> p (f m)) = ternary_ternary_eval (map_match_tac \<beta> p m) \<Longrightarrow> matches (\<beta>,\<alpha>) (f m) a d p \<longleftrightarrow> matches (\<beta>,\<alpha>) m a d p"
  by(fact matches_iff_apply_f_generic)

subsection\<open>Removing Unknown Primitives\<close>

definition unknown_match_all :: "'a unknown_match_tac \<Rightarrow> action \<Rightarrow> decision \<Rightarrow> bool" where
   "unknown_match_all \<alpha> a d = (\<forall>p. \<alpha> a d p)"
definition unknown_not_match_any :: "'a unknown_match_tac \<Rightarrow> action \<Rightarrow> decision \<Rightarrow> bool" where
   "unknown_not_match_any \<alpha> a d = (\<forall>p. \<not> \<alpha> a d p)"

(*see upper_closure_matchexpr*)
fun remove_unknowns_generic :: "('a, 'packet) match_tac \<Rightarrow> action \<Rightarrow> decision \<Rightarrow> 'a match_expr \<Rightarrow> 'a match_expr" where
  "remove_unknowns_generic _ _ _ MatchAny = MatchAny" |
  "remove_unknowns_generic _ _ _ (MatchNot MatchAny) = MatchNot MatchAny" |
  "remove_unknowns_generic (\<beta>, \<alpha>) a d (Match A) = (if
      (\<forall>p. ternary_ternary_eval (map_match_tac \<beta> p (Match A)) = TernaryUnknown)
    then
      if unknown_match_all \<alpha> a d then MatchAny else if unknown_not_match_any \<alpha> a d then MatchNot MatchAny else Match A
    else (Match A))" |
  "remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot (Match A)) = (if
      (\<forall>p. ternary_ternary_eval (map_match_tac \<beta> p (Match A)) = TernaryUnknown)
    then
      if unknown_match_all \<alpha> a d then MatchAny else if unknown_not_match_any \<alpha> a d then MatchNot MatchAny else MatchNot (Match A)
    else MatchNot (Match A))" |
  "remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot (MatchNot m)) = remove_unknowns_generic (\<beta>, \<alpha>) a d m" |
  "remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchAnd m1 m2) = MatchAnd
      (remove_unknowns_generic (\<beta>, \<alpha>) a d m1)
      (remove_unknowns_generic (\<beta>, \<alpha>) a d m2)" |

  \<comment> \<open>@{text "\<not> (a \<and> b) = \<not> b \<or> \<not> a"}   and   @{text "\<not> Unknown = Unknown"}\<close>
  "remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot (MatchAnd m1 m2)) =
    (if (remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot m1)) = MatchAny \<or>
        (remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot m2)) = MatchAny
        then MatchAny else
        (if (remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot m1)) = MatchNot MatchAny then
          remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot m2) else
         if (remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot m2)) = MatchNot MatchAny then
          remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot m1) else
         MatchNot (MatchAnd (MatchNot (remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot m1))) (MatchNot (remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot m2)))))
       )"

lemma remove_unknowns_generic_simp_3_4_unfolded: "remove_unknowns_generic (\<beta>, \<alpha>) a d (Match A) = (if
      (\<forall>p. ternary_ternary_eval (map_match_tac \<beta> p (Match A)) = TernaryUnknown)
    then
      if (\<forall>p. \<alpha> a d p) then MatchAny else if (\<forall>p. \<not> \<alpha> a d p) then MatchNot MatchAny else Match A
    else (Match A))"
 "remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot (Match A)) = (if
      (\<forall>p. ternary_ternary_eval (map_match_tac \<beta> p (Match A)) = TernaryUnknown)
    then
      if (\<forall>p. \<alpha> a d p) then MatchAny else if (\<forall>p. \<not> \<alpha> a d p) then MatchNot MatchAny else MatchNot (Match A)
    else MatchNot (Match A))"
  by(auto simp add: unknown_match_all_def unknown_not_match_any_def)

declare remove_unknowns_generic.simps[simp del]

lemmas remove_unknowns_generic_simps2 = remove_unknowns_generic.simps(1) remove_unknowns_generic.simps(2)
            remove_unknowns_generic_simp_3_4_unfolded
            remove_unknowns_generic.simps(5) remove_unknowns_generic.simps(6) remove_unknowns_generic.simps(7)

lemma "matches (\<beta>, \<alpha>) (remove_unknowns_generic (\<beta>, \<alpha>) a d (MatchNot (Match A))) a d p = matches (\<beta>, \<alpha>) (MatchNot (Match A)) a d p"
by(simp add: remove_unknowns_generic_simps2 matches_case_ternaryvalue_tuple)

lemma remove_unknowns_generic: "matches \<gamma> (remove_unknowns_generic \<gamma> a d m) a d = matches \<gamma> m a d"
proof -
  have "matches \<gamma> (remove_unknowns_generic \<gamma> a d m) a d p = matches \<gamma> m a d p"
  for p
  proof(induction \<gamma> a d m rule: remove_unknowns_generic.induct)
  case 3 thus ?case
      by(simp add: bunch_of_lemmata_about_matches match_raw_ternary remove_unknowns_generic_simps2)
  next
  case 4 thus ?case
     by(simp add: matches_case_ternaryvalue_tuple remove_unknowns_generic_simps2)
  next
  case 7 thus ?case
    apply(simp add: bunch_of_lemmata_about_matches matches_DeMorgan remove_unknowns_generic_simps2)
    apply(simp add: matches_case_ternaryvalue_tuple)
    by fastforce
  qed(simp_all add: bunch_of_lemmata_about_matches remove_unknowns_generic_simps2)
  thus ?thesis by(simp add: fun_eq_iff)
qed

fun has_unknowns :: " ('a, 'p) exact_match_tac \<Rightarrow> 'a match_expr \<Rightarrow> bool" where
  "has_unknowns \<beta> (Match A) = (\<exists>p. ternary_ternary_eval (map_match_tac \<beta> p (Match A)) = TernaryUnknown)" |
  "has_unknowns \<beta> (MatchNot m) = has_unknowns \<beta> m" |
  "has_unknowns \<beta> MatchAny = False" |
  "has_unknowns \<beta> (MatchAnd m1 m2) = (has_unknowns \<beta> m1 \<or> has_unknowns \<beta> m2)"

definition packet_independent_\<alpha> :: "'p unknown_match_tac \<Rightarrow> bool" where
  "packet_independent_\<alpha> \<alpha> = (\<forall>a d p1 p2. \<alpha> a d p1 \<longleftrightarrow> \<alpha> a d p2)"

lemma packet_independent_unknown_match: "a=Pass \<or> a=Block \<Longrightarrow> packet_independent_\<alpha> \<alpha> \<Longrightarrow> \<not> unknown_not_match_any \<alpha> a d \<longleftrightarrow> unknown_match_all \<alpha> a d"
  by(auto simp add: packet_independent_\<alpha>_def unknown_match_all_def unknown_not_match_any_def)

text\<open>If for some type the exact matcher returns unknown, then it returns unknown for all these types\<close>
definition packet_independent_\<beta>_unknown :: "('a, 'packet) exact_match_tac \<Rightarrow> bool" where
  "packet_independent_\<beta>_unknown \<beta> \<equiv> \<forall>A. (\<exists>p. \<beta> A p \<noteq> TernaryUnknown) \<longrightarrow> (\<forall>p. \<beta> A p \<noteq> TernaryUnknown)"

lemma remove_unknowns_generic_specification: "a=Pass \<or> a=Block \<Longrightarrow> packet_independent_\<alpha> \<alpha> \<Longrightarrow>
  packet_independent_\<beta>_unknown \<beta> \<Longrightarrow>
   \<not> has_unknowns \<beta> (remove_unknowns_generic (\<beta>, \<alpha>) a d m)"
  proof(induction "(\<beta>, \<alpha>)" a d m rule: remove_unknowns_generic.induct)
  case 3 thus ?case by(simp add: packet_independent_unknown_match packet_independent_\<beta>_unknown_def remove_unknowns_generic.simps)
  next
  case 4 thus ?case by(simp add: packet_independent_unknown_match packet_independent_\<beta>_unknown_def remove_unknowns_generic.simps)
  qed(simp_all add: remove_unknowns_generic.simps)

text\<open>Checking is something matches unconditionally\<close>
context
begin
  private lemma no_primitives_no_unknown: "\<not> has_primitive m  \<Longrightarrow> (ternary_ternary_eval (map_match_tac \<beta> p m)) \<noteq> TernaryUnknown"
  proof(induction m)
  case Match thus ?case by auto
  next
  case MatchAny thus ?case by simp
  next
  case MatchAnd thus ?case by(auto elim: eval_ternary_And.elims)
  next
  case MatchNot thus ?case by(auto dest: eval_ternary_Not_UnknownD)
  qed

  private lemma no_primitives_matchNot: assumes "\<not> has_primitive m" shows "matches \<gamma> (MatchNot m) a d p \<longleftrightarrow> \<not> matches \<gamma> m a d p"
  proof -
    obtain \<beta> \<alpha> where "(\<beta>, \<alpha>) = \<gamma>" by (cases \<gamma>, simp)
    thm no_primitives_no_unknown
    from assms have "matches (\<beta>, \<alpha>) (MatchNot m) a d p \<longleftrightarrow> \<not> matches (\<beta>, \<alpha>) m a d p"
      apply(induction m)
         apply(simp_all add: matches_case_ternaryvalue_tuple split: ternaryvalue.split )
      apply(rename_tac m1 m2)
      by(simp split: ternaryvalue.split_asm)
    with \<open>(\<beta>, \<alpha>) = \<gamma>\<close> assms show ?thesis by simp
  qed

  lemma matcheq_matchAny: "\<not> has_primitive m \<Longrightarrow> matcheq_matchAny m \<longleftrightarrow> matches \<gamma> m a d p"
  proof(induction m)
  case Match hence False by auto
    thus ?case ..
  next
  case (MatchNot m)
    from MatchNot.prems have "\<not> has_primitive m" by simp
    with no_primitives_matchNot have "matches \<gamma> (MatchNot m) a d p = (\<not> matches \<gamma> m a d p)" by metis
    with MatchNot show ?case by(simp)
  next
  case (MatchAnd m1 m2)
    thus ?case by(simp add: bunch_of_lemmata_about_matches)
  next
  case MatchAny show ?case by(simp add: PF_Matching_Ternary.bunch_of_lemmata_about_matches)
  qed

  lemma matcheq_matchNone: "\<not> has_primitive m \<Longrightarrow> matcheq_matchNone m \<longleftrightarrow> \<not> matches \<gamma> m a d p"
    by(auto dest: matcheq_matchAny matachAny_matchNone)

  lemma matcheq_matchNone_not_matches: "matcheq_matchNone m \<Longrightarrow> \<not> matches \<gamma> m a d p"
    proof(induction m rule: matcheq_matchNone.induct)
    qed(auto simp add: bunch_of_lemmata_about_matches matches_DeMorgan)

end

text\<open>Lemmas about @{const MatchNot} in ternary logic.\<close>

lemma matches_MatchNot_no_unknowns:
   assumes "\<not> has_unknowns \<beta> m"
   shows "matches (\<beta>,\<alpha>) (MatchNot m) a d p \<longleftrightarrow> \<not> matches (\<beta>,\<alpha>) m a d p"
proof -
  { fix m have "\<not> has_unknowns \<beta> m \<Longrightarrow>
       ternary_to_bool (ternary_ternary_eval (map_match_tac \<beta> p m)) \<noteq> None"
    apply(induction m)
       apply(simp_all)
      using ternary_to_bool.elims apply blast
     using ternary_to_bool_Some apply fastforce
    using ternary_lift(6) ternary_to_bool_Some by auto
  } note no_unknowns_ternary_to_bool_Some=this
    from assms show ?thesis
      by(auto split: option.split_asm
              simp: matches_case_tuple no_unknowns_ternary_to_bool_Some ternary_to_bool_Some  ternary_eval_def ternary_to_bool_bool_to_ternary
              elim: ternary_to_bool.elims)
qed

lemma MatchNot_ternary_ternary_eval: "(ternary_ternary_eval (map_match_tac \<beta> p m')) = (ternary_ternary_eval (map_match_tac \<beta> p m)) \<Longrightarrow>
    matches (\<beta>,\<alpha>) (MatchNot m') a d p = matches (\<beta>,\<alpha>) (MatchNot m) a d p"
by(simp add: matches_tuple)

text\<open>For our @{typ "'p unknown_match_tac"}s @{text in_doubt_allow} and @{text in_doubt_deny},
      when doing an induction over some function that modifies @{term "m::'a match_expr"},
      we get the @{const MatchNot} case for free (if we can set arbitrary @{term "p::'p"}).
      This does not hold for arbitrary @{typ "'p unknown_match_tac"}s.\<close>
lemma matches_induction_case_MatchNot:
      assumes "\<alpha> Block d \<noteq> \<alpha> Pass d" and "packet_independent_\<alpha> \<alpha>"
      and     "\<forall> a. matches (\<beta>,\<alpha>) m' a d p = matches (\<beta>,\<alpha>) m a d p"
      shows   "matches (\<beta>,\<alpha>) (MatchNot m') a d p = matches (\<beta>,\<alpha>) (MatchNot m) a d p"
proof -
  from assms(1) assms(2) have xxxx_xxX: "\<And>b. \<forall>a. \<alpha> a d p = (\<not> b) \<Longrightarrow> False"
    apply(simp add: packet_independent_\<alpha>_def)
    apply(case_tac "\<alpha> Pass d p")
     apply(simp_all)
     apply(case_tac [!] "\<alpha> Block d p")
       apply(simp_all add: fun_eq_iff)
     apply blast+
    done

  have xx2: "\<And>t. ternary_eval (TernaryNot t) = None \<Longrightarrow> ternary_eval t = None"
  by (simp add: eval_ternary_Not_UnknownD ternary_eval_def ternary_to_bool_None)

  have xx3: "\<And>t b. ternary_eval (TernaryNot t) = Some b \<Longrightarrow>  ternary_eval t = Some (\<not> b)"
  by (metis eval_ternary_Not.simps(1) eval_ternary_Not.simps(2) ternary_eval_def ternary_ternary_eval.simps(3) ternary_ternary_eval_idempotence_Not ternary_to_bool_Some)

  from assms show ?thesis
    apply(simp add: matches_case_tuple)
    apply(case_tac "ternary_eval (TernaryNot (map_match_tac \<beta> p m'))")
     apply(case_tac [!] "ternary_eval (TernaryNot (map_match_tac \<beta> p m))")
       apply(simp_all)
      apply(drule xx2)
      apply(drule xx3)
      apply(simp)
      using xxxx_xxX apply metis
     apply(drule xx2)
     apply(drule xx3)
     apply(simp)
     using xxxx_xxX apply metis
    apply(drule xx3)+
    apply(simp)
    done
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_tree_Flatten3
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype 'a Tree = Node "'a Tree" "'a" "'a Tree" | Nil

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

(*fun did not finish the proof*)
function flatten3 :: "'a Tree => 'a list" where
  "flatten3 (Node (Node p x2 q) z2 r) =
   flatten3 (Node p x2 (Node q z2 r))"
| "flatten3 (Node (Nil) z2 r) = cons2 z2 (flatten3 r)"
| "flatten3 (Nil) = nil2"
  by pat_completeness auto

fun flatten0 :: "'a Tree => 'a list" where
  "flatten0 (Node p z q) =
   x (flatten0 p) (x (cons2 z (nil2)) (flatten0 q))"
| "flatten0 (Nil) = nil2"

theorem property0 :
  "((flatten3 p) = (flatten0 p))"
  oops

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_22
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun max :: "Nat => Nat => Nat" where
  "max (Z) y = y"
| "max (S z) (Z) = S z"
| "max (S z) (S x2) = S (max z x2)"

theorem property0 :
  "((max (max a b) c) = (max a (max b c)))"
  oops

end


theory T119
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(* Title:      Kruskal's Minimum Spanning Tree Algorithm
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Kruskal's Minimum Spanning Tree Algorithm\<close>

text \<open>
In this theory we prove total correctness of Kruskal's minimum spanning tree algorithm.
The proof uses the following steps \<^cite>\<open>"Guttmann2018c"\<close>.
We first establish that the algorithm terminates and constructs a spanning tree.
This is a constructive proof of the existence of a spanning tree; any spanning tree algorithm could be used for this.
We then conclude that a minimum spanning tree exists.
This is necessary to establish the invariant for the actual correctness proof, which shows that Kruskal's algorithm produces a minimum spanning tree.
\<close>

theory Kruskal

imports "HOL-Hoare.Hoare_Logic" Aggregation_Algebras.Aggregation_Algebras

begin

context m_kleene_algebra
begin

definition "spanning_forest f g \<equiv> forest f \<and> f \<le> --g \<and> components g \<le> forest_components f \<and> regular f"
definition "minimum_spanning_forest f g \<equiv> spanning_forest f g \<and> (\<forall>u . spanning_forest u g \<longrightarrow> sum (f \<sqinter> g) \<le> sum (u \<sqinter> g))"
definition "kruskal_spanning_invariant f g h \<equiv> symmetric g \<and> h = h\<^sup>T \<and> g \<sqinter> --h = h \<and> spanning_forest f (-h \<sqinter> g)"
definition "kruskal_invariant f g h \<equiv> kruskal_spanning_invariant f g h \<and> (\<exists>w . minimum_spanning_forest w g \<and> f \<le> w \<squnion> w\<^sup>T)"

text \<open>
We first show two verification conditions which are used in both correctness proofs.
\<close>

lemma kruskal_vc_1:
  assumes "symmetric g"
    shows "kruskal_spanning_invariant bot g g"
proof (unfold kruskal_spanning_invariant_def, intro conjI)
  show "symmetric g"
    using assms by simp
next
  show "g = g\<^sup>T"
    using assms by simp
next
  show "g \<sqinter> --g = g"
    using inf.sup_monoid.add_commute selection_closed_id by simp
next
  show "spanning_forest bot (-g \<sqinter> g)"
    using star.circ_transitive_equal spanning_forest_def by simp
qed

lemma kruskal_vc_2:
  assumes "kruskal_spanning_invariant f g h"
      and "h \<noteq> bot"
    shows "(minarc h \<le> -forest_components f \<longrightarrow> kruskal_spanning_invariant ((f \<sqinter> -(top * minarc h * f\<^sup>T\<^sup>\<star>)) \<squnion> (f \<sqinter> top * minarc h * f\<^sup>T\<^sup>\<star>)\<^sup>T \<squnion> minarc h) g (h \<sqinter> -minarc h \<sqinter> -minarc h\<^sup>T)
                                               \<and> card { x . regular x \<and> x \<le> --h \<and> x \<le> -minarc h \<and> x \<le> -minarc h\<^sup>T } < card { x . regular x \<and> x \<le> --h }) \<and>
           (\<not> minarc h \<le> -forest_components f \<longrightarrow> kruskal_spanning_invariant f g (h \<sqinter> -minarc h \<sqinter> -minarc h\<^sup>T)
                                                 \<and> card { x . regular x \<and> x \<le> --h \<and> x \<le> -minarc h \<and> x \<le> -minarc h\<^sup>T } < card { x . regular x \<and> x \<le> --h })"
proof -
  let ?e = "minarc h"
  let ?f = "(f \<sqinter> -(top * ?e * f\<^sup>T\<^sup>\<star>)) \<squnion> (f \<sqinter> top * ?e * f\<^sup>T\<^sup>\<star>)\<^sup>T \<squnion> ?e"
  let ?h = "h \<sqinter> -?e \<sqinter> -?e\<^sup>T"
  let ?F = "forest_components f"
  let ?n1 = "card { x . regular x \<and> x \<le> --h }"
  let ?n2 = "card { x . regular x \<and> x \<le> --h \<and> x \<le> -?e \<and> x \<le> -?e\<^sup>T }"
  have 1: "regular f \<and> regular ?e"
    by (metis assms(1) kruskal_spanning_invariant_def spanning_forest_def minarc_regular)
  hence 2: "regular ?f \<and> regular ?F \<and> regular (?e\<^sup>T)"
    using regular_closed_star regular_conv_closed regular_mult_closed by simp
  have 3: "\<not> ?e \<le> -?e"
    using assms(2) inf.orderE minarc_bot_iff by fastforce
  have 4: "?n2 < ?n1"
    apply (rule psubset_card_mono)
    using finite_regular apply simp
    using 1 3 kruskal_spanning_invariant_def minarc_below by auto
  show "(?e \<le> -?F \<longrightarrow> kruskal_spanning_invariant ?f g ?h \<and> ?n2 < ?n1) \<and> (\<not> ?e \<le> -?F \<longrightarrow> kruskal_spanning_invariant f g ?h \<and> ?n2 < ?n1)"
  proof (rule conjI)
    have 5: "injective ?f"
      apply (rule kruskal_injective_inv)
      using assms(1) kruskal_spanning_invariant_def spanning_forest_def apply simp
      apply (simp add: covector_mult_closed)
      apply (simp add: comp_associative comp_isotone star.right_plus_below_circ)
      apply (meson mult_left_isotone order_lesseq_imp star_outer_increasing top.extremum)
      using assms(1,2) kruskal_spanning_invariant_def kruskal_injective_inv_2 minarc_arc spanning_forest_def apply simp
      using assms(2) arc_injective minarc_arc apply blast
      using assms(1,2) kruskal_spanning_invariant_def kruskal_injective_inv_3 minarc_arc spanning_forest_def by simp
    show "?e \<le> -?F \<longrightarrow> kruskal_spanning_invariant ?f g ?h \<and> ?n2 < ?n1"
    proof
      assume 6: "?e \<le> -?F"
      have 7: "equivalence ?F"
        using assms(1) kruskal_spanning_invariant_def forest_components_equivalence spanning_forest_def by simp
      have "?e\<^sup>T * top * ?e\<^sup>T = ?e\<^sup>T"
        using assms(2) by (simp add: arc_top_arc minarc_arc)
      hence "?e\<^sup>T * top * ?e\<^sup>T \<le> -?F"
        using 6 7 conv_complement conv_isotone by fastforce
      hence 8: "?e * ?F * ?e = bot"
        using le_bot triple_schroeder_p by simp
      show "kruskal_spanning_invariant ?f g ?h \<and> ?n2 < ?n1"
      proof (unfold kruskal_spanning_invariant_def, intro conjI)
        show "symmetric g"
          using assms(1) kruskal_spanning_invariant_def by simp
      next
        show "?h = ?h\<^sup>T"
          using assms(1) by (simp add: conv_complement conv_dist_inf inf_commute inf_left_commute kruskal_spanning_invariant_def)
      next
        show "g \<sqinter> --?h = ?h"
          using 1 2 by (metis (opaque_lifting) assms(1) kruskal_spanning_invariant_def inf_assoc pp_dist_inf)
      next
        show "spanning_forest ?f (-?h \<sqinter> g)"
        proof (unfold spanning_forest_def, intro conjI)
          show "injective ?f"
            using 5 by simp
        next
          show "acyclic ?f"
            apply (rule kruskal_acyclic_inv)
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def apply simp
            apply (simp add: covector_mult_closed)
            using 8 assms(1) kruskal_spanning_invariant_def spanning_forest_def kruskal_acyclic_inv_1 apply simp
            using 8 apply (metis comp_associative mult_left_sub_dist_sup_left star.circ_loop_fixpoint sup_commute le_bot)
            using 6 by (simp add: p_antitone_iff)
        next
          show "?f \<le> --(-?h \<sqinter> g)"
            apply (rule kruskal_subgraph_inv)
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def apply simp
            using assms(1) apply (metis kruskal_spanning_invariant_def minarc_below order.trans pp_isotone_inf)
            using assms(1) kruskal_spanning_invariant_def apply simp
            using assms(1) kruskal_spanning_invariant_def by simp
        next
          show "components (-?h \<sqinter> g) \<le> forest_components ?f"
            apply (rule kruskal_spanning_inv)
            using 5 apply simp
            using 1 regular_closed_star regular_conv_closed regular_mult_closed apply simp
            using 1 apply simp
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def by simp
        next
          show "regular ?f"
            using 2 by simp
        qed
      next
        show "?n2 < ?n1"
          using 4 by simp
      qed
    qed
  next
    show "\<not> ?e \<le> -?F \<longrightarrow> kruskal_spanning_invariant f g ?h \<and> ?n2 < ?n1"
    proof
      assume "\<not> ?e \<le> -?F"
      hence 9: "?e \<le> ?F"
        using 2 assms(2) arc_in_partition minarc_arc by fastforce
      show "kruskal_spanning_invariant f g ?h \<and> ?n2 < ?n1"
      proof (unfold kruskal_spanning_invariant_def, intro conjI)
        show "symmetric g"
          using assms(1) kruskal_spanning_invariant_def by simp
      next
        show "?h = ?h\<^sup>T"
          using assms(1) by (simp add: conv_complement conv_dist_inf inf_commute inf_left_commute kruskal_spanning_invariant_def)
      next
        show "g \<sqinter> --?h = ?h"
          using 1 2 by (metis (opaque_lifting) assms(1) kruskal_spanning_invariant_def inf_assoc pp_dist_inf)
      next
        show "spanning_forest f (-?h \<sqinter> g)"
        proof (unfold spanning_forest_def, intro conjI)
          show "injective f"
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def by simp
        next
          show "acyclic f"
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def by simp
        next
          have "f \<le> --(-h \<sqinter> g)"
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def by simp
          also have "... \<le> --(-?h \<sqinter> g)"
            using comp_inf.mult_right_isotone inf.sup_monoid.add_commute inf_left_commute p_antitone_inf pp_isotone by presburger
          finally show "f \<le> --(-?h \<sqinter> g)"
            by simp
        next
          show "components (-?h \<sqinter> g) \<le> ?F"
            apply (rule kruskal_spanning_inv_1)
            using 9 apply simp
            using 1 apply simp
            using assms(1) kruskal_spanning_invariant_def spanning_forest_def apply simp
            using assms(1) kruskal_spanning_invariant_def forest_components_equivalence spanning_forest_def by simp
        next
          show "regular f"
            using 1 by simp
        qed
      next
        show "?n2 < ?n1"
          using 4 by simp
      qed
    qed
  qed
qed

text \<open>
The following result shows that Kruskal's algorithm terminates and constructs a spanning tree.
We cannot yet show that this is a minimum spanning tree.
\<close>

theorem kruskal_spanning:
  "VARS e f h
  [ symmetric g ]
  f := bot;
  h := g;
  WHILE h \<noteq> bot
    INV { kruskal_spanning_invariant f g h }
    VAR { card { x . regular x \<and> x \<le> --h } }
     DO e := minarc h;
        IF e \<le> -forest_components f THEN
          f := (f \<sqinter> -(top * e * f\<^sup>T\<^sup>\<star>)) \<squnion> (f \<sqinter> top * e * f\<^sup>T\<^sup>\<star>)\<^sup>T \<squnion> e
        ELSE
          SKIP
        FI;
        h := h \<sqinter> -e \<sqinter> -e\<^sup>T
     OD
  [ spanning_forest f g ]"
  apply vcg_tc_simp
  using kruskal_vc_1 apply simp
  using kruskal_vc_2 apply simp
  using kruskal_spanning_invariant_def by auto

text \<open>
Because we have shown total correctness, we conclude that a spanning tree exists.
\<close>

lemma kruskal_exists_spanning:
  "symmetric g \<Longrightarrow> \<exists>f . spanning_forest f g"
  using tc_extract_function kruskal_spanning by blast

text \<open>
This implies that a minimum spanning tree exists, which is used in the subsequent correctness proof.
\<close>

lemma kruskal_exists_minimal_spanning:
  assumes "symmetric g"
    shows "\<exists>f . minimum_spanning_forest f g"
proof -
  let ?s = "{ f . spanning_forest f g }"
  have "\<exists>m\<in>?s . \<forall>z\<in>?s . sum (m \<sqinter> g) \<le> sum (z \<sqinter> g)"
    apply (rule finite_set_minimal)
    using finite_regular spanning_forest_def apply simp
    using assms kruskal_exists_spanning apply simp
    using sum_linear by simp
  thus ?thesis
    using minimum_spanning_forest_def by simp
qed

text \<open>
Kruskal's minimum spanning tree algorithm terminates and is correct.
This is the same algorithm that is used in the previous correctness proof, with the same precondition and variant, but with a different invariant and postcondition.
\<close>

theorem kruskal:
  "VARS e f h
  [ symmetric g ]
  f := bot;
  h := g;
  WHILE h \<noteq> bot
    INV { kruskal_invariant f g h }
    VAR { card { x . regular x \<and> x \<le> --h } }
     DO e := minarc h;
        IF e \<le> -forest_components f THEN
          f := (f \<sqinter> -(top * e * f\<^sup>T\<^sup>\<star>)) \<squnion> (f \<sqinter> top * e * f\<^sup>T\<^sup>\<star>)\<^sup>T \<squnion> e
        ELSE
          SKIP
        FI;
        h := h \<sqinter> -e \<sqinter> -e\<^sup>T
     OD
  [ minimum_spanning_forest f g ]"
proof vcg_tc_simp
  assume "symmetric g"
  thus "kruskal_invariant bot g g"
    using kruskal_vc_1 kruskal_exists_minimal_spanning kruskal_invariant_def by simp
next
  fix f h
  let ?e = "minarc h"
  let ?f = "(f \<sqinter> -(top * ?e * f\<^sup>T\<^sup>\<star>)) \<squnion> (f \<sqinter> top * ?e * f\<^sup>T\<^sup>\<star>)\<^sup>T \<squnion> ?e"
  let ?h = "h \<sqinter> -?e \<sqinter> -?e\<^sup>T"
  let ?F = "forest_components f"
  let ?n1 = "card { x . regular x \<and> x \<le> --h }"
  let ?n2 = "card { x . regular x \<and> x \<le> --h \<and> x \<le> -?e \<and> x \<le> -?e\<^sup>T }"
  assume 1: "kruskal_invariant f g h \<and> h \<noteq> bot"
  from 1 obtain w where 2: "minimum_spanning_forest w g \<and> f \<le> w \<squnion> w\<^sup>T"
    using kruskal_invariant_def by auto
  hence 3: "regular f \<and> regular w \<and> regular ?e"
    using 1 by (metis kruskal_invariant_def kruskal_spanning_invariant_def minimum_spanning_forest_def spanning_forest_def minarc_regular)
  show "(?e \<le> -?F \<longrightarrow> kruskal_invariant ?f g ?h \<and> ?n2 < ?n1) \<and> (\<not> ?e \<le> -?F \<longrightarrow> kruskal_invariant f g ?h \<and> ?n2 < ?n1)"
  proof (rule conjI)
    show "?e \<le> -?F \<longrightarrow> kruskal_invariant ?f g ?h \<and> ?n2 < ?n1"
    proof
      assume 4: "?e \<le> -?F"
      have 5: "equivalence ?F"
        using 1 kruskal_invariant_def kruskal_spanning_invariant_def forest_components_equivalence spanning_forest_def by simp
      have "?e\<^sup>T * top * ?e\<^sup>T = ?e\<^sup>T"
        using 1 by (simp add: arc_top_arc minarc_arc)
      hence "?e\<^sup>T * top * ?e\<^sup>T \<le> -?F"
        using 4 5 conv_complement conv_isotone by fastforce
      hence 6: "?e * ?F * ?e = bot"
        using le_bot triple_schroeder_p by simp
      show "kruskal_invariant ?f g ?h \<and> ?n2 < ?n1"
      proof (unfold kruskal_invariant_def, intro conjI)
        show "kruskal_spanning_invariant ?f g ?h"
          using 1 4 kruskal_vc_2 kruskal_invariant_def by simp
      next
        show "\<exists>w . minimum_spanning_forest w g \<and> ?f \<le> w \<squnion> w\<^sup>T"
        proof
          let ?p = "w \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>"
          let ?v = "(w \<sqinter> -(top * ?e * w\<^sup>T\<^sup>\<star>)) \<squnion> ?p\<^sup>T"
          have 7: "regular ?p"
            using 3 regular_closed_star regular_conv_closed regular_mult_closed by simp
          have 8: "injective ?v"
            apply (rule kruskal_exchange_injective_inv_1)
            using 2 minimum_spanning_forest_def spanning_forest_def apply simp
            apply (simp add: covector_mult_closed)
            apply (simp add: comp_associative comp_isotone star.right_plus_below_circ)
            using 1 2 kruskal_injective_inv_3 minarc_arc minimum_spanning_forest_def spanning_forest_def by simp
          have 9: "components g \<le> forest_components ?v"
            apply (rule kruskal_exchange_spanning_inv_1)
            using 8 apply simp
            using 7 apply simp
            using 2 minimum_spanning_forest_def spanning_forest_def by simp
          have 10: "spanning_forest ?v g"
          proof (unfold spanning_forest_def, intro conjI)
            show "injective ?v"
              using 8 by simp
          next
            show "acyclic ?v"
              apply (rule kruskal_exchange_acyclic_inv_1)
              using 2 minimum_spanning_forest_def spanning_forest_def apply simp
              by (simp add: covector_mult_closed)
          next
            show "?v \<le> --g"
              apply (rule sup_least)
              using 2 inf.coboundedI1 minimum_spanning_forest_def spanning_forest_def apply simp
              using 1 2 by (metis kruskal_invariant_def kruskal_spanning_invariant_def conv_complement conv_dist_inf order.trans inf.absorb2 inf.cobounded1 minimum_spanning_forest_def spanning_forest_def)
          next
            show "components g \<le> forest_components ?v"
              using 9 by simp
          next
            show "regular ?v"
              using 3 regular_closed_star regular_conv_closed regular_mult_closed by simp
          qed
          have 11: "sum (?v \<sqinter> g) = sum (w \<sqinter> g)"
          proof -
            have "sum (?v \<sqinter> g) = sum (w \<sqinter> -(top * ?e * w\<^sup>T\<^sup>\<star>) \<sqinter> g) + sum (?p\<^sup>T \<sqinter> g)"
              using 2 by (metis conv_complement conv_top epm_8 inf_import_p inf_top_right regular_closed_top vector_top_closed minimum_spanning_forest_def spanning_forest_def sum_disjoint)
            also have "... = sum (w \<sqinter> -(top * ?e * w\<^sup>T\<^sup>\<star>) \<sqinter> g) + sum (?p \<sqinter> g)"
              using 1 kruskal_invariant_def kruskal_spanning_invariant_def sum_symmetric by simp
            also have "... = sum (((w \<sqinter> -(top * ?e * w\<^sup>T\<^sup>\<star>)) \<squnion> ?p) \<sqinter> g)"
              using inf_commute inf_left_commute sum_disjoint by simp
            also have "... = sum (w \<sqinter> g)"
              using 3 7 maddux_3_11_pp by simp
            finally show ?thesis
              by simp
          qed
          have 12: "?v \<squnion> ?v\<^sup>T = w \<squnion> w\<^sup>T"
          proof -
            have "?v \<squnion> ?v\<^sup>T = (w \<sqinter> -?p) \<squnion> ?p\<^sup>T \<squnion> (w\<^sup>T \<sqinter> -?p\<^sup>T) \<squnion> ?p"
              using conv_complement conv_dist_inf conv_dist_sup inf_import_p sup_assoc by simp
            also have "... = w \<squnion> w\<^sup>T"
              using 3 7 conv_complement conv_dist_inf inf_import_p maddux_3_11_pp sup_monoid.add_assoc sup_monoid.add_commute by simp
            finally show ?thesis
              by simp
          qed
          have 13: "?v * ?e\<^sup>T = bot"
            apply (rule kruskal_reroot_edge)
            using 1 apply (simp add: minarc_arc)
            using 2 minimum_spanning_forest_def spanning_forest_def by simp
          have "?v \<sqinter> ?e \<le> ?v \<sqinter> top * ?e"
            using inf.sup_right_isotone top_left_mult_increasing by simp
          also have "... \<le> ?v * (top * ?e)\<^sup>T"
            using covector_restrict_comp_conv covector_mult_closed vector_top_closed by simp
          finally have 14: "?v \<sqinter> ?e = bot"
            using 13 by (metis conv_dist_comp mult_assoc le_bot mult_left_zero)
          let ?d = "?v \<sqinter> top * ?e\<^sup>T * ?v\<^sup>T\<^sup>\<star> \<sqinter> ?F * ?e\<^sup>T * top \<sqinter> top * ?e * -?F"
          let ?w = "(?v \<sqinter> -?d) \<squnion> ?e"
          have 15: "regular ?d"
            using 3 regular_closed_star regular_conv_closed regular_mult_closed by simp
          have 16: "?F \<le> -?d"
            apply (rule kruskal_edge_between_components_1)
            using 5 apply simp
            using 1 conv_dist_comp minarc_arc mult_assoc by simp
          have 17: "f \<squnion> f\<^sup>T \<le> (?v \<sqinter> -?d \<sqinter> -?d\<^sup>T) \<squnion> (?v\<^sup>T \<sqinter> -?d \<sqinter> -?d\<^sup>T)"
            apply (rule kruskal_edge_between_components_2)
            using 16 apply simp
            using 1 kruskal_invariant_def kruskal_spanning_invariant_def spanning_forest_def apply simp
            using 2 12 by (metis conv_dist_sup conv_involutive conv_isotone le_supI sup_commute)
          show "minimum_spanning_forest ?w g \<and> ?f \<le> ?w \<squnion> ?w\<^sup>T"
          proof (intro conjI)
            have 18: "?e\<^sup>T \<le> ?v\<^sup>\<star>"
              apply (rule kruskal_edge_arc_1[where g=g and h=h])
              using minarc_below apply simp
              using 1 apply (metis kruskal_invariant_def kruskal_spanning_invariant_def inf_le1)
              using 1 kruskal_invariant_def kruskal_spanning_invariant_def apply simp
              using 9 apply simp
              using 13 by simp
            have 19: "arc ?d"
              apply (rule kruskal_edge_arc)
              using 5 apply simp
              using 10 spanning_forest_def apply blast
              using 1 apply (simp add: minarc_arc)
              using 3 apply (metis conv_complement pp_dist_star regular_mult_closed)
              using 2 8 12 apply (simp add: kruskal_forest_components_inf)
              using 10 spanning_forest_def apply simp
              using 13 apply simp
              using 6 apply simp
              using 18 by simp
            show "minimum_spanning_forest ?w g"
            proof (unfold minimum_spanning_forest_def, intro conjI)
              have "(?v \<sqinter> -?d) * ?e\<^sup>T \<le> ?v * ?e\<^sup>T"
                using inf_le1 mult_left_isotone by simp
              hence "(?v \<sqinter> -?d) * ?e\<^sup>T = bot"
                using 13 le_bot by simp
              hence 20: "?e * (?v \<sqinter> -?d)\<^sup>T = bot"
                using conv_dist_comp conv_involutive conv_bot by force
              have 21: "injective ?w"
                apply (rule injective_sup)
                using 8 apply (simp add: injective_inf_closed)
                using 20 apply simp
                using 1 arc_injective minarc_arc by blast
              show "spanning_forest ?w g"
              proof (unfold spanning_forest_def, intro conjI)
                show "injective ?w"
                  using 21 by simp
              next
                show "acyclic ?w"
                  apply (rule kruskal_exchange_acyclic_inv_2)
                  using 10 spanning_forest_def apply blast
                  using 8 apply simp
                  using inf.coboundedI1 apply simp
                  using 19 apply simp
                  using 1 apply (simp add: minarc_arc)
                  using inf.cobounded2 inf.coboundedI1 apply simp
                  using 13 by simp
              next
                have "?w \<le> ?v \<squnion> ?e"
                  using inf_le1 sup_left_isotone by simp
                also have "... \<le> --g \<squnion> ?e"
                  using 10 sup_left_isotone spanning_forest_def by blast
                also have "... \<le> --g \<squnion> --h"
                  by (simp add: le_supI2 minarc_below)
                also have "... = --g"
                  using 1 by (metis kruskal_invariant_def kruskal_spanning_invariant_def pp_isotone_inf sup.orderE)
                finally show "?w \<le> --g"
                  by simp
              next
                have 22: "?d \<le> (?v \<sqinter> -?d)\<^sup>T\<^sup>\<star> * ?e\<^sup>T * top"
                  apply (rule kruskal_exchange_spanning_inv_2)
                  using 8 apply simp
                  using 13 apply (metis semiring.mult_not_zero star_absorb star_simulation_right_equal)
                  using 17 apply simp
                  by (simp add: inf.coboundedI1)
                have "components g \<le> forest_components ?v"
                  using 10 spanning_forest_def by auto
                also have "... \<le> forest_components ?w"
                  apply (rule kruskal_exchange_forest_components_inv)
                  using 21 apply simp
                  using 15 apply simp
                  using 1 apply (simp add: arc_top_arc minarc_arc)
                  apply (simp add: inf.coboundedI1)
                  using 13 apply simp
                  using 8 apply simp
                  apply (simp add: le_infI1)
                  using 22 by simp
                finally show "components g \<le> forest_components ?w"
                  by simp
              next
                show "regular ?w"
                  using 3 7 regular_conv_closed by simp
              qed
            next
              have 23: "?e \<sqinter> g \<noteq> bot"
                using 1 by (metis kruskal_invariant_def kruskal_spanning_invariant_def comp_inf.semiring.mult_zero_right inf.sup_monoid.add_assoc inf.sup_monoid.add_commute minarc_bot_iff minarc_meet_bot)
              have "g \<sqinter> -h \<le> (g \<sqinter> -h)\<^sup>\<star>"
                using star.circ_increasing by simp
              also have "... \<le> (--(g \<sqinter> -h))\<^sup>\<star>"
                using pp_increasing star_isotone by blast
              also have "... \<le> ?F"
                using 1 kruskal_invariant_def kruskal_spanning_invariant_def inf.sup_monoid.add_commute spanning_forest_def by simp
              finally have 24: "g \<sqinter> -h \<le> ?F"
                by simp
              have "?d \<le> --g"
                using 10 inf.coboundedI1 spanning_forest_def by blast
              hence "?d \<le> --g \<sqinter> -?F"
                using 16 inf.boundedI p_antitone_iff by simp
              also have "... = --(g \<sqinter> -?F)"
                by simp
              also have "... \<le> --h"
                using 24 p_shunting_swap pp_isotone by fastforce
              finally have 25: "?d \<le> --h"
                by simp
              have "?d = bot \<longrightarrow> top = bot"
                using 19 by (metis mult_left_zero mult_right_zero)
              hence "?d \<noteq> bot"
                using 1 le_bot by auto
              hence 26: "?d \<sqinter> h \<noteq> bot"
                using 25 by (metis inf.absorb_iff2 inf_commute pseudo_complement)
              have "sum (?e \<sqinter> g) = sum (?e \<sqinter> --h \<sqinter> g)"
                by (simp add: inf.absorb1 minarc_below)
              also have "... = sum (?e \<sqinter> h)"
                using 1 by (metis kruskal_invariant_def kruskal_spanning_invariant_def inf.left_commute inf.sup_monoid.add_commute)
              also have "... \<le> sum (?d \<sqinter> h)"
                using 19 26 minarc_min by simp
              also have "... = sum (?d \<sqinter> (--h \<sqinter> g))"
                using 1 kruskal_invariant_def kruskal_spanning_invariant_def inf_commute by simp
              also have "... = sum (?d \<sqinter> g)"
                using 25 by (simp add: inf.absorb2 inf_assoc inf_commute)
              finally have 27: "sum (?e \<sqinter> g) \<le> sum (?d \<sqinter> g)"
                by simp
              have "?v \<sqinter> ?e \<sqinter> -?d = bot"
                using 14 by simp
              hence "sum (?w \<sqinter> g) = sum (?v \<sqinter> -?d \<sqinter> g) + sum (?e \<sqinter> g)"
                using sum_disjoint inf_commute inf_assoc by simp
              also have "... \<le> sum (?v \<sqinter> -?d \<sqinter> g) + sum (?d \<sqinter> g)"
                using 23 27 sum_plus_right_isotone by simp
              also have "... = sum (((?v \<sqinter> -?d) \<squnion> ?d) \<sqinter> g)"
                using sum_disjoint inf_le2 pseudo_complement by simp
              also have "... = sum ((?v \<squnion> ?d) \<sqinter> (-?d \<squnion> ?d) \<sqinter> g)"
                by (simp add: sup_inf_distrib2)
              also have "... = sum ((?v \<squnion> ?d) \<sqinter> g)"
                using 15 by (metis inf_top_right stone)
              also have "... = sum (?v \<sqinter> g)"
                by (simp add: inf.sup_monoid.add_assoc)
              finally have "sum (?w \<sqinter> g) \<le> sum (?v \<sqinter> g)"
                by simp
              thus "\<forall>u . spanning_forest u g \<longrightarrow> sum (?w \<sqinter> g) \<le> sum (u \<sqinter> g)"
                using 2 11 minimum_spanning_forest_def by auto
            qed
          next
            have "?f \<le> f \<squnion> f\<^sup>T \<squnion> ?e"
              using conv_dist_inf inf_le1 sup_left_isotone sup_mono by presburger
            also have "... \<le> (?v \<sqinter> -?d \<sqinter> -?d\<^sup>T) \<squnion> (?v\<^sup>T \<sqinter> -?d \<sqinter> -?d\<^sup>T) \<squnion> ?e"
              using 17 sup_left_isotone by simp
            also have "... \<le> (?v \<sqinter> -?d) \<squnion> (?v\<^sup>T \<sqinter> -?d \<sqinter> -?d\<^sup>T) \<squnion> ?e"
              using inf.cobounded1 sup_inf_distrib2 by presburger
            also have "... = ?w \<squnion> (?v\<^sup>T \<sqinter> -?d \<sqinter> -?d\<^sup>T)"
              by (simp add: sup_assoc sup_commute)
            also have "... \<le> ?w \<squnion> (?v\<^sup>T \<sqinter> -?d\<^sup>T)"
              using inf.sup_right_isotone inf_assoc sup_right_isotone by simp
            also have "... \<le> ?w \<squnion> ?w\<^sup>T"
              using conv_complement conv_dist_inf conv_dist_sup sup_right_isotone by simp
            finally show "?f \<le> ?w \<squnion> ?w\<^sup>T"
              by simp
          qed
        qed
      next
        show "?n2 < ?n1"
          using 1 kruskal_vc_2 kruskal_invariant_def by auto
      qed
    qed
  next
    show "\<not> ?e \<le> -?F \<longrightarrow> kruskal_invariant f g ?h \<and> ?n2 < ?n1"
      using 1 kruskal_vc_2 kruskal_invariant_def by auto
  qed
next
  fix f
  assume 28: "kruskal_invariant f g bot"
  hence 29: "spanning_forest f g"
    using kruskal_invariant_def kruskal_spanning_invariant_def by auto
  from 28 obtain w where 30: "minimum_spanning_forest w g \<and> f \<le> w \<squnion> w\<^sup>T"
    using kruskal_invariant_def by auto
  hence "w = w \<sqinter> --g"
    by (simp add: inf.absorb1 minimum_spanning_forest_def spanning_forest_def)
  also have "... \<le> w \<sqinter> components g"
    by (metis inf.sup_right_isotone star.circ_increasing)
  also have "... \<le> w \<sqinter> f\<^sup>T\<^sup>\<star> * f\<^sup>\<star>"
    using 29 spanning_forest_def inf.sup_right_isotone by simp
  also have "... \<le> f \<squnion> f\<^sup>T"
    apply (rule cancel_separate_6[where z=w and y="w\<^sup>T"])
    using 30 minimum_spanning_forest_def spanning_forest_def apply simp
    using 30 apply (metis conv_dist_inf conv_dist_sup conv_involutive inf.cobounded2 inf.orderE)
    using 30 apply (simp add: sup_commute)
    using 30 minimum_spanning_forest_def spanning_forest_def apply simp
    using 30 by (metis acyclic_star_below_complement comp_inf.mult_right_isotone inf_p le_bot minimum_spanning_forest_def spanning_forest_def)
  finally have 31: "w \<le> f \<squnion> f\<^sup>T"
    by simp
  have "sum (f \<sqinter> g) = sum ((w \<squnion> w\<^sup>T) \<sqinter> (f \<sqinter> g))"
    using 30 by (metis inf_absorb2 inf.assoc)
  also have "... = sum (w \<sqinter> (f \<sqinter> g)) + sum (w\<^sup>T \<sqinter> (f \<sqinter> g))"
    using 30 inf.commute acyclic_asymmetric sum_disjoint minimum_spanning_forest_def spanning_forest_def by simp
  also have "... = sum (w \<sqinter> (f \<sqinter> g)) + sum (w \<sqinter> (f\<^sup>T \<sqinter> g\<^sup>T))"
    by (metis conv_dist_inf conv_involutive sum_conv)
  also have "... = sum (f \<sqinter> (w \<sqinter> g)) + sum (f\<^sup>T \<sqinter> (w \<sqinter> g))"
    using 28 inf.commute inf.assoc kruskal_invariant_def kruskal_spanning_invariant_def by simp
  also have "... = sum ((f \<squnion> f\<^sup>T) \<sqinter> (w \<sqinter> g))"
    using 29 acyclic_asymmetric inf.sup_monoid.add_commute sum_disjoint spanning_forest_def by simp
  also have "... = sum (w \<sqinter> g)"
    using 31 by (metis inf_absorb2 inf.assoc)
  finally show "minimum_spanning_forest f g"
    using 29 30 minimum_spanning_forest_def by simp
qed

end

end


section \<open>The Unit Group\<close>

theory "UnitGroup"
imports
   "HOL-Algebra.Group"
   Generators
begin

text \<open>There is, up to isomorphisms, only one group with one element.\<close>

definition unit_group :: "unit monoid"
where
  "unit_group \<equiv> \<lparr>
     carrier = UNIV,
     mult = \<lambda> x y. (),
     one = ()
  \<rparr>"

theorem unit_group_is_group: "group unit_group"
  by (rule groupI, auto simp add:unit_group_def)

theorem (in group) unit_group_unique:
  assumes "card (carrier G) = 1"
  shows "\<exists> h. h \<in> iso G unit_group"
proof-
  from assms obtain x where "carrier G = {x}" by (auto dest: card_eq_SucD)
  hence "(\<lambda> x. ()) \<in> iso G unit_group"
    by -(rule group_isoI, auto simp add:unit_group_is_group is_group, simp add:unit_group_def)
  thus ?thesis by auto
qed

end


(*  Title:      HOL/Quotient_Examples/DList.thy
    Author:     Cezary Kaliszyk, University of Tsukuba

Based on typedef version "Library/Dlist" by Florian Haftmann
and theory morphism version by Maksym Bortin
*)

section {* Lists with distinct elements *}

theory DList
imports "~~/src/HOL/Library/Quotient_List"
begin

text {* Some facts about lists *}

lemma remdups_removeAll_commute[simp]:
  "remdups (removeAll x l) = removeAll x (remdups l)"
  by (induct l) auto

lemma removeAll_distinct[simp]:
  assumes "distinct l"
  shows "distinct (removeAll x l)"
  using assms by (induct l) simp_all

lemma removeAll_commute:
  "removeAll x (removeAll y l) = removeAll y (removeAll x l)"
  by (induct l) auto

lemma remdups_hd_notin_tl:
  "remdups dl = h # t \<Longrightarrow> h \<notin> set t"
  by (induct dl arbitrary: h t)
     (case_tac [!] "a \<in> set dl", auto)

lemma remdups_repeat:
  "remdups dl = h # t \<Longrightarrow> t = remdups t"
  by (induct dl arbitrary: h t, case_tac [!] "a \<in> set dl")
     (simp_all, metis remdups_remdups)

lemma remdups_nil_noteq_cons:
  "remdups (h # t) \<noteq> remdups []"
  "remdups [] \<noteq> remdups (h # t)"
  by auto

lemma remdups_eq_map_eq:
  assumes "remdups xa = remdups ya"
    shows "remdups (map f xa) = remdups (map f ya)"
  using assms
  by (induct xa ya rule: list_induct2')
     (metis (full_types) remdups_nil_noteq_cons(2) remdups_map_remdups)+

lemma remdups_eq_member_eq:
  assumes "remdups xa = remdups ya"
    shows "List.member xa = List.member ya"
  using assms
  unfolding fun_eq_iff List.member_def
  by (induct xa ya rule: list_induct2')
     (metis remdups_nil_noteq_cons set_remdups)+

text {* Setting up the quotient type *}

definition
  dlist_eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  [simp]: "dlist_eq xs ys \<longleftrightarrow> remdups xs = remdups ys"

lemma dlist_eq_reflp:
  "reflp dlist_eq"
  by (auto intro: reflpI)

lemma dlist_eq_symp:
  "symp dlist_eq"
  by (auto intro: sympI)

lemma dlist_eq_transp:
  "transp dlist_eq"
  by (auto intro: transpI)

lemma dlist_eq_equivp:
  "equivp dlist_eq"
  by (auto intro: equivpI dlist_eq_reflp dlist_eq_symp dlist_eq_transp)

quotient_type
  'a dlist = "'a list" / "dlist_eq"
  by (rule dlist_eq_equivp)

text {* respectfulness and constant definitions *}

definition [simp]: "card_remdups = length \<circ> remdups"
definition [simp]: "foldr_remdups f xs e = foldr f (remdups xs) e"

quotient_definition empty where "empty :: 'a dlist"
  is "Nil" done

quotient_definition insert where "insert :: 'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
  is "Cons" by (metis (mono_tags) List.insert_def dlist_eq_def remdups.simps(2) set_remdups)

quotient_definition "member :: 'a dlist \<Rightarrow> 'a \<Rightarrow> bool"
  is "List.member" by (metis dlist_eq_def remdups_eq_member_eq)

quotient_definition foldr where "foldr :: ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b"
  is "foldr_remdups" by auto

quotient_definition "remove :: 'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
  is "removeAll" by force

quotient_definition card where "card :: 'a dlist \<Rightarrow> nat"
  is "card_remdups" by fastforce

quotient_definition map where "map :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b dlist"
  is "List.map :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" by (metis dlist_eq_def remdups_eq_map_eq)

quotient_definition filter where "filter :: ('a \<Rightarrow> bool) \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
  is "List.filter" by (metis dlist_eq_def remdups_filter)

quotient_definition "list_of_dlist :: 'a dlist \<Rightarrow> 'a list"
  is "remdups" by simp

text {* lifted theorems *}

lemma dlist_member_insert:
  "member dl x \<Longrightarrow> insert x dl = dl"
  by descending (simp add: List.member_def)

lemma dlist_member_insert_eq:
  "member (insert y dl) x = (x = y \<or> member dl x)"
  by descending (simp add: List.member_def)

lemma dlist_insert_idem:
  "insert x (insert x dl) = insert x dl"
  by descending simp

lemma dlist_insert_not_empty:
  "insert x dl \<noteq> empty"
  by descending auto

lemma not_dlist_member_empty:
  "\<not> member empty x"
  by descending (simp add: List.member_def)

lemma not_dlist_member_remove:
  "\<not> member (remove x dl) x"
  by descending (simp add: List.member_def)

lemma dlist_in_remove:
  "a \<noteq> b \<Longrightarrow> member (remove b dl) a = member dl a"
  by descending (simp add: List.member_def)

lemma dlist_not_memb_remove:
  "\<not> member dl x \<Longrightarrow> remove x dl = dl"
  by descending (simp add: List.member_def)

lemma dlist_no_memb_remove_insert:
"\<not> member dl x \<Longrightarrow> remove x (insert x dl) = dl"
  by descending (simp add: List.member_def)

lemma dlist_remove_empty:
  "remove x empty = empty"
  by descending simp

lemma dlist_remove_insert_commute:
  "a \<noteq> b \<Longrightarrow> remove a (insert b dl) = insert b (remove a dl)"
  by descending simp

lemma dlist_remove_commute:
"remove a (remove b dl) = remove b (remove a dl)"
  by (lifting removeAll_commute)

lemma dlist_foldr_empty:
  "foldr f empty e = e"
  by descending simp

lemma dlist_no_memb_foldr:
  assumes "\<not> member dl x"
  shows "foldr f (insert x dl) e = f x (foldr f dl e)"
  using assms by descending (simp add: List.member_def)

lemma dlist_foldr_insert_not_memb:
  assumes "\<not>member t h"
  shows "foldr f (insert h t) e = f h (foldr f t e)"
  using assms by descending (simp add: List.member_def)

lemma list_of_dlist_empty[simp]:
  "list_of_dlist empty = []"
  by descending simp

lemma list_of_dlist_insert[simp]:
  "list_of_dlist (insert x xs) =
    (if member xs x then (remdups (list_of_dlist xs))
    else x # (remdups (list_of_dlist xs)))"
  by descending (simp add: List.member_def remdups_remdups)

lemma list_of_dlist_remove[simp]:
  "list_of_dlist (remove x dxs) = remove1 x (list_of_dlist dxs)"
  by descending (simp add: distinct_remove1_removeAll)

lemma list_of_dlist_map[simp]:
  "list_of_dlist (map f dxs) = remdups (List.map f (list_of_dlist dxs))"
  by descending (simp add: remdups_map_remdups)

lemma list_of_dlist_filter [simp]:
  "list_of_dlist (filter P dxs) = List.filter P (list_of_dlist dxs)"
  by descending (simp add: remdups_filter)

lemma dlist_map_empty:
  "map f empty = empty"
  by descending simp

lemma dlist_map_insert:
  "map f (insert x xs) = insert (f x) (map f xs)"
  by descending simp

lemma dlist_eq_iff:
  "dxs = dys \<longleftrightarrow> list_of_dlist dxs = list_of_dlist dys"
  by descending simp

lemma dlist_eqI:
  "list_of_dlist dxs = list_of_dlist dys \<Longrightarrow> dxs = dys"
  by (simp add: dlist_eq_iff)

abbreviation
  "dlist xs \<equiv> abs_dlist xs"

lemma distinct_list_of_dlist [simp, intro]:
  "distinct (list_of_dlist dxs)"
  by descending simp

lemma list_of_dlist_dlist [simp]:
  "list_of_dlist (dlist xs) = remdups xs"
  unfolding list_of_dlist_def map_fun_apply id_def
  by (metis Quotient3_rep_abs[OF Quotient3_dlist] dlist_eq_def)

lemma remdups_list_of_dlist [simp]:
  "remdups (list_of_dlist dxs) = list_of_dlist dxs"
  by simp

lemma dlist_list_of_dlist [simp, code abstype]:
  "dlist (list_of_dlist dxs) = dxs"
  by (simp add: list_of_dlist_def)
  (metis Quotient3_def Quotient3_dlist dlist_eqI list_of_dlist_dlist remdups_list_of_dlist)

lemma dlist_filter_simps:
  "filter P empty = empty"
  "filter P (insert x xs) = (if P x then insert x (filter P xs) else filter P xs)"
  by (lifting filter.simps)

lemma dlist_induct:
  assumes "P empty"
      and "\<And>a dl. P dl \<Longrightarrow> P (insert a dl)"
    shows "P dl"
  using assms by descending (drule list.induct, simp)

lemma dlist_induct_stronger:
  assumes a1: "P empty"
  and     a2: "\<And>x dl. \<lbrakk>\<not>member dl x; P dl\<rbrakk> \<Longrightarrow> P (insert x dl)"
  shows "P dl"
proof(induct dl rule: dlist_induct)
  show "P empty" using a1 by simp
next
  fix x dl
  assume "P dl"
  then show "P (insert x dl)" using a2
    by (cases "member dl x") (simp_all add: dlist_member_insert)
qed

lemma dlist_card_induct:
  assumes "\<And>xs. (\<And>ys. card ys < card xs \<Longrightarrow> P ys) \<Longrightarrow> P xs"
    shows "P xs"
  using assms
  by descending (rule measure_induct [of card_remdups], blast)

lemma dlist_cases:
  "dl = empty \<or> (\<exists>h t. dl = insert h t \<and> \<not> member t h)"
  apply (descending, simp add: List.member_def)
  by (metis list.exhaust remdups_eq_nil_iff remdups_hd_notin_tl remdups_repeat)

lemma dlist_exhaust:
  assumes "y = empty \<Longrightarrow> P"
      and "\<And>a dl. y = insert a dl \<Longrightarrow> P"
    shows "P"
  using assms by (lifting list.exhaust)

lemma dlist_exhaust_stronger:
  assumes "y = empty \<Longrightarrow> P"
      and "\<And>a dl. y = insert a dl \<Longrightarrow> \<not> member dl a \<Longrightarrow> P"
    shows "P"
  using assms by (metis dlist_cases)

end


theory Directed_Sums
  imports Directed_Products

begin

section \<open>Directed Sums\<close>

subsection \<open>Definitions\<close>

definition sum_group :: "'a set \<Rightarrow> ('a \<Rightarrow> ('b, 'c) monoid_scheme) \<Rightarrow> ('a \<Rightarrow> 'b) monoid"
  where "sum_group I G \<equiv> product_group I G
           \<lparr> carrier := {x \<in> carrier (product_group I G). finite {i \<in> I. x i \<noteq> \<one>\<^bsub>G i\<^esub>}} \<rparr>"

subsection \<open>Algebraic Structure\<close>

lemma subgroup_of_finite_sequences:
  assumes "\<And>i. i \<in> I \<Longrightarrow> group (G i)"
  shows "subgroup {x \<in> carrier (product_group I G). finite {i \<in> I. x i \<noteq> \<one>\<^bsub>G i\<^esub>}} (product_group I G)"
    (is "subgroup ?S ?H")
proof -
  interpret H: group "product_group I G"
    using product_group_is_group(1)[of I G, OF assms] .

  show ?thesis
  proof
    show "?S \<subseteq> carrier ?H" and "\<one>\<^bsub>?H\<^esub> \<in> ?S"
      using H.one_closed unfolding product_group_def by auto
  next
    fix x y
    assume x: "x \<in> ?S" and y: "y \<in> ?S"
    have "{i \<in> I. (x \<otimes>\<^bsub>?H\<^esub> y) i \<noteq> \<one>\<^bsub>G i\<^esub>} \<subseteq> {i \<in> I. x i \<noteq> \<one>\<^bsub>G i\<^esub>} \<union> {i \<in> I. y i \<noteq> \<one>\<^bsub>G i\<^esub>}"
      using monoid.l_one[OF _ monoid.one_closed] group.axioms(1)[OF assms]
      by (auto simp add: product_group_fields(2))
    hence "finite {i \<in> I. (x \<otimes>\<^bsub>?H\<^esub> y) i \<noteq> \<one>\<^bsub>G i\<^esub>}"
      using x y finite_subset[OF _ finite_UnI] by auto
    with \<open>x \<in> ?S\<close> and \<open>y \<in> ?S\<close> show "x \<otimes>\<^bsub>?H\<^esub> y \<in> ?S"
      using H.m_closed by simp
  next
    fix x assume x: "x \<in> ?S"
    then have in_carrier: "x \<in> carrier ?H"
      by simp
    have "{i \<in> I. (\<lambda>i\<in>I. inv\<^bsub>G i\<^esub> (x i)) i \<noteq> \<one>\<^bsub>G i\<^esub>} \<subseteq> {i \<in> I. x i \<noteq> \<one>\<^bsub>G i\<^esub>}"
      using monoid.inv_one[OF group.axioms(1)[OF assms]] by auto
    hence "finite {i \<in> I. (inv\<^bsub>?H\<^esub> x) i \<noteq> \<one>\<^bsub>G i\<^esub>}"
      using x product_group_is_group(2)[of I G x, OF assms in_carrier]
      by (simp add: finite_subset)
    with \<open>x \<in> ?S\<close> show "inv\<^bsub>?H\<^esub> x \<in> ?S"
      using H.inv_closed[of x] by simp
  qed
qed

lemma sum_group_is_group:
  assumes "\<And>i. i \<in> I \<Longrightarrow> group (G i)" shows "group (sum_group I G)"
  using group.subgroup_imp_group[OF product_group_is_group(1)   [of I G, OF assms]
                                    subgroup_of_finite_sequences[of I G, OF assms]]
  by (simp add: sum_group_def)

end


(*<*)
(*
   Title:  Theory  stream.thy (FOCUS streams)
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2013
*)
(*>*)

section "FOCUS streams: operators and lemmas"

theory stream
  imports ListExtras ArithExtras
begin

subsection \<open>Definition of the FOCUS stream types\<close>

\<comment> \<open>Finite timed FOCUS stream\<close>
type_synonym 'a fstream = "'a list list"

\<comment> \<open>Infinite timed FOCUS stream\<close>
type_synonym 'a istream = "nat \<Rightarrow> 'a list"

\<comment> \<open>Infinite untimed FOCUS stream\<close>
type_synonym 'a iustream = "nat \<Rightarrow> 'a"

\<comment> \<open>FOCUS stream (general)\<close>
datatype 'a stream =
          FinT "'a fstream" \<comment> \<open>finite timed streams\<close>
        | FinU "'a list" \<comment> \<open>finite untimed streams\<close>
        | InfT "'a istream" \<comment> \<open>infinite timed streams\<close>
        | InfU "'a iustream" \<comment> \<open>infinite untimed streams\<close>

subsection \<open>Definitions of operators\<close>

\<comment> \<open>domain of an infinite untimed stream\<close>
definition
   infU_dom :: "natInf set"
 where
  "infU_dom \<equiv> {x. \<exists> i. x = (Fin i)} \<union> {\<infinity>}"

\<comment> \<open>domain of a finite untimed stream (using natural numbers enriched by Infinity)\<close>
definition
   finU_dom_natInf :: "'a list \<Rightarrow> natInf set"
   where
  "finU_dom_natInf s \<equiv> {x. \<exists> i. x = (Fin i) \<and> i < (length s)}"

\<comment> \<open>domain of a finite untimed stream\<close>
primrec
finU_dom :: "'a list \<Rightarrow> nat set"
where
  "finU_dom [] = {}" |
  "finU_dom (x#xs) = {length xs} \<union> (finU_dom xs)"

\<comment> \<open>range of a finite timed stream\<close>
primrec
  finT_range :: "'a fstream \<Rightarrow> 'a set"
where
  "finT_range [] = {}" |
  "finT_range (x#xs) = (set x) \<union> finT_range xs"

\<comment> \<open>range of a finite untimed stream\<close>
definition
   finU_range :: "'a list \<Rightarrow> 'a set"
where
  "finU_range x \<equiv> set x"

\<comment> \<open>range of an infinite timed stream\<close>
definition
   infT_range :: "'a istream \<Rightarrow> 'a set"
where
  "infT_range s \<equiv> {y. \<exists> i::nat. y mem (s i)}"

\<comment> \<open>range of a finite untimed stream\<close>
definition
   infU_range :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a set"
where
  "infU_range s \<equiv> { y. \<exists> i::nat. y = (s i) }"

\<comment> \<open>range of a (general) stream\<close>
definition
   stream_range :: "'a stream \<Rightarrow> 'a set"
where
 "stream_range s \<equiv> case s of
       FinT x \<Rightarrow> finT_range x
     | FinU x \<Rightarrow> finU_range x
     | InfT x \<Rightarrow> infT_range x
     | InfU x \<Rightarrow> infU_range x"

\<comment> \<open>finite timed stream that consists of n empty time intervals\<close>
primrec
   nticks :: "nat \<Rightarrow> 'a fstream"
where
  "nticks 0 = []" |
  "nticks (Suc i) = [] # (nticks i)"

\<comment> \<open>removing the first element from an infinite stream\<close>
\<comment> \<open>in the case of an untimed stream: removing the first data element\<close>
\<comment> \<open>in the case of a timed stream: removing the first time interval\<close>
definition
   inf_tl :: "(nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)"
where
  "inf_tl s \<equiv> (\<lambda> i. s (Suc i))"

\<comment> \<open>removing i first elements from an infinite stream s\<close>
\<comment> \<open>in the case of an untimed stream: removing i first data elements\<close>
\<comment> \<open>in the case of a timed stream: removing i first time intervals\<close>
definition
   inf_drop :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)"
where
  "inf_drop i s \<equiv>  \<lambda> j. s (i+j)"

\<comment> \<open>finding the first nonempty time interval in a finite timed stream\<close>
primrec
 fin_find1nonemp :: "'a fstream \<Rightarrow> 'a list"
where
 "fin_find1nonemp [] = []" |
 "fin_find1nonemp (x#xs) =
    ( if x = []
      then fin_find1nonemp xs
      else x )"

\<comment> \<open>finding the first nonempty time interval in an infinite timed stream\<close>
definition
  inf_find1nonemp :: "'a istream \<Rightarrow> 'a list"
where
 "inf_find1nonemp s
  \<equiv>
  ( if (\<exists> i. s i \<noteq> [])
    then s (LEAST i. s i \<noteq> [])
    else [] )"

\<comment> \<open>finding the index of the first nonempty time interval in a finite timed stream\<close>
primrec
 fin_find1nonemp_index :: "'a fstream \<Rightarrow> nat"
where
 "fin_find1nonemp_index [] = 0" |
 "fin_find1nonemp_index (x#xs) =
    ( if x = []
      then Suc (fin_find1nonemp_index xs)
      else 0 )"

\<comment> \<open>finding the index of the first nonempty time interval in an infinite timed stream\<close>
definition
  inf_find1nonemp_index :: "'a istream \<Rightarrow> nat"
where
 "inf_find1nonemp_index s
  \<equiv>
  ( if (\<exists> i. s i \<noteq> [])
    then (LEAST i. s i \<noteq> [])
    else 0 )"

\<comment> \<open>length of a finite timed stream: number of data elements in this stream\<close>
primrec
  fin_length :: "'a fstream \<Rightarrow> nat"
where
  "fin_length [] = 0" |
  "fin_length (x#xs) = (length x) + (fin_length xs)"

\<comment> \<open>length of a (general) stream\<close>
definition
   stream_length :: "'a stream \<Rightarrow> natInf"
where
  "stream_length s \<equiv>
      case s of
                (FinT x) \<Rightarrow> Fin (fin_length x)
              | (FinU x) \<Rightarrow> Fin (length x)
              | (InfT x) \<Rightarrow> \<infinity>
              | (InfU x) \<Rightarrow> \<infinity>"

\<comment> \<open>removing the first k elements from a finite (nonempty) timed stream\<close>
axiomatization
  fin_nth :: "'a fstream \<Rightarrow> nat \<Rightarrow> 'a"
where
   fin_nth_Cons:
  "fin_nth (hds # tls) k =
      ( if hds = []
        then fin_nth tls k
        else ( if (k < (length hds))
               then nth hds k
               else fin_nth tls (k - length hds) ))"

\<comment> \<open>removing i first data elements from an infinite timed stream s\<close>
primrec
  inf_nth :: "'a istream \<Rightarrow> nat \<Rightarrow> 'a"
where
 "inf_nth s 0 =  hd (s (LEAST i.(s i) \<noteq> []))"  |
 "inf_nth s (Suc k) =
      ( if ((Suc k) < (length (s 0)))
        then (nth (s 0) (Suc k))
        else ( if (s 0) = []
               then (inf_nth (inf_tl (inf_drop
                     (LEAST i. (s i) \<noteq> []) s)) k )
               else inf_nth (inf_tl s) k ))"

\<comment> \<open>removing the first k data elements from a (general) stream\<close>
definition
    stream_nth :: "'a stream \<Rightarrow> nat \<Rightarrow> 'a"
where
   "stream_nth s k \<equiv>
         case s of (FinT x) \<Rightarrow> fin_nth x k
                 | (FinU x) \<Rightarrow> nth x k
                 | (InfT x) \<Rightarrow> inf_nth x k
                 | (InfU x) \<Rightarrow> x k"

\<comment> \<open>prefix of an infinite stream\<close>
primrec
  inf_prefix :: "'a list \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> bool"
where
  "inf_prefix [] s k = True" |
  "inf_prefix (x#xs) s k = ( (x = (s k)) \<and> (inf_prefix xs s (Suc k)) )"

\<comment> \<open>prefix of a finite stream\<close>
primrec
  fin_prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "fin_prefix [] s = True" |
  "fin_prefix (x#xs) s =
     (if (s = [])
      then False
      else (x = (hd s)) \<and> (fin_prefix xs s) )"

\<comment> \<open>prefix of a (general) stream\<close>
definition
   stream_prefix :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> bool"
where
  "stream_prefix p s \<equiv>
   (case p of
        (FinT x) \<Rightarrow>
        (case s of (FinT y) \<Rightarrow>  (fin_prefix x y)
                 | (FinU y) \<Rightarrow> False
                 | (InfT y) \<Rightarrow> inf_prefix x y 0
                 | (InfU y) \<Rightarrow> False )
      | (FinU x) \<Rightarrow>
        (case s of (FinT y) \<Rightarrow> False
                 | (FinU y) \<Rightarrow>  (fin_prefix x y)
                 | (InfT y) \<Rightarrow> False
                 | (InfU y) \<Rightarrow>  inf_prefix x y 0 )
      | (InfT x) \<Rightarrow>
        (case s of (FinT y) \<Rightarrow> False
                 | (FinU y) \<Rightarrow> False
                 | (InfT y) \<Rightarrow> (\<forall> i. x i = y i)
                 | (InfU y) \<Rightarrow> False )
      | (InfU x) \<Rightarrow>
        (case s of (FinT y) \<Rightarrow> False
                 | (FinU y) \<Rightarrow> False
                 | (InfT y) \<Rightarrow> False
                 | (InfU y) \<Rightarrow> (\<forall> i. x i = y i) )  )"

\<comment> \<open>truncating a finite stream after the n-th element\<close>
primrec
fin_truncate :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list"
where
  "fin_truncate [] n = []" |
  "fin_truncate (x#xs) i =
      (case i of 0 \<Rightarrow> []
         | (Suc n) \<Rightarrow> x # (fin_truncate xs n))"

\<comment> \<open>truncating a finite stream after the n-th element\<close>
\<comment> \<open>n is of type of natural numbers enriched by Infinity\<close>
definition
  fin_truncate_plus :: "'a list \<Rightarrow> natInf \<Rightarrow> 'a list"
 where
 "fin_truncate_plus s n
  \<equiv>
  case n of (Fin i) \<Rightarrow> fin_truncate s i
           |  \<infinity>     \<Rightarrow> s "

\<comment> \<open>truncating an infinite stream after the n-th element\<close>
primrec
  inf_truncate :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a list"
where
   "inf_truncate s 0 = [ s 0 ]" |
   "inf_truncate s (Suc k) = (inf_truncate s k) @ [s (Suc k)]"

\<comment> \<open>truncating an infinite stream after the n-th element\<close>
\<comment> \<open>n is of type of natural numbers enriched by Infinity\<close>
definition
  inf_truncate_plus :: "'a istream \<Rightarrow> natInf \<Rightarrow> 'a stream"
 where
 "inf_truncate_plus s n
  \<equiv>
  case n of (Fin i) \<Rightarrow> FinT (inf_truncate s i)
           | \<infinity>     \<Rightarrow> InfT s"

\<comment> \<open>concatanation of a finite and an infinite stream\<close>
definition
    fin_inf_append ::
        "'a list \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)"
where
"fin_inf_append us s \<equiv>
 (\<lambda> i. ( if (i < (length us))
         then (nth us i)
         else s (i - (length us)) ))"

\<comment> \<open>insuring that the infinite timed stream is time-synchronous\<close>
definition
   ts :: "'a istream \<Rightarrow> bool"
where
"ts s \<equiv>  \<forall> i. (length (s i) = 1)"

\<comment> \<open>insuring that each time interval of an infinite timed stream contains at most n data elements\<close>
definition
  msg :: "nat \<Rightarrow> 'a istream \<Rightarrow> bool"
where
 "msg n s \<equiv>  \<forall> t. length (s t) \<le> n"

\<comment> \<open>insuring that each time interval of a finite timed stream contains at most n data elements\<close>
primrec
  fin_msg :: "nat \<Rightarrow> 'a list list \<Rightarrow> bool"
where
 "fin_msg n [] = True" |
 "fin_msg n (x#xs) = (((length x) \<le> n) \<and> (fin_msg n xs))"

\<comment> \<open>making a finite timed stream to a finite untimed stream\<close>
definition
   fin_make_untimed :: "'a fstream  \<Rightarrow> 'a list"
where
  "fin_make_untimed x \<equiv>  concat x"

\<comment> \<open>making an infinite timed stream to an infinite untimed stream\<close>
\<comment> \<open>(auxiliary function)\<close>
primrec
  inf_make_untimed1 :: "'a istream \<Rightarrow> nat \<Rightarrow> 'a "
where
inf_make_untimed1_0:
  "inf_make_untimed1 s 0 =  hd (s (LEAST i.(s i) \<noteq> []))"  |
inf_make_untimed1_Suc:
  "inf_make_untimed1 s (Suc k) =
    ( if ((Suc k) < length (s 0))
      then nth (s 0) (Suc k)
      else ( if (s 0) = []
             then (inf_make_untimed1 (inf_tl (inf_drop
                          (LEAST i. \<forall> j. j < i \<longrightarrow> (s j) = [])
                           s)) k )
             else inf_make_untimed1 (inf_tl s) k ))"

\<comment> \<open>making an infinite timed stream to an infinite untimed stream\<close>
\<comment> \<open>(main function)\<close>
definition
   inf_make_untimed :: "'a istream \<Rightarrow> (nat \<Rightarrow> 'a) "
where
  "inf_make_untimed s
   \<equiv>
   \<lambda> i. inf_make_untimed1 s i"

\<comment> \<open>making a (general) stream untimed\<close>
definition
    make_untimed :: "'a stream  \<Rightarrow> 'a stream"
where
   "make_untimed s \<equiv>
      case s of (FinT x) \<Rightarrow> FinU (fin_make_untimed x)
              | (FinU x) \<Rightarrow> FinU x
              | (InfT x) \<Rightarrow>
                (if (\<exists> i.\<forall> j. i < j \<longrightarrow> (x j) = [])
                 then FinU (fin_make_untimed (inf_truncate x
                             (LEAST i.\<forall> j. i < j \<longrightarrow> (x j) = [])))
                 else InfU (inf_make_untimed x))
              | (InfU x) \<Rightarrow> InfU x"

\<comment> \<open>finding the index of the time interval that contains the k-th data element\<close>
\<comment> \<open>defined over a finite timed stream\<close>
primrec
  fin_tm :: "'a fstream \<Rightarrow> nat \<Rightarrow> nat"
where
  "fin_tm [] k = k" |
  "fin_tm (x#xs) k =
    (if k = 0
     then 0
     else (if (k \<le> length x)
           then (Suc 0)
           else Suc(fin_tm xs (k - length x))))"

\<comment> \<open>auxiliary lemma for the definition of the truncate operator\<close>
lemma inf_tm_hint1:
  assumes "i2 = Suc i - length a"
      and "\<not> Suc i \<le> length a"
      and "a \<noteq> []"
  shows "i2 < Suc i"
using assms
by auto

\<comment> \<open>filtering a finite timed stream\<close>
definition
   finT_filter :: "'a set => 'a fstream => 'a fstream"
where
  "finT_filter m s \<equiv>  map (\<lambda> s. filter (\<lambda> y. y \<in> m) s) s"

\<comment> \<open>filtering an infinite timed stream\<close>
definition
   infT_filter :: "'a set => 'a istream => 'a istream"
where
  "infT_filter m s \<equiv>  (\<lambda>i.( filter (\<lambda> x. x \<in> m) (s i)))"

\<comment> \<open>removing duplications from a finite timed stream\<close>
definition
   finT_remdups :: "'a fstream => 'a fstream"
where
  "finT_remdups s \<equiv>  map (\<lambda> s. remdups s) s"

\<comment> \<open>removing duplications from an infinite timed stream\<close>
definition
   infT_remdups :: "'a istream => 'a istream"
where
  "infT_remdups s \<equiv>  (\<lambda>i.( remdups (s i)))"

\<comment> \<open>removing duplications from a time interval of a stream\<close>
primrec
   fst_remdups :: "'a list \<Rightarrow> 'a list"
where
 "fst_remdups [] = []" |
 "fst_remdups (x#xs) =
    (if xs = []
     then [x]
     else (if x = (hd xs)
           then fst_remdups xs
           else (x#xs)))"

\<comment> \<open>time interval operator\<close>
definition
  ti :: "'a fstream \<Rightarrow> nat \<Rightarrow> 'a list"
where
 "ti s i \<equiv>
    (if s = []
     then []
     else (nth s i))"

\<comment> \<open>insuring that a sheaf of channels is correctly defined\<close>
definition
   CorrectSheaf :: "nat \<Rightarrow> bool"
where
  "CorrectSheaf n \<equiv> 0 < n"

\<comment> \<open>insuring that all channels in a sheaf are disjunct\<close>
\<comment> \<open>indices in the sheaf are represented using an extra specified set\<close>
definition
   inf_disjS :: "'b set \<Rightarrow> ('b \<Rightarrow> 'a istream) \<Rightarrow> bool"
where
  "inf_disjS IdSet nS
   \<equiv>
   \<forall> (t::nat) i j. (i:IdSet) \<and> (j:IdSet) \<and>
   ((nS i) t) \<noteq> []  \<longrightarrow> ((nS j) t) = []"

\<comment> \<open>insuring that all channels in a sheaf are disjunct\<close>
\<comment> \<open>indices in the sheaf are represented using natural numbers\<close>
definition
   inf_disj :: "nat \<Rightarrow> (nat \<Rightarrow> 'a istream) \<Rightarrow> bool"
where
  "inf_disj n nS
   \<equiv>
   \<forall> (t::nat) (i::nat) (j::nat).
   i < n  \<and>  j < n \<and> i \<noteq> j \<and> ((nS i) t) \<noteq> []  \<longrightarrow>
   ((nS j) t) = []"

\<comment> \<open>taking the prefix of n data elements from a finite timed stream\<close>
\<comment> \<open>(defined over natural numbers)\<close>
fun fin_get_prefix  :: "('a fstream \<times> nat) \<Rightarrow> 'a fstream"
where
  "fin_get_prefix([], n) = []" |
  "fin_get_prefix(x#xs, i) =
     ( if (length x) < i
       then x # fin_get_prefix(xs, (i - (length x)))
       else [take i x] ) "

\<comment> \<open>taking the prefix of n data elements from a finite timed stream\<close>
\<comment> \<open>(defined over natural numbers enriched by Infinity)\<close>
definition
  fin_get_prefix_plus :: "'a fstream \<Rightarrow> natInf \<Rightarrow> 'a fstream"
where
 "fin_get_prefix_plus s n
  \<equiv>
  case n of (Fin i) \<Rightarrow> fin_get_prefix(s, i)
           | \<infinity>      \<Rightarrow> s "

\<comment> \<open>auxiliary lemmas\<close>
lemma length_inf_drop_hint1:
  assumes "s k \<noteq> []"
  shows    "length (inf_drop k s 0) \<noteq> 0"
using assms
by (auto simp: inf_drop_def)

\<comment> \<open>taking the prefix of n data elements from an infinite timed stream\<close>
\<comment> \<open>(defined over natural numbers)\<close>
fun infT_get_prefix  :: "('a istream \<times> nat) \<Rightarrow> 'a fstream"
where
  "infT_get_prefix(s, 0) = []"
|
  "infT_get_prefix(s, Suc i) =
    ( if (s 0) = []
      then ( if (\<forall> i. s i = [])
             then []
             else (let
                     k = (LEAST k. s k \<noteq> [] \<and> (\<forall>i. i < k \<longrightarrow> s i = []));
                     s2 = inf_drop (k+1) s
                   in (if (length (s k)=0)
                       then []
                       else (if (length (s k) < (Suc i))
                             then s k # infT_get_prefix (s2,Suc i - length (s k))
                             else [take (Suc i) (s k)] )))
           )
      else
        (if ((length (s 0)) < (Suc i))
         then (s 0) # infT_get_prefix( inf_drop 1 s, (Suc i) - (length (s 0)))
         else [take (Suc i) (s 0)]
         )
     )"

\<comment> \<open>taking the prefix of n data elements from an infinite untimed stream\<close>
\<comment> \<open>(defined over natural numbers)\<close>
primrec
  infU_get_prefix  :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a list"
where
  "infU_get_prefix s 0 = []" |
  "infU_get_prefix s (Suc i)
         = (infU_get_prefix s i) @ [s i]"

\<comment> \<open>taking the prefix of n data elements from an infinite timed stream\<close>
\<comment> \<open>(defined over natural numbers enriched by Infinity)\<close>
definition
  infT_get_prefix_plus :: "'a istream \<Rightarrow> natInf \<Rightarrow> 'a stream"
where
"infT_get_prefix_plus s n
  \<equiv>
  case n of (Fin i) \<Rightarrow> FinT (infT_get_prefix(s, i))
           | \<infinity>     \<Rightarrow> InfT s"

\<comment> \<open>taking the prefix of n data elements from an infinite untimed stream\<close>
\<comment> \<open>(defined over natural numbers enriched by Infinity)\<close>
definition
  infU_get_prefix_plus :: "(nat \<Rightarrow> 'a) \<Rightarrow> natInf \<Rightarrow> 'a stream"
where
 "infU_get_prefix_plus s n
  \<equiv>
  case n of (Fin i) \<Rightarrow> FinU (infU_get_prefix s i)
           | \<infinity>     \<Rightarrow> InfU s"

\<comment> \<open>taking the prefix of n data elements from an infinite stream\<close>
\<comment> \<open>(defined over natural numbers enriched by Infinity)\<close>
definition
  take_plus :: "natInf \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
 "take_plus n s
  \<equiv>
  case n of (Fin i) \<Rightarrow> (take i s)
           | \<infinity>      \<Rightarrow> s"

\<comment> \<open>taking the prefix of n data elements from a (general) stream\<close>
\<comment> \<open>(defined over natural numbers enriched by Infinity)\<close>
definition
   get_prefix :: "'a stream \<Rightarrow> natInf \<Rightarrow> 'a stream"
where
   "get_prefix s k \<equiv>
        case s of  (FinT x) \<Rightarrow> FinT (fin_get_prefix_plus x k)
                 | (FinU x) \<Rightarrow> FinU (take_plus k x)
                 | (InfT x) \<Rightarrow> infT_get_prefix_plus x k
                 | (InfU x) \<Rightarrow> infU_get_prefix_plus x k"

\<comment> \<open>merging time intervals of two finite timed streams\<close>
primrec
   fin_merge_ti :: "'a fstream \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"
where
 "fin_merge_ti [] y = y" |
 "fin_merge_ti (x#xs) y =
    ( case y of [] \<Rightarrow> (x#xs)
         | (z#zs) \<Rightarrow> (x@z) # (fin_merge_ti xs zs))"

\<comment> \<open>merging time intervals of two infinite timed streams\<close>
definition
 inf_merge_ti :: "'a istream \<Rightarrow> 'a istream \<Rightarrow> 'a istream"
where
 "inf_merge_ti x y
  \<equiv>
  \<lambda> i. (x i)@(y i)"

\<comment> \<open>the last time interval of a finite timed stream\<close>
primrec
  fin_last_ti :: "('a list) list \<Rightarrow> nat \<Rightarrow> 'a list"
where
 "fin_last_ti s 0 = hd s" |
 "fin_last_ti s (Suc i) =
     ( if s!(Suc i) \<noteq> []
       then s!(Suc i)
       else fin_last_ti s i)"

\<comment> \<open>the last nonempty time interval of a finite timed stream\<close>
\<comment> \<open>(can be applied to the streams which time intervals are empty from some moment)\<close>
primrec
  inf_last_ti :: "'a istream \<Rightarrow> nat \<Rightarrow> 'a list"
where
 "inf_last_ti s 0 = s 0" |
 "inf_last_ti s (Suc i) =
     ( if s (Suc i) \<noteq> []
       then s (Suc i)
       else inf_last_ti s i)"

subsection \<open>Properties of operators\<close>

lemma inf_last_ti_nonempty_k:
  assumes "inf_last_ti dt t \<noteq> []"
  shows    "inf_last_ti dt (t + k) \<noteq> []"
using assms
by (induct k, auto)

lemma inf_last_ti_nonempty:
  assumes "s t \<noteq> []"
  shows    "inf_last_ti s (t + k) \<noteq> []"
using assms
by (induct k, auto, induct t, auto)

lemma arith_sum_t2k:
"t + 2 + k = (Suc t) + (Suc k)"
by arith

lemma inf_last_ti_Suc2:
  assumes "dt (Suc t) \<noteq> [] \<or> dt (Suc (Suc t)) \<noteq> []"
  shows    "inf_last_ti dt (t + 2 + k) \<noteq> []"
proof (cases "dt (Suc t) \<noteq> []")
  assume a1:"dt (Suc t) \<noteq> []"
  from a1 have sg2:"inf_last_ti dt ((Suc t) + (Suc k)) \<noteq> []"
    by (rule inf_last_ti_nonempty)
  from sg2 show ?thesis by (simp add: arith_sum_t2k)
next
  assume a2:"\<not> dt (Suc t) \<noteq> []"
  from a2 and assms have sg1:"dt (Suc (Suc t)) \<noteq> []" by simp
  from sg1 have sg2:"inf_last_ti dt (Suc (Suc t) + k) \<noteq> []"
    by (rule inf_last_ti_nonempty)
  from sg2 show ?thesis by auto
qed

subsubsection \<open>Lemmas for concatenation operator\<close>

lemma fin_length_append:
  "fin_length (x@y) = (fin_length x) + (fin_length y)"
by (induct x, auto)

lemma fin_append_Nil:  "fin_inf_append [] z = z"
by (simp add: fin_inf_append_def)

lemma correct_fin_inf_append1:
  assumes "s1 = fin_inf_append [x] s"
  shows    "s1 (Suc i) = s i"
using assms
by (simp add: fin_inf_append_def)

lemma correct_fin_inf_append2:
  "fin_inf_append [x] s (Suc i) = s i"
by (simp add: fin_inf_append_def)

lemma fin_append_com_Nil1:
  "fin_inf_append [] (fin_inf_append y z)
   = fin_inf_append ([] @ y) z"
by (simp add: fin_append_Nil)

lemma fin_append_com_Nil2:
  "fin_inf_append x (fin_inf_append [] z)
  = fin_inf_append (x @ []) z"
by (simp add: fin_append_Nil)

lemma fin_append_com_i:
  "fin_inf_append x (fin_inf_append y z) i = fin_inf_append (x @ y) z i "
proof (cases x)
  assume Nil:"x = []"
  thus ?thesis by (simp add: fin_append_com_Nil1)
next
  fix a l assume Cons:"x = a # l"
  thus ?thesis
  proof (cases y)
    assume "y = []"
    thus ?thesis by (simp add: fin_append_com_Nil2)
  next
    fix aa la assume Cons2:"y = aa # la"
    show ?thesis
    apply (simp add: fin_inf_append_def, auto, simp add: list_nth_append0)
    by (simp add: nth_append)
  qed
qed

subsubsection \<open>Lemmas for operators $ts$ and $msg$\<close>

lemma ts_msg1:
  assumes "ts p"
  shows    "msg 1 p"
using assms
by (simp add: ts_def msg_def)

lemma ts_inf_tl:
  assumes "ts x"
  shows    "ts (inf_tl x)"
using assms
by (simp add: ts_def inf_tl_def)

lemma ts_length_hint1:
 assumes "ts x"
 shows    "x i \<noteq> []"
proof -
  from assms have sg1:"length (x i) = Suc 0"  by (simp add: ts_def)
  thus ?thesis by auto
qed

lemma ts_length_hint2:
 assumes "ts x"
 shows    "length (x i) = Suc (0::nat)"
using assms
by (simp add: ts_def)

lemma ts_Least_0:
  assumes "ts x"
  shows    "(LEAST i. (x i) \<noteq> [] ) = (0::nat)"
proof -
  from assms have sg1:"x 0 \<noteq> []" by (rule ts_length_hint1)
  thus ?thesis
  apply (simp add: Least_def)
  by auto
qed

lemma inf_tl_Suc: "inf_tl x i = x (Suc i)"
by (simp add: inf_tl_def)

lemma ts_Least_Suc0:
  assumes "ts x"
  shows    "(LEAST i. x (Suc i) \<noteq> []) = 0"
proof -
  from assms have "x (Suc 0) \<noteq> []" by (simp add: ts_length_hint1)
  thus ?thesis by (simp add: Least_def, auto)
qed

lemma ts_inf_make_untimed_inf_tl:
  assumes "ts x"
  shows     "inf_make_untimed (inf_tl x) i = inf_make_untimed x (Suc i)"
using assms
apply (simp add: inf_make_untimed_def)
by (metis Suc_less_eq gr_implies_not0 ts_length_hint1 ts_length_hint2)

lemma ts_inf_make_untimed1_inf_tl:
  assumes "ts x"
  shows    "inf_make_untimed1 (inf_tl x) i = inf_make_untimed1 x (Suc i)"
using assms
by (metis inf_make_untimed_def ts_inf_make_untimed_inf_tl)

lemma msg_nonempty1:
  assumes h1:"msg (Suc 0) a"
         and h2:"a t = aa # l"
  shows "l = []"
proof -
  from h1 have "length (a t) \<le> Suc 0" by (simp add: msg_def)
  from h2 and this show ?thesis by auto
qed

lemma msg_nonempty2:
  assumes h1:"msg (Suc 0) a"
         and h2:"a t  \<noteq> []"
  shows "length (a t) = (Suc 0)"
proof -
  from h1 have sg1:"length (a t) \<le> Suc 0" by (simp add: msg_def)
  from h2 have sg2:"length (a t) \<noteq> 0" by auto
  from sg1 and sg2 show ?thesis by arith
qed

subsubsection \<open>Lemmas for $inf\_truncate$\<close>

lemma inf_truncate_nonempty:
  assumes "z i \<noteq> []"
  shows    "inf_truncate z i \<noteq> []"
proof (induct i)
    case 0
    from assms  show ?case by auto
  next
    case (Suc i)
     from assms show ?case by auto
qed

lemma concat_inf_truncate_nonempty:
  assumes  "z i \<noteq> []"
  shows      "concat (inf_truncate z i) \<noteq> []"
using assms
proof (induct i)
    case 0
    thus ?case by auto
  next
    case (Suc i)
    thus ?case by auto
qed

lemma concat_inf_truncate_nonempty_a:
  assumes "z i = [a]"
  shows    "concat (inf_truncate z i) \<noteq> []"
using assms
by (metis concat_inf_truncate_nonempty list.distinct(1))

lemma concat_inf_truncate_nonempty_el:
  assumes "z i \<noteq> []"
  shows    "concat (inf_truncate z i) \<noteq> []"
using assms
by (metis concat_inf_truncate_nonempty)

lemma inf_truncate_append:
  "(inf_truncate z i @ [z (Suc i)]) = inf_truncate z (Suc i)"
by (metis inf_truncate.simps(2))

subsubsection \<open>Lemmas for $fin\_make\_untimed$\<close>

lemma fin_make_untimed_append:
  assumes "fin_make_untimed x \<noteq> []"
  shows    "fin_make_untimed (x @ y) \<noteq> []"
using assms by (simp add: fin_make_untimed_def)

lemma fin_make_untimed_inf_truncate_Nonempty:
  assumes "z k \<noteq> []"
         and "k \<le> i"
  shows "fin_make_untimed (inf_truncate z i) \<noteq> []"
using assms
  apply (simp add: fin_make_untimed_def)
  proof (induct i)
    case 0
    thus ?case  by auto
  next
    case (Suc i)
    thus ?case
    proof cases
      assume "k \<le> i"
      from Suc and this show "\<exists>xs\<in>set (inf_truncate z (Suc i)). xs \<noteq> []"
        by auto
    next
      assume "\<not> k \<le> i"
      from Suc and this have "k = Suc i" by arith
      from Suc and this show "\<exists>xs\<in>set (inf_truncate z (Suc i)). xs \<noteq> []"
        by auto
     qed
qed

lemma last_fin_make_untimed_inf_truncate:
  assumes "z i = [a]"
  shows    "last (fin_make_untimed (inf_truncate z i)) = a"
using assms
proof (induction i)
   case 0  thus ?case by (simp add: fin_make_untimed_def)
next
   case (Suc i)  thus ?case by (simp add: fin_make_untimed_def)
qed

lemma fin_make_untimed_append_empty:
  "fin_make_untimed (z @ [[]]) = fin_make_untimed z"
by (simp add: fin_make_untimed_def)

lemma fin_make_untimed_inf_truncate_append_a:
  "fin_make_untimed (inf_truncate z i @ [[a]]) !
  (length (fin_make_untimed (inf_truncate z i @ [[a]])) - Suc 0) = a"
by (simp add: fin_make_untimed_def)

lemma fin_make_untimed_inf_truncate_Nonempty_all:
  assumes "z k \<noteq> []"
  shows    "\<forall> i. k \<le> i \<longrightarrow> fin_make_untimed (inf_truncate z i) \<noteq> []"
using assms by (simp add:  fin_make_untimed_inf_truncate_Nonempty)

lemma fin_make_untimed_inf_truncate_Nonempty_all0:
  assumes "z 0 \<noteq> []"
  shows    "\<forall> i. fin_make_untimed (inf_truncate z i) \<noteq> []"
using assms by (simp add: fin_make_untimed_inf_truncate_Nonempty)

lemma fin_make_untimed_inf_truncate_Nonempty_all0a:
  assumes "z 0 = [a]"
  shows    "\<forall> i. fin_make_untimed (inf_truncate z i) \<noteq> []"
using assms by (simp add: fin_make_untimed_inf_truncate_Nonempty_all0)

lemma fin_make_untimed_inf_truncate_Nonempty_all_app:
  assumes "z 0 = [a]"
  shows    "\<forall> i. fin_make_untimed (inf_truncate z i @ [z (Suc i)]) \<noteq> []"
proof
  fix i
  from assms have "fin_make_untimed (inf_truncate z i) \<noteq> []"
    by (simp add: fin_make_untimed_inf_truncate_Nonempty_all0a)
  from assms and this show
    "fin_make_untimed (inf_truncate z i @ [z (Suc i)]) \<noteq> []"
    by (simp add: fin_make_untimed_append)
qed

lemma fin_make_untimed_nth_length:
  assumes "z i = [a]"
  shows
  "fin_make_untimed (inf_truncate z i) !
     (length (fin_make_untimed (inf_truncate z i)) - Suc 0)
    = a"
proof -
from assms have sg1:"last (fin_make_untimed (inf_truncate z i)) = a"
  by (simp add: last_fin_make_untimed_inf_truncate)
from assms have sg2:"concat (inf_truncate z i) \<noteq> []"
  by (rule concat_inf_truncate_nonempty_a)
from assms and sg1 and sg2 show ?thesis
  by (simp add: fin_make_untimed_def last_nth_length)
qed

subsubsection \<open>Lemmas for $inf\_disj$ and $inf\_disjS$\<close>

lemma inf_disj_index:
  assumes h1:"inf_disj n nS"
         and "nS k t \<noteq> []"
         and "k < n"
  shows  "(SOME i. i < n \<and>  nS i t \<noteq> []) = k"
proof -
  from h1 have "\<forall> j. k < n \<and> j < n \<and> k \<noteq> j \<and> nS k t \<noteq> [] \<longrightarrow> nS j t = []"
    by (simp add: inf_disj_def, auto)
  from this and assms show ?thesis by auto
qed

lemma inf_disjS_index:
  assumes h1:"inf_disjS IdSet nS"
      and "k:IdSet"
      and "nS k t \<noteq> []"
  shows "(SOME i. (i:IdSet) \<and> nSend i t \<noteq> []) = k"
proof -
  from h1 have "\<forall> j. k \<in> IdSet \<and> j \<in> IdSet \<and> nS k t \<noteq> [] \<longrightarrow> nS j t = []"
    by (simp add: inf_disjS_def, auto)
  from this and assms show ?thesis by auto
qed

end