section \<open>Product Machines\<close>

text \<open>This theory defines the construction of product machines.
      A product machine of two finite state machines essentially represents all possible parallel
      executions of those two machines.\<close>

theory Product_FSM
imports FSM
begin

lift_definition product :: "('a,'b,'c) fsm \<Rightarrow> ('d,'b,'c) fsm \<Rightarrow> ('a \<times> 'd,'b,'c) fsm" is FSM_Impl.product
proof -
  fix A :: "('a,'b,'c) fsm_impl"
  fix B :: "('d,'b,'c) fsm_impl"
  assume "well_formed_fsm A" and "well_formed_fsm B"

  then have p1a: "fsm_impl.initial A \<in> fsm_impl.states A"
        and p2a: "finite (fsm_impl.states A)"
        and p3a: "finite (fsm_impl.inputs A)"
        and p4a: "finite (fsm_impl.outputs A)"
        and p5a: "finite (fsm_impl.transitions A)"
        and p6a: "(\<forall>t\<in>fsm_impl.transitions A.
            t_source t \<in> fsm_impl.states A \<and>
            t_input t \<in> fsm_impl.inputs A \<and> t_target t \<in> fsm_impl.states A \<and>
                                             t_output t \<in> fsm_impl.outputs A)"
        and p1b: "fsm_impl.initial B \<in> fsm_impl.states B"
        and p2b: "finite (fsm_impl.states B)"
        and p3b: "finite (fsm_impl.inputs B)"
        and p4b: "finite (fsm_impl.outputs B)"
        and p5b: "finite (fsm_impl.transitions B)"
        and p6b: "(\<forall>t\<in>fsm_impl.transitions B.
            t_source t \<in> fsm_impl.states B \<and>
            t_input t \<in> fsm_impl.inputs B \<and> t_target t \<in> fsm_impl.states B \<and>
                                             t_output t \<in> fsm_impl.outputs B)"
    by simp+

  let ?P = "FSM_Impl.product A B"

  have "fsm_impl.initial ?P \<in> fsm_impl.states ?P"
    using p1a p1b by auto
  moreover have "finite (fsm_impl.states ?P)"
    using p2a p2b by auto
  moreover have "finite (fsm_impl.inputs ?P)"
    using p3a p3b by auto
  moreover have "finite (fsm_impl.outputs ?P)"
    using p4a p4b by auto
  moreover have "finite (fsm_impl.transitions ?P)"
    using p5a p5b unfolding product_code_naive by auto
  moreover have "(\<forall>t\<in>fsm_impl.transitions ?P.
            t_source t \<in> fsm_impl.states ?P \<and>
            t_input t \<in> fsm_impl.inputs ?P \<and> t_target t \<in> fsm_impl.states ?P \<and>
                                             t_output t \<in> fsm_impl.outputs ?P)"
    using p6a p6b by auto

  ultimately show "well_formed_fsm (FSM_Impl.product A B)"
    by blast
qed

abbreviation "left_path p \<equiv> map (\<lambda>t. (fst (t_source t), t_input t, t_output t, fst (t_target t))) p"
abbreviation "right_path p \<equiv> map (\<lambda>t. (snd (t_source t), t_input t, t_output t, snd (t_target t))) p"
abbreviation "zip_path p1 p2 \<equiv> (map (\<lambda> t . ((t_source (fst t), t_source (snd t)), t_input (fst t), t_output (fst t), (t_target (fst t), t_target (snd t))))
                                     (zip p1 p2))"

lemma product_simps[simp]:
  "initial (product A B) = (initial A, initial B)"
  "states (product A B) = (states A) \<times> (states B)"
  "inputs (product A B) = inputs A \<union> inputs B"
  "outputs (product A B) = outputs A \<union> outputs B"
  by (transfer; simp)+

lemma product_transitions_def :
  "transitions (product A B) = {((qA,qB),x,y,(qA',qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B}"
  by (transfer; simp)+

lemma product_transitions_alt_def :
  "transitions (product A B) = {((t_source tA, t_source tB),t_input tA, t_output tA, (t_target tA, t_target tB)) | tA tB . tA \<in> transitions A \<and> tB \<in> transitions B \<and> t_input tA = t_input tB \<and> t_output tA = t_output tB}"
  (is "?T1 = ?T2")
proof -
  have "\<And> t . t \<in> ?T1 \<Longrightarrow> t \<in> ?T2"
  proof -
    fix tt assume "tt \<in> ?T1"
    then obtain qA qB x y qA' qB' where "tt = ((qA,qB),x,y,(qA',qB'))" and "(qA,x,y,qA') \<in> transitions A" and "(qB,x,y,qB') \<in> transitions B"
      unfolding product_transitions_def by blast
    then have "((t_source (qA,x,y,qA'), t_source (qB,x,y,qB')),t_input (qA,x,y,qA'), t_output (qA,x,y,qA'), (t_target (qA,x,y,qA'), t_target (qB,x,y,qB'))) \<in> ?T2"
      by auto
    then show "tt \<in> ?T2"
      unfolding \<open>tt = ((qA,qB),x,y,(qA',qB'))\<close> fst_conv snd_conv by assumption
  qed
  moreover have "\<And> t . t \<in> ?T2 \<Longrightarrow> t \<in> ?T1"
  proof -
    fix tt assume "tt \<in> ?T2"
    then obtain tA tB where "tt = ((t_source tA, t_source tB),t_input tA, t_output tA, (t_target tA, t_target tB))"
                        and "tA \<in> transitions A" and "tB \<in> transitions B" and "t_input tA = t_input tB" and "t_output tA = t_output tB"
      by blast
    then have "(t_source tA, t_input tA, t_output tA, t_target tA) \<in> transitions A"
         and  "(t_source tB, t_input tA, t_output tA, t_target tB) \<in> transitions B"
      by (metis prod.collapse)+
    then show "tt \<in> ?T1"
      unfolding product_transitions_def \<open>tt = ((t_source tA, t_source tB),t_input tA, t_output tA, (t_target tA, t_target tB))\<close> by blast
  qed
  ultimately show ?thesis by blast
qed

lemma zip_path_last : "length xs = length ys \<Longrightarrow> (zip_path (xs @ [x]) (ys @ [y])) = (zip_path xs ys)@(zip_path [x] [y])"
  by (induction xs ys rule: list_induct2; simp)

lemma product_path_from_paths :
  assumes "path A (initial A) p1"
      and "path B (initial B) p2"
      and "p_io p1 = p_io p2"
    shows "path (product A B) (initial (product A B)) (zip_path p1 p2)"
      and "target (initial (product A B)) (zip_path p1 p2) = (target (initial A) p1, target (initial B) p2)"
proof -
  have "initial (product A B) = (initial A, initial B)" by auto
  then have "(initial A, initial B) \<in> states (product A B)"
    by (metis fsm_initial)

  have "length p1 = length p2" using assms(3)
    using map_eq_imp_length_eq by blast
  then have c: "path (product A B) (initial (product A B)) (zip_path p1 p2)
                \<and> target (initial (product A B)) (zip_path p1 p2) = (target (initial A) p1, target (initial B) p2)"
    using assms proof (induction p1 p2 rule: rev_induct2)
    case Nil

    then have "path (product A B) (initial (product A B)) (zip_path [] [])"
      using \<open>initial (product A B) = (initial A, initial B)\<close> \<open>(initial A, initial B) \<in> states (product A B)\<close>
      by (metis Nil_is_map_conv path.nil zip_Nil)
    moreover have "target (initial (product A B)) (zip_path [] []) = (target (initial A) [], target (initial B) [])"
      using \<open>initial (product A B) = (initial A, initial B)\<close> by auto
    ultimately show ?case by fast
  next
    case (snoc x xs y ys)

    have "path A (initial A) xs" using snoc.prems(1) by auto
    moreover have "path B (initial B) ys" using snoc.prems(2) by auto
    moreover have "p_io xs = p_io ys" using snoc.prems(3) by auto
    ultimately have *:"path (product A B) (initial (product A B)) (zip_path xs ys)"
                and **:"target (initial (product A B)) (zip_path xs ys) = (target (initial A) xs, target (initial B) ys)"
      using snoc.IH by blast+
    then have "(target (initial A) xs, target (initial B) ys) \<in> states (product A B)"
      by (metis (no_types, lifting) path_target_is_state)
    then have "(t_source x, t_source y) \<in> states (product A B)"
      using snoc.prems(1-2)  by (metis path_cons_elim path_suffix)

    have "x \<in> transitions A" using snoc.prems(1) by auto
    moreover have "y \<in> transitions B" using snoc.prems(2) by auto
    moreover have "t_input x = t_input y" using snoc.prems(3) by auto
    moreover have "t_output x = t_output y" using snoc.prems(3) by auto
    ultimately have "((t_source x, t_source y), t_input x, t_output x, (t_target x, t_target y)) \<in> transitions (product A B)"
      unfolding product_transitions_alt_def by blast

    moreover have "t_source x = target (initial A) xs" using snoc.prems(1) by auto
    moreover have "t_source y = target (initial B) ys" using snoc.prems(2) by auto
    ultimately have "((target (initial A) xs, target (initial B) ys), t_input x, t_output x, (t_target x, t_target y)) \<in> transitions (product A B)"
      using \<open>(t_source x, t_source y) \<in> states (product A B)\<close>
      by simp
    then have ***: "path (product A B) (initial (product A B)) ((zip_path xs ys)@[((target (initial A) xs, target (initial B) ys), t_input x, t_output x, (t_target x, t_target y))])"
      using * **
      by (metis (no_types, lifting) fst_conv path_append_transition)

    have "t_target x = target (initial A) (xs@[x])" by auto
    moreover have "t_target y = target (initial B) (ys@[y])" by auto
    ultimately have ****: "target (initial (product A B)) ((zip_path xs ys)@[((target (initial A) xs, target (initial B) ys), t_input x, t_output x, (t_target x, t_target y))])
                            = (target (initial A) (xs@[x]), target (initial B) (ys@[y]))"
      by fastforce

    have "(zip_path [x] [y]) = [((target (initial A) xs, target (initial B) ys), t_input x, t_output x, (t_target x, t_target y))]"
      using \<open>t_source x = target (initial A) xs\<close> \<open>t_source y = target (initial B) ys\<close> by auto
    moreover have "(zip_path (xs @ [x]) (ys @ [y])) = (zip_path xs ys)@(zip_path [x] [y])"
      using zip_path_last[of xs ys x y, OF snoc.hyps]  by assumption
    ultimately have *****:"(zip_path (xs@[x]) (ys@[y]))
                            = (zip_path xs ys)@[((target (initial A) xs, target (initial B) ys), t_input x, t_output x, (t_target x, t_target y))]"
      by auto
    then have "path (product A B) (initial (product A B)) (zip_path (xs@[x]) (ys@[y]))"
      using *** by presburger
    moreover have "target (initial (product A B)) (zip_path (xs@[x]) (ys@[y]))
                      = (target (initial A) (xs@[x]), target (initial B) (ys@[y]))"
      using **** ***** by auto
    ultimately show ?case by linarith
  qed

  from c show "path (product A B) (initial (product A B)) (zip_path p1 p2)"
    by auto
  from c show "target (initial (product A B)) (zip_path p1 p2)
                  = (target (initial A) p1, target (initial B) p2)"
    by auto
