(*  Title:      ZF/UNITY/UNITY.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section \<open>The Basic UNITY Theory\<close>

theory UNITY imports State begin

text\<open>The basic UNITY theory (revised version, based upon the "co" operator)
From Misra, "A Logic for Concurrent Programming", 1994.

This ZF theory was ported from its HOL equivalent.\<close>

definition
  program  :: i  where
  "program == {<init, acts, allowed>:
               Pow(state) * Pow(Pow(state*state)) * Pow(Pow(state*state)).
               id(state) \<in> acts & id(state) \<in> allowed}"

definition
  mk_program :: "[i,i,i]=>i"  where
  \<comment>\<open>The definition yields a program thanks to the coercions
       init \<inter> state, acts \<inter> Pow(state*state), etc.\<close>
  "mk_program(init, acts, allowed) ==
    <init \<inter> state, cons(id(state), acts \<inter> Pow(state*state)),
              cons(id(state), allowed \<inter> Pow(state*state))>"

definition
  SKIP :: i  ("\<bottom>") where
  "SKIP == mk_program(state, 0, Pow(state*state))"

  (* Coercion from anything to program *)
definition
  programify :: "i=>i"  where
  "programify(F) == if F \<in> program then F else SKIP"

definition
  RawInit :: "i=>i"  where
  "RawInit(F) == fst(F)"

definition
  Init :: "i=>i"  where
  "Init(F) == RawInit(programify(F))"

definition
  RawActs :: "i=>i"  where
  "RawActs(F) == cons(id(state), fst(snd(F)))"

definition
  Acts :: "i=>i"  where
  "Acts(F) == RawActs(programify(F))"

definition
  RawAllowedActs :: "i=>i"  where
  "RawAllowedActs(F) == cons(id(state), snd(snd(F)))"

definition
  AllowedActs :: "i=>i"  where
  "AllowedActs(F) == RawAllowedActs(programify(F))"

definition
  Allowed :: "i =>i"  where
  "Allowed(F) == {G \<in> program. Acts(G) \<subseteq> AllowedActs(F)}"

definition
  initially :: "i=>i"  where
  "initially(A) == {F \<in> program. Init(F)\<subseteq>A}"

definition "constrains" :: "[i, i] => i"  (infixl "co" 60)  where
  "A co B == {F \<in> program. (\<forall>act \<in> Acts(F). act``A\<subseteq>B) & st_set(A)}"
    \<comment>\<open>the condition @{term "st_set(A)"} makes the definition slightly
         stronger than the HOL one\<close>

definition unless :: "[i, i] => i"  (infixl "unless" 60)  where
  "A unless B == (A - B) co (A \<union> B)"

definition
  stable     :: "i=>i"  where
   "stable(A) == A co A"

definition
  strongest_rhs :: "[i, i] => i"  where
  "strongest_rhs(F, A) == \<Inter>({B \<in> Pow(state). F \<in> A co B})"

definition
  invariant :: "i => i"  where
  "invariant(A) == initially(A) \<inter> stable(A)"

  (* meta-function composition *)
definition
  metacomp :: "[i=>i, i=>i] => (i=>i)" (infixl "comp" 65)  where
  "f comp g == %x. f(g(x))"

definition
  pg_compl :: "i=>i"  where
  "pg_compl(X)== program - X"

text\<open>SKIP\<close>
lemma SKIP_in_program [iff,TC]: "SKIP \<in> program"
by (force simp add: SKIP_def program_def mk_program_def)

subsection\<open>The function @{term programify}, the coercion from anything to
 program\<close>

lemma programify_program [simp]: "F \<in> program ==> programify(F)=F"
by (force simp add: programify_def)

lemma programify_in_program [iff,TC]: "programify(F) \<in> program"
by (force simp add: programify_def)

text\<open>Collapsing rules: to remove programify from expressions\<close>
lemma programify_idem [simp]: "programify(programify(F))=programify(F)"
by (force simp add: programify_def)

lemma Init_programify [simp]: "Init(programify(F)) = Init(F)"
by (simp add: Init_def)

lemma Acts_programify [simp]: "Acts(programify(F)) = Acts(F)"
by (simp add: Acts_def)

lemma AllowedActs_programify [simp]:
     "AllowedActs(programify(F)) = AllowedActs(F)"
by (simp add: AllowedActs_def)

subsection\<open>The Inspectors for Programs\<close>

lemma id_in_RawActs: "F \<in> program ==>id(state) \<in> RawActs(F)"
by (auto simp add: program_def RawActs_def)

lemma id_in_Acts [iff,TC]: "id(state) \<in> Acts(F)"
by (simp add: id_in_RawActs Acts_def)

lemma id_in_RawAllowedActs: "F \<in> program ==>id(state) \<in> RawAllowedActs(F)"
by (auto simp add: program_def RawAllowedActs_def)

lemma id_in_AllowedActs [iff,TC]: "id(state) \<in> AllowedActs(F)"
by (simp add: id_in_RawAllowedActs AllowedActs_def)

lemma cons_id_Acts [simp]: "cons(id(state), Acts(F)) = Acts(F)"
by (simp add: cons_absorb)

lemma cons_id_AllowedActs [simp]:
     "cons(id(state), AllowedActs(F)) = AllowedActs(F)"
by (simp add: cons_absorb)

subsection\<open>Types of the Inspectors\<close>

lemma RawInit_type: "F \<in> program ==> RawInit(F)\<subseteq>state"
by (auto simp add: program_def RawInit_def)

lemma RawActs_type: "F \<in> program ==> RawActs(F)\<subseteq>Pow(state*state)"
by (auto simp add: program_def RawActs_def)

lemma RawAllowedActs_type:
     "F \<in> program ==> RawAllowedActs(F)\<subseteq>Pow(state*state)"
by (auto simp add: program_def RawAllowedActs_def)

lemma Init_type: "Init(F)\<subseteq>state"
by (simp add: RawInit_type Init_def)

lemmas InitD = Init_type [THEN subsetD]

lemma st_set_Init [iff]: "st_set(Init(F))"
apply (unfold st_set_def)
apply (rule Init_type)
done

lemma Acts_type: "Acts(F)\<subseteq>Pow(state*state)"
by (simp add: RawActs_type Acts_def)

lemma AllowedActs_type: "AllowedActs(F) \<subseteq> Pow(state*state)"
by (simp add: RawAllowedActs_type AllowedActs_def)

text\<open>Needed in Behaviors\<close>
lemma ActsD: "[| act \<in> Acts(F); <s,s'> \<in> act |] ==> s \<in> state & s' \<in> state"
by (blast dest: Acts_type [THEN subsetD])

lemma AllowedActsD:
     "[| act \<in> AllowedActs(F); <s,s'> \<in> act |] ==> s \<in> state & s' \<in> state"
by (blast dest: AllowedActs_type [THEN subsetD])

subsection\<open>Simplification rules involving @{term state}, @{term Init},
  @{term Acts}, and @{term AllowedActs}\<close>

text\<open>But are they really needed?\<close>

lemma state_subset_is_Init_iff [iff]: "state \<subseteq> Init(F) \<longleftrightarrow> Init(F)=state"
by (cut_tac F = F in Init_type, auto)

lemma Pow_state_times_state_is_subset_Acts_iff [iff]:
     "Pow(state*state) \<subseteq> Acts(F) \<longleftrightarrow> Acts(F)=Pow(state*state)"
by (cut_tac F = F in Acts_type, auto)

lemma Pow_state_times_state_is_subset_AllowedActs_iff [iff]:
     "Pow(state*state) \<subseteq> AllowedActs(F) \<longleftrightarrow> AllowedActs(F)=Pow(state*state)"
by (cut_tac F = F in AllowedActs_type, auto)

subsubsection\<open>Eliminating \<open>\<inter> state\<close> from expressions\<close>

lemma Init_Int_state [simp]: "Init(F) \<inter> state = Init(F)"
by (cut_tac F = F in Init_type, blast)

lemma state_Int_Init [simp]: "state \<inter> Init(F) = Init(F)"
by (cut_tac F = F in Init_type, blast)

lemma Acts_Int_Pow_state_times_state [simp]:
     "Acts(F) \<inter> Pow(state*state) = Acts(F)"
by (cut_tac F = F in Acts_type, blast)

lemma state_times_state_Int_Acts [simp]:
     "Pow(state*state) \<inter> Acts(F) = Acts(F)"
by (cut_tac F = F in Acts_type, blast)

lemma AllowedActs_Int_Pow_state_times_state [simp]:
     "AllowedActs(F) \<inter> Pow(state*state) = AllowedActs(F)"
by (cut_tac F = F in AllowedActs_type, blast)

lemma state_times_state_Int_AllowedActs [simp]:
     "Pow(state*state) \<inter> AllowedActs(F) = AllowedActs(F)"
by (cut_tac F = F in AllowedActs_type, blast)

subsubsection\<open>The Operator @{term mk_program}\<close>

lemma mk_program_in_program [iff,TC]:
     "mk_program(init, acts, allowed) \<in> program"
by (auto simp add: mk_program_def program_def)

lemma RawInit_eq [simp]:
     "RawInit(mk_program(init, acts, allowed)) = init \<inter> state"
by (auto simp add: mk_program_def RawInit_def)

lemma RawActs_eq [simp]:
     "RawActs(mk_program(init, acts, allowed)) =
      cons(id(state), acts \<inter> Pow(state*state))"
by (auto simp add: mk_program_def RawActs_def)

lemma RawAllowedActs_eq [simp]:
     "RawAllowedActs(mk_program(init, acts, allowed)) =
      cons(id(state), allowed \<inter> Pow(state*state))"
by (auto simp add: mk_program_def RawAllowedActs_def)

lemma Init_eq [simp]: "Init(mk_program(init, acts, allowed)) = init \<inter> state"
by (simp add: Init_def)

lemma Acts_eq [simp]:
     "Acts(mk_program(init, acts, allowed)) =
      cons(id(state), acts  \<inter> Pow(state*state))"
by (simp add: Acts_def)

lemma AllowedActs_eq [simp]:
     "AllowedActs(mk_program(init, acts, allowed))=
      cons(id(state), allowed \<inter> Pow(state*state))"
by (simp add: AllowedActs_def)

text\<open>Init, Acts, and AlowedActs  of SKIP\<close>

lemma RawInit_SKIP [simp]: "RawInit(SKIP) = state"
by (simp add: SKIP_def)

lemma RawAllowedActs_SKIP [simp]: "RawAllowedActs(SKIP) = Pow(state*state)"
by (force simp add: SKIP_def)

lemma RawActs_SKIP [simp]: "RawActs(SKIP) = {id(state)}"
by (force simp add: SKIP_def)

lemma Init_SKIP [simp]: "Init(SKIP) = state"
by (force simp add: SKIP_def)

lemma Acts_SKIP [simp]: "Acts(SKIP) = {id(state)}"
by (force simp add: SKIP_def)

lemma AllowedActs_SKIP [simp]: "AllowedActs(SKIP) = Pow(state*state)"
by (force simp add: SKIP_def)

text\<open>Equality of UNITY programs\<close>

lemma raw_surjective_mk_program:
     "F \<in> program ==> mk_program(RawInit(F), RawActs(F), RawAllowedActs(F))=F"
apply (auto simp add: program_def mk_program_def RawInit_def RawActs_def
            RawAllowedActs_def, blast+)
done

lemma surjective_mk_program [simp]:
  "mk_program(Init(F), Acts(F), AllowedActs(F)) = programify(F)"
by (auto simp add: raw_surjective_mk_program Init_def Acts_def AllowedActs_def)

