theory Networks
  imports TA.Timed_Automata TA_Impl.Normalized_Zone_Semantics_Impl
    TA_Library.Reordering_Quantifiers TA_Library.Syntax_Bundles
begin

unbundle no_library_syntax

chapter \<open>Networks of Timed Automata\<close>

section \<open>Networks of Timed Automata\<close>

subsection \<open>Syntax and Operational Semantics\<close>

text \<open>Input, output and internal transitions\<close>

datatype 'a act = In 'a | Out 'a | Sil 'a

datatype 'b label = Del | Act 'b | Syn 'b 'b

type_synonym
  ('a, 'b, 'c, 't, 's) nta = "('a act * 'b, 'c, 't, 's) ta list"

inductive step_n ::
  "('a, 'b, 'c, 't, 's) nta \<Rightarrow> 's list \<Rightarrow> ('c, ('t::time)) cval \<Rightarrow> 'b label
  \<Rightarrow> 's list \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
("_ \<turnstile>\<^sub>N \<langle>_, _\<rangle> \<rightarrow>\<^bsub>_\<^esub> \<langle>_,_\<rangle>" [61,61,61,61,61,61] 61)
where
  step_n_t:
    "\<lbrakk>\<forall> p \<in> {..<length N}. N!p \<turnstile> \<langle>L!p, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>L!p, u \<oplus> d\<rangle>; d \<ge> 0\<rbrakk>
    \<Longrightarrow> N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L, u \<oplus> d\<rangle>" |
  step_n_i:
    "\<lbrakk>
      N!p \<turnstile> l \<longrightarrow>\<^bsup>g,(Sil a, b),r\<^esup> l'; u \<turnstile> g; \<forall> p \<in> {..<length N}. u' \<turnstile> inv_of (N!p) (L'!p);
      L!p = l; p < length L; L' = L[p := l']; u' = [r\<rightarrow>0]u
     \<rbrakk>
    \<Longrightarrow> N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Act b\<^esub> \<langle>L', u'\<rangle>" |
  step_n_s:
    "\<lbrakk>N!p \<turnstile> l1 \<longrightarrow>\<^bsup>g1,(In a, b1),r1\<^esup> l1'; N!q \<turnstile> l2 \<longrightarrow>\<^bsup>g2,(Out a, b2),r2\<^esup> l2'; u \<turnstile> g1; u \<turnstile> g2;
      \<forall> p \<in> {..<length N}. u' \<turnstile> inv_of (N!p) (L'!p);
      L!p = l1; L!q = l2; p < length L; q < length L; p \<noteq> q;
      L' = L[p := l1', q := l2']; u' = [(r1 @ r2)\<rightarrow>0]u
     \<rbrakk> \<Longrightarrow> N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Syn b1 b2\<^esub> \<langle>L', u'\<rangle>"

inductive_cases[elim!]: "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', u'\<rangle>"

inductive steps_n ::
  "('a, 'b, 'c, 't, 's) nta \<Rightarrow> 's list \<Rightarrow> ('c, ('t::time)) cval
  \<Rightarrow> 's list \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
("_ \<turnstile>\<^sub>N \<langle>_, _\<rangle> \<rightarrow>* \<langle>_,_\<rangle>" [61,61,61] 61)
where
  refl: "N \<turnstile>\<^sub>N \<langle>l, Z\<rangle> \<rightarrow>* \<langle>l, Z\<rangle>" |
  step: "N \<turnstile>\<^sub>N \<langle>l, Z\<rangle> \<rightarrow>* \<langle>l', Z'\<rangle> \<Longrightarrow> N \<turnstile>\<^sub>N \<langle>l', Z'\<rangle> \<rightarrow>\<^bsub>_\<^esub> \<langle>l'', Z''\<rangle>
        \<Longrightarrow> N \<turnstile>\<^sub>N \<langle>l, Z\<rangle> \<rightarrow>* \<langle>l'', Z''\<rangle>"

declare steps_n.intros[intro]

lemma stepI2:
  "N \<turnstile>\<^sub>N \<langle>l, Z\<rangle> \<rightarrow>* \<langle>l'', Z''\<rangle>" if "N \<turnstile>\<^sub>N \<langle>l', Z'\<rangle> \<rightarrow>* \<langle>l'', Z''\<rangle>" "N \<turnstile>\<^sub>N \<langle>l, Z\<rangle> \<rightarrow>\<^bsub>b\<^esub> \<langle>l', Z'\<rangle>"
  using that
  apply induction
   apply rule
    apply (rule refl)
   apply assumption
  apply simp
  by (rule; assumption)

lemma step_n_t_I:
  "\<lbrakk>\<forall> p \<in> {..<length N}. u \<turnstile> inv_of (N!p) (L!p); \<forall> p \<in> {..<length N}. u \<oplus> d \<turnstile> inv_of (N!p) (L!p);
    d \<ge> 0
   \<rbrakk> \<Longrightarrow> N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L, u \<oplus> d\<rangle>"
by (auto intro: step_n_t)

subsection \<open>Product Automaton\<close>

abbreviation state_set :: "('a, 'c, 'time, 's) transition set \<Rightarrow> 's set" where
  "state_set T \<equiv> fst ` T \<union> (snd o snd o snd o snd) ` T"

lemma guard_concat:
  assumes "\<forall> g \<in> set xs. u \<turnstile> g"
  shows "u \<turnstile> concat xs"
  using assms by (induction xs) (auto simp: clock_val_def)

lemma guard_append:
  assumes "u \<turnstile> g1" "u \<turnstile> g2"
  shows "u \<turnstile> g1 @ g2"
  using assms by (auto simp: clock_val_def)

lemma concat_guard:
  assumes "u \<turnstile> concat xs" "g \<in> set xs"
  shows "u \<turnstile> g"
using assms by (auto simp: list_all_iff clock_val_def)

lemma guard_consE:
  assumes "u \<turnstile> ac # cc"
  obtains "u \<turnstile>\<^sub>a ac" "u \<turnstile> cc"
  using assms unfolding clock_val_def by auto

lemma guard_consI:
  assumes "u \<turnstile>\<^sub>a ac" "u \<turnstile> cc"
  shows "u \<turnstile> ac # cc"
  using assms unfolding clock_val_def by auto

lemma collect_clock_pairs_append_cases:
  assumes "x \<in> collect_clock_pairs (g1 @ g2)"
  shows "x \<in> collect_clock_pairs g1 \<or> x \<in> collect_clock_pairs g2"
    using assms unfolding collect_clock_pairs_def by auto

(* XXX Move? *)
lemma list_update_nth_split:
  assumes "j < length xs"
  shows "P (xs[i := x] ! j) = ((i = j \<longrightarrow> P x) \<and> (i \<noteq> j \<longrightarrow> P (xs ! j)))"
    using assms by (cases "i = j") auto

locale Product_TA_Defs =
  fixes N :: "('a, 'b, 'c, 't, 's) nta"