qed

lemma paths_from_product_path :
  assumes "path (product A B) (initial (product A B)) p"
  shows   "path A (initial A) (left_path p)"
      and "path B (initial B) (right_path p)"
      and "target (initial A) (left_path p) = fst (target (initial (product A B)) p)"
      and "target (initial B) (right_path p) = snd (target (initial (product A B)) p)"
proof -
  have "path A (initial A) (left_path p)
            \<and> path B (initial B) (right_path p)
            \<and> target (initial A) (left_path p) = fst (target (initial (product A B)) p)
            \<and> target (initial B) (right_path p) = snd (target (initial (product A B)) p)"
  using assms proof (induction p rule: rev_induct)
    case Nil
    then show ?case by auto
  next
    case (snoc t p)
    then have "path (product A B) (initial (product A B)) p" by fast
    then have "path A (initial A) (left_path p)"
      and "path B (initial B) (right_path p)"
      and "target (initial A) (left_path p) = fst (target (initial (product A B)) p)"
      and "target (initial B) (right_path p) = snd (target (initial (product A B)) p)"
      using snoc.IH  by fastforce+

    then have "t_source t = (target (initial A) (left_path p), target (initial B) (right_path p))"
      using snoc.prems by (metis (no_types, lifting) path_cons_elim path_suffix prod.collapse)

    have ***: "target (initial A) (left_path (p@[t]))= fst (target (initial (product A B)) (p@[t]))"
      by fastforce
    have ****: "target (initial B) (right_path (p@[t]))= snd (target (initial (product A B)) (p@[t]))"
      by fastforce

    have "t \<in> transitions (product A B)" using snoc.prems by auto

    then have "(fst (t_source t), t_input t, t_output t, fst (t_target t)) \<in> transitions A"
      unfolding product_transitions_alt_def by force
    moreover have "target (initial A) (left_path p) = fst (t_source t)"
      using \<open>t_source t = (target (initial A) (left_path p), target (initial B) (right_path p))\<close> by auto
    ultimately have "path A (initial A) ((left_path p)@[(fst (t_source t), t_input t, t_output t, fst (t_target t))])"
      by (simp add: \<open>path A (initial A) (map (\<lambda>t. (fst (t_source t), t_input t, t_output t, fst (t_target t))) p)\<close> path_append_transition)
    then have *: "path A (initial A) (left_path (p@[t]))" by auto

    have "(snd (t_source t), t_input t, t_output t, snd (t_target t)) \<in> transitions B"
      using \<open>t \<in> transitions (product A B)\<close> unfolding product_transitions_alt_def by auto
    moreover have "target (initial B) (right_path p) = snd (t_source t)"
      using \<open>t_source t = (target (initial A) (left_path p), target (initial B) (right_path p))\<close> by auto
    ultimately have "path B (initial B) ((right_path p)@[(snd (t_source t), t_input t, t_output t, snd (t_target t))])"
      by (simp add: \<open>path B (initial B) (map (\<lambda>t. (snd (t_source t), t_input t, t_output t, snd (t_target t))) p)\<close> path_append_transition)
    then have **: "path B (initial B) (right_path (p@[t]))" by auto

    show ?case using * ** *** **** by blast
  qed

  then show "path A (initial A) (left_path p)"
      and "path B (initial B) (right_path p)"
      and "target (initial A) (left_path p) = fst (target (initial (product A B)) p)"
      and "target (initial B) (right_path p) = snd (target (initial (product A B)) p)" by linarith+
qed

lemma zip_path_left_right[simp] :
  "(zip_path (left_path p) (right_path p)) = p" by (induction p; auto)

lemma product_reachable_state_paths :
  assumes "(q1,q2) \<in> reachable_states (product A B)"
obtains p1 p2
  where "path A (initial A) p1"
  and   "path B (initial B) p2"
  and   "target (initial A) p1 = q1"
  and   "target (initial B) p2 = q2"
  and   "p_io p1 = p_io p2"
  and   "path (product A B) (initial (product A B)) (zip_path p1 p2)"
  and   "target (initial (product A B)) (zip_path p1 p2) = (q1,q2)"
proof -
  let ?P = "product A B"
  from assms obtain p where "path ?P (initial ?P) p" and "target (initial ?P) p = (q1,q2)"
    unfolding reachable_states_def by auto

  have "path A (initial A) (left_path p)"
   and "path B (initial B) (right_path p)"
   and "target (initial A) (left_path p) = q1"
   and "target (initial B) (right_path p) = q2"
    using paths_from_product_path[OF \<open>path ?P (initial ?P) p\<close>] \<open>target (initial ?P) p = (q1,q2)\<close> by auto

  moreover have "p_io (left_path p) = p_io (right_path p)" by auto
  moreover have "path (product A B) (initial (product A B)) (zip_path (left_path p) (right_path p))"
    using \<open>path ?P (initial ?P) p\<close> by auto
  moreover have "target (initial (product A B)) (zip_path (left_path p) (right_path p)) = (q1,q2)"
    using \<open>target (initial ?P) p = (q1,q2)\<close> by auto
  ultimately show ?thesis using that by blast
qed

lemma product_reachable_states[iff] :
  "(q1,q2) \<in> reachable_states (product A B) \<longleftrightarrow> (\<exists> p1 p2 . path A (initial A) p1 \<and> path B (initial B) p2 \<and> target (initial A) p1 = q1 \<and> target (initial B) p2 = q2 \<and> p_io p1 = p_io p2)"
proof
  show "(q1,q2) \<in> reachable_states (product A B) \<Longrightarrow> (\<exists> p1 p2 . path A (initial A) p1 \<and> path B (initial B) p2 \<and> target (initial A) p1 = q1 \<and> target (initial B) p2 = q2 \<and> p_io p1 = p_io p2)"
    using product_reachable_state_paths[of q1 q2 A B] by blast
  show "(\<exists> p1 p2 . path A (initial A) p1 \<and> path B (initial B) p2 \<and> target (initial A) p1 = q1 \<and> target (initial B) p2 = q2 \<and> p_io p1 = p_io p2) \<Longrightarrow> (q1,q2) \<in> reachable_states (product A B)"
  proof -
    assume "(\<exists> p1 p2 . path A (initial A) p1 \<and> path B (initial B) p2 \<and> target (initial A) p1 = q1 \<and> target (initial B) p2 = q2 \<and> p_io p1 = p_io p2)"
    then obtain p1 p2 where "path A (initial A) p1 \<and> path B (initial B) p2 \<and> target (initial A) p1 = q1 \<and> target (initial B) p2 = q2 \<and> p_io p1 = p_io p2"
      by blast
    then show ?thesis
      using product_path_from_paths[of A p1 B p2] unfolding reachable_states_def
      by (metis (mono_tags, lifting) mem_Collect_eq)
  qed
qed

lemma left_path_zip : "length p1 = length p2 \<Longrightarrow> left_path (zip_path p1 p2) = p1"
  by (induction p1 p2 rule: list_induct2; simp)

lemma right_path_zip : "length p1 = length p2 \<Longrightarrow> p_io p1 = p_io p2 \<Longrightarrow> right_path (zip_path p1 p2) = p2"
  by (induction p1 p2 rule: list_induct2; simp)

lemma zip_path_append_left_right : "length p1 = length p2 \<Longrightarrow> zip_path (p1@(left_path p)) (p2@(right_path p)) = (zip_path p1 p2)@p"
proof (induction p1 p2 rule: list_induct2)
  case Nil
  then show ?case by (induction p; simp)
next
  case (Cons x xs y ys)
  then show ?case by simp
qed

lemma product_path:
  "path (product A B) (q1,q2) p \<longleftrightarrow> (path A q1 (left_path p) \<and> path B q2 (right_path p))"
proof (induction p arbitrary: q1 q2)
  case Nil
  then show ?case by auto