lemma program_equalityI:
    "[|Init(F) = Init(G); Acts(F) = Acts(G);
       AllowedActs(F) = AllowedActs(G); F \<in> program; G \<in> program |] ==> F = G"
apply (subgoal_tac "programify(F) = programify(G)")
apply simp
apply (simp only: surjective_mk_program [symmetric])
done

lemma program_equalityE:
 "[|F = G;
    [|Init(F) = Init(G); Acts(F) = Acts(G); AllowedActs(F) = AllowedActs(G) |]
    ==> P |]
  ==> P"
by force

lemma program_equality_iff:
    "[| F \<in> program; G \<in> program |] ==>(F=G)  \<longleftrightarrow>
     (Init(F) = Init(G) & Acts(F) = Acts(G) & AllowedActs(F) = AllowedActs(G))"
by (blast intro: program_equalityI program_equalityE)

subsection\<open>These rules allow "lazy" definition expansion\<close>

lemma def_prg_Init:
     "F == mk_program (init,acts,allowed) ==> Init(F) = init \<inter> state"
by auto

lemma def_prg_Acts:
     "F == mk_program (init,acts,allowed)
      ==> Acts(F) = cons(id(state), acts \<inter> Pow(state*state))"
by auto

lemma def_prg_AllowedActs:
     "F == mk_program (init,acts,allowed)
      ==> AllowedActs(F) = cons(id(state), allowed \<inter> Pow(state*state))"
by auto

lemma def_prg_simps:
    "[| F == mk_program (init,acts,allowed) |]
     ==> Init(F) = init \<inter> state &
         Acts(F) = cons(id(state), acts \<inter> Pow(state*state)) &
         AllowedActs(F) = cons(id(state), allowed \<inter> Pow(state*state))"
by auto