begin

  abbreviation "T \<equiv> map trans_of N"
  abbreviation "I \<equiv> map inv_of N"

  definition "states = {L. length L = length T \<and> (\<forall> p \<in> {..<length T}. L!p \<in> state_set (T!p))}"

  definition
    "product_trans_i =
      {(L,g,(a,Act b),r,L[p:=l']) | L p g a b r l'.
      L \<in> states \<and> (L!p, g, (Sil a, b), r, l') \<in> T!p \<and> p < length L}"

  definition
    "product_trans_s =
      {(L,g1 @ g2,(a,Syn b1 b2),r1 @ r2,L[p:=l1',q:=l2']) | L p q g1 g2 a b1 b2 r1 r2 l1' l2'.
        L \<in> states \<and> (L!p, g1, (In a, b1), r1, l1') \<in> T!p \<and> (L!q, g2, (Out a, b2), r2, l2') \<in> T!q
        \<and> p < length L \<and> q < length L \<and> p \<noteq> q
      }"

  definition
    "product_trans \<equiv> product_trans_i \<union> product_trans_s"

lemma product_state_set_subs:
  assumes "q < length N" "l \<in> state_set product_trans"
  shows "l ! q \<in> state_set (T ! q)"
  using assms
  unfolding product_trans_def product_trans_i_def product_trans_s_def states_def
  apply safe
     apply (auto; fail)
    apply (auto; fail)
  apply simp
   apply (subst list_update_nth_split; force) (* XXX Slow *)
  apply simp
  apply (subst list_update_nth_split)
   apply simp
  apply safe
   apply (subst (asm) (2) list_update_nth_split; force)
  apply (subst list_update_nth_split)
   apply simp
  by (subst (asm) (2) list_update_nth_split; force)  (* XXX Slow *)

  definition
    "product_invariant L \<equiv>
    concat (map (\<lambda> p. if p < length I then (I!p) (L!p) else []) [0..<length L])"

  definition product_ta :: "('a \<times> 'b label, 'c, 't, 's list) ta" where
    "product_ta \<equiv> (product_trans, product_invariant)"

  lemma collect_clki_product_invariant:
    "Timed_Automata.collect_clki product_invariant = \<Union> (Timed_Automata.collect_clki ` set I)"
    unfolding Timed_Automata.collect_clki_def product_invariant_def
    apply (simp add: image_Union)
    apply safe
    subgoal
      unfolding collect_clock_pairs_def by fastforce
    apply clarsimp
    subgoal premises prems for a b aa ba x
    proof -
      let ?L = "map (\<lambda> _. x) [0..<length N]"
      let ?x = "collect_clock_pairs
        (concat
        (map (\<lambda>p. if p < length N then (I ! p) (?L ! p) else [])
        [0..<length ?L]))"
      show ?thesis
        apply (rule exI[where x = ?x])
        apply rule
         apply (rule exI; rule HOL.refl)
        apply simp
        using prems unfolding collect_clock_pairs_def by (fastforce dest: aux)
    qed
    done

  lemma states_length:
    assumes "L \<in> states"
    shows "length L = length N"
    using assms unfolding states_def by auto

  lemma collect_clkt_product_trans_subs:
    "Timed_Automata.collect_clkt product_trans \<subseteq> \<Union> (Timed_Automata.collect_clkt ` set T)"
    unfolding
      Timed_Automata.collect_clkt_def product_trans_def product_trans_i_def product_trans_s_def
    by (fastforce dest: collect_clock_pairs_append_cases states_length)

  lemma collect_clkvt_product_trans_subs:
    "collect_clkvt product_trans \<subseteq> \<Union> (collect_clkvt ` set T)"
    unfolding collect_clkvt_def product_trans_def product_trans_i_def product_trans_s_def
    by (fastforce dest: states_length)

  (* XXX No conditional split *)
  lemma statesI_aux:
    fixes L
    assumes L: "L \<in> states"
    assumes
      "p < length T"
      "(l, g, a, r, l') \<in> T ! p"
    shows "(L[p := l]) \<in> states"
    unfolding states_def apply clarsimp
    apply rule
    using L apply (simp add: states_def)
    apply rule
    apply (subst list_update_nth_split)
    using assms apply (auto simp: states_def)
    by blast

  lemma product_trans_s_alt_def:
    "product_trans_s =
      {(L, g, (a, Syn b1 b2), r, L') | L g a b1 b2 r L'. \<exists> p q g1 g2 r1 r2 l1' l2'.
      L \<in> states \<and> p < length L \<and> q < length L \<and> p \<noteq> q \<and>
      g = g1 @ g2 \<and> r = r1 @ r2 \<and> L' = L[p:=l1', q:=l2']
        \<and> (L!p, g1, (In a, b1), r1, l1') \<in> T!p \<and> (L!q, g2, (Out a, b2), r2, l2') \<in> T!q
      }"
    unfolding product_trans_s_def by (safe; metis)

  context
    assumes states_not_empty: "states \<noteq> {}"
    assumes trans_complete:
      "\<forall> p < length T. \<forall> t1 \<in> T ! p. case t1 of (l1, g1, (In a, b1), r1, l1')
      \<Rightarrow> \<exists> q < length T. p \<noteq> q \<and> (\<exists> l2 g2 b2 r2 l2'. (l2, g2, (Out a, b2), r2, l2') \<in> T ! q) |
      (l1, g1, (Out a, b1), r1, l1')
      \<Rightarrow> \<exists> q < length T. p \<noteq> q \<and> (\<exists> l2 g2 b2 r2 l2'. (l2, g2, (In a, b2), r2, l2') \<in> T ! q) | _ \<Rightarrow> True"
  begin

  lemma collect_clkt_product_trans_sups:
    "Timed_Automata.collect_clkt product_trans \<supseteq> \<Union> (Timed_Automata.collect_clkt ` set T)"
  proof
    fix x assume "x \<in> \<Union> (Timed_Automata.collect_clkt ` set T)"
    then obtain trans l1 g1 a' b1 r1 l1' where x:
      "trans \<in> set T" "(l1, g1, (a', b1), r1, l1') \<in> trans" "x \<in> collect_clock_pairs g1"
      unfolding Timed_Automata.collect_clkt_def by force
    then obtain p where p:
        "p < length T" "T ! p = trans"
      by (auto dest!: aux)
    from states_not_empty obtain L where L: "L \<in> states" by auto
    have "length T = length L" by (auto simp: states_length[OF \<open>L \<in> states\<close>])
    show "x \<in> Timed_Automata.collect_clkt product_trans"
    proof (cases a')
      case a': (In a)
      with x p trans_complete obtain q l2 g2 b2 r2 l2' where trans2:
        "q < length T" "(l2, g2, (Out a, b2), r2, l2') \<in> T ! q" "p \<noteq> q"
        by atomize_elim fastforce
      have "L[p := l1, q := l2] \<in> states" (is "?L \<in> _")
        using L p(1) x(1,2) trans2 unfolding p(2)[symmetric] by (auto intro!: statesI_aux)
      moreover have "?L ! p = l1" "?L ! q = l2"
        using \<open>p \<noteq> q\<close> \<open>p < length T\<close> \<open>q < length T\<close> \<open>L \<in> states\<close> by (auto dest: states_length)
      moreover note t = calculation
      have "(?L, g1 @ g2, (a, Syn b1 b2), r1 @ r2, ?L[p := l1', q := l2']) \<in> product_trans_s"
        unfolding product_trans_s_alt_def
        apply clarsimp
        using t p(1) x(1,2) trans2 unfolding p(2)[symmetric] a' \<open>length T = length L\<close>
        by metis
      moreover have "x \<in> collect_clock_pairs (g1 @ g2)"
        using x(3) by (auto simp: collect_clock_pairs_def)
      ultimately show ?thesis unfolding Timed_Automata.collect_clkt_def product_trans_def by force
    next
      case a': (Out a)
      with x p trans_complete obtain q l2 g2 b2 r2 l2' where trans2:
        "q < length T" "(l2, g2, (In a, b2), r2, l2') \<in> T ! q" "p \<noteq> q"
        by atomize_elim fastforce
      have "L[q := l2, p := l1] \<in> states" (is "?L \<in> _")
        using L p(1) x(1,2) trans2 unfolding p(2)[symmetric] by (auto intro!: statesI_aux)
      moreover have "?L ! p = l1" "?L ! q = l2"
        using \<open>p \<noteq> q\<close> \<open>p < length T\<close> \<open>q < length T\<close> \<open>L \<in> states\<close> by (auto dest: states_length)
      moreover note t = calculation
      have "(?L, g2 @ g1, (a, Syn b2 b1), r2 @ r1, ?L[q := l2', p := l1']) \<in> product_trans_s"
        unfolding product_trans_s_alt_def
        apply clarsimp
        using t p(1) x(1,2) trans2 unfolding p(2)[symmetric] a' \<open>length T = length L\<close>
        by metis
      moreover have "x \<in> collect_clock_pairs (g2 @ g1)"
        using x(3) by (auto simp: collect_clock_pairs_def)
      ultimately show ?thesis unfolding Timed_Automata.collect_clkt_def product_trans_def by force
    next
      case a': (Sil a)
      have "L[p := l1] \<in> states" (is "?L \<in> _")
        using L p(1) x(1,2) unfolding p(2)[symmetric] by (auto intro!: statesI_aux)
      moreover have "?L ! p = l1"
        using \<open>p < length T\<close> \<open>L \<in> states\<close> by (auto dest: states_length)
      ultimately have "(?L, g1, (a, Act b1), r1, ?L[p := l1']) \<in> product_trans_i"
        using x p unfolding product_trans_i_def a' by (force simp: states_length[OF \<open>L \<in> states\<close>])
      with x(3) show ?thesis unfolding Timed_Automata.collect_clkt_def product_trans_def by force
    qed
  qed

  lemma collect_clkvt_product_trans_sups:
    "collect_clkvt product_trans \<supseteq> \<Union> (collect_clkvt ` set T)"
  proof
    fix x assume "x \<in> \<Union> (collect_clkvt ` set T)"
    then obtain trans l1 g1 a' b1 r1 l1' where x:
      "trans \<in> set T" "(l1, g1, (a', b1), r1, l1') \<in> trans" "x \<in> set r1"
      unfolding collect_clkvt_def by force
    then obtain p where p:
        "p < length T" "T ! p = trans"
      by (auto dest!: aux)
    from states_not_empty obtain L where L: "L \<in> states" by auto
    show "x \<in> collect_clkvt product_trans"
    proof (cases a')
      case a': (In a)
      with x p trans_complete obtain q l2 g2 b2 r2 l2' where trans2:
        "q < length T" "(l2, g2, (Out a, b2), r2, l2') \<in> T ! q" "p \<noteq> q"
        by atomize_elim fastforce
      moreover have "L[p := l1, q := l2] \<in> states" (is "?L \<in> _")
        using L p(1) x(1,2) trans2 unfolding p(2)[symmetric] by (auto intro!: statesI_aux)
      moreover have "?L ! p = l1" "?L ! q = l2"
        using \<open>p \<noteq> q\<close> \<open>p < length T\<close> \<open>q < length T\<close> \<open>L \<in> states\<close> by (auto dest: states_length)
      ultimately have
        "(?L, g1 @ g2, (a, Syn b1 b2), r1 @ r2, ?L[p := l1', q := l2']) \<in> product_trans_s"
        using p(1) x trans2 unfolding p(2)[symmetric] a' product_trans_s_def
        by (fastforce simp: states_length[OF \<open>L \<in> states\<close>])
      with x(3) show ?thesis unfolding collect_clkvt_def product_trans_def by force
    next
      case a': (Out a)
      with x p trans_complete obtain q l2 g2 b2 r2 l2' where trans2:
        "q < length T" "(l2, g2, (In a, b2), r2, l2') \<in> T ! q" "p \<noteq> q"
        by atomize_elim fastforce
      moreover have "L[q := l2, p := l1] \<in> states" (is "?L \<in> _")
        using L p(1) x(1,2) trans2 unfolding p(2)[symmetric] by (auto intro!: statesI_aux)
      moreover have "?L ! p = l1" "?L ! q = l2"
        using \<open>p \<noteq> q\<close> \<open>p < length T\<close> \<open>q < length T\<close> \<open>L \<in> states\<close> by (auto dest: states_length)
      ultimately have "(?L, g2 @ g1, (a, Syn b2 b1), r2 @ r1, ?L[q := l2', p := l1']) \<in> product_trans_s"
        using p(1) x trans2 unfolding p(2)[symmetric] a' product_trans_s_def
        apply (simp add: states_length[OF \<open>L \<in> states\<close>] del: ex_simps)
        apply (tactic \<open>rearrange_ex_tac @{context} 1\<close>)
        apply simp
        apply (rule exI, rule conjI, assumption)
        apply (simp only: ex_simps[symmetric])
        apply (tactic \<open>rearrange_ex_tac @{context} 1\<close>)
        apply simp
        by (fastforce simp: states_length[OF \<open>L \<in> states\<close>])
          (* fastforce can solve this on its own but not very quickly *)
      with x(3) show ?thesis unfolding collect_clkvt_def product_trans_def by force
    next
      case a': (Sil a)
      have "L[p := l1] \<in> states" (is "?L \<in> _")
        using L p(1) x(1,2) unfolding p(2)[symmetric] by (auto intro!: statesI_aux)
      moreover have "?L ! p = l1"
        using \<open>p < length T\<close> \<open>L \<in> states\<close> by (auto dest: states_length)
      ultimately have "(?L, g1, (a, Act b1), r1, ?L[p := l1']) \<in> product_trans_i"
        using x p unfolding product_trans_i_def a' by (force simp: states_length[OF \<open>L \<in> states\<close>])
      with x(3) show ?thesis unfolding collect_clkvt_def product_trans_def by force
    qed
  qed

  lemma collect_clkt_product_trans:
    "Timed_Automata.collect_clkt product_trans = \<Union> (Timed_Automata.collect_clkt ` set T)"
    using collect_clkt_product_trans_sups collect_clkt_product_trans_subs by simp

  lemma collect_clkvt_product_trans:
    "collect_clkvt product_trans = \<Union> (collect_clkvt ` set T)"
  using collect_clkvt_product_trans_sups collect_clkvt_product_trans_subs by simp

  end (* End of context for syntactic 1-to-1 correspondence for transitions *)

  context
    assumes finite_trans: "\<forall> A \<in> set N. finite (trans_of A)"
  begin

  lemma finite_states:
    "finite states"
  proof -
    have "states \<subseteq> {L. set L \<subseteq>
          (\<Union> {fst ` trans_of (N ! p) | p. p < length N} \<union>
            \<Union> {(snd \<circ> snd \<circ> snd \<circ> snd) ` trans_of (N ! p) | p. p < length N})
          \<and> length L = length N}"
      unfolding states_def
      apply clarsimp
      apply (drule aux)
      apply safe
      subgoal for _ _ i
        by (erule ballE[where x = i]) auto
      done
    moreover have "finite \<dots>" using finite_trans by - (rule finite_lists_length_eq; auto)
    ultimately show ?thesis by (rule finite_subset)
  qed

  lemma finite_product_trans_i:
    "finite product_trans_i"
  proof -
    let ?N = "\<Union> (trans_of ` set N)"
    let ?S = "{(L, p, g, (a, Act b), r, l')|L p g a b r l'.
      L \<in> states \<and> (L ! p, g, (Sil a, b), r, l') \<in> map trans_of N ! p \<and> p < length L}"
    let ?R = "{(L, p, g, (a, Act b), r, l')|L p g a b r l'.
      L \<in> states \<and> p < length L \<and> (g, (Sil a, b), r, l') \<in> snd ` ?N}"
    have "?S \<subseteq> ?R" by (fastforce simp: states_length dest: nth_mem)
    moreover have "finite ?R" using finite_states [[simproc add: finite_Collect]]
      apply simp
      apply rule
      apply rule
       apply (rule finite_subset[where B = "{(p, L). p < length L \<and> L \<in> states}"])
        apply force
      using states_length
        (* XXX Perfect situation for a finiteness cong *)
       apply -
       apply (rule finite_subset[where B = "{(p, L). p < length N \<and> L \<in> states}"]; fastforce)
      using finite_trans
      apply -
      apply auto[]
      apply (rule finite_vimageI)
       apply (auto; fail)
      unfolding inj_on_def
      by (auto; fail)
    ultimately have "finite ?S" by (rule finite_subset)
    moreover have "product_trans_i = (\<lambda> (L, p, g, a, r, l'). (L, g, a, r, L[p := l'])) ` ?S"
      unfolding product_trans_i_def apply (rule; rule)
       apply simp
       apply safe[]
       apply (fastforce simp: image_Collect)
      by force
    ultimately show ?thesis by auto
  qed

lemma
  assumes A: "finite A"
  shows "finite {(a,b,c) | a b c. a \<in> A \<and> b < (n :: nat) \<and> P c}"
  using assms [[simproc add: finite_Collect]] apply simp
  oops

lemma
  assumes A: "finite A"
  shows "finite {(d, c, a, b) | a b c d. d < n \<and> P c \<and> (a, b) \<in> A}"
  using assms
  using [[simproc add: finite_Collect]] apply simp
  oops

  thm Finite_Set.finite_Collect_bounded_ex

lemma
  assumes A: "finite A"
  shows "finite {t. \<exists> a c. a \<in> A \<and> P c \<and> t = (a,c)}"
  using [[simp_trace]] apply simp
  oops

  (*
  lemma finite_product_trans_s:
    "finite product_trans_s"
  proof -
    let ?N = "\<Union> (trans_of ` set N)"
    (* XXX Possible intro weakening for finiteness method *)
    have "(g1, In a, r1, l1') \<in> snd ` ?N" if
      "(L ! p, g1, In a, r1, l1') \<in> map trans_of N ! p" "p < length L" "L \<in> states"
      for L p g1 a r1 l1'
      using that by (auto simp: states_length dest: nth_mem)
    let ?S = "{(L, p, q, g1, g2, a, r1, r2, l1', l2')|L p q g1 g2 a r1 r2 l1' l2'.
      L \<in> states \<and> (L ! p, g1, In a, r1, l1') \<in> map trans_of N ! p \<and>
        (L ! q, g2, Out a, r2, l2') \<in> map trans_of N ! q \<and> p < length L \<and> q < length L}"
    have S_alt_def: "?S = {t. \<exists> L p q g1 g2 a r1 r2 l1' l2'.
      L \<in> states \<and> (L ! p, g1, In a, r1, l1') \<in> map trans_of N ! p \<and>
        (L ! q, g2, Out a, r2, l2') \<in> map trans_of N ! q \<and> p < length L \<and> q < length L
        \<and> t = (L, p, q, g1, g2, a, r1, r2, l1', l2')}" by auto
    have "finite ?S"
      unfolding S_alt_def using finite_states
      supply [[simproc add: ex_reorder]]
      apply simp
      apply clarsimp
      apply (simp only: ex_simps[symmetric])
      oops
      supply [[simproc del: ex_reorder]]
      apply simp

    define F1 where "F1 \<equiv> {(g1, a, r1, l1') | g1 a r1 l1'. (g1, In a, r1, l1') \<in> snd ` ?N}"
    have fin1: "finite F1" unfolding F1_def using finite_trans
      using [[simproc add: finite_Collect]] by (auto simp: inj_on_def intro: finite_vimageI)
    define F2 where "F2 \<equiv> {(g1, a, r1, l1') | g1 a r1 l1'. (g1, Out a, r1, l1') \<in> snd ` ?N}"
    have fin2: "finite F2" unfolding F2_def using finite_trans
      using [[simproc add: finite_Collect]] by (auto simp: inj_on_def intro: finite_vimageI)
    define R where "R \<equiv> {(L, p, q, g1, g2, a, r1, r2, l1', l2')|L p q g1 g2 a r1 r2 l1' l2'.
      L \<in> states \<and> p < length L \<and> q < length L \<and> (g1, a, r1, l1') \<in> F1 \<and> (g2, a, r2, l2') \<in> F2}"

    have R_alt_def: "R = {t. \<exists> L p q g1 a r1 l1' g2 r2 l2'.
      L \<in> states \<and> p < length L \<and> q < length L
      \<and> (g1, a, r1, l1') \<in> F1 \<and> (g2, a, r2, l2') \<in> F2
      \<and> t = (L, p, q, g1, g2, a, r1, r2, l1', l2')
      }"
      unfolding R_def by auto
    have "?S \<subseteq> R" by (fastforce simp: R_alt_def F1_def F2_def states_length dest: nth_mem)
    moreover have "finite R"
      unfolding R_alt_def
      using fin1 fin2 finite_states
      using [[simproc add: finite_Collect]]
      by (auto simp: inj_on_def intro: finite_vimageI intro!: finite_imageI)
    ultimately have "finite ?S" by (rule finite_subset)
    moreover have
      "product_trans_s
      \<subseteq> (\<lambda> (L, p, q, g1, g2, a, r1, r2, l1', l2'). (L, g1 @ g2, a, r1 @ r2, L[p := l1', q := l2'])) ` ?S"
      unfolding product_trans_s_def apply (rule)
       apply simp
       apply safe[]
      subgoal for a aa ab ac b L p q g1 g2 ad r1 r2 l1' l2'
        apply (rule image_eqI[where x = "(L, p, q, g1, g2, ad, r1, r2, l1', l2')"])
        by auto
      done
    ultimately show ?thesis by (auto intro: finite_subset)
  qed
*)

  lemma finite_Collect_bounded_ex_5' [simp]:
  assumes "finite {(a,b,c,d,e) . P a b c d e}"
  shows
    "finite {x. \<exists>a b c d e. P a b c d e \<and> Q x a b c d e}
    \<longleftrightarrow> (\<forall> a b c d e. P a b c d e \<longrightarrow> finite {x. Q x a b c d e})"
  using assms finite_Collect_bounded_ex[OF assms, where Q = "\<lambda> x. \<lambda> (a, b, c, d, e). Q x a b c d e"]
  by clarsimp (* force, simp *)

  lemma finite_product_trans_s:
    "finite product_trans_s"
  proof -
    let ?N = "\<Union> (trans_of ` set N)"
    (* XXX Possible intro weakening for finiteness method *)
    have "(g1, (In a, b), r1, l1') \<in> snd ` ?N" if
      "(L ! p, g1, (In a, b), r1, l1') \<in> map trans_of N ! p" "p < length L" "L \<in> states"
      for L p g1 a b r1 l1'
      using that by (auto simp: states_length dest: nth_mem)
    let ?S = "{(L, p, q, g1, g2, (a, Syn b1 b2), r1, r2, l1', l2')|L p q g1 g2 a b1 b2 r1 r2 l1' l2'.
      L \<in> states \<and> (L ! p, g1, (In a, b1), r1, l1') \<in> map trans_of N ! p \<and>
        (L ! q, g2, (Out a, b2), r2, l2') \<in> map trans_of N ! q \<and> p < length L \<and> q < length L}"
    define F1 where "F1 \<equiv> {(g1, a, b, r1, l1') | g1 a b r1 l1'. (g1, (In a, b), r1, l1') \<in> snd ` ?N}"
    have fin1: "finite F1" unfolding F1_def using finite_trans
      using [[simproc add: finite_Collect]] by (force simp: inj_on_def intro: finite_vimageI)
    define F2 where "F2 \<equiv> {(g1, a, b, r1, l1') | g1 a b r1 l1'. (g1, (Out a, b), r1, l1') \<in> snd ` ?N}"
    have fin2: "finite F2" unfolding F2_def using finite_trans
      using [[simproc add: finite_Collect]] by (force simp: inj_on_def intro: finite_vimageI)
    define R where "R \<equiv> {(L, p, q, g1, g2, (a, Syn b1 b2), r1, r2, l1', l2')|L p q g1 g2 a b1 b2 r1 r2 l1' l2'.
      L \<in> states \<and> p < length L \<and> q < length L \<and> (g1, a, b1, r1, l1') \<in> F1 \<and> (g2, a, b2, r2, l2') \<in> F2}"

    (* XXX Term for demonstrating miniscoping imperfections *)
    term "finite
        {t. \<exists>g1 a b1 b2 r1 l1'.
               (g1, a, b1, r1, l1') \<in> F1 \<and>
               (\<exists>g2 r2 l2'.
                   (g2, a, b2, r2, l2') \<in> F2 \<and>
                   t = (L, p, q, g1, g2, (a, Syn b1 b2), r1, r2, l1', l2'))}"

    have R_alt_def: "R = {t. \<exists> L p q g1 a b1 r1 l1' g2 b2 r2 l2'.
      L \<in> states \<and> p < length L \<and> q < length L
      \<and> (g1, a, b1, r1, l1') \<in> F1 \<and> (g2, a, b2, r2, l2') \<in> F2
      \<and> t = (L, p, q, g1, g2, (a, Syn b1 b2), r1, r2, l1', l2')
      }"
      unfolding R_def by auto
    have "?S \<subseteq> R" by (fastforce simp: R_alt_def F1_def F2_def states_length dest: nth_mem)
    moreover have "finite R"
      unfolding R_alt_def
      using fin1 fin2 finite_states
      apply simp (* XXX For illustration purposes *)
      using [[simproc add: finite_Collect]]
      by (auto simp: inj_on_def intro: finite_vimageI intro!: finite_imageI)
    ultimately have "finite ?S" by (rule finite_subset)
    moreover have
      "product_trans_s
      \<subseteq> (\<lambda> (L, p, q, g1, g2, a, r1, r2, l1', l2'). (L, g1 @ g2, a, r1 @ r2, L[p := l1', q := l2'])) ` ?S"
      unfolding product_trans_s_def by (simp add: image_Collect) blast
    ultimately show ?thesis by (auto intro: finite_subset)
  qed

  lemma finite_trans_of_product:
    shows "finite (trans_of product_ta)"
    using finite_product_trans_s finite_product_trans_i
    unfolding product_ta_def trans_of_def product_trans_def
    by auto

  end (* End of context for finiteness of trans *)

  lemma inv_of_product[simp]:
      "inv_of product_ta = product_invariant"
    unfolding product_ta_def inv_of_def by simp

  (* XXX Move? *)
  lemma concat_map_if_aux:
    assumes "(m :: nat) \<ge> n"
    shows "concat (map (\<lambda> i. if i < n then f i else []) [0..<m])
         = concat (map (\<lambda> i. if i < n then f i else []) [0..<n])"
    using assms by (induction rule: dec_induct) auto

  lemma finite_invariant_of_product[folded inv_of_product]:
    assumes "\<forall> A \<in> set N. finite (range (inv_of A))"
    shows "finite (range product_invariant)"
  proof -
    let ?N = "\<Union> (range ` inv_of ` set N)"
    let ?X = "{I. set I \<subseteq> ?N \<and> length I \<le> length N}"
    have "[] \<in> ?X" by auto
    have "finite ?N"
      using assms
      by auto
    then have "finite ?X" by (rule finite_lists_length_le)
    moreover have "range product_invariant \<subseteq> concat ` ?X"
    proof
      fix x assume "x \<in> range product_invariant"
      then obtain L where L:
            "x = concat
                       (map (\<lambda>p. if p < length (map inv_of N)
                                  then (map inv_of N ! p) (L ! p) else [])
                         [0..<length L])"
        unfolding product_invariant_def by auto
      show "x \<in> concat ` ?X"
      proof (cases "length L \<le> length N")
        case True
        then show ?thesis using L by (fastforce dest: nth_mem)
      next
        case False
        then have "x = concat
                       (map (\<lambda>p. if p < length (map inv_of N)
                                  then (map inv_of N ! p) (L ! p) else [])
                         [0..<length N])"
          using L by (auto intro: concat_map_if_aux)
        then show ?thesis by (fastforce dest: nth_mem)
      qed
    qed
    ultimately show ?thesis by - (drule finite_subset; auto)
  qed

end (* End locale for product TA definition *)

locale Product_TA_Defs' =
  Product_TA_Defs N for N :: "('a, 'b, 'c, 't :: time, 's) nta"
begin

  lemma product_invariantD:
    assumes "u \<turnstile> product_invariant L" "p < length N" "length L = length N"
    shows "u \<turnstile> inv_of (N ! p) (L!p)"
  using assms unfolding product_invariant_def by (force intro: concat_guard)

  lemma states_step:
    "L' \<in> states" if "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', u'\<rangle>" "L \<in> states"
    using that unfolding states_def apply safe
        apply simp
       apply simp
      apply force
     apply (subst list_update_nth_split)
      apply simp
     apply rule
      apply clarsimp
    subgoal premises prems for p g a r l'
      using prems(3-6) by force
     apply clarsimp
     apply (auto; fail)
    apply (subst list_update_nth_split)
     apply (simp; fail)
    apply safe
     apply simp
    subgoal premises prems
      using prems(3-7) by force
    apply (subst list_update_nth_split)
     apply simp
    apply safe
     apply simp
    subgoal premises prems
      using prems(3-6) by force
    by auto

  lemma states_steps:
    "L' \<in> states" if "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>* \<langle>L', u'\<rangle>" "L \<in> states"
    using that apply (induction N \<equiv> N _ _ _ _ rule: steps_n.induct)
     apply assumption
    apply simp
    by (rule states_step; assumption)

end

lemma steps_altI:
  "A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>* \<langle>l'', Z''\<rangle>" if
  "A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>* \<langle>l', Z'\<rangle>" "A \<turnstile> \<langle>l', Z'\<rangle> \<rightarrow> \<langle>l'', Z''\<rangle>"
  using that by (induction; blast)

(* Network + valid start state *)
locale Product_TA =
  Product_TA_Defs' N for N :: "('a, 'b, 'c, 't :: time, 's) nta" +
  fixes L :: "'s list"
  assumes states[intro]: "L \<in> states"
begin

  lemma
    len[simp]: "length L = length N"
  using states unfolding states_def by auto

  lemma product_delay_complete:
    assumes step: "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L', u'\<rangle>"
    obtains d where "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>L', u'\<rangle>"
  using step proof cases
    case prems: (step_n_t d)
    from prems have *:
      "\<forall>p\<in>{..<length N}. u \<oplus> d \<turnstile> inv_of (N ! p) (L ! p)"
    by (auto elim!: step_t.cases)
    from prems * show ?thesis
    by (fastforce simp add: product_ta_def inv_of_def product_invariant_def[abs_def]
                  intro!: guard_concat that
       )
  qed

  lemma product_int_complete:
    assumes step: "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Act b\<^esub> \<langle>L', u'\<rangle>"
    obtains a where "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>\<^bsub>(a, Act b)\<^esub> \<langle>L', u'\<rangle>"
    using step proof cases
    case prems: (step_n_i p l g a r l')
    from prems show ?thesis
      apply -
      apply (rule that)
      apply (rule step_a.intros[where g = g and r = r])
      by (fastforce
          simp: product_trans_def product_trans_i_def product_invariant_def product_ta_def
          trans_of_def inv_of_def
          intro: guard_concat
          )+
  qed

  lemma product_sync_complete:
    assumes step: "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Syn b1 b2\<^esub> \<langle>L', u'\<rangle>"
    obtains a where "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>\<^bsub>(a, Syn b1 b2)\<^esub> \<langle>L', u'\<rangle>"
    using step proof cases
    case prems: (step_n_s p l1 g1 a r1 l1' q l2 g2 r2 l2')
    from prems show ?thesis
      apply -
      apply (rule that)
      apply (rule step_a.intros[where g = "g1 @ g2" and a = "(a, Syn b1 b2)" and r = "r1 @ r2"])
      subgoal premises prems
        apply
          (auto simp add:
            product_trans_def product_trans_s_def product_invariant_def product_ta_def
            trans_of_def inv_of_def
            )
        apply (erule allE[where x = p])
        using \<open>p < _\<close> apply simp
        apply (erule allE[where x = q])
        using prems by (fastforce simp: trans_of_def)
      by (fastforce
            simp: product_invariant_def product_ta_def inv_of_def
            intro: guard_concat guard_append
         )+
  qed

  lemma product_complete:
    assumes step: "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>b\<^esub> \<langle>L', u'\<rangle>"
    shows "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow> \<langle>L', u'\<rangle>"
    using step
    by (cases b) (rule product_delay_complete product_int_complete product_sync_complete, simp, blast)+

  lemma product_ta_cases:
    assumes "product_ta \<turnstile> L \<longrightarrow>\<^bsup>g,a,r\<^esup> L'"
    shows "(L, g, a, r, L') \<in> product_trans_i \<or> (L, g, a, r, L') \<in> product_trans_s"
  using assms unfolding product_ta_def trans_of_def product_trans_def by auto

  lemma product_delay_sound:
    assumes step: "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>L', u'\<rangle>"
    shows "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L', u'\<rangle>"
  using assms by cases (force intro!: step_n_t product_invariantD len)

  lemma product_action_sound:
    assumes step: "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>\<^bsub>(a, b)\<^esub> \<langle>L', u'\<rangle>"
    shows "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>b\<^esub> \<langle>L', u'\<rangle>"
    using assms
    apply cases
    apply simp
    apply (drule product_ta_cases)
    apply (erule disjE)
    unfolding product_trans_i_def product_trans_s_def
     apply (clarsimp; auto intro!: product_invariantD step_n_i; fail)
    by (auto intro!: product_invariantD step_n_s simp: clock_val_def)

  lemma product_sound:
    assumes step: "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow> \<langle>L', u'\<rangle>"
    obtains a where "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', u'\<rangle>"
    using step by cases (force dest!: product_action_sound product_delay_sound)+

  lemma states_product_step[intro]:
    "L' \<in> states" if "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow> \<langle>L', u'\<rangle>"
    by (auto intro: product_sound that elim!: states_step)

  lemma product_steps_sound:
    "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>* \<langle>L', u'\<rangle>" if "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>* \<langle>L', u'\<rangle>"
    using that states proof (induction A \<equiv> product_ta _ _ _ _ rule: steps.induct)
    case (refl l u)
    then show ?case by blast
  next
    case prems: (step l u l' u' l'' u'')
    interpret interp: Product_TA N l by standard (rule prems)
    from prems have *: "N \<turnstile>\<^sub>N \<langle>l', u'\<rangle> \<rightarrow>* \<langle>l'',u''\<rangle>" by auto
    from prems show ?case by - (erule interp.product_sound, rule stepI2, rule *)
  qed

  lemma product_steps_complete:
    "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>* \<langle>L', u'\<rangle>" if "N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>* \<langle>L', u'\<rangle>"
    using that states proof (induction N \<equiv> N _ _ _ _ rule: steps_n.induct)
    case (refl l Z)
    then show ?case by blast
  next
    case prems: (step l Z l' Z' _ l'' Z'')
    interpret interp: Product_TA N l' by standard (blast intro: prems states_steps)
    from prems show ?case by - (assumption | rule steps_altI interp.product_complete)+
  qed

  lemma product_correct:
    "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>* \<langle>L', u'\<rangle> \<longleftrightarrow> N \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>* \<langle>L', u'\<rangle>"
    by (metis product_steps_complete product_steps_sound)

  end (* End context: network + valid start state *)

end (* End of theory *)


(*  Title:      ZF/AC/WO2_AC16.thy
    Author:     Krzysztof Grabczewski

The proof of WO2 ==> AC16(k #+ m, k)

The main part of the proof is the inductive reasoning concerning
properties of constructed family T_gamma.
The proof deals with three cases for ordinals: 0, succ and limit ordinal.
The first instance is trivial, the third not difficult, but the second
is very complicated requiring many lemmas.
We also need to prove that at any stage gamma the set
(s - \<Union>(...) - k_gamma)   (Rubin & Rubin page 15)
contains m distinct elements (in fact is equipollent to s)
*)

theory WO2_AC16 imports AC_Equiv AC16_lemmas Cardinal_aux begin

(**** A recursive definition used in the proof of WO2 ==> AC16 ****)

definition
  recfunAC16 :: "[i,i,i,i] => i"  where
    "recfunAC16(f,h,i,a) ==
         transrec2(i, 0,
              %g r. if (\<exists>y \<in> r. h`g \<subseteq> y) then r
                    else r \<union> {f`(\<mu> i. h`g \<subseteq> f`i &
                         (\<forall>b<a. (h`b \<subseteq> f`i \<longrightarrow> (\<forall>t \<in> r. ~ h`b \<subseteq> t))))})"

(* ********************************************************************** *)
(* Basic properties of recfunAC16                                         *)
(* ********************************************************************** *)

lemma recfunAC16_0: "recfunAC16(f,h,0,a) = 0"
by (simp add: recfunAC16_def)

lemma recfunAC16_succ:
     "recfunAC16(f,h,succ(i),a) =
      (if (\<exists>y \<in> recfunAC16(f,h,i,a). h ` i \<subseteq> y) then recfunAC16(f,h,i,a)
       else recfunAC16(f,h,i,a) \<union>
            {f ` (\<mu> j. h ` i \<subseteq> f ` j &
             (\<forall>b<a. (h`b \<subseteq> f`j
              \<longrightarrow> (\<forall>t \<in> recfunAC16(f,h,i,a). ~ h`b \<subseteq> t))))})"
apply (simp add: recfunAC16_def)
done

lemma recfunAC16_Limit: "Limit(i)
        ==> recfunAC16(f,h,i,a) = (\<Union>j<i. recfunAC16(f,h,j,a))"
by (simp add: recfunAC16_def transrec2_Limit)

(* ********************************************************************** *)
(* Monotonicity of transrec2                                              *)
(* ********************************************************************** *)

lemma transrec2_mono_lemma [rule_format]:
     "[| !!g r. r \<subseteq> B(g,r);  Ord(i) |]
      ==> j<i \<longrightarrow> transrec2(j, 0, B) \<subseteq> transrec2(i, 0, B)"
apply (erule trans_induct)
apply (rule Ord_cases, assumption+, fast)
apply (simp (no_asm_simp))
apply (blast elim!: leE)
apply (simp add: transrec2_Limit)
apply (blast intro: OUN_I ltI Ord_in_Ord [THEN le_refl]
             elim!: Limit_has_succ [THEN ltE])
done

lemma transrec2_mono:
     "[| !!g r. r \<subseteq> B(g,r); j\<le>i |]
      ==> transrec2(j, 0, B) \<subseteq> transrec2(i, 0, B)"
apply (erule leE)
apply (rule transrec2_mono_lemma)
apply (auto intro: lt_Ord2 )
done

(* ********************************************************************** *)
(* Monotonicity of recfunAC16                                             *)
(* ********************************************************************** *)

lemma recfunAC16_mono:
       "i\<le>j ==> recfunAC16(f, g, i, a) \<subseteq> recfunAC16(f, g, j, a)"
apply (unfold recfunAC16_def)
apply (rule transrec2_mono, auto)
done

(* ********************************************************************** *)
(* case of limit ordinal                                                  *)
(* ********************************************************************** *)

lemma lemma3_1:
    "[| \<forall>y<x. \<forall>z<a. z<y | (\<exists>Y \<in> F(y). f(z)<=Y) \<longrightarrow> (\<exists>! Y. Y \<in> F(y) & f(z)<=Y);
        \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j); j\<le>i; i<x; z<a;
        V \<in> F(i); f(z)<=V; W \<in> F(j); f(z)<=W |]
     ==> V = W"
apply (erule asm_rl allE impE)+
apply (drule subsetD, assumption, blast)
done

lemma lemma3:
    "[| \<forall>y<x. \<forall>z<a. z<y | (\<exists>Y \<in> F(y). f(z)<=Y) \<longrightarrow> (\<exists>! Y. Y \<in> F(y) & f(z)<=Y);
        \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j); i<x; j<x; z<a;
        V \<in> F(i); f(z)<=V; W \<in> F(j); f(z)<=W |]
     ==> V = W"
apply (rule_tac j=j in Ord_linear_le [OF lt_Ord lt_Ord], assumption+)
apply (erule lemma3_1 [symmetric], assumption+)
apply (erule lemma3_1, assumption+)
done

lemma lemma4:
     "[| \<forall>y<x. F(y) \<subseteq> X &
                (\<forall>x<a. x < y | (\<exists>Y \<in> F(y). h(x) \<subseteq> Y) \<longrightarrow>
                 (\<exists>! Y. Y \<in> F(y) & h(x) \<subseteq> Y));
         x < a |]
      ==> \<forall>y<x. \<forall>z<a. z < y | (\<exists>Y \<in> F(y). h(z) \<subseteq> Y) \<longrightarrow>
                       (\<exists>! Y. Y \<in> F(y) & h(z) \<subseteq> Y)"
apply (intro oallI impI)
apply (drule ospec, assumption, clarify)
apply (blast elim!: oallE )
done

lemma lemma5:
     "[| \<forall>y<x. F(y) \<subseteq> X &
               (\<forall>x<a. x < y | (\<exists>Y \<in> F(y). h(x) \<subseteq> Y) \<longrightarrow>
                (\<exists>! Y. Y \<in> F(y) & h(x) \<subseteq> Y));
         x < a; Limit(x); \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j) |]
      ==> (\<Union>x<x. F(x)) \<subseteq> X &
          (\<forall>xa<a. xa < x | (\<exists>x \<in> \<Union>x<x. F(x). h(xa) \<subseteq> x)
                \<longrightarrow> (\<exists>! Y. Y \<in> (\<Union>x<x. F(x)) & h(xa) \<subseteq> Y))"
apply (rule conjI)
apply (rule subsetI)
apply (erule OUN_E)
apply (drule ospec, assumption, fast)
apply (drule lemma4, assumption)
apply (rule oallI)
apply (rule impI)
apply (erule disjE)
apply (frule ospec, erule Limit_has_succ, assumption)
apply (drule_tac A = a and x = xa in ospec, assumption)
apply (erule impE, rule le_refl [THEN disjI1], erule lt_Ord)
apply (blast intro: lemma3 Limit_has_succ)
apply (blast intro: lemma3)
done

(* ********************************************************************** *)
(* case of successor ordinal                                              *)
(* ********************************************************************** *)

(*
  First quite complicated proof of the fact used in the recursive construction
  of the family T_gamma (WO2 ==> AC16(k #+ m, k)) - the fact that at any stage
  gamma the set (s - \<Union>(...) - k_gamma) is equipollent to s
  (Rubin & Rubin page 15).
*)

(* ********************************************************************** *)
(* dbl_Diff_eqpoll_Card                                                   *)
(* ********************************************************************** *)

lemma dbl_Diff_eqpoll_Card:
      "[| A\<approx>a; Card(a); ~Finite(a); B\<prec>a; C\<prec>a |] ==> A - B - C\<approx>a"
by (blast intro: Diff_lesspoll_eqpoll_Card)

(* ********************************************************************** *)
(* Case of finite ordinals                                                *)
(* ********************************************************************** *)

lemma Finite_lesspoll_infinite_Ord:
      "[| Finite(X); ~Finite(a); Ord(a) |] ==> X\<prec>a"
apply (unfold lesspoll_def)
apply (rule conjI)
apply (drule nat_le_infinite_Ord [THEN le_imp_lepoll], assumption)
apply (unfold Finite_def)
apply (blast intro: leI [THEN le_imp_subset, THEN subset_imp_lepoll]
                    ltI eqpoll_imp_lepoll lepoll_trans)
apply (blast intro: eqpoll_sym [THEN eqpoll_trans])
done

lemma Union_lesspoll:
     "[| \<forall>x \<in> X. x \<lesssim> n & x \<subseteq> T; well_ord(T, R); X \<lesssim> b;
         b<a; ~Finite(a); Card(a); n \<in> nat |]
      ==> \<Union>(X)\<prec>a"
apply (case_tac "Finite (X)")
apply (blast intro: Card_is_Ord Finite_lesspoll_infinite_Ord
                    lepoll_nat_imp_Finite Finite_Union)
apply (drule lepoll_imp_ex_le_eqpoll)
apply (erule lt_Ord)
apply (elim exE conjE)
apply (frule eqpoll_imp_lepoll [THEN lepoll_infinite], assumption)
apply (erule eqpoll_sym [THEN eqpoll_def [THEN def_imp_iff, THEN iffD1],
                         THEN exE])
apply (frule bij_is_surj [THEN surj_image_eq])
apply (drule image_fun [OF bij_is_fun subset_refl])
apply (drule sym [THEN trans], assumption)
apply (blast intro: lt_Ord UN_lepoll lt_Card_imp_lesspoll
                    lt_trans1 lesspoll_trans1)
done

(* ********************************************************************** *)
(* recfunAC16_lepoll_index                                                *)
(* ********************************************************************** *)

lemma Un_sing_eq_cons: "A \<union> {a} = cons(a, A)"
by fast

lemma Un_lepoll_succ: "A \<lesssim> B ==> A \<union> {a} \<lesssim> succ(B)"
apply (simp add: Un_sing_eq_cons succ_def)
apply (blast elim!: mem_irrefl intro: cons_lepoll_cong)
done

lemma Diff_UN_succ_empty: "Ord(a) ==> F(a) - (\<Union>b<succ(a). F(b)) = 0"
by (fast intro!: le_refl)

lemma Diff_UN_succ_subset: "Ord(a) ==> F(a) \<union> X - (\<Union>b<succ(a). F(b)) \<subseteq> X"
by blast

lemma recfunAC16_Diff_lepoll_1:
     "Ord(x)
      ==> recfunAC16(f, g, x, a) - (\<Union>i<x. recfunAC16(f, g, i, a)) \<lesssim> 1"
apply (erule Ord_cases)
  apply (simp add: recfunAC16_0 empty_subsetI [THEN subset_imp_lepoll])
(*Limit case*)
prefer 2 apply (simp add: recfunAC16_Limit Diff_cancel
                          empty_subsetI [THEN subset_imp_lepoll])
(*succ case*)
apply (simp add: recfunAC16_succ
                 Diff_UN_succ_empty [of _ "%j. recfunAC16(f,g,j,a)"]
                 empty_subsetI [THEN subset_imp_lepoll])
apply (best intro: Diff_UN_succ_subset [THEN subset_imp_lepoll]
                   singleton_eqpoll_1 [THEN eqpoll_imp_lepoll] lepoll_trans)
done

lemma in_Least_Diff:
     "[| z \<in> F(x); Ord(x) |]
      ==> z \<in> F(\<mu> i. z \<in> F(i)) - (\<Union>j<(\<mu> i. z \<in> F(i)). F(j))"
by (fast elim: less_LeastE elim!: LeastI)

lemma Least_eq_imp_ex:
     "[| (\<mu> i. w \<in> F(i)) = (\<mu> i. z \<in> F(i));
         w \<in> (\<Union>i<a. F(i)); z \<in> (\<Union>i<a. F(i)) |]
      ==> \<exists>b<a. w \<in> (F(b) - (\<Union>c<b. F(c))) & z \<in> (F(b) - (\<Union>c<b. F(c)))"
apply (elim OUN_E)
apply (drule in_Least_Diff, erule lt_Ord)
apply (frule in_Least_Diff, erule lt_Ord)
apply (rule oexI, force)
apply (blast intro: lt_Ord Least_le [THEN lt_trans1])
done

lemma two_in_lepoll_1: "[| A \<lesssim> 1; a \<in> A; b \<in> A |] ==> a=b"
by (fast dest!: lepoll_1_is_sing)

lemma UN_lepoll_index:
     "[| \<forall>i<a. F(i)-(\<Union>j<i. F(j)) \<lesssim> 1; Limit(a) |]
      ==> (\<Union>x<a. F(x)) \<lesssim> a"
apply (rule lepoll_def [THEN def_imp_iff [THEN iffD2]])
apply (rule_tac x = "\<lambda>z \<in> (\<Union>x<a. F (x)). \<mu> i. z \<in> F (i) " in exI)
apply (unfold inj_def)
apply (rule CollectI)
apply (rule lam_type)
apply (erule OUN_E)
apply (erule Least_in_Ord)
apply (erule ltD)
apply (erule lt_Ord2)
apply (intro ballI)
apply (simp (no_asm_simp))
apply (rule impI)
apply (drule Least_eq_imp_ex, assumption+)
apply (fast elim!: two_in_lepoll_1)
done

lemma recfunAC16_lepoll_index: "Ord(y) ==> recfunAC16(f, h, y, a) \<lesssim> y"
apply (erule trans_induct3)
(*0 case*)
apply (simp (no_asm_simp) add: recfunAC16_0 lepoll_refl)
(*succ case*)
apply (simp (no_asm_simp) add: recfunAC16_succ)
apply (blast dest!: succI1 [THEN rev_bspec]
             intro: subset_succI [THEN subset_imp_lepoll] Un_lepoll_succ
                    lepoll_trans)
apply (simp (no_asm_simp) add: recfunAC16_Limit)
apply (blast intro: lt_Ord [THEN recfunAC16_Diff_lepoll_1] UN_lepoll_index)
done

lemma Union_recfunAC16_lesspoll:
     "[| recfunAC16(f,g,y,a) \<subseteq> {X \<in> Pow(A). X\<approx>n};
         A\<approx>a;  y<a;  ~Finite(a);  Card(a);  n \<in> nat |]
      ==> \<Union>(recfunAC16(f,g,y,a))\<prec>a"
apply (erule eqpoll_def [THEN def_imp_iff, THEN iffD1, THEN exE])
apply (rule_tac T=A in Union_lesspoll, simp_all)
apply (blast intro!: eqpoll_imp_lepoll)
apply (blast intro: bij_is_inj Card_is_Ord [THEN well_ord_Memrel]
                    well_ord_rvimage)
apply (erule lt_Ord [THEN recfunAC16_lepoll_index])
done

lemma dbl_Diff_eqpoll:
     "[| recfunAC16(f, h, y, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)};
         Card(a); ~ Finite(a); A\<approx>a;
         k \<in> nat;  y<a;
         h \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k)}) |]
      ==> A - \<Union>(recfunAC16(f, h, y, a)) - h`y\<approx>a"
apply (rule dbl_Diff_eqpoll_Card, simp_all)
apply (simp add: Union_recfunAC16_lesspoll)
apply (rule Finite_lesspoll_infinite_Ord)
apply (rule Finite_def [THEN def_imp_iff, THEN iffD2])
apply (blast dest: ltD bij_is_fun [THEN apply_type], assumption)
apply (blast intro: Card_is_Ord)
done

(* back to the proof *)

lemmas disj_Un_eqpoll_nat_sum =
    eqpoll_trans [THEN eqpoll_trans,
                  OF disj_Un_eqpoll_sum sum_eqpoll_cong nat_sum_eqpoll_sum]

lemma Un_in_Collect: "[| x \<in> Pow(A - B - h`i); x\<approx>m;
        h \<in> bij(a, {x \<in> Pow(A) . x\<approx>k}); i<a; k \<in> nat; m \<in> nat |]
        ==> h ` i \<union> x \<in> {x \<in> Pow(A) . x\<approx>k #+ m}"
by (blast intro: disj_Un_eqpoll_nat_sum
          dest:  ltD bij_is_fun [THEN apply_type])

(* ********************************************************************** *)
(* Lemmas simplifying assumptions                                         *)
(* ********************************************************************** *)

lemma lemma6:
     "[| \<forall>y<succ(j). F(y)<=X & (\<forall>x<a. x<y | P(x,y) \<longrightarrow> Q(x,y)); succ(j)<a |]
      ==> F(j)<=X & (\<forall>x<a. x<j | P(x,j) \<longrightarrow> Q(x,j))"
by (blast intro!: lt_Ord succI1 [THEN ltI, THEN lt_Ord, THEN le_refl])

lemma lemma7:
     "[| \<forall>x<a. x<j | P(x,j) \<longrightarrow> Q(x,j);  succ(j)<a |]
      ==> P(j,j) \<longrightarrow> (\<forall>x<a. x\<le>j | P(x,j) \<longrightarrow> Q(x,j))"
by (fast elim!: leE)

(* ********************************************************************** *)
(* Lemmas needed to prove ex_next_set, which means that for any successor *)
(* ordinal there is a set satisfying certain properties                   *)
(* ********************************************************************** *)

lemma ex_subset_eqpoll:
     "[| A\<approx>a; ~ Finite(a); Ord(a); m \<in> nat |] ==> \<exists>X \<in> Pow(A). X\<approx>m"
apply (rule lepoll_imp_eqpoll_subset [of m A, THEN exE])
 apply (rule lepoll_trans, rule leI [THEN le_imp_lepoll])
  apply (blast intro: lt_trans2 [OF ltI nat_le_infinite_Ord] Ord_nat)
apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll])
apply (fast elim!: eqpoll_sym)
done

lemma subset_Un_disjoint: "[| A \<subseteq> B \<union> C; A \<inter> C = 0 |] ==> A \<subseteq> B"
by blast

lemma Int_empty:
     "[| X \<in> Pow(A - \<Union>(B) -C); T \<in> B; F \<subseteq> T |] ==> F \<inter> X = 0"
by blast

(* ********************************************************************** *)
(* equipollent subset (and finite) is the whole set                       *)
(* ********************************************************************** *)

lemma subset_imp_eq_lemma:
     "m \<in> nat ==> \<forall>A B. A \<subseteq> B & m \<lesssim> A & B \<lesssim> m \<longrightarrow> A=B"
apply (induct_tac "m")
apply (fast dest!: lepoll_0_is_0)
apply (intro allI impI)
apply (elim conjE)
apply (rule succ_lepoll_imp_not_empty [THEN not_emptyE], assumption)
apply (frule subsetD [THEN Diff_sing_lepoll], assumption+)
apply (frule lepoll_Diff_sing)
apply (erule allE impE)+
apply (rule conjI)
prefer 2 apply fast
apply fast
apply (blast elim: equalityE)
done

lemma subset_imp_eq: "[| A \<subseteq> B; m \<lesssim> A; B \<lesssim> m; m \<in> nat |] ==> A=B"
by (blast dest!: subset_imp_eq_lemma)

lemma bij_imp_arg_eq:
     "[| f \<in> bij(a, {Y \<in> X. Y\<approx>succ(k)}); k \<in> nat; f`b \<subseteq> f`y; b<a; y<a |]
      ==> b=y"
apply (drule subset_imp_eq)
apply (erule_tac [3] nat_succI)
apply (unfold bij_def inj_def)
apply (blast intro: eqpoll_sym eqpoll_imp_lepoll
             dest:  ltD apply_type)+
done

lemma ex_next_set:
     "[| recfunAC16(f, h, y, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)};
         Card(a); ~ Finite(a); A\<approx>a;
         k \<in> nat; m \<in> nat; y<a;
         h \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k)});
         ~ (\<exists>Y \<in> recfunAC16(f, h, y, a). h`y \<subseteq> Y) |]
      ==> \<exists>X \<in> {Y \<in> Pow(A). Y\<approx>succ(k #+ m)}. h`y \<subseteq> X &
                (\<forall>b<a. h`b \<subseteq> X \<longrightarrow>
                (\<forall>T \<in> recfunAC16(f, h, y, a). ~ h`b \<subseteq> T))"
apply (erule_tac m1=m in dbl_Diff_eqpoll [THEN ex_subset_eqpoll, THEN bexE],
       assumption+)
apply (erule Card_is_Ord, assumption)
apply (frule Un_in_Collect, (erule asm_rl nat_succI)+)
apply (erule CollectE)
apply (rule rev_bexI, simp)
apply (rule conjI, blast)
apply (intro ballI impI oallI notI)
apply (drule subset_Un_disjoint, rule Int_empty, assumption+)
apply (blast dest: bij_imp_arg_eq)
done

(* ********************************************************************** *)
(* Lemma ex_next_Ord states that for any successor                        *)
(* ordinal there is a number of the set satisfying certain properties     *)
(* ********************************************************************** *)

lemma ex_next_Ord:
     "[| recfunAC16(f, h, y, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)};
         Card(a); ~ Finite(a); A\<approx>a;
         k \<in> nat; m \<in> nat; y<a;
         h \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k)});
         f \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k #+ m)});
         ~ (\<exists>Y \<in> recfunAC16(f, h, y, a). h`y \<subseteq> Y) |]
      ==> \<exists>c<a. h`y \<subseteq> f`c &
                (\<forall>b<a. h`b \<subseteq> f`c \<longrightarrow>
                (\<forall>T \<in> recfunAC16(f, h, y, a). ~ h`b \<subseteq> T))"