next
  case (Cons t p)

  have "path (Product_FSM.product A B) (q1, q2) (t # p) \<Longrightarrow> (path A q1 (left_path (t # p)) \<and> path B q2 (right_path (t # p)))"
  proof -
    assume "path (Product_FSM.product A B) (q1, q2) (t # p)"
    then obtain x y qA' qB' where "t = ((q1,q2),x,y,(qA',qB'))" using prod.collapse
      by (metis path_cons_elim)
    then have "((q1,q2),x,y,(qA',qB')) \<in> transitions (product A B)"
      using \<open>path (Product_FSM.product A B) (q1, q2) (t # p)\<close> by auto
    then have "(q1, x, y, qA') \<in> FSM.transitions A" and "(q2, x, y, qB') \<in> FSM.transitions B"
      unfolding product_transitions_def by blast+
    moreover have "(path A qA' (left_path p) \<and> path B qB' (right_path p))"
      using Cons.IH[of qA' qB'] \<open>path (Product_FSM.product A B) (q1, q2) (t # p)\<close> unfolding \<open>t = ((q1,q2),x,y,(qA',qB'))\<close> by auto
    ultimately show ?thesis
      unfolding \<open>t = ((q1,q2),x,y,(qA',qB'))\<close>
      by (simp add: path_prepend_t)
  qed

  moreover have "path A q1 (left_path (t # p)) \<Longrightarrow> path B q2 (right_path (t # p)) \<Longrightarrow> path (Product_FSM.product A B) (q1, q2) (t # p)"
  proof -
    assume "path A q1 (left_path (t # p))" and "path B q2 (right_path (t # p))"
    then obtain x y qA' qB' where "t = ((q1,q2),x,y,(qA',qB'))" using prod.collapse
      by (metis (no_types, lifting) fst_conv list.simps(9) path_cons_elim)
    then have "(q1, x, y, qA') \<in> FSM.transitions A" and "(q2, x, y, qB') \<in> FSM.transitions B"
      using \<open>path A q1 (left_path (t # p))\<close> \<open>path B q2 (right_path (t # p))\<close> by auto
    then have "((q1,q2),x,y,(qA',qB')) \<in> transitions (product A B)"
      unfolding product_transitions_def by blast
    moreover have "path (Product_FSM.product A B) (qA', qB') p"
      using Cons.IH[of qA' qB'] \<open>path A q1 (left_path (t # p))\<close> \<open>path B q2 (right_path (t # p))\<close> unfolding \<open>t = ((q1,q2),x,y,(qA',qB'))\<close> by auto
    ultimately show "path (Product_FSM.product A B) (q1, q2) (t # p)"
      unfolding \<open>t = ((q1,q2),x,y,(qA',qB'))\<close>
      by (simp add: path_prepend_t)
  qed

  ultimately show ?case by force
qed

lemma product_path_rev:
  assumes "p_io p1 = p_io p2"
  shows "path (product A B) (q1,q2) (zip_path p1 p2) \<longleftrightarrow> (path A q1 p1 \<and> path B q2 p2)"
proof -
  have "length p1 = length p2" using assms
    using map_eq_imp_length_eq by blast
  then have "(map (\<lambda> t . (fst (t_source t), t_input t, t_output t, fst (t_target t))) (map (\<lambda> t . ((t_source (fst t), t_source (snd t)), t_input (fst t), t_output (fst t), (t_target (fst t), t_target (snd t)))) (zip p1 p2))) = p1"
    by (induction p1 p2 arbitrary: q1 q2 rule: list_induct2; auto)

  moreover have "(map (\<lambda> t . (snd (t_source t), t_input t, t_output t, snd (t_target t))) (map (\<lambda> t . ((t_source (fst t), t_source (snd t)), t_input (fst t), t_output (fst t), (t_target (fst t), t_target (snd t)))) (zip p1 p2))) = p2"
    using \<open>length p1 = length p2\<close> assms by (induction p1 p2 arbitrary: q1 q2 rule: list_induct2; auto)

  ultimately show ?thesis using product_path[of A B q1 q2 "(map (\<lambda> t . ((t_source (fst t), t_source (snd t)), t_input (fst t), t_output (fst t), (t_target (fst t), t_target (snd t)))) (zip p1 p2))"]
    by auto
qed

lemma product_language_state :
  shows "LS (product A B) (q1,q2) = LS A q1 \<inter> LS B q2"
proof
  show "LS (product A B) (q1, q2) \<subseteq> LS A q1 \<inter> LS B q2"
  proof
    fix io assume "io \<in> LS (product A B) (q1, q2)"
    then obtain p where "io = p_io p"
                    and "path (product A B) (q1,q2) p"
      by auto
    then obtain p1 p2 where "path A q1 p1"
                        and "path B q2 p2"
                        and "io = p_io p1"
                        and "io = p_io p2"
      using product_path[of A B q1 q2 p] by fastforce
    then show "io \<in> LS A q1 \<inter> LS B q2"
      unfolding LS.simps by blast
  qed

  show "LS A q1 \<inter> LS B q2 \<subseteq> LS (product A B) (q1, q2)"
  proof
    fix io assume "io \<in> LS A q1 \<inter> LS B q2"
    then obtain p1 p2 where "path A q1 p1"
                        and "path B q2 p2"
                        and "io = p_io p1"
                        and "io = p_io p2"
                        and "p_io p1 = p_io p2"
      by auto

    let ?p = "zip_path p1 p2"

    have "length p1 = length p2"
      using \<open>p_io p1 = p_io p2\<close> map_eq_imp_length_eq by blast
    moreover have "p_io ?p = p_io (map fst (zip p1 p2))" by auto
    ultimately have "p_io ?p = p_io p1" by auto

    then have "p_io ?p = io"
      using \<open>io = p_io p1\<close> by auto
    moreover have "path (product A B) (q1, q2) ?p"
      using product_path_rev[OF \<open>p_io p1 = p_io p2\<close>, of A B q1 q2] \<open>path A q1 p1\<close> \<open>path B q2 p2\<close> by auto
    ultimately show "io \<in> LS (product A B) (q1, q2)"
      unfolding LS.simps by blast
  qed
qed

lemma product_language : "L (product A B) = L A \<inter> L B"
  unfolding product_simps product_language_state by blast

lemma product_transition_split_ob :
  assumes "t \<in> transitions (product A B)"
  obtains t1 t2
  where "t1 \<in> transitions A \<and> t_source t1 = fst (t_source t) \<and> t_input t1 = t_input t \<and> t_output t1 = t_output t \<and> t_target t1 = fst (t_target t)"
    and "t2 \<in> transitions B \<and> t_source t2 = snd (t_source t) \<and> t_input t2 = t_input t \<and> t_output t2 = t_output t \<and> t_target t2 = snd (t_target t)"
  using assms unfolding product_transitions_alt_def
  by auto

lemma product_transition_split :
  assumes "t \<in> transitions (product A B)"
  shows "(fst (t_source t), t_input t, t_output t, fst (t_target t)) \<in> transitions A"
    and "(snd (t_source t), t_input t, t_output t, snd (t_target t)) \<in> transitions B"
  using product_transition_split_ob[OF assms] prod.collapse by fastforce+

lemma  product_target_split:
  assumes "target (q1,q2) p = (q1',q2')"
  shows "target q1 (left_path p) = q1'"
    and "target q2 (right_path p) = q2'"
using assms by (induction p arbitrary: q1 q2; force)+

lemma target_single_transition[simp] : "target q1 [(q1, x, y, q1')] = q1'"
  by auto

lemma product_undefined_input :
  assumes "\<not> (\<exists> t \<in> transitions (product (from_FSM M q1) (from_FSM M q2)).
               t_source t = qq \<and> t_input t = x)"
  and "q1 \<in> states M"
  and "q2 \<in> states M"
shows "\<not> (\<exists> t1 \<in> transitions M. \<exists> t2 \<in> transitions M.
                 t_source t1 = fst qq \<and>
                 t_source t2 = snd qq \<and>
                 t_input t1 = x \<and> t_input t2 = x \<and> t_output t1 = t_output t2)"
proof
  assume "\<exists> t1 \<in> transitions M. \<exists> t2 \<in> transitions M.
                 t_source t1 = fst qq \<and>
                 t_source t2 = snd qq \<and>
                 t_input t1 = x \<and> t_input t2 = x \<and> t_output t1 = t_output t2"
  then obtain t1 t2 where "t1 \<in> transitions M"
                      and "t2 \<in> transitions M"
                      and "t_source t1 = fst qq"
                      and "t_source t2 = snd qq"
                      and "t_input t1 = x"
                      and "t_input t1 = t_input t2"
                      and "t_output t1 = t_output t2"
    by force

  have "((t_source t1, t_source t2), t_input t1, t_output t1, t_target t1, t_target t2) \<in> transitions (product (from_FSM M q1) (from_FSM M q2))"
    unfolding product_transitions_alt_def
    unfolding from_FSM_simps[OF assms(2)]
    unfolding from_FSM_simps[OF assms(3)]
    using \<open>t1 \<in> transitions M\<close> \<open>t2 \<in> transitions M\<close> \<open>t_input t1 = t_input t2\<close> \<open>t_output t1 = t_output t2\<close> by blast
  then show False
    unfolding \<open>t_source t1 = fst qq\<close> \<open>t_source t2 = snd qq\<close> \<open>t_input t1 = x\<close> prod.collapse
    using assms(1) by auto
qed

subsection \<open>Product Machines and Changing Initial States\<close>

lemma product_from_reachable_next :
  assumes "((q1,q2),x,y,(q1',q2')) \<in> transitions (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
  shows   "(from_FSM (product (from_FSM M q1) (from_FSM M q2)) (q1', q2')) = (product (from_FSM M q1') (from_FSM M q2'))"
          (is "?P1 = ?P2")
proof -
  have "(q1,x,y,q1') \<in> transitions (from_FSM M q1)"
  and  "(q2,x,y,q2') \<in> transitions (from_FSM M q2)"
    using assms(1) unfolding product_transitions_def by blast+
  then have "q1' \<in> states (from_FSM M q1)" and "q2' \<in> states (from_FSM M q2)"
    using fsm_transition_target by auto

  have "q1' \<in> states (from_FSM M q1')" and "q1' \<in> states M" and "q1 \<in> states M"
    using \<open>q1' \<in> FSM.states (FSM.from_FSM M q1)\<close> assms(2) reachable_state_is_state by fastforce+
  have "q2' \<in> states (from_FSM M q2')" and "q2' \<in> states M" and "q2 \<in> states M"
    using \<open>q2' \<in> FSM.states (FSM.from_FSM M q2)\<close> assms(3) reachable_state_is_state by fastforce+

  have "initial ?P1 = initial ?P2"
  and  "states ?P1 = states ?P2"
  and  "inputs ?P1 = inputs ?P2"
  and  "outputs ?P1 = outputs ?P2"
  and  "transitions ?P1 = transitions ?P2"
    using from_FSM_simps[OF fsm_transition_target[OF assms(1)]]
    unfolding snd_conv
    unfolding product_simps
    unfolding product_transitions_def
    unfolding from_FSM_simps[OF \<open>q1' \<in> states M\<close>] from_FSM_simps[OF \<open>q2' \<in> states M\<close>]
    unfolding from_FSM_simps[OF \<open>q1 \<in> states M\<close>] from_FSM_simps[OF \<open>q2 \<in> states M\<close>]
    by auto

  then show ?thesis by (transfer; auto)
qed

lemma from_FSM_product_inputs :
  assumes "q1 \<in> states M" and "q2 \<in> states M"
shows "(inputs (product (from_FSM M q1) (from_FSM M q2))) = (inputs M)"
  by (simp add: assms(1) assms(2))

lemma from_FSM_product_outputs :
  assumes "q1 \<in> states M" and "q2 \<in> states M"
shows "(outputs (product (from_FSM M q1) (from_FSM M q2))) = (outputs M)"
  by (simp add: assms(1) assms(2))

lemma from_FSM_product_initial :
  assumes "q1 \<in> states M" and "q2 \<in> states M"
shows "initial (product (from_FSM M q1) (from_FSM M q2)) = (q1,q2)"
  by (simp add: assms(1) assms(2))

lemma product_from_reachable_next' :
  assumes "t \<in> transitions (product (from_FSM M (fst (t_source t))) (from_FSM M (snd (t_source t))))"
  and     "fst (t_source t) \<in> states M"
  and     "snd (t_source t) \<in> states M"
shows "(from_FSM (product (from_FSM M (fst (t_source t))) (from_FSM M (snd (t_source t)))) (fst (t_target t),snd (t_target t))) = (product (from_FSM M (fst (t_target t))) (from_FSM M (snd (t_target t))))"
proof -
  have "((fst (t_source t), snd (t_source t)), t_input t, t_output t, fst (t_target t), snd (t_target t)) = t"
    by simp
  then show ?thesis
    by (metis (no_types) assms(1) assms(2) assms(3) product_from_reachable_next)
qed

lemma product_from_reachable_next'_path :
  assumes "t \<in> transitions (product (from_FSM M (fst (t_source t))) (from_FSM M (snd (t_source t))))"
  and     "fst (t_source t) \<in> states M"
  and     "snd (t_source t) \<in> states M"
  shows "path (from_FSM (product (from_FSM M (fst (t_source t))) (from_FSM M (snd (t_source t)))) (fst (t_target t),snd (t_target t))) (fst (t_target t),snd (t_target t)) p = path (product (from_FSM M (fst (t_target t))) (from_FSM M (snd (t_target t)))) (fst (t_target t),snd (t_target t)) p"
    (is "path ?P1 ?q p = path ?P2 ?q p")
proof -
  have i1: "initial ?P1 = ?q"
    using assms(1) fsm_transition_target by fastforce
  have i2: "initial ?P2 = ?q"
  proof -
    have "((fst (t_source t), snd (t_source t)), t_input t, t_output t, fst (t_target t), snd (t_target t)) = t"
      by auto
    then show ?thesis
      by (metis (no_types) assms(1) assms(2) assms(3) i1 product_from_reachable_next)
  qed

  have h12: "transitions ?P1 = transitions ?P2" using product_from_reachable_next'[OF assms] by simp

  show ?thesis proof (induction p rule: rev_induct)
    case Nil
    then show ?case
      by (metis (full_types) i1 i2 fsm_initial path.nil)
  next
    case (snoc t p)
    show ?case
      by (metis h12 path_append_transition path_append_transition_elim(1) path_append_transition_elim(2) path_append_transition_elim(3) snoc.IH)
  qed
qed

lemma product_from_transition:
  assumes "(q1',q2') \<in> states (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
shows "transitions (product (from_FSM M q1') (from_FSM M q2')) = transitions (product (from_FSM M q1) (from_FSM M q2))"
proof -
  have "q1' \<in> states M" and "q2' \<in> states M"
    using assms(1) unfolding product_simps from_FSM_simps[OF assms(2)] from_FSM_simps[OF assms(3)] by auto
  show ?thesis
    unfolding product_transitions_def from_FSM_simps[OF \<open>q1 \<in> states M\<close>] from_FSM_simps[OF \<open>q1' \<in> states M\<close>] from_FSM_simps[OF \<open>q2 \<in> states M\<close>] from_FSM_simps[OF \<open>q2' \<in> states M\<close>] by blast
qed

lemma product_from_path:
  assumes "(q1',q2') \<in> states (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
      and "path (product (from_FSM M q1') (from_FSM M q2')) (q1',q2') p"
    shows "path (product (from_FSM M q1) (from_FSM M q2)) (q1',q2') p"
  by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) from_FSM_path_initial from_FSM_simps(5) from_from mem_Sigma_iff product_path product_simps(2))

lemma product_from_path_previous :
  assumes "path (product (from_FSM M (fst (t_target t)))
                         (from_FSM M (snd (t_target t))))
                (t_target t) p"                                           (is "path ?Pt (t_target t) p")
      and "t \<in> transitions (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
    shows "path (product (from_FSM M q1) (from_FSM M q2)) (t_target t) p" (is "path ?P (t_target t) p")
  by (metis assms(1) assms(2) assms(3) assms(4) fsm_transition_target prod.collapse product_from_path)

lemma product_from_transition_shared_state :
  assumes "t \<in> transitions (product (from_FSM M q1') (from_FSM M q2'))"
  and     "(q1',q2') \<in> states (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
shows "t \<in> transitions (product (from_FSM M q1) (from_FSM M q2))"
  by (metis assms product_from_transition)

lemma product_from_not_completely_specified :
  assumes "\<not> completely_specified_state (product (from_FSM M q1) (from_FSM M q2)) (q1',q2')"
  and     "(q1',q2') \<in> states (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
    shows  "\<not> completely_specified_state (product (from_FSM M q1') (from_FSM M q2')) (q1',q2')"
proof -
  have "q1' \<in> states M" and "q2' \<in> states M"
    using assms(2) unfolding product_simps from_FSM_simps[OF assms(3)] from_FSM_simps[OF assms(4)] by auto
  show ?thesis

    using from_FSM_product_inputs[OF assms(3) assms(4)]
    using from_FSM_product_inputs[OF \<open>q1' \<in> states M\<close> \<open>q2' \<in> states M\<close> ]
  proof -
    have "FSM.transitions (Product_FSM.product (FSM.from_FSM M q1') (FSM.from_FSM M q2')) = FSM.transitions (Product_FSM.product (FSM.from_FSM M q1) (FSM.from_FSM M q2))"
      by (metis (no_types) \<open>(q1', q2') \<in> FSM.states (Product_FSM.product (FSM.from_FSM M q1) (FSM.from_FSM M q2))\<close> assms(3) assms(4) product_from_transition)
    then show ?thesis
      using \<open>FSM.inputs (Product_FSM.product (FSM.from_FSM M q1') (FSM.from_FSM M q2')) = FSM.inputs M\<close> \<open>FSM.inputs (Product_FSM.product (FSM.from_FSM M q1) (FSM.from_FSM M q2)) = FSM.inputs M\<close> \<open>\<not> completely_specified_state (Product_FSM.product (FSM.from_FSM M q1) (FSM.from_FSM M q2)) (q1', q2')\<close> by fastforce
  qed
qed

lemma from_product_initial_paths_ex :
  assumes "q1 \<in> states M"
  and     "q2 \<in> states M"
shows  "(\<exists>p1 p2.
         path (from_FSM M q1) (initial (from_FSM M q1)) p1 \<and>
         path (from_FSM M q2) (initial (from_FSM M q2)) p2 \<and>
         target (initial (from_FSM M q1)) p1 = q1 \<and>
         target (initial (from_FSM M q2)) p2 = q2 \<and> p_io p1 = p_io p2)"
