(*  Title:      HOL/Nunchaku_Examples/Hotel_Nuns_FO.thy
    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    Copyright   2010-2011

Nunchaku example based on Tobias Nipkow's hotel key card formalization.
*)

section {* Nunchaku Example Based on Tobias Nipkow's Hotel Key Card
          Formalization *}

theory Hotel_Nuns_FO
imports "../Nunchaku"
begin

nunchaku_params [verbose, max_potential = 0, timeout = 240]

(*
typedecl guest
typedecl key
typedecl room

typedecl card
typedecl state
*)

datatype room = R1
datatype guest = G1 | G2
datatype key = K1 | K2 | K3 | K4
datatype card = C1 | C2 | C3 | C4 | C5
datatype state = S1 | S2 | S3 | S4 | S5 | S6

(*
nitpick [card room = 1, card guest = 2, card "guest option" = 3,
         card key = 4, card state = 6,
*)

consts
  fst :: "card \<Rightarrow> key"
  snd :: "card \<Rightarrow> key"

consts
  owns :: "state \<Rightarrow> room \<Rightarrow> guest option"
  currk :: "state \<Rightarrow> room \<Rightarrow> key"
  issued :: "state \<Rightarrow> key \<Rightarrow> bool"
  cards :: "state \<Rightarrow> guest \<Rightarrow> card \<Rightarrow> bool"
  roomk :: "state \<Rightarrow> room \<Rightarrow> key"
  isin :: "state \<Rightarrow> room \<Rightarrow> guest \<Rightarrow> bool"
  safe :: "state \<Rightarrow> room \<Rightarrow> bool"

definition "next" where
  "next s s' =
   ((s = S1 \<and> s' = S2) \<or>
    (s = S2 \<and> s' = S3) \<or>
    (s = S3 \<and> s' = S4) \<or>
    (s = S4 \<and> s' = S5) \<or>
    (s = S5 \<and> s' = S6))"

consts buggy :: bool

inductive reach :: "state \<Rightarrow> bool" where
init:
  "s = S1 \<Longrightarrow>
   (\<forall>r. owns s r = None) \<Longrightarrow>
   (\<forall>r. \<forall>r'. currk s r = currk s r' \<longrightarrow> r = r') \<Longrightarrow>
   (\<forall>k. issued s k \<longleftrightarrow> (\<exists>r. currk s r = k)) \<Longrightarrow>
   (\<forall>g c. \<not> cards s g c) \<Longrightarrow>
   (\<forall>r. roomk s r = currk s r) \<Longrightarrow>
   (\<forall>r g. \<not> isin s r g) \<Longrightarrow>
   (\<forall>r. safe s r) \<Longrightarrow> reach s"
| check_in:
  "next s s' \<Longrightarrow>
   reach s \<Longrightarrow>
   \<not> issued s K \<Longrightarrow>
   fst C = currk s R \<Longrightarrow>
   snd C = K \<Longrightarrow>
   (\<forall>r. owns s' r = (if r = R then Some G else owns s r)) \<Longrightarrow>
   (\<forall>r. currk s' r = (if r = R then K else currk s r)) \<Longrightarrow>
   (\<forall>k. issued s' k = (k = K \<or> issued s k)) \<Longrightarrow>
   (\<forall>g c. cards s' g c = ((g = G \<and> c = C) \<or> cards s g c)) \<Longrightarrow>
   (\<forall>r. roomk s' r = roomk s r) \<Longrightarrow>
   (\<forall>r g. isin s' r g = isin s r g) \<Longrightarrow>
   (\<forall>r. safe s' r = (r \<noteq> R \<and> safe s r)) \<Longrightarrow>
   reach s'"
| enter_room:
  "next s s' \<Longrightarrow>
   reach s \<Longrightarrow>
   cards s G C \<Longrightarrow>
   fst C = K \<Longrightarrow>
   snd C = K' \<Longrightarrow>
   roomk s r = K \<or> roomk s r = K' \<Longrightarrow>
   (\<forall>r. owns s' r = owns s r) \<Longrightarrow>
   (\<forall>r. currk s' r = currk s r) \<Longrightarrow>
   (\<forall>k. issued s' k = issued s k) \<Longrightarrow>
   (\<forall>g c. cards s' g c = cards s g c) \<Longrightarrow>
   (\<forall>r. roomk s' r = (if r = R then K' else roomk s r)) \<Longrightarrow>
   (\<forall>r g. isin s' r g = ((r = R \<and> g = G) \<or> isin s r g)) \<Longrightarrow>
   (\<forall>r. safe s' r = (if r = R then (owns s R = Some G \<and> (\<forall>r g. \<not> isin s r g) \<and> (buggy \<or> K' = currk s R)) \<or> safe s R
      else safe s r)) \<Longrightarrow>
   reach s'"
| exit_room:
  "next s s' \<Longrightarrow>
   reach s \<Longrightarrow>
   isin s R G \<Longrightarrow>
   (\<forall>r. owns s' r = owns s r) \<Longrightarrow>
   (\<forall>r. currk s' r = currk s r) \<Longrightarrow>
   (\<forall>k. issued s' k = issued s k) \<Longrightarrow>
   (\<forall>g c. cards s' g c = cards s g c) \<Longrightarrow>
   (\<forall>r. roomk s' r = roomk s r) \<Longrightarrow>
   (\<forall>r g. isin s' r g = ((r \<noteq> R \<or> g \<noteq> G) \<and> isin s r g)) \<Longrightarrow>
   (\<forall>r. safe s' r = safe s r) \<Longrightarrow>
   reach s'"

axiomatization reach' where
reach': "reach' a \<Longrightarrow>
((\<exists>s. a = s \<and>
      s = S1 \<and>
      (\<forall>r. owns s r = None) \<and>
      (\<forall>r r'. currk s r = currk s r' \<longrightarrow> r = r') \<and>
      (\<forall>k. issued s k = (\<exists>r. currk s r = k)) \<and>
      (\<forall>g c. \<not> cards s g c) \<and> (\<forall>r. roomk s r = currk s r) \<and> (\<forall>r g. \<not> isin s r g) \<and> (\<forall>r. safe s r)) \<or>
 (\<exists>s s' K C R G.
     a = s' \<and>
     next s s' \<and>
     reach' s \<and>
     \<not> issued s K \<and>
     Hotel_Nuns_FO.fst C = currk s R \<and>
     Hotel_Nuns_FO.snd C = K \<and>
     (\<forall>r. owns s' r = (if r = R then Some G else owns s r)) \<and>
     (\<forall>r. currk s' r = (if r = R then K else currk s r)) \<and>
     (\<forall>k. issued s' k = (k = K \<or> issued s k)) \<and>
     (\<forall>g c. cards s' g c = (g = G \<and> c = C \<or> cards s g c)) \<and>
     (\<forall>r. roomk s' r = roomk s r) \<and>
     (\<forall>r g. isin s' r g = isin s r g) \<and> (\<forall>r. safe s' r = (r \<noteq> R \<and> safe s r))) \<or>
 (\<exists>s s' G C K K' r R.
     a = s' \<and>
     next s s' \<and>
     reach' s \<and>
     cards s G C \<and>
     Hotel_Nuns_FO.fst C = K \<and>
     Hotel_Nuns_FO.snd C = K' \<and>
     (roomk s r = K \<or> roomk s r = K') \<and>
     (\<forall>r. owns s' r = owns s r) \<and>
     (\<forall>r. currk s' r = currk s r) \<and>
     (\<forall>k. issued s' k = issued s k) \<and>
     (\<forall>g c. cards s' g c = cards s g c) \<and>
     (\<forall>r. roomk s' r = (if r = R then K' else roomk s r)) \<and>
     (\<forall>r g. isin s' r g = (r = R \<and> g = G \<or> isin s r g)) \<and>
     (\<forall>r. safe s' r =
          (if r = R then owns s R = Some G \<and> (\<forall>r g. \<not> isin s r g) \<and> (buggy \<or> K' = currk s R) \<or> safe s R
           else safe s r))) \<or>
 (\<exists>s s' R G.
     a = s' \<and>
     next s s' \<and>
     reach' s \<and>
     isin s R G \<and>
     (\<forall>r. owns s' r = owns s r) \<and>
     (\<forall>r. currk s' r = currk s r) \<and>
     (\<forall>k. issued s' k = issued s k) \<and>
     (\<forall>g c. cards s' g c = cards s g c) \<and>
     (\<forall>r. roomk s' r = roomk s r) \<and>
     (\<forall>r g. isin s' r g = ((r \<noteq> R \<or> g \<noteq> G) \<and> isin s r g)) \<and> (\<forall>r. safe s' r = safe s r)))"

theorem safe: "buggy \<Longrightarrow> reach' s \<Longrightarrow> safe s r \<Longrightarrow> isin s r g \<Longrightarrow> owns s r = Some g"
nunchaku [wf, overlord, timeout = 60]
(* nitpick[card = 100] *)
(* nitpick[wf, card = 100, debug] *)
(* nitpick[card = 10, datatype_sym_break = 0, kodkod_sym_break = 0, timeout = 300] *)
(*
*)
(* nitpick[card = 10] *)

oops

(*
inductive_set reach :: "state set" where
exit_room:

theorem safe: "s \<in> reach \<Longrightarrow> safe s r \<Longrightarrow> g \<in> isin s r \<Longrightarrow> owns s r = Some g"
nunchaku [expect = genuine]
oops
*)

end


(*  Title:      HOL/Types_To_Sets/Examples/Prerequisites.thy
    Author:     Ondřej Kunčar, TU München
*)

theory Prerequisites
  imports MainRLT
  keywords "lemmas_with" :: thy_decl
begin

context
  fixes Rep Abs A T
  assumes type: "type_definition Rep Abs A"
  assumes T_def: "T \<equiv> (\<lambda>(x::'a) (y::'b). x = Rep y)"
begin

lemma type_definition_Domainp: "Domainp T = (\<lambda>x. x \<in> A)"
proof -
  interpret type_definition Rep Abs A by(rule type)
  show ?thesis
    unfolding Domainp_iff[abs_def] T_def fun_eq_iff
    by (metis Abs_inverse Rep)
qed

end

subsection \<open>setting up transfer for local typedef\<close>

lemmas [transfer_rule] = \<comment> \<open>prefer right-total rules\<close>
  right_total_All_transfer
  right_total_UNIV_transfer
  right_total_Ex_transfer

locale local_typedef = fixes S ::"'b set" and s::"'s itself"
  assumes Ex_type_definition_S: "\<exists>(Rep::'s \<Rightarrow> 'b) (Abs::'b \<Rightarrow> 's). type_definition Rep Abs S"
begin

definition "rep = fst (SOME (Rep::'s \<Rightarrow> 'b, Abs). type_definition Rep Abs S)"
definition "Abs = snd (SOME (Rep::'s \<Rightarrow> 'b, Abs). type_definition Rep Abs S)"

lemma type_definition_S: "type_definition rep Abs S"
  unfolding Abs_def rep_def split_beta'
  by (rule someI_ex) (use Ex_type_definition_S in auto)

lemma rep_in_S[simp]: "rep x \<in> S"
  and rep_inverse[simp]: "Abs (rep x) = x"
  and Abs_inverse[simp]: "y \<in> S \<Longrightarrow> rep (Abs y) = y"
  using type_definition_S
  unfolding type_definition_def by auto

definition cr_S where "cr_S \<equiv> \<lambda>s b. s = rep b"
lemmas Domainp_cr_S = type_definition_Domainp[OF type_definition_S cr_S_def, transfer_domain_rule]
lemmas right_total_cr_S = typedef_right_total[OF type_definition_S cr_S_def, transfer_rule]
  and bi_unique_cr_S = typedef_bi_unique[OF type_definition_S cr_S_def, transfer_rule]
  and left_unique_cr_S = typedef_left_unique[OF type_definition_S cr_S_def, transfer_rule]
  and right_unique_cr_S = typedef_right_unique[OF type_definition_S cr_S_def, transfer_rule]

lemma cr_S_rep[intro, simp]: "cr_S (rep a) a" by (simp add: cr_S_def)
lemma cr_S_Abs[intro, simp]: "a\<in>S \<Longrightarrow> cr_S a (Abs a)" by (simp add: cr_S_def)

end

subsection \<open>some \<close>

subsection \<open>Tool support\<close>

lemmas subset_iff' = subset_iff[folded Ball_def]

ML \<open>
structure More_Simplifier =
struct

fun asm_full_var_simplify ctxt thm =
  let
    val ((_, [thm']), ctxt') = Variable.import false [thm] ctxt
  in
    Simplifier.asm_full_simplify ctxt' thm'
    |> singleton (Variable.export ctxt' ctxt)
    |> Drule.zero_var_indexes
  end

fun var_simplify_only ctxt ths thm =
  asm_full_var_simplify (Raw_Simplifier.clear_simpset ctxt addsimps ths) thm

val var_simplified = Attrib.thms >>
  (fn ths => Thm.rule_attribute ths
    (fn context => var_simplify_only (Context.proof_of context) ths))

val _ = Theory.setup (Attrib.setup \<^binding>\<open>var_simplified\<close> var_simplified "simplified rule (with vars)")

end
\<close>

ML \<open>
val _ = Outer_Syntax.local_theory' \<^command_keyword>\<open>lemmas_with\<close> "note theorems with (the same) attributes"
    (Parse.attribs --| \<^keyword>\<open>:\<close> -- Parse_Spec.name_facts -- Parse.for_fixes
     >> (fn (((attrs),facts), fixes) =>
      #2 oo Specification.theorems_cmd Thm.theoremK
        (map (apsnd (map (apsnd (fn xs => attrs@xs)))) facts) fixes))
\<close>

end