section {* Records \label{sec:records} *}

(*<*)
theory Records imports Main begin
(*>*)

text {*
  \index{records|(}%
  Records are familiar from programming languages.  A record of $n$
  fields is essentially an $n$-tuple, but the record's components have
  names, which can make expressions easier to read and reduces the
  risk of confusing one field for another.

  A record of Isabelle/HOL covers a collection of fields, with select
  and update operations.  Each field has a specified type, which may
  be polymorphic.  The field names are part of the record type, and
  the order of the fields is significant --- as it is in Pascal but
  not in Standard ML.  If two different record types have field names
  in common, then the ambiguity is resolved in the usual way, by
  qualified names.

  Record types can also be defined by extending other record types.
  Extensible records make use of the reserved pseudo-field \cdx{more},
  which is present in every record type.  Generic record operations
  work on all possible extensions of a given type scheme; polymorphism
  takes care of structural sub-typing behind the scenes.  There are
  also explicit coercion functions between fixed record types.
*}

subsection {* Record Basics *}

text {*
  Record types are not primitive in Isabelle and have a delicate
  internal representation @{cite "NaraschewskiW-TPHOLs98"}, based on
  nested copies of the primitive product type.  A \commdx{record}
  declaration introduces a new record type scheme by specifying its
  fields, which are packaged internally to hold up the perception of
  the record as a distinguished entity.  Here is a simple example:
*}

record point =
  Xcoord :: int
  Ycoord :: int

text {*\noindent
  Records of type @{typ point} have two fields named @{const Xcoord}
  and @{const Ycoord}, both of type~@{typ int}.  We now define a
  constant of type @{typ point}:
*}

definition pt1 :: point where
"pt1 \<equiv> (| Xcoord = 999, Ycoord = 23 |)"

text {*\noindent
  We see above the ASCII notation for record brackets.  You can also
  use the symbolic brackets @{text \<lparr>} and @{text \<rparr>}.  Record type
  expressions can be also written directly with individual fields.
  The type name above is merely an abbreviation.
*}

definition pt2 :: "\<lparr>Xcoord :: int, Ycoord :: int\<rparr>" where
"pt2 \<equiv> \<lparr>Xcoord = -45, Ycoord = 97\<rparr>"

text {*
  For each field, there is a \emph{selector}\index{selector!record}
  function of the same name.  For example, if @{text p} has type @{typ
  point} then @{text "Xcoord p"} denotes the value of the @{text
  Xcoord} field of~@{text p}.  Expressions involving field selection
  of explicit records are simplified automatically:
*}

lemma "Xcoord \<lparr>Xcoord = a, Ycoord = b\<rparr> = a"
  by simp

text {*
  The \emph{update}\index{update!record} operation is functional.  For
  example, @{term "p\<lparr>Xcoord := 0\<rparr>"} is a record whose @{const Xcoord}
  value is zero and whose @{const Ycoord} value is copied from~@{text
  p}.  Updates of explicit records are also simplified automatically:
*}

lemma "\<lparr>Xcoord = a, Ycoord = b\<rparr>\<lparr>Xcoord := 0\<rparr> =
         \<lparr>Xcoord = 0, Ycoord = b\<rparr>"
  by simp

text {*
  \begin{warn}
  Field names are declared as constants and can no longer be used as
  variables.  It would be unwise, for example, to call the fields of
  type @{typ point} simply @{text x} and~@{text y}.
  \end{warn}
*}

subsection {* Extensible Records and Generic Operations *}

text {*
  \index{records!extensible|(}%

  Now, let us define coloured points (type @{text cpoint}) to be
  points extended with a field @{text col} of type @{text colour}:
*}

datatype colour = Red | Green | Blue

record cpoint = point +
  col :: colour

text {*\noindent
  The fields of this new type are @{const Xcoord}, @{text Ycoord} and
  @{text col}, in that order.
*}

definition cpt1 :: cpoint where
"cpt1 \<equiv> \<lparr>Xcoord = 999, Ycoord = 23, col = Green\<rparr>"

text {*
  We can define generic operations that work on arbitrary
  instances of a record scheme, e.g.\ covering @{typ point}, @{typ
  cpoint}, and any further extensions.  Every record structure has an
  implicit pseudo-field, \cdx{more}, that keeps the extension as an
  explicit value.  Its type is declared as completely
  polymorphic:~@{typ 'a}.  When a fixed record value is expressed
  using just its standard fields, the value of @{text more} is
  implicitly set to @{text "()"}, the empty tuple, which has type
  @{typ unit}.  Within the record brackets, you can refer to the
  @{text more} field by writing ``@{text "\<dots>"}'' (three dots):
*}

lemma "Xcoord \<lparr>Xcoord = a, Ycoord = b, \<dots> = p\<rparr> = a"
  by simp

text {*
  This lemma applies to any record whose first two fields are @{text
  Xcoord} and~@{const Ycoord}.  Note that @{text "\<lparr>Xcoord = a, Ycoord
  = b, \<dots> = ()\<rparr>"} is exactly the same as @{text "\<lparr>Xcoord = a, Ycoord
  = b\<rparr>"}.  Selectors and updates are always polymorphic wrt.\ the
  @{text more} part of a record scheme, its value is just ignored (for
  select) or copied (for update).

  The @{text more} pseudo-field may be manipulated directly as well,
  but the identifier needs to be qualified:
*}

lemma "point.more cpt1 = \<lparr>col = Green\<rparr>"
  by (simp add: cpt1_def)

text {*\noindent
  We see that the colour part attached to this @{typ point} is a
  rudimentary record in its own right, namely @{text "\<lparr>col =
  Green\<rparr>"}.  In order to select or update @{text col}, this fragment
  needs to be put back into the context of the parent type scheme, say
  as @{text more} part of another @{typ point}.

  To define generic operations, we need to know a bit more about
  records.  Our definition of @{typ point} above has generated two
  type abbreviations:

  \medskip
  \begin{tabular}{l}
  @{typ point}~@{text "="}~@{text "\<lparr>Xcoord :: int, Ycoord :: int\<rparr>"} \\
  @{typ "'a point_scheme"}~@{text "="}~@{text "\<lparr>Xcoord :: int, Ycoord :: int, \<dots> :: 'a\<rparr>"} \\
  \end{tabular}
  \medskip

\noindent
  Type @{typ point} is for fixed records having exactly the two fields
  @{const Xcoord} and~@{text Ycoord}, while the polymorphic type @{typ
  "'a point_scheme"} comprises all possible extensions to those two
  fields.  Note that @{typ "unit point_scheme"} coincides with @{typ
  point}, and @{typ "\<lparr>col :: colour\<rparr> point_scheme"} with @{typ
  cpoint}.

  In the following example we define two operations --- methods, if we
  regard records as objects --- to get and set any point's @{text
  Xcoord} field.
*}

definition getX :: "'a point_scheme \<Rightarrow> int" where
"getX r \<equiv> Xcoord r"
definition setX :: "'a point_scheme \<Rightarrow> int \<Rightarrow> 'a point_scheme" where
"setX r a \<equiv> r\<lparr>Xcoord := a\<rparr>"

text {*
  Here is a generic method that modifies a point, incrementing its
  @{const Xcoord} field.  The @{text Ycoord} and @{text more} fields
  are copied across.  It works for any record type scheme derived from
  @{typ point} (including @{typ cpoint} etc.):
*}

definition incX :: "'a point_scheme \<Rightarrow> 'a point_scheme" where
"incX r \<equiv>
  \<lparr>Xcoord = Xcoord r + 1, Ycoord = Ycoord r, \<dots> = point.more r\<rparr>"

text {*
  Generic theorems can be proved about generic methods.  This trivial
  lemma relates @{const incX} to @{text getX} and @{text setX}:
*}

lemma "incX r = setX r (getX r + 1)"
  by (simp add: getX_def setX_def incX_def)

text {*
  \begin{warn}
  If you use the symbolic record brackets @{text \<lparr>} and @{text \<rparr>},
  then you must also use the symbolic ellipsis, ``@{text \<dots>}'', rather
  than three consecutive periods, ``@{text "..."}''.  Mixing the ASCII
  and symbolic versions causes a syntax error.  (The two versions are
  more distinct on screen than they are on paper.)
  \end{warn}%
  \index{records!extensible|)}
*}

subsection {* Record Equality *}

text {*
  Two records are equal\index{equality!of records} if all pairs of
  corresponding fields are equal.  Concrete record equalities are
  simplified automatically:
*}

lemma "(\<lparr>Xcoord = a, Ycoord = b\<rparr> = \<lparr>Xcoord = a', Ycoord = b'\<rparr>) =
    (a = a' \<and> b = b')"
  by simp

text {*
  The following equality is similar, but generic, in that @{text r}
  can be any instance of @{typ "'a point_scheme"}:
*}

lemma "r\<lparr>Xcoord := a, Ycoord := b\<rparr> = r\<lparr>Ycoord := b, Xcoord := a\<rparr>"
  by simp

text {*\noindent
  We see above the syntax for iterated updates.  We could equivalently
  have written the left-hand side as @{text "r\<lparr>Xcoord := a\<rparr>\<lparr>Ycoord :=
  b\<rparr>"}.

  Record equality is \emph{extensional}:
  \index{extensionality!for records} a record is determined entirely
  by the values of its fields.
*}

lemma "r = \<lparr>Xcoord = Xcoord r, Ycoord = Ycoord r\<rparr>"
  by simp

text {*\noindent
  The generic version of this equality includes the pseudo-field
  @{text more}:
*}

lemma "r = \<lparr>Xcoord = Xcoord r, Ycoord = Ycoord r, \<dots> = point.more r\<rparr>"
  by simp

text {*
  The simplifier can prove many record equalities
  automatically, but general equality reasoning can be tricky.
  Consider proving this obvious fact:
*}

lemma "r\<lparr>Xcoord := a\<rparr> = r\<lparr>Xcoord := a'\<rparr> \<Longrightarrow> a = a'"
  apply simp?
  oops

text {*\noindent
  Here the simplifier can do nothing, since general record equality is
  not eliminated automatically.  One way to proceed is by an explicit
  forward step that applies the selector @{const Xcoord} to both sides
  of the assumed record equality:
*}

lemma "r\<lparr>Xcoord := a\<rparr> = r\<lparr>Xcoord := a'\<rparr> \<Longrightarrow> a = a'"
  apply (drule_tac f = Xcoord in arg_cong)
  txt {* @{subgoals [display, indent = 0, margin = 65]}
    Now, @{text simp} will reduce the assumption to the desired
    conclusion. *}
  apply simp
  done

text {*
  The @{text cases} method is preferable to such a forward proof.  We
  state the desired lemma again:
*}

lemma "r\<lparr>Xcoord := a\<rparr> = r\<lparr>Xcoord := a'\<rparr> \<Longrightarrow> a = a'"

  txt {* The \methdx{cases} method adds an equality to replace the
  named record term by an explicit record expression, listing all
  fields.  It even includes the pseudo-field @{text more}, since the
  record equality stated here is generic for all extensions. *}

  apply (cases r)

  txt {* @{subgoals [display, indent = 0, margin = 65]} Again, @{text
  simp} finishes the proof.  Because @{text r} is now represented as
  an explicit record construction, the updates can be applied and the
  record equality can be replaced by equality of the corresponding
  fields (due to injectivity). *}

  apply simp
  done

text {*
  The generic cases method does not admit references to locally bound
  parameters of a goal.  In longer proof scripts one might have to
  fall back on the primitive @{text rule_tac} used together with the
  internal field representation rules of records.  The above use of
  @{text "(cases r)"} would become @{text "(rule_tac r = r in
  point.cases_scheme)"}.
*}

subsection {* Extending and Truncating Records *}

text {*
  Each record declaration introduces a number of derived operations to
  refer collectively to a record's fields and to convert between fixed
  record types.  They can, for instance, convert between types @{typ
  point} and @{typ cpoint}.  We can add a colour to a point or convert
  a @{typ cpoint} to a @{typ point} by forgetting its colour.

  \begin{itemize}

  \item Function \cdx{make} takes as arguments all of the record's
  fields (including those inherited from ancestors).  It returns the
  corresponding record.

  \item Function \cdx{fields} takes the record's very own fields and
  returns a record fragment consisting of just those fields.  This may
  be filled into the @{text more} part of the parent record scheme.

  \item Function \cdx{extend} takes two arguments: a record to be
  extended and a record containing the new fields.

  \item Function \cdx{truncate} takes a record (possibly an extension
  of the original record type) and returns a fixed record, removing
  any additional fields.

  \end{itemize}
  These functions provide useful abbreviations for standard
  record expressions involving constructors and selectors.  The
  definitions, which are \emph{not} unfolded by default, are made
  available by the collective name of @{text defs} (@{text
  point.defs}, @{text cpoint.defs}, etc.).
  For example, here are the versions of those functions generated for
  record @{typ point}.  We omit @{text point.fields}, which happens to
  be the same as @{text point.make}.

  @{thm [display, indent = 0, margin = 65] point.make_def [no_vars]
  point.extend_def [no_vars] point.truncate_def [no_vars]}
  Contrast those with the corresponding functions for record @{typ
  cpoint}.  Observe @{text cpoint.fields} in particular.
  @{thm [display, indent = 0, margin = 65] cpoint.make_def [no_vars]
  cpoint.fields_def [no_vars] cpoint.extend_def [no_vars]
  cpoint.truncate_def [no_vars]}

  To demonstrate these functions, we declare a new coloured point by
  extending an ordinary point.  Function @{text point.extend} augments
  @{text pt1} with a colour value, which is converted into an
  appropriate record fragment by @{text cpoint.fields}.
*}

definition cpt2 :: cpoint where
"cpt2 \<equiv> point.extend pt1 (cpoint.fields Green)"

text {*
  The coloured points @{const cpt1} and @{text cpt2} are equal.  The
  proof is trivial, by unfolding all the definitions.  We deliberately
  omit the definition of~@{text pt1} in order to reveal the underlying
  comparison on type @{typ point}.
*}

lemma "cpt1 = cpt2"
  apply (simp add: cpt1_def cpt2_def point.defs cpoint.defs)
  txt {* @{subgoals [display, indent = 0, margin = 65]} *}
  apply (simp add: pt1_def)
  done

text {*
  In the example below, a coloured point is truncated to leave a
  point.  We use the @{text truncate} function of the target record.
*}

lemma "point.truncate cpt2 = pt1"
  by (simp add: pt1_def cpt2_def point.defs)

text {*
  \begin{exercise}
  Extend record @{typ cpoint} to have a further field, @{text
  intensity}, of type~@{typ nat}.  Experiment with generic operations
  (using polymorphic selectors and updates) and explicit coercions
  (using @{text extend}, @{text truncate} etc.) among the three record
  types.
  \end{exercise}

  \begin{exercise}
  (For Java programmers.)
  Model a small class hierarchy using records.
  \end{exercise}
  \index{records|)}
*}

(*<*)
end
(*>*)


theory SINVAR_BLPbasic
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant Basic Bell LaPadula  *}

type_synonym privacy_level = nat

definition default_node_properties :: "privacy_level"
  where  "default_node_properties \<equiv> 0"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> privacy_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (nP e1) \<le> (nP e2))"

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> privacy_level) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