proof -
  have "path (from_FSM M q1) (initial (from_FSM M q1)) []" by blast
  moreover have "path (from_FSM M q2) (initial (from_FSM M q2)) []" by blast
  moreover have "
         target (initial (from_FSM M q1)) [] = q1 \<and>
         target (initial (from_FSM M q2)) [] = q2 \<and> p_io [] = p_io []"
    unfolding from_FSM_simps[OF assms(1)] from_FSM_simps[OF assms(2)] by auto
  ultimately show ?thesis by blast
qed

lemma product_observable :
  assumes "observable M1"
  and     "observable M2"
shows "observable (product M1 M2)" (is "observable ?P")
proof -
  have "\<And> t1 t2 . t1 \<in> transitions ?P \<Longrightarrow> t2 \<in> transitions ?P \<Longrightarrow> t_source t1 = t_source t2 \<Longrightarrow> t_input t1 = t_input t2 \<Longrightarrow> t_output t1 = t_output t2 \<Longrightarrow> t_target t1 = t_target t2"
  proof -
    fix t1 t2 assume "t1 \<in> transitions ?P" and "t2 \<in> transitions ?P" and "t_source t1 = t_source t2" and "t_input t1 = t_input t2" and "t_output t1 = t_output t2"

    let ?t1L = "(fst (t_source t1), t_input t1, t_output t1, fst (t_target t1))"
    let ?t1R = "(snd (t_source t1), t_input t1, t_output t1, snd (t_target t1))"
    let ?t2L = "(fst (t_source t2), t_input t2, t_output t2, fst (t_target t2))"
    let ?t2R = "(snd (t_source t2), t_input t2, t_output t2, snd (t_target t2))"

    have "t_target ?t1L = t_target ?t2L"
      using product_transition_split(1)[OF \<open>t1 \<in> transitions ?P\<close>]
            product_transition_split(1)[OF \<open>t2 \<in> transitions ?P\<close>]
            \<open>observable M1\<close>
            \<open>t_source t1 = t_source t2\<close>
            \<open>t_input t1 = t_input t2\<close>
            \<open>t_output t1 = t_output t2\<close> by auto
    moreover have "t_target ?t1R = t_target ?t2R"
      using product_transition_split(2)[OF \<open>t1 \<in> transitions ?P\<close>]
            product_transition_split(2)[OF \<open>t2 \<in> transitions ?P\<close>]
            \<open>observable M2\<close>
            \<open>t_source t1 = t_source t2\<close>
            \<open>t_input t1 = t_input t2\<close>
            \<open>t_output t1 = t_output t2\<close> by auto
    ultimately show "t_target t1 = t_target t2"
      by (metis prod.exhaust_sel snd_conv)
  qed
  then show ?thesis unfolding observable.simps by blast
qed

lemma product_observable_self_transitions :
  assumes "q \<in> reachable_states (product M M)"
  and     "observable M"
shows "fst q = snd q"
proof -
  let ?P = "product M M"

  have "\<And> p . path ?P (initial ?P) p \<Longrightarrow> fst (target (initial ?P) p) = snd (target (initial ?P) p)"
  proof -
    fix p assume "path ?P (initial ?P) p"
    then show "fst (target (initial ?P) p) = snd (target (initial ?P) p)"
    proof (induction p rule: rev_induct)
      case Nil
      then show ?case by simp
    next
      case (snoc t p)

      have "path ?P (initial ?P) p" and "path ?P (target (initial ?P) p) [t]"
        using path_append_elim[of ?P "initial ?P" p "[t]", OF \<open>path (product M M) (initial (product M M)) (p @ [t])\<close>] by blast+
      then have "t \<in> transitions ?P"
        by blast
      have "t_source t = target (initial ?P) p"
        using snoc.prems by fastforce

      let ?t1 = "(fst (t_source t), t_input t, t_output t, fst (t_target t))"
      let ?t2 = "(snd (t_source t), t_input t, t_output t, snd (t_target t))"
      have "?t1 \<in> transitions M" and "?t2 \<in> transitions M"
        using product_transition_split[OF \<open>t \<in> transitions ?P\<close>] by auto
      moreover have "t_source ?t1 = t_source ?t2"
        using \<open>t_source t = target (initial ?P) p\<close> snoc.IH[OF \<open>path ?P (initial ?P) p\<close>]
        by (metis fst_conv)
      moreover have "t_input ?t1 = t_input ?t2"
        by auto
      moreover have "t_output ?t1 = t_output ?t2"
        by auto
      ultimately have "t_target ?t1 = t_target ?t2"
        using \<open>observable M\<close> unfolding observable.simps by blast
      then have "fst (t_target t) = snd (t_target t)"
        by auto
      then show ?case unfolding target.simps visited_states.simps
      proof -
        show "fst (last (initial (product M M) # map t_target (p @ [t]))) = snd (last (initial (product M M) # map t_target (p @ [t])))"
          using \<open>fst (t_target t) = snd (t_target t)\<close> last_map last_snoc length_append_singleton length_map by force
      qed
    qed
  qed

  then show ?thesis
    using assms(1) unfolding reachable_states_def
    by blast
qed

lemma zip_path_eq_left :
  assumes "length xs1 = length xs2"
  and     "length xs2 = length ys1"
  and     "length ys1 = length ys2"
  and     "zip_path xs1 xs2 = zip_path ys1 ys2"
shows "xs1 = ys1"
  using assms by (induction xs1 xs2 ys1 ys2 rule: list_induct4; auto)

lemma zip_path_eq_right :
  assumes "length xs1 = length xs2"
  and     "length xs2 = length ys1"
  and     "length ys1 = length ys2"
  and     "p_io xs2 = p_io ys2"
  and     "zip_path xs1 xs2 = zip_path ys1 ys2"
shows "xs2 = ys2"
  using assms by (induction xs1 xs2 ys1 ys2 rule: list_induct4; auto)

lemma zip_path_merge :
  "(zip_path (left_path p) (right_path p)) = p"
  by (induction p; auto)

lemma product_from_reachable_path' :
  assumes "path (product (from_FSM M q1) (from_FSM M q2)) (q1', q2') p"
  and     "q1 \<in> reachable_states M"
  and     "q2 \<in> reachable_states M"
shows "path (product (from_FSM M q1') (from_FSM M q2')) (q1', q2') p"
  by (meson assms(1) assms(2) assms(3) from_FSM_path from_FSM_path_rev_initial product_path reachable_state_is_state)

