subsection \<open>Identity Characterization Equivalences\<close>

theory Identity
  imports Correspondence "../ParticularStructures/StructuralPropertiesTheorems"
  Individuality AnchoringAndIdentifiability

begin

context ufo_particular_theory
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Here is a summary of the logical equivalences between the concepts that can
  be used to characterize identity:
\<close>
text_raw \<open>\par\<close>
lemma \<^marker>\<open>tag (proof) aponly\<close> identifiable_particulars_are_individuals:
    \<open>\<P>\<^sub>= \<subseteq> \<P>\<^sub>i\<^sub>n\<^sub>d\<close>
  by (simp add: identifiables_are_the_non_permutables non_permutables_are_non_collapsible)

theorem  identifiable_particulars_are_the_non_permutables:
    \<open>\<P>\<^sub>= = \<P>\<^sub>1\<^sub>!\<close>
  using identifiables_are_the_non_permutables .

theorem  identifiable_particulars_are_the_isomorphically_unique:
    \<open>\<P>\<^sub>= = \<P>\<^sub>\<simeq>\<^sub>!\<close>
  using identifiables_are_the_im_uniques .

theorem identifiable_particulars_are_the_anchored_particulars:
    \<open>\<P>\<^sub>= = \<P>\<^sub>\<down>\<close>
  by (simp add: anchored_are_the_non_permutable
                identifiables_are_the_im_uniques
                non_permutable_particulars_are_the_unique_particulars)

end

end


section \<open>Verifying term graph optimizations using Isabelle/HOL\<close>

theory TreeSnippets
  imports
    Canonicalizations.BinaryNode
    Canonicalizations.ConditionalPhase
    Canonicalizations.AddPhase
    Semantics.TreeToGraphThms
    Snippets.Snipping
    "HOL-Library.OptionalSugar"
begin

\<comment> \<open>First, we disable undesirable markup.\<close>
declare [[show_types=false,show_sorts=false]]
no_notation ConditionalExpr ("_ ? _ : _")

\<comment> \<open>We want to disable and reduce how aggressive automated tactics are as obligations are generated in the paper\<close>
method unfold_size = -
method unfold_optimization =
  (unfold rewrite_preservation.simps, unfold rewrite_termination.simps,
    rule conjE, simp, simp del: le_expr_def)

subsection \<open>Markup syntax for common operations\<close>

notation (latex)
  kind ("_\<llangle>_\<rrangle>")

notation (latex)
  valid_value ("_ \<in> _")

notation (latex)
  val_to_bool ("\<^latex>\<open>bool-of\<close> _")

notation (latex)
  constantAsStamp ("\<^latex>\<open>stamp-from-value\<close> _")

notation (latex)
  find_node_and_stamp ("\<^latex>\<open>find-matching\<close> _")

notation (latex)
  add_node ("\<^latex>\<open>insert\<close> _")

notation (latex)
  get_fresh_id ("\<^latex>\<open>fresh-id\<close> _")

notation (latex)
  size ("\<^latex>\<open>trm(\<close>_\<^latex>\<open>)\<close>")

subsection \<open>Representing canonicalization optimizations\<close>

text \<open>
We wish to provide an example of the semantics layers
at which optimizations can be expressed.
\<close>

\<comment> \<open>Algebraic laws\<close>
lemma diff_self:
  fixes x :: int
  shows "x - x = 0"
  by simp
lemma diff_diff_cancel:
  fixes x y :: int
  shows "x - (x - y) = y"
  by simp
thm diff_self
thm diff_diff_cancel
snipbegin \<open>algebraic-laws\<close>
text \<open>\begin{align}
@{thm diff_self[show_types=false]}\\
@{thm diff_diff_cancel[show_types=false]}
\end{align}\<close>
snipend -

\<comment> \<open>Values\<close>
lemma diff_self_value: "\<forall>x::'a::len word. x - x = 0"
  by simp
lemma diff_diff_cancel_value:
  "\<forall> x y::'a::len word . x - (x - y) = y"
  by simp

snipbegin \<open>algebraic-laws-values\<close>
text_raw \<open>\begin{align}
@{thm diff_self_value[show_types]} \label{prop-v-minus-v}\\
@{thm diff_diff_cancel_value[show_types]} \label{prop-redundant-sub}
\end{align}\<close>
snipend -

\<comment> \<open>Expression\<close>
translations
  "n" <= "CONST ConstantExpr (CONST IntVal b n)"
  "x - y" <= "CONST BinaryExpr (CONST BinSub) x y"
notation (ExprRule output)
  Refines ("_ \<longmapsto> _")
lemma diff_self_expr:
  assumes "\<forall>m p v. [m,p] \<turnstile> exp[x - x] \<mapsto> IntVal b v"
  shows "exp[x - x] \<ge> exp[const (IntVal b 0)]"
  using assms apply simp
  by (metis(full_types) evalDet val_to_bool.simps(1) zero_neq_one)

method open_eval = (simp; (rule impI)?; (rule allI)+; rule impI)

lemma diff_diff_cancel_expr:
  shows "exp[x - (x - y)] \<ge> exp[y]"
  apply open_eval
  subgoal premises eval for m p v
  proof -
    obtain vx where vx: "[m, p] \<turnstile> x \<mapsto> vx"
      using eval by blast
    obtain vy where vy: "[m, p] \<turnstile> y \<mapsto> vy"
      using eval by blast
    then have e: "[m, p] \<turnstile> exp[x - (x - y)] \<mapsto> val[vx - (vx - vy)]"
      using vx vy eval
      by (smt (verit, ccfv_SIG) bin_eval.simps(3) evalDet unfold_binary)
    then have notUn: "val[vx - (vx - vy)] \<noteq> UndefVal"
      using evaltree_not_undef by auto
    then have "val[vx - (vx - vy)] = vy"
      apply (cases vx; cases vy; auto simp: notUn)
      using eval_unused_bits_zero vy apply blast
      by (metis(full_types) intval_sub.simps(5))
    then show ?thesis
      by (metis e eval evalDet vy)
  qed
  done

thm_oracles diff_diff_cancel_expr

snipbegin \<open>algebraic-laws-expressions\<close>
text_raw \<open>\begin{align}
@{thm[mode=ExprRule] (concl) diff_self_expr} \label{prop-MinusSame} \\
@{thm[mode=ExprRule] (concl) diff_diff_cancel_expr}
\end{align}\<close>
snipend -
no_translations
  "n" <= "CONST ConstantExpr (CONST IntVal b n)"
  "x - y" <= "CONST BinaryExpr (CONST BinSub) x y"

definition wf_stamp :: "IRExpr \<Rightarrow> bool" where
  "wf_stamp e = (\<forall>m p v. ([m, p] \<turnstile> e \<mapsto> v) \<longrightarrow> valid_value v (stamp_expr e))"

lemma wf_stamp_eval:
  assumes "wf_stamp e"
  assumes "stamp_expr e = IntegerStamp b lo hi"
  shows "\<forall>m p v. ([m, p] \<turnstile> e \<mapsto> v) \<longrightarrow> (\<exists>vv. v = IntVal b vv)"
  using assms unfolding wf_stamp_def
  using valid_int_same_bits valid_int
  by metis

phase SnipPhase
  terminating size
begin
lemma sub_same_val:
  assumes "val[x - x] = IntVal b v"
  shows "val[x - x] = val[IntVal b 0]"
  using assms by (cases x; auto)

snipbegin \<open>sub-same-32\<close>
optimization SubIdentity:
  "x - x \<longmapsto> ConstantExpr (IntVal b 0)
     when ((stamp_expr exp[x - x] = IntegerStamp b lo hi) \<and> wf_stamp exp[x - x])"
  snipend -
   using IRExpr.disc(42) size.simps(4) size_non_const
   apply simp
  apply (rule impI) apply simp
proof -
  assume assms: "stamp_binary BinSub (stamp_expr x) (stamp_expr x) = IntegerStamp b lo hi \<and> wf_stamp exp[x - x]"
  have "\<forall>m p v . ([m, p] \<turnstile> exp[x - x] \<mapsto> v) \<longrightarrow> (\<exists>vv. v = IntVal b vv)"
    using assms wf_stamp_eval
    by (metis stamp_expr.simps(2))
  then show "\<forall>m p v. ([m,p] \<turnstile> BinaryExpr BinSub x x \<mapsto> v) \<longrightarrow> ([m,p] \<turnstile> ConstantExpr (IntVal b 0) \<mapsto> v)"
    using wf_value_def
    by (smt (verit, best) BinaryExprE TreeSnippets.wf_stamp_def assms bin_eval.simps(3) constantAsStamp.simps(1) evalDet stamp_expr.simps(2) sub_same_val unfold_const valid_stamp.simps(1) valid_value.simps(1))
qed
thm_oracles SubIdentity

snipbegin \<open>RedundantSubtract\<close>
optimization RedundantSubtract:
  "x - (x - y) \<longmapsto> y"
snipend -
  using size_simps apply simp
  using diff_diff_cancel_expr by presburger
end

subsection \<open>Representing terms\<close>

text \<open>
We wish to show a simple example of expressions represented as terms.
\<close>

snipbegin \<open>ast-example\<close>
text "@{value[display,margin=40] \<open>BinaryExpr BinAdd (BinaryExpr BinMul x x) (BinaryExpr BinMul x x)\<close>}"
snipend -

text \<open>
Then we need to show the datatypes that compose the example expression.
\<close>

snipbegin \<open>abstract-syntax-tree\<close>
text \<open>@{datatype[display,margin=40] IRExpr}\<close>
snipend -

snipbegin \<open>value\<close>
text \<open>@{datatype[display,margin=40,show_abbrevs] Value}\<close>
snipend -

subsection \<open>Term semantics\<close>

text \<open>
The core expression evaluation functions need to be introduced.
\<close>

snipbegin \<open>eval\<close>
text \<open>@{term_type[mode=type_def] unary_eval}\\
@{term_type[mode=type_def] bin_eval}\<close>
snipend -

text \<open>
We then provide the full semantics of IR expressions.
\<close>

no_translations
  ("prop") "P \<and> Q \<Longrightarrow> R" <= ("prop") "P \<Longrightarrow> Q \<Longrightarrow> R"
translations
  ("prop") "P \<Longrightarrow> Q \<Longrightarrow> R" <= ("prop") "P \<and> Q \<Longrightarrow> R"
snipbegin \<open>tree-semantics\<close>
text \<open>
\induct{@{thm[mode=Rule] evaltree.UnaryExpr [no_vars]}}{semantics:unary}
\induct{@{thm[mode=Rule] evaltree.BinaryExpr [no_vars]}}{semantics:binary}
\induct{@{thm[mode=Rule] evaltree.ConditionalExpr [no_vars]}}{semantics:conditional}
\induct{@{thm[mode=Rule] evaltree.ConstantExpr [no_vars]}}{semantics:constant}
\induct{@{thm[mode=Rule] evaltree.ParameterExpr [no_vars]}}{semantics:parameter}
\induct{@{thm[mode=Rule] evaltree.LeafExpr [no_vars]}}{semantics:leaf}
\<close>
snipend -
no_translations
  ("prop") "P \<Longrightarrow> Q \<Longrightarrow> R" <= ("prop") "P \<and> Q \<Longrightarrow> R"
translations
  ("prop") "P \<and> Q \<Longrightarrow> R" <= ("prop") "P \<Longrightarrow> Q \<Longrightarrow> R"

text \<open>And show that expression evaluation is deterministic.\<close>

snipbegin \<open>tree-evaluation-deterministic\<close>
text \<open>@{thm[display] evalDet [no_vars]}\<close>
snipend -

text \<open>
We then want to start demonstrating the obligations for optimizations.
For this we define refinement over terms.
\<close>

snipbegin \<open>expression-refinement\<close>
text \<open>@{thm le_expr_def [no_vars]} \<close>
snipend -

text \<open>
To motivate this definition we show the obligations generated
by optimization definitions.
\<close>

phase SnipPhase
  terminating size
begin
snipbegin \<open>InverseLeftSub\<close>
optimization InverseLeftSub:
  "(x - y) + y \<longmapsto> x"
snipend -
  snipbegin \<open>InverseLeftSubObligation\<close>
  text \<open>@{subgoals[display]}\<close>
  snipend -
  using RedundantSubAdd by auto

snipbegin \<open>InverseRightSub\<close>
optimization InverseRightSub: "y + (x - y) \<longmapsto> x"
snipend -
  snipbegin \<open>InverseRightSubObligation\<close>
  text \<open>@{subgoals[display]}\<close>
  snipend -
  using RedundantSubAdd2(2) rewrite_termination.simps(1) apply blast
  using RedundantSubAdd2(1) rewrite_preservation.simps(1) by blast
end

snipbegin \<open>expression-refinement-monotone\<close>
text \<open>@{thm[display,margin=60] mono_unary}
@{thm[display,margin=60] mono_binary}
@{thm[display,margin=60] mono_conditional}
\<close>
snipend -

phase SnipPhase
  terminating size
begin
snipbegin \<open>BinaryFoldConstant\<close>
optimization BinaryFoldConstant: "BinaryExpr op (const v1) (const v2) \<longmapsto> ConstantExpr (bin_eval op v1 v2)"
snipend -
  snipbegin \<open>BinaryFoldConstantObligation\<close>
  text \<open>@{subgoals[display]}\<close>
  snipend -
  using BinaryFoldConstant(1) by auto

snipbegin \<open>AddCommuteConstantRight\<close>
optimization AddCommuteConstantRight:
  "(const v) + y \<longmapsto> y + (const v) when \<not>(is_ConstantExpr y)"
snipend -
  snipbegin \<open>AddCommuteConstantRightObligation\<close>
  text \<open>@{subgoals[display,margin=50]}\<close>
  snipend -
  using AddShiftConstantRight by auto

snipbegin \<open>AddNeutral\<close>
optimization AddNeutral: "x + (const (IntVal 32 0)) \<longmapsto> x"
snipend -
  snipbegin \<open>AddNeutralObligation\<close>
  text \<open>@{subgoals[display]}\<close>
  snipend -
  apply auto
  using AddNeutral(1) rewrite_preservation.simps(1) by force

snipbegin \<open>AddToSub\<close>
optimization AddToSub: "-x + y \<longmapsto> y - x"
snipend -
  snipbegin \<open>AddToSubObligation\<close>
  text \<open>@{subgoals[display]}\<close>
  snipend -
  using AddLeftNegateToSub by auto

end

definition trm where "trm = size"

lemma trm_defn[size_simps]:
  "trm x = size x"
  by (simp add: trm_def)

snipbegin \<open>phase\<close>
phase AddCanonicalizations
  terminating trm
begin
  text_raw "\\dots"
end
snipend -

hide_const (open) "Form.wf_stamp"

snipbegin \<open>phase-example\<close>
phase Conditional
  terminating trm
