theory CategorySet imports "ZFC_in_HOL.ZFC_Typeclasses" Category

begin

 (*Begin: some useful parameter settings*)
declare [[ smt_solver = cvc4, smt_oracle = true, smt_timeout = 120]] declare [[ show_types ]]
sledgehammer_params [provers = cvc4 z3 spass e vampire]
nitpick_params [user_axioms, show_all, format = 2]
(*nitpick_params[user_axioms, show_all, format = 2, expect = genuine]*)
 (*End: some useful parameter settings*)

text\<open>Lets try to build the category of sets!\<close>

section\<open>Prerequisites\<close>

declare[[coercion_enabled]]

\<comment>\<open>The type of set functions\<close>
typedef setFunc = "{(f, A, B). f \<in> elts (VPi A (\<lambda>x. B))}"
  using VPi_I by blast

type_synonym funcRaw = "setFunc option"
typedef setCat = "UNIV::funcRaw set" by auto

setup_lifting type_definition_setFunc

lift_definition ffst::"setFunc \<Rightarrow> V" is fst
  done

lift_definition Psnd::"setFunc \<Rightarrow> V \<times> V" is snd
  done

definition fdom_r::"setFunc \<Rightarrow> V"
   where "fdom_r m \<equiv> fst(Psnd(m))"

definition fcod_r::"setFunc \<Rightarrow> V"
  where "fcod_r m \<equiv> snd(Psnd(m))"

declare [[coercion Abs_setFunc]]

\<comment> \<open>Raw definition of composition\<close>
definition PComp::"setFunc \<Rightarrow> setFunc \<Rightarrow> setFunc" (infixl "\<^bold>\<odot>" 75)
  where "g \<^bold>\<odot> f \<equiv> ((THE h. h \<in> elts (VPi (fdom_r f) (\<lambda>x. fcod_r g)) \<and>
                    (\<forall>a\<in>(elts (fdom_r f)). \<langle>a, (app (ffst g) (app (ffst f) a))\<rangle> \<in> elts h)),
                     fdom_r f, fcod_r g)"

section\<open>Setting up definitions for dom, cod and comp\<close>

declare [[coercion Abs_setCat]]

definition fdom::"setCat \<Rightarrow> setCat"
  where "fdom m \<equiv> case Rep_setCat m of None \<Rightarrow> None |
          Some y \<Rightarrow> Some (Abs_setFunc ((VLambda (fdom_r y) (\<lambda>x::V. x)) , (fdom_r y), (fdom_r y)))"

definition fcod::"setCat \<Rightarrow> setCat"
  where "fcod m \<equiv> case Rep_setCat m of None \<Rightarrow> None |
          Some y \<Rightarrow> Some (Abs_setFunc ((VLambda (fcod_r y) (\<lambda>x::V. x)) , (fcod_r y), (fcod_r y)))"

\<comment> \<open>Refined function composition\<close>
definition fComp::"setCat \<Rightarrow> setCat \<Rightarrow> setCat" (infixl "\<odot>" 75)
  where "g \<odot> f \<equiv> case Rep_setCat g of None \<Rightarrow> None
                  | Some y \<Rightarrow> (case Rep_setCat f of None \<Rightarrow> None
                                      | Some z \<Rightarrow> if (fdom_r y = fcod_r z)  then Some (y \<^bold>\<odot> z) else None)"

section\<open>Axiomatization of existence in free logic\<close>

axiomatization where
SetCatEx: "E (f::setCat) \<longleftrightarrow> \<not>(Rep_setCat f = None)"

lemma NoneNotEx: "\<not>(E ((Abs_setCat None)::setCat))"
  by (simp add: Abs_setCat_inverse SetCatEx)

lemma DomExHelp: assumes "E x" shows "\<exists>y. fdom x = Abs_setCat (Some y)"
proof -
  obtain y where 1:"fdom x = Abs_setCat (Some y)"
    using SetCatEx assms fdom_def by auto
  show ?thesis using 1 by auto
qed

