(*  Title:      HOL/SPARK/Examples/RIPEMD-160/Round.thy
    Author:     Fabian Immler, TU Muenchen

Verification of the RIPEMD-160 hash function
*)

theory Round
imports RMD_Specification
begin

spark_open "rmd/round"

abbreviation from_chain :: "chain \<Rightarrow> RMD.chain" where
  "from_chain c \<equiv> (
    word_of_int (h0 c),
    word_of_int (h1 c),
    word_of_int (h2 c),
    word_of_int (h3 c),
    word_of_int (h4 c))"

abbreviation from_chain_pair :: "chain_pair \<Rightarrow> RMD.chain \<times> RMD.chain" where
  "from_chain_pair cc \<equiv> (
    from_chain (left cc),
    from_chain (right cc))"

abbreviation to_chain :: "RMD.chain \<Rightarrow> chain" where
  "to_chain c \<equiv>
    (let (h0, h1, h2, h3, h4) = c in
      (|h0 = uint h0,
        h1 = uint h1,
        h2 = uint h2,
        h3 = uint h3,
        h4 = uint h4|))"

abbreviation to_chain_pair :: "RMD.chain \<times> RMD.chain \<Rightarrow> chain_pair" where
  "to_chain_pair c == (let (c1, c2) = c in
    (| left = to_chain c1,
      right = to_chain c2 |))"

abbreviation steps' :: "chain_pair \<Rightarrow> int \<Rightarrow> block \<Rightarrow> chain_pair" where
  "steps' cc i b == to_chain_pair (steps
    (\<lambda>n. word_of_int (b (int n)))
    (from_chain_pair cc)
    (nat i))"

abbreviation round_spec :: "chain \<Rightarrow> block \<Rightarrow> chain" where
  "round_spec c b == to_chain (round (\<lambda>n. word_of_int (b (int n))) (from_chain c))"

spark_proof_functions
  steps = steps'
  round_spec = round_spec