begin
snipend -

snipbegin \<open>phase-example-1\<close>optimization NegateCond: "((!c) ? t : f) \<longmapsto> (c ? f : t)"snipend -
  apply (simp add: size_simps)
  using ConditionalPhase.NegateConditionFlipBranches(1) by simp

snipbegin \<open>phase-example-2\<close>optimization TrueCond: "(true ? t : f) \<longmapsto> t"snipend -
  by (auto simp: trm_def)

snipbegin \<open>phase-example-3\<close>optimization FalseCond: "(false ? t : f) \<longmapsto> f"snipend -
  by (auto simp: trm_def)

snipbegin \<open>phase-example-4\<close>optimization BranchEqual: "(c ? x : x) \<longmapsto> x"snipend -
  by (auto simp: trm_def)

snipbegin \<open>phase-example-5\<close>optimization LessCond: "((u < v) ? t : f) \<longmapsto> t
                   when (stamp_under (stamp_expr u) (stamp_expr v)
                            \<and> wf_stamp u \<and> wf_stamp v)"snipend -
  apply (auto simp: trm_def)
  using ConditionalPhase.condition_bounds_x(1)
  by (metis(full_types) StampEvalThms.wf_stamp_def TreeSnippets.wf_stamp_def bin_eval.simps(12) stamp_under_defn)

snipbegin \<open>phase-example-6\<close>optimization condition_bounds_y: "((x < y) ? x : y) \<longmapsto> y
                   when (stamp_under (stamp_expr y) (stamp_expr x) \<and> wf_stamp x \<and> wf_stamp y)"snipend -
  apply (auto simp: trm_def)
  using ConditionalPhase.condition_bounds_y(1)
  by (metis(full_types) StampEvalThms.wf_stamp_def TreeSnippets.wf_stamp_def bin_eval.simps(12) stamp_under_defn_inverse)

snipbegin \<open>phase-example-7\<close>end snipend -

lemma simplified_binary: "\<not>(is_ConstantExpr b) \<Longrightarrow> size (BinaryExpr op a b) = size a + size b + 2"
  by (induction b; induction op; auto simp: is_ConstantExpr_def)

thm bin_size
thm bin_const_size
thm unary_size
thm size_non_add
snipbegin \<open>termination\<close>
text \<open>
@{thm[display,margin=80] unary_size}
@{thm[display,margin=80] bin_const_size}
@{thm[display,margin=80] (concl) simplified_binary}
@{thm[display,margin=80] cond_size}
@{thm[display,margin=80] const_size}
@{thm[display,margin=80] param_size}
@{thm[display,margin=80] leaf_size}
\<close>
snipend -

(* definition 5 (semantics-preserving) is there a distinction in Isabelle? *)

snipbegin \<open>graph-representation\<close>
text \<open>@{bold \<open>typedef\<close>} IRGraph =

@{term[source] \<open>{g :: ID \<rightharpoonup> (IRNode \<times> Stamp) . finite (dom g)}\<close>}\<close>
snipend -

no_translations
  ("prop") "P \<and> Q \<Longrightarrow> R" <= ("prop") "P \<Longrightarrow> Q \<Longrightarrow> R"
translations
  ("prop") "P \<Longrightarrow> Q \<Longrightarrow> R" <= ("prop") "P \<and> Q \<Longrightarrow> R"
snipbegin \<open>graph2tree\<close>
text \<open>
\induct{@{thm[mode=Rule] rep.ConstantNode [no_vars]}}{rep:constant}
\induct{@{thm[mode=Rule] rep.ParameterNode [no_vars]}}{rep:parameter}
\induct{@{thm[mode=Rule] rep.ConditionalNode [no_vars]}}{rep:conditional}
\induct{@{thm[mode=Rule] rep.AbsNode [no_vars]}}{rep:unary}
\induct{@{thm[mode=Rule] rep.SignExtendNode [no_vars]}}{rep:convert}
\induct{@{thm[mode=Rule] rep.AddNode [no_vars]}}{rep:binary}
\induct{@{thm[mode=Rule] rep.LeafNode [no_vars]}}{rep:leaf}
\induct{@{thm[mode=Rule] rep.RefNode [no_vars]}}{rep:ref}
\<close>
snipend -

snipbegin \<open>tree2graph\<close>
text \<open>
\induct{@{thm[mode=Rule] unrep.UnaryNodeSame [no_vars]}}{unrep:unarysame}
\induct{@{thm[mode=Rule] unrep.ConstantNodeNew [no_vars]}}{unrep:constantnew}
\induct{@{thm[mode=Rule] unrep.ParameterNodeNew [no_vars]}}{unrep:parameternew}
\induct{@{thm[mode=Rule] unrep.UnaryNodeNew [no_vars]}}{unrep:unarynew}
\induct{@{thm[mode=Rule] unrep.BinaryNodeNew [no_vars]}}{unrep:binarynew}
\induct{@{thm[mode=Rule] unrep.AllLeafNodes [no_vars]}}{unrep:leaf}
\<close>
snipend -
no_translations
  ("prop") "P \<Longrightarrow> Q \<Longrightarrow> R" <= ("prop") "P \<and> Q \<Longrightarrow> R"
translations
  ("prop") "P \<and> Q \<Longrightarrow> R" <= ("prop") "P \<Longrightarrow> Q \<Longrightarrow> R"

snipbegin \<open>preeval\<close>
text \<open>@{thm is_preevaluated.simps}\<close>
snipend -

snipbegin \<open>deterministic-representation\<close>
text \<open>@{thm[display] repDet [no_vars]}\<close>
snipend -
thm_oracles repDet

snipbegin \<open>well-formed-term-graph\<close>
text "@{thm (rhs) wf_term_graph_def [no_vars]}"
snipend -

(* definition 9 (well-formed graph) no? *)

snipbegin \<open>graph-semantics\<close>
text \<open>@{thm encodeeval_def}\<close>
snipend -

snipbegin \<open>graph-semantics-deterministic\<close>
text \<open>@{thm graphDet [no_vars]}\<close>
snipend -
thm_oracles graphDet

notation (latex)
  graph_refinement ("\<^latex>\<open>term-graph-refinement\<close> _")

snipbegin \<open>graph-refinement\<close>
text \<open>@{thm[display, margin=60] graph_refinement_def [no_vars]}\<close>
snipend -

(* hide as_set, should treat IRGraph as a set of pairs in paper *)
translations
  "n" <= "CONST as_set n"

snipbegin \<open>graph-semantics-preservation\<close>
text \<open>@{thm[display, margin=30] graph_semantics_preservation_subscript [no_vars]}\<close>
snipend -
thm_oracles graph_semantics_preservation_subscript

snipbegin \<open>maximal-sharing\<close>
text \<open>@{thm[display, margin=50] maximal_sharing [no_vars]}\<close>
snipend -

snipbegin \<open>tree-to-graph-rewriting\<close>
text \<open>@{thm[display, margin=30] tree_to_graph_rewriting [no_vars]}\<close>
snipend -
thm_oracles tree_to_graph_rewriting

snipbegin \<open>term-graph-refines-term\<close>
text \<open>@{thm[display] graph_represents_expression_def [no_vars]}\<close>
snipend -

snipbegin \<open>term-graph-evaluation\<close>
text \<open>@{thm[display] term_graph_evaluation [no_vars]}\<close>
snipend -

snipbegin \<open>graph-construction\<close>
text \<open>@{thm[display, margin=40] graph_construction [no_vars]}\<close>
snipend -
thm_oracles graph_construction

snipbegin \<open>term-graph-reconstruction\<close>
text \<open>@{thm[display] term_graph_reconstruction [no_vars]}\<close>
snipend -

snipbegin \<open>refined-insert\<close>
text \<open>@{thm[display, margin=40] refined_insert [no_vars]}\<close>
snipend -

end


theory Bool_Assn_Setup
  imports
    Isabelle_LLVM.LLVM_Shallow_RS
    "Separation_Logic_Solver/Methods"
begin

abbreviation (input) ll_True :: "1 word" where "ll_True \<equiv> 1"
abbreviation (input) ll_False :: "1 word" where "ll_False \<equiv> 0"

lemma [simp]: "\<flat>\<^sub>pbool.assn B ll_False = (\<not>B)"
  by (simp add: bool.assn_def)

lemma
  bool_assn_pure_eq:
  "\<upharpoonleft>bool.assn b bi = \<up>(if b then bi = 1 else bi = 0)"
  unfolding bool.assn_def
  apply (cases b; cases bi)
  apply auto
  done

lemma
  bool_assn_True_TrueI:
  "\<box> \<turnstile> \<upharpoonleft>bool.assn True ll_True"
  by (auto simp add: pure_true_conv bool_assn_pure_eq)

lemma
  bool_assn_True_True_eq [simp]:
  "\<upharpoonleft>bool.assn True ll_True = \<box>"
  by (auto simp add: pure_true_conv bool_assn_pure_eq)

lemma
  bool_assn_False_FalseI:
  "\<box> \<turnstile> \<upharpoonleft>bool.assn False ll_False"
  by (auto simp add: pure_true_conv bool_assn_pure_eq)

lemma
  bool_assn_False_False_eq [simp]:
  "\<upharpoonleft>bool.assn False ll_False = \<box>"
  by (auto simp add: pure_true_conv bool_assn_pure_eq)

declare intro_red_rule[OF bool_assn_True_TrueI, fri_red_rules]
declare intro_red_rule[OF bool_assn_False_FalseI, fri_red_rules]

lemma [simp]: "x \<noteq> ll_True \<longleftrightarrow> x = ll_False"
  using word1_neqZ_is_one by blast

lemma [simp]: "x \<noteq> ll_False \<longleftrightarrow> x = ll_True" using word1_neqZ_is_one .

lemma from_bool_False [simp]: "from_bool False = 0" by simp
lemma from_bool_True [simp]: "from_bool True = 1" by simp

end


section {* Alphabet manipulation *}

theory utp_alphabet
  imports
    utp_pred
begin

named_theorems alpha

method alpha_tac = (simp add: alpha unrest)?

subsection {* Alphabet extension *}

text {* Extend an alphabet by application of a lens that demonstrates how the smaller alphabet
  ($\beta$) injects into the larger alphabet ($\alpha$). *}

lift_definition aext :: "('a, '\<beta>) uexpr \<Rightarrow> ('\<beta>, '\<alpha>) lens \<Rightarrow> ('a, '\<alpha>) uexpr" (infixr "\<oplus>\<^sub>p" 95)
is "\<lambda> P x b. P (get\<^bsub>x\<^esub> b)" .

update_uexpr_rep_eq_thms

lemma aext_id [alpha]: "P \<oplus>\<^sub>p 1\<^sub>L = P"
  by (pred_auto)

lemma aext_lit [alpha]: "\<guillemotleft>v\<guillemotright> \<oplus>\<^sub>p a = \<guillemotleft>v\<guillemotright>"
  by (pred_auto)

lemma aext_zero [alpha]: "0 \<oplus>\<^sub>p a = 0"
  by (pred_auto)

lemma aext_one [alpha]: "1 \<oplus>\<^sub>p a = 1"
  by (pred_auto)

lemma aext_numeral [alpha]: "numeral n \<oplus>\<^sub>p a = numeral n"
  by (pred_auto)

