(*  Title:       Category
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Category"

theory Category
imports Main "HOL-Library.FuncSet"
begin

  text \<open>
    This theory develops an ``object-free'' definition of category loosely following
    \<^cite>\<open>"AHS"\<close>, Sec. 3.52-3.53.
    We define the notion ``category'' in terms of axioms that concern a single
    partial binary operation on a type, some of whose elements are to be regarded
    as the ``arrows'' of the category.

    The nonstandard definition of category has some advantages and disadvantages.
    An advantage is that only one piece of data (the composition operation) is required
    to specify a category, so the use of records is not required to bundle up several
    separate objects.  A related advantage is the fact that functors and natural
    transformations can be defined simply to be functions that satisfy certain axioms,
    rather than more complex composite objects.
    One disadvantage is that the notions of ``object'' and ``identity arrow'' are
    conflated, though this is easy to get used to.  Perhaps a more significant disadvantage
    is that each arrow of a category must carry along the information about its domain
    and codomain. This implies, for example, that the arrows of a category of sets and
    functions cannot be directly identified with functions, but rather only with functions that
    have been equipped with their domain and codomain sets.

    To represent the partiality of the composition operation of a category, we assume that the
    composition for a category has a unique zero element, which we call \<open>null\<close>,
    and we consider arrows to be ``composable'' if and only if their composite is non-null.
    Functors and natural transformations are required to map arrows to arrows and be
    ``extensional'' in the sense that they map non-arrows to null.  This is so that
    equality of functors and natural transformations coincides with their extensional equality
    as functions in HOL.
    The fact that we co-opt an element of the arrow type to serve as \<open>null\<close> means that
    it is not possible to define a category whose arrows exhaust the elements of a given type.
    This presents a disadvantage in some situations.  For example, we cannot construct a
    discrete category whose arrows are directly identified with the set of \emph{all}
    elements of a given type @{typ 'a}; instead, we must pass to a larger type
    (such as @{typ "'a option"}) so that there is an element available for use as \<open>null\<close>.
    The presence of \<open>null\<close>, however, is crucial to our being able to define a
    system of introduction and elimination rules that can be applied automatically to establish
    that a given expression denotes an arrow.  Without \<open>null\<close>, we would be able to
    define an introduction rule to infer, say, that the composition of composable arrows
    is composable, but not an elimination rule to infer that arrows are composable from
    the fact that their composite is an arrow.  Having the ability to do both is critical
    to the usability of the theory.
\<close>

  section "Partial Magmas"

  text \<open>
    A \emph{partial magma} is a partial binary operation \<open>C\<close> defined on the set
    of elements at a type @{typ 'a}.  As discussed above,
    we assume the existence of a unique element \<open>null\<close> of type @{typ 'a}
    that is a zero for \<open>C\<close>, and we use \<open>null\<close> to represent ``undefined''.
    We think of the operation \<open>C\<close> as an operation of ``composition'', and
    we regard elements \<open>f\<close> and \<open>g\<close> of type @{typ 'a} as \emph{composable}
    if \<open>C g f \<noteq> null\<close>.
\<close>

  type_synonym 'a comp = "'a \<Rightarrow> 'a \<Rightarrow> 'a"

  locale partial_magma =
  fixes C :: "'a comp" (infixr "\<cdot>" 55)
  assumes ex_un_null: "\<exists>!n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
  begin

    definition null :: 'a
    where "null = (THE n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n)"

    lemma null_eqI:
    assumes "\<And>f. n \<cdot> f = n \<and> f \<cdot> n = n"
    shows "n = null"
      using assms null_def ex_un_null the1_equality [of "\<lambda>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"]
      by auto

    lemma comp_null [simp]:
    shows "null \<cdot> f = null" and "f \<cdot> null = null"
      using null_def ex_un_null theI' [of "\<lambda>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"]
      by auto

    text \<open>
      An \emph{identity} is a self-composable element \<open>a\<close> such that composition of
      any other element \<open>f\<close> with \<open>a\<close> on either the left or the right results in
      \<open>f\<close> whenever the composition is defined.
\<close>

    definition ide
    where "ide a \<equiv> a \<cdot> a \<noteq> null \<and>
                   (\<forall>f. (f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f) \<and> (a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f))"

    text \<open>
      A \emph{domain} of an element \<open>f\<close> is an identity \<open>a\<close> for which composition of
      \<open>f\<close> with \<open>a\<close> on the right is defined.
      The notion \emph{codomain} is defined similarly, using composition on the left.
      Note that, although these definitions are completely dual, the choice of terminology
      implies that we will think of composition as being written in traditional order,
      as opposed to diagram order.  It is pretty much essential to do it this way, to maintain
      compatibility with the notation for function application once we start working with
      functors and natural transformations.
\<close>

    definition domains
    where "domains f \<equiv> {a. ide a \<and> f \<cdot> a \<noteq> null}"

    definition codomains
    where "codomains f \<equiv> {b. ide b \<and> b \<cdot> f \<noteq> null}"

    lemma domains_null:
    shows "domains null = {}"
      by (simp add: domains_def)

    lemma codomains_null:
    shows "codomains null = {}"
      by (simp add: codomains_def)

    lemma self_domain_iff_ide:
    shows "a \<in> domains a \<longleftrightarrow> ide a"
      using ide_def domains_def by auto

    lemma self_codomain_iff_ide:
    shows "a \<in> codomains a \<longleftrightarrow> ide a"
      using ide_def codomains_def by auto

    text \<open>
      An element \<open>f\<close> is an \emph{arrow} if either it has a domain or it has a codomain.
      In an arbitrary partial magma it is possible for \<open>f\<close> to have one but not the other,
      but the \<open>category\<close> locale will include assumptions to rule this out.
\<close>

    definition arr
    where "arr f \<equiv> domains f \<noteq> {} \<or> codomains f \<noteq> {}"

    lemma not_arr_null [simp]:
    shows "\<not> arr null"
      by (simp add: arr_def domains_null codomains_null)

    text \<open>
      Using the notions of domain and codomain, we can define \emph{homs}.
      The predicate @{term "in_hom f a b"} expresses ``@{term f} is an arrow from @{term a}
      to @{term b},'' and the term @{term "hom a b"} denotes the set of all such arrows.
      It is convenient to have both of these, though passing back and forth sometimes involves
      extra work.  We choose @{term "in_hom"} as the more fundamental notion.
\<close>

    definition in_hom     ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
    where "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<equiv> a \<in> domains f \<and> b \<in> codomains f"

    abbreviation hom
    where "hom a b \<equiv> {f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>}"

    lemma arrI:
    assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
    shows "arr f"
      using assms arr_def in_hom_def by auto

    lemma ide_in_hom [intro]:
    shows "ide a \<longleftrightarrow> \<guillemotleft>a : a \<rightarrow> a\<guillemotright>"
      using self_domain_iff_ide self_codomain_iff_ide in_hom_def ide_def by fastforce

    text \<open>
      Arrows @{term "f"} @{term "g"} for which the composite @{term "g \<cdot> f"} is defined
      are \emph{sequential}.
\<close>

    abbreviation seq
    where "seq g f \<equiv> arr (g \<cdot> f)"

    lemma comp_arr_ide:
    assumes "ide a" and "seq f a"
    shows "f \<cdot> a = f"
      using assms ide_in_hom ide_def not_arr_null by metis

    lemma comp_ide_arr:
    assumes "ide b" and "seq b f"
    shows "b \<cdot> f = f"
      using assms ide_in_hom ide_def not_arr_null by metis

    text \<open>
      The \emph{domain} of an arrow @{term f} is an element chosen arbitrarily from the
      set of domains of @{term f} and the \emph{codomain} of @{term f} is an element chosen
      arbitrarily from the set of codomains.
\<close>

    definition dom
    where "dom f = (if domains f \<noteq> {} then (SOME a. a \<in> domains f) else null)"

    definition cod
    where "cod f = (if codomains f \<noteq> {} then (SOME b. b \<in> codomains f) else null)"

    lemma dom_null [simp]:
    shows "dom null = null"
      by (simp add: dom_def domains_null)

    lemma cod_null [simp]:
    shows "cod null = null"
      by (simp add: cod_def codomains_null)

    lemma dom_in_domains:
    assumes "domains f \<noteq> {}"
    shows "dom f \<in> domains f"
      using assms dom_def someI [of "\<lambda>a. a \<in> domains f"] by auto

    lemma cod_in_codomains:
    assumes "codomains f \<noteq> {}"
    shows "cod f \<in> codomains f"
      using assms cod_def someI [of "\<lambda>b. b \<in> codomains f"] by auto

  end

  section "Categories"

  text\<open>
    A \emph{category} is defined to be a partial magma whose composition satisfies an
    extensionality condition, an associativity condition, and the requirement that every
    arrow have both a domain and a codomain.
    The associativity condition involves four ``matching conditions''
    (\<open>match_1\<close>, \<open>match_2\<close>, \<open>match_3\<close>, and \<open>match_4\<close>)
    which constrain the domain of definition of the composition, and a fifth condition
    (\<open>comp_assoc'\<close>) which states that the results of the two ways of composing
    three elements are equal.  In the presence of the \<open>comp_assoc'\<close> axiom
    \<open>match_4\<close> can be derived from \<open>match_3\<close> and vice versa.
\<close>

  locale category = partial_magma +
  assumes ext: "g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
  and has_domain_iff_has_codomain: "domains f \<noteq> {} \<longleftrightarrow> codomains f \<noteq> {}"
  and match_1: "\<lbrakk> seq h g; seq (h \<cdot> g) f \<rbrakk> \<Longrightarrow> seq g f"
  and match_2: "\<lbrakk> seq h (g \<cdot> f); seq g f \<rbrakk> \<Longrightarrow> seq h g"
  and match_3: "\<lbrakk> seq g f; seq h g \<rbrakk> \<Longrightarrow> seq (h \<cdot> g) f"
  and comp_assoc': "\<lbrakk> seq g f; seq h g \<rbrakk> \<Longrightarrow> (h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
  begin

    text\<open>
      Associativity of composition holds unconditionally.  This was not the case in
      previous, weaker versions of this theory, and I did not notice this for some
      time after updating to the current axioms.  It is obviously an advantage that
      no additional hypotheses have to be verified in order to apply associativity,
      but a disadvantage is that this fact is now ``too readily applicable,''
      so that if it is made a default simplification it tends to get in the way of
      applying other simplifications that we would also like to be able to apply automatically.
      So, it now seems best not to make this fact a default simplification, but rather
      to invoke it explicitly where it is required.
\<close>

    lemma comp_assoc:
    shows "(h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
      by (metis comp_assoc' ex_un_null ext match_1 match_2)

    lemma match_4:
    assumes "seq g f" and "seq h g"
    shows "seq h (g \<cdot> f)"
      using assms match_3 comp_assoc by auto

    lemma domains_comp:
    assumes "seq g f"
    shows "domains (g \<cdot> f) = domains f"
    proof -
      have "domains (g \<cdot> f) = {a. ide a \<and> seq (g \<cdot> f) a}"
        using domains_def ext by auto
      also have "... = {a. ide a \<and> seq f a}"
        using assms ide_def match_1 match_3 by meson
      also have "... = domains f"
        using domains_def ext by auto
      finally show ?thesis by blast
    qed

    lemma codomains_comp:
    assumes "seq g f"
    shows "codomains (g \<cdot> f) = codomains g"
    proof -
      have "codomains (g \<cdot> f) = {b. ide b \<and> seq b (g \<cdot> f)}"
        using codomains_def ext by auto
      also have "... = {b. ide b \<and> seq b g}"
        using assms ide_def match_2 match_4 by meson
      also have "... = codomains g"
        using codomains_def ext by auto
      finally show ?thesis by blast
    qed

    lemma has_domain_iff_arr:
    shows "domains f \<noteq> {} \<longleftrightarrow> arr f"
      by (simp add: arr_def has_domain_iff_has_codomain)

    lemma has_codomain_iff_arr:
    shows "codomains f \<noteq> {} \<longleftrightarrow> arr f"
      using has_domain_iff_arr has_domain_iff_has_codomain by auto

    text\<open>
      A consequence of the category axioms is that domains and codomains, if they exist,
      are unique.
\<close>

    lemma domain_unique:
    assumes "a \<in> domains f" and "a' \<in> domains f"
    shows "a = a'"
    proof -
      have "ide a \<and> seq f a \<and> ide a' \<and> seq f a'"
        using assms domains_def ext by force
      thus ?thesis
        using match_1 ide_def not_arr_null by metis
    qed

    lemma codomain_unique:
    assumes "b \<in> codomains f" and "b' \<in> codomains f"
    shows "b = b'"
    proof -
      have "ide b \<and> seq b f \<and> ide b' \<and> seq b' f"
        using assms codomains_def ext by force
      thus ?thesis
        using match_2 ide_def not_arr_null by metis
    qed

    lemma domains_simp:
    assumes "arr f"
    shows "domains f = {dom f}"
      using assms dom_in_domains has_domain_iff_arr domain_unique by auto

    lemma codomains_simp:
    assumes "arr f"
    shows "codomains f = {cod f}"
      using assms cod_in_codomains has_codomain_iff_arr codomain_unique by auto

    lemma domains_char:
    shows "domains f = (if arr f then {dom f} else {})"
      using dom_in_domains has_domain_iff_arr domain_unique by auto

    lemma codomains_char:
    shows "codomains f = (if arr f then {cod f} else {})"
      using cod_in_codomains has_codomain_iff_arr codomain_unique by auto

    text\<open>
      A consequence of the following lemma is that the notion @{term "arr"} is redundant,
      given @{term "in_hom"}, @{term "dom"}, and @{term "cod"}.  However, I have retained it
      because I have not been able to find a set of usefully powerful simplification rules
      expressed only in terms of @{term "in_hom"} that does not result in looping in many
      situations.
\<close>

    lemma arr_iff_in_hom:
    shows "arr f \<longleftrightarrow> \<guillemotleft>f : dom f \<rightarrow> cod f\<guillemotright>"
      using cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr in_hom_def
      by auto

    lemma in_homI [intro]:
    assumes "arr f" and "dom f = a" and "cod f = b"
    shows "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
      using assms cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr
            in_hom_def
      by auto

    lemma in_homE [elim]:
    assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
    and "arr f \<Longrightarrow> dom f = a \<Longrightarrow> cod f = b \<Longrightarrow> T"
    shows "T"
     using assms in_hom_def domains_char codomains_char has_domain_iff_arr
     by (metis empty_iff singleton_iff)

    text\<open>
      To obtain the ``only if'' direction in the next two results and in similar results later
      for composition and the application of functors and natural transformations,
      is the reason for assuming the existence of @{term null} as a special element of the
      arrow type, as opposed to, say, using option types to represent partiality.
      The presence of @{term null} allows us not only to make the ``upward'' inference that
      the domain of an arrow is again an arrow, but also to make the ``downward'' inference
      that if @{term "dom f"} is an arrow then so is @{term f}.  Similarly, we will be able
      to infer not only that if @{term f} and @{term g} are composable arrows then
      @{term "C g f"} is an arrow, but also that if @{term "C g f"} is an arrow then
      \<open>f\<close> and \<open>g\<close> are composable arrows.  These inferences allow most necessary
      facts about what terms denote arrows to be deduced automatically from minimal
      assumptions.  Typically all that is required is to assume or establish that certain
      terms denote arrows in particular homs at the point where those terms are first
      introduced, and then similar facts about related terms can be derived automatically.
      Without this feature, nearly every proof would involve many tedious additional steps
      to establish that each of the terms appearing in the proof (including all its subterms)
      in fact denote arrows.
\<close>

    lemma arr_dom_iff_arr:
    shows "arr (dom f) \<longleftrightarrow> arr f"
      using dom_def dom_in_domains has_domain_iff_arr self_domain_iff_ide domains_def
      by fastforce

    lemma arr_cod_iff_arr:
    shows "arr (cod f) \<longleftrightarrow> arr f"
      using cod_def cod_in_codomains has_codomain_iff_arr self_codomain_iff_ide codomains_def
      by fastforce

    lemma arr_cod [simp]:
    assumes "arr f"
    shows "arr (cod f)"
      using assms arr_cod_iff_arr by simp

    lemma seqI [simp]:
    assumes "arr f" and "arr g" and "dom g = cod f"
    shows "seq g f"
    proof -
      have "ide (cod f) \<and> seq (cod f) f"
        using assms(1) has_codomain_iff_arr codomains_def cod_in_codomains ext by blast
      moreover have "ide (cod f) \<and> seq g (cod f)"
        using assms(2-3) domains_def domains_simp ext by fastforce
      ultimately show ?thesis
        using match_4 ide_def ext by metis
    qed

    text \<open>
      This version of \<open>seqI\<close> is useful as an introduction rule, but not as useful
      as a simplification, because it requires finding the intermediary term \<open>b\<close>.
      Sometimes \emph{auto} is able to do this, but other times it is more expedient
      just to invoke this rule and fill in the missing terms manually, especially
      when dealing with a chain of compositions.
    \<close>

    lemma seqI' [intro]:
    assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : b \<rightarrow> c\<guillemotright>"
    shows "seq g f"
      using assms by fastforce

    lemma compatible_iff_seq:
    shows "domains g \<inter> codomains f \<noteq> {} \<longleftrightarrow> seq g f"
    proof
      show "domains g \<inter> codomains f \<noteq> {} \<Longrightarrow> seq g f"
        using cod_in_codomains dom_in_domains empty_iff has_domain_iff_arr has_codomain_iff_arr
              domain_unique codomain_unique
        by (metis Int_emptyI seqI)
      show "seq g f \<Longrightarrow> domains g \<inter> codomains f \<noteq> {}"
      proof -
        assume gf: "seq g f"
        have 1: "cod f \<in> codomains f"
          using gf has_domain_iff_arr domains_comp cod_in_codomains codomains_simp by blast
        have "ide (cod f) \<and> seq (cod f) f"
          using 1 codomains_def ext by auto
        hence "seq g (cod f)"
          using gf has_domain_iff_arr match_2 domains_null ide_def by metis
        thus ?thesis
          using domains_def 1 codomains_def by auto
      qed
    qed

    text\<open>
      The following is another example of a crucial ``downward'' rule that would not be possible
      without a reserved @{term null} value.
\<close>

    lemma seqE [elim]:
    assumes "seq g f"
    and "arr f \<Longrightarrow> arr g \<Longrightarrow> dom g = cod f \<Longrightarrow> T"
    shows "T"
      using assms cod_in_codomains compatible_iff_seq has_domain_iff_arr has_codomain_iff_arr
            domains_comp codomains_comp domains_char codomain_unique
      by (metis Int_emptyI singletonD)

    lemma comp_in_homI [intro]:
    assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : b \<rightarrow> c\<guillemotright>"
    shows "\<guillemotleft>g \<cdot> f : a \<rightarrow> c\<guillemotright>"
    proof
      show 1: "seq g f" using assms compatible_iff_seq by blast
      show "dom (g \<cdot> f) = a"
        using assms 1 domains_comp domains_simp by blast
      show "cod (g \<cdot> f) = c"
        using assms 1 codomains_comp codomains_simp by blast
    qed

    lemma comp_in_homI' [simp]:
    assumes "arr f" and "arr g" and "dom f = a" and "cod g = c" and "dom g = cod f"
    shows "\<guillemotleft>g \<cdot> f : a \<rightarrow> c\<guillemotright>"
      using assms by auto

    lemma comp_in_homE [elim]:
    assumes "\<guillemotleft>g \<cdot> f : a \<rightarrow> c\<guillemotright>"
    obtains b where "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : b \<rightarrow> c\<guillemotright>"
      using assms in_hom_def domains_comp codomains_comp
      by (metis arrI in_homI seqE)

    text \<open>
      The next two rules are useful as simplifications, but they slow down the
      simplifier too much to use them by default.  So it is necessary to guess when
      they are needed and cite them explicitly.  This is usually not too difficult.
    \<close>

    lemma comp_arr_dom:
    assumes "arr f" and "dom f = a"
    shows "f \<cdot> a = f"
      using assms dom_in_domains has_domain_iff_arr domains_def ide_def by auto

    lemma comp_cod_arr:
    assumes "arr f" and "cod f = b"
    shows "b \<cdot> f = f"
      using assms cod_in_codomains has_codomain_iff_arr ide_def codomains_def by auto

    lemma ide_char:
    shows "ide a \<longleftrightarrow> arr a \<and> dom a = a \<and> cod a = a"
      using ide_in_hom by auto

    text \<open>
      In some contexts, this rule causes the simplifier to loop, but it is too useful
      not to have as a default simplification.  In cases where it is a problem, usually
      a method like \emph{blast} or \emph{force} will succeed if this rule is cited
      explicitly.
    \<close>

    lemma ideD [simp]:
    assumes "ide a"
    shows "arr a" and "dom a = a" and "cod a = a"
      using assms ide_char by auto

    lemma ide_dom [simp]:
    assumes "arr f"
    shows "ide (dom f)"
      using assms dom_in_domains has_domain_iff_arr domains_def by auto

    lemma ide_cod [simp]:
    assumes "arr f"
    shows "ide (cod f)"
      using assms cod_in_codomains has_codomain_iff_arr codomains_def by auto

    lemma dom_eqI:
    assumes "ide a" and "seq f a"
    shows "dom f = a"
      using assms cod_in_codomains codomain_unique ide_char
      by (metis seqE)

    lemma cod_eqI:
    assumes "ide b" and "seq b f"
    shows "cod f = b"
      using assms dom_in_domains domain_unique ide_char
      by (metis seqE)

    lemma dom_eqI':
    assumes "a \<in> domains f"
    shows "a = dom f"
      using assms dom_in_domains domain_unique by blast

    lemma cod_eqI':
    assumes "a \<in> codomains f"
    shows "a = cod f"
      using assms cod_in_codomains codomain_unique by blast

    lemma ide_char':
    shows "ide a \<longleftrightarrow> arr a \<and> (dom a = a \<or> cod a = a)"
      using ide_dom ide_cod ide_char by metis

    lemma dom_dom:
    shows "dom (dom f) = dom f"
      by (metis dom_null domains_char ideD(2) ide_dom dom_def)

    lemma cod_cod:
    shows "cod (cod f) = cod f"
      by (metis arr_cod_iff_arr cod_def has_codomain_iff_arr ideD(3) ide_cod)

    lemma dom_cod:
    shows "dom (cod f) = cod f"
      by (metis arr_cod_iff_arr cod_def has_codomain_iff_arr has_domain_iff_arr ideD(2)
          ide_cod dom_def)

    lemma dom_comp [simp]:
    assumes "seq g f"
    shows "dom (g \<cdot> f) = dom f"
      using assms by (simp add: dom_def domains_comp)

    lemma cod_comp [simp]:
    assumes "seq g f"
    shows "cod (g \<cdot> f) = cod g"
      using assms by (simp add: cod_def codomains_comp)

    lemma comp_ide_self [simp]:
    assumes "ide a"
    shows "a \<cdot> a = a"
      using assms comp_arr_ide arrI by auto

    lemma ide_compE [elim]:
    assumes "ide (g \<cdot> f)"
    and "seq g f \<Longrightarrow> seq f g \<Longrightarrow> g \<cdot> f = dom f \<Longrightarrow> g \<cdot> f = cod g \<Longrightarrow> T"
    shows "T"
      using assms dom_comp cod_comp ide_char ide_in_hom
      by (metis seqE seqI)

    text \<open>
      The next two results are sometimes useful for performing manipulations at the
      head of a chain of composed arrows.  I have adopted the convention that such
      chains are canonically represented in right-associated form.  This makes it
      easy to perform manipulations at the ``tail'' of a chain, but more difficult
      to perform them at the ``head''.  These results take care of the rote manipulations
      using associativity that are needed to either permute or combine arrows at the
      head of a chain.
\<close>

    lemma comp_permute:
    assumes "f \<cdot> g = k \<cdot> l" and "seq f g" and "seq g h"
    shows "f \<cdot> g \<cdot> h = k \<cdot> l \<cdot> h"
      using assms by (metis comp_assoc)

    lemma comp_reduce:
    assumes "f \<cdot> g = k" and "seq f g" and "seq g h"
    shows "f \<cdot> g \<cdot> h = k \<cdot> h"
      using assms comp_assoc by auto

    text\<open>
      Here we define some common configurations of arrows.
      These are defined as abbreviations, because we want all ``diagrammatic'' assumptions
      in a theorem to reduce readily to a conjunction of assertions of the basic forms
      @{term "arr f"}, @{term "dom f = X"}, @{term "cod f = Y"}, and @{term "in_hom f a b"}.
\<close>

    abbreviation endo
    where "endo f \<equiv> seq f f"

    abbreviation antipar
    where "antipar f g \<equiv> seq g f \<and> seq f g"

    abbreviation span
    where "span f g \<equiv> arr f \<and> arr g \<and> dom f = dom g"

    abbreviation cospan
    where "cospan f g \<equiv> arr f \<and> arr g \<and> cod f = cod g"

    abbreviation par
    where "par f g \<equiv> arr f \<and> arr g \<and> dom f = dom g \<and> cod f = cod g"

  end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_bin_nat_distrib
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs1) y = ZeroAnd (times xs1 y)"
| "times (OneAnd xs12) y = plus (ZeroAnd (times xs12 y)) y"

theorem property0 :
  "((times x (plus y z)) = (plus (times x y) (times x z)))"
  oops

end


theory IMP
  imports Main
begin

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n " |
"aval (V v) s = s v" |
"aval (Plus a b) s = aval a s + aval b s"

value "aval (Plus (N 3) (V y)) ((\<lambda>x. 0) (x:= 7))"

lemma
"[ \<forall>x y. T x y \<or> T y x;
\<forall> x y . A x y \<and> A y x −\<rightarrow> x = y ; \<forall>x y. T x y −\<rightarrow> A x y ]
\<Longrightarrow> \<forall>x y. A x y −\<rightarrow> T x y" by blast

(*
definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"
*)

print_statement append_eq_conv_conj

end


theory Searching_In_Lists
imports
  Main
begin

fun first_pos :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat" where
"first_pos _ Nil = 0" |
\<open>first_pos f (Cons x xs) = (if f x then 0 else 1 + first_pos f xs)\<close>

value "first_pos (\<lambda>x. x = (3 :: nat)) [1::nat, 3, 5, 3, 1]"
value "first_pos (\<lambda>x. x \<ge> 4) [1::nat, 3, 5, 7]"
value "first_pos (\<lambda>x. size x > 1) [[], [1::nat, 2], [3]]"

lemma "(first_pos P xs = size xs) = (\<forall> x \<in> set xs. \<not>(P x))"
  by(induct xs, auto)

lemma "list_all (\<lambda>x. \<not>P x) (take (first_pos P xs) xs)"
  by(induct xs, auto)

lemma "first_pos (\<lambda>x. P x \<or> Q x) xs = min (first_pos P xs) (first_pos Q xs)"
  by(induction xs, auto)

lemma "first_pos (\<lambda>x. P x \<and> Q x) xs \<ge> max (first_pos P xs) (first_pos Q xs)"
  by(induction xs, auto)

lemma
  assumes "\<forall>x. (P x \<longrightarrow> Q x)"
  shows "first_pos P xs < length xs \<longrightarrow> first_pos Q xs < length xs"
  using assms by (induction xs, auto)

fun count :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat" where
"count _ Nil = 0" |
"count f (Cons x xs) = (if f x then 1 else 0) + count f xs"

print_theorems

lemma count_concat_split: "count f (xs @ ys) = count f xs + count f ys"
  by(induct xs, auto)

lemma "count f xs = count f (rev xs)"
  by(induct xs, auto simp add: count_concat_split)

lemma "length (filter f xs) = count f xs"
  by(induct xs, auto)

end


(*
    Title:      Echelon_Form_Inverse_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Inverse matrices over principal ideal rings using immutable arrays\<close>

theory Echelon_Form_Inverse_IArrays
  imports
    Echelon_Form_Inverse
    Code_Cayley_Hamilton_IArrays
    Gauss_Jordan.Inverse_IArrays
begin

subsection\<open>Computing the inverse of matrices over rings using immutable arrays\<close>

definition "inverse_matrix_ring_iarray A = (let d=det_iarrays_rings A in
  if is_unit d then Some(1 div d *ssi adjugate_iarrays A) else None)"

lemma matrix_to_iarray_inverse:
  fixes A::"'a::{euclidean_ring_gcd}^'n::{mod_type}^'n::{mod_type}"
  shows"matrix_to_iarray_option (inverse_matrix A) = inverse_matrix_ring_iarray (matrix_to_iarray A)"
  unfolding inverse_matrix_ring_iarray_def inverse_matrix_code_rings matrix_to_iarray_option_def
  unfolding matrix_to_iarray_det_euclidean_ring matrix_to_iarray_adjugate
  by (simp add: matrix_to_iarray_adjugate matrix_to_iarray_scalar_matrix_mult Let_def)

end


theory Sets
  imports "../Algebra/PartialQuantales"
begin

section {* Resource Predicates *}

text {* A resource predicate is a set on a partial monoid. *}

text {* The powerset lifting of a partial semigroup form a quantale *}

instantiation "set" :: (partial_semigroup) near_quantale_pmult
begin
definition "P * Q \<equiv> {x * y | x y. x ## y \<and> x \<in> P \<and> y \<in> Q}"
definition "(P :: 'a set) ## Q \<equiv> True"
declare pmult_defined_set_def[simp]

lemma [simp]: "(P :: 'a set) * Q ## R"
  by (simp add: pmult_set_def)

instance
  apply (default, auto simp: pmult_set_def)
  apply (metis partial_semigroup_class.pmult_assoc partial_semigroup_class.pmult_def)
  by (metis partial_semigroup_class.pmult_assoc partial_semigroup_class.pmult_def)
end

instance "set" :: (partial_semigroup) pre_quantale_pmult
  by default (auto simp: pmult_set_def)

instance "set" :: (partial_semigroup) quantale_pmult
  by default (auto simp: pmult_set_def)

text {* Unit, commutativity and distributivity are also lifted. *}

instantiation "set" :: (partial_monoid) near_quantale_pmult_unital
begin
definition "1' \<equiv> {1'}"
instance
  by default (auto simp: pmult_set_def pmult_one_set_def pmult_oner pmult_onel)
end

instance "set" :: (partial_ab_semigroup) comm_quantale_pmult
  apply (default, auto simp: pmult_set_def)
  apply (metis pmult_ab_assoc pmult_def_eq)
  by (metis pmult_ab_assoc pmult_def_eq pmult_comm pmult_comm_def)+

instance "set" :: (partial_monoid) quantale_pmult_unital ..

instance "set" :: (partial_comm_monoid) comm_quantale_pmult_unital ..

instance "set" :: (partial_semigroup) distrib_quantale_pmult ..

instance "set" :: (partial_comm_monoid) distrib_comm_quantale_pmult_unital ..

end


theory Orders
imports Partial_Semigroups
begin

locale transitive  =
  fixes R :: "('a) rel"
  assumes trans_rel: "trans R"
begin
end

locale proset = transitive +
  assumes refl_rel:"refl_on (carrier R) R"
begin

abbreviation (input) "the_ordering \<equiv> R"

abbreviation leq  (infixr "\<preceq>" 40) where
 "leq x y \<equiv> (x, y) \<in> R"

lemma carrier_refl: "x \<in> carrier R \<longleftrightarrow> (x, x) \<in> R"
  apply (safe; clarsimp simp: carrier_def image_iff)
   apply (metis prod.collapse refl_onD refl_on_domain refl_rel)
  by (metis fst_conv)

end

locale poset = proset +
  assumes antisym: "x \<preceq> y \<Longrightarrow> y \<preceq> x \<Longrightarrow> x = y"

locale linset = poset +
  assumes complete: "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow>  x \<preceq> y \<or> y \<preceq> x"

locale semilattice = abel_semigroup + idemp_semigroup
begin

sublocale poset "{(x, y). x \<in> S \<and> y \<in> S \<and> times x y = y}"
  apply (standard)
    apply (rule transI; clarsimp)
  apply (metis assoc)
   apply (rule refl_onI; clarsimp simp: carrier_def)
    apply (intro conjI; clarsimp simp: image_iff)
    apply (blast)
    apply (intro conjI; clarsimp simp: image_iff)
    apply (elim disjE; clarsimp)
   apply (elim disjE; clarsimp simp: idemp)
  apply (clarsimp simp: idemp)
  using commute by force

lemma "S = carrier {(x, y). x \<in> S \<and> y \<in> S \<and> times x y = y}"
  apply (clarsimp simp: carrier_def total_on carrier_def, safe; clarsimp simp: image_iff)
  by (metis closed fst_conv idemp)+

notation leq  (infixr "\<preceq>" 40)

lemma le_join:  "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> x \<preceq> (times x y)"
  apply (clarsimp)
  by (simp add: assoc closed_times idemp)

lemma join_least:  " x \<preceq> z \<Longrightarrow> y \<preceq> z \<Longrightarrow> (times x y) \<preceq> z "
  apply (clarsimp)
  by (metis closed_times assoc)

end

locale lattice = join: pis _ lub +  semilattice _ lub _ + meet: pis _ glb + dual: semilattice _ glb _
  for  lub :: "'b \<Rightarrow> 'b \<Rightarrow> 'b" (infixl "\<squnion>" 70) and
       glb :: "'b \<Rightarrow> 'b \<Rightarrow> 'b" (infixl "\<sqinter>" 70) +
     assumes meet_join: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> glb x y = x \<longleftrightarrow> lub x y = y"

begin

lemma "leq y x \<Longrightarrow> z \<in> S \<Longrightarrow> dual.leq x (y \<sqinter> z)"
  apply (clarsimp)
  by (metis dual.assoc  dual.closed_times dual.commute meet_join)

end

interpretation set_lattice: lattice "UNIV \<times> UNIV" "UNIV" "(\<union>)" "(\<inter>)"
  apply (standard; (clarsimp intro!: refl_onI symI simp: carrier_def Un_commute Un_assoc)?)
        apply force+
       apply (rule refl_onI; clarsimp)
    apply force+
  done

lemma set_eqD: "S = S' \<Longrightarrow> \<forall>x. x \<in> S \<longleftrightarrow> x \<in> S'"
  by blast

lemma set_noteq_disj:"S \<noteq> S' \<Longrightarrow> (\<exists>x. x \<in> S' \<and> x \<notin> S) \<or> (\<exists>x. x \<notin> S' \<and> x \<in> S)"
  apply (blast)
  done

definition "restrict R S = R - (S \<times> UNIV)"

definition "project R S = R - (UNIV \<times> S)"

abbreviation (input) "to_rel f \<equiv> {(x, y). y = f x} "

lemma insert_ssubsetD: "x \<notin> F \<Longrightarrow> insert x F \<subset> R \<Longrightarrow> F \<subset> R - {x}"
  apply (safe; clarsimp)
  apply blast
  done

lemma project_iff:"(a, b) \<in> project R S \<longleftrightarrow> (a, b) \<in> R \<and> b \<notin> S"
  by (safe; clarsimp simp: project_def)

lemma restrict_iff:"(a, b) \<in> restrict R S \<longleftrightarrow> (a, b) \<in> R \<and> a \<notin> S"
  by (safe; clarsimp simp: restrict_def)

lemma project_insert: "x \<notin> F \<Longrightarrow> insert x F \<subset> snd ` R \<Longrightarrow> F \<subset> snd ` (project R {x}) "
  apply (frule (1) insert_ssubsetD)
  apply (erule psubset_subset_trans)
  apply (clarsimp simp: )
  apply (clarsimp simp:  image_iff Ball_def project_iff)
  apply blast
  done

end


subsection\<open>Schnorr \<open>\<Sigma>\<close>-protocol\<close>

text\<open>In this section we show the Schnoor protocol \<^cite>\<open>"DBLP:journals/joc/Schnorr91"\<close> is a \<open>\<Sigma>\<close>-protocol and then use it to construct a commitment scheme.
The security statements for the resulting commitment scheme come for free from our general proof of the construction.\<close>

theory Schnorr_Sigma_Commit imports
  Commitment_Schemes
  Sigma_Protocols
  Cyclic_Group_Ext
  Discrete_Log
  Number_Theory_Aux
  Uniform_Sampling
  "HOL-Number_Theory.Cong"
begin

locale schnorr_base =
  fixes \<G> :: "'grp cyclic_group" (structure)
  assumes prime_order: "prime (order \<G>)"
begin

lemma order_gt_0 [simp]: "order \<G> > 0"
  using prime_order prime_gt_0_nat by blast

text\<open>The types for the \<open>\<Sigma>\<close>-protocol.\<close>

type_synonym witness = "nat"
type_synonym rand = nat
type_synonym 'grp' msg = "'grp'"
type_synonym response = nat
type_synonym challenge = nat
type_synonym 'grp' pub_in = "'grp'"

definition R_DL :: "('grp pub_in \<times> witness) set"
  where "R_DL = {(h, w). h = \<^bold>g [^] w}"

definition init :: "'grp pub_in \<Rightarrow> witness \<Rightarrow> (rand \<times> 'grp msg) spmf"
  where "init h w = do {
    r \<leftarrow> sample_uniform (order \<G>);
    return_spmf (r, \<^bold>g [^] r)}"

lemma  lossless_init: "lossless_spmf (init h w)"
  by(simp add: init_def)

definition "response r w c = return_spmf ((w*c + r) mod (order \<G>))"

lemma lossless_response: "lossless_spmf (response r w c)"
  by(simp add: response_def)

definition G :: "('grp pub_in \<times> witness) spmf"
  where "G = do {
    w \<leftarrow> sample_uniform (order \<G>);
    return_spmf (\<^bold>g [^] w, w)}"

lemma lossless_G: "lossless_spmf G"
  by(simp add: G_def)

definition "challenge_space = {..< order \<G>}"

definition check :: "'grp pub_in \<Rightarrow> 'grp msg \<Rightarrow> challenge \<Rightarrow> response \<Rightarrow> bool"
  where "check h a e z = (a \<otimes> (h [^] e) = \<^bold>g [^] z \<and> a \<in> carrier \<G>)"

definition S2 :: "'grp \<Rightarrow> challenge \<Rightarrow> ('grp msg, response) sim_out spmf"
  where "S2 h e = do {
  c \<leftarrow> sample_uniform (order \<G>);
  let a = \<^bold>g [^] c \<otimes> (inv (h [^] e));
  return_spmf (a, c)}"

definition ss_adversary :: "'grp \<Rightarrow> ('grp msg, challenge, response) conv_tuple \<Rightarrow> ('grp msg, challenge, response) conv_tuple \<Rightarrow> nat spmf"
  where "ss_adversary x c1 c2 = do {
    let (a, e, z) = c1;
    let (a', e', z') = c2;
    return_spmf (if (e > e') then
                    (nat ((int z - int z') * inverse ((e - e')) (order \<G>) mod order \<G>)) else
                        (nat ((int z' - int z) * inverse ((e' - e)) (order \<G>) mod order \<G>)))}"

definition "valid_pub = carrier \<G>"

text\<open>We now use the Schnorr \<open>\<Sigma>\<close>-protocol use Schnorr to construct a commitment scheme.\<close>

type_synonym 'grp' ck = "'grp'"
type_synonym 'grp' vk = "'grp' \<times> nat"
type_synonym plain = "nat"
type_synonym 'grp' commit = "'grp'"
type_synonym "opening" = "nat"

text\<open>The adversary we use in the discrete log game to reduce the binding property to the discrete log assumption.\<close>

definition dis_log_\<A> :: "('grp ck, plain, 'grp commit, opening) bind_adversary \<Rightarrow> 'grp ck \<Rightarrow> nat spmf"
  where "dis_log_\<A> \<A> h = do {
  (c, e, z, e', z') \<leftarrow> \<A> h;
  _ :: unit \<leftarrow> assert_spmf (e > e' \<and> \<not> [e = e'] (mod order \<G>) \<and> (gcd (e - e') (order \<G>) = 1) \<and> c \<in> carrier \<G>);
  _ :: unit \<leftarrow> assert_spmf (((c \<otimes> h [^] e) = \<^bold>g [^] z) \<and> (c \<otimes> h [^] e') = \<^bold>g [^] z');
  return_spmf  (nat ((int z - int z') * inverse ((e - e')) (order \<G>) mod order \<G>))}"

sublocale discrete_log: dis_log \<G>
  unfolding dis_log_def by simp

end

locale schnorr_sigma_protocol = schnorr_base + cyclic_group \<G>
begin

sublocale Schnorr_\<Sigma>: \<Sigma>_protocols_base init response check R_DL S2 ss_adversary challenge_space valid_pub
  apply unfold_locales
  by(simp add: R_DL_def valid_pub_def; blast)

text\<open>The Schnorr \<open>\<Sigma>\<close>-protocol is complete.\<close>

lemma completeness: "Schnorr_\<Sigma>.completeness"
proof-
  have "\<^bold>g [^] y \<otimes> (\<^bold>g [^] w') [^] e = \<^bold>g [^] (y + w' * e)" for y e w' :: nat
    using nat_pow_pow nat_pow_mult by simp
  then show ?thesis
    unfolding Schnorr_\<Sigma>.completeness_game_def Schnorr_\<Sigma>.completeness_def
    by(auto simp add: init_def response_def check_def pow_generator_mod R_DL_def add.commute bind_spmf_const)
qed

text\<open>The next two lemmas help us rewrite terms in the proof  of honest verfier zero knowledge.\<close>

lemma zr_rewrite:
  assumes z: "z = (x*c + r) mod (order \<G>)"
    and r: "r < order \<G>"
  shows "(z + (order \<G>)*x*c - x*c) mod (order \<G>) = r"
proof(cases "x = 0")
  case True
  then show ?thesis using assms by simp
next
  case x_neq_0: False
  then show ?thesis
  proof(cases "c = 0")
    case True
    then show ?thesis
      by (simp add: assms)
  next
    case False
    have cong: "[z + (order \<G>)*x*c = x*c + r] (mod (order \<G>))"
      by (simp add: cong_def mult.assoc z)
    hence "[z + (order \<G>)*x*c - x*c = r] (mod (order \<G>))"
    proof-
      have "z + (order \<G>)*x*c > x*c"
        by (metis One_nat_def mult_less_cancel2 n_less_m_mult_n neq0_conv prime_gt_1_nat prime_order trans_less_add2 x_neq_0 False)
      then show ?thesis
        by (metis cong add_diff_inverse_nat cong_add_lcancel_nat less_imp_le linorder_not_le)
    qed
    then show ?thesis
      by(simp add: cong_def r)
  qed
qed

lemma h_sub_rewrite:
  assumes "h = \<^bold>g [^] x"
    and z: "z < order \<G>"
  shows "\<^bold>g [^] ((z + (order \<G>)*x*c - x*c)) = \<^bold>g [^] z \<otimes> inv (h [^] c)"
    (is "?lhs = ?rhs")
proof(cases "x = 0")
  case True
  then show ?thesis using assms by simp
next
  case x_neq_0: False
  then show ?thesis
  proof-
    have "(z + order \<G> * x * c - x * c) = (z + (order \<G> * x * c - x * c))"
      using z by (simp add: less_imp_le_nat mult_le_mono)
    then have lhs: "?lhs = \<^bold>g [^] z \<otimes> \<^bold>g [^] ((order \<G>)*x*c - x*c)"
      by(simp add: nat_pow_mult)
    have " \<^bold>g [^] ((order \<G>)*x*c - x*c) =  inv (h [^] c)"
    proof(cases "c = 0")
      case True
      then show ?thesis by simp
    next
      case False
      hence bound: "((order \<G>)*x*c - x*c) > 0"
        using assms x_neq_0 prime_gt_1_nat prime_order by auto
      then have "\<^bold>g [^] ((order \<G>)*x*c- x*c) = \<^bold>g [^] int ((order \<G>)*x*c - x*c)"
        by (simp add: int_pow_int)
      also have "... = \<^bold>g [^] int ((order \<G>)*x*c) \<otimes> inv (\<^bold>g [^] (x*c))"
        by (metis bound generator_closed int_ops(6) int_pow_int of_nat_eq_0_iff of_nat_less_0_iff of_nat_less_iff int_pow_diff)
      also have "... = \<^bold>g [^] ((order \<G>)*x*c) \<otimes> inv (\<^bold>g [^] (x*c))"
        by (metis int_pow_int)
      also have "... = \<^bold>g [^] ((order \<G>)*x*c) \<otimes> inv ((\<^bold>g [^] x) [^] c)"
        by(simp add: nat_pow_pow)
      also have "... = \<^bold>g [^] ((order \<G>)*x*c) \<otimes> inv (h [^] c)"
        using assms by simp
      also have "... = \<one> \<otimes> inv (h [^] c)"
        using generator_pow_order
        by (metis generator_closed mult_is_0 nat_pow_0 nat_pow_pow)
      ultimately show ?thesis
        by (simp add: assms(1))
    qed
    then show ?thesis using lhs by simp
  qed
qed

lemma hvzk_R_rewrite_grp:
  fixes x c r :: nat
  assumes "r < order \<G>"
  shows "\<^bold>g [^] (((x * c + order \<G> - r) mod order \<G> + order \<G> * x * c - x * c) mod order \<G>) = inv \<^bold>g [^] r"
    (is "?lhs = ?rhs")
proof-
  have "[(x * c + order \<G> - r) mod order \<G> + order \<G> * x * c - x * c = order \<G> - r] (mod order \<G>)"
  proof-
    have "[(x * c + order \<G> - r) mod order \<G> + order \<G> * x * c - x * c
              = x * c + order \<G> - r + order \<G> * x * c - x * c] (mod order \<G>)"
      by (smt cong_def One_nat_def add_diff_inverse_nat cong_diff_nat less_imp_le_nat linorder_not_less mod_add_left_eq mult.assoc n_less_m_mult_n prime_gt_1_nat prime_order trans_less_add2 zero_less_diff)
    hence "[(x * c + order \<G> - r) mod order \<G> + order \<G> * x * c - x * c
              =  order \<G> - r + order \<G> * x * c] (mod order \<G>)"
      using assms by auto
    thus ?thesis
      by (simp add: cong_def mult.assoc)
  qed
  hence "\<^bold>g [^] ((x * c + order \<G> - r) mod order \<G> + order \<G> * x * c - x * c) = \<^bold>g [^] (order \<G> - r)"
    using finite_carrier pow_generator_eq_iff_cong by blast
  thus ?thesis using neg_power_inverse
    by (simp add: assms inverse_pow_pow pow_generator_mod)
