(*  Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Datatypes of agents and messages;
Inductive relations "parts", "analz" and "synth"
*)(*<*)

section{*Theory of Agents and Messages for Security Protocols*}

theory Message imports Main begin
ML_file "../../antiquote_setup.ML"

(*Needed occasionally with spy_analz_tac, e.g. in analz_insert_Key_newK*)
lemma [simp] : "A \<union> (B \<union> A) = B \<union> A"
by blast
(*>*)

section{* Agents and Messages *}

text {*
All protocol specifications refer to a syntactic theory of messages.
Datatype
@{text agent} introduces the constant @{text Server} (a trusted central
machine, needed for some protocols), an infinite population of
friendly agents, and the~@{text Spy}:
*}

datatype agent = Server | Friend nat | Spy

text {*
Keys are just natural numbers.  Function @{text invKey} maps a public key to
the matching private key, and vice versa:
*}

type_synonym key = nat
consts invKey :: "key \<Rightarrow> key"
(*<*)
consts all_symmetric :: bool        --{*true if all keys are symmetric*}

specification (invKey)
  invKey [simp]: "invKey (invKey K) = K"
  invKey_symmetric: "all_symmetric --> invKey = id"
    by (rule exI [of _ id], auto)

text{*The inverse of a symmetric key is itself; that of a public key
      is the private key and vice versa*}

definition symKeys :: "key set" where
  "symKeys == {K. invKey K = K}"
(*>*)

text {*
Datatype
@{text msg} introduces the message forms, which include agent names, nonces,
keys, compound messages, and encryptions.
*}

datatype
     msg = Agent  agent
         | Nonce  nat
         | Key    key
         | MPair  msg msg
         | Crypt  key msg

text {*
\noindent
The notation $\comp{X\sb 1,\ldots X\sb{n-1},X\sb n}$
abbreviates
$\isa{MPair}\,X\sb 1\,\ldots\allowbreak(\isa{MPair}\,X\sb{n-1}\,X\sb n)$.

Since datatype constructors are injective, we have the theorem
@{thm [display,indent=0] msg.inject(5) [THEN iffD1, of K X K' X']}
A ciphertext can be decrypted using only one key and
can yield only one plaintext.  In the real world, decryption with the
wrong key succeeds but yields garbage.  Our model of encryption is
realistic if encryption adds some redundancy to the plaintext, such as a
checksum, so that garbage can be detected.
*}

(*<*)
text{*Concrete syntax: messages appear as \<open>\<lbrace>A,B,NA\<rbrace>\<close>, etc...*}
syntax
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2\<lbrace>_,/ _\<rbrace>)")
translations
  "\<lbrace>x, y, z\<rbrace>"   == "\<lbrace>x, \<lbrace>y, z\<rbrace>\<rbrace>"
  "\<lbrace>x, y\<rbrace>"      == "CONST MPair x y"

definition keysFor :: "msg set => key set" where
    --{*Keys useful to decrypt elements of a message set*}
  "keysFor H == invKey ` {K. \<exists>X. Crypt K X \<in> H}"

subsubsection{*Inductive Definition of All Parts" of a Message*}

inductive_set
  parts :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro]:               "X \<in> H ==> X \<in> parts H"
  | Fst:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> X \<in> parts H"
  | Snd:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

text{*Monotonicity*}
lemma parts_mono: "G \<subseteq> H ==> parts(G) \<subseteq> parts(H)"
apply auto
apply (erule parts.induct)
apply (blast dest: parts.Fst parts.Snd parts.Body)+
done

text{*Equations hold because constructors are injective.*}
lemma Friend_image_eq [simp]: "(Friend x \<in> Friend`A) = (x:A)"
by auto

lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x\<in>A)"
by auto

lemma Nonce_Key_image_eq [simp]: "(Nonce x \<notin> Key`A)"
by auto

subsubsection{*Inverse of keys *}

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K=K')"
apply safe
apply (drule_tac f = invKey in arg_cong, simp)
done

subsection{*keysFor operator*}

lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)

lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)

lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)

text{*Monotonicity*}
lemma keysFor_mono: "G \<subseteq> H ==> keysFor(G) \<subseteq> keysFor(H)"
by (unfold keysFor_def, blast)

lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_MPair [simp]: "keysFor (insert \<lbrace>X,Y\<rbrace> H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Crypt [simp]:
    "keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)

lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H ==> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

subsection{*Inductive relation "parts"*}

lemma MPair_parts:
     "[| \<lbrace>X,Y\<rbrace> \<in> parts H;
         [| X \<in> parts H; Y \<in> parts H |] ==> P |] ==> P"
by (blast dest: parts.Fst parts.Snd)

declare MPair_parts [elim!]  parts.Body [dest!]
text{*NB These two rules are UNSAFE in the formal sense, as they discard the
     compound message.  They work well on THIS FILE.
  @{text MPair_parts} is left as SAFE because it speeds up proofs.
  The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.*}

lemma parts_increasing: "H \<subseteq> parts(H)"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct, blast+)
done

lemma parts_emptyE [elim!]: "X\<in> parts{} ==> P"
by simp

text{*WARNING: loops if H = {Y}, therefore must not be repeated!*}
lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
by (erule parts.induct, fast+)

subsubsection{*Unions *}

lemma parts_Un_subset1: "parts(G) \<union> parts(H) \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)

lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts(G) \<union> parts(H)"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_Un [simp]: "parts(G \<union> H) = parts(G) \<union> parts(H)"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
apply (subst insert_is_Un [of _ H])
apply (simp only: parts_Un)
done

text{*TWO inserts to avoid looping.  This rewrite is better than nothing.
  Not suitable for Addsimps: its behaviour can be strange.*}
lemma parts_insert2:
     "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
apply (simp add: Un_assoc)
apply (simp add: parts_insert [symmetric])
done

lemma parts_UN_subset1: "(\<Union>x\<in>A. parts(H x)) \<subseteq> parts(\<Union>x\<in>A. H x)"
by (intro UN_least parts_mono UN_upper)

lemma parts_UN_subset2: "parts(\<Union>x\<in>A. H x) \<subseteq> (\<Union>x\<in>A. parts(H x))"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_UN [simp]: "parts(\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts(H x))"
by (intro equalityI parts_UN_subset1 parts_UN_subset2)

text{*Added to simplify arguments to parts, analz and synth.
  NOTE: the UN versions are no longer used!*}

text{*This allows @{text blast} to simplify occurrences of
  @{term "parts(G\<union>H)"} in the assumption.*}
lemmas in_parts_UnE = parts_Un [THEN equalityD1, THEN subsetD, THEN UnE]
declare in_parts_UnE [elim!]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

subsubsection{*Idempotence and transitivity *}

lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_subset_iff [simp]: "(parts G \<subseteq> parts H) = (G \<subseteq> parts H)"
apply (rule iffI)
apply (iprover intro: subset_trans parts_increasing)
apply (frule parts_mono, simp)
done

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (drule parts_mono, blast)

text{*Cut*}
lemma parts_cut:
     "[| Y\<in> parts (insert X G);  X\<in> parts H |] ==> Y\<in> parts (G \<union> H)"
by (blast intro: parts_trans)

lemma parts_cut_eq [simp]: "X\<in> parts H ==> parts (insert X H) = parts H"
by (force dest!: parts_cut intro: parts_insertI)

subsubsection{*Rewrite rules for pulling out atomic messages *}

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
     "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Nonce [simp]:
     "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Key [simp]:
     "parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Crypt [simp]:
     "parts (insert (Crypt K X) H) = insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Body)
done

lemma parts_insert_MPair [simp]:
     "parts (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Fst parts.Snd)+
done

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
apply auto
apply (erule parts.induct, auto)
done

text{*In any message, there is an upper bound N on its greatest nonce.*}
lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n --> Nonce n \<notin> parts {msg}"
apply (induct_tac "msg")
apply (simp_all (no_asm_simp) add: exI parts_insert2)
 txt{*MPair case: blast works out the necessary sum itself!*}
 prefer 2 apply auto apply (blast elim!: add_leE)
txt{*Nonce case*}
apply (rename_tac nat)
apply (rule_tac x = "N + Suc nat" in exI, auto)
done
(*>*)

section{* Modelling the Adversary *}

text {*
The spy is part of the system and must be built into the model.  He is
a malicious user who does not have to follow the protocol.  He
watches the network and uses any keys he knows to decrypt messages.
Thus he accumulates additional keys and nonces.  These he can use to
compose new messages, which he may send to anybody.

Two functions enable us to formalize this behaviour: @{text analz} and
@{text synth}.  Each function maps a sets of messages to another set of
messages. The set @{text "analz H"} formalizes what the adversary can learn
from the set of messages~$H$.  The closure properties of this set are
defined inductively.
*}

inductive_set
  analz :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Inj [intro,simp] : "X \<in> H \<Longrightarrow> X \<in> analz H"
  | Fst:     "\<lbrace>X,Y\<rbrace> \<in> analz H \<Longrightarrow> X \<in> analz H"
  | Snd:     "\<lbrace>X,Y\<rbrace> \<in> analz H \<Longrightarrow> Y \<in> analz H"
  | Decrypt [dest]:
             "\<lbrakk>Crypt K X \<in> analz H; Key(invKey K) \<in> analz H\<rbrakk>
              \<Longrightarrow> X \<in> analz H"
(*<*)
text{*Monotonicity; Lemma 1 of Lowe's paper*}
lemma analz_mono: "G\<subseteq>H ==> analz(G) \<subseteq> analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd)
done

text{*Making it safe speeds up proofs*}
lemma MPair_analz [elim!]:
     "[| \<lbrace>X,Y\<rbrace> \<in> analz H;
             [| X \<in> analz H; Y \<in> analz H |] ==> P
          |] ==> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_increasing: "H \<subseteq> analz(H)"
by blast

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
apply (rule equalityI)
apply (rule analz_subset_parts [THEN parts_mono, THEN subset_trans], simp)
apply (blast intro: analz_increasing [THEN parts_mono, THEN subsetD])
done

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]

subsubsection{*General equational properties *}

lemma analz_empty [simp]: "analz{} = {}"
apply safe
apply (erule analz.induct, blast+)
done

text{*Converse fails: we can analz more from the union than from the
  separate parts, as a key in one might decrypt a message in the other*}
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsubsection{*Rewrite rules for pulling out atomic messages *}

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_insert_Agent [simp]:
     "analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Nonce [simp]:
     "analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

text{*Can only pull out Keys if they are not needed to decrypt the rest*}
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) ==>
          analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_MPair [simp]:
     "analz (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct)
apply (blast intro: analz.Fst analz.Snd)+
done

text{*Can pull out enCrypted message if the Key is not known*}
lemma analz_insert_Crypt:
     "Key (invKey K) \<notin> analz H
      ==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)

done

lemma lemma1: "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) \<subseteq>
               insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule_tac x = x in analz.induct, auto)
done

lemma lemma2: "Key (invKey K) \<in> analz H ==>
               insert (Crypt K X) (analz (insert X H)) \<subseteq>
               analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
apply (blast intro: analz_insertI analz.Decrypt)
done

lemma analz_insert_Decrypt:
     "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) =
               insert (Crypt K X) (analz (insert X H))"
by (intro equalityI lemma1 lemma2)

text{*Case analysis: either the message is secure, or it is not! Effective,
but can cause subgoals to blow up! Use with @{text "if_split"}; apparently
@{text "split_tac"} does not cope with patterns such as @{term"analz (insert
(Crypt K X) H)"} *}
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

text{*This rule supposes "for the sake of argument" that we have the key.*}
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule analz.induct, auto)
done

lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done

subsubsection{*Idempotence and transitivity *}

lemma analz_analzD [dest!]: "X\<in> analz (analz H) ==> X\<in> analz H"
by (erule analz.induct, blast+)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast

lemma analz_subset_iff [simp]: "(analz G \<subseteq> analz H) = (G \<subseteq> analz H)"
apply (rule iffI)
apply (iprover intro: subset_trans analz_increasing)
apply (frule analz_mono, simp)
done

lemma analz_trans: "[| X\<in> analz G;  G \<subseteq> analz H |] ==> X\<in> analz H"
by (drule analz_mono, blast)

text{*Cut; Lemma 2 of Lowe*}
lemma analz_cut: "[| Y\<in> analz (insert X H);  X\<in> analz H |] ==> Y\<in> analz H"
by (erule analz_trans, blast)

(*Cut can be proved easily by induction on
   "Y: analz (insert X H) ==> X: analz H --> Y: analz H"
*)