lemma aext_uop [alpha]: "uop f u \<oplus>\<^sub>p a = uop f (u \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_bop [alpha]: "bop f u v \<oplus>\<^sub>p a = bop f (u \<oplus>\<^sub>p a) (v \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_trop [alpha]: "trop f u v w \<oplus>\<^sub>p a = trop f (u \<oplus>\<^sub>p a) (v \<oplus>\<^sub>p a) (w \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_qtop [alpha]: "qtop f u v w x \<oplus>\<^sub>p a = qtop f (u \<oplus>\<^sub>p a) (v \<oplus>\<^sub>p a) (w \<oplus>\<^sub>p a) (x \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_plus [alpha]:
  "(x + y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) + (y \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_minus [alpha]:
  "(x - y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) - (y \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_uminus [simp]:
  "(- x) \<oplus>\<^sub>p a = - (x \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_times [alpha]:
  "(x * y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) * (y \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_divide [alpha]:
  "(x / y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) / (y \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_var [alpha]:
  "var x \<oplus>\<^sub>p a = var (x ;\<^sub>L a)"
  by (pred_auto)

lemma aext_ulambda [alpha]: "((\<lambda> x \<bullet> P(x)) \<oplus>\<^sub>p a) = (\<lambda> x \<bullet> P(x) \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_true [alpha]: "true \<oplus>\<^sub>p a = true"
  by (pred_auto)

lemma aext_false [alpha]: "false \<oplus>\<^sub>p a = false"
  by (pred_auto)

lemma aext_not [alpha]: "(\<not> P) \<oplus>\<^sub>p x = (\<not> (P \<oplus>\<^sub>p x))"
  by (pred_auto)

lemma aext_and [alpha]: "(P \<and> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<and> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_or [alpha]: "(P \<or> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<or> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_imp [alpha]: "(P \<Rightarrow> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<Rightarrow> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_iff [alpha]: "(P \<Leftrightarrow> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<Leftrightarrow> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma unrest_aext [unrest]:
  "\<lbrakk> mwb_lens a; x \<sharp> p \<rbrakk> \<Longrightarrow> unrest (x ;\<^sub>L a) (p \<oplus>\<^sub>p a)"
  by (transfer, simp add: lens_comp_def)

lemma unrest_aext_indep [unrest]:
  "a \<bowtie> b \<Longrightarrow> b \<sharp> (p \<oplus>\<^sub>p a)"
  by pred_auto

subsection {* Alphabet restriction *}

text {* Restrict an alphabet by application of a lens that demonstrates how the smaller alphabet
  ($\beta$) injects into the larger alphabet ($\alpha$). Unlike extension, this operation
  can lose information if the expressions refers to variables in the larger alphabet. *}

lift_definition arestr :: "('a, '\<alpha>) uexpr \<Rightarrow> ('\<beta>, '\<alpha>) lens \<Rightarrow> ('a, '\<beta>) uexpr" (infixr "\<restriction>\<^sub>p" 90)
is "\<lambda> P x b. P (create\<^bsub>x\<^esub> b)" .

update_uexpr_rep_eq_thms

lemma arestr_id [alpha]: "P \<restriction>\<^sub>p 1\<^sub>L = P"
  by (pred_auto)

lemma arestr_aext [simp]: "mwb_lens a \<Longrightarrow> (P \<oplus>\<^sub>p a) \<restriction>\<^sub>p a = P"
  by (pred_auto)

text {* If an expression's alphabet can be divided into two disjoint sections and the expression
  does not depend on the second half then restricting the expression to the first half is
  lossless. *}

lemma aext_arestr [alpha]:
  assumes "mwb_lens a" "bij_lens (a +\<^sub>L b)" "a \<bowtie> b" "b \<sharp> P"
  shows "(P \<restriction>\<^sub>p a) \<oplus>\<^sub>p a = P"
proof -
  from assms(2) have "1\<^sub>L \<subseteq>\<^sub>L a +\<^sub>L b"
    by (simp add: bij_lens_equiv_id lens_equiv_def)
  with assms(1,3,4) show ?thesis
    apply (auto simp add: alpha_of_def id_lens_def lens_plus_def sublens_def lens_comp_def prod.case_eq_if)
    apply (pred_simp)
    apply (metis lens_indep_comm mwb_lens_weak weak_lens.put_get)
  done
qed

lemma arestr_lit [alpha]: "\<guillemotleft>v\<guillemotright> \<restriction>\<^sub>p a = \<guillemotleft>v\<guillemotright>"
  by (pred_auto)

lemma arestr_zero [alpha]: "0 \<restriction>\<^sub>p a = 0"
  by (pred_auto)

lemma arestr_one [alpha]: "1 \<restriction>\<^sub>p a = 1"
  by (pred_auto)

lemma arestr_numeral [alpha]: "numeral n \<restriction>\<^sub>p a = numeral n"
  by (pred_auto)

lemma arestr_var [alpha]:
  "var x \<restriction>\<^sub>p a = var (x /\<^sub>L a)"
  by (pred_auto)

lemma arestr_true [alpha]: "true \<restriction>\<^sub>p a = true"
  by (pred_auto)

lemma arestr_false [alpha]: "false \<restriction>\<^sub>p a = false"
  by (pred_auto)

lemma arestr_not [alpha]: "(\<not> P)\<restriction>\<^sub>pa = (\<not> (P\<restriction>\<^sub>pa))"
  by (pred_auto)

lemma arestr_and [alpha]: "(P \<and> Q)\<restriction>\<^sub>px = (P\<restriction>\<^sub>px \<and> Q\<restriction>\<^sub>px)"
  by (pred_auto)

lemma arestr_or [alpha]: "(P \<or> Q)\<restriction>\<^sub>px = (P\<restriction>\<^sub>px \<or> Q\<restriction>\<^sub>px)"
  by (pred_auto)

lemma arestr_imp [alpha]: "(P \<Rightarrow> Q)\<restriction>\<^sub>px = (P\<restriction>\<^sub>px \<Rightarrow> Q\<restriction>\<^sub>px)"
  by (pred_auto)

subsection {* Alphabet lens laws *}

lemma alpha_in_var [alpha]: "x ;\<^sub>L fst\<^sub>L = in_var x"
  by (simp add: in_var_def)

lemma alpha_out_var [alpha]: "x ;\<^sub>L snd\<^sub>L = out_var x"
  by (simp add: out_var_def)

lemma in_var_prod_lens [alpha]:
  "wb_lens Y \<Longrightarrow> in_var x ;\<^sub>L (X \<times>\<^sub>L Y) = in_var (x ;\<^sub>L X)"
  by (simp add: in_var_def prod_as_plus lens_comp_assoc fst_lens_plus)

lemma out_var_prod_lens [alpha]:
  "wb_lens X \<Longrightarrow> out_var x ;\<^sub>L (X \<times>\<^sub>L Y) = out_var (x ;\<^sub>L Y)"
  apply (simp add: out_var_def prod_as_plus lens_comp_assoc)
  apply (subst snd_lens_plus)
  using comp_wb_lens fst_vwb_lens vwb_lens_wb apply blast
  apply (simp add: alpha_in_var alpha_out_var)
  apply (simp)
done

subsection {* Alphabet coercion *}

definition id_on :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> \<Rightarrow> '\<alpha>" where
[upred_defs]: "id_on x = (\<lambda> s. undefined \<oplus>\<^sub>L s on x)"

definition alpha_coerce :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred"
where [upred_defs]: "alpha_coerce x P = id_on x \<dagger> P"

syntax
  "_alpha_coerce" :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("!\<^sub>\<alpha> _ \<bullet> _" [0, 10] 10)

translations
  "_alpha_coerce P x" == "CONST alpha_coerce P x"

subsection {* Substitution alphabet extension *}

definition subst_ext :: "'\<alpha> usubst \<Rightarrow> ('\<alpha> \<Longrightarrow> '\<beta>) \<Rightarrow> '\<beta> usubst" (infix "\<oplus>\<^sub>s" 65) where
[upred_defs]: "\<sigma> \<oplus>\<^sub>s x = (\<lambda> s. put\<^bsub>x\<^esub> s (\<sigma> (get\<^bsub>x\<^esub> s)))"

lemma id_subst_ext [usubst,alpha]:
  "wb_lens x \<Longrightarrow> id \<oplus>\<^sub>s x = id"
  by pred_auto

lemma upd_subst_ext [alpha]:
  "vwb_lens x \<Longrightarrow> \<sigma>(y \<mapsto>\<^sub>s v) \<oplus>\<^sub>s x = (\<sigma> \<oplus>\<^sub>s x)(&x:y \<mapsto>\<^sub>s v \<oplus>\<^sub>p x)"
  by pred_auto

lemma apply_subst_ext [alpha]:
  "vwb_lens x \<Longrightarrow> (\<sigma> \<dagger> e) \<oplus>\<^sub>p x = (\<sigma> \<oplus>\<^sub>s x) \<dagger> (e \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_upred_eq [alpha]:
  "((e =\<^sub>u f) \<oplus>\<^sub>p a) = ((e \<oplus>\<^sub>p a) =\<^sub>u (f \<oplus>\<^sub>p a))"
  by (pred_auto)

subsection {* Substitution alphabet restriction *}

definition subst_res :: "'\<alpha> usubst \<Rightarrow> ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<beta> usubst" (infix "\<restriction>\<^sub>s" 65) where
[upred_defs]: "\<sigma> \<restriction>\<^sub>s x = (\<lambda> s. get\<^bsub>x\<^esub> (\<sigma> (create\<^bsub>x\<^esub> s)))"

lemma id_subst_res [alpha,usubst]:
  "mwb_lens x \<Longrightarrow> id \<restriction>\<^sub>s x = id"
  by pred_auto

lemma upd_subst_res [alpha]:
  "mwb_lens x \<Longrightarrow> \<sigma>(&x:y \<mapsto>\<^sub>s v) \<restriction>\<^sub>s x = (\<sigma> \<restriction>\<^sub>s x)(&y \<mapsto>\<^sub>s v \<restriction>\<^sub>p x)"
  by (pred_auto)

lemma subst_ext_res [alpha,usubst]:
  "mwb_lens x \<Longrightarrow> (\<sigma> \<oplus>\<^sub>s x) \<restriction>\<^sub>s x = \<sigma>"
  by (pred_auto)

lemma unrest_subst_alpha_ext [unrest]:
  "x \<bowtie> y \<Longrightarrow> x \<sharp> (P \<oplus>\<^sub>s y)"
  by (pred_simp robust, metis lens_indep_def)
end


theory Finite_Alpha
imports "../Nominal2"
begin

lemma
  assumes "(supp x - as) \<sharp>* p"
      and "p \<bullet> x = y"
      and "p \<bullet> as = bs"
    shows "(as, x) \<approx>set (op =) supp p (bs, y)"
  using assms unfolding alphas
  apply(simp)
  apply(clarify)
  apply(simp only: Diff_eqvt[symmetric] supp_eqvt[symmetric])
  apply(simp only: atom_set_perm_eq)
  done

lemma
  assumes "(supp x - set as) \<sharp>* p"
      and "p \<bullet> x = y"
      and "p \<bullet> as = bs"
    shows "(as, x) \<approx>lst (op =) supp p (bs, y)"
  using assms unfolding alphas
  apply(simp)
  apply(clarify)
  apply(simp only: set_eqvt[symmetric] Diff_eqvt[symmetric] supp_eqvt[symmetric])
  apply(simp only: atom_set_perm_eq)
  done

lemma
  assumes "(supp x - as) \<sharp>* p"
      and "p \<bullet> x = y"
      and "p \<bullet> (as \<inter> supp x) = bs \<inter> supp y"
      and "finite (supp x)"
  shows "(as, x) \<approx>res (op =) supp p (bs, y)"
  using assms
  unfolding alpha_res_alpha_set
  unfolding alphas
  apply simp
  apply rule
  apply (rule trans)
  apply (rule supp_perm_eq[symmetric, of _ p])
  apply (simp add: supp_finite_atom_set fresh_star_def)
  apply(auto)[1]
  apply(simp only: Diff_eqvt inter_eqvt supp_eqvt)
  apply (simp add: fresh_star_def)
  apply blast
  done

lemma
  assumes "(as, x) \<approx>res (op =) supp p (bs, y)"
  shows "(supp x - as) \<sharp>* p"
    and "p \<bullet> (as \<inter> supp x) = bs \<inter> supp y"
    and "p \<bullet> x = y"
  using assms
  apply -
  prefer 3
  apply (auto simp add: alphas)[2]
  unfolding alpha_res_alpha_set
  unfolding alphas
  by blast

(* On the raw level *)

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam"
| Lam x::"name" l::"lam"  binds x in l ("Lam [_]. _" [100, 100] 100)

thm alpha_lam_raw.intros(3)[unfolded alphas, simplified]

lemma alpha_fv: "alpha_lam_raw l r \<Longrightarrow> fv_lam_raw l = fv_lam_raw r"
  by (induct rule: alpha_lam_raw.induct) (simp_all add: alphas)

lemma finite_fv_raw: "finite (fv_lam_raw l)"
  by (induct rule: lam_raw.induct) (simp_all add: supp_at_base)

lemma "(fv_lam_raw l - {atom n}) \<sharp>* p \<Longrightarrow> alpha_lam_raw (p \<bullet> l) r \<Longrightarrow>
  fv_lam_raw l - {atom n} = fv_lam_raw r - {atom (p \<bullet> n)}"
  apply (rule trans)
  apply (rule supp_perm_eq[symmetric])
  apply (subst supp_finite_atom_set)
  apply (rule finite_Diff)
  apply (rule finite_fv_raw)
  apply assumption
  apply (simp add: eqvts)
  apply (subst alpha_fv)
  apply assumption
  apply (rule)
  done

(* For the res binding *)

nominal_datatype ty2 =
  Var2 "name"
| Fun2 "ty2" "ty2"

nominal_datatype tys2 =
  All2 xs::"name fset" ty::"ty2" binds (set+) xs in ty

lemma alpha_fv': "alpha_tys2_raw l r \<Longrightarrow> fv_tys2_raw l = fv_tys2_raw r"
  by (induct rule: alpha_tys2_raw.induct) (simp_all add: alphas)

lemma finite_fv_raw': "finite (fv_tys2_raw l)"
  by (induct rule: tys2_raw.induct) (simp_all add: supp_at_base finite_supp)

thm alpha_tys2_raw.intros[unfolded alphas, simplified]

lemma "(supp x - atom ` (fset as)) \<sharp>* p \<Longrightarrow> p \<bullet> (x :: tys2) = y \<Longrightarrow>
  p \<bullet> (atom ` (fset as) \<inter> supp x) = atom ` (fset bs) \<inter> supp y \<Longrightarrow>
  supp x - atom ` (fset as) = supp y - atom ` (fset bs)"
  apply (rule trans)
  apply (rule supp_perm_eq[symmetric])
  apply (subst supp_finite_atom_set)
  apply (rule finite_Diff)
  apply (rule finite_supp)
  apply assumption
  apply (simp add: eqvts)
  apply blast
  done

end


(*  Title:       CoreC++

    Author:      Tobias Nipkow
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>
*)

header {* \isaheader{Weak well-formedness of CoreC++ programs} *}

theory WWellForm imports WellForm Expr begin

definition wwf_mdecl :: "prog \<Rightarrow> cname \<Rightarrow> mdecl \<Rightarrow> bool" where
  "wwf_mdecl P C  \<equiv>  \<lambda>(M,Ts,T,(pns,body)).
  length Ts = length pns \<and> distinct pns \<and> this \<notin> set pns \<and> fv body \<subseteq> {this} \<union> set pns"

lemma wwf_mdecl[simp]:
  "wwf_mdecl P C (M,Ts,T,pns,body) =
  (length Ts = length pns \<and> distinct pns \<and> this \<notin> set pns \<and> fv body \<subseteq> {this} \<union> set pns)"
by(simp add:wwf_mdecl_def)

abbreviation
  wwf_prog :: "prog \<Rightarrow> bool" where
  "wwf_prog == wf_prog wwf_mdecl"

end


(*File: IMP.thy*)
(*Authors: Lennart Beringer and Martin Hofmann, LMU Munich 2008*)
theory IMP imports Main begin
section {*The language IMP*}

text{*\label{sec:IMP}In this section we define a simple imperative programming
language. Syntax and operational semantics are as in \cite{Winskel93},
except that we enrich the language with a single unnamed,
parameterless procedure. Both, this section and the following one
merely set the basis for the development described in the later
sections and largely follow the approach to formalize program logics
advocated by Kleymann, Nipkow, and others - see for example
\cite{KleymannPhD,Nipkow-CSL02,Nipkow-AFP-AHL}.*}

subsection{*Syntax*}

text{*We start from unspecified categories of program variables and
values.*}

typedecl Var
typedecl Val

text{*Arithmetic expressions are inductively built up from variables,
values, and binary operators which are modeled as meta-logical
functions over values. Similarly, boolean expressions are built up
from arithmetic expressions using binary boolean operators which are
modeled as functions of the ambient logic HOL.*}

datatype Expr =
   varE Var
 | valE Val
 | opE "Val \<Rightarrow> Val \<Rightarrow> Val" Expr Expr

datatype BExpr = compB "Val \<Rightarrow> Val \<Rightarrow> bool" Expr Expr

text{*Commands are the usual ones for an imperative language, plus the
command $\mathit{Call}$ which stands for the invocation of a single
(unnamed, parameterless) procedure.*}

datatype IMP =
    Skip
  | Assign Var Expr
  | Comp IMP IMP
  | While BExpr IMP
  | Iff BExpr IMP IMP
  | Call

text{*The body of this procedure is identified by the following
constant.*}

consts body :: IMP

subsection{*Dynamic semantics*}

text{*States are given by stores - in our case, HOL functions
mapping program variables to values.*}

type_synonym State = "Var \<Rightarrow> Val"

definition update :: "State \<Rightarrow> Var \<Rightarrow> Val \<Rightarrow> State"
where "update s x v = (\<lambda> y . if x=y then v else s y)"

text{*The evaluation of expressions is defined inductively, as
standard.*}

primrec evalE::"Expr \<Rightarrow> State \<Rightarrow> Val"
where
"evalE (varE x) s = s x" |
"evalE (valE v) s = v" |
"evalE (opE f e1 e2) s = f (evalE e1 s) (evalE e2 s)"

primrec evalB::"BExpr \<Rightarrow> State \<Rightarrow> bool"
where
"evalB (compB f e1 e2) s = f (evalE e1 s) (evalE e2 s)"

text{*The operational semantics is a standard big-step relation, with
a height index that facilitates the Kleymann-Nipkow-style~\cite{KleymannPhD,Nipkow-CSL02}
soundness proof of the program logic.*}

inductive_set Semn :: "(State \<times> IMP \<times> nat \<times> State) set" where
 SemSkip: "(s,Skip,1,s) : Semn"

| SemAssign:
  "\<lbrakk> t = update s x (evalE e s)\<rbrakk> \<Longrightarrow> (s,Assign x e,1,t):Semn"

| SemComp:
  "\<lbrakk> (s,c1,n,r):Semn; (r,c2,m,t):Semn; k=(max n m)+1\<rbrakk>
   \<Longrightarrow> (s,Comp c1 c2,k,t):Semn"

| SemWhileT:
  "\<lbrakk>evalB b s; (s,c,n,r):Semn; (r,While b c,m,t):Semn;
       k=((max n m)+1)\<rbrakk>
   \<Longrightarrow> (s,While b c,k,t):Semn"

| SemWhileF: "\<lbrakk>\<not> (evalB b s); t=s\<rbrakk> \<Longrightarrow> (s,While b c,1,t):Semn"

| SemTrue:
  "\<lbrakk>evalB b s; (s,c1,n,t):Semn \<rbrakk> \<Longrightarrow> (s,Iff b c1 c2,n+1,t):Semn"

| SemFalse:
  "\<lbrakk>\<not> (evalB b s); (s,c2,n,t):Semn\<rbrakk> \<Longrightarrow> (s,Iff b c1 c2,n+1,t):Semn"

| SemCall: "(s,body,n,t):Semn \<Longrightarrow> (s,Call,n+1,t):Semn"
(*
 SemSkip:  "(s,Skip \<longrightarrow>\<^sub>1 s"
 SemAssign:"\<lbrakk> t = update s x (evalE e s)\<rbrakk> \<Longrightarrow> s,(Assign x e) \<longrightarrow>\<^sub>1 t"
SemComp:  "\<lbrakk> s,c1 \<longrightarrow>\<^sub>n r; r,c2 \<longrightarrow>\<^sub>m t; k=(max n m)+1\<rbrakk>
          \<Longrightarrow> s,(Comp c1 c2) \<longrightarrow>\<^sub>k t"
 SemWhileT:"\<lbrakk>evalB b s; s,c \<longrightarrow>\<^sub>n r; r,(While b c) \<longrightarrow>\<^sub>m t;
             k=((max n m)+1)\<rbrakk>
          \<Longrightarrow> s,(While b c) \<longrightarrow>\<^sub>k t"
 SemWhileF:"\<lbrakk>\<not> (evalB b s); t=s\<rbrakk> \<Longrightarrow> s,(While b c) \<longrightarrow>\<^sub>1 t"
 SemTrue:  "\<lbrakk>evalB b s; s,c1 \<longrightarrow>\<^sub>n t\<rbrakk> \<Longrightarrow> s,(Iff b c1 c2) \<longrightarrow>\<^sub>(n+1) t"
 SemFalse: "\<lbrakk>\<not> (evalB b s); s,c2 \<longrightarrow>\<^sub>n t\<rbrakk>
          \<Longrightarrow> s,(Iff b c1 c2) \<longrightarrow>\<^sub>(n+1) t"
 SemCall:  "\<lbrakk> s,body \<longrightarrow>\<^sub>n t\<rbrakk> \<Longrightarrow> s,Call \<longrightarrow>\<^sub>(n+1) t"
*)

abbreviation
SemN  :: "[State, IMP, nat, State] \<Rightarrow> bool"   (" _ , _ \<rightarrow>\<^sub>_  _ ")
where
"s,c \<rightarrow>\<^sub>n t == (s,c,n,t) : Semn"

text{*Often, the height index does not matter, so we define a notion
hiding it.*}

definition Sem :: "[State, IMP, State] \<Rightarrow> bool" ("_ , _ \<Down> _ " 1000)
where "s,c \<Down> t = (\<exists> n. s,c \<rightarrow>\<^sub>n t)"

text{*Inductive elimination rules for the (indexed) dynamic semantics:*}

inductive_cases Sem_eval_cases:
 "s,Skip \<rightarrow>\<^sub>n t"
 "s,(Assign x e) \<rightarrow>\<^sub>n t"
 "s,(Comp c1 c2) \<rightarrow>\<^sub>n t"
 "s,(While b c) \<rightarrow>\<^sub>n t"
 "s,(Iff b c1 c2) \<rightarrow>\<^sub>n t"
 "s, Call \<rightarrow>\<^sub>n t"

(*<*)
lemma Sem_no_zero_height_derivsAux: "\<forall> s t. ((s, c \<rightarrow>\<^sub>0 t) --> False)"
by (induct_tac c, auto elim: Sem_eval_cases)
(*>*)

text{*An induction on $c$ shows that no derivations of height
$0$ exist.*}

lemma Sem_no_zero_height_derivs: "(s, c \<rightarrow>\<^sub>0 t) ==> False"
(*<*)by (insert Sem_no_zero_height_derivsAux, fastforce)(*>*)

(*<*)
lemma SemnDeterm[rule_format]:
"(s, c \<rightarrow>\<^sub>n t) ==> (\<forall> r m . (s, c \<rightarrow>\<^sub>m r) --> m=n \<and> r=t)"
apply (erule Semn.induct)
apply(clarsimp, elim Sem_eval_cases, simp)
(*Assign*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply simp
(*Comp*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply simp
(*WhileT*)
apply (rule allI)+ apply rule
apply (rotate_tac 3) apply (erule thin_rl)
apply (erule Sem_eval_cases) apply clarify
  apply (rotate_tac -4)
  apply (erule_tac x=rb in allE) apply (erule_tac x=na in allE) apply clarsimp
  apply clarify
(*WhileF*)
apply (rule allI)+ apply rule
apply (erule Sem_eval_cases) apply clarify
  apply simp
(*True*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply simp
apply fast
(*False*)
apply (rule allI)+ apply rule
apply(elim Sem_eval_cases)
apply fast
apply simp
(*Call*)
apply clarify
apply(elim Sem_eval_cases)
apply simp
done
(*>*)

text{*The proof of determinism is by induction on the
      (indexed) operational semantics.*}

lemma SemDeterm: "\<lbrakk>s, c \<Down> t; s, c \<Down> r\<rbrakk> \<Longrightarrow> r=t"
(*<*)
apply (simp add: Sem_def, clarsimp)
apply (drule SemnDeterm, assumption)
apply simp
done
(*>*)

text{*End of theory IMP*}
end


(*  Title:      HOL/SET_Protocol/Public_SET.thy
    Author:     Giampaolo Bella
    Author:     Fabio Massacci
    Author:     Lawrence C Paulson
*)

section\<open>The Public-Key Theory, Modified for SET\<close>

theory Public_SET
imports Event_SET
begin

subsection\<open>Symmetric and Asymmetric Keys\<close>

text\<open>definitions influenced by the wish to assign asymmetric keys
  - since the beginning - only to RCA and CAs, namely we need a partial
  function on type Agent\<close>

text\<open>The SET specs mention two signature keys for CAs - we only have one\<close>

consts
  publicKey :: "[bool, agent] => key"
    \<comment>\<open>the boolean is TRUE if a signing key\<close>

abbreviation "pubEK == publicKey False"
abbreviation "pubSK == publicKey True"

(*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
abbreviation "priEK A == invKey (pubEK A)"
abbreviation "priSK A == invKey (pubSK A)"

text\<open>By freeness of agents, no two agents have the same key. Since
 @{term "True\<noteq>False"}, no agent has the same signing and encryption keys.\<close>

specification (publicKey)
  injective_publicKey:
    "publicKey b A = publicKey c A' ==> b=c & A=A'"
(*<*)
   apply (rule exI [of _ "%b A. 2 * nat_of_agent A + (if b then 1 else 0)"])
   apply (auto simp add: inj_on_def inj_nat_of_agent [THEN inj_eq] split: agent.split)
   apply (drule_tac f="%x. x mod 2" in arg_cong, simp add: mod_Suc)+
(*or this, but presburger won't abstract out the function applications
   apply presburger+
*)
   done
(*>*)

axiomatization where
  (*No private key equals any public key (essential to ensure that private
    keys are private!) *)
  privateKey_neq_publicKey [iff]:
      "invKey (publicKey b A) \<noteq> publicKey b' A'"

declare privateKey_neq_publicKey [THEN not_sym, iff]

subsection\<open>Initial Knowledge\<close>

text\<open>This information is not necessary.  Each protocol distributes any needed
certificates, and anyway our proofs require a formalization of the Spy's
knowledge only.  However, the initial knowledge is as follows:
   All agents know RCA's public keys;
   RCA and CAs know their own respective keys;
   RCA (has already certified and therefore) knows all CAs public keys;
   Spy knows all keys of all bad agents.\<close>

overloading initState \<equiv> "initState"
begin

primrec initState where
(*<*)
  initState_CA:
    "initState (CA i)  =
       (if i=0 then Key ` ({priEK RCA, priSK RCA} Un
                            pubEK ` (range CA) Un pubSK ` (range CA))
        else {Key (priEK (CA i)), Key (priSK (CA i)),
              Key (pubEK (CA i)), Key (pubSK (CA i)),
              Key (pubEK RCA), Key (pubSK RCA)})"

| initState_Cardholder:
    "initState (Cardholder i)  =
       {Key (priEK (Cardholder i)), Key (priSK (Cardholder i)),
        Key (pubEK (Cardholder i)), Key (pubSK (Cardholder i)),
        Key (pubEK RCA), Key (pubSK RCA)}"

| initState_Merchant:
    "initState (Merchant i)  =
       {Key (priEK (Merchant i)), Key (priSK (Merchant i)),
        Key (pubEK (Merchant i)), Key (pubSK (Merchant i)),
        Key (pubEK RCA), Key (pubSK RCA)}"

| initState_PG:
    "initState (PG i)  =
       {Key (priEK (PG i)), Key (priSK (PG i)),
        Key (pubEK (PG i)), Key (pubSK (PG i)),
        Key (pubEK RCA), Key (pubSK RCA)}"
(*>*)
| initState_Spy:
    "initState Spy = Key ` (invKey ` pubEK ` bad Un
                            invKey ` pubSK ` bad Un
                            range pubEK Un range pubSK)"

end

text\<open>Injective mapping from agents to PANs: an agent can have only one card\<close>

consts  pan :: "agent => nat"

specification (pan)
  inj_pan: "inj pan"
  \<comment>\<open>No two agents have the same PAN\<close>
(*<*)
   apply (rule exI [of _ "nat_of_agent"])
   apply (simp add: inj_on_def inj_nat_of_agent [THEN inj_eq])
   done
(*>*)

declare inj_pan [THEN inj_eq, iff]

consts
  XOR :: "nat*nat => nat"  \<comment>\<open>no properties are assumed of exclusive-or\<close>

subsection\<open>Signature Primitives\<close>

definition
 (* Signature = Message + signed Digest *)
  sign :: "[key, msg]=>msg"
  where "sign K X = \<lbrace>X, Crypt K (Hash X) \<rbrace>"

definition
 (* Signature Only = signed Digest Only *)
  signOnly :: "[key, msg]=>msg"
  where "signOnly K X = Crypt K (Hash X)"

definition
 (* Signature for Certificates = Message + signed Message *)
  signCert :: "[key, msg]=>msg"
  where "signCert K X = \<lbrace>X, Crypt K X \<rbrace>"

definition
 (* Certification Authority's Certificate.
    Contains agent name, a key, a number specifying the key's target use,
              a key to sign the entire certificate.

    Should prove if signK=priSK RCA and C=CA i,
                  then Ka=pubEK i or pubSK i depending on T  ??
 *)
  cert :: "[agent, key, msg, key] => msg"
  where "cert A Ka T signK = signCert signK \<lbrace>Agent A, Key Ka, T\<rbrace>"

definition
 (* Cardholder's Certificate.
    Contains a PAN, the certified key Ka, the PANSecret PS,
    a number specifying the target use for Ka, the signing key signK.
 *)
  certC :: "[nat, key, nat, msg, key] => msg"
  where "certC PAN Ka PS T signK =
    signCert signK \<lbrace>Hash \<lbrace>Nonce PS, Pan PAN\<rbrace>, Key Ka, T\<rbrace>"

(*cert and certA have no repeated elements, so they could be abbreviations,
  but that's tricky and makes proofs slower*)

abbreviation "onlyEnc == Number 0"
abbreviation "onlySig == Number (Suc 0)"
abbreviation "authCode == Number (Suc (Suc 0))"

subsection\<open>Encryption Primitives\<close>

definition EXcrypt :: "[key,key,msg,msg] => msg" where
  \<comment>\<open>Extra Encryption\<close>
    (*K: the symmetric key   EK: the public encryption key*)
    "EXcrypt K EK M m =
       \<lbrace>Crypt K \<lbrace>M, Hash m\<rbrace>, Crypt EK \<lbrace>Key K, m\<rbrace>\<rbrace>"

definition EXHcrypt :: "[key,key,msg,msg] => msg" where
  \<comment>\<open>Extra Encryption with Hashing\<close>
    (*K: the symmetric key   EK: the public encryption key*)
    "EXHcrypt K EK M m =
       \<lbrace>Crypt K \<lbrace>M, Hash m\<rbrace>, Crypt EK \<lbrace>Key K, m, Hash M\<rbrace>\<rbrace>"

definition Enc :: "[key,key,key,msg] => msg" where
  \<comment>\<open>Simple Encapsulation with SIGNATURE\<close>
    (*SK: the sender's signing key
      K: the symmetric key
      EK: the public encryption key*)
    "Enc SK K EK M =
       \<lbrace>Crypt K (sign SK M), Crypt EK (Key K)\<rbrace>"

definition EncB :: "[key,key,key,msg,msg] => msg" where
  \<comment>\<open>Encapsulation with Baggage.  Keys as above, and baggage b.\<close>
    "EncB SK K EK M b =
       \<lbrace>Enc SK K EK \<lbrace>M, Hash b\<rbrace>, b\<rbrace>"

subsection\<open>Basic Properties of pubEK, pubSK, priEK and priSK\<close>

lemma publicKey_eq_iff [iff]:
     "(publicKey b A = publicKey b' A') = (b=b' & A=A')"
by (blast dest: injective_publicKey)

lemma privateKey_eq_iff [iff]:
     "(invKey (publicKey b A) = invKey (publicKey b' A')) = (b=b' & A=A')"
by auto

lemma not_symKeys_publicKey [iff]: "publicKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma not_symKeys_privateKey [iff]: "invKey (publicKey b A) \<notin> symKeys"
by (simp add: symKeys_def)

lemma symKeys_invKey_eq [simp]: "K \<in> symKeys ==> invKey K = K"
by (simp add: symKeys_def)

lemma symKeys_invKey_iff [simp]: "(invKey K \<in> symKeys) = (K \<in> symKeys)"
by (unfold symKeys_def, auto)

text\<open>Can be slow (or even loop) as a simprule\<close>
lemma symKeys_neq_imp_neq: "(K \<in> symKeys) \<noteq> (K' \<in> symKeys) ==> K \<noteq> K'"
by blast

text\<open>These alternatives to \<open>symKeys_neq_imp_neq\<close> don't seem any better
in practice.\<close>
lemma publicKey_neq_symKey: "K \<in> symKeys ==> publicKey b A \<noteq> K"
by blast

lemma symKey_neq_publicKey: "K \<in> symKeys ==> K \<noteq> publicKey b A"
by blast

lemma privateKey_neq_symKey: "K \<in> symKeys ==> invKey (publicKey b A) \<noteq> K"
by blast

lemma symKey_neq_privateKey: "K \<in> symKeys ==> K \<noteq> invKey (publicKey b A)"
by blast

lemma analz_symKeys_Decrypt:
     "[| Crypt K X \<in> analz H;  K \<in> symKeys;  Key K \<in> analz H |]
      ==> X \<in> analz H"
by auto

subsection\<open>"Image" Equations That Hold for Injective Functions\<close>

lemma invKey_image_eq [iff]: "(invKey x \<in> invKey`A) = (x\<in>A)"
by auto

text\<open>holds because invKey is injective\<close>
lemma publicKey_image_eq [iff]:
     "(publicKey b A \<in> publicKey c ` AS) = (b=c & A\<in>AS)"
by auto

lemma privateKey_image_eq [iff]:
     "(invKey (publicKey b A) \<in> invKey ` publicKey c ` AS) = (b=c & A\<in>AS)"
by auto

lemma privateKey_notin_image_publicKey [iff]:
     "invKey (publicKey b A) \<notin> publicKey c ` AS"
by auto

lemma publicKey_notin_image_privateKey [iff]:
     "publicKey b A \<notin> invKey ` publicKey c ` AS"
by auto

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

text\<open>for proving \<open>new_keys_not_used\<close>\<close>
lemma keysFor_parts_insert:
     "[| K \<in> keysFor (parts (insert X H));  X \<in> synth (analz H) |]
      ==> K \<in> keysFor (parts H) | Key (invKey K) \<in> parts H"
by (force dest!:
         parts_insert_subset_Un [THEN keysFor_mono, THEN [2] rev_subsetD]
         analz_subset_parts [THEN keysFor_mono, THEN [2] rev_subsetD]
            intro: analz_into_parts)

lemma Crypt_imp_keysFor [intro]:
     "[|K \<in> symKeys; Crypt K X \<in> H|] ==> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

text\<open>Agents see their own private keys!\<close>
lemma privateKey_in_initStateCA [iff]:
     "Key (invKey (publicKey b A)) \<in> initState A"
by (case_tac "A", auto)

text\<open>Agents see their own public keys!\<close>
lemma publicKey_in_initStateCA [iff]: "Key (publicKey b A) \<in> initState A"
by (case_tac "A", auto)

text\<open>RCA sees CAs' public keys!\<close>
lemma pubK_CA_in_initState_RCA [iff]:
     "Key (publicKey b (CA i)) \<in> initState RCA"
by auto

text\<open>Spy knows all public keys\<close>
lemma knows_Spy_pubEK_i [iff]: "Key (publicKey b A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all add: imageI knows_Cons split: event.split)
done

declare knows_Spy_pubEK_i [THEN analz.Inj, iff]
                            (*needed????*)

text\<open>Spy sees private keys of bad agents! [and obviously public keys too]\<close>
lemma knows_Spy_bad_privateKey [intro!]:
     "A \<in> bad ==> Key (invKey (publicKey b A)) \<in> knows Spy evs"
by (rule initState_subset_knows [THEN subsetD], simp)

subsection\<open>Fresh Nonces for Possibility Theorems\<close>

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState B)"
by (induct_tac "B", auto)

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
by (simp add: used_Nil)

text\<open>In any trace, there is an upper bound N on the greatest nonce in use.\<close>
lemma Nonce_supply_lemma: "\<exists>N. \<forall>n. N<=n --> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all add: used_Cons split: event.split, safe)
apply (rule msg_Nonce_supply [THEN exE], blast elim!: add_leE)+
done

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
by (rule Nonce_supply_lemma [THEN exE], blast)

lemma Nonce_supply: "Nonce (@ N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, fast)
done

subsection\<open>Specialized Methods for Possibility Theorems\<close>

ML
\<open>
(*Tactic for possibility theorems*)
fun possibility_tac ctxt =
    REPEAT (*omit used_Says so that Nonces start from different traces!*)
    (ALLGOALS (simp_tac (ctxt delsimps [@{thm used_Says}, @{thm used_Notes}]))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}]))

(*For harder protocols (such as SET_CR!), 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]))
\<close>

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

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

subsection\<open>Specialized Rewriting for Theorems About @{term analz} and Image\<close>

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} Un H"
by blast

lemma insert_Key_image:
     "insert (Key K) (Key`KK Un C) = Key ` (insert K KK) Un C"
by blast

text\<open>Needed for \<open>DK_fresh_not_KeyCryptKey\<close>\<close>
lemma publicKey_in_used [iff]: "Key (publicKey b A) \<in> used evs"
by auto

lemma privateKey_in_used [iff]: "Key (invKey (publicKey b A)) \<in> used evs"
by (blast intro!: initState_into_used)

text\<open>Reverse the normal simplification of "image" to build up (not break down)
  the set of keys.  Based on \<open>analz_image_freshK_ss\<close>, but simpler.\<close>
lemmas analz_image_keys_simps =
       simp_thms mem_simps \<comment>\<open>these two allow its use with \<open>only:\<close>\<close>
       image_insert [THEN sym] image_Un [THEN sym]
       rangeI symKeys_neq_imp_neq
       insert_Key_singleton insert_Key_image Un_assoc [THEN sym]

(*General lemmas proved by Larry*)

subsection\<open>Controlled Unfolding of Abbreviations\<close>

text\<open>A set is expanded only if a relation is applied to it\<close>
lemma def_abbrev_simp_relation:
     "A = B ==> (A \<in> X) = (B \<in> X) &
                 (u = A) = (u = B) &
                 (A = u) = (B = u)"
by auto

text\<open>A set is expanded only if one of the given functions is applied to it\<close>
lemma def_abbrev_simp_function:
     "A = B
      ==> parts (insert A X) = parts (insert B X) &
          analz (insert A X) = analz (insert B X) &
          keysFor (insert A X) = keysFor (insert B X)"
by auto

subsubsection\<open>Special Simplification Rules for @{term signCert}\<close>

text\<open>Avoids duplicating X and its components!\<close>
lemma parts_insert_signCert:
     "parts (insert (signCert K X) H) =
      insert \<lbrace>X, Crypt K X\<rbrace> (parts (insert (Crypt K X) H))"
by (simp add: signCert_def insert_commute [of X])

text\<open>Avoids a case split! [X is always available]\<close>
lemma analz_insert_signCert:
     "analz (insert (signCert K X) H) =
      insert \<lbrace>X, Crypt K X\<rbrace> (insert (Crypt K X) (analz (insert X H)))"
by (simp add: signCert_def insert_commute [of X])

lemma keysFor_insert_signCert: "keysFor (insert (signCert K X) H) = keysFor H"
by (simp add: signCert_def)

text\<open>Controlled rewrite rules for @{term signCert}, just the definitions
  of the others. Encryption primitives are just expanded, despite their huge
  redundancy!\<close>
lemmas abbrev_simps [simp] =
    parts_insert_signCert analz_insert_signCert keysFor_insert_signCert
    sign_def     [THEN def_abbrev_simp_relation]
    sign_def     [THEN def_abbrev_simp_function]
    signCert_def [THEN def_abbrev_simp_relation]
    signCert_def [THEN def_abbrev_simp_function]
    certC_def    [THEN def_abbrev_simp_relation]
    certC_def    [THEN def_abbrev_simp_function]
    cert_def     [THEN def_abbrev_simp_relation]
    cert_def     [THEN def_abbrev_simp_function]
    EXcrypt_def  [THEN def_abbrev_simp_relation]
    EXcrypt_def  [THEN def_abbrev_simp_function]
    EXHcrypt_def [THEN def_abbrev_simp_relation]
    EXHcrypt_def [THEN def_abbrev_simp_function]
    Enc_def      [THEN def_abbrev_simp_relation]
    Enc_def      [THEN def_abbrev_simp_function]
    EncB_def     [THEN def_abbrev_simp_relation]
    EncB_def     [THEN def_abbrev_simp_function]

subsubsection\<open>Elimination Rules for Controlled Rewriting\<close>

lemma Enc_partsE:
     "!!R. [|Enc SK K EK M \<in> parts H;
             [|Crypt K (sign SK M) \<in> parts H;
               Crypt EK (Key K) \<in> parts H|] ==> R|]
           ==> R"

by (unfold Enc_def, blast)

lemma EncB_partsE:
     "!!R. [|EncB SK K EK M b \<in> parts H;
             [|Crypt K (sign SK \<lbrace>M, Hash b\<rbrace>) \<in> parts H;
               Crypt EK (Key K) \<in> parts H;
               b \<in> parts H|] ==> R|]
           ==> R"
by (unfold EncB_def Enc_def, blast)

lemma EXcrypt_partsE:
     "!!R. [|EXcrypt K EK M m \<in> parts H;
             [|Crypt K \<lbrace>M, Hash m\<rbrace> \<in> parts H;
               Crypt EK \<lbrace>Key K, m\<rbrace> \<in> parts H|] ==> R|]
           ==> R"
by (unfold EXcrypt_def, blast)

subsection\<open>Lemmas to Simplify Expressions Involving @{term analz}\<close>

lemma analz_knows_absorb:
     "Key K \<in> analz (knows Spy evs)
      ==> analz (Key ` (insert K H) \<union> knows Spy evs) =
          analz (Key ` H \<union> knows Spy evs)"
by (simp add: analz_insert_eq Un_upper2 [THEN analz_mono, THEN subsetD])

lemma analz_knows_absorb2:
     "Key K \<in> analz (knows Spy evs)
      ==> analz (Key ` (insert X (insert K H)) \<union> knows Spy evs) =
          analz (Key ` (insert X H) \<union> knows Spy evs)"
apply (subst insert_commute)
apply (erule analz_knows_absorb)
done

lemma analz_insert_subset_eq:
     "[|X \<in> analz (knows Spy evs);  knows Spy evs \<subseteq> H|]
      ==> analz (insert X H) = analz H"
apply (rule analz_insert_eq)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])
done