apply (drule ex_next_set, assumption+)
apply (erule bexE)
apply (rule_tac x="converse(f)`X" in oexI)
apply (simp add: right_inverse_bij)
apply (blast intro: bij_converse_bij bij_is_fun [THEN apply_type] ltI
                    Card_is_Ord)
done

(* ********************************************************************** *)
(* Lemma simplifying assumptions                                          *)
(* ********************************************************************** *)

lemma lemma8:
     "[| \<forall>x<a. x<j | (\<exists>xa \<in> F(j). P(x, xa))
         \<longrightarrow> (\<exists>! Y. Y \<in> F(j) & P(x, Y)); F(j) \<subseteq> X;
         L \<in> X; P(j, L) & (\<forall>x<a. P(x, L) \<longrightarrow> (\<forall>xa \<in> F(j). ~P(x, xa))) |]
      ==> F(j) \<union> {L} \<subseteq> X &
          (\<forall>x<a. x\<le>j | (\<exists>xa \<in> (F(j) \<union> {L}). P(x, xa)) \<longrightarrow>
                 (\<exists>! Y. Y \<in> (F(j) \<union> {L}) & P(x, Y)))"
apply (rule conjI)
apply (fast intro!: singleton_subsetI)
apply (rule oallI)
apply (blast elim!: leE oallE)
done