lemma CodExHelp: assumes "E x" shows "\<exists>y. fcod x = Abs_setCat (Some y)"
proof -
  obtain y where 1: "fcod x = Abs_setCat(Some y)"
    using SetCatEx assms fcod_def by auto
  show ?thesis using 1 by auto
qed

section\<open>setCat defines a category - the category of sets\<close>

instantiation setCat :: category
begin

lift_definition domain_setCat::"setCat\<Rightarrow>setCat" is fdom done
lift_definition codomain_setCat::"setCat\<Rightarrow>setCat" is fcod done
lift_definition composition_setCat::"setCat\<Rightarrow>setCat\<Rightarrow>setCat" is fComp done

instance
proof
  show S1: "\<And>x::setCat. E (dom x) \<longrightarrow> E x"
    apply(rule contraposition)
  proof
    fix x::setCat
    assume "\<not> (E x)"
    then have "Rep_setCat x = None"
      using SetCatEx by blast
    hence "dom x = Abs_setCat None"
    using domain_setCat.transfer fdom_def by auto
    thus "\<not> (E (dom x))"
      by (simp add: NoneNotEx)
  qed

  show S2: "\<And>x::setCat. E (cod x) \<longrightarrow> E x"
  apply(rule contraposition)
  proof
    fix x::setCat
    assume "\<not> (E x)"
    then have "Rep_setCat x = None"
      using SetCatEx by blast
    hence "cod x = Abs_setCat None"
    using codomain_setCat.transfer fcod_def by auto
    thus "\<not> (E (cod x))"
      by (simp add: NoneNotEx)
  qed

  show "\<And>(x::setCat) y::setCat. E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    apply(transfer, rule equE)
  proof -
    fix x y :: setCat
      assume "E (x \<odot> y)"
      thus "fdom x \<simeq> fcod y"
        by (smt Abs_setCat_inverse CategorySet.fComp_def SetCatEx UNIV_I fcod_def fdom_def option.case_eq_if option.discI)
    next
    fix x y :: setCat
      assume 1:"fdom x \<simeq> fcod y"
      then have 2:"E x \<and> E y"
        by (metis(mono_tags) codomain_setCat.abs_eq domain_setCat.transfer local.S1 local.S2)
      from 1 show "E (x \<odot> y)" unfolding fComp_def
        apply (split option.splits)
        apply (split option.splits)
        apply (auto)
        using "2" SetCatEx apply blast
        using "2" SetCatEx apply blast
         apply (simp add: Abs_setCat_inverse SetCatEx)
      proof -
        fix u w :: setFunc
        assume 1: "E (fcod y)" and
         2: "fdom x \<^bold>= fcod y" and
         3: "fdom_r u \<noteq> fcod_r w" and
         4: "Rep_setCat y \<^bold>= Some w" and
         5: "Rep_setCat x \<^bold>= Some u"

        from 2 4 5 have 8: "fdom (Some u) = fcod (Some w)"
          by (metis Rep_setCat_inverse)

        have 6: "fcod (Some w) =
                    Some (Abs_setFunc((VLambda (fcod_r w) (\<lambda>x::V. x)) , (fcod_r w), (fcod_r w)))"
          by (simp add: Abs_setCat_inverse fcod_def)

        have 7: "fdom (Some u) = Some (Abs_setFunc((VLambda (fdom_r u) (\<lambda>x::V. x)) , (fdom_r u), (fdom_r u)))"
          by (simp add: Abs_setCat_inverse fdom_def)

        from 6 7 8 Abs_setFunc_inverse  have "((VLambda (fcod_r w) (\<lambda>x::V. x)) , (fcod_r w), (fcod_r w)) =
                        ((VLambda (fdom_r u) (\<lambda>x::V. x)) , (fdom_r u), (fdom_r u))"
          by (metis Abs_setCat_inverse UNIV_I VPi_I mem_Collect_eq option.sel prod.simps(2))
        then have "(fcod_r w) = (fdom_r u)" using VLambda_def
          by blast
        with 3 have "False" by auto
        thus "E (Abs_setCat None)" by simp
      qed
  qed

  show "\<And>(x::setCat) (y::setCat) z::setCat. x \<cdot> (y \<cdot> z) \<cong> (x \<cdot> y) \<cdot> z"
    apply(transfer)
    sorry

  show "\<And>x::setCat. x \<cdot> (dom x) \<cong> x"
    apply(transfer) unfolding fdom_def fComp_def
    apply(split option.split, split option.split, split option.split, split option.split)
    apply(auto)
    using NoneNotEx apply blast
    using SetCatEx apply blast
    using NoneNotEx apply blast
    apply (simp add: Abs_setCat_inverse)
       defer
       defer
    using NoneNotEx apply blast
    sorry

  show "\<And>y::setCat. (cod y) \<cdot> y \<cong> y"
    apply(transfer)
    sorry