lemmas analz_insert_simps =
         analz_insert_subset_eq Un_upper2
         subset_insertI [THEN [2] subset_trans]

subsection\<open>Freshness Lemmas\<close>

lemma in_parts_Says_imp_used:
     "[|Key K \<in> parts {X}; Says A B X \<in> set evs|] ==> Key K \<in> used evs"
by (blast intro: parts_trans dest!: Says_imp_knows_Spy [THEN parts.Inj])

text\<open>A useful rewrite rule with @{term analz_image_keys_simps}\<close>
lemma Crypt_notin_image_Key: "Crypt K X \<notin> Key ` KK"
by auto

lemma fresh_notin_analz_knows_Spy:
     "Key K \<notin> used evs ==> Key K \<notin> analz (knows Spy evs)"
by (auto dest: analz_into_parts)

end


subsection \<open>Definition of \texorpdfstring{$\Psi$}{Psi}\label{sec:psi}\<close>

theory Psi
  imports SortKeys "HOL-Eisbach.Eisbach"
begin

fun extended_size :: "('\<I> sort_key) extended \<Rightarrow> nat"
  where
    "extended_size \<lbrakk>x\<rbrakk> = size x" |
    "extended_size _ = 0"

lemma extended_simps [simp]:
  "(\<turnstile> < x) = (x \<noteq> \<turnstile>)"
  "(\<lbrakk>x'\<rbrakk> < \<lbrakk>y'\<rbrakk>) = (x' < y')"
  "\<lbrakk>x'\<rbrakk> < \<stileturn>"
  "\<not>(\<lbrakk>x'\<rbrakk> < \<turnstile>)"
  "\<not>(\<stileturn> < x)"
  "\<turnstile> \<le> x"
  "(\<lbrakk>x'\<rbrakk> \<le> \<lbrakk>y'\<rbrakk>) = ((x' :: '\<I> :: linorder) \<le> y')"
  "x \<le> \<stileturn>"
  "\<not>(\<lbrakk>x'\<rbrakk> \<le> \<turnstile>)"
  "(\<stileturn> \<le> x) = (x = \<stileturn>)"
  by (case_tac [!] x, simp_all add:less_extended_def less_eq_extended_def le_less)