text\<open>An action is expanded only if a pair of states is being tested against it\<close>
lemma def_act_simp:
     "[| act == {<s,s'> \<in> A*B. P(s, s')} |]
      ==> (<s,s'> \<in> act) \<longleftrightarrow> (<s,s'> \<in> A*B & P(s, s'))"
by auto

text\<open>A set is expanded only if an element is being tested against it\<close>
lemma def_set_simp: "A == B ==> (x \<in> A) \<longleftrightarrow> (x \<in> B)"
by auto

subsection\<open>The Constrains Operator\<close>

lemma constrains_type: "A co B \<subseteq> program"
by (force simp add: constrains_def)

lemma constrainsI:
    "[|(!!act s s'. [| act: Acts(F);  <s,s'> \<in> act; s \<in> A|] ==> s' \<in> A');
        F \<in> program; st_set(A) |]  ==> F \<in> A co A'"
by (force simp add: constrains_def)

lemma constrainsD:
   "F \<in> A co B ==> \<forall>act \<in> Acts(F). act``A\<subseteq>B"
by (force simp add: constrains_def)

lemma constrainsD2: "F \<in> A co B ==> F \<in> program & st_set(A)"
by (force simp add: constrains_def)

lemma constrains_empty [iff]: "F \<in> 0 co B \<longleftrightarrow> F \<in> program"
by (force simp add: constrains_def st_set_def)

lemma constrains_empty2 [iff]: "(F \<in> A co 0) \<longleftrightarrow> (A=0 & F \<in> program)"
by (force simp add: constrains_def st_set_def)

lemma constrains_state [iff]: "(F \<in> state co B) \<longleftrightarrow> (state\<subseteq>B & F \<in> program)"
apply (cut_tac F = F in Acts_type)
apply (force simp add: constrains_def st_set_def)
done

lemma constrains_state2 [iff]: "F \<in> A co state \<longleftrightarrow> (F \<in> program & st_set(A))"
apply (cut_tac F = F in Acts_type)
apply (force simp add: constrains_def st_set_def)
done

text\<open>monotonic in 2nd argument\<close>
lemma constrains_weaken_R:
    "[| F \<in> A co A'; A'\<subseteq>B' |] ==> F \<in> A co B'"
apply (unfold constrains_def, blast)
done

text\<open>anti-monotonic in 1st argument\<close>
lemma constrains_weaken_L:
    "[| F \<in> A co A'; B\<subseteq>A |] ==> F \<in> B co A'"
apply (unfold constrains_def st_set_def, blast)
done

lemma constrains_weaken:
   "[| F \<in> A co A'; B\<subseteq>A; A'\<subseteq>B' |] ==> F \<in> B co B'"
apply (drule constrains_weaken_R)
apply (drule_tac [2] constrains_weaken_L, blast+)
done

subsection\<open>Constrains and Union\<close>

lemma constrains_Un:
    "[| F \<in> A co A'; F \<in> B co B' |] ==> F \<in> (A \<union> B) co (A' \<union> B')"
by (auto simp add: constrains_def st_set_def, force)

lemma constrains_UN:
     "[|!!i. i \<in> I ==> F \<in> A(i) co A'(i); F \<in> program |]
      ==> F \<in> (\<Union>i \<in> I. A(i)) co (\<Union>i \<in> I. A'(i))"
by (force simp add: constrains_def st_set_def)

lemma constrains_Un_distrib:
     "(A \<union> B) co C = (A co C) \<inter> (B co C)"
by (force simp add: constrains_def st_set_def)

lemma constrains_UN_distrib:
   "i \<in> I ==> (\<Union>i \<in> I. A(i)) co B = (\<Inter>i \<in> I. A(i) co B)"
by (force simp add: constrains_def st_set_def)

subsection\<open>Constrains and Intersection\<close>

lemma constrains_Int_distrib: "C co (A \<inter> B) = (C co A) \<inter> (C co B)"
by (force simp add: constrains_def st_set_def)

lemma constrains_INT_distrib:
     "x \<in> I ==> A co (\<Inter>i \<in> I. B(i)) = (\<Inter>i \<in> I. A co B(i))"
by (force simp add: constrains_def st_set_def)

lemma constrains_Int:
    "[| F \<in> A co A'; F \<in> B co B' |] ==> F \<in> (A \<inter> B) co (A' \<inter> B')"
by (force simp add: constrains_def st_set_def)

lemma constrains_INT [rule_format]:
     "[| \<forall>i \<in> I. F \<in> A(i) co A'(i); F \<in> program|]
      ==> F \<in> (\<Inter>i \<in> I. A(i)) co (\<Inter>i \<in> I. A'(i))"
apply (case_tac "I=0")
 apply (simp add: Inter_def)
apply (erule not_emptyE)
apply (auto simp add: constrains_def st_set_def, blast)
apply (drule bspec, assumption, force)
done

(* The rule below simulates the HOL's one for (\<Inter>z. A i) co (\<Inter>z. B i) *)
lemma constrains_All:
"[| \<forall>z. F:{s \<in> state. P(s, z)} co {s \<in> state. Q(s, z)}; F \<in> program |]==>
    F:{s \<in> state. \<forall>z. P(s, z)} co {s \<in> state. \<forall>z. Q(s, z)}"
by (unfold constrains_def, blast)

lemma constrains_imp_subset:
  "[| F \<in> A co A' |] ==> A \<subseteq> A'"
by (unfold constrains_def st_set_def, force)

text\<open>The reasoning is by subsets since "co" refers to single actions
  only.  So this rule isn't that useful.\<close>

lemma constrains_trans: "[| F \<in> A co B; F \<in> B co C |] ==> F \<in> A co C"
by (unfold constrains_def st_set_def, auto, blast)

lemma constrains_cancel:
"[| F \<in> A co (A' \<union> B); F \<in> B co B' |] ==> F \<in> A co (A' \<union> B')"
apply (drule_tac A = B in constrains_imp_subset)
apply (blast intro: constrains_weaken_R)
done

subsection\<open>The Unless Operator\<close>

lemma unless_type: "A unless B \<subseteq> program"
by (force simp add: unless_def constrains_def)

lemma unlessI: "[| F \<in> (A-B) co (A \<union> B) |] ==> F \<in> A unless B"
apply (unfold unless_def)
apply (blast dest: constrainsD2)
done

lemma unlessD: "F :A unless B ==> F \<in> (A-B) co (A \<union> B)"
by (unfold unless_def, auto)

subsection\<open>The Operator @{term initially}\<close>

lemma initially_type: "initially(A) \<subseteq> program"
by (unfold initially_def, blast)

lemma initiallyI: "[| F \<in> program; Init(F)\<subseteq>A |] ==> F \<in> initially(A)"
by (unfold initially_def, blast)

lemma initiallyD: "F \<in> initially(A) ==> Init(F)\<subseteq>A"
by (unfold initially_def, blast)

subsection\<open>The Operator @{term stable}\<close>

lemma stable_type: "stable(A)\<subseteq>program"
by (unfold stable_def constrains_def, blast)

lemma stableI: "F \<in> A co A ==> F \<in> stable(A)"
by (unfold stable_def, assumption)

lemma stableD: "F \<in> stable(A) ==> F \<in> A co A"
by (unfold stable_def, assumption)

lemma stableD2: "F \<in> stable(A) ==> F \<in> program & st_set(A)"
by (unfold stable_def constrains_def, auto)

lemma stable_state [simp]: "stable(state) = program"
by (auto simp add: stable_def constrains_def dest: Acts_type [THEN subsetD])

lemma stable_unless: "stable(A)= A unless 0"
by (auto simp add: unless_def stable_def)

subsection\<open>Union and Intersection with @{term stable}\<close>

lemma stable_Un:
    "[| F \<in> stable(A); F \<in> stable(A') |] ==> F \<in> stable(A \<union> A')"
apply (unfold stable_def)
apply (blast intro: constrains_Un)
done

lemma stable_UN:
     "[|!!i. i\<in>I ==> F \<in> stable(A(i)); F \<in> program |]
      ==> F \<in> stable (\<Union>i \<in> I. A(i))"
apply (unfold stable_def)
apply (blast intro: constrains_UN)
done

lemma stable_Int:
    "[| F \<in> stable(A);  F \<in> stable(A') |] ==> F \<in> stable (A \<inter> A')"
apply (unfold stable_def)
apply (blast intro: constrains_Int)
done

lemma stable_INT:
     "[| !!i. i \<in> I ==> F \<in> stable(A(i)); F \<in> program |]
      ==> F \<in> stable (\<Inter>i \<in> I. A(i))"
apply (unfold stable_def)
apply (blast intro: constrains_INT)
done

lemma stable_All:
    "[|\<forall>z. F \<in> stable({s \<in> state. P(s, z)}); F \<in> program|]
     ==> F \<in> stable({s \<in> state. \<forall>z. P(s, z)})"
apply (unfold stable_def)
apply (rule constrains_All, auto)
done

lemma stable_constrains_Un:
     "[| F \<in> stable(C); F \<in> A co (C \<union> A') |] ==> F \<in> (C \<union> A) co (C \<union> A')"
apply (unfold stable_def constrains_def st_set_def, auto)
apply (blast dest!: bspec)
done

lemma stable_constrains_Int:
     "[| F \<in> stable(C); F \<in>  (C \<inter> A) co A' |] ==> F \<in> (C \<inter> A) co (C \<inter> A')"
by (unfold stable_def constrains_def st_set_def, blast)

(* [| F \<in> stable(C); F  \<in> (C \<inter> A) co A |] ==> F \<in> stable(C \<inter> A) *)
lemmas stable_constrains_stable = stable_constrains_Int [THEN stableI]

subsection\<open>The Operator @{term invariant}\<close>

lemma invariant_type: "invariant(A) \<subseteq> program"
apply (unfold invariant_def)
apply (blast dest: stable_type [THEN subsetD])
done

lemma invariantI: "[| Init(F)\<subseteq>A;  F \<in> stable(A) |] ==> F \<in> invariant(A)"
apply (unfold invariant_def initially_def)
apply (frule stable_type [THEN subsetD], auto)
done

lemma invariantD: "F \<in> invariant(A) ==> Init(F)\<subseteq>A & F \<in> stable(A)"
by (unfold invariant_def initially_def, auto)

lemma invariantD2: "F \<in> invariant(A) ==> F \<in> program & st_set(A)"
apply (unfold invariant_def)
apply (blast dest: stableD2)
done

text\<open>Could also say
      @{term "invariant(A) \<inter> invariant(B) \<subseteq> invariant (A \<inter> B)"}\<close>
lemma invariant_Int:
  "[| F \<in> invariant(A);  F \<in> invariant(B) |] ==> F \<in> invariant(A \<inter> B)"
apply (unfold invariant_def initially_def)
apply (simp add: stable_Int, blast)
done

subsection\<open>The Elimination Theorem\<close>

(** The "free" m has become universally quantified!
 Should the premise be !!m instead of \<forall>m ? Would make it harder
 to use in forward proof. **)

text\<open>The general case is easier to prove than the special case!\<close>
lemma "elimination":
    "[| \<forall>m \<in> M. F \<in> {s \<in> A. x(s) = m} co B(m); F \<in> program  |]
     ==> F \<in> {s \<in> A. x(s) \<in> M} co (\<Union>m \<in> M. B(m))"
by (auto simp add: constrains_def st_set_def, blast)

text\<open>As above, but for the special case of A=state\<close>
lemma elimination2:
     "[| \<forall>m \<in> M. F \<in> {s \<in> state. x(s) = m} co B(m); F \<in> program  |]
     ==> F:{s \<in> state. x(s) \<in> M} co (\<Union>m \<in> M. B(m))"
by (rule UNITY.elimination, auto)

subsection\<open>The Operator @{term strongest_rhs}\<close>

lemma constrains_strongest_rhs:
    "[| F \<in> program; st_set(A) |] ==> F \<in> A co (strongest_rhs(F,A))"
by (auto simp add: constrains_def strongest_rhs_def st_set_def
              dest: Acts_type [THEN subsetD])

lemma strongest_rhs_is_strongest:
     "[| F \<in> A co B; st_set(B) |] ==> strongest_rhs(F,A) \<subseteq> B"
by (auto simp add: constrains_def strongest_rhs_def st_set_def)

ML \<open>
fun simp_of_act def = def RS @{thm def_act_simp};
fun simp_of_set def = def RS @{thm def_set_simp};
\<close>

end


section \<open> Imperative Programs \<close>

theory utp_prog
  imports "UTP1-Designs.utp_designs" "UTP1-Memory.utp_memory"
begin recall_syntax

subsection \<open> Program Type \<close>

typedef '\<alpha> prog = "{P :: '\<alpha> hrel_des. P is \<^bold>N}"
  by (rule_tac x="\<bottom>\<^sub>D" in exI, simp add: closure)

named_theorems prog_rep_eq and prog_defs

notation Rep_prog ("\<lbrakk>_\<rbrakk>\<^sub>P")

lemma Rep_prog_H1_H3_closed [closure]: "\<lbrakk>P\<rbrakk>\<^sub>P is \<^bold>N"
  using Rep_prog by auto

lemma Rep_prog_split: "\<lbrakk> \<And> pre post. Q(pre \<turnstile>\<^sub>n post) \<rbrakk> \<Longrightarrow> Q(\<lbrakk>P\<rbrakk>\<^sub>P)"
  by (simp add: Rep_prog_H1_H3_closed ndes_split)

lemma Rep_prog_comp [prog_rep_eq]:
  "(Rep_prog \<circ> (\<lambda> i. P(i))) = (\<lambda> i. \<lbrakk>P(i)\<rbrakk>\<^sub>P)"
  by (auto)

setup_lifting type_definition_prog

instantiation prog :: (type) refine
begin
  lift_definition less_eq_prog :: "'a prog \<Rightarrow> 'a prog \<Rightarrow> bool" is
  "(\<le>)" .
  lift_definition less_prog :: "'a prog \<Rightarrow> 'a prog \<Rightarrow> bool" is
  "(<)" .
  instance by (intro_classes, (transfer, simp add: less_uexpr_def)+)
end

lemma Rep_prog_refine [prog_rep_eq]:
  "P \<sqsubseteq> Q \<longleftrightarrow> \<lbrakk>P\<rbrakk>\<^sub>P \<sqsubseteq> \<lbrakk>Q\<rbrakk>\<^sub>P"
  by (simp add: less_eq_prog.rep_eq)

lemma Rep_prog_eq [prog_rep_eq]:
  "P = Q \<longleftrightarrow> \<lbrakk>P\<rbrakk>\<^sub>P = \<lbrakk>Q\<rbrakk>\<^sub>P"
  by (metis Rep_prog_inverse)

method ptransfer = (simp add: prog_rep_eq)

subsection \<open> Operators \<close>

instantiation prog :: (type) lattice
begin
  lift_definition inf_prog :: "'\<alpha> prog \<Rightarrow> '\<alpha> prog \<Rightarrow> '\<alpha> prog" is "(\<squnion>)" by (simp add: closure)
  lift_definition sup_prog :: "'\<alpha> prog \<Rightarrow> '\<alpha> prog \<Rightarrow> '\<alpha> prog" is "(\<sqinter>)" by (simp add: closure)
instance by (intro_classes; (transfer, rel_simp))
end

instantiation prog :: (type) bounded_lattice
begin
  lift_definition top_prog :: "'\<alpha> prog" is "\<bottom>\<^sub>D" by (simp add: closure)
  lift_definition bot_prog :: "'\<alpha> prog" is "\<top>\<^sub>D" by (simp add: closure)
instance
  apply (intro_classes; transfer)
  apply (metis H1_below_top Healthy_def)
  apply (simp add: bot_d_true)
  done
end

abbreviation abort :: "'\<alpha> prog" where "abort \<equiv> \<bottom>"
abbreviation magic :: "'\<alpha> prog" where "magic \<equiv> \<top>"

lift_definition skip     :: "'\<alpha> prog" is "II\<^sub>D" by (simp add: closure)
lift_definition pseq     :: "'\<alpha> prog \<Rightarrow> '\<alpha> prog \<Rightarrow> '\<alpha> prog" is "(;;)" by (simp add: closure)
lift_definition passigns :: "'\<alpha> usubst \<Rightarrow> '\<alpha> prog" ("\<langle>_\<rangle>\<^sub>p") is "assigns_d" by (simp add: closure)
lift_definition psubst   :: "'\<alpha> usubst \<Rightarrow> '\<alpha> prog \<Rightarrow> '\<alpha> prog" is "\<lambda> \<sigma> P. ((\<sigma> \<oplus>\<^sub>s \<Sigma>\<^sub>D) \<oplus>\<^sub>s in\<alpha>) \<dagger> P" by (simp add: closure)
lift_definition paltern  :: "'a set \<Rightarrow> ('a \<Rightarrow> '\<alpha> upred) \<Rightarrow> ('a \<Rightarrow> '\<alpha> prog) \<Rightarrow> '\<alpha> prog \<Rightarrow> '\<alpha> prog" is AlternateD by (simp add: closure)
lift_definition paltern_list  :: "('\<alpha> upred \<times> '\<alpha> prog) list \<Rightarrow> '\<alpha> prog \<Rightarrow> '\<alpha> prog" is AlternateD_list
  by (simp add: AlternateD_list_def list_all_def pred_prod_beta closure)
     (metis (no_types) AlternateD_H1_H3_closed atLeastLessThan_iff nth_map nth_mem)

lift_definition piterate :: "'a set \<Rightarrow> ('a \<Rightarrow> '\<alpha> upred) \<Rightarrow> ('a \<Rightarrow> '\<alpha> prog) \<Rightarrow> '\<alpha> prog" is IterateD by (simp add: closure)
lift_definition piterate_list :: "('\<alpha> upred \<times> '\<alpha> prog) list \<Rightarrow> '\<alpha> prog" is IterateD_list
  by (simp add: IterateD_list_def list_all_def pred_prod_beta closure)
     (metis IterateD_H1_H3_closed atLeastLessThan_iff nth_mem)

lift_definition plocal :: "'a::countable itself \<Rightarrow> (('a \<Longrightarrow> 'b clocal) \<Rightarrow> 'b clocal prog) \<Rightarrow> 'b clocal prog" is
  "\<lambda> t. utp_local_state.var_scope \<L>\<^sub>D['a::countable]" by (simp add: closure)

declare inf_prog.rep_eq [prog_rep_eq]
declare sup_prog.rep_eq [prog_rep_eq]
declare top_prog.rep_eq [prog_rep_eq]
declare bot_prog.rep_eq [prog_rep_eq]
declare skip.rep_eq [prog_rep_eq]
declare pseq.rep_eq [prog_rep_eq]
declare passigns.rep_eq [prog_rep_eq]
declare psubst.rep_eq [prog_rep_eq]
declare paltern.rep_eq [prog_rep_eq]
declare paltern_list.rep_eq [prog_rep_eq]
declare piterate.rep_eq [prog_rep_eq]
declare piterate_list.rep_eq [prog_rep_eq]
declare plocal.rep_eq [prog_rep_eq]

subsection \<open> Syntax Translations \<close>

adhoc_overloading
  useq pseq and
  usubst psubst and
  uassigns passigns and
  ualtern paltern and
  ualtern_list paltern_list and
  uiterate piterate and
  uiterate_list piterate_list

no_adhoc_overloading
  useq seqr

translations
  "_assignment xs vs" => "CONST passigns (_mk_usubst id\<^sub>s xs vs)"
  "x := v" <= "CONST passigns (CONST subst_upd id\<^sub>s (CONST pr_var x) v)"
  "_altgcomm (_gcomm_show cs)" <= "CONST ualtern_list cs (CONST abort)"

no_translations
  "_rel_var_scope x P" => "_var_scope R\<^sub>l x P"
  "_rel_var_scope_type x t P" => "_var_scope_type (_rel_local_state_type t) x t P"

translations
  "var x :: 'a \<bullet> P" == "CONST plocal TYPE('a) (\<lambda> x. P)"

subsection \<open> Proof Tactics \<close>

method pauto   = ((simp add: prog_defs)?, ptransfer, rel_auto)
method prefine = ((simp add: prog_defs)?, ptransfer, ndes_refine)
method peq     = ((simp add: prog_defs)?, ptransfer, ndes_eq)

method prefine' = ((simp add: prog_defs)?, transfer, ndes_refine)
method peq'     = ((simp add: prog_defs)?, transfer, ndes_eq)

subsection \<open> Substitution Laws \<close>

lemma psubst_seq [usubst]:
  "\<sigma> \<dagger> (P ;; Q) = (\<sigma> \<dagger> P) ;; Q"
  by pauto

lemma psubst_assigns [usubst]:
  "\<sigma> \<dagger> \<langle>\<rho>\<rangle>\<^sub>p = \<langle>\<rho> \<circ>\<^sub>s \<sigma>\<rangle>\<^sub>p"
  by pauto

lemma psubst_binary_altern [usubst]:
  fixes P Q :: "'\<alpha> prog"
  shows "\<sigma> \<dagger> (if b \<rightarrow> P else Q fi) = (if (\<sigma> \<dagger> b) \<rightarrow> (\<sigma> \<dagger> P) else (\<sigma> \<dagger> Q) fi)"
  by (pauto)

subsection \<open> Laws of Programming \<close>

theorem skip_left_unit [simp]:
  "skip ;; P = P"
  by (peq')

theorem skip_right_unit [simp]:
  "P ;; skip = P"
  by (peq')

theorem abort_left_zero [simp]:
  "abort ;; P = abort"
  by (peq')

theorem magic_left_zero [simp]:
  "magic ;; P = magic"
  by (peq')

lemma passigns_comp: "\<langle>\<sigma>\<rangle>\<^sub>p ;; P = \<sigma> \<dagger> P"
  by (transfer, rel_blast)

end


section "Linux Router"
theory Linux_Router
imports
	Routing_Table
	Simple_Firewall.SimpleFw_Semantics
	Simple_Firewall.Simple_Packet
	"HOL-Library.Monad_Syntax"
begin

definition "fromMaybe a m = (case m of Some a \<Rightarrow> a | None \<Rightarrow> a)" (* mehr Haskell wagen *)

text\<open>Here, we present a heavily simplified model of a linux router.
(i.e., a linux-based device with \texttt{net.ipv4.ip\_forward})
It covers the following steps in packet processing:
\begin{itemize}
 \item Packet arrives (destination port is empty, destination mac address is own address).
 \item Destination address is extracted and used for a routing table lookup.
 \item Packet is updated with output interface of routing decision.
 \item The FORWARD chain of iptables is considered.
 \item Next hop is extracted from the routing decision, fallback to destination address if directly attached.
 \item MAC address of next hop is looked up (using the mac lookup function mlf)
 \item L2 destination address of packet is updated.
\end{itemize}
This is stripped down to model only the most important and widely used aspects of packet processing.
Here are a few examples of what was abstracted away:
\begin{itemize}
 \item No local traffic.
 \item Only the \texttt{filter} table of iptables is considered, \texttt{raw} and \texttt{nat} are not.
 \item Only one routing table is considered. (Linux can have other tables than the \texttt{default} one.)
 \item No source MAC modification.
 \item \ldots
\end{itemize}
\<close>

record interface =
	iface_name :: string
	iface_mac :: "48 word"
	(*iface_ips :: "(ipv4addr \<times> 32 prefix_match) set" (* there is a set of IP addresses and the reachable subnets for them *), but we don't use that right now, so it is commented out.
	Also, part of that information is already in the routing table, so careful here... *)

definition iface_packet_check ::  "interface list \<Rightarrow>('i::len,'b) simple_packet_ext_scheme \<Rightarrow> interface option"
where "iface_packet_check ifs p \<equiv> find (\<lambda>i. iface_name i = p_iiface p \<and> iface_mac i = p_l2dst p) ifs"
term simple_fw
definition simple_linux_router ::
  "'i routing_rule list \<Rightarrow> 'i simple_rule list \<Rightarrow> (('i::len) word \<Rightarrow> 48 word option) \<Rightarrow>
         interface list \<Rightarrow> 'i simple_packet_ext \<Rightarrow> 'i simple_packet_ext option" where
"simple_linux_router rt fw mlf ifl p \<equiv> do {
	_ \<leftarrow> iface_packet_check ifl p;
	let rd \<comment> \<open>(routing decision)\<close> = routing_table_semantics rt (p_dst p);
	let p = p\<lparr>p_oiface := output_iface rd\<rparr>;
	let fd \<comment> \<open>(firewall decision)\<close> = simple_fw fw p;
	_ \<leftarrow> (case fd of Decision FinalAllow \<Rightarrow> Some () | Decision FinalDeny \<Rightarrow> None);
	let nh = fromMaybe (p_dst p) (next_hop rd);
	ma \<leftarrow> mlf nh;
	Some (p\<lparr>p_l2dst := ma\<rparr>)
}"
(* Can I find something that looks a bit more semantic. Maybe the option monad can reduce a bit of the foo? *)
(* TODO: What happens in linux, if I send a packet to an interface with the mac of another interface? Hopefully, that is going to be dropped? *)

text\<open>However, the above model is still too powerful for some use-cases.
Especially, the next hop look-up cannot be done without either a pre-distributed table of all MAC addresses,
or the usual mechanic of sending out an ARP request and caching the answer.
Doing ARP requests in the restricted environment of, e.g., an OpenFlow ruleset seems impossible.
Therefore, we present this model:\<close>
definition simple_linux_router_nol12 ::
    "'i routing_rule list \<Rightarrow> 'i simple_rule list \<Rightarrow> ('i,'a) simple_packet_scheme \<Rightarrow> ('i::len,'a) simple_packet_scheme option" where
"simple_linux_router_nol12 rt fw p \<equiv> do {
	let rd = routing_table_semantics rt (p_dst p);
	let p = p\<lparr>p_oiface := output_iface rd\<rparr>;
	let fd = simple_fw fw p;
	_ \<leftarrow> (case fd of Decision FinalAllow \<Rightarrow> Some () | Decision FinalDeny \<Rightarrow> None);
	Some p
}"
text\<open>The differences to @{const simple_linux_router} are illustrated by the lemmata below.\<close>
(* an alternative formulation would maybe be "if the routing decision for the source is the same as for the destination, don't forward it."
   This might be advantageous in $cases, however, this formulation is clearly easier to translate to openflow. *)

lemma rtr_nomac_e1:
  fixes pi
	assumes "simple_linux_router rt fw mlf ifl pi = Some po"
	assumes "simple_linux_router_nol12 rt fw pi = Some po'"
	shows "\<exists>x. po = po'\<lparr>p_l2dst := x\<rparr>"
using assms
unfolding simple_linux_router_nol12_def simple_linux_router_def
by(simp add: Let_def split: option.splits state.splits final_decision.splits Option.bind_splits if_splits) blast+

lemma rtr_nomac_e2:
  fixes pi
	assumes "simple_linux_router rt fw mlf ifl pi = Some po"
	shows "\<exists>po'. simple_linux_router_nol12 rt fw pi = Some po'"
using assms
unfolding simple_linux_router_nol12_def simple_linux_router_def
by(clarsimp simp add: Let_def split: option.splits state.splits final_decision.splits Option.bind_splits if_splits)

lemma rtr_nomac_e3:
  fixes pi
	assumes "simple_linux_router_nol12 rt fw pi = Some po"
	assumes "iface_packet_check ifl pi = Some i \<comment> \<open>don't care\<close>"
	assumes "mlf (fromMaybe (p_dst pi) (next_hop (routing_table_semantics rt (p_dst pi)))) = Some i2"
	shows "\<exists>po'. simple_linux_router rt fw mlf ifl pi = Some po'"
using assms
unfolding simple_linux_router_nol12_def simple_linux_router_def
by(clarsimp simp add: Let_def split: option.splits state.splits final_decision.splits Option.bind_splits if_splits)

lemma rtr_nomac_eq:
  fixes pi
	assumes "iface_packet_check ifl pi \<noteq> None"
	assumes "mlf (fromMaybe (p_dst pi) (next_hop (routing_table_semantics rt (p_dst pi)))) \<noteq> None"
	shows "\<exists>x. map_option (\<lambda>p. p\<lparr>p_l2dst := x\<rparr>) (simple_linux_router_nol12 rt fw pi) = simple_linux_router rt fw mlf ifl pi"
proof(cases "simple_linux_router_nol12 rt fw pi"; cases "simple_linux_router rt fw mlf ifl pi")
	fix a b
	assume as: "simple_linux_router rt fw mlf ifl pi = Some b" "simple_linux_router_nol12 rt fw pi = Some a"
	note rtr_nomac_e1[OF this]
	with as show ?thesis by auto
next
	fix a assume as: "simple_linux_router_nol12 rt fw pi = None" "simple_linux_router rt fw mlf ifl pi = Some a"
	note rtr_nomac_e2[OF as(2)]
	with as(1) have False by simp
	thus ?thesis ..
next
	fix a assume as: "simple_linux_router_nol12 rt fw pi = Some a" "simple_linux_router rt fw mlf ifl pi = None"
	from \<open>iface_packet_check ifl pi \<noteq> None\<close> obtain i3 where "iface_packet_check ifl pi = Some i3" by blast
	note rtr_nomac_e3[OF as(1) this] assms(2)
	with as(2) have False by force
	thus ?thesis ..
qed simp

end


(*<*)
theory AxiomaticCategoryTheory imports Main

abbrevs
 f_neg="\<^bold>\<not>" and f_or="\<^bold>\<or>" and f_and="\<^bold>\<and>" and f_impl="\<^bold>\<rightarrow>" and f_imp="\<^bold>\<leftarrow>" and mequ="\<^bold>\<leftrightarrow>" and f_all="\<^bold>\<forall>"
 and f_exi="\<^bold>\<exists>" and f_all2="(\<^bold>\<forall>x.)" and f_exi2="(\<^bold>\<exists>x.)" and f_kleeneeq="\<cong>" and f_primeq="\<simeq>" and
 f_comp2="(\<cdot>)" and f_comp="\<cdot>"

begin
 (*Begin: some useful parameter settings*)
  declare [[ smt_solver = cvc4, smt_oracle = true ]]
  nitpick_params[user_axioms, show_all, format = 2, expect = genuine]
  sledgehammer_params[overlord]
 (*End: some useful parameter settings*)
(*>*)

section\<open>Introduction\<close>

  text\<open>This document provides a concise overview on the core results of our previous
       work @{cite "C67,R58,C57"} on the exploration of axiom systems for category theory.
       Extending the previous studies we
       include one further axiomatic theory in our experiments. This additional
       theory has been suggested by Mac Lane~@{cite "MacLane48"} in
       1948. We show that the axioms proposed by Mac Lane are equivalent to the ones studied
       in~@{cite "R58"}, which includes an axioms set suggested by Scott~@{cite "Scott79"}
       in the 1970s and another axioms set proposed by Freyd and Scedrov~@{cite "FreydScedrov90"} in 1990,
       which we slightly modified in~@{cite "R58"} to remedy a minor technical issue.

      The explanations given below are minimal, for more details we refer to the referenced
      papers, in particular, to~@{cite "R58"}.\<close>

section\<open>Embedding of Free Logic in HOL\<close>

text\<open>We introduce a shallow semantical embedding of free logic @{cite "R58"} in Isabelle/HOL.
     Definite description is omitted, since it is not needed in the studies below and also
     since the definition provided in @{cite "C57"} introduces the here undesired commitment
     that at least one non-existing element of type $i$ is a priori given. We here want to
     consider this an optional condition.\<close>

 typedecl i \<comment> \<open>Type for individuals\<close>
 consts fExistence:: "i\<Rightarrow>bool" ("E") \<comment> \<open>Existence/definedness predicate in free logic\<close>

 abbreviation fNot   ("\<^bold>\<not>")               where "\<^bold>\<not>\<phi> \<equiv> \<not>\<phi>"
 abbreviation fImpl  (infixr "\<^bold>\<rightarrow>" 13)  where "\<phi> \<^bold>\<rightarrow> \<psi> \<equiv> \<phi> \<longrightarrow> \<psi>"
 abbreviation fId     (infixr "\<^bold>=" 25)   where "l \<^bold>= r \<equiv> l = r"
 abbreviation fAll    ("\<^bold>\<forall>")               where "\<^bold>\<forall>\<Phi> \<equiv> \<forall>x. E x \<longrightarrow> \<Phi> x"
 abbreviation fAllBi (binder "\<^bold>\<forall>" [8]9) where "\<^bold>\<forall>x. \<phi> x \<equiv> \<^bold>\<forall>\<phi>"
 abbreviation fOr    (infixr "\<^bold>\<or>" 21)     where "\<phi> \<^bold>\<or> \<psi> \<equiv> (\<^bold>\<not>\<phi>) \<^bold>\<rightarrow> \<psi>"
 abbreviation fAnd   (infixr "\<^bold>\<and>" 22)     where "\<phi> \<^bold>\<and> \<psi> \<equiv> \<^bold>\<not>(\<^bold>\<not>\<phi> \<^bold>\<or> \<^bold>\<not>\<psi>)"
 abbreviation fImpli (infixr "\<^bold>\<leftarrow>" 13)    where "\<phi> \<^bold>\<leftarrow> \<psi> \<equiv> \<psi> \<^bold>\<rightarrow> \<phi>"
 abbreviation fEquiv (infixr "\<^bold>\<leftrightarrow>" 15)    where "\<phi> \<^bold>\<leftrightarrow> \<psi> \<equiv> (\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<and> (\<psi> \<^bold>\<rightarrow> \<phi>)"
 abbreviation fEx     ("\<^bold>\<exists>")                 where "\<^bold>\<exists>\<Phi> \<equiv> \<^bold>\<not>(\<^bold>\<forall>(\<lambda>y. \<^bold>\<not>(\<Phi> y)))"
 abbreviation fExiBi (binder "\<^bold>\<exists>" [8]9)  where "\<^bold>\<exists>x. \<phi> x \<equiv> \<^bold>\<exists>\<phi>"

section\<open>Some Basic Notions in Category Theory\<close>

text \<open>Morphisms in the category are modeled as objects of type $i$.
We introduce three partial functions,
$dom$ (domain), $cod$ (codomain), and morphism composition ($\cdot$).

For composition we assume set-theoretical composition here (i.e., functional
composition from right to left). \label{IDMcL}\<close>

 consts
  domain:: "i\<Rightarrow>i" ("dom _" [108] 109)
  codomain:: "i\<Rightarrow>i" ("cod _" [110] 111)
  composition:: "i\<Rightarrow>i\<Rightarrow>i" (infix "\<cdot>" 110)

 \<comment> \<open>Kleene Equality\<close>
 abbreviation KlEq (infixr "\<cong>" 56) where "x \<cong> y \<equiv> (E x \<^bold>\<or> E y) \<^bold>\<rightarrow> x \<^bold>= y"
 \<comment> \<open>Existing Identity\<close>
 abbreviation ExId (infixr "\<simeq>" 56) where "x \<simeq> y \<equiv> (E x \<^bold>\<and> E y \<^bold>\<and> x \<^bold>= y)"

 \<comment> \<open>Identity-morphism: see also p.~4. of \cite{FreydScedrov90}.\<close>
 abbreviation "ID i \<equiv> (\<^bold>\<forall>x. E(i\<cdot>x) \<^bold>\<rightarrow> i\<cdot>x \<cong> x) \<^bold>\<and> (\<^bold>\<forall>x. E(x\<cdot>i) \<^bold>\<rightarrow> x\<cdot>i \<cong> x)"
 \<comment> \<open>Identity-morphism: Mac Lane's definition, the same as ID except for notion of equality.\<close>
 abbreviation "IDMcL \<rho> \<equiv> (\<^bold>\<forall>\<alpha>. E(\<rho>\<cdot>\<alpha>) \<^bold>\<rightarrow> \<rho>\<cdot>\<alpha> = \<alpha>) \<^bold>\<and> (\<^bold>\<forall>\<beta>. E(\<beta>\<cdot>\<rho>) \<^bold>\<rightarrow> \<beta>\<cdot>\<rho> = \<beta>)"

 \<comment> \<open>The two notions of identity-morphisms are obviously equivalent.\<close>
 lemma IDPredicates: "ID \<equiv> IDMcL" by auto

section\<open>The Axioms Sets studied by Benzm\"uller and Scott @{cite "R58"}\<close>

subsection\<open>AxiomsSet1\<close>

 text\<open>AxiomsSet1 generalizes the notion of a monoid by introducing a partial, strict binary
      composition operation ``$\cdot$''. The existence of left and right identity elements is
      addressed in axioms @{term "C\<^sub>i"} and @{term "D\<^sub>i"}. The notions of $dom$ (domain) and
      $cod$ (codomain)
      abstract from their common meaning in the context of sets. In category theory we
     work with just a single type of objects (the type $i$ in our setting) and therefore
     identity morphisms are employed to suitably characterize their
     meanings.\<close>

 locale AxiomsSet1 =
  assumes
   S\<^sub>i: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" and
   E\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" and
   A\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
   C\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. ID i \<^bold>\<and> i\<cdot>y \<cong> y" and
   D\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. ID j \<^bold>\<and> x\<cdot>j \<cong> x"
  begin
   lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>

   lemma E\<^sub>iImpl: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" by (metis A\<^sub>i C\<^sub>i S\<^sub>i)
   \<comment> \<open>Uniqueness of i and j in the latter two axioms.\<close>
   lemma UC\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. ID i \<^bold>\<and> i\<cdot>y \<cong> y \<^bold>\<and> (\<^bold>\<forall>j.(ID j \<^bold>\<and> j\<cdot>y \<cong> y) \<^bold>\<rightarrow> i \<cong> j)" by (smt A\<^sub>i C\<^sub>i S\<^sub>i)
   lemma UD\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. ID j \<^bold>\<and> x\<cdot>j \<cong> x \<^bold>\<and> (\<^bold>\<forall>i.(ID i \<^bold>\<and> x\<cdot>i \<cong> x) \<^bold>\<rightarrow> j \<cong> i)" by (smt A\<^sub>i D\<^sub>i S\<^sub>i)
   \<comment> \<open>But i and j need not to equal.\<close>
   lemma "(\<exists>C D. (\<^bold>\<forall>y. ID (C y) \<^bold>\<and> (C y)\<cdot>y \<cong> y) \<^bold>\<and> (\<^bold>\<forall>x. ID (D x) \<^bold>\<and> x\<cdot>(D x) \<cong> x) \<^bold>\<and> \<^bold>\<not>(D \<^bold>= C))"
     nitpick [satisfy] oops \<comment> \<open>Model found\<close>
   lemma "(\<exists>x. E x) \<^bold>\<and> (\<exists>C D. (\<^bold>\<forall>y. ID(C y) \<^bold>\<and> (C y)\<cdot>y \<cong> y) \<^bold>\<and> (\<^bold>\<forall>x. ID(D x) \<^bold>\<and> x\<cdot>(D x) \<cong> x) \<^bold>\<and> \<^bold>\<not>(D \<^bold>= C))"
     nitpick [satisfy] oops \<comment> \<open>Model found\<close>
  end

subsection\<open>AxiomsSet2\<close>

text\<open>AxiomsSet2 is developed from AxiomsSet1 by Skolemization of the
     existentially quantified variables $i$ and $j$ in axioms $C_i$ and
     $D_i$. We can argue semantically that every model of AxiomsSet1 has
     such functions. Hence, we get a conservative extension of AxiomsSet1.
     The strictness axiom $S$ is extended, so
     that strictness is now also postulated for the new Skolem functions
     $dom$ and $cod$.\<close>

 locale AxiomsSet2 =
  assumes
   S\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
   E\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" and
   A\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
   C\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" and
   D\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
  begin
   lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>

   lemma E\<^sub>i\<^sub>iImpl: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" by (metis A\<^sub>i\<^sub>i C\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)

 subsubsection\<open>AxiomsSet2 entails AxiomsSet1\<close>

 context AxiomsSet2
  begin
   lemma S\<^sub>i: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" using S\<^sub>i\<^sub>i by blast
   lemma E\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" using E\<^sub>i\<^sub>i by blast
   lemma A\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>i by blast
   lemma C\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. ID i \<^bold>\<and> i\<cdot>y \<cong> y" by (metis C\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
   lemma D\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. ID j \<^bold>\<and> x\<cdot>j \<cong> x" by (metis D\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
  end

 subsubsection\<open>AxiomsSet1 entails AxiomsSet2 (by semantic means)\<close>
 text\<open>By semantic means (Skolemization).\<close>

 subsection\<open>AxiomsSet3\<close>

 text\<open>In AxiomsSet3 the existence  axiom  $E_{ii}$ from AxiomsSet2  is simplified by taking
      advantage of the two new Skolem functions $dom$ and $cod$.

      The left-to-right direction of existence axiom $E_{iii}$ is implied.\<close>

 locale AxiomsSet3 =
  assumes
   S\<^sub>i\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
   E\<^sub>i\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" and
   A\<^sub>i\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
   C\<^sub>i\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" and
   D\<^sub>i\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
  begin
   lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>

   lemma E\<^sub>i\<^sub>i\<^sub>iImpl: "E(x\<cdot>y) \<^bold>\<rightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" by (metis (full_types) A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
  end

 subsubsection\<open>AxiomsSet3 entails AxiomsSet2\<close>

 context AxiomsSet3
  begin
   lemma S\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)" using S\<^sub>i\<^sub>i\<^sub>i by blast
   lemma E\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" by (metis A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i E\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
   lemma A\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>i\<^sub>i by blast
   lemma C\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" using C\<^sub>i\<^sub>i\<^sub>i by auto
   lemma D\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)" using D\<^sub>i\<^sub>i\<^sub>i by auto
  end

 subsubsection\<open>AxiomsSet2 entails AxiomsSet3\<close>

 context AxiomsSet2
  begin
   lemma S\<^sub>i\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)" using S\<^sub>i\<^sub>i by blast
   lemma E\<^sub>i\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" by (metis C\<^sub>i\<^sub>i D\<^sub>i\<^sub>i E\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
   lemma A\<^sub>i\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>i by blast
   lemma C\<^sub>i\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" using C\<^sub>i\<^sub>i by auto
   lemma D\<^sub>i\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)" using D\<^sub>i\<^sub>i by auto
  end

  subsection\<open>The Axioms Set AxiomsSet4\<close>

  text\<open>AxiomsSet4 simplifies the axioms $C_{iii}$ and  $D_{iii}$. However, as it turned
       out, these simplifications also require the existence axiom $E_{iii}$ to be strengthened
       into an equivalence.\<close>

 locale AxiomsSet4 =
  assumes
   S\<^sub>i\<^sub>v: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
   E\<^sub>i\<^sub>v: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" and
   A\<^sub>i\<^sub>v: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
   C\<^sub>i\<^sub>v: "(cod y)\<cdot>y \<cong> y" and
   D\<^sub>i\<^sub>v: "x\<cdot>(dom x) \<cong> x"
  begin
   lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
  end

 subsubsection\<open>AxiomsSet4 entails AxiomsSet3\<close>

 context AxiomsSet4
  begin
   lemma S\<^sub>i\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)" using S\<^sub>i\<^sub>v by blast
   lemma E\<^sub>i\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> (E(cod y)))" using E\<^sub>i\<^sub>v by blast
   lemma A\<^sub>i\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>v by blast
   lemma C\<^sub>i\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" by (metis C\<^sub>i\<^sub>v D\<^sub>i\<^sub>v E\<^sub>i\<^sub>v)
   lemma D\<^sub>i\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)" by (metis C\<^sub>i\<^sub>v D\<^sub>i\<^sub>v E\<^sub>i\<^sub>v)
  end

 subsubsection\<open>AxiomsSet3 entails AxiomsSet4\<close>

 context AxiomsSet3
  begin
   lemma S\<^sub>i\<^sub>v: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  using S\<^sub>i\<^sub>i\<^sub>i by blast
   lemma E\<^sub>i\<^sub>v: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" by (metis (full_types) A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i E\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
   lemma A\<^sub>i\<^sub>v: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>i\<^sub>i by blast
   lemma C\<^sub>i\<^sub>v: "(cod y)\<cdot>y \<cong> y" using C\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i by blast
   lemma D\<^sub>i\<^sub>v: "x\<cdot>(dom x) \<cong> x" using D\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i by blast
  end