qed

end

end


theory RelationalSemantics
  imports StoreHeapModel
begin

no_notation pleq (infix "\<sqsubseteq>" 50)

type_synonym 'a state = "('a \<times> heap) option"

definition pred :: "'a pred \<Rightarrow> 'a state set" where
  "pred P = {Some x | x. x \<in> P}"

lemma predE [elim!]: "x \<in> pred P \<Longrightarrow> (\<And>a b. x = Some (a, b) \<Longrightarrow> (a, b) \<in> P \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (auto simp: pred_def)

lemma predI [intro!]: "x \<in> P \<Longrightarrow> Some x \<in> pred P"
  apply (auto simp: pred_def )
  apply (rule_tac x="fst x" in exI)
  apply (rule_tac x="snd x" in exI)
  by auto

definition stran :: "'a state rel \<Rightarrow> ('a \<times> heap) \<Rightarrow> 'a pred option" where
  "stran R a \<equiv> if (Some a, None) \<in> R then None else Some {b. (Some a, Some b) \<in> R}"

lemma stranD: "stran R a = Some P \<Longrightarrow> b \<in> P \<Longrightarrow> (Some a, Some b) \<in> R"
  apply (auto simp: stran_def)
  apply (case_tac "(Some a, None) \<in> R")
  apply auto
done

lemma stranD2: "stran R a = Some P \<Longrightarrow> (Some a, Some b) \<in> R \<Longrightarrow> b \<in> P"
  apply (auto simp: stran_def)
  apply (case_tac "(Some a, None) \<in> R")
  apply auto
done

lemma stran_none: "stran R a = None \<longleftrightarrow> (Some a, None) \<in> R"
  by (auto simp: stran_def)

lemma stran_some: "stran R a = Some P \<Longrightarrow> (Some a, None) \<notin> R"
  by (auto simp: stran_def)

definition valid_subset :: "'a set option \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "\<sqsubseteq>" 100) where
  "P \<sqsubseteq> Q \<equiv> case P of None \<Rightarrow> False | Some P' \<Rightarrow> P' \<subseteq> Q"

lemma stranE2 [elim!]: "stran R a \<sqsubseteq> Q \<Longrightarrow> ((Some a, None) \<notin> R \<Longrightarrow> \<forall>b. (Some a, Some b) \<in> R \<longrightarrow> b \<in> Q \<Longrightarrow> G) \<Longrightarrow> G"
  apply (auto simp: stran_def valid_subset_def valid_mem_def)
  apply (case_tac "(Some a, None) \<in> R")
  apply simp
  apply auto
done

lemma stranI [intro!]: "(Some a, None) \<notin> R \<Longrightarrow> (\<And>b. (Some a, Some b) \<in> R \<Longrightarrow> b \<in> Q) \<Longrightarrow> stran R a \<sqsubseteq> Q"
  by (auto simp: stran_def valid_subset_def)

definition ptran :: "'a state rel \<Rightarrow> 'a ptran" where
  "ptran R Q = {a. stran R a \<sqsubseteq> Q}"