fun int_size where "int_size (l,u) = max (extended_size l) (extended_size u)"

lemma position_cases:
  assumes "\<And> y z. x = \<lbrakk>NonFinal (y,Left) z\<rbrakk> \<Longrightarrow> p"
  assumes "\<And> y z. x = \<lbrakk>NonFinal (y,Right) z\<rbrakk> \<Longrightarrow> p"
  assumes "\<And> y. x = \<lbrakk>Final y\<rbrakk> \<Longrightarrow> p"
  assumes "x = \<turnstile> \<Longrightarrow> p"
  assumes "x = \<stileturn> \<Longrightarrow> p"
  shows "p"
  by (metis assms embed_dir.cases extended_size.cases sort_key_embedding.cases)

fun derive_pos ::
  "('\<I> :: linorder) \<times> sort_dir \<Rightarrow> '\<I> sort_key extended \<Rightarrow> '\<I> sort_key extended"
  where
    "derive_pos h \<lbrakk>NonFinal x y\<rbrakk> =
      (if h < x then \<stileturn> else (if x < h then \<turnstile> else \<lbrakk>y\<rbrakk>))" |
    "derive_pos h \<lbrakk>Final x\<rbrakk> =
      (if fst h < x \<or> fst h = x \<and> snd h = Left then \<stileturn> else \<turnstile>)" |
    "derive_pos _ \<turnstile> = \<turnstile>" |
    "derive_pos _ \<stileturn> = \<stileturn>"

lemma derive_pos_mono: "x \<le> y \<Longrightarrow> derive_pos h x \<le> derive_pos h y"
  apply (cases h, cases "snd h")
  apply (rule_tac [!] position_cases [where x=x])
  apply (rule_tac [!] position_cases [where x=y])
  by (simp_all, auto)

