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

section {* Cartesian products *}

theory Product_Type
imports Typedef Inductive Fun
keywords "inductive_set" "coinductive_set" :: thy_decl
begin

subsection {* @{typ bool} is a datatype *}

free_constructors case_bool for True | False
  by auto

text {* Avoid name clashes by prefixing the output of @{text old_rep_datatype} with @{text old}. *}

setup {* Sign.mandatory_path "old" *}

old_rep_datatype True False by (auto intro: bool_induct)

setup {* Sign.parent_path *}

text {* But erase the prefix for properties that are not generated by @{text free_constructors}. *}

setup {* Sign.mandatory_path "bool" *}

lemmas induct = old.bool.induct
lemmas inducts = old.bool.inducts
lemmas rec = old.bool.rec
lemmas simps = bool.distinct bool.case bool.rec

setup {* Sign.parent_path *}

declare case_split [cases type: bool]
  -- "prefer plain propositional version"

lemma
  shows [code]: "HOL.equal False P \<longleftrightarrow> \<not> P"
    and [code]: "HOL.equal True P \<longleftrightarrow> P"
    and [code]: "HOL.equal P False \<longleftrightarrow> \<not> P"
    and [code]: "HOL.equal P True \<longleftrightarrow> P"
    and [code nbe]: "HOL.equal P P \<longleftrightarrow> True"
  by (simp_all add: equal)

lemma If_case_cert:
  assumes "CASE \<equiv> (\<lambda>b. If b f g)"
  shows "(CASE True \<equiv> f) &&& (CASE False \<equiv> g)"
  using assms by simp_all

setup {* Code.add_case @{thm If_case_cert} *}

code_printing
  constant "HOL.equal :: bool \<Rightarrow> bool \<Rightarrow> bool" \<rightharpoonup> (Haskell) infix 4 "=="
| class_instance "bool" :: "equal" \<rightharpoonup> (Haskell) -

subsection {* The @{text unit} type *}

typedef unit = "{True}"
  by auto

definition Unity :: unit  ("'(')")
  where "() = Abs_unit True"

lemma unit_eq [no_atp]: "u = ()"
  by (induct u) (simp add: Unity_def)

text {*
  Simplification procedure for @{thm [source] unit_eq}.  Cannot use
  this rule directly --- it loops!
*}

simproc_setup unit_eq ("x::unit") = {*
  fn _ => fn _ => fn ct =>
    if HOLogic.is_unit (term_of ct) then NONE
    else SOME (mk_meta_eq @{thm unit_eq})
*}

free_constructors case_unit for "()"
  by auto

text {* Avoid name clashes by prefixing the output of @{text old_rep_datatype} with @{text old}. *}

setup {* Sign.mandatory_path "old" *}

old_rep_datatype "()" by simp

setup {* Sign.parent_path *}

text {* But erase the prefix for properties that are not generated by @{text free_constructors}. *}

setup {* Sign.mandatory_path "unit" *}

lemmas induct = old.unit.induct
lemmas inducts = old.unit.inducts
lemmas rec = old.unit.rec
lemmas simps = unit.case unit.rec

setup {* Sign.parent_path *}

lemma unit_all_eq1: "(!!x::unit. PROP P x) == PROP P ()"
  by simp

lemma unit_all_eq2: "(!!x::unit. PROP P) == PROP P"
  by (rule triv_forall_equality)

text {*
  This rewrite counters the effect of simproc @{text unit_eq} on @{term
  [source] "%u::unit. f u"}, replacing it by @{term [source]
  f} rather than by @{term [source] "%u. f ()"}.
*}

lemma unit_abs_eta_conv [simp]: "(%u::unit. f ()) = f"
  by (rule ext) simp

lemma UNIV_unit:
  "UNIV = {()}" by auto

instantiation unit :: default
begin

definition "default = ()"

instance ..

end

instantiation unit :: "{complete_boolean_algebra, complete_linorder, wellorder}"
begin

definition less_eq_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool"
where
  "(_::unit) \<le> _ \<longleftrightarrow> True"

lemma less_eq_unit [iff]:
  "(u::unit) \<le> v"
  by (simp add: less_eq_unit_def)

definition less_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool"
where
  "(_::unit) < _ \<longleftrightarrow> False"

lemma less_unit [iff]:
  "\<not> (u::unit) < v"
  by (simp_all add: less_eq_unit_def less_unit_def)

definition bot_unit :: unit
where
  [code_unfold]: "\<bottom> = ()"

definition top_unit :: unit
where
  [code_unfold]: "\<top> = ()"

definition inf_unit :: "unit \<Rightarrow> unit \<Rightarrow> unit"
where
  [simp]: "_ \<sqinter> _ = ()"

definition sup_unit :: "unit \<Rightarrow> unit \<Rightarrow> unit"
where
  [simp]: "_ \<squnion> _ = ()"

definition Inf_unit :: "unit set \<Rightarrow> unit"
where
  [simp]: "\<Sqinter>_ = ()"

definition Sup_unit :: "unit set \<Rightarrow> unit"
where
  [simp]: "\<Squnion>_ = ()"

definition uminus_unit :: "unit \<Rightarrow> unit"
where
  [simp]: "- _ = ()"

declare less_eq_unit_def [abs_def, code_unfold]
  less_unit_def [abs_def, code_unfold]
  inf_unit_def [abs_def, code_unfold]
  sup_unit_def [abs_def, code_unfold]
  Inf_unit_def [abs_def, code_unfold]
  Sup_unit_def [abs_def, code_unfold]
  uminus_unit_def [abs_def, code_unfold]

instance
  by intro_classes auto

end

code_printing
  type_constructor unit \<rightharpoonup>
    (SML) "unit"
    and (OCaml) "unit"
    and (Haskell) "()"
    and (Scala) "Unit"
| constant Unity \<rightharpoonup>
    (SML) "()"
    and (OCaml) "()"
    and (Haskell) "()"
    and (Scala) "()"
| class_instance unit :: equal \<rightharpoonup>
    (Haskell) -
| constant "HOL.equal :: unit \<Rightarrow> unit \<Rightarrow> bool" \<rightharpoonup>
    (Haskell) infix 4 "=="

code_reserved SML
  unit

code_reserved OCaml
  unit

code_reserved Scala
  Unit

subsection {* The product type *}

subsubsection {* Type definition *}

definition Pair_Rep :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" where
  "Pair_Rep a b = (\<lambda>x y. x = a \<and> y = b)"

definition "prod = {f. \<exists>a b. f = Pair_Rep (a\<Colon>'a) (b\<Colon>'b)}"

typedef ('a, 'b) prod (infixr "*" 20) = "prod :: ('a \<Rightarrow> 'b \<Rightarrow> bool) set"
  unfolding prod_def by auto

type_notation (xsymbols)
  "prod"  ("(_ \<times>/ _)" [21, 20] 20)
type_notation (HTML output)
  "prod"  ("(_ \<times>/ _)" [21, 20] 20)

definition Pair :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<times> 'b" where
  "Pair a b = Abs_prod (Pair_Rep a b)"

lemma prod_cases: "(\<And>a b. P (Pair a b)) \<Longrightarrow> P p"
  by (cases p) (auto simp add: prod_def Pair_def Pair_Rep_def)

free_constructors case_prod for Pair fst snd
proof -
  fix P :: bool and p :: "'a \<times> 'b"
  show "(\<And>x1 x2. p = Pair x1 x2 \<Longrightarrow> P) \<Longrightarrow> P"
    by (cases p) (auto simp add: prod_def Pair_def Pair_Rep_def)
next
  fix a c :: 'a and b d :: 'b
  have "Pair_Rep a b = Pair_Rep c d \<longleftrightarrow> a = c \<and> b = d"
    by (auto simp add: Pair_Rep_def fun_eq_iff)
  moreover have "Pair_Rep a b \<in> prod" and "Pair_Rep c d \<in> prod"
    by (auto simp add: prod_def)
  ultimately show "Pair a b = Pair c d \<longleftrightarrow> a = c \<and> b = d"
    by (simp add: Pair_def Abs_prod_inject)
qed

text {* Avoid name clashes by prefixing the output of @{text old_rep_datatype} with @{text old}. *}

setup {* Sign.mandatory_path "old" *}

old_rep_datatype Pair
by (erule prod_cases) (rule prod.inject)

setup {* Sign.parent_path *}

text {* But erase the prefix for properties that are not generated by @{text free_constructors}. *}

setup {* Sign.mandatory_path "prod" *}

declare
  old.prod.inject[iff del]

lemmas induct = old.prod.induct
lemmas inducts = old.prod.inducts
lemmas rec = old.prod.rec
lemmas simps = prod.inject prod.case prod.rec

setup {* Sign.parent_path *}

declare prod.case [nitpick_simp del]
declare prod.case_cong_weak [cong del]

subsubsection {* Tuple syntax *}

abbreviation (input) split :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c" where
  "split \<equiv> case_prod"

text {*
  Patterns -- extends pre-defined type @{typ pttrn} used in
  abstractions.
*}