(* ********************************************************************** *)
(* The main part of the proof: inductive proof of the property of T_gamma *)
(* lemma main_induct                                                      *)
(* ********************************************************************** *)

lemma main_induct:
     "[| b < a; f \<in> bij(a, {Y \<in> Pow(A) . Y\<approx>succ(k #+ m)});
         h \<in> bij(a, {Y \<in> Pow(A) . Y\<approx>succ(k)});
         ~Finite(a); Card(a); A\<approx>a; k \<in> nat; m \<in> nat |]
      ==> recfunAC16(f, h, b, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)} &
          (\<forall>x<a. x < b | (\<exists>Y \<in> recfunAC16(f, h, b, a). h ` x \<subseteq> Y) \<longrightarrow>
          (\<exists>! Y. Y \<in> recfunAC16(f, h, b, a) & h ` x \<subseteq> Y))"
apply (erule lt_induct)
apply (frule lt_Ord)
apply (erule Ord_cases)
(* case 0 *)
apply (simp add: recfunAC16_0)
(* case Limit *)
prefer 2  apply (simp add: recfunAC16_Limit)
          apply (rule lemma5, assumption+)
          apply (blast dest!: recfunAC16_mono)
(* case succ *)
apply clarify
apply (erule lemma6 [THEN conjE], assumption)
apply (simp (no_asm_simp) split del: split_if add: recfunAC16_succ)
apply (rule conjI [THEN split_if [THEN iffD2]])
 apply (simp, erule lemma7, assumption)