lemma product_from :
  assumes "q1 \<in> states M"
  and     "q2 \<in> states M"
shows "product (from_FSM M q1) (from_FSM M q2) = from_FSM (product M M) (q1,q2)" (is "?PF = ?FP")
proof -
  have "(q1,q2) \<in> states (product M M)"
    using assms unfolding product_simps by auto

  have "initial ?FP = initial ?PF"
  and  "inputs ?FP = inputs ?PF"
  and  "outputs ?FP = outputs ?PF"
  and  "states ?FP = states ?PF"
  and  "transitions ?FP = transitions ?PF"
    unfolding product_simps
              from_FSM_simps[OF assms(1)]
              from_FSM_simps[OF assms(2)]
              from_FSM_simps[OF \<open>(q1,q2) \<in> states (product M M)\<close>]
              product_transitions_def
    by auto
  then show ?thesis by (transfer; auto)
qed

lemma product_from_from :
  assumes "(q1',q2') \<in> states (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
shows "(product (from_FSM M q1') (from_FSM M q2')) = (from_FSM (product (from_FSM M q1) (from_FSM M q2)) (q1',q2'))"
  using product_from
  by (metis (no_types, lifting) assms(1) assms(2) assms(3) from_FSM_simps(5) from_from mem_Sigma_iff product_simps(2))

lemma submachine_transition_product_from :
  assumes "is_submachine S (product (from_FSM M q1) (from_FSM M q2))"
  and     "((q1,q2),x,y,(q1',q2')) \<in> transitions S"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
 shows "is_submachine (from_FSM S (q1',q2')) (product (from_FSM M q1') (from_FSM M q2'))"
proof -
  have "((q1,q2),x,y,(q1',q2')) \<in> transitions (product (from_FSM M q1) (from_FSM M q2))"
    using assms(1) assms(2) by auto
  have "(q1',q2') \<in> states S" using fsm_transition_target assms(2) by auto
  show ?thesis
    using product_from_reachable_next[OF \<open>((q1,q2),x,y,(q1',q2')) \<in> transitions (product (from_FSM M q1) (from_FSM M q2))\<close> assms(3,4)]
          submachine_from[OF assms(1) \<open>(q1',q2') \<in> states S\<close>]
    by simp
qed

lemma submachine_transition_complete_product_from :
  assumes "is_submachine S (product (from_FSM M q1) (from_FSM M q2))"
      and "completely_specified S"
      and "((q1,q2),x,y,(q1',q2')) \<in> transitions S"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
 shows "completely_specified (from_FSM S (q1',q2'))"