text{*This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated. *}
lemma analz_insert_eq: "X\<in> analz H ==> analz (insert X H) = analz H"
by (blast intro: analz_cut analz_insertI)

text{*A congruence rule for "analz" *}

lemma analz_subset_cong:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H' |]
      ==> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
apply simp
apply (iprover intro: conjI subset_trans analz_mono Un_upper1 Un_upper2)
done

lemma analz_cong:
     "[| analz G = analz G'; analz H = analz H' |]
      ==> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
     "analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)

text{*If there are no pairs or encryptions then analz does nothing*}
lemma analz_trivial:
     "[| \<forall>X Y. \<lbrace>X,Y\<rbrace> \<notin> H;  \<forall>X K. Crypt K X \<notin> H |] ==> analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

text{*These two are obsolete (with a single Spy) but cost little to prove...*}
lemma analz_UN_analz_lemma:
     "X\<in> analz (\<Union>i\<in>A. analz (H i)) ==> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])+
done

lemma analz_UN_analz [simp]: "analz (\<Union>i\<in>A. analz (H i)) = analz (\<Union>i\<in>A. H i)"
by (blast intro: analz_UN_analz_lemma analz_mono [THEN [2] rev_subsetD])
(*>*)
text {*
Note the @{text Decrypt} rule: the spy can decrypt a
message encrypted with key~$K$ if he has the matching key,~$K^{-1}$.
Properties proved by rule induction include the following:
@{named_thms [display,indent=0] analz_mono [no_vars] (analz_mono) analz_idem [no_vars] (analz_idem)}

The set of fake messages that an intruder could invent
starting from~@{text H} is @{text "synth(analz H)"}, where @{text "synth H"}
formalizes what the adversary can build from the set of messages~$H$.
*}

inductive_set
  synth :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Inj    [intro]: "X \<in> H \<Longrightarrow> X \<in> synth H"
  | Agent  [intro]: "Agent agt \<in> synth H"
  | MPair  [intro]:
              "\<lbrakk>X \<in> synth H;  Y \<in> synth H\<rbrakk> \<Longrightarrow> \<lbrace>X,Y\<rbrace> \<in> synth H"
  | Crypt  [intro]:
              "\<lbrakk>X \<in> synth H;  Key K \<in> H\<rbrakk> \<Longrightarrow> Crypt K X \<in> synth H"
(*<*)
lemma synth_mono: "G\<subseteq>H ==> synth(G) \<subseteq> synth(H)"
  by (auto, erule synth.induct, auto)

inductive_cases Key_synth   [elim!]: "Key K \<in> synth H"
inductive_cases MPair_synth [elim!]: "\<lbrace>X,Y\<rbrace> \<in> synth H"
inductive_cases Crypt_synth [elim!]: "Crypt K X \<in> synth H"

lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct)
prefer 5 apply (blast intro: analz_mono [THEN [2] rev_subsetD])
apply (blast intro: analz.Fst analz.Snd analz.Decrypt)+
done

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
apply (cut_tac H = "{}" in analz_synth_Un)
apply (simp (no_asm_use))
done
(*>*)
text {*
The set includes all agent names.  Nonces and keys are assumed to be
unguessable, so none are included beyond those already in~$H$.   Two
elements of @{term "synth H"} can be combined, and an element can be encrypted
using a key present in~$H$.

Like @{text analz}, this set operator is monotone and idempotent.  It also
satisfies an interesting equation involving @{text analz}:
@{named_thms [display,indent=0] analz_synth [no_vars] (analz_synth)}
Rule inversion plays a major role in reasoning about @{text synth}, through
declarations such as this one:
*}

inductive_cases Nonce_synth [elim!]: "Nonce n \<in> synth H"

text {*
\noindent
The resulting elimination rule replaces every assumption of the form
@{term "Nonce n \<in> synth H"} by @{term "Nonce n \<in> H"},
expressing that a nonce cannot be guessed.

A third operator, @{text parts}, is useful for stating correctness
properties.  The set
@{term "parts H"} consists of the components of elements of~$H$.  This set
includes~@{text H} and is closed under the projections from a compound
message to its immediate parts.
Its definition resembles that of @{text analz} except in the rule
corresponding to the constructor @{text Crypt}:
@{thm [display,indent=5] parts.Body [no_vars]}
The body of an encrypted message is always regarded as part of it.  We can
use @{text parts} to express general well-formedness properties of a protocol,
for example, that an uncompromised agent's private key will never be
included as a component of any message.
*}
(*<*)
lemma synth_increasing: "H \<subseteq> synth(H)"
by blast

subsubsection{*Unions *}

text{*Converse fails: we can synth more from the union than from the
  separate parts, building a compound message using elements of each.*}
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (blast intro: synth_mono [THEN [2] rev_subsetD])

subsubsection{*Idempotence and transitivity *}

lemma synth_synthD [dest!]: "X\<in> synth (synth H) ==> X\<in> synth H"
by (erule synth.induct, blast+)

lemma synth_idem: "synth (synth H) = synth H"
by blast

lemma synth_subset_iff [simp]: "(synth G \<subseteq> synth H) = (G \<subseteq> synth H)"
apply (rule iffI)
apply (iprover intro: subset_trans synth_increasing)
apply (frule synth_mono, simp add: synth_idem)
done

lemma synth_trans: "[| X\<in> synth G;  G \<subseteq> synth H |] ==> X\<in> synth H"
by (drule synth_mono, blast)

text{*Cut; Lemma 2 of Lowe*}
lemma synth_cut: "[| Y\<in> synth (insert X H);  X\<in> synth H |] ==> Y\<in> synth H"
by (erule synth_trans, blast)

lemma Agent_synth [simp]: "Agent A \<in> synth H"
by blast

lemma Nonce_synth_eq [simp]: "(Nonce N \<in> synth H) = (Nonce N \<in> H)"
by blast

lemma Crypt_synth_eq [simp]:
     "Key K \<notin> H ==> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast

lemma keysFor_synth [simp]:
    "keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)

subsubsection{*Combinations of parts, analz and synth *}

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (blast intro: synth_increasing [THEN parts_mono, THEN subsetD]
                    parts.Fst parts.Snd parts.Body)+
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (intro equalityI analz_subset_cong)+
apply simp_all
done

subsubsection{*For reasoning about the Fake rule in traces *}

lemma parts_insert_subset_Un: "X\<in> G ==> parts(insert X H) \<subseteq> parts G \<union> parts H"
by (rule subset_trans [OF parts_mono parts_Un_subset2], blast)

text{*More specifically for Fake.  Very occasionally we could do with a version
  of the form  @{term"parts{X} \<subseteq> synth (analz H) \<union> parts H"} *}
lemma Fake_parts_insert:
     "X \<in> synth (analz H) ==>
      parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
apply (drule parts_insert_subset_Un)
apply (simp (no_asm_use))
apply blast
done

lemma Fake_parts_insert_in_Un:
     "[|Z \<in> parts (insert X H);  X: synth (analz H)|]
      ==> Z \<in>  synth (analz H) \<union> parts H"
by (blast dest: Fake_parts_insert  [THEN subsetD, dest])

text{*@{term H} is sometimes @{term"Key ` KK \<union> spies evs"}, so can't put
  @{term "G=H"}.*}
lemma Fake_analz_insert:
     "X\<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H) ")