nonterminal tuple_args and patterns

syntax
  "_tuple"      :: "'a => tuple_args => 'a * 'b"        ("(1'(_,/ _'))")
  "_tuple_arg"  :: "'a => tuple_args"                   ("_")
  "_tuple_args" :: "'a => tuple_args => tuple_args"     ("_,/ _")
  "_pattern"    :: "[pttrn, patterns] => pttrn"         ("'(_,/ _')")
  ""            :: "pttrn => patterns"                  ("_")
  "_patterns"   :: "[pttrn, patterns] => patterns"      ("_,/ _")

translations
  "(x, y)" == "CONST Pair x y"
  "_pattern x y" => "CONST Pair x y"
  "_patterns x y" => "CONST Pair x y"
  "_tuple x (_tuple_args y z)" == "_tuple x (_tuple_arg (_tuple y z))"
  "%(x, y, zs). b" == "CONST case_prod (%x (y, zs). b)"
  "%(x, y). b" == "CONST case_prod (%x y. b)"
  "_abs (CONST Pair x y) t" => "%(x, y). t"
  -- {* The last rule accommodates tuples in `case C ... (x,y) ... => ...'
     The (x,y) is parsed as `Pair x y' because it is logic, not pttrn *}

(*reconstruct pattern from (nested) splits, avoiding eta-contraction of body;
  works best with enclosing "let", if "let" does not avoid eta-contraction*)
print_translation {*
  let
    fun split_tr' [Abs (x, T, t as (Abs abs))] =
          (* split (%x y. t) => %(x,y) t *)
          let
            val (y, t') = Syntax_Trans.atomic_abs_tr' abs;
            val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, T, t');
          in
            Syntax.const @{syntax_const "_abs"} $
              (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t''
          end
      | split_tr' [Abs (x, T, (s as Const (@{const_syntax case_prod}, _) $ t))] =
          (* split (%x. (split (%y z. t))) => %(x,y,z). t *)
          let
            val Const (@{syntax_const "_abs"}, _) $
              (Const (@{syntax_const "_pattern"}, _) $ y $ z) $ t' = split_tr' [t];
            val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, T, t');
          in
            Syntax.const @{syntax_const "_abs"} $
              (Syntax.const @{syntax_const "_pattern"} $ x' $
                (Syntax.const @{syntax_const "_patterns"} $ y $ z)) $ t''
          end
      | split_tr' [Const (@{const_syntax case_prod}, _) $ t] =
          (* split (split (%x y z. t)) => %((x, y), z). t *)
          split_tr' [(split_tr' [t])] (* inner split_tr' creates next pattern *)
      | split_tr' [Const (@{syntax_const "_abs"}, _) $ x_y $ Abs abs] =
          (* split (%pttrn z. t) => %(pttrn,z). t *)
          let val (z, t) = Syntax_Trans.atomic_abs_tr' abs in
            Syntax.const @{syntax_const "_abs"} $
              (Syntax.const @{syntax_const "_pattern"} $ x_y $ z) $ t
          end
      | split_tr' _ = raise Match;
  in [(@{const_syntax case_prod}, K split_tr')] end
*}

(* print "split f" as "\<lambda>(x,y). f x y" and "split (\<lambda>x. f x)" as "\<lambda>(x,y). f x y" *)
typed_print_translation {*
  let
    fun split_guess_names_tr' T [Abs (x, _, Abs _)] = raise Match
      | split_guess_names_tr' T [Abs (x, xT, t)] =
          (case (head_of t) of
            Const (@{const_syntax case_prod}, _) => raise Match
          | _ =>
            let
              val (_ :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match;
              val (y, t') = Syntax_Trans.atomic_abs_tr' ("y", yT, incr_boundvars 1 t $ Bound 0);
              val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, xT, t');
            in
              Syntax.const @{syntax_const "_abs"} $
                (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t''
            end)
      | split_guess_names_tr' T [t] =
          (case head_of t of
            Const (@{const_syntax case_prod}, _) => raise Match
          | _ =>
            let
              val (xT :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match;
              val (y, t') =
                Syntax_Trans.atomic_abs_tr' ("y", yT, incr_boundvars 2 t $ Bound 1 $ Bound 0);
              val (x', t'') = Syntax_Trans.atomic_abs_tr' ("x", xT, t');
            in
              Syntax.const @{syntax_const "_abs"} $
                (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t''
            end)
      | split_guess_names_tr' _ _ = raise Match;
  in [(@{const_syntax case_prod}, K split_guess_names_tr')] end
*}

subsubsection {* Code generator setup *}

code_printing
  type_constructor prod \<rightharpoonup>
    (SML) infix 2 "*"
    and (OCaml) infix 2 "*"
    and (Haskell) "!((_),/ (_))"
    and (Scala) "((_),/ (_))"
| constant Pair \<rightharpoonup>
    (SML) "!((_),/ (_))"
    and (OCaml) "!((_),/ (_))"
    and (Haskell) "!((_),/ (_))"
    and (Scala) "!((_),/ (_))"
| class_instance  prod :: equal \<rightharpoonup>
    (Haskell) -
| constant "HOL.equal :: 'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" \<rightharpoonup>
    (Haskell) infix 4 "=="

subsubsection {* Fundamental operations and properties *}

lemma Pair_inject:
  assumes "(a, b) = (a', b')"
    and "a = a' ==> b = b' ==> R"
  shows R
  using assms by simp

lemma surj_pair [simp]: "EX x y. p = (x, y)"
  by (cases p) simp

code_printing
  constant fst \<rightharpoonup> (Haskell) "fst"
| constant snd \<rightharpoonup> (Haskell) "snd"

lemma case_prod_unfold [nitpick_unfold]: "case_prod = (%c p. c (fst p) (snd p))"
  by (simp add: fun_eq_iff split: prod.split)

lemma fst_eqD: "fst (x, y) = a ==> x = a"
  by simp

lemma snd_eqD: "snd (x, y) = a ==> y = a"
  by simp

lemmas surjective_pairing = prod.collapse [symmetric]

lemma prod_eq_iff: "s = t \<longleftrightarrow> fst s = fst t \<and> snd s = snd t"
  by (cases s, cases t) simp

lemma prod_eqI [intro?]: "fst p = fst q \<Longrightarrow> snd p = snd q \<Longrightarrow> p = q"
  by (simp add: prod_eq_iff)

lemma split_conv [simp, code]: "split f (a, b) = f a b"
  by (fact prod.case)

lemma splitI: "f a b \<Longrightarrow> split f (a, b)"
  by (rule split_conv [THEN iffD2])

lemma splitD: "split f (a, b) \<Longrightarrow> f a b"
  by (rule split_conv [THEN iffD1])

lemma split_Pair [simp]: "(\<lambda>(x, y). (x, y)) = id"
  by (simp add: fun_eq_iff split: prod.split)

lemma split_eta: "(\<lambda>(x, y). f (x, y)) = f"
  -- {* Subsumes the old @{text split_Pair} when @{term f} is the identity function. *}
  by (simp add: fun_eq_iff split: prod.split)

lemma split_comp: "split (f \<circ> g) x = f (g (fst x)) (snd x)"
  by (cases x) simp

lemma split_twice: "split f (split g p) = split (\<lambda>x y. split f (g x y)) p"
  by (cases p) simp

lemma The_split: "The (split P) = (THE xy. P (fst xy) (snd xy))"
  by (simp add: case_prod_unfold)

lemmas split_weak_cong = prod.case_cong_weak
  -- {* Prevents simplification of @{term c}: much faster *}

lemma cond_split_eta: "(!!x y. f x y = g (x, y)) ==> (%(x, y). f x y) = g"
  by (simp add: split_eta)

lemma split_paired_all [no_atp]: "(!!x. PROP P x) == (!!a b. PROP P (a, b))"
proof
  fix a b
  assume "!!x. PROP P x"
  then show "PROP P (a, b)" .
next
  fix x
  assume "!!a b. PROP P (a, b)"
  from `PROP P (fst x, snd x)` show "PROP P x" by simp
qed

lemma case_prod_distrib: "f (case x of (x, y) \<Rightarrow> g x y) = (case x of (x, y) \<Rightarrow> f (g x y))"
  by (cases x) simp

text {*
  The rule @{thm [source] split_paired_all} does not work with the
  Simplifier because it also affects premises in congrence rules,
  where this can lead to premises of the form @{text "!!a b. ... =
  ?P(a, b)"} which cannot be solved by reflexivity.
*}

lemmas split_tupled_all = split_paired_all unit_all_eq2

ML {*
  (* replace parameters of product type by individual component parameters *)
  local (* filtering with exists_paired_all is an essential optimization *)
    fun exists_paired_all (Const (@{const_name Pure.all}, _) $ Abs (_, T, t)) =
          can HOLogic.dest_prodT T orelse exists_paired_all t
      | exists_paired_all (t $ u) = exists_paired_all t orelse exists_paired_all u
      | exists_paired_all (Abs (_, _, t)) = exists_paired_all t
      | exists_paired_all _ = false;
    val ss =
      simpset_of
       (put_simpset HOL_basic_ss @{context}
        addsimps [@{thm split_paired_all}, @{thm unit_all_eq2}, @{thm unit_abs_eta_conv}]
        addsimprocs [@{simproc unit_eq}]);
  in
    fun split_all_tac ctxt = SUBGOAL (fn (t, i) =>
      if exists_paired_all t then safe_full_simp_tac (put_simpset ss ctxt) i else no_tac);

    fun unsafe_split_all_tac ctxt = SUBGOAL (fn (t, i) =>
      if exists_paired_all t then full_simp_tac (put_simpset ss ctxt) i else no_tac);

    fun split_all ctxt th =
      if exists_paired_all (Thm.prop_of th)
      then full_simplify (put_simpset ss ctxt) th else th;
  end;
*}

setup {* map_theory_claset (fn ctxt => ctxt addSbefore ("split_all_tac", split_all_tac)) *}

lemma split_paired_All [simp, no_atp]: "(ALL x. P x) = (ALL a b. P (a, b))"
  -- {* @{text "[iff]"} is not a good idea because it makes @{text blast} loop *}
  by fast

lemma split_paired_Ex [simp, no_atp]: "(EX x. P x) = (EX a b. P (a, b))"
  by fast

lemma split_paired_The [no_atp]: "(THE x. P x) = (THE (a, b). P (a, b))"
  -- {* Can't be added to simpset: loops! *}
  by (simp add: split_eta)

text {*
  Simplification procedure for @{thm [source] cond_split_eta}.  Using
  @{thm [source] split_eta} as a rewrite rule is not general enough,
  and using @{thm [source] cond_split_eta} directly would render some
  existing proofs very inefficient; similarly for @{text
  split_beta}.
*}

ML {*
local
  val cond_split_eta_ss =
    simpset_of (put_simpset HOL_basic_ss @{context} addsimps @{thms cond_split_eta});
  fun Pair_pat k 0 (Bound m) = (m = k)
    | Pair_pat k i (Const (@{const_name Pair},  _) $ Bound m $ t) =
        i > 0 andalso m = k + i andalso Pair_pat k (i - 1) t
    | Pair_pat _ _ _ = false;
  fun no_args k i (Abs (_, _, t)) = no_args (k + 1) i t
    | no_args k i (t $ u) = no_args k i t andalso no_args k i u
    | no_args k i (Bound m) = m < k orelse m > k + i
    | no_args _ _ _ = true;
  fun split_pat tp i (Abs  (_, _, t)) = if tp 0 i t then SOME (i, t) else NONE
    | split_pat tp i (Const (@{const_name case_prod}, _) $ Abs (_, _, t)) = split_pat tp (i + 1) t
    | split_pat tp i _ = NONE;
  fun metaeq ctxt lhs rhs = mk_meta_eq (Goal.prove ctxt [] []
        (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)))
        (K (simp_tac (put_simpset cond_split_eta_ss ctxt) 1)));

  fun beta_term_pat k i (Abs (_, _, t)) = beta_term_pat (k + 1) i t
    | beta_term_pat k i (t $ u) =
        Pair_pat k i (t $ u) orelse (beta_term_pat k i t andalso beta_term_pat k i u)
    | beta_term_pat k i t = no_args k i t;
  fun eta_term_pat k i (f $ arg) = no_args k i f andalso Pair_pat k i arg
    | eta_term_pat _ _ _ = false;
  fun subst arg k i (Abs (x, T, t)) = Abs (x, T, subst arg (k+1) i t)
    | subst arg k i (t $ u) =
        if Pair_pat k i (t $ u) then incr_boundvars k arg
        else (subst arg k i t $ subst arg k i u)
    | subst arg k i t = t;
in
  fun beta_proc ctxt (s as Const (@{const_name case_prod}, _) $ Abs (_, _, t) $ arg) =
        (case split_pat beta_term_pat 1 t of
          SOME (i, f) => SOME (metaeq ctxt s (subst arg 0 i f))
        | NONE => NONE)
    | beta_proc _ _ = NONE;
  fun eta_proc ctxt (s as Const (@{const_name case_prod}, _) $ Abs (_, _, t)) =
        (case split_pat eta_term_pat 1 t of
          SOME (_, ft) => SOME (metaeq ctxt s (let val f $ _ = ft in f end))
        | NONE => NONE)
    | eta_proc _ _ = NONE;
end;
*}
simproc_setup split_beta ("split f z") = {* fn _ => fn ctxt => fn ct => beta_proc ctxt (term_of ct) *}
simproc_setup split_eta ("split f") = {* fn _ => fn ctxt => fn ct => eta_proc ctxt (term_of ct) *}

lemmas split_beta [mono] = prod.case_eq_if

lemma split_beta': "(\<lambda>(x,y). f x y) = (\<lambda>x. f (fst x) (snd x))"
  by (auto simp: fun_eq_iff)

lemmas split_split [no_atp] = prod.split
  -- {* For use with @{text split} and the Simplifier. *}

text {*
  @{thm [source] split_split} could be declared as @{text "[split]"}
  done after the Splitter has been speeded up significantly;
  precompute the constants involved and don't do anything unless the
  current goal contains one of those constants.
*}

lemmas split_split_asm [no_atp] = prod.split_asm

text {*
  \medskip @{term split} used as a logical connective or set former.

  \medskip These rules are for use with @{text blast}; could instead
  call @{text simp} using @{thm [source] prod.split} as rewrite. *}

lemma splitI2: "!!p. [| !!a b. p = (a, b) ==> c a b |] ==> split c p"
  apply (simp only: split_tupled_all)
  apply (simp (no_asm_simp))
  done

lemma splitI2': "!!p. [| !!a b. (a, b) = p ==> c a b x |] ==> split c p x"
  apply (simp only: split_tupled_all)
  apply (simp (no_asm_simp))
  done

lemma splitE: "split c p ==> (!!x y. p = (x, y) ==> c x y ==> Q) ==> Q"
  by (induct p) auto

lemma splitE': "split c p z ==> (!!x y. p = (x, y) ==> c x y z ==> Q) ==> Q"
  by (induct p) auto

lemma splitE2:
  "[| Q (split P z);  !!x y. [|z = (x, y); Q (P x y)|] ==> R |] ==> R"
proof -
  assume q: "Q (split P z)"
  assume r: "!!x y. [|z = (x, y); Q (P x y)|] ==> R"
  show R
    apply (rule r surjective_pairing)+
    apply (rule split_beta [THEN subst], rule q)
    done
qed

lemma splitD': "split R (a,b) c ==> R a b c"
  by simp

lemma mem_splitI: "z: c a b ==> z: split c (a, b)"
  by simp

lemma mem_splitI2: "!!p. [| !!a b. p = (a, b) ==> z: c a b |] ==> z: split c p"
by (simp only: split_tupled_all, simp)

lemma mem_splitE:
  assumes "z \<in> split c p"
  obtains x y where "p = (x, y)" and "z \<in> c x y"
  using assms by (rule splitE2)

declare mem_splitI2 [intro!] mem_splitI [intro!] splitI2' [intro!] splitI2 [intro!] splitI [intro!]
declare mem_splitE [elim!] splitE' [elim!] splitE [elim!]

ML {*
local (* filtering with exists_p_split is an essential optimization *)
  fun exists_p_split (Const (@{const_name case_prod},_) $ _ $ (Const (@{const_name Pair},_)$_$_)) = true
    | exists_p_split (t $ u) = exists_p_split t orelse exists_p_split u
    | exists_p_split (Abs (_, _, t)) = exists_p_split t
    | exists_p_split _ = false;
in
fun split_conv_tac ctxt = SUBGOAL (fn (t, i) =>
  if exists_p_split t
  then safe_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms split_conv}) i
  else no_tac);
end;
*}

(* This prevents applications of splitE for already splitted arguments leading
   to quite time-consuming computations (in particular for nested tuples) *)
setup {* map_theory_claset (fn ctxt => ctxt addSbefore ("split_conv_tac", split_conv_tac)) *}

lemma split_eta_SetCompr [simp, no_atp]: "(%u. EX x y. u = (x, y) & P (x, y)) = P"
  by (rule ext) fast

lemma split_eta_SetCompr2 [simp, no_atp]: "(%u. EX x y. u = (x, y) & P x y) = split P"
  by (rule ext) fast

lemma split_part [simp]: "(%(a,b). P & Q a b) = (%ab. P & split Q ab)"
  -- {* Allows simplifications of nested splits in case of independent predicates. *}
  by (rule ext) blast

(* Do NOT make this a simp rule as it
   a) only helps in special situations
   b) can lead to nontermination in the presence of split_def
*)
lemma split_comp_eq:
  fixes f :: "'a => 'b => 'c" and g :: "'d => 'a"
  shows "(%u. f (g (fst u)) (snd u)) = (split (%x. f (g x)))"
  by (rule ext) auto

lemma pair_imageI [intro]: "(a, b) : A ==> f a b : (%(a, b). f a b) ` A"
  apply (rule_tac x = "(a, b)" in image_eqI)
   apply auto
  done

lemma The_split_eq [simp]: "(THE (x',y'). x = x' & y = y') = (x, y)"
  by blast

(*
the following  would be slightly more general,
but cannot be used as rewrite rule:
### Cannot add premise as rewrite rule because it contains (type) unknowns:
### ?y = .x
Goal "[| P y; !!x. P x ==> x = y |] ==> (@(x',y). x = x' & P y) = (x,y)"
by (rtac some_equality 1)
by ( Simp_tac 1)
by (split_all_tac 1)
by (Asm_full_simp_tac 1)
qed "The_split_eq";
*)

text {*
  Setup of internal @{text split_rule}.
*}

lemmas case_prodI = prod.case [THEN iffD2]

lemma case_prodI2: "!!p. [| !!a b. p = (a, b) ==> c a b |] ==> case_prod c p"
  by (fact splitI2)

lemma case_prodI2': "!!p. [| !!a b. (a, b) = p ==> c a b x |] ==> case_prod c p x"
  by (fact splitI2')

lemma case_prodE: "case_prod c p ==> (!!x y. p = (x, y) ==> c x y ==> Q) ==> Q"
  by (fact splitE)

lemma case_prodE': "case_prod c p z ==> (!!x y. p = (x, y) ==> c x y z ==> Q) ==> Q"
  by (fact splitE')

declare case_prodI [intro!]

lemma case_prod_beta:
  "case_prod f p = f (fst p) (snd p)"
  by (fact split_beta)

lemma prod_cases3 [cases type]:
  obtains (fields) a b c where "y = (a, b, c)"
  by (cases y, case_tac b) blast

lemma prod_induct3 [case_names fields, induct type]:
    "(!!a b c. P (a, b, c)) ==> P x"
  by (cases x) blast

lemma prod_cases4 [cases type]:
  obtains (fields) a b c d where "y = (a, b, c, d)"
  by (cases y, case_tac c) blast

lemma prod_induct4 [case_names fields, induct type]:
    "(!!a b c d. P (a, b, c, d)) ==> P x"
  by (cases x) blast

lemma prod_cases5 [cases type]:
  obtains (fields) a b c d e where "y = (a, b, c, d, e)"
  by (cases y, case_tac d) blast

lemma prod_induct5 [case_names fields, induct type]:
    "(!!a b c d e. P (a, b, c, d, e)) ==> P x"
  by (cases x) blast

lemma prod_cases6 [cases type]:
  obtains (fields) a b c d e f where "y = (a, b, c, d, e, f)"
  by (cases y, case_tac e) blast

lemma prod_induct6 [case_names fields, induct type]:
    "(!!a b c d e f. P (a, b, c, d, e, f)) ==> P x"
  by (cases x) blast

lemma prod_cases7 [cases type]:
  obtains (fields) a b c d e f g where "y = (a, b, c, d, e, f, g)"
  by (cases y, case_tac f) blast

lemma prod_induct7 [case_names fields, induct type]:
    "(!!a b c d e f g. P (a, b, c, d, e, f, g)) ==> P x"
  by (cases x) blast

lemma split_def:
  "split = (\<lambda>c p. c (fst p) (snd p))"
  by (fact case_prod_unfold)

definition internal_split :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c" where
  "internal_split == split"

lemma internal_split_conv: "internal_split c (a, b) = c a b"
  by (simp only: internal_split_def split_conv)

ML_file "Tools/split_rule.ML"

hide_const internal_split

subsubsection {* Derived operations *}

definition curry    :: "('a \<times> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c" where
  "curry = (\<lambda>c x y. c (x, y))"

lemma curry_conv [simp, code]: "curry f a b = f (a, b)"
  by (simp add: curry_def)

lemma curryI [intro!]: "f (a, b) \<Longrightarrow> curry f a b"
  by (simp add: curry_def)

lemma curryD [dest!]: "curry f a b \<Longrightarrow> f (a, b)"
  by (simp add: curry_def)

lemma curryE: "curry f a b \<Longrightarrow> (f (a, b) \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (simp add: curry_def)

lemma curry_split [simp]: "curry (split f) = f"
  by (simp add: curry_def split_def)

lemma split_curry [simp]: "split (curry f) = f"
  by (simp add: curry_def split_def)

lemma curry_K: "curry (\<lambda>x. c) = (\<lambda>x y. c)"
by(simp add: fun_eq_iff)

text {*
  The composition-uncurry combinator.
*}

notation fcomp (infixl "\<circ>>" 60)

definition scomp :: "('a \<Rightarrow> 'b \<times> 'c) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> 'a \<Rightarrow> 'd" (infixl "\<circ>\<rightarrow>" 60) where
  "f \<circ>\<rightarrow> g = (\<lambda>x. case_prod g (f x))"

lemma scomp_unfold: "scomp = (\<lambda>f g x. g (fst (f x)) (snd (f x)))"
  by (simp add: fun_eq_iff scomp_def case_prod_unfold)

lemma scomp_apply [simp]: "(f \<circ>\<rightarrow> g) x = case_prod g (f x)"
  by (simp add: scomp_unfold case_prod_unfold)

lemma Pair_scomp: "Pair x \<circ>\<rightarrow> f = f x"
  by (simp add: fun_eq_iff)

lemma scomp_Pair: "x \<circ>\<rightarrow> Pair = x"
  by (simp add: fun_eq_iff)

lemma scomp_scomp: "(f \<circ>\<rightarrow> g) \<circ>\<rightarrow> h = f \<circ>\<rightarrow> (\<lambda>x. g x \<circ>\<rightarrow> h)"
  by (simp add: fun_eq_iff scomp_unfold)

lemma scomp_fcomp: "(f \<circ>\<rightarrow> g) \<circ>> h = f \<circ>\<rightarrow> (\<lambda>x. g x \<circ>> h)"
  by (simp add: fun_eq_iff scomp_unfold fcomp_def)

lemma fcomp_scomp: "(f \<circ>> g) \<circ>\<rightarrow> h = f \<circ>> (g \<circ>\<rightarrow> h)"
  by (simp add: fun_eq_iff scomp_unfold)

code_printing
  constant scomp \<rightharpoonup> (Eval) infixl 3 "#->"

no_notation fcomp (infixl "\<circ>>" 60)
no_notation scomp (infixl "\<circ>\<rightarrow>" 60)

text {*
  @{term map_prod} --- action of the product functor upon
  functions.
*}

definition map_prod :: "('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c \<times> 'd" where
  "map_prod f g = (\<lambda>(x, y). (f x, g y))"

lemma map_prod_simp [simp, code]:
  "map_prod f g (a, b) = (f a, g b)"
  by (simp add: map_prod_def)

functor map_prod: map_prod
  by (auto simp add: split_paired_all)

lemma fst_map_prod [simp]:
  "fst (map_prod f g x) = f (fst x)"
  by (cases x) simp_all

lemma snd_map_prod [simp]:
  "snd (map_prod f g x) = g (snd x)"
  by (cases x) simp_all

lemma fst_comp_map_prod [simp]:
  "fst \<circ> map_prod f g = f \<circ> fst"
  by (rule ext) simp_all

lemma snd_comp_map_prod [simp]:
  "snd \<circ> map_prod f g = g \<circ> snd"
  by (rule ext) simp_all

lemma map_prod_compose:
  "map_prod (f1 o f2) (g1 o g2) = (map_prod f1 g1 o map_prod f2 g2)"
  by (rule ext) (simp add: map_prod.compositionality comp_def)

lemma map_prod_ident [simp]:
  "map_prod (%x. x) (%y. y) = (%z. z)"
  by (rule ext) (simp add: map_prod.identity)

lemma map_prod_imageI [intro]:
  "(a, b) \<in> R \<Longrightarrow> (f a, g b) \<in> map_prod f g ` R"
  by (rule image_eqI) simp_all

lemma prod_fun_imageE [elim!]:
  assumes major: "c \<in> map_prod f g ` R"
    and cases: "\<And>x y. c = (f x, g y) \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> P"
  shows P
  apply (rule major [THEN imageE])
  apply (case_tac x)
  apply (rule cases)
  apply simp_all
  done

definition apfst :: "('a \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c \<times> 'b" where
  "apfst f = map_prod f id"

definition apsnd :: "('b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'c" where
  "apsnd f = map_prod id f"

lemma apfst_conv [simp, code]:
  "apfst f (x, y) = (f x, y)"
  by (simp add: apfst_def)

lemma apsnd_conv [simp, code]:
  "apsnd f (x, y) = (x, f y)"
  by (simp add: apsnd_def)

lemma fst_apfst [simp]:
  "fst (apfst f x) = f (fst x)"
  by (cases x) simp

lemma fst_comp_apfst [simp]:
  "fst \<circ> apfst f = f \<circ> fst"
  by (simp add: fun_eq_iff)

lemma fst_apsnd [simp]:
  "fst (apsnd f x) = fst x"
  by (cases x) simp

lemma fst_comp_apsnd [simp]:
  "fst \<circ> apsnd f = fst"
  by (simp add: fun_eq_iff)

lemma snd_apfst [simp]:
  "snd (apfst f x) = snd x"
  by (cases x) simp

lemma snd_comp_apfst [simp]:
  "snd \<circ> apfst f = snd"
  by (simp add: fun_eq_iff)

lemma snd_apsnd [simp]:
  "snd (apsnd f x) = f (snd x)"
  by (cases x) simp

lemma snd_comp_apsnd [simp]:
  "snd \<circ> apsnd f = f \<circ> snd"
  by (simp add: fun_eq_iff)

lemma apfst_compose:
  "apfst f (apfst g x) = apfst (f \<circ> g) x"
  by (cases x) simp

lemma apsnd_compose:
  "apsnd f (apsnd g x) = apsnd (f \<circ> g) x"
  by (cases x) simp

lemma apfst_apsnd [simp]:
  "apfst f (apsnd g x) = (f (fst x), g (snd x))"
  by (cases x) simp

lemma apsnd_apfst [simp]:
  "apsnd f (apfst g x) = (g (fst x), f (snd x))"
  by (cases x) simp

lemma apfst_id [simp] :
  "apfst id = id"
  by (simp add: fun_eq_iff)

lemma apsnd_id [simp] :
  "apsnd id = id"
  by (simp add: fun_eq_iff)

lemma apfst_eq_conv [simp]:
  "apfst f x = apfst g x \<longleftrightarrow> f (fst x) = g (fst x)"
  by (cases x) simp

lemma apsnd_eq_conv [simp]:
  "apsnd f x = apsnd g x \<longleftrightarrow> f (snd x) = g (snd x)"
  by (cases x) simp

lemma apsnd_apfst_commute:
  "apsnd f (apfst g p) = apfst g (apsnd f p)"
  by simp

context
begin

local_setup {* Local_Theory.map_naming (Name_Space.mandatory_path "prod") *}

definition swap :: "'a \<times> 'b \<Rightarrow> 'b \<times> 'a"
where
  "swap p = (snd p, fst p)"

end

lemma swap_simp [simp]:
  "prod.swap (x, y) = (y, x)"
  by (simp add: prod.swap_def)

lemma swap_swap [simp]:
  "prod.swap (prod.swap p) = p"
  by (cases p) simp

lemma swap_comp_swap [simp]:
  "prod.swap \<circ> prod.swap = id"
  by (simp add: fun_eq_iff)

lemma pair_in_swap_image [simp]:
  "(y, x) \<in> prod.swap ` A \<longleftrightarrow> (x, y) \<in> A"
  by (auto intro!: image_eqI)

lemma inj_swap [simp]:
  "inj_on prod.swap A"
  by (rule inj_onI) auto

lemma swap_inj_on:
  "inj_on (\<lambda>(i, j). (j, i)) A"
  by (rule inj_onI) auto

lemma surj_swap [simp]:
  "surj prod.swap"
  by (rule surjI [of _ prod.swap]) simp

lemma bij_swap [simp]:
  "bij prod.swap"
  by (simp add: bij_def)

lemma case_swap [simp]:
  "(case prod.swap p of (y, x) \<Rightarrow> f x y) = (case p of (x, y) \<Rightarrow> f x y)"
  by (cases p) simp

text {*
  Disjoint union of a family of sets -- Sigma.
*}

definition Sigma :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<times> 'b) set" where
  Sigma_def: "Sigma A B == UN x:A. UN y:B x. {Pair x y}"

abbreviation
  Times :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set"
    (infixr "<*>" 80) where
  "A <*> B == Sigma A (%_. B)"

notation (xsymbols)
  Times  (infixr "\<times>" 80)

notation (HTML output)
  Times  (infixr "\<times>" 80)

hide_const (open) Times

syntax
  "_Sigma" :: "[pttrn, 'a set, 'b set] => ('a * 'b) set"  ("(3SIGMA _:_./ _)" [0, 0, 10] 10)
translations
  "SIGMA x:A. B" == "CONST Sigma A (%x. B)"

lemma SigmaI [intro!]: "[| a:A;  b:B(a) |] ==> (a,b) : Sigma A B"
  by (unfold Sigma_def) blast

lemma SigmaE [elim!]:
    "[| c: Sigma A B;
        !!x y.[| x:A;  y:B(x);  c=(x,y) |] ==> P
     |] ==> P"
  -- {* The general elimination rule. *}
  by (unfold Sigma_def) blast

text {*
  Elimination of @{term "(a, b) : A \<times> B"} -- introduces no
  eigenvariables.
*}

lemma SigmaD1: "(a, b) : Sigma A B ==> a : A"
  by blast

lemma SigmaD2: "(a, b) : Sigma A B ==> b : B a"
  by blast

lemma SigmaE2:
    "[| (a, b) : Sigma A B;
        [| a:A;  b:B(a) |] ==> P
     |] ==> P"
  by blast

lemma Sigma_cong:
     "\<lbrakk>A = B; !!x. x \<in> B \<Longrightarrow> C x = D x\<rbrakk>
      \<Longrightarrow> (SIGMA x: A. C x) = (SIGMA x: B. D x)"
  by auto

lemma Sigma_mono: "[| A <= C; !!x. x:A ==> B x <= D x |] ==> Sigma A B <= Sigma C D"
  by blast

lemma Sigma_empty1 [simp]: "Sigma {} B = {}"
  by blast

lemma Sigma_empty2 [simp]: "A <*> {} = {}"
  by blast

lemma UNIV_Times_UNIV [simp]: "UNIV <*> UNIV = UNIV"
  by auto

lemma Compl_Times_UNIV1 [simp]: "- (UNIV <*> A) = UNIV <*> (-A)"
  by auto

lemma Compl_Times_UNIV2 [simp]: "- (A <*> UNIV) = (-A) <*> UNIV"
  by auto

lemma mem_Sigma_iff [iff]: "((a,b): Sigma A B) = (a:A & b:B(a))"
  by blast

lemma Sigma_empty_iff: "(SIGMA i:I. X i) = {} \<longleftrightarrow> (\<forall>i\<in>I. X i = {})"
  by auto

lemma Times_subset_cancel2: "x:C ==> (A <*> C <= B <*> C) = (A <= B)"
  by blast

lemma Times_eq_cancel2: "x:C ==> (A <*> C = B <*> C) = (A = B)"
  by (blast elim: equalityE)

lemma SetCompr_Sigma_eq:
    "Collect (split (%x y. P x & Q x y)) = (SIGMA x:Collect P. Collect (Q x))"
  by blast

lemma Collect_split [simp]: "{(a,b). P a & Q b} = Collect P <*> Collect Q"
  by blast

lemma UN_Times_distrib:
  "(UN (a,b):(A <*> B). E a <*> F b) = (UNION A E) <*> (UNION B F)"
  -- {* Suggested by Pierre Chartier *}
  by blast

lemma split_paired_Ball_Sigma [simp, no_atp]:
    "(ALL z: Sigma A B. P z) = (ALL x:A. ALL y: B x. P(x,y))"
  by blast

lemma split_paired_Bex_Sigma [simp, no_atp]:
    "(EX z: Sigma A B. P z) = (EX x:A. EX y: B x. P(x,y))"
  by blast

lemma Sigma_Un_distrib1: "(SIGMA i:I Un J. C(i)) = (SIGMA i:I. C(i)) Un (SIGMA j:J. C(j))"
  by blast

lemma Sigma_Un_distrib2: "(SIGMA i:I. A(i) Un B(i)) = (SIGMA i:I. A(i)) Un (SIGMA i:I. B(i))"
  by blast

lemma Sigma_Int_distrib1: "(SIGMA i:I Int J. C(i)) = (SIGMA i:I. C(i)) Int (SIGMA j:J. C(j))"
  by blast

lemma Sigma_Int_distrib2: "(SIGMA i:I. A(i) Int B(i)) = (SIGMA i:I. A(i)) Int (SIGMA i:I. B(i))"
  by blast

lemma Sigma_Diff_distrib1: "(SIGMA i:I - J. C(i)) = (SIGMA i:I. C(i)) - (SIGMA j:J. C(j))"
  by blast

lemma Sigma_Diff_distrib2: "(SIGMA i:I. A(i) - B(i)) = (SIGMA i:I. A(i)) - (SIGMA i:I. B(i))"
  by blast

lemma Sigma_Union: "Sigma (Union X) B = (UN A:X. Sigma A B)"
  by blast

text {*
  Non-dependent versions are needed to avoid the need for higher-order
  matching, especially when the rules are re-oriented.
*}

lemma Times_Un_distrib1: "(A Un B) <*> C = (A <*> C) Un (B <*> C)"
  by (fact Sigma_Un_distrib1)

lemma Times_Int_distrib1: "(A Int B) <*> C = (A <*> C) Int (B <*> C)"
  by (fact Sigma_Int_distrib1)

lemma Times_Diff_distrib1: "(A - B) <*> C = (A <*> C) - (B <*> C)"
  by (fact Sigma_Diff_distrib1)

lemma Times_empty[simp]: "A \<times> B = {} \<longleftrightarrow> A = {} \<or> B = {}"
  by auto

lemma times_eq_iff: "A \<times> B = C \<times> D \<longleftrightarrow> A = C \<and> B = D \<or> ((A = {} \<or> B = {}) \<and> (C = {} \<or> D = {}))"
  by auto

lemma fst_image_times[simp]: "fst ` (A \<times> B) = (if B = {} then {} else A)"
  by force

lemma snd_image_times[simp]: "snd ` (A \<times> B) = (if A = {} then {} else B)"
  by force

lemma vimage_fst:
  "fst -` A = A \<times> UNIV"
  by auto

lemma vimage_snd:
  "snd -` A = UNIV \<times> A"
  by auto

lemma insert_times_insert[simp]:
  "insert a A \<times> insert b B =
   insert (a,b) (A \<times> insert b B \<union> insert a A \<times> B)"
by blast

lemma vimage_Times: "f -` (A \<times> B) = ((fst \<circ> f) -` A) \<inter> ((snd \<circ> f) -` B)"
  apply auto
  apply (case_tac "f x")
  apply auto
  done

lemma times_Int_times: "A \<times> B \<inter> C \<times> D = (A \<inter> C) \<times> (B \<inter> D)"
  by auto

lemma product_swap:
  "prod.swap ` (A \<times> B) = B \<times> A"
  by (auto simp add: set_eq_iff)

lemma swap_product:
  "(\<lambda>(i, j). (j, i)) ` (A \<times> B) = B \<times> A"
  by (auto simp add: set_eq_iff)

lemma image_split_eq_Sigma:
  "(\<lambda>x. (f x, g x)) ` A = Sigma (f ` A) (\<lambda>x. g ` (f -` {x} \<inter> A))"
proof (safe intro!: imageI)
  fix a b assume *: "a \<in> A" "b \<in> A" and eq: "f a = f b"
  show "(f b, g a) \<in> (\<lambda>x. (f x, g x)) ` A"
    using * eq[symmetric] by auto
qed simp_all

definition product :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set" where
  [code_abbrev]: "product A B = A \<times> B"

hide_const (open) product

lemma member_product:
  "x \<in> Product_Type.product A B \<longleftrightarrow> x \<in> A \<times> B"
  by (simp add: product_def)

text {* The following @{const map_prod} lemmas are due to Joachim Breitner: *}

lemma map_prod_inj_on:
  assumes "inj_on f A" and "inj_on g B"
  shows "inj_on (map_prod f g) (A \<times> B)"
proof (rule inj_onI)
  fix x :: "'a \<times> 'c" and y :: "'a \<times> 'c"
  assume "x \<in> A \<times> B" hence "fst x \<in> A" and "snd x \<in> B" by auto
  assume "y \<in> A \<times> B" hence "fst y \<in> A" and "snd y \<in> B" by auto
  assume "map_prod f g x = map_prod f g y"
  hence "fst (map_prod f g x) = fst (map_prod f g y)" by (auto)
  hence "f (fst x) = f (fst y)" by (cases x,cases y,auto)
  with `inj_on f A` and `fst x \<in> A` and `fst y \<in> A`
  have "fst x = fst y" by (auto dest:dest:inj_onD)
  moreover from `map_prod f g x = map_prod f g y`
  have "snd (map_prod f g x) = snd (map_prod f g y)" by (auto)
  hence "g (snd x) = g (snd y)" by (cases x,cases y,auto)
  with `inj_on g B` and `snd x \<in> B` and `snd y \<in> B`
  have "snd x = snd y" by (auto dest:dest:inj_onD)
  ultimately show "x = y" by(rule prod_eqI)
qed

lemma map_prod_surj:
  fixes f :: "'a \<Rightarrow> 'b" and g :: "'c \<Rightarrow> 'd"
  assumes "surj f" and "surj g"
  shows "surj (map_prod f g)"
unfolding surj_def
proof
  fix y :: "'b \<times> 'd"
  from `surj f` obtain a where "fst y = f a" by (auto elim:surjE)
  moreover
  from `surj g` obtain b where "snd y = g b" by (auto elim:surjE)
  ultimately have "(fst y, snd y) = map_prod f g (a,b)" by auto
  thus "\<exists>x. y = map_prod f g x" by auto
qed

lemma map_prod_surj_on:
  assumes "f ` A = A'" and "g ` B = B'"
  shows "map_prod f g ` (A \<times> B) = A' \<times> B'"
unfolding image_def
proof(rule set_eqI,rule iffI)
  fix x :: "'a \<times> 'c"
  assume "x \<in> {y\<Colon>'a \<times> 'c. \<exists>x\<Colon>'b \<times> 'd\<in>A \<times> B. y = map_prod f g x}"
  then obtain y where "y \<in> A \<times> B" and "x = map_prod f g y" by blast
  from `image f A = A'` and `y \<in> A \<times> B` have "f (fst y) \<in> A'" by auto
  moreover from `image g B = B'` and `y \<in> A \<times> B` have "g (snd y) \<in> B'" by auto
  ultimately have "(f (fst y), g (snd y)) \<in> (A' \<times> B')" by auto
  with `x = map_prod f g y` show "x \<in> A' \<times> B'" by (cases y, auto)
next
  fix x :: "'a \<times> 'c"
  assume "x \<in> A' \<times> B'" hence "fst x \<in> A'" and "snd x \<in> B'" by auto
  from `image f A = A'` and `fst x \<in> A'` have "fst x \<in> image f A" by auto
  then obtain a where "a \<in> A" and "fst x = f a" by (rule imageE)
  moreover from `image g B = B'` and `snd x \<in> B'`
  obtain b where "b \<in> B" and "snd x = g b" by auto
  ultimately have "(fst x, snd x) = map_prod f g (a,b)" by auto
  moreover from `a \<in> A` and  `b \<in> B` have "(a , b) \<in> A \<times> B" by auto
  ultimately have "\<exists>y \<in> A \<times> B. x = map_prod f g y" by auto
  thus "x \<in> {x. \<exists>y \<in> A \<times> B. x = map_prod f g y}" by auto
qed

subsection {* Simproc for rewriting a set comprehension into a pointfree expression *}

ML_file "Tools/set_comprehension_pointfree.ML"

setup {*
  Code_Preproc.map_pre (fn ctxt => ctxt addsimprocs
    [Raw_Simplifier.make_simproc {name = "set comprehension", lhss = [@{cpat "Collect ?P"}],
    proc = K Set_Comprehension_Pointfree.code_simproc, identifier = []}])
*}

subsection {* Inductively defined sets *}

(* simplify {(x1, ..., xn). (x1, ..., xn) : S} to S *)
simproc_setup Collect_mem ("Collect t") = {*
  fn _ => fn ctxt => fn ct =>
    (case term_of ct of
      S as Const (@{const_name Collect}, Type (@{type_name fun}, [_, T])) $ t =>
        let val (u, _, ps) = HOLogic.strip_psplits t in
          (case u of
            (c as Const (@{const_name Set.member}, _)) $ q $ S' =>
              (case try (HOLogic.strip_ptuple ps) q of
                NONE => NONE
              | SOME ts =>
                  if not (Term.is_open S') andalso
                    ts = map Bound (length ps downto 0)
                  then
                    let val simp =
                      full_simp_tac (put_simpset HOL_basic_ss ctxt
                        addsimps [@{thm split_paired_all}, @{thm split_conv}]) 1
                    in
                      SOME (Goal.prove ctxt [] []
                        (Const (@{const_name Pure.eq}, T --> T --> propT) $ S $ S')
                        (K (EVERY
                          [resolve_tac [eq_reflection] 1,
                           resolve_tac @{thms subset_antisym} 1,
                           resolve_tac [subsetI] 1, dresolve_tac [CollectD] 1, simp,
                           resolve_tac [subsetI] 1, resolve_tac [CollectI] 1, simp])))
                    end
                  else NONE)
          | _ => NONE)
        end
    | _ => NONE)
*}

ML_file "Tools/inductive_set.ML"

subsection {* Legacy theorem bindings and duplicates *}

lemma PairE:
  obtains x y where "p = (x, y)"
  by (fact prod.exhaust)

lemmas Pair_eq = prod.inject
lemmas fst_conv = prod.sel(1)
lemmas snd_conv = prod.sel(2)
lemmas pair_collapse = prod.collapse
lemmas split = split_conv
lemmas Pair_fst_snd_eq = prod_eq_iff

hide_const (open) prod

end


section \<open>Machine Words\<close>
theory WordRefine
imports "../Refine_Monadic" "HOL-Library.Word"
begin

text \<open>This theory provides a simple example to show refinement of natural
  numbers to machine words. The setup is not yet very elaborated, but shows
  the direction to go.
\<close>

subsection \<open>Setup\<close>
definition [simp]: "word_nat_rel \<equiv> build_rel (unat) (\<lambda>_. True)"
lemma word_nat_RELEATES[refine_dref_RELATES]:
  "RELATES word_nat_rel" by (simp add: RELATES_def)

lemma [simp, relator_props]:
  "single_valued word_nat_rel" unfolding word_nat_rel_def
  by blast

lemma [simp, relator_props]: "single_valued (converse word_nat_rel)"
  by (auto intro: injI)

lemmas [refine_hsimp] =
  word_less_nat_alt word_le_nat_alt unat_sub iffD1[OF unat_add_lem]

subsection \<open>Example\<close>
type_synonym word32 = "32 word"

definition test :: "nat \<Rightarrow> nat \<Rightarrow> nat set nres" where "test x0 y0 \<equiv> do {
  let S={};
  (S,_,_) \<leftarrow> WHILE (\<lambda>(S,x,y). x>0) (\<lambda>(S,x,y). do {
    let S=S\<union>{y};
    let x=x - 1;
    ASSERT (y<x0+y0);
    let y=y + 1;
    RETURN (S,x,y)
  }) (S,x0,y0);
  RETURN S
}"

lemma "y0>0 \<Longrightarrow> test x0 y0 \<le> SPEC (\<lambda>S. S={y0 .. y0 + x0 - 1})"
  \<comment> \<open>Choosen pre-condition to get least trouble when proving\<close>
  unfolding test_def
  apply (intro WHILE_rule[where I="\<lambda>(S,x,y).
    x+y=x0+y0 \<and> x\<le>x0 \<and>
    S={y0 .. y0 + (x0-x) - 1}"]
    refine_vcg)
  by auto

definition test_impl :: "word32 \<Rightarrow> word32 \<Rightarrow> word32 set nres" where
  "test_impl x y \<equiv> do {
    let S={};
    (S,_,_) \<leftarrow> WHILE (\<lambda>(S,x,y). x>0) (\<lambda>(S,x,y). do {
      let S=S\<union>{y};
      let x=x - 1;
      let y=y + 1;
      RETURN (S,x,y)
    }) (S,x,y);
    RETURN S
  }"

end


theory God
imports AoC

begin
consts E :: "c" ("E!")
consts G :: "c" ("G")
consts NESS :: "bool \<Rightarrow> bool" (*emulates the box operator; very skeptical about that.*)

axiomatization where
GOD3: "\<forall>X. X \<^bold>\<in> G \<longleftrightarrow> (NESS (X \<^bold>\<in> E!))" and
M: "NESS X \<Longrightarrow> X" (*Only the T-Axiom is necessary for the proof to work.*)

theorem GOD2: "(P G) \<longrightarrow> G \<^bold>\<in> E!"
using CONT1 GOD3 M by blast

theorem GOD1: "P G" nitpick[user_axioms] oops
(*Nitpick finds a countermodel *)

theorem NOTGOD1: "\<not> P G" nitpick[user_axioms] oops
(*Nitpick also finds a countermodel for the opposite claim*)

(*However: Gods existence can still be proven. But this is !not! part of Lenzens paper.*)
theorem GOD: "G \<^bold>\<in> E!" using CONT1 GOD3 M by blast
(* To see why this is true, consider: Either P G then by modus ponens and GOD2 god exists.
Or \<not>(P G) then the concept contains (an analogon to ex falso quodlibet)
 every other concept therefore also the existence concept. In Isabelle:
theorem exfalso: " (\<not> (P A)) \<Longrightarrow> (A \<^bold>\<in> B) " using  CONJ4 POSS1 POSS2  by blast
*)

end


(* Author:     Giampaolo Bella, Catania University
*)

section\<open>Theory of smartcards\<close>

theory Smartcard
imports EventSC "../All_Symmetric"
begin

text\<open>
As smartcards handle long-term (symmetric) keys, this theoy extends and
supersedes theory Private.thy

An agent is bad if she reveals her PIN to the spy, not the shared key that
is embedded in her card. An agent's being bad implies nothing about her
smartcard, which independently may be stolen or cloned.
\<close>

axiomatization
  shrK    :: "agent => key" and  (*long-term keys saved in smart cards*)
  crdK    :: "card  => key" and  (*smart cards' symmetric keys*)
  pin     :: "agent => key" and  (*pin to activate the smart cards*)

  (*Mostly for Shoup-Rubin*)
  Pairkey :: "agent * agent => nat" and
  pairK   :: "agent * agent => key"
where
  inj_shrK: "inj shrK" and  \<comment> \<open>No two smartcards store the same key\<close>
  inj_crdK: "inj crdK" and  \<comment> \<open>Nor do two cards\<close>
  inj_pin : "inj pin" and   \<comment> \<open>Nor do two agents have the same pin\<close>

  (*pairK is injective on each component, if we assume encryption to be a PRF
    or at least collision free *)
  inj_pairK    [iff]: "(pairK(A,B) = pairK(A',B')) = (A = A' & B = B')" and
  comm_Pairkey [iff]: "Pairkey(A,B) = Pairkey(B,A)" and

  (*long-term keys differ from each other*)
  pairK_disj_crdK [iff]: "pairK(A,B) \<noteq> crdK C" and
  pairK_disj_shrK [iff]: "pairK(A,B) \<noteq> shrK P" and
  pairK_disj_pin [iff]:  "pairK(A,B) \<noteq> pin P" and
  shrK_disj_crdK [iff]:  "shrK P \<noteq> crdK C" and
  shrK_disj_pin [iff]:  "shrK P \<noteq> pin Q" and
  crdK_disj_pin [iff]:   "crdK C \<noteq> pin P"

definition legalUse :: "card => bool" ("legalUse (_)") where
  "legalUse C == C \<notin> stolen"

primrec illegalUse :: "card  => bool" where
  illegalUse_def: "illegalUse (Card A) = ( (Card A \<in> stolen \<and> A \<in> bad)  \<or>  Card A \<in> cloned )"

text\<open>initState must be defined with care\<close>

overloading
  initState \<equiv> initState
begin

primrec initState where
(*Server knows all long-term keys; adding cards' keys may be redundant but
  helps prove crdK_in_initState and crdK_in_used to distinguish cards' keys
  from fresh (session) keys*)
  initState_Server:  "initState Server =
        (Key`(range shrK \<union> range crdK \<union> range pin \<union> range pairK)) \<union>
        (Nonce`(range Pairkey))" |

(*Other agents know only their own*)
  initState_Friend:  "initState (Friend i) = {Key (pin (Friend i))}" |

(*Spy knows bad agents' pins, cloned cards' keys, pairKs, and Pairkeys *)
  initState_Spy: "initState Spy  =
                 (Key`((pin`bad) \<union> (pin `{A. Card A \<in> cloned}) \<union>
                                      (shrK`{A. Card A \<in> cloned}) \<union>
                        (crdK`cloned) \<union>
                        (pairK`{(X,A). Card A \<in> cloned})))
           \<union> (Nonce`(Pairkey`{(A,B). Card A \<in> cloned & Card B \<in> cloned}))"

end

text\<open>Still relying on axioms\<close>
axiomatization where
  Key_supply_ax:  "finite KK \<Longrightarrow> \<exists> K. K \<notin> KK & Key K \<notin> used evs" and

  (*Needed because of Spy's knowledge of Pairkeys*)
  Nonce_supply_ax: "finite NN \<Longrightarrow> \<exists> N. N \<notin> NN & Nonce N \<notin> used evs"

subsection\<open>Basic properties of shrK\<close>

(*Injectiveness: Agents' long-term keys are distinct.*)
declare inj_shrK [THEN inj_eq, iff]
declare inj_crdK [THEN inj_eq, iff]
declare inj_pin  [THEN inj_eq, iff]

lemma invKey_K [simp]: "invKey K = K"
apply (insert isSym_keys)
apply (simp add: symKeys_def)
done

lemma analz_Decrypt' [dest]:
     "\<lbrakk> Crypt K X \<in> analz H;  Key K  \<in> analz H \<rbrakk> \<Longrightarrow> X \<in> analz H"
by auto

text\<open>Now cancel the \<open>dest\<close> attribute given to
 \<open>analz.Decrypt\<close> in its declaration.\<close>
declare analz.Decrypt [rule del]

text\<open>Rewrites should not refer to  \<^term>\<open>initState(Friend i)\<close> because
  that expression is not in normal form.\<close>

text\<open>Added to extend initstate with set of nonces\<close>
lemma parts_image_Nonce [simp]: "parts (Nonce`N) = Nonce`N"
  by auto

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
unfolding keysFor_def
apply (induct_tac "C", auto)
done

(*Specialized to shared-key model: no @{term invKey}*)
lemma keysFor_parts_insert:
     "\<lbrakk> K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) \<rbrakk>
     \<Longrightarrow> K \<in> keysFor (parts (G \<union> H)) | Key K \<in> parts H"
by (force dest: EventSC.keysFor_parts_insert)

lemma Crypt_imp_keysFor: "Crypt K X \<in> H \<Longrightarrow> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

subsection\<open>Function "knows"\<close>

(*Spy knows the pins of bad agents!*)
lemma Spy_knows_bad [intro!]: "A \<in> bad \<Longrightarrow> Key (pin A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

(*Spy knows the long-term keys of cloned cards!*)
lemma Spy_knows_cloned [intro!]:
     "Card A \<in> cloned \<Longrightarrow>  Key (crdK (Card A)) \<in> knows Spy evs &
                           Key (shrK A) \<in> knows Spy evs &
                           Key (pin A)  \<in> knows Spy evs &
                          (\<forall> B. Key (pairK(B,A)) \<in> knows Spy evs)"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

lemma Spy_knows_cloned1 [intro!]: "C \<in> cloned \<Longrightarrow> Key (crdK C) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

lemma Spy_knows_cloned2 [intro!]: "\<lbrakk> Card A \<in> cloned; Card B \<in> cloned \<rbrakk>
   \<Longrightarrow> Nonce (Pairkey(A,B))\<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

(*Spy only knows pins of bad agents!*)
lemma Spy_knows_Spy_bad [intro!]: "A\<in> bad \<Longrightarrow> Key (pin A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

(*For case analysis on whether or not an agent is compromised*)
lemma Crypt_Spy_analz_bad:
  "\<lbrakk> Crypt (pin A) X \<in> analz (knows Spy evs);  A\<in>bad \<rbrakk>
      \<Longrightarrow> X \<in> analz (knows Spy evs)"
apply (force dest!: analz.Decrypt)
done

(** Fresh keys never clash with other keys **)

lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState Server"
apply (induct_tac "A")
apply auto
done

lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

lemma crdK_in_initState [iff]: "Key (crdK A) \<in> initState Server"
apply (induct_tac "A")
apply auto
done

lemma crdK_in_used [iff]: "Key (crdK A) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

lemma pin_in_initState [iff]: "Key (pin A) \<in> initState A"
apply (induct_tac "A")
apply auto
done

lemma pin_in_used [iff]: "Key (pin A) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

lemma pairK_in_initState [iff]: "Key (pairK X) \<in> initState Server"
apply (induct_tac "X")
apply auto
done

lemma pairK_in_used [iff]: "Key (pairK X) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

(*Used in parts_induct_tac and analz_Fake_tac to distinguish session keys
  from long-term shared keys*)
lemma Key_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range shrK"
by blast

lemma shrK_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> shrK B \<noteq> K"
by blast

lemma crdK_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range crdK"
apply clarify
done

lemma crdK_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> crdK C \<noteq> K"
apply clarify
done

lemma pin_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range pin"
apply clarify
done

lemma pin_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> pin A \<noteq> K"
apply clarify
done

lemma pairK_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range pairK"
apply clarify
done

lemma pairK_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> pairK(A,B) \<noteq> K"
apply clarify
done

declare shrK_neq [THEN not_sym, simp]
declare crdK_neq [THEN not_sym, simp]
declare pin_neq [THEN not_sym, simp]
declare pairK_neq [THEN not_sym, simp]

subsection\<open>Fresh nonces\<close>

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState (Friend i))"
by auto

(*This lemma no longer holds of smartcard protocols, where the cards can store
  nonces.

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
unfolding used_Nil
done

So, we must use old-style supply fresh nonce theorems relying on the appropriate axiom*)

subsection\<open>Supply fresh nonces for possibility theorems.\<close>

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
apply (rule finite.emptyI [THEN Nonce_supply_ax, THEN exE], blast)
done

lemma Nonce_supply2:
  "\<exists>N N'. Nonce N \<notin> used evs & Nonce N' \<notin> used evs' & N \<noteq> N'"
apply (cut_tac evs = evs in finite.emptyI [THEN Nonce_supply_ax])
apply (erule exE)
apply (cut_tac evs = evs' in finite.emptyI [THEN finite.insertI, THEN Nonce_supply_ax])
apply auto
done

lemma Nonce_supply3: "\<exists>N N' N''. Nonce N \<notin> used evs & Nonce N' \<notin> used evs' &
                    Nonce N'' \<notin> used evs'' & N \<noteq> N' & N' \<noteq> N'' & N \<noteq> N''"
apply (cut_tac evs = evs in finite.emptyI [THEN Nonce_supply_ax])
apply (erule exE)
apply (cut_tac evs = evs' and a1 = N in finite.emptyI [THEN finite.insertI, THEN Nonce_supply_ax])
apply (erule exE)
apply (cut_tac evs = evs'' and a1 = Na and a2 = N in finite.emptyI [THEN finite.insertI, THEN finite.insertI, THEN Nonce_supply_ax])
apply blast
done

lemma Nonce_supply: "Nonce (SOME N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule finite.emptyI [THEN Nonce_supply_ax, THEN exE])
apply (rule someI, blast)
done

text\<open>Unlike the corresponding property of nonces, we cannot prove
    \<^term>\<open>finite KK \<Longrightarrow> \<exists>K. K \<notin> KK & Key K \<notin> used evs\<close>.
    We have infinitely many agents and there is nothing to stop their
    long-term keys from exhausting all the natural numbers.  Instead,
    possibility theorems must assume the existence of a few keys.\<close>

subsection\<open>Specialized Rewriting for Theorems About \<^term>\<open>analz\<close> and Image\<close>

lemma subset_Compl_range_shrK: "A \<subseteq> - (range shrK) \<Longrightarrow> shrK x \<notin> A"
by blast

lemma subset_Compl_range_crdK: "A \<subseteq> - (range crdK) \<Longrightarrow> crdK x \<notin> A"
apply blast
done

lemma subset_Compl_range_pin: "A \<subseteq> - (range pin) \<Longrightarrow> pin x \<notin> A"
apply blast
done

lemma subset_Compl_range_pairK: "A \<subseteq> - (range pairK) \<Longrightarrow> pairK x \<notin> A"
apply blast
done
lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key`(insert K KK) \<union> C"
by blast

(** Reverse the normal simplification of "image" to build up (not break down)
    the set of keys.  Use analz_insert_eq with (Un_upper2 RS analz_mono) to
    erase occurrences of forwarded message components (X). **)

lemmas analz_image_freshK_simps =
       simp_thms mem_simps \<comment> \<open>these two allow its use with \<open>only:\<close>\<close>
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN [2] rev_subsetD]
       insert_Key_singleton subset_Compl_range_shrK subset_Compl_range_crdK
       subset_Compl_range_pin subset_Compl_range_pairK
       Key_not_used insert_Key_image Un_assoc [THEN sym]

(*Lemma for the trivial direction of the if-and-only-if*)
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) \<longrightarrow> (K \<in> nE | Key K \<in> analz H)  \<Longrightarrow>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsection\<open>Tactics for possibility theorems\<close>

ML
\<open>
structure Smartcard =
struct

(*Omitting used_Says makes the tactic much faster: it leaves expressions
    such as  Nonce ?N \<notin> used evs that match Nonce_supply*)
fun possibility_tac ctxt =
   (REPEAT
    (ALLGOALS (simp_tac (ctxt
      delsimps @{thms used_Cons_simps}
      setSolver safe_solver))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}])))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac ctxt [refl, conjI]))

val analz_image_freshK_ss =
  simpset_of
   (\<^context> delsimps [image_insert, image_Un]
               delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
               addsimps @{thms analz_image_freshK_simps})
end
\<close>

(*Lets blast_tac perform this step without needing the simplifier*)
lemma invKey_shrK_iff [iff]:
     "(Key (invKey K) \<in> X) = (Key K \<in> X)"
by auto

(*Specialized methods*)

method_setup analz_freshK = \<open>
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac ctxt [allI, ballI, impI]),
          REPEAT_FIRST (resolve_tac ctxt @{thms analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Smartcard.analz_image_freshK_ss ctxt))])))\<close>
    "for proving the Session Key Compromise theorem"

method_setup possibility = \<open>
    Scan.succeed (fn ctxt =>
        SIMPLE_METHOD (Smartcard.possibility_tac ctxt))\<close>
    "for proving possibility theorems"

method_setup basic_possibility = \<open>
    Scan.succeed (fn ctxt =>
        SIMPLE_METHOD (Smartcard.basic_possibility_tac ctxt))\<close>
    "for proving possibility theorems"

lemma knows_subset_knows_Cons: "knows A evs \<subseteq> knows A (e # evs)"
by (induct e) (auto simp: knows_Cons)

(*Needed for actual protocols that will follow*)
declare shrK_disj_crdK[THEN not_sym, iff]
declare shrK_disj_pin[THEN not_sym, iff]
declare pairK_disj_shrK[THEN not_sym, iff]
declare pairK_disj_crdK[THEN not_sym, iff]
declare pairK_disj_pin[THEN not_sym, iff]
declare crdK_disj_pin[THEN not_sym, iff]

declare legalUse_def [iff] illegalUse_def [iff]

end