subsection\<open>AxiomsSet5\<close>

  text\<open>AxiomsSet5 has been proposed by Scott @{cite "Scott79"} in the 1970s. This set of
 axioms is equivalent to the axioms set presented by Freyd and Scedrov in their textbook
 ``Categories, Allegories'' @{cite "FreydScedrov90"} when encoded in free logic, corrected/adapted
 and further simplified, see Section 5.\<close>

 locale AxiomsSet5 =
  assumes
   S1: "E(dom x) \<^bold>\<rightarrow> E x" and
   S2: "E(cod y) \<^bold>\<rightarrow> E y" and
   S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
   S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
   S5: "(cod y)\<cdot>y \<cong> y" and
   S6: "x\<cdot>(dom x) \<cong> x"
  begin
   lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
  end

 subsubsection\<open>AxiomsSet5 entails AxiomsSet4\<close>

 context AxiomsSet5
  begin
   lemma S\<^sub>i\<^sub>v: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)" using S1 S2 S3 by blast
   lemma E\<^sub>i\<^sub>v: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" using S3 by metis
   lemma A\<^sub>i\<^sub>v: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using S4 by blast
   lemma C\<^sub>i\<^sub>v: "(cod y)\<cdot>y \<cong> y" using S5 by blast
   lemma D\<^sub>i\<^sub>v: "x\<cdot>(dom x) \<cong> x" using S6 by blast
  end

 subsubsection\<open>AxiomsSet4 entails AxiomsSet5\<close>

 context AxiomsSet4
  begin
   lemma S1: "E(dom x) \<^bold>\<rightarrow> E x" using S\<^sub>i\<^sub>v by blast
   lemma S2: "E(cod y) \<^bold>\<rightarrow> E y" using S\<^sub>i\<^sub>v by blast
   lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" using E\<^sub>i\<^sub>v by metis
   lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>v by blast
   lemma S5: "(cod y)\<cdot>y \<cong> y" using C\<^sub>i\<^sub>v by blast
   lemma S6: "x\<cdot>(dom x) \<cong> x" using D\<^sub>i\<^sub>v by blast
  end