prefer 2 apply (blast intro: analz_mono [THEN [2] rev_subsetD] analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
apply (simp (no_asm_use))
apply blast
done

lemma analz_conj_parts [simp]:
     "(X \<in> analz H & X \<in> parts H) = (X \<in> analz H)"
by (blast intro: analz_subset_parts [THEN subsetD])

lemma analz_disj_parts [simp]:
     "(X \<in> analz H | X \<in> parts H) = (X \<in> parts H)"
by (blast intro: analz_subset_parts [THEN subsetD])

text{*Without this equation, other rules for synth and analz would yield
  redundant cases*}
lemma MPair_synth_analz [iff]:
     "(\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) =
      (X \<in> synth (analz H) & Y \<in> synth (analz H))"
by blast

lemma Crypt_synth_analz:
     "[| Key K \<in> analz H;  Key (invKey K) \<in> analz H |]
       ==> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
by blast

text{*We do NOT want Crypt... messages broken up in protocols!!*}
declare parts.Body [rule del]

text{*Rewrites to push in Key and Crypt messages, so that other messages can
    be pulled out using the @{text analz_insert} rules*}

lemmas pushKeys =
  insert_commute [of "Key K" "Agent C"]
  insert_commute [of "Key K" "Nonce N"]
  insert_commute [of "Key K" "Number N"]
  insert_commute [of "Key K" "Hash X"]
  insert_commute [of "Key K" "MPair X Y"]
  insert_commute [of "Key K" "Crypt X K'"]
  for K C N X Y K'

lemmas pushCrypts =
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Nonce N"]
  insert_commute [of "Crypt X K" "Number N"]
  insert_commute [of "Crypt X K" "Hash X'"]
  insert_commute [of "Crypt X K" "MPair X' Y"]
  for X K C N X' Y

text{*Cannot be added with @{text "[simp]"} -- messages should not always be
  re-ordered. *}
lemmas pushes = pushKeys pushCrypts

subsection{*Tactics useful for many protocol proofs*}
ML
{*
val invKey = @{thm invKey};
val keysFor_def = @{thm keysFor_def};
val symKeys_def = @{thm symKeys_def};
val parts_mono = @{thm parts_mono};
val analz_mono = @{thm analz_mono};
val synth_mono = @{thm synth_mono};
val analz_increasing = @{thm analz_increasing};

val analz_insertI = @{thm analz_insertI};
val analz_subset_parts = @{thm analz_subset_parts};
val Fake_parts_insert = @{thm Fake_parts_insert};
val Fake_analz_insert = @{thm Fake_analz_insert};
val pushes = @{thms pushes};

(*Analysis of Fake cases.  Also works for messages that forward unknown parts,
  but this application is no longer necessary if analz_insert_eq is used.
  Abstraction over i is ESSENTIAL: it delays the dereferencing of claset
  DEPENDS UPON "X" REFERRING TO THE FRADULENT MESSAGE *)

(*Apply rules to break down assumptions of the form
  Y \<in> parts(insert X H)  and  Y \<in> analz(insert X H)
*)
fun impOfSubs th = th RSN (2, @{thm rev_subsetD})

fun Fake_insert_tac ctxt =
    dresolve_tac ctxt [impOfSubs Fake_analz_insert,
                  impOfSubs Fake_parts_insert] THEN'
    eresolve_tac ctxt [asm_rl, @{thm synth.Inj}];

fun Fake_insert_simp_tac ctxt i =
  REPEAT (Fake_insert_tac ctxt i) THEN asm_full_simp_tac ctxt i;

fun atomic_spy_analz_tac ctxt =
  SELECT_GOAL
   (Fake_insert_simp_tac ctxt 1 THEN
    IF_UNSOLVED (Blast.depth_tac (ctxt addIs [analz_insertI, impOfSubs analz_subset_parts]) 4 1));

fun spy_analz_tac ctxt i =
  DETERM
   (SELECT_GOAL
     (EVERY
      [  (*push in occurrences of X...*)
       (REPEAT o CHANGED)
         (Rule_Insts.res_inst_tac ctxt [((("x", 1), Position.none), "X")] []
           (insert_commute RS ssubst) 1),
       (*...allowing further simplifications*)
       simp_tac ctxt 1,
       REPEAT (FIRSTGOAL (resolve_tac ctxt [allI,impI,notI,conjI,iffI])),
       DEPTH_SOLVE (atomic_spy_analz_tac ctxt 1)]) i);
*}

text{*By default only @{text o_apply} is built-in.  But in the presence of
eta-expansion this means that some terms displayed as @{term "f o g"} will be
rewritten, and others will not!*}
declare o_def [simp]

lemma Crypt_notin_image_Key [simp]: "Crypt K X \<notin> Key ` A"
by auto

lemma synth_analz_mono: "G\<subseteq>H ==> synth (analz(G)) \<subseteq> synth (analz(H))"
by (iprover intro: synth_mono analz_mono)

lemma Fake_analz_eq [simp]:
     "X \<in> synth(analz H) ==> synth (analz (insert X H)) = synth (analz H)"
apply (drule Fake_analz_insert[of _ _ "H"])
apply (simp add: synth_increasing[THEN Un_absorb2])
apply (drule synth_mono)
apply (simp add: synth_idem)
apply (rule equalityI)
apply (simp add: )
apply (rule synth_analz_mono, blast)
done

text{*Two generalizations of @{text analz_insert_eq}*}
lemma gen_analz_insert_eq [rule_format]:
     "X \<in> analz H ==> ALL G. H \<subseteq> G --> analz (insert X G) = analz G"
by (blast intro: analz_cut analz_insertI analz_mono [THEN [2] rev_subsetD])

lemma synth_analz_insert_eq [rule_format]:
     "X \<in> synth (analz H)
      ==> ALL G. H \<subseteq> G --> (Key K \<in> analz (insert X G)) = (Key K \<in> analz G)"
apply (erule synth.induct)
apply (simp_all add: gen_analz_insert_eq subset_trans [OF _ subset_insertI])
done

lemma Fake_parts_sing:
     "X \<in> synth (analz H) ==> parts{X} \<subseteq> synth (analz H) \<union> parts H"
apply (rule subset_trans)
 apply (erule_tac [2] Fake_parts_insert)
apply (rule parts_mono, blast)
done

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

method_setup spy_analz = {*
    Scan.succeed (SIMPLE_METHOD' o spy_analz_tac) *}
    "for proving the Fake case when analz is involved"

method_setup atomic_spy_analz = {*
    Scan.succeed (SIMPLE_METHOD' o atomic_spy_analz_tac) *}
    "for debugging spy_analz"

method_setup Fake_insert_simp = {*
    Scan.succeed (SIMPLE_METHOD' o Fake_insert_simp_tac) *}
    "for debugging spy_analz"

end
(*>*)


theory Finprod
  imports IDirProds
begin

lemma (in comm_group) finprod_subgroup:
  assumes "f \<in> S \<rightarrow> H" "subgroup H G"
  shows "finprod G f S = finprod (G\<lparr>carrier := H\<rparr>) f S"
proof (cases "finite S")
  case True
  interpret H: comm_group "G\<lparr>carrier := H\<rparr>" using subgroup_is_comm_group[OF assms(2)] .
  show ?thesis using True assms
  proof (induction S rule: finite_induct)
    case empty
    then show ?case using finprod_empty H.finprod_empty by simp
  next
    case i: (insert x F)
    then have "finprod G f F = finprod (G\<lparr>carrier := H\<rparr>) f F" by blast
    moreover have "finprod G f (insert x F) = f x \<otimes> finprod G f F"
    proof(intro finprod_insert[OF i(1, 2), of f])
      show "f \<in> F \<rightarrow> carrier G" "f x \<in> carrier G" using i(4) subgroup.subset[OF i(5)] by blast+
    qed
    ultimately have "finprod G f (insert x F) = f x \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> finprod (G\<lparr>carrier := H\<rparr>) f F" by auto
    moreover have "finprod (G\<lparr>carrier := H\<rparr>) f (insert x F) = \<dots>"
    proof(intro H.finprod_insert[OF i(1, 2)])
      show "f \<in> F \<rightarrow> carrier (G\<lparr>carrier := H\<rparr>)" "f x \<in> carrier (G\<lparr>carrier := H\<rparr>)" using i(4) by auto
    qed
    ultimately show ?case by simp
  qed
next
  case False
  then show ?thesis unfolding finprod_def by simp
qed

lemma (in comm_group) finprod_eq:
  assumes "\<And>a. a \<in> A \<Longrightarrow> f a \<otimes> g a = h a"
  and "f \<in> A \<rightarrow> carrier G" "g \<in> A \<rightarrow> carrier G" "h \<in> A \<rightarrow> carrier G"
  shows "finprod G h A = finprod G f A \<otimes> finprod G g A" using assms
proof(induct A rule: infinite_finite_induct)
case (infinite A)
then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case i: (insert x F)
  then have iH: "finprod G h F = finprod G f F \<otimes> finprod G g F" by fast
  have f: "finprod G f (insert x F) = f x \<otimes> finprod G f F" by(intro finprod_insert[OF i(1, 2), of f]; use i(5) in simp)
  have g: "finprod G g (insert x F) = g x \<otimes> finprod G g F" by(intro finprod_insert[OF i(1, 2), of g]; use i(6) in simp)
  have h: "finprod G h (insert x F) = h x \<otimes> finprod G h F" by(intro finprod_insert[OF i(1, 2), of h]; use i(7) in simp)
  also have "\<dots> = h x \<otimes> (finprod G f F \<otimes> finprod G g F)" using iH by argo
  also have "\<dots> = f x \<otimes> g x \<otimes> (finprod G f F \<otimes> finprod G g F)" using i(4) by simp
  also have "\<dots> = f x \<otimes> finprod G f F \<otimes> (g x \<otimes> finprod G g F)" using m_comm m_assoc i(5-7) by simp
  also have "\<dots> = finprod G f (insert x F) \<otimes> finprod G g (insert x F)" using f g by argo
  finally show ?case .
qed

lemma (in comm_group) finprod_closed_subgroup:
  assumes "subgroup H G" "f \<in> A \<rightarrow> H"
  shows "finprod G f A \<in> H"
  using assms(2)
proof (induct A rule: infinite_finite_induct)
case (infinite A)
then show ?case using subgroup.one_closed[OF assms(1)] by auto
next
  case empty
  then show ?case using subgroup.one_closed[OF assms(1)] by auto
next
  case i: (insert x F)
  from finprod_insert[OF i(1, 2), of f] i have fi: "finprod G f (insert x F) = f x \<otimes> finprod G f F"
    using subgroup.subset[OF assms(1)] by blast
  from i have "finprod G f F \<in> H" "f x \<in> H" by blast+
  with fi show ?case using subgroup.m_closed[OF assms(1)] by presburger
qed

lemma (in comm_group) finprod_comp:
  assumes "inj_on g A" "(f \<circ> g) ` A \<subseteq> carrier G"
  shows "finprod G f (g ` A) = finprod G (f \<circ> g) A"
  using finprod_reindex[OF _ assms(1), of f] using assms(2) unfolding comp_def by blast

lemma (in comm_group) finprod_minus:
  assumes "a \<in> A" "f \<in> A \<rightarrow> carrier G" "finite A"
  shows "finprod G f A = f a \<otimes> finprod G f (A - {a})"
proof -
  from assms have "A = insert a (A - {a})" by blast
  then have "finprod G f A = finprod G f (insert a (A - {a}))" by simp
  also have "\<dots> = f a \<otimes> finprod G f (A - {a})" using assms by (intro finprod_insert, auto)
  finally show ?thesis .
qed

lemma (in comm_group) finprod_minus_symm:
  assumes "a \<in> A" "f \<in> A \<rightarrow> carrier G" "finite A"
  shows "finprod G f A = finprod G f (A - {a}) \<otimes> f a"
proof -
  from assms have "A = insert a (A - {a})" by blast
  then have "finprod G f A = finprod G f (insert a (A - {a}))" by simp
  also have "\<dots> = f a \<otimes> finprod G f (A - {a})" using assms by (intro finprod_insert, auto)
  also have "\<dots> = finprod G f (A - {a}) \<otimes> f a"
    by (intro m_comm, use assms in blast, intro finprod_closed, use assms in blast)
  finally show ?thesis .
qed

lemma (in comm_group) finprod_singleton:
  assumes "f x \<in> carrier G" "finprod G f {x} = a"
  shows "f x = a"
proof -
  have "finprod G f {x} = f x \<otimes> finprod G f {}" using finprod_minus[of x "{x}" f] assms by auto
  thus ?thesis using assms by simp
qed

lemma (in comm_group) finprod_exp:
  assumes "A \<subseteq> carrier G" "f \<in> A \<rightarrow> carrier G"
  shows "(finprod G f A) [^] (k::int) = finprod G ((\<lambda>a. a [^] k) \<circ> f) A"
  using assms
proof(induction A rule: infinite_finite_induct)
  case i: (insert x F)
  hence ih: "finprod G f F [^] k = finprod G ((\<lambda>a. a [^] k) \<circ> f) F" by blast
  have fpc: "finprod G f F \<in> carrier G" by (intro finprod_closed, use i in auto)
  have fxc: "f x \<in> carrier G" using i by auto
  have "finprod G f (insert x F) = f x \<otimes> finprod G f F" by (intro finprod_insert, use i in auto)
  hence "finprod G f (insert x F) [^] k = (f x \<otimes> finprod G f F) [^] k" by simp
  also have "\<dots> = f x [^] k \<otimes> finprod G f F [^] k" using fpc fxc int_pow_distrib by blast
  also have "\<dots> = ((\<lambda>a. a [^] k) \<circ> f) x \<otimes> finprod G ((\<lambda>a. a [^] k) \<circ> f) F" using ih by simp
  also have "\<dots> = finprod G ((\<lambda>a. a [^] k) \<circ> f) (insert x F)" by (intro finprod_insert[symmetric], use i in auto)
  finally show ?case .
qed auto

lemma (in comm_group) generate_eq_finprod_PiE_image:
  assumes "finite gs" "gs \<subseteq> carrier G"
  shows "generate G gs = (\<lambda>x. finprod G x gs) ` Pi\<^sub>E gs (\<lambda>a. generate G {a})" (is "?g = ?fp")
proof
  show "?g \<subseteq> ?fp"
  proof
    fix x
    assume x: "x \<in> ?g"
    thus "x \<in> ?fp"
    proof (induction rule: generate.induct)
      case one
      show ?case
      proof
        let ?r = "restrict (\<lambda>_. \<one>) gs"
        show "?r \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" using generate.one by auto
        show "\<one> = finprod G ?r gs" by(intro finprod_one_eqI[symmetric], simp)
      qed
    next
      case g: (incl g)
      show ?case
      proof
        let ?r = "restrict ((\<lambda>_. \<one>)(g := g)) gs"
        show "?r \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" using generate.one generate.incl[of g "{g}" G] by fastforce
        show "g = finprod G ?r gs"
        proof -
          have "finprod G ?r gs = ?r g \<otimes> finprod G ?r (gs - {g})"
          proof -
            have "gs = insert g (gs - {g})" using g by fast
            then have "finprod G ?r gs = finprod G ?r (insert g (gs - {g}))" by simp
            also have "\<dots> = ?r g \<otimes> finprod G ?r (gs - {g})"
              by(rule finprod_insert, use assms g in auto)
            finally show ?thesis .
          qed
          moreover have "?r g = g" using g by simp
          moreover have "finprod G ?r (gs - {g}) = \<one>" by(rule finprod_one_eqI; use g in simp)
          ultimately show ?thesis using assms g by auto
        qed
      qed
    next
      case g: (inv g)
      show ?case
      proof
        let ?r = "restrict ((\<lambda>_. \<one>)(g := inv g)) gs"
        show "?r \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" using generate.one generate.inv[of g "{g}" G] by fastforce
        show "inv g = finprod G ?r gs"
        proof -
          have "finprod G ?r gs = ?r g \<otimes> finprod G ?r (gs - {g})"
          proof -
            have "gs = insert g (gs - {g})" using g by fast
            then have "finprod G ?r gs = finprod G ?r (insert g (gs - {g}))" by simp
            also have "\<dots> = ?r g \<otimes> finprod G ?r (gs - {g})"
              by(rule finprod_insert, use assms g in auto)
            finally show ?thesis .
          qed
          moreover have "?r g = inv g" using g by simp
          moreover have "finprod G ?r (gs - {g}) = \<one>" by(rule finprod_one_eqI; use g in simp)
          ultimately show ?thesis using assms g by auto
        qed
      qed
    next
      case gh: (eng g h)
      from gh obtain i where i: "i \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" "g = finprod G i gs" by blast
      from gh obtain j where j: "j \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" "h = finprod G j gs" by blast
      from i j have "g \<otimes> h = finprod G i gs \<otimes> finprod G j gs" by blast
      also have "\<dots> = finprod G (\<lambda>a. i a \<otimes> j a) gs"
      proof(intro finprod_multf[symmetric]; rule)
        fix x
        assume x: "x \<in> gs"
        have "i x \<in> generate G {x}" "j x \<in> generate G {x}"using i(1) j(1) x by blast+
        thus "i x \<in> carrier G" "j x \<in> carrier G" using generate_incl[of "{x}"] x assms(2) by blast+
      qed
      also have "\<dots> = finprod G (restrict (\<lambda>a. i a \<otimes> j a) gs) gs"
      proof(intro finprod_cong)
        have ip: "i g \<in> generate G {g}" if "g \<in> gs" for g using i that by auto
        have jp: "j g \<in> generate G {g}" if "g \<in> gs" for g using j that by auto
        have "i g \<otimes> j g \<in> generate G {g}" if "g \<in> gs" for g using generate.eng[OF ip[OF that] jp[OF that]] .
        thus "((\<lambda>a. i a \<otimes> j a) \<in> gs \<rightarrow> carrier G) = True" using generate_incl assms(2) by blast
      qed auto
      finally have "g \<otimes> h = finprod G (restrict (\<lambda>a. i a \<otimes> j a) gs) gs" .
      moreover have "(restrict (\<lambda>a. i a \<otimes> j a) gs) \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})"
      proof -
        have ip: "i g \<in> generate G {g}" if "g \<in> gs" for g using i that by auto
        have jp: "j g \<in> generate G {g}" if "g \<in> gs" for g using j that by auto
        have "i g \<otimes> j g \<in> generate G {g}" if "g \<in> gs" for g using generate.eng[OF ip[OF that] jp[OF that]] .
        thus ?thesis by auto
      qed
      ultimately show ?case using i j by blast
    qed
  qed
  show "?fp \<subseteq> ?g"
  proof
    fix x
    assume x: "x \<in> ?fp"
    then obtain f where f: "f \<in> (Pi\<^sub>E gs (\<lambda>a. generate G {a}))" "x = finprod G f gs" by blast
    have sg: "subgroup ?g G" by(intro generate_is_subgroup, fact)
    have "finprod G f gs \<in> ?g"
    proof(intro finprod_closed_subgroup[OF sg])
      have "f g \<in> generate G gs" if "g \<in> gs" for g
      proof -
        have "f g \<in> generate G {g}" using f(1) that by auto
        moreover have "generate G {g} \<subseteq> generate G gs" by(intro mono_generate, use that in simp)
        ultimately show ?thesis by fast
      qed
      thus "f \<in> gs \<rightarrow> generate G gs" by simp
    qed
    thus "x \<in> ?g" using f by blast
  qed
qed

lemma (in comm_group) generate_eq_finprod_Pi_image:
  assumes "finite gs" "gs \<subseteq> carrier G"
  shows "generate G gs = (\<lambda>x. finprod G x gs) ` Pi gs (\<lambda>a. generate G {a})" (is "?g = ?fp")
proof -
  have "(\<lambda>x. finprod G x gs) ` Pi\<^sub>E gs (\<lambda>a. generate G {a}) = (\<lambda>x. finprod G x gs) ` Pi gs (\<lambda>a. generate G {a})"
  proof
    have "Pi\<^sub>E gs (\<lambda>a. generate G {a}) \<subseteq> Pi gs (\<lambda>a. generate G {a})" by blast
    thus "(\<lambda>x. finprod G x gs) ` Pi\<^sub>E gs (\<lambda>a. generate G {a}) \<subseteq> (\<lambda>x. finprod G x gs) ` Pi gs (\<lambda>a. generate G {a})" by blast
    show "(\<lambda>x. finprod G x gs) ` Pi gs (\<lambda>a. generate G {a}) \<subseteq> (\<lambda>x. finprod G x gs) ` Pi\<^sub>E gs (\<lambda>a. generate G {a})"
    proof
      fix x
      assume x: "x \<in> (\<lambda>x. finprod G x gs) ` Pi gs (\<lambda>a. generate G {a})"
      then obtain f where f: "x = finprod G f gs" "f \<in> Pi gs (\<lambda>a. generate G {a})" by blast
      moreover have "finprod G f gs = finprod G (restrict f gs) gs"
      proof(intro finprod_cong)
        have "f g \<in> carrier G" if "g \<in> gs" for g
          using that f(2) mono_generate[of "{g}" gs] generate_incl[OF assms(2)] by fast
        thus "(f \<in> gs \<rightarrow> carrier G) = True" by blast
      qed auto
      moreover have "restrict f gs \<in> Pi\<^sub>E gs (\<lambda>a. generate G {a})" using f(2) by simp
      ultimately show "x \<in> (\<lambda>x. finprod G x gs) ` Pi\<^sub>E gs (\<lambda>a. generate G {a})" by blast
    qed
  qed
  with generate_eq_finprod_PiE_image[OF assms] show ?thesis by auto
qed

lemma (in comm_group) generate_eq_finprod_Pi_int_image:
  assumes "finite gs" "gs \<subseteq> carrier G"
  shows "generate G gs = (\<lambda>x. finprod G (\<lambda>g. g [^] x g) gs) ` Pi gs (\<lambda>_. (UNIV::int set))"
proof -
  from generate_eq_finprod_Pi_image[OF assms] have "generate G gs = (\<lambda>x. finprod G x gs) ` (\<Pi> a\<in>gs. generate G {a})" .
  also have "\<dots> = (\<lambda>x. finprod G (\<lambda>g. g [^] x g) gs) ` Pi gs (\<lambda>_. (UNIV::int set))"
  proof(rule; rule)
    fix x
    assume x: "x \<in> (\<lambda>x. finprod G x gs) ` (\<Pi> a\<in>gs. generate G {a})"
    then obtain f where f: "f \<in> (\<Pi> a\<in>gs. generate G {a})" "x = finprod G f gs" by blast
    hence "\<exists>k::int. f a = a [^] k" if "a \<in> gs" for a using generate_pow[of a] that assms(2) by blast
    hence "\<exists>(h::'a \<Rightarrow> int). \<forall>a\<in>gs. f a = a [^] h a" by meson
    then obtain h where h: "\<forall>a\<in>gs. f a = a [^] h a" "h \<in> gs \<rightarrow> (UNIV :: int set)" by auto
    have "finprod G (\<lambda>g. g [^] h g) gs = finprod G f gs" by (intro finprod_cong, use int_pow_closed h assms(2) in auto)
    with f have "x = finprod G (\<lambda>g. g [^] h g) gs" by argo
    with h(2) show "x \<in> (\<lambda>x. finprod G (\<lambda>g. g [^] x g) gs) ` (gs \<rightarrow> (UNIV::int set))" by auto
  next
    fix x
    assume x: "x \<in> (\<lambda>x. finprod G (\<lambda>g. g [^] x g) gs) ` (gs \<rightarrow> (UNIV::int set))"
    then obtain h where h: "x = finprod G (\<lambda>g. g [^] h g) gs" "h \<in> gs \<rightarrow> (UNIV :: int set)" by blast
    hence "\<exists>k\<in>generate G {a}. a [^] h a = k" if "a \<in> gs" for a using generate_pow[of a] that assms(2) by blast
    then obtain f where f: "\<forall>a\<in>gs. a [^] h a = f a" "f \<in> (\<Pi> a\<in>gs. generate G {a})" by fast
    have "finprod G f gs = finprod G (\<lambda>g. g [^] h g) gs"
    proof(intro finprod_cong)
      have "f a \<in> carrier G" if "a \<in> gs" for a using generate_incl[of "{a}"] assms(2) that f(2) by fast
      thus "(f \<in> gs \<rightarrow> carrier G) = True" by blast
    qed (use f in auto)
    with h have "x = finprod G f gs" by argo
    with f(2) show "x \<in> (\<lambda>x. finprod G x gs) ` (\<Pi> a\<in>gs. generate G {a})" by blast
  qed
  finally show ?thesis .
qed

lemma (in comm_group) generate_one_switched_exp_eqI:
  assumes "A \<subseteq> carrier G" "a \<in> A" "B = (A - {a}) \<union> {b}"
  and "f \<in> A \<rightarrow> (UNIV::int set)" "g \<in> B \<rightarrow> (UNIV::int set)"
  and "a = finprod G (\<lambda>x. x [^] g x) B" "b = finprod G (\<lambda>x. x [^] f x) A"
  shows "generate G A = generate G B"
proof(intro generate_one_switched_eqI[OF assms(1, 2, 3)]; cases "finite A")
  case True
  hence fB: "finite B" using assms(3) by blast
  have cB: "B \<subseteq> carrier G"
  proof -
    have "b \<in> carrier G" by (subst assms(7), intro finprod_closed, use assms(1, 4) int_pow_closed in fast)
    thus ?thesis using assms(1, 3) by blast
  qed
  show "a \<in> generate G B"
  proof(subst generate_eq_finprod_Pi_image[OF fB cB], rule)
    show "a = finprod G (\<lambda>x. x [^] g x) B" by fact
    have "x [^] g x \<in> generate G {x}" if "x \<in> B" for x using generate_pow[of x] cB that by blast
    thus "(\<lambda>x. x [^] g x) \<in> (\<Pi> a\<in>B. generate G {a})" unfolding Pi_def by blast
  qed
  show "b \<in> generate G A"
  proof(subst generate_eq_finprod_Pi_image[OF True assms(1)], rule)
    show "b = finprod G (\<lambda>x. x [^] f x) A" by fact
    have "x [^] f x \<in> generate G {x}" if "x \<in> A" for x using generate_pow[of x] assms(1) that by blast
    thus "(\<lambda>x. x [^] f x) \<in> (\<Pi> a\<in>A. generate G {a})" unfolding Pi_def by blast
  qed
next
  case False
  hence b: "b = \<one>" using assms(7) unfolding finprod_def by simp
  from False assms(3) have "infinite B" by simp
  hence a: "a = \<one>" using assms(6) unfolding finprod_def by simp
  show "a \<in> generate G B" using generate.one a by blast
  show "b \<in> generate G A" using generate.one b by blast
qed

lemma (in comm_group) IDirProds_eq_finprod_PiE:
  assumes "finite Hs" "\<And>H. H \<in> Hs \<Longrightarrow> subgroup H G"
  shows "IDirProds G Hs = (\<lambda>x. finprod G x Hs) ` (Pi\<^sub>E Hs id)" (is "?DP = ?fp")
proof
  show "?fp \<subseteq> ?DP"
  proof
    fix x
    assume x: "x \<in> ?fp"
    then obtain f where f: "f \<in> (Pi\<^sub>E Hs id)" "x = finprod G f Hs" by blast
    have sDP: "subgroup ?DP G" by(intro IDirProds_is_subgroup; use subgroup.subset[OF assms(2)] in blast)
    have "finprod G f Hs \<in> ?DP"
    proof(intro finprod_closed_subgroup[OF sDP])
      have "f H \<in> IDirProds G Hs" if "H \<in> Hs" for H
      proof
        show "f H \<in> H" using f(1) that by auto
        show "H \<subseteq> IDirProds G Hs" by(intro IDirProds_incl[OF that])
      qed
      thus "f \<in> Hs \<rightarrow> IDirProds G Hs" by simp
    qed
    thus "x \<in> ?DP" using f by blast
  qed
  show "?DP \<subseteq> ?fp"
  proof(unfold IDirProds_def; rule subsetI)
    fix x
    assume x: "x \<in> generate G (\<Union>Hs)"
    thus "x \<in> ?fp" using assms
    proof (induction rule: generate.induct)
      case one
      define g where g: "g = (\<lambda>x. if x \<in> Hs then \<one> else undefined)"
      then have "g \<in> Pi\<^sub>E Hs id"
        using subgroup.one_closed[OF one(2)] by auto
      moreover have "finprod G g Hs = \<one>" by(intro finprod_one_eqI; use g in simp)
      ultimately show ?case unfolding image_def by (auto; metis)
    next
      case i: (incl h)
      from i obtain H where H: "H \<in> Hs" "h \<in> H" by blast
      define hf where "hf = (\<lambda>x. (if x \<in> Hs then \<one> else undefined))(H := h)"
      with H have "hf \<in> Pi\<^sub>E Hs id"
        using subgroup.one_closed[OF i(3)] by force
      moreover have "finprod G hf Hs = h"
      proof -
        have "finprod G hf Hs = hf H \<otimes> finprod G hf (Hs - {H})"
        proof -
          have "Hs = insert H (Hs - {H})" using H by fast
          then have "finprod G hf Hs = finprod G hf (insert H (Hs - {H}))" by simp
          also have "\<dots> = hf H \<otimes> finprod G hf (Hs - {H})"
            by (rule finprod_insert; use assms hf_def subgroup.subset[OF i(3)[OF H(1)]] H in auto)
          finally show ?thesis .
        qed
        moreover have "hf H = h" using hf_def by simp
        moreover have "finprod G hf (Hs - {H}) = \<one>" by(rule finprod_one_eqI; use hf_def in simp)
        ultimately show ?thesis using subgroup.subset[OF i(3)[OF H(1)]] H(2) by auto
      qed
      ultimately show ?case unfolding image_def by (auto; metis)
    next
      case i: (inv h)
      from i obtain H where H: "H \<in> Hs" "h \<in> H" by blast
      have ih: "inv h \<in> H" using subgroup.m_inv_closed[OF i(3)[OF H(1)] H(2)] .
      define hf where "hf = (\<lambda>x. (if x \<in> Hs then \<one> else undefined))(H := inv h)"
      with H ih have "hf \<in> Pi\<^sub>E Hs id"
        using subgroup.one_closed[OF i(3)] by force
      moreover have "finprod G hf Hs = inv h"
      proof -
        have "finprod G hf Hs = hf H \<otimes> finprod G hf (Hs - {H})"
        proof -
          have "Hs = insert H (Hs - {H})" using H by fast
          then have "finprod G hf Hs = finprod G hf (insert H (Hs - {H}))" by simp
          also have "\<dots> = hf H \<otimes> finprod G hf (Hs - {H})"
            by (rule finprod_insert; use assms hf_def subgroup.subset[OF i(3)[OF H(1)]] H in auto)
          finally show ?thesis .
        qed
        moreover have "hf H = inv h" using hf_def by simp
        moreover have "finprod G hf (Hs - {H}) = \<one>" by(rule finprod_one_eqI; use hf_def in simp)
        ultimately show ?thesis using subgroup.subset[OF i(3)[OF H(1)]] H(2) by auto
      qed
      ultimately show ?case unfolding image_def by (auto; metis)
    next
      case e: (eng a b)
      from e obtain f where f: "f \<in> Pi\<^sub>E Hs id" "a = finprod G f Hs" by blast
      from e obtain g where g: "g \<in> Pi\<^sub>E Hs id" "b = finprod G g Hs" by blast
      from f g have "a \<otimes> b = finprod G f Hs \<otimes> finprod G g Hs" by blast
      also have "\<dots> = finprod G (\<lambda>a. f a \<otimes> g a) Hs"
      proof(intro finprod_multf[symmetric])
        have "\<Union>Hs \<subseteq> carrier G" using subgroup.subset[OF e(6)] by blast
        thus "f \<in> Hs \<rightarrow> carrier G" "g \<in> Hs \<rightarrow> carrier G"
          using f(1) g(1) unfolding PiE_def Pi_def by auto
      qed
      also have "\<dots> = finprod G (restrict (\<lambda>a. f a \<otimes> g a) Hs) Hs"
      proof(intro finprod_cong)
        show "Hs = Hs" by simp
        show "\<And>i. i \<in> Hs =simp=> f i \<otimes> g i = (\<lambda>a\<in>Hs. f a \<otimes> g a) i" by simp
        have fp: "f H \<in> H" if "H \<in> Hs" for H using f that by auto
        have gp: "g H \<in> H" if "H \<in> Hs" for H using g that by auto
        have "f H \<otimes> g H \<in> H" if "H \<in> Hs" for H using subgroup.m_closed[OF e(6)[OF that] fp[OF that] gp[OF that]] .
        thus "((\<lambda>a. f a \<otimes> g a) \<in> Hs \<rightarrow> carrier G) = True" using subgroup.subset[OF e(6)] by auto
      qed
      finally have "a \<otimes> b = finprod G (restrict (\<lambda>a. f a \<otimes> g a) Hs) Hs" .
      moreover have "(restrict (\<lambda>a. f a \<otimes> g a) Hs) \<in> Pi\<^sub>E Hs id"
      proof -
        have fp: "f H \<in> H" if "H \<in> Hs" for H using f that by auto
        have gp: "g H \<in> H" if "H \<in> Hs" for H using g that by auto
        have "f H \<otimes> g H \<in> H" if "H \<in> Hs" for H using subgroup.m_closed[OF e(6)[OF that] fp[OF that] gp[OF that]] .
        thus ?thesis by auto
      qed
      ultimately show ?case using f g by blast
    qed
  qed
qed

lemma (in comm_group) IDirProds_eq_finprod_Pi:
  assumes "finite Hs" "\<And>H. H \<in> Hs \<Longrightarrow> subgroup H G"
  shows "IDirProds G Hs = (\<lambda>x. finprod G x Hs) ` (Pi Hs id)" (is "?DP = ?fp")
proof -
  have "(\<lambda>x. finprod G x Hs) ` (Pi Hs id) = (\<lambda>x. finprod G x Hs) ` (Pi\<^sub>E Hs id)"
  proof
    have "Pi\<^sub>E Hs id \<subseteq> Pi Hs id" by blast
    thus "(\<lambda>x. finprod G x Hs) ` Pi\<^sub>E Hs id \<subseteq> (\<lambda>x. finprod G x Hs) ` Pi Hs id" by blast
    show "(\<lambda>x. finprod G x Hs) ` Pi Hs id \<subseteq> (\<lambda>x. finprod G x Hs) ` Pi\<^sub>E Hs id"
    proof
      fix x
      assume x: "x \<in> (\<lambda>x. finprod G x Hs) ` Pi Hs id"
      then obtain f where f: "x = finprod G f Hs" "f \<in> Pi Hs id" by blast
      moreover have "finprod G f Hs = finprod G (restrict f Hs) Hs" by(intro finprod_cong; use f(2) subgroup.subset[OF assms(2)] in fastforce)
      moreover have "restrict f Hs \<in> Pi\<^sub>E Hs id" using f(2) by simp
      ultimately show "x \<in> (\<lambda>x. finprod G x Hs) ` Pi\<^sub>E Hs id" by blast
    qed
  qed
  with IDirProds_eq_finprod_PiE[OF assms] show ?thesis by auto
qed

lemma (in comm_group) comp_fam_imp_triv_finprod:
  assumes "complementary_family Hs" "finite Hs" "\<And>H. H \<in> Hs \<Longrightarrow> subgroup H G"
  and "finprod G f Hs = \<one>" "f \<in> Pi Hs id"
  shows "\<forall>H\<in>Hs. f H = \<one>"
proof (rule ccontr; clarify)
  from assms(5) have f: "f H \<in> H" if "H \<in> Hs" for H using that by fastforce
  fix H
  assume H: "H \<in> Hs"
  have sH: "subgroup H G" using assms(3)[OF H] .
  consider (triv) "H = {\<one>}" | (not_triv) "H \<noteq> {\<one>}" by blast
  thus "f H = \<one>"
  proof (cases)
    case triv
    then show ?thesis using f[OF H] by blast
  next
    case not_triv
    show ?thesis
    proof (rule ccontr)
      have fc: "f H \<in> carrier G" using f[OF H] subgroup.subset[OF sH] by blast
      assume no: "f H \<noteq> \<one>"
      have fH: "f H \<in> H" using f[OF H] .
      from subgroup.m_inv_closed[OF sH this] have ifH: "inv (f H) \<in> H" .
      moreover have "inv (f H) \<noteq> \<one>" using no fc by simp
      moreover have "inv (f H) = finprod G f (Hs - {H})"
      proof -
        have "\<one> = finprod G f Hs" using assms(4) by simp
        also have "\<dots> = finprod G f (insert H (Hs - {H}))"
        proof -
          have "Hs = insert H (Hs - {H})" using H by fast
          thus ?thesis by simp
        qed
        also have "\<dots> = f H \<otimes> finprod G f (Hs - {H})"
        proof(intro finprod_insert)
          show "finite (Hs - {H})" using assms(2) by blast
          show "H \<notin> Hs - {H}" by blast
          show "f \<in> Hs - {H} \<rightarrow> carrier G" using assms(3) f subgroup.subset by blast
          show "f H \<in> carrier G" by fact
        qed
        finally have o: "\<one> = f H \<otimes> finprod G f (Hs - {H})" .
        show ?thesis
        proof(intro inv_equality)
          show "f H \<in> carrier G" by fact
          show "finprod G f (Hs - {H}) \<in> carrier G"
            by (intro finprod_closed; use assms(3) f subgroup.subset in blast)
          from m_comm[OF this fc] o show "finprod G f (Hs - {H}) \<otimes> f H = \<one>" by simp
        qed
      qed
      moreover have "finprod G f (Hs - {H}) \<in> IDirProds G (Hs - {H})"
      proof (intro finprod_closed_subgroup IDirProds_is_subgroup)
        show "\<Union> (Hs - {H}) \<subseteq> carrier G" using assms(3) subgroup.subset by auto
        have "f J \<in> (IDirProds G (Hs - {H}))" if "J \<in> (Hs - {H})" for J
          using IDirProds_incl[OF that] f that by blast
        thus "f \<in> Hs - {H} \<rightarrow> IDirProds G (Hs - {H})" by blast
      qed
      ultimately have "\<not>complementary H (IDirProds G (Hs - {H}))"
        unfolding complementary_def by auto
      thus False using assms(1) H unfolding complementary_family_def by blast
    qed
  qed
qed

lemma (in comm_group) triv_finprod_imp_comp_fam:
  assumes "finite Hs" "\<And>H. H \<in> Hs \<Longrightarrow> subgroup H G"
  and "\<forall>f \<in> Pi Hs id. finprod G f Hs = \<one> \<longrightarrow> (\<forall>H\<in>Hs. f H = \<one>)"
shows "complementary_family Hs"
proof (unfold complementary_family_def; rule)
  fix H
  assume H: "H \<in> Hs"
  let ?DP = "IDirProds G (Hs - {H})"
  show "complementary H ?DP"
  proof (rule ccontr; unfold complementary_def)
    have sH: "subgroup H G" using assms(2)[OF H] .
    have sDP: "subgroup ?DP G"
      by (intro IDirProds_is_subgroup; use subgroup.subset[OF assms(2)] in blast)
    assume a: "H \<inter> IDirProds G (Hs - {H}) \<noteq> {\<one>}"
    then obtain x where x: "x \<in> H" "x \<in> IDirProds G (Hs - {H})" "x \<noteq> \<one>" using subgroup.one_closed sH sDP by blast
    then have "x \<in> (\<lambda>x. finprod G x (Hs - {H})) ` (Pi (Hs - {H}) id)" using IDirProds_eq_finprod_Pi[of "(Hs - {H})"] assms(1, 2) by blast
    then obtain ht where ht: "finprod G ht (Hs - {H}) = x" "ht \<in> Pi (Hs - {H}) id" by blast
    define h where h: "h = (ht(H := inv x))"
    then have hPi: "h \<in> Pi Hs id" using ht subgroup.m_inv_closed[OF assms(2)[OF H] x(1)] by auto
    have "finprod G h (Hs - {H}) = x"
    proof (subst ht(1)[symmetric], intro finprod_cong)
      show "Hs - {H} = Hs - {H}" by simp
      show "(h \<in> Hs - {H} \<rightarrow> carrier G) = True" using h ht(2) subgroup.subset[OF assms(2)]
        unfolding Pi_def id_def by auto
      show "\<And>i. i \<in> Hs - {H} =simp=> h i = ht i" using ht(2) h by simp
    qed
    moreover have "finprod G h Hs = h H \<otimes> finprod G h (Hs - {H})"
    proof -
      have "Hs = insert H (Hs - {H})" using H by fast
      then have "finprod G h Hs = finprod G h (insert H (Hs - {H}))" by simp
      also have "\<dots> = h H \<otimes> finprod G h (Hs - {H})"
      proof(intro finprod_insert)
        show "finite (Hs - {H})" "H \<notin> Hs - {H}" using assms(1) by blast+
        have "h J \<in> J" if "J \<in> Hs" for J using hPi that by auto
        thus "h H \<in> carrier G" "h \<in> Hs - {H} \<rightarrow> carrier G" using H subgroup.subset[OF assms(2)] by blast+
      qed
      finally show ?thesis .
    qed
    ultimately have "finprod G h Hs = inv x \<otimes> x" using h by simp
    then have "finprod G h Hs = \<one>" using subgroup.subset[OF sH] x(1) by auto
    moreover have "h H \<noteq> \<one>" using h x(3) subgroup.subset[OF sH] x(1) by force
    ultimately show False using assms(3) H hPi by blast
  qed
qed

lemma (in comm_group) triv_finprod_iff_comp_fam_Pi:
  assumes "finite Hs" "\<And>H. H \<in> Hs \<Longrightarrow> subgroup H G"
  shows "complementary_family Hs \<longleftrightarrow> (\<forall>f \<in> Pi Hs id. finprod G f Hs = \<one> \<longrightarrow> (\<forall>H\<in>Hs. f H = \<one>))"
  using comp_fam_imp_triv_finprod triv_finprod_imp_comp_fam assms by blast

lemma (in comm_group) triv_finprod_iff_comp_fam_PiE:
  assumes "finite Hs" "\<And>H. H \<in> Hs \<Longrightarrow> subgroup H G"
  shows "complementary_family Hs \<longleftrightarrow> (\<forall>f \<in> Pi\<^sub>E Hs id. finprod G f Hs = \<one> \<longrightarrow> (\<forall>H\<in>Hs. f H = \<one>))"
proof
  show "complementary_family Hs \<Longrightarrow> \<forall>f\<in>Pi\<^sub>E Hs id. finprod G f Hs = \<one> \<longrightarrow> (\<forall>H\<in>Hs. f H = \<one>)" using triv_finprod_iff_comp_fam_Pi[OF assms] by blast
  have "\<forall>f\<in>Pi\<^sub>E Hs id. finprod G f Hs = \<one> \<longrightarrow> (\<forall>H\<in>Hs. f H = \<one>) \<Longrightarrow> \<forall>f\<in>Pi Hs id. finprod G f Hs = \<one> \<longrightarrow> (\<forall>H\<in>Hs. f H = \<one>)"
  proof(rule+)
    fix f H
    assume f: "f \<in> Pi Hs id" "finprod G f Hs = \<one>" and H: "H \<in> Hs"
    assume allf: "\<forall>f\<in>Pi\<^sub>E Hs id. finprod G f Hs = \<one> \<longrightarrow> (\<forall>H\<in>Hs. f H = \<one>)"
    have "f H = restrict f Hs H" using H by simp
    moreover have "finprod G (restrict f Hs) Hs = finprod G f Hs"
      using f subgroup.subset[OF assms(2)] unfolding Pi_def by(intro finprod_cong; auto)
    moreover have "restrict f Hs \<in> Pi\<^sub>E Hs id" using f by simp
    ultimately show "f H = \<one>" using allf f H by metis
  qed
  thus "\<forall>f\<in>Pi\<^sub>E Hs id. finprod G f Hs = \<one> \<longrightarrow> (\<forall>H\<in>Hs. f H = \<one>) \<Longrightarrow> complementary_family Hs" using triv_finprod_iff_comp_fam_Pi[OF assms] by blast
qed

lemma (in comm_group) triv_finprod_iff_comp_gens:
  assumes "finite gs" "gs \<subseteq> carrier G"
  shows "(\<forall>f \<in> Pi\<^sub>E gs (\<lambda>a. generate G {a}). finprod G f gs = \<one> \<longrightarrow> (\<forall>a\<in>gs. f a = \<one>)) \<longleftrightarrow> compl_gens gs"
proof
  assume a: "\<forall>f\<in>\<Pi>\<^sub>E a\<in>gs. generate G {a}. finprod G f gs = \<one> \<longrightarrow> (\<forall>a\<in>gs. f a = \<one>)"
  show "compl_gens gs"
  proof (unfold compl_gens_def, rule)
    fix g
    assume g: "g \<in> gs"
    show "complementary (generate G {g}) (generate G (gs - {g}))" (is "complementary ?gg ?ggs")
    proof (rule ccontr, unfold complementary_def)
      from assms g have s: "subgroup ?gg G" "subgroup ?ggs G"
        by (intro generate_is_subgroup, auto, intro generate_is_subgroup, auto)
      assume nt: "?gg \<inter> ?ggs \<noteq> {\<one>}"
      with s obtain e where e: "e \<in> ?gg" "e \<in> ?ggs" "e \<noteq> \<one>" using subgroup.one_closed by blast
      then have ec: "e \<in> carrier G" using subgroup.subset s by blast
      then have ie: "inv e \<in> ?gg" "inv e \<in> ?ggs" using subgroup.m_inv_closed s e by fast+
      with assms generate_eq_finprod_PiE_image[of "gs - {g}"] obtain f where
        f: "finprod G f (gs - {g}) = inv e" "f \<in> (\<Pi>\<^sub>E a\<in>gs - {g}. generate G {a})" by fastforce
      let ?r = "f(g := e)"
      have rc: "f(g := e) \<in> gs \<rightarrow> carrier G"
      proof
        fix x
        assume x: "x \<in> gs"
        then have "?r x \<in> generate G {x}" using f(2) e(1) by(cases "x = g", auto)
        with generate_incl[OF assms(2)] mono_generate[of "{x}" gs] x show "?r x \<in> carrier G" by blast
      qed
      then have fc: "f \<in> (gs - {g}) \<rightarrow> carrier G" using g f by force
      have "finprod G ?r gs = \<one>"
      proof -
        have "finprod G ?r gs = ?r g \<otimes> finprod G ?r (gs - {g})" by (intro finprod_minus[OF g rc assms(1)])
        moreover have "?r g = e" by simp
        moreover have "finprod G ?r (gs - {g}) = inv e"
        proof -
          have "finprod G ?r (gs - {g}) = finprod G f (gs - {g})" by (intro finprod_cong, use rc assms fc in auto)
          thus ?thesis using f by simp
        qed
        ultimately show ?thesis using ec by fastforce
      qed
      moreover have "?r \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" using f g e by fastforce
      ultimately show False using a e g by fastforce
    qed
  qed
next
  assume c: "compl_gens gs"
  show "\<forall>f\<in>\<Pi>\<^sub>E a\<in>gs. generate G {a}. finprod G f gs = \<one> \<longrightarrow> (\<forall>a\<in>gs. f a = \<one>)"
  proof(rule, rule, rule, rule ccontr)
    fix f g
    assume f: "f \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" "finprod G f gs = \<one>"
    have fc: "f \<in> gs \<rightarrow> carrier G"
    proof
      fix x
      assume x: "x \<in> gs"
      then have "f x \<in> generate G {x}" using f(1) by fast
      with mono_generate[of "{x}" gs] generate_incl[OF assms(2)] x show "f x \<in> carrier G" by fast
    qed
    assume g: "g \<in> gs" "f g \<noteq> \<one>"
    with f have no: "generate G {g} \<noteq> {\<one>}" by blast
    with g f obtain e where e: "e \<in> generate G {g}" "e \<noteq> \<one>" "e = f g" using generate.one by blast
    then have ec: "e \<in> carrier G" using g assms(2) generate_incl by blast
    from subgroup.m_inv_closed[OF generate_is_subgroup e(1)] g(1) assms(2) e ec
    have ie: "inv e \<in> generate G {g}" "inv e \<noteq> \<one>" by auto
    let ?r = "restrict f (gs - {g})"
    have rr: "?r \<in> (\<Pi>\<^sub>E a\<in>gs - {g}. generate G {a})" using g f by auto
    have "inv e = finprod G ?r (gs - {g})"
    proof(intro inv_equality[OF _ ec])
      have "finprod G ?r (gs - {g}) = finprod G f (gs - {g})" by (intro finprod_cong; use fc in auto)
      moreover have "finprod G f gs = finprod G f (gs - {g}) \<otimes> f g" by (rule finprod_minus_symm[OF g(1) fc assms(1)])
      ultimately show "finprod G ?r (gs - {g}) \<otimes> e = \<one>" using f(2) e(3) by argo
      show "finprod G ?r (gs - {g}) \<in> carrier G" by (intro finprod_closed, use fc in blast)
    qed
    with generate_eq_finprod_PiE_image[of "gs - {g}"] assms rr have "inv e \<in> generate G (gs - {g})" by blast
    with ie have "\<not>complementary (generate G {g}) (generate G (gs - {g}))" unfolding complementary_def by blast
    with c g(1) show False unfolding compl_gens_def by blast
  qed
qed

(* belongs to IDirProd, but uses Finprod stuff *)
lemma (in comm_group) idirgen_ind:
  assumes "finite gs" "gs \<subseteq> carrier G" "g \<in> carrier G"
  and "is_idirgen (generate G gs) gs" "complementary (generate G {g}) (generate G gs)"
  shows "is_idirgen (generate G (gs \<union> {g})) (gs \<union> {g})"
proof(cases "g \<in> gs")
  case True
  hence "gs = (gs \<union> {g})" by blast
  thus ?thesis using assms(4) by auto
next
  case gngs: False
  show ?thesis
  proof
    have gsgc: "gs \<union> {g} \<subseteq> carrier G" using assms(2, 3) by blast
    have figsg: "finite (gs \<union> {g})" using assms(1) by blast
    have sg: "subgroup (generate G {g}) G" by (intro generate_is_subgroup, use assms(3) in blast)
    from assms(4) is_idirgen.simps[of "generate G gs" gs] have ih: "\<forall>x. x \<in> gs \<longrightarrow> generate G {x} \<lhd> G" "compl_gens gs" by blast+
    hence ca: "\<forall>a\<in>gs. complementary (generate G {a}) (generate G (gs - {a}))" unfolding compl_gens_def by blast
    show "\<And>ga. ga \<in> gs \<union> {g} \<Longrightarrow> generate G {ga} \<lhd> G" using subgroup_imp_normal[OF sg] ih(1) by blast
    show "compl_gens (gs \<union> {g})" unfolding compl_gens_def
    proof(rule, rule ccontr)
      fix h
      assume h: "h \<in> gs \<union> {g}"
      assume c: "\<not> complementary (generate G {h}) (generate G (gs \<union> {g} - {h}))"
      show "False"
      proof (cases "h = g")
        case True
        with c have "\<not> complementary (generate G {g}) (generate G (gs - {g}))" by auto
        moreover have "complementary (generate G {g}) (generate G (gs - {g}))"
          by (rule subgroup_subset_complementary[OF generate_is_subgroup generate_is_subgroup[of gs] generate_is_subgroup mono_generate], use assms(2, 3, 5) in auto)
        ultimately show False by blast
      next
        case hng: False
        hence h: "h \<in> gs" "h \<noteq> g" using h by blast+
        hence "gs \<union> {g} - {h} = gs - {h} \<union> {g}" by blast
        with c have c: "\<not> complementary (generate G {h}) (generate G (gs - {h} \<union> {g}))" by argo
        then obtain k where k: "k \<in> generate G {h}" "k \<in> generate G (gs - {h} \<union> {g})" "k \<noteq> \<one>"
          unfolding complementary_def using generate.one by blast
        with ca have kngh: "k \<notin> generate G (gs - {h})" using h unfolding complementary_def by blast
        from k(2) generate_eq_finprod_PiE_image[of "gs - {h} \<union> {g}"] assms(1) gsgc
        obtain f where f: "k = finprod G f (gs - {h} \<union> {g})" "f \<in> (\<Pi>\<^sub>E a\<in>gs - {h} \<union> {g}. generate G {a})"
          by blast
        have fg: "f a \<in> generate G {a}" if "a \<in> (gs - {h} \<union> {g})" for a using that f(2) by blast
        have fc: "f a \<in> carrier G" if "a \<in> (gs - {h} \<union> {g})" for a
        proof -
          have "generate G {a} \<subseteq> carrier G" if "a \<in> (gs - {h} \<union> {g})" for a
            using that generate_incl[of "{a}"] gsgc by blast
          thus "f a \<in> carrier G" using that fg by auto
        qed
        have kp: "k = f g \<otimes> finprod G f (gs - {h})"
        proof -
          have "(gs - {h} \<union> {g}) = insert g (gs - {h})" by fast
          moreover have "finprod G f (insert g (gs - {h})) = f g \<otimes> finprod G f (gs - {h})"
            by (intro finprod_insert, use fc assms(1) gngs in auto)
          ultimately show ?thesis using f(1) by argo
        qed
        have fgsh: "finprod G f (gs - {h}) \<in> generate G (gs - {h})"
        proof(intro finprod_closed_subgroup[OF generate_is_subgroup])
          show "gs - {h} \<subseteq> carrier G" using gsgc by blast
          have "f a \<in> generate G (gs - {h})" if "a \<in> (gs - {h})" for a
            using mono_generate[of "{a}" "gs - {h}"] fg that by blast
          thus "f \<in> gs - {h} \<rightarrow> generate G (gs - {h})" by blast
        qed
        have "f g \<otimes> finprod G f (gs - {h}) \<notin> generate G gs"
        proof
          assume fpgs: "f g \<otimes> finprod G f (gs - {h}) \<in> generate G gs"
          from fgsh have fgsgs: "finprod G f (gs - {h}) \<in> generate G gs" using mono_generate[of "gs - {h}" gs] by blast
          have fPi: "f \<in> (\<Pi> a\<in>(gs - {h}). generate G {a})" using f by blast
          have gI: "generate G (gs - {h}) = (\<lambda>x. finprod G x (gs - {h})) ` (\<Pi> a\<in>gs - {h}. generate G {a})"
            using generate_eq_finprod_Pi_image[of "gs - {h}"] assms(1, 2) by blast
          have fgno: "f g \<noteq> \<one>"
          proof (rule ccontr)
            assume o: "\<not> f g \<noteq> \<one>"
            hence kf: "k = finprod G f (gs - {h})" using kp finprod_closed fc by auto
            hence "k \<in> generate G (gs - {h})" using fPi gI by blast
            thus False using k ca h unfolding complementary_def by blast
          qed
          from fpgs have "f g \<in> generate G gs"
            using subgroup.mult_in_cancel_right[OF generate_is_subgroup[OF assms(2)] fc[of g] fgsgs]
            by blast
          with fgno assms(5) fg[of g] show "False" unfolding complementary_def by blast
        qed
        moreover have "k \<in> generate G gs" using k(1) mono_generate[of "{h}" gs] h(1) by blast
        ultimately show False using kp by blast
      qed
    qed
  qed simp
qed

lemma (in comm_group) stronger_PiE_finprod_imp:
  assumes "A \<subseteq> carrier G" "\<forall>f \<in> Pi\<^sub>E A (\<lambda>a. generate G {a}). finprod G f A = \<one> \<longrightarrow> (\<forall>a\<in>A. f a = \<one>)"
  shows "\<forall>f \<in> Pi\<^sub>E ((\<lambda>a. generate G {a}) ` A) id. finprod G f ((\<lambda>a. generate G {a}) ` A) = \<one> \<longrightarrow> (\<forall>H\<in> (\<lambda>a. generate G {a}) ` A. f H = \<one>)"
proof(rule, rule)
  fix f
  assume f: "f \<in> Pi\<^sub>E ((\<lambda>a. generate G {a}) ` A) id" "finprod G f ((\<lambda>a. generate G {a}) ` A) = \<one>"
  define B where "B = inv_into A (\<lambda>a. generate G {a}) ` ((\<lambda>a. generate G {a}) ` A)"
  have Bs: "B \<subseteq> A"
  proof
    fix x
    assume x: "x \<in> B"
    then obtain C where C: "C \<in> ((\<lambda>a. generate G {a}) ` A)" "x = inv_into A (\<lambda>a. generate G {a}) C" unfolding B_def by blast
    then obtain c where c: "C = generate G {c}" "c \<in> A" by blast
    with C someI_ex[of "\<lambda>y. y \<in> A \<and> generate G {y} = C"] show "x \<in> A" unfolding inv_into_def by blast
  qed
  have sI: "(\<lambda>x. generate G {x}) ` B = (\<lambda>x. generate G {x}) ` A"
  proof
    show "(\<lambda>x. generate G {x}) ` B \<subseteq> (\<lambda>x. generate G {x}) ` A" using Bs by blast
    show "(\<lambda>x. generate G {x}) ` A \<subseteq> (\<lambda>x. generate G {x}) ` B"
    proof
      fix C
      assume C: "C \<in> (\<lambda>x. generate G {x}) ` A"
      then obtain x where x: "x = inv_into A (\<lambda>a. generate G {a}) C" unfolding B_def by blast
      then obtain c where c: "C = generate G {c}" "c \<in> A" using C by blast
      with C x someI_ex[of "\<lambda>y. y \<in> A \<and> generate G {y} = C"] have "generate G {x} = C" unfolding inv_into_def by blast
      with x C show "C \<in> (\<lambda>x. generate G {x}) ` B" unfolding B_def by blast
    qed
  qed
  have fBc: "f (generate G {b}) \<in> carrier G" if "b \<in> B" for b
  proof -
    have "f (generate G {b}) \<in> generate G {b}" using f(1) by(subst (asm) sI[symmetric], use that in fastforce)
    moreover have "generate G {b} \<subseteq> carrier G" using assms(1) that Bs generate_incl by blast
    ultimately show ?thesis by blast
  qed
  let ?r = "restrict (\<lambda>a. if a\<in>B then f (generate G {a}) else \<one>) A"
  have "?r \<in> Pi\<^sub>E A (\<lambda>a. generate G {a})"
  proof
    show "?r x = undefined" if "x \<notin> A" for x using that by simp
    show "?r x \<in> generate G {x}" if "x \<in> A" for x using that generate.one B_def f(1) by auto
  qed
  moreover have "finprod G ?r A = \<one>"
  proof (cases "finite A")
    case True
    have "A = B \<union> (A - B)" using Bs by auto
    then have "finprod G ?r A = finprod G ?r (B\<union>(A-B))" by auto
    moreover have "\<dots> = finprod G ?r B \<otimes> finprod G ?r (A - B)"
    proof(intro finprod_Un_disjoint)
      from True Bs finite_subset show "finite B" "finite (A - B)" "B \<inter> (A - B) = {}" by auto
      show "(\<lambda>a\<in>A. if a \<in> B then f (generate G {a}) else \<one>) \<in> A - B \<rightarrow> carrier G" using Bs by simp
      from fBc show "(\<lambda>a\<in>A. if a \<in> B then f (generate G {a}) else \<one>) \<in> B \<rightarrow> carrier G" using Bs by auto
    qed
    moreover have "finprod G ?r B = \<one>"
    proof -
      have "finprod G ?r B = finprod G (f \<circ> (\<lambda>a. generate G {a})) B"
      proof(intro finprod_cong')
        show "?r b = (f \<circ> (\<lambda>a. generate G {a})) b" if "b \<in> B" for b using that Bs by auto
        show "f \<circ> (\<lambda>a. generate G {a}) \<in> B \<rightarrow> carrier G" using fBc by simp
      qed simp
      also have "\<dots> = finprod G f ((\<lambda>a. generate G {a}) ` B)"
      proof(intro finprod_comp[symmetric])
        show "(f \<circ> (\<lambda>a. generate G {a})) ` B \<subseteq> carrier G" using fBc by auto
        show "inj_on (\<lambda>a. generate G {a}) B" by(intro inj_onI, unfold B_def, metis (no_types, lifting) f_inv_into_f inv_into_into)
      qed
      also have "\<dots> = finprod G f ((\<lambda>a. generate G {a}) ` A)" using sI by argo
      finally show ?thesis using f(2) by argo
    qed
    moreover have "finprod G ?r (A - B) = \<one>" by(intro finprod_one_eqI, simp)
    ultimately show ?thesis by fastforce
  next
    case False
    then show ?thesis unfolding finprod_def by simp
  qed
  ultimately have a: "\<forall>a\<in>A. ?r a = \<one>" using assms(2) by blast
  then have BA: "\<forall>a\<in>B\<inter>A. ?r a = \<one>" by blast
  from Bs sI have "\<forall>a\<in>A. (generate G {a}) \<in> ((\<lambda>x. generate G {x}) ` B)" by simp
  then have "\<forall>a\<in>A. \<exists>b\<in>B. f (generate G {a}) = f (generate G {b})" by force
  thus "\<forall>H\<in>(\<lambda>a. generate G {a}) ` A. f H = \<one>" using a BA Bs by fastforce
qed

(* Manuel *)
lemma Sigma_insert: "Sigma (insert x A) B = (\<lambda>y. (x, y)) ` B x \<union> Sigma A B"
  by auto

(* Manuel, TODO: move to library *)
lemma (in comm_monoid) finprod_Sigma:
  assumes "finite A" "\<And>x. x \<in> A \<Longrightarrow> finite (B x)"
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> B x \<Longrightarrow> g x y \<in> carrier G"
  shows   "(\<Otimes>x\<in>A. \<Otimes>y\<in>B x. g x y) = (\<Otimes>z\<in>Sigma A B. case z of (x, y) \<Rightarrow> g x y)"
  using assms
proof (induction A rule: finite_induct)
  case (insert x A)
  have "(\<Otimes>z\<in>Sigma (insert x A) B. case z of (x, y) \<Rightarrow> g x y) =
          (\<Otimes>z\<in>Pair x ` B x. case z of (x, y) \<Rightarrow> g x y) \<otimes> (\<Otimes>z\<in>Sigma A B. case z of (x, y) \<Rightarrow> g x y)"
    unfolding Sigma_insert using insert.prems insert.hyps
    by (subst finprod_Un_disjoint) auto
  also have "(\<Otimes>z\<in>Sigma A B. case z of (x, y) \<Rightarrow> g x y) = (\<Otimes>x\<in>A. \<Otimes>y\<in>B x. g x y)"
    using insert.prems insert.hyps by (subst insert.IH [symmetric]) auto
  also have "(\<Otimes>z\<in>Pair x ` B x. case z of (x, y) \<Rightarrow> g x y) = (\<Otimes>y\<in>B x. g x y)"
    using insert.prems insert.hyps by (subst finprod_reindex) (auto intro: inj_onI)
  finally show ?case
    using insert.hyps insert.prems by simp
qed auto

end


theory Abstract_Cost
imports Main "HOL-Library.Extended_Nat"
begin

  datatype ('a, 'b) acost = acostC (the_acost: "'a \<Rightarrow> 'b")
  type_synonym cost = "(string, nat) acost"

  \<comment> \<open>TODO: warning! will clash with another definition of plus lifted to function,
          from "../../lib/Sep_Algebra_Add"
        maybe hide @{type cost} behind a new type and define + for it? \<close>

  lemma acost_eq_I: "(\<And>x. the_acost P x = the_acost Q x) \<Longrightarrow> P=Q"
    by (cases P; cases Q; auto)

  instantiation acost :: (type, zero) zero
  begin
    definition "zero_acost = acostC (\<lambda>_. 0)"
    instance ..
  end

  instantiation acost :: (type, plus) plus
  begin
    fun plus_acost where "plus_acost (acostC a) (acostC b) = acostC (\<lambda>x. a x + b x)"
    instance ..
  end

  instantiation acost :: (type, minus) minus
  begin
    fun minus_acost where "minus_acost (acostC a) (acostC b) = acostC (\<lambda>x. a x - b x)"
    instance ..
  end

  instantiation acost :: (type, ord) ord
  begin
    definition "less_eq_acost a b = (\<forall>x. the_acost a x \<le> the_acost b x)"
    definition "less_acost a b \<equiv> (\<forall>x. the_acost a x \<le> the_acost b x) \<and> (\<exists>x. the_acost a x < the_acost b x)"

    instance ..
  end

  instantiation acost :: (type, monoid_add) monoid_add
  begin

    instance (* TODO refactor *)
      apply standard
      subgoal for a b c apply(cases a; cases b; cases c) by (auto simp: add.assoc)
          apply (auto simp: zero_acost_def add.assoc diff_diff_add)
      subgoal for a     apply(cases a) by auto
      subgoal for a     apply(cases a) by auto
      done
  end

  lemma plus_acost_alt: "a+b = (case (a,b) of (acostC a,acostC b) \<Rightarrow> acostC (\<lambda>x. a x+b x))"
    by (cases a; cases b; auto)

  lemma minus_acost_alt: "a-b = (case (a,b) of (acostC a,acostC b) \<Rightarrow> acostC (\<lambda>x. a x-b x))"
    by (cases a; cases b; auto)

(*
  instantiation acost :: (type, ab_semigroup_add) ab_semigroup_add
  begin

    instance (* TODO refactor *)
      apply standard
      subgoal for a b c apply(cases a; cases b; cases c) by (auto simp: add.assoc)
      subgoal for a b   apply(cases a; cases b) by (auto simp: add.commute)
      done
  end
*)

  instantiation acost :: (type, comm_monoid_add) comm_monoid_add
  begin

    instance (* TODO refactor *)
      apply standard
          apply (auto simp: zero_acost_def add.assoc diff_diff_add)
      subgoal for a b   apply(cases a; cases b) by (auto simp: add.commute)
      subgoal for a     apply(cases a) by auto
      done
  end

  instantiation acost :: (type, cancel_comm_monoid_add) cancel_comm_monoid_add
  begin

    instance (* TODO refactor *)
      apply standard
      subgoal for a b   apply(cases a; cases b) by (auto simp: add.commute)
      subgoal for a b c apply(cases a; cases b; cases c) by (auto simp: diff_diff_add)
      done
  end

  term "(a::cost) + b"
  term "(0::cost)"

  definition cost :: "'a \<Rightarrow> 'b::{comm_monoid_add} \<Rightarrow> ('a,'b) acost" where
    "cost n x = acostC ((the_acost 0)(n:=x))"

  lemma cost_same_curr_add: "cost n x + cost n y = cost n (x+y)" by (auto simp: cost_def fun_eq_iff zero_acost_def)
  lemma cost_same_curr_minus:
    "cost n (x::_::{cancel_comm_monoid_add}) - cost n y = cost n (x-y)" by (auto simp: cost_def fun_eq_iff zero_acost_def)
  lemma cost_zero: "cost n 0 = 0" by(auto simp: cost_def zero_acost_def)

  lemmas c_simps = cost_same_curr_add cost_same_curr_minus cost_zero add_ac[where a="_::(_,_) acost"]
      \<comment> \<open>strange: thm  add_ac[where ?'a="(_,_) acost"] \<close>

lemma the_acost_costs_distrib_left:
  "the_acost (cost n x + (r:: ('c, nat) acost)) m * p
     = the_acost (cost n x) m * p + the_acost r m * p"
  apply(cases r) by(auto simp: cost_def zero_acost_def ring_distribs )
lemma the_acost_costs_distrib_right:
  "the_acost ((r:: ('c, nat) acost) + cost n x ) m * p
     = the_acost (cost n x) m * p + the_acost r m * p"
  apply(cases r) by(auto simp: cost_def zero_acost_def ring_distribs )
lemmas the_acost_costs_distrib = the_acost_costs_distrib_left the_acost_costs_distrib_right
lemma the_acost_cost_mult: "the_acost (cost n c) x * (p::nat) = the_acost (cost n (c*p)) x"
  by(auto simp: cost_def zero_acost_def)
lemma acostC_the_acost_cost: "acostC (\<lambda>x. the_acost (cost n t) x + r x) = cost n t + acostC r"
  by (auto simp: cost_def)
lemma "acostC (\<lambda>x. the_acost (cost n t) x + r x) = cost n t + acostC r"
  by (auto simp: cost_def)

  instantiation acost :: (type, Sup) Sup
  begin
    definition "Sup A = acostC (\<lambda>x. SUP f\<in>A. the_acost f x)"

    instance ..

  end

  instantiation acost :: (type, Inf) Inf
  begin

    definition "Inf A = acostC (\<lambda>x. INF f\<in>A. the_acost f x)"

    instance ..

end

  instantiation acost :: (type, complete_lattice) complete_lattice
  begin
    definition "bot_acost = acostC (\<lambda>x. bot)"
    definition "top_acost = acostC (\<lambda>x. top)"
    definition "sup_acost c c' = acostC (\<lambda>x. sup (the_acost c x) (the_acost c' x))"
    definition "inf_acost c c' = acostC (\<lambda>x. inf (the_acost c x) (the_acost c' x))"

    instance
      apply standard
     apply(auto simp add: le_fun_def less_eq_acost_def less_acost_def split: acost.split)
      subgoal for x y apply(cases x; cases y) apply (auto simp: le_less less_fun_def le_fun_def)
        using less_not_sym by fastforce
      subgoal for x y apply(cases x; cases y) apply (auto simp: le_less less_fun_def le_fun_def)
        by metis
      subgoal for x y z apply(cases x; cases y; cases z) apply (auto simp: less_fun_def le_fun_def)
        using order_trans by blast
      subgoal for x y  apply(cases x; cases y) apply (auto simp: less_fun_def le_fun_def)
        using antisym_conv by fastforce
      subgoal for x y  apply(cases x; cases y) by (auto simp: inf.strict_order_iff inf_acost_def inf_commute)
      subgoal for x y  apply(cases x; cases y) by (auto simp: inf.strict_order_iff inf_acost_def)
      subgoal for x y z apply(cases x; cases y; cases z) by (auto simp: inf_acost_def)
      subgoal for x y  apply(cases x; cases y) by (simp add: sup.strict_order_iff sup_acost_def sup_commute)
      subgoal for x y  apply(cases x; cases y) by (simp add: sup.strict_order_iff sup_acost_def)
      subgoal for x y z  apply(cases x; cases y; cases z) apply (auto simp: le_less less_fun_def le_fun_def)
        by (smt acost.sel dual_order.strict_implies_order le_sup_iff order.not_eq_order_implies_strict order_refl sup_acost_def)
      subgoal for x  apply(cases x) apply (auto simp: Inf_acost_def)
        by (metis acost.sel le_INF_iff order_refl)
      subgoal for A z x apply(cases z) by (auto simp add: Inf_acost_def le_INF_iff)
      subgoal for x A y apply(cases x) apply (simp add: Sup_acost_def) by (metis Sup_upper acost.sel image_iff)
      subgoal for A z x apply(cases z) apply (simp add: Sup_acost_def) by (simp add: SUP_least)
      subgoal unfolding Inf_acost_def top_acost_def by simp
      subgoal unfolding Sup_acost_def bot_acost_def by simp
      done
end

lemma top_acost_absorbs: "top + (x::(_,enat)acost) = top"
  apply(cases x) by (auto simp: top_acost_def plus_acost_alt top_enat_def)

lemma the_acost_mono: "T \<le> T' \<Longrightarrow> the_acost T b \<le> the_acost T' b"
  apply(cases T; cases T') by (auto simp: le_fun_def less_eq_acost_def)

lemma the_acost_propagate:
  shows "the_acost (a + b) = (\<lambda>x. the_acost a x + the_acost b x)"
  apply(cases a; cases b) by auto

subsection \<open>skalar multiplication with acost\<close>
definition costmult :: "_ \<Rightarrow> ('b, _ ) acost \<Rightarrow> ('b, _ ) acost" (infixl "*m" 80)
  where  "costmult s c \<equiv> acostC (\<lambda>x. s * the_acost c x)"

lemma costmult_1_absorb[simp]: "(1::('b::comm_semiring_1)) *m c = c"
  "(Suc 0) *m d = d"
  by(simp_all add: costmult_def)

lemma costmult_right_mono:
  fixes a :: enat
  shows "a \<le> a' \<Longrightarrow> a *m c \<le> a' *m c"
  unfolding costmult_def less_eq_acost_def
  by (auto simp add: mult_right_mono)

lemma costmult_zero_is_zero_enat[simp]: "(x::enat) *m 0 = 0"
  unfolding costmult_def zero_acost_def by auto

lemma costmult_add_distrib:
  fixes a :: "'b::semiring"
  shows "a *m (c + d) = a *m c + a *m d"
  apply(cases c; cases d) by (auto simp: costmult_def plus_acost_alt ring_distribs)

lemma costmult_minus_distrib2:
  fixes a :: nat
  shows "a *m c - a *m d = a *m (c - d)"
  apply(cases c; cases d) by (auto simp: costmult_def plus_acost_alt diff_mult_distrib2)

lemma costmult_minus_distrib:
  fixes a :: nat
  shows "a *m c - b *m c = (a-b) *m c"
  apply(cases c) by (auto simp: costmult_def plus_acost_alt diff_mult_distrib)

lemma costmult_cost:
  fixes x :: "'b::comm_semiring_1"
  shows "x *m (cost n y) = cost n (x*y)"
  by(auto simp: costmult_def cost_def zero_acost_def)

end


theory BoolRelations imports Main
begin
primrec member where
  \<open>member _ [] = False\<close> |
  \<open>member m (n # A) = (m = n \<or> member m A)\<close>

lemma member_iff [iff]: \<open>member m A \<longleftrightarrow> m \<in> set A\<close>
  by (induct A) simp_all

primrec common where
  \<open>common _ [] = False\<close> |
  \<open>common A (m # B) = (member m A \<or> common A B)\<close>

lemma common_iff [iff]: \<open>common A B \<longleftrightarrow> set A \<inter> set B \<noteq> {}\<close>
  by (induct B) simp_all

datatype 'a form = Pro 'a
                 | Neg \<open>'a form\<close>
                 | Con \<open>'a form\<close> \<open>'a form\<close>
                 | Dis \<open>'a form\<close> \<open>'a form\<close>
                 | Imp \<open>'a form\<close> \<open>'a form\<close>
                 | Iff \<open>'a form\<close> \<open>'a form\<close>
                 | Non \<open>'a form\<close> \<open>'a form\<close>
                 | Nis \<open>'a form\<close> \<open>'a form\<close>

datatype 'a non_form = ProNon 'a | Non' \<open>'a non_form\<close> \<open>'a non_form\<close> (infix \<open>\<up>\<close> 0)

datatype 'a nis_form = ProNis 'a | Nis' \<open>'a nis_form\<close> \<open>'a nis_form\<close> (infix \<open>\<down>\<close> 0)

fun semantics where
  \<open>semantics i (Pro a)   = i a\<close> |
  \<open>semantics i (Neg p)   = (\<not>(semantics i p))\<close> |
  \<open>semantics i (Con p q) = ((semantics i p) \<and> (semantics i q))\<close> |
  \<open>semantics i (Dis p q) = ((semantics i p) \<or> (semantics i q))\<close> |
  \<open>semantics i (Imp p q) = ((semantics i p) \<longrightarrow> (semantics i q))\<close> |
  \<open>semantics i (Iff p q) = ((semantics i p) \<longleftrightarrow> (semantics i q))\<close> |
  \<open>semantics i (Non p q) = (\<not>((semantics i p) \<and> (semantics i q)))\<close> |
  \<open>semantics i (Nis p q) = (\<not>((semantics i p) \<or> (semantics i q)))\<close>

primrec non_semantics where
  \<open>non_semantics i (ProNon n) = i n\<close> |
  \<open>non_semantics i (p \<up> q) = (\<not>(non_semantics i p \<and> non_semantics i q))\<close>

primrec nis_semantics where
  \<open>nis_semantics i (ProNis n) = i n\<close> |
  \<open>nis_semantics i (p \<down> q) = (\<not>(nis_semantics i p \<or> nis_semantics i q))\<close>

fun f_size :: \<open>bool \<Rightarrow> 'a form \<Rightarrow> nat\<close> where
  \<open>f_size m (Pro a)   = (1)\<close> |
  \<open>f_size m (Nis p q) = ((if m then 1 else 5) + (f_size m p) + (f_size m q))\<close> |
  \<open>f_size m (Non p q) = ((if m then 5 else 1) + (f_size m p) + (f_size m q))\<close> |
  \<open>f_size m (Neg p)   = (1 + (f_size m p))\<close> |
  \<open>f_size m (Con p q) = (5 + (f_size m p) + (f_size m q))\<close> |
  \<open>f_size m (Dis p q) = (5 + (f_size m p) + (f_size m q))\<close> |
  \<open>f_size m (Imp p q) = (5 + (f_size m p) + (f_size m q))\<close> |
  \<open>f_size m (Iff p q) = (20 + 2*((f_size m p) + (f_size m q)))\<close>

function non_expand where
  \<open>non_expand (Pro a)   = ProNon a\<close> |
  \<open>non_expand (Non p q) = (non_expand p \<up> non_expand q)\<close> |
  \<open>non_expand (Neg p)   = (let pex = non_expand p in (pex \<up> pex))\<close> |
  \<open>non_expand (Con p q) = non_expand (Neg (Non p q))\<close> |
  \<open>non_expand (Dis p q) = (non_expand (Neg p) \<up> non_expand (Neg q))\<close> |
  \<open>non_expand (Imp p q) = (non_expand p \<up> non_expand (Neg q))\<close> |
  \<open>non_expand (Nis p q) = non_expand (Neg (Non (Neg p) (Neg q)))\<close> |
  \<open>non_expand (Iff p q) = non_expand (Con (Imp p q) (Imp q p))\<close>
  by pat_completeness auto
termination by (relation \<open>measure (\<lambda>(p). f_size False p)\<close>) auto

function nis_expand where
  \<open>nis_expand (Pro a)   = ProNis a\<close> |
  \<open>nis_expand (Nis p q) = (nis_expand p \<down> nis_expand q)\<close> |
  \<open>nis_expand (Neg p)   = (let pex = nis_expand p in (pex \<down> pex))\<close> |
  \<open>nis_expand (Con p q) = (nis_expand (Neg p) \<down> nis_expand (Neg q))\<close> |
  \<open>nis_expand (Dis p q) = nis_expand (Neg (Nis p q))\<close> |
  \<open>nis_expand (Imp p q) = nis_expand (Neg (Nis (Neg p) q))\<close> |
  \<open>nis_expand (Non p q) = nis_expand (Neg (Nis (Neg p) (Neg q)))\<close> |
  \<open>nis_expand (Iff p q) = nis_expand (Con (Imp p q) (Imp q p))\<close>
  by pat_completeness auto
termination by (relation \<open>measure (\<lambda>(p). (f_size True p))\<close>) auto

lemma non_equal: \<open>(semantics i p) \<longleftrightarrow> (non_semantics i (non_expand p))\<close>
  by (induct p) (auto simp add: Let_def)

lemma nis_equal: \<open>(semantics i p) \<longleftrightarrow> (nis_semantics i (nis_expand p))\<close>
  by (induct p) (auto simp add: Let_def)

datatype atoms = A' | B' | C'
abbreviation example where  \<open>example \<equiv>
  Imp (Con (Imp (Pro A') (Pro C'))
      (Con (Imp (Neg (Pro A')) (Pro B'))
           (Imp (Neg (Pro C')) (Neg (Pro B')))))
      (Pro C')\<close>

value \<open>nis_expand example\<close>

end