theory nat_alt_mul_comm
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S n) y = S (plus n y)"

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

(*hipster plus altmul *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) . (altmul x y) = (altmul y x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory HS_CAS_Integration
  imports Proof_Automation "CAS_Integration.Subst_ODE"
  keywords "find_local_flow" :: diag
begin

ML \<open>
fun match_term (top, _) = case top of
     Const ("Framed_Dyn_Sys.g_orbital_on", _) => true
   | _ => false

fun find_ode term =
let
open Zipper
val matches = Seq.filter match_term (EqSubst.search_lr_all (mktop term))
val get_ode = (move_up_right #> move_up_right #> move_down_right #> move_down_abs #> trm)
in
  get_ode (Seq.hd matches)
end

(* Legacy function - reconstructs original ODE *)
fun solve_subst_ode_cmd ctx term =
    let
      open Syntax
      val sode = find_ode term
      val tm = Solve_Subst_ODE.solve_subst_ode ctx sode
      val {odes = odes, ...} = Subst_ODE.subst_ode "t" sode
      val frame = foldl1 (fn (x, y) => const @{const_name lens_plus} $ x $ y) (map (Expr_Util.const_or_free ctx) (Symtab.keys odes))
      val lflow = @{term "local_flow_on"} $ sode $ frame $ const @{const_abbrev UNIV} $ const @{const_abbrev UNIV} $ tm
    in
    "Found ODE solution: " ^ Active.sendback_markup_command ("lemma \"" ^ Syntax.string_of_term ctx lflow ^ "\" by local_flow_auto") |> writeln
    end;

fun find_local_flow_cmd state =
    let
      val ctx = Proof.context_of state
      val {goal = g, ...} = Proof.goal state
      val term = Thm.concl_of g
      val sode = find_ode term
      val tm = Solve_Subst_ODE.solve_subst_ode ctx sode
    in
    "try this: " ^ Active.sendback_markup_command
     ("apply (wlp_solve \"" ^ Syntax.string_of_term ctx tm ^ "\")") |> writeln
   end
;

val _ =
  Outer_Syntax.command \<^command_keyword>\<open>find_local_flow\<close>
    "search for solutions to ODEs using a CAS"
    (Scan.option Parse.string >>
      (fn (_) =>
        Toplevel.keep_proof
          (find_local_flow_cmd o Toplevel.proof_of)))
\<close>
end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Time_Methods_Cmd_Test imports
  Lib.Time_Methods_Cmd
  Eisbach_Tools.Eisbach_Methods
  "HOL-Library.Sublist"
begin

text \<open>
  @{method time_methods} is a utility that runs several methods on the same
  proof goal, printing the running time of each one.

  Usage:

    apply (time_methods [(no_check)] [(skip_fail)]
        [name1:] \<open>method1\<close>
        [name2:] \<open>method2\<close>
        ...)

  Options:

    no_check: Don't check that the outputs of each method match.

    skip_fail: Don't print anything for failed methods.
\<close>

experiment begin
  section \<open>Basic examples\<close>

  lemma
    "A \<Longrightarrow> B \<Longrightarrow> A \<or> B"
    apply (time_methods
            \<open>erule disjI1\<close>
            \<open>erule disjI2\<close>)
    done

  text \<open>Give labels to methods:\<close>
  lemma
    "A \<Longrightarrow> B \<Longrightarrow> A \<or> B"
    apply (time_methods
            label: \<open>erule disjI1\<close>
            "another label": \<open>erule disjI2\<close>)
    done

  text \<open>no_check prevents failing even if the method results differ.\<close>
  lemma
    "A \<Longrightarrow> B \<Longrightarrow> A \<or> B"
    apply (time_methods (no_check)
            \<open>rule disjI1\<close>
            \<open>rule disjI2\<close>)
    apply assumption
    done

  text \<open>
    Fast and slow list reversals.
  \<close>
  lemma list_eval_rev_append:
    "rev xs = rev xs @ []"
    "rev [] @ ys = ys"
    "rev (x # xs) @ ys = rev xs @ (x # ys)"
    by auto

  lemma "rev [0..100] = map ((-) 100) [0..100]"
        "rev [0..200] = map ((-) 200) [0..200]"
    text \<open>evaluate everything but @{term rev}\<close>
    apply (all \<open>match conclusion in "rev x = y" for x y \<Rightarrow>
                  \<open>rule subst[where t = x], simp add: upto.simps\<close>\<close>)
    apply (all \<open>match conclusion in "rev x = y" for x y \<Rightarrow>
                  \<open>rule subst[where t = y], simp add: upto.simps\<close>\<close>)

    text \<open>evaluate @{term rev}\<close>
    apply (time_methods
            naive100: \<open>simp\<close>
            slow100: \<open>simp only: rev.simps append.simps\<close>
            fast100: \<open>subst list_eval_rev_append(1), simp only: list_eval_rev_append(2-3)\<close>
          )
    apply (time_methods
            naive200: \<open>simp\<close>
            slow200: \<open>simp only: rev.simps append.simps\<close>
            fast200: \<open>subst list_eval_rev_append(1), simp only: list_eval_rev_append(2-3)\<close>
          )
    done

  text \<open>
    Fast and slow subsequence testing.
  \<close>
  lemma
    "subseq (map ((*) 2) [1 ..  5]) [1 .. 10]"
    "subseq (map ((*) 2) [1 ..  6]) [1 .. 12]"
    "subseq (map ((*) 2) [1 ..  7]) [1 .. 14]"
    "subseq (map ((*) 2) [1 ..  8]) [1 .. 16]"
    apply (all \<open>match conclusion in "subseq x y" for x y \<Rightarrow>
                  \<open>rule subst[where t = x], simp add: upto.simps,
                   rule subst[where t = y], simp add: upto.simps\<close>\<close>)

    apply (time_methods
      "HOL simp": \<open>simp\<close>

      "l4v simp": \<open>simp cong: if_cong cong del: if_weak_cong\<close>
        \<comment> \<open>exponential time!\<close>
      )+
    done

  text \<open>
    Which method is a better SAT solver?
    Instance 01 from the uf20-91 dataset at http://www.cs.ubc.ca/~hoos/SATLIB/benchm.html
  \<close>
  lemma "\<exists>x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20.
          (~x4 & x18 & ~x19) | (~x3 & ~x18 & x5) | (x5 & x8 & x15) | (x20 & ~x7 & x16) |
          (~x10 & x13 & x7) | (x12 & x9 & ~x17) | (~x17 & ~x19 & ~x5) | (x16 & ~x9 & ~x15) |
          (~x11 & x5 & x14) | (~x18 & x10 & ~x13) | (x3 & ~x11 & ~x12) | (x6 & x17 & x8) |
          (x18 & ~x14 & ~x1) | (x19 & x15 & ~x10) | (~x12 & ~x18 & x19) | (x8 & ~x4 & ~x7) |
          (x8 & x9 & ~x4) | (~x7 & ~x17 & x15) | (~x12 & x7 & x14) | (x10 & x11 & ~x8) |
          (~x2 & x15 & x11) | (~x9 & ~x6 & ~x1) | (x11 & ~x20 & x17) | (~x9 & x15 & ~x13) |
          (~x12 & x7 & x17) | (x18 & x2 & ~x20) | (~x20 & ~x12 & ~x4) | (~x19 & ~x11 & ~x14) |
          (x16 & ~x18 & x4) | (x1 & x17 & x19) | (x13 & ~x15 & ~x10) | (x12 & x14 & x13) |
          (~x12 & x14 & x7) | (x7 & ~x16 & ~x10) | (~x6 & ~x10 & ~x7) | (~x20 & ~x14 & x16) |
          (x19 & ~x17 & ~x11) | (x7 & ~x1 & x20) | (x5 & ~x12 & ~x15) | (x4 & x9 & x13) |
          (~x12 & x11 & x7) | (x5 & ~x19 & x8) | (~x1 & ~x16 & ~x17) | (~x20 & x14 & x15) |
          (~x13 & x4 & ~x10) | (~x14 & ~x7 & ~x10) | (x5 & ~x9 & ~x20) | (~x10 & ~x1 & x19) |
          (x16 & x15 & x1) | (~x16 & ~x3 & x11) | (x15 & x10 & ~x4) | (~x4 & x15 & x3) |
          (x10 & x16 & ~x11) | (x8 & ~x12 & x5) | (~x14 & x6 & ~x12) | (~x1 & ~x6 & ~x11) |
          (x13 & x5 & x1) | (x7 & x2 & ~x12) | (~x1 & x20 & ~x19) | (x2 & x13 & x8) |
          (~x15 & ~x18 & ~x4) | (x11 & ~x14 & ~x9) | (x6 & x15 & x2) | (~x5 & x12 & x15) |
          (x6 & ~x17 & ~x5) | (x13 & ~x5 & x19) | (~x20 & x1 & ~x14) | (~x9 & x17 & ~x15) |
          (x5 & ~x19 & x18) | (x12 & ~x8 & x10) | (x18 & ~x14 & x4) | (~x15 & x9 & ~x13) |
          (~x9 & x5 & x1) | (~x10 & x19 & x14) | (~x20 & ~x9 & ~x4) | (x9 & x2 & ~x19) |
          (x5 & ~x13 & x17) | (~x2 & x10 & x18) | (x18 & ~x3 & ~x11) | (~x7 & x9 & ~x17) |
          (x15 & x6 & x3) | (x2 & ~x3 & x13) | (~x12 & ~x3 & x2) | (x2 & x3 & ~x17) |
          (~x20 & x15 & x16) | (x5 & x17 & x19) | (x20 & x18 & ~x11) | (x9 & ~x1 & x5) |
          (x19 & ~x9 & ~x17) | (~x12 & x2 & ~x17)"
    using [[meson_max_clauses=99]]
    apply (time_methods
              blast: \<open>blast\<close>
              metis: \<open>metis\<close>
              meson: \<open>meson\<close>
              smt:   \<open>smt\<close>
              force: \<open>force\<close>
              fastforce: \<open>fastforce intro: ex_bool_eq[THEN iffD2]\<close>
              fastforce: \<open>fastforce simp: ex_bool_eq\<close>
              presburger: \<open>use ex_bool_eq[simp] in presburger\<close>
          )
    done

  section \<open>Other tests\<close>

  text \<open>Test ML interface\<close>
  lemma "True"
    apply (tactic \<open>
            let val method = SIMPLE_METHOD (simp_tac @{context} 1)
                fun dummy_callback _ _ = ()
            in (fn st => Time_Methods.time_methods false false dummy_callback [(NONE, method)] [] st
                      |> (fn ([timing], st') => (tracing (Timing.message timing); st')))
               |> NO_CONTEXT_TACTIC @{context}
            end\<close>)
    done

  text \<open>Check that we fail when the methods give different results\<close>
  lemma
    "A \<or> B"
    apply (tactic \<open>
      let
        fun skip_dummy_state tac = fn st =>
            case Thm.prop_of st of
                Const ("Pure.prop", _) $ (Const ("Pure.term", _) $ Const ("Pure.dummy_pattern", _)) =>
                  Seq.succeed st
              | _ => tac st;
        val methods = @{thms disjI1 disjI2}
              |> map (fn rule => (NONE, SIMPLE_METHOD (resolve_tac @{context} [rule] 1)))
        fun dummy_callback _ _ = ()
      in (fn st => Time_Methods.time_methods false false dummy_callback methods [] st
                   |> (fn (timing, st') => error "test failed: shouldn't reach here")
                   handle THM _ => Seq.succeed (Seq.Result st)) (* should reach here *)
         |> NO_CONTEXT_TACTIC @{context}
         |> skip_dummy_state
      end\<close>)
    oops

  text \<open>Check that we propagate failures from the input methods\<close>
  lemma "A"
    apply (fails \<open>time_methods \<open>simp\<close>\<close>)
    oops

  text \<open>Check that we skip failing methods when skip_fail set\<close>
  lemma "A \<and> B \<Longrightarrow> A"
    apply (
        ( \<comment> \<open>roughly corresponds to "time_methods (skip_fail) \<open>fail\<close>",
              but errors if it calls the output callback\<close>
          tactic \<open>
            let
              fun timing_callback _ _ = error "test failed: shouldn't reach here"
              val methods = [(NONE, SIMPLE_METHOD no_tac)]
            in
              (fn st =>
                #2 (Time_Methods.time_methods false true timing_callback methods [] st))
              |> NO_CONTEXT_TACTIC @{context}
            end\<close>)
      | time_methods (skip_fail) good_simp: \<open>simp\<close>)
    done
end

end


theory CFGExit_wf imports CFGExit CFG_wf begin

subsection \<open>New well-formedness lemmas using \<open>(_Exit_)\<close>\<close>

locale CFGExit_wf =
  CFG_wf sourcenode targetnode kind valid_edge Entry Def Use state_val +
  CFGExit sourcenode targetnode kind valid_edge Entry Exit
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") and Def :: "'node \<Rightarrow> 'var set"
  and Use :: "'node \<Rightarrow> 'var set" and state_val :: "'state \<Rightarrow> 'var \<Rightarrow> 'val"
  and Exit :: "'node" ("'('_Exit'_')") +
  assumes Exit_empty:"Def (_Exit_) = {} \<and> Use (_Exit_) = {}"

begin

lemma Exit_Use_empty [dest!]: "V \<in> Use (_Exit_) \<Longrightarrow> False"
by(simp add:Exit_empty)

lemma Exit_Def_empty [dest!]: "V \<in> Def (_Exit_) \<Longrightarrow> False"
by(simp add:Exit_empty)

end

end


(*  Title:      HOL/Auth/Yahalom.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section\<open>The Yahalom Protocol\<close>

theory Yahalom imports Public begin

text\<open>From page 257 of
  Burrows, Abadi and Needham (1989).  A Logic of Authentication.
  Proc. Royal Soc. 426

This theory has the prototypical example of a secrecy relation, KeyCryptNonce.
\<close>

inductive_set yahalom :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> yahalom"

         (*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.*)
 | Fake: "\<lbrakk>evsf \<in> yahalom;  X \<in> synth (analz (knows Spy evsf))\<rbrakk>
          \<Longrightarrow> Says Spy B X  # evsf \<in> yahalom"

         (*A message that has been sent can be received by the
           intended recipient.*)
 | Reception: "\<lbrakk>evsr \<in> yahalom;  Says A B X \<in> set evsr\<rbrakk>
               \<Longrightarrow> Gets B X # evsr \<in> yahalom"

         (*Alice initiates a protocol run*)
 | YM1:  "\<lbrakk>evs1 \<in> yahalom;  Nonce NA \<notin> used evs1\<rbrakk>
          \<Longrightarrow> Says A B \<lbrace>Agent A, Nonce NA\<rbrace> # evs1 \<in> yahalom"

         (*Bob's response to Alice's message.*)
 | YM2:  "\<lbrakk>evs2 \<in> yahalom;  Nonce NB \<notin> used evs2;
             Gets B \<lbrace>Agent A, Nonce NA\<rbrace> \<in> set evs2\<rbrakk>
          \<Longrightarrow> Says B Server
                  \<lbrace>Agent B, Crypt (shrK B) \<lbrace>Agent A, Nonce NA, Nonce NB\<rbrace>\<rbrace>
                # evs2 \<in> yahalom"

         (*The Server receives Bob's message.  He responds by sending a
            new session key to Alice, with a packet for forwarding to Bob.*)
 | YM3:  "\<lbrakk>evs3 \<in> yahalom;  Key KAB \<notin> used evs3;  KAB \<in> symKeys;
             Gets Server
                  \<lbrace>Agent B, Crypt (shrK B) \<lbrace>Agent A, Nonce NA, Nonce NB\<rbrace>\<rbrace>
               \<in> set evs3\<rbrakk>
          \<Longrightarrow> Says Server A
                   \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key KAB, Nonce NA, Nonce NB\<rbrace>,
                     Crypt (shrK B) \<lbrace>Agent A, Key KAB\<rbrace>\<rbrace>
                # evs3 \<in> yahalom"

 | YM4:
       \<comment> \<open>Alice receives the Server's (?) message, checks her Nonce, and
           uses the new session key to send Bob his Nonce.  The premise
           \<^term>\<open>A \<noteq> Server\<close> is needed for \<open>Says_Server_not_range\<close>.
           Alice can check that K is symmetric by its length.\<close>
         "\<lbrakk>evs4 \<in> yahalom;  A \<noteq> Server;  K \<in> symKeys;
             Gets A \<lbrace>Crypt(shrK A) \<lbrace>Agent B, Key K, Nonce NA, Nonce NB\<rbrace>, X\<rbrace>
                \<in> set evs4;
             Says A B \<lbrace>Agent A, Nonce NA\<rbrace> \<in> set evs4\<rbrakk>
          \<Longrightarrow> Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> # evs4 \<in> yahalom"

         (*This message models possible leaks of session keys.  The Nonces
           identify the protocol run.  Quoting Server here ensures they are
           correct.*)
 | Oops: "\<lbrakk>evso \<in> yahalom;
             Says Server A \<lbrace>Crypt (shrK A)
                                   \<lbrace>Agent B, Key K, Nonce NA, Nonce NB\<rbrace>,
                             X\<rbrace>  \<in> set evso\<rbrakk>
          \<Longrightarrow> Notes Spy \<lbrace>Nonce NA, Nonce NB, Key K\<rbrace> # evso \<in> yahalom"

definition KeyWithNonce :: "[key, nat, event list] \<Rightarrow> bool" where
  "KeyWithNonce K NB evs ==
     \<exists>A B na X.
       Says Server A \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, Nonce NB\<rbrace>, X\<rbrace>
         \<in> set evs"

declare Says_imp_analz_Spy [dest]
declare parts.Body  [dest]
declare Fake_parts_insert_in_Un  [dest]
declare analz_into_parts [dest]

text\<open>A "possibility property": there are traces that reach the end\<close>
lemma "\<lbrakk>A \<noteq> Server; K \<in> symKeys; Key K \<notin> used []\<rbrakk>
      \<Longrightarrow> \<exists>X NB. \<exists>evs \<in> yahalom.
             Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] yahalom.Nil
                    [THEN yahalom.YM1, THEN yahalom.Reception,
                     THEN yahalom.YM2, THEN yahalom.Reception,
                     THEN yahalom.YM3, THEN yahalom.Reception,
                     THEN yahalom.YM4])
apply (possibility, simp add: used_Cons)
done

subsection\<open>Regularity Lemmas for Yahalom\<close>

lemma Gets_imp_Says:
     "\<lbrakk>Gets B X \<in> set evs; evs \<in> yahalom\<rbrakk> \<Longrightarrow> \<exists>A. Says A B X \<in> set evs"
by (erule rev_mp, erule yahalom.induct, auto)

text\<open>Must be proved separately for each protocol\<close>
lemma Gets_imp_knows_Spy:
     "\<lbrakk>Gets B X \<in> set evs; evs \<in> yahalom\<rbrakk>  \<Longrightarrow> X \<in> knows Spy evs"
by (blast dest!: Gets_imp_Says Says_imp_knows_Spy)

lemmas Gets_imp_analz_Spy = Gets_imp_knows_Spy [THEN analz.Inj]
declare Gets_imp_analz_Spy [dest]

text\<open>Lets us treat YM4 using a similar argument as for the Fake case.\<close>
lemma YM4_analz_knows_Spy:
     "\<lbrakk>Gets A \<lbrace>Crypt (shrK A) Y, X\<rbrace> \<in> set evs;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> X \<in> analz (knows Spy evs)"
by blast

lemmas YM4_parts_knows_Spy =
       YM4_analz_knows_Spy [THEN analz_into_parts]

text\<open>For Oops\<close>
lemma YM4_Key_parts_knows_Spy:
     "Says Server A \<lbrace>Crypt (shrK A) \<lbrace>B,K,NA,NB\<rbrace>, X\<rbrace> \<in> set evs
      \<Longrightarrow> K \<in> parts (knows Spy evs)"
  by (metis parts.Body parts.Fst parts.Snd  Says_imp_knows_Spy parts.Inj)

text\<open>Theorems of the form \<^term>\<open>X \<notin> parts (knows Spy evs)\<close> imply
that NOBODY sends messages containing X!\<close>

text\<open>Spy never sees a good agent's shared key!\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> yahalom \<Longrightarrow> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule yahalom.induct, force,
    drule_tac [6] YM4_parts_knows_Spy, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
     "evs \<in> yahalom \<Longrightarrow> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "\<lbrakk>Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> yahalom\<rbrakk> \<Longrightarrow> A \<in> bad"
by (blast dest: Spy_see_shrK)

text\<open>Nobody can have used non-existent keys!
    Needed to apply \<open>analz_insert_Key\<close>\<close>
lemma new_keys_not_used [simp]:
    "\<lbrakk>Key K \<notin> used evs; K \<in> symKeys; evs \<in> yahalom\<rbrakk>
     \<Longrightarrow> K \<notin> keysFor (parts (spies evs))"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt\<open>Fake\<close>
apply (force dest!: keysFor_parts_insert, auto)
done

text\<open>Earlier, all protocol proofs declared this theorem.
  But only a few proofs need it, e.g. Yahalom and Kerberos IV.\<close>
lemma new_keys_not_analzd:
 "\<lbrakk>K \<in> symKeys; evs \<in> yahalom; Key K \<notin> used evs\<rbrakk>
  \<Longrightarrow> K \<notin> keysFor (analz (knows Spy evs))"
by (blast dest: new_keys_not_used intro: keysFor_mono [THEN subsetD])

text\<open>Describes the form of K when the Server sends this message.  Useful for
  Oops as well as main secrecy property.\<close>
lemma Says_Server_not_range [simp]:
     "\<lbrakk>Says Server A \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace>, X\<rbrace>
           \<in> set evs;   evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> K \<notin> range shrK"
by (erule rev_mp, erule yahalom.induct, simp_all)

subsection\<open>Secrecy Theorems\<close>

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) \<Longrightarrow>
  Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.
****)

text\<open>Session keys are not used to encrypt other session keys\<close>

lemma analz_image_freshK [rule_format]:
 "evs \<in> yahalom \<Longrightarrow>
   \<forall>K KK. KK \<subseteq> - (range shrK) \<longrightarrow>
          (Key K \<in> analz (Key`KK \<union> (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule yahalom.induct,
       drule_tac [7] YM4_analz_knows_Spy, analz_freshK, spy_analz, blast)
apply (simp only: Says_Server_not_range analz_image_freshK_simps)
apply safe
done

lemma analz_insert_freshK:
     "\<lbrakk>evs \<in> yahalom;  KAB \<notin> range shrK\<rbrakk> \<Longrightarrow>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text\<open>The Key K uniquely identifies the Server's  message.\<close>
lemma unique_session_keys:
     "\<lbrakk>Says Server A
          \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace>, X\<rbrace> \<in> set evs;
        Says Server A'
          \<lbrace>Crypt (shrK A') \<lbrace>Agent B', Key K, na', nb'\<rbrace>, X'\<rbrace> \<in> set evs;
        evs \<in> yahalom\<rbrakk>
     \<Longrightarrow> A=A' \<and> B=B' \<and> na=na' \<and> nb=nb'"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, simp_all)
txt\<open>YM3, by freshness, and YM4\<close>
apply blast+
done

text\<open>Crucial secrecy property: Spy does not see the keys sent in msg YM3\<close>
lemma secrecy_lemma:
     "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Says Server A
            \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace>,
              Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
           \<in> set evs \<longrightarrow>
          Notes Spy \<lbrace>na, nb, Key K\<rbrace> \<notin> set evs \<longrightarrow>
          Key K \<notin> analz (knows Spy evs)"
apply (erule yahalom.induct, force,
       drule_tac [6] YM4_analz_knows_Spy)
apply (simp_all add: pushes analz_insert_eq analz_insert_freshK)
  subgoal \<comment> \<open>Fake\<close> by spy_analz
  subgoal \<comment> \<open>YM3\<close> by blast
  subgoal \<comment> \<open>Oops\<close> by  (blast dest: unique_session_keys)
done

text\<open>Final version\<close>
lemma Spy_not_see_encrypted_key:
     "\<lbrakk>Says Server A
            \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace>,
              Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
           \<in> set evs;
         Notes Spy \<lbrace>na, nb, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest: secrecy_lemma)

subsubsection\<open>Security Guarantee for A upon receiving YM3\<close>

text\<open>If the encrypted message appears then it originated with the Server\<close>
lemma A_trusts_YM3:
     "\<lbrakk>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace> \<in> parts (knows Spy evs);
         A \<notin> bad;  evs \<in> yahalom\<rbrakk>
       \<Longrightarrow> Says Server A
            \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace>,
              Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
           \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt\<open>Fake, YM3\<close>
apply blast+
done

text\<open>The obvious combination of \<open>A_trusts_YM3\<close> with
  \<open>Spy_not_see_encrypted_key\<close>\<close>
lemma A_gets_good_key:
     "\<lbrakk>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace> \<in> parts (knows Spy evs);
         Notes Spy \<lbrace>na, nb, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
  by (metis A_trusts_YM3 secrecy_lemma)

subsubsection\<open>Security Guarantees for B upon receiving YM4\<close>

text\<open>B knows, by the first part of A's message, that the Server distributed
  the key for A and B.  But this part says nothing about nonces.\<close>
lemma B_trusts_YM4_shrK:
     "\<lbrakk>Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace> \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> \<exists>NA NB. Says Server A
                      \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K,
                                         Nonce NA, Nonce NB\<rbrace>,
                        Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
                     \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt\<open>Fake, YM3\<close>
apply blast+
done

text\<open>B knows, by the second part of A's message, that the Server
  distributed the key quoting nonce NB.  This part says nothing about
  agent names.  Secrecy of NB is crucial.  Note that \<^term>\<open>Nonce NB
  \<notin> analz(knows Spy evs)\<close> must be the FIRST antecedent of the
  induction formula.\<close>

lemma B_trusts_YM4_newK [rule_format]:
     "\<lbrakk>Crypt K (Nonce NB) \<in> parts (knows Spy evs);
        Nonce NB \<notin> analz (knows Spy evs);  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> \<exists>A B NA. Says Server A
                      \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, Nonce NA, Nonce NB\<rbrace>,
                        Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
                     \<in> set evs"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
         apply (analz_mono_contra, simp_all)
  subgoal \<comment> \<open>Fake\<close> by blast
  subgoal \<comment> \<open>YM3\<close> by blast
txt\<open>YM4.  A is uncompromised because NB is secure
  A's certificate guarantees the existence of the Server message\<close>
apply (blast dest!: Gets_imp_Says Crypt_Spy_analz_bad
             dest: Says_imp_spies
                   parts.Inj [THEN parts.Fst, THEN A_trusts_YM3])
done

subsubsection\<open>Towards proving secrecy of Nonce NB\<close>

text\<open>Lemmas about the predicate KeyWithNonce\<close>

lemma KeyWithNonceI:
 "Says Server A
          \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, Nonce NB\<rbrace>, X\<rbrace>
        \<in> set evs \<Longrightarrow> KeyWithNonce K NB evs"
  unfolding KeyWithNonce_def by blast

lemma KeyWithNonce_Says [simp]:
   "KeyWithNonce K NB (Says S A X # evs) =
      (Server = S \<and>
       (\<exists>B n X'. X = \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, n, Nonce NB\<rbrace>, X'\<rbrace>)
      | KeyWithNonce K NB evs)"
by (simp add: KeyWithNonce_def, blast)

lemma KeyWithNonce_Notes [simp]:
   "KeyWithNonce K NB (Notes A X # evs) = KeyWithNonce K NB evs"
by (simp add: KeyWithNonce_def)

lemma KeyWithNonce_Gets [simp]:
   "KeyWithNonce K NB (Gets A X # evs) = KeyWithNonce K NB evs"
by (simp add: KeyWithNonce_def)

text\<open>A fresh key cannot be associated with any nonce
  (with respect to a given trace).\<close>
lemma fresh_not_KeyWithNonce:
     "Key K \<notin> used evs \<Longrightarrow> \<not> KeyWithNonce K NB evs"
  unfolding KeyWithNonce_def by blast

text\<open>The Server message associates K with NB' and therefore not with any
  other nonce NB.\<close>
lemma Says_Server_KeyWithNonce:
 "\<lbrakk>Says Server A \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, Nonce NB'\<rbrace>, X\<rbrace>
       \<in> set evs;
     NB \<noteq> NB';  evs \<in> yahalom\<rbrakk>
  \<Longrightarrow> \<not> KeyWithNonce K NB evs"
  unfolding KeyWithNonce_def by (blast dest: unique_session_keys)

text\<open>The only nonces that can be found with the help of session keys are
  those distributed as nonce NB by the Server.  The form of the theorem
  recalls \<open>analz_image_freshK\<close>, but it is much more complicated.\<close>

text\<open>As with \<open>analz_image_freshK\<close>, we take some pains to express the
  property as a logical equivalence so that the simplifier can apply it.\<close>
lemma Nonce_secrecy_lemma:
     "P \<longrightarrow> (X \<in> analz (G \<union> H)) \<longrightarrow> (X \<in> analz H)  \<Longrightarrow>
      P \<longrightarrow> (X \<in> analz (G \<union> H)) = (X \<in> analz H)"
by (blast intro: analz_mono [THEN subsetD])

lemma Nonce_secrecy:
     "evs \<in> yahalom \<Longrightarrow>
      (\<forall>KK. KK \<subseteq> - (range shrK) \<longrightarrow>
           (\<forall>K \<in> KK. K \<in> symKeys \<longrightarrow> \<not> KeyWithNonce K NB evs)   \<longrightarrow>
           (Nonce NB \<in> analz (Key`KK \<union> (knows Spy evs))) =
           (Nonce NB \<in> analz (knows Spy evs)))"
apply (erule yahalom.induct,
       frule_tac [7] YM4_analz_knows_Spy)
apply (safe del: allI impI intro!: Nonce_secrecy_lemma [THEN impI, THEN allI])
apply (simp_all del: image_insert image_Un
       add: analz_image_freshK_simps split_ifs
            all_conj_distrib ball_conj_distrib
            analz_image_freshK fresh_not_KeyWithNonce
            imp_disj_not1               (*Moves NBa\<noteq>NB to the front*)
            Says_Server_KeyWithNonce)
txt\<open>For Oops, simplification proves \<^prop>\<open>NBa\<noteq>NB\<close>.  By
  \<^term>\<open>Says_Server_KeyWithNonce\<close>, we get \<^prop>\<open>\<not> KeyWithNonce K NB
  evs\<close>; then simplification can apply the induction hypothesis with
  \<^term>\<open>KK = {K}\<close>.\<close>
  subgoal \<comment> \<open>Fake\<close> by spy_analz
  subgoal \<comment> \<open>YM2\<close> by blast
  subgoal \<comment> \<open>YM3\<close> by blast
  subgoal \<comment> \<open>YM4: If \<^prop>\<open>A \<in> bad\<close> then \<^term>\<open>NBa\<close> is known, therefore \<^prop>\<open>NBa \<noteq> NB\<close>.\<close>
    by (metis A_trusts_YM3 Gets_imp_analz_Spy Gets_imp_knows_Spy KeyWithNonce_def
        Spy_analz_shrK analz.Fst analz.Snd analz_shrK_Decrypt parts.Fst parts.Inj)
done

text\<open>Version required below: if NB can be decrypted using a session key then
   it was distributed with that key.  The more general form above is required
   for the induction to carry through.\<close>
lemma single_Nonce_secrecy:
     "\<lbrakk>Says Server A
          \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key KAB, na, Nonce NB'\<rbrace>, X\<rbrace>
         \<in> set evs;
         NB \<noteq> NB';  KAB \<notin> range shrK;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> (Nonce NB \<in> analz (insert (Key KAB) (knows Spy evs))) =
          (Nonce NB \<in> analz (knows Spy evs))"
by (simp_all del: image_insert image_Un imp_disjL
             add: analz_image_freshK_simps split_ifs
                  Nonce_secrecy Says_Server_KeyWithNonce)

subsubsection\<open>The Nonce NB uniquely identifies B's message.\<close>

lemma unique_NB:
     "\<lbrakk>Crypt (shrK B) \<lbrace>Agent A, Nonce NA, nb\<rbrace> \<in> parts (knows Spy evs);
         Crypt (shrK B') \<lbrace>Agent A', Nonce NA', nb\<rbrace> \<in> parts (knows Spy evs);
        evs \<in> yahalom;  B \<notin> bad;  B' \<notin> bad\<rbrakk>
      \<Longrightarrow> NA' = NA \<and> A' = A \<and> B' = B"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt\<open>Fake, and YM2 by freshness\<close>
apply blast+
done

text\<open>Variant useful for proving secrecy of NB.  Because nb is assumed to be
  secret, we no longer must assume B, B' not bad.\<close>
lemma Says_unique_NB:
     "\<lbrakk>Says C S   \<lbrace>X,  Crypt (shrK B) \<lbrace>Agent A, Nonce NA, nb\<rbrace>\<rbrace>
           \<in> set evs;
         Gets S' \<lbrace>X', Crypt (shrK B') \<lbrace>Agent A', Nonce NA', nb\<rbrace>\<rbrace>
           \<in> set evs;
         nb \<notin> analz (knows Spy evs);  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> NA' = NA \<and> A' = A \<and> B' = B"
by (blast dest!: Gets_imp_Says Crypt_Spy_analz_bad
          dest: Says_imp_spies unique_NB parts.Inj analz.Inj)

subsubsection\<open>A nonce value is never used both as NA and as NB\<close>

lemma no_nonce_YM1_YM2:
     "\<lbrakk>Crypt (shrK B') \<lbrace>Agent A', Nonce NB, nb'\<rbrace> \<in> parts(knows Spy evs);
        Nonce NB \<notin> analz (knows Spy evs);  evs \<in> yahalom\<rbrakk>
  \<Longrightarrow> Crypt (shrK B)  \<lbrace>Agent A, na, Nonce NB\<rbrace> \<notin> parts(knows Spy evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
apply (analz_mono_contra, simp_all)
txt\<open>Fake, YM2\<close>
apply blast+
done

text\<open>The Server sends YM3 only in response to YM2.\<close>
lemma Says_Server_imp_YM2:
     "\<lbrakk>Says Server A \<lbrace>Crypt (shrK A) \<lbrace>Agent B, k, na, nb\<rbrace>, X\<rbrace> \<in> set evs;
         evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Gets Server \<lbrace>Agent B, Crypt (shrK B) \<lbrace>Agent A, na, nb\<rbrace>\<rbrace>
             \<in> set evs"
by (erule rev_mp, erule yahalom.induct, auto)

text\<open>A vital theorem for B, that nonce NB remains secure from the Spy.\<close>
theorem Spy_not_see_NB :
     "\<lbrakk>Says B Server
                \<lbrace>Agent B, Crypt (shrK B) \<lbrace>Agent A, Nonce NA, Nonce NB\<rbrace>\<rbrace>
           \<in> set evs;
         (\<forall>k. Notes Spy \<lbrace>Nonce NA, Nonce NB, k\<rbrace> \<notin> set evs);
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Nonce NB \<notin> analz (knows Spy evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_analz_knows_Spy)
apply (simp_all add: split_ifs pushes new_keys_not_analzd analz_insert_eq
                     analz_insert_freshK)
  subgoal \<comment> \<open>Fake\<close> by spy_analz
  subgoal \<comment> \<open>YM1: NB=NA is impossible anyway, but NA is secret because it is fresh!\<close> by blast
  subgoal \<comment> \<open>YM2\<close> by blast
  subgoal \<comment> \<open>YM3: because no NB can also be an NA\<close>
    by (blast dest!: no_nonce_YM1_YM2 dest: Gets_imp_Says Says_unique_NB)
  subgoal \<comment> \<open>YM4: key K is visible to Spy, contradicting session key secrecy theorem\<close>
    \<comment> \<open>Case analysis on whether Aa is bad;
            use \<open>Says_unique_NB\<close> to identify message components: \<^term>\<open>Aa=A\<close>, \<^term>\<open>Ba=B\<close>\<close>
    apply clarify
    apply (blast dest!: Says_unique_NB analz_shrK_Decrypt
                        parts.Inj [THEN parts.Fst, THEN A_trusts_YM3]
                 dest: Gets_imp_Says Says_imp_spies Says_Server_imp_YM2
                       Spy_not_see_encrypted_key)
    done
  subgoal \<comment> \<open>Oops case: if the nonce is betrayed now, show that the Oops event is
    covered by the quantified Oops assumption.\<close>
    apply clarsimp
    apply (metis Says_Server_imp_YM2 Gets_imp_Says Says_Server_not_range Says_unique_NB no_nonce_YM1_YM2 parts.Snd single_Nonce_secrecy spies_partsEs(1))
    done
done

text\<open>B's session key guarantee from YM4.  The two certificates contribute to a
  single conclusion about the Server's message.  Note that the "Notes Spy"
  assumption must quantify over \<open>\<forall>\<close> POSSIBLE keys instead of our particular K.
  If this run is broken and the spy substitutes a certificate containing an
  old key, B has no means of telling.\<close>
lemma B_trusts_YM4:
     "\<lbrakk>Gets B \<lbrace>Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>,
                  Crypt K (Nonce NB)\<rbrace> \<in> set evs;
         Says B Server
           \<lbrace>Agent B, Crypt (shrK B) \<lbrace>Agent A, Nonce NA, Nonce NB\<rbrace>\<rbrace>
           \<in> set evs;
         \<forall>k. Notes Spy \<lbrace>Nonce NA, Nonce NB, k\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
       \<Longrightarrow> Says Server A
                   \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K,
                             Nonce NA, Nonce NB\<rbrace>,
                     Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
             \<in> set evs"
by (blast dest: Spy_not_see_NB Says_unique_NB
                Says_Server_imp_YM2 B_trusts_YM4_newK)

text\<open>The obvious combination of \<open>B_trusts_YM4\<close> with
  \<open>Spy_not_see_encrypted_key\<close>\<close>
lemma B_gets_good_key:
     "\<lbrakk>Gets B \<lbrace>Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>,
                  Crypt K (Nonce NB)\<rbrace> \<in> set evs;
         Says B Server
           \<lbrace>Agent B, Crypt (shrK B) \<lbrace>Agent A, Nonce NA, Nonce NB\<rbrace>\<rbrace>
           \<in> set evs;
         \<forall>k. Notes Spy \<lbrace>Nonce NA, Nonce NB, k\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
  by (metis B_trusts_YM4 Spy_not_see_encrypted_key)

subsection\<open>Authenticating B to A\<close>

text\<open>The encryption in message YM2 tells us it cannot be faked.\<close>
lemma B_Said_YM2 [rule_format]:
     "\<lbrakk>Crypt (shrK B) \<lbrace>Agent A, Nonce NA, nb\<rbrace> \<in> parts (knows Spy evs);
        evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> B \<notin> bad \<longrightarrow>
          Says B Server \<lbrace>Agent B, Crypt (shrK B) \<lbrace>Agent A, Nonce NA, nb\<rbrace>\<rbrace>
            \<in> set evs"
apply (erule rev_mp, erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt\<open>Fake\<close>
apply blast
done

text\<open>If the server sends YM3 then B sent YM2\<close>
lemma YM3_auth_B_to_A_lemma:
     "\<lbrakk>Says Server A \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, Nonce NA, nb\<rbrace>, X\<rbrace>
       \<in> set evs;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> B \<notin> bad \<longrightarrow>
          Says B Server \<lbrace>Agent B, Crypt (shrK B) \<lbrace>Agent A, Nonce NA, nb\<rbrace>\<rbrace>
            \<in> set evs"
apply (erule rev_mp, erule yahalom.induct, simp_all)
txt\<open>YM3, YM4\<close>
apply (blast dest!: B_Said_YM2)+
done

text\<open>If A receives YM3 then B has used nonce NA (and therefore is alive)\<close>
theorem YM3_auth_B_to_A:
     "\<lbrakk>Gets A \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, Nonce NA, nb\<rbrace>, X\<rbrace>
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> Says B Server \<lbrace>Agent B, Crypt (shrK B) \<lbrace>Agent A, Nonce NA, nb\<rbrace>\<rbrace>
       \<in> set evs"
  by (metis A_trusts_YM3 Gets_imp_analz_Spy YM3_auth_B_to_A_lemma analz.Fst
         not_parts_not_analz)

subsection\<open>Authenticating A to B using the certificate
  \<^term>\<open>Crypt K (Nonce NB)\<close>\<close>

text\<open>Assuming the session key is secure, if both certificates are present then
  A has said NB.  We can't be sure about the rest of A's message, but only
  NB matters for freshness.\<close>
theorem A_Said_YM3_lemma [rule_format]:
     "evs \<in> yahalom
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs) \<longrightarrow>
          Crypt K (Nonce NB) \<in> parts (knows Spy evs) \<longrightarrow>
          Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace> \<in> parts (knows Spy evs) \<longrightarrow>
          B \<notin> bad \<longrightarrow>
          (\<exists>X. Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> \<in> set evs)"
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
apply (analz_mono_contra, simp_all)
  subgoal \<comment> \<open>Fake\<close> by blast
  subgoal \<comment> \<open>YM3 because the message \<^term>\<open>Crypt K (Nonce NB)\<close> could not exist\<close>
     by (force dest!: Crypt_imp_keysFor)
   subgoal \<comment> \<open>YM4: was \<^term>\<open>Crypt K (Nonce NB)\<close> the very last message? If not, use the induction hypothesis,
               otherwise by unicity of session keys\<close>
     by (blast dest!: Gets_imp_Says A_trusts_YM3 B_trusts_YM4_shrK Crypt_Spy_analz_bad
             dest: Says_imp_knows_Spy [THEN parts.Inj] unique_session_keys)
done

text\<open>If B receives YM4 then A has used nonce NB (and therefore is alive).
  Moreover, A associates K with NB (thus is talking about the same run).
  Other premises guarantee secrecy of K.\<close>
theorem YM4_imp_A_Said_YM3 [rule_format]:
     "\<lbrakk>Gets B \<lbrace>Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>,
                  Crypt K (Nonce NB)\<rbrace> \<in> set evs;
         Says B Server
           \<lbrace>Agent B, Crypt (shrK B) \<lbrace>Agent A, Nonce NA, Nonce NB\<rbrace>\<rbrace>
           \<in> set evs;
         (\<forall>NA k. Notes Spy \<lbrace>Nonce NA, Nonce NB, k\<rbrace> \<notin> set evs);
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom\<rbrakk>
      \<Longrightarrow> \<exists>X. Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> \<in> set evs"
by (metis A_Said_YM3_lemma B_gets_good_key Gets_imp_analz_Spy YM4_parts_knows_Spy analz.Fst not_parts_not_analz)

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>\<open>Set\<close> as a semicategory\<close>
theory CZH_SMC_Set
  imports
    CZH_DG_Set
    CZH_SMC_Par
    CZH_SMC_Subsemicategory
begin

subsection\<open>Background\<close>

text\<open>
The methodology chosen for the exposition
of \<open>Set\<close> as a semicategory is analogous to the
one used in the previous chapter for the exposition
of \<open>Set\<close> as a digraph.
\<close>

named_theorems smc_Set_cs_simps
named_theorems smc_Set_cs_intros

lemmas (in arr_Set) [smc_Set_cs_simps] =
  dg_Rel_shared_cs_simps

lemmas (in arr_Set) [smc_cs_intros, smc_Set_cs_intros] =
  arr_Set_axioms'

lemmas [smc_Set_cs_simps] =
  dg_Rel_shared_cs_simps
  arr_Set.arr_Set_ArrVal_vdomain
  arr_Set_comp_Set_id_Set_left
  arr_Set_comp_Set_id_Set_right

lemmas [smc_Set_cs_intros] =
  dg_Rel_shared_cs_intros
  arr_Set_comp_Set

subsection\<open>\<open>Set\<close> as a semicategory\<close>

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

definition smc_Set :: "V \<Rightarrow> V"
  where "smc_Set \<alpha> =
    [
      Vset \<alpha>,
      set {T. arr_Set \<alpha> T},
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Set \<alpha> T}. T\<lparr>ArrDom\<rparr>),
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Set \<alpha> T}. T\<lparr>ArrCod\<rparr>),
      (\<lambda>ST\<in>\<^sub>\<circ>composable_arrs (dg_Set \<alpha>). ST\<lparr>0\<rparr> \<circ>\<^sub>R\<^sub>e\<^sub>l ST\<lparr>1\<^sub>\<nat>\<rparr>)
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma smc_Set_components:
  shows "smc_Set \<alpha>\<lparr>Obj\<rparr> = Vset \<alpha>"
    and "smc_Set \<alpha>\<lparr>Arr\<rparr> = set {T. arr_Set \<alpha> T}"
    and "smc_Set \<alpha>\<lparr>Dom\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Set \<alpha> T}. T\<lparr>ArrDom\<rparr>)"
    and "smc_Set \<alpha>\<lparr>Cod\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Set \<alpha> T}. T\<lparr>ArrCod\<rparr>)"
    and "smc_Set \<alpha>\<lparr>Comp\<rparr> = (\<lambda>ST\<in>\<^sub>\<circ>composable_arrs (dg_Set \<alpha>). ST\<lparr>0\<rparr> \<circ>\<^sub>R\<^sub>e\<^sub>l ST\<lparr>1\<^sub>\<nat>\<rparr>)"
  unfolding smc_Set_def dg_field_simps by (simp_all add: nat_omega_simps)

text\<open>Slicing.\<close>

lemma smc_dg_smc_Set: "smc_dg (smc_Set \<alpha>) = dg_Set \<alpha>"
proof(rule vsv_eqI)
  have dom_lhs: "\<D>\<^sub>\<circ> (smc_dg (smc_Set \<alpha>)) = 4\<^sub>\<nat>"
    unfolding smc_dg_def by (simp add: nat_omega_simps)
  have dom_rhs: "\<D>\<^sub>\<circ> (dg_Set \<alpha>) = 4\<^sub>\<nat>"
    unfolding dg_Set_def by (simp add: nat_omega_simps)
  show "\<D>\<^sub>\<circ> (smc_dg (smc_Set \<alpha>)) = \<D>\<^sub>\<circ> (dg_Set \<alpha>)"
    unfolding dom_lhs dom_rhs by simp
  show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_dg (smc_Set \<alpha>)) \<Longrightarrow> smc_dg (smc_Set \<alpha>)\<lparr>a\<rparr> = dg_Set \<alpha>\<lparr>a\<rparr>"
    for a
    by
      (
        unfold dom_lhs,
        elim_in_numeral,
        unfold smc_dg_def dg_field_simps smc_Set_def dg_Set_def
      )
      (auto simp: nat_omega_simps)