lemma uint_word_of_int_id:
  assumes "0 <= (x::int)"
  assumes "x <= 4294967295"
  shows"uint(word_of_int x::word32) = x"
  unfolding int_word_uint
  using assms
  by (simp add:int_mod_eq')

lemma steps_step: "steps X cc (Suc i) = step_both X (steps X cc i) i"
  unfolding steps_def
  by (induct i) simp_all

lemma from_to_id: "from_chain_pair (to_chain_pair CC) = CC"
proof (cases CC)
  fix a::RMD.chain
  fix b c d e f::word32
  assume "CC = (a, b, c, d, e, f)"
  thus ?thesis by (cases a) simp
qed

lemma steps_to_steps':
  "F A (steps X cc i) B =
   F A (from_chain_pair (to_chain_pair (steps X cc i))) B"
  unfolding from_to_id ..

lemma steps'_step:
  assumes "0 <= i"
  shows
  "steps' cc (i + 1) X = to_chain_pair (
     step_both
       (\<lambda>n. word_of_int (X (int n)))
       (from_chain_pair (steps' cc i X))
       (nat i))"
proof -
  have "nat (i + 1) = Suc (nat i)" using assms by simp
  show ?thesis
    unfolding \<open>nat (i + 1) = Suc (nat i)\<close> steps_step steps_to_steps'
    ..
qed

lemma step_from_hyp:
  assumes
  step_hyp:
  "\<lparr>left =
      \<lparr>h0 = a, h1 = b, h2 = c, h3 = d, h4 = e\<rparr>,
    right =
      \<lparr>h0 = a', h1 = b', h2 = c', h3 = d', h4 = e'\<rparr>\<rparr> =
   steps'
     (\<lparr>left =
         \<lparr>h0 = a_0, h1 = b_0, h2 = c_0,
          h3 = d_0, h4 = e_0\<rparr>,
       right =
         \<lparr>h0 = a_0, h1 = b_0, h2 = c_0,
          h3 = d_0, h4 = e_0\<rparr>\<rparr>)
     j x"
  assumes "a <= 4294967295" (is "_ <= ?M")
  assumes                "b  <= ?M" and "c  <= ?M" and "d  <= ?M" and "e  <= ?M"
  assumes "a' <= ?M" and "b' <= ?M" and "c' <= ?M" and "d' <= ?M" and "e' <= ?M"
  assumes "0 <= a " and "0 <= b " and "0 <= c " and "0 <= d " and "0 <= e "
  assumes "0 <= a'" and "0 <= b'" and "0 <= c'" and "0 <= d'" and "0 <= e'"
  assumes "0 <= x (r_l_spec j)" and "x (r_l_spec j) <= ?M"
  assumes "0 <= x (r_r_spec j)" and "x (r_r_spec j) <= ?M"
  assumes "0 <= j" and "j <= 79"
  shows
  "\<lparr>left =
      \<lparr>h0 = e,
         h1 =
           (rotate_left (s_l_spec j)
             ((((a + f_spec j b c d) mod 4294967296 +
                x (r_l_spec j)) mod
               4294967296 +
               k_l_spec j) mod
              4294967296) +
            e) mod
           4294967296,
         h2 = b, h3 = rotate_left 10 c,
         h4 = d\<rparr>,
      right =
        \<lparr>h0 = e',
           h1 =
             (rotate_left (s_r_spec j)
               ((((a' + f_spec (79 - j) b' c' d') mod
                  4294967296 +
                  x (r_r_spec j)) mod
                 4294967296 +
                 k_r_spec j) mod
                4294967296) +
              e') mod
             4294967296,
           h2 = b', h3 = rotate_left 10 c',
           h4 = d'\<rparr>\<rparr> =
   steps'
    (\<lparr>left =
        \<lparr>h0 = a_0, h1 = b_0, h2 = c_0,
           h3 = d_0, h4 = e_0\<rparr>,
        right =
          \<lparr>h0 = a_0, h1 = b_0, h2 = c_0,
             h3 = d_0, h4 = e_0\<rparr>\<rparr>)
    (j + 1) x"
  using step_hyp
proof -
  let ?MM = 4294967296
  have AL: "uint(word_of_int e::word32) = e"
    by (rule uint_word_of_int_id[OF \<open>0 <= e\<close> \<open>e <= ?M\<close>])
  have CL: "uint(word_of_int b::word32) = b"
    by (rule uint_word_of_int_id[OF \<open>0 <= b\<close> \<open>b <= ?M\<close>])
  have DL: "True" ..
  have EL: "uint(word_of_int d::word32) = d"
    by (rule uint_word_of_int_id[OF \<open>0 <= d\<close> \<open>d <= ?M\<close>])
  have AR: "uint(word_of_int e'::word32) = e'"
    by (rule uint_word_of_int_id[OF \<open>0 <= e'\<close> \<open>e' <= ?M\<close>])
  have CR: "uint(word_of_int b'::word32) = b'"
    by (rule uint_word_of_int_id[OF \<open>0 <= b'\<close> \<open>b' <= ?M\<close>])
  have DR: "True" ..
  have ER: "uint(word_of_int d'::word32) = d'"
    by (rule uint_word_of_int_id[OF \<open>0 <= d'\<close> \<open>d' <= ?M\<close>])
  have BL:
    "(uint
      (word_rotl (s (nat j))
        ((word_of_int::int\<Rightarrow>word32)
          ((((a + f_spec j b c d) mod ?MM +
             x (r_l_spec j)) mod ?MM +
            k_l_spec j) mod ?MM))) +
        e) mod ?MM
    =
    uint
              (word_rotl (s (nat j))
                (word_of_int a +
                 f (nat j) (word_of_int b)
                  (word_of_int c) (word_of_int d) +
                 word_of_int (x (r_l_spec j)) +
                 K (nat j)) +
               word_of_int e)"
    (is "(uint (word_rotl _ (_ ((((_ + ?F) mod _ + ?X) mod _ + _) mod _))) + _) mod _ = _")
  proof -
    have "a mod ?MM = a" using \<open>0 <= a\<close> \<open>a <= ?M\<close>
      by (simp add: int_mod_eq')
    have "?X mod ?MM = ?X" using \<open>0 <= ?X\<close> \<open>?X <= ?M\<close>
      by (simp add: int_mod_eq')
    have "e mod ?MM = e" using \<open>0 <= e\<close> \<open>e <= ?M\<close>
      by (simp add: int_mod_eq')
    have "(?MM::int) = 2 ^ len_of TYPE(32)" by simp
    show ?thesis
      unfolding
        word_add_def
        uint_word_of_int_id[OF \<open>0 <= a\<close> \<open>a <= ?M\<close>]
        uint_word_of_int_id[OF \<open>0 <= ?X\<close> \<open>?X <= ?M\<close>]
        int_word_uint
      unfolding \<open>?MM = 2 ^ len_of TYPE(32)\<close>
      unfolding word_uint.Abs_norm
      by (simp add:
        \<open>a mod ?MM = a\<close>
        \<open>e mod ?MM = e\<close>
        \<open>?X mod ?MM = ?X\<close>)
  qed

  have BR:
    "(uint
      (word_rotl (s' (nat j))
        ((word_of_int::int\<Rightarrow>word32)
          ((((a' + f_spec (79 - j) b' c' d') mod ?MM +
             x (r_r_spec j)) mod ?MM +
            k_r_spec j) mod ?MM))) +
        e') mod ?MM
    =
    uint
              (word_rotl (s' (nat j))
                (word_of_int a' +
                 f (79 - nat j) (word_of_int b')
                  (word_of_int c') (word_of_int d') +
                 word_of_int (x (r_r_spec j)) +
                 K' (nat j)) +
               word_of_int e')"
    (is "(uint (word_rotl _ (_ ((((_ + ?F) mod _ + ?X) mod _ + _) mod _))) + _) mod _ = _")
  proof -
    have "a' mod ?MM = a'" using \<open>0 <= a'\<close> \<open>a' <= ?M\<close>
      by (simp add: int_mod_eq')
    have "?X mod ?MM = ?X" using \<open>0 <= ?X\<close> \<open>?X <= ?M\<close>
      by (simp add: int_mod_eq')
    have "e' mod ?MM = e'" using \<open>0 <= e'\<close> \<open>e' <= ?M\<close>
      by (simp add: int_mod_eq')
    have "(?MM::int) = 2 ^ len_of TYPE(32)" by simp
    have nat_transfer: "79 - nat j = nat (79 - j)"
      using nat_diff_distrib \<open>0 <= j\<close>  \<open>j <= 79\<close>
      by simp
    show ?thesis
      unfolding
        word_add_def
        uint_word_of_int_id[OF \<open>0 <= a'\<close> \<open>a' <= ?M\<close>]
        uint_word_of_int_id[OF \<open>0 <= ?X\<close> \<open>?X <= ?M\<close>]
        int_word_uint
        nat_transfer
      unfolding \<open>?MM = 2 ^ len_of TYPE(32)\<close>
      unfolding word_uint.Abs_norm
      by (simp add:
        \<open>a' mod ?MM = a'\<close>
        \<open>e' mod ?MM = e'\<close>
        \<open>?X mod ?MM = ?X\<close>)
  qed

  show ?thesis
    unfolding steps'_step[OF \<open>0 <= j\<close>] step_hyp[symmetric]
      step_both_def step_r_def step_l_def
    by (simp add: AL BL CL DL EL AR BR CR DR ER)
qed

spark_vc procedure_round_61
proof -
  let ?M = "4294967295::int"
  have step_hyp:
  "\<lparr>left =
      \<lparr>h0 = ca, h1 = cb, h2 = cc,
         h3 = cd, h4 = ce\<rparr>,
      right =
        \<lparr>h0 = ca, h1 = cb, h2 = cc,
           h3 = cd, h4 = ce\<rparr>\<rparr> =
   steps'
    (\<lparr>left =
        \<lparr>h0 = ca, h1 = cb, h2 = cc,
           h3 = cd, h4 = ce\<rparr>,
        right =
          \<lparr>h0 = ca, h1 = cb, h2 = cc,
             h3 = cd, h4 = ce\<rparr>\<rparr>)
    0 x"
    unfolding steps_def
    by (simp add:
      uint_word_of_int_id[OF \<open>0 <= ca\<close> \<open>ca <= ?M\<close>]
      uint_word_of_int_id[OF \<open>0 <= cb\<close> \<open>cb <= ?M\<close>]
      uint_word_of_int_id[OF \<open>0 <= cc\<close> \<open>cc <= ?M\<close>]
      uint_word_of_int_id[OF \<open>0 <= cd\<close> \<open>cd <= ?M\<close>]
      uint_word_of_int_id[OF \<open>0 <= ce\<close> \<open>ce <= ?M\<close>])
  let ?rotate_arg_l =
    "((((ca + f 0 cb cc cd) mod 4294967296 +
        x (r_l 0)) mod 4294967296 + k_l 0) mod 4294967296)"
  let ?rotate_arg_r =
    "((((ca + f 79 cb cc cd) mod 4294967296 +
        x (r_r 0)) mod 4294967296 + k_r 0) mod 4294967296)"
  note returns =
    \<open>wordops__rotate (s_l 0) ?rotate_arg_l =
     rotate_left (s_l 0) ?rotate_arg_l\<close>
    \<open>wordops__rotate (s_r 0) ?rotate_arg_r =
     rotate_left (s_r 0) ?rotate_arg_r\<close>
    \<open>wordops__rotate 10 cc = rotate_left 10 cc\<close>
    \<open>f 0 cb cc cd = f_spec 0 cb cc cd\<close>
    \<open>f 79 cb cc cd = f_spec 79 cb cc cd\<close>
    \<open>k_l 0 = k_l_spec 0\<close>
    \<open>k_r 0 = k_r_spec 0\<close>
    \<open>r_l 0 = r_l_spec 0\<close>
    \<open>r_r 0 = r_r_spec 0\<close>
    \<open>s_l 0 = s_l_spec 0\<close>
    \<open>s_r 0 = s_r_spec 0\<close>

  note x_borders = \<open>\<forall>i. 0 \<le> i \<and> i \<le> 15 \<longrightarrow> 0 \<le> x i \<and> x i \<le> ?M\<close>

  from \<open>0 <= r_l 0\<close> \<open>r_l 0 <= 15\<close> x_borders
  have "0 \<le> x (r_l 0)" by blast
  hence x_lower: "0 <= x (r_l_spec 0)" unfolding returns .

  from \<open>0 <= r_l 0\<close> \<open>r_l 0 <= 15\<close> x_borders
  have "x (r_l 0) <= ?M" by blast
  hence x_upper: "x (r_l_spec 0) <= ?M" unfolding returns .

  from \<open>0 <= r_r 0\<close> \<open>r_r 0 <= 15\<close> x_borders
  have "0 \<le> x (r_r 0)" by blast
  hence x_lower': "0 <= x (r_r_spec 0)" unfolding returns .

  from \<open>0 <= r_r 0\<close> \<open>r_r 0 <= 15\<close> x_borders
  have "x (r_r 0) <= ?M" by blast
  hence x_upper': "x (r_r_spec 0) <= ?M" unfolding returns .

  have "0 <= (0::int)" by simp
  have "0 <= (79::int)" by simp
  note step_from_hyp [OF
    step_hyp
    H2 H4 H6 H8 H10 H2 H4 H6 H8 H10 (* upper bounds *)
    H1 H3 H5 H7 H9  H1 H3 H5 H7 H9  (* lower bounds *)
  ]
  from this[OF x_lower x_upper x_lower' x_upper' \<open>0 <= 0\<close> \<open>0 <= 79\<close>]
    \<open>0 \<le> ca\<close> \<open>0 \<le> ce\<close> x_lower x_lower'
  show ?thesis unfolding returns(1) returns(2) unfolding returns
    by simp
qed

spark_vc procedure_round_62
proof -
  let ?M = "4294967295::int"
  let ?rotate_arg_l =
    "((((cla + f (loop__1__j + 1) clb clc cld) mod 4294967296 +
         x (r_l (loop__1__j + 1))) mod 4294967296 +
         k_l (loop__1__j + 1)) mod 4294967296)"
  let ?rotate_arg_r =
    "((((cra + f (79 - (loop__1__j + 1)) crb crc crd) mod
         4294967296 + x (r_r (loop__1__j + 1))) mod 4294967296 +
         k_r (loop__1__j + 1)) mod 4294967296)"

  have s: "78 - loop__1__j = (79 - (loop__1__j + 1))" by simp
  note returns =
    \<open>wordops__rotate (s_l (loop__1__j + 1)) ?rotate_arg_l =
     rotate_left (s_l (loop__1__j + 1)) ?rotate_arg_l\<close>
    \<open>wordops__rotate (s_r (loop__1__j + 1)) ?rotate_arg_r =
     rotate_left (s_r (loop__1__j + 1)) ?rotate_arg_r\<close>
    \<open>f (loop__1__j + 1) clb clc cld =
     f_spec (loop__1__j + 1) clb clc cld\<close>
    \<open>f (78 - loop__1__j) crb crc crd =
     f_spec (78 - loop__1__j) crb crc crd\<close>[simplified s]
    \<open>wordops__rotate 10 clc = rotate_left 10 clc\<close>
    \<open>wordops__rotate 10 crc = rotate_left 10 crc\<close>
    \<open>k_l (loop__1__j + 1) = k_l_spec (loop__1__j + 1)\<close>
    \<open>k_r (loop__1__j + 1) = k_r_spec (loop__1__j + 1)\<close>
    \<open>r_l (loop__1__j + 1) = r_l_spec (loop__1__j + 1)\<close>
    \<open>r_r (loop__1__j + 1) = r_r_spec (loop__1__j + 1)\<close>
    \<open>s_l (loop__1__j + 1) = s_l_spec (loop__1__j + 1)\<close>
    \<open>s_r (loop__1__j + 1) = s_r_spec (loop__1__j + 1)\<close>

  note x_borders = \<open>\<forall>i. 0 \<le> i \<and> i \<le> 15 \<longrightarrow> 0 \<le> x i \<and> x i \<le> ?M\<close>

  from \<open>0 <= r_l (loop__1__j + 1)\<close> \<open>r_l (loop__1__j + 1) <= 15\<close> x_borders
  have "0 \<le> x (r_l (loop__1__j + 1))" by blast
  hence x_lower: "0 <= x (r_l_spec (loop__1__j + 1))" unfolding returns .

  from \<open>0 <= r_l (loop__1__j + 1)\<close> \<open>r_l (loop__1__j + 1) <= 15\<close> x_borders
  have "x (r_l (loop__1__j + 1)) <= ?M" by blast
  hence x_upper: "x (r_l_spec (loop__1__j + 1)) <= ?M" unfolding returns .

  from \<open>0 <= r_r (loop__1__j + 1)\<close> \<open>r_r (loop__1__j + 1) <= 15\<close> x_borders
  have "0 \<le> x (r_r (loop__1__j + 1))" by blast
  hence x_lower': "0 <= x (r_r_spec (loop__1__j + 1))" unfolding returns .

  from \<open>0 <= r_r (loop__1__j + 1)\<close> \<open>r_r (loop__1__j + 1) <= 15\<close> x_borders
  have "x (r_r (loop__1__j + 1)) <= ?M" by blast
  hence x_upper': "x (r_r_spec (loop__1__j + 1)) <= ?M" unfolding returns .

  from \<open>0 <= loop__1__j\<close> have "0 <= loop__1__j + 1" by simp
  from \<open>loop__1__j <= 78\<close> have "loop__1__j + 1 <= 79" by simp

  have "loop__1__j + 1 + 1 = loop__1__j + 2" by simp

  note step_from_hyp[OF H1
    \<open>cla <= ?M\<close>
    \<open>clb <= ?M\<close>
    \<open>clc <= ?M\<close>
    \<open>cld <= ?M\<close>
    \<open>cle <= ?M\<close>
    \<open>cra <= ?M\<close>
    \<open>crb <= ?M\<close>
    \<open>crc <= ?M\<close>
    \<open>crd <= ?M\<close>
    \<open>cre <= ?M\<close>

    \<open>0 <= cla\<close>
    \<open>0 <= clb\<close>
    \<open>0 <= clc\<close>
    \<open>0 <= cld\<close>
    \<open>0 <= cle\<close>
    \<open>0 <= cra\<close>
    \<open>0 <= crb\<close>
    \<open>0 <= crc\<close>
    \<open>0 <= crd\<close>
    \<open>0 <= cre\<close>]
  from this[OF
    x_lower x_upper x_lower' x_upper'
    \<open>0 <= loop__1__j + 1\<close> \<open>loop__1__j + 1 <= 79\<close>]
    \<open>0 \<le> cla\<close> \<open>0 \<le> cle\<close> \<open>0 \<le> cra\<close> \<open>0 \<le> cre\<close> x_lower x_lower'
  show ?thesis unfolding \<open>loop__1__j + 1 + 1 = loop__1__j + 2\<close>
    unfolding returns(1) returns(2) unfolding returns
    by simp
qed

spark_vc procedure_round_76
proof -
  let ?M = "4294967295 :: int"
  let ?INIT_CHAIN =
     "\<lparr>h0 = ca_init, h1 = cb_init,
         h2 = cc_init, h3 = cd_init,
         h4 = ce_init\<rparr>"
  have steps_to_steps':
    "steps
       (\<lambda>n::nat. word_of_int (x (int n)))
       (from_chain ?INIT_CHAIN, from_chain ?INIT_CHAIN)
       80 =
    from_chain_pair (
      steps'
      (\<lparr>left = ?INIT_CHAIN, right = ?INIT_CHAIN\<rparr>)
      80
      x)"
    unfolding from_to_id by simp
  from
    \<open>0 \<le> ca_init\<close> \<open>ca_init \<le> ?M\<close>
    \<open>0 \<le> cb_init\<close> \<open>cb_init \<le> ?M\<close>
    \<open>0 \<le> cc_init\<close> \<open>cc_init \<le> ?M\<close>
    \<open>0 \<le> cd_init\<close> \<open>cd_init \<le> ?M\<close>
    \<open>0 \<le> ce_init\<close> \<open>ce_init \<le> ?M\<close>
    \<open>0 \<le> cla\<close> \<open>cla \<le> ?M\<close>
    \<open>0 \<le> clb\<close> \<open>clb \<le> ?M\<close>
    \<open>0 \<le> clc\<close> \<open>clc \<le> ?M\<close>
    \<open>0 \<le> cld\<close> \<open>cld \<le> ?M\<close>
    \<open>0 \<le> cle\<close> \<open>cle \<le> ?M\<close>
    \<open>0 \<le> cra\<close> \<open>cra \<le> ?M\<close>
    \<open>0 \<le> crb\<close> \<open>crb \<le> ?M\<close>
    \<open>0 \<le> crc\<close> \<open>crc \<le> ?M\<close>
    \<open>0 \<le> crd\<close> \<open>crd \<le> ?M\<close>
    \<open>0 \<le> cre\<close> \<open>cre \<le> ?M\<close>
  show ?thesis
    unfolding round_def
    unfolding steps_to_steps'
    unfolding H1[symmetric]
    by (simp add: uint_word_ariths(1) rdmods
      uint_word_of_int_id)
qed

spark_end

end


(* Copyright 2020 (C) Mihails Milehins *)

section\<open>Simplicial category\<close>
theory CZH_ECAT_CSimplicial
  imports CZH_ECAT_Ordinal
begin

subsection\<open>Background\<close>

text\<open>
The content of this section is based, primarily, on the elements of the
content of Chapter I-2 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
\<close>

named_theorems cat_simplicial_cs_simps
named_theorems cat_simplicial_cs_intros

subsection\<open>Composable arrows for simplicial category\<close>

definition composable_cat_simplicial :: "V \<Rightarrow> V \<Rightarrow> V"
  where "composable_cat_simplicial \<alpha> A = set
    {
      [g, f]\<^sub>\<circ> | g f. \<exists>m n p.
        g : cat_ordinal n \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal p \<and>
        f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n \<and>
        m \<in>\<^sub>\<circ> A \<and> n \<in>\<^sub>\<circ> A \<and> p \<in>\<^sub>\<circ> A
    }"

lemma small_composable_cat_simplicial[simp]:
  "small
    {
      [g, f]\<^sub>\<circ> | g f. \<exists>m n p.
        g : cat_ordinal n \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal p \<and>
        f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n \<and>
        m \<in>\<^sub>\<circ> A \<and> n \<in>\<^sub>\<circ> A \<and> p \<in>\<^sub>\<circ> A
    }"
  (is \<open>small ?S\<close>)
proof(rule down)
  show "?S \<subseteq> elts (all_cfs \<alpha> \<times>\<^sub>\<bullet> all_cfs \<alpha>)"
  proof
    (
      intro subsetI,
      unfold mem_Collect_eq, elim exE conjE; simp only:; intro ftimesI2
    )
    fix m n p g f
    assume prems:
      "m \<in>\<^sub>\<circ> A"
      "n \<in>\<^sub>\<circ> A"
      "p \<in>\<^sub>\<circ> A"
      "g : cat_ordinal n \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal p"
      "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
    interpret g: is_preorder_functor \<alpha> \<open>cat_ordinal n\<close> \<open>cat_ordinal p\<close> g
      by (rule prems(4))
    interpret f: is_preorder_functor \<alpha> \<open>cat_ordinal m\<close> \<open>cat_ordinal n\<close> f
      by (rule prems(5))
    from g.is_functor_axioms show "g \<in>\<^sub>\<circ> all_cfs \<alpha>" by auto
    from f.is_functor_axioms show "f \<in>\<^sub>\<circ> all_cfs \<alpha>" by auto
  qed
qed

text\<open>Rules.\<close>

lemma composable_cat_simplicialI:
  assumes "g : cat_ordinal n \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal p"
    and "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
    and "m \<in>\<^sub>\<circ> A"
    and "n \<in>\<^sub>\<circ> A"
    and "p \<in>\<^sub>\<circ> A"
    and "gf = [g, f]\<^sub>\<circ>"
  shows "gf \<in>\<^sub>\<circ> composable_cat_simplicial \<alpha> A"
  using assms
  unfolding composable_cat_simplicial_def
  by (intro in_small_setI small_composable_cat_simplicial) auto

lemma composable_cat_simplicialE[elim]:
  assumes "gf \<in>\<^sub>\<circ> composable_cat_simplicial \<alpha> A"
  obtains g f m n p where "gf = [g, f]\<^sub>\<circ>"
    and "g : cat_ordinal n \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal p"
    and "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
    and "m \<in>\<^sub>\<circ> A"
    and "n \<in>\<^sub>\<circ> A"
    and "p \<in>\<^sub>\<circ> A"
proof-
  from assms obtain g f m n p where
    "gf = [g, f]\<^sub>\<circ>"
    "g : cat_ordinal n \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal p"
    "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
    "m \<in>\<^sub>\<circ> A"
    "n \<in>\<^sub>\<circ> A"
    "p \<in>\<^sub>\<circ> A"
    unfolding composable_cat_simplicial_def
    by (elim in_small_setE, intro small_composable_cat_simplicial) auto
  with that show ?thesis by auto
qed

subsection\<open>Simplicial category\<close>

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

definition cat_simplicial :: "V \<Rightarrow> V \<Rightarrow> V"
  where "cat_simplicial \<alpha> A =
    [
      set {cat_ordinal m | m. m \<in>\<^sub>\<circ> A},
      set
        {
          f. \<exists>m n.
            f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n \<and> m \<in>\<^sub>\<circ> A \<and> n \<in>\<^sub>\<circ> A
        },
      (
        \<lambda>f\<in>\<^sub>\<circ> set
          {
            f. \<exists>m n.
              f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n \<and> m \<in>\<^sub>\<circ> A \<and> n \<in>\<^sub>\<circ> A
          }. f\<lparr>HomDom\<rparr>
      ),
      (
        \<lambda>f\<in>\<^sub>\<circ> set
          {
            f. \<exists>m n.
              f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n \<and> m \<in>\<^sub>\<circ> A \<and> n \<in>\<^sub>\<circ> A
          }. f\<lparr>HomCod\<rparr>
      ),
      (\<lambda>gf\<in>\<^sub>\<circ>composable_cat_simplicial \<alpha> A. gf\<lparr>0\<rparr> \<circ>\<^sub>C\<^sub>F gf\<lparr>1\<^sub>\<nat>\<rparr>),
      (\<lambda>m\<in>\<^sub>\<circ>set {cat_ordinal m | m. m \<in>\<^sub>\<circ> A}. cf_id m)
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma cat_simplicial_components:
  shows "cat_simplicial \<alpha> A\<lparr>Obj\<rparr> = set {cat_ordinal m | m. m \<in>\<^sub>\<circ> A}"
    and "cat_simplicial \<alpha> A\<lparr>Arr\<rparr> =
      set {f. \<exists>m n. f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n \<and> m \<in>\<^sub>\<circ> A \<and> n \<in>\<^sub>\<circ> A}"
    and "cat_simplicial \<alpha> A\<lparr>Dom\<rparr> =
      (
        \<lambda>f\<in>\<^sub>\<circ>set
          {
            f. \<exists>m n.
              f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n \<and> m \<in>\<^sub>\<circ> A \<and> n \<in>\<^sub>\<circ> A
          }. f\<lparr>HomDom\<rparr>
      )"
    and "cat_simplicial \<alpha> A\<lparr>Cod\<rparr> =
      (
        \<lambda>f\<in>\<^sub>\<circ>set
          {
            f. \<exists>m n.
              f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n \<and> m \<in>\<^sub>\<circ> A \<and> n \<in>\<^sub>\<circ> A
          }. f\<lparr>HomCod\<rparr>
      )"
    and "cat_simplicial \<alpha> A\<lparr>Comp\<rparr> =
      (\<lambda>gf\<in>\<^sub>\<circ>composable_cat_simplicial \<alpha> A. gf\<lparr>0\<rparr> \<circ>\<^sub>C\<^sub>F gf\<lparr>1\<^sub>\<nat>\<rparr>)"
    and "cat_simplicial \<alpha> A\<lparr>CId\<rparr> =
      (\<lambda>m\<in>\<^sub>\<circ>set {cat_ordinal m | m. m \<in>\<^sub>\<circ> A}. cf_id m)"
  unfolding cat_simplicial_def dg_field_simps by (simp_all add: nat_omega_simps)

subsubsection\<open>Objects\<close>

lemma cat_simplicial_ObjI[cat_simplicial_cs_intros]:
  assumes "m \<in>\<^sub>\<circ> A" and "a = cat_ordinal m"
  shows "a \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr> "
  using assms unfolding cat_simplicial_components by auto

lemma cat_simplicial_ObjD:
  assumes "cat_ordinal m \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr> "
  shows "m \<in>\<^sub>\<circ> A"
  using assms cat_ordinal_inj unfolding cat_simplicial_components by auto

lemma cat_simplicial_ObjE:
  assumes "M \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr> "
  obtains m where "M = cat_ordinal m" and "m \<in>\<^sub>\<circ> A"
  using assms cat_ordinal_inj that unfolding cat_simplicial_components by auto

subsubsection\<open>Arrows\<close>

lemma small_cat_simplicial_Arr[simp]:
  "small {f. \<exists>m n. f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n \<and> m \<in>\<^sub>\<circ> A \<and> n \<in>\<^sub>\<circ> A}"
  (is \<open>small ?S\<close>)
proof(rule down)
  show "?S \<subseteq> elts (all_cfs \<alpha>)" by auto
qed

lemma cat_simplicial_ArrI[cat_simplicial_cs_intros]:
  assumes "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n" and "m \<in>\<^sub>\<circ> A" and "n \<in>\<^sub>\<circ> A"
  shows "f \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Arr\<rparr>"
  using assms
  unfolding cat_simplicial_components
  by (intro in_small_setI small_cat_simplicial_Arr) auto

lemma cat_simplicial_ArrE:
  assumes "f \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Arr\<rparr>"
  obtains m n
    where "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n" and "m \<in>\<^sub>\<circ> A" and "n \<in>\<^sub>\<circ> A"
proof-
  from assms cat_ordinal_inj obtain m n
    where "m \<in>\<^sub>\<circ> A" "n \<in>\<^sub>\<circ> A" "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
    unfolding cat_simplicial_components
    by (elim in_small_setE, intro small_cat_simplicial_Arr) auto
  with that show ?thesis by simp
qed

subsubsection\<open>Domain\<close>

mk_VLambda cat_simplicial_components(3)
  |vsv cat_simplicial_Dom_vsv[cat_simplicial_cs_intros]|
  |vdomain
    cat_simplicial_Dom_vdomain[
      folded cat_simplicial_components, cat_simplicial_cs_simps
    ]
  |
  |app cat_simplicial_Dom_app[folded cat_simplicial_components]|

lemma cat_simplicial_Dom_app'[cat_simplicial_cs_simps]:
  assumes "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n" and "m \<in>\<^sub>\<circ> A" and "n \<in>\<^sub>\<circ> A"
  shows "cat_simplicial \<alpha> A\<lparr>Dom\<rparr>\<lparr>f\<rparr> = cat_ordinal m"
proof-
  interpret f: is_preorder_functor \<alpha> \<open>cat_ordinal m\<close> \<open>cat_ordinal n\<close> f
    by (rule assms(1))
  from assms show "cat_simplicial \<alpha> A\<lparr>Dom\<rparr>\<lparr>f\<rparr> = cat_ordinal m"
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_simplicial_Dom_app
          cs_intro: cat_simplicial_cs_intros
      )
qed

subsubsection\<open>Codomain\<close>

mk_VLambda cat_simplicial_components(4)
  |vsv cat_simplicial_Cod_vsv[cat_simplicial_cs_intros]|
  |vdomain
    cat_simplicial_Cod_vdomain[
      folded cat_simplicial_components, cat_simplicial_cs_simps
    ]
  |
  |app cat_simplicial_Cod_app[folded cat_simplicial_components]|

lemma cat_simplicial_Cod_app'[cat_simplicial_cs_simps]:
  assumes "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n" and "m \<in>\<^sub>\<circ> A" and "n \<in>\<^sub>\<circ> A"
  shows "cat_simplicial \<alpha> A\<lparr>Cod\<rparr>\<lparr>f\<rparr> = cat_ordinal n"
proof-
  interpret f: is_preorder_functor \<alpha> \<open>cat_ordinal m\<close> \<open>cat_ordinal n\<close> f
    by (rule assms(1))
  from assms show "cat_simplicial \<alpha> A\<lparr>Cod\<rparr>\<lparr>f\<rparr> = cat_ordinal n"
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_simplicial_Cod_app
          cs_intro: cat_simplicial_cs_intros
      )