fun \<gamma> :: "('\<I> :: linorder) position \<Rightarrow> sort_dir \<Rightarrow> '\<I> \<times> sort_dir"
  where
    "\<gamma> \<lbrakk>NonFinal x y\<rbrakk> _ = x" |
    "\<gamma> \<lbrakk>Final x\<rbrakk> d = (x,d)" |
    "\<gamma> \<turnstile> _ = undefined" |
    "\<gamma> \<stileturn> _ = undefined"

fun derive_left  where
  "derive_left (l, u) = (derive_pos (\<gamma> l Right) l, derive_pos (\<gamma> l Right) u)"

fun derive_right where
  "derive_right (l, u) = (derive_pos (\<gamma> u Left) l, derive_pos (\<gamma> u Left) u)"

fun is_interval where "is_interval (l,u) = (l < u)"

fun elem where "elem x (l,u) = (l < x \<and> x < u)"

fun subset where "subset (l,u) (l',u') = (l' \<le> l \<and> u \<le> u')"

method interval_split for x :: "('\<I> :: linorder) position \<times> '\<I> position" =
  (case_tac [!] x,
   rule_tac [!] position_cases [where x="fst x"],
   rule_tac [!] position_cases [where x="snd x"])

lemma derive_size:
  "\<lbrakk>Final i\<rbrakk> \<le> fst x \<and> is_interval x \<Longrightarrow> int_size (derive_left x) < int_size x"
  "snd x \<le> \<lbrakk>Final i\<rbrakk> \<and> is_interval x \<Longrightarrow> int_size (derive_right x) < int_size x"
  by (interval_split x, simp_all add:less_SucI)

lemma derive_interval:
  "\<lbrakk>Final i\<rbrakk> \<le> fst x \<Longrightarrow> is_interval x \<Longrightarrow> is_interval (derive_left x)"
  "snd x \<le> \<lbrakk>Final i\<rbrakk> \<Longrightarrow> is_interval x \<Longrightarrow> is_interval (derive_right x)"
  by (interval_split x, simp_all, auto)

function \<Psi> :: "('\<I> :: linorder) position \<times> '\<I> position \<Rightarrow> '\<I> \<Rightarrow> '\<I> sort_key"
  where
    "\<Psi> (l,u) i = Final i"
      if "l < \<lbrakk>Final i\<rbrakk> \<and> \<lbrakk>Final i\<rbrakk> < u" |
    "\<Psi> (l,u) i = NonFinal (\<gamma> l Right) (\<Psi> (derive_left (l,u)) i)"
      if "\<lbrakk>Final i\<rbrakk> \<le> l \<and> l < u" |
    "\<Psi> (l,u) i = NonFinal (\<gamma> u Left) (\<Psi> (derive_right (l,u)) i)"
      if "u \<le> \<lbrakk>Final i\<rbrakk> \<and> l < u" |
    "\<Psi> (l,u) i = undefined" if "u \<le> l"
  by (metis leI old.prod.exhaust, auto)

termination
  apply (relation "measure (\<lambda>(p,i). int_size p)", simp)
  using derive_size by fastforce+

proposition psi_elem: "is_interval x \<Longrightarrow> elem \<lbrakk>\<Psi> x i\<rbrakk> x"
proof (induct "int_size x" arbitrary:x rule: nat_less_induct)
  case 1
  consider (a) "\<lbrakk>Final i\<rbrakk> \<le> fst x" | (b) "elem \<lbrakk>Final i\<rbrakk> x" | (c) "snd x \<le> \<lbrakk>Final i\<rbrakk>"
    using not_le by (metis elem.simps prod.collapse)
  then show ?case
  proof (cases)
    case a
    hence "elem  \<lbrakk>\<Psi> (derive_left x) i\<rbrakk> (derive_left x)"
      by (metis 1 derive_size(1) derive_interval(1))
    then show ?thesis using a "1"(2)
      by (interval_split x, simp_all del:\<Psi>.simps, auto)
  next
    case b
    then show ?thesis by (cases x, simp)
  next
    case c
    hence "elem  \<lbrakk>\<Psi> (derive_right x) i\<rbrakk> (derive_right x)"
      by (metis 1 derive_size(2) derive_interval(2))
    then show ?thesis using c "1"(2)
      by (interval_split x, simp_all del:\<Psi>.simps, auto)
  qed
qed

proposition psi_mono:
  assumes "i1 < i2"
  shows "is_interval x \<Longrightarrow> \<Psi> x i1 < \<Psi> x i2"
proof (induct "int_size x" arbitrary:x rule: nat_less_induct)
  case 1
  have a:"\<lbrakk>Final i1\<rbrakk> < \<lbrakk>Final i2\<rbrakk>"
    using assms by auto
  then consider
    (a) "\<lbrakk>Final i1\<rbrakk> \<le> fst x \<and> \<lbrakk>Final i2\<rbrakk> \<le> fst x" |
    (b) "\<lbrakk>Final i1\<rbrakk> \<le> fst x \<and> elem \<lbrakk>Final i2\<rbrakk> x" |
    (c) "\<lbrakk>Final i1\<rbrakk> \<le> fst x \<and> snd x \<le> \<lbrakk>Final i2\<rbrakk>" |
    (d) "elem \<lbrakk>Final i1\<rbrakk> x  \<and> elem \<lbrakk>Final i2\<rbrakk> x" |
    (e) "elem \<lbrakk>Final i1\<rbrakk> x \<and> snd x \<le> \<lbrakk>Final i2\<rbrakk>" |
    (f) "snd x \<le> \<lbrakk>Final i2\<rbrakk> \<and> snd x \<le> \<lbrakk>Final i1\<rbrakk>"
    using assms "1"(2) apply (cases x)
    by (metis (mono_tags, opaque_lifting) dual_order.strict_trans elem.simps
        fst_conv leI snd_conv)
  then show ?case
  proof (cases)
    case a
    hence "\<Psi> (derive_left x) i1  < \<Psi> (derive_left x) i2"
      by (metis 1 derive_size(1) derive_interval(1))
    thus ?thesis using a "1"(2) by (cases x, simp)
  next
    case b
    thus ?thesis using "1"(2) apply (cases x, simp)
      by (rule_tac [!] position_cases [where x="fst x"], simp_all)
  next
    case c
    show ?thesis
    proof (cases "\<gamma> (fst x) Right = \<gamma> (snd x) Left")
      case True
      have e:"is_interval (derive_left x)" using c "1"(2) derive_interval(1) by blast
      have f:"derive_left x = derive_right x" using True by (cases x, simp)
      have h:"\<Psi> (derive_left x) i1 < \<Psi> (derive_right x) i2"
        apply (cases x, simp only: f)
        by (metis "1.hyps" "1.prems" c derive_size(2) e f)
      show ?thesis using c "1"(2) h True by (cases x, simp)
    next
      case False
      hence "\<gamma> (fst x) Right < \<gamma> (snd x) Left" using "1"(2) c
      by (interval_split x, simp_all, auto)
      then show ?thesis using c "1"(2) by (cases x, simp)
    qed
  next
    case d
    thus ?thesis using "1"(2) a by (cases x, simp)
  next
    case e
    thus ?thesis using "1"(2) apply (cases x, simp)
      by (rule_tac [!] position_cases [where x="snd x"], simp_all del:\<Psi>.simps)
  next
    case f
    hence b:"\<Psi> (derive_right x) i1  < \<Psi> (derive_right x) i2"
      by (metis 1 derive_size(2) derive_interval(2))
    thus ?thesis using f "1"(2) by (cases x, simp)
  qed
qed

proposition psi_narrow:
  "elem \<lbrakk>\<Psi> x' i\<rbrakk> x \<Longrightarrow> subset x x' \<Longrightarrow> \<Psi> x' i = \<Psi> x i"