lemma "P \<le> ptran R Q \<Longrightarrow> (Id_on (pred P)) O R \<le> R O (Id_on (pred Q))"
  apply (clarsimp simp: ptran_def)
  by (case_tac z) auto

lemma "(Id_on (pred P)) O R \<le> R O (Id_on (pred Q)) \<Longrightarrow> P \<le> ptran R Q"
  by (auto simp: ptran_def)

fun sep_bot :: "'a pred option \<Rightarrow> 'a pred option \<Rightarrow> 'a pred option" (infixl "*\<^sub>h" 75) where
  "(Some P) *\<^sub>h (Some Q) = Some (P * Q)"
| "P *\<^sub>h None = None"
| "None *\<^sub>h Q = None"

fun leq_bot :: "'a pred option \<Rightarrow> 'a pred option \<Rightarrow> bool" (infixl "\<sqsubseteq>\<^sub>h" 50) where
  "Some P \<sqsubseteq>\<^sub>h Some Q \<longleftrightarrow> P \<subseteq> Q"
| "p \<sqsubseteq>\<^sub>h None \<longleftrightarrow> True"
| "None \<sqsubseteq>\<^sub>h q \<longleftrightarrow> q = None"

definition stran_local :: "('a \<times> heap \<Rightarrow> 'a pred option) \<Rightarrow> 'a pred \<Rightarrow> bool" where
  "stran_local f R \<equiv> \<forall>s h h'. h \<bottom> h' \<and> (s, h') \<in> R \<longrightarrow> f (s, (h ++ h')) \<sqsubseteq>\<^sub>h (f (s, h)) *\<^sub>h (Some R)"

lemma subseteqE: "P \<subseteq> Q \<Longrightarrow> (\<forall>x. x \<in> P \<longrightarrow> x \<in> Q \<Longrightarrow> R) \<Longrightarrow> R"
by auto

lemma "local (ptran R) A \<Longrightarrow> stran_local (stran R) A"
  apply (auto simp: stran_local_def ptran_def local_def)
  apply (case_tac "stran R (s, h)")
  apply simp
  apply simp
  apply (erule_tac x=a in allE)
  apply (erule subseteqE)
  apply (erule_tac x="(s, h ++ h')" in allE)
  apply (subgoal_tac "(s, h ++ h') \<in> {aa. stran R aa \<sqsubseteq> a} * A")
  prefer 2
  apply (clarsimp simp: sep_def valid_subset_def)
  apply force
  apply auto
  apply (case_tac "stran R (s, h ++ h')")
  apply (simp add: stran_def)
  apply auto
  apply (erule_tac x="ab" in allE)
  apply (erule_tac x="b" in allE)
  apply (drule stranD) back
  apply assumption
  apply auto
done

lemma "stran_local (stran R) A \<Longrightarrow> local (ptran R) A"
  apply (auto simp: stran_local_def local_def sep_def)
  apply (erule_tac x=s in allE)
  apply (erule_tac x=h1 in allE)
  apply (erule_tac x=h2 in allE)
  apply auto
  apply (case_tac "stran R (s, h1)")
  apply (clarsimp simp: ptran_def valid_subset_def)
  apply simp
  apply (case_tac "stran R (s, h1 ++ h2)")
  apply simp
  apply (auto simp: ptran_def valid_subset_def sep_def)
  apply (erule subseteqE) back
  apply (erule_tac x="(ab, b)" in allE)
  apply auto
done

text {* Safety and Framing properties on Relations *}

definition substate :: "heap \<Rightarrow> heap \<Rightarrow> bool" (infix "\<preceq>" 50) where
  "h \<preceq> h' \<equiv> \<exists>dh. h \<bottom> dh \<and> h' = h ++ dh"

definition safe :: "'a state rel \<Rightarrow> 'a pred \<Rightarrow> bool" where
  "safe R A \<equiv> \<forall>s h dh. (Some (s, h), None) \<notin> R \<and> h \<bottom> dh \<and> (s, dh) \<in> A \<longrightarrow> (Some (s, h ++ dh), None) \<notin> R"