proof -
  let ?P = "(product (from_FSM M q1) (from_FSM M q2))"
  let ?P' = "(product (from_FSM M q1') (from_FSM M q2'))"
  let ?F = "(from_FSM S (q1',q2'))"

  have "initial ?P = (q1,q2)"
    by (simp add: assms(4) assms(5) reachable_state_is_state)

  then have "initial S = (q1,q2)"
    using assms(1) by (metis is_submachine.simps)
  then have "(q1',q2') \<in> states S"
    using assms(3)
    using fsm_transition_target by fastforce
  then have "states ?F = states S"
    using from_FSM_simps(5) by simp
  moreover have "inputs ?F = inputs S"
    using from_FSM_simps(2) \<open>(q1',q2') \<in> states S\<close> by simp
  ultimately show "completely_specified ?F"
    using assms(2) unfolding completely_specified.simps
    by (meson assms(2) completely_specified.elims(2) from_FSM_completely_specified)
qed

subsection \<open>Calculating Acyclic Intersection Languages\<close>

lemma acyclic_product :
  assumes "acyclic B"
  shows "acyclic (product A B)"
proof -
  show "acyclic (product A B)"
  proof (rule ccontr)
    assume "\<not> FSM.acyclic (Product_FSM.product A B)"
    then obtain p where "path (product A B) (initial (product A B)) p" and "\<not> distinct (visited_states (initial (product A B)) p)"
      by auto

    have "path B (initial B) (right_path p)"
      using product_path[of A B] \<open>path (product A B) (initial (product A B)) p\<close>
      unfolding product_simps
      by auto

    moreover have "\<not> distinct (visited_states (initial B) (right_path p))"
    proof -
      obtain i j where "i < j" and "j < length ((initial A, initial B) # map t_target p)" and "((initial A, initial B) # map t_target p) ! i = ((initial A, initial B) # map t_target p) ! j"
        using \<open>\<not> distinct (visited_states (initial (product A B)) p)\<close>
        unfolding visited_states.simps product_simps
        using non_distinct_repetition_indices by blast

      then have "snd (((initial A, initial B) # map t_target p) ! i) = snd (((initial A, initial B) # map t_target p) ! j)"
        by simp

      have * :"i < length ((initial B) # map t_target (right_path p))"
      and  **:"j < length ((initial B) # map t_target (right_path p))"
        using \<open>i < j\<close> \<open>j < length ((initial A, initial B) # map t_target p)\<close> by auto

      have right_nth: "\<And> i . i < length ((initial B) # map t_target (right_path p)) \<Longrightarrow> ((initial B) # map t_target (right_path p)) ! i = snd (((initial A, initial B) # map t_target p) ! i)"
      proof -
        have "((initial B) # map t_target (right_path p)) ! 0 = snd (((initial A, initial B) # map t_target p) ! 0)"
          by simp
        moreover have "\<And> i . Suc i < length ((initial B) # map t_target (right_path p)) \<Longrightarrow> ((initial B) # map t_target (right_path p)) ! Suc i = snd (((initial A, initial B) # map t_target p) ! Suc i)"
          by auto
        ultimately show "\<And> i . i < length ((initial B) # map t_target (right_path p)) \<Longrightarrow> ((initial B) # map t_target (right_path p)) ! i = snd (((initial A, initial B) # map t_target p) ! i)"
          using less_Suc_eq_0_disj by auto
      qed

      have "((initial B) # map t_target (right_path p)) ! i = ((initial B) # map t_target (right_path p)) ! j"
        using \<open>snd (((initial A, initial B) # map t_target p) ! i) = snd (((initial A, initial B) # map t_target p) ! j)\<close>
        unfolding right_nth[OF *] right_nth[OF **]
        by assumption
      then show ?thesis
        unfolding visited_states.simps product_simps
        using non_distinct_repetition_indices_rev[OF \<open>i < j\<close> **] by blast
    qed
    ultimately show "False"
      using \<open>acyclic B\<close> unfolding acyclic.simps by blast
  qed
qed

lemma acyclic_product_path_length :
  assumes "acyclic B"
  and     "path (product A B) (initial (product A B)) p"
shows "length p < size B"
proof -
  have *:"path B (initial B) (right_path p)"
    using product_path[of A B] \<open>path (product A B) (initial (product A B)) p\<close>
    unfolding product_simps
    by auto
  then have **: "distinct (visited_states (initial B) (right_path p))"
    using assms unfolding acyclic.simps by blast

  have "length (right_path p) < size B"
    using acyclic_path_length_limit[OF * **] by assumption
  then show "length p < size B"
    by auto
qed

lemma acyclic_language_alt_def :
  assumes "acyclic A"
  shows "image p_io (acyclic_paths_up_to_length A (initial A) (size A - 1)) = L A"
proof -
  let ?ps = "acyclic_paths_up_to_length A (initial A) (size A - 1)"
  have "\<And> p . path A (initial A) p \<Longrightarrow> length p \<le> FSM.size A - 1"
    using acyclic_path_length_limit assms unfolding acyclic.simps
    by fastforce
  then have "?ps = {p. path A (initial A) p}"
    using assms unfolding acyclic_paths_up_to_length.simps acyclic.simps by blast
  then show ?thesis unfolding LS.simps by blast
qed

definition acyclic_language_intersection :: "('a,'b,'c) fsm \<Rightarrow> ('d,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set" where
  "acyclic_language_intersection M A = (let P = product M A in image p_io (acyclic_paths_up_to_length P (initial P) (size A - 1)))"

lemma acyclic_language_intersection_completeness :
  assumes "acyclic A"
  shows "acyclic_language_intersection M A = L M \<inter> L A"
proof -
  let ?P = "product M A"
  let ?ps = "acyclic_paths_up_to_length ?P (initial ?P) (size A - 1)"

  have "L ?P = L M \<inter> L A"
    using product_language by blast

  have "\<And> p . path ?P (initial ?P) p \<Longrightarrow> length p \<le> FSM.size A - 1"
    using acyclic_product_path_length[OF assms]
    by fastforce
  then have "?ps = {p. path ?P (initial ?P) p}"
    using acyclic_product[OF assms] unfolding acyclic_paths_up_to_length.simps acyclic.simps by blast
  then have "image p_io ?ps = L ?P"
    unfolding LS.simps by blast
  then show ?thesis
    using product_language unfolding acyclic_language_intersection_def Let_def by blast
qed

end


theory FreePlane
  imports Chapter2 (* Jordan_Normal_Form.Matrix *)
(* Need to somehow import AFP first; see https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2018-February/msg00129.html*)

begin
text \<open>\begin{hartshorne}
Example (A non-Desarguesian projective plane). Let $\pi_0$ be four points and no lines.
Let $\Pi$ be the free projective plane generated by $\pi_0.$ Note, as a Corollary of the previous
proposition, that $\Pi$ is infinite, and so every line contains infinitely many points. Thus
it is possible to choose $O,A,B,C,$ no three collinear, $A'$ on $OA,$ $B'$ on $OB,$ $C'$ on $OC,$ such
that they form 7 distinct points and $A', B', C'$ are not collinear. Then construct
\begin{align*}
P &= AB \cdot A'B'\\
Q &= AC \cdot A'C'\\
R &= BC \cdot B'C'.
\end{align*}

Check that all $10$ points are distinct. If Desargues’ Theorem is true in $\Pi,$ then $P,Q,R$
lie on a
line, hence these $10$ points and $10$ lines form a confined configuration, which
must lie in $\pi_0,$ and that's a contradiction,
 since $\pi_0$ has only four points.
\end{hartshorne}\<close>

text \<open>\spike
Modeling the free projective plane on a set of points is quite a pain in the neck. Hatshorne can
be glib, for instance, saying that if $l$ and $m$ don't intersect at level $n$, then we add a
new point called $l \cdot m$ at level $n+1$, but we need some actual representation of $l \cdot m$,
and when we try to construct once, we recognize that it must be ``the same'' as $m \cdot l$. So
we place an order on lines, and only construct the intersection of $l$ and $m$ when $l < m$; we
do the same for the line joining points $P $ and $Q$, which must be the same as the line joining
$Q$ and $P$.

The natural solution, in both cases, would be to use a constructor ``Join {P,Q}'', but it turns
out that I could not make ``Join fpoint set'' be a legal constructor description, and parenthesizing
was of no use either. Another possibility would be to define all possible (unordered) joins/meets,
and then build an equivalence relation and take quotients, but that seemed grim as well.

I've ignored lines that occur in the initial
configuration, as free projective planes appear only once more in the book, and it didn't seem
worth making this definition even more complex just to handle that one additional mention.

I've really constructed only the free projective plane on four points (defined in the
type "basepoint"), but this can clearly be extended to more points as needed.

There's one more divergence from the text: I'm really defining \emph{two} mutually recursive sets:
$\Pi_n$, the set of points in the $n$th version of the projective plane, and $\Lambda_n$, the set of
lines. My $\Pi_n$ is Hartshorne's $\pi_{2n}$; my $\Pi_n$, together with $\Lambda_n$ as the set of lines,
is Hartshorne's $\pi{2n+1}$. This has the advantage that each of these sequences of things has a
single natural-number index, rather than one being indexed by evens and one being indexed by odds;
this sets them up for a (mutual) induction of some sort.
\done\<close>
locale free_projective_plane_data =
    fixes meets :: "'point \<Rightarrow> 'line \<Rightarrow> bool"
begin
datatype basepoint = AA | BB | CC | DD

(* I need an order on basepoints to start an inductive definition of order on pairs of points,
and pairs of lines, etc. *)

fun lt:: "basepoint \<Rightarrow> basepoint \<Rightarrow> bool" where
    "lt AA BB = True"
  | "lt AA CC = True"
  | "lt AA DD = True"
  | "lt BB CC = True"
  | "lt BB DD = True"
  | "lt CC DD = True"
  | "lt U V = False"

lemma "antisymp lt"
  by (smt antisympI free_projective_plane_data.lt.elims(2) free_projective_plane_data.lt.simps(15) free_projective_plane_data.lt.simps(7))

lemma "transp lt"
  by (smt free_projective_plane_data.basepoint.exhaust lt.simps(2,3,5,10,12,13) transpI)

datatype fpoint = Basepoint nat basepoint | Intersect nat fline fline and
fline =  Join nat fpoint fpoint | Extend nat fline (* | Baseline nat baseline;  removed to simplify *)

text \<open>\spike
To clarify the typedefs above: the "nat" in each item is its "level" (in Hartshorne's terminology),
although I guess it's Hartshorne's level divided by two. And while this "level" can be any
natural number, we're actually going to build a final set of points, point_set, that contains
only certain special fpoints. For instance, Basepoints will only be included if their level is 0
(and all such Basepoints will be included). Intersect i k l will only be included if one of
k and l has level i-1, and if k and l don't intersect at level i-1,m and if k is "before" l in some
ordering that I'll define.

What about lines? Well, Join i P Q will only be included if at least one of P and Q has level i-1,
and P is before Q in a soon-to-be-defined ordering, AND if there's no line at level i-1 containing
both P and Q. The only slightly tricky one is "Extend i k". For that, k must already be an
fline at level i-1, but the semantics of Extend i k is that it contains all points of k (i.e., points
P such that "nmeets (i-1) P k") AND contains any level-i point P of the form Intersect i k m or
Intersect i m k.
\done\<close>

(* "less than" rules for points and lines. *)
fun plt:: "fpoint  \<Rightarrow> fpoint \<Rightarrow> bool"
     and llt:: "fline \<Rightarrow> fline \<Rightarrow> bool"
where
    "plt (Basepoint n P) (Basepoint k Q) = (lt P Q)"
  | "plt (Basepoint n P) (Intersect i l m) = True"
  | "plt (Intersect i l m) (Basepoint n P)  = False"
  | "plt (Intersect i l m) (Intersect j n p)
        = ((i < j) \<or>
           ((i = j) \<and> (llt l n)) \<or>
           ((i = j) \<and> (l = n) \<and> (llt m p)))"
  | "llt (Join i P Q)(Join j R S) = ((i < j) \<or>
                                     ((i = j) \<and> (plt P  R)) \<or>
                                     ((i = j) \<and> (P = R) \<and> (plt Q  S)))"
  | "llt (Join i P Q) (Extend j m) = (i \<le> j)"
  | "llt (Extend j m) (Join i P Q)  = (j < i)"
  | "llt (Extend i l) (Extend j m) = ((i < j) \<or>
                                       (i = j) \<and> (llt l m))"

(* Basepoints: the only "stage" (the 'nat' data) allowed is 0. For all flines, the 'nat' data is
  1 or more (now that I've gotten rid of Baselines)  *)
(* Use "s" for "stage" (i.e., the index in the construction process). I'll use i and j similarly *)

(* define a rule for when, at stage s, a particular point and line "meet". So (nmeets s) takes
points and lines at stage s and tells whether or not they meet.

Note that points whose stage is greater than s cannot meet a line at stage s.
On the other hand, a new point at stage s may be joined to a basepoint (stage 0 !) by a
new line at stage s, so lines at stage s may meet any point whose stage is s or less.

Finally, we have to define "stage s meeting" for *all* imaginable points and lines,
even if many will never be relevant (basepoints at level 3, for instance).
*)

(* Reminder of the type-defs:
datatype fpoint = Basepoint nat basepoint | Intersect nat fline fline and
fline =  Join nat fpoint fpoint | Extend nat fline (* | Baseline nat baseline removed to simplify *)
*)

fun nmeets :: "nat  \<Rightarrow> fpoint  \<Rightarrow> fline \<Rightarrow> bool" where
    "nmeets s (Basepoint i X) (Join j (Intersect ii u v)  (Intersect jj y z))  = False"
  | "nmeets s (Basepoint i X) (Join j (Basepoint u Y)  (Intersect jj y z))  = ((i = 0) \<and> (u = 0) \<and> (X = Y))"
  | "nmeets s (Basepoint i X) (Join j (Intersect ii u v)(Basepoint x Y) )  = ((i = 0) \<and> (x = 0) \<and> (X = Y))"
  | "nmeets s (Basepoint i X) (Join j (Basepoint u Z) (Basepoint v Y) )  = ((i = 0) \<and> ((u = 0) \<and> (X = Y)) \<or>
                                                                                ((v = 0) \<and> (X = Z)))"
  | "nmeets s (Basepoint i X) (Extend j l)  = ((i = 0) \<and> ((nmeets (s-1) (Basepoint i X) l)))"

  | "nmeets s (Intersect i k l) (Extend j m)  = ((i = j) \<and> ((k = m) \<or> (l = m)))"
  | "nmeets s (Intersect i l m) (Join j P Q)  = ((i = j) \<and>
                                                 ((P = (Intersect i l m)) \<or> (Q = (Intersect i l m))))"

fun is_config :: " 'point set  \<Rightarrow> 'line set  \<Rightarrow> ('point   \<Rightarrow> 'line  \<Rightarrow> bool) \<Rightarrow> bool" where
  "is_config Points Lines mmeets = (\<forall> k l P Q. (k \<in> Lines) \<and> (l \<in> Lines) \<and> (k \<noteq> l) \<and> (mmeets P k) \<and> (mmeets P l)
   \<and> mmeets Q k \<and> mmeets Q l \<longrightarrow> P = Q)"

datatype lline = LLine "fpoint set" (* limit line *)

fun Plevel:: "fpoint\<Rightarrow>nat" where
  "Plevel (Basepoint n x) = n " |
  "Plevel (Intersect n k l) = n"

fun Llevel:: "fline \<Rightarrow> nat" where
  "Llevel (Join n k l) = n" |
  "Llevel (Extend n l) = n"

text \<open>\spike
Now we'd like to build
(1) a set, PS, of points for the free projective plane (namely, the union of all the reasonable
points, i.e., basepoints or lines of the form Inter (l, m) where l is "less than" m, and they don't already
have points in common) and
(2) a set of lines, LS, (using the type lline), where a line in our geometry is actually a point set (imagine
that!) whose intersection with SOME level is a line at that level, and the same is true thereafter,

Now there's an observation about lines that Hartshorne doesn't mention: suppose that some line in
$\Pi$ (the free projective plane) intersects level $i$ in some line $k$. Then its intersection
with level $i+1$ must contain all the points that were in $k$, and possibly a few more, i.e.,
this intersection must be exactly "Extend (i+1) k". So our line in the free projective plane not only
meets each level in some line at that level, it meets the "same" line at every level (in the sense
that we keep extending k, etc.) And in fact these are the ONLY lines in the free projective plane.

To capture this notion, and the description of the ith point-set (which is a superset of
the $(i-1)$th point-set, and the description of the ith line-set (which \emph{replaces} the (i-1)th
line-set), we need a few predicates (which will be used to construct the set of items satisfying
the predicates).
\done\<close>

text \<open>\spike
First, something that tests, given the (i-1)th point- and line-sets, whether some
fpoint is in fact a "new point" that should be included in the ith point-set. For this to tbe
the case, there need to be lines k and l at level i-1 that do not meet, and X must be the "Intersect"
point constructed from these, and k must come before l in our order to ensure we don't get duplicates
(and to ensure that k and l are distinct).
\done\<close>

fun newPoint :: "nat  \<Rightarrow> fpoint set\<Rightarrow> fline set \<Rightarrow> fpoint \<Rightarrow> bool" where
 "newPoint i pts lines X = (\<exists>k l . (k \<in> lines) \<and> (l \<in> lines) \<and>
                            (X = Intersect i k l) \<and>
                            (llt k l) \<and>
                            (\<forall> P \<in> pts . \<not>(nmeets i P l \<and> nmeets i P k)))"

text \<open>\spike
Same kind of things for lines:
\done\<close>

fun newLine :: "nat  \<Rightarrow> fpoint set\<Rightarrow> fline set \<Rightarrow> fline \<Rightarrow> bool" where
 "newLine i pts lines k = (\<exists>P Q . (P \<in> pts) \<and> (Q \<in> pts) \<and>
                            (k = Join i P Q) \<and>
                            (plt P Q) \<and>
                            (\<forall> m \<in> lines . \<not>(nmeets (i-1) P m \<and> nmeets (i-1) Q m)))"
text \<open>\spike
Which "extended" lines should be included in the ith line-set? Extensions of lines that
were in the $i-1$th line-set!
\done\<close>

fun extendedLine :: "nat  \<Rightarrow> fpoint set\<Rightarrow> fline set \<Rightarrow> fline \<Rightarrow> bool" where
 "extendedLine i pts lines k = (\<exists>l . (l \<in> lines)  \<and>
                            (k = Extend i l))"

text \<open>\spike
And now we're ready to define the ith point-set and line-set:
\done\<close>

fun Pi:: "nat  \<Rightarrow> fpoint set"
     and Lambda:: "nat \<Rightarrow> fline set"
where
  "Pi 0 = {Basepoint 0 AA, Basepoint 0 BB, Basepoint 0 CC, Basepoint 0 DD }"
  | "Pi (Suc n) = Pi(n) \<union> Collect (newPoint (Suc n) (Pi n) (Lambda n)) "
  | "Lambda 0 = {}"
  | "Lambda (Suc n) = Collect (newLine (Suc n) (Pi n) (Lambda n)) \<union> Collect (extendedLine (Suc n) (Pi n) (Lambda n))"