section\<open>The Axioms Sets by Freyd and Scedrov @{cite "FreydScedrov90"}\<close>

subsection\<open>AxiomsSet6\<close>
text\<open>The axioms by Freyd and Scedrov  @{cite "FreydScedrov90"} in our notation, when being
     corrected (cf. the modification in axiom A1).

     Freyd and Scedrov employ a different notation for $dom\ x$ and $cod\
     x$. They denote these operations by $\Box x$
     and $x\Box$. Moreover, they employ diagrammatic composition instead of the set-theoretic
     definition (functional composition from right to left) used so
     far.
     We leave it to the reader to verify that their axioms corresponds to the axioms presented
     here modulo an appropriate conversion of notation.\<close>

 locale AxiomsSet6 =
  assumes
    A1: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
   A2a: "cod(dom x) \<cong> dom x" and
   A2b: "dom(cod y) \<cong> cod y" and
   A3a: "x\<cdot>(dom x) \<cong> x" and
   A3b: "(cod y)\<cdot>y \<cong> y" and
   A4a: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
   A4b: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
    A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
  begin
   lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
end

 subsubsection\<open>AxiomsSet6 entails AxiomsSet5\<close>

 context AxiomsSet6
  begin
   lemma S1: "E(dom x) \<^bold>\<rightarrow> E x" by (metis A1 A2a A3a)
   lemma S2: "E(cod y) \<^bold>\<rightarrow> E y" using A1 A2b A3b by metis
   lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" by (metis A1)
   lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A5 by blast
   lemma S5: "(cod y)\<cdot>y \<cong> y" using A3b by blast
   lemma S6: "x\<cdot>(dom x) \<cong> x" using A3a by blast

   lemma A4aRedundant: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" using A1 A2a A3a A5 by metis
   lemma A4bRedundant: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" using A1 A2b A3b A5 by smt
   lemma A2aRedundant: "cod(dom x) \<cong> dom x" using A1 A3a A3b A4a A4b by smt
   lemma A2bRedundant: "dom(cod y) \<cong> cod y" using  A1 A3a A3b A4a A4b by smt
  end

 subsubsection\<open>AxiomsSet5 entails AxiomsSet6\<close>

 context AxiomsSet5
  begin