qed (auto simp: smc_dg_def dg_Set_def)

lemmas_with [folded smc_dg_smc_Set, unfolded slicing_simps]:
  smc_Set_Obj_iff = dg_Set_Obj_iff
  and smc_Set_Arr_iff[smc_Set_cs_simps] = dg_Set_Arr_iff
  and smc_Set_Dom_vsv[smc_Set_cs_intros] = dg_Set_Dom_vsv
  and smc_Set_Dom_vdomain[smc_Set_cs_simps] = dg_Set_Dom_vdomain
  and smc_Set_Dom_vrange = dg_Set_Dom_vrange
  and smc_Set_Dom_app[smc_Set_cs_simps] = dg_Set_Dom_app
  and smc_Set_Cod_vsv[smc_Set_cs_intros] = dg_Set_Cod_vsv
  and smc_Set_Cod_vdomain[smc_Set_cs_simps] = dg_Set_Cod_vdomain
  and smc_Set_Cod_vrange = dg_Set_Cod_vrange
  and smc_Set_Cod_app[smc_Set_cs_simps] = dg_Set_Cod_app
  and smc_Set_is_arrI = dg_Set_is_arrI
  and smc_Set_is_arrD = dg_Set_is_arrD
  and smc_Set_is_arrE = dg_Set_is_arrE
  and smc_Set_ArrVal_vdomain[smc_Set_cs_simps] = dg_Set_ArrVal_vdomain
  and smc_Set_ArrVal_app_vrange[smc_Set_cs_intros] = dg_Set_ArrVal_app_vrange