proof (induct "int_size x'" arbitrary: x x' rule: nat_less_induct)
  case 1
  have a: "is_interval x" using "1"(2)
    by (metis dual_order.strict_trans elem.elims(2) is_interval.simps)
  have d: "is_interval x'" using a "1"(3) apply (cases x', cases x, simp) by auto
  consider
    (before) "\<lbrakk>Final i\<rbrakk> \<le> fst x'" |
    (between) "elem \<lbrakk>Final i\<rbrakk> x'" |
    (after) "snd x' \<le> \<lbrakk>Final i\<rbrakk>" using 1 apply simp
    by (metis elem.simps leI prod.collapse)
  then show ?case
  proof (cases)
    case before
    have b: "\<lbrakk>Final i\<rbrakk> \<le> fst x" using before 1 apply (cases x)
      by (metis dual_order.trans fst_conv subset.elims(2))
    obtain z where z_def: "\<Psi> x' i = NonFinal (\<gamma> (fst x') Right) z"
      using before d apply (cases x') by simp
    have c:"\<gamma> (fst x') Right = \<gamma> (fst x) Right"
      using "1"(3) z_def "1"(2) apply (cases x, cases x', simp)
      apply (rule_tac [!] position_cases [where x="fst x"])
      apply (rule_tac [!] position_cases [where x="fst x'"])
      using before by (simp_all del:\<Psi>.simps, auto)
    have c1:"subset (derive_left x) (derive_left x')"
      using c "1"(3) by (cases x, cases x', simp add:derive_pos_mono)
    have g:"z = \<Psi> (derive_left x') i" using z_def before d by (cases x', simp)
    have "elem \<lbrakk>NonFinal (\<gamma> (fst x) Right) z\<rbrakk> x"
      using "1"(2) z_def by (simp add: c)
    hence "elem \<lbrakk>z\<rbrakk> (derive_left x)" using before b
      by (interval_split x, simp_all del:\<Psi>.simps, auto)
    hence "\<Psi> (derive_left x') i = \<Psi> (derive_left x) i"
      using "1"(1) before d c1 apply (simp only:g)
      by (metis (no_types) derive_size(1))
    thus ?thesis using before b a d c by (cases x, cases x', simp)
  next
    case between
    thus ?thesis using 1 by (cases x, cases x', auto)
  next
    case after
    have b: "snd x \<le> \<lbrakk>Final i\<rbrakk>" using after 1 apply (cases x)
      by (metis (mono_tags, opaque_lifting) dual_order.trans prod.exhaust_sel
          subset.simps)
    obtain z where z_def:"\<Psi> x' i = NonFinal (\<gamma> (snd x') Left) z"
      using after d by (cases x', simp)
    have c:"\<gamma> (snd x') Left = \<gamma> (snd x) Left"
      using "1"(3) z_def "1"(2) apply (simp, cases x, cases x')
      apply (rule_tac [!] position_cases [where x="snd x"])
      apply (rule_tac [!] position_cases [where x="snd x'"]) using after
      by (simp_all del:\<Psi>.simps, auto)
    have c1:"subset (derive_right x) (derive_right x')"
      using c "1"(3) by (cases x, cases x', simp add:derive_pos_mono)
    have g:"z = \<Psi> (derive_right x') i" using z_def after d by (cases x', simp)
    have "elem \<lbrakk>NonFinal (\<gamma> (snd x) Left) z\<rbrakk> x"
      using "1"(2) z_def by (simp add: c)
    hence "elem \<lbrakk>z\<rbrakk> (derive_right x)" using after b
      by (interval_split x, simp_all del:\<Psi>.simps, auto)
    hence "\<Psi> (derive_right x') i = \<Psi> (derive_right x) i"
      using "1"(1) after d c1 apply (simp only:g)
      by (metis (no_types) derive_size(2))
    thus ?thesis using after b a d c by (cases x, cases x', simp)
  qed
qed

definition preserve_order :: "'a :: linorder \<Rightarrow> 'a \<Rightarrow> 'b :: linorder \<Rightarrow> 'b \<Rightarrow> bool"
  where "preserve_order x y u v \<equiv> (x < y \<longrightarrow> u < v) \<and> (x > y \<longrightarrow> u > v)"

proposition psi_preserve_order:
  fixes l l' u u' i i'
  assumes "elem \<lbrakk>\<Psi> (l, u) i\<rbrakk> (l',u')"
  assumes "elem \<lbrakk>\<Psi> (l', u') i'\<rbrakk> (l, u)"
  shows "preserve_order i i' \<lbrakk>\<Psi> (l,u) i\<rbrakk> \<lbrakk>\<Psi> (l', u') i'\<rbrakk>"
proof -
  have "l < u" using assms(2) by auto
  hence a:"elem \<lbrakk>\<Psi> (l, u) i\<rbrakk> (max l l', min u u')"
    using assms(1) psi_elem by fastforce
  hence b:"\<Psi> (l,u) i = \<Psi> (max l l', min u u') i"
    by (simp add: psi_narrow)
  have "l' < u'" using assms(1) by auto
  hence "elem \<lbrakk>\<Psi> (l',u') i'\<rbrakk> (max l l', min u u')"
    using assms(2) psi_elem by fastforce
  hence c:"\<Psi> (l',u') i' = \<Psi> (max l l', min u u') i'"
    by (simp add: psi_narrow)
  hence "max l l' < min u u'" using a min_def by auto
  then show ?thesis apply (simp only: preserve_order_def b c)
    using psi_mono extended_simps(2) is_interval.simps by blast
qed

end


theory Timed_Automata
  imports Main
begin

chapter \<open>Basic Definitions and Semantics\<close>

section \<open>Time\<close>

class time = linordered_ab_group_add +
  assumes dense: "x < y \<Longrightarrow> \<exists>z. x < z \<and> z < y"
  assumes non_trivial: "\<exists> x. x \<noteq> 0"

begin

lemma non_trivial_neg: "\<exists> x. x < 0"
proof -
  from non_trivial obtain x where "x \<noteq> 0" by auto
  then show ?thesis
  proof (cases "x < 0", auto, goal_cases)
    case 1
    then have "x > 0" by auto
    then have "(-x) < 0" by auto
    then show ?case by blast
  qed
qed

end

datatype ('c, 't :: time) cconstraint =
  AND "('c, 't) cconstraint" "('c, 't) cconstraint" |
  LT 'c 't |
  LE 'c 't |
  EQ 'c 't |
  GT 'c 't |
  GE 'c 't

section \<open>Syntactic Definition\<close>

text \<open>
  For an informal description of timed automata we refer to Bengtsson and Yi \<^cite>\<open>"BengtssonY03"\<close>.
  We define a timed automaton \<open>A\<close>
\<close>

type_synonym
  ('c, 'time, 's) invassn = "'s \<Rightarrow> ('c, 'time) cconstraint"

type_synonym
  ('a, 'c, 'time, 's) transition = "'s * ('c, 'time) cconstraint * 'a * 'c list * 's"

type_synonym
  ('a, 'c, 'time, 's) ta = "('a, 'c, 'time, 's) transition set * ('c, 'time, 's) invassn"

definition trans_of :: "('a, 'c, 'time, 's) ta \<Rightarrow> ('a, 'c, 'time, 's) transition set" where
  "trans_of \<equiv> fst"
definition inv_of  :: "('a, 'c, 'time, 's) ta \<Rightarrow> ('c, 'time, 's) invassn" where
  "inv_of \<equiv> snd"

abbreviation transition ::
  "('a, 'c, 'time, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, 'time) cconstraint \<Rightarrow> 'a \<Rightarrow> 'c list \<Rightarrow> 's \<Rightarrow> bool"
("_ \<turnstile> _ \<longrightarrow>\<^bsup>_,_,_\<^esup> _" [61,61,61,61,61,61] 61) where
  "(A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l') \<equiv> (l,g,a,r,l') \<in> trans_of A"

subsection \<open>Collecting Information About Clocks\<close>

fun collect_clks :: "('c, 't :: time) cconstraint \<Rightarrow> 'c set"
where
  "collect_clks (AND cc1 cc2) = collect_clks cc1 \<union> collect_clks cc2" |
  "collect_clks (LT c _) = {c}" |
  "collect_clks (LE c _) = {c}" |
  "collect_clks (EQ c _) = {c}" |
  "collect_clks (GE c _) = {c}" |
  "collect_clks (GT c _) = {c}"

fun collect_clock_pairs :: "('c, 't :: time) cconstraint \<Rightarrow> ('c * 't) set"
where
  "collect_clock_pairs (LT x m) = {(x, m)}" |
  "collect_clock_pairs (LE x m) = {(x, m)}" |
  "collect_clock_pairs (EQ x m) = {(x, m)}" |
  "collect_clock_pairs (GE x m) = {(x, m)}" |
  "collect_clock_pairs (GT x m) = {(x, m)}" |
  "collect_clock_pairs (AND cc1 cc2) = (collect_clock_pairs cc1 \<union> collect_clock_pairs cc2)"

definition collect_clkt :: "('a, 'c, 't::time, 's) transition set \<Rightarrow> ('c *'t) set"
where
  "collect_clkt S = \<Union> {collect_clock_pairs (fst (snd t)) | t . t \<in> S}"

definition collect_clki :: "('c, 't :: time, 's) invassn \<Rightarrow> ('c *'t) set"
where
  "collect_clki I = \<Union> {collect_clock_pairs (I x) | x. True}"

definition clkp_set :: "('a, 'c, 't :: time, 's) ta \<Rightarrow> ('c *'t) set"
where
  "clkp_set A = collect_clki (inv_of A) \<union> collect_clkt (trans_of A)"

definition collect_clkvt :: "('a, 'c, 't::time, 's) transition set \<Rightarrow> 'c set"
where
  "collect_clkvt S = \<Union> {set ((fst o snd o snd o snd) t) | t . t \<in> S}"

abbreviation clk_set where "clk_set A \<equiv> fst ` clkp_set A \<union> collect_clkvt (trans_of A)"

(* We don not need this here but most other theories will make use of this predicate *)
inductive valid_abstraction
where
  "\<lbrakk>\<forall>(x,m) \<in> clkp_set A. m \<le> k x \<and> x \<in> X \<and> m \<in> \<nat>; collect_clkvt (trans_of A) \<subseteq> X; finite X\<rbrakk>
  \<Longrightarrow> valid_abstraction A X k"

section \<open>Operational Semantics\<close>

type_synonym ('c, 't) cval = "'c \<Rightarrow> 't"

definition cval_add :: "('c,'t) cval \<Rightarrow> 't::time \<Rightarrow> ('c,'t) cval" (infixr "\<oplus>" 64)
where
  "u \<oplus> d = (\<lambda> x. u x + d)"

inductive clock_val :: "('c, 't) cval \<Rightarrow> ('c, 't::time) cconstraint \<Rightarrow> bool" ("_ \<turnstile> _" [62, 62] 62)
where
  "\<lbrakk>u \<turnstile> cc1; u \<turnstile> cc2\<rbrakk> \<Longrightarrow> u \<turnstile> AND cc1 cc2" |
  "\<lbrakk>u c < d\<rbrakk> \<Longrightarrow> u \<turnstile> LT c d" |
  "\<lbrakk>u c \<le> d\<rbrakk> \<Longrightarrow> u \<turnstile> LE c d" |
  "\<lbrakk>u c = d\<rbrakk> \<Longrightarrow> u \<turnstile> EQ c d" |
  "\<lbrakk>u c \<ge> d\<rbrakk> \<Longrightarrow> u \<turnstile> GE c d" |
  "\<lbrakk>u c > d\<rbrakk> \<Longrightarrow> u \<turnstile> GT c d"

declare clock_val.intros[intro]

inductive_cases[elim!]: "u \<turnstile> AND cc1 cc2"
inductive_cases[elim!]: "u \<turnstile> LT c d"
inductive_cases[elim!]: "u \<turnstile> LE c d"
inductive_cases[elim!]: "u \<turnstile> EQ c d"
inductive_cases[elim!]: "u \<turnstile> GE c d"
inductive_cases[elim!]: "u \<turnstile> GT c d"

fun clock_set :: "'c list \<Rightarrow> 't::time \<Rightarrow> ('c,'t) cval \<Rightarrow> ('c,'t) cval"
where
  "clock_set [] _ u = u" |
  "clock_set (c#cs) t u = (clock_set cs t u)(c:=t)"

abbreviation clock_set_abbrv :: "'c list \<Rightarrow> 't::time \<Rightarrow> ('c,'t) cval \<Rightarrow> ('c,'t) cval"
("[_\<rightarrow>_]_" [65,65,65] 65)
where
  "[r \<rightarrow> t]u \<equiv> clock_set r t u"

inductive step_t ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, 't) cval \<Rightarrow> ('t::time) \<Rightarrow> 's \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<rightarrow>\<^bsup>_\<^esup> \<langle>_, _\<rangle>" [61,61,61] 61)
where
  "\<lbrakk>u \<turnstile> inv_of A l; u \<oplus> d \<turnstile> inv_of A l; d \<ge> 0\<rbrakk> \<Longrightarrow> A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l, u \<oplus> d\<rangle>"

declare step_t.intros[intro!]

inductive_cases[elim!]: "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l',u'\<rangle>"

lemma step_t_determinacy1:
  "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l',u'\<rangle> \<Longrightarrow>  A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l'',u''\<rangle> \<Longrightarrow> l' = l''"
by auto

lemma step_t_determinacy2:
  "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l',u'\<rangle> \<Longrightarrow>  A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l'',u''\<rangle> \<Longrightarrow> u' = u''"
by auto

lemma step_t_cont1:
  "d \<ge> 0 \<Longrightarrow> e \<ge> 0 \<Longrightarrow> A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l',u'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l', u'\<rangle> \<rightarrow>\<^bsup>e\<^esup> \<langle>l'',u''\<rangle>
  \<Longrightarrow> A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d+e\<^esup> \<langle>l'',u''\<rangle>"
proof -
  assume A: "d \<ge> 0" "e \<ge> 0" "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l',u'\<rangle>" "A \<turnstile> \<langle>l', u'\<rangle> \<rightarrow>\<^bsup>e\<^esup> \<langle>l'',u''\<rangle>"
  hence "u' = (u \<oplus> d)" "u'' = (u' \<oplus> e)" by auto
  hence "u'' = (u \<oplus> (d + e))" unfolding cval_add_def by auto
  with A show ?thesis by auto
qed

inductive step_a ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, ('t::time)) cval \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<rightarrow>\<^bsub>_\<^esub> \<langle>_, _\<rangle>" [61,61,61] 61)
where
  "\<lbrakk>A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'; u \<turnstile> g; u' \<turnstile> inv_of A l'; u' = [r \<rightarrow> 0]u\<rbrakk> \<Longrightarrow> (A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l', u'\<rangle>)"

inductive step ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, ('t::time)) cval \<Rightarrow> 's \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<rightarrow> \<langle>_,_\<rangle>" [61,61,61] 61)
where
  step_a: "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l',u'\<rangle> \<Longrightarrow> (A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>)" |
  step_t: "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l',u'\<rangle> \<Longrightarrow> (A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>)"

inductive_cases[elim!]: "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>"

declare step.intros[intro]

inductive
  steps :: "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, ('t::time)) cval \<Rightarrow> 's \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<rightarrow>* \<langle>_, _\<rangle>" [61,61,61] 61)
where
  refl: "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>* \<langle>l, u\<rangle>" |
  step: "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l', u'\<rangle> \<rightarrow>* \<langle>l'', u''\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>* \<langle>l'', u''\<rangle>"

declare steps.intros[intro]

section \<open>Zone Semantics\<close>

type_synonym ('c, 't) zone = "('c, 't) cval set"

definition zone_delay :: "('c, ('t::time)) zone \<Rightarrow> ('c, 't) zone"
("_\<^sup>\<up>" [71] 71)
where
  "Z\<^sup>\<up> = {u \<oplus> d|u d. u \<in> Z \<and> d \<ge> (0::'t)}"

definition zone_set :: "('c, 't::time) zone \<Rightarrow> 'c list \<Rightarrow> ('c, 't) zone"
("_\<^bsub>_ \<rightarrow> 0\<^esub>" [71] 71)
where
  "zone_set Z r = {[r \<rightarrow> (0::'t)]u | u . u \<in> Z}"

inductive step_z ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, ('t::time)) zone \<Rightarrow> 's \<Rightarrow> ('c, 't) zone \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<leadsto> \<langle>_, _\<rangle>" [61,61,61] 61)
where
  step_t_z: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l, (Z \<inter> {u. u \<turnstile> inv_of A l})\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}\<rangle>" |
  step_a_z: "\<lbrakk>A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'\<rbrakk>
              \<Longrightarrow> (A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l', zone_set (Z \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'}\<rangle> )"

inductive_cases[elim!]: "A \<turnstile> \<langle>l, u\<rangle> \<leadsto> \<langle>l', u'\<rangle>"

declare step_z.intros[intro]

lemma step_z_sound:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l',Z'\<rangle> \<Longrightarrow> (\<forall> u' \<in> Z'. \<exists> u \<in> Z.  A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>)"
proof (induction rule: step_z.induct, goal_cases)
  case 1 thus ?case unfolding zone_delay_def by blast
next
  case (2 A l g a r l' Z)
  show ?case
  proof
    fix u' assume "u' \<in> zone_set (Z \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'}"
    then obtain u where
      "u \<turnstile> g" "u' \<turnstile> inv_of A l'" "u' = [r\<rightarrow>0]u" "u \<in> Z"
    unfolding zone_set_def by auto
    with step_a.intros[OF 2 this(1-3)] show "\<exists>u\<in>Z. A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>" by fast
  qed
qed

text \<open>
  Corresponds to version in old papers --
  not strong enough for inductive proof over transitive closure relation.
\<close>
lemma step_z_complete1:
  "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle> \<Longrightarrow> \<exists> Z. A \<turnstile> \<langle>l, {u}\<rangle> \<leadsto> \<langle>l', Z\<rangle> \<and> u' \<in> Z"
proof (induction rule: step.induct, goal_cases)
  case (1 A l u a l' u')
  then obtain g r
  where u': "u' = [r\<rightarrow>0]u" "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'" "u \<turnstile> g" "[r\<rightarrow>0]u \<turnstile> inv_of A l'"
  by (cases rule: step_a.cases) auto
  hence "{[r\<rightarrow>0]u} = zone_set ({u} \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'}"
  unfolding zone_set_def by blast
  with u'(1,2) show ?case by auto
next
  case (2 A l u d l' u')
  hence u': "u' = (u \<oplus> d)" "u \<turnstile> inv_of A l" "u \<oplus> d \<turnstile> inv_of A l" "0 \<le> d" and "l = l'" by auto
  hence "{u} = {u} \<inter> {u''. u'' \<turnstile> inv_of A l}" by fastforce
  with u'(1) have "{u'} = {u'' \<oplus> d |u''. u'' \<in> {u} \<inter> {u''. u'' \<turnstile> inv_of A l}}" by fastforce
  with u' have
    "u' \<in> {u'' \<oplus> d |u'' d. u'' \<in> {u} \<inter> {u. u \<turnstile> inv_of A l} \<and> 0 \<le> d} \<inter> {u. u \<turnstile> inv_of A l}"
  by fastforce
  thus ?case using \<open>l = l'\<close> step_t_z[unfolded zone_delay_def, of A l "{u}"] by blast
qed

text \<open>
  Easier proof.
\<close>
lemma step_z_complete2:
  "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle> \<Longrightarrow> \<exists> Z. A \<turnstile> \<langle>l, {u}\<rangle> \<leadsto> \<langle>l', Z\<rangle> \<and> u' \<in> Z"
using step_z_complete by fast

inductive
  steps_z :: "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, ('t::time)) zone \<Rightarrow> 's \<Rightarrow> ('c, 't) zone \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<leadsto>* \<langle>_, _\<rangle>" [61,61,61] 61)
where
  refl: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l, Z\<rangle>" |
  step: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l', Z'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto>* \<langle>l'', Z''\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l'', Z''\<rangle>"

declare steps_z.intros[intro]

lemma steps_z_complete:
  "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>* \<langle>l', u'\<rangle> \<Longrightarrow> u \<in> Z \<Longrightarrow> \<exists> Z'. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l', Z'\<rangle> \<and> u' \<in> Z'"
proof (induction arbitrary: Z rule: steps.induct)
  case refl thus ?case by auto
next
  case (step A l u l' u' l'' u'' Z)
  from step_z_complete[OF this(1,4)] obtain Z' where Z': "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l',Z'\<rangle>" "u' \<in> Z'" by auto
  then obtain Z'' where "A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto>* \<langle>l'',Z''\<rangle>" "u'' \<in> Z''" using step by metis
  with Z' show ?case by blast
qed

end


theory deMorgan3
  imports Main

begin

text\<open> Apply style \<close>
theorem de_morgan_2 : "((\<not> p \<or> \<not> q)  \<longrightarrow> (\<not> (p \<and> q)))"
  apply (rule impI)
  apply (rule notI)
  apply (erule disjE)
  apply (erule conjE)
  apply (erule notE)
  apply assumption
  apply (erule conjE)
  apply (erule notE)
  apply assumption
  done
end


theory prop_45
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype ('a, 'b) Pair2 = Pair "'a" "'b"
  fun zip2 :: "'a list => 'b list => (('a, 'b) Pair2) list" where
  "zip2 (Nil2) y = Nil2"
  | "zip2 (Cons2 z x2) (Nil2) = Nil2"
  | "zip2 (Cons2 z x2) (Cons2 x3 x4) = Cons2 (Pair z x3) (zip2 x2 x4)"

  hipster zip2
lemma lemma_a [thy_expl]: "zip2 Nil2 x1 = zip2 x1 Nil2"
by (hipster_induct_schemes zip2.simps)

lemma lemma_aa [thy_expl]: "zip2 Nil2 x1 = zip2 y1 Nil2"
by (hipster_induct_schemes zip2.simps)

  theorem x0 :
    "(zip2 (Cons2 x xs) (Cons2 y ys)) = (Cons2 (Pair x y) (zip2 xs ys))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(*<*)(*:maxLineLen=68:*)
theory SPF

imports bundle.SB

begin
(*>*)
section \<open>Stream Processing Functions \label{sec:spf}\<close>

text\<open>A deterministic component can be  modeled by a \Gls{spf}.
Since we there is no restriction for be \gls{spf}, beside being
continuous, we do not introduce an extra type for \Gls{spf}, because
it is only a type synonym.\<close>

type_synonym ('I,'O) SPF = "('I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>)"

text\<open>However, we will introduce a function to convert the domain of
a component. Similar to @{const sbConvert}\ref{subsub.sbconvert}
this makes it possible to evaluate the equality of two components
with the same domains but different types. It also allows us to
restrict input or output domains, hence it can be used for hiding
channels.\<close>

definition spfConvert::"('I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>) \<rightarrow> ('Ie\<^sup>\<Omega> \<rightarrow> 'Oe\<^sup>\<Omega>)" where
"spfConvert \<equiv> \<Lambda> f sb. (f\<cdot>(sb\<star>)\<star>)"

lemma spfconvert_eq [simp]: "spfConvert\<cdot>f = f"
  apply(rule cfun_eqI)
  by(simp add: spfConvert_def)

subsection \<open>Causal SPFs \label{sub:cspf}\<close>

text\<open>However, we will introduce types for causal \Gls{spf}. Beside
the continuity of the components also its causality is important for
its realizeability. This section introduces two predicates to
distinguish between strong, weak, and non-causal \Gls{spf}. The
causal \gls{spf} types are a direct consequence from the predicates.
Strong causal components are a subset of weak causal. A weak causal
component is realizable, but we also introduce a type for strong
causal components for their compositional properties. In general,
both causal types do not contain a \<open>\<bottom>\<close> element, because this would
be inconsistent with our time model.\<close>

subsubsection \<open>Weak SPF\<close>

text\<open>Weak causal \Gls{spf} can not look into the future. Their
output must depend completely on their previous input. Since we
interpret a stream bundle element as a time slice, @{const sbLen}
\ref{subsub:sblen} is enough to restrict the behaviour to a causal
one. If the output of a \gls{spf} is longer or equally long to the
input, it consists of as least as many time slices as the input.
Hence, we can define as weak, if the output is in all cases at least
as long as the input.\<close>

definition weak_well::"('I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>) \<Rightarrow> bool" where
"weak_well spf = (\<forall>sb. sbLen sb \<le> sbLen (spf\<cdot>sb))"

text\<open>Now we can immediately construct a type for weal causal
\Gls{spf} with the @{const weak_well} Predicate.\<close>
(*<*)
definition sometimesspfw::"('I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>)"where
"sometimesspfw = (\<Lambda> sb. Abs_sb(\<lambda>c. sinftimes
                  (\<up>(SOME a. a \<in> ctype (Rep c)))))"

lemma sometimesspfw_well:
"\<not>chDomEmpty TYPE('cs) \<Longrightarrow>
 sb_well (\<lambda>c::'cs. sinftimes (\<up>(SOME a. a \<in> ctype (Rep c))))"
  apply(auto simp add: sb_well_def)
  using cEmpty_def cnotempty_rule some_in_eq by auto

lemma sometimesspfw_len:
"\<not>chDomEmpty TYPE('cs) \<Longrightarrow> sbLen ((sometimesspfw\<cdot>sb)::'cs\<^sup>\<Omega>) = \<infinity>"
  apply(rule sblen_rule,simp_all add: sometimesspfw_def
        sbgetch_insert2)
  by(simp add: Abs_sb_inverse sometimesspfw_well)+

lemma weak_well_adm:"adm weak_well"
  unfolding weak_well_def
  apply (rule admI)
  apply auto
  by (meson is_ub_thelub  cfun_below_iff sblen_mono lnle_def
      monofun_def less_lnsuc order_trans)

lemma strong_spf_exist:" \<exists>x::('I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>) .
  (\<forall>sb. lnsuc\<cdot>(sbLen sb) \<le> sbLen (x\<cdot>sb))"
  apply(cases "chDomEmpty TYPE('O)")
  apply simp
  apply(rule_tac x=sometimesspfw in exI)
  by(simp add:  sometimesspfw_len)
(*>*)

cpodef ('I,'O)spfw = "{f::('I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>) . weak_well f}"
  apply(simp add: weak_well_def)
  apply (metis (full_types) eq_iff strong_spf_exist fold_inf inf_ub
        le2lnle leI le_cases less_irrefl trans_lnle)
  by (simp add: weak_well_adm)

setup_lifting %invisible type_definition_spfw

lemma [simp, cont2cont]:"cont Rep_spfw"
  using cont_Rep_spfw cont_id by blast

lift_definition %invisible Rep_spfw_fun::
"('I,'O)spfw \<rightarrow> ('I\<^sup>\<Omega> \<rightarrow>'O\<^sup>\<Omega>)"is "\<lambda> spfs. Rep_spfw( spfs)"
  by(intro cont2cont)

lemma spf_weakI:
  fixes spf :: "'I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>"
  assumes "\<And>sb. (sbLen sb) \<le> sbLen (spf\<cdot>sb)"
  shows "weak_well spf"
  by(simp add: weak_well_def assms)

lemma spf_weakI2:
  fixes spf :: "'I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>"
  assumes "\<not>chDomEmpty TYPE('I)"
    and "\<And>sb. sbLen sb < \<infinity> \<Longrightarrow> sbLen sb \<le> sbLen (spf\<cdot>sb)"
  shows "weak_well spf"
proof-
  have "\<And>sb. sbLen sb = \<infinity> \<Longrightarrow> sbLen sb \<le> sbLen (spf\<cdot>sb)"
  proof (rule ccontr)
    fix sb::"'I\<^sup>\<Omega>"
    assume sb_len: "sbLen sb = \<infinity>"
      and not_weak: "\<not> sbLen sb \<le> sbLen (spf\<cdot>sb)"
    then obtain k where out_len: "sbLen (spf\<cdot>sb) = Fin k"
      by (metis le_less_linear lnat_well_h2)
    have sbtake_sb_len: "sbLen (sbTake (Suc k)\<cdot>sb) = Fin (Suc k)"
      by (simp add: assms sbtake_len sb_len)
    have "sbLen (spf\<cdot>(sbTake (Suc k)\<cdot>sb)) \<le> sbLen (spf\<cdot>sb)"
      using monofun_cfun_arg sblen_monosimp sbtake_below by blast
    thus False
      by (metis Fin_Suc Fin_leq_Suc_leq SBv3.lnat.inject assms(2)
          le_less_linear less2eq less_lnsuc n_not_Suc_n
          notinfI3 out_len sbtake_sb_len)
  qed
  thus ?thesis
    by (metis assms(2) inf_ub order.not_eq_order_implies_strict
        weak_well_def)
qed

subsubsection \<open>Strong SPF \<close>

text\<open>Strong causal \Gls{spf} model weak components, whose output
never depends on the current input. Thus, its output only depends on
earlier input. This property is again definable with @{const sbLen}.
Here we have to mind that an input can be infinitely long, hence,
the output will not always be longer than the input. Therefore, we
use a increment instead of the smaller relation.\<close>

definition strong_well::"('I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>) \<Rightarrow> bool" where
"strong_well spf = (\<forall>sb. lnsuc\<cdot>(sbLen sb) \<le> sbLen (spf\<cdot>sb))"

text\<open>Now it is easy to show, that every strong component is also a
weak component.\<close>

theorem strong2weak:"\<And>f. strong_well f \<Longrightarrow> weak_well f"
  using less_lnsuc strong_well_def trans_lnle weak_well_def by blast

lemma strong_well_adm:
"adm (\<lambda>x::('I, 'O) spfw. strong_well (Rep_spfw x))"
  unfolding strong_well_def
  apply (rule admI)
  apply auto
  by (meson is_ub_thelub below_spfw_def cfun_below_iff sblen_mono
      lnle_def monofun_def less_lnsuc order_trans)

text\<open>Following this property, we define the strong \gls{spf} type as
a subset of the weak type.\<close>

cpodef ('I,'O)spfs = "{f::('I,'O)spfw . strong_well (Rep_spfw f)}"
  apply (metis Rep_spfw_cases mem_Collect_eq strong2weak
         strong_spf_exist strong_well_def)
  by(simp add: strong_well_adm)

setup_lifting %invisible type_definition_spfs

lemma [simp, cont2cont]:"cont Rep_spfs"
  using cont_Rep_spfs cont_id by blast

lift_definition %invisible Rep_spfs_fun::
"('I,'O)spfs \<rightarrow> ('I\<^sup>\<Omega> \<rightarrow>'O\<^sup>\<Omega>)"is "\<lambda> spfs. Rep_spfw_fun\<cdot>(Rep_spfs spfs)"
  by(intro cont2cont)

lemma spf_strongI:
  fixes spf :: "'I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>"
  assumes "\<And>sb. lnsuc\<cdot>(sbLen sb) \<le> sbLen (spf\<cdot>sb)"
  shows "strong_well spf"
  by(simp add: strong_well_def assms)

(*<*)
end
(*>*)


theory Prelude_Eq
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"NotFalse\", \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\",
     \"OrDef\", \"OtherwiseDef\", \"NotFalse1\", \"NotTrue1\",
     \"notNot1\", \"notNot2\", \"EqualTDef\", \"EqualSymDef\",
     \"EqualReflex\", \"EqualTransT\", \"DiffDef\", \"IBE3\",
     \"DiffSymDef\", \"DiffTDef\", \"DiffFDef\", \"TE1\", \"TE2\",
     \"TE3\", \"TE4\", \"IUE1\", \"IUE2\", \"IBE1\", \"IBE2\", \"IBE4\",
     \"IBE5\", \"IBE6\", \"IBE7\", \"IBE8\"]"

typedecl Bool
typedecl Unit

consts
Not__X :: "bool => bool" ("(Not''/ _)" [56] 56)
X__XAmpXAmp__X :: "bool => bool => bool" ("(_/ &&/ _)" [54,54] 52)
X__XEqXEq__X :: "'a partial => 'a partial => bool" ("(_/ ==''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a partial => 'a partial => bool" ("(_/ '/=/ _)" [54,54] 52)
X__XVBarXVBar__X :: "bool => bool => bool" ("(_/ ||/ _)" [54,54] 52)
otherwiseH :: "bool"

axioms
NotFalse [rule_format] : "Not' False"

NotTrue [rule_format] : "~ Not' True"

AndFalse [rule_format] : "ALL x. ~ False && x"

AndTrue [rule_format] : "ALL x. True && x = x"

AndSym [rule_format] : "ALL x. ALL y. x && y = y && x"

OrDef [rule_format] :
"ALL x. ALL y. x || y = Not' (Not' x && Not' y)"

OtherwiseDef [rule_format] : "otherwiseH"

NotFalse1 [rule_format] : "ALL x. Not' x = (~ x)"

NotTrue1 [rule_format] : "ALL x. ~ Not' x = x"

notNot1 [rule_format] : "ALL x. (~ x) = Not' x"

notNot2 [rule_format] : "ALL x. (~ ~ x) = (~ Not' x)"

EqualTDef [rule_format] : "ALL x. ALL y. x = y --> x ==' y"

EqualSymDef [rule_format] : "ALL x. ALL y. x ==' y = y ==' x"

EqualReflex [rule_format] : "ALL x. x ==' x"

EqualTransT [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & y ==' z --> x ==' z"

DiffDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

IBE3 [rule_format] : "~ undefinedOp ==' makePartial ()"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare OtherwiseDef [simp]
declare NotTrue1 [simp]
declare EqualReflex [simp]
declare IBE3 [simp]

theorem DiffSymDef : "ALL x. ALL y. x /= y = y /= x"
apply(auto)
apply(simp add: DiffDef)
apply(simp add: EqualSymDef)
apply(simp add: DiffDef)
apply(simp add: EqualSymDef)
done

ML "Header.record \"DiffSymDef\""

theorem DiffTDef : "ALL x. ALL y. x /= y = Not' (x ==' y)"
apply(auto)
apply(simp add: DiffDef)
apply(simp add: DiffDef)
done

ML "Header.record \"DiffTDef\""

theorem DiffFDef : "ALL x. ALL y. (~ x /= y) = x ==' y"
apply(auto)
apply(simp add: DiffDef)
apply(simp add: NotFalse1)
apply(simp add: DiffDef)
done

ML "Header.record \"DiffFDef\""

theorem TE1 : "ALL x. ALL y. ~ x ==' y --> ~ x = y"
apply(auto)
apply(case_tac "a")
apply(auto)
done

ML "Header.record \"TE1\""

theorem TE2 : "ALL x. ALL y. Not' (x ==' y) = (~ x ==' y)"
by (auto)

ML "Header.record \"TE2\""

theorem TE3 : "ALL x. ALL y. (~ Not' (x ==' y)) = x ==' y"
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
by (auto)

ML "Header.record \"TE3\""

theorem TE4 : "ALL x. ALL y. (~ x ==' y) = (~ x ==' y)"
by (auto)

ML "Header.record \"TE4\""

theorem IUE1 : "makePartial () ==' makePartial ()"
by (auto)

ML "Header.record \"IUE1\""

theorem IUE2 : "~ makePartial () /= makePartial ()"
apply(simp add: DiffDef)
done

ML "Header.record \"IUE2\""

theorem IBE1 : "makePartial () ==' makePartial ()"
by (auto)

ML "Header.record \"IBE1\""

theorem IBE2 : "undefinedOp ==' undefinedOp"
by (auto)

ML "Header.record \"IBE2\""

theorem IBE4 : "~ makePartial () ==' undefinedOp"
apply (auto)
apply(simp add: EqualSymDef)
done

ML "Header.record \"IBE4\""

theorem IBE5 : "makePartial () /= undefinedOp"
apply(simp add: DiffDef)
apply(simp add: NotFalse1)
apply(simp add: EqualSymDef)
done

ML "Header.record \"IBE5\""

theorem IBE6 : "undefinedOp /= makePartial ()"
apply(simp add: DiffDef)
done

ML "Header.record \"IBE6\""

theorem IBE7 : "Not' (makePartial () ==' undefinedOp)"
apply(simp add: NotFalse1)
apply(simp add: EqualSymDef)
done

ML "Header.record \"IBE7\""

theorem IBE8 : "~ Not' Not' (makePartial () ==' undefinedOp)"
apply(simp add: EqualSymDef)
done

ML "Header.record \"IBE8\""

end