subsection\<open>AxiomsSet7 (technically flawed)\<close>
  text\<open>The axioms by Freyd and Scedrov in our notation, without the suggested correction of
       axiom A1. This axioms set is technically flawed
       when encoded in our given context. It leads to a constricted inconsistency.\<close>

 locale AxiomsSet7 =
  assumes
    A1: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" and
   A2a: "cod(dom x) \<cong> dom x " and
   A2b: "dom(cod y) \<cong> cod y" and
   A3a: "x\<cdot>(dom x) \<cong> x" and
   A3b: "(cod y)\<cdot>y \<cong> y" and
   A4a: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
   A4b: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
    A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
  begin
   lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   (*
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  --{*No model found*}
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  --{*No model found*}
   *)
   lemma InconsistencyAutomatic: "(\<exists>x. \<^bold>\<not>(E x)) \<^bold>\<rightarrow> False" by (metis A1 A2a A3a) \<comment> \<open>Inconsistency\<close>
   lemma "\<forall>x. E x" using InconsistencyAutomatic by auto

   lemma InconsistencyInteractive:
    assumes NEx: "\<exists>x. \<^bold>\<not>(E x)" shows False
    proof -
    obtain a where 1: "\<^bold>\<not>(E a)" using NEx by auto
    have 2: "a\<cdot>(dom a) \<cong> a" using A3a by blast
    have 3: "\<^bold>\<not>(E(a\<cdot>(dom a)))" using 1 2 by metis
    have 4: "E(a\<cdot>(dom a)) \<^bold>\<leftrightarrow> dom a \<cong> cod(dom a)" using A1 by blast
    have 5: "cod(dom a) \<cong> dom a" using A2a by blast
    have 6: "E(a\<cdot>(dom a)) \<^bold>\<leftrightarrow> dom a \<cong> dom a" using 4 5 by auto
    have 7: "E(a\<cdot>(dom a))" using 6 by blast
    then show ?thesis using 7 3 by blast
    qed
  end

subsection\<open>AxiomsSet7orig (technically flawed)\<close>

text\<open>The axioms by Freyd and Scedrov in their original notation, without the suggested
     correction of axiom A1.

      We present the constricted inconsistency argument from above once again,
      but this time in the original notation of Freyd and Scedrov.\<close>

 locale AxiomsSet7orig =
  fixes
   source:: "i\<Rightarrow>i" ("\<box>_" [108] 109) and
   target:: "i\<Rightarrow>i" ("_\<box>" [110] 111) and
   compositionF:: "i\<Rightarrow>i\<Rightarrow>i" (infix "\<^bold>\<cdot>" 110)
  assumes
    A1: "E(x\<^bold>\<cdot>y) \<^bold>\<leftrightarrow> (x\<box> \<cong> \<box>y)" and
   A2a: "((\<box>x)\<box>) \<cong> \<box>x" and
   A2b: "\<box>(x\<box>) \<cong> \<box>x" and
   A3a: "(\<box>x)\<^bold>\<cdot>x \<cong> x" and
   A3b: "x\<^bold>\<cdot>(x\<box>) \<cong> x" and
   A4a: "\<box>(x\<^bold>\<cdot>y) \<cong> \<box>(x\<^bold>\<cdot>(\<box>y))" and
   A4b: "(x\<^bold>\<cdot>y)\<box> \<cong> ((x\<box>)\<^bold>\<cdot>y)\<box>" and
    A5: "x\<^bold>\<cdot>(y\<^bold>\<cdot>z) \<cong> (x\<^bold>\<cdot>y)\<^bold>\<cdot>z"
  begin
   lemma True nitpick [satisfy] oops \<comment> \<open>Consistency\<close>
   (*
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  --{*No model found*}
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  --{*No model found*}
    *)
   lemma InconsistencyAutomatic: "(\<exists>x. \<^bold>\<not>(E x)) \<^bold>\<rightarrow> False" by (metis A1 A2a A3a) \<comment> \<open>Inconsistency\<close>
   lemma "\<forall>x. E x" using InconsistencyAutomatic by auto

   lemma InconsistencyInteractive:
    assumes NEx: "\<exists>x. \<^bold>\<not>(E x)" shows False
    proof -
    obtain a where 1: "\<^bold>\<not>(E a)" using assms by auto
    have 2: "(\<box>a)\<^bold>\<cdot>a \<cong> a" using A3a by blast
    have 3: "\<^bold>\<not>(E((\<box>a)\<^bold>\<cdot>a))" using 1 2 by metis
    have 4: "E((\<box>a)\<^bold>\<cdot>a) \<^bold>\<leftrightarrow> (\<box>a)\<box> \<cong> \<box>a" using A1 by blast
    have 5: "(\<box>a)\<box> \<cong> \<box>a" using A2a by blast
    have 6: "E((\<box>a)\<^bold>\<cdot>a)" using 4 5 by blast
    then show ?thesis using 6 3 by blast
    qed
  end

subsection\<open>AxiomsSet8 (algebraic reading, still technically flawed)\<close>

 text\<open>The axioms by Freyd and Scedrov in our notation again, but this time we adopt
      an algebraic reading of the free variables, meaning that they range over existing
      morphisms only.\<close>

 locale AxiomsSet8 =
  assumes
    B1: "\<^bold>\<forall>x.\<^bold>\<forall>y. E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" and
   B2a: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " and
   B2b: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" and
   B3a: "\<^bold>\<forall>x. x\<cdot>(dom x) \<cong> x" and
   B3b: "\<^bold>\<forall>y. (cod y)\<cdot>y \<cong> y" and
   B4a: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
   B4b: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
    B5: "\<^bold>\<forall>x.\<^bold>\<forall>y.\<^bold>\<forall>z. x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
  begin
   lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
  end

 text\<open>None of the axioms in AxiomsSet5 are implied.\<close>

 context AxiomsSet8
  begin
   lemma S1: "E(dom x) \<^bold>\<rightarrow> E x" nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
   lemma S2: "E(cod y) \<^bold>\<rightarrow> E y" nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
   lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
   lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
   lemma S5: "(cod y)\<cdot>y \<cong> y"  nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
   lemma S6: "x\<cdot>(dom x) \<cong> x"  nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
  end