lemmas [smc_cs_simps] = smc_Set_is_arrD(2,3)

lemmas_with (in \<Z>) [folded smc_dg_smc_Set, unfolded slicing_simps]:
  smc_Set_Hom_vifunion_in_Vset = dg_Set_Hom_vifunion_in_Vset
  and smc_Set_incl_Set_is_arr = dg_Set_incl_Set_is_arr

lemmas [smc_Set_cs_intros] =
  smc_Set_is_arrI

lemma (in \<Z>) smc_Set_incl_Set_is_arr'[smc_cs_intros, smc_Set_cs_intros]:
  assumes "A \<in>\<^sub>\<circ> smc_Set \<alpha>\<lparr>Obj\<rparr>"
    and "B \<in>\<^sub>\<circ> smc_Set \<alpha>\<lparr>Obj\<rparr>"
    and "A \<subseteq>\<^sub>\<circ> B"
    and "A' = A"
    and "B' = B"
    and "\<CC>' = smc_Set \<alpha>"
  shows "incl_Set A B : A' \<mapsto>\<^bsub>\<CC>'\<^esub> B'"
  using assms(1-3) unfolding assms(4-6) by (rule smc_Set_incl_Set_is_arr)

lemmas [smc_Set_cs_intros] = \<Z>.smc_Set_incl_Set_is_arr'