definition frame :: "('a \<times> heap) option rel \<Rightarrow> 'a pred \<Rightarrow> bool" where
  "frame R A \<equiv> \<forall>so ho h dh s' h'.
              (Some (so, ho), None) \<notin> R \<and>
              ho \<bottom> dh \<and>
              h = ho ++ dh \<and> (so, dh) \<in> A \<and>
              (Some (so, h), Some (s', h')) \<in> R
              \<longrightarrow> (\<exists>ho' dh'. ho' \<bottom> dh' \<and> h' = ho' ++ dh' \<and> (Some (so, ho), Some (s', ho')) \<in> R \<and> (s', dh') \<in> A)"

lemma "stran_local (stran R) A \<Longrightarrow> safe R A"
  apply (auto simp: stran_local_def safe_def)
  apply (erule_tac x=s in allE)
  apply (erule_tac x=h in allE)
  apply (erule_tac x=dh in allE)
  apply (case_tac "stran R (s, h)")
  apply auto
  apply (clarsimp simp: stran_def)+
done

lemma heap_cut: "h1 \<bottom> h2 \<Longrightarrow> h1 \<bottom> h3 \<Longrightarrow> h1 ++ h2 = h1 ++ h3 \<Longrightarrow> h2 = h3"
  apply (auto simp: ortho_def map_add_def fun_eq_iff)
  apply (erule_tac x=x in allE)
  apply (case_tac "h2 x")
  apply auto
  apply (case_tac "h3 x")
  apply auto
  apply (case_tac "h3 x")
  apply auto
done

lemma "stran_local (stran R) A \<Longrightarrow> frame R A"
  apply (auto simp: stran_local_def frame_def)
  apply (erule_tac x=so in allE)
  apply (erule_tac x=ho in allE)
  apply (erule_tac x=dh in allE)
  apply auto
  apply (case_tac "stran R (so, ho)")
  apply auto
  apply (simp add: stran_def)
  apply (case_tac "stran R (so, ho ++ dh)")
  apply (simp add: stran_def)
  apply auto
  apply (auto simp: sep_def)
  apply (frule stranD2) back
  apply assumption

  apply (erule subseteqE)
  apply (erule_tac x="(s', h')" in allE)
  apply auto
  apply (rule_tac x=h1 in exI)
  apply (rule_tac x=h2 in exI)
  apply clarsimp
  using stranD apply blast
done

lemma "safe R A \<Longrightarrow> frame R A \<Longrightarrow> stran_local (stran R) A"
  apply (auto simp: stran_local_def)
  apply (case_tac "stran R (s, h)")
  apply simp_all
  apply (case_tac "stran R (s, h ++ h')")
  apply simp_all
  apply (simp add: stran_none safe_def)
  apply (drule stran_some)
  apply (erule_tac x=s in allE)
  apply (erule_tac x=h in allE)
  apply (erule_tac x=h' in allE)
  apply clarsimp

  apply (rule subrelI)
  apply (frule stranD) back
  apply assumption
  apply (simp add: frame_def)

  apply (erule_tac x=s in allE)
  apply (erule_tac x=h in allE)
  apply (erule_tac x=h' in allE)
  apply clarsimp
  apply (erule_tac x=x in allE)
  apply (erule_tac x=y in allE)
  apply clarsimp
  apply (frule stran_some)
  apply clarsimp
  apply (simp add: sep_def)
  apply (rule_tac x=ho' in exI)
  apply (rule_tac x=dh' in exI)
  apply auto
  apply (drule stranD2)
apply assumption
by auto

lemma "ptran R Q = {a. \<forall>b. if (Some a, None) \<notin> R then (Some a, Some b) \<in> R \<longrightarrow> b \<in> Q else False}"
  by (auto simp: ptran_def)

lemma "(\<exists>a. P \<longleftrightarrow> Q a) \<longleftrightarrow> (P \<longleftrightarrow> (\<exists>a. Q a))"
apply auto
oops

lemma "(Some a, None) \<notin> R \<Longrightarrow> a \<notin> ptran R Q \<longleftrightarrow> (\<exists>b. (Some a, Some b) \<in> R \<and> b \<notin> Q)"
by (auto simp: ptran_def)

end


theory ValueOntology                 (*Benzmüller,Fuenmayor & Lomfeld, 2020*)
  imports PreferenceLogicBasics
begin (** proof of concept: ethical value ontology and wild animal cases **)
abbreviation pref::\<nu>            ("_\<^bold>\<prec>_")   where  "\<phi> \<^bold>\<prec> \<psi> \<equiv> \<phi> \<prec>\<^sub>A\<^sub>E \<psi>"
abbreviation subs::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" ("_\<subseteq>_")   where  "\<alpha>\<subseteq>\<beta> \<equiv> \<forall>w.(\<alpha> w)\<longrightarrow>(\<beta> w)"
abbreviation boxg::\<mu> ("\<^bold>\<box>_") where "\<^bold>\<box>\<phi> \<equiv> \<^bold>\<box>\<^sup>\<preceq>\<phi>"

(*ethico-legal values*)
datatype UVAL = SECURITY | LIBERTY | EQUALITY | UTILITY
datatype VAL = WILL | RELI | RESP | EQUI | FAIR | EFFI | STAB | GAIN

(*contenders have values*)
datatype c = p | d      (*parties/contenders: plaintiff, defendant*)
fun other::"c\<Rightarrow>c" ("_\<inverse>") where "p\<inverse> = d" | "d\<inverse>= p"
consts UV::"c\<Rightarrow>UVAL\<Rightarrow>\<sigma>" ("_\<up>_") (*c\<up>UV: contenders c has upper value UV*)
consts  V::"c\<Rightarrow> VAL\<Rightarrow>\<sigma>" ("_\<down>_") (*c\<down>V: contenders c has value V*)

axiomatization where (*axiomatization of the ethico-legal value ontology*)
V1: "\<lfloor>(x\<up>SECURITY \<^bold>\<and> x\<up>EQUALITY) \<^bold>\<rightarrow> \<^bold>\<not>(x\<up>UTILITY \<^bold>\<and> x\<up>LIBERTY)\<rfloor>" and
V2: "\<lfloor>(x\<down>RELI \<^bold>\<or> x\<down>EQUI \<^bold>\<or> x\<down>STAB \<^bold>\<or> x\<down>EFFI) \<^bold>\<leftrightarrow> x\<up>SECURITY\<rfloor>" and
V3: "\<lfloor>(x\<down>FAIR \<^bold>\<or> x\<down>RESP \<^bold>\<or> x\<down>EQUI \<^bold>\<or> x\<down>RELI) \<^bold>\<leftrightarrow> x\<up>EQUALITY\<rfloor>" and
V4: "\<lfloor>(x\<down>WILL \<^bold>\<or> x\<down>GAIN \<^bold>\<or> x\<down>RESP \<^bold>\<or> x\<down>FAIR) \<^bold>\<leftrightarrow> x\<up>LIBERTY\<rfloor>" and
V5: "\<lfloor>(x\<down>EFFI \<^bold>\<or> x\<down>STAB \<^bold>\<or> x\<down>GAIN \<^bold>\<or> x\<down>WILL) \<^bold>\<leftrightarrow> x\<up>UTILITY\<rfloor>"

lemma L1: "\<lfloor>(x\<up>UTILITY  \<^bold>\<and> x\<up>LIBERTY)  \<^bold>\<rightarrow> \<^bold>\<not>(x\<up>SECURITY \<^bold>\<and> x\<up>EQUALITY)\<rfloor>"
  using V1 by blast
lemma L2: "\<lfloor>(x\<up>LIBERTY  \<^bold>\<and> x\<up>EQUALITY) \<^bold>\<rightarrow> \<^bold>\<not>(x\<up>SECURITY \<^bold>\<and> x\<up>UTILITY)\<rfloor>"
  using V1 by blast
lemma L3: "\<lfloor>(x\<up>EQUALITY \<^bold>\<and> x\<up>SECURITY) \<^bold>\<rightarrow> \<^bold>\<not>(x\<up>UTILITY  \<^bold>\<and> x\<up>LIBERTY)\<rfloor>"
  using V1 by blast

(*exploring & assessing the ontology with reasoning tools*)
lemma "True" nitpick[satisfy,max_genuine=80,eval=UV V p d] oops (*show models*)
lemma "\<exists>x. \<lfloor>x\<down>GAIN \<^bold>\<and> x\<down>STAB \<^bold>\<and> x\<down>WILL\<rfloor>" nitpick[satisfy]  oops (*satisfiable*)
lemma "\<exists>x. \<lfloor>x\<down>RELI \<^bold>\<and> x\<down>WILL\<rfloor>" nitpick[satisfy]  oops (*not satisfiable*)
lemma "\<not>(\<exists>x. \<lfloor>x\<down>RELI \<^bold>\<and> x\<down>WILL\<rfloor>)" using L2 V2 V3 V4 V5 by blast
end


(*  Title:      State based hotel key card system with "new card"

    Author:     Tobias Nipkow, TU Muenchen

Like State.thy but with additional features: cards can be lost and new
ones can be issued. Cannot build on State.thy because record state
needs to be extended with a new field. This would require explaining
Isabelle's record inheritance. An interesting project, but not now.
*)

(*<*)
theory NewCard
imports Main
begin

abbreviation
 "SomeFloor" ("(\<lfloor>_\<rfloor>)") where "\<lfloor>x\<rfloor> \<equiv> Some x"

declare if_split_asm[split]

typedecl guest
typedecl key
type_synonym card = "key * key"
typedecl room

record state =
 (* reception: *)
 owns :: "room \<Rightarrow> guest option"
 prevk :: "room \<Rightarrow> key"
 currk :: "room \<Rightarrow> key"
 issued :: "key set"
 (* guests: *)
 cards :: "guest \<Rightarrow> card set"
 (* rooms: *)
 roomk :: "room \<Rightarrow> key"
 isin :: "room \<Rightarrow> guest set"
 (* ghost variable: *)
 safe :: "room \<Rightarrow> bool"

inductive_set reach :: "state set"
where
init: (* prevk = arbitrary prevents the invariant prevk : issued *)
"\<forall>r r'. (initk r = initk r') = (r = r') \<Longrightarrow>
\<lparr> owns = (\<lambda>r. None), prevk = initk, currk = initk, issued = range initk,
  cards = (\<lambda>g. {}), roomk = initk, isin = (\<lambda>r. {}),
  safe = (\<lambda>r. True) \<rparr> \<in> reach"

| enter_room:
"\<lbrakk> s \<in> reach; (k,k') \<in> cards s g; roomk s r \<in> {k,k'} \<rbrakk> \<Longrightarrow>
s\<lparr> isin := (isin s)(r := isin s r \<union> {g}),
   roomk := (roomk s)(r := k'),
   safe := (safe s)(r := owns s r = \<lfloor>g\<rfloor> \<and> isin s r = {} \<and> k' = currk s r
                              \<or> safe s r)
  \<rparr> \<in> reach"

| exit_room:
"\<lbrakk> s \<in> reach;  g \<in> isin s r \<rbrakk> \<Longrightarrow>
s\<lparr> isin := (isin s)(r := isin s r - {g}) \<rparr> \<in> reach"

| check_in:
"\<lbrakk> s : reach; k \<notin> issued s \<rbrakk> \<Longrightarrow>
 s\<lparr>currk := (currk s)(r := k), prevk := (prevk s)(r := currk s r),
   issued := issued s \<union> {k},
   cards := (cards s)(g := cards s g \<union> {(currk s r, k)}),
   owns :=  (owns s)(r := Some g),
   safe := (safe s)(r := False) \<rparr> : reach"

| loose_card:
"s : reach \<Longrightarrow> c : cards s g \<Longrightarrow>
 s\<lparr>cards := (cards s)(g := cards s g - {c})\<rparr> : reach"

| new_card:
"s : reach \<Longrightarrow> owns s r = Some g \<Longrightarrow>
 s\<lparr>cards := (cards s)(g := cards s g \<union> {(prevk s r, currk s r)})\<rparr> : reach"

lemma currk_issued[simp]: "s : reach \<Longrightarrow> currk s r : issued s"
by (induct set: reach) auto

lemma prevk_issued[simp]: "s : reach \<Longrightarrow> prevk s r : issued s"
by (induct set: reach) auto

lemma key2_issued[simp]: "s : reach \<Longrightarrow> (k,k') : cards s g \<Longrightarrow> k' : issued s"
by (induct set: reach) auto

lemma key1_issued[simp]: "s : reach \<Longrightarrow> (k,k') : cards s g \<Longrightarrow> k : issued s"
by (induct set: reach) auto

lemma roomk_issued[simp]: "s : reach \<Longrightarrow> roomk s k : issued s"
by (induct set: reach) auto

lemma currk_inj[simp]:
 "s : reach \<Longrightarrow> \<forall>r r'. (currk s r = currk s r') = (r = r')"
by (induct set: reach) auto

lemma currk_not_prevk[simp]:
 "s : reach \<Longrightarrow> owns s r' = Some g \<Longrightarrow> currk s r \<noteq> prevk s r'"
by (induct set: reach) auto

lemma key1_not_currk[simp]:
 "s : reach \<Longrightarrow> (currk s r,k') \<notin> cards s g"
by (induct set: reach) auto

lemma key2_not_currk:
 "s : reach \<Longrightarrow> owns s r = Some g \<Longrightarrow> g \<noteq> g' \<Longrightarrow> (k, currk s r) \<notin> cards s g'"
by (induct set: reach) auto

lemma guest_key2_disj2[simp]:
"\<lbrakk> s : reach; (k\<^sub>1,k) \<in> cards s g\<^sub>1; (k\<^sub>2,k) \<in> cards s g\<^sub>2 \<rbrakk> \<Longrightarrow> g\<^sub>1=g\<^sub>2"
by (induct set: reach) (auto simp:key2_not_currk)

lemma safe_roomk_currk[simp]:
 "s : reach \<Longrightarrow> safe s r \<Longrightarrow> roomk s r = currk s r"
by (induct set: reach) auto

lemma only_owner_enter_normal[simp]:
 "\<lbrakk> s : reach; safe s r; (k',roomk s r) \<in> cards s g \<rbrakk> \<Longrightarrow> owns s r = Some g"
by (induct set: reach) auto

theorem "s : reach \<Longrightarrow> safe s r \<Longrightarrow> g : isin s r \<Longrightarrow> owns s r = Some g"
by (induct set: reach) auto

lemmas new_invs = prevk_issued currk_not_prevk key2_not_currk
(*>*)

subsection\<open>An extension\<close>

text\<open>
To test the flexibility of our model we extended it with the
possibility for obtaining a new card, e.g.\ when one has lost one's
card. Now reception needs to remember not just the current but also
the previous key for each room, i.e.\ a new field \<open>prevk :: room
\<Rightarrow> key\<close> is added to @{typ state}. It is initialized with the same value
as @{const currk}: though strictly speaking it could be arbitrary,
this permits the convenient invariant @{prop"prevk s r \<in> issued s"}.
Upon check-in we set \<open>prevk\<close> to \mbox{@{term"(prevk s)(r := currk s r)"}}.
Event \<open>new_card\<close> is simple enough:
@{thm[display] new_card}

The verification is not seriously affected. Some additional
invariants are required
@{thm[display] new_invs}
but the proofs are still of the same trivial induct-auto format.

Adding a further event for loosing a card has no impact at all on the proofs.
\<close>

(*<*)
end
(*>*)