subsection\<open>AxiomsSet8Strict (algebraic reading)\<close>

 text\<open>The situation changes when strictness conditions are postulated. Note that in the algebraic
      framework of Freyd and Scedrov such conditions have to be assumed as given in the
      logic, while here we can explicitly encode them as axioms.\<close>

 locale AxiomsSet8Strict = AxiomsSet8 +
  assumes
   B0a: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" and
   B0b: "E(dom x) \<^bold>\<rightarrow> E x" and
   B0c: "E(cod x) \<^bold>\<rightarrow> E x"
  begin
   lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
  end

 subsubsection\<open>AxiomsSet8Strict entails AxiomsSet5\<close>

 context AxiomsSet8Strict
  begin
   lemma S1: "E(dom x) \<^bold>\<rightarrow> E x"  using B0b by blast
   lemma S2: "E(cod y) \<^bold>\<rightarrow> E y"  using B0c by blast
   lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" by (metis B0a B0b B0c B1 B3a)
   lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" by (meson B0a B5)
   lemma S5: "(cod y)\<cdot>y \<cong> y" using B0a B3b by blast
   lemma S6: "x\<cdot>(dom x) \<cong> x" using B0a B3a by blast
  end

 subsubsection\<open>AxiomsSet5 entails AxiomsSet8Strict\<close>

 context AxiomsSet5
  begin
   lemma B0a: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" using S1 S2 S3 by blast
   lemma B0b: "E(dom x) \<^bold>\<rightarrow> E x" using S1 by blast
   lemma B0c: "E(cod x) \<^bold>\<rightarrow> E x" using S2 by blast
   lemma  B1: "\<^bold>\<forall>x.\<^bold>\<forall>y. E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" by (metis S3 S5)
   lemma B2a: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x" using A2 by blast
   lemma B2b: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" using A2b by blast
   lemma B3a: "\<^bold>\<forall>x. x\<cdot>(dom x) \<cong> x" using S6 by blast
   lemma B3b: "\<^bold>\<forall>y. (cod y)\<cdot>y \<cong> y" using S5 by blast
   lemma B4a: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" by (metis S1 S3 S4 S6)
   lemma B4b: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" by (metis S1 S2 S3 S4 S5)
   lemma  B5: "\<^bold>\<forall>x.\<^bold>\<forall>y.\<^bold>\<forall>z. x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using S4 by blast
  end

  subsubsection\<open>AxiomsSet8Strict is Redundant\<close>

  text\<open>AxiomsSet8Strict is redundant: either the B2-axioms can be omitted or the B4-axioms.\<close>

 context AxiomsSet8Strict
  begin
   lemma B2aRedundant: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " by (metis B0a B1 B3a)
   lemma B2bRedundant: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" by (metis B0a B1 B3b)
   lemma B4aRedundant: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" by (metis B0a B0b B1 B3a B5)
   lemma B4bRedundant: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" by (metis B0a B0c B1 B3b B5)
  end

  section\<open>The Axioms Sets of Mac Lane @{cite "MacLane48"}\<close>

  text\<open>We analyse the axioms set suggested by Mac Lane~@{cite "MacLane48"} already in 1948.
      As for the theory by
       Freyd and Scedrov above, which was developed much later, we need to assume
       strictness of composition to show equivalence to our previous axiom sets.
       Note that his complicated conditions on existence of compositions proved to be
       unnecessary, as we show. It shows it is hard to think about partial operations.\<close>

 locale AxiomsSetMcL =
  assumes
   C\<^sub>0 : "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" and
   C\<^sub>1 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>)) \<^bold>\<rightarrow> E(\<beta>\<cdot>\<alpha>)" and
   C\<^sub>1': "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<beta>\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>))) \<^bold>\<rightarrow> E(\<gamma>\<cdot>\<beta>)" and
   C\<^sub>2 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E(\<beta>\<cdot>\<alpha>)) \<^bold>\<rightarrow> (E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)) \<^bold>\<and> ((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) = (\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)))" and
   C\<^sub>3 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eD. IDMcL(eD) \<^bold>\<and> E(\<gamma>\<cdot>eD)" and
   C\<^sub>4 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eR. IDMcL(eR) \<^bold>\<and> E(eR\<cdot>\<gamma>)"
  begin
   lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
  end

  text\<open>Remember that IDMcL  was defined on p.~\pageref{IDMcL} and proved
       equivalent to ID.\<close>

 subsection\<open>AxiomsSetMcL entails AxiomsSet1\<close>

 context AxiomsSetMcL
  begin
   lemma S\<^sub>i: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)"  using C\<^sub>0 by blast
   lemma E\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" by (metis C\<^sub>2)
   lemma A\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"       by (metis C\<^sub>1 C\<^sub>1' C\<^sub>2 C\<^sub>0)
   lemma C\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. ID i \<^bold>\<and> i\<cdot>y \<cong> y" using C\<^sub>4 by fastforce
   lemma D\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. ID j \<^bold>\<and> x\<cdot>j \<cong> x" using C\<^sub>3 by fastforce
  end

 subsection\<open>AxiomsSet1 entails AxiomsSetMcL\<close>

 context AxiomsSet1
  begin
   lemma C\<^sub>0 : "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" using S\<^sub>i by blast
   lemma C\<^sub>1 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>)) \<^bold>\<rightarrow> E(\<beta>\<cdot>\<alpha>)" by (metis A\<^sub>i S\<^sub>i)
   lemma C\<^sub>1': "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<beta>\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>))) \<^bold>\<rightarrow> E(\<gamma>\<cdot>\<beta>)" by (metis A\<^sub>i S\<^sub>i)
   lemma C\<^sub>2 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E(\<beta>\<cdot>\<alpha>)) \<^bold>\<rightarrow> (E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)) \<^bold>\<and> ((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) = (\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)))" by (smt A\<^sub>i C\<^sub>i E\<^sub>i S\<^sub>i)
   lemma C\<^sub>3 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eD. IDMcL(eD) \<^bold>\<and> E(\<gamma>\<cdot>eD)" using D\<^sub>i by force
   lemma C\<^sub>4 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eR. IDMcL(eR) \<^bold>\<and> E(eR\<cdot>\<gamma>)" using C\<^sub>i by force
  end

 subsection\<open>Skolemization of the Axioms of Mac Lane\<close>

 text\<open>Mac Lane employs diagrammatic composition instead of the set-theoretic
     definition as used in our axiom sets. As we have seen above,
      this is not a problem as long as composition is the only primitive.
      But when adding the Skolem terms $dom$ and $cod$ care must be taken and we should
      actually transform all axioms into a common form. Below we address this (in a minimal way) by
      using $dom$ in axiom @{term "C\<^sub>3s"} and $cod$ in axiom @{term "C\<^sub>4s"}, which is opposite of
      what Mac Lane proposed. For this axioms set we then show  equivalence to AxiomsSet1/2/5.\<close>

 locale SkolemizedAxiomsSetMcL =
  assumes
   C\<^sub>0s : "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<and> (E(dom x) \<^bold>\<rightarrow> E x) \<and> (E(cod y) \<^bold>\<rightarrow> E y)" and
   C\<^sub>1s : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>)) \<^bold>\<rightarrow> E(\<beta>\<cdot>\<alpha>)" and
   C\<^sub>1's: "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<beta>\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>))) \<^bold>\<rightarrow> E(\<gamma>\<cdot>\<beta>)" and
   C\<^sub>2s : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E(\<beta>\<cdot>\<alpha>)) \<^bold>\<rightarrow> (E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)) \<^bold>\<and> ((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) = (\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)))" and
   C\<^sub>3s : "\<^bold>\<forall>\<gamma>. IDMcL(dom \<gamma>) \<^bold>\<and> E(\<gamma>\<cdot>(dom \<gamma>))" and
   C\<^sub>4s : "\<^bold>\<forall>\<gamma>. IDMcL(cod \<gamma>) \<^bold>\<and> E((cod \<gamma>)\<cdot>\<gamma>)"
  begin
   lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
  end

 subsection\<open>SkolemizedAxiomsSetMcL entails AxiomsSetMcL and AxiomsSet1-5\<close>

 context SkolemizedAxiomsSetMcL
  begin
   lemma C\<^sub>0 : "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" using C\<^sub>0s by blast
   lemma C\<^sub>1 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>)) \<^bold>\<rightarrow> E(\<beta>\<cdot>\<alpha>)" using C\<^sub>1s by blast
   lemma C\<^sub>1': "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<beta>\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>))) \<^bold>\<rightarrow> E(\<gamma>\<cdot>\<beta>)" using C\<^sub>1's by blast
   lemma C\<^sub>2 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E(\<beta>\<cdot>\<alpha>)) \<^bold>\<rightarrow> (E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)) \<^bold>\<and> ((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) = (\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)))" using C\<^sub>2s by blast
   lemma C\<^sub>3 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eD. IDMcL(eD) \<^bold>\<and> E(\<gamma>\<cdot>eD)" by (metis C\<^sub>0s C\<^sub>3s)
   lemma C\<^sub>4 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eR. IDMcL(eR) \<^bold>\<and> E(eR\<cdot>\<gamma>)" by (metis C\<^sub>0s C\<^sub>4s)

   lemma S\<^sub>i: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)"   using C\<^sub>0s by blast
   lemma E\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))"  by (metis C\<^sub>2s)
   lemma A\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"        by (metis C\<^sub>1s C\<^sub>1's C\<^sub>2s C\<^sub>0s)
   lemma C\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. ID i \<^bold>\<and> i\<cdot>y \<cong> y"  by (metis C\<^sub>0s C\<^sub>4s)
   lemma D\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. ID j \<^bold>\<and> x\<cdot>j \<cong> x"  by (metis C\<^sub>0s C\<^sub>3s)

   lemma S\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)" using C\<^sub>0s by blast
   lemma E\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" by (metis C\<^sub>2s)
   lemma A\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" by (metis C\<^sub>1s C\<^sub>1's C\<^sub>2s C\<^sub>0s)
   lemma C\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" using C\<^sub>4s by auto
   lemma D\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)" using C\<^sub>3s by auto

   \<comment> \<open>AxiomsSets3/4 are omitted here; we already know they are equivalent.\<close>

   lemma S1: "E(dom x) \<^bold>\<rightarrow> E x"         using C\<^sub>0s by blast
   lemma S2: "E(cod y) \<^bold>\<rightarrow> E y"         using C\<^sub>0s by blast
   lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" by (metis (full_types) C\<^sub>0s C\<^sub>1s C\<^sub>1's C\<^sub>2s C\<^sub>3s C\<^sub>4s)
   lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"        by (metis C\<^sub>0s C\<^sub>1s C\<^sub>1's C\<^sub>2s)
   lemma S5: "(cod y)\<cdot>y \<cong> y"           using C\<^sub>0s C\<^sub>4s by blast
   lemma S6: "x\<cdot>(dom x) \<cong> x"           using C\<^sub>0s C\<^sub>3s by blast
  end

(*<*)
end
(*>*)


section \<open>Refinements for Utilities \<close>

text \<open>Introduces program refinement for @{text "Util.thy"}.\<close>

theory Util_Refined
imports Util Containers.Containers
begin

subsection \<open>New Code Equations for @{text "set_as_map"}\<close>

declare [[code drop: set_as_map]]

lemma set_as_map_refined[code] :
  fixes t :: "('a :: ccompare \<times> 'c :: ccompare) set_rbt"
  and   xs:: "('b :: ceq \<times> 'd :: ceq) set_dlist"
  shows "set_as_map (RBT_set t) = (case ID CCOMPARE(('a \<times> 'c)) of
           Some _ \<Rightarrow> Mapping.lookup (RBT_Set2.fold (\<lambda> (x,z) m . case Mapping.lookup m (x) of
                        None \<Rightarrow> Mapping.update (x) {z} m |
                        Some zs \<Rightarrow> Mapping.update (x) (Set.insert z zs) m)
                      t
                      Mapping.empty) |
           None   \<Rightarrow> Code.abort (STR ''set_as_map RBT_set: ccompare = None'')
                                (\<lambda>_. set_as_map (RBT_set t)))"
    (is "?C1")
  and   "set_as_map (DList_set xs) = (case ID CEQ(('b \<times> 'd)) of
            Some _ \<Rightarrow> Mapping.lookup (DList_Set.fold (\<lambda> (x,z) m . case Mapping.lookup m (x) of
                        None \<Rightarrow> Mapping.update (x) {z} m |
                        Some zs \<Rightarrow> Mapping.update (x) (Set.insert z zs) m)
                      xs
                      Mapping.empty) |
           None   \<Rightarrow> Code.abort (STR ''set_as_map RBT_set: ccompare = None'')
                                (\<lambda>_. set_as_map (DList_set xs)))"
    (is "?C2")