definition receiver_violation :: "bool" where "receiver_violation \<equiv> True"

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
and verify_globals = verify_globals
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF valid_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[6]
   apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[1]
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

lemma BLP_def_unique: "otherbot \<noteq> 0 \<Longrightarrow>
    \<exists>G p i f. valid_graph G \<and> \<not> sinvar G p \<and> f \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G p) \<and>
       sinvar (delete_edges G f) p \<and>
        i \<in> snd ` f \<and> sinvar G (p(i := otherbot)) "
  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: split_split_asm split_split)
  apply(rule_tac x="\<lparr> nodes=set [vertex_1,vertex_2], edges = set [(vertex_1,vertex_2)] \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: valid_graph_def)
  apply(rule_tac x="(\<lambda> x. 0)(vertex_1 := 1, vertex_2 := 0)" in exI, simp)
  apply(rule_tac x="vertex_2" in exI, simp)
  apply(rule_tac x="set [(vertex_1,vertex_2)]" in exI, simp)
  done

(*Test instantiation without any fancy lemmata*)
(*
interpretation SecurityInvariant
where default_node_properties = default_node_properties
and sinvar = sinvar
and verify_globals = verify_globals
and receiver_violation = receiver_violation
  unfolding default_node_properties_def
  unfolding receiver_violation_def
  apply unfold_locales

  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: split_split_asm split_split add:prod_case_beta)
   apply(auto intro!:bexI)[1]
   (*apply (smt image_iff offending_in_edges pair_collapse)*)
  apply(blast intro: BLP_def_unique)
done
*)

subsubsection {*ENF*}
  lemma zero_default_candidate: "\<And> nP e1 e2. \<not> (op \<le>::privacy_level \<Rightarrow> privacy_level \<Rightarrow> bool) (nP e1) (nP e2) \<Longrightarrow> \<not> (op \<le>) (nP e1) 0"
    by simp_all
  lemma zero_default_candidate_rule: "\<And> (nP::('v \<Rightarrow> privacy_level)) e1 e2. \<not> (nP e1) \<le> (nP e2) \<Longrightarrow> \<not> (nP e1) \<le> 0"
    by simp_all
  lemma privacylevel_refl: "(op \<le>::privacy_level \<Rightarrow> privacy_level \<Rightarrow> bool) e e"
    by(simp_all)
  lemma BLP_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar (op \<le>)"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    by simp
  lemma BLP_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar (op \<le>)"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: BLP_ENF)
    apply(simp add: privacylevel_refl)
  done

  definition BLP_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> privacy_level) \<Rightarrow> ('v \<times> 'v) set set" where
  "BLP_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> (nP e1) > (nP e2)} })"
  lemma BLP_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply(simp only: fun_eq_iff SecurityInvariant_withOffendingFlows.ENF_offending_set[OF BLP_ENF] BLP_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

  interpretation BLPbasic: SecurityInvariant_IFS sinvar verify_globals default_node_properties
  where "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    unfolding receiver_violation_def
    unfolding default_node_properties_def
    apply(unfold_locales)
      apply(rule ballI)
      apply(rule SecurityInvariant_withOffendingFlows.ENF_snds_refl_instance[OF BLP_ENF_refl])
         apply(simp_all add: BLP_ENF BLP_ENF_refl)[3]
     apply(erule default_uniqueness_by_counterexample_IFS)
     apply(fact BLP_def_unique)
    apply(fact BLP_offending_set)
   done

  lemma TopoS_BLPBasic: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_fact (open) sinvar_mono
hide_fact BLP_def_unique zero_default_candidate zero_default_candidate_rule privacylevel_refl BLP_ENF BLP_ENF_refl

hide_const (open) sinvar verify_globals receiver_violation default_node_properties

end


theory Prelude_NumClass
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"AbsSigRule\", \"NotFalse\", \"NotTrue\", \"AndFalse\",
     \"AndTrue\", \"AndSym\", \"OrDef\", \"OtherwiseDef\",
     \"NotFalse1\", \"NotTrue1\", \"notNot1\", \"notNot2\",
     \"EqualTDef\", \"EqualSymDef\", \"EqualReflex\", \"EqualTransT\",
     \"DiffDef\", \"DiffSymDef\", \"DiffTDef\", \"DiffFDef\", \"TE1\",
     \"TE2\", \"TE3\", \"TE4\", \"IBE1\", \"IBE2\", \"IBE3\", \"IBE4\",
     \"IBE5\", \"IBE6\", \"IBE7\", \"IBE8\", \"IUE1\", \"IUE2\",
     \"ga_selector_pre\", \"ga_injective_suc\", \"ga_disjoint_0_suc\",
     \"ga_selector_undef_pre_0\", \"X1_def_Nat\", \"X2_def_Nat\",
     \"X3_def_Nat\", \"X4_def_Nat\", \"X5_def_Nat\", \"X6_def_Nat\",
     \"X7_def_Nat\", \"X8_def_Nat\", \"X9_def_Nat\", \"decimal_def\",
     \"ga_comm___XPlus__\", \"ga_assoc___XPlus__\",
     \"ga_right_unit___XPlus__\", \"ga_left_unit___XPlus__\",
     \"ga_left_comm___XPlus__\", \"ga_comm___Xx__\",
     \"ga_assoc___Xx__\", \"ga_right_unit___Xx__\",
     \"ga_left_unit___Xx__\", \"ga_left_comm___Xx__\", \"ga_comm_min\",
     \"ga_assoc_min\", \"ga_left_comm_min\", \"ga_comm_max\",
     \"ga_assoc_max\", \"ga_right_unit_max\", \"ga_left_unit_max\",
     \"ga_left_comm_max\", \"leq_def1_Nat\", \"leq_def2_Nat\",
     \"leq_def3_Nat\", \"geq_def_Nat\", \"less_def_Nat\",
     \"greater_def_Nat\", \"even_0_Nat\", \"even_suc_Nat\",
     \"odd_def_Nat\", \"factorial_0\", \"factorial_suc\", \"add_0_Nat\",
     \"add_suc_Nat\", \"mult_0_Nat\", \"mult_suc_Nat\", \"power_0_Nat\",
     \"power_suc_Nat\", \"min_def_Nat\", \"max_def_Nat\",
     \"subTotal_def1_Nat\", \"subTotal_def2_Nat\", \"sub_dom_Nat\",
     \"sub_def_Nat\", \"divide_dom_Nat\", \"divide_0_Nat\",
     \"divide_Pos_Nat\", \"div_dom_Nat\", \"div_Nat\", \"mod_dom_Nat\",
     \"mod_Nat\", \"distr1_Nat\", \"distr2_Nat\", \"Pos_def\",
     \"X1_as_Pos_def\", \"min_0\", \"div_mod_Nat\", \"power_Nat\",
     \"equality_Int\", \"NatToInt\", \"IntToNat\",
     \"ga_comm___XPlus___1\", \"ga_assoc___XPlus___1\",
     \"ga_right_unit___XPlus___1\", \"ga_left_unit___XPlus___1\",
     \"ga_left_comm___XPlus___1\", \"ga_comm___Xx___1\",
     \"ga_assoc___Xx___1\", \"ga_right_unit___Xx___1\",
     \"ga_left_unit___Xx___1\", \"ga_left_comm___Xx___1\",
     \"ga_comm_min_1\", \"ga_comm_max_1\", \"ga_assoc_min_1\",
     \"ga_assoc_max_1\", \"ga_left_comm_min_1\", \"ga_left_comm_max_1\",
     \"leq_def_Int\", \"geq_def_Int\", \"less_def_Int\",
     \"greater_def_Int\", \"even_def_Int\", \"odd_def_Int\",
     \"odd_alt_Int\", \"neg_def_Int\", \"sign_def_Int\",
     \"abs_def_Int\", \"add_def_Int\", \"mult_def_Int\",
     \"sub_def_Int\", \"min_def_Int\", \"max_def_Int\",
     \"power_neg1_Int\", \"power_others_Int\", \"divide_dom2_Int\",
     \"divide_alt_Int\", \"divide_Int\", \"div_dom_Int\", \"div_Int\",
     \"quot_dom_Int\", \"quot_neg_Int\", \"quot_nonneg_Int\",
     \"rem_dom_Int\", \"quot_rem_Int\", \"rem_nonneg_Int\",
     \"mod_dom_Int\", \"mod_Int\", \"distr1_Int\", \"distr2_Int\",
     \"Int_Nat_sub_compat\", \"abs_decomp_Int\", \"mod_abs_Int\",
     \"div_mod_Int\", \"quot_abs_Int\", \"rem_abs_Int\",
     \"quot_rem_Int_1\", \"power_Int\", \"IIN04\", \"IIN05\", \"IIN06\",
     \"IIN07\"]"

typedecl Pos
typedecl Unit
typedecl X_Int

datatype Bool = X_False ("False''") | X_True ("True''")
datatype Nat = X0X2 ("0''''") | sucX1 "Nat" ("suc''/'(_')" [3] 999)

consts
IntToNat__X :: "X_Int => Nat" ("(IntToNat/ _)" [56] 56)
NatToInt__X :: "Nat => X_Int" ("(NatToInt/ _)" [56] 56)
Not__X :: "Bool => Bool" ("(Not''/ _)" [56] 56)
X0X1 :: "X_Int" ("0''")
X1X1 :: "X_Int" ("1''")
X1X2 :: "Nat" ("1''''")
X1X3 :: "Pos" ("1'_3")
X2X1 :: "X_Int" ("2''")
X2X2 :: "Nat" ("2''''")
X3X1 :: "X_Int" ("3''")
X3X2 :: "Nat" ("3''''")
X4X1 :: "X_Int" ("4''")
X4X2 :: "Nat" ("4''''")
X5X1 :: "X_Int" ("5''")
X5X2 :: "Nat" ("5''''")
X6X1 :: "X_Int" ("6''")
X6X2 :: "Nat" ("6''''")
X7X1 :: "X_Int" ("7''")
X7X2 :: "Nat" ("7''''")
X8X1 :: "X_Int" ("8''")
X8X2 :: "Nat" ("8''''")
X9X1 :: "X_Int" ("9''")
X9X2 :: "Nat" ("9''''")
XMinus__X :: "X_Int => X_Int" ("(-''/ _)" [56] 56)
X__XAmpXAmp__X :: "Bool => Bool => Bool" ("(_/ &&/ _)" [54,54] 52)
X__XAtXAt__X :: "Nat => Nat => Nat" ("(_/ @@/ _)" [54,54] 52)
X__XCaret__XX1 :: "X_Int => Nat => X_Int" ("(_/ ^''/ _)" [54,54] 52)
X__XCaret__XX2 :: "Nat => Nat => Nat" ("(_/ ^''''/ _)" [54,54] 52)
X__XEqXEq__X :: "'a => 'a => Bool" ("(_/ ==''/ _)" [54,54] 52)
X__XExclam :: "Nat => Nat" ("(_/ !'')" [58] 58)
X__XGtXEq__XX1 :: "X_Int => X_Int => bool" ("(_/ >=''/ _)" [44,44] 42)
X__XGtXEq__XX2 :: "Nat => Nat => bool" ("(_/ >=''''/ _)" [44,44] 42)
X__XGt__XX1 :: "X_Int => X_Int => bool" ("(_/ >''/ _)" [44,44] 42)
X__XGt__XX2 :: "Nat => Nat => bool" ("(_/ >''''/ _)" [44,44] 42)
X__XLtXEq__XX1 :: "X_Int => X_Int => bool" ("(_/ <=''/ _)" [44,44] 42)
X__XLtXEq__XX2 :: "Nat => Nat => bool" ("(_/ <=''''/ _)" [44,44] 42)
X__XLt__XX1 :: "X_Int => X_Int => bool" ("(_/ <''/ _)" [44,44] 42)
X__XLt__XX2 :: "Nat => Nat => bool" ("(_/ <''''/ _)" [44,44] 42)
X__XMinusXExclam__X :: "Nat => Nat => Nat" ("(_/ -!/ _)" [54,54] 52)
X__XMinusXQuest__X :: "Nat => Nat => Nat option" ("(_/ -?/ _)" [54,54] 52)
X__XMinus__XX1 :: "X_Int => X_Int => X_Int" ("(_/ -''/ _)" [54,54] 52)
X__XMinus__XX2 :: "Nat => Nat => X_Int" ("(_/ -''''/ _)" [54,54] 52)
X__XMinus__XX3 :: "'a => 'a => 'a" ("(_/ -'_3/ _)" [54,54] 52)
X__XPlus__XX1 :: "X_Int => X_Int => X_Int" ("(_/ +''/ _)" [54,54] 52)
X__XPlus__XX2 :: "Nat => Nat => Nat" ("(_/ +''''/ _)" [54,54] 52)
X__XPlus__XX3 :: "Nat => Pos => Pos" ("(_/ +'_3/ _)" [54,54] 52)
X__XPlus__XX4 :: "Pos => Nat => Pos" ("(_/ +'_4/ _)" [54,54] 52)
X__XPlus__XX5 :: "'a => 'a => 'a" ("(_/ +'_5/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a => 'a => Bool" ("(_/ '/=/ _)" [54,54] 52)
X__XSlashXQuest__XX1 :: "X_Int => X_Int => X_Int option" ("(_/ '/?''/ _)" [54,54] 52)
X__XSlashXQuest__XX2 :: "Nat => Nat => Nat option" ("(_/ '/?''''/ _)" [54,54] 52)
X__XVBarXVBar__X :: "Bool => Bool => Bool" ("(_/ ||/ _)" [54,54] 52)
X__Xx__XX1 :: "X_Int => X_Int => X_Int" ("(_/ *''/ _)" [54,54] 52)
X__Xx__XX2 :: "Nat => Nat => Nat" ("(_/ *''''/ _)" [54,54] 52)
X__Xx__XX3 :: "Pos => Pos => Pos" ("(_/ *'_3/ _)" [54,54] 52)
X__Xx__XX4 :: "'a => 'a => 'a" ("(_/ *'_4/ _)" [54,54] 52)
X__div__XX1 :: "X_Int => X_Int => X_Int option" ("(_/ div''/ _)" [54,54] 52)
X__div__XX2 :: "Nat => Nat => Nat option" ("(_/ div''''/ _)" [54,54] 52)
X__mod__XX1 :: "X_Int => X_Int => Nat option" ("(_/ mod''/ _)" [54,54] 52)
X__mod__XX2 :: "Nat => Nat => Nat option" ("(_/ mod''''/ _)" [54,54] 52)
X__quot__X :: "X_Int => X_Int => X_Int option" ("(_/ quot/ _)" [54,54] 52)
X__rem__X :: "X_Int => X_Int => X_Int option" ("(_/ rem/ _)" [54,54] 52)
X_absX1 :: "X_Int => Nat" ("abs''/'(_')" [3] 999)
X_absX2 :: "'a => 'a" ("abs''''/'(_')" [3] 999)
X_evenX1 :: "X_Int => bool" ("even''/'(_')" [3] 999)
X_evenX2 :: "Nat => bool" ("even''''/'(_')" [3] 999)
X_fromInteger :: "X_Int => 'a" ("fromInteger/'(_')" [3] 999)
X_gn_inj :: "'a => 'b" ("gn'_inj/'(_')" [3] 999)
X_gn_proj :: "'a => 'b option" ("gn'_proj/'(_')" [3] 999)
X_maxX1 :: "X_Int => X_Int => X_Int" ("max''/'(_,/ _')" [3,3] 999)
X_maxX2 :: "Nat => Nat => Nat" ("max''''/'(_,/ _')" [3,3] 999)
X_minX1 :: "X_Int => X_Int => X_Int" ("min''/'(_,/ _')" [3,3] 999)
X_minX2 :: "Nat => Nat => Nat" ("min''''/'(_,/ _')" [3,3] 999)
X_negate :: "'a => 'a" ("negate/'(_')" [3] 999)
X_oddX1 :: "X_Int => bool" ("odd''/'(_')" [3] 999)
X_oddX2 :: "Nat => bool" ("odd''''/'(_')" [3] 999)
X_pre :: "Nat => Nat option" ("pre/'(_')" [3] 999)
X_sign :: "X_Int => X_Int" ("sign/'(_')" [3] 999)
X_signum :: "'a => 'a" ("signum/'(_')" [3] 999)
otherwiseH :: "Bool"
sucX2 :: "Nat => Pos" ("suc''''/'(_')" [3] 999)

instance Bool:: type ..
instance Nat:: type ..
instance Pos:: type ..
instance Unit:: type ..
instance X_Int:: type ..

axioms
NotFalse [rule_format] : "Not' False' = True'"

NotTrue [rule_format] : "Not' True' = False'"

AndFalse [rule_format] : "ALL x. False' && x = False'"

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 = True'"

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

NotTrue1 [rule_format] : "ALL x. Not' x = False' = (x = True')"

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

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

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

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

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

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

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

DiffSymDef [rule_format] : "ALL x. ALL y. x /= y = y /= x"

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

DiffFDef [rule_format] :
"ALL x. ALL y. x /= y = False' = (x ==' y = True')"

TE1 [rule_format] : "ALL x. ALL y. x ==' y = False' --> ~ x = y"

TE2 [rule_format] :
"ALL x. ALL y. Not' (x ==' y) = True' = (x ==' y = False')"

TE3 [rule_format] :
"ALL x. ALL y. Not' (x ==' y) = False' = (x ==' y = True')"

TE4 [rule_format] :
"ALL x. ALL y. (~ x ==' y = True') = (x ==' y = False')"

IBE1 [rule_format] : "True' ==' True' = True'"

IBE2 [rule_format] : "False' ==' False' = True'"

IBE3 [rule_format] : "False' ==' True' = False'"

IBE4 [rule_format] : "True' ==' False' = False'"

IBE5 [rule_format] : "True' /= False' = True'"

IBE6 [rule_format] : "False' /= True' = True'"

IBE7 [rule_format] : "Not' (True' ==' False') = True'"

IBE8 [rule_format] : "Not' Not' (True' ==' False') = False'"

IUE1 [rule_format] : "() ==' () = True'"

IUE2 [rule_format] : "() /= () = False'"

ga_selector_pre [rule_format] :
"ALL XX1. pre(suc'(XX1)) = Some XX1"

ga_injective_suc [rule_format] :
"ALL XX1. ALL Y1. suc'(XX1) = suc'(Y1) = (XX1 = Y1)"

ga_disjoint_0_suc [rule_format] : "ALL Y1. ~ 0'' = suc'(Y1)"

ga_selector_undef_pre_0 [rule_format] : "~ defOp (pre(0''))"

X1_def_Nat [rule_format] : "1'' = suc'(0'')"

X2_def_Nat [rule_format] : "2'' = suc'(1'')"

X3_def_Nat [rule_format] : "3'' = suc'(2'')"

X4_def_Nat [rule_format] : "4'' = suc'(3'')"

X5_def_Nat [rule_format] : "5'' = suc'(4'')"

X6_def_Nat [rule_format] : "6'' = suc'(5'')"

X7_def_Nat [rule_format] : "7'' = suc'(6'')"

X8_def_Nat [rule_format] : "8'' = suc'(7'')"

X9_def_Nat [rule_format] : "9'' = suc'(8'')"

decimal_def [rule_format] :
"ALL m. ALL X_n. m @@ X_n = (m *'' suc'(9'')) +'' X_n"

ga_comm___XPlus__ [rule_format] : "ALL x. ALL y. x +'' y = y +'' x"

ga_assoc___XPlus__ [rule_format] :
"ALL x. ALL y. ALL z. (x +'' y) +'' z = x +'' (y +'' z)"

ga_right_unit___XPlus__ [rule_format] : "ALL x. x +'' 0'' = x"

ga_left_unit___XPlus__ [rule_format] : "ALL x. 0'' +'' x = x"

ga_left_comm___XPlus__ [rule_format] :
"ALL x. ALL y. ALL z. x +'' (y +'' z) = y +'' (x +'' z)"

ga_comm___Xx__ [rule_format] : "ALL x. ALL y. x *'' y = y *'' x"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x *'' y) *'' z = x *'' (y *'' z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x *'' 1'' = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. 1'' *'' x = x"

ga_left_comm___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. x *'' (y *'' z) = y *'' (x *'' z)"

ga_comm_min [rule_format] :
"ALL x. ALL y. min''(x, y) = min''(y, x)"

ga_assoc_min [rule_format] :
"ALL x.
 ALL y. ALL z. min''(min''(x, y), z) = min''(x, min''(y, z))"

ga_left_comm_min [rule_format] :
"ALL x.
 ALL y. ALL z. min''(x, min''(y, z)) = min''(y, min''(x, z))"

ga_comm_max [rule_format] :
"ALL x. ALL y. max''(x, y) = max''(y, x)"

ga_assoc_max [rule_format] :
"ALL x.
 ALL y. ALL z. max''(max''(x, y), z) = max''(x, max''(y, z))"

ga_right_unit_max [rule_format] : "ALL x. max''(x, 0'') = x"

ga_left_unit_max [rule_format] : "ALL x. max''(0'', x) = x"

ga_left_comm_max [rule_format] :
"ALL x.
 ALL y. ALL z. max''(x, max''(y, z)) = max''(y, max''(x, z))"

leq_def1_Nat [rule_format] : "ALL X_n. 0'' <='' X_n"

leq_def2_Nat [rule_format] : "ALL X_n. ~ suc'(X_n) <='' 0''"

leq_def3_Nat [rule_format] :
"ALL m. ALL X_n. (suc'(m) <='' suc'(X_n)) = (m <='' X_n)"

geq_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >='' X_n) = (X_n <='' m)"

less_def_Nat [rule_format] :
"ALL m. ALL X_n. (m <'' X_n) = (m <='' X_n & ~ m = X_n)"

greater_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >'' X_n) = (X_n <'' m)"

even_0_Nat [rule_format] : "even''(0'')"

even_suc_Nat [rule_format] : "ALL m. even''(suc'(m)) = odd''(m)"

odd_def_Nat [rule_format] : "ALL m. odd''(m) = (~ even''(m))"

factorial_0 [rule_format] : "0'' !' = 1''"

factorial_suc [rule_format] :
"ALL X_n. suc'(X_n) !' = suc'(X_n) *'' X_n !'"

add_0_Nat [rule_format] : "ALL m. 0'' +'' m = m"

add_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc'(X_n) +'' m = suc'(X_n +'' m)"

mult_0_Nat [rule_format] : "ALL m. 0'' *'' m = 0''"

mult_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc'(X_n) *'' m = (X_n *'' m) +'' m"

power_0_Nat [rule_format] : "ALL m. m ^'' 0'' = 1''"

power_suc_Nat [rule_format] :
"ALL m. ALL X_n. m ^'' suc'(X_n) = m *'' (m ^'' X_n)"

min_def_Nat [rule_format] :
"ALL m. ALL X_n. min''(m, X_n) = (if m <='' X_n then m else X_n)"

max_def_Nat [rule_format] :
"ALL m. ALL X_n. max''(m, X_n) = (if m <='' X_n then X_n else m)"

subTotal_def1_Nat [rule_format] :
"ALL m. ALL X_n. m >'' X_n --> X_n -! m = 0''"

subTotal_def2_Nat [rule_format] :
"ALL m. ALL X_n. m <='' X_n --> Some (X_n -! m) = X_n -? m"

sub_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m -? X_n) = (m >='' X_n)"

sub_def_Nat [rule_format] :
"ALL m. ALL X_n. ALL r. m -? X_n = Some r = (m = r +'' X_n)"

divide_dom_Nat [rule_format] :
"ALL m.
 ALL X_n.
 defOp (m /?'' X_n) = (~ X_n = 0'' & m mod'' X_n = Some 0'')"

divide_0_Nat [rule_format] : "ALL m. ~ defOp (m /?'' 0'')"

divide_Pos_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL r. X_n >'' 0'' --> m /?'' X_n = Some r = (m = r *'' X_n)"

div_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m div'' X_n) = (~ X_n = 0'')"

div_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m div'' X_n = Some r = (EX s. m = (X_n *'' r) +'' s & s <'' X_n)"

mod_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m mod'' X_n) = (~ X_n = 0'')"

mod_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL s.
 m mod'' X_n = Some s = (EX r. m = (X_n *'' r) +'' s & s <'' X_n)"

distr1_Nat [rule_format] :
"ALL r. ALL s. ALL t. (r +'' s) *'' t = (r *'' t) +'' (s *'' t)"

distr2_Nat [rule_format] :
"ALL r. ALL s. ALL t. t *'' (r +'' s) = (t *'' r) +'' (t *'' s)"

Pos_def [rule_format] : "ALL p. True = (p >'' 0'')"

X1_as_Pos_def [rule_format] : "1_3 = suc''(0'')"

min_0 [rule_format] : "ALL m. min''(m, 0'') = 0''"

div_mod_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ~ X_n = 0'' -->
 Some m =
 (case case m div'' X_n of
       None => None |
       Some Xc2 => Some (Xc2 *'' X_n) of
  None => None |
  Some Xc0 =>
  (case m mod'' X_n of
   None => None |
   Some Xc1 => Some (Xc0 +'' Xc1)))"

power_Nat [rule_format] :
"ALL m. ALL r. ALL s. m ^'' (r +'' s) = (m ^'' r) *'' (m ^'' s)"

equality_Int [rule_format] :
"ALL a.
 ALL b. ALL c. ALL d. a -'' b = c -'' d = (a +'' d = c +'' b)"

NatToInt [rule_format] : "ALL a. NatToInt a = a -'' 0''"

IntToNat [rule_format] :
"ALL a. ALL b. IntToNat (a -'' b) = a -! b"

ga_comm___XPlus___1 [rule_format] : "ALL x. ALL y. x +' y = y +' x"

ga_assoc___XPlus___1 [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) +' z = x +' (y +' z)"

ga_right_unit___XPlus___1 [rule_format] : "ALL x. x +' 0' = x"

ga_left_unit___XPlus___1 [rule_format] : "ALL x. 0' +' x = x"

ga_left_comm___XPlus___1 [rule_format] :
"ALL x. ALL y. ALL z. x +' (y +' z) = y +' (x +' z)"

ga_comm___Xx___1 [rule_format] : "ALL x. ALL y. x *' y = y *' x"

ga_assoc___Xx___1 [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx___1 [rule_format] : "ALL x. x *' 1' = x"

ga_left_unit___Xx___1 [rule_format] : "ALL x. 1' *' x = x"

ga_left_comm___Xx___1 [rule_format] :
"ALL x. ALL y. ALL z. x *' (y *' z) = y *' (x *' z)"

ga_comm_min_1 [rule_format] :
"ALL x. ALL y. min'(x, y) = min'(y, x)"

ga_comm_max_1 [rule_format] :
"ALL x. ALL y. max'(x, y) = max'(y, x)"

ga_assoc_min_1 [rule_format] :
"ALL x. ALL y. ALL z. min'(min'(x, y), z) = min'(x, min'(y, z))"

ga_assoc_max_1 [rule_format] :
"ALL x. ALL y. ALL z. max'(max'(x, y), z) = max'(x, max'(y, z))"

ga_left_comm_min_1 [rule_format] :
"ALL x. ALL y. ALL z. min'(x, min'(y, z)) = min'(y, min'(x, z))"

ga_left_comm_max_1 [rule_format] :
"ALL x. ALL y. ALL z. max'(x, max'(y, z)) = max'(y, max'(x, z))"

leq_def_Int [rule_format] : "ALL m. ALL X_n. (m <=' X_n) = True"

geq_def_Int [rule_format] :
"ALL m. ALL X_n. (m >=' X_n) = (X_n <=' m)"

less_def_Int [rule_format] :
"ALL m. ALL X_n. (m <' X_n) = (m <=' X_n & ~ m = X_n)"

greater_def_Int [rule_format] :
"ALL m. ALL X_n. (m >' X_n) = (X_n <' m)"

even_def_Int [rule_format] : "ALL m. even'(m) = even''(abs'(m))"

odd_def_Int [rule_format] : "ALL m. odd'(m) = (~ even'(m))"

odd_alt_Int [rule_format] : "ALL m. odd'(m) = odd''(abs'(m))"

neg_def_Int [rule_format] : "ALL a. ALL b. -' (a -'' b) = b -'' a"

sign_def_Int [rule_format] :
"ALL m.
 sign(m) = (if m = 0' then 0' else if m >' 0' then 1' else -' 1')"

abs_def_Int [rule_format] :
"ALL m. abs'(m) = (if m <' 0' then IntToNat -' m else IntToNat m)"

add_def_Int [rule_format] :
"ALL a.
 ALL b.
 ALL c. ALL d. (a -'' b) +' (c -'' d) = (a +'' c) -'' (b +'' d)"

mult_def_Int [rule_format] :
"ALL a.
 ALL b.
 ALL c.
 ALL d.
 (a -'' b) *' (c -'' d) =
 ((a *'' c) +'' (b *'' d)) -'' ((b *'' c) +'' (a *'' d))"

sub_def_Int [rule_format] :
"ALL m. ALL X_n. m -' X_n = m +' -' X_n"

min_def_Int [rule_format] :
"ALL m. ALL X_n. min'(m, X_n) = (if m <=' X_n then m else X_n)"

max_def_Int [rule_format] :
"ALL m. ALL X_n. max'(m, X_n) = (if m <=' X_n then X_n else m)"

power_neg1_Int [rule_format] :
"ALL a. -' 1' ^' a = (if even''(a) then 1' else -' 1')"

power_others_Int [rule_format] :
"ALL m.
 ALL a.
 ~ m = -' 1' --> m ^' a = (sign(m) ^' a) *' (NatToInt abs'(m) ^' a)"

divide_dom2_Int [rule_format] :
"ALL m. ALL X_n. defOp (m /?' X_n) = (m mod' X_n = Some 0'')"

divide_alt_Int [rule_format] :
"ALL m.
 ALL X_n. ALL r. m /?' X_n = Some r = (~ X_n = 0' & X_n *' r = m)"

divide_Int [rule_format] :
"ALL m.
 ALL X_n.
 m /?' X_n =
 (case NatToInt abs'(m) /?' NatToInt abs'(X_n) of
  None => None |
  Some Xc0 => Some ((sign(m) *' sign(X_n)) *' Xc0))"

div_dom_Int [rule_format] :
"ALL m. ALL X_n. defOp (m div' X_n) = (~ X_n = 0')"

div_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m div' X_n = Some r =
 (EX a. m = (X_n *' r) +' NatToInt a & a <'' abs'(X_n))"

quot_dom_Int [rule_format] :
"ALL m. ALL X_n. defOp (m quot X_n) = (~ X_n = 0')"

quot_neg_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m <' 0' -->
 m quot X_n = Some r =
 (EX s.
  m = (X_n *' r) +' s & 0' >=' s & s >' -' NatToInt abs'(X_n))"

quot_nonneg_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m >=' 0' -->
 m quot X_n = Some r =
 (EX s. m = (X_n *' r) +' s & 0' <=' s & s <' NatToInt abs'(X_n))"

rem_dom_Int [rule_format] :
"ALL m. ALL X_n. defOp (m rem X_n) = (~ X_n = 0')"

quot_rem_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL s.
 m <' 0' -->
 m rem X_n = Some s =
 (EX r.
  m = (X_n *' r) +' s & 0' >=' s & s >' -' NatToInt abs'(X_n))"

rem_nonneg_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL s.
 m >=' 0' -->
 m rem X_n = Some s =
 (EX r. m = (X_n *' r) +' s & 0' <=' s & s <' NatToInt abs'(X_n))"

mod_dom_Int [rule_format] :
"ALL m. ALL X_n. defOp (m mod' X_n) = (~ X_n = 0')"

mod_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL a.
 m mod' X_n = Some a =
 (EX r. m = (X_n *' r) +' NatToInt a & a <'' abs'(X_n))"

distr1_Int [rule_format] :
"ALL r. ALL s. ALL t. (r +' s) *' t = (r *' t) +' (s *' t)"

distr2_Int [rule_format] :
"ALL r. ALL s. ALL t. t *' (r +' s) = (t *' r) +' (t *' s)"

Int_Nat_sub_compat [rule_format] :
"ALL a.
 ALL b. defOp (a -? b) --> a -? b = Some (IntToNat (a -'' b))"

abs_decomp_Int [rule_format] :
"ALL m. m = sign(m) *' NatToInt abs'(m)"

mod_abs_Int [rule_format] :
"ALL m. ALL X_n. m mod' X_n = m mod' NatToInt abs'(X_n)"

div_mod_Int [rule_format] :
"ALL m.
 ALL X_n.
 ~ X_n = 0' -->
 Some m =
 (case case m div' X_n of
       None => None |
       Some Xc3 => Some (Xc3 *' X_n) of
  None => None |
  Some Xc0 =>
  (case case m mod' X_n of
        None => None |
        Some Xc2 => Some (NatToInt Xc2) of
   None => None |
   Some Xc1 => Some (Xc0 +' Xc1)))"

quot_abs_Int [rule_format] :
"ALL m.
 ALL X_n.
 (case case m quot X_n of
       None => None |
       Some Xc1 => Some (abs'(Xc1)) of
  None => None |
  Some Xc0 => Some (NatToInt Xc0)) =
 NatToInt abs'(m) quot NatToInt abs'(X_n)"

rem_abs_Int [rule_format] :
"ALL m.
 ALL X_n.
 (case case m rem X_n of
       None => None |
       Some Xc1 => Some (abs'(Xc1)) of
  None => None |
  Some Xc0 => Some (NatToInt Xc0)) =
 NatToInt abs'(m) rem NatToInt abs'(X_n)"

quot_rem_Int_1 [rule_format] :
"ALL m.
 ALL X_n.
 ~ X_n = 0' -->
 Some m =
 (case case m quot X_n of
       None => None |
       Some Xc2 => Some (Xc2 *' X_n) of
  None => None |
  Some Xc0 =>
  (case m rem X_n of
   None => None |
   Some Xc1 => Some (Xc0 +' Xc1)))"

power_Int [rule_format] :
"ALL m. ALL a. ALL b. m ^' (a +'' b) = (m ^' a) *' (m ^' b)"

IIN04 [rule_format] : "ALL x. negate(x) = 0' -' x"

IIN05 [rule_format] :
"ALL x. abs''(x) = (if x <' 0' then -' x else x)"

IIN06 [rule_format] :
"ALL x.
 signum(x) = (if x = 0' then 0' else if x >' 0' then 1' else -' 1')"

IIN07 [rule_format] : "ALL x. fromInteger(x) = x"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare EqualReflex [simp]
declare IBE1 [simp]
declare IBE2 [simp]
declare IBE3 [simp]
declare IBE4 [simp]
declare IBE5 [simp]
declare IBE6 [simp]
declare IBE7 [simp]
declare IBE8 [simp]
declare ga_selector_pre [simp]
declare ga_selector_undef_pre_0 [simp]
declare ga_comm___XPlus__ [simp]
declare ga_assoc___XPlus__ [simp]
declare ga_right_unit___XPlus__ [simp]
declare ga_left_unit___XPlus__ [simp]
declare ga_left_comm___XPlus__ [simp]
declare ga_comm___Xx__ [simp]
declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare ga_left_comm___Xx__ [simp]
declare ga_comm_min [simp]
declare ga_assoc_min [simp]
declare ga_left_comm_min [simp]
declare ga_comm_max [simp]
declare ga_assoc_max [simp]
declare ga_right_unit_max [simp]
declare ga_left_unit_max [simp]
declare ga_left_comm_max [simp]
declare leq_def1_Nat [simp]
declare leq_def2_Nat [simp]
declare leq_def3_Nat [simp]
declare even_0_Nat [simp]
declare even_suc_Nat [simp]
declare factorial_0 [simp]
declare add_0_Nat [simp]
declare mult_0_Nat [simp]
declare power_0_Nat [simp]
declare subTotal_def1_Nat [simp]
declare subTotal_def2_Nat [simp]
declare sub_dom_Nat [simp]
declare divide_0_Nat [simp]
declare min_0 [simp]
declare IntToNat [simp]
declare ga_comm___XPlus___1 [simp]
declare ga_assoc___XPlus___1 [simp]
declare ga_right_unit___XPlus___1 [simp]
declare ga_left_unit___XPlus___1 [simp]
declare ga_left_comm___XPlus___1 [simp]
declare ga_comm___Xx___1 [simp]
declare ga_assoc___Xx___1 [simp]
declare ga_right_unit___Xx___1 [simp]
declare ga_left_unit___Xx___1 [simp]
declare ga_left_comm___Xx___1 [simp]
declare ga_comm_min_1 [simp]
declare ga_comm_max_1 [simp]
declare ga_assoc_min_1 [simp]
declare ga_assoc_max_1 [simp]
declare ga_left_comm_min_1 [simp]
declare ga_left_comm_max_1 [simp]
declare leq_def_Int [simp]
declare neg_def_Int [simp]
declare IIN07 [simp]

theorem AbsSigRule : "ALL x. abs''(x) *' signum(x) = x"
apply(auto)
apply(simp add: IIN05 IIN06)

ML "Header.record \"AbsSigRule\""

end


theory VecSum
imports
  TwoSum
begin

subsection \<open>Implementation\<close>

fun itVecSum :: "float list \<Rightarrow> float list \<Rightarrow> float list" where
  "itVecSum [] hs = rev hs" |
  "itVecSum [a] hs = a # rev hs" |
  "itVecSum (a1 # a2 # as) hs = (let
    (s, e) = twoSum (a2, a1)
    in itVecSum (s # as) (e # hs))"

fun vecSum :: "float list \<Rightarrow> float list" where
  "vecSum mpf = itVecSum mpf []"

subsection \<open>Properties\<close>

lemma itVecSum_correct1:
  --\<open>listsum is not available due to missing monoid properties of fadd\<close>
  shows "hd (itVecSum (a # as) bs) = fold op+ as a"
  apply (induction as arbitrary: a bs)
  apply (simp_all add: twoSum_correct1_eq split_def del: twoSum.simps)
  done

lemma vecSum_correct1_eq:
  shows "hd (vecSum (a # as)) = fold op + as a"
  by (simp add: itVecSum_correct1)

corollary vecSum_correct1:
  assumes "Finite (fold op + as a)"
  shows "hd (vecSum (a # as)) \<doteq> fold op + as a"
  using assms float_eq vecSum_correct1_eq
  by presburger

lemma vecSum_correct2:
  assumes "list_all Finite mpf"
  assumes "list_all Finite (vecSum mpf)"
  shows "listsum (map Val (vecSum mpf)) = listsum (map Val mpf)"
  sorry

lemma vecSum_regular:
  assumes "list_all Finite a"
  assumes "list_all Finite (vecSum a)"
  assumes "length_ok a"
  shows "regular (vecSum a)"
  sorry

lemma length_cons: "length (itVecSum (a#as) b) = Suc (length as + length b)"
  apply (induction as arbitrary: a b)
  apply (simp_all split: prod.splits)
  done

lemma length_add: "length a + length b = length (itVecSum a b)"
  apply (induction a)
  apply (simp_all add: length_cons)
  done

end


section {* Concurrent programming *}

theory utp_concurrency
  imports "../hoare/Algebraic_Laws" utp_tactics
begin

text {* In parallel-by-merge constructions, a merge predicate defines the behaviour following execution of
        of parallel processes, P || Q, as a relation that merges the output of P and Q. In order to achieve
        this we need to separate the variable values output from P and Q, and in addition the variable values
        before execution. The following three constructs do these separations. *}

definition [upred_defs]: "left_uvar x = x ;\<^sub>L fst\<^sub>L ;\<^sub>L snd\<^sub>L"

definition [upred_defs]: "right_uvar x = x ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L"

definition [upred_defs]: "pre_uvar x = x ;\<^sub>L fst\<^sub>L"

lemma left_uvar_indep_right_uvar [simp]:
  "left_uvar x \<bowtie> right_uvar y"
  apply (simp add: left_uvar_def right_uvar_def lens_comp_assoc[THEN sym])
  apply (simp add: alpha_in_var alpha_out_var)
done

lemma right_uvar_indep_left_uvar [simp]:
  "right_uvar x \<bowtie> left_uvar y"
  by (simp add: lens_indep_sym)

lemma left_uvar [simp]: "vwb_lens x \<Longrightarrow> vwb_lens (left_uvar x)"
  by (simp add: left_uvar_def )

lemma right_uvar [simp]: "vwb_lens x \<Longrightarrow> vwb_lens (right_uvar x)"
  by (simp add: right_uvar_def)

syntax
  "_svarpre"   :: "svid \<Rightarrow> svid" ("_\<^sub><" [999] 999)
  "_svarleft"  :: "svid \<Rightarrow> svid" ("0-_" [999] 999)
  "_svarright" :: "svid \<Rightarrow> svid" ("1-_" [999] 999)

translations
  "_svarpre x" == "CONST pre_uvar x"
  "_svarleft x" == "CONST left_uvar x"
  "_svarright x" == "CONST right_uvar x"

type_synonym '\<alpha> merge = "('\<alpha> \<times> ('\<alpha> \<times> '\<alpha>), '\<alpha>) rel"

text {* U0 and U1 are relations that index all input variables x to 0-x and 1-x, respectively. *}

definition [upred_defs]: "U0 = ($0-\<Sigma>\<acute> =\<^sub>u $\<Sigma>)"

definition [upred_defs]: "U1 = ($1-\<Sigma>\<acute> =\<^sub>u $\<Sigma>)"

text {* As shown below, separating simulations can also be expressed using the following two alphabet extrusions *}

definition U0\<alpha> where [upred_defs]: "U0\<alpha> = (1\<^sub>L \<times>\<^sub>L out_var fst\<^sub>L)"

definition U1\<alpha> where [upred_defs]: "U1\<alpha> = (1\<^sub>L \<times>\<^sub>L out_var snd\<^sub>L)"

abbreviation U0_alpha_lift ("\<lceil>_\<rceil>\<^sub>0") where "\<lceil>P\<rceil>\<^sub>0 \<equiv> P \<oplus>\<^sub>p U0\<alpha>"

abbreviation U1_alpha_lift ("\<lceil>_\<rceil>\<^sub>1") where "\<lceil>P\<rceil>\<^sub>1 \<equiv> P \<oplus>\<^sub>p U1\<alpha>"

text {* We implement the following useful abbreviation for separating of two parallel processes and
  copying of the before variables, all to act as input to the merge predicate. *}

abbreviation par_sep (infixl "\<parallel>\<^sub>s" 85) where
"P \<parallel>\<^sub>s Q \<equiv> (P ;; U0) \<and> (Q ;; U1) \<and> $\<Sigma>\<^sub><\<acute> =\<^sub>u $\<Sigma>"

text {* The following implementation of parallel by merge is less general than the book version, in
  that it does not properly partition the alphabet into two disjoint segments. We could actually
  achieve this specifying lenses into the larger alphabet, but this would complicate the definition
  of programs. May reconsider later. *}

definition par_by_merge  ("_ \<parallel>\<^bsub>_\<^esub> _" [85,0,86] 85)
where [upred_defs]: "P \<parallel>\<^bsub>M\<^esub> Q = (P \<parallel>\<^sub>s Q ;; M)"

text {* nil is the merge predicate which ignores the output of both parallel predicates *}

definition [upred_defs]: "nil\<^sub>m = ($\<Sigma>\<acute> =\<^sub>u $\<Sigma>\<^sub><)"

text {* swap is a predicate that the swaps the left and right indices; it is used to specify commutativity of the parallel operator *}

-- {* TODO: There is an ambiguity below due to list assignment and tuples. *}

definition [upred_defs]: "swap\<^sub>m = (0-\<Sigma>,1-\<Sigma> :== &1-\<Sigma>,&0-\<Sigma>)"

lemma U0_swap: "(U0 ;; swap\<^sub>m) = U1"
  by (rel_auto)+

lemma U1_swap: "(U1 ;; swap\<^sub>m) = U0"
  by (rel_auto)

text {* We can equivalently express separating simulations using alphabet extrusion *}

lemma U0_as_alpha: "(P ;; U0) = \<lceil>P\<rceil>\<^sub>0"
  by (rel_auto)

lemma U1_as_alpha: "(P ;; U1) = \<lceil>P\<rceil>\<^sub>1"
  by (rel_auto)

lemma U0\<alpha>_vwb_lens [simp]: "vwb_lens U0\<alpha>"
  by (simp add: U0\<alpha>_def id_vwb_lens prod_vwb_lens)

lemma U1\<alpha>_vwb_lens [simp]: "vwb_lens U1\<alpha>"
  by (simp add: U1\<alpha>_def id_vwb_lens prod_vwb_lens)

lemma U0_alpha_out_var [alpha]: "\<lceil>$x\<acute>\<rceil>\<^sub>0 = $0-x\<acute>"
  by (rel_auto)

lemma U1_alpha_out_var [alpha]: "\<lceil>$x\<acute>\<rceil>\<^sub>1 = $1-x\<acute>"
  by (rel_auto)

lemma U0\<alpha>_comp_in_var [alpha]: "(in_var x) ;\<^sub>L U0\<alpha> = in_var x"
  by (simp add: U0\<alpha>_def alpha_in_var in_var_prod_lens pre_uvar_def)

lemma U0\<alpha>_comp_out_var [alpha]: "(out_var x) ;\<^sub>L U0\<alpha> = out_var (left_uvar x)"
  by (simp add: U0\<alpha>_def alpha_out_var id_wb_lens left_uvar_def out_var_prod_lens)

lemma U1\<alpha>_comp_in_var [alpha]: "(in_var x) ;\<^sub>L U1\<alpha> = in_var x"
  by (simp add: U1\<alpha>_def alpha_in_var in_var_prod_lens pre_uvar_def)

lemma U1\<alpha>_comp_out_var [alpha]: "(out_var x) ;\<^sub>L U1\<alpha> = out_var (right_uvar x)"
  by (simp add: U1\<alpha>_def alpha_out_var id_wb_lens right_uvar_def out_var_prod_lens)

lemma U0_seq_subst: "(P ;; U0)\<lbrakk>\<guillemotleft>v\<guillemotright>/$0-x\<acute>\<rbrakk> = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; U0)"
  by (rel_auto)

lemma U1_seq_subst: "(P ;; U1)\<lbrakk>\<guillemotleft>v\<guillemotright>/$1-x\<acute>\<rbrakk> = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; U1)"
  by (rel_auto)

lemma par_by_merge_false [simp]:
  "P \<parallel>\<^bsub>false\<^esub> Q = false"
  by (rel_auto)

lemma par_by_merge_left_false [simp]:
  "false \<parallel>\<^bsub>M\<^esub> Q = false"
  by (rel_auto)

lemma par_by_merge_right_false [simp]:
  "P \<parallel>\<^bsub>M\<^esub> false = false"
  by (rel_auto)

lemma par_by_merge_commute:
  assumes "(swap\<^sub>m ;; M) = M"
  shows "P \<parallel>\<^bsub>M\<^esub> Q = Q \<parallel>\<^bsub>M\<^esub> P"
proof -
  have "P \<parallel>\<^bsub>M\<^esub> Q = (((P ;; U0) \<and> (Q ;; U1) \<and> $\<Sigma>\<^sub><\<acute> =\<^sub>u $\<Sigma>) ;; M)"
    by (simp add: par_by_merge_def)
  also have "... = ((((P ;; U0) \<and> (Q ;; U1) \<and> $\<Sigma>\<^sub><\<acute> =\<^sub>u $\<Sigma>) ;; swap\<^sub>m) ;; M)"
    by (metis assms seqr_assoc)
  also have "... = (((P ;; U0 ;; swap\<^sub>m) \<and> (Q ;; U1 ;; swap\<^sub>m) \<and> $\<Sigma>\<^sub><\<acute> =\<^sub>u $\<Sigma>) ;; M)"
    by (rel_auto)
  also have "... = (((P ;; U1) \<and> (Q ;; U0) \<and> $\<Sigma>\<^sub><\<acute> =\<^sub>u $\<Sigma>) ;; M)"
    by (simp add: U0_swap U1_swap)
  also have "... = Q \<parallel>\<^bsub>M\<^esub> P"
    by (simp add: par_by_merge_def utp_pred.inf.left_commute)
  finally show ?thesis .
qed

lemma shEx_pbm_left: "((\<^bold>\<exists> x \<bullet> P x) \<parallel>\<^bsub>M\<^esub> Q) = (\<^bold>\<exists> x \<bullet> (P x \<parallel>\<^bsub>M\<^esub> Q))"
  by (rel_auto)

lemma shEx_pbm_right: "(P \<parallel>\<^bsub>M\<^esub> (\<^bold>\<exists> x \<bullet> Q x)) = (\<^bold>\<exists> x \<bullet> (P \<parallel>\<^bsub>M\<^esub> Q x))"
  by (rel_auto)

lemma par_by_merge_mono_1:
  assumes "P\<^sub>1 \<sqsubseteq> P\<^sub>2"
  shows "P\<^sub>1 \<parallel>\<^bsub>M\<^esub> Q \<sqsubseteq> P\<^sub>2 \<parallel>\<^bsub>M\<^esub> Q"
  using assms by (rel_auto)

lemma par_by_merge_mono_2:
  assumes "Q\<^sub>1 \<sqsubseteq> Q\<^sub>2"
  shows "(P \<parallel>\<^bsub>M\<^esub> Q\<^sub>1) \<sqsubseteq> (P \<parallel>\<^bsub>M\<^esub> Q\<^sub>2)"
  using assms by (rel_blast)

lemma zero_one_pbm_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 0) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>0/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>0/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>0/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 1) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>1/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>1/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>1/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 0) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>0/$x\<acute>\<rbrakk>\<^esub> Q)"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 1) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>1/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+

lemma numeral_pbm_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s numeral n) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>numeral n/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>numeral n/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>numeral n/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s numeral n) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>numeral n/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+
end


theory Convert_Monoid_SST_Type_Misc
  imports Main
          "../Core/Update" "../Core/SST" "../Core/Monoid_SST" "../Decomposition/Decompose_Update"
          "../Composition/Convert_Monoid_SST_Def"
          "../Type/Monoid_SST_Type"
begin

lemma resolve_shuffle_iota:
  "\<pi>\<^sub>1 (\<iota> B \<alpha> x) = \<alpha> x"
  unfolding \<iota>_def
  by (simp add: synthesize_inverse_shuffle)

lemma iota_alpha_type_hom:
  assumes "\<forall>x. \<alpha> x \<in> \<gamma> (q, x)"
  shows "\<pi>\<^sub>1 (hat_homU (\<iota> B \<alpha>) u) \<in> type_hom \<gamma> (q, u)"
proof (induct u rule: xa_induct)
  case Nil
  then show ?case by (simp add: resolve_idU_idS)
next
  case (Var x xs)
  then show ?case
    by (simp add: resolve_shuffle_distrib mult_shuffles_member resolve_shuffle_iota assms)
next
  case (Alpha a xs)
  then show ?case
    by (simp add: resolve_shuffle_distrib resolve_shuffle_map_alpha  mult_shuffles_member)
qed

lemma initial_condition_of_convert_MSST_state:
  fixes msst :: "('q, 'x, 'y::enum, 'a, 'b) MSST"
  fixes \<gamma> :: "('q, 'x, 'y) msst_type"
  assumes assm_is_type: "bctype k msst \<gamma>"
  shows "\<alpha>0 x \<in> \<gamma> (initial msst, x)"
  using assm_is_type by (simp add: bctype_idS \<alpha>0_def)

lemma step_condition_of_convert_MSST_state:
  fixes msst :: "('q, 'x, 'y::enum, 'a, 'b) MSST"
  fixes \<gamma> :: "('q, 'x, 'y) msst_type"
  fixes B :: "'k::enum boundedness"
  assumes assm_boundedness: "boundedness B k"
  assumes assm_bctype: "bctype k msst \<gamma>"
  assumes assm_prev:    "\<forall>x. Rep_alpha B \<beta>' x \<in> \<gamma> (q', x)"
  assumes assm_reachable: "reachable (convert_MSST B msst) (q', \<beta>')"
  assumes assm_states:  "(q, \<beta>) = delta (convert_MSST B msst) ((q', \<beta>'), a)"
  shows "Rep_alpha B \<beta> x \<in> \<gamma> (q, x)"
  using assm_states unfolding convert_MSST_def convert_\<delta>_def \<Delta>'_def
proof (simp)
  have q: "q = delta msst (q', a)"
    using assm_states unfolding convert_MSST_def convert_\<delta>_def by simp
  let ?hhU = "hat_homU (\<iota> B (Rep_alpha B \<beta>')) (SST.eta msst (q', a) x)"
  have "\<pi>\<^sub>1 ?hhU \<in> type_hom \<gamma> (q', SST.eta msst (q', a) x)"
    by (rule iota_alpha_type_hom, rule assm_prev)
  also have "... \<subseteq> \<gamma> (delta msst (q', a), x)"
    using assm_bctype by (simp add: bctype_step)
  finally have hhU_typed: "\<pi>\<^sub>1 ?hhU \<in> \<gamma> (delta msst (q', a), x)" .
  have "reachable msst (delta msst (q', a))" proof -
    have "reachable msst q'" using assm_reachable
      by (rule reachable_convert)
    then show ?thesis by (rule reachable_delta)
  qed
  then have hhU_bc: "bounded_shuffle k (\<pi>\<^sub>1 ?hhU)"
    using assm_bctype hhU_typed by (simp add: bctype_bounded)
  have "Rep_bc_shuffle (Abs_bc_shuffle (\<pi>\<^sub>1 ?hhU) :: ('k, 'y) bc_shuffle)
     = \<pi>\<^sub>1 ?hhU"
    using assm_boundedness hhU_bc
    unfolding boundedness_def
    by (auto simp add: Abs_bc_shuffle_inverse)
  also have "... \<in> type_hom \<gamma> (q', SST.eta msst (q', a) x)"
    by (rule iota_alpha_type_hom, rule assm_prev)
  also have "... \<subseteq> \<gamma> (delta msst (q', a), x)"
    using assm_bctype by (simp add: bctype_step)
  finally show "Rep_bc_shuffle (Abs_bc_shuffle (\<pi>\<^sub>1 ?hhU) :: ('k, 'y) bc_shuffle)
              \<in> \<gamma> (delta msst (q', a), x)" .
qed

lemma condition_of_convert_MSST_state:
  fixes msst :: "('q, 'x, 'y::enum, 'a, 'b) MSST"
  fixes \<gamma> :: "('q, 'x, 'y) msst_type"
  fixes B :: "'k::enum boundedness"
  assumes assm_bounded: "boundedness B k"
  assumes assm_bctype: "bctype k msst \<gamma>"
  assumes assm_states:  "(q, \<beta>) = delta_hat (convert_MSST B msst) (initial (convert_MSST B msst), w)"
  shows "Rep_alpha B \<beta> x \<in> \<gamma> (q, x)"
using assm_states proof (induct w arbitrary: q \<beta> x rule: rev_induct)
case Nil
  then show ?case
    using assms unfolding convert_MSST_def reachable_def
  proof (simp add: assms idS_bounded del: Rep_alpha.simps Abs_alpha.simps)
    show "\<alpha>0 x \<in> \<gamma> (initial msst, x)"
      using assm_bctype by (simp add: \<alpha>0_def bctype_idS)
  qed
next
  case (snoc a w)
  show ?case proof (rule step_condition_of_convert_MSST_state[OF assm_bounded assm_bctype])
    let ?st = "delta_hat (convert_MSST B msst) (initial (convert_MSST B msst), w)"
    show "\<forall>x. Rep_alpha B (snd ?st) x \<in> \<gamma> (fst ?st, x)"
      by (rule allI, rule snoc(1), simp)
    show "(q, \<beta>) = delta (convert_MSST B msst) ((fst ?st, snd ?st), a)"
      by (simp add: snoc.prems)
    show "reachable (convert_MSST B msst) (fst ?st, snd ?st)"
      by (auto simp add: reachable_def)
  qed
qed

lemma condition_of_convert_MSST_reachable_state:
  fixes msst :: "('q, 'x, 'y::enum, 'a, 'b) MSST"
  fixes \<gamma> :: "('q, 'x, 'y) msst_type"
  fixes B :: "'k::enum boundedness"
  assumes assm_bounded: "boundedness B k"
  assumes assm_bctype: "bctype k msst \<gamma>"
  assumes assm_reachable: "reachable (convert_MSST B msst) (q, \<beta>)"
  shows "Rep_alpha B \<beta> x \<in> \<gamma> (q, x)"
proof -
  obtain w where "(q, \<beta>) = delta_hat (convert_MSST B msst) (initial (convert_MSST B msst), w)"
    using assm_reachable by (auto simp add: reachable_def)
  then show ?thesis using condition_of_convert_MSST_state[OF assm_bounded assm_bctype] by simp
qed

lemma hat_homU_iota_bounded_copy_tail:
  fixes msst :: "('q, 'x, 'y::enum, 'a, 'b) MSST"
  fixes \<gamma> :: "('q, 'x, 'y) msst_type"
  fixes B :: "'k::enum boundedness"
  assumes assm_k_bounded: "boundedness B k"
  assumes assm_bctype: "bctype k msst \<gamma>"
  assumes assm_reachable: "reachable (convert_MSST B msst) (q, \<beta>)"
  assumes assm_tail: "u \<in> tails (SST.eta_hat msst (q, w) x)"
  shows "bounded k (hat_homU (\<iota> B (Rep_alpha B \<beta>)) u)"
proof -
  have reach: "reachable msst q" by (rule reachable_convert[OF assm_reachable])
  then have tail: "\<forall>m\<in>type_hom \<gamma> (q, u). bounded_shuffle k m"
    using assm_bctype assm_tail by (simp add: bctype_tails)
  have "\<pi>\<^sub>1 (hat_homU (\<iota> B (Rep_alpha B \<beta>)) u)
      \<in> type_hom \<gamma> (q, u)"
    apply (rule iota_alpha_type_hom[rule_format])
    apply (rule condition_of_convert_MSST_reachable_state[OF assms(1-3)])
    done
  then have "bounded_shuffle k (\<pi>\<^sub>1 (hat_homU (\<iota> B (Rep_alpha B \<beta>)) u))"
    using tail by simp
  then show "bounded k (hat_homU (\<iota> B (Rep_alpha B \<beta>)) u)"
    by (simp add: resolve_bounded_inverse)
qed

lemma hat_homU_iota_bounded_copy:
  fixes msst :: "('q, 'x, 'y::enum, 'a, 'b) MSST"
  fixes \<gamma> :: "('q, 'x, 'y) msst_type"
  fixes B :: "'k::enum boundedness"
  assumes assm_k_bounded: "boundedness B k"
  assumes assm_bctype: "bctype k msst \<gamma>"
  assumes assm_reachable: "reachable (convert_MSST B msst) (q, \<beta>)"
  shows "bounded k (hat_homU (\<iota> B (Rep_alpha B \<beta>)) (SST.eta_hat msst (q, w) x))"
  apply (rule hat_homU_iota_bounded_copy_tail[OF assms])
  apply (simp add: tails_def)
  apply (rule exI[where x="[]"])
  by simp

lemma resolve_shuffle_hat_homU_inverse:
  fixes msst :: "('q, 'x, 'y::enum, 'a, 'b) MSST"
  fixes \<gamma> :: "('q, 'x, 'y) msst_type"
  fixes B :: "'k::enum boundedness"
  assumes assm_k_bounded: "boundedness B k"
  assumes assm_bctype: "bctype k msst \<gamma>"
  assumes assm_reachable: "reachable (convert_MSST B msst) (q, \<beta>)"
  shows "Rep_bc_shuffle (Abs_bc_shuffle
          (\<pi>\<^sub>1 (hat_homU (\<iota> B (Rep_alpha B \<beta>)) (SST.eta_hat msst (q, w) x))) :: ('k, 'y) bc_shuffle)
       = \<pi>\<^sub>1 (hat_homU (\<iota> B (Rep_alpha B \<beta>)) (SST.eta_hat msst (q, w) x))"
  apply (rule Abs_bc_shuffle_inverse, simp)
  apply (subst assm_k_bounded[simplified boundedness_def, symmetric])
  apply (rule resolve_bounded)
  apply (rule hat_homU_iota_bounded_copy[OF assms])
  done
end


theory Basic_Contrasim_Game
imports
  Simple_Game
  Contrasimulation
begin

subsection \<open>The Basic Contrasimulation Preorder Game\<close>

datatype ('s, 'a) c_basic_game_node =
  AttackerNode 's 's |
  DefenderNode "'a list" 's 's

fun (in lts_tau) c_game_moves ::
  \<open>('s, 'a) c_basic_game_node \<Rightarrow> ('s, 'a) c_basic_game_node \<Rightarrow> bool\<close> where

  simulation_challenge:
   \<open>c_game_moves (AttackerNode p q) (DefenderNode A p1 q0) =
     (p \<Rightarrow>$A p1 \<and> q = q0 \<and> (\<forall>a\<in>set A. a \<noteq> \<tau>))\<close> |

  simulation_answer:
    \<open>c_game_moves (DefenderNode A p1 q0) (AttackerNode q1 p10) =
      (q0 \<Rightarrow>$A q1 \<and> p1 = p10)\<close> |

  c_game_moves_no_step:
    \<open>c_game_moves _ _ = False\<close>

fun c_game_defender_node :: \<open>('s, 'a) c_basic_game_node \<Rightarrow> bool\<close> where
  \<open>c_game_defender_node (AttackerNode _ _) = False\<close> |
  \<open>c_game_defender_node (DefenderNode _ _ _) = True\<close>

subsection \<open>Contrasimulation Implies Winning Strategy (Completeness)\<close>

locale c_basic_game =
  lts_tau trans \<tau> +
  simple_game c_game_moves c_game_defender_node
for
  trans :: \<open>'s \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool\<close> and
  \<tau> :: \<open>'a\<close> and
  initial :: \<open>('s, 'a) c_basic_game_node\<close>
begin

fun strategy_from_contrasim:: \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s, 'a) c_basic_game_node strategy\<close> where
  \<open>strategy_from_contrasim R ((DefenderNode A p1 q0)#play) =
    (AttackerNode (SOME q1 . R q1 p1 \<and> q0 \<Rightarrow>$A q1) p1)\<close> |
  \<open>strategy_from_contrasim _ _ = undefined\<close>

lemma basic_defender_pred_is_attacker:
  assumes
    \<open>c_game_defender_node n0\<close>
    \<open>n0 = DefenderNode A p' q\<close>
    \<open>(n0#play) \<in> plays initial\<close>
    \<open>initial = AttackerNode p0 q0\<close>
  shows \<open>\<exists>p. (hd play) = AttackerNode p q \<and> c_game_moves (hd play) n0\<close>
proof -
  have \<open>n0 \<noteq> initial\<close> using assms (2, 4) by auto
  hence mov: \<open>c_game_moves (hd play) n0\<close> using assms(3)
    by (metis list.inject list.sel(1) plays.cases)
  hence \<open>\<exists>p. (hd play) = AttackerNode p q\<close> using assms(1 - 3)
    by (metis c_basic_game_node.inject(2) c_game_defender_node.simps(1) c_game_moves.elims(2))
  thus ?thesis using mov by auto
qed

lemma second_elem_in_play_set :
  assumes
    \<open>(n0#play) \<in> plays initial\<close>
    \<open>initial = AttackerNode p0 q0\<close>
    \<open>n0 = DefenderNode A p q\<close>
  shows \<open>hd play \<in> set (n0 # play)\<close>
proof -
  from assms(2, 3) have \<open>n0 \<noteq> initial\<close> by auto
  hence \<open>play \<in> plays initial\<close> using assms(1) plays.cases no_empty_plays by blast
  hence play_split: \<open>\<exists>x xs. play = x#xs\<close> using no_empty_plays
    using plays.cases by blast
  then obtain x where x_def: \<open>\<exists>xs. play = x#xs\<close> ..
  have x_in_set: \<open>x \<in> set (n0#play)\<close> using x_def by auto
  have \<open>x = hd play\<close> using x_def by auto
  with x_in_set show \<open>hd play \<in> set (n0 # play)\<close> by auto
qed

lemma basic_game_all_f_consistent_atk_pos_in_R:
  assumes
    \<open>contrasimulation R\<close>
    \<open>R p0 q0\<close>
    \<open>initial = AttackerNode p0 q0\<close>
    \<open>play \<in> plays_for_0strategy (strategy_from_contrasim R) initial\<close>
shows \<open>((AttackerNode p q) \<in> set play) \<Longrightarrow> R p q\<close>
  using assms(4)
proof (induct arbitrary: p q rule: plays_for_0strategy.induct[OF assms(4)])
  case 1
  fix p q
  assume  \<open>(AttackerNode p q) \<in> (set [initial])\<close>
  thus \<open>R p q\<close> using assms(3, 2) by simp
next
  case p0moved: (2 n0 play)
  hence IH:\<open>AttackerNode p q \<in> set (n0#play) \<Longrightarrow> R p q\<close> by simp
  from p0moved.prems have \<open>(AttackerNode p q) \<in> set ((strategy_from_contrasim R (n0 # play))#n0#play)\<close>
    by simp
  hence \<open>(AttackerNode p q = (strategy_from_contrasim R (n0 # play))) \<or> (AttackerNode p q \<in> set (n0#play))\<close>
    by simp
  thus \<open>R p q\<close>
  proof (rule disjE)
     assume \<open>AttackerNode p q \<in> set (n0#play)\<close>
     thus \<open>R p q\<close> using IH by simp
   next
     assume A: \<open>AttackerNode p q = (strategy_from_contrasim R (n0 # play))\<close>
     have \<open>\<exists>A ppred. n0 = (DefenderNode A q ppred)\<close> using p0moved.hyps(3)
       strategy_from_contrasim.simps(1)[of \<open>R\<close>]
       by (metis (no_types, lifting) A c_basic_game_node.inject(1) c_game_defender_node.elims(2))
     then obtain A ppred where n0_def: \<open>n0 = (DefenderNode A q ppred)\<close> \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close>
       by (metis assms(3) c_basic_game.basic_defender_pred_is_attacker simulation_challenge p0moved.hyps(1, 3) strategy0_plays_subset)
     hence \<open>strategy_from_contrasim R (n0#play) = AttackerNode (SOME q1. R q1 q \<and> ppred \<Rightarrow>$ A  q1) q\<close>
       using n0_def strategy_from_contrasim.simps(1)[of \<open>R\<close> \<open>A\<close> \<open>q\<close> \<open>ppred\<close> \<open>play\<close>] by auto
     hence p_def: \<open>p = (SOME p1. R p1 q \<and> ppred \<Rightarrow>$ A p1)\<close> using A by auto
     have \<open>\<exists>qpred. hd play = (AttackerNode qpred ppred) \<and> c_game_moves (hd play) n0\<close>
       using basic_defender_pred_is_attacker strategy0_plays_subset[OF p0moved.hyps(1)]
       by (simp add: assms(3) n0_def  p0moved.hyps(3))
     then obtain qpred where qpred_def: \<open>hd play = (AttackerNode qpred ppred)\<close>
       and qpred_move: \<open>c_game_moves (hd play) n0\<close> by auto
     have qpred_q_move: \<open>qpred \<Rightarrow>$A q\<close> using qpred_def qpred_move n0_def by simp
     have \<open>hd play \<in> set (n0 # play)\<close>
       using second_elem_in_play_set strategy0_plays_subset[OF p0moved.hyps(1)] assms(3)
       by (auto simp add: n0_def)
     hence pred_R: \<open>R qpred ppred\<close>
       by (simp add: qpred_def p0moved.hyps(1) p0moved.hyps(2))
     have  \<open>\<exists> p1 . R p1 q \<and> ppred \<Rightarrow>$ A p1\<close>
      using qpred_q_move pred_R assms(1) \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close>
      unfolding contrasimulation_def by blast
    from someI_ex[OF this] show \<open>R p q\<close> unfolding p_def by blast
   qed
next
  case p1moved: (3 n1 play n1')
  from p1moved.hyps have IH:\<open>AttackerNode p q \<in> set (n1#play) \<Longrightarrow> R p q\<close> by simp
  assume  \<open>(AttackerNode p q) \<in> (set (n1'#n1#play))\<close>
  hence \<open>(AttackerNode p q = n1') \<or> (AttackerNode p q \<in> set (n1#play))\<close> by auto
  thus \<open>R p q\<close>
  proof (rule disjE)
    assume \<open>(AttackerNode p q \<in> set (n1#play))\<close>
    thus \<open>R p q\<close> using p1moved.hyps by auto
  next
   assume A: \<open>AttackerNode p q = n1'\<close>
   from p1moved.hyps have \<open>player1_position n1\<close> by simp
   hence \<open>c_game_defender_node n1'\<close>
     by (metis c_game_defender_node.simps(2) c_game_moves.elims(2) p1moved.hyps(4))
   hence \<open>False\<close> using A by auto
   thus \<open>R p q\<close> ..
 qed
qed

lemma basic_contrasim_game_complete:
  assumes
    \<open>contrasimulation R\<close>
    \<open>R p q\<close>
    \<open>initial = AttackerNode p q\<close>
  shows \<open>player0_winning_strategy (strategy_from_contrasim R) initial\<close>
    unfolding player0_winning_strategy_def

proof (safe)
  fix play
  assume A1: \<open>play \<in> plays_for_0strategy (strategy_from_contrasim R) initial\<close>
  thus \<open>player1_wins_immediately play \<Longrightarrow> False\<close>
    unfolding player1_wins_immediately_def
  proof -
    assume A: \<open>c_game_defender_node (hd play) \<and> (\<nexists>p'. c_game_moves (hd play) p')\<close>
    have player0_has_succ_node: \<open>c_game_defender_node (hd play) \<Longrightarrow> \<exists>p'. c_game_moves (hd play) p'\<close>
    proof (induct rule: simple_game.plays_for_0strategy.induct[OF A1])
      case init: 1
      from assms(3) have \<open>\<not>c_game_defender_node (hd [initial])\<close> by simp
      hence \<open>False\<close> using init.prems by simp
      then show ?case ..
    next
      case p0moved: (2 n0 play)
      from p0moved.hyps have \<open>c_game_defender_node n0\<close> by simp
      hence \<open>\<exists>A p1 q. n0 = (DefenderNode A p1 q)\<close>
        by (meson c_game_defender_node.elims(2))
      hence \<open>\<not>c_game_defender_node (strategy_from_contrasim R (n0#play))\<close>
        using p0moved.hyps(4) c_game_moves.elims(2)[of \<open>n0\<close> \<open>strategy_from_contrasim R (n0#play)\<close>]
        by force
      hence \<open>\<not>c_game_defender_node (hd (strategy_from_contrasim R (n0 # play) # n0 # play))\<close>
        by simp
      hence \<open>False\<close> using p0moved.prems ..
      then show ?case ..
    next
      case p1moved: (3 n1 play n1')
      hence \<open>\<not>c_game_defender_node n1\<close> using p1moved.hyps by simp
      then obtain p q where n1_def: \<open>n1 = AttackerNode p q\<close>
        using c_game_defender_node.elims(3) by auto
      hence pq_in_R: \<open>R p q\<close>
        using basic_game_all_f_consistent_atk_pos_in_R[OF assms, of \<open>n1#play\<close>, OF p1moved.hyps(1)]
        by auto
      have is_def: \<open>c_game_defender_node n1'\<close> using p1moved.prems by auto
      then obtain A p1 q0 where n1'_def: \<open>n1' = DefenderNode A p1 q0\<close>
        using c_game_defender_node.elims(2)[OF is_def] by auto
      hence \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> using p1moved.hyps(4) n1_def by simp
      have Move_n1_n1': \<open>c_game_moves (AttackerNode p q) (DefenderNode A p1 q0)\<close>
        using p1moved.hyps n1_def n1'_def by auto
      hence same_q: \<open>q0 = q\<close> by auto
      from Move_n1_n1' have p_succ: \<open>p \<Rightarrow>$A p1\<close> by auto
      from assms(1) have Contra: \<open>\<And>p q p' A. (\<forall>a\<in>set A. a \<noteq> \<tau>) \<Longrightarrow> R p q \<Longrightarrow> p \<Rightarrow>$ A  p' \<Longrightarrow> (\<exists>q'. q \<Rightarrow>$ A  q' \<and> R q' p')\<close>
        unfolding contrasimulation_def by auto
      hence \<open>\<exists> q'. (q \<Rightarrow>$ A q')\<and> R q' p1\<close> using Contra[OF \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> pq_in_R p_succ] by auto
      hence \<open>\<exists> p1 q1. c_game_moves n1' (AttackerNode p1 q1)\<close> using same_q n1'_def by auto
      then show ?case by auto
    qed
    thus \<open>False\<close> using A by auto
  qed
qed

subsection \<open>Winning Strategy Implies Contrasimulation (Soundness)\<close>

lemma strategy_from_contrasim_sound :
  assumes
    \<open>R p0 q0\<close>
    \<open>contrasimulation R\<close>
    \<open>initial = AttackerNode p0 q0\<close>
  shows
    \<open>sound_0strategy (strategy_from_contrasim R) initial\<close>
  unfolding sound_0strategy_def
proof (safe)
  fix n0 play
  assume A:
    \<open>n0 # play \<in> plays_for_0strategy (strategy_from_contrasim R) initial\<close>
    \<open>c_game_defender_node n0\<close>
  then obtain A p1 q where n0_def: \<open>n0 = DefenderNode A p1 q\<close>
    using c_game_defender_node.elims(2) by blast
  then obtain p where p_def: \<open>hd play = AttackerNode p q\<close>
    using n0_def A basic_defender_pred_is_attacker assms(3) strategy0_plays_subset by blast
  hence \<open>c_game_moves (AttackerNode p q) (DefenderNode A p1 q)\<close>
    using A n0_def by (metis assms(3) basic_defender_pred_is_attacker strategy0_plays_subset)
  hence mov_p_p1: \<open>p \<Rightarrow>$A p1\<close> \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> by auto
  from p_def have \<open>R p q\<close>
    using basic_game_all_f_consistent_atk_pos_in_R A assms
      second_elem_in_play_set n0_def strategy0_plays_subset
    by fastforce
  with mov_p_p1 have q1_def: \<open>\<exists>q1. R q1 p1 \<and> q \<Rightarrow>$A q1\<close>
    using assms(2) unfolding contrasimulation_def by blast
  from n0_def have \<open>strategy_from_contrasim R (n0 # play) = (AttackerNode (SOME q1 . R q1 p1 \<and> q \<Rightarrow>$A q1) p1)\<close>
    by auto
  then obtain q' where \<open>AttackerNode (SOME q1 . R q1 p1 \<and> q \<Rightarrow>$A q1) p1 = AttackerNode q' p1\<close> by blast
  hence q'_def: \<open>q' = (SOME q1 . R q1 p1 \<and> q \<Rightarrow>$A q1)\<close> by auto
  with someI_ex[OF q1_def] have \<open>R q' p1 \<and> q \<Rightarrow>$A q'\<close> by blast
  thus \<open>c_game_moves n0 (strategy_from_contrasim R (n0 # play))\<close> using q'_def by (simp add: n0_def)
qed

lemma basic_contrasim_game_sound:
  assumes
    \<open>player0_winning_strategy f initial\<close>
    \<open>sound_0strategy f initial\<close>
  defines
    \<open>R == \<lambda> p q . (\<exists> play \<in> plays_for_0strategy f initial. hd play = AttackerNode p q)\<close>
  shows
    \<open>contrasimulation R\<close>  unfolding contrasimulation_def
proof (safe)
  fix p q p1 A
  assume A1: \<open>p \<Rightarrow>$A p1\<close>
  assume A2: \<open>R p q\<close> \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close>
  hence \<open>\<exists> play . play \<in> plays_for_0strategy f initial \<and> hd play = AttackerNode p q\<close> using R_def by auto
  from this obtain play where play_def: \<open>play \<in> plays_for_0strategy f initial \<and> hd play = AttackerNode p q\<close> ..
  from assms(1) have \<open>\<not>player1_wins_immediately play\<close> using player0_winning_strategy_def play_def by auto
  hence \<open>(c_game_defender_node (hd play) \<and> (\<nexists>p'. c_game_moves (hd play) p')) \<Longrightarrow> False\<close>
    using player1_wins_immediately_def by auto
  hence Def_not_stuck: \<open>c_game_defender_node (hd play) \<Longrightarrow> (\<nexists>p'. c_game_moves (hd play) p') \<Longrightarrow> False\<close>
    by auto
  have \<open>(p \<Rightarrow>$A p1) \<Longrightarrow> (((DefenderNode A p1 q)#play) \<in> plays_for_0strategy f initial)\<close>
  proof -
    have \<open>\<exists>n0. n0 = DefenderNode A p1 q\<close> by auto
    from this obtain n0 where n0_def: \<open>n0 = DefenderNode A p1 q\<close> ..
    have play_split: \<open>play = (hd play)#(tl play)\<close>
      by (metis hd_Cons_tl play_def strategy0_plays_subset no_empty_plays)
    hence inF:\<open>(hd play)#(tl play) \<in> plays_for_0strategy f initial\<close> by (simp add: play_def)
    have pl1: \<open>player1_position (hd play)\<close> by (simp add: play_def)
    have mov0:\<open>c_game_moves (hd play) (DefenderNode A p1 q)\<close>
      using  \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> by (auto simp add: play_def A1)
    have \<open>(DefenderNode A p1 q)#(hd play)#(tl play) \<in> plays_for_0strategy f initial\<close>
      using plays_for_0strategy.p1move[OF inF pl1 mov0] .
    thus \<open>DefenderNode A p1 q#play \<in> plays_for_0strategy f initial\<close> by (simp add: sym[OF play_split])
  qed

  hence def_in_f: \<open>(DefenderNode A p1 q)#play \<in> plays_for_0strategy f initial\<close> by (simp add: A1)
  hence \<open>\<not>(player1_wins_immediately (DefenderNode A p1 q#play))\<close>
    using assms(1) player0_winning_strategy_def by auto
  hence \<open>\<exists>n1. c_game_moves (DefenderNode A p1 q) n1\<close> using player1_wins_immediately_def by auto
  have move_ex: \<open>c_game_moves (DefenderNode A p1 q) (f (DefenderNode A p1 q # play))\<close>
    using assms(2) def_in_f sound_0strategy_def by auto
  hence  in_f: \<open>f ((DefenderNode A p1 q) # play) # (DefenderNode A p1 q) # play \<in> plays_for_0strategy f initial\<close>
    using plays_for_0strategy.p0move[OF def_in_f] by auto
  obtain n1 where n1_def: \<open>n1 = f (DefenderNode A p1 q # play)\<close>
    and n1_move: \<open>c_game_moves (DefenderNode A p1 q) n1\<close> using move_ex by auto
  hence \<open>\<exists>q1. n1 = (AttackerNode q1 p1)\<close>
    using c_game_moves.elims(2)[of \<open>DefenderNode A p1 q\<close> n1] by auto
  from this obtain q1 where q1_def: \<open>n1 = (AttackerNode q1 p1)\<close> ..
  have \<open>c_game_moves (DefenderNode A p1 q) (AttackerNode q1 p1)\<close> using q1_def move_ex n1_def by auto
  hence q1_succ: \<open>q \<Rightarrow>$A q1\<close> using c_game_moves.simps(2) by auto
  have def: \<open>c_game_defender_node (DefenderNode A p1 q)\<close> by simp
  hence \<open>(AttackerNode q1 p1)#(DefenderNode A p1 q)#play \<in> plays_for_0strategy f initial\<close>
    using q1_def n1_def in_f by auto
  then obtain R_play where R_play_def: \<open>R_play = (AttackerNode q1 p1)#(DefenderNode A p1 q)#play\<close>
    and R_play_in_f: \<open>R_play \<in> plays_for_0strategy f initial\<close> by simp
  hence \<open>(hd R_play) = AttackerNode q1 p1\<close> by (simp add: R_play_def)
  hence \<open>R q1 p1\<close> unfolding R_def using R_play_in_f by auto
  thus \<open>R p q \<Longrightarrow> p \<Rightarrow>$ A  p1 \<Longrightarrow> \<exists>q1. q \<Rightarrow>$ A  q1 \<and> R q1 p1\<close> using q1_succ by auto
qed

theorem winning_strategy_in_basic_game_iff_contrasim:
  assumes
    \<open>initial = AttackerNode p q\<close>
  shows
    \<open>(\<exists> f . player0_winning_strategy f initial \<and> sound_0strategy f initial) = (\<exists> C. contrasimulation C \<and> C p q)\<close>
proof
  assume
    \<open>(\<exists>f. player0_winning_strategy f initial \<and> sound_0strategy f initial)\<close>
  then obtain f where
    \<open>contrasimulation (\<lambda>p q. \<exists>play\<in>plays_for_0strategy f initial. hd play = AttackerNode p q)\<close>
    using basic_contrasim_game_sound by blast
  moreover have \<open>(\<lambda>p q. \<exists>play\<in>plays_for_0strategy f initial. hd play = AttackerNode p q) p q\<close>
    using assms plays_for_0strategy.init[of _ f] by (meson list.sel(1))
  ultimately show \<open>\<exists> C. contrasimulation C \<and> C p q\<close> by blast
next
  assume
    \<open>\<exists> C. contrasimulation C \<and> C p q\<close>
  thus \<open>(\<exists>f. player0_winning_strategy f initial \<and> sound_0strategy f initial)\<close>
    using basic_contrasim_game_complete[OF _ _ assms]
         strategy_from_contrasim_sound[OF _ _ assms] by blast
qed

end
end


theory Relation
imports Signal
begin

definition dtyp :: "i \<Rightarrow> i" where
  "dtyp(R) == range(Union(domain(R)))"

definition rtyp :: "i \<Rightarrow> i" where
  "rtyp(R) == range(Union(range(R)))"

definition ddtyp :: "i \<Rightarrow> i" where
  "ddtyp(R) == domain(dtyp(R))"

definition rdtyp :: "i \<Rightarrow> i" where
  "rdtyp(R) == range(dtyp(R))"

definition rrtyp :: "i \<Rightarrow> i" where
  "rrtyp(R) == range(rtyp(R))"

definition drtyp :: "i \<Rightarrow> i" where
  "drtyp(R) == domain(rtyp(R))"

syntax
  "@rel" :: "[i, i] \<Rightarrow> i"  (\<open>(_~/_)\<close> [73, 72] 72)
  "@srel" :: "[i, i] \<Rightarrow> i" (\<open>(_<~>/_)\<close> [73, 72] 72)
translations
  "A~B" == "CONST Pow(A * B)"
  "A<~>B" == "sig(A)~sig(B)"

theorem rel_extension: "\<lbrakk> c:A; A:B~C; \<And> x y. \<lbrakk> <x, y> = c; <x,y>:A \<rbrakk> \<Longrightarrow>P \<rbrakk> \<Longrightarrow> P"
apply(blast)
done

theorem subset_rel: "\<lbrakk> \<And>x. x:A \<Longrightarrow> A:C~D; \<And>x y. \<lbrakk> <x, y>:A \<rbrakk> \<Longrightarrow> <x, y>:B \<rbrakk> \<Longrightarrow> A \<subseteq> B"
apply(blast)
done

theorem mem_rel_type: "\<lbrakk> <x, y>:R; R:A~B \<rbrakk> \<Longrightarrow> x:A & y:B"
apply(blast)
done

theorem mem_rel_dtype: "\<lbrakk> <x, y>:R; R:A~B \<rbrakk> \<Longrightarrow> x:A"
apply(blast)
done

theorem mem_rel_rtype: "\<lbrakk> <x, y>:R; R:A~B \<rbrakk> \<Longrightarrow> y:B"
apply(blast)
done

theorem dtyp_sig: "\<lbrakk> <x, y>:R; x:sig(A) \<rbrakk> \<Longrightarrow> x:sig(dtyp(R))"
apply(rule sig_sub_func, simp)
apply(frule apply_rangeI, simp)
apply(auto simp add: dtyp_def)
done

theorem rtyp_sig: "\<lbrakk> <x, y>:R; y:sig(A) \<rbrakk> \<Longrightarrow> y:sig(rtyp(R))"
apply(rule sig_sub_func, simp)
apply(frule apply_rangeI, simp)
apply(auto simp add: rtyp_def)
done

lemma range_sub: "A \<subseteq> B \<Longrightarrow> range(A) \<subseteq> range(B)"
apply(auto)
done

lemma domain_sub: "A \<subseteq> B \<Longrightarrow> domain(A) \<subseteq> domain(B)"
apply(auto)
done

lemma range_Union: "range(Union(sig(A))) \<subseteq> A"
apply(auto)
apply(drule range_type, simp+)
done

theorem dtyp_rel: "\<lbrakk> R \<subseteq> (sig(A))*(sig(B)); x:sig(dtyp(R)) \<rbrakk> \<Longrightarrow> x:sig(A)"
apply(rule sig_sub_func, simp)
apply(frule domain_rel_subset)
apply(simp add: dtyp_def)
apply(drule Union_mono) back
apply(drule range_sub) back
apply(insert range_Union[of A], drule subset_trans, simp)
apply(drule apply_funtype, simp)
apply(insert subsetD[of "range(\<Union>domain(R))"], simp)
done

theorem rtyp_rel: "\<lbrakk> R \<subseteq> (sig(A))*(sig(B)); x:sig(rtyp(R)) \<rbrakk> \<Longrightarrow> x:sig(B)"
apply(rule sig_sub_func, simp)
apply(frule range_rel_subset)
apply(simp add: rtyp_def)
apply(drule Union_mono) back
apply(drule range_sub) back
apply(insert range_Union[of B], drule subset_trans, simp)
apply(drule apply_funtype, simp)
apply(insert subsetD[of "range(\<Union>range(R))"], simp)
done

theorem sub_dtyp_rtyp: "R:A<~>B \<Longrightarrow> R:dtyp(R) <~> rtyp(R)"
apply(auto)
apply(drule subsetD, simp)
apply(auto)
apply(rule dtyp_sig, simp+)
apply(rule rtyp_sig, simp+)
done

theorem sub_dtyp_rtypI: "\<lbrakk> A:A2<~>B2; c:A \<rbrakk> \<Longrightarrow> c:(sig(dtyp(A)))*(sig(rtyp(A)))"
apply(auto)
apply(drule subsetD, simp)
apply(auto)
apply(rule dtyp_sig, simp+)
apply(rule rtyp_sig, simp+)
done

lemma domain_time_range_extension: "\<lbrakk> x: Sigma(A, B); x:R \<rbrakk> \<Longrightarrow> x:domain(R)*range(R)"
apply(auto)
done

theorem sub_ddtyp_rrtyp: "R:(A*B)<~>(C*E) \<Longrightarrow> R:ddtyp(R)*rdtyp(R)<~>drtyp(R)*rrtyp(R)"
apply(auto)
apply(frule PowI)
apply(erule rel_extension, simp)
apply(auto simp add: ddtyp_def rdtyp_def)
apply(frule mem_rel_dtype, simp)
apply(frule dtyp_sig, simp)
apply(rule sig_sub_func, simp)
apply(frule apply_funtype, simp)
apply(frule apply_funtype, simp) back
apply(rule domain_time_range_extension, simp+)
apply(auto simp add: drtyp_def rrtyp_def)
apply(frule mem_rel_rtype, simp)
apply(frule rtyp_sig, simp)
apply(rule sig_sub_func, simp)
apply(frule apply_funtype, simp)
apply(frule apply_funtype, simp) back
apply(rule domain_time_range_extension, simp+)
done

theorem ddtyp_rel: "\<lbrakk> x:sig(ddtyp(R)); R:A*B<~>C*E \<rbrakk> \<Longrightarrow> x:sig(A)"
apply(rule sig_sub_func, simp)
apply(drule apply_funtype, (simp add: ddtyp_def dtyp_def)+)
apply(frule domain_rel_subset)
apply(drule Union_mono) back
apply(drule range_sub) back
apply(insert range_Union[of "A*B"], drule subset_trans, simp)
apply(blast)
done

theorem rdtyp_rel: "\<lbrakk> x:sig(rdtyp(R)); R:A*B<~>C*E \<rbrakk> \<Longrightarrow> x:sig(B)"
apply(rule sig_sub_func, simp)
apply(drule apply_funtype, (simp add: rdtyp_def dtyp_def)+)
apply(frule domain_rel_subset)
apply(drule Union_mono) back
apply(drule range_sub) back
apply(insert range_Union[of "A*B"], drule subset_trans, simp)
apply(blast)
done

theorem rrtyp_rel: "\<lbrakk> x:sig(rrtyp(R)); R:A*B<~>C*E \<rbrakk> \<Longrightarrow> x:sig(E)"
apply(rule sig_sub_func, simp)
apply(drule apply_funtype, (simp add: rrtyp_def rtyp_def)+)
apply(frule range_rel_subset)
apply(drule Union_mono) back
apply(drule range_sub) back
apply(insert range_Union[of "C*E"], drule subset_trans, simp)
apply(blast)
done

theorem drtyp_rel: "\<lbrakk> x:sig(drtyp(R)); R:A*B<~>C*E \<rbrakk> \<Longrightarrow> x:sig(C)"
apply(rule sig_sub_func, simp)
apply(drule apply_funtype, (simp add: drtyp_def rtyp_def)+)
apply(frule range_rel_subset)
apply(drule Union_mono) back
apply(drule range_sub) back
apply(insert range_Union[of "C*E"], drule subset_trans, simp)
apply(blast)
done

lemma spair_type_weak: "<a#b>:sig({<a`t, b`t>. t:time})"
apply(auto simp add: spair_def)
apply(rule lam_funtype)
done

theorem ddtyp_sig: "\<lbrakk> x:sig(A); <<x#x2>, y>:R \<rbrakk> \<Longrightarrow> x:sig(ddtyp(R))"
apply(simp add: ddtyp_def)
apply(rule sig_sub_func, simp)
apply(insert spair_type_weak[of x x2])
apply(frule dtyp_sig, auto simp add: spair_def)
apply(drule apply_funtype, simp) back back
apply(auto)
done

theorem rdtyp_sig: "\<lbrakk> x:sig(A); <<x1#x>, y>:R \<rbrakk> \<Longrightarrow> x:sig(rdtyp(R))"
apply(simp add: rdtyp_def)
apply(rule sig_sub_func, simp)
apply(insert spair_type_weak[of x1 x])
apply(frule dtyp_sig, auto simp add: spair_def)
apply(drule apply_funtype, simp) back back
apply(auto)
done

theorem rrtyp_sig: "\<lbrakk> y:sig(A); <x, <y1#y>>:R \<rbrakk> \<Longrightarrow> y:sig(rrtyp(R))"
apply(simp add: rrtyp_def)
apply(rule sig_sub_func, simp)
apply(insert spair_type_weak[of y1 y])
apply(frule rtyp_sig, auto simp add: spair_def)
apply(drule apply_funtype, simp) back back
apply(auto)
done

theorem drtyp_sig: "\<lbrakk> y:sig(A); <x, <y#y2>>:R \<rbrakk> \<Longrightarrow> y:sig(drtyp(R))"
apply(simp add: drtyp_def)
apply(rule sig_sub_func, simp)
apply(insert spair_type_weak[of y y2])
apply(frule rtyp_sig, auto simp add: spair_def)
apply(drule apply_funtype, simp) back back
apply(auto)
done

theorem dddtyp_rel: "\<lbrakk> x:sig(domain(ddtyp(R))); R:(A*A1)*B<~>C*E \<rbrakk> \<Longrightarrow> x:sig(A)"
apply(rule sig_sub_func, simp)
apply(drule apply_funtype, (simp add: ddtyp_def dtyp_def)+)
apply(frule domain_rel_subset)
apply(drule Union_mono) back
apply(drule range_sub) back
apply(insert range_Union[of "(A*A1)*B"], drule subset_trans, simp)
apply(blast)
done

theorem rddtyp_rel: "\<lbrakk> x:sig(range(ddtyp(R))); R:(A1*A)*B<~>C*E \<rbrakk> \<Longrightarrow> x:sig(A)"
apply(rule sig_sub_func, simp)
apply(drule apply_funtype, (simp add: ddtyp_def dtyp_def)+)
apply(frule domain_rel_subset)
apply(drule Union_mono) back
apply(drule range_sub) back
apply(insert range_Union[of "(A1*A)*B"], drule subset_trans, simp)
apply(blast)
done

theorem drrtyp_rel: "\<lbrakk> x:sig(domain(rrtyp(R))); R:A*B<~>C*(E*E1) \<rbrakk> \<Longrightarrow> x:sig(E)"
apply(rule sig_sub_func, simp)
apply(drule apply_funtype, (simp add: rrtyp_def rtyp_def)+)
apply(frule range_rel_subset)
apply(drule Union_mono) back
apply(drule range_sub) back
apply(insert range_Union[of "C*(E*E1)"], drule subset_trans, simp)
apply(blast)
done

theorem dddtyp_sig: "\<lbrakk> x:sig(A); <<<x#x2>#x3>, y>:R \<rbrakk> \<Longrightarrow> x:sig(domain(ddtyp(R)))"
apply(simp add: ddtyp_def)
apply(rule sig_sub_func, simp)
apply(insert spair_type_weak[of "<x#x2>" x3])
apply(frule dtyp_sig, auto simp add: spair_def)
apply(drule apply_funtype, simp) back back
apply(auto)
done

theorem drrtyp_sig: "\<lbrakk> x:sig(A); <y, <x1#<x#x3>>>:R \<rbrakk> \<Longrightarrow> x:sig(domain(rrtyp(R)))"
apply(simp add: rrtyp_def)
apply(rule sig_sub_func, simp)
apply(insert spair_type_weak[of "x1" "<x#x3>"])
apply(frule rtyp_sig, auto simp add: spair_def)
apply(drule apply_funtype, simp) back back
apply(auto)
done

theorem rddtyp_sig: "\<lbrakk> x:sig(A); <<<x1#x>#x3>, y>:R \<rbrakk> \<Longrightarrow> x:sig(range(ddtyp(R)))"
apply(simp add: ddtyp_def)
apply(rule sig_sub_func, simp)
apply(insert spair_type_weak[of "<x1#x>" x3])
apply(frule dtyp_sig, auto simp add: spair_def)
apply(drule apply_funtype, simp) back back
apply(auto)
done

lemmas typ_sigs =
  rrtyp_sig ddtyp_sig drtyp_sig rdtyp_sig
  dddtyp_sig drrtyp_sig rddtyp_sig

lemmas typ_rels =
  rrtyp_rel ddtyp_rel drtyp_rel rdtyp_rel
  dddtyp_rel rddtyp_rel drrtyp_rel

end