subsubsection\<open>Composable arrows\<close>

lemma smc_Set_composable_arrs_dg_Set:
  "composable_arrs (dg_Set \<alpha>) = composable_arrs (smc_Set \<alpha>)"
  unfolding composable_arrs_def smc_dg_smc_Set[symmetric] slicing_simps by simp

lemma smc_Set_Comp:
  "smc_Set \<alpha>\<lparr>Comp\<rparr> =
    VLambda (composable_arrs (smc_Set \<alpha>)) (\<lambda>ST. ST\<lparr>0\<rparr> \<circ>\<^sub>R\<^sub>e\<^sub>l ST\<lparr>1\<^sub>\<nat>\<rparr>)"
  unfolding smc_Set_components smc_Set_composable_arrs_dg_Set ..

subsubsection\<open>Composition\<close>

lemma smc_Set_Comp_app[smc_Set_cs_simps]:
  assumes "S : b \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> c" and "T : a \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> b"
  shows "S \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> T = S \<circ>\<^sub>S\<^sub>e\<^sub>t T"
proof-
  from assms have "[S, T]\<^sub>\<circ> \<in>\<^sub>\<circ> composable_arrs (smc_Set \<alpha>)"
    by (auto simp: smc_cs_intros)
  then show "S \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> T = S \<circ>\<^sub>S\<^sub>e\<^sub>t T"
    unfolding smc_Set_Comp by (simp add: nat_omega_simps)
qed

lemma smc_Set_Comp_vdomain: "\<D>\<^sub>\<circ> (smc_Set \<alpha>\<lparr>Comp\<rparr>) = composable_arrs (smc_Set \<alpha>)"
  unfolding smc_Set_Comp by simp

lemma (in \<Z>) smc_Set_Comp_vrange:
  "\<R>\<^sub>\<circ> (smc_Set \<alpha>\<lparr>Comp\<rparr>) \<subseteq>\<^sub>\<circ> set {T. arr_Set \<alpha> T}"
proof(rule vsubsetI)
  interpret digraph \<alpha> \<open>smc_dg (smc_Set \<alpha>)\<close>
    unfolding smc_dg_smc_Set by (simp add: digraph_dg_Set)
  fix R assume "R \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (smc_Set \<alpha>\<lparr>Comp\<rparr>)"
  then obtain ST
    where R_def: "R = smc_Set \<alpha>\<lparr>Comp\<rparr>\<lparr>ST\<rparr>"
      and "ST \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_Set \<alpha>\<lparr>Comp\<rparr>)"
    unfolding smc_Set_components by (blast dest: rel_VLambda.vrange_atD)
  then obtain S T a b c
    where "ST = [S, T]\<^sub>\<circ>"
      and S: "S : b \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> c"
      and T: "T : a \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> b"
    by (auto simp: smc_Set_Comp_vdomain)
  with R_def have R_def': "R = S \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> T" by simp
  interpret S: arr_Set \<alpha> S + T: arr_Set \<alpha> T
    rewrites [simp]: "S\<lparr>ArrDom\<rparr> = b"
      and [simp]: "S\<lparr>ArrCod\<rparr> = c"
      and [simp]: "T\<lparr>ArrDom\<rparr> = a"
      and [simp]: "T\<lparr>ArrCod\<rparr> = b"
    using S T by (auto elim!: smc_Set_is_arrD)
  have "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> \<D>\<^sub>\<circ> (S\<lparr>ArrVal\<rparr>)"
  proof(intro vsubsetI)
    fix y assume prems: "y \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
    with T.ArrVal.vrange_atD obtain x
      where y_def: "y = T\<lparr>ArrVal\<rparr>\<lparr>x\<rparr>" and x: "x \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
      by metis
    from prems x T.arr_Set_ArrVal_vrange show "y \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (S\<lparr>ArrVal\<rparr>)"
      unfolding y_def by (auto simp: smc_Set_cs_simps)
  qed
  with S.arr_Set_axioms T.arr_Set_axioms have "arr_Set \<alpha> (S \<circ>\<^sub>S\<^sub>e\<^sub>t T)"
    by (simp add: arr_Set_comp_Set)
  from this show "R \<in>\<^sub>\<circ> set {T. arr_Set \<alpha> T}"
    unfolding R_def' smc_Set_Comp_app[OF S T] by simp
qed

lemma smc_Set_composable_vrange_vdomain[smc_Set_cs_intros]:
  assumes "g : b \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> c" and "f : a \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> b"
  shows "\<R>\<^sub>\<circ> (f\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> \<D>\<^sub>\<circ> (g\<lparr>ArrVal\<rparr>)"
proof(intro vsubsetI)
  from assms have g: "arr_Set \<alpha> g" and f: "arr_Set \<alpha> f"
    by (auto simp: smc_Set_is_arrD)
  fix y assume "y \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (f\<lparr>ArrVal\<rparr>)"
  with assms f have "y \<in>\<^sub>\<circ> b" by (force simp: smc_Set_is_arrD(3))
  with assms g show "y \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (g\<lparr>ArrVal\<rparr>)"
    by (simp add: smc_Set_is_arrD(2) arr_SetD(5))
qed