qed

subsubsection\<open>Arrow with a domain and a codomain\<close>

lemma cat_simplicial_is_arrI:
  assumes "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
    and "m \<in>\<^sub>\<circ> A"
    and "n \<in>\<^sub>\<circ> A"
  shows "f : cat_ordinal m \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> cat_ordinal n"
proof(intro is_arrI cat_simplicial_ArrI, rule assms; (intro assms(2,3))?)
  from assms show
    "cat_simplicial \<alpha> A\<lparr>Dom\<rparr>\<lparr>f\<rparr> = cat_ordinal m"
    "cat_simplicial \<alpha> A\<lparr>Cod\<rparr>\<lparr>f\<rparr> = cat_ordinal n"
    by (cs_concl cs_shallow cs_simp: cat_simplicial_cs_simps)+
qed

lemma cat_simplicial_is_arrI'[cat_simplicial_cs_intros]:
  assumes "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
    and "m \<in>\<^sub>\<circ> A"
    and "n \<in>\<^sub>\<circ> A"
    and "a = cat_ordinal m"
    and "b = cat_ordinal n"
  shows "f : a \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> b"
  using assms(1-3) unfolding assms(4-5) by (rule cat_simplicial_is_arrI)

lemma cat_simplicial_is_arrD[dest]:
  assumes "f : cat_ordinal m \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> cat_ordinal n"
    and "m \<in>\<^sub>\<circ> A"
    and "n \<in>\<^sub>\<circ> A"
  shows "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
proof-
  note f = is_arrD[OF assms(1)]
  from f(1) obtain m' n'
    where f_is_preorder_functor: "f : cat_ordinal m' \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n'"
      and "m' \<in>\<^sub>\<circ> A"
      and "n' \<in>\<^sub>\<circ> A"
    by (elim cat_simplicial_ArrE)
  then have
    "cat_simplicial \<alpha> A\<lparr>Dom\<rparr>\<lparr>f\<rparr> = cat_ordinal m'"
    "cat_simplicial \<alpha> A\<lparr>Cod\<rparr>\<lparr>f\<rparr> = cat_ordinal n'"
    by (cs_concl cs_shallow cs_simp: cat_simplicial_cs_simps)+
  with f(2,3) have
    "cat_ordinal m' = cat_ordinal m" "cat_ordinal n' = cat_ordinal n"
    by auto
  with f(2,3) cat_ordinal_inj have [simp]: "m' = m" "n' = n" by auto
  from f_is_preorder_functor show ?thesis by simp
qed

lemma cat_simplicial_is_arrE[elim]:
  assumes "f : a \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> b"
  obtains m n where "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
    and "m \<in>\<^sub>\<circ> A"
    and "n \<in>\<^sub>\<circ> A"
    and "a = cat_ordinal m"
    and "b = cat_ordinal n"
proof-
  note f = is_arrD[OF assms(1)]
  from f(1) obtain m n
    where f_is_preorder_functor: "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
      and m: "m \<in>\<^sub>\<circ> A"
      and n: "n \<in>\<^sub>\<circ> A"
    by (elim cat_simplicial_ArrE)
  then have
    "cat_simplicial \<alpha> A\<lparr>Dom\<rparr>\<lparr>f\<rparr> = cat_ordinal m"
    "cat_simplicial \<alpha> A\<lparr>Cod\<rparr>\<lparr>f\<rparr> = cat_ordinal n"
    by (cs_concl cs_shallow cs_simp: cat_simplicial_cs_simps)+
  with f(2,3) have "cat_ordinal m = a" "cat_ordinal n = b"
    by auto
  with f_is_preorder_functor m n that show ?thesis by auto
qed

subsubsection\<open>Composition\<close>

mk_VLambda cat_simplicial_components(5)
  |vsv cat_simplicial_Comp_vsv[cat_simplicial_cs_intros]|
  |vdomain cat_simplicial_Comp_vdomain[cat_simplicial_cs_simps]|

lemma cat_simplicial_Comp_app[cat_simplicial_cs_simps]:
  assumes "g : cat_ordinal n \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> cat_ordinal p"
    and "f : cat_ordinal m \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> cat_ordinal n"
    and "m \<in>\<^sub>\<circ> A"
    and "n \<in>\<^sub>\<circ> A"
    and "p \<in>\<^sub>\<circ> A"
  shows "g \<circ>\<^sub>A\<^bsub>cat_simplicial \<alpha> A\<^esub> f = g \<circ>\<^sub>C\<^sub>F f"
proof-
  note g = cat_simplicial_is_arrD[OF assms(1,4,5)]
  note f = cat_simplicial_is_arrD[OF assms(2,3,4)]
  interpret g: is_preorder_functor \<alpha> \<open>cat_ordinal n\<close> \<open>cat_ordinal p\<close> g
    by (rule g)
  interpret f: is_preorder_functor \<alpha> \<open>cat_ordinal m\<close> \<open>cat_ordinal n\<close> f
    by (rule f)
  have "[g, f]\<^sub>\<circ> \<in>\<^sub>\<circ> composable_cat_simplicial \<alpha> A"
    by
      (
        intro composable_cat_simplicialI, rule g, rule f;
        (intro assms refl)?
      )
  then show "g \<circ>\<^sub>A\<^bsub>cat_simplicial \<alpha> A\<^esub> f = g \<circ>\<^sub>C\<^sub>F f"
    unfolding cat_simplicial_components by (simp add: nat_omega_simps)
qed

subsubsection\<open>Identity\<close>

context
  fixes \<alpha> A :: V
begin

mk_VLambda cat_simplicial_components(6)[where \<alpha>=\<alpha> and A=A]
  |vsv cat_simplicial_CId_vsv[cat_simplicial_cs_intros]|
  |vdomain
    cat_simplicial_CId_vdomain'[
      folded cat_simplicial_components(1)[where \<alpha>=\<alpha> and A=A]
    ]
  |
  |app cat_simplicial_CId_app'[
    folded cat_simplicial_components(1)[where \<alpha>=\<alpha> and A=A]
    ]
  |

lemmas cat_simplicial_CId_vdomain[cat_simplicial_cs_simps] =
  cat_simplicial_CId_vdomain'
lemmas cat_simplicial_CId_app[cat_simplicial_cs_simps] =
  cat_simplicial_CId_app'

end

subsubsection\<open>Simplicial category is a category\<close>

lemma (in \<Z>) category_simplicial:
  assumes "Ord A" and "A \<subseteq>\<^sub>\<circ> \<alpha>"
  shows "category \<alpha> (cat_simplicial \<alpha> A)"