text \<open>\spike
A line k "extends" a line n if they're equal, or if there's a chain of "Extends" constructors
leading from one to the other. So a Join fline never extends any line except itself.
\done\<close>
fun extends:: "fline \<Rightarrow> fline \<Rightarrow> bool" where
 "extends (Join i P Q) (Extend j n)  = False"  |
 "extends (Join i P Q) (Join j R S)  = ( (i = j) \<and> (P = R) \<and> (Q = S))" |
 "extends (Extend i n) (Join j R S)  = ( ((Join j R S) \<in> Lambda(j)) \<and> ((Extend i n) \<in> Lambda(i)) \<and>
                                         (j < i) \<and> (extends n (Join j R S)))" |
 "extends (Extend i n) (Extend j m)  = ( ((Extend j m) \<in> Lambda(j)) \<and> ((Extend i n) \<in> Lambda(i)) \<and>
                                         (j < i) \<and> (extends n m))"
text \<open>\spike
It's nice to be able to test whether an fpoint P lies on the extension of some fline. Why? Because
we're going to take each possible "Join" fline, build the set of points that lies on it, and that
SET will be a line in our free-projective-plane.
\done\<close>

fun lies_on_extension::"fpoint \<Rightarrow> fline \<Rightarrow> bool" where
 "lies_on_extension P (Extend j n)  = False"  |
 "lies_on_extension (Basepoint i XX) (Join j R S)  = ( (i = 0) \<and> (j = 1) \<and> ((R = Basepoint 0 XX)\<or> (S = Basepoint 0 XX)))" |
 "lies_on_extension (Intersect  i k n) (Join j R S)  = ( ((Join j R S) \<in> Lambda(j)) \<and> ((Intersect i k n ) \<in> Pi(i))
                                          \<and> ((extends k (Join j R S))\<or> (extends n (Join j R S))))"

fun line_points:: "fline \<Rightarrow> fpoint set" where
  "line_points (Join i P Q) = {P, Q}" |
  "line_points (Extend i k) = line_points(k) \<union> {X . \<exists>l . (l \<in> Lambda(i-1) \<and>
                            (X = Intersect i k l) \<and>
                            (llt k l) \<and>
                            (\<forall> P \<in> Pi(i) . \<not>(nmeets i P l \<and> nmeets i P k)))} \<union>
                                        {X . \<exists>l . (l \<in> Lambda(i-1) \<and>
                            (X = Intersect i l k) \<and>
                            (llt l k) \<and>
                            (\<forall> P \<in> Pi(i) . \<not>(nmeets i P l \<and> nmeets i P k)))}"

text \<open>\spike
We'll say that a point is "a limit point" if it lies in Pi(i) for some i. So the collection of
all limit points is exactly the point-set for the free projective plane.
\done\<close>
fun is_limit_point:: "fpoint  \<Rightarrow> bool" where
  "is_limit_point (Basepoint 0 X) = True" |
  "is_limit_point (Intersect i p q) = ((Intersect i p q) \<in> Pi(i))" |
  "is_limit_point Z = False"

definition PS where "PS = {X. is_limit_point(X)}"

text \<open>\spike
Now for an fline k, we'll define the "limit set of points" to be all points that lie on
any extension of k.
\done\<close>

fun lsp:: "fline \<Rightarrow> fpoint \<Rightarrow> bool" where
  "lsp k P = lies_on_extension P k"

text \<open>\spike
...and then we'll actually construct that set, which (for Join flines) will
constitute a line in the free projective plane.
\done\<close>

fun UU :: "fline \<Rightarrow> fpoint set" where
  "UU k = {P . lsp k P  }"

text \<open>\spike
Finally, we're ready to define our "line set", a point-set-set, where each
point-set is the limit-set-of-points for SOME Join-constructed fline:
\done\<close>

definition LS where
  "LS = {Z . \<exists>k i P Q . ((Z = UU k) \<and> (k = Join i P Q) \<and> (k \<in> Lambda i))}"

text \<open>\spike
In the free projective plane, where each line really IS just a subset of the set
of points, it's easy to define "meets".
\done\<close>

fun fmeets:: "fpoint  \<Rightarrow> fpoint set  \<Rightarrow> bool" where
 "fmeets P k = (P \<in> k)"

(* a few lemmas, like "every basepoint is actually a point of the free pp *)
lemma basepoints_in_PS:
  fixes P and X
  assumes "P \<in> PS"
  assumes "P = Basepoint i X"
  shows "(i = 0) \<and> (X= AA) \<or> (X=BB) \<or> (X=CC) \<or> (X= DD)"
proof -
  have i0: "i = 0"
  proof (rule ccontr)
    assume "i \<noteq> 0"
    have "P \<in>PS" using assms(1) by auto
    have A:"is_limit_point P" using PS_def assms(1) by blast
    have notA: "\<not>(is_limit_point P)"
      using \<open>i \<noteq> 0\<close> assms(2) free_projective_plane_data.is_limit_point.elims(2) by auto
    thus False using A notA by auto
  qed
  have "P = Basepoint 0 X" by (simp add: \<open>i = 0\<close> assms(2))
  have "(X= AA) \<or> (X=BB) \<or> (X=CC) \<or> (X= DD)"
    using free_projective_plane_data.basepoint.exhaust by blast
  thus ?thesis using i0 by blast
qed

text \<open>
\spike
We'd now like  to assert that \textbf{if} several things are true, namely
\begin{itemize}
\item if $U \in PS$ and $Plevel(U) = 0$, then $U = A,B,C,$ or $D$.
\item if $k \in LS$ then $Llevel(k) > 0$.
\item $Join (i P Q) \in LS$ implies that $P,Q \in PS, P \ne Q,  level(P) \le i, level(Q) \le i$
and $P$ comes before $Q$ in our lexicographic ordering.
\item $Intersect (i k m) \in PS$ implies that $k,m \in LS, k \ne m, level(k) < i, level(m) < i$,
and $k$ comes before $m$ in our lexicographic ordering
\end{itemize}
and a couple more that say that whenever two points aren't already on a line, their ``Join'' is in
the line-set, and the dual of this, \textbf{then} $LS$ and $PS$ cannot contain a Desargues configuration
because it'd have to be at level zero, which only contains four points.

Presumably we need some lemmas first, like "if P = Intersect (n k m) and level(l) < n, then NOT meets
P l" (i.e., k and m are the only lines of level less than n that intersect P).

But first, we really should show that this "free pp" really IS a projective plane... This proof is still
very much under construction. With luck, everything above here really is static, and I can
keep working on this in "FreePlane2", which is the same file, but without lots of text.
\done
\<close>

lemma fpp_a1a:
  fixes P and Q
  assumes "P \<in> PS"
  assumes "Q \<in> PS"
  assumes "P \<noteq> Q"
  shows "\<exists>l \<in> LS . fmeets P l \<and> fmeets Q l"
proof -
  show ?thesis
  proof (cases P)
    case (Basepoint i X)
    have "(i = 0) \<and> (X= AA) \<or> (X=BB) \<or> (X=CC) \<or> (X= DD)" using basepoints_in_PS Basepoint assms(1) by auto
    have Pform: "P = Basepoint 0 X"
      using Basepoint PS_def assms(1) free_projective_plane_data.is_limit_point.elims(2) by auto
    show ?thesis
      proof (cases Q)
        case (Basepoint j Y)
        have "(j = 0) \<and> (Y= AA) \<or> (Y=BB) \<or> (Y=CC) \<or> (Y= DD)" using basepoints_in_PS Basepoint assms(2) by auto
        have Qform: "Q = Basepoint 0 Y"
          using Basepoint PS_def assms(2) free_projective_plane_data.is_limit_point.elims(2) by auto
        then show ?thesis
        proof -
          have "X \<noteq> Y" using assms(3) Pform Qform by simp
          show ?thesis
          proof (cases "plt P Q")
            case True
            let ?k = "Join 1 P Q"
            let ?S = "UU ?k"
            have "fmeets P ?S" using fmeets.simps(1) UU.simps lsp.simps  by (simp add: Pform)
            have "fmeets Q ?S" using fmeets.simps(1) UU.simps lsp.simps  by (simp add: Qform)
  (*          have "Lambda 0 = {}" try
   "Lambda (Suc n) = Collect (newLine (Suc n) (Pi n) (Lambda n)) \<union> Collect (extendedLine (Suc n) (Pi n) (Lambda n))"
*)
            have L1a: "Lambda (1) = Collect (newLine (1) (Pi 0) (Lambda 0)) \<union> Collect (extendedLine (1) (Pi 0) (Lambda 0))" by simp
            have L1b: "Lambda (1) = Collect (newLine (1) (Pi 0) {}) \<union> Collect (extendedLine (1) (Pi 0) {})" by simp
            have p2emptyA: "\<forall> X . \<not> (extendedLine (1) (Pi 0) {} X)" by simp
            have p2emptyB: "Collect (extendedLine (1) (Pi 0) {}) = {}" using p2emptyA by simp
            have L1c: "Lambda (1) = Collect (newLine (1) (Pi 0) {}) \<union> {}" using L1b p2emptyB by blast
            have L1d: "Lambda (1) = Collect (newLine (1) (Pi 0) {})" using L1c by blast
            have k_in_Lam1: "newLine 1 (Pi 0) {} (Join 1 P Q)" unfolding newLine.simps
              using Pform Qform True assms(1) assms(2) basepoints_in_PS by auto
            have k_in_Lam1B: "?k \<in> Lambda 1" using k_in_Lam1 by simp
            have "?S \<in> LS" using LS_def
            proof -
              have zl1: "(Join 1 P Q) \<in> Lambda 1" using k_in_Lam1B by auto
              let ?Z = "UU ?k"
              have big: "?Z = UU ?k \<and> ?k = Join 1 P Q \<and> ?k \<in> Lambda 1" using zl1 by simp
              thus ?thesis using big LS_def by force
            qed
            have c1: "fmeets P  (UU (Join 1 P Q))"
              using \<open>fmeets P (UU (Join 1 P Q))\<close> by blast
            have c2: "fmeets Q  (UU (Join 1 P Q))"
              using \<open>fmeets Q (UU (Join 1 P Q))\<close> by blast
            have "(fmeets P  (UU (Join 1 P Q))) \<and> (fmeets Q  (UU (Join 1 P Q)))" using c1 c2 by auto
            thus ?thesis
              using \<open>UU (Join 1 P Q) \<in> LS\<close> by blast
          next
            case False
            have ineq: "plt Q P"
              by (smt Basepoint False Pform \<open>X \<noteq> Y\<close> basepoint.simps(3)
                    basepoint.simps(5) basepoint.simps(9) free_projective_plane_data.plt.simps(1) lt.elims(3))
            show ?thesis
            proof-
            let ?k = "Join 1 Q P"
            let ?S = "UU ?k"
            have "fmeets P ?S" using fmeets.simps(1) UU.simps lsp.simps  by (simp add: Pform)
            have "fmeets Q ?S" using fmeets.simps(1) UU.simps lsp.simps  by (simp add: Qform)
            have L1a: "Lambda (1) = Collect (newLine (1) (Pi 0) (Lambda 0)) \<union> Collect (extendedLine (1) (Pi 0) (Lambda 0))" by simp
            have L1b: "Lambda (1) = Collect (newLine (1) (Pi 0) {}) \<union> Collect (extendedLine (1) (Pi 0) {})" by simp
            have p2emptyA: "\<forall> X . \<not> (extendedLine (1) (Pi 0) {} X)" by simp
            have p2emptyB: "Collect (extendedLine (1) (Pi 0) {}) = {}" using p2emptyA by simp
            have L1c: "Lambda (1) = Collect (newLine (1) (Pi 0) {}) \<union> {}" using L1b p2emptyB by blast
            have L1d: "Lambda (1) = Collect (newLine (1) (Pi 0) {})" using L1c by blast
            have qp0: "Q \<in> Pi 0"
              using Qform assms(2) basepoints_in_PS by auto
            have pp0: "P \<in> Pi 0"
              using Pform assms(1) basepoints_in_PS by auto
            have k_in_Lam1: "newLine 1 (Pi 0) {} (Join 1 Q P)" unfolding newLine.simps using qp0 pp0 ineq try by simp
            have k_in_Lam1B: "?k \<in> Lambda 1" using k_in_Lam1 by simp
            have "?S \<in> LS" using LS_def
            proof -
              have zl1: "(Join 1 Q P) \<in> Lambda 1" using k_in_Lam1B by auto
              let ?Z = "UU ?k"
              have big: "?Z = UU ?k \<and> ?k = Join 1 Q P \<and> ?k \<in> Lambda 1" using zl1 by simp
              thus ?thesis using big LS_def by force
            qed
            thus ?thesis
              using \<open>fmeets P (UU (Join 1 Q P))\<close> \<open>fmeets Q (UU (Join 1 Q P))\<close> by blast
          qed
        qed
      qed
    next
      case (Intersect j m n)
        then show ?thesis sorry
      qed
  next
    case (Intersect i k l)
    then show ?thesis
    proof (cases Q)
      case (Basepoint j A)
      then show ?thesis sorry
    next
      case (Intersect j m n)
      then show ?thesis sorry
    qed
  qed

theorem "projective_plane PS LS fmeets"
  sorry
end


section\<open>Basic relativization of cardinality\<close>

theory Discipline_Cardinal
  imports
    Discipline_Function
begin

relativize functional "cardinal" "cardinal_rel" external
relationalize "cardinal_rel" "is_cardinal"
synthesize "is_cardinal" from_definition assuming "nonempty"

notation is_cardinal_fm (\<open>cardinal'(_') is _\<close>)