apply (rule impI)
apply (rule ex_next_Ord [THEN oexE],
       assumption+, rule le_refl [THEN lt_trans], assumption+)
apply (erule lemma8, assumption)
 apply (rule bij_is_fun [THEN apply_type], assumption)
 apply (erule Least_le [THEN lt_trans2, THEN ltD])
  apply (erule lt_Ord)
 apply (erule succ_leI)
apply (erule LeastI)
apply (erule lt_Ord)
done

(* ********************************************************************** *)
(* Lemma to simplify the inductive proof                                  *)
(*   - the desired property is a consequence of the inductive assumption  *)
(* ********************************************************************** *)

lemma lemma_simp_induct:
     "[| \<forall>b. b<a \<longrightarrow> F(b) \<subseteq> S & (\<forall>x<a. (x<b | (\<exists>Y \<in> F(b). f`x \<subseteq> Y))
                                   \<longrightarrow> (\<exists>! Y. Y \<in> F(b) & f`x \<subseteq> Y));
         f \<in> a->f``(a); Limit(a);
         \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j) |]
        ==> (\<Union>j<a. F(j)) \<subseteq> S &
            (\<forall>x \<in> f``a. \<exists>! Y. Y \<in> (\<Union>j<a. F(j)) & x \<subseteq> Y)"
apply (rule conjI)
apply (rule subsetI)
apply (erule OUN_E, blast)
apply (rule ballI)
apply (erule imageE)
apply (drule ltI, erule Limit_is_Ord)
apply (drule Limit_has_succ, assumption)
apply (frule_tac x1="succ(xa)" in spec [THEN mp], assumption)
apply (erule conjE)
apply (drule ospec)
(** LEVEL 10 **)
apply (erule leI [THEN succ_leE])
apply (erule impE)
apply (fast elim!: leI [THEN succ_leE, THEN lt_Ord, THEN le_refl])
apply (drule apply_equality, assumption)
apply (elim conjE ex1E)
(** LEVEL 15 **)
apply (rule ex1I, blast)
apply (elim conjE OUN_E)
apply (erule_tac i="succ(xa)" and j=aa
       in Ord_linear_le [OF lt_Ord lt_Ord], assumption)
prefer 2
apply (drule spec [THEN spec, THEN mp, THEN subsetD], assumption+, blast)
(** LEVEL 20 **)
apply (drule_tac x1=aa in spec [THEN mp], assumption)
apply (frule succ_leE)
apply (drule spec [THEN spec, THEN mp, THEN subsetD], assumption+, blast)
done

(* ********************************************************************** *)
(* The target theorem                                                     *)
(* ********************************************************************** *)

theorem WO2_AC16: "[| WO2; 0<m; k \<in> nat; m \<in> nat |] ==> AC16(k #+ m,k)"
apply (unfold AC16_def)
apply (rule allI)
apply (rule impI)
apply (frule WO2_infinite_subsets_eqpoll_X, assumption+)
apply (frule_tac n="k #+ m" in WO2_infinite_subsets_eqpoll_X, simp, simp)
apply (frule WO2_imp_ex_Card)
apply (elim exE conjE)
apply (drule eqpoll_trans [THEN eqpoll_sym,
                           THEN eqpoll_def [THEN def_imp_iff, THEN iffD1]],
       assumption)
apply (drule eqpoll_trans [THEN eqpoll_sym,
                           THEN eqpoll_def [THEN def_imp_iff, THEN iffD1]],
       assumption+)
apply (elim exE)
apply (rename_tac h)
apply (rule_tac x = "\<Union>j<a. recfunAC16 (h,f,j,a) " in exI)
apply (rule_tac P="%z. Y & (\<forall>x \<in> z. Z(x))"  for Y Z
       in bij_is_surj [THEN surj_image_eq, THEN subst], assumption)
apply (rule lemma_simp_induct)
apply (blast del: conjI notI
             intro!: main_induct eqpoll_imp_lepoll [THEN lepoll_infinite] )
apply (blast intro: bij_is_fun [THEN surj_image, THEN surj_is_fun])
apply (erule eqpoll_imp_lepoll [THEN lepoll_infinite,
                                THEN infinite_Card_is_InfCard,
                                THEN InfCard_is_Limit],
       assumption+)
apply (blast dest!: recfunAC16_mono)
done

end


theory HFunctor
  imports Main
         "HOL-Algebra.Group"
         AbelianGroups
         Gamma
         "HOL-Library.Poly_Mapping"
begin

section "Abelian Groups to Gammaset"

locale group_to_gammaset =
  A: comm_group A
  for A:: "('a,'b) monoid_scheme"
begin

interpretation Ab : abelian_group_category.
interpretation AbCC : classical_category Ab.Obj' Ab.Arr' Ab.Dom' Ab.Cod' Ab.Id' Ab.Comp'
  using Ab.is_classical_category.

interpretation T: group_to_Lawvere_theory_functor A
  unfolding group_to_Lawvere_theory_functor_def
  using A.comm_group_axioms.

lift_definition HFunctorHat_on_arr :: "(nat \<times> nat list) option \<Rightarrow> (nat \<Rightarrow>\<^sub>0 int) \<Rightarrow> (nat \<Rightarrow>\<^sub>0 int)" is
  "\<lambda>f g x. if 0 < x \<and> x < fin_set.Dom' (the f) then g (get (snd (the f)) x) else 0"
proof-
  fix f :: "(nat \<times> nat list) option"
  fix g :: "(nat \<Rightarrow> int)"
  assume "finite {y. g y \<noteq> 0}"
  show "finite {x. (if 0 < x \<and> x < length (snd (the f)) then g (get (snd (the f)) x) else 0) \<noteq> 0}"
    by simp
qed

definition HFunctorHat :: "(nat \<times> nat list) option \<Rightarrow> T.Lawv_arr" where
  "HFunctorHat = MkFunctor pointed_fin_set.comp (dual_category.comp (Ab.Lawv_comp))
               (\<lambda>f. Ab.MkArr (free_Abelian_group {i. 0 < i \<and> i < fin_set.Cod' (the f)})
                             (free_Abelian_group {i. 0 < i \<and> i < fin_set.Dom' (the f)})
                             (HFunctorHat_on_arr f))"

lemma HFunctorHat : "functor pointed_fin_set.comp (dual_category.comp (Ab.Lawv_comp)) HFunctorHat"
  unfolding functor_def
  apply (simp add: pointed_fin_set.is_category)
  apply auto
   apply (rule_tac dual_category.is_category)
  unfolding dual_category_def
   apply (simp add: Ab.Lawv_is_category)
  unfolding functor_axioms_def
  apply auto
proof-
  interpret PFT : category pointed_fin_set.comp
    using pointed_fin_set.is_category.
  interpret DL : dual_category "Ab.Lawv_comp"
    by (simp add: Ab.Lawv_is_category dual_category_def)
  show "\<And>f. \<not> PFT.arr f \<Longrightarrow> HFunctorHat f = DL.null"
    unfolding HFunctorHat_def by simp
  show arr: "\<And>f. PFT.arr f \<Longrightarrow> DL.arr (HFunctorHat f)"
    unfolding DL.arr_char
    unfolding Ab.Lawv_comp_def
    apply (subst classical_category.arr_char)
    using Ab.Lawv_is_classical_category apply simp
    unfolding HFunctorHat_def Ab.MkArr_def
    apply simp
    unfolding classical_full_subcategory.SArr_def
          [OF Ab.Lawv_is_classical_full_subcategory]
    unfolding Ab.is_Z_tothe_n_def Ab.Dom'_def Ab.Cod'_def
    apply simp
    apply safe
  proof-
    fix f
    assume arr_f : "PFT.arr f"
    define S1 where "S1 = {i. 0 < i \<and> i < fst (the f)}"
    have "finite S1 \<and> free_Abelian_group S1 = free_Abelian_group {i. 0 < i \<and> i < fst (the f)}"
      unfolding S1_def by simp
    then show "\<exists>S. finite S \<and> free_Abelian_group S = free_Abelian_group {i. 0 < i \<and> i < fst (the f)}"
      apply (rule_tac exI)
      by simp
    define S2 where "S2 = {i. 0 < i \<and> i < length (snd (the f))}"
    have "finite S2 \<and> free_Abelian_group S2 = free_Abelian_group {i. 0 < i \<and> i < length (snd (the f))}"
      unfolding S2_def by simp
    then show "\<exists>S. finite S \<and> free_Abelian_group S = free_Abelian_group {i. 0 < i \<and> i < length (snd (the f))}"
      apply (rule_tac exI)
      by simp

    show "Ab.Arr'
          (restrict (HFunctorHat_on_arr f) (carrier (free_Abelian_group {i. 0 < i \<and> i < fst (the f)})),
           free_Abelian_group {i. 0 < i \<and> i < fst (the f)}, free_Abelian_group {i. 0 < i \<and> i < length (snd (the f))})"
      apply (simp add: Ab.Arr'_def Ab.Obj'_def Ab.Dom'_def Ab.Cod'_def)
      apply (simp add: abelian_free_Abelian_group)
      apply (simp add: hom_def free_Abelian_group_def)
      apply (simp add: HFunctorHat_on_arr_def Poly_Mapping.keys_def)
      apply auto
        apply (rule_tac poly_mapping_eqI)
      unfolding lookup_add
        apply simp
    proof-
      fix x y :: "nat \<Rightarrow>\<^sub>0 int"
      fix xa
      assume "poly_mapping.lookup x xa + poly_mapping.lookup y xa \<noteq> 0"
      then have "poly_mapping.lookup x xa \<noteq> 0 \<or> poly_mapping.lookup y xa \<noteq> 0"
        by simp
      then have T: "{k. poly_mapping.lookup x k \<noteq> 0} \<subseteq> {i. 0 < i \<and> i < fst (the f)} \<Longrightarrow>
       {k. poly_mapping.lookup y k \<noteq> 0} \<subseteq> {i. 0 < i \<and> i < fst (the f)} \<Longrightarrow> 0 < xa \<and> xa < fst (the f)"
      proof
        show "{k. poly_mapping.lookup x k \<noteq> 0} \<subseteq> {i. 0 < i \<and> i < fst (the f)} \<Longrightarrow>
              poly_mapping.lookup x xa \<noteq> 0 \<Longrightarrow> 0 < xa \<and> xa < fst (the f) "
          by auto
        show "{k. poly_mapping.lookup y k \<noteq> 0} \<subseteq> {i. 0 < i \<and> i < fst (the f)} \<Longrightarrow>
              poly_mapping.lookup y xa \<noteq> 0 \<Longrightarrow> 0 < xa \<and> xa < fst (the f) "
          by auto
      qed
      then show "{k. poly_mapping.lookup x k \<noteq> 0} \<subseteq> {i. 0 < i \<and> i < fst (the f)} \<Longrightarrow>
       {k. poly_mapping.lookup y k \<noteq> 0} \<subseteq> {i. 0 < i \<and> i < fst (the f)} \<Longrightarrow> 0 < xa"
        by simp
      from T show "{k. poly_mapping.lookup x k \<noteq> 0} \<subseteq> {i. 0 < i \<and> i < fst (the f)} \<Longrightarrow>
       {k. poly_mapping.lookup y k \<noteq> 0} \<subseteq> {i. 0 < i \<and> i < fst (the f)} \<Longrightarrow> xa < fst (the f)"
        by simp
    qed
  qed

  show dom : "\<And>f. PFT.arr f \<Longrightarrow> DL.dom (HFunctorHat f) = HFunctorHat (PFT.dom f)"
    using arr
    unfolding DL.dom_char DL.arr_char
    unfolding Ab.Lawv_comp_def
    unfolding classical_category.cod_char [OF Ab.Lawv_is_classical_category]
    apply simp
  proof-
    fix f
    assume arr_f : "PFT.arr f"
    show "Some (Ab.Id' (Ab.Cod' (the (HFunctorHat f)))) = HFunctorHat (PFT.dom f)"
      unfolding HFunctorHat_def
      apply (simp add: arr_f Ab.Id'_def Ab.Cod'_def Ab.MkArr_def)
      unfolding pointed_fin_set.dom_char [OF arr_f]
      apply (simp add: fin_set.Id'_def)
    proof
      fix x
      show "(\<lambda>x\<in>carrier (free_Abelian_group {i. 0 < i \<and> i < length (snd (the f))}). x) x =
         restrict (HFunctorHat_on_arr (Some (length (snd (the f)), rev_get (length (snd (the f))) (\<lambda>k. k))))
          (carrier (free_Abelian_group {i. 0 < i \<and> i < length (snd (the f))})) x"
        unfolding HFunctorHat_on_arr_def
        apply auto
        apply (rule_tac poly_mapping_eqI)
        apply auto

      proof-
        assume A: "Poly_Mapping.keys x \<subseteq> {i. 0 < i \<and> i < length (snd (the f))}"
        have "0 \<notin> {i. 0 < i \<and> i < length (snd (the f))}"
          by simp
        from this and A have " 0 \<notin> Poly_Mapping.keys x"
          by auto
        then show "poly_mapping.lookup x 0 = 0"
          by (simp add: in_keys_iff)
        fix k
        assume "\<not> k < length (snd (the f))"
        then have "k \<notin> {i. 0 < i \<and> i < length (snd (the f))}"
          by simp
        from this and A have "k \<notin> Poly_Mapping.keys x"
          by auto
        then show "poly_mapping.lookup x k = 0"
          by (simp add: in_keys_iff)
      qed
    qed
  qed
  show cod : "\<And>f. PFT.arr f \<Longrightarrow> DL.cod (HFunctorHat f) = HFunctorHat (PFT.cod f)"
    using arr
    unfolding DL.cod_char DL.arr_char
    unfolding Ab.Lawv_comp_def
    unfolding classical_category.dom_char [OF Ab.Lawv_is_classical_category]
    apply simp
  proof-
    fix f
    assume arr_f : "PFT.arr f"
    show "Some (Ab.Id' (Ab.Dom' (the (HFunctorHat f)))) = HFunctorHat (PFT.cod f)"
      unfolding HFunctorHat_def
      apply (simp add: arr_f Ab.Id'_def Ab.Dom'_def Ab.MkArr_def)
      unfolding pointed_fin_set.cod_char [OF arr_f]
      apply (simp add: fin_set.Id'_def)
    proof
      fix x
      show "(\<lambda>x\<in>carrier (free_Abelian_group {i. 0 < i \<and> i < fst (the f)}). x) x =
         restrict (HFunctorHat_on_arr (Some (fst (the f), rev_get (fst (the f)) (\<lambda>k. k))))
          (carrier (free_Abelian_group {i. 0 < i \<and> i < fst (the f)})) x"
        unfolding HFunctorHat_on_arr_def
        apply auto
        apply (rule_tac poly_mapping_eqI)
        apply auto

      proof-
        assume A: "Poly_Mapping.keys x \<subseteq> {i. 0 < i \<and> i < fst (the f)}"
        have "0 \<notin> {i. 0 < i \<and> i < length (snd (the f))}"
          by simp
        from this and A have " 0 \<notin> Poly_Mapping.keys x"
          by auto
        then show "poly_mapping.lookup x 0 = 0"
          by (simp add: in_keys_iff)
        fix k
        assume "\<not> k < fst (the f)"
        then have "k \<notin> {i. 0 < i \<and> i < fst (the f)}"
          by simp
        from this and A have "k \<notin> Poly_Mapping.keys x"
          by auto
        then show "poly_mapping.lookup x k = 0"
          by (simp add: in_keys_iff)
      qed
    qed
  qed
  fix g f
  assume arr_gf : "PFT.seq g f"
  have arr_hgf : "DL.seq (HFunctorHat g) (HFunctorHat f)"
    apply (rule_tac PFT.seqE [OF arr_gf])
    apply (rule_tac DL.seqI)
    using arr dom cod by simp_all

  have arr_f : "PFT.arr f"
    apply (rule_tac PFT.seqE [OF arr_gf])
    by simp
  have arr_g : "PFT.arr g"
    apply (rule_tac PFT.seqE [OF arr_gf])
    by simp
  have seq : "PFT.dom g = PFT.cod f"
    apply (rule_tac PFT.seqE [OF arr_gf])
    by simp

  interpret LawvCC : classical_category Ab.is_Z_tothe_n
   "(classical_full_subcategory.SArr Ab.Arr' Ab.Dom' Ab.Cod' Ab.is_Z_tothe_n)" Ab.Dom' Ab.Cod' Ab.Id'
   Ab.Comp'
    using Ab.Lawv_is_classical_category.

  have LA_arr : "\<And>f. DL.arr f \<Longrightarrow> AbCC.arr f"
    unfolding AbCC.arr_char
    unfolding DL.arr_char
    unfolding Ab.Lawv_comp_def
    unfolding LawvCC.arr_char
    unfolding classical_full_subcategory.SArr_def
          [OF Ab.Lawv_is_classical_full_subcategory]
    by simp
  have LA_dom : "\<And>f. DL.arr f \<Longrightarrow> AbCC.cod f = DL.dom f"
    unfolding AbCC.cod_char
    apply (simp add: LA_arr)
    unfolding DL.dom_char
    unfolding Ab.Lawv_comp_def
    unfolding LawvCC.cod_char
    by simp
  have LA_cod : "\<And>f. DL.arr f \<Longrightarrow> AbCC.dom f = DL.cod f"
    unfolding AbCC.dom_char
    apply (simp add: LA_arr)
    unfolding DL.cod_char
    unfolding Ab.Lawv_comp_def
    unfolding LawvCC.dom_char
    by simp
  have LA_comp : "\<And>g f. DL.seq g f \<Longrightarrow> DL.comp g f = Ab.comp f g"
    unfolding Ab.comp_def
    apply (subst AbCC.comp_simp)
    using LA_arr
    unfolding AbCC.arr_char AbCC.null_char
     apply (metis AbCC.arr_char AbCC.classical_category_axioms DL.seqE
            LA_cod LA_dom category.seqI classical_category.induces_category)
    apply simp
    unfolding Ab.Lawv_comp_def
    apply (subst LawvCC.comp_simp)
    by auto

  show "HFunctorHat (pointed_fin_set.comp g f) = DL.comp (HFunctorHat g) (HFunctorHat f)"
    apply (subst LA_comp [OF arr_hgf])
    apply (rule_tac Ab.comp_eqI)
          apply (rule_tac LA_arr [OF arr [OF arr_gf]])
         apply (rule_tac LA_arr [OF arr [OF arr_f]])
        apply (rule_tac LA_arr [OF arr [OF arr_g]])
    unfolding LA_cod [OF arr [OF arr_g]]
    unfolding LA_cod [OF arr [OF arr_gf]]
    unfolding cod [OF arr_g] cod [OF arr_gf]
    unfolding PFT.cod_comp [OF arr_gf] apply simp
    unfolding LA_dom [OF arr [OF arr_f]]
    unfolding LA_dom [OF arr [OF arr_gf]]
    unfolding dom [OF arr_f] dom [OF arr_gf]
    unfolding PFT.dom_comp [OF arr_gf] apply simp
    unfolding LA_dom [OF arr [OF arr_g]]
    unfolding LA_cod [OF arr [OF arr_f]]
    unfolding dom [OF arr_g] cod [OF arr_f]
     apply (simp add: seq)
    unfolding HFunctorHat_def
    apply (simp add: arr_f arr_g arr_gf Ab.MkArr_def Ab.Dom'_def)
    unfolding pointed_fin_set.comp_char [OF arr_f arr_g seq]
    unfolding fin_set.Comp'_def
    apply auto
    apply (simp add: HFunctorHat_on_arr_def)
    apply (rule_tac poly_mapping_eqI)
    apply auto
  proof-
    fix x :: "nat \<Rightarrow>\<^sub>0 int"
    fix k :: nat
    have g_zero: "get (snd (the g)) 0 = 0"
      using arr_g
      unfolding pointed_fin_set.comp_def
      unfolding subcategory.arr_char [OF pointed_fin_set.is_subcategory]
      unfolding pointed_fin_set.PointedArr'_def
      by simp
    assume A: "Poly_Mapping.keys x \<subseteq> {i. 0 < i \<and> i < fst (the g)}"
    have "0 \<notin> {i. 0 < i \<and> i < fst (the g)}"
      by simp
    from this and A have "0 \<notin> Poly_Mapping.keys x" by auto
    then show "poly_mapping.lookup x (get (snd (the g)) 0) = 0"
      unfolding g_zero
      by (simp add: in_keys_iff)
    assume "k < length (snd (the f))"
    then have fk_less: "get (snd (the f)) k < fst (the f)"
      using arr_f
      unfolding pointed_fin_set.comp_def
      unfolding subcategory.arr_char [OF pointed_fin_set.is_subcategory]
      unfolding pointed_fin_set.PointedArr'_def
      unfolding fin_set.arr_char
      unfolding fin_set.Arr'_def
      by simp
    have seq_eq : "fst (the f) = length (snd (the g))"
      using seq arr_f arr_g
      unfolding pointed_fin_set.comp_def
      unfolding subcategory.dom_char [OF pointed_fin_set.is_subcategory]
      unfolding subcategory.cod_char [OF pointed_fin_set.is_subcategory]
      unfolding subcategory.arr_char [OF pointed_fin_set.is_subcategory]
      apply simp
      unfolding fin_set.dom_char fin_set.cod_char pointed_fin_set.PointedArr'_def
      unfolding reverse_equality [OF fin_set.comp_def]
      by (simp add: fin_set.Id'_def)
    assume "\<not> get (snd (the f)) k < length (snd (the g))"
    then have "False"
      using fk_less
      unfolding seq_eq by simp
    then show "poly_mapping.lookup x (get (snd (the g)) (get (snd (the f)) k)) = 0"
      by simp
  qed
qed

definition HFunctor where
  "HFunctor = T.map \<circ> HFunctorHat"

lemma is_functor : "functor pointed_fin_set.comp pointed_set.pointed_set_comp HFunctor"
  unfolding HFunctor_def
  apply (rule_tac functor_comp)
   apply (rule_tac HFunctorHat)
  by (rule_tac T.is_functor)

end

end