proof-

  show ?thesis
  proof(intro categoryI')

    show "vfsequence (cat_simplicial \<alpha> A)" unfolding cat_simplicial_def by simp
    show "vcard (cat_simplicial \<alpha> A) = 6\<^sub>\<nat>"
      unfolding cat_simplicial_def by (simp add: nat_omega_simps)

    show "\<R>\<^sub>\<circ> (cat_simplicial \<alpha> A\<lparr>Dom\<rparr>) \<subseteq>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr>"
    proof(rule vsv.vsv_vrange_vsubset, unfold cat_simplicial_cs_simps)
      fix f assume "f \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Arr\<rparr>"
      then obtain m n
        where "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
          and "m \<in>\<^sub>\<circ> A"
          and "n \<in>\<^sub>\<circ> A"
        by (elim cat_simplicial_ArrE)
      then show "cat_simplicial \<alpha> A\<lparr>Dom\<rparr>\<lparr>f\<rparr> \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr>"
        by (auto simp: cat_simplicial_Dom_app' intro: cat_simplicial_ObjI)
    qed (auto simp: cat_simplicial_components)

    show "\<R>\<^sub>\<circ> (cat_simplicial \<alpha> A\<lparr>Cod\<rparr>) \<subseteq>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr>"
    proof(rule vsv.vsv_vrange_vsubset, unfold cat_simplicial_cs_simps)
      fix f assume "f \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Arr\<rparr>"
      then obtain m n
        where "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
          and "m \<in>\<^sub>\<circ> A"
          and "n \<in>\<^sub>\<circ> A"
        by (elim cat_simplicial_ArrE)
      then show "cat_simplicial \<alpha> A\<lparr>Cod\<rparr>\<lparr>f\<rparr> \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr>"
        by (auto simp: cat_simplicial_Cod_app' intro: cat_simplicial_ObjI)
    qed (auto simp: cat_simplicial_components)

    show "(gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (cat_simplicial \<alpha> A\<lparr>Comp\<rparr>)) \<longleftrightarrow>
      (
        \<exists>g f b c a.
          gf = [g, f]\<^sub>\<circ> \<and>
          g : b \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> c \<and>
          f : a \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> b
      )"
      for gf
    proof(intro iffI; (elim exE conjE)?)
      assume "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (cat_simplicial \<alpha> A\<lparr>Comp\<rparr>)"
      then have "gf \<in>\<^sub>\<circ> composable_cat_simplicial \<alpha> A"
        unfolding cat_simplicial_components by simp
      then obtain g f m n p
        where gf_def: "gf = [g, f]\<^sub>\<circ>"
          and g: "g : cat_ordinal n \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal p"
          and f: "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
          and m: "m \<in>\<^sub>\<circ> A"
          and n: "n \<in>\<^sub>\<circ> A"
          and p: "p \<in>\<^sub>\<circ> A"
        by auto
      show "\<exists>g f b c a.
        gf = [g, f]\<^sub>\<circ> \<and>
        g : b \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> c \<and>
        f : a \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> b"
      proof(intro exI conjI)
        from g n p show "g : cat_ordinal n \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> cat_ordinal p"
          by (intro cat_simplicial_is_arrI) simp_all
        from f m n show "f : cat_ordinal m \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> cat_ordinal n"
          by (intro cat_simplicial_is_arrI) simp_all
      qed (simp add: gf_def)
    next
      fix g f a b c assume prems:
        "gf = [g, f]\<^sub>\<circ>"
        "g : b \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> c"
        "f : a \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> b"
      from prems(2) obtain n p
        where g: "g : cat_ordinal n \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal p"
          and n: "n \<in>\<^sub>\<circ> A"
          and p: "p \<in>\<^sub>\<circ> A"
          and b_def: "b = cat_ordinal n"
          and "c = cat_ordinal p"
        by auto
      from prems(3) obtain m n'
        where f: "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n'"
          and m: "m \<in>\<^sub>\<circ> A"
          and n': "n' \<in>\<^sub>\<circ> A"
          and a_def: "a = cat_ordinal m"
          and b_def': "b = cat_ordinal n'"
        by auto
      from b_def b_def' have n'n: "n' = n" by (auto simp: cat_ordinal_inj)
      show "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (cat_simplicial \<alpha> A\<lparr>Comp\<rparr>)"
        unfolding prems(1) cat_simplicial_Comp_vdomain
        by (intro composable_cat_simplicialI, rule g, rule f[unfolded n'n])
          (simp_all add:  m n p)
    qed
    show "g \<circ>\<^sub>A\<^bsub>cat_simplicial \<alpha> A\<^esub> f : a \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> c"
      if "g : b \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> c" and "f : a \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> b"
      for b c g a f
      using that
      by (elim cat_simplicial_is_arrE; simp only: cat_ordinal_inj)
        (
          cs_concl cs_shallow
            cs_simp: cat_simplicial_cs_simps
            cs_intro: cat_order_cs_intros cat_simplicial_cs_intros
        )

    show "h \<circ>\<^sub>A\<^bsub>cat_simplicial \<alpha> A\<^esub> g \<circ>\<^sub>A\<^bsub>cat_simplicial \<alpha> A\<^esub> f =
      h \<circ>\<^sub>A\<^bsub>cat_simplicial \<alpha> A\<^esub> (g \<circ>\<^sub>A\<^bsub>cat_simplicial \<alpha> A\<^esub> f)"
      if "h : c \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> d"
        and "g : b \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> c"
        and "f : a \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> b"
      for c d h b g a f
      using that
      apply(elim cat_simplicial_is_arrE; simp only:)
      subgoal for m n m' n' m'' n'' (*FIXME: investigate comp_no_flatten*)
        by
          (
            cs_concl cs_shallow
              cs_simp: cat_cs_simps cat_simplicial_cs_simps
              cs_intro: cat_order_cs_intros cat_simplicial_cs_intros
          )+
      done

    show "cat_simplicial \<alpha> A\<lparr>CId\<rparr>\<lparr>a\<rparr> : a \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> a"
      if "a \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr>" for a
      using that
    proof(elim cat_simplicial_ObjE; simp only:)
      fix m assume prems: "m \<in>\<^sub>\<circ> A" "cat_ordinal m \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr>"
      moreover from prems(1) assms(1) have "Ord m" by auto
      moreover from prems assms have "m \<subseteq>\<^sub>\<circ> \<alpha>"
        by (meson Ord_trans vsubsetI rev_vsubsetD)
      ultimately show "cat_simplicial \<alpha> A\<lparr>CId\<rparr>\<lparr>cat_ordinal m\<rparr> :
        cat_ordinal m \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> cat_ordinal m"
        by
          (
            cs_concl
              cs_simp: cat_simplicial_cs_simps
              cs_intro:
                cat_ordinal_cs_intros
                cat_order_cs_intros
                cat_simplicial_cs_intros
          )
    qed
    show "cat_simplicial \<alpha> A\<lparr>CId\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>cat_simplicial \<alpha> A\<^esub> f = f"
      if "f : a \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> b" for a b f
      using that
      by (elim cat_simplicial_is_arrE; simp only:)
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_simplicial_cs_simps
            cs_intro: cat_order_cs_intros cat_simplicial_cs_intros
        )
    show "f \<circ>\<^sub>A\<^bsub>cat_simplicial \<alpha> A\<^esub> cat_simplicial \<alpha> A\<lparr>CId\<rparr>\<lparr>b\<rparr> = f"
      if "f : b \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> c" for b c f
      using that
      by (elim cat_simplicial_is_arrE; simp only:)
        (
          cs_concl
            cs_simp: cat_cs_simps cat_simplicial_cs_simps
            cs_intro: cat_order_cs_intros cat_simplicial_cs_intros
        )
    show "cat_simplicial \<alpha> A\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
    proof(intro vsubsetI, elim cat_simplicial_ObjE; simp only:)
      fix m assume prems: "m \<in>\<^sub>\<circ> A"
      then have "Ord m" using assms(1) by auto
      moreover from prems have "m \<in>\<^sub>\<circ> \<alpha>" using assms(2) by auto
      ultimately interpret m: cat_tiny_linear_order \<alpha> \<open>cat_ordinal m\<close>
        by (intro cat_tiny_linear_order_cat_ordinal)
      show "cat_ordinal m \<in>\<^sub>\<circ> Vset \<alpha>" by (rule m.tiny_cat_in_Vset)
    qed

    show "(\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A'. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B'. Hom (cat_simplicial \<alpha> A) a b) \<in>\<^sub>\<circ> Vset \<alpha>"
      if "A' \<subseteq>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr>"
        and "B' \<subseteq>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr>"
        and "A' \<in>\<^sub>\<circ> Vset \<alpha>"
        and "B' \<in>\<^sub>\<circ> Vset \<alpha>"
      for A' B'
    proof-
      define Q where "Q i =
        (
          if i = 0 \<Rightarrow> VPow ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<circ> (\<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B'. b'\<lparr>Obj\<rparr>))
           | i = 1\<^sub>\<nat> \<Rightarrow> VPow
              (((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>)) \<times>\<^sub>\<circ>
              ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>)))
           | i = 2\<^sub>\<nat> \<Rightarrow> A'
           | i = 3\<^sub>\<nat> \<Rightarrow> B'
           | otherwise \<Rightarrow> 0
        )"
        for i
      let ?Q =
        \<open>{
          [fo, fa, a, b]\<^sub>\<circ> | fo fa a b.
            fo \<subseteq>\<^sub>\<circ> ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<circ> (\<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B'. b'\<lparr>Obj\<rparr>)) \<and>
            fa \<subseteq>\<^sub>\<circ>
              ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>)) \<times>\<^sub>\<circ>
              ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>)) \<and>
            a \<in>\<^sub>\<circ> A' \<and>
            b \<in>\<^sub>\<circ> B'
         }\<close>

      have QQ: "?Q \<subseteq> elts (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>, 3\<^sub>\<nat>}. Q i)"
      proof(intro subsetI, unfold mem_Collect_eq, elim exE conjE)
        fix x fo fa a b assume prems:
          "x = [fo, fa, a, b]\<^sub>\<circ>"
          "fo \<subseteq>\<^sub>\<circ> ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<circ> (\<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B'. b'\<lparr>Obj\<rparr>))"
          "fa \<subseteq>\<^sub>\<circ>
            ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>)) \<times>\<^sub>\<circ>
            ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>))"
          "a \<in>\<^sub>\<circ> A'"
          "b \<in>\<^sub>\<circ> B'"
        show "x \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>, 3\<^sub>\<nat>}. Q i)"
        proof(intro vproductI, unfold Ball_def; (intro allI impI)?)
          show "\<D>\<^sub>\<circ> x = set {[]\<^sub>\<circ>, 1\<^sub>\<nat>, 2\<^sub>\<nat>, 3\<^sub>\<nat>}"
            unfolding prems(1) by (force simp: nat_omega_simps)
          fix i assume "i \<in>\<^sub>\<circ> set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>, 3\<^sub>\<nat>}"
          then consider \<open>i = 0\<close> | \<open>i = 1\<^sub>\<nat>\<close> | \<open>i = 2\<^sub>\<nat>\<close> | \<open>i = 3\<^sub>\<nat>\<close> by auto
          then show "x\<lparr>i\<rparr> \<in>\<^sub>\<circ> Q i"
            by cases (auto simp: Q_def prems nat_omega_simps)
        qed (auto simp: prems)
      qed
      then have small_Q[simp]: "small ?Q" by (intro down)

      have "(\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A'. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B'. Hom (cat_simplicial \<alpha> A) a b) \<subseteq>\<^sub>\<circ> set ?Q"
      proof(intro vsubsetI in_small_setI small_Q)
        fix f assume "f \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A'. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B'. Hom (cat_simplicial \<alpha> A) a b)"
        then obtain a b
          where a: "a \<in>\<^sub>\<circ> A'"
            and b: "b \<in>\<^sub>\<circ> B'"
            and "f : a \<mapsto>\<^bsub>cat_simplicial \<alpha> A\<^esub> b"
          by auto
        then obtain m n
          where f: "f : cat_ordinal m \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^bsub>\<alpha>\<^esub> cat_ordinal n"
            and m: "m \<in>\<^sub>\<circ> A"
            and n: "n \<in>\<^sub>\<circ> A"
            and a_def: "a = cat_ordinal m"
            and b_def: "b = cat_ordinal n"
          by auto
        interpret f: is_preorder_functor \<alpha> \<open>cat_ordinal m\<close> \<open>cat_ordinal n\<close> f
          by (rule f)
        show "f \<in> ?Q"
        proof(unfold mem_Collect_eq, intro exI conjI)
          show "f\<lparr>ObjMap\<rparr> \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<circ> (\<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B'. b'\<lparr>Obj\<rparr>)"
          proof(intro vsubsetI)
            fix x assume prems: "x \<in>\<^sub>\<circ> f\<lparr>ObjMap\<rparr>"
            obtain xl xr
              where x_def: "x = \<langle>xl, xr\<rangle>"
                and xl: "xl \<in>\<^sub>\<circ> cat_ordinal m\<lparr>Obj\<rparr>"
                and xr: "xr \<in>\<^sub>\<circ> (\<R>\<^sub>\<circ> (f\<lparr>ObjMap\<rparr>))"
              by (elim f.ObjMap.vbrelation_vinE[OF prems, unfolded cat_cs_simps])
            show "x \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<circ> (\<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B'. b'\<lparr>Obj\<rparr>)"
              unfolding x_def
            proof(standard; (intro vifunionI))
              from xr f.cf_ObjMap_vrange show "xr \<in>\<^sub>\<circ> cat_ordinal n\<lparr>Obj\<rparr>" by auto
            qed (use a b in \<open>auto intro: xl simp: a_def b_def\<close>)
          qed
          show "f\<lparr>ArrMap\<rparr> \<subseteq>\<^sub>\<circ>
            ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>)) \<times>\<^sub>\<circ>
            ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>))"
          proof(intro vsubsetI)
            fix x assume prems: "x \<in>\<^sub>\<circ> f\<lparr>ArrMap\<rparr>"
            obtain xl xr
              where x_def: "x = \<langle>xl, xr\<rangle>"
                and xl: "xl \<in>\<^sub>\<circ> cat_ordinal m\<lparr>Arr\<rparr>"
                and xr: "xr \<in>\<^sub>\<circ> (\<R>\<^sub>\<circ> (f\<lparr>ArrMap\<rparr>))"
              by (elim f.ArrMap.vbrelation_vinE[OF prems, unfolded cat_cs_simps])
            from xr vsubsetD have xr: "xr \<in>\<^sub>\<circ> cat_ordinal n\<lparr>Arr\<rparr>"
              by (auto intro: f.cf_ArrMap_vrange)
            from xl obtain xll xlr where xl_def: "xl = [xll, xlr]\<^sub>\<circ>"
              and xll_m: "xll \<in>\<^sub>\<circ> m"
              and xlr_m: "xlr \<in>\<^sub>\<circ> m"
              and "xll \<subseteq>\<^sub>\<circ> xlr"
              unfolding ordinal_arrs_def cat_ordinal_components by clarsimp
            from xr obtain xrl xrr where xr_def: "xr = [xrl, xrr]\<^sub>\<circ>"
              and xrl_n: "xrl \<in>\<^sub>\<circ> n"
              and xrr_n:"xrr \<in>\<^sub>\<circ> n"
              and "xrl \<subseteq>\<^sub>\<circ> xrr"
              unfolding ordinal_arrs_def cat_ordinal_components by clarsimp
            show "x \<in>\<^sub>\<circ>
              ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>)) \<times>\<^sub>\<circ>
              ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>))"
              unfolding x_def
              by (standard; (intro vifunionI ftimesI1)?)
                (
                  use a b in \<open>
                    auto
                      simp: xl_def xr_def a_def b_def cat_ordinal_components
                      intro: xrr_n xrl_n xlr_m xll_m
                    \<close>
                )
          qed
        qed
          (
            auto
              simp: cat_cs_simps
              intro: a[unfolded a_def] b[unfolded b_def] f.cf_def
          )
      qed
      moreover have "set ?Q \<subseteq>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>, 3\<^sub>\<nat>}. Q i)"
        by
          (
            intro vsubset_if_subset,
            unfold small_elts_of_set[OF small_Q],
            intro QQ
          )
      moreover have "(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>, 3\<^sub>\<nat>}. Q i) \<in>\<^sub>\<circ> Vset \<alpha>"
      proof(intro Limit_vproduct_in_VsetI)
        show "set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>, 3\<^sub>\<nat>} \<in>\<^sub>\<circ> Vset \<alpha>"
          unfolding four[symmetric] by simp
        have "(\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>(\<Union>\<^sub>\<circ>r\<in>\<^sub>\<circ>A'. \<R>\<^sub>\<circ> r)"
        proof(intro vsubsetI)
          fix x assume "x \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>)"
          then obtain a' where a': "a' \<in>\<^sub>\<circ> A'" and x: "x \<in>\<^sub>\<circ> a'\<lparr>Obj\<rparr>" by auto
          from a' that(1) have "a' \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr>" by auto
          then obtain m where a'_def: "a' = cat_ordinal m" and m: "m \<in>\<^sub>\<circ> A"
            unfolding cat_simplicial_components by clarsimp
          show "x \<in>\<^sub>\<circ> \<Union>\<^sub>\<circ>(\<Union>\<^sub>\<circ>r\<in>\<^sub>\<circ>A'. \<R>\<^sub>\<circ> r)"
          proof(rule VUnionI, rule vifunionI)
            from a'_def have "vsv a'" and "Obj \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> a'"
              unfolding a'_def cat_ordinal_def Obj_def by auto
            then show "a'\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> a'" by auto
          qed (auto simp: x a')
        qed
        moreover have "(\<Union>\<^sub>\<circ>r\<in>\<^sub>\<circ>A'. \<R>\<^sub>\<circ> r) \<in>\<^sub>\<circ> Vset \<alpha>"
          by (intro Limit_VUnion_vrange_in_VsetI[OF Limit_\<alpha>] that)
        ultimately have UA': "(\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>" by blast
        have B': "(\<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B'. b'\<lparr>Obj\<rparr>) \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>(\<Union>\<^sub>\<circ>r\<in>\<^sub>\<circ>B'. \<R>\<^sub>\<circ> r)"
          (*FIXME: code duplication*)
        proof(intro vsubsetI)
          fix x assume "x \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B'. b'\<lparr>Obj\<rparr>)"
          then obtain b' where b': "b' \<in>\<^sub>\<circ> B'" and x: "x \<in>\<^sub>\<circ> b'\<lparr>Obj\<rparr>" by auto
          from b' that(2) have "b' \<in>\<^sub>\<circ> cat_simplicial \<alpha> A\<lparr>Obj\<rparr>" by auto
          then obtain m where b'_def: "b' = cat_ordinal m" and m: "m \<in>\<^sub>\<circ> A"
            unfolding cat_simplicial_components by clarsimp
          show "x \<in>\<^sub>\<circ> \<Union>\<^sub>\<circ>(\<Union>\<^sub>\<circ>r\<in>\<^sub>\<circ>B'. \<R>\<^sub>\<circ> r)"
          proof(rule VUnionI, rule vifunionI)
            from b'_def have "vsv b'" and "Obj \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> b'"
              unfolding b'_def cat_ordinal_def Obj_def by auto
            then show "b'\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> b'" by auto
          qed (auto simp: x b')
        qed
        moreover have "(\<Union>\<^sub>\<circ>r\<in>\<^sub>\<circ>B'. \<R>\<^sub>\<circ> r) \<in>\<^sub>\<circ> Vset \<alpha>"
          by (intro Limit_VUnion_vrange_in_VsetI[OF Limit_\<alpha>] that)
        ultimately have UB': "(\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>" by blast
        have [simp]:
          "VPow ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<circ> (\<Union>\<^sub>\<circ>b'\<in>\<^sub>\<circ>B'. b'\<lparr>Obj\<rparr>)) \<in>\<^sub>\<circ> Vset \<alpha>"
          by (intro Limit_VPow_in_VsetI Limit_vtimes_in_VsetI UA' UB') auto
        have [simp]:
          "VPow
            (
              ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>A'. a'\<lparr>Obj\<rparr>)) \<times>\<^sub>\<circ>
              ((\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>) \<times>\<^sub>\<bullet> (\<Union>\<^sub>\<circ>a'\<in>\<^sub>\<circ>B'. a'\<lparr>Obj\<rparr>))
            ) \<in>\<^sub>\<circ> Vset \<alpha>"
          by
            (
              intro
                Limit_VPow_in_VsetI
                Limit_vtimes_in_VsetI
                Limit_ftimes_in_VsetI
                UA' UB'
            )
            auto
        fix i assume "i \<in>\<^sub>\<circ> set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>, 3\<^sub>\<nat>}"
        then consider \<open>i = 0\<close> | \<open>i = 1\<^sub>\<nat>\<close> | \<open>i = 2\<^sub>\<nat>\<close> | \<open>i = 3\<^sub>\<nat>\<close> by auto
        then show "Q i \<in>\<^sub>\<circ> Vset \<alpha>"
          by cases (simp_all add: Q_def that nat_omega_simps)
      qed auto
      ultimately show ?thesis by (simp add: vsubset_in_VsetI)
    qed
  qed (auto simp: cat_simplicial_components)

qed

text\<open>\newpage\<close>

end


(*  Title:      HOL/Proofs/Lambda/NormalForm.thy
    Author:     Stefan Berghofer, TU Muenchen, 2003
*)

section \<open>Inductive characterization of lambda terms in normal form\<close>

theory NormalForm
imports ListBeta
begin

subsection \<open>Terms in normal form\<close>

definition
  listall :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "listall P xs \<equiv> (\<forall>i. i < length xs \<longrightarrow> P (xs ! i))"

declare listall_def [extraction_expand_def]

theorem listall_nil: "listall P []"
  by (simp add: listall_def)

theorem listall_nil_eq [simp]: "listall P [] = True"
  by (iprover intro: listall_nil)

theorem listall_cons: "P x \<Longrightarrow> listall P xs \<Longrightarrow> listall P (x # xs)"
  apply (simp add: listall_def)
  apply (rule allI impI)+
  apply (case_tac i)
  apply simp+
  done

theorem listall_cons_eq [simp]: "listall P (x # xs) = (P x \<and> listall P xs)"
  apply (rule iffI)
  prefer 2
  apply (erule conjE)
  apply (erule listall_cons)
  apply assumption
  apply (unfold listall_def)
  apply (rule conjI)
  apply (erule_tac x=0 in allE)
  apply simp
  apply simp
  apply (rule allI)
  apply (erule_tac x="Suc i" in allE)
  apply simp
  done

lemma listall_conj1: "listall (\<lambda>x. P x \<and> Q x) xs \<Longrightarrow> listall P xs"
  by (induct xs) simp_all

lemma listall_conj2: "listall (\<lambda>x. P x \<and> Q x) xs \<Longrightarrow> listall Q xs"
  by (induct xs) simp_all

lemma listall_app: "listall P (xs @ ys) = (listall P xs \<and> listall P ys)"
  apply (induct xs)
   apply (rule iffI, simp, simp)
  apply (rule iffI, simp, simp)
  done

lemma listall_snoc [simp]: "listall P (xs @ [x]) = (listall P xs \<and> P x)"
  apply (rule iffI)
  apply (simp add: listall_app)+
  done

lemma listall_cong [cong, extraction_expand]:
  "xs = ys \<Longrightarrow> listall P xs = listall P ys"
  \<comment> \<open>Currently needed for strange technical reasons\<close>
  by (unfold listall_def) simp

text \<open>
@{term "listsp"} is equivalent to @{term "listall"}, but cannot be
used for program extraction.
\<close>

lemma listall_listsp_eq: "listall P xs = listsp P xs"
  by (induct xs) (auto intro: listsp.intros)

inductive NF :: "dB \<Rightarrow> bool"
where
  App: "listall NF ts \<Longrightarrow> NF (Var x \<degree>\<degree> ts)"
| Abs: "NF t \<Longrightarrow> NF (Abs t)"
monos listall_def

lemma nat_eq_dec: "\<And>n::nat. m = n \<or> m \<noteq> n"
  apply (induct m)
  apply (case_tac n)
  apply (case_tac [3] n)
  apply (simp only: nat.simps, iprover?)+
  done

lemma nat_le_dec: "\<And>n::nat. m < n \<or> \<not> (m < n)"
  apply (induct m)
  apply (case_tac n)
  apply (case_tac [3] n)
  apply (simp del: simp_thms, iprover?)+
  done

lemma App_NF_D: assumes NF: "NF (Var n \<degree>\<degree> ts)"
  shows "listall NF ts" using NF
  by cases simp_all

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

lemma Var_NF: "NF (Var n)"
  apply (subgoal_tac "NF (Var n \<degree>\<degree> [])")
   apply simp
  apply (rule NF.App)
  apply simp
  done

lemma Abs_NF:
  assumes NF: "NF (Abs t \<degree>\<degree> ts)"
  shows "ts = []" using NF
proof cases
  case (App us i)
  thus ?thesis by (simp add: Var_apps_neq_Abs_apps [THEN not_sym])
next
  case (Abs u)
  thus ?thesis by simp
qed

lemma subst_terms_NF: "listall NF ts \<Longrightarrow>
    listall (\<lambda>t. \<forall>i j. NF (t[Var i/j])) ts \<Longrightarrow>
    listall NF (map (\<lambda>t. t[Var i/j]) ts)"
  by (induct ts) simp_all

lemma subst_Var_NF: "NF t \<Longrightarrow> NF (t[Var i/j])"
  apply (induct arbitrary: i j set: NF)
  apply simp
  apply (frule listall_conj1)
  apply (drule listall_conj2)
  apply (drule_tac i=i and j=j in subst_terms_NF)
  apply assumption
  apply (rule_tac m1=x and n1=j in nat_eq_dec [THEN disjE])
  apply simp
  apply (erule NF.App)
  apply (rule_tac m1=j and n1=x in nat_le_dec [THEN disjE])
  apply simp
  apply (iprover intro: NF.App)
  apply simp
  apply (iprover intro: NF.App)
  apply simp
  apply (iprover intro: NF.Abs)
  done

lemma app_Var_NF: "NF t \<Longrightarrow> \<exists>t'. t \<degree> Var i \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
  apply (induct set: NF)
  apply (simplesubst app_last)  \<comment>\<open>Using \<open>subst\<close> makes extraction fail\<close>
  apply (rule exI)
  apply (rule conjI)
  apply (rule rtranclp.rtrancl_refl)
  apply (rule NF.App)
  apply (drule listall_conj1)
  apply (simp add: listall_app)
  apply (rule Var_NF)
  apply (rule exI)
  apply (rule conjI)
  apply (rule rtranclp.rtrancl_into_rtrancl)
  apply (rule rtranclp.rtrancl_refl)
  apply (rule beta)
  apply (erule subst_Var_NF)
  done

lemma lift_terms_NF: "listall NF ts \<Longrightarrow>
    listall (\<lambda>t. \<forall>i. NF (lift t i)) ts \<Longrightarrow>
    listall NF (map (\<lambda>t. lift t i) ts)"
  by (induct ts) simp_all

lemma lift_NF: "NF t \<Longrightarrow> NF (lift t i)"
  apply (induct arbitrary: i set: NF)
  apply (frule listall_conj1)
  apply (drule listall_conj2)
  apply (drule_tac i=i in lift_terms_NF)
  apply assumption
  apply (rule_tac m1=x and n1=i in nat_le_dec [THEN disjE])
  apply simp
  apply (rule NF.App)
  apply assumption
  apply simp
  apply (rule NF.App)
  apply assumption
  apply simp
  apply (rule NF.Abs)
  apply simp
  done

text \<open>
@{term NF} characterizes exactly the terms that are in normal form.
\<close>

lemma NF_eq: "NF t = (\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t')"
proof
  assume "NF t"
  then have "\<And>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  proof induct
    case (App ts t)
    show ?case
    proof
      assume "Var t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> t'"
      then obtain rs where "ts => rs"
        by (iprover dest: head_Var_reduction)
      with App show False
        by (induct rs arbitrary: ts) auto
    qed
  next
    case (Abs t)
    show ?case
    proof
      assume "Abs t \<rightarrow>\<^sub>\<beta> t'"
      then show False using Abs by cases simp_all
    qed
  qed
  then show "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'" ..
next
  assume H: "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  then show "NF t"
  proof (induct t rule: Apps_dB_induct)
    case (1 n ts)
    then have "\<forall>ts'. \<not> ts => ts'"
      by (iprover intro: apps_preserves_betas)
    with 1(1) have "listall NF ts"
      by (induct ts) auto
    then show ?case by (rule NF.App)
  next
    case (2 u ts)
    show ?case
    proof (cases ts)
      case Nil
      from 2 have "\<forall>u'. \<not> u \<rightarrow>\<^sub>\<beta> u'"
        by (auto intro: apps_preserves_beta)
      then have "NF u" by (rule 2)
      then have "NF (Abs u)" by (rule NF.Abs)
      with Nil show ?thesis by simp
    next
      case (Cons r rs)
      have "Abs u \<degree> r \<rightarrow>\<^sub>\<beta> u[r/0]" ..
      then have "Abs u \<degree> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> u[r/0] \<degree>\<degree> rs"
        by (rule apps_preserves_beta)
      with Cons have "Abs u \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> u[r/0] \<degree>\<degree> rs"
        by simp
      with 2 show ?thesis by iprover
    qed
  qed
qed

end


(*  Title:      ZF/Epsilon.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section{*Epsilon Induction and Recursion*}

theory Epsilon imports Nat_ZF begin

definition
  eclose    :: "i=>i"  where
    "eclose(A) == \<Union>n\<in>nat. nat_rec(n, A, %m r. \<Union>(r))"

definition
  transrec  :: "[i, [i,i]=>i] =>i"  where
    "transrec(a,H) == wfrec(Memrel(eclose({a})), a, H)"

definition
  rank      :: "i=>i"  where
    "rank(a) == transrec(a, %x f. \<Union>y\<in>x. succ(f`y))"

definition
  transrec2 :: "[i, i, [i,i]=>i] =>i"  where
    "transrec2(k, a, b) ==
       transrec(k,
                %i r. if(i=0, a,
                        if(\<exists>j. i=succ(j),
                           b(THE j. i=succ(j), r`(THE j. i=succ(j))),
                           \<Union>j<i. r`j)))"

definition
  recursor  :: "[i, [i,i]=>i, i]=>i"  where
    "recursor(a,b,k) ==  transrec(k, %n f. nat_case(a, %m. b(m, f`m), n))"

definition
  rec  :: "[i, i, [i,i]=>i]=>i"  where
    "rec(k,a,b) == recursor(a,b,k)"

subsection{*Basic Closure Properties*}

lemma arg_subset_eclose: "A \<subseteq> eclose(A)"
apply (unfold eclose_def)
apply (rule nat_rec_0 [THEN equalityD2, THEN subset_trans])
apply (rule nat_0I [THEN UN_upper])
done

lemmas arg_into_eclose = arg_subset_eclose [THEN subsetD]

lemma Transset_eclose: "Transset(eclose(A))"
apply (unfold eclose_def Transset_def)
apply (rule subsetI [THEN ballI])
apply (erule UN_E)
apply (rule nat_succI [THEN UN_I], assumption)
apply (erule nat_rec_succ [THEN ssubst])
apply (erule UnionI, assumption)
done

(* @{term"x \<in> eclose(A) ==> x \<subseteq> eclose(A)"} *)
lemmas eclose_subset =
       Transset_eclose [unfolded Transset_def, THEN bspec]

(* @{term"[| A \<in> eclose(B); c \<in> A |] ==> c \<in> eclose(B)"} *)
lemmas ecloseD = eclose_subset [THEN subsetD]

lemmas arg_in_eclose_sing = arg_subset_eclose [THEN singleton_subsetD]
lemmas arg_into_eclose_sing = arg_in_eclose_sing [THEN ecloseD]

(* This is epsilon-induction for eclose(A); see also eclose_induct_down...
   [| a \<in> eclose(A);  !!x. [| x \<in> eclose(A); \<forall>y\<in>x. P(y) |] ==> P(x)
   |] ==> P(a)
*)
lemmas eclose_induct =
     Transset_induct [OF _ Transset_eclose, induct set: eclose]

(*Epsilon induction*)
lemma eps_induct:
    "[| !!x. \<forall>y\<in>x. P(y) ==> P(x) |]  ==>  P(a)"
by (rule arg_in_eclose_sing [THEN eclose_induct], blast)

subsection{*Leastness of @{term eclose}*}

(** eclose(A) is the least transitive set including A as a subset. **)

lemma eclose_least_lemma:
    "[| Transset(X);  A<=X;  n \<in> nat |] ==> nat_rec(n, A, %m r. \<Union>(r)) \<subseteq> X"
apply (unfold Transset_def)
apply (erule nat_induct)
apply (simp add: nat_rec_0)
apply (simp add: nat_rec_succ, blast)
done

lemma eclose_least:
     "[| Transset(X);  A<=X |] ==> eclose(A) \<subseteq> X"
apply (unfold eclose_def)
apply (rule eclose_least_lemma [THEN UN_least], assumption+)
done

(*COMPLETELY DIFFERENT induction principle from eclose_induct!!*)
lemma eclose_induct_down [consumes 1]:
    "[| a \<in> eclose(b);
        !!y.   [| y \<in> b |] ==> P(y);
        !!y z. [| y \<in> eclose(b);  P(y);  z \<in> y |] ==> P(z)
     |] ==> P(a)"
apply (rule eclose_least [THEN subsetD, THEN CollectD2, of "eclose(b)"])
  prefer 3 apply assumption
 apply (unfold Transset_def)
 apply (blast intro: ecloseD)
apply (blast intro: arg_subset_eclose [THEN subsetD])
done

lemma Transset_eclose_eq_arg: "Transset(X) ==> eclose(X) = X"
apply (erule equalityI [OF eclose_least arg_subset_eclose])
apply (rule subset_refl)
done

text{*A transitive set either is empty or contains the empty set.*}
lemma Transset_0_lemma [rule_format]: "Transset(A) ==> x\<in>A \<longrightarrow> 0\<in>A"
apply (simp add: Transset_def)
apply (rule_tac a=x in eps_induct, clarify)
apply (drule bspec, assumption)
apply (case_tac "x=0", auto)
done

lemma Transset_0_disj: "Transset(A) ==> A=0 | 0\<in>A"
by (blast dest: Transset_0_lemma)

subsection{*Epsilon Recursion*}

(*Unused...*)
lemma mem_eclose_trans: "[| A \<in> eclose(B);  B \<in> eclose(C) |] ==> A \<in> eclose(C)"
by (rule eclose_least [OF Transset_eclose eclose_subset, THEN subsetD],
    assumption+)

(*Variant of the previous lemma in a useable form for the sequel*)
lemma mem_eclose_sing_trans:
     "[| A \<in> eclose({B});  B \<in> eclose({C}) |] ==> A \<in> eclose({C})"
by (rule eclose_least [OF Transset_eclose singleton_subsetI, THEN subsetD],
    assumption+)

lemma under_Memrel: "[| Transset(i);  j \<in> i |] ==> Memrel(i)-``{j} = j"
by (unfold Transset_def, blast)

lemma lt_Memrel: "j < i ==> Memrel(i) -`` {j} = j"
by (simp add: lt_def Ord_def under_Memrel)

(* @{term"j \<in> eclose(A) ==> Memrel(eclose(A)) -`` j = j"} *)
lemmas under_Memrel_eclose = Transset_eclose [THEN under_Memrel]

lemmas wfrec_ssubst = wf_Memrel [THEN wfrec, THEN ssubst]

lemma wfrec_eclose_eq:
    "[| k \<in> eclose({j});  j \<in> eclose({i}) |] ==>
     wfrec(Memrel(eclose({i})), k, H) = wfrec(Memrel(eclose({j})), k, H)"
apply (erule eclose_induct)
apply (rule wfrec_ssubst)
apply (rule wfrec_ssubst)
apply (simp add: under_Memrel_eclose mem_eclose_sing_trans [of _ j i])
done

lemma wfrec_eclose_eq2:
    "k \<in> i ==> wfrec(Memrel(eclose({i})),k,H) = wfrec(Memrel(eclose({k})),k,H)"
apply (rule arg_in_eclose_sing [THEN wfrec_eclose_eq])
apply (erule arg_into_eclose_sing)
done

lemma transrec: "transrec(a,H) = H(a, \<lambda>x\<in>a. transrec(x,H))"
apply (unfold transrec_def)
apply (rule wfrec_ssubst)
apply (simp add: wfrec_eclose_eq2 arg_in_eclose_sing under_Memrel_eclose)
done

(*Avoids explosions in proofs; resolve it with a meta-level definition.*)
lemma def_transrec:
    "[| !!x. f(x)==transrec(x,H) |] ==> f(a) = H(a, \<lambda>x\<in>a. f(x))"
apply simp
apply (rule transrec)
done

lemma transrec_type:
    "[| !!x u. [| x \<in> eclose({a});  u \<in> Pi(x,B) |] ==> H(x,u) \<in> B(x) |]
     ==> transrec(a,H) \<in> B(a)"
apply (rule_tac i = a in arg_in_eclose_sing [THEN eclose_induct])
apply (subst transrec)
apply (simp add: lam_type)
done

lemma eclose_sing_Ord: "Ord(i) ==> eclose({i}) \<subseteq> succ(i)"
apply (erule Ord_is_Transset [THEN Transset_succ, THEN eclose_least])
apply (rule succI1 [THEN singleton_subsetI])
done

lemma succ_subset_eclose_sing: "succ(i) \<subseteq> eclose({i})"
apply (insert arg_subset_eclose [of "{i}"], simp)
apply (frule eclose_subset, blast)
done

lemma eclose_sing_Ord_eq: "Ord(i) ==> eclose({i}) = succ(i)"
apply (rule equalityI)
apply (erule eclose_sing_Ord)
apply (rule succ_subset_eclose_sing)
done

lemma Ord_transrec_type:
  assumes jini: "j \<in> i"
      and ordi: "Ord(i)"
      and minor: " !!x u. [| x \<in> i;  u \<in> Pi(x,B) |] ==> H(x,u) \<in> B(x)"
  shows "transrec(j,H) \<in> B(j)"
apply (rule transrec_type)
apply (insert jini ordi)
apply (blast intro!: minor
             intro: Ord_trans
             dest: Ord_in_Ord [THEN eclose_sing_Ord, THEN subsetD])
done

subsection{*Rank*}

(*NOT SUITABLE FOR REWRITING -- RECURSIVE!*)
lemma rank: "rank(a) = (\<Union>y\<in>a. succ(rank(y)))"
by (subst rank_def [THEN def_transrec], simp)

lemma Ord_rank [simp]: "Ord(rank(a))"
apply (rule_tac a=a in eps_induct)
apply (subst rank)
apply (rule Ord_succ [THEN Ord_UN])
apply (erule bspec, assumption)
done

lemma rank_of_Ord: "Ord(i) ==> rank(i) = i"
apply (erule trans_induct)
apply (subst rank)
apply (simp add: Ord_equality)
done

lemma rank_lt: "a \<in> b ==> rank(a) < rank(b)"
apply (rule_tac a1 = b in rank [THEN ssubst])
apply (erule UN_I [THEN ltI])
apply (rule_tac [2] Ord_UN, auto)
done

lemma eclose_rank_lt: "a \<in> eclose(b) ==> rank(a) < rank(b)"
apply (erule eclose_induct_down)
apply (erule rank_lt)
apply (erule rank_lt [THEN lt_trans], assumption)
done

lemma rank_mono: "a<=b ==> rank(a) \<le> rank(b)"
apply (rule subset_imp_le)
apply (auto simp add: rank [of a] rank [of b])
done

lemma rank_Pow: "rank(Pow(a)) = succ(rank(a))"
apply (rule rank [THEN trans])
apply (rule le_anti_sym)
apply (rule_tac [2] UN_upper_le)
apply (rule UN_least_le)
apply (auto intro: rank_mono simp add: Ord_UN)
done

lemma rank_0 [simp]: "rank(0) = 0"
by (rule rank [THEN trans], blast)

lemma rank_succ [simp]: "rank(succ(x)) = succ(rank(x))"
apply (rule rank [THEN trans])
apply (rule equalityI [OF UN_least succI1 [THEN UN_upper]])
apply (erule succE, blast)
apply (erule rank_lt [THEN leI, THEN succ_leI, THEN le_imp_subset])
done

lemma rank_Union: "rank(\<Union>(A)) = (\<Union>x\<in>A. rank(x))"
apply (rule equalityI)
apply (rule_tac [2] rank_mono [THEN le_imp_subset, THEN UN_least])
apply (erule_tac [2] Union_upper)
apply (subst rank)
apply (rule UN_least)
apply (erule UnionE)
apply (rule subset_trans)
apply (erule_tac [2] RepFunI [THEN Union_upper])
apply (erule rank_lt [THEN succ_leI, THEN le_imp_subset])
done

lemma rank_eclose: "rank(eclose(a)) = rank(a)"
apply (rule le_anti_sym)
apply (rule_tac [2] arg_subset_eclose [THEN rank_mono])
apply (rule_tac a1 = "eclose (a) " in rank [THEN ssubst])
apply (rule Ord_rank [THEN UN_least_le])
apply (erule eclose_rank_lt [THEN succ_leI])
done

lemma rank_pair1: "rank(a) < rank(<a,b>)"
apply (unfold Pair_def)
apply (rule consI1 [THEN rank_lt, THEN lt_trans])
apply (rule consI1 [THEN consI2, THEN rank_lt])
done

lemma rank_pair2: "rank(b) < rank(<a,b>)"
apply (unfold Pair_def)
apply (rule consI1 [THEN consI2, THEN rank_lt, THEN lt_trans])
apply (rule consI1 [THEN consI2, THEN rank_lt])
done

(*Not clear how to remove the P(a) condition, since the "then" part
  must refer to "a"*)
lemma the_equality_if:
     "P(a) ==> (THE x. P(x)) = (if (EX!x. P(x)) then a else 0)"
by (simp add: the_0 the_equality2)

(*The first premise not only fixs i but ensures @{term"f\<noteq>0"}.
  The second premise is now essential.  Consider otherwise the relation
  r = {<0,0>,<0,1>,<0,2>,...}.  Then f`0 = \<Union>(f``{0}) = \<Union>(nat) = nat,
  whose rank equals that of r.*)
lemma rank_apply: "[|i \<in> domain(f); function(f)|] ==> rank(f`i) < rank(f)"
apply clarify
apply (simp add: function_apply_equality)
apply (blast intro: lt_trans rank_lt rank_pair2)
done

subsection{*Corollaries of Leastness*}

lemma mem_eclose_subset: "A \<in> B ==> eclose(A)<=eclose(B)"
apply (rule Transset_eclose [THEN eclose_least])
apply (erule arg_into_eclose [THEN eclose_subset])
done

lemma eclose_mono: "A<=B ==> eclose(A) \<subseteq> eclose(B)"
apply (rule Transset_eclose [THEN eclose_least])
apply (erule subset_trans)
apply (rule arg_subset_eclose)
done

(** Idempotence of eclose **)

lemma eclose_idem: "eclose(eclose(A)) = eclose(A)"
apply (rule equalityI)
apply (rule eclose_least [OF Transset_eclose subset_refl])
apply (rule arg_subset_eclose)
done

(** Transfinite recursion for definitions based on the
    three cases of ordinals **)

lemma transrec2_0 [simp]: "transrec2(0,a,b) = a"
by (rule transrec2_def [THEN def_transrec, THEN trans], simp)

lemma transrec2_succ [simp]: "transrec2(succ(i),a,b) = b(i, transrec2(i,a,b))"
apply (rule transrec2_def [THEN def_transrec, THEN trans])
apply (simp add: the_equality if_P)
done

lemma transrec2_Limit:
     "Limit(i) ==> transrec2(i,a,b) = (\<Union>j<i. transrec2(j,a,b))"
apply (rule transrec2_def [THEN def_transrec, THEN trans])
apply (auto simp add: OUnion_def)
done

lemma def_transrec2:
     "(!!x. f(x)==transrec2(x,a,b))
      ==> f(0) = a &
          f(succ(i)) = b(i, f(i)) &
          (Limit(K) \<longrightarrow> f(K) = (\<Union>j<K. f(j)))"
by (simp add: transrec2_Limit)

(** recursor -- better than nat_rec; the succ case has no type requirement! **)

(*NOT suitable for rewriting*)
lemmas recursor_lemma = recursor_def [THEN def_transrec, THEN trans]

lemma recursor_0: "recursor(a,b,0) = a"
by (rule nat_case_0 [THEN recursor_lemma])

lemma recursor_succ: "recursor(a,b,succ(m)) = b(m, recursor(a,b,m))"
by (rule recursor_lemma, simp)

(** rec: old version for compatibility **)

lemma rec_0 [simp]: "rec(0,a,b) = a"
apply (unfold rec_def)
apply (rule recursor_0)
done

lemma rec_succ [simp]: "rec(succ(m),a,b) = b(m, rec(m,a,b))"
apply (unfold rec_def)
apply (rule recursor_succ)
done

lemma rec_type:
    "[| n \<in> nat;
        a \<in> C(0);
        !!m z. [| m \<in> nat;  z \<in> C(m) |] ==> b(m,z): C(succ(m)) |]
     ==> rec(n,a,b) \<in> C(n)"
by (erule nat_induct, auto)

end


theory Test_Suite_ATC_RBT
imports Test_Suite_ATC "HOL-Library.RBT_Set" "HOL-Library.RBT_Mapping" (*"HOL-Data_Structures.AVL_Set"*)
begin

(* from RBT_Set : *)
(*
  Users should be aware that by including this file all code equations
  outside of List.thy using 'a list as an implementation of sets cannot be
  used for code generation. If such equations are not needed, they can be
  deleted from the code generator. Otherwise, a user has to provide their
  own equations using RBT trees.
*)

lemma x:
  fixes X :: "('a :: linorder) set"

  shows "set (sorted_list_of_set X) = X"

end (*
value "sorted_list_of_set (Mapping.keys (Mapping.empty :: (nat,nat) Mapping.mapping))"

instantiation sum :: (ord,ord) ord
begin

fun less_eq_sum ::  "'a + 'b \<Rightarrow> 'a + 'b \<Rightarrow> bool" where
  "less_eq_sum (Inl a) (Inl b) = (a \<le> b)" |
  "less_eq_sum (Inl a) (Inr b) = True" |
  "less_eq_sum (Inr a) (Inl b) = False" |
  "less_eq_sum (Inr a) (Inr b) = (a \<le> b)"

fun less_sum ::  "'a + 'b \<Rightarrow> 'a + 'b \<Rightarrow> bool" where
  "less_sum a b = (a \<le> b \<and> a \<noteq> b)"

instance by (intro_classes)
end

instantiation sum :: (linorder,linorder) linorder
begin

lemma less_le_not_le_sum :
  fixes x :: "'a + 'b"
  and   y :: "'a + 'b"
shows "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
  by (induct x; induct y; auto)

lemma order_refl_sum :
  fixes x :: "'a + 'b"
shows "x \<le> x"
  by (induct x; auto)

lemma order_trans_sum :
  fixes x :: "'a + 'b"
  fixes y :: "'a + 'b"
  fixes z :: "'a + 'b"
shows "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
  by (induct x; induct y; induct z; auto)

lemma antisym_sum :
  fixes x :: "'a + 'b"
  fixes y :: "'a + 'b"
shows "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
  by (induct x; induct y; auto)

lemma linear_sum :
  fixes x :: "'a + 'b"
  fixes y :: "'a + 'b"
shows "x \<le> y \<or> y \<le> x"
  by (induct x; induct y; auto)

instance
  using less_le_not_le_sum order_refl_sum order_trans_sum antisym_sum linear_sum
  by (intro_classes; metis+)
end

instantiation list :: (ord) ord
begin

fun less_eq_list ::  "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "less_eq_list [] xs = True" |
  "less_eq_list (x#xs) [] = False" |
  "less_eq_list (x#xs) (y#ys) = (x < y \<or> (x = y \<and> less_eq_list xs ys))"

fun less_list ::  "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "less_list a b = (a \<le> b \<and> a \<noteq> b)"

instance by (intro_classes)
end

instantiation list :: (linorder) linorder
begin

lemma less_le_not_le_list :
  fixes x :: "'a list"
  and   y :: "'a list"
shows "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
proof
  show "x < y \<Longrightarrow> x \<le> y \<and> \<not> y \<le> x"
    using less_eq_list.elims(2) by (induction rule: less_eq_list.induct; fastforce)
  show "x \<le> y \<and> \<not> y \<le> x \<Longrightarrow> x < y"
    by (induction rule: less_eq_list.induct; auto)
qed

lemma order_refl_list :
  fixes x :: "'a list"
shows "x \<le> x"
proof (induction x)
  case Nil
  then show ?case by auto
next
  case (Cons x xs)
  then show ?case by (cases xs; auto)
qed

lemma order_trans_list :
  fixes x :: "'a list"
  fixes y :: "'a list"
  fixes z :: "'a list"
shows "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
proof (induction x arbitrary: y z)
  case Nil
  then show ?case by auto
next
  case (Cons x xs)
  then show ?case proof (induction y arbitrary: z)
    case Nil
    then show ?case by auto
  next
    case (Cons y ys)
    then show ?case proof (induction z)
      case Nil
      then show ?case by auto
    next
      case (Cons z zs)
      from \<open>x # xs \<le> y # ys\<close> \<open>y # ys \<le> z # zs\<close>
      consider "x < y" |
               "x = y \<and> y < z" |
               "x = y \<and> xs \<le> ys \<and> y = z \<and> ys \<le> zs"
        using less_eq_list.simps(3) by blast
      then show ?case using Cons.prems(2,4) by (cases; auto)
    qed
  qed
qed

lemma antisym_list :
  fixes x :: "'a list"
  fixes y :: "'a list"
shows "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
  by (meson less_le_not_le_list less_list.elims(3))

lemma linear_list :
  fixes x :: "'a list"
  fixes y :: "'a list"
shows "x \<le> y \<or> y \<le> x"
  by (induct rule: less_eq_list.induct; auto)

instance
  using less_le_not_le_list order_refl_list order_trans_list antisym_list linear_list
  by (intro_classes; metis+)
end

instantiation FSM_ext :: (ord,ord) ord
begin

fun less_eq_FSM_ext ::  "('a,'b) FSM_scheme \<Rightarrow> ('a,'b) FSM_scheme \<Rightarrow> bool" where
  "less_eq_FSM_ext M1 M2 =
    (if initial M1 < initial M2
      then True
      else ((initial M1 = initial M2) \<and> (if inputs M1 < inputs M2
        then True
        else ((inputs M1 = inputs M2) \<and> (if outputs M1 < outputs M2
          then True
          else ((outputs M1 = outputs M2) \<and> (if transitions M1 < transitions M2
            then True
            else ((transitions M1 = transitions M2) \<and> (more M1 \<le> more M2)))))))))"

fun less_FSM_ext ::  "('a,'b) FSM_scheme \<Rightarrow> ('a,'b) FSM_scheme \<Rightarrow> bool" where
  "less_FSM_ext a b = (a \<le> b \<and> a \<noteq> b)"

instance by (intro_classes)
end

instantiation FSM_ext :: (linorder,linorder) linorder
begin

lemma less_le_not_le_FSM :
  fixes x :: "('a,'b) FSM_scheme"
  and   y :: "('a,'b) FSM_scheme"
shows "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
proof
  show "x < y \<Longrightarrow> x \<le> y \<and> \<not> y \<le> x"
    unfolding less_FSM_ext.simps less_eq_FSM_ext.simps
    by (metis dual_order.antisym equality not_less_iff_gr_or_eq)
  show "x \<le> y \<and> \<not> y \<le> x \<Longrightarrow> x < y"
    unfolding less_FSM_ext.simps less_eq_FSM_ext.simps
    by blast
qed

lemma order_refl_FSM :
  fixes x :: "('a,'b) FSM_scheme"
  shows "x \<le> x"
  by auto

lemma order_trans_FSM :
  fixes x :: "('a,'b) FSM_scheme"
  fixes y :: "('a,'b) FSM_scheme"
  fixes z :: "('a,'b) FSM_scheme"
  shows "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
  unfolding less_eq_FSM_ext.simps
  using less_trans[of "initial x" "initial y"]
        less_trans[of "inputs x" "inputs y"]
        less_trans[of "outputs x" "outputs y"]
        less_trans[of "transitions x" "transitions y"]
        less_trans[of "more x" "more y"]
  using order_trans[of "initial x" "initial y"]
        order_trans[of "inputs x" "inputs y"]
        order_trans[of "outputs x" "outputs y"]
        order_trans[of "transitions x" "transitions y"]
        order_trans[of "more x" "more y"]
  by metis

lemma antisym_FSM :
  fixes x :: "('a,'b) FSM_scheme"
  fixes y :: "('a,'b) FSM_scheme"
shows "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
  unfolding less_eq_FSM_ext.simps
  by (metis dual_order.antisym equality not_less_iff_gr_or_eq)

lemma linear_FSM :
  fixes x :: "('a,'b) FSM_scheme"
  fixes y :: "('a,'b) FSM_scheme"
shows "x \<le> y \<or> y \<le> x"
  unfolding less_eq_FSM_ext.simps
  by (metis linear not_less_iff_gr_or_eq)

instance
  using less_le_not_le_FSM order_refl_FSM order_trans_FSM antisym_FSM linear_FSM
  by (intro_classes; metis+)
end

lemma remdups_by_RBT :
  "set (remdups xs) = set (RBT.keys (foldl (\<lambda> prev t . RBT.insert t () prev) RBT.empty xs))"
proof (induction xs rule: rev_induct)
  case Nil
  then show ?case by (simp add: empty_Set set_keys)
next
  case (snoc x xs)
  then show ?case
    using RBT_Set.insert_code(1) set_keys by fastforce
qed

value "calculate_test_suite M_ex_H 4"
value "calculate_test_suite_set M_ex_H 4"
(*

lemma x : "set (fst (calculate_test_suite' M m)) = set (fst (calculate_test_suite_rbt M m))"
  unfolding calculate_test_suite_rbt_def calculate_test_suite'_def
  unfolding Let_def fst_conv
  unfolding set_append set_remdups
  using set_append set_remdups

  unfolding remdups_by_RBT

lemma calculate_test_suite_rbt_calculate_test_suite' :
  assumes "calculate_test_suite' M m = (tl1,pr1)"
  and     "calculate_test_suite_rbt M m = (tl2,pr2)"
shows "set tl1 = set tl2"
and   "pr1 = pr2"
  using assms
  unfolding calculate_test_suite_rbt_def calculate_test_suite'_def
  unfolding Let_def
  using remdups_by_RBT

  *)

(*

fun convert_test_suite_elem :: "(('a::linorder \<times> 'a Traversal_Path \<times> ('a \<times> 'a + 'a,'b) ATC) list \<times> ('a \<times> ('a,'b) Preamble)) \<Rightarrow> ('a \<times> ('a,'b) Preamble) list \<Rightarrow> 'a Transition list avl_tree" where
  "convert_test_suite_elem (q,p,atcs) preambles = empty"

thm foldl.simps

fun convert_test_suite :: "(('a::linorder \<times> 'a Traversal_Path \<times> ('a \<times> 'a + 'a,'b) ATC) list \<times> ('a \<times> ('a,'b) Preamble) list) \<Rightarrow> 'a Transition list avl_tree" where
  "convert_test_suite (elems,preambles) = foldl (\<lambda> prev elem . AVL_Set.union prev prev ) empty elems"

*)

end


(*  Title:      HOL/UNITY/Simple/NSP_Bad.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Original file is ../Auth/NS_Public_Bad
*)

section{*Analyzing the Needham-Schroeder Public-Key Protocol in UNITY*}

theory NSP_Bad imports "../../Auth/Public" "../UNITY_Main" begin

text{*This is the flawed version, vulnerable to Lowe's attack.
From page 260 of
  Burrows, Abadi and Needham.  A Logic of Authentication.
  Proc. Royal Soc. 426 (1989).
*}

type_synonym state = "event list"

  (*The spy MAY say anything he CAN say.  We do not expect him to
    invent new nonces here, but he can also use NS1.  Common to
    all similar protocols.*)
definition
  Fake :: "(state*state) set"
  where "Fake = {(s,s').
              \<exists>B X. s' = Says Spy B X # s
                    & X \<in> synth (analz (spies s))}"

  (*The numeric suffixes on A identify the rule*)

  (*Alice initiates a protocol run, sending a nonce to Bob*)
definition
  NS1 :: "(state*state) set"
  where "NS1 = {(s1,s').
             \<exists>A1 B NA.
                 s' = Says A1 B (Crypt (pubK B) {|Nonce NA, Agent A1|}) # s1
               & Nonce NA \<notin> used s1}"

  (*Bob responds to Alice's message with a further nonce*)
definition
  NS2 :: "(state*state) set"
  where "NS2 = {(s2,s').
             \<exists>A' A2 B NA NB.
                 s' = Says B A2 (Crypt (pubK A2) {|Nonce NA, Nonce NB|}) # s2
               & Says A' B (Crypt (pubK B) {|Nonce NA, Agent A2|}) \<in> set s2
               & Nonce NB \<notin> used s2}"

  (*Alice proves her existence by sending NB back to Bob.*)