abbreviation
  cardinal_r :: "[i,i\<Rightarrow>o] \<Rightarrow> i" (\<open>|_|\<^bsup>_\<^esup>\<close>) where
  "|x|\<^bsup>M\<^esup> \<equiv> cardinal_rel(M,x)"

abbreviation
  cardinal_r_set :: "[i,i]\<Rightarrow>i"  (\<open>|_|\<^bsup>_\<^esup>\<close>) where
  "|x|\<^bsup>M\<^esup> \<equiv> cardinal_rel(##M,x)"

context M_trivial
begin
rel_closed for "cardinal"
  using Least_closed'[of "\<lambda>i. M(i) \<and> i \<approx>\<^bsup>M\<^esup> A"]
  unfolding cardinal_rel_def
  by simp
end \<comment> \<open>\<^locale>\<open>M_trivial\<close>\<close>

manual_arity intermediate for "is_Int_fm"
  unfolding is_Int_fm_def
  using arity pred_Un_distrib
  by (simp)

arity_theorem for "is_Int_fm"

arity_theorem for "is_funspace_fm"

arity_theorem for "is_function_space_fm"

arity_theorem for "surjP_rel_fm"

arity_theorem intermediate for "is_surj_fm"

lemma arity_is_surj_fm [arity] :
  "A \<in> nat \<Longrightarrow> B \<in> nat \<Longrightarrow> I \<in> nat \<Longrightarrow> arity(is_surj_fm(A, B, I)) = succ(A) \<union> succ(B) \<union> succ(I)"
  using arity_is_surj_fm' pred_Un_distrib
  by auto

arity_theorem for "injP_rel_fm"

arity_theorem intermediate for "is_inj_fm"

lemma arity_is_inj_fm [arity]:
  "A \<in> nat \<Longrightarrow> B \<in> nat \<Longrightarrow> I \<in> nat \<Longrightarrow> arity(is_inj_fm(A, B, I)) = succ(A) \<union> succ(B) \<union> succ(I)"
  using arity_is_inj_fm' pred_Un_distrib
  by auto

arity_theorem for "is_bij_fm"

arity_theorem for "is_eqpoll_fm"

arity_theorem for "is_cardinal_fm"

context M_Perm
begin
is_iff_rel for "cardinal"
  using least_abs'[of "\<lambda>i. M(i) \<and> i \<approx>\<^bsup>M\<^esup> A"]
    is_eqpoll_iff
  unfolding is_cardinal_def cardinal_rel_def
  by simp
end \<comment> \<open>\<^locale>\<open>M_Perm\<close>\<close>

reldb_add functional "Ord" "Ord"
reldb_add relational "Ord" "ordinal"
reldb_add functional "lt" "lt"
reldb_add relational "lt" "lt_rel"
synthesize "lt_rel" from_definition
notation lt_rel_fm (\<open>\<cdot>_ < _\<cdot>\<close>)
arity_theorem intermediate for "lt_rel_fm"

lemma arity_lt_rel_fm[arity]: "a \<in> nat \<Longrightarrow> b \<in> nat \<Longrightarrow> arity(lt_rel_fm(a, b)) = succ(a) \<union> succ(b)"
  using arity_lt_rel_fm'
  by auto

relativize functional "Card" "Card_rel" external
relationalize "Card_rel" "is_Card"
synthesize "is_Card" from_definition assuming "nonempty"
notation is_Card_fm (\<open>\<cdot>Card'(_')\<cdot>\<close>)
arity_theorem for "is_Card_fm"

notation Card_rel (\<open>Card\<^bsup>_\<^esup>'(_')\<close>)

lemma (in M_Perm) is_Card_iff: "M(A) \<Longrightarrow> is_Card(M, A) \<longleftrightarrow> Card\<^bsup>M\<^esup>(A)"
  using is_cardinal_iff
  unfolding is_Card_def Card_rel_def by simp

abbreviation
  Card_r_set  :: "[i,i]\<Rightarrow>o"  (\<open>Card\<^bsup>_\<^esup>'(_')\<close>) where
  "Card\<^bsup>M\<^esup>(i) \<equiv> Card_rel(##M,i)"

relativize functional "InfCard" "InfCard_rel" external
relationalize "InfCard_rel" "is_InfCard"
synthesize "is_InfCard" from_definition assuming "nonempty"
notation is_InfCard_fm (\<open>\<cdot>InfCard'(_')\<cdot>\<close>)
arity_theorem for "is_InfCard_fm"

notation InfCard_rel (\<open>InfCard\<^bsup>_\<^esup>'(_')\<close>)

abbreviation
  InfCard_r_set  :: "[i,i]\<Rightarrow>o"  (\<open>InfCard\<^bsup>_\<^esup>'(_')\<close>) where
  "InfCard\<^bsup>M\<^esup>(i) \<equiv> InfCard_rel(##M,i)"

subsection\<open>Disicpline for \<^term>\<open>cadd\<close>\<close>
relativize functional "cadd" "cadd_rel" external

abbreviation
  cadd_r :: "[i,i\<Rightarrow>o,i] \<Rightarrow> i" (\<open>_ \<oplus>\<^bsup>_\<^esup> _\<close> [66,1,66] 65) where
  "A \<oplus>\<^bsup>M\<^esup> B \<equiv> cadd_rel(M,A,B)"

context M_basic
begin
rel_closed for "cadd"
  using cardinal_rel_closed
  unfolding cadd_rel_def
  by simp
end \<comment> \<open>\<^locale>\<open>M_basic\<close>\<close>

relationalize "cadd_rel" "is_cadd"

manual_schematic for "is_cadd" assuming "nonempty"
  unfolding is_cadd_def
  by (rule iff_sats sum_iff_sats | simp)+
synthesize "is_cadd" from_schematic

arity_theorem for "sum_fm"

arity_theorem for "is_cadd_fm"

context M_Perm
begin
is_iff_rel for "cadd"
  using is_cardinal_iff
  unfolding is_cadd_def cadd_rel_def
  by simp

end  \<comment> \<open>\<^locale>\<open>M_Perm\<close>\<close>

subsection\<open>Disicpline for \<^term>\<open>cmult\<close>\<close>

relativize functional "cmult" "cmult_rel" external

abbreviation
  cmult_r :: "[i,i\<Rightarrow>o,i] \<Rightarrow> i" (\<open>_ \<otimes>\<^bsup>_\<^esup> _\<close> [66,1,66] 65) where
  "A \<otimes>\<^bsup>M\<^esup> B \<equiv> cmult_rel(M,A,B)"

relationalize "cmult_rel" "is_cmult"

declare cartprod_iff_sats [iff_sats]

synthesize "is_cmult" from_definition assuming "nonempty"

arity_theorem for "is_cmult_fm"

context M_Perm
begin
rel_closed for "cmult"
  using cardinal_rel_closed
  unfolding cmult_rel_def
  by simp

is_iff_rel for "cmult"
  using is_cardinal_iff
  unfolding is_cmult_def cmult_rel_def
  by simp

end \<comment> \<open>\<^locale>\<open>M_Perm\<close>\<close>

end


(*
  File: Connectivity_Impl.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of connectivity on graphs\<close>

theory Connectivity_Impl
  imports Union_Find_Impl "../Functional/Connectivity"
begin

text \<open>Imperative version of graph-connectivity example.\<close>

subsection \<open>Constructing the connected relation\<close>

fun connected_rel_imp :: "nat \<Rightarrow> (nat \<times> nat) list \<Rightarrow> nat \<Rightarrow> uf Heap" where
  "connected_rel_imp n es 0 = do { p \<leftarrow> uf_init n; return p }"
| "connected_rel_imp n es (Suc k) = do {
    p \<leftarrow> connected_rel_imp n es k;
    p' \<leftarrow> uf_union p (fst (es ! k)) (snd (es ! k));
    return p' }"

lemma connected_rel_imp_to_fun [hoare_triple]:
  "is_valid_graph n (set es) \<Longrightarrow> k \<le> length es \<Longrightarrow>
   <emp>
   connected_rel_imp n es k
   <is_uf n (connected_rel_ind n es k)>"
@proof @induct k @qed

lemma connected_rel_imp_correct [hoare_triple]:
  "is_valid_graph n (set es) \<Longrightarrow>
   <emp>
   connected_rel_imp n es (length es)
   <is_uf n (connected_rel n (set es))>" by auto2

subsection \<open>Connectedness tests\<close>

text \<open>Correctness of the algorithm for detecting connectivity.\<close>
theorem uf_cmp_correct [hoare_triple]:
  "<is_uf n (connected_rel n S) p>
   uf_cmp p i j
   <\<lambda>r. is_uf n (connected_rel n S) p * \<up>(r \<longleftrightarrow> has_path n S i j)>" by auto2

end