proof -
  show ?C1
  proof (cases "ID CCOMPARE(('a \<times> 'c))")
    case None
    then show ?thesis by auto
  next
    case (Some a)

    let ?f' = "(\<lambda> t' . (RBT_Set2.fold (\<lambda> (x,z) m . case Mapping.lookup m x of
                                                  None \<Rightarrow> Mapping.update x {z} m |
                                                  Some zs \<Rightarrow> Mapping.update x (Set.insert z zs) m)
                             t'
                             Mapping.empty))"

    let ?f = "\<lambda> xs . (fold (\<lambda> (x,z) m . case Mapping.lookup m x of
                                                  None \<Rightarrow> Mapping.update x {z} m |
                                                  Some zs \<Rightarrow> Mapping.update x (Set.insert z zs) m)
                            xs Mapping.empty)"
    have "\<And> xs :: ('a \<times> 'c) list . Mapping.lookup (?f xs) = (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None)"
    proof -
      fix xs :: "('a \<times> 'c) list"
      show "Mapping.lookup (?f xs) = (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None)"
      proof (induction xs rule: rev_induct)
        case Nil
        then show ?case
          by (simp add: Mapping.empty.abs_eq Mapping.lookup.abs_eq)
      next
        case (snoc xz xs)
        then obtain x z where "xz = (x,z)"
          by (metis (mono_tags, opaque_lifting) surj_pair)

        have *: "(?f (xs@[(x,z)])) = (case Mapping.lookup (?f xs) x of
                                    None \<Rightarrow> Mapping.update x {z} (?f xs) |
                                    Some zs \<Rightarrow> Mapping.update x (Set.insert z zs) (?f xs))"
          by auto

        then show ?case proof (cases "Mapping.lookup (?f xs) x")
          case None
          then have **: "Mapping.lookup (?f (xs@[(x,z)])) = Mapping.lookup (Mapping.update x {z} (?f xs))" using * by auto

          have scheme: "\<And> m k v . Mapping.lookup (Mapping.update k v m) = (\<lambda>k' . if k' = k then Some v else Mapping.lookup m k')"
            by (metis lookup_update')

          have m1: "Mapping.lookup (?f (xs@[(x,z)])) = (\<lambda> x' . if x' = x then Some {z} else Mapping.lookup (?f xs) x')"
            unfolding **
            unfolding scheme by force

          have "(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x = None"
          using None snoc by auto
          then have "\<not>(\<exists> z . (x,z) \<in> set xs)"
            by (metis (mono_tags, lifting) option.distinct(1))
          then have "(\<exists> z' . (x,z') \<in> set (xs@[(x,z)]))" and "{z' . (x,z') \<in> set (xs@[(x,z)])} = {z}"
            by fastforce+
          then have m2: "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None)
                       = (\<lambda> x' . if x' = x then Some {z} else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x')"
            by force

          show ?thesis using m1 m2 snoc
            using \<open>xz = (x, z)\<close> by presburger
        next
          case (Some zs)
          then have **: "Mapping.lookup (?f (xs@[(x,z)])) = Mapping.lookup (Mapping.update x (Set.insert z zs) (?f xs))" using * by auto
          have scheme: "\<And> m k v . Mapping.lookup (Mapping.update k v m) = (\<lambda>k' . if k' = k then Some v else Mapping.lookup m k')"
            by (metis lookup_update')

          have m1: "Mapping.lookup (?f (xs@[(x,z)])) = (\<lambda> x' . if x' = x then Some (Set.insert z zs) else Mapping.lookup (?f xs) x')"
            unfolding **
            unfolding scheme by force

          have "(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x = Some zs"
            using Some snoc by auto
          then have "(\<exists> z' . (x,z') \<in> set xs)"
            unfolding case_prod_conv using  option.distinct(2) by metis
          then have "(\<exists> z' . (x,z') \<in> set (xs@[(x,z)]))" by fastforce

          have "{z' . (x,z') \<in> set (xs@[(x,z)])} = Set.insert z zs"
          proof -
            have "Some {z . (x,z) \<in> set xs} = Some zs"
              using \<open>(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x = Some zs\<close>
              unfolding case_prod_conv using  option.distinct(2) by metis
            then have "{z . (x,z) \<in> set xs} = zs" by auto
            then show ?thesis by auto
          qed

          have "\<And> a  . (\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None) a
                     = (\<lambda> x' . if x' = x then Some (Set.insert z zs) else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x') a"
          proof -
            fix a show "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None) a
                       = (\<lambda> x' . if x' = x then Some (Set.insert z zs) else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x') a"
            using \<open>{z' . (x,z') \<in> set (xs@[(x,z)])} = Set.insert z zs\<close> \<open>(\<exists> z' . (x,z') \<in> set (xs@[(x,z)]))\<close>
            by (cases "a = x"; auto)
          qed

          then have m2: "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None)
                       = (\<lambda> x' . if x' = x then Some (Set.insert z zs) else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x')"
            by auto

          show ?thesis using m1 m2 snoc
            using \<open>xz = (x, z)\<close> by presburger
        qed
      qed
    qed
    then have "Mapping.lookup (?f' t) = (\<lambda> x . if (\<exists> z . (x,z) \<in> set (RBT_Set2.keys t)) then Some {z . (x,z) \<in> set (RBT_Set2.keys t)} else None)"
      unfolding fold_conv_fold_keys by metis
    moreover have "set (RBT_Set2.keys t) = (RBT_set t)"
      using Some by (simp add: RBT_set_conv_keys)
    ultimately have "Mapping.lookup (?f' t) = (\<lambda> x . if (\<exists> z . (x,z) \<in> (RBT_set t)) then Some {z . (x,z) \<in> (RBT_set t)} else None)"
      by force

    then show ?thesis
      using Some unfolding set_as_map_def by simp
  qed

  show ?C2
  proof (cases "ID CEQ(('b \<times> 'd))")
    case None
    then show ?thesis by auto
  next
    case (Some a)

    let ?f' = "(\<lambda> t' . (DList_Set.fold (\<lambda> (x,z) m . case Mapping.lookup m x of
                                                  None \<Rightarrow> Mapping.update x {z} m |
                                                  Some zs \<Rightarrow> Mapping.update x (Set.insert z zs) m)
                             t'
                             Mapping.empty))"

    let ?f = "\<lambda> xs . (fold (\<lambda> (x,z) m . case Mapping.lookup m x of
                                                  None \<Rightarrow> Mapping.update x {z} m |
                                                  Some zs \<Rightarrow> Mapping.update x (Set.insert z zs) m)
                            xs Mapping.empty)"
    have *: "\<And> xs :: ('b \<times> 'd) list . Mapping.lookup (?f xs) = (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None)"
    proof -
      fix xs :: "('b \<times> 'd) list"
      show "Mapping.lookup (?f xs) = (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None)"
      proof (induction xs rule: rev_induct)
        case Nil
        then show ?case
          by (simp add: Mapping.empty.abs_eq Mapping.lookup.abs_eq)
      next
        case (snoc xz xs)
        then obtain x z where "xz = (x,z)"
          by (metis (mono_tags, opaque_lifting) surj_pair)

        have *: "(?f (xs@[(x,z)])) = (case Mapping.lookup (?f xs) x of
                                    None \<Rightarrow> Mapping.update x {z} (?f xs) |
                                    Some zs \<Rightarrow> Mapping.update x (Set.insert z zs) (?f xs))"
          by auto

        then show ?case proof (cases "Mapping.lookup (?f xs) x")
          case None
          then have **: "Mapping.lookup (?f (xs@[(x,z)])) = Mapping.lookup (Mapping.update x {z} (?f xs))" using * by auto

          have scheme: "\<And> m k v . Mapping.lookup (Mapping.update k v m) = (\<lambda>k' . if k' = k then Some v else Mapping.lookup m k')"
            by (metis lookup_update')

          have m1: "Mapping.lookup (?f (xs@[(x,z)])) = (\<lambda> x' . if x' = x then Some {z} else Mapping.lookup (?f xs) x')"
            unfolding **
            unfolding scheme by force

          have "(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x = None"
          using None snoc by auto
          then have "\<not>(\<exists> z . (x,z) \<in> set xs)"
            by (metis (mono_tags, lifting) option.distinct(1))
          then have "(\<exists> z' . (x,z') \<in> set (xs@[(x,z)]))" and "{z' . (x,z') \<in> set (xs@[(x,z)])} = {z}"
            by fastforce+
          then have m2: "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None)
                       = (\<lambda> x' . if x' = x then Some {z} else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x')"
            by force

          show ?thesis using m1 m2 snoc
            using \<open>xz = (x, z)\<close> by presburger
        next
          case (Some zs)
          then have **: "Mapping.lookup (?f (xs@[(x,z)])) = Mapping.lookup (Mapping.update x (Set.insert z zs) (?f xs))" using * by auto
          have scheme: "\<And> m k v . Mapping.lookup (Mapping.update k v m) = (\<lambda>k' . if k' = k then Some v else Mapping.lookup m k')"
            by (metis lookup_update')

          have m1: "Mapping.lookup (?f (xs@[(x,z)])) = (\<lambda> x' . if x' = x then Some (Set.insert z zs) else Mapping.lookup (?f xs) x')"
            unfolding **
            unfolding scheme by force

          have "(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x = Some zs"
            using Some snoc by auto
          then have "(\<exists> z' . (x,z') \<in> set xs)"
            unfolding case_prod_conv using  option.distinct(2) by metis
          then have "(\<exists> z' . (x,z') \<in> set (xs@[(x,z)]))" by fastforce

          have "{z' . (x,z') \<in> set (xs@[(x,z)])} = Set.insert z zs"
          proof -
            have "Some {z . (x,z) \<in> set xs} = Some zs"
              using \<open>(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x = Some zs\<close>
              unfolding case_prod_conv using  option.distinct(2) by metis
            then have "{z . (x,z) \<in> set xs} = zs" by auto
            then show ?thesis by auto
          qed

          have "\<And> a  . (\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None) a
                     = (\<lambda> x' . if x' = x then Some (Set.insert z zs) else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x') a"
          proof -
            fix a show "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None) a
                       = (\<lambda> x' . if x' = x then Some (Set.insert z zs) else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x') a"
            using \<open>{z' . (x,z') \<in> set (xs@[(x,z)])} = Set.insert z zs\<close> \<open>(\<exists> z' . (x,z') \<in> set (xs@[(x,z)]))\<close>
            by (cases "a = x"; auto)
          qed

          then have m2: "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None)
                       = (\<lambda> x' . if x' = x then Some (Set.insert z zs) else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x')"
            by auto

          show ?thesis using m1 m2 snoc
            using \<open>xz = (x, z)\<close> by presburger
        qed
      qed
    qed

    have "ID CEQ('b \<times> 'd) \<noteq> None"
      using Some by auto
    then have **: "\<And> x . x \<in> set (list_of_dlist xs) = (x \<in> (DList_set xs))"
      using DList_Set.member.rep_eq[of xs]
      using Set_member_code(2) ceq_class.ID_ceq in_set_member by fastforce

    have "Mapping.lookup (?f' xs) = (\<lambda> x . if (\<exists> z . (x,z) \<in> (DList_set xs)) then Some {z . (x,z) \<in> (DList_set xs)} else None)"
      using *[of "(list_of_dlist xs)"]
      unfolding DList_Set.fold.rep_eq ** by assumption
    then show ?thesis unfolding set_as_map_def using Some by simp
  qed
qed

end