definition
  NS3 :: "(state*state) set"
  where "NS3 = {(s3,s').
             \<exists>A3 B' B NA NB.
                 s' = Says A3 B (Crypt (pubK B) (Nonce NB)) # s3
               & Says A3  B (Crypt (pubK B) {|Nonce NA, Agent A3|}) \<in> set s3
               & Says B' A3 (Crypt (pubK A3) {|Nonce NA, Nonce NB|}) \<in> set s3}"

definition Nprg :: "state program" where
    (*Initial trace is empty*)
    "Nprg = mk_total_program({[]}, {Fake, NS1, NS2, NS3}, UNIV)"

declare spies_partsEs [elim]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

text{*For other theories, e.g. Mutex and Lift, using [iff] slows proofs down.
  Here, it facilitates re-use of the Auth proofs.*}

declare Fake_def [THEN def_act_simp, iff]
declare NS1_def [THEN def_act_simp, iff]
declare NS2_def [THEN def_act_simp, iff]
declare NS3_def [THEN def_act_simp, iff]

declare Nprg_def [THEN def_prg_Init, simp]

text{*A "possibility property": there are traces that reach the end.
  Replace by LEADSTO proof!*}
lemma "A \<noteq> B ==>
       \<exists>NB. \<exists>s \<in> reachable Nprg. Says A B (Crypt (pubK B) (Nonce NB)) \<in> set s"
apply (intro exI bexI)
apply (rule_tac [2] act = "totalize_act NS3" in reachable.Acts)
apply (rule_tac [3] act = "totalize_act NS2" in reachable.Acts)
apply (rule_tac [4] act = "totalize_act NS1" in reachable.Acts)
apply (rule_tac [5] reachable.Init)
apply (simp_all (no_asm_simp) add: Nprg_def totalize_act_def)
apply auto
done

subsection{*Inductive Proofs about @{term ns_public}*}

lemma ns_constrainsI:
     "(!!act s s'. [| act \<in> {Id, Fake, NS1, NS2, NS3};
                      (s,s') \<in> act;  s \<in> A |] ==> s' \<in> A')
      ==> Nprg \<in> A co A'"
apply (simp add: Nprg_def mk_total_program_def)
apply (rule constrainsI, auto)
done

text{*This ML code does the inductions directly.*}
ML{*
fun ns_constrains_tac ctxt i =
  SELECT_GOAL
    (EVERY
     [REPEAT (etac @{thm Always_ConstrainsI} 1),
      REPEAT (resolve_tac [@{thm StableI}, @{thm stableI}, @{thm constrains_imp_Constrains}] 1),
      rtac @{thm ns_constrainsI} 1,
      full_simp_tac ctxt 1,
      REPEAT (FIRSTGOAL (etac disjE)),
      ALLGOALS (clarify_tac (ctxt delrules [impI, @{thm impCE}])),
      REPEAT (FIRSTGOAL (analz_mono_contra_tac ctxt)),
      ALLGOALS (asm_simp_tac ctxt)]) i;

(*Tactic for proving secrecy theorems*)
fun ns_induct_tac ctxt =
  (SELECT_GOAL o EVERY)
     [rtac @{thm AlwaysI} 1,
      force_tac ctxt 1,
      (*"reachable" gets in here*)
      rtac (@{thm Always_reachable} RS @{thm Always_ConstrainsI} RS @{thm StableI}) 1,
      ns_constrains_tac ctxt 1];
*}

method_setup ns_induct = {*
    Scan.succeed (SIMPLE_METHOD' o ns_induct_tac) *}
    "for inductive reasoning about the Needham-Schroeder protocol"

text{*Converts invariants into statements about reachable states*}
lemmas Always_Collect_reachableD =
     Always_includes_reachable [THEN subsetD, THEN CollectD]

text{*Spy never sees another agent's private key! (unless it's bad at start)*}
lemma Spy_see_priK:
     "Nprg \<in> Always {s. (Key (priK A) \<in> parts (spies s)) = (A \<in> bad)}"
apply ns_induct
apply blast
done
declare Spy_see_priK [THEN Always_Collect_reachableD, simp]

lemma Spy_analz_priK:
     "Nprg \<in> Always {s. (Key (priK A) \<in> analz (spies s)) = (A \<in> bad)}"
by (rule Always_reachable [THEN Always_weaken], auto)
declare Spy_analz_priK [THEN Always_Collect_reachableD, simp]

subsection{*Authenticity properties obtained from NS2*}

text{*It is impossible to re-use a nonce in both NS1 and NS2 provided the
     nonce is secret.  (Honest users generate fresh nonces.)*}
lemma no_nonce_NS1_NS2:
 "Nprg
  \<in> Always {s. Crypt (pubK C) {|NA', Nonce NA|} \<in> parts (spies s) -->
                Crypt (pubK B) {|Nonce NA, Agent A|} \<in> parts (spies s) -->
                Nonce NA \<in> analz (spies s)}"
apply ns_induct
apply (blast intro: analz_insertI)+
done

text{*Adding it to the claset slows down proofs...*}
lemmas no_nonce_NS1_NS2_reachable =
       no_nonce_NS1_NS2 [THEN Always_Collect_reachableD, rule_format]

text{*Unicity for NS1: nonce NA identifies agents A and B*}
lemma unique_NA_lemma:
     "Nprg
  \<in> Always {s. Nonce NA \<notin> analz (spies s) -->
                Crypt(pubK B) {|Nonce NA, Agent A|} \<in> parts(spies s) -->
                Crypt(pubK B') {|Nonce NA, Agent A'|} \<in> parts(spies s) -->
                A=A' & B=B'}"
apply ns_induct
apply auto
txt{*Fake, NS1 are non-trivial*}
done

text{*Unicity for NS1: nonce NA identifies agents A and B*}
lemma unique_NA:
     "[| Crypt(pubK B)  {|Nonce NA, Agent A|} \<in> parts(spies s);
         Crypt(pubK B') {|Nonce NA, Agent A'|} \<in> parts(spies s);
         Nonce NA \<notin> analz (spies s);
         s \<in> reachable Nprg |]
      ==> A=A' & B=B'"
by (blast dest: unique_NA_lemma [THEN Always_Collect_reachableD])

text{*Secrecy: Spy does not see the nonce sent in msg NS1 if A and B are secure*}
lemma Spy_not_see_NA:
     "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says A B (Crypt(pubK B) {|Nonce NA, Agent A|}) \<in> set s
                  --> Nonce NA \<notin> analz (spies s)}"
apply ns_induct
txt{*NS3*}
prefer 4 apply (blast intro: no_nonce_NS1_NS2_reachable)
txt{*NS2*}
prefer 3 apply (blast dest: unique_NA)
txt{*NS1*}
prefer 2 apply blast
txt{*Fake*}
apply spy_analz
done

text{*Authentication for A: if she receives message 2 and has used NA
  to start a run, then B has sent message 2.*}
lemma A_trusts_NS2:
 "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says A B (Crypt(pubK B) {|Nonce NA, Agent A|}) \<in> set s &
                  Crypt(pubK A) {|Nonce NA, Nonce NB|} \<in> parts (knows Spy s)
         --> Says B A (Crypt(pubK A) {|Nonce NA, Nonce NB|}) \<in> set s}"
  (*insert an invariant for use in some of the subgoals*)
apply (insert Spy_not_see_NA [of A B NA], simp, ns_induct)
apply (auto dest: unique_NA)
done

text{*If the encrypted message appears then it originated with Alice in NS1*}
lemma B_trusts_NS1:
     "Nprg \<in> Always
              {s. Nonce NA \<notin> analz (spies s) -->
                  Crypt (pubK B) {|Nonce NA, Agent A|} \<in> parts (spies s)
         --> Says A B (Crypt (pubK B) {|Nonce NA, Agent A|}) \<in> set s}"
apply ns_induct
apply blast
done

subsection{*Authenticity properties obtained from NS2*}

text{*Unicity for NS2: nonce NB identifies nonce NA and agent A.
   Proof closely follows that of @{text unique_NA}.*}
lemma unique_NB_lemma:
 "Nprg
  \<in> Always {s. Nonce NB \<notin> analz (spies s)  -->
                Crypt (pubK A) {|Nonce NA, Nonce NB|} \<in> parts (spies s) -->
                Crypt(pubK A'){|Nonce NA', Nonce NB|} \<in> parts(spies s) -->
                A=A' & NA=NA'}"
apply ns_induct
apply auto
txt{*Fake, NS2 are non-trivial*}
done

lemma unique_NB:
     "[| Crypt(pubK A) {|Nonce NA, Nonce NB|} \<in> parts(spies s);
         Crypt(pubK A'){|Nonce NA', Nonce NB|} \<in> parts(spies s);
         Nonce NB \<notin> analz (spies s);
         s \<in> reachable Nprg |]
      ==> A=A' & NA=NA'"
apply (blast dest: unique_NB_lemma [THEN Always_Collect_reachableD])
done

text{*NB remains secret PROVIDED Alice never responds with round 3*}
lemma Spy_not_see_NB:
     "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says B A (Crypt (pubK A) {|Nonce NA, Nonce NB|}) \<in> set s &
                  (ALL C. Says A C (Crypt (pubK C) (Nonce NB)) \<notin> set s)
                  --> Nonce NB \<notin> analz (spies s)}"
apply ns_induct
apply (simp_all (no_asm_simp) add: all_conj_distrib)
txt{*NS3: because NB determines A*}
prefer 4 apply (blast dest: unique_NB)
txt{*NS2: by freshness and unicity of NB*}
prefer 3 apply (blast intro: no_nonce_NS1_NS2_reachable)
txt{*NS1: by freshness*}
prefer 2 apply blast
txt{*Fake*}
apply spy_analz
done

text{*Authentication for B: if he receives message 3 and has used NB
  in message 2, then A has sent message 3--to somebody....*}
lemma B_trusts_NS3:
     "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Crypt (pubK B) (Nonce NB) \<in> parts (spies s) &
                  Says B A  (Crypt (pubK A) {|Nonce NA, Nonce NB|}) \<in> set s
                  --> (\<exists>C. Says A C (Crypt (pubK C) (Nonce NB)) \<in> set s)}"
  (*insert an invariant for use in some of the subgoals*)
apply (insert Spy_not_see_NB [of A B NA NB], simp, ns_induct)
apply (simp_all (no_asm_simp) add: ex_disj_distrib)
apply auto
txt{*NS3: because NB determines A. This use of @{text unique_NB} is robust.*}
apply (blast intro: unique_NB [THEN conjunct1])
done

text{*Can we strengthen the secrecy theorem?  NO*}
lemma "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says B A (Crypt (pubK A) {|Nonce NA, Nonce NB|}) \<in> set s
                  --> Nonce NB \<notin> analz (spies s)}"
apply ns_induct
apply auto
txt{*Fake*}
apply spy_analz
txt{*NS2: by freshness and unicity of NB*}
 apply (blast intro: no_nonce_NS1_NS2_reachable)
txt{*NS3: unicity of NB identifies A and NA, but not B*}
apply (frule_tac A'=A in Says_imp_spies [THEN parts.Inj, THEN unique_NB])
apply (erule Says_imp_spies [THEN parts.Inj], auto)
apply (rename_tac s B' C)
txt{*This is the attack!
@{subgoals[display,indent=0,margin=65]}
*}
oops

(*
THIS IS THE ATTACK!
[| A \<notin> bad; B \<notin> bad |]
==> Nprg
   \<in> Always
       {s. Says B A (Crypt (pubK A) {|Nonce NA, Nonce NB|}) \<in> set s -->
           Nonce NB \<notin> analz (knows Spy s)}
 1. !!s B' C.
       [| A \<notin> bad; B \<notin> bad; s \<in> reachable Nprg
          Says A C (Crypt (pubK C) {|Nonce NA, Agent A|}) \<in> set s;
          Says B' A (Crypt (pubK A) {|Nonce NA, Nonce NB|}) \<in> set s;
          C \<in> bad; Says B A (Crypt (pubK A) {|Nonce NA, Nonce NB|}) \<in> set s;
          Nonce NB \<notin> analz (knows Spy s) |]
       ==> False
*)

end