lemma smc_Set_Comp_ArrVal[smc_cs_simps]:
  assumes "S : y \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> z" and "T : x \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> y" and "a \<in>\<^sub>\<circ> x"
  shows "(S \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> T)\<lparr>ArrVal\<rparr>\<lparr>a\<rparr> = S\<lparr>ArrVal\<rparr>\<lparr>T\<lparr>ArrVal\<rparr>\<lparr>a\<rparr>\<rparr>"
proof-
  interpret S: arr_Set \<alpha> S + T: arr_Set \<alpha> T
    using assms by (auto simp: smc_Set_is_arrD)
  have Ta: "T\<lparr>ArrVal\<rparr>\<lparr>a\<rparr> \<in>\<^sub>\<circ> y"
  proof-
    from assms have "a \<in>\<^sub>\<circ> T\<lparr>ArrDom\<rparr>" by (auto simp: smc_Set_is_arrD)
    with assms T.arr_Set_ArrVal_vrange show ?thesis
      by
        (
          simp add:
            T.ArrVal.vsv_vimageI2 vsubset_iff smc_Set_is_arrD smc_Set_cs_simps
        )
  qed
  from Ta assms S.arr_Set_axioms T.arr_Set_axioms show ?thesis
    by ((cs_concl_step smc_Set_cs_simps)+, intro arr_Set_comp_Set_ArrVal_app[of \<alpha>])
      (simp_all add: smc_Set_is_arrD smc_Set_cs_simps)
qed

subsubsection\<open>\<open>Set\<close> is a semicategory\<close>

lemma (in \<Z>) semicategory_smc_Set: "semicategory \<alpha> (smc_Set \<alpha>)"
proof(rule semicategoryI, unfold smc_dg_smc_Set)

  interpret wide_subdigraph \<alpha> \<open>dg_Set \<alpha>\<close> \<open>dg_Par \<alpha>\<close>
    by (rule wide_subdigraph_dg_Set_dg_Par)
  interpret smc_Par: semicategory \<alpha> \<open>smc_Par \<alpha>\<close> by (rule semicategory_smc_Par)

  show "vfsequence (smc_Set \<alpha>)" unfolding smc_Set_def by simp
  show "vcard (smc_Set \<alpha>) = 5\<^sub>\<nat>"
    unfolding smc_Set_def by (simp add: nat_omega_simps)

  show "(gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_Set \<alpha>\<lparr>Comp\<rparr>)) \<longleftrightarrow>
    (\<exists>g f b c a. gf = [g, f]\<^sub>\<circ> \<and> g : b \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> c \<and> f : a \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> b)"
    for gf
    unfolding smc_Set_Comp_vdomain by (auto intro: composable_arrsI)

  show [intro]: "g \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> f : a \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> c"
    if "g : b \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> c" "f : a \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> b" for g b c f a
  proof-
    from that have g: "arr_Set \<alpha> g" and f: "arr_Set \<alpha> f"
      by (auto simp: smc_Set_is_arrD)
    with that show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: smc_cs_simps smc_Set_cs_simps
            cs_intro: smc_Set_cs_intros
        )
  qed

  show "h \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> g \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> f = h \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> (g \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> f)"
    if "h : c \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> d"
      and "g : b \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> c"
      and "f : a \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> b"
    for h c d g b f a
  proof-
    from that have "arr_Set \<alpha> h" "arr_Set \<alpha> g" "arr_Set \<alpha> f"
      by (auto simp: smc_Set_is_arrD)
    with that show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: smc_cs_simps smc_Set_cs_simps
            cs_intro: smc_Set_cs_intros
        )
  qed

qed (auto simp: digraph_dg_Set smc_Set_components)

subsubsection\<open>\<open>Set\<close> is a wide subsemicategory of \<open>Par\<close>\<close>

lemma (in \<Z>) wide_subsemicategory_smc_Set_smc_Par:
  "smc_Set \<alpha> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> smc_Par \<alpha>"
proof-
  interpret Par: semicategory \<alpha> \<open>smc_Par \<alpha>\<close> by (rule semicategory_smc_Par)
  interpret Set: semicategory \<alpha> \<open>smc_Set \<alpha>\<close> by (rule semicategory_smc_Set)
  show ?thesis
  proof
    (
      intro wide_subsemicategoryI subsemicategoryI,
      unfold smc_dg_smc_Par smc_dg_smc_Set
    )
    from wide_subdigraph_dg_Set_dg_Par show wsd:
      "dg_Set \<alpha> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> dg_Par \<alpha>"
      "dg_Set \<alpha> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> dg_Par \<alpha>"
      by auto
    interpret wide_subdigraph \<alpha> \<open>dg_Set \<alpha>\<close> \<open>dg_Par \<alpha>\<close> by (rule wsd(2))
    show "g \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> f = g \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> f"
      if "g : b \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> c" and "f : a \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> b" for g b c f a
    proof-
      from that have "g : b \<mapsto>\<^bsub>dg_Set \<alpha>\<^esub> c" and "f : a \<mapsto>\<^bsub>dg_Set \<alpha>\<^esub> b"
        by
          (
            cs_concl cs_shallow
              cs_simp: smc_dg_smc_Set[symmetric] cs_intro: slicing_intros
          )+
      then have "g : b \<mapsto>\<^bsub>dg_Par \<alpha>\<^esub> c" and "f : a \<mapsto>\<^bsub>dg_Par \<alpha>\<^esub> b"
        by (cs_concl cs_shallow cs_intro: dg_sub_fw_cs_intros)+
      then have "g : b \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> c" and "f : a \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> b"
        unfolding smc_dg_smc_Par[symmetric] slicing_simps by simp_all
      from that this show "g \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> f = g \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> f"
        by (cs_concl cs_shallow cs_simp: smc_Set_cs_simps smc_Par_cs_simps)
    qed
  qed (auto simp: smc_cs_intros)
qed

subsection\<open>Monic arrow and epic arrow\<close>

lemma smc_Set_is_monic_arrI:
  \<comment>\<open>See Chapter I-5 in \cite{mac_lane_categories_2010}).\<close>
  assumes "T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B" and "v11 (T\<lparr>ArrVal\<rparr>)" and "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
  shows "T : A \<mapsto>\<^sub>m\<^sub>o\<^sub>n\<^bsub>smc_Set \<alpha>\<^esub> B"
proof(rule is_monic_arrI)

  interpret T: arr_Set \<alpha> T by (intro smc_Set_is_arrD[OF assms(1)])+
  interpret wide_subsemicategory \<alpha> \<open>smc_Set \<alpha>\<close> \<open>smc_Par \<alpha>\<close>
    by (rule T.wide_subsemicategory_smc_Set_smc_Par)
  interpret v11 \<open>T\<lparr>ArrVal\<rparr>\<close> by (rule assms(2))

  show T: "T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B" by (rule assms(1))
  fix S R A'
  assume S: "S : A' \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> A"
    and R: "R : A' \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> A"
    and TS_TR: "T \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> S = T \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> R"
  from assms(3) T have "T : A \<mapsto>\<^sub>m\<^sub>o\<^sub>n\<^bsub>smc_Par \<alpha>\<^esub> B"
    by (intro smc_Par_is_monic_arrI)
      (auto simp: v11_axioms dest: subsmc_is_arrD)
  moreover from S subsemicategory_axioms have "S : A' \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> A"
    by (cs_concl cs_shallow cs_intro: smc_sub_fw_cs_intros)
  moreover from R subsemicategory_axioms have "R : A' \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> A"
    by (cs_concl cs_shallow cs_intro: smc_sub_fw_cs_intros)
  moreover from T S R TS_TR subsemicategory_axioms have
    "T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> S = T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> R"
    by (auto simp: smc_sub_bw_cs_simps)
  ultimately show "S = R" by (rule is_monic_arrD(2))

qed

lemma smc_Set_is_monic_arrD:
  assumes "T : A \<mapsto>\<^sub>m\<^sub>o\<^sub>n\<^bsub>smc_Set \<alpha>\<^esub> B"
  shows "T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B" and "v11 (T\<lparr>ArrVal\<rparr>)" and "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
proof-

  from assms show T: "T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B" by auto
  interpret T: arr_Set \<alpha> T
    rewrites [simp]: "T\<lparr>ArrDom\<rparr> = A" and [simp]: "T\<lparr>ArrCod\<rparr> = B"
    by (intro smc_Set_is_arrD[OF T])+

  interpret wide_subdigraph \<alpha> \<open>dg_Set \<alpha>\<close> \<open>dg_Par \<alpha>\<close>
    by (rule T.wide_subdigraph_dg_Set_dg_Par)
  interpret Par: semicategory \<alpha> \<open>smc_Par \<alpha>\<close> by (rule T.semicategory_smc_Par)

  show "v11 (T\<lparr>ArrVal\<rparr>)"
  proof(rule v11I)

    show "vsv ((T\<lparr>ArrVal\<rparr>)\<inverse>\<^sub>\<circ>)"
    proof(rule vsvI)

      fix a b c assume "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)\<inverse>\<^sub>\<circ>" and "\<langle>a, c\<rangle> \<in>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)\<inverse>\<^sub>\<circ>"

      then have bar: "\<langle>b, a\<rangle> \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>" and car: "\<langle>c, a\<rangle> \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
        by auto
      with T.arr_Set_ArrVal_vdomain have [intro]: "b \<in>\<^sub>\<circ> A" "c \<in>\<^sub>\<circ> A" by blast+

      define R where "R = [set {\<langle>0, b\<rangle>}, set {0}, A]\<^sub>\<circ>"
      define S where "S = [set {\<langle>0, c\<rangle>}, set {0}, A]\<^sub>\<circ>"

      have R: "R : set {0} \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> A"
      proof(rule smc_Set_is_arrI)
        show "arr_Set \<alpha> R"
          unfolding R_def
          by (rule T.arr_Set_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (simp_all add: R_def arr_Rel_components)
      interpret R: arr_Set \<alpha> R
        rewrites [simp]: "R\<lparr>ArrDom\<rparr> = set {0}" and [simp]: "R\<lparr>ArrCod\<rparr> = A"
        by (intro smc_Set_is_arrD[OF R])+

      have S: "S : set {0} \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> A"
      proof(rule smc_Set_is_arrI)
        show "arr_Set \<alpha> S"
          unfolding S_def
          by (rule T.arr_Set_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (simp_all add: S_def arr_Rel_components)
      interpret S: arr_Set \<alpha> S
        rewrites [simp]: "S\<lparr>ArrDom\<rparr> = set {0}" and [simp]: "S\<lparr>ArrCod\<rparr> = A"
        by (intro smc_Set_is_arrD[OF S])+

      have "T \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> R = [set {\<langle>0, a\<rangle>}, set {0}, B]\<^sub>\<circ>"
        unfolding smc_Set_Comp_app[OF T R]
      proof
        (
          rule arr_Set_eqI[of \<alpha>],
          unfold comp_Rel_components arr_Rel_components
        )
        from R T show "arr_Set \<alpha> (T \<circ>\<^sub>S\<^sub>e\<^sub>t R)"
          by (intro arr_Set_comp_Set)
            (auto elim!: smc_Set_is_arrE simp: smc_Set_cs_simps)
        show "arr_Set \<alpha> [set {\<langle>0, a\<rangle>}, set {0}, B]\<^sub>\<circ>"
        proof(rule T.arr_Set_vfsequenceI)
          from T.arr_Rel_ArrVal_vrange bar show "\<R>\<^sub>\<circ> (set {\<langle>0, a\<rangle>}) \<subseteq>\<^sub>\<circ> B" by auto
        qed (auto simp: T.arr_Rel_ArrCod_in_Vset T.Axiom_of_Powers)
        show "T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> R\<lparr>ArrVal\<rparr> = set {\<langle>0, a\<rangle>}"
          unfolding R_def arr_Rel_components
        proof(rule vsv_eqI, unfold vdomain_vsingleton)
          from bar show "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, b\<rangle>}) = set {0}" by auto
          with bar show "a' \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, b\<rangle>}) \<Longrightarrow>
            (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, b\<rangle>})\<lparr>a'\<rparr> = set {\<langle>0, a\<rangle>}\<lparr>a'\<rparr>"
            for a'
            by auto
        qed (auto intro: vsv_vcomp)
      qed (simp_all add: R_def arr_Rel_components)
      moreover have "T \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> S = [set {\<langle>0, a\<rangle>}, set {0}, B]\<^sub>\<circ>"
        unfolding smc_Set_Comp_app[OF T S]
      proof
        (
          rule arr_Set_eqI[of \<alpha>],
          unfold comp_Rel_components arr_Rel_components
        )
        from T S show "arr_Set \<alpha> (T \<circ>\<^sub>S\<^sub>e\<^sub>t S)"
          by (intro arr_Set_comp_Set)
            (
              auto simp:
                T.arr_Set_axioms
                smc_Set_is_arrD
                S.arr_Set_ArrVal_vrange
                smc_Set_cs_simps
            )
        show "arr_Set \<alpha> [set {\<langle>0, a\<rangle>}, set {0}, B]\<^sub>\<circ>"
        proof(rule T.arr_Set_vfsequenceI)
          from T.arr_Rel_ArrVal_vrange bar show "\<R>\<^sub>\<circ> (set {\<langle>0, a\<rangle>}) \<subseteq>\<^sub>\<circ> B" by auto
        qed (auto simp: T.arr_Rel_ArrCod_in_Vset T.Axiom_of_Powers)
        show "T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> S\<lparr>ArrVal\<rparr> = set {\<langle>0, a\<rangle>}"
          unfolding S_def arr_Rel_components
        proof(rule vsv_eqI, unfold vdomain_vsingleton)
          from car show "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, c\<rangle>}) = set {0}" by auto
          with car show "a' \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, c\<rangle>}) \<Longrightarrow>
            (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, c\<rangle>})\<lparr>a'\<rparr> = set {\<langle>0, a\<rangle>}\<lparr>a'\<rparr>"
            for a'
            by auto
        qed (auto intro: vsv_vcomp)
      qed (simp_all add: S_def arr_Rel_components)
      ultimately have "T \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> R = T \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> S" by simp
      from R S assms this have "R = S" by clarsimp
      then have "R\<lparr>ArrVal\<rparr> = S\<lparr>ArrVal\<rparr>" by simp
      then show "b = c" unfolding R_def S_def arr_Rel_components by simp
    qed clarsimp

  qed auto

  show "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A" by (simp add: smc_Set_cs_simps)

qed

lemma smc_Set_is_monic_arr:
  "T : A \<mapsto>\<^sub>m\<^sub>o\<^sub>n\<^bsub>smc_Set \<alpha>\<^esub> B \<longleftrightarrow>
    T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B \<and> v11 (T\<lparr>ArrVal\<rparr>) \<and> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
  by (rule iffI) (auto simp: smc_Set_is_monic_arrD smc_Set_is_monic_arrI)

text\<open>
An epic arrow in \<open>Set\<close> is a total surjective function (see Chapter I-5
in \<^cite>\<open>"mac_lane_categories_2010"\<close>).
\<close>

lemma smc_Set_is_epic_arrI:
  assumes "T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B" and "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
  shows "T : A \<mapsto>\<^sub>e\<^sub>p\<^sub>i\<^bsub>smc_Set \<alpha>\<^esub> B"
proof-

  interpret T: arr_Set \<alpha> T
    rewrites [simp]: "T\<lparr>ArrDom\<rparr> = A" and [simp]: "T\<lparr>ArrCod\<rparr> = B"
    by (intro smc_Set_is_arrD[OF assms(1)])+

  interpret wide_subsemicategory \<alpha> \<open>smc_Set \<alpha>\<close> \<open>smc_Par \<alpha>\<close>
    by (rule T.wide_subsemicategory_smc_Set_smc_Par)
  have epi_T: "T : A \<mapsto>\<^sub>e\<^sub>p\<^sub>i\<^bsub>smc_Par \<alpha>\<^esub> B"
    using assms by (meson smc_Par_is_epic_arr subsmc_is_arrD)

  show ?thesis
  proof(rule sdg.is_epic_arrI)
    show T: "T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B" by (rule assms(1))
    fix f g a
    assume prems:
      "f : B \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> a"
      "g : B \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> a"
      "f \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> T = g \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> T"
    from prems(1) subsemicategory_axioms have "f : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> a"
      by (cs_concl cs_shallow cs_intro: smc_sub_fw_cs_intros)
    moreover from prems(2) subsemicategory_axioms have "g : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> a"
      by (cs_concl cs_shallow cs_intro: smc_sub_fw_cs_intros)
    moreover from prems T subsemicategory_axioms have
      "f \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T = g \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T"
      by (auto simp: smc_sub_bw_cs_simps)
    ultimately show "f = g"
      by (rule dg.is_epic_arrD(2)[OF epi_T])
  qed

qed

lemma smc_Set_is_epic_arrD:
  assumes "T : A \<mapsto>\<^sub>e\<^sub>p\<^sub>i\<^bsub>smc_Set \<alpha>\<^esub> B"
  shows "T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B" and "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
proof-

  from assms show T: "T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B" by auto
  interpret T: arr_Set \<alpha> T
    rewrites "T\<lparr>ArrDom\<rparr> = A" and "T\<lparr>ArrCod\<rparr> = B"
    by (intro smc_Set_is_arrD[OF T])+

  interpret semicategory \<alpha> \<open>smc_Set \<alpha>\<close> by (rule T.semicategory_smc_Set)

  show "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
  proof(intro vsubset_antisym vsubsetI)
    fix b assume [intro]: "b \<in>\<^sub>\<circ> B"
    show "b \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
    proof(rule ccontr)
      assume b: "b \<notin>\<^sub>\<circ> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
      define R
        where "R = [vinsert \<langle>b, 0\<rangle> ((B -\<^sub>\<circ> set {b}) \<times>\<^sub>\<circ> set {1}), B, set {0, 1}]\<^sub>\<circ>"
      define S where "S = [B \<times>\<^sub>\<circ> set {1}, B, set {0, 1}]\<^sub>\<circ>"
      have R: "R : B \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> set {0, 1}"
        unfolding R_def
      proof
        (
          intro smc_Set_is_arrI T.arr_Set_vfsequenceI,
          unfold arr_Rel_components
        )
        from T.Axiom_of_Infinity vone_in_omega show "set {0, 1} \<in>\<^sub>\<circ> Vset \<alpha>"
          by blast
      qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
      have S: "S : B \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> set {0, 1}"
        unfolding S_def
      proof
        (
          intro smc_Set_is_arrI T.arr_Set_vfsequenceI,
          unfold arr_Rel_components
        )
        from T.Axiom_of_Infinity vone_in_omega show "set {0, 1} \<in>\<^sub>\<circ> Vset \<alpha>"
          by blast
      qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
      from b have "R\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> T\<lparr>ArrVal\<rparr> = S\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
        unfolding S_def R_def arr_Rel_components
        by (auto intro!: vsubset_antisym vsubsetI)
      then have "R \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> T = S \<circ>\<^sub>A\<^bsub>smc_Set \<alpha>\<^esub> T"
        unfolding smc_Set_Comp_app[OF R T] smc_Set_Comp_app[OF S T]
        by (simp add: R_def S_def arr_Rel_components comp_Rel_def)
      from R S this have "R = S" by (rule is_epic_arrD(2)[OF assms])
      with zero_neq_one show False unfolding R_def S_def by blast
    qed
  qed (use T.arr_Set_ArrVal_vrange in auto)

qed

lemma smc_Set_is_epic_arr:
  "T : A \<mapsto>\<^sub>e\<^sub>p\<^sub>i\<^bsub>smc_Set \<alpha>\<^esub> B \<longleftrightarrow> T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B \<and> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
  by (rule iffI) (simp_all add: smc_Set_is_epic_arrD smc_Set_is_epic_arrI)

subsection\<open>Terminal object, initial object and null object\<close>

text\<open>
An object in \<open>Set\<close> is terminal if and only if it is a singleton
set (see Chapter I-5 in \<^cite>\<open>"mac_lane_categories_2010"\<close>).
\<close>

lemma (in \<Z>) smc_Set_obj_terminal:
  "obj_terminal (smc_Set \<alpha>) A \<longleftrightarrow> (\<exists>B\<in>\<^sub>\<circ>Vset \<alpha>. A = set {B})"
proof-

  interpret semicategory \<alpha> \<open>smc_Set \<alpha>\<close> by (rule semicategory_smc_Set)

  have "(\<forall>A\<in>\<^sub>\<circ>Vset \<alpha>. \<exists>!T. T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B) \<longleftrightarrow> (\<exists>C\<in>\<^sub>\<circ>Vset \<alpha>. B = set {C})"
    for B
  proof(intro iffI ballI)

    assume prems[rule_format]: "\<forall>A\<in>\<^sub>\<circ>Vset \<alpha>. \<exists>!T. T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B"

    then obtain T where T0B: "T : 0 \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B" by (meson vempty_is_zet)
    then have B[simp]: "B \<in>\<^sub>\<circ> Vset \<alpha>" by (fastforce simp: smc_Set_components(1))

    show "\<exists>C\<in>\<^sub>\<circ>Vset \<alpha>. B = set {C}"
    proof(rule ccontr, cases \<open>B = 0\<close>)
      case True
      from prems have "\<exists>!T. T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> 0" if "A \<in>\<^sub>\<circ> Vset \<alpha>" for A
        using that unfolding True by simp
      then obtain T where T: "T : set {0} \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> 0"
        by (metis Axiom_of_Pairing insert_absorb2 vempty_is_zet)
      interpret T: arr_Set \<alpha> T
        rewrites "T\<lparr>ArrDom\<rparr> = set {0}" and "T\<lparr>ArrCod\<rparr> = 0"
        by (intro smc_Set_is_arrD[OF T])+
      from
        T.vdomain_vrange_is_vempty
        T.ArrVal.vdomain_vrange_is_vempty
        T.arr_Set_ArrVal_vrange
      show False
        by (auto simp: smc_Set_cs_simps)
    next
      case False
      assume "\<not>(\<exists>C\<in>\<^sub>\<circ>Vset \<alpha>. B = set {C})"
      with B have "\<nexists>C. B = set {C}" by blast
      with False obtain a b where ab: "a \<noteq> b" "a \<in>\<^sub>\<circ> B" "b \<in>\<^sub>\<circ> B"
        by (metis V_equalityI vemptyE vintersection_vsingleton vsingletonD)
      have "[set {\<langle>0, a\<rangle>}, set {0}, B]\<^sub>\<circ> : set {0} \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B"
        by (intro smc_Set_is_arrI arr_SetI, unfold arr_Rel_components)
          (auto simp: ab(2) nat_omega_simps)
      moreover from ab have
        "[set {\<langle>0, b\<rangle>}, set {0}, B]\<^sub>\<circ> : set {0} \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B"
        by (intro smc_Set_is_arrI arr_SetI, unfold arr_Rel_components)
          (auto simp: ab(2) nat_omega_simps)
      moreover with ab have
        "[set {\<langle>0, a\<rangle>}, set {0}, B]\<^sub>\<circ> \<noteq> [set {\<langle>0, b\<rangle>}, set {0}, B]\<^sub>\<circ>"
        by simp
      ultimately show False
        by (metis prems smc_is_arrE smc_Set_components(1))
    qed

  next

    fix A assume prems: "\<exists>b\<in>\<^sub>\<circ>Vset \<alpha>. B = set {b}" "A \<in>\<^sub>\<circ> Vset \<alpha>"
    then obtain b where B_def: "B = set {b}" and b: "b \<in>\<^sub>\<circ> Vset \<alpha>" by blast

    have "vconst_on A b = A \<times>\<^sub>\<circ> set {b}" by (simp add: vconst_on_eq_vtimes)

    show "\<exists>!T. T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B"
      unfolding B_def
    proof(rule ex1I[of _ \<open>[A \<times>\<^sub>\<circ> set {b}, A, set {b}]\<^sub>\<circ>\<close>])

      show "[A \<times>\<^sub>\<circ> set {b}, A, set {b}]\<^sub>\<circ> : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> set {b}"
        using b
        by
          (
            intro smc_Set_is_arrI arr_Set_vfsequenceI,
            unfold arr_Rel_components
          )
          (auto simp: prems(2) vconst_on_eq_vtimes[symmetric])

      fix T assume prems: "T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> set {b}"

      interpret T: arr_Set \<alpha> T
        rewrites [simp]: "T\<lparr>ArrDom\<rparr> = A" and [simp]: "T\<lparr>ArrCod\<rparr> = set {b}"
        by (intro smc_Set_is_arrD[OF prems])+

      have [simp]: "T\<lparr>ArrVal\<rparr> = A \<times>\<^sub>\<circ> set {b}"
      proof(intro vsubset_antisym vsubsetI)
        fix x assume prems: "x \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
        with T.vbrelation_axioms app_vdomainI obtain a b'
          where "x = \<langle>a, b'\<rangle>" and "a \<in>\<^sub>\<circ> A"
          by (metis T.ArrVal.vbrelation_vinE T.arr_Set_ArrVal_vdomain)
        with prems T.arr_Set_ArrVal_vrange show "x \<in>\<^sub>\<circ> A \<times>\<^sub>\<circ> set {b}" by auto
      next
        fix x assume "x \<in>\<^sub>\<circ> A \<times>\<^sub>\<circ> set {b}"
        then obtain a where x_def: "x = \<langle>a, b\<rangle>" and "a \<in>\<^sub>\<circ> A" by clarsimp
        have "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A" by (simp add: smc_Set_cs_simps)
        moreover with
          T.arr_Set_ArrVal_vrange T.ArrVal.vdomain_vrange_is_vempty \<open>a \<in>\<^sub>\<circ> A\<close>
        have "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = set {b}"
          by auto
        ultimately show "x \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
          using \<open>a \<in>\<^sub>\<circ> A\<close>
          unfolding x_def
          by
            (
              metis
                T.ArrVal.vsv_ex1_app1
                T.ArrVal.vsv_vimageI1
                vimage_vdomain
                vsingletonD
            )
      qed

      show "T = [A \<times>\<^sub>\<circ> set {b}, A, set {b}]\<^sub>\<circ>"
      proof(rule arr_Set_eqI[of \<alpha>], unfold arr_Rel_components)
        show "arr_Set \<alpha> [A \<times>\<^sub>\<circ> set {b}, A, set {b}]\<^sub>\<circ>"
          using T.arr_Rel_def T.arr_Set_axioms by auto
      qed (auto simp: T.arr_Set_axioms)

    qed
  qed

  then show ?thesis
    apply(intro iffI obj_terminalI)
    subgoal by (metis smc_is_arrD(2) obj_terminalE)
    subgoal by blast
    subgoal by (metis smc_Set_components(1))
    done

qed

text\<open>
An object in \<open>Set\<close> is initial if and only if it is the empty
set (see Chapter I-5 in \<^cite>\<open>"mac_lane_categories_2010"\<close>).
\<close>

lemma (in \<Z>) smc_Set_obj_initial: "obj_initial (smc_Set \<alpha>) A \<longleftrightarrow> A = 0"
proof-

  interpret semicategory \<alpha> \<open>smc_Set \<alpha>\<close> by (rule semicategory_smc_Set)

  have "(\<forall>B\<in>\<^sub>\<circ>Vset \<alpha>. \<exists>!T. T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B) \<longleftrightarrow> A = 0" for A
  proof(intro iffI ballI)

    assume prems[rule_format]: "\<forall>B\<in>\<^sub>\<circ>Vset \<alpha>. \<exists>!T. T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B"

    then obtain T where T0B: "T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> 0" by (meson vempty_is_zet)
    then have A[simp]: "A \<in>\<^sub>\<circ> Vset \<alpha>" by (fastforce simp: smc_Set_components(1))

    show "A = 0"
    proof(rule ccontr)
      assume "A \<noteq> 0"
      then obtain a where a: "a \<in>\<^sub>\<circ> A" by (auto dest: trad_foundation)
      from Axiom_of_Powers a have A0:
        "[A \<times>\<^sub>\<circ> set {0}, A, set {0}]\<^sub>\<circ> : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> set {0}"
        by
          (
            intro smc_Set_is_arrI arr_Set_vfsequenceI,
            unfold arr_Rel_components
          )
          auto
      have A1: "[A \<times>\<^sub>\<circ> set {1}, A, set {1}]\<^sub>\<circ> : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> set {1}"
      proof
          (
            intro smc_Set_is_arrI arr_Set_vfsequenceI,
            unfold arr_Rel_components
          )
        show "set {1} \<in>\<^sub>\<circ> Vset \<alpha>" by (blast intro: vone_in_omega Axiom_of_Infinity)
      qed auto
      have "[A \<times>\<^sub>\<circ> set {0}, A, set {0, 1}]\<^sub>\<circ> : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> set {0, 1}"
      proof
        (
          intro smc_Set_is_arrI arr_Set_vfsequenceI,
          unfold arr_Rel_components
        )
        show "set {0, 1} \<in>\<^sub>\<circ> Vset \<alpha>"
          by (intro Limit_vdoubleton_in_VsetI) (force simp: nat_omega_simps)+
      qed auto
      moreover have
        "[A \<times>\<^sub>\<circ> set {1}, A, set {0, 1}]\<^sub>\<circ> : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> set {0, 1}"
      proof
        (
          intro smc_Set_is_arrI arr_Set_vfsequenceI,
          unfold arr_Rel_components
        )
        show "set {0, 1} \<in>\<^sub>\<circ> Vset \<alpha>"
          by (intro Limit_vdoubleton_in_VsetI) (force simp: nat_omega_simps)+
      qed auto
      moreover from \<open>A \<noteq> 0\<close> one_neq_zero have
        "[A \<times>\<^sub>\<circ> set {0}, A, set {0, 1}]\<^sub>\<circ> \<noteq> [A \<times>\<^sub>\<circ> set {1}, A, set {0, 1}]\<^sub>\<circ>"
        by (blast intro!: vsubset_antisym)
      ultimately show False
        by (metis prems smc_is_arrE smc_Set_components(1))
    qed
  next
    fix B assume prems: "A = 0" "B \<in>\<^sub>\<circ> Vset \<alpha>"
    show "\<exists>!T. T : A \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B"
    proof(rule ex1I[of _ \<open>[0, 0, B]\<^sub>\<circ>\<close>], unfold prems(1))
      show zzB: "[0, 0, B]\<^sub>\<circ> : 0 \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B"
        by
          (
            intro smc_Set_is_arrI arr_Set_vfsequenceI,
            unfold arr_Rel_components
          )
          (simp_all add: prems)
      fix T assume prems': "T : 0 \<mapsto>\<^bsub>smc_Set \<alpha>\<^esub> B"
      interpret T: arr_Set \<alpha> T
        rewrites [simp]: "T\<lparr>ArrDom\<rparr> = 0" and [simp]: "T\<lparr>ArrCod\<rparr> = B"
        by (intro smc_Set_is_arrD[OF prems'])+
      show "T = [0, 0, B]\<^sub>\<circ>"
      proof(rule arr_Set_eqI[of \<alpha>], unfold arr_Rel_components)
        show "arr_Set \<alpha> T" by (rule T.arr_Set_axioms)
        from zzB show "arr_Set \<alpha> [0, 0, B]\<^sub>\<circ>" by (meson smc_Set_is_arrE)
        from T.ArrVal.vdomain_vrange_is_vempty show "T\<lparr>ArrVal\<rparr> = 0"
          by (auto intro: T.ArrVal.vsv_vrange_vempty simp: smc_Set_cs_simps)
      qed simp_all
    qed
  qed

  then show ?thesis
    apply(intro iffI obj_initialI, elim obj_initialE)
    subgoal by (metis smc_Set_components(1))
    subgoal by (simp add: smc_Set_components(1))
    subgoal by (metis smc_Set_components(1))
    done

qed

text\<open>
There are no null objects in \<open>Set\<close> (this is a trivial corollary of the above).
\<close>

lemma (in \<Z>) smc_Set_obj_null: "obj_null (smc_Set \<alpha>) A \<longleftrightarrow> False"
  unfolding obj_null_def smc_Set_obj_terminal smc_Set_obj_initial by simp

subsection\<open>Zero arrow\<close>

text\<open>
There are no zero arrows in \<open>Set\<close> (this result is a trivial
corollary of the absence of null objects).
\<close>

lemma (in \<Z>) smc_Set_is_zero_arr: "T : A \<mapsto>\<^sub>0\<^bsub>smc_Set \<alpha>\<^esub> B \<longleftrightarrow> False"
  using smc_Set_obj_null unfolding is_zero_arr_def by auto

text\<open>\newpage\<close>

end


(*  Title:      ZF/Constructible/WFrec.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section\<open>Relativized Well-Founded Recursion\<close>

theory WFrec imports Wellorderings begin

subsection\<open>General Lemmas\<close>

(*Many of these might be useful in WF.thy*)

lemma apply_recfun2:
    "[| is_recfun(r,a,H,f); <x,i>:f |] ==> i = H(x, restrict(f,r-``{x}))"
apply (frule apply_recfun)
 apply (blast dest: is_recfun_type fun_is_rel)
apply (simp add: function_apply_equality [OF _ is_recfun_imp_function])
done

text\<open>Expresses \<open>is_recfun\<close> as a recursion equation\<close>
lemma is_recfun_iff_equation:
     "is_recfun(r,a,H,f) \<longleftrightarrow>
           f \<in> r -`` {a} \<rightarrow> range(f) &
           (\<forall>x \<in> r-``{a}. f`x = H(x, restrict(f, r-``{x})))"
apply (rule iffI)
 apply (simp add: is_recfun_type apply_recfun Ball_def vimage_singleton_iff,
        clarify)
apply (simp add: is_recfun_def)
apply (rule fun_extension)
  apply assumption
 apply (fast intro: lam_type, simp)
done

lemma is_recfun_imp_in_r: "[|is_recfun(r,a,H,f); \<langle>x,i\<rangle> \<in> f|] ==> \<langle>x, a\<rangle> \<in> r"
by (blast dest: is_recfun_type fun_is_rel)

lemma trans_Int_eq:
      "[| trans(r); <y,x> \<in> r |] ==> r -`` {x} \<inter> r -`` {y} = r -`` {y}"
by (blast intro: transD)

lemma is_recfun_restrict_idem:
     "is_recfun(r,a,H,f) ==> restrict(f, r -`` {a}) = f"
apply (drule is_recfun_type)
apply (auto simp add: Pi_iff subset_Sigma_imp_relation restrict_idem)
done

lemma is_recfun_cong_lemma:
  "[| is_recfun(r,a,H,f); r = r'; a = a'; f = f';
      !!x g. [| <x,a'> \<in> r'; relation(g); domain(g) \<subseteq> r' -``{x} |]
             ==> H(x,g) = H'(x,g) |]
   ==> is_recfun(r',a',H',f')"
apply (simp add: is_recfun_def)
apply (erule trans)
apply (rule lam_cong)
apply (simp_all add: vimage_singleton_iff Int_lower2)
done

text\<open>For \<open>is_recfun\<close> we need only pay attention to functions
      whose domains are initial segments of @{term r}.\<close>
lemma is_recfun_cong:
  "[| r = r'; a = a'; f = f';
      !!x g. [| <x,a'> \<in> r'; relation(g); domain(g) \<subseteq> r' -``{x} |]
             ==> H(x,g) = H'(x,g) |]
   ==> is_recfun(r,a,H,f) \<longleftrightarrow> is_recfun(r',a',H',f')"
apply (rule iffI)
txt\<open>Messy: fast and blast don't work for some reason\<close>
apply (erule is_recfun_cong_lemma, auto)
apply (erule is_recfun_cong_lemma)
apply (blast intro: sym)+
done

subsection\<open>Reworking of the Recursion Theory Within @{term M}\<close>

lemma (in M_basic) is_recfun_separation':
    "[| f \<in> r -`` {a} \<rightarrow> range(f); g \<in> r -`` {b} \<rightarrow> range(g);
        M(r); M(f); M(g); M(a); M(b) |]
     ==> separation(M, \<lambda>x. \<not> (\<langle>x, a\<rangle> \<in> r \<longrightarrow> \<langle>x, b\<rangle> \<in> r \<longrightarrow> f ` x = g ` x))"
apply (insert is_recfun_separation [of r f g a b])
apply (simp add: vimage_singleton_iff)
done

text\<open>Stated using @{term "trans(r)"} rather than
      @{term "transitive_rel(M,A,r)"} because the latter rewrites to
      the former anyway, by \<open>transitive_rel_abs\<close>.
      As always, theorems should be expressed in simplified form.
      The last three M-premises are redundant because of @{term "M(r)"},
      but without them we'd have to undertake
      more work to set up the induction formula.\<close>
lemma (in M_basic) is_recfun_equal [rule_format]:
    "[|is_recfun(r,a,H,f);  is_recfun(r,b,H,g);
       wellfounded(M,r);  trans(r);
       M(f); M(g); M(r); M(x); M(a); M(b) |]
     ==> <x,a> \<in> r \<longrightarrow> <x,b> \<in> r \<longrightarrow> f`x=g`x"
apply (frule_tac f=f in is_recfun_type)
apply (frule_tac f=g in is_recfun_type)
apply (simp add: is_recfun_def)
apply (erule_tac a=x in wellfounded_induct, assumption+)
txt\<open>Separation to justify the induction\<close>
 apply (blast intro: is_recfun_separation')
txt\<open>Now the inductive argument itself\<close>
apply clarify
apply (erule ssubst)+
apply (simp (no_asm_simp) add: vimage_singleton_iff restrict_def)
apply (rename_tac x1)
apply (rule_tac t="%z. H(x1,z)" in subst_context)
apply (subgoal_tac "\<forall>y \<in> r-``{x1}. \<forall>z. <y,z>\<in>f \<longleftrightarrow> <y,z>\<in>g")
 apply (blast intro: transD)
apply (simp add: apply_iff)
apply (blast intro: transD sym)
done

lemma (in M_basic) is_recfun_cut:
    "[|is_recfun(r,a,H,f);  is_recfun(r,b,H,g);
       wellfounded(M,r); trans(r);
       M(f); M(g); M(r); <b,a> \<in> r |]
      ==> restrict(f, r-``{b}) = g"
apply (frule_tac f=f in is_recfun_type)
apply (rule fun_extension)
apply (blast intro: transD restrict_type2)
apply (erule is_recfun_type, simp)
apply (blast intro: is_recfun_equal transD dest: transM)
done

lemma (in M_basic) is_recfun_functional:
     "[|is_recfun(r,a,H,f);  is_recfun(r,a,H,g);
       wellfounded(M,r); trans(r); M(f); M(g); M(r) |] ==> f=g"
apply (rule fun_extension)
apply (erule is_recfun_type)+
apply (blast intro!: is_recfun_equal dest: transM)
done

text\<open>Tells us that \<open>is_recfun\<close> can (in principle) be relativized.\<close>
lemma (in M_basic) is_recfun_relativize:
  "[| M(r); M(f); \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
   ==> is_recfun(r,a,H,f) \<longleftrightarrow>
       (\<forall>z[M]. z \<in> f \<longleftrightarrow>
        (\<exists>x[M]. <x,a> \<in> r & z = <x, H(x, restrict(f, r-``{x}))>))"
apply (simp add: is_recfun_def lam_def)
apply (safe intro!: equalityI)
   apply (drule equalityD1 [THEN subsetD], assumption)
   apply (blast dest: pair_components_in_M)
  apply (blast elim!: equalityE dest: pair_components_in_M)
 apply (frule transM, assumption)
 apply simp
 apply blast
apply (subgoal_tac "is_function(M,f)")
 txt\<open>We use @{term "is_function"} rather than @{term "function"} because
      the subgoal's easier to prove with relativized quantifiers!\<close>
 prefer 2 apply (simp add: is_function_def)
apply (frule pair_components_in_M, assumption)
apply (simp add: is_recfun_imp_function function_restrictI)
done

lemma (in M_basic) is_recfun_restrict:
     "[| wellfounded(M,r); trans(r); is_recfun(r,x,H,f); \<langle>y,x\<rangle> \<in> r;
       M(r); M(f);
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
       ==> is_recfun(r, y, H, restrict(f, r -`` {y}))"
apply (frule pair_components_in_M, assumption, clarify)
apply (simp (no_asm_simp) add: is_recfun_relativize restrict_iff
           trans_Int_eq)
apply safe
  apply (simp_all add: vimage_singleton_iff is_recfun_type [THEN apply_iff])
  apply (frule_tac x=xa in pair_components_in_M, assumption)
  apply (frule_tac x=xa in apply_recfun, blast intro: transD)
  apply (simp add: is_recfun_type [THEN apply_iff]
                   is_recfun_imp_function function_restrictI)
apply (blast intro: apply_recfun dest: transD)
done

lemma (in M_basic) restrict_Y_lemma:
   "[| wellfounded(M,r); trans(r); M(r);
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));  M(Y);
       \<forall>b[M].
           b \<in> Y \<longleftrightarrow>
           (\<exists>x[M]. <x,a1> \<in> r &
            (\<exists>y[M]. b = \<langle>x,y\<rangle> & (\<exists>g[M]. is_recfun(r,x,H,g) \<and> y = H(x,g))));
          \<langle>x,a1\<rangle> \<in> r; is_recfun(r,x,H,f); M(f) |]
       ==> restrict(Y, r -`` {x}) = f"
apply (subgoal_tac "\<forall>y \<in> r-``{x}. \<forall>z. <y,z>:Y \<longleftrightarrow> <y,z>:f")
 apply (simp (no_asm_simp) add: restrict_def)
 apply (thin_tac "rall(M,P)" for P)+  \<comment>\<open>essential for efficiency\<close>
 apply (frule is_recfun_type [THEN fun_is_rel], blast)
apply (frule pair_components_in_M, assumption, clarify)
apply (rule iffI)
 apply (frule_tac y="<y,z>" in transM, assumption)
 apply (clarsimp simp add: vimage_singleton_iff is_recfun_type [THEN apply_iff]
                           apply_recfun is_recfun_cut)
txt\<open>Opposite inclusion: something in f, show in Y\<close>
apply (frule_tac y="<y,z>" in transM, assumption)
apply (simp add: vimage_singleton_iff)
apply (rule conjI)
 apply (blast dest: transD)
apply (rule_tac x="restrict(f, r -`` {y})" in rexI)
apply (simp_all add: is_recfun_restrict
                     apply_recfun is_recfun_type [THEN apply_iff])
done

text\<open>For typical applications of Replacement for recursive definitions\<close>
lemma (in M_basic) univalent_is_recfun:
     "[|wellfounded(M,r); trans(r); M(r)|]
      ==> univalent (M, A, \<lambda>x p.
              \<exists>y[M]. p = \<langle>x,y\<rangle> & (\<exists>f[M]. is_recfun(r,x,H,f) & y = H(x,f)))"
apply (simp add: univalent_def)
apply (blast dest: is_recfun_functional)
done

text\<open>Proof of the inductive step for \<open>exists_is_recfun\<close>, since
      we must prove two versions.\<close>
lemma (in M_basic) exists_is_recfun_indstep:
    "[|\<forall>y. \<langle>y, a1\<rangle> \<in> r \<longrightarrow> (\<exists>f[M]. is_recfun(r, y, H, f));
       wellfounded(M,r); trans(r); M(r); M(a1);
       strong_replacement(M, \<lambda>x z.
              \<exists>y[M]. \<exists>g[M]. pair(M,x,y,z) & is_recfun(r,x,H,g) & y = H(x,g));
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
      ==> \<exists>f[M]. is_recfun(r,a1,H,f)"
apply (drule_tac A="r-``{a1}" in strong_replacementD)
  apply blast
 txt\<open>Discharge the "univalent" obligation of Replacement\<close>
 apply (simp add: univalent_is_recfun)
txt\<open>Show that the constructed object satisfies \<open>is_recfun\<close>\<close>
apply clarify
apply (rule_tac x=Y in rexI)
txt\<open>Unfold only the top-level occurrence of @{term is_recfun}\<close>
apply (simp (no_asm_simp) add: is_recfun_relativize [of concl: _ a1])
txt\<open>The big iff-formula defining @{term Y} is now redundant\<close>
apply safe
 apply (simp add: vimage_singleton_iff restrict_Y_lemma [of r H _ a1])
txt\<open>one more case\<close>
apply (simp (no_asm_simp) add: Bex_def vimage_singleton_iff)
apply (drule_tac x1=x in spec [THEN mp], assumption, clarify)
apply (rename_tac f)
apply (rule_tac x=f in rexI)
apply (simp_all add: restrict_Y_lemma [of r H])
txt\<open>FIXME: should not be needed!\<close>
apply (subst restrict_Y_lemma [of r H])
apply (simp add: vimage_singleton_iff)+
apply blast+
done

text\<open>Relativized version, when we have the (currently weaker) premise
      @{term "wellfounded(M,r)"}\<close>
lemma (in M_basic) wellfounded_exists_is_recfun:
    "[|wellfounded(M,r);  trans(r);
       separation(M, \<lambda>x. ~ (\<exists>f[M]. is_recfun(r, x, H, f)));
       strong_replacement(M, \<lambda>x z.
          \<exists>y[M]. \<exists>g[M]. pair(M,x,y,z) & is_recfun(r,x,H,g) & y = H(x,g));
       M(r);  M(a);
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
      ==> \<exists>f[M]. is_recfun(r,a,H,f)"
apply (rule wellfounded_induct, assumption+, clarify)
apply (rule exists_is_recfun_indstep, assumption+)
done

lemma (in M_basic) wf_exists_is_recfun [rule_format]:
    "[|wf(r);  trans(r);  M(r);
       strong_replacement(M, \<lambda>x z.
         \<exists>y[M]. \<exists>g[M]. pair(M,x,y,z) & is_recfun(r,x,H,g) & y = H(x,g));
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
      ==> M(a) \<longrightarrow> (\<exists>f[M]. is_recfun(r,a,H,f))"
apply (rule wf_induct, assumption+)
apply (frule wf_imp_relativized)
apply (intro impI)
apply (rule exists_is_recfun_indstep)
      apply (blast dest: transM del: rev_rallE, assumption+)
done

subsection\<open>Relativization of the ZF Predicate @{term is_recfun}\<close>

definition
  M_is_recfun :: "[i=>o, [i,i,i]=>o, i, i, i] => o" where
   "M_is_recfun(M,MH,r,a,f) ==
     \<forall>z[M]. z \<in> f \<longleftrightarrow>
            (\<exists>x[M]. \<exists>y[M]. \<exists>xa[M]. \<exists>sx[M]. \<exists>r_sx[M]. \<exists>f_r_sx[M].
               pair(M,x,y,z) & pair(M,x,a,xa) & upair(M,x,x,sx) &
               pre_image(M,r,sx,r_sx) & restriction(M,f,r_sx,f_r_sx) &
               xa \<in> r & MH(x, f_r_sx, y))"

definition
  is_wfrec :: "[i=>o, [i,i,i]=>o, i, i, i] => o" where
   "is_wfrec(M,MH,r,a,z) ==
      \<exists>f[M]. M_is_recfun(M,MH,r,a,f) & MH(a,f,z)"

definition
  wfrec_replacement :: "[i=>o, [i,i,i]=>o, i] => o" where
   "wfrec_replacement(M,MH,r) ==
        strong_replacement(M,
             \<lambda>x z. \<exists>y[M]. pair(M,x,y,z) & is_wfrec(M,MH,r,x,y))"

lemma (in M_basic) is_recfun_abs:
     "[| \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));  M(r); M(a); M(f);
         relation2(M,MH,H) |]
      ==> M_is_recfun(M,MH,r,a,f) \<longleftrightarrow> is_recfun(r,a,H,f)"
apply (simp add: M_is_recfun_def relation2_def is_recfun_relativize)
apply (rule rall_cong)
apply (blast dest: transM)
done

lemma M_is_recfun_cong [cong]:
     "[| r = r'; a = a'; f = f';
       !!x g y. [| M(x); M(g); M(y) |] ==> MH(x,g,y) \<longleftrightarrow> MH'(x,g,y) |]
      ==> M_is_recfun(M,MH,r,a,f) \<longleftrightarrow> M_is_recfun(M,MH',r',a',f')"
by (simp add: M_is_recfun_def)

lemma (in M_basic) is_wfrec_abs:
     "[| \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));
         relation2(M,MH,H);  M(r); M(a); M(z) |]
      ==> is_wfrec(M,MH,r,a,z) \<longleftrightarrow>
          (\<exists>g[M]. is_recfun(r,a,H,g) & z = H(a,g))"
by (simp add: is_wfrec_def relation2_def is_recfun_abs)

text\<open>Relating @{term wfrec_replacement} to native constructs\<close>
lemma (in M_basic) wfrec_replacement':
  "[|wfrec_replacement(M,MH,r);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));
     relation2(M,MH,H);  M(r)|]
   ==> strong_replacement(M, \<lambda>x z. \<exists>y[M].
                pair(M,x,y,z) & (\<exists>g[M]. is_recfun(r,x,H,g) & y = H(x,g)))"
by (simp add: wfrec_replacement_def is_wfrec_abs)

lemma wfrec_replacement_cong [cong]:
     "[| !!x y z. [| M(x); M(y); M(z) |] ==> MH(x,y,z) \<longleftrightarrow> MH'(x,y,z);
         r=r' |]
      ==> wfrec_replacement(M, %x y. MH(x,y), r) \<longleftrightarrow>
          wfrec_replacement(M, %x y. MH'(x,y), r')"
by (simp add: is_wfrec_def wfrec_replacement_def)

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Legacy aliases\<close>

theory Legacy_Aliases
  imports "HOL-Library.Word"
begin

context abstract_boolean_algebra
begin

lemma conj_assoc: "(x \<^bold>\<sqinter> y) \<^bold>\<sqinter> z = x \<^bold>\<sqinter> (y \<^bold>\<sqinter> z)"
  by (fact conj.assoc)

lemma conj_commute: "x \<^bold>\<sqinter> y = y \<^bold>\<sqinter> x"
  by (fact conj.commute)

lemmas conj_left_commute = conj.left_commute
lemmas conj_ac = conj.assoc conj.commute conj.left_commute

lemma conj_one_left: "\<^bold>1 \<^bold>\<sqinter> x = x"
  by (fact conj.left_neutral)

lemma conj_left_absorb: "x \<^bold>\<sqinter> (x \<^bold>\<sqinter> y) = x \<^bold>\<sqinter> y"
  by (fact conj.left_idem)

lemma conj_absorb: "x \<^bold>\<sqinter> x = x"
  by (fact conj.idem)

lemma disj_assoc: "(x \<^bold>\<squnion> y) \<^bold>\<squnion> z = x \<^bold>\<squnion> (y \<^bold>\<squnion> z)"
  by (fact disj.assoc)

lemma disj_commute: "x \<^bold>\<squnion> y = y \<^bold>\<squnion> x"
  by (fact disj.commute)

lemmas disj_left_commute = disj.left_commute

lemmas disj_ac = disj.assoc disj.commute disj.left_commute

lemma disj_zero_left: "\<^bold>0 \<^bold>\<squnion> x = x"
  by (fact disj.left_neutral)

lemma disj_left_absorb: "x \<^bold>\<squnion> (x \<^bold>\<squnion> y) = x \<^bold>\<squnion> y"
  by (fact disj.left_idem)

lemma disj_absorb: "x \<^bold>\<squnion> x = x"
  by (fact disj.idem)

end

context abstract_boolean_algebra_sym_diff
begin

lemmas xor_assoc = xor.assoc
lemmas xor_commute = xor.commute
lemmas xor_left_commute = xor.left_commute

lemmas xor_ac = xor.assoc xor.commute xor.left_commute

lemma xor_zero_right: "x \<^bold>\<ominus> \<^bold>0 = x"
  by (fact xor.comm_neutral)

lemma xor_zero_left: "\<^bold>0 \<^bold>\<ominus> x = x"
  by (fact xor.left_neutral)

end

abbreviation (input) test_bit :: \<open>'a::semiring_bits \<Rightarrow> nat \<Rightarrow> bool\<close>
  where \<open>test_bit \<equiv> bit\<close>

abbreviation (input) bin_nth :: \<open>int \<Rightarrow> nat \<Rightarrow> bool\<close>
  where \<open>bin_nth \<equiv> bit\<close>

abbreviation (input) bin_last :: \<open>int \<Rightarrow> bool\<close>
  where \<open>bin_last \<equiv> odd\<close>

abbreviation (input) bin_rest :: \<open>int \<Rightarrow> int\<close>
  where \<open>bin_rest w \<equiv> w div 2\<close>

abbreviation (input) bintrunc :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>bintrunc \<equiv> take_bit\<close>

abbreviation (input) sbintrunc :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>sbintrunc \<equiv> signed_take_bit\<close>

abbreviation (input) bin_cat :: \<open>int \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>bin_cat k n l \<equiv> concat_bit n l k\<close>

abbreviation (input) norm_sint :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>norm_sint n \<equiv> signed_take_bit (n - 1)\<close>

abbreviation (input) max_word :: \<open>'a::len word\<close>
  where \<open>max_word \<equiv> - 1\<close>

abbreviation (input) complement :: \<open>'a::len word \<Rightarrow> 'a word\<close>
  where \<open>complement \<equiv> not\<close>

lemma complement_mask:
  "complement (2 ^ n - 1) = not (mask n)"
  unfolding mask_eq_decr_exp by simp

context
  includes bit_operations_syntax
begin

abbreviation (input) bshiftr1 :: \<open>bool \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>
  where \<open>bshiftr1 b w \<equiv> w div 2 OR push_bit (LENGTH('a) - Suc 0) (of_bool b) \<close>

end

lemma bit_bshiftr1_iff:
  \<open>bit (bshiftr1 b w) n \<longleftrightarrow> b \<and> n = LENGTH('a) - 1 \<or> bit w (Suc n)\<close>
    for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps simp flip: bit_Suc)

abbreviation (input) setBit :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> 'a word\<close>
  where \<open>setBit w n \<equiv> set_bit n w\<close>

abbreviation (input) clearBit :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> 'a word\<close>
  where \<open>clearBit w n \<equiv> unset_bit n w\<close>

lemma bit_setBit_iff:
  \<open>bit (setBit w m) n \<longleftrightarrow> (m = n \<and> n < LENGTH('a) \<or> bit w n)\<close>
  for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps)

lemma bit_clearBit_iff:
  \<open>bit (clearBit w m) n \<longleftrightarrow> m \<noteq> n \<and> bit w n\<close>
  for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps)

lemmas less_def = less_eq [symmetric]
lemmas le_def = not_less [symmetric, where ?'a = nat]

end