qed

lemma hv_zk:
  assumes "(h,x) \<in> R_DL"
  shows "Schnorr_\<Sigma>.R h x c = Schnorr_\<Sigma>.S h c"
  including monad_normalisation
proof-
  have "Schnorr_\<Sigma>.R h x c = do {
      r \<leftarrow> sample_uniform (order \<G>);
      let z = (x*c + r) mod (order \<G>);
      let a = \<^bold>g [^] ((z + (order \<G>)*x*c - x*c) mod (order \<G>));
      return_spmf (a,c,z)}"
    apply(simp add: Let_def Schnorr_\<Sigma>.R_def init_def response_def)
    using assms zr_rewrite R_DL_def
    by(simp cong: bind_spmf_cong_simp)
  also have "... = do {
      z \<leftarrow> map_spmf (\<lambda> r. (x*c + r) mod (order \<G>)) (sample_uniform (order \<G>));
      let a = \<^bold>g [^] ((z + (order \<G>)*x*c - x*c) mod (order \<G>));
      return_spmf (a,c,z)}"
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... = do {
      z \<leftarrow>  (sample_uniform (order \<G>));
      let a = \<^bold>g [^] ((z + (order \<G>)*x*c - x*c));
      return_spmf (a,c,z)}"
    by(simp add: samp_uni_plus_one_time_pad pow_generator_mod)
  also have "... = do {
      z \<leftarrow>  (sample_uniform (order \<G>));
      let a = \<^bold>g [^] z \<otimes> inv (h [^] c);
      return_spmf (a,c,z)}"
    using h_sub_rewrite assms R_DL_def
    by(simp cong: bind_spmf_cong_simp)
  ultimately show ?thesis
    by(simp add: Schnorr_\<Sigma>.S_def S2_def map_spmf_conv_bind_spmf)
qed

text\<open>We can now prove that honest verifier zero knowledge holds for the Schnorr \<open>\<Sigma>\<close>-protocol.\<close>

lemma honest_verifier_ZK:
  shows "Schnorr_\<Sigma>.HVZK"
  unfolding Schnorr_\<Sigma>.HVZK_def
  by(auto simp add: hv_zk R_DL_def S2_def check_def valid_pub_def challenge_space_def cyclic_group_assoc)

text\<open>It is left to prove the special soundness property. First we prove a lemma we use to rewrite a
term in the special soundness proof and then prove the property itself.\<close>

lemma ss_rewrite:
  assumes "e' < e"
    and "e < order \<G>"
    and a_mem:"a  \<in> carrier \<G>"
    and h_mem: "h \<in> carrier \<G>"
    and a: "a \<otimes> h [^] e = \<^bold>g [^] z"
    and a': "a \<otimes> h [^] e' = \<^bold>g [^] z'"
  shows  "h = \<^bold>g [^] ((int z - int z') * inverse ((e - e')) (order \<G>) mod int (order \<G>))"
proof-
  have gcd: "gcd (nat (int e - int e') mod (order \<G>)) (order \<G>) = 1"
    using prime_field
    by (metis Primes.prime_nat_def assms(1) assms(2) coprime_imp_gcd_eq_1 diff_is_0_eq less_imp_diff_less
            mod_less nat_minus_as_int not_less schnorr_base.prime_order schnorr_base_axioms)
  have "a = \<^bold>g [^] z \<otimes> inv (h [^] e)"
    using a a_mem
    by (simp add: h_mem group.inv_solve_right)
  moreover have "a = \<^bold>g [^] z' \<otimes> inv (h [^] e')"
    using a' a_mem
    by (simp add: h_mem group.inv_solve_right)
  ultimately have "\<^bold>g [^] z \<otimes> h [^] e'  = \<^bold>g [^] z' \<otimes> h [^] e"
    using h_mem
    by (metis (no_types, lifting) a a' h_mem a_mem cyclic_group_assoc cyclic_group_commute nat_pow_closed)
  moreover obtain t :: nat where  t: "h = \<^bold>g  [^] t"
    using h_mem generatorE by blast
  ultimately have "\<^bold>g [^] (z + t * e')  = \<^bold>g [^] (z' +  t * e) "
    by (simp add: monoid.nat_pow_mult nat_pow_pow)
  hence "[z + t * e' = z' +  t * e] (mod  order \<G>)"
    using group_eq_pow_eq_mod order_gt_0 by blast
  hence "[int z + int t * int e' = int z' +  int t * int e] (mod  order \<G>)"
    using cong_int_iff by force
  hence "[int z - int z' = int t * int e - int t * int e'] (mod  order \<G>)"
    by (smt cong_iff_lin)
  hence "[int z - int z' = int t * (int e - int e')] (mod  order \<G>)"
    by (simp add: \<open>[int z - int z' = int t * int e - int t * int e'] (mod int (order \<G>))\<close> right_diff_distrib)
  hence "[int z - int z' = int t * (int e - int e')] (mod  order \<G>)"
    by (meson cong_diff cong_mod_left cong_mult cong_refl cong_trans)
  hence *: "[int z - int z' = int t * (int e - int e')] (mod  order \<G>)"
    using assms
    by (simp add: int_ops(9) of_nat_diff)
  hence "[int z - int z' = int t * nat (int e - int e')] (mod  order \<G>)"
    using assms
    by auto
  hence **: "[(int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>))
              = int t * (nat (int e - int e')
                  * fst (bezw ((nat (int e - int e'))) (order \<G>)))] (mod  order \<G>)"
    by (smt \<open>[int z - int z' = int t * (int e - int e')] (mod int (order \<G>))\<close> assms(1) assms(2)
          cong_scalar_right int_nat_eq less_imp_of_nat_less mod_less more_arith_simps(11) nat_less_iff of_nat_0_le_iff)
  hence "[(int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>)) = int t * 1] (mod  order \<G>)"
    by (metis (no_types, opaque_lifting) gcd inverse assms(2) cong_scalar_left cong_trans less_imp_diff_less mod_less mult.comm_neutral nat_minus_as_int)
  hence "[(int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>))
              = t] (mod  order \<G>)" by simp
  hence "[ ((int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>)))mod order \<G>
              = t] (mod  order \<G>)"
    using cong_mod_left by blast
  hence  **: "[nat (((int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>)))mod order \<G>)
              = t] (mod  order \<G>)"
    by (metis cong_def mod_mod_trivial nat_int of_nat_mod)
  hence "\<^bold>g [^] (nat (((int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>)))mod order \<G>)) = \<^bold>g [^] t"
    using cyclic_group.pow_generator_eq_iff_cong cyclic_group_axioms order_gt_0 order_gt_0_iff_finite by blast
  thus ?thesis using t
    by (simp add: nat_minus_as_int)
qed

text\<open>The special soundness property for the Schnorr \<open>\<Sigma>\<close>-protocol.\<close>

lemma special_soundness:
  shows "Schnorr_\<Sigma>.special_soundness"
  unfolding Schnorr_\<Sigma>.special_soundness_def
  by(auto simp add: valid_pub_def ss_rewrite challenge_space_def split_def ss_adversary_def check_def R_DL_def Let_def)

text\<open>We are now able to prove that the Schnorr \<open>\<Sigma>\<close>-protocol is a \<open>\<Sigma>\<close>-protocol, the proof comes from the properties of
completeness, HVZK and special soundness we have previously proven.\<close>

theorem sigma_protocol:
  shows "Schnorr_\<Sigma>.\<Sigma>_protocol"
  by(simp add: Schnorr_\<Sigma>.\<Sigma>_protocol_def completeness honest_verifier_ZK special_soundness)

text\<open>Having proven the \<open>\<Sigma>\<close>-protocol property is satisfied we can show the commitment scheme we construct from the
Schnorr \<open>\<Sigma>\<close>-protocol has the desired properties. This result comes with very little proof effort as we can instantiate
our general proof.\<close>

sublocale Schnorr_\<Sigma>_commit: \<Sigma>_protocols_to_commitments init response check R_DL S2 ss_adversary challenge_space valid_pub G
  unfolding \<Sigma>_protocols_to_commitments_def \<Sigma>_protocols_to_commitments_axioms_def
  apply(auto simp add: \<Sigma>_protocols_base_def)
       apply(simp add: R_DL_def valid_pub_def)
      apply(auto simp add: sigma_protocol lossless_G lossless_init lossless_response)
  by(simp add: R_DL_def G_def)

lemma "Schnorr_\<Sigma>_commit.abstract_com.correct"
  by(fact Schnorr_\<Sigma>_commit.commit_correct)

lemma "Schnorr_\<Sigma>_commit.abstract_com.perfect_hiding_ind_cpa \<A>"
  by(fact Schnorr_\<Sigma>_commit.perfect_hiding)

lemma rel_adv_eq_dis_log_adv:
  "Schnorr_\<Sigma>_commit.rel_advantage \<A> = discrete_log.advantage \<A>"
proof-
  have "Schnorr_\<Sigma>_commit.rel_game \<A> = discrete_log.dis_log \<A>"
    unfolding Schnorr_\<Sigma>_commit.rel_game_def discrete_log.dis_log_def
    by(auto intro: try_spmf_cong bind_spmf_cong[OF refl]
       simp add: G_def R_DL_def cong_less_modulus_unique_nat group_eq_pow_eq_mod finite_carrier pow_generator_eq_iff_cong)
  thus ?thesis
    using Schnorr_\<Sigma>_commit.rel_advantage_def discrete_log.advantage_def by simp
qed

lemma bind_advantage_bound_dis_log:
  "Schnorr_\<Sigma>_commit.abstract_com.bind_advantage \<A> \<le> discrete_log.advantage (Schnorr_\<Sigma>_commit.adversary \<A>)"
  using Schnorr_\<Sigma>_commit.bind_advantage rel_adv_eq_dis_log_adv by simp

end

locale schnorr_asymp =
  fixes \<G> :: "nat \<Rightarrow> 'grp cyclic_group"
  assumes schnorr: "\<And>\<eta>. schnorr_sigma_protocol (\<G> \<eta>)"
begin

sublocale schnorr_sigma_protocol "\<G> \<eta>" for \<eta>
  by(simp add: schnorr)

text\<open>The \<open>\<Sigma>\<close>-protocol statement comes easily in the asymptotic setting.\<close>

theorem sigma_protocol:
  shows "Schnorr_\<Sigma>.\<Sigma>_protocol n"
  by(simp add: sigma_protocol)

text\<open>We now show the statements of security for the commitment scheme in the asymptotic setting, the main difference is that
we are able to show the binding advantage is negligible in the security parameter.\<close>

lemma asymp_correct: "Schnorr_\<Sigma>_commit.abstract_com.correct n"
  using  Schnorr_\<Sigma>_commit.commit_correct by simp

lemma asymp_perfect_hiding: "Schnorr_\<Sigma>_commit.abstract_com.perfect_hiding_ind_cpa n (\<A> n)"
  using Schnorr_\<Sigma>_commit.perfect_hiding by blast

end

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_35
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

definition(*fun*) one :: "Nat" where
  "one = S Z"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

fun t22 :: "Nat => Nat => Nat" where
  "t22 (Z) y = Z"
| "t22 (S z) y = t2 y (t22 z y)"

fun exp :: "Nat => Nat => Nat" where
  "exp x (Z) = S Z"
| "exp x (S n) = t22 x (exp x n)"

fun qexp :: "Nat => Nat => Nat => Nat" where
  "qexp x (Z) z = z"
| "qexp x (S n) z = qexp x n (t22 x z)"

lemma t2_comm: "t2 x y = t2 y x" sorry

lemma t22_zero: "t22 x Z = Z" by(induction x, auto)

lemma t22_comm: "t22 x y = t22 y x"
  apply(induction x, auto)
   apply(simp add: t22_zero)apply(induction y, auto)
  sorry

lemma t22_assoc: "t22 x (t22 y z) = t22 (t22 x y) z" apply(induction y, auto)apply(simp add: t22_zero) sorry

lemma t2_qexp: "t22 w (qexp x y z) = qexp x y (t22 w z)"
  apply(induction y arbitrary: z, auto)
  apply(simp add: t22_assoc)
  apply(simp add: t22_comm)
  done

theorem property0 :
  "((exp x y) = (qexp x y one))"
  apply(induction y arbitrary: x)
  unfolding one_def apply(simp)
  apply(auto)
  apply(simp add: t2_qexp)
  done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_HSort2Permutes
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Heap = Node "Heap" "int" "Heap" | Nil

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => int list" where
  "toList (Node p y q) = cons2 y (toList (hmerge p q))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "int => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "int list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "int list => int list" where
  "hsort2 x = toList (toHeap2 x)"

fun elem :: "'a => 'a list => bool" where
  "elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (hsort2 xs) xs"
  oops

end


(*
  Title:    SDS_Lowering.thy
  Author:   Manuel Eberl, TU München

  Allows to lower an SDS, i.e. take an existing ex-post efficient SDS
  and construct from it an SDS for fewer agents and alternatives. (which is
  also ex-post efficient)
    The standard properties (anonymity, neutrality, SD efficiency, strategyproofness)
  are preserved by this construction.
*)

section \<open>Lowering Social Decision Schemes\<close>

theory SDS_Lowering
imports Social_Decision_Schemes
begin

definition lift_pref_profile ::
    "'agent set \<Rightarrow> 'alt set \<Rightarrow> 'agent set \<Rightarrow> 'alt set \<Rightarrow>
       ('agent, 'alt) pref_profile \<Rightarrow> ('agent, 'alt) pref_profile" where
  "lift_pref_profile agents alts agents' alts' R = (\<lambda>i x y.
     x \<in> alts' \<and> y \<in> alts' \<and> i \<in> agents' \<and>
     (x = y \<or> x \<notin> alts \<or> i \<notin> agents \<or> (y \<in> alts \<and> R i x y)))"

lemma lift_pref_profile_wf:
  assumes "pref_profile_wf agents alts R"
  assumes "agents \<subseteq> agents'" "alts \<subseteq> alts'" "finite alts'"
  defines "R' \<equiv> lift_pref_profile agents alts agents' alts' R"
  shows   "pref_profile_wf agents' alts' R'"
proof -
  from assms interpret R: pref_profile_wf agents alts by simp
  have "finite_total_preorder_on alts' (R' i)"
    if i: "i \<in> agents'" for i
  proof (cases "i \<in> agents")
    case True
    then interpret finite_total_preorder_on alts "R i" by simp
    from True assms show ?thesis
      by unfold_locales (auto simp: lift_pref_profile_def dest: total intro: trans)
  next
    case False
    with assms i show ?thesis
      by unfold_locales (simp_all add: lift_pref_profile_def)
  qed
  moreover have "R' i = (\<lambda>_ _. False)" if "i \<notin> agents'" for i
    unfolding lift_pref_profile_def R'_def using that by simp
  ultimately show ?thesis unfolding pref_profile_wf_def using assms by auto
qed

lemma lift_pref_profile_permute_agents:
  assumes "\<pi> permutes agents" "agents \<subseteq> agents'"
  shows   "lift_pref_profile agents alts agents' alts' (R \<circ> \<pi>) =
             lift_pref_profile agents alts agents' alts' R \<circ> \<pi>"
  using assms permutes_subset[OF assms]
  by (auto simp add: lift_pref_profile_def o_def permutes_in_image)

lemma lift_pref_profile_permute_alts:
  assumes "\<sigma> permutes alts" "alts \<subseteq> alts'"
  shows   "lift_pref_profile agents alts agents' alts' (permute_profile \<sigma> R) =
             permute_profile \<sigma> (lift_pref_profile agents alts agents' alts' R)"
proof -
  from assms have inv: "inv \<sigma> permutes alts" by (intro permutes_inv)
  from this assms(2) have "inv \<sigma> permutes alts'" by (rule permutes_subset)
  with inv show ?thesis using assms permutes_inj[OF \<open>inv \<sigma> permutes alts\<close>]
    by (fastforce simp add: lift_pref_profile_def permutes_in_image
          permute_profile_def fun_eq_iff dest: injD)
qed

lemma lotteries_on_subset: "A \<subseteq> B \<Longrightarrow> p \<in> lotteries_on A \<Longrightarrow> p \<in> lotteries_on B"
  unfolding lotteries_on_def by blast

lemma lottery_prob_carrier: "p \<in> lotteries_on A \<Longrightarrow> measure_pmf.prob p A = 1"
  by (auto simp: measure_pmf.prob_eq_1 lotteries_on_def AE_measure_pmf_iff)

context
  fixes agents alts R agents' alts' R'
  assumes R_wf: "pref_profile_wf agents alts R"
  assumes election: "agents \<subseteq> agents'" "alts \<subseteq> alts'" "alts \<noteq> {}" "agents \<noteq> {}" "finite alts'"
  defines "R' \<equiv> lift_pref_profile agents alts agents' alts' R"
begin

interpretation R: pref_profile_wf agents alts R by fact
interpretation R': pref_profile_wf agents' alts' R'
  using election R_wf by (simp add: R'_def lift_pref_profile_wf)

lemma lift_pref_profile_strict_iff:
  "x \<prec>[lift_pref_profile agents alts agents' alts' R i] y \<longleftrightarrow>
     i \<in> agents \<and> ((y \<in> alts \<and> x \<in> alts' - alts) \<or> x \<prec>[R i] y)"
proof (cases "i \<in> agents")
  case True
  then interpret total_preorder_on alts "R i" by simp
  show ?thesis using not_outside election
    by (auto simp: lift_pref_profile_def strongly_preferred_def)
qed (simp_all add: lift_pref_profile_def strongly_preferred_def)

lemma preferred_alts_lift_pref_profile:
  assumes i: "i \<in> agents'" and x: "x \<in> alts'"
  shows   "preferred_alts (R' i) x =
             (if i \<in> agents \<and> x \<in> alts then preferred_alts (R i) x else alts')"
proof (cases "i \<in> agents")
  assume i: "i \<in> agents"
  then interpret Ri: total_preorder_on alts "R i" by simp
  show ?thesis
  using i x election Ri.not_outside
    by (auto simp: preferred_alts_def R'_def lift_pref_profile_def Ri.refl)
qed (auto simp: preferred_alts_def R'_def lift_pref_profile_def i x)

lemma lift_pref_profile_Pareto_iff:
  "x \<preceq>[Pareto(R')] y \<longleftrightarrow> x \<in> alts' \<and> y \<in> alts' \<and> (x \<notin> alts \<or> x \<preceq>[Pareto(R)] y)"
proof -
  from R.nonempty_agents obtain i where i: "i \<in> agents" by blast
  then interpret Ri: finite_total_preorder_on alts "R i" by simp
  show ?thesis unfolding R'.Pareto_iff R.Pareto_iff unfolding R'_def lift_pref_profile_def
    using election i by (auto simp: preorder_on.refl[OF R.in_dom]
      simp del: R.nonempty_alts R.nonempty_agents  intro: Ri.not_outside)
qed

lemma lift_pref_profile_Pareto_strict_iff:
  "x \<prec>[Pareto(R')] y \<longleftrightarrow> x \<in> alts' \<and> y \<in> alts' \<and> (x \<notin> alts \<and> y \<in> alts \<or> x \<prec>[Pareto(R)] y)"
  by (auto simp: strongly_preferred_def lift_pref_profile_Pareto_iff R.Pareto.not_outside)

lemma pareto_losers_lift_pref_profile:
  shows   "pareto_losers R' = pareto_losers R \<union> (alts' - alts)"
proof -
  have A: "x \<in> alts" "y \<in> alts" if "x \<prec>[Pareto(R)] y" for x y
    using that R.Pareto.not_outside unfolding strongly_preferred_def by auto
  have B: "x \<in> alts'" if "x \<in> alts" for x using election that by blast
  from R.nonempty_alts obtain x where x: "x \<in> alts" by blast
  thus ?thesis unfolding pareto_losers_def lift_pref_profile_Pareto_strict_iff [abs_def]
    by (auto dest: A B)
qed

context
begin
private lemma lift_SD_iff_agent:
  assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts" and i: "i \<in> agents"
  shows   "p \<preceq>[SD(R' i)] q \<longleftrightarrow> p \<preceq>[SD(R i)] q"
proof -
  from i interpret Ri: preorder_on alts "R i" by simp
  from i election have i': "i \<in> agents'" by blast
  then interpret R'i: preorder_on alts' "R' i" by simp
  from assms election have "p \<in> lotteries_on alts'" "q \<in> lotteries_on alts'"
    by (auto intro: lotteries_on_subset)
  with assms election i' show ?thesis
    by (auto simp: Ri.SD_preorder R'i.SD_preorder
          preferred_alts_lift_pref_profile lottery_prob_carrier)
qed

private lemma lift_SD_iff_nonagent:
  assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts" and i: "i \<in> agents' - agents"
  shows   "p \<preceq>[SD(R' i)] q"
proof -
  from i election have i': "i \<in> agents'" by blast
  then interpret R'i: preorder_on alts' "R' i" by simp
  from assms election have "p \<in> lotteries_on alts'" "q \<in> lotteries_on alts'"
    by (auto intro: lotteries_on_subset)
  with assms election i' show ?thesis
    by (auto simp: R'i.SD_preorder preferred_alts_lift_pref_profile lottery_prob_carrier)
qed

lemmas lift_SD_iff = lift_SD_iff_agent lift_SD_iff_nonagent

lemma lift_SD_iff':
  "p \<in> lotteries_on alts \<Longrightarrow> q \<in> lotteries_on alts \<Longrightarrow> i \<in> agents' \<Longrightarrow>
     p \<preceq>[SD(R' i)] q \<longleftrightarrow> i \<notin> agents \<or> p \<preceq>[SD(R i)] q"
  by (cases "i \<in> agents") (simp_all add: lift_SD_iff)

end

lemma lift_SD_strict_iff:
  assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts" and i: "i \<in> agents"
  shows   "p \<prec>[SD(R' i)] q \<longleftrightarrow> p \<prec>[SD(R i)] q"
  using assms by (simp add: strongly_preferred_def lift_SD_iff)

lemma lift_Pareto_SD_iff:
  assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts"
  shows   "p \<preceq>[Pareto(SD \<circ> R')] q \<longleftrightarrow> p \<preceq>[Pareto(SD \<circ> R)] q"
  using assms election by (auto simp: R.SD.Pareto_iff R'.SD.Pareto_iff lift_SD_iff')

lemma lift_Pareto_SD_strict_iff:
  assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts"
  shows   "p \<prec>[Pareto(SD \<circ> R')] q \<longleftrightarrow> p \<prec>[Pareto(SD \<circ> R)] q"
  using assms by (simp add: strongly_preferred_def lift_Pareto_SD_iff)

lemma lift_SD_efficient_iff:
  assumes p: "p \<in> lotteries_on alts"
  shows   "SD_efficient R' p \<longleftrightarrow> SD_efficient R p"
proof
  assume eff: "SD_efficient R' p"
  have "\<not>(q \<succ>[Pareto(SD \<circ> R)] p)" if q: "q \<in> lotteries_on alts" for q
  proof -
    from q election have q': "q \<in> lotteries_on alts'" by (blast intro: lotteries_on_subset)
    with eff have "\<not>(q \<succ>[Pareto(SD \<circ> R')] p)" by (simp add: R'.SD_efficient_def)
    with p q show ?thesis by (simp add: lift_Pareto_SD_strict_iff)
  qed
  thus "SD_efficient R p" by (simp add: R.SD_efficient_def)
next
  assume eff: "SD_efficient R p"
  have "\<not>(q \<succ>[Pareto(SD \<circ> R')] p)" if q: "q \<in> lotteries_on alts'" for q
  proof
    assume less: "q \<succ>[Pareto(SD \<circ> R')] p"
    from R'.SD_efficient_lottery_exists[OF q] guess q' . note q' = this
    have "x \<notin> set_pmf q'" if x: "x \<in> alts' - alts" for x
    proof -
      from x have "x \<in> pareto_losers R'" by (simp add: pareto_losers_lift_pref_profile)
      with R'.SD_efficient_no_pareto_loser[OF q'(3,1)] show "x \<notin> set_pmf q'" by blast
    qed
    with q' have "q' \<in> lotteries_on alts" by (auto simp: lotteries_on_def)
    moreover from q' less have "q' \<succ>[Pareto(SD \<circ> R')] p"
      by (auto intro: R'.SD.Pareto.strict_weak_trans)
    with \<open>q' \<in> lotteries_on alts\<close> p have "q' \<succ>[Pareto(SD \<circ> R)] p"
      by (subst (asm) lift_Pareto_SD_strict_iff)
    ultimately have "\<not>SD_efficient R p" by (auto simp: R.SD_efficient_def)
    with eff show False by contradiction
  qed
  thus "SD_efficient R' p" by (simp add: R'.SD_efficient_def)
qed

end

locale sds_lowering =
  ex_post_efficient_sds agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  fixes agents' alts'
  assumes agents'_subset: "agents' \<subseteq> agents" and alts'_subset: "alts' \<subseteq> alts"
      and agents'_nonempty [simp]: "agents' \<noteq> {}" and alts'_nonempty [simp]: "alts' \<noteq> {}"
begin

lemma finite_agents' [simp]: "finite agents'"
  using agents'_subset finite_agents by (rule finite_subset)

lemma finite_alts' [simp]: "finite alts'"
  using alts'_subset finite_alts by (rule finite_subset)

abbreviation lift :: "('agent, 'alt) pref_profile \<Rightarrow> ('agent, 'alt) pref_profile" where
  "lift \<equiv> lift_pref_profile agents' alts' agents alts"

definition lowered :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt lottery" where
  "lowered = sds \<circ> lift"

lemma lift_wf [simp, intro]:
  "pref_profile_wf agents' alts' R \<Longrightarrow> is_pref_profile (lift R)"
  using alts'_subset agents'_subset by (intro lift_pref_profile_wf) simp_all

sublocale lowered: election agents' alts'
  by unfold_locales simp_all

lemma preferred_alts_lift:
  "lowered.is_pref_profile R \<Longrightarrow> i \<in> agents \<Longrightarrow> x \<in> alts \<Longrightarrow>
     preferred_alts (lift R i) x =
       (if i \<in> agents' \<and> x \<in> alts' then preferred_alts (R i) x else alts)"
  using alts'_subset agents'_subset
  by (intro preferred_alts_lift_pref_profile) simp_all

lemma pareto_losers_lift:
  "lowered.is_pref_profile R \<Longrightarrow> pareto_losers (lift R) = pareto_losers R \<union> (alts - alts')"
  using agents'_subset alts'_subset by (intro pareto_losers_lift_pref_profile) simp_all

lemma lowered_lotteries: "lowered.lotteries \<subseteq> lotteries"
  unfolding lotteries_on_def using alts'_subset by blast

sublocale lowered: social_decision_scheme agents' alts' lowered
proof
  fix R assume R_wf: "pref_profile_wf agents' alts' R"
  from R_wf have R'_wf: "pref_profile_wf agents alts (lift R)" by (rule lift_wf)
  show "lowered R \<in> lowered.lotteries" unfolding lotteries_on_def
  proof safe
    fix x assume "x \<in> set_pmf (lowered R)"
    hence x: "x \<in> set_pmf (sds (lift R))" by (simp add: lowered_def)
    with ex_post_efficient[OF R'_wf]
      have "x \<notin> pareto_losers (lift R)" by blast
    with pareto_losers_lift[OF R_wf]
      have "x \<notin> alts - alts'" by blast
    moreover from x have "x \<in> alts" using sds_wf[OF R'_wf]
      by (auto simp: lotteries_on_def)
    ultimately show "x \<in> alts'" by simp
  qed
qed

sublocale ex_post_efficient_sds agents' alts' lowered
proof
  fix R assume R_wf: "lowered.is_pref_profile R"
  hence "is_pref_profile (lift R)" by simp
  have "set_pmf (lowered R) \<inter> pareto_losers (lift R) = {}"
    unfolding lowered_def o_def by (intro ex_post_efficient lift_wf R_wf)
  also have "pareto_losers (lift R) = pareto_losers R \<union> (alts - alts')"
    by (intro pareto_losers_lift R_wf)
  finally show "set_pmf (lowered R) \<inter> pareto_losers R = {}" by blast
qed

lemma lowered_in_lotteries [simp]: "lowered.is_pref_profile R \<Longrightarrow> lowered R \<in> lotteries"
  using lowered.sds_wf[of R] lowered_lotteries by blast

end

locale sds_lowering_anonymous =
  anonymous_sds agents alts sds +
  sds_lowering agents alts sds agents' alts'
  for agents :: "'agent set" and alts :: "'alt set" and sds agents' alts'
begin

sublocale lowered: anonymous_sds agents' alts' lowered
proof
  fix \<pi> R assume perm: "\<pi> permutes agents'" and R_wf: "lowered.is_pref_profile R"
  from perm have "lift (R \<circ> \<pi>) = lift R \<circ> \<pi>"
    using agents'_subset by (rule lift_pref_profile_permute_agents)
  hence "sds (lift (R \<circ> \<pi>)) = sds (lift R \<circ> \<pi>)" by simp
  also from perm R_wf have "\<pi> permutes agents" "is_pref_profile (lift R)"
    using agents'_subset by (auto dest: permutes_subset)
  from anonymous[OF this] have "sds (lift R \<circ> \<pi>) = sds (lift R)"
    by (simp add: lowered_def)
  finally show "lowered (R \<circ> \<pi>) = lowered R" unfolding lowered_def o_def .
qed

end

locale sds_lowering_neutral =
  neutral_sds agents alts sds +
  sds_lowering agents alts sds agents' alts'
  for agents :: "'agent set" and alts :: "'alt set" and sds agents' alts'
begin

sublocale lowered: neutral_sds agents' alts' lowered
proof
  fix \<sigma> R assume perm: "\<sigma> permutes alts'" and R_wf: "lowered.is_pref_profile R"
  from perm alts'_subset
    have "lift (permute_profile \<sigma> R) = permute_profile \<sigma> (lift R)"
    by (rule lift_pref_profile_permute_alts)
  hence "sds (lift (permute_profile \<sigma> R)) = sds (permute_profile \<sigma> (lift R))" by simp
  also from R_wf perm have "is_pref_profile (lift R)" by simp
  with perm alts'_subset
    have "sds (permute_profile \<sigma> (lift R)) = map_pmf \<sigma> (sds (lift R))"
    by (intro neutral) (auto intro: permutes_subset)
  finally show "lowered (permute_profile \<sigma> R) = map_pmf \<sigma> (lowered R)"
    by (simp add: lowered_def o_def)
qed

end

locale sds_lowering_sd_efficient =
  sd_efficient_sds agents alts sds +
  sds_lowering agents alts sds agents' alts'
  for agents :: "'agent set" and alts :: "'alt set" and sds agents' alts'
begin

sublocale sd_efficient_sds agents' alts' lowered
proof
  fix R assume R_wf: "lowered.is_pref_profile R"
  interpret R: pref_profile_wf agents' alts' R by fact
  from R_wf agents'_subset alts'_subset show "SD_efficient R (lowered R)"
    unfolding lowered_def o_def
    by (subst lift_SD_efficient_iff [symmetric])
       (insert SD_efficient R_wf lowered.sds_wf[OF R_wf], auto simp: lowered_def)
qed

end

locale sds_lowering_strategyproof =
  strategyproof_sds agents alts sds +
  sds_lowering agents alts sds agents' alts'
  for agents :: "'agent set" and alts :: "'alt set" and sds agents' alts'
begin

sublocale strategyproof_sds agents' alts' lowered
proof (unfold_locales, safe)
  fix R i Ri'
  assume R_wf: "lowered.is_pref_profile R" and i: "i \<in> agents'"
  assume Ri': "total_preorder_on alts' Ri'"
  assume manipulable: "lowered.manipulable_profile R i Ri'"
  from i agents'_subset have i': "i \<in> agents" by blast
  interpret R: pref_profile_wf agents' alts' R by fact
  from R_wf interpret liftR: pref_profile_wf agents alts "lift R" by simp

  define lift_Ri'
    where "lift_Ri' x y \<longleftrightarrow> x \<in> alts \<and> y \<in> alts \<and> (x = y \<or> x \<notin> alts' \<or> (y \<in> alts' \<and> Ri' x y))"
    for x y
  define S where "S = (lift R)(i := lift_Ri')"
  from Ri' interpret Ri': total_preorder_on alts' Ri' .
  have wf_lift_Ri': "total_preorder_on alts lift_Ri'" using Ri'.total
    by unfold_locales (auto simp: lift_Ri'_def intro: Ri'.trans)
  from agents'_subset i have S_altdef: "S = lift (R(i := Ri'))"
    by (auto simp: fun_eq_iff lift_pref_profile_def lift_Ri'_def S_def)
  have "lowered (R(i := Ri')) \<in> lowered.lotteries"
    by (intro lowered.sds_wf R.wf_update i Ri')
  hence sds_S_wf: "sds S \<in> lowered.lotteries" by (simp add: S_altdef lowered_def)

  from manipulable have "lowered R \<prec>[SD (R i)] sds (lift (R(i := Ri')))"
    unfolding lowered.manipulable_profile_def by (simp add: lowered_def)
  also note S_altdef [symmetric]
  finally have "lowered R \<prec>[SD (lift R i)] sds S"
    using R_wf i lowered.sds_wf[OF R_wf] sds_S_wf
      by (subst lift_SD_strict_iff) (simp_all add: agents'_subset alts'_subset)
  hence "manipulable_profile (lift R) i lift_Ri'"
    by (simp add: manipulable_profile_def lowered_def S_def)
  with strategyproof[OF lift_wf[OF R_wf] i' wf_lift_Ri'] show False by contradiction
qed

end

locale sds_lowering_anonymous_neutral_sdeff_stratproof =
  sds_lowering_anonymous + sds_lowering_neutral +
  sds_lowering_sd_efficient + sds_lowering_strategyproof

end


theory sort_HSortSorts
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype 'a Heap = Node "'a Heap" "'a" "'a Heap" | Nil2

fun toHeap2 :: "int list => (int Heap) list" where
"toHeap2 (Nil2) = Nil2"
| "toHeap2 (Cons2 y z) = Cons2 (Node (Nil2) y (Nil2)) (toHeap2 z)"

fun hmerge :: "int Heap => int Heap => int Heap" where
"hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil2) = Node z x2 x3"
| "hmerge (Nil2) y = y"

fun hpairwise :: "(int Heap) list => (int Heap) list" where
"hpairwise (Nil2) = Nil2"
| "hpairwise (Cons2 p (Nil2)) = Cons2 p (Nil2)"
| "hpairwise (Cons2 p (Cons2 q qs)) =
     Cons2 (hmerge p q) (hpairwise qs)"

fun hmerging :: "(int Heap) list => int Heap" where
"hmerging (Nil2) = Nil2"
| "hmerging (Cons2 p (Nil2)) = p"
| "hmerging (Cons2 p (Cons2 z x2)) =
     hmerging (hpairwise (Cons2 p (Cons2 z x2)))"

fun toHeap :: "int list => int Heap" where
"toHeap x = hmerging (toHeap2 x)"

fun toList :: "int Heap => int list" where
"toList (Node p y q) = Cons2 y (toList (hmerge p q))"
| "toList (Nil2) = Nil2"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun hsort :: "int list => int list" where
"hsort x =
   dot
     (% (y :: int Heap) => toList y) (% (z :: int list) => toHeap z) x"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun ordered :: "int list => bool" where
"ordered (Nil2) = True"
| "ordered (Cons2 y (Nil2)) = True"
| "ordered (Cons2 y (Cons2 y2 xs)) =
     and2 (y <= y2) (ordered (Cons2 y2 xs))"

(*hipster toHeap2
          hmerge
          hpairwise
          hmerging
          toHeap
          toList
          dot
          hsort
          and2
          ordered *)

theorem x0 :
  "!! (x :: int list) . ordered (hsort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end