section \<open>Certification of Reachability Problems on MDPs\<close>

theory MDP_RP_Certification
imports
  "../MDP_Reachability_Problem"
  "HOL-Library.IArray"
  "HOL-Library.Code_Target_Numeral"
begin

context Reachability_Problem
begin

lemma p_ub':
  fixes x
  assumes 1: "s \<in> S" "\<And>s D. s \<in> S1 \<Longrightarrow> D \<in> K s \<Longrightarrow> (\<Sum>t\<in>S. pmf D t * x t) \<le> x s"
  assumes 2: "\<And>s. s \<in> S1 \<Longrightarrow> x s \<noteq> 0 \<Longrightarrow> (\<exists>t\<in>S2. (s, t) \<in> (SIGMA s:S1. \<Union>D\<in>K s. set_pmf D)\<^sup>*)"
  assumes 3: "\<And>s. s \<in> S - S1 - S2 \<Longrightarrow> x s = 0"
  assumes 4: "\<And>s. s \<in> S2 \<Longrightarrow> x s = 1"
  shows "enn2real (p s) \<le> x s"
proof (rule p_ub[OF 1 _ 4])
  fix s assume "s \<in> S" "p s = 0" with 2[of s] p_pos[of s] p_S2[of s] 3[of s] show "x s = 0"
    by (cases "x s = 0") auto
qed

lemma n_lb':
  fixes x
  assumes "wf R"
  assumes 1: "s \<in> S" "\<And>s D. s \<in> S1 \<Longrightarrow> D \<in> K s \<Longrightarrow> x s \<le> (\<Sum>t\<in>S. pmf D t * x t)"
  assumes 2: "\<And>s D. s \<in> S1 \<Longrightarrow> D \<in> K s \<Longrightarrow> x s \<noteq> 0 \<Longrightarrow> \<exists>t\<in>D. ((t, s) \<in> R \<and> t \<in> S1 \<and> x t \<noteq> 0) \<or> t \<in> S2"
  assumes 3: "\<And>s. s \<in> S - S1 - S2 \<Longrightarrow> x s = 0"
  assumes 4: "\<And>s. s \<in> S2 \<Longrightarrow> x s = 1"
  shows "x s \<le> enn2real (n s)"
proof (rule n_lb[OF 1 _ 4])
  fix s assume *: "s \<in> S" "n s = 0"
  show "x s = 0"
  proof (rule ccontr)
    assume "x s \<noteq> 0"
    with * n_S2[of s] n_nS12[of s] 3[of s] have "s \<in> S1"
      by (metis DiffI zero_neq_one)
    have "0 < n s"
      by (intro n_pos[of "\<lambda>s. x s \<noteq> 0", OF \<open>x s \<noteq> 0\<close> \<open>s \<in> S1\<close> \<open>wf R\<close>])
         (metis zero_less_one n_S2 2)
    with \<open>n s = 0\<close> show False by auto
  qed
qed

end

no_notation Stream.snth (infixl "!!" 100) \<comment> \<open>we use @{text "!!"} for IArray\<close>

subsection \<open>Computable representation\<close>

record mdp_reachability_problem =
  state_count :: nat
  distrs :: "(nat \<times> rat) list list iarray"
  states1 :: "bool iarray"
  states2 :: "bool iarray"

record 'a RP_sub_cert =
  solution :: "rat iarray"
  witness :: "('a \<times> nat) iarray"

record RP_cert =
  pos_cert :: "(nat \<times> nat) RP_sub_cert"
  neg_cert :: "nat list RP_sub_cert"

definition "sparse_mult sx y = sum_list (map (\<lambda>(n, x). x * y !! n) sx)"

primrec lookup where
  "lookup d [] x = d"
| "lookup d (y#ys) x = (if fst y = x then snd y else lookup d ys x)"

lemma lookup_eq_map_of: "lookup d xs x = (case map_of xs x of Some x \<Rightarrow> x | None \<Rightarrow> d)"
  by (induct xs) simp_all

lemma lookup_not_in_set:
  "x \<notin> fst ` set xs \<Longrightarrow> lookup d xs x = d"
  unfolding lookup_eq_map_of
  by (subst map_of_eq_None_iff[of xs x, THEN iffD2]) auto

lemma lookup_nonneg:
  "(\<And>x v. (x, v) \<in> set xs \<Longrightarrow> 0 \<le> v) \<Longrightarrow> (0::'a::ordered_comm_monoid_add) \<le> lookup 0 xs x"
  apply (induction xs)
  apply simp
  apply force
  done

lemma sparse_mult_eq_sum_lookup:
  fixes xs :: "(nat \<times> 'a::comm_semiring_1) list"
  assumes "list_all (\<lambda>(n, x). n < M) xs" "distinct (map fst xs)"
  shows "sparse_mult xs y = (\<Sum>i<M. lookup 0 xs i * y !! i)"
proof -
  from \<open>distinct (map fst xs)\<close> have "distinct xs" "inj_on fst (set xs)"
    by (simp_all add: distinct_map)
  then have "sparse_mult xs y = (\<Sum>x\<in>set xs. snd x * y !! fst x)"
    by (auto intro!: sum.cong simp add: sparse_mult_def sum_list_distinct_conv_sum_set)
  also have "\<dots> = (\<Sum>x\<in>set xs. lookup 0 xs (fst x) * y !! fst x)"
    by (intro sum.cong refl arg_cong2[where f="(*)"]) (simp add: lookup_in_set assms)
  also have "\<dots> = (\<Sum>x\<in>fst ` set xs. lookup 0 xs x * y !! x)"
    using \<open>inj_on fst (set xs)\<close> by (simp add: sum.reindex)
  also have "\<dots> = (\<Sum>x<M. lookup 0 xs x * y !! x)"
    using assms(1)
    by (intro sum.mono_neutral_cong_left)
       (auto simp: list_all_iff lookup_eq_map_of map_of_eq_None_iff[THEN iffD2])
  finally show ?thesis .
qed

lemma sum_list_eq_sum_lookup:
  fixes xs :: "(nat \<times> 'a::comm_semiring_1) list"
  assumes "list_all (\<lambda>(n, x). n < M) xs" "distinct (map fst xs)"
  shows "sum_list (map snd xs) = (\<Sum>i<M. lookup 0 xs i)"
proof -
  from \<open>distinct (map fst xs)\<close> have "distinct xs" "inj_on fst (set xs)"
    by (simp_all add: distinct_map)
  then have "sum_list (map snd xs) = (\<Sum>x\<in>set xs. snd x)"
    by (auto intro!: sum.cong simp add: sparse_mult_def sum_list_distinct_conv_sum_set)
  also have "\<dots> = (\<Sum>x\<in>set xs. lookup 0 xs (fst x))"
    by (intro sum.cong refl arg_cong2[where f="(*)"]) (simp add: lookup_in_set assms)
  also have "\<dots> = (\<Sum>x\<in>fst ` set xs. lookup 0 xs x)"
    using \<open>inj_on fst (set xs)\<close> by (simp add: sum.reindex)
  also have "\<dots> = (\<Sum>x<M. lookup 0 xs x)"
    using assms(1)
    by (intro sum.mono_neutral_cong_left)
       (auto simp: list_all_iff lookup_eq_map_of map_of_eq_None_iff[THEN iffD2])
  finally show ?thesis .
qed

definition
  "valid_mdp_rp mdp \<longleftrightarrow>
    0 < state_count mdp \<and>
    IArray.length (distrs mdp) = state_count mdp \<and>
    IArray.length (states1 mdp) = state_count mdp \<and>
    IArray.length (states2 mdp) = state_count mdp \<and>
    (\<forall>i<state_count mdp. \<not> (states1 mdp !! i \<and> states2 mdp !! i) \<and>
      list_all (\<lambda>ds. distinct (map fst ds) \<and> list_all (\<lambda>(n, x). 0 \<le> x \<and> n < state_count mdp) ds \<and>
                     sum_list (map snd ds) = 1) (distrs mdp !! i) \<and>
      \<not> List.null (distrs mdp !! i))"

definition
  "valid_sub_cert mdp c ord check \<longleftrightarrow>
    IArray.length (witness c) = state_count mdp \<and>
    IArray.length (solution c) = state_count mdp \<and>
    (\<forall>i<state_count mdp.
      if states2 mdp !! i then solution c !! i = 1
      else if states1 mdp !! i then 0 \<le> solution c !! i \<and>
        (list_all (\<lambda>ds. ord (sparse_mult ds (solution c)) (solution c !! i)) (distrs mdp !! i)) \<and>
        (0 < solution c !! i \<longrightarrow> check (distrs mdp !! i) (witness c !! i))
      else solution c !! i = 0)"

definition
  "valid_pos_cert mdp c \<longleftrightarrow>
    valid_sub_cert mdp c (\<le>)
      (\<lambda>D ((j, a), n). j < state_count mdp \<and> snd (witness c !! j) < n \<and> 0 < solution c !! j \<and>
        a < length D \<and> lookup 0 (D ! a) j \<noteq> 0)"

definition
  "valid_neg_cert mdp c \<longleftrightarrow>
    valid_sub_cert mdp c (\<ge>)
      (\<lambda>D (J, n). list_all2 (\<lambda>j d. j < state_count mdp \<and> snd (witness c !! j) < n \<and>
        lookup 0 d j \<noteq> 0 \<and> 0 < solution c !! j) J D)"

definition
  "valid_cert mdp c \<longleftrightarrow> valid_pos_cert mdp (pos_cert c) \<and> valid_neg_cert mdp (neg_cert c)"

lemma valid_mdp_rpD_length:
  assumes "valid_mdp_rp mdp"
  shows "0 < state_count mdp" "IArray.length (distrs mdp) = state_count mdp"
    "IArray.length (states1 mdp) = state_count mdp" "IArray.length (states2 mdp) = state_count mdp"
  using assms by (auto simp: valid_mdp_rp_def)

lemma valid_mdp_rpD:
  assumes "valid_mdp_rp mdp" "i < state_count mdp"
  shows "\<not> (states1 mdp !! i \<and> states2 mdp !! i)"
    and "\<And>ds n x. ds \<in> set (distrs mdp !! i) \<Longrightarrow> (n, x) \<in> set ds \<Longrightarrow> n < state_count mdp"
    and "\<And>ds n x. ds \<in> set (distrs mdp !! i) \<Longrightarrow> (n, x) \<in> set ds \<Longrightarrow> 0 \<le> x"
    and "\<And>ds. ds \<in> set (distrs mdp !! i) \<Longrightarrow> sum_list (map snd ds) = 1"
    and "\<And>ds. ds \<in> set (distrs mdp !! i) \<Longrightarrow> distinct (map fst ds)"
    and "distrs mdp !! i \<noteq> []"
  using assms by (auto simp: valid_mdp_rp_def list_all_iff List.null_def elim!: allE[of _ i])

lemma valid_mdp_rp_sparse_mult:
  assumes "valid_mdp_rp mdp" "i < state_count mdp" "ds \<in> set (distrs mdp !! i)"
  shows "sparse_mult ds y = (\<Sum>i<state_count mdp. lookup 0 ds i * y !! i)"
  using valid_mdp_rpD(2,5)[OF assms] by (intro sparse_mult_eq_sum_lookup) (auto simp: list_all_iff)

lemma valid_sub_certD:
  assumes "valid_mdp_rp mdp" "valid_sub_cert mdp c ord check" "i < state_count mdp"
  shows "\<not> states1 mdp !! i \<Longrightarrow> \<not> states2 mdp !! i \<Longrightarrow> solution c !! i = 0"
    and "states2 mdp !! i \<Longrightarrow> solution c !! i = 1"
    and "states1 mdp !! i \<Longrightarrow> 0 \<le> solution c !! i"
    and "\<And>ds. states1 mdp !! i \<Longrightarrow> ds \<in> set (distrs mdp !! i) \<Longrightarrow> ord (sparse_mult ds (solution c)) (solution c !! i)"
    and "\<And>ds. states1 mdp !! i \<Longrightarrow> 0 < solution c !! i \<longrightarrow> check (distrs mdp !! i) (witness c !! i)"
  using assms(2,3) valid_mdp_rpD(1)[OF assms(1,3)]
  by (auto simp add: valid_sub_cert_def list_all_iff)

lemma valid_pos_certD:
  assumes "valid_mdp_rp mdp" "valid_pos_cert mdp c" "i < state_count mdp" "states1 mdp !! i"
    "0 < solution c !! i" "witness c !! i = ((j, a), n)"
  shows "snd (witness c !! j) < n \<and> j < state_count mdp \<and> a < length (distrs mdp !! i) \<and>
          lookup 0 ((distrs mdp !! i) ! a) j \<noteq> 0 \<and> 0 < solution c !! j"
  using valid_sub_certD(5)[OF assms(1) assms(2)[unfolded valid_pos_cert_def] assms(3,4)] assms(5-) by auto

lemma valid_neg_certD:
  assumes "valid_mdp_rp mdp" "valid_neg_cert mdp c" "i < state_count mdp" "states1 mdp !! i"
    "0 < solution c !! i" "witness c !! i = (js, n)"
  shows "list_all2 (\<lambda>j ds. j < state_count mdp \<and> snd (witness c !! j) < n \<and> lookup 0 ds j \<noteq> 0 \<and> 0 < solution c !! j) js (distrs mdp !! i)"
  using valid_sub_certD(5)[OF assms(1) assms(2)[unfolded valid_neg_cert_def] assms(3)] assms(4-) by auto

context
  fixes mdp c
  assumes rp: "valid_mdp_rp mdp"
  assumes cert: "valid_cert mdp c"
begin

interpretation pmf_as_function .

abbreviation "S \<equiv> {..< state_count mdp}"
abbreviation "S1 \<equiv> {i. i < state_count mdp \<and> (states1 mdp) !! i}"
abbreviation "S2 \<equiv> {i. i < state_count mdp \<and> (states2 mdp) !! i}"

lift_definition K :: "nat \<Rightarrow> nat pmf set" is
  "\<lambda>i. if i < state_count mdp then
     { (\<lambda>j. of_rat (lookup 0 D j) :: real) | D. D \<in> set (distrs mdp !! i) }
     else { indicator {0} }"
proof (auto split: if_split_asm simp del: IArray.sub_def)
  fix n D assume n: "n < state_count mdp" and D: "D \<in> set (distrs mdp !! n)"
  from valid_mdp_rpD(3)[OF rp this] show nn: "\<And>i. 0 \<le> lookup 0 D i"
    by (auto simp add: lookup_eq_map_of split: option.split dest: map_of_SomeD)
  show "(\<integral>\<^sup>+ x. ennreal (real_of_rat (lookup 0 D x)) \<partial>count_space UNIV) = 1"
    using valid_mdp_rpD(2,3,4,5)[OF rp n D]
    apply (subst nn_integral_count_space'[of "{..< state_count mdp}"])
    apply (auto intro: nn lookup_not_in_set simp: of_rat_sum[symmetric] lookup_nonneg)
    apply (subst sum_list_eq_sum_lookup[symmetric])
    apply (auto simp: list_all_iff lookup_eq_map_of split: option.split)
    done
next
  show "(\<integral>\<^sup>+ x. ennreal (indicator {0} x) \<partial>count_space UNIV) = 1"
    by (subst nn_integral_count_space'[of "{0}"]) auto
qed

interpretation MDP: Reachability_Problem K S S1 S2
proof
  show "S1 \<inter> S2 = {}" "S1 \<subseteq> S" "S2 \<subseteq> S"
    using valid_mdp_rpD(1)[OF rp] by auto
  show "finite S" "S \<noteq> {}"
    using \<open>valid_mdp_rp mdp\<close> by (auto simp add: valid_mdp_rp_def)
  show "\<And>s. K s \<noteq> {}"
    using valid_mdp_rpD(6)[OF rp] by transfer simp
  show "\<And>s. finite (K s)"
    by transfer simp

  fix s assume "s \<in> S" then show "(\<Union>D\<in>K s. set_pmf D) \<subseteq> S"
    using valid_mdp_rpD(2)[OF rp]
    by transfer (auto simp: lookup_eq_map_of split: option.splits dest!: map_of_SomeD)
qed

definition "P_max s = enn2real (MDP.p s)"
definition "P_min s = enn2real (MDP.n s)"

lemma
  assumes "i < state_count mdp"
  shows P_max: "P_max i \<le> real_of_rat (solution (pos_cert c) !! i)" (is ?max)
    and P_min: "P_min i \<ge> real_of_rat (solution (neg_cert c) !! i)" (is ?min)
proof -
  have "valid_pos_cert mdp (pos_cert c)" "valid_neg_cert mdp (neg_cert c)"
    using \<open>valid_cert mdp c\<close> by (auto simp: valid_cert_def)
  note pos = this(1)[unfolded valid_pos_cert_def] and neg = this(2)[unfolded valid_neg_cert_def]

  let ?x = "\<lambda>s. real_of_rat (solution (pos_cert c) !! s)"
  have "enn2real (MDP.p i) \<le> ?x i"
  proof (rule MDP.p_ub')
    show "i \<in> S" using assms by simp
  next
    fix s D assume "s \<in> S1" "D \<in> K s"
    then obtain j where j: "j < length (distrs mdp !! s)"
      "\<And>i. i < state_count mdp \<Longrightarrow> pmf D i = real_of_rat (lookup 0 (distrs mdp !! s ! j) i)"
      by transfer (auto simp: in_set_conv_nth)
    with valid_sub_certD(4)[OF \<open>valid_mdp_rp mdp\<close> pos, of s "distrs mdp !! s ! j"] \<open>s \<in> S1\<close>
         valid_mdp_rp_sparse_mult[OF \<open>valid_mdp_rp mdp\<close>, of s "distrs mdp !! s ! j" "solution (pos_cert c)"]
    show "(\<Sum>t\<in>S. pmf D t * ?x t) \<le> ?x s"
      by (simp add: of_rat_mult[symmetric] of_rat_sum[symmetric] of_rat_less_eq j)
  next
    fix s a assume "s \<in> S2" then show "?x s = 1"
      using valid_sub_certD[OF \<open>valid_mdp_rp mdp\<close> pos] by simp
  next
    fix s define X where "X = (SIGMA s:S1. \<Union>D\<in>K s. set_pmf D)"
    assume "s \<in> S1" "?x s \<noteq> 0"
    with valid_sub_certD(3)[OF rp pos, of s]
    have "0 < ?x s"
      by simp
    with \<open>s\<in>S1\<close> show "\<exists>t\<in>S2. (s, t) \<in> X\<^sup>*"
    proof (induction n\<equiv>"snd (witness (pos_cert c) !! s)" arbitrary: s rule: less_induct)
      case (less s)
      obtain t a n where eq: "witness (pos_cert c) !! s = ((t, a), n)"
        by (metis prod.exhaust)
      from valid_pos_certD[OF rp \<open>valid_pos_cert mdp (pos_cert c)\<close> _ _ _ this] less.prems
      have ord: "snd (witness (pos_cert c) !! t) < snd (witness (pos_cert c) !! s)"
        and t: "lookup 0 (distrs mdp !! s ! a) t \<noteq> 0" "0 < ?x t" "t\<in>S" "a < length (distrs mdp !! s)"
        unfolding eq by auto
      with \<open>s\<in>S1\<close> have X: "(s, t) \<in> X"
        unfolding X_def
        by (transfer fixing: s t a c)
           (auto simp: X_def in_set_conv_nth
                 intro!: exI[of _ "\<lambda>j. real_of_rat (lookup 0 (distrs mdp !! s ! a) j)"]
                         exI[of _ "distrs mdp !! s ! a"] exI[of _ a])
      show ?case
      proof cases
        assume "t \<in> S1"
        with less.hyps[OF ord _ \<open>0 < ?x t\<close>] X show ?thesis
          by auto
      next
        assume "t \<notin> S1"
        with valid_sub_certD[OF \<open>valid_mdp_rp mdp\<close> pos, of t] \<open>0 < ?x t\<close> \<open>t\<in>S\<close>
        have "t \<in> S2"
          by auto
        with X show ?thesis
          by auto
      qed
    qed
  next
    fix s assume "s \<in> S - S1 - S2" then show "?x s = 0"
      using valid_sub_certD(1)[OF \<open>valid_mdp_rp mdp\<close> pos, of s] by simp
  qed
  then show ?max
    by (simp add: P_max_def)

  let ?x = "\<lambda>s. real_of_rat (solution (neg_cert c) !! s)"
  have "?x i \<le> enn2real (MDP.n i)"
  proof (rule MDP.n_lb')
    show "i \<in> S" using assms by simp
  next
    fix s D assume "s \<in> S1" "D \<in> K s"
    then obtain j where j: "j < length (distrs mdp !! s)"
      "\<And>i. i < state_count mdp \<Longrightarrow> pmf D i = real_of_rat (lookup 0 (distrs mdp !! s ! j) i)"
      by transfer (auto simp: in_set_conv_nth)
    with valid_sub_certD(4)[OF \<open>valid_mdp_rp mdp\<close> neg, of s "distrs mdp !! s ! j"] \<open>s \<in> S1\<close>
         valid_mdp_rp_sparse_mult[OF \<open>valid_mdp_rp mdp\<close>, of s "distrs mdp !! s ! j" "solution (neg_cert c)"]
    show "?x s \<le> (\<Sum>t\<in>S. pmf D t * ?x t)"
      by (simp add: of_rat_mult[symmetric] of_rat_sum[symmetric] of_rat_less_eq j)
  next
    fix s a assume "s \<in> S2" then show "?x s = 1"
      using valid_sub_certD[OF \<open>valid_mdp_rp mdp\<close> neg] by simp
  next
    show "wf ((S \<times> S \<inter> {(s, t). snd (witness (neg_cert c) !! t) < snd (witness (neg_cert c) !! s)})\<inverse>)" (is "wf ?F")
      using MDP.S_finite
      by (intro finite_acyclic_wf_converse acyclicI_order[where f="\<lambda>s. snd (witness (neg_cert c) !! s)"]) auto

    fix s D assume 2: "s \<in> S1" "D \<in> K s" and "?x s \<noteq> 0"
    then have "0 < ?x s"
      using valid_sub_certD(3)[OF \<open>valid_mdp_rp mdp\<close> neg, of s] by auto

    from 2 obtain a where a: "a < length (distrs mdp !! s)"
      "\<And>i. i < state_count mdp \<Longrightarrow> pmf D i = real_of_rat (lookup 0 (distrs mdp !! s ! a) i)"
      by transfer (auto simp: in_set_conv_nth)

    obtain js n where eq: "witness (neg_cert c) !! s = (js, n)"
      by (metis prod.exhaust)
    from valid_neg_certD[OF \<open>valid_mdp_rp mdp\<close> \<open>valid_neg_cert mdp (neg_cert c)\<close> _ _ _ eq] a \<open>s \<in> S1\<close> \<open>0 < ?x s\<close>
    have *: "length js = length (distrs mdp !! s)" "js ! a \<in> S"
      "snd (witness (neg_cert c) !! (js ! a)) < snd (witness (neg_cert c) !! s)"
      "lookup 0 (distrs mdp !! s ! a) (js ! a) \<noteq> 0"
      "0 < ?x (js ! a)"
      unfolding eq by (auto dest: list_all2_nthD2 list_all2_lengthD)
    with a \<open>s \<in> S1\<close> have js_a: "js ! a \<in> D" "(js ! a, s) \<in> ?F"
      by (auto simp: set_pmf_iff)

    show "\<exists>t\<in>D. (t, s) \<in> ?F \<and> t \<in> S1 \<and> ?x t \<noteq> 0 \<or> t \<in> S2"
    proof cases
      assume "js ! a \<in> S1" with js_a \<open>0 < ?x (js ! a)\<close> show ?thesis by auto
    next
      assume "js ! a \<notin> S1"
      with \<open>0 < ?x (js ! a)\<close> \<open>js!a \<in> S\<close> valid_sub_certD[OF rp neg, of "js ! a"]
      have "js ! a \<in> S2"
        by (auto simp:  less_le)
      with \<open>js ! a \<in> D\<close> show ?thesis
        by auto
    qed
  next
    fix s assume "s \<in> S - S1 - S2" then show "?x s = 0"
      using valid_sub_certD(1)[OF \<open>valid_mdp_rp mdp\<close> neg, of s] by simp
  qed
  then show ?min
    by (simp add: P_min_def)
qed

end

end


theory Regex_ACI
  imports "HOL-Library.Confluent_Quotient"
begin

datatype 'a rexp = Zero | Eps | Atom 'a | Alt "'a rexp" "'a rexp" | Conc "'a rexp" "'a rexp" | Star "'a rexp"

inductive ACI (infix "~" 64) where
  a1: "Alt (Alt r s) t ~ Alt r (Alt s t)"
| a2: "Alt r (Alt s t) ~ Alt (Alt r s) t"
| c: "Alt r s ~ Alt s r"
| i: "r ~ Alt r r"
| R: "r ~ r"
| A: "r ~ r' \<Longrightarrow> s ~ s' \<Longrightarrow> Alt r s ~ Alt r' s'"
| C: "r ~ r' \<Longrightarrow> s ~ s' \<Longrightarrow> Conc r s ~ Conc r' s'"
| S: "r ~ r' \<Longrightarrow> Star r ~ Star r'"

declare ACI.intros[intro]

abbreviation ACIcl (infix "~~" 64) where "(~~) \<equiv> equivclp (~)"

lemma eq_set_preserves_inter:
  fixes eq set
  assumes "\<And>r s. eq r s \<Longrightarrow> set r = set s" and "Ss \<noteq> {}"
  shows "(\<Inter>As\<in>Ss. {(x, x'). eq x x'} `` {x. set x \<subseteq> As}) \<subseteq> {(x, x'). eq x x'} `` {x. set x \<subseteq> \<Inter> Ss}"
  using assms by (auto simp: subset_eq) metis

lemma ACI_map_respects:
  fixes f :: "'a \<Rightarrow> 'b" and r s :: "'a rexp"
  assumes "r ~ s"
  shows "map_rexp f r ~ map_rexp f s"
  using assms by (induct r s rule: ACI.induct) auto

lemma ACIcl_map_respects:
  fixes f :: "'a \<Rightarrow> 'b" and r s :: "'a rexp"
  assumes "r ~~ s"
  shows "map_rexp f r ~~ map_rexp f s"
  using assms by (induct rule: equivclp_induct) (auto intro: ACI_map_respects equivclp_trans)

lemma ACI_set_eq:
  fixes r s :: "'a rexp"
  assumes "r ~ s"
  shows "set_rexp r = set_rexp s"
  using assms by (induct r s rule: ACI.induct) auto

lemma ACIcl_set_eq:
  fixes r s :: "'a rexp"
  assumes "r ~~ s"
  shows "set_rexp r = set_rexp s"
  using assms by (induct rule: equivclp_induct) (auto dest: ACI_set_eq)

lemma Alt_eq_map_rexp_iff:
  "Alt r s = map_rexp f x \<longleftrightarrow> (\<exists>r' s'. x = Alt r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  "map_rexp f x = Alt r s \<longleftrightarrow> (\<exists>r' s'. x = Alt r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  by (cases x; auto)+

lemma Conc_eq_map_rexp_iff:
  "Conc r s = map_rexp f x \<longleftrightarrow> (\<exists>r' s'. x = Conc r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  "map_rexp f x = Conc r s \<longleftrightarrow> (\<exists>r' s'. x = Conc r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  by (cases x; auto)+

lemma Star_eq_map_rexp_iff:
  "Star r = map_rexp f x \<longleftrightarrow> (\<exists>r'. x = Star r' \<and> map_rexp f r' = r)"
  "map_rexp f x = Star r \<longleftrightarrow> (\<exists>r'. x = Star r' \<and> map_rexp f r' = r)"
  by (cases x; auto)+

lemma AA: "r ~~ r' \<Longrightarrow> s ~~ s' \<Longrightarrow> Alt r s ~~ Alt r' s'"
proof (induct rule: equivclp_induct)
  case base
  then show ?case
    by (induct rule: equivclp_induct) (auto elim!: equivclp_trans)
next
  case (step s t)
  then show ?case
    by (auto elim!: equivclp_trans)
qed

lemma AAA: "(~)\<^sup>*\<^sup>* r  r' \<Longrightarrow> (~)\<^sup>*\<^sup>* s s' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Alt r s) (Alt r' s')"
proof (induct r r' rule: rtranclp.induct)
  case (rtrancl_refl r)
  then show ?case
    by (induct s s' rule: rtranclp.induct)
      (auto elim!: rtranclp.rtrancl_into_rtrancl)
next
  case (rtrancl_into_rtrancl a b c)
  then show ?case
    by (auto elim!: rtranclp.rtrancl_into_rtrancl)
qed

lemma CC: "r ~~ r' \<Longrightarrow> s ~~ s' \<Longrightarrow> Conc r s ~~ Conc r' s'"
proof (induct rule: equivclp_induct)
  case base
  then show ?case
    by (induct rule: equivclp_induct) (auto elim!: equivclp_trans)
next
  case (step s t)
  then show ?case
    by (auto elim!: equivclp_trans)
qed

lemma CCC: "(~)\<^sup>*\<^sup>* r r' \<Longrightarrow> (~)\<^sup>*\<^sup>* s s' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Conc r s) (Conc r' s')"
proof (induct r r' rule: rtranclp.induct)
  case (rtrancl_refl r)
  then show ?case
    by (induct s s' rule: rtranclp.induct)
      (auto elim!: rtranclp.rtrancl_into_rtrancl)
next
  case (rtrancl_into_rtrancl a b c)
  then show ?case
    by (auto elim!: rtranclp.rtrancl_into_rtrancl)
qed

lemma SS: "r ~~ r' \<Longrightarrow> Star r ~~ Star r'"
proof (induct rule: equivclp_induct)
  case (step s t)
  then show ?case
    by (auto elim!: equivclp_trans)
qed auto

lemma SSS: "(~)\<^sup>*\<^sup>* r r' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Star r) (Star r')"
proof (induct r r' rule: rtranclp.induct)
  case (rtrancl_into_rtrancl a b c)
  then show ?case
    by (auto elim!: rtranclp.rtrancl_into_rtrancl)
qed auto

lemma map_rexp_ACI_inv: "map_rexp f x ~ y \<Longrightarrow> \<exists>z. x ~~ z \<and> y = map_rexp f z \<and> set_rexp z \<subseteq> set_rexp x"
proof (induct "map_rexp f x" y arbitrary: x rule: ACI.induct)
  case (a1 r s t)
  then obtain r' s' t' where "x = Alt (Alt r' s') t'"
    "map_rexp f r' = r" "map_rexp f s' = s" "map_rexp f t' = t"
    by (auto simp: Alt_eq_map_rexp_iff)
  then show ?case
    by (intro exI[of _ "Alt r' (Alt s' t')"]) auto
next
  case (a2 r s t)
  then obtain r' s' t' where "x = Alt r' (Alt s' t')"
    "map_rexp f r' = r" "map_rexp f s' = s" "map_rexp f t' = t"
    by (auto simp: Alt_eq_map_rexp_iff)
  then show ?case
    by (intro exI[of _ "Alt (Alt r' s') t'"]) auto
next
  case (c r s)
  then obtain r' s' where "x = Alt r' s'"
    "map_rexp f r' = r" "map_rexp f s' = s"
    by (auto simp: Alt_eq_map_rexp_iff)
  then show ?case
    by (intro exI[of _ "Alt s' r'"]) auto
next
  case (i r)
  then show ?case
    by (intro exI[of _ "Alt r r"]) auto
next
  case (R r)
  then show ?case by (auto intro: exI[of _ r])
next
  case (A r rr s ss)
  then obtain r' s' where "x = Alt r' s'"
    "map_rexp f r' = r" "map_rexp f s' = s"
    by (auto simp: Alt_eq_map_rexp_iff)
  moreover from A(2)[OF this(2)[symmetric]] A(4)[OF this(3)[symmetric]] obtain rr' ss' where
    "r' ~~ rr'" "rr = map_rexp f rr'" "s' ~~ ss'" "ss = map_rexp f ss'"
    "set_rexp rr' \<subseteq> set_rexp r'" "set_rexp ss' \<subseteq> set_rexp s'"
    by blast
  ultimately show ?case using A(1,3)
    by (intro exI[of _ "Alt rr' ss'"]) (auto intro!: AA)
next
  case (C r rr s ss)
  then obtain r' s' where "x = Conc r' s'"
    "map_rexp f r' = r" "map_rexp f s' = s"
    by (auto simp: Conc_eq_map_rexp_iff)
  moreover from C(2)[OF this(2)[symmetric]] C(4)[OF this(3)[symmetric]] obtain rr' ss' where
    "r' ~~ rr'" "rr = map_rexp f rr'" "s' ~~ ss'" "ss = map_rexp f ss'"
    "set_rexp rr' \<subseteq> set_rexp r'" "set_rexp ss' \<subseteq> set_rexp s'"
    by blast
  ultimately show ?case using C(1,3)
    by (intro exI[of _ "Conc rr' ss'"]) (auto intro!: CC)
next
  case (S r rr)
  then obtain r' where "x = Star r'" "map_rexp f r' = r"
    by (auto simp: Star_eq_map_rexp_iff)
  moreover from S(2)[OF this(2)[symmetric]] obtain rr' where "r' ~~ rr'" "rr = map_rexp f rr'"
    "set_rexp rr' \<subseteq> set_rexp r'"
    by blast
  ultimately show ?case
    by (intro exI[of _ "Star rr'"]) (auto intro!: SS)
qed

lemma reflclp_ACI: "(~)\<^sup>=\<^sup>= = (~)"
  unfolding fun_eq_iff
  by auto

lemma strong_confluentp_ACI: "strong_confluentp (~)"
  apply (rule strong_confluentpI, unfold reflclp_ACI)
  subgoal for x y z
  proof (induct x y arbitrary: z rule: ACI.induct)
    case (a1 r s t)
    then show ?case
      by (auto intro: AAA converse_rtranclp_into_rtranclp)
  next
    case (a2 r s t)
    then show ?case
      by (auto intro: AAA converse_rtranclp_into_rtranclp)
  next
    case (c r s)
    then show ?case
      by (cases rule: ACI.cases) (auto intro: AAA)
  next
    case (i r)
    then show ?case
      by (auto intro: AAA)
  next
    case (R r)
    then show ?case
      by auto
  next
    note A1 = ACI.A[OF _ R]
    note A2 = ACI.A[OF R]
    case (A r r' s s')
    from A(5,1-4) show ?case
    proof (cases rule: ACI.cases)
      case inner: (a1 r'' s'')
      from A(1,3) show ?thesis
        unfolding inner
      proof (elim ACI.cases[of _ r'], goal_cases Xa1 Xa2 XC XI XR XP XT XS)
        case (Xa1 rr ss tt)
        with A(3) show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
            (metis a1 a2 A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (Xa2 r s t)
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
            (metis a1 A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (XC r s)
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
            (metis a1 c A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (XI r)
        then show ?case
          apply (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ ACI.A[OF i ACI.A[OF i]]], rotated])
          apply hypsubst
          apply (rule converse_rtranclp_into_rtranclp, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A1, rule c)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply blast
          done
      qed auto
    next
      case inner: (a2 s'' t'')
      with A(1,3) show ?thesis
        unfolding inner
      proof (elim ACI.cases[of _ s'], goal_cases Xa1 Xa2 XC XI XR XP XT XS)
        case (Xa1 rr ss tt)
        with A(3) show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
            (metis a2 A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (Xa2 r s t)
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
            (metis a1 a2 A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (XC r s)
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
            (metis a2 c A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (XI r)
        then show ?case
          apply (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ ACI.A[OF ACI.A[OF _ i] i]], rotated])
          apply hypsubst
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A1, rule c)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule a2)
          apply blast
          done
      qed auto
    qed (auto 5 0 intro: AAA)
  next
    case (C r r' s s')
    from C(5,1-4) show ?case
      by (cases rule: ACI.cases) (auto 5 0 intro: CCC)
  next
    case (S r r')
    from S(3,1,2) show ?case
      by (cases rule: ACI.cases) (auto intro: SSS)
  qed
  done

lemma confluent_quotient_ACI:
  "confluent_quotient (~) (~~) (~~) (~~) (~~) (~~)
     (map_rexp fst) (map_rexp snd) (map_rexp fst) (map_rexp snd)
     rel_rexp rel_rexp rel_rexp set_rexp set_rexp"
  by unfold_locales (auto dest: ACIcl_set_eq ACIcl_map_respects simp: rexp.in_rel rexp.rel_compp map_rexp_ACI_inv
      intro: equivpI reflpI sympI transpI
      strong_confluentp_imp_confluentp[OF strong_confluentp_ACI])

inductive ACIEQ (infix "\<approx>" 64) where
  a: "Alt (Alt r s) t \<approx> Alt r (Alt s t)"
| c: "Alt r s \<approx> Alt s r"
| i: "Alt r r \<approx> r"
| A: "r \<approx> r' \<Longrightarrow> s \<approx> s' \<Longrightarrow> Alt r s \<approx> Alt r' s'"
| C: "r \<approx> r' \<Longrightarrow> s \<approx> s' \<Longrightarrow> Conc r s \<approx> Conc r' s'"
| S: "r \<approx> r' \<Longrightarrow> Star r \<approx> Star r'"
| r: "r \<approx> r"
| s: "r \<approx> s \<Longrightarrow> s \<approx> r"
| t: "r \<approx> s \<Longrightarrow> s \<approx> t \<Longrightarrow> r \<approx> t"

lemma ACIEQ_le_ACIcl: "r \<approx> s \<Longrightarrow> r ~~ s"
  by (induct r s rule: ACIEQ.induct) (auto intro: AA CC SS equivclp_sym equivclp_trans)

lemma ACI_le_ACIEQ: "r ~ s \<Longrightarrow> r \<approx> s"
  by (induct r s rule: ACI.induct) (auto intro: ACIEQ.intros)

lemma ACIcl_le_ACIEQ: "r ~~ s \<Longrightarrow> r \<approx> s"
  by (induct rule: equivclp_induct) (auto 0 3 intro: ACIEQ.intros ACI_le_ACIEQ)

lemma ACIEQ_alt: "(\<approx>) = (~~)"
  by (simp add: ACIEQ_le_ACIcl ACIcl_le_ACIEQ antisym predicate2I)

quotient_type 'a ACI_rexp = "'a rexp" / "(\<approx>)"
  unfolding ACIEQ_alt by (auto intro!: equivpI reflpI sympI transpI)

lift_bnf 'a ACI_rexp
  unfolding ACIEQ_alt
  subgoal for A Q by (rule confluent_quotient.subdistributivity[OF confluent_quotient_ACI])
  subgoal for Ss by (intro eq_set_preserves_inter[rotated] ACIcl_set_eq; auto)
  done

datatype ldl = Prop string | And ldl ldl | Not ldl | Match "ldl ACI_rexp"

end


header{*Pseudo-Coding: Section 7 Material*}

theory Pseudo_Coding
imports II_Prelims
begin

section{*General Lemmas*}

lemma Collect_disj_Un: "{f i |i. P i \<or> Q i} = {f i |i. P i} \<union> {f i |i. Q i}"
by auto

abbreviation Q_Subset :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Subset t u \<equiv> (Q_All (Q_Imp (Q_Mem (Q_Ind Zero) t) (Q_Mem (Q_Ind Zero) u)))"

lemma NEQ_quot_tm: "i\<noteq>j \<Longrightarrow> {} \<turnstile> \<lceil>Var i\<rceil> NEQ \<lceil>Var j\<rceil>"
  by (auto intro: Sigma_fm_imp_thm [OF OrdNotEqP_sf]
           simp: ground_fm_aux_def supp_conv_fresh quot_tm_def)

lemma EQ_quot_tm_Fls: "i\<noteq>j \<Longrightarrow> insert (\<lceil>Var i\<rceil> EQ \<lceil>Var j\<rceil>) H \<turnstile> Fls"
  by (metis (full_types) NEQ_quot_tm Assume OrdNotEqP_E cut2 thin0)

lemma perm_commute: "a \<sharp> p \<Longrightarrow> a' \<sharp> p \<Longrightarrow> (a \<rightleftharpoons> a') + p = p + (a \<rightleftharpoons> a')"
  by (rule plus_perm_eq) (simp add: supp_swap fresh_def)

lemma perm_self_inverseI: "\<lbrakk>-p = q; a \<sharp> p; a' \<sharp> p\<rbrakk> \<Longrightarrow> - ((a \<rightleftharpoons> a') + p) = (a \<rightleftharpoons> a') + q"
  by (simp_all add: perm_commute fresh_plus_perm minus_add)

lemma fresh_image:
  fixes f :: "'a \<Rightarrow> 'b::fs"  shows "finite A \<Longrightarrow> i \<sharp> f ` A \<longleftrightarrow> (\<forall>x\<in>A. i \<sharp> f x)"
  by (induct rule: finite_induct) (auto simp: fresh_finite_insert)

lemma atom_in_atom_image [simp]: "atom j \<in> atom ` V \<longleftrightarrow> j \<in> V"
  by auto

lemma fresh_star_empty [simp]: "{} \<sharp>* bs"
  by (simp add: fresh_star_def)

declare fresh_star_insert [simp]

lemma fresh_star_finite_insert:
  fixes S :: "('a::fs) set"  shows "finite S \<Longrightarrow> a \<sharp>* insert x S \<longleftrightarrow> a \<sharp>* x \<and> a \<sharp>* S"
  by (auto simp: fresh_star_def fresh_finite_insert)

lemma fresh_finite_Diff_single [simp]:
  fixes V :: "name set"   shows "finite V \<Longrightarrow> a \<sharp> (V - {j}) \<longleftrightarrow> (a \<sharp> j \<longrightarrow> a \<sharp> V)"
apply (auto simp: fresh_finite_insert)
apply (metis finite_Diff fresh_finite_insert insert_Diff_single)
apply (metis Diff_iff finite_Diff fresh_atom fresh_atom_at_base fresh_finite_set_at_base insertI1)
apply (metis Diff_idemp Diff_insert_absorb finite_Diff fresh_finite_insert insert_Diff_single insert_absorb)
done

lemma fresh_image_atom [simp]: "finite A \<Longrightarrow> i \<sharp> atom ` A \<longleftrightarrow> i \<sharp> A"
  by (induct rule: finite_induct) (auto simp: fresh_finite_insert)

lemma atom_fresh_star_atom_set_conv: "\<lbrakk>atom i \<sharp> bs; finite bs\<rbrakk> \<Longrightarrow> bs \<sharp>* i"
by (metis fresh_finite_atom_set fresh_ineq_at_base fresh_star_def)

lemma notin_V:
  assumes p: "atom i \<sharp> p" and V: "finite V" "atom ` (p \<bullet> V) \<sharp>* V"
  shows "i \<notin> V" "i \<notin> p \<bullet> V"
  using V
  apply (auto simp: fresh_def fresh_star_def supp_finite_set_at_base)
  apply (metis p mem_permute_iff fresh_at_base_permI)+
  done

section{*Simultaneous Substitution*}

definition ssubst :: "tm \<Rightarrow> name set \<Rightarrow> (name \<Rightarrow> tm) \<Rightarrow> tm"
  where "ssubst t V F = Finite_Set.fold (\<lambda>i. subst i (F i)) t V"

definition make_F :: "name set \<Rightarrow> perm \<Rightarrow> name \<Rightarrow> tm"
  where "make_F Vs p \<equiv> \<lambda>i. if i \<in> Vs then Var (p \<bullet> i) else Var i"

lemma ssubst_empty [simp]: "ssubst t {} F = t"
  by (simp add: ssubst_def)

text{*Renaming a finite set of variables. Based on the theorem @{text at_set_avoiding}*}
locale quote_perm =
  fixes p :: perm and Vs :: "name set" and F :: "name \<Rightarrow> tm"
  assumes p: "atom ` (p \<bullet> Vs) \<sharp>* Vs"
      and pinv: "-p = p"
      and Vs:  "finite Vs"
  defines "F \<equiv> make_F Vs p"
begin

lemma F_unfold: "F i = (if i \<in> Vs then Var (p \<bullet> i) else Var i)"
  by (simp add: F_def make_F_def)

lemma finite_V [simp]: "V \<subseteq> Vs \<Longrightarrow> finite V"
  by (metis Vs finite_subset)

lemma perm_exits_Vs: "i \<in> Vs \<Longrightarrow> (p \<bullet> i) \<notin> Vs"
  by (metis Vs fresh_finite_set_at_base imageI fresh_star_def mem_permute_iff p)

lemma atom_fresh_perm: "\<lbrakk>x \<in> Vs; y \<in> Vs\<rbrakk> \<Longrightarrow> atom x \<sharp> p \<bullet> y"
  by (metis imageI Vs p fresh_finite_set_at_base fresh_star_def mem_permute_iff fresh_at_base(2))

lemma fresh_pj: "\<lbrakk>a \<sharp> p; j \<in> Vs\<rbrakk> \<Longrightarrow> a \<sharp> p \<bullet> j"
  by (metis atom_fresh_perm fresh_at_base(2) fresh_perm fresh_permute_left pinv)

lemma fresh_Vs: "a \<sharp> p \<Longrightarrow> a \<sharp> Vs"
  by (metis Vs fresh_def fresh_perm fresh_permute_iff fresh_star_def p permute_finite supp_finite_set_at_base)

lemma fresh_pVs: "a \<sharp> p \<Longrightarrow> a \<sharp> p \<bullet> Vs"
  by (metis fresh_Vs fresh_perm fresh_permute_left pinv)

lemma assumes "V \<subseteq> Vs" "a \<sharp> p"
      shows fresh_pV [simp]: "a \<sharp> p \<bullet> V" and fresh_V [simp]: "a \<sharp> V"
  using fresh_pVs fresh_Vs assms
  apply (auto simp: fresh_def)
  apply (metis (full_types) Vs finite_V permute_finite set_mp subset_Un_eq supp_of_finite_union union_eqvt)
  by (metis Vs finite_V set_mp subset_Un_eq supp_of_finite_union)

lemma qp_insert:
  fixes i::name and i'::name
  assumes "atom i \<sharp> p" "atom i' \<sharp> (i,p)"
    shows  "quote_perm ((atom i \<rightleftharpoons> atom i') + p) (insert i Vs)"
using p pinv Vs assms
  by (auto simp: quote_perm_def fresh_at_base_permI atom_fresh_star_atom_set_conv swap_fresh_fresh
                 fresh_star_finite_insert fresh_finite_insert perm_self_inverseI)

lemma subst_F_left_commute: "subst x (F x) (subst y (F y) t) = subst y (F y) (subst x (F x) t)"
  by (metis subst_tm_commute2 F_unfold subst_tm_id F_unfold atom_fresh_perm tm.fresh(2))

lemma
  assumes "finite V" "i \<notin> V"
  shows ssubst_insert:  "ssubst t (insert i V) F = subst i (F i) (ssubst t V F)"  (is ?thesis1)
    and ssubst_insert2: "ssubst t (insert i V) F = ssubst (subst i (F i) t) V F"  (is ?thesis2)
proof -
  interpret comp_fun_commute "(\<lambda>i. subst i (F i))"
  proof qed (simp add: subst_F_left_commute fun_eq_iff)
  show ?thesis1 using assms Vs
    by (simp add: ssubst_def)
  show ?thesis2 using assms Vs
    by (simp add: ssubst_def fold_insert2 del: fold_insert)
qed

lemma ssubst_insert_if:
  "finite V \<Longrightarrow>
     ssubst t (insert i V) F = (if i \<in> V then ssubst t V F
                                         else subst i (F i) (ssubst t V F))"
  by (simp add: ssubst_insert insert_absorb)

lemma ssubst_single [simp]: "ssubst t {i} F = subst i (F i) t"
  by (simp add: ssubst_insert)

lemma ssubst_Var_if [simp]:
  assumes "finite V"
    shows "ssubst (Var i) V F = (if i \<in> V then F i else Var i)"
using assms
  apply (induction V, auto)
  apply (metis ssubst_insert subst.simps(2))
  apply (metis ssubst_insert2 subst.simps(2))+
  done

lemma ssubst_Zero [simp]: "finite V \<Longrightarrow> ssubst Zero V F = Zero"
  by (induct V rule: finite_induct) (auto simp: ssubst_insert)

lemma ssubst_Eats [simp]: "finite V \<Longrightarrow> ssubst (Eats t u) V F = Eats (ssubst t V F) (ssubst u V F)"
  by (induct V rule: finite_induct) (auto simp: ssubst_insert)

lemma ssubst_SUCC [simp]: "finite V \<Longrightarrow> ssubst (SUCC t) V F = SUCC (ssubst t V F)"
  by (metis SUCC_def ssubst_Eats)

lemma ssubst_ORD_OF [simp]: "finite V \<Longrightarrow> ssubst (ORD_OF n) V F = ORD_OF n"
  by (induction n) auto

lemma ssubst_HPair [simp]:
  "finite V \<Longrightarrow> ssubst (HPair t u) V F = HPair (ssubst t V F) (ssubst u V F)"
  by (simp add: HPair_def)

lemma ssubst_HTuple [simp]: "finite V \<Longrightarrow> ssubst (HTuple n) V F = (HTuple n)"
  by (induction n) (auto simp: HTuple.simps)

lemma ssubst_Subset:
  assumes "finite V" shows "ssubst \<lfloor>t SUBS u\<rfloor>V V F = Q_Subset (ssubst \<lfloor>t\<rfloor>V V F) (ssubst \<lfloor>u\<rfloor>V V F)"
proof -
  obtain i::name where "atom i \<sharp> (t,u)"
    by (rule obtain_fresh)
  thus ?thesis using assms
    by (auto simp: Subset.simps [of i] vquot_fm_def vquot_tm_def trans_tm_forget)
qed

lemma fresh_ssubst:
  assumes "finite V" "a \<sharp> p \<bullet> V" "a \<sharp> t"
    shows "a \<sharp> ssubst t V F"
using assms
  by (induct V)
     (auto simp: ssubst_insert_if fresh_finite_insert F_unfold intro: fresh_ineq_at_base)

lemma fresh_ssubst':
  assumes "finite V" "atom i \<sharp> t" "atom (p \<bullet> i) \<sharp> t"
    shows "atom i \<sharp> ssubst t V F"
using assms
  by (induct t rule: tm.induct) (auto simp: F_unfold fresh_permute_left pinv)

lemma ssubst_vquot_Ex:
  "\<lbrakk>finite V; atom i \<sharp> p \<bullet> V\<rbrakk>
   \<Longrightarrow> ssubst \<lfloor>Ex i A\<rfloor>(insert i V) (insert i V) F = ssubst \<lfloor>Ex i A\<rfloor>V V F"
   by (simp add: ssubst_insert_if insert_absorb vquot_fm_insert fresh_ssubst)

lemma ground_ssubst_eq: "\<lbrakk>finite V; supp t = {}\<rbrakk> \<Longrightarrow> ssubst t V F = t"
  by (induct V rule: finite_induct) (auto simp: ssubst_insert fresh_def)

lemma ssubst_quot_fm [simp]:
  fixes A::fm shows "finite V \<Longrightarrow> ssubst \<lceil>A\<rceil> V F = \<lceil>A\<rceil>"
  by (simp add: ground_ssubst_eq supp_conv_fresh)

lemma atom_in_p_Vs: "\<lbrakk>i \<in> p \<bullet> V; V \<subseteq> Vs\<rbrakk> \<Longrightarrow> i \<in> p \<bullet> Vs"
  by (metis (full_types) True_eqvt set_mp subset_eqvt)

section{*The Main Theorems of Section 7*}

lemma SubstTermP_vquot_dbtm:
  assumes w: "w \<in> Vs - V" and V: "V \<subseteq> Vs" "V' = p \<bullet> V"
      and s: "supp dbtm \<subseteq> atom ` Vs"
  shows
  "insert (ConstP (F w)) {ConstP (F i) | i. i \<in> V}
   \<turnstile> SubstTermP \<lceil>Var w\<rceil> (F w)
                (ssubst (vquot_dbtm V dbtm) V F)
                (subst w (F w) (ssubst (vquot_dbtm (insert w V) dbtm) V F))"
using s
proof (induct dbtm rule: dbtm.induct)
  case DBZero thus ?case using V w
    by (auto intro: SubstTermP_Zero [THEN cut1] ConstP_imp_TermP [THEN cut1])
next
  case (DBInd n) thus ?case using V
    apply auto
    apply (rule thin [of "{ConstP (F w)}"])
    apply (rule SubstTermP_Ind [THEN cut3])
    apply (auto simp: IndP_Q_Ind OrdP_ORD_OF ConstP_imp_TermP)
    done
next
  case (DBVar i) show ?case
  proof (cases "i \<in> V'")
    case True hence "i \<notin> Vs" using assms
      by (metis p Vs atom_in_atom_image atom_in_p_Vs fresh_finite_set_at_base fresh_star_def)
    thus ?thesis using DBVar True V
      by auto
  next
    case False thus ?thesis using DBVar V w
      apply (auto simp: quot_Var [symmetric])
        apply (blast intro: thin [of "{ConstP (F w)}"] ConstP_imp_TermP
                            SubstTermP_Var_same [THEN cut2])
       apply (subst forget_subst_tm, metis F_unfold atom_fresh_perm tm.fresh(2))
       apply (blast intro: Hyp thin [of "{ConstP (F w)}"] ConstP_imp_TermP
                           SubstTermP_Const [THEN cut2])
       apply (blast intro: Hyp thin [of "{ConstP (F w)}"] ConstP_imp_TermP EQ_quot_tm_Fls
                           SubstTermP_Var_diff [THEN cut4])
      done
  qed
next
  case (DBEats tm1 tm2) thus ?case using V
    by (auto simp: SubstTermP_Eats [THEN cut2])
qed

lemma SubstFormP_vquot_dbfm:
  assumes w: "w \<in> Vs - V" and V: "V \<subseteq> Vs" "V' = p \<bullet> V"
      and s: "supp dbfm \<subseteq> atom ` Vs"
  shows
  "insert (ConstP (F w)) {ConstP (F i) | i. i \<in> V}
   \<turnstile> SubstFormP \<lceil>Var w\<rceil> (F w)
                (ssubst (vquot_dbfm V dbfm) V F)
                (subst w (F w) (ssubst (vquot_dbfm (insert w V) dbfm) V F))"
using w s
proof (induct dbfm rule: dbfm.induct)
  case (DBMem t u) thus ?case using V
    by (auto intro: SubstTermP_vquot_dbtm SubstFormP_Mem [THEN cut2])
next
  case (DBEq t u) thus ?case using V
    by (auto intro: SubstTermP_vquot_dbtm SubstFormP_Eq [THEN cut2])
next
  case (DBDisj A B) thus ?case using V
    by (auto intro: SubstFormP_Disj [THEN cut2])
next
  case (DBNeg A) thus ?case using V
    by (auto intro: SubstFormP_Neg [THEN cut1])
next
  case (DBEx A) thus ?case using V
    by (auto intro: SubstFormP_Ex [THEN cut1])
qed

text{*Lemmas 7.5 and 7.6*}
lemma ssubst_SubstFormP:
  fixes A::fm
  assumes w: "w \<in> Vs - V" and V: "V \<subseteq> Vs" "V' = p \<bullet> V"
      and s: "supp A \<subseteq> atom ` Vs"
  shows
  "insert (ConstP (F w)) {ConstP (F i) | i. i \<in> V}
   \<turnstile> SubstFormP \<lceil>Var w\<rceil> (F w)
                (ssubst \<lfloor>A\<rfloor>V V F)
                (ssubst \<lfloor>A\<rfloor>(insert w V) (insert w V) F)"
proof -
  have "w \<notin> V" using assms
    by auto
  thus ?thesis using assms
    by (simp add: vquot_fm_def supp_conv_fresh ssubst_insert_if SubstFormP_vquot_dbfm)
qed

text{*Theorem 7.3*}
theorem PfP_implies_PfP_ssubst:
  fixes \<beta>::fm
  assumes \<beta>: "{} \<turnstile> PfP \<lceil>\<beta>\<rceil>"
      and V: "V \<subseteq> Vs"
      and s: "supp \<beta> \<subseteq> atom ` Vs"
    shows    "{ConstP (F i) | i. i \<in> V} \<turnstile> PfP (ssubst \<lfloor>\<beta>\<rfloor>V V F)"
proof -
  show ?thesis using finite_V [OF V] V
  proof induction
    case empty thus ?case
      by (auto simp: \<beta>)
  next
    case (insert i V)
    thus ?case using assms
      by (auto simp: Collect_disj_Un fresh_finite_set_at_base
               intro: PfP_implies_SubstForm_PfP thin1 ssubst_SubstFormP)
  qed
qed

end

end


theory Lexer
  imports PosixSpec
begin

section \<open>The Lexer Functions by Sulzmann and Lu  (without simplification)\<close>

fun
  mkeps :: "rexp \<Rightarrow> val"
where
  "mkeps(ONE) = Void"
| "mkeps(SEQ r1 r2) = Seq (mkeps r1) (mkeps r2)"
| "mkeps(ALT r1 r2) = (if nullable(r1) then Left (mkeps r1) else Right (mkeps r2))"
| "mkeps(STAR r) = Stars []"
| "mkeps(NTIMES r n) = Stars (replicate n (mkeps r))"

fun injval :: "rexp \<Rightarrow> char \<Rightarrow> val \<Rightarrow> val"
where
  "injval (CH d) c Void = Char d"
| "injval (ALT r1 r2) c (Left v1) = Left(injval r1 c v1)"
| "injval (ALT r1 r2) c (Right v2) = Right(injval r2 c v2)"
| "injval (SEQ r1 r2) c (Seq v1 v2) = Seq (injval r1 c v1) v2"
| "injval (SEQ r1 r2) c (Left (Seq v1 v2)) = Seq (injval r1 c v1) v2"
| "injval (SEQ r1 r2) c (Right v2) = Seq (mkeps r1) (injval r2 c v2)"
| "injval (STAR r) c (Seq v (Stars vs)) = Stars ((injval r c v) # vs)"
| "injval (NTIMES r n) c (Seq v (Stars vs)) = Stars ((injval r c v) # vs)"

fun
  lexer :: "rexp \<Rightarrow> string \<Rightarrow> val option"
where
  "lexer r [] = (if nullable r then Some(mkeps r) else None)"
| "lexer r (c#s) = (case (lexer (der c r) s) of
                    None \<Rightarrow> None
                  | Some(v) \<Rightarrow> Some(injval r c v))"

section \<open>Mkeps, Injval Properties\<close>

lemma mkeps_flat:
  assumes "nullable(r)"
  shows "flat (mkeps r) = []"
using assms
  by (induct rule: mkeps.induct) (auto)

lemma Prf_NTimes_empty:
  assumes "\<forall>v \<in> set vs. \<Turnstile> v : r \<and> flat v = []"
  and     "length vs = n"
  shows "\<Turnstile> Stars vs : NTIMES r n"
  using assms
  by (metis Prf.intros(7) empty_iff eq_Nil_appendI list.set(1))

lemma mkeps_nullable:
  assumes "nullable(r)"
  shows "\<Turnstile> mkeps r : r"
using assms
  apply (induct rule: mkeps.induct)
  apply(auto intro: Prf.intros split: if_splits)
  apply (metis Prf.intros(7) append_is_Nil_conv empty_iff list.set(1) list.size(3))
  apply(rule Prf_NTimes_empty)
  apply(auto simp add: mkeps_flat)
  done

lemma Prf_injval_flat:
  assumes "\<Turnstile> v : der c r"
  shows "flat (injval r c v) = c # (flat v)"
using assms
apply(induct c r arbitrary: v rule: der.induct)
apply(auto elim!: Prf_elims intro: mkeps_flat split: if_splits)
done

lemma Prf_injval:
  assumes "\<Turnstile> v : der c r"
  shows "\<Turnstile> (injval r c v) : r"
using assms
apply(induct r arbitrary: c v rule: rexp.induct)
apply(auto intro!: Prf.intros mkeps_nullable elim!: Prf_elims simp add: Prf_injval_flat split: if_splits)[7]
(* NTimes *)
apply(case_tac x2)
apply(simp)
apply(simp)
apply(subst append.simps(2)[symmetric])
  apply(rule Prf.intros)
  apply (metis Prf_injval_flat list.distinct(1) set_ConsD)
  apply blast
  by simp

text \<open>Mkeps and injval produce, or preserve, Posix values.\<close>

lemma Posix_mkeps:
  assumes "nullable r"
  shows "[] \<in> r \<rightarrow> mkeps r"
using assms
apply(induct r rule: nullable.induct)
apply(auto intro: Posix.intros simp add: nullable_correctness Sequ_def)
apply(subst append.simps(1)[symmetric])
apply(rule Posix.intros)
apply(auto)
  apply(simp add: Posix_NTIMES2 pow_empty_iff)
  done

lemma Posix_injval:
  assumes "s \<in> (der c r) \<rightarrow> v"
  shows "(c # s) \<in> r \<rightarrow> (injval r c v)"
using assms
proof(induct r arbitrary: s v rule: rexp.induct)
  case ZERO
  have "s \<in> der c ZERO \<rightarrow> v" by fact
  then have "s \<in> ZERO \<rightarrow> v" by simp
  then have "False" by cases
  then show "(c # s) \<in> ZERO \<rightarrow> (injval ZERO c v)" by simp
next
  case ONE
  have "s \<in> der c ONE \<rightarrow> v" by fact
  then have "s \<in> ZERO \<rightarrow> v" by simp
  then have "False" by cases
  then show "(c # s) \<in> ONE \<rightarrow> (injval ONE c v)" by simp
next
  case (CH d)
  consider (eq) "c = d" | (ineq) "c \<noteq> d" by blast
  then show "(c # s) \<in> (CH d) \<rightarrow> (injval (CH d) c v)"
  proof (cases)
    case eq
    have "s \<in> der c (CH d) \<rightarrow> v" by fact
    then have "s \<in> ONE \<rightarrow> v" using eq by simp
    then have eqs: "s = [] \<and> v = Void" by cases simp
    show "(c # s) \<in> CH d \<rightarrow> injval (CH d) c v" using eq eqs
    by (auto intro: Posix.intros)
  next
    case ineq
    have "s \<in> der c (CH d) \<rightarrow> v" by fact
    then have "s \<in> ZERO \<rightarrow> v" using ineq by simp
    then have "False" by cases
    then show "(c # s) \<in> CH d \<rightarrow> injval (CH d) c v" by simp
  qed
next
  case (ALT r1 r2)
  have IH1: "\<And>s v. s \<in> der c r1 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r1 \<rightarrow> injval r1 c v" by fact
  have IH2: "\<And>s v. s \<in> der c r2 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r2 \<rightarrow> injval r2 c v" by fact
  have "s \<in> der c (ALT r1 r2) \<rightarrow> v" by fact
  then have "s \<in> ALT (der c r1) (der c r2) \<rightarrow> v" by simp
  then consider (left) v' where "v = Left v'" "s \<in> der c r1 \<rightarrow> v'"
              | (right) v' where "v = Right v'" "s \<notin> L (der c r1)" "s \<in> der c r2 \<rightarrow> v'"
              by cases auto
  then show "(c # s) \<in> ALT r1 r2 \<rightarrow> injval (ALT r1 r2) c v"
  proof (cases)
    case left
    have "s \<in> der c r1 \<rightarrow> v'" by fact
    then have "(c # s) \<in> r1 \<rightarrow> injval r1 c v'" using IH1 by simp
    then have "(c # s) \<in> ALT r1 r2 \<rightarrow> injval (ALT r1 r2) c (Left v')" by (auto intro: Posix.intros)
    then show "(c # s) \<in> ALT r1 r2 \<rightarrow> injval (ALT r1 r2) c v" using left by simp
  next
    case right
    have "s \<notin> L (der c r1)" by fact
    then have "c # s \<notin> L r1" by (simp add: der_correctness Der_def)
    moreover
    have "s \<in> der c r2 \<rightarrow> v'" by fact
    then have "(c # s) \<in> r2 \<rightarrow> injval r2 c v'" using IH2 by simp
    ultimately have "(c # s) \<in> ALT r1 r2 \<rightarrow> injval (ALT r1 r2) c (Right v')"
      by (auto intro: Posix.intros)
    then show "(c # s) \<in> ALT r1 r2 \<rightarrow> injval (ALT r1 r2) c v" using right by simp
  qed
next
  case (SEQ r1 r2)
  have IH1: "\<And>s v. s \<in> der c r1 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r1 \<rightarrow> injval r1 c v" by fact
  have IH2: "\<And>s v. s \<in> der c r2 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r2 \<rightarrow> injval r2 c v" by fact
  have "s \<in> der c (SEQ r1 r2) \<rightarrow> v" by fact
  then consider
        (left_nullable) v1 v2 s1 s2 where
        "v = Left (Seq v1 v2)"  "s = s1 @ s2"
        "s1 \<in> der c r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" "nullable r1"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r1) \<and> s\<^sub>4 \<in> L r2)"
      | (right_nullable) v1 s1 s2 where
        "v = Right v1" "s = s1 @ s2"
        "s \<in> der c r2 \<rightarrow> v1" "nullable r1" "s1 @ s2 \<notin> L (SEQ (der c r1) r2)"
      | (not_nullable) v1 v2 s1 s2 where
        "v = Seq v1 v2" "s = s1 @ s2"
        "s1 \<in> der c r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" "\<not>nullable r1"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r1) \<and> s\<^sub>4 \<in> L r2)"
        by (force split: if_splits elim!: Posix_elims simp add: Sequ_def der_correctness Der_def)
  then show "(c # s) \<in> SEQ r1 r2 \<rightarrow> injval (SEQ r1 r2) c v"
    proof (cases)
      case left_nullable
      have "s1 \<in> der c r1 \<rightarrow> v1" by fact
      then have "(c # s1) \<in> r1 \<rightarrow> injval r1 c v1" using IH1 by simp
      moreover
      have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r1) \<and> s\<^sub>4 \<in> L r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)" by (simp add: der_correctness Der_def)
      ultimately have "((c # s1) @ s2) \<in> SEQ r1 r2 \<rightarrow> Seq (injval r1 c v1) v2" using left_nullable by (rule_tac Posix.intros)
      then show "(c # s) \<in> SEQ r1 r2 \<rightarrow> injval (SEQ r1 r2) c v" using left_nullable by simp
    next
      case right_nullable
      have "nullable r1" by fact
      then have "[] \<in> r1 \<rightarrow> (mkeps r1)" by (rule Posix_mkeps)
      moreover
      have "s \<in> der c r2 \<rightarrow> v1" by fact
      then have "(c # s) \<in> r2 \<rightarrow> (injval r2 c v1)" using IH2 by simp
      moreover
      have "s1 @ s2 \<notin> L (SEQ (der c r1) r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = c # s \<and> [] @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)" using right_nullable
        by(auto simp add: der_correctness Der_def append_eq_Cons_conv Sequ_def)
      ultimately have "([] @ (c # s)) \<in> SEQ r1 r2 \<rightarrow> Seq (mkeps r1) (injval r2 c v1)"
      by(rule Posix.intros)
      then show "(c # s) \<in> SEQ r1 r2 \<rightarrow> injval (SEQ r1 r2) c v" using right_nullable by simp
    next
      case not_nullable
      have "s1 \<in> der c r1 \<rightarrow> v1" by fact
      then have "(c # s1) \<in> r1 \<rightarrow> injval r1 c v1" using IH1 by simp
      moreover
      have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r1) \<and> s\<^sub>4 \<in> L r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)" by (simp add: der_correctness Der_def)
      ultimately have "((c # s1) @ s2) \<in> SEQ r1 r2 \<rightarrow> Seq (injval r1 c v1) v2" using not_nullable
        by (rule_tac Posix.intros) (simp_all)
      then show "(c # s) \<in> SEQ r1 r2 \<rightarrow> injval (SEQ r1 r2) c v" using not_nullable by simp
    qed
next
  case (STAR r)
  have IH: "\<And>s v. s \<in> der c r \<rightarrow> v \<Longrightarrow> (c # s) \<in> r \<rightarrow> injval r c v" by fact
  have "s \<in> der c (STAR r) \<rightarrow> v" by fact
  then consider
      (cons) v1 vs s1 s2 where
        "v = Seq v1 (Stars vs)" "s = s1 @ s2"
        "s1 \<in> der c r \<rightarrow> v1" "s2 \<in> (STAR r) \<rightarrow> (Stars vs)"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r) \<and> s\<^sub>4 \<in> L (STAR r))"
        apply(auto elim!: Posix_elims(1-5) simp add: der_correctness Der_def intro: Posix.intros)
        apply(rotate_tac 3)
        apply(erule_tac Posix_elims(6))
        apply (simp add: Posix.intros(6))
        using Posix.intros(7) by blast
    then show "(c # s) \<in> STAR r \<rightarrow> injval (STAR r) c v"
    proof (cases)
      case cons
          have "s1 \<in> der c r \<rightarrow> v1" by fact
          then have "(c # s1) \<in> r \<rightarrow> injval r c v1" using IH by simp
        moreover
          have "s2 \<in> STAR r \<rightarrow> Stars vs" by fact
        moreover
          have "(c # s1) \<in> r \<rightarrow> injval r c v1" by fact
          then have "flat (injval r c v1) = (c # s1)" by (rule Posix1)
          then have "flat (injval r c v1) \<noteq> []" by simp
        moreover
          have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r) \<and> s\<^sub>4 \<in> L (STAR r))" by fact
          then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (STAR r))"
            by (simp add: der_correctness Der_def)
        ultimately
        have "((c # s1) @ s2) \<in> STAR r \<rightarrow> Stars (injval r c v1 # vs)" by (rule Posix.intros)
        then show "(c # s) \<in> STAR r \<rightarrow> injval (STAR r) c v" using cons by(simp)
      qed
next
  case (NTIMES r n)
  have IH: "\<And>s v. s \<in> der c r \<rightarrow> v \<Longrightarrow> (c # s) \<in> r \<rightarrow> injval r c v" by fact
  have "s \<in> der c (NTIMES r n) \<rightarrow> v" by fact
  then consider
      (cons) v1 vs s1 s2 where
        "v = Seq v1 (Stars vs)" "s = s1 @ s2"
        "s1 \<in> der c r \<rightarrow> v1" "s2 \<in> (NTIMES r (n - 1)) \<rightarrow> (Stars vs)" "0 < n"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r) \<and> s\<^sub>4 \<in> L (NTIMES r (n - 1)))"
    apply(auto elim: Posix_elims simp add: der_correctness Der_def intro: Posix.intros split: if_splits)
    apply(erule Posix_elims)
    apply(simp)
    apply(subgoal_tac "\<exists>vss. v2 = Stars vss")
    apply(clarify)
    apply(drule_tac x="vss" in meta_spec)
    apply(drule_tac x="s1" in meta_spec)
    apply(drule_tac x="s2" in meta_spec)
     apply(simp add: der_correctness Der_def)
    apply(erule Posix_elims)
     apply(auto)
      done
    then show "(c # s) \<in> (NTIMES r n) \<rightarrow> injval (NTIMES r n) c v"
    proof (cases)
      case cons
          have "s1 \<in> der c r \<rightarrow> v1" by fact
          then have "(c # s1) \<in> r \<rightarrow> injval r c v1" using IH by simp
        moreover
          have "s2 \<in> (NTIMES r (n - 1)) \<rightarrow> Stars vs" by fact
        moreover
          have "(c # s1) \<in> r \<rightarrow> injval r c v1" by fact
          then have "flat (injval r c v1) = (c # s1)" by (rule Posix1)
          then have "flat (injval r c v1) \<noteq> []" by simp
        moreover
          have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r) \<and> s\<^sub>4 \<in> L (NTIMES r (n - 1)))" by fact
          then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (NTIMES r (n - 1)))"
            by (simp add: der_correctness Der_def)
        ultimately
        have "((c # s1) @ s2) \<in> NTIMES r n \<rightarrow> Stars (injval r c v1 # vs)"
          by (metis One_nat_def Posix_NTIMES1 Suc_eq_plus1 Suc_pred cons(5))
        then show "(c # s) \<in> NTIMES r n \<rightarrow> injval (NTIMES r n) c v" using cons by(simp)
      qed
qed

section \<open>Lexer Correctness\<close>

lemma lexer_correct_None:
  shows "s \<notin> L r \<longleftrightarrow> lexer r s = None"
  apply(induct s arbitrary: r)
  apply(simp)
  apply(simp add: nullable_correctness)
  apply(simp)
  apply(drule_tac x="der a r" in meta_spec)
  apply(auto)
  apply(auto simp add: der_correctness Der_def)
done

lemma lexer_correct_Some:
  shows "s \<in> L r \<longleftrightarrow> (\<exists>v. lexer r s = Some(v) \<and> s \<in> r \<rightarrow> v)"
  apply(induct s arbitrary : r)
  apply(simp only: lexer.simps)
  apply(simp)
  apply(simp add: nullable_correctness Posix_mkeps)
  apply(drule_tac x="der a r" in meta_spec)
  apply(simp (no_asm_use) add: der_correctness Der_def del: lexer.simps)
  apply(simp del: lexer.simps)
  apply(simp only: lexer.simps)
  apply(case_tac "lexer (der a r) s = None")
   apply(auto)[1]
  apply(simp)
  apply(erule exE)
  apply(simp)
  apply(rule iffI)
  apply(simp add: Posix_injval)
  apply(simp add: Posix1(1))
done

lemma lexer_correctness:
  shows "(lexer r s = Some v) \<longleftrightarrow> s \<in> r \<rightarrow> v"
  and   "(lexer r s = None) \<longleftrightarrow> \<not>(\<exists>v. s \<in> r \<rightarrow> v)"
using Posix1(1) Posix_determ lexer_correct_None lexer_correct_Some apply fastforce
using Posix1(1) lexer_correct_None lexer_correct_Some by blast

subsection {* A slight reformulation of the lexer algorithm using stacked functions*}

fun flex :: "rexp \<Rightarrow> (val \<Rightarrow> val) => string \<Rightarrow> (val \<Rightarrow> val)"
  where
  "flex r f [] = f"
| "flex r f (c#s) = flex (der c r) (\<lambda>v. f (injval r c v)) s"

lemma flex_fun_apply:
  shows "g (flex r f s v) = flex r (g o f) s v"
  apply(induct s arbitrary: g f r v)
  apply(simp_all add: comp_def)
  by meson

lemma flex_fun_apply2:
  shows "g (flex r id s v) = flex r g s v"
  by (simp add: flex_fun_apply)

lemma flex_append:
  shows "flex r f (s1 @ s2) = flex (ders s1 r) (flex r f s1) s2"
  apply(induct s1 arbitrary: s2 r f)
  apply(simp_all)
  done

lemma lexer_flex:
  shows "lexer r s = (if nullable (ders s r)
                      then Some(flex r id s (mkeps (ders s r))) else None)"
  apply(induct s arbitrary: r)
  apply(simp_all add: flex_fun_apply)
  done

lemma Posix_flex:
  assumes "s2 \<in> (ders s1 r) \<rightarrow> v"
  shows "(s1 @ s2) \<in> r \<rightarrow> flex r id s1 v"
  using assms
  apply(induct s1 arbitrary: r v s2)
  apply(simp)
  apply(simp)
  apply(drule_tac x="der a r" in meta_spec)
  apply(drule_tac x="v" in meta_spec)
  apply(drule_tac x="s2" in meta_spec)
  apply(simp)
  using  Posix_injval
  apply(drule_tac Posix_injval)
  apply(subst (asm) (5) flex_fun_apply)
  apply(simp)
  done

lemma injval_inj:
  assumes "\<Turnstile> a : (der c r)" "\<Turnstile> v : (der c r)" "injval r c a = injval r c v"
  shows "a = v"
  using  assms
  apply(induct r arbitrary: a c v)
       apply(auto)
  using Prf_elims(1) apply blast
  using Prf_elims(1) apply blast
     apply(case_tac "c = x")
      apply(auto)
  using Prf_elims(4) apply auto[1]
  using Prf_elims(1) apply blast
    prefer 2
  apply (smt Prf_elims(3) injval.simps(2) injval.simps(3) val.distinct(25) val.inject(3) val.inject(4))
  apply(case_tac "nullable r1")
    apply(auto)
    apply(erule Prf_elims)
     apply(erule Prf_elims)
     apply(erule Prf_elims)
      apply(erule Prf_elims)
      apply(auto)
     apply (metis Prf_injval_flat list.distinct(1) mkeps_flat)
  apply(erule Prf_elims)
     apply(erule Prf_elims)
  apply(auto)
  using Prf_injval_flat mkeps_flat apply fastforce
  apply(erule Prf_elims)
     apply(erule Prf_elims)
   apply(auto)
  apply(erule Prf_elims)
     apply(erule Prf_elims)
  apply(auto)
   apply (smt Prf_elims(6) injval.simps(7) list.inject val.inject(5))
  apply (smt Prf_elims(6) injval.simps(7) list.inject val.inject(5))
  apply(smt (verit, best) Prf_elims(1) Prf_elims(2) Prf_elims(7) injval.simps(8) list.inject val.simps(5))
  done

lemma uu:
  assumes "(c # s) \<in> r \<rightarrow> injval r c v" "\<Turnstile> v : (der c r)"
  shows "s \<in> der c r \<rightarrow> v"
  using assms
  apply -
  apply(subgoal_tac "lexer r (c # s) = Some (injval r c v)")
  prefer 2
  using lexer_correctness(1) apply blast
  apply(simp add: )
  apply(case_tac  "lexer (der c r) s")
   apply(simp)
  apply(simp)
  apply(case_tac "s \<in> der c r \<rightarrow> a")
   prefer 2
   apply (simp add: lexer_correctness(1))
  apply(subgoal_tac "\<Turnstile> a : (der c r)")
   prefer 2
  using Posix1a apply blast
  using injval_inj by blast

lemma Posix_flex2:
  assumes "(s1 @ s2) \<in> r \<rightarrow> flex r id s1 v" "\<Turnstile> v : ders s1 r"
  shows "s2 \<in> (ders s1 r) \<rightarrow> v"
  using assms
  apply(induct s1 arbitrary: r v s2 rule: rev_induct)
  apply(simp)
  apply(simp)
  apply(drule_tac x="r" in meta_spec)
  apply(drule_tac x="injval (ders xs r) x v" in meta_spec)
  apply(drule_tac x="x#s2" in meta_spec)
  apply(simp add: flex_append ders_append)
  using Prf_injval uu by blast

lemma Posix_flex3:
  assumes "s1 \<in> r \<rightarrow> flex r id s1 v" "\<Turnstile> v : ders s1 r"
  shows "[] \<in> (ders s1 r) \<rightarrow> v"
  using assms
  by (simp add: Posix_flex2)

lemma flex_injval:
  shows "flex (der a r) (injval r a) s v = injval r a (flex (der a r) id s v)"
  by (simp add: flex_fun_apply)

lemma Prf_flex:
  assumes "\<Turnstile> v : ders s r"
  shows "\<Turnstile> flex r id s v : r"
  using assms
  apply(induct s arbitrary: v r)
  apply(simp)
  apply(simp)
  by (simp add: Prf_injval flex_injval)

unused_thms

end


(*  Title:      HOL/TLA/Memory/MemoryParameters.thy
    Author:     Stephan Merz, University of Munich
*)

section \<open>RPC-Memory example: Memory parameters\<close>

theory MemoryParameters
imports RPCMemoryParams
begin

(* the memory operations *)
datatype memOp = read Locs | "write" Locs Vals

consts
  (* memory locations and contents *)
  MemLoc         :: "Locs set"
  MemVal         :: "Vals set"

  (* some particular values *)
  OK             :: "Vals"
  BadArg         :: "Vals"
  MemFailure     :: "Vals"
  NotAResult     :: "Vals"  (* defined here for simplicity *)

  (* the initial value stored in each memory cell *)
  InitVal        :: "Vals"

axiomatization where
  (* basic assumptions about the above constants and predicates *)
  BadArgNoMemVal:    "BadArg \<notin> MemVal" and
  MemFailNoMemVal:   "MemFailure \<notin> MemVal" and
  InitValMemVal:     "InitVal \<in> MemVal" and
  NotAResultNotVal:  "NotAResult \<notin> MemVal" and
  NotAResultNotOK:   "NotAResult \<noteq> OK" and
  NotAResultNotBA:   "NotAResult \<noteq> BadArg" and
  NotAResultNotMF:   "NotAResult \<noteq> MemFailure"

lemmas [simp] =
  BadArgNoMemVal MemFailNoMemVal InitValMemVal NotAResultNotVal
  NotAResultNotOK NotAResultNotBA NotAResultNotMF
  NotAResultNotOK [symmetric] NotAResultNotBA [symmetric] NotAResultNotMF [symmetric]

lemma MemValNotAResultE: "\<lbrakk> x \<in> MemVal; (x \<noteq> NotAResult \<Longrightarrow> P) \<rbrakk> \<Longrightarrow> P"
  using NotAResultNotVal by blast

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>\<open>CAT\<close> as a semicategory\label{sec:smc_CAT}\<close>
theory CZH_SMC_CAT
  imports
    CZH_DG_CAT
    CZH_ECAT_Simple
begin

subsection\<open>Background\<close>

text\<open>
The subsection presents the theory of the semicategories of \<open>\<alpha>\<close>-categories.
It continues the development that was initiated in section
\ref{sec:dg_CAT}.
\<close>

named_theorems smc_CAT_simps
named_theorems smc_CAT_intros

subsection\<open>Definition and elementary properties\<close>

definition smc_CAT :: "V \<Rightarrow> V"
  where "smc_CAT \<alpha> =
    [
      set {\<CC>. category \<alpha> \<CC>},
      all_cfs \<alpha>,
      (\<lambda>\<FF>\<in>\<^sub>\<circ>all_cfs \<alpha>. \<FF>\<lparr>HomDom\<rparr>),
      (\<lambda>\<FF>\<in>\<^sub>\<circ>all_cfs \<alpha>. \<FF>\<lparr>HomCod\<rparr>),
      (\<lambda>\<GG>\<FF>\<in>\<^sub>\<circ>composable_arrs (dg_CAT \<alpha>). \<GG>\<FF>\<lparr>0\<rparr> \<circ>\<^sub>C\<^sub>F \<GG>\<FF>\<lparr>1\<^sub>\<nat>\<rparr>)
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma smc_CAT_components:
  shows "smc_CAT \<alpha>\<lparr>Obj\<rparr> = set {\<CC>. category \<alpha> \<CC>}"
    and "smc_CAT \<alpha>\<lparr>Arr\<rparr> = all_cfs \<alpha>"
    and "smc_CAT \<alpha>\<lparr>Dom\<rparr> = (\<lambda>\<FF>\<in>\<^sub>\<circ>all_cfs \<alpha>. \<FF>\<lparr>HomDom\<rparr>)"
    and "smc_CAT \<alpha>\<lparr>Cod\<rparr> = (\<lambda>\<FF>\<in>\<^sub>\<circ>all_cfs \<alpha>. \<FF>\<lparr>HomCod\<rparr>)"
    and "smc_CAT \<alpha>\<lparr>Comp\<rparr> = (\<lambda>\<GG>\<FF>\<in>\<^sub>\<circ>composable_arrs (dg_CAT \<alpha>). \<GG>\<FF>\<lparr>0\<rparr> \<circ>\<^sub>C\<^sub>F \<GG>\<FF>\<lparr>1\<^sub>\<nat>\<rparr>)"
  unfolding smc_CAT_def dg_field_simps by (simp_all add: nat_omega_simps)

text\<open>Slicing.\<close>

lemma smc_dg_CAT: "smc_dg (smc_CAT \<alpha>) = dg_CAT \<alpha>"
proof(rule vsv_eqI)
  show "vsv (smc_dg (smc_CAT \<alpha>))" unfolding smc_dg_def by auto
  show "vsv (dg_CAT \<alpha>)" unfolding dg_CAT_def by auto
  have dom_lhs: "\<D>\<^sub>\<circ> (smc_dg (smc_CAT \<alpha>)) = 4\<^sub>\<nat>"
    unfolding smc_dg_def by (simp add: nat_omega_simps)
  have dom_rhs: "\<D>\<^sub>\<circ> (dg_CAT \<alpha>) = 4\<^sub>\<nat>"
    unfolding dg_CAT_def by (simp add: nat_omega_simps)
  show "\<D>\<^sub>\<circ> (smc_dg (smc_CAT \<alpha>)) = \<D>\<^sub>\<circ> (dg_CAT \<alpha>)"
    unfolding dom_lhs dom_rhs by simp
  show "\<AA> \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_dg (smc_CAT \<alpha>)) \<Longrightarrow> smc_dg (smc_CAT \<alpha>)\<lparr>\<AA>\<rparr> = dg_CAT \<alpha>\<lparr>\<AA>\<rparr>"
    for \<AA>
    by
      (
        unfold dom_lhs,
        elim_in_numeral,
        unfold smc_dg_def dg_field_simps smc_CAT_def dg_CAT_def
      )
      (auto simp: nat_omega_simps)
qed

lemmas_with [folded smc_dg_CAT, unfolded slicing_simps]:
  smc_CAT_ObjI = dg_CAT_ObjI
  and smc_CAT_ObjD = dg_CAT_ObjD
  and smc_CAT_ObjE = dg_CAT_ObjE
  and smc_CAT_Obj_iff[smc_CAT_simps] = dg_CAT_Obj_iff
  and smc_CAT_Dom_app[smc_CAT_simps] = dg_CAT_Dom_app
  and smc_CAT_Cod_app[smc_CAT_simps] = dg_CAT_Cod_app
  and smc_CAT_is_arrI = dg_CAT_is_arrI
  and smc_CAT_is_arrD = dg_CAT_is_arrD
  and smc_CAT_is_arrE = dg_CAT_is_arrE
  and smc_CAT_is_arr_iff[smc_CAT_simps] = dg_CAT_is_arr_iff

subsection\<open>Composable arrows\<close>

lemma smc_CAT_composable_arrs_dg_CAT:
  "composable_arrs (dg_CAT \<alpha>) = composable_arrs (smc_CAT \<alpha>)"
  unfolding composable_arrs_def smc_dg_CAT[symmetric] slicing_simps by auto

lemma smc_CAT_Comp:
  "smc_CAT \<alpha>\<lparr>Comp\<rparr> = (\<lambda>\<GG>\<FF>\<in>\<^sub>\<circ>composable_arrs (smc_CAT \<alpha>). \<GG>\<FF>\<lparr>0\<rparr> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG>\<FF>\<lparr>1\<^sub>\<nat>\<rparr>)"
  unfolding smc_CAT_components smc_CAT_composable_arrs_dg_CAT ..

subsection\<open>Composition\<close>

lemma smc_CAT_Comp_app[smc_CAT_simps]:
  assumes "\<GG> : \<BB> \<mapsto>\<^bsub>smc_CAT \<alpha>\<^esub> \<CC>" and "\<FF> : \<AA> \<mapsto>\<^bsub>smc_CAT \<alpha>\<^esub> \<BB>"
  shows "\<GG> \<circ>\<^sub>A\<^bsub>smc_CAT \<alpha>\<^esub> \<FF> = \<GG> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<FF>"
proof-
  from assms have "[\<GG>, \<FF>]\<^sub>\<circ> \<in>\<^sub>\<circ> composable_arrs (smc_CAT \<alpha>)"
    by (auto simp: smc_cs_intros)
  then show "\<GG> \<circ>\<^sub>A\<^bsub>smc_CAT \<alpha>\<^esub> \<FF> = \<GG> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<FF>"
    unfolding smc_CAT_Comp by (simp add: nat_omega_simps)
qed

lemma smc_CAT_Comp_vdomain: "\<D>\<^sub>\<circ> (smc_CAT \<alpha>\<lparr>Comp\<rparr>) = composable_arrs (smc_CAT \<alpha>)"
  unfolding smc_CAT_Comp by auto

lemma smc_CAT_Comp_vrange: "\<R>\<^sub>\<circ> (smc_CAT \<alpha>\<lparr>Comp\<rparr>) \<subseteq>\<^sub>\<circ> all_cfs \<alpha>"
proof(rule vsubsetI)
  fix \<HH> assume "\<HH> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (smc_CAT \<alpha>\<lparr>Comp\<rparr>)"
  then obtain \<GG>\<FF>
    where \<HH>_def: "\<HH> = smc_CAT \<alpha>\<lparr>Comp\<rparr>\<lparr>\<GG>\<FF>\<rparr>"
      and "\<GG>\<FF> \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_CAT \<alpha>\<lparr>Comp\<rparr>)"
    by (auto simp: smc_CAT_components intro: smc_cs_intros)
  then obtain \<GG> \<FF> \<AA> \<BB> \<CC>
    where "\<GG>\<FF> = [\<GG>, \<FF>]\<^sub>\<circ>"
      and \<GG>: "\<GG> : \<BB> \<mapsto>\<^bsub>smc_CAT \<alpha>\<^esub> \<CC>"
      and \<FF>: "\<FF> : \<AA> \<mapsto>\<^bsub>smc_CAT \<alpha>\<^esub> \<BB>"
    by (auto simp: smc_CAT_Comp_vdomain)
  with \<HH>_def have \<HH>_def': "\<HH> = \<GG> \<circ>\<^sub>A\<^bsub>smc_CAT \<alpha>\<^esub> \<FF>" by simp
  from \<GG> \<FF> show "\<HH> \<in>\<^sub>\<circ> all_cfs \<alpha>"
    unfolding \<HH>_def' by (auto simp: smc_CAT_simps intro: cat_cs_intros)
qed

subsection\<open>\<open>CAT\<close> is a category\<close>

lemma (in \<Z>) tiny_semicategory_smc_CAT:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "tiny_semicategory \<beta> (smc_CAT \<alpha>)"
proof(intro tiny_semicategoryI, unfold smc_CAT_is_arr_iff)
  show "vfsequence (smc_CAT \<alpha>)" unfolding smc_CAT_def by auto
  show "vcard (smc_CAT \<alpha>) = 5\<^sub>\<nat>"
    unfolding smc_CAT_def by (simp add: nat_omega_simps)
  show "(\<GG>\<FF> \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_CAT \<alpha>\<lparr>Comp\<rparr>)) \<longleftrightarrow>
    (\<exists>\<GG> \<FF> \<BB> \<CC> \<AA>. \<GG>\<FF> = [\<GG>, \<FF>]\<^sub>\<circ> \<and> \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC> \<and> \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>)"
    for \<GG>\<FF>
    unfolding smc_CAT_Comp_vdomain
  proof
    show "\<GG>\<FF> \<in>\<^sub>\<circ> composable_arrs (smc_CAT \<alpha>) \<Longrightarrow>
      \<exists>\<GG> \<FF> \<BB> \<CC> \<AA>. \<GG>\<FF> = [\<GG>, \<FF>]\<^sub>\<circ> \<and> \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC> \<and> \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
      by (elim composable_arrsE) (auto simp: smc_CAT_is_arr_iff)
  next
    assume "\<exists>\<GG> \<FF> \<BB> \<CC> \<AA>. \<GG>\<FF> = [\<GG>, \<FF>]\<^sub>\<circ> \<and> \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC> \<and> \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    with smc_CAT_is_arr_iff show "\<GG>\<FF> \<in>\<^sub>\<circ> composable_arrs (smc_CAT \<alpha>)"
      unfolding smc_CAT_Comp_vdomain by (auto intro: smc_cs_intros)
  qed
  show "\<lbrakk> \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>; \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB> \<rbrakk> \<Longrightarrow>
    \<GG> \<circ>\<^sub>A\<^bsub>smc_CAT \<alpha>\<^esub> \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    for \<GG> \<BB> \<CC> \<FF> \<AA>
    by (cs_concl cs_simp: smc_CAT_simps cs_intro: cat_cs_intros)

  fix \<HH> \<CC> \<DD> \<GG> \<BB> \<FF> \<AA>
  assume "\<HH> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  moreover then have "\<GG> \<circ>\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" "\<HH> \<circ>\<^sub>C\<^sub>F \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
    by (cs_concl cs_simp: smc_CAT_simps cs_intro: cat_cs_intros)+
  ultimately show
    "\<HH> \<circ>\<^sub>A\<^bsub>smc_CAT \<alpha>\<^esub> \<GG> \<circ>\<^sub>A\<^bsub>smc_CAT \<alpha>\<^esub> \<FF> = \<HH> \<circ>\<^sub>A\<^bsub>smc_CAT \<alpha>\<^esub> (\<GG> \<circ>\<^sub>A\<^bsub>smc_CAT \<alpha>\<^esub> \<FF>)"
    by (simp add: smc_CAT_is_arr_iff smc_CAT_Comp_app cf_comp_assoc)
qed (auto simp: assms smc_dg_CAT tiny_category_dg_CAT smc_CAT_components)

subsection\<open>Initial object\<close>

lemma (in \<Z>) smc_CAT_obj_initialI: "obj_initial (smc_CAT \<alpha>) cat_0"
  \<comment>\<open>
  See \cite{noauthor_nlab_nodate}\footnote{\url{
  https://ncatlab.org/nlab/show/initial+object
  }}).
  \<close>
  unfolding obj_initial_def
proof(intro obj_terminalI, unfold smc_op_simps smc_CAT_is_arr_iff smc_CAT_Obj_iff)
  show "category \<alpha> cat_0" by (intro category_cat_0)
  fix \<AA> assume "category \<alpha> \<AA>"
  then interpret category \<alpha> \<AA> .
  show "\<exists>!f. f : cat_0 \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
  proof
    show cf_0: "cf_0 \<AA> : cat_0 \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
      by (simp add: cf_0_is_ft_functor category_axioms is_ft_functor.axioms(1))
    fix \<FF> assume prems: "\<FF> : cat_0 \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
    interpret \<FF>: is_functor \<alpha> cat_0 \<AA> \<FF> using prems .
    show "\<FF> = cf_0 \<AA>"
    proof(rule cf_eqI)
      show "\<FF> : cat_0 \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>" by (simp add: prems)
      from cf_0 show "cf_0 \<AA> : cat_0 \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
        unfolding smc_CAT_is_arr_iff by simp
      have "\<D>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = 0" by (auto simp: cat_0_components cat_cs_simps)
      then show "\<FF>\<lparr>ObjMap\<rparr> = cf_0 \<AA>\<lparr>ObjMap\<rparr>"
        using \<FF>.ObjMap.vbrelation_vintersection_vdomain
        by (auto simp: cf_0_components)
      have "\<D>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) = 0" by (auto simp: cat_0_components cat_cs_simps)
      with \<FF>.ArrMap.vbrelation_vintersection_vdomain show
        "\<FF>\<lparr>ArrMap\<rparr> = cf_0 \<AA>\<lparr>ArrMap\<rparr>"
        by (auto simp: cf_0_components)
    qed (simp_all add: cf_0_components)
  qed
qed

lemma (in \<Z>) smc_CAT_obj_initialD:
  assumes "obj_initial (smc_CAT \<alpha>) \<AA>"
  shows "\<AA> = cat_0"
  using assms unfolding obj_initial_def
proof(elim obj_terminalE, unfold smc_op_simps smc_CAT_is_arr_iff smc_CAT_Obj_iff)
  assume prems:
    "category \<alpha> \<AA>"
    "category \<alpha> \<BB> \<Longrightarrow> \<exists>!\<FF>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    for \<BB>
  from prems(2)[OF category_cat_0] obtain \<FF> where \<FF>: "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_0"
    by meson
  interpret \<FF>: is_functor \<alpha> \<AA> cat_0 \<FF> by (rule \<FF>)
  have "\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> 0"
    unfolding cat_0_components(1)[symmetric] by (simp add: \<FF>.cf_ObjMap_vrange)
  then have "\<FF>\<lparr>ObjMap\<rparr> = 0" by (auto intro: \<FF>.ObjMap.vsv_vrange_vempty)
  with \<FF>.cf_ObjMap_vdomain have Obj[simp]: "\<AA>\<lparr>Obj\<rparr> = 0" by auto
  have "\<R>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> 0"
    unfolding cat_0_components(2)[symmetric] by (simp add: \<FF>.cf_ArrMap_vrange)
  then have "\<FF>\<lparr>ArrMap\<rparr> = 0" by (auto intro: \<FF>.ArrMap.vsv_vrange_vempty)
  with \<FF>.cf_ArrMap_vdomain have Arr[simp]: "\<AA>\<lparr>Arr\<rparr> = 0" by auto
  from \<FF>.HomDom.Dom.vdomain_vrange_is_vempty have [simp]: "\<AA>\<lparr>Dom\<rparr> = 0"
    by (fastforce simp: \<FF>.HomDom.cat_Dom_vempty_if_Arr_vempty)
  from \<FF>.HomDom.Cod.vdomain_vrange_is_vempty have [simp]: "\<AA>\<lparr>Cod\<rparr> = 0"
    by (fastforce simp: \<FF>.HomDom.cat_Cod_vempty_if_Arr_vempty)
  from Arr have "\<AA>\<lparr>Arr\<rparr> ^\<^sub>\<times> 2\<^sub>\<nat> = 0" by (simp add: vcpower_of_vempty)
  with \<FF>.HomDom.Comp.pnop_vdomain have "\<D>\<^sub>\<circ> (\<AA>\<lparr>Comp\<rparr>) = 0" by simp
  with \<FF>.HomDom.Comp.vdomain_vrange_is_vempty have [simp]: "\<AA>\<lparr>Comp\<rparr> = 0"
    by (auto intro: \<FF>.HomDom.Comp.vsv_vrange_vempty)
  have "\<D>\<^sub>\<circ> (\<AA>\<lparr>CId\<rparr>) = 0"
    by (simp add: \<FF>.HomDom.cat_CId_vdomain)
  with \<FF>.HomDom.CId.vdomain_vrange_is_vempty \<FF>.HomDom.CId.vsv_vrange_vempty
  have [simp]: "\<AA>\<lparr>CId\<rparr> = 0"
    by simp
  show "\<AA> = cat_0"
    by (rule cat_eqI[of \<alpha>])
      (simp_all add: prems(1) cat_0_components category_cat_0)
qed

lemma (in \<Z>) smc_CAT_obj_initialE:
  assumes "obj_initial (smc_CAT \<alpha>) \<AA>"
  obtains "\<AA> = cat_0"
  using assms by (auto dest: smc_CAT_obj_initialD)

lemma (in \<Z>) smc_CAT_obj_initial_iff[smc_CAT_simps]:
  "obj_initial (smc_CAT \<alpha>) \<AA> \<longleftrightarrow> \<AA> = cat_0"
  using smc_CAT_obj_initialI smc_CAT_obj_initialD by auto

subsection\<open>Terminal object\<close>

lemma (in \<Z>) smc_CAT_obj_terminalI:
  \<comment>\<open>See \cite{noauthor_nlab_nodate}\footnote{\url{
  https://ncatlab.org/nlab/show/terminal+object
  }}.\<close>
  assumes "a \<in>\<^sub>\<circ> Vset \<alpha>" and "f \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "obj_terminal (smc_CAT \<alpha>) (cat_1 a f)"
proof(intro obj_terminalI, unfold smc_op_simps smc_CAT_is_arr_iff smc_CAT_Obj_iff)
  fix \<AA> assume prems: "category \<alpha> \<AA>"
  then interpret category \<alpha> \<AA> .
  show "\<exists>!\<FF>'. \<FF>' : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_1 a f"
  proof
    show cf_1: "cf_const \<AA> (cat_1 a f) a : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_1 a f"
      by (rule cf_const_is_functor)
        (auto simp: assms prems category_cat_1 cat_1_components)
    fix \<FF>' assume "\<FF>' : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_1 a f"
    then interpret \<FF>': is_functor \<alpha> \<AA> \<open>cat_1 a f\<close> \<FF>' .
    show "\<FF>' = cf_const \<AA> (cat_1 a f) a"
    proof(rule cf_eqI, unfold dghm_const_components)
      from cf_1 show "cf_const \<AA> (cat_1 a f) a : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_1 a f" by simp
      show "\<FF>'\<lparr>ObjMap\<rparr> = vconst_on (\<AA>\<lparr>Obj\<rparr>) a"
      proof(cases\<open>\<AA>\<lparr>Obj\<rparr> = 0\<close>)
        case True
        with \<FF>'.ObjMap.vbrelation_vintersection_vdomain have "\<FF>'\<lparr>ObjMap\<rparr> = 0"
          by (auto simp: cat_cs_simps)
        with True show ?thesis by simp
      next
        case False
        then have "\<D>\<^sub>\<circ> (\<FF>'\<lparr>ObjMap\<rparr>) \<noteq> 0" by (auto simp: cat_cs_simps)
        then have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ObjMap\<rparr>) \<noteq> 0"
          by (simp add: \<FF>'.ObjMap.vsv_vdomain_vempty_vrange_vempty)
        moreover from \<FF>'.cf_ObjMap_vrange have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> set {a}"
          by (simp add: cat_1_components)
        ultimately have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ObjMap\<rparr>) = set {a}" by auto
        then show ?thesis
          by (intro vsv.vsv_is_vconst_onI) (auto simp: cat_cs_simps)
      qed
      show "\<FF>'\<lparr>ArrMap\<rparr> = vconst_on (\<AA>\<lparr>Arr\<rparr>) (cat_1 a f\<lparr>CId\<rparr>\<lparr>a\<rparr>)"
      proof(cases\<open>\<AA>\<lparr>Arr\<rparr> = 0\<close>)
        case True
        with
          \<FF>'.ArrMap.vdomain_vrange_is_vempty
          vsv.vsv_vrange_vempty[OF \<FF>'.cf_ArrMap_vsv]
        have "\<FF>'\<lparr>ArrMap\<rparr> = 0"
          by (auto simp: cat_cs_simps)
        with True show ?thesis by simp
      next
        case False
        then have "\<D>\<^sub>\<circ> (\<FF>'\<lparr>ArrMap\<rparr>) \<noteq> 0" by (auto simp: cat_cs_simps)
        then have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ArrMap\<rparr>) \<noteq> 0"
          by (simp add: \<FF>'.ArrMap.vsv_vdomain_vempty_vrange_vempty)
        moreover from \<FF>'.cf_ArrMap_vrange have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> set {f}"
          by (simp add: cat_1_components)
        ultimately have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ArrMap\<rparr>) = set {f}" by auto
        then show ?thesis
          by
            (
              cs_concl cs_shallow
                cs_simp: V_cs_simps cat_cs_simps cat_1_components
                cs_intro: V_cs_intros vsv.vsv_is_vconst_onI
            )+
      qed
    qed (auto intro: cat_cs_intros)
  qed
qed (simp add: assms category_cat_1)

lemma (in \<Z>) smc_CAT_obj_terminalE:
  assumes "obj_terminal (smc_CAT \<alpha>) \<BB>"
  obtains a f where "a \<in>\<^sub>\<circ> Vset \<alpha>" and "f \<in>\<^sub>\<circ> Vset \<alpha>" and "\<BB> = cat_1 a f"
  using assms
proof(elim obj_terminalE, unfold cat_op_simps smc_CAT_is_arr_iff smc_CAT_Obj_iff)

  assume prems: "category \<alpha> \<BB>" "category \<alpha> \<AA> \<Longrightarrow> \<exists>!\<FF>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" for \<AA>
  interpret \<BB>: category \<alpha> \<BB> by (rule prems(1))

  obtain a where \<BB>_Obj: "\<BB>\<lparr>Obj\<rparr> = set {a}" and a: "a \<in>\<^sub>\<circ> Vset \<alpha>"
  proof-
    have cat_1: "category \<alpha> (cat_1 0 0)" by (rule category_cat_1) auto
    from prems(2)[OF cat_1] obtain \<FF>
      where \<FF>: "\<FF> : cat_1 0 0 \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
        and \<GG>\<FF>: "\<GG> : cat_1 0 0 \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB> \<Longrightarrow> \<GG> = \<FF>" for \<GG>
      by fastforce
    interpret \<FF>: is_functor \<alpha> \<open>cat_1 0 0\<close> \<BB> \<FF> by (rule \<FF>)
    have "\<D>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = set {0}" by (simp add: cat_1_components cat_cs_simps)
    then obtain a where vrange_\<FF>[simp]: "\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = set {a}"
      by (auto intro: \<FF>.ObjMap.vsv_vdomain_vsingleton_vrange_vsingleton)
    with \<BB>.cat_Obj_vsubset_Vset \<FF>.cf_ObjMap_vrange have [simp]: "a \<in>\<^sub>\<circ> Vset \<alpha>"
      by auto
    from \<FF>.cf_ObjMap_vrange have "set {a} \<subseteq>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" by simp
    moreover have "\<BB>\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> set {a}"
    proof(rule ccontr)
      assume "\<not>\<BB>\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> set {a}"
      then obtain b where ba: "b \<noteq> a" and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" by force
      have "cf_const (cat_1 0 0) \<BB> b : cat_1 0 0 \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
        by (rule cf_const_is_functor)
          (simp_all add: \<BB>.category_axioms category_cat_1 b)
      then have \<GG>_def: "cf_const (cat_1 0 0) \<BB> b = \<FF>" by (rule \<GG>\<FF>)
      have "\<R>\<^sub>\<circ> (cf_const (cat_1 0 0) \<BB> b\<lparr>ObjMap\<rparr>) = set {b}"
        unfolding dghm_const_components cat_1_components by simp
      with vrange_\<FF> ba show False unfolding \<GG>_def by simp
    qed
    ultimately have "\<BB>\<lparr>Obj\<rparr> = set {a}" by simp
    with that show ?thesis by simp
  qed

  have \<BB>_Arr: "\<BB>\<lparr>Arr\<rparr> = set {\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>}"
  proof(rule vsubset_antisym)
    from \<BB>_Obj show "set {\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>} \<subseteq>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
      by (blast intro: \<BB>.cat_is_arrD(1) cat_cs_intros)
    show "\<BB>\<lparr>Arr\<rparr> \<subseteq>\<^sub>\<circ> set {\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>}"
    proof(intro vsubsetI)
      fix f assume "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
      with \<BB>_Obj have f: "f : a \<mapsto>\<^bsub>\<BB>\<^esub> a"
        by (metis \<BB>.cat_is_arrD(2,3) is_arrI vsingleton_iff)
      from f have "cf_const \<BB> \<BB> a : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
        by (intro cf_const_is_functor) (auto simp: \<BB>.category_axioms)
      moreover from f have "cf_id \<BB> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
        by (intro category.cat_cf_id_is_functor)
          (auto simp: \<BB>.category_axioms)
      ultimately have "cf_const \<BB> \<BB> a = cf_id \<BB>"
        by (metis prems(2) \<BB>.category_axioms)
      moreover from f have "cf_const \<BB> \<BB> a\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> = \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>"
        by (simp add: \<open>f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>\<close> dghm_const_ArrMap_app)
      moreover from f have "cf_id \<BB>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> = f"
        unfolding dghm_id_components by (simp add: cat_cs_intros)
      ultimately show "f \<in>\<^sub>\<circ> set {\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>}" by simp
    qed
  qed

  have "\<BB> = cat_1 a (\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>)"
  proof(rule cat_eqI[of \<alpha>], unfold cat_1_components)
    from \<BB>.cat_Arr_vsubset_Vset \<BB>_Arr show "category \<alpha> (cat_1 a (\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>))"
      by (intro category_cat_1) (auto simp: a)
    show "\<BB>\<lparr>Arr\<rparr> = set {\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>}" by (simp add: \<BB>_Arr)
    then have "\<D>\<^sub>\<circ> (\<BB>\<lparr>Dom\<rparr>) = set {\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>}"
      by (simp add: cat_cs_simps cat_cs_intros)
    moreover have "\<R>\<^sub>\<circ> (\<BB>\<lparr>Dom\<rparr>) = set {a}"
      using \<BB>.cat_Dom_vrange \<BB>.cat_CId_is_arr \<BB>.cat_Dom_vdomain
      by (auto simp: \<BB>_Obj elim: \<BB>.Dom.vbrelation_vinE) (*slow*)
    ultimately show "\<BB>\<lparr>Dom\<rparr> = set {\<langle>\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>, a\<rangle>}"
      using \<BB>.Dom.vsv_vdomain_vrange_vsingleton by simp
    have "\<D>\<^sub>\<circ> (\<BB>\<lparr>Cod\<rparr>) = set {\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>}"
      by (simp add: \<BB>_Arr cat_cs_simps)
    moreover have "\<R>\<^sub>\<circ> (\<BB>\<lparr>Cod\<rparr>) = set {a}"
      using \<BB>.cat_Cod_vrange \<BB>.cat_CId_is_arr \<BB>.cat_Cod_vdomain
      by (auto simp: \<BB>_Obj elim: \<BB>.Cod.vbrelation_vinE) (*slow*)
    ultimately show "\<BB>\<lparr>Cod\<rparr> = set {\<langle>\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>, a\<rangle>}"
      by (auto intro: \<BB>.Cod.vsv_vdomain_vrange_vsingleton)
    show "\<BB>\<lparr>Comp\<rparr> = set {\<langle>[\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>]\<^sub>\<circ>, \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>\<rangle>}"
    proof(rule vsv_eqI)
      show dom:
        "\<D>\<^sub>\<circ> (\<BB>\<lparr>Comp\<rparr>) = \<D>\<^sub>\<circ> (set {\<langle>[\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>]\<^sub>\<circ>, \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>\<rangle>})"
        unfolding vdomain_vsingleton
      proof(rule vsubset_antisym)
         show "\<D>\<^sub>\<circ> (\<BB>\<lparr>Comp\<rparr>) \<subseteq>\<^sub>\<circ> set {[\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>]\<^sub>\<circ>}"
           by (intro vsubsetI)
             (metis \<BB>.cat_Comp_vdomain \<BB>_Arr vsingleton_iff \<BB>.cat_is_arrD(1))
        show "set {[\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>]\<^sub>\<circ>} \<subseteq>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<BB>\<lparr>Comp\<rparr>)"
          by
            (
              metis
                \<BB>_Obj vsingleton_iff
                \<BB>.cat_CId_is_arr
                \<BB>.cat_Comp_vdomainI
                vsubset_vsingleton_left
            )
      qed
      have "\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr> = \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>"
        by (metis \<BB>_Obj \<BB>.cat_CId_is_arr \<BB>.cat_CId_left_left vsingletonI)
      then show "a' \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<BB>\<lparr>Comp\<rparr>) \<Longrightarrow>
        \<BB>\<lparr>Comp\<rparr>\<lparr>a'\<rparr> = set {\<langle>[\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>, \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>]\<^sub>\<circ>, \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>\<rangle>}\<lparr>a'\<rparr>"
        for a'
        unfolding dom by simp
    qed (auto simp: \<BB>_Obj \<BB>_Arr)
    have "\<D>\<^sub>\<circ> (\<BB>\<lparr>CId\<rparr>) = set {a}" by (simp add: \<BB>_Obj \<BB>.cat_CId_vdomain)
    moreover then have "\<R>\<^sub>\<circ> (\<BB>\<lparr>CId\<rparr>) = set {\<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>}"
      by
        (
          metis
            \<BB>.CId.vdomain_atE
            \<BB>.CId.vsv_vdomain_vsingleton_vrange_vsingleton
            vsingleton_iff
        )
    ultimately show "\<BB>\<lparr>CId\<rparr> = set {\<langle>a, \<BB>\<lparr>CId\<rparr>\<lparr>a\<rparr>\<rangle>}"
      by (blast intro: \<BB>.CId.vsv_vdomain_vrange_vsingleton)
  qed (auto simp: \<BB>_Obj cat_cs_intros)

  with a that \<BB>.cat_Arr_vsubset_Vset \<BB>_Arr show ?thesis by auto

qed

text\<open>\newpage\<close>

end