theory SimpleVariantSE imports HOML MFilter BaseDefs
begin
(*Axiom's of new variant based on ultrafilters*)
axiomatization where
 A1': "\<lfloor>\<^bold>\<not>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>" and
 A2'': "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> (X\<^bold>\<sqsubseteq>Y)) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" and
 T2:  "\<lfloor>\<P> \<G>\<rfloor>"

(*Necessary existence of a Godlike entity*)
theorem T6: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" using A1' A2'' T2 by blast
theorem T7: "\<lfloor>\<^bold>\<exists>\<^sup>E \<G>\<rfloor>" using A1' A2'' T2 by blast

(*Possible existence of a Godlike: has counterodel*)
lemma T3: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" nitpick oops (*Counterodel*)

lemma T3': assumes T: "\<lfloor>\<^bold>\<forall>\<phi>.((\<^bold>\<box>\<phi>) \<^bold>\<rightarrow> \<phi>)\<rfloor>"
           shows "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>"
           using A1' A2'' T2 T by metis
end

(*
(*Gödel's A1, A4, A5: not implied anymore*)

(*
(*Further Tests*)
 lemma A3': "\<lfloor>\<^bold>\<forall>X Y.((\<P> X) \<^bold>\<and> (\<P> Y)) \<^bold>\<rightarrow> \<P> (\<lambda>z. X z  \<^bold>\<and> Y z)\<rfloor>" sledgehammer(A3) nitpick oops

 lemma "\<lfloor>(X\<^bold>\<sqsubseteq>Y)\<^bold>\<rightarrow>(X\<Rrightarrow>Y)\<rfloor>" nitpick oops (*Countermodel*)
 lemma "\<lfloor>(X\<Rrightarrow>Y)\<^bold>\<rightarrow>(X\<^bold>\<sqsubseteq>Y)\<rfloor>" sledgehammer nitpick oops (*Countermodel*)
 lemma "(\<lfloor>(X\<^bold>\<sqsubseteq>Y)\<rfloor>)\<longrightarrow>(\<lfloor>(X\<Rrightarrow>Y)\<rfloor>)" nitpick oops (*Countermodel*)
 lemma "(\<lfloor>(X\<Rrightarrow>Y)\<rfloor>)\<longrightarrow>(\<lfloor>(X\<^bold>\<sqsubseteq>Y)\<rfloor>)" nitpick oops (*Countermodel*)
*)

(*
 consts Godlike::\<gamma>  NeEx::\<gamma>
 axiomatization where
  1: "Godlike = G" and
  2: "NeEx = NE"
 lemma True nitpick[satisfy] oops
 lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>" nitpick[format=8] oops (*Countermodel*)
 lemma A1: "\<lfloor>\<^bold>\<forall>X.(\<^bold>\<not>(\<P> X) \<^bold>\<leftrightarrow> \<P>(\<^bold>\<rightharpoondown>X))\<rfloor>" nitpick[format=4] oops (*Countermodel*)
 lemma A4: "\<lfloor>\<forall>X.(\<P> X \<^bold>\<rightarrow> \<^bold>\<box>(\<P> X))\<rfloor>" nitpick[format=4] oops (*Countermodel*)
 lemma A5: "\<lfloor>\<P> NE\<rfloor>" nitpick oops (*Countermodel*)
*)


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

section{*The Yahalom Protocol*}

theory Yahalom imports Public begin

text{*From page 257 of
  Burrows, Abadi and Needham (1989).  A Logic of Authentication.
  Proc. Royal Soc. 426

This theory has the prototypical example of a secrecy relation, KeyCryptNonce.
*}

inductive_set yahalom :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> yahalom"

         (*The spy MAY say anything he CAN say.  We do not expect him to
           invent new nonces here, but he can also use NS1.  Common to
           all similar protocols.*)
 | Fake: "[| evsf \<in> yahalom;  X \<in> synth (analz (knows Spy evsf)) |]
          ==> Says Spy B X  # evsf \<in> yahalom"

         (*A message that has been sent can be received by the
           intended recipient.*)
 | Reception: "[| evsr \<in> yahalom;  Says A B X \<in> set evsr |]
               ==> Gets B X # evsr \<in> yahalom"

         (*Alice initiates a protocol run*)
 | YM1:  "[| evs1 \<in> yahalom;  Nonce NA \<notin> used evs1 |]
          ==> Says A B {|Agent A, Nonce NA|} # evs1 \<in> yahalom"

         (*Bob's response to Alice's message.*)
 | YM2:  "[| evs2 \<in> yahalom;  Nonce NB \<notin> used evs2;
             Gets B {|Agent A, Nonce NA|} \<in> set evs2 |]
          ==> Says B Server
                  {|Agent B, Crypt (shrK B) {|Agent A, Nonce NA, Nonce NB|}|}
                # evs2 \<in> yahalom"

         (*The Server receives Bob's message.  He responds by sending a
            new session key to Alice, with a packet for forwarding to Bob.*)
 | YM3:  "[| evs3 \<in> yahalom;  Key KAB \<notin> used evs3;  KAB \<in> symKeys;
             Gets Server
                  {|Agent B, Crypt (shrK B) {|Agent A, Nonce NA, Nonce NB|}|}
               \<in> set evs3 |]
          ==> Says Server A
                   {|Crypt (shrK A) {|Agent B, Key KAB, Nonce NA, Nonce NB|},
                     Crypt (shrK B) {|Agent A, Key KAB|}|}
                # evs3 \<in> yahalom"

 | YM4:
       --{*Alice receives the Server's (?) message, checks her Nonce, and
           uses the new session key to send Bob his Nonce.  The premise
           @{term "A \<noteq> Server"} is needed for @{text Says_Server_not_range}.
           Alice can check that K is symmetric by its length.*}
         "[| evs4 \<in> yahalom;  A \<noteq> Server;  K \<in> symKeys;
             Gets A {|Crypt(shrK A) {|Agent B, Key K, Nonce NA, Nonce NB|}, X|}
                \<in> set evs4;
             Says A B {|Agent A, Nonce NA|} \<in> set evs4 |]
          ==> Says A B {|X, Crypt K (Nonce NB)|} # evs4 \<in> yahalom"

         (*This message models possible leaks of session keys.  The Nonces
           identify the protocol run.  Quoting Server here ensures they are
           correct.*)
 | Oops: "[| evso \<in> yahalom;
             Says Server A {|Crypt (shrK A)
                                   {|Agent B, Key K, Nonce NA, Nonce NB|},
                             X|}  \<in> set evso |]
          ==> Notes Spy {|Nonce NA, Nonce NB, Key K|} # evso \<in> yahalom"

definition KeyWithNonce :: "[key, nat, event list] => bool" where
  "KeyWithNonce K NB evs ==
     \<exists>A B na X.
       Says Server A {|Crypt (shrK A) {|Agent B, Key K, na, Nonce NB|}, X|}
         \<in> set evs"

declare Says_imp_analz_Spy [dest]
declare parts.Body  [dest]
declare Fake_parts_insert_in_Un  [dest]
declare analz_into_parts [dest]

text{*A "possibility property": there are traces that reach the end*}
lemma "[| A \<noteq> Server; K \<in> symKeys; Key K \<notin> used [] |]
      ==> \<exists>X NB. \<exists>evs \<in> yahalom.
             Says A B {|X, Crypt K (Nonce NB)|} \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] yahalom.Nil
                    [THEN yahalom.YM1, THEN yahalom.Reception,
                     THEN yahalom.YM2, THEN yahalom.Reception,
                     THEN yahalom.YM3, THEN yahalom.Reception,
                     THEN yahalom.YM4])
apply (possibility, simp add: used_Cons)
done

subsection{*Regularity Lemmas for Yahalom*}

lemma Gets_imp_Says:
     "[| Gets B X \<in> set evs; evs \<in> yahalom |] ==> \<exists>A. Says A B X \<in> set evs"
by (erule rev_mp, erule yahalom.induct, auto)

text{*Must be proved separately for each protocol*}
lemma Gets_imp_knows_Spy:
     "[| Gets B X \<in> set evs; evs \<in> yahalom |]  ==> X \<in> knows Spy evs"
by (blast dest!: Gets_imp_Says Says_imp_knows_Spy)

lemmas Gets_imp_analz_Spy = Gets_imp_knows_Spy [THEN analz.Inj]
declare Gets_imp_analz_Spy [dest]

text{*Lets us treat YM4 using a similar argument as for the Fake case.*}
lemma YM4_analz_knows_Spy:
     "[| Gets A {|Crypt (shrK A) Y, X|} \<in> set evs;  evs \<in> yahalom |]
      ==> X \<in> analz (knows Spy evs)"
by blast

lemmas YM4_parts_knows_Spy =
       YM4_analz_knows_Spy [THEN analz_into_parts]

text{*For Oops*}
lemma YM4_Key_parts_knows_Spy:
     "Says Server A {|Crypt (shrK A) {|B,K,NA,NB|}, X|} \<in> set evs
      ==> K \<in> parts (knows Spy evs)"
  by (metis parts.Body parts.Fst parts.Snd  Says_imp_knows_Spy parts.Inj)

text{*Theorems of the form @{term "X \<notin> parts (knows Spy evs)"} imply
that NOBODY sends messages containing X! *}

text{*Spy never sees a good agent's shared key!*}
lemma Spy_see_shrK [simp]:
     "evs \<in> yahalom ==> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule yahalom.induct, force,
    drule_tac [6] YM4_parts_knows_Spy, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
     "evs \<in> yahalom ==> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "[|Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> yahalom|] ==> A \<in> bad"
by (blast dest: Spy_see_shrK)

text{*Nobody can have used non-existent keys!
    Needed to apply @{text analz_insert_Key}*}
lemma new_keys_not_used [simp]:
    "[|Key K \<notin> used evs; K \<in> symKeys; evs \<in> yahalom|]
     ==> K \<notin> keysFor (parts (spies evs))"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake*}
apply (force dest!: keysFor_parts_insert, auto)
done

text{*Earlier, all protocol proofs declared this theorem.
  But only a few proofs need it, e.g. Yahalom and Kerberos IV.*}
lemma new_keys_not_analzd:
 "[|K \<in> symKeys; evs \<in> yahalom; Key K \<notin> used evs|]
  ==> K \<notin> keysFor (analz (knows Spy evs))"
by (blast dest: new_keys_not_used intro: keysFor_mono [THEN subsetD])

text{*Describes the form of K when the Server sends this message.  Useful for
  Oops as well as main secrecy property.*}
lemma Says_Server_not_range [simp]:
     "[| Says Server A {|Crypt (shrK A) {|Agent B, Key K, na, nb|}, X|}
           \<in> set evs;   evs \<in> yahalom |]
      ==> K \<notin> range shrK"
by (erule rev_mp, erule yahalom.induct, simp_all)

subsection{*Secrecy Theorems*}

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) ==>
  Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.
****)

text{* Session keys are not used to encrypt other session keys *}

lemma analz_image_freshK [rule_format]:
 "evs \<in> yahalom ==>
   \<forall>K KK. KK <= - (range shrK) -->
          (Key K \<in> analz (Key`KK Un (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule yahalom.induct,
       drule_tac [7] YM4_analz_knows_Spy, analz_freshK, spy_analz, blast)
apply (simp only: Says_Server_not_range analz_image_freshK_simps)
apply safe
done

lemma analz_insert_freshK:
     "[| evs \<in> yahalom;  KAB \<notin> range shrK |] ==>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text{*The Key K uniquely identifies the Server's  message.*}
lemma unique_session_keys:
     "[| Says Server A
          {|Crypt (shrK A) {|Agent B, Key K, na, nb|}, X|} \<in> set evs;
        Says Server A'
          {|Crypt (shrK A') {|Agent B', Key K, na', nb'|}, X'|} \<in> set evs;
        evs \<in> yahalom |]
     ==> A=A' & B=B' & na=na' & nb=nb'"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, simp_all)
txt{*YM3, by freshness, and YM4*}
apply blast+
done

text{*Crucial secrecy property: Spy does not see the keys sent in msg YM3*}
lemma secrecy_lemma:
     "[| A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Says Server A
            {|Crypt (shrK A) {|Agent B, Key K, na, nb|},
              Crypt (shrK B) {|Agent A, Key K|}|}
           \<in> set evs -->
          Notes Spy {|na, nb, Key K|} \<notin> set evs -->
          Key K \<notin> analz (knows Spy evs)"
apply (erule yahalom.induct, force,
       drule_tac [6] YM4_analz_knows_Spy)
apply (simp_all add: pushes analz_insert_eq analz_insert_freshK, spy_analz)   --{*Fake*}
apply (blast dest: unique_session_keys)+  --{*YM3, Oops*}
done

text{*Final version*}
lemma Spy_not_see_encrypted_key:
     "[| Says Server A
            {|Crypt (shrK A) {|Agent B, Key K, na, nb|},
              Crypt (shrK B) {|Agent A, Key K|}|}
           \<in> set evs;
         Notes Spy {|na, nb, Key K|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest: secrecy_lemma)

subsubsection{* Security Guarantee for A upon receiving YM3 *}

text{*If the encrypted message appears then it originated with the Server*}
lemma A_trusts_YM3:
     "[| Crypt (shrK A) {|Agent B, Key K, na, nb|} \<in> parts (knows Spy evs);
         A \<notin> bad;  evs \<in> yahalom |]
       ==> Says Server A
            {|Crypt (shrK A) {|Agent B, Key K, na, nb|},
              Crypt (shrK B) {|Agent A, Key K|}|}
           \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake, YM3*}
apply blast+
done

text{*The obvious combination of @{text A_trusts_YM3} with
  @{text Spy_not_see_encrypted_key}*}
lemma A_gets_good_key:
     "[| Crypt (shrK A) {|Agent B, Key K, na, nb|} \<in> parts (knows Spy evs);
         Notes Spy {|na, nb, Key K|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
  by (metis A_trusts_YM3 secrecy_lemma)

subsubsection{* Security Guarantees for B upon receiving YM4 *}

text{*B knows, by the first part of A's message, that the Server distributed
  the key for A and B.  But this part says nothing about nonces.*}
lemma B_trusts_YM4_shrK:
     "[| Crypt (shrK B) {|Agent A, Key K|} \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> yahalom |]
      ==> \<exists>NA NB. Says Server A
                      {|Crypt (shrK A) {|Agent B, Key K,
                                         Nonce NA, Nonce NB|},
                        Crypt (shrK B) {|Agent A, Key K|}|}
                     \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake, YM3*}
apply blast+
done

text{*B knows, by the second part of A's message, that the Server
  distributed the key quoting nonce NB.  This part says nothing about
  agent names.  Secrecy of NB is crucial.  Note that @{term "Nonce NB
  \<notin> analz(knows Spy evs)"} must be the FIRST antecedent of the
  induction formula.*}

lemma B_trusts_YM4_newK [rule_format]:
     "[|Crypt K (Nonce NB) \<in> parts (knows Spy evs);
        Nonce NB \<notin> analz (knows Spy evs);  evs \<in> yahalom|]
      ==> \<exists>A B NA. Says Server A
                      {|Crypt (shrK A) {|Agent B, Key K, Nonce NA, Nonce NB|},
                        Crypt (shrK B) {|Agent A, Key K|}|}
                     \<in> set evs"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
apply (analz_mono_contra, simp_all)
txt{*Fake, YM3*}
apply blast
apply blast
txt{*YM4.  A is uncompromised because NB is secure
  A's certificate guarantees the existence of the Server message*}
apply (blast dest!: Gets_imp_Says Crypt_Spy_analz_bad
             dest: Says_imp_spies
                   parts.Inj [THEN parts.Fst, THEN A_trusts_YM3])
done

subsubsection{* Towards proving secrecy of Nonce NB *}

text{*Lemmas about the predicate KeyWithNonce*}

lemma KeyWithNonceI:
 "Says Server A
          {|Crypt (shrK A) {|Agent B, Key K, na, Nonce NB|}, X|}
        \<in> set evs ==> KeyWithNonce K NB evs"
by (unfold KeyWithNonce_def, blast)

lemma KeyWithNonce_Says [simp]:
   "KeyWithNonce K NB (Says S A X # evs) =
      (Server = S &
       (\<exists>B n X'. X = {|Crypt (shrK A) {|Agent B, Key K, n, Nonce NB|}, X'|})
      | KeyWithNonce K NB evs)"
by (simp add: KeyWithNonce_def, blast)

lemma KeyWithNonce_Notes [simp]:
   "KeyWithNonce K NB (Notes A X # evs) = KeyWithNonce K NB evs"
by (simp add: KeyWithNonce_def)

lemma KeyWithNonce_Gets [simp]:
   "KeyWithNonce K NB (Gets A X # evs) = KeyWithNonce K NB evs"
by (simp add: KeyWithNonce_def)

text{*A fresh key cannot be associated with any nonce
  (with respect to a given trace). *}
lemma fresh_not_KeyWithNonce:
     "Key K \<notin> used evs ==> ~ KeyWithNonce K NB evs"
by (unfold KeyWithNonce_def, blast)

text{*The Server message associates K with NB' and therefore not with any
  other nonce NB.*}
lemma Says_Server_KeyWithNonce:
 "[| Says Server A {|Crypt (shrK A) {|Agent B, Key K, na, Nonce NB'|}, X|}
       \<in> set evs;
     NB \<noteq> NB';  evs \<in> yahalom |]
  ==> ~ KeyWithNonce K NB evs"
by (unfold KeyWithNonce_def, blast dest: unique_session_keys)

text{*The only nonces that can be found with the help of session keys are
  those distributed as nonce NB by the Server.  The form of the theorem
  recalls @{text analz_image_freshK}, but it is much more complicated.*}

text{*As with @{text analz_image_freshK}, we take some pains to express the
  property as a logical equivalence so that the simplifier can apply it.*}
lemma Nonce_secrecy_lemma:
     "P --> (X \<in> analz (G Un H)) --> (X \<in> analz H)  ==>
      P --> (X \<in> analz (G Un H)) = (X \<in> analz H)"
by (blast intro: analz_mono [THEN subsetD])

lemma Nonce_secrecy:
     "evs \<in> yahalom ==>
      (\<forall>KK. KK <= - (range shrK) -->
           (\<forall>K \<in> KK. K \<in> symKeys --> ~ KeyWithNonce K NB evs)   -->
           (Nonce NB \<in> analz (Key`KK Un (knows Spy evs))) =
           (Nonce NB \<in> analz (knows Spy evs)))"
apply (erule yahalom.induct,
       frule_tac [7] YM4_analz_knows_Spy)
apply (safe del: allI impI intro!: Nonce_secrecy_lemma [THEN impI, THEN allI])
apply (simp_all del: image_insert image_Un
       add: analz_image_freshK_simps split_ifs
            all_conj_distrib ball_conj_distrib
            analz_image_freshK fresh_not_KeyWithNonce
            imp_disj_not1               (*Moves NBa\<noteq>NB to the front*)
            Says_Server_KeyWithNonce)
txt{*For Oops, simplification proves @{prop "NBa\<noteq>NB"}.  By
  @{term Says_Server_KeyWithNonce}, we get @{prop "~ KeyWithNonce K NB
  evs"}; then simplification can apply the induction hypothesis with
  @{term "KK = {K}"}.*}
txt{*Fake*}
apply spy_analz
txt{*YM2*}
apply blast
txt{*YM3*}
apply blast
txt{*YM4*}
apply (erule_tac V = "\<forall>KK. ?P KK" in thin_rl, clarify)
txt{*If @{prop "A \<in> bad"} then @{term NBa} is known, therefore
  @{prop "NBa \<noteq> NB"}.  Previous two steps make the next step
  faster.*}
apply (metis A_trusts_YM3 Gets_imp_analz_Spy Gets_imp_knows_Spy KeyWithNonce_def
      Spy_analz_shrK analz.Fst analz.Snd analz_shrK_Decrypt parts.Fst parts.Inj)
done

text{*Version required below: if NB can be decrypted using a session key then
   it was distributed with that key.  The more general form above is required
   for the induction to carry through.*}
lemma single_Nonce_secrecy:
     "[| Says Server A
          {|Crypt (shrK A) {|Agent B, Key KAB, na, Nonce NB'|}, X|}
         \<in> set evs;
         NB \<noteq> NB';  KAB \<notin> range shrK;  evs \<in> yahalom |]
      ==> (Nonce NB \<in> analz (insert (Key KAB) (knows Spy evs))) =
          (Nonce NB \<in> analz (knows Spy evs))"
by (simp_all del: image_insert image_Un imp_disjL
             add: analz_image_freshK_simps split_ifs
                  Nonce_secrecy Says_Server_KeyWithNonce)

subsubsection{* The Nonce NB uniquely identifies B's message. *}

lemma unique_NB:
     "[| Crypt (shrK B) {|Agent A, Nonce NA, nb|} \<in> parts (knows Spy evs);
         Crypt (shrK B') {|Agent A', Nonce NA', nb|} \<in> parts (knows Spy evs);
        evs \<in> yahalom;  B \<notin> bad;  B' \<notin> bad |]
      ==> NA' = NA & A' = A & B' = B"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake, and YM2 by freshness*}
apply blast+
done

text{*Variant useful for proving secrecy of NB.  Because nb is assumed to be
  secret, we no longer must assume B, B' not bad.*}
lemma Says_unique_NB:
     "[| Says C S   {|X,  Crypt (shrK B) {|Agent A, Nonce NA, nb|}|}
           \<in> set evs;
         Gets S' {|X', Crypt (shrK B') {|Agent A', Nonce NA', nb|}|}
           \<in> set evs;
         nb \<notin> analz (knows Spy evs);  evs \<in> yahalom |]
      ==> NA' = NA & A' = A & B' = B"
by (blast dest!: Gets_imp_Says Crypt_Spy_analz_bad
          dest: Says_imp_spies unique_NB parts.Inj analz.Inj)

subsubsection{* A nonce value is never used both as NA and as NB *}

lemma no_nonce_YM1_YM2:
     "[|Crypt (shrK B') {|Agent A', Nonce NB, nb'|} \<in> parts(knows Spy evs);
        Nonce NB \<notin> analz (knows Spy evs);  evs \<in> yahalom|]
  ==> Crypt (shrK B)  {|Agent A, na, Nonce NB|} \<notin> parts(knows Spy evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
apply (analz_mono_contra, simp_all)
txt{*Fake, YM2*}
apply blast+
done

text{*The Server sends YM3 only in response to YM2.*}
lemma Says_Server_imp_YM2:
     "[| Says Server A {|Crypt (shrK A) {|Agent B, k, na, nb|}, X|} \<in> set evs;
         evs \<in> yahalom |]
      ==> Gets Server {| Agent B, Crypt (shrK B) {|Agent A, na, nb|} |}
             \<in> set evs"
by (erule rev_mp, erule yahalom.induct, auto)

text{*A vital theorem for B, that nonce NB remains secure from the Spy.*}
lemma Spy_not_see_NB :
     "[| Says B Server
                {|Agent B, Crypt (shrK B) {|Agent A, Nonce NA, Nonce NB|}|}
           \<in> set evs;
         (\<forall>k. Notes Spy {|Nonce NA, Nonce NB, k|} \<notin> set evs);
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Nonce NB \<notin> analz (knows Spy evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_analz_knows_Spy)
apply (simp_all add: split_ifs pushes new_keys_not_analzd analz_insert_eq
                     analz_insert_freshK)
txt{*Fake*}
apply spy_analz
txt{*YM1: NB=NA is impossible anyway, but NA is secret because it is fresh!*}
apply blast
txt{*YM2*}
apply blast
txt{*Prove YM3 by showing that no NB can also be an NA*}
apply (blast dest!: no_nonce_YM1_YM2 dest: Gets_imp_Says Says_unique_NB)
txt{*LEVEL 7: YM4 and Oops remain*}
apply (clarify, simp add: all_conj_distrib)
txt{*YM4: key K is visible to Spy, contradicting session key secrecy theorem*}
txt{*Case analysis on Aa:bad; PROOF FAILED problems
  use @{text Says_unique_NB} to identify message components: @{term "Aa=A"}, @{term "Ba=B"}*}
apply (blast dest!: Says_unique_NB analz_shrK_Decrypt
                    parts.Inj [THEN parts.Fst, THEN A_trusts_YM3]
             dest: Gets_imp_Says Says_imp_spies Says_Server_imp_YM2
                   Spy_not_see_encrypted_key)
txt{*Oops case: if the nonce is betrayed now, show that the Oops event is
  covered by the quantified Oops assumption.*}
apply (clarify, simp add: all_conj_distrib)
apply (frule Says_Server_imp_YM2, assumption)
apply (metis Gets_imp_Says Says_Server_not_range Says_unique_NB no_nonce_YM1_YM2 parts.Snd single_Nonce_secrecy spies_partsEs(1))
done

text{*B's session key guarantee from YM4.  The two certificates contribute to a
  single conclusion about the Server's message.  Note that the "Notes Spy"
  assumption must quantify over @{text \<forall>} POSSIBLE keys instead of our particular K.
  If this run is broken and the spy substitutes a certificate containing an
  old key, B has no means of telling.*}
lemma B_trusts_YM4:
     "[| Gets B {|Crypt (shrK B) {|Agent A, Key K|},
                  Crypt K (Nonce NB)|} \<in> set evs;
         Says B Server
           {|Agent B, Crypt (shrK B) {|Agent A, Nonce NA, Nonce NB|}|}
           \<in> set evs;
         \<forall>k. Notes Spy {|Nonce NA, Nonce NB, k|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
       ==> Says Server A
                   {|Crypt (shrK A) {|Agent B, Key K,
                             Nonce NA, Nonce NB|},
                     Crypt (shrK B) {|Agent A, Key K|}|}
             \<in> set evs"
by (blast dest: Spy_not_see_NB Says_unique_NB
                Says_Server_imp_YM2 B_trusts_YM4_newK)

text{*The obvious combination of @{text B_trusts_YM4} with
  @{text Spy_not_see_encrypted_key}*}
lemma B_gets_good_key:
     "[| Gets B {|Crypt (shrK B) {|Agent A, Key K|},
                  Crypt K (Nonce NB)|} \<in> set evs;
         Says B Server
           {|Agent B, Crypt (shrK B) {|Agent A, Nonce NA, Nonce NB|}|}
           \<in> set evs;
         \<forall>k. Notes Spy {|Nonce NA, Nonce NB, k|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
  by (metis B_trusts_YM4 Spy_not_see_encrypted_key)

subsection{*Authenticating B to A*}

text{*The encryption in message YM2 tells us it cannot be faked.*}
lemma B_Said_YM2 [rule_format]:
     "[|Crypt (shrK B) {|Agent A, Nonce NA, nb|} \<in> parts (knows Spy evs);
        evs \<in> yahalom|]
      ==> B \<notin> bad -->
          Says B Server {|Agent B, Crypt (shrK B) {|Agent A, Nonce NA, nb|}|}
            \<in> set evs"
apply (erule rev_mp, erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake*}
apply blast
done

text{*If the server sends YM3 then B sent YM2*}
lemma YM3_auth_B_to_A_lemma:
     "[|Says Server A {|Crypt (shrK A) {|Agent B, Key K, Nonce NA, nb|}, X|}
       \<in> set evs;  evs \<in> yahalom|]
      ==> B \<notin> bad -->
          Says B Server {|Agent B, Crypt (shrK B) {|Agent A, Nonce NA, nb|}|}
            \<in> set evs"
apply (erule rev_mp, erule yahalom.induct, simp_all)
txt{*YM3, YM4*}
apply (blast dest!: B_Said_YM2)+
done

text{*If A receives YM3 then B has used nonce NA (and therefore is alive)*}
lemma YM3_auth_B_to_A:
     "[| Gets A {|Crypt (shrK A) {|Agent B, Key K, Nonce NA, nb|}, X|}
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Says B Server {|Agent B, Crypt (shrK B) {|Agent A, Nonce NA, nb|}|}
       \<in> set evs"
  by (metis A_trusts_YM3 Gets_imp_analz_Spy YM3_auth_B_to_A_lemma analz.Fst
         not_parts_not_analz)

subsection{*Authenticating A to B using the certificate
  @{term "Crypt K (Nonce NB)"}*}

text{*Assuming the session key is secure, if both certificates are present then
  A has said NB.  We can't be sure about the rest of A's message, but only
  NB matters for freshness.*}
lemma A_Said_YM3_lemma [rule_format]:
     "evs \<in> yahalom
      ==> Key K \<notin> analz (knows Spy evs) -->
          Crypt K (Nonce NB) \<in> parts (knows Spy evs) -->
          Crypt (shrK B) {|Agent A, Key K|} \<in> parts (knows Spy evs) -->
          B \<notin> bad -->
          (\<exists>X. Says A B {|X, Crypt K (Nonce NB)|} \<in> set evs)"
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
apply (analz_mono_contra, simp_all)
txt{*Fake*}
apply blast
txt{*YM3: by @{text new_keys_not_used}, the message
   @{term "Crypt K (Nonce NB)"} could not exist*}
apply (force dest!: Crypt_imp_keysFor)
txt{*YM4: was @{term "Crypt K (Nonce NB)"} the very last message?
    If not, use the induction hypothesis*}
apply (simp add: ex_disj_distrib)
txt{*yes: apply unicity of session keys*}
apply (blast dest!: Gets_imp_Says A_trusts_YM3 B_trusts_YM4_shrK
                    Crypt_Spy_analz_bad
             dest: Says_imp_knows_Spy [THEN parts.Inj] unique_session_keys)
done

text{*If B receives YM4 then A has used nonce NB (and therefore is alive).
  Moreover, A associates K with NB (thus is talking about the same run).
  Other premises guarantee secrecy of K.*}
lemma YM4_imp_A_Said_YM3 [rule_format]:
     "[| Gets B {|Crypt (shrK B) {|Agent A, Key K|},
                  Crypt K (Nonce NB)|} \<in> set evs;
         Says B Server
           {|Agent B, Crypt (shrK B) {|Agent A, Nonce NA, Nonce NB|}|}
           \<in> set evs;
         (\<forall>NA k. Notes Spy {|Nonce NA, Nonce NB, k|} \<notin> set evs);
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> \<exists>X. Says A B {|X, Crypt K (Nonce NB)|} \<in> set evs"
by (metis A_Said_YM3_lemma B_gets_good_key Gets_imp_analz_Spy YM4_parts_knows_Spy analz.Fst not_parts_not_analz)
end


(*  Title:      HOL/Nitpick_Examples/Special_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick's "specialize" optimization.
*)

section \<open>Examples Featuring Nitpick's \textit{specialize} Optimization\<close>

theory Special_Nits
imports MainRLT
begin

nitpick_params [verbose, card = 4, sat_solver = MiniSat, max_threads = 1,
                timeout = 240]

fun f1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f1 a b c d e = a + b + c + d + e"

lemma "f1 0 0 0 0 0 = f1 0 0 0 0 (1 - 1)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f1 u v w x y = f1 y x w v u"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

fun f2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f2 a b c d (Suc e) = a + b + c + d + e"

lemma "f2 0 0 0 0 0 = f2 (1 - 1) 0 0 0 0"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f2 0 (v - v) 0 (x - x) 0 = f2 (u - u) 0 (w - w) 0 (y - y)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f2 1 0 0 0 0 = f2 0 1 0 0 0"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "f2 0 0 0 0 0 = f2 0 0 0 0 0"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

fun f3 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f3 (Suc a) b 0 d (Suc e) = a + b + d + e" |
"f3 0 b 0 d 0 = b + d"

lemma "f3 a b c d e = f3 e d c b a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "f3 a b c d a = f3 a d c d a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "\<lbrakk>c < 1; a \<ge> e; e \<ge> a\<rbrakk> \<Longrightarrow> f3 a b c d a = f3 e d c b e"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "(\<forall>u. a = u \<longrightarrow> f3 a a a a a = f3 u u u u u)
       \<and> (\<forall>u. b = u \<longrightarrow> f3 b b u b b = f3 u u b u u)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

function f4 :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"f4 x x = 1" |
"f4 y z = (if y = z then 1 else 0)"
by auto
termination by lexicographic_order

lemma "f4 a b = f4 b a"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f4 a (Suc a) = f4 a a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

fun f5 :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
"f5 f (Suc a) = f a"

lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}.
       f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}.
       f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}.
       f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
nitpick [expect = genuine]
oops

lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}.
       f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
nitpick [expect = genuine]
oops

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>one \<in> {1}. \<exists>two \<in> {2}. f5 g x =
                      f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>one \<in> {2}. \<exists>two \<in> {1}. f5 g x =
                      f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
nitpick [expect = potential]
nitpick [dont_specialize, expect = potential]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
           b\<^sub>1 < b\<^sub>11 \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 < b\<^sub>11 then a else h b\<^sub>2) x"
nitpick [expect = potential]
nitpick [dont_specialize, expect = none]
nitpick [dont_box, expect = none]
nitpick [dont_box, dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
           b\<^sub>1 < b\<^sub>11
           \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 < b\<^sub>11 then
                                a
                              else
                                h b\<^sub>2 + h b\<^sub>3 + h b\<^sub>4 + h b\<^sub>5 + h b\<^sub>6 + h b\<^sub>7 + h b\<^sub>8
                                + h b\<^sub>9 + h b\<^sub>10) x"
nitpick [card nat = 2, card 'a = 1, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_box, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_specialize, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_box, dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
           b\<^sub>1 < b\<^sub>11
           \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 \<ge> b\<^sub>11 then
                                a
                              else
                                h b\<^sub>2 + h b\<^sub>3 + h b\<^sub>4 + h b\<^sub>5 + h b\<^sub>6 + h b\<^sub>7 + h b\<^sub>8
                                + h b\<^sub>9 + h b\<^sub>10) x"
nitpick [card nat = 2, card 'a = 1, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_box, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_specialize, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_box, dont_specialize,
         expect = potential]
oops

end


theory BeispielZahlenwelt
  imports Zahlenwelt BeispielPerson KategorischerImperativ
begin

section\<open>Beispiel: Zahlenwelt\label{sec:bspzahlenwelt}\<close>
text\<open>In diesem Abschnitt werden wir ein Beispiel sehen.\<close>

text\<open>Wir nehmen an, die Welt lässt sich durch eine Zahl darstellen,
die den Besitz einer Person modelliert.

Der Besitz ist als ganze Zahl \<^typ>\<open>int\<close> modelliert und kann auch beliebig negativ werden.\<close>
datatype zahlenwelt = Zahlenwelt
  \<open>person \<Rightarrow> int \<comment> \<open>besitz: Besitz jeder Person.\<close>\<close>

(*<*)
definition \<open>show_zahlenwelt w \<equiv> case w of Zahlenwelt besitz \<Rightarrow> show_num_fun besitz\<close>
(*>*)

fun gesamtbesitz :: \<open>zahlenwelt \<Rightarrow> int\<close> where
  \<open>gesamtbesitz (Zahlenwelt besitz) = aufsummieren besitz\<close>

text\<open>Beispiel:\<close>
beispiel \<open>gesamtbesitz (Zahlenwelt (\<euro>(Alice := 4, Carol := 8))) = 12\<close> by eval
beispiel \<open>gesamtbesitz (Zahlenwelt (\<euro>(Alice := 4, Carol := 4))) = 8\<close> by eval

text\<open>Mein persönlicher Besitz:\<close>
fun meins :: \<open>person \<Rightarrow> zahlenwelt \<Rightarrow> int\<close> where
  \<open>meins p (Zahlenwelt besitz) = besitz p\<close>

text\<open>Beispiel:\<close>
beispiel \<open>meins Carol (Zahlenwelt (\<euro>(Alice := 8, Carol := 4))) = 4\<close> by eval

text\<open>Um den \<^file>\<open>SchleierNichtwissen.thy\<close> zu implementieren:\<close>
fun zahlenwps :: \<open>person \<Rightarrow> person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt\<close> where
  \<open>zahlenwps p1 p2 (Zahlenwelt besitz) = Zahlenwelt (swap p1 p2 besitz)\<close>

text\<open>Beispiel:\<close>
beispiel \<open>zahlenwps Alice Carol (Zahlenwelt (\<euro>(Alice := 4, Bob := 6, Carol := 8)))
    = (Zahlenwelt (\<euro>(Alice := 8, Bob := 6, Carol := 4)))\<close>
  by eval

(*<*)
lemma zahlenwps_sym:
  \<open>zahlenwps p1 p2 welt = zahlenwps p2 p1 welt\<close>
  by(cases \<open>welt\<close>, simp add: swap_symmetric)

lemma zahlenwps_id: \<open>zahlenwps p p w = w\<close>
  by(cases \<open>w\<close>, simp)

lemma zahlenwps_twice:
  \<open>zahlenwps p1 p2 (zahlenwps p1 p2 welt) = welt\<close>
  \<open>zahlenwps p1 p2 (zahlenwps p2 p1 welt) = welt\<close>
  by(cases \<open>welt\<close>, simp)+

lemma gesamtbesitz_swap:
  \<open>gesamtbesitz (zahlenwps p1 p2 welt) = gesamtbesitz welt\<close>
  by(cases \<open>welt\<close>, simp add: aufsummieren_swap)

lemma hlp1: \<open>meins p1 (zahlenwps p1 p2 welt) = meins p2 welt\<close>
  by(cases \<open>welt\<close>, simp add: swap_def)
lemma hlp2: \<open>meins p2 (zahlenwps p1 p2 welt) = meins p1 welt\<close>
  by(cases \<open>welt\<close>, simp add: swap_def)

lemma hlp3: \<open>p1 \<noteq> p2 \<Longrightarrow> p \<noteq> p1 \<Longrightarrow> p \<noteq> p2 \<Longrightarrow>
         meins p (zahlenwps p1 p2 welt) = meins p welt\<close>
  by(cases \<open>welt\<close>, simp add: swap_def)
(*>*)

text\<open>\<^const>\<open>Alice\<close> hat Besitz, \<^const>\<open>Bob\<close> ist reicher, \<^const>\<open>Carol\<close> hat Schulden.\<close>
definition \<open>initialwelt \<equiv> Zahlenwelt (\<euro>(Alice := 5, Bob := 10, Carol := -3))\<close>

subsection\<open>Ungültige Handlung\<close>
text\<open>Sobald ich eine konkrete Person in einer Handlungsabsicht hardcode,
  ist diese nicht mehr wohlgeformt.\<close>

beispiel \<open>\<not>wohlgeformte_handlungsabsicht
    zahlenwps (Zahlenwelt (\<euro>(Alice := 5, Bob := 10, Carol := -3)))
    (Handlungsabsicht (\<lambda>ich w. if ich = Alice then Some w else Some (Zahlenwelt (\<lambda>_. 0))))\<close>
  apply(simp add: wohlgeformte_handlungsabsicht.simps swap_def)
  apply(eval)
  done

subsection\<open>Nicht-Wohlgeformte Handlungen\<close>
fun stehlen_nichtwf :: \<open>int \<Rightarrow> person \<Rightarrow> person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>stehlen_nichtwf beute opfer dieb (Zahlenwelt besitz) =
        Some (Zahlenwelt \<lbrakk>\<lbrakk>besitz(opfer -= beute)\<rbrakk>(dieb += beute)\<rbrakk>)\<close>
text\<open>Die Handlung \<^const>\<open>stehlen\<close> diskriminiert und ist damit nicht wohlgeformt:\<close>
lemma \<open>wohlgeformte_handlungsabsicht_gegenbeispiel zahlenwps
      (Zahlenwelt (\<lambda>x. 0)) (Handlungsabsicht (stehlen_nichtwf 5 Bob))
      Alice Bob\<close>
  by(eval)

text\<open>Wir versuchen, das Opfer nach Besitz auszuwählen, nicht nach Namen.
  Nach unserer Definition ist der Besitz ein Merkmal, nach dem man diskriminieren darf.
  Man darf nur nicht nach Eigenschaften der \<^typ>\<open>person\<close> diskriminieren, sondern nur
  nach Eigenschaften der \<^typ>\<open>zahlenwelt\<close>.\<close>
fun opfer_nach_besitz_auswaehlen :: \<open>int \<Rightarrow> ('person \<Rightarrow> int) \<Rightarrow> 'person list \<Rightarrow> 'person option\<close> where
  \<open>opfer_nach_besitz_auswaehlen _ _ [] = None\<close>
| \<open>opfer_nach_besitz_auswaehlen b besitz (p#ps) =
      (if besitz p = b then Some p else opfer_nach_besitz_auswaehlen b besitz ps)\<close>

fun stehlen_nichtwf2 :: \<open>int \<Rightarrow> int \<Rightarrow> person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>stehlen_nichtwf2 beute opfer_nach_besitz dieb (Zahlenwelt besitz) =
        (case opfer_nach_besitz_auswaehlen opfer_nach_besitz besitz Enum.enum
           of None \<Rightarrow> None
            | Some opfer \<Rightarrow> Some (Zahlenwelt \<lbrakk>\<lbrakk>besitz(opfer -= beute)\<rbrakk>(dieb += beute)\<rbrakk>)
        )\<close>
text\<open>Leider ist diese Funktion auch diskriminierend:
  Wenn es mehrere potenzielle Opfer mit dem gleichen Besitz gibt,
  dann bestimmt die Reihenfolge in \<^term>\<open>Enum.enum\<close> wer bestohlen wird.
  Diese Reihenfolge ist wieder eine Eigenschaft von \<^typ>\<open>person\<close> und nicht \<^typ>\<open>zahlenwelt\<close>.\<close>
beispiel\<open>handeln Alice (Zahlenwelt (\<euro>(Alice := 10, Bob := 10, Carol := -3)))
                (Handlungsabsicht (stehlen_nichtwf2 5 10))
  = Handlung (Zahlenwelt (\<euro>(Alice := 10, Bob := 10, Carol := - 3)))
               (Zahlenwelt (\<euro>(Alice := 10, Bob := 10, Carol := - 3)))\<close> by eval
beispiel\<open>handeln Bob (Zahlenwelt (\<euro>(Alice := 10, Bob := 10, Carol := -3)))
              (Handlungsabsicht (stehlen_nichtwf2 5 10))
  = Handlung (Zahlenwelt (\<euro>(Alice := 10, Bob := 10, Carol := - 3)))
             (Zahlenwelt (\<euro>(Alice := 5, Bob := 15, Carol := - 3)))\<close> by eval
beispiel \<open>wohlgeformte_handlungsabsicht_gegenbeispiel
      zahlenwps
      (Zahlenwelt (\<euro>(Alice := 10, Bob := 10, Carol := -3))) (Handlungsabsicht (stehlen_nichtwf2 5 10))
      Alice Bob\<close>
  by eval

fun schenken :: \<open>int \<Rightarrow> person \<Rightarrow> person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>schenken betrag empfaenger schenker (Zahlenwelt besitz) =
        Some (Zahlenwelt \<lbrakk>\<lbrakk>besitz(schenker -= betrag)\<rbrakk>(empfaenger += betrag)\<rbrakk>)\<close>

text\<open>Da wir ganze Zahlen verwenden und der Besitz auch beliebig negativ werden kann,
  ist Stehlen äquivalent dazu einen negativen Betrag zu verschenken:\<close>
lemma stehlen_ist_schenken: \<open>stehlen_nichtwf i = schenken (-i)\<close>
  apply(simp add: fun_eq_iff)
  apply(intro allI, rename_tac p1 p2 welt, case_tac \<open>welt\<close>)
  by auto

text\<open>Das Modell ist nicht ganz perfekt, .... Aber passt schon um damit zu spielen.\<close>

subsection\<open>Wohlgeformte Handlungen\<close>
text\<open>Die folgende Handlung erschafft neuen Besitz aus dem Nichts:\<close>
fun erschaffen :: \<open>nat \<Rightarrow> person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>erschaffen i p (Zahlenwelt besitz) = Some (Zahlenwelt \<lbrakk>besitz(p += int i)\<rbrakk>)\<close>

lemma wohlgeformte_handlungsabsicht_erschaffen:
  \<open>wohlgeformte_handlungsabsicht zahlenwps welt (Handlungsabsicht (erschaffen n))\<close>
  apply(case_tac \<open>welt\<close>, simp add: wohlgeformte_handlungsabsicht.simps)
  apply(simp add: swap_def Fun.swap_def)
  done

text\<open>Wenn wir das Opfer eindeutig auswählen, ist die Handlungsabsicht "Stehlen" wohlgeformt.
  Allerdings wird niemand bestohlen, wenn das Opfer nicht eindeutig ist.\<close>
fun stehlen :: \<open>int \<Rightarrow> int \<Rightarrow> person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>stehlen beute opfer_nach_besitz dieb (Zahlenwelt besitz) =
        map_option Zahlenwelt (Zahlenwelt.stehlen beute opfer_nach_besitz dieb besitz)\<close>

(*<*)
lemma wohlgeformte_handlungsabsicht_stehlen:
  \<open>wohlgeformte_handlungsabsicht zahlenwps welt (Handlungsabsicht (stehlen n p))\<close>
  apply(cases \<open>welt\<close>)
  apply(rule wfh_generalize_world_ConstrI[OF wohlgeformte_handlungsabsicht_stehlen, where C=\<open>Zahlenwelt\<close>])
  by(auto)
(*>*)

text\<open>Reset versetzt die Welt wieder in den Ausgangszustand. Eine sehr destruktive Handlung.\<close>
fun reset :: \<open>person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>reset ich (Zahlenwelt besitz) = Some (Zahlenwelt (\<lambda> _. 0))\<close>

text\<open>Der \<^const>\<open>reset\<close> ist im moralischen Sinne vermutlich keine gute Handlung,
  dennoch ist es eine wohlgeformte Handlung, welche wir betrachten können:\<close>
lemma wohlgeformte_handlungsabsicht_reset:
  \<open>wohlgeformte_handlungsabsicht zahlenwps welt (Handlungsabsicht reset)\<close>
  apply(simp add: wohlgeformte_handlungsabsicht.simps handeln_def nachher_handeln.simps)
  by(case_tac \<open>welt\<close>, simp add: swap_def fun_eq_iff)

fun alles_kaputt_machen :: \<open>person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>alles_kaputt_machen ich (Zahlenwelt besitz) = Some (Zahlenwelt (\<lambda> _. Min (besitz ` UNIV) - 1))\<close>

(*<*)
lemma alles_kaputt_machen_code[code]:
  \<open>alles_kaputt_machen ich welt =
     (case welt of Zahlenwelt besitz \<Rightarrow> Some (Zahlenwelt (\<lambda>_. min_list (map besitz enum_class.enum) -1)))\<close>
  apply(cases \<open>welt\<close>, simp add: alles_kaputt_machen_code_help)
  done

lemma wohlgeformte_handlungsabsicht_alles_kaputt_machen:
  \<open>wohlgeformte_handlungsabsicht zahlenwps welt (Handlungsabsicht alles_kaputt_machen)\<close>
  apply(simp add: wohlgeformte_handlungsabsicht.simps)
  apply(simp add: alles_kaputt_machen_code)
  apply(case_tac \<open>welt\<close>, simp add: fun_eq_iff)
  apply(simp add: min_list_swap_int_enum)
  by (simp add: swap_def)
(*>*)

beispiel \<open>alles_kaputt_machen Alice (Zahlenwelt (\<euro>(Alice := 5, Bob := 10, Carol := -3)))
  = Some (Zahlenwelt (\<euro>(Alice := -4, Bob := -4, Carol := -4, Eve := -4)))\<close>
  by(code_simp)

(*TODO: Handlung alles_besser_machen.*)

text\<open>Auch die unmögliche (niemals ausführbare) Handlung lässt sich modellieren.\<close>
fun unmoeglich :: \<open>person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>unmoeglich _ _ = None\<close>

text\<open>Die Beispielhandlungsabsichten, die wir betrachten wollen.\<close>
definition \<open>handlungsabsichten \<equiv> [
  Handlungsabsicht (erschaffen 5),
  Handlungsabsicht (stehlen 5 10),
  Handlungsabsicht reset,
  Handlungsabsicht alles_kaputt_machen,
  Handlungsabsicht unmoeglich
]\<close>

lemma wfh_handlungsabsichten:
  \<open>ha \<in> set handlungsabsichten \<Longrightarrow> wohlgeformte_handlungsabsicht zahlenwps welt ha\<close>
  apply(simp add: handlungsabsichten_def)
  apply(safe)
      apply(simp_all add: wohlgeformte_handlungsabsicht_stehlen
      wohlgeformte_handlungsabsicht_alles_kaputt_machen
      wohlgeformte_handlungsabsicht_erschaffen
      wohlgeformte_handlungsabsicht_reset)
  apply(simp add: wohlgeformte_handlungsabsicht.simps)
  done

subsection\<open>Maxime für individuellen Fortschritt\<close>
text\<open>Wir definieren eine Maxime die besagt,
  dass sich der Besitz einer Person nicht verringern darf:\<close>
fun individueller_fortschritt :: \<open>person \<Rightarrow> zahlenwelt handlung \<Rightarrow> bool\<close> where
  \<open>individueller_fortschritt p (Handlung vor nach) \<longleftrightarrow> (meins p vor) \<le> (meins p nach)\<close>

definition maxime_zahlenfortschritt :: \<open>(person, zahlenwelt) maxime\<close> where
  \<open>maxime_zahlenfortschritt \<equiv> Maxime (\<lambda>ich. individueller_fortschritt ich)\<close>

(*<*)
lemma mhg_maxime_zahlenfortschritt_stehlen:
  \<open>maxime_und_handlungsabsicht_generalisieren zahlenwps welt maxime_zahlenfortschritt (Handlungsabsicht (stehlen 5 10)) p\<close>
  apply(simp add: maxime_und_handlungsabsicht_generalisieren_def
                  maxime_zahlenfortschritt_def, intro allI impI)
  apply(case_tac \<open>welt\<close>, simp)
  apply(simp add: Zahlenwelt.stehlen.simps handeln_def nachher_handeln.simps
                  opfer_eindeutig_nach_besitz_auswaehlen_the_single_elem_enumall)
  apply(auto intro: the_single_elem_exhaust)
  done
(*>*)

text\<open>Die Eigenschaft \<^const>\<open>maxime_und_handlungsabsicht_generalisieren\<close> wird von den meisten
Handlungsabsichten erfüllt.
Jedoch nicht von \<^const>\<open>reset\<close>.
Das nicht-wohlgeformte \<^const>\<open>stehlen_nichtwf\<close> erfüllt sie allerdings schon.\<close>
lemma \<open>ha \<in> {
    Handlungsabsicht (erschaffen 5),
    Handlungsabsicht (stehlen_nichtwf 5 Bob),
    Handlungsabsicht (stehlen 5 10),
    Handlungsabsicht alles_kaputt_machen,
    Handlungsabsicht unmoeglich
  } \<Longrightarrow> maxime_und_handlungsabsicht_generalisieren zahlenwps welt maxime_zahlenfortschritt ha p\<close>
  apply(simp)
  apply(safe)
      apply(case_tac \<open>welt\<close>, simp add: handeln_def nachher_handeln.simps maxime_und_handlungsabsicht_generalisieren_def maxime_zahlenfortschritt_def; fail)
     apply(case_tac \<open>welt\<close>, simp add: handeln_def nachher_handeln.simps maxime_und_handlungsabsicht_generalisieren_def maxime_zahlenfortschritt_def; fail)
  subgoal using mhg_maxime_zahlenfortschritt_stehlen by simp
  subgoal
    by(case_tac \<open>welt\<close>, simp add: handeln_def nachher_handeln.simps maxime_und_handlungsabsicht_generalisieren_def maxime_zahlenfortschritt_def, auto)
  apply(case_tac \<open>welt\<close>, simp add: handeln_def nachher_handeln.simps maxime_und_handlungsabsicht_generalisieren_def maxime_zahlenfortschritt_def; fail)
  done

text\<open>Nicht alle Handlungen generalisieren, z.B. \<^const>\<open>reset\<close> nicht:\<close>
beispiel
  \<open>\<not> maxime_und_handlungsabsicht_generalisieren
         zahlenwps (Zahlenwelt (\<euro>(Alice := 5, Bob := 10, Carol := -3)))
         maxime_zahlenfortschritt (Handlungsabsicht reset) Alice\<close>
  by eval

text\<open>Die \<^const>\<open>maxime_zahlenfortschritt\<close> erfüllt allgemein \<^bold>\<open>nicht\<close>
den \<^const>\<open>kategorischer_imperativ\<close>,
da \<^const>\<open>Alice\<close> nach der Maxime z.B. \<^const>\<open>Bob\<close> bestehlen dürfte.\<close>
beispiel \<open>kategorischer_imperativ_gegenbeispiel
  zahlenwps initialwelt maxime_zahlenfortschritt
  (Handlungsabsicht (stehlen 1 10))
  Alice
  Bob
  Alice\<close>
  apply(simp add: kategorischer_imperativ_gegenbeispiel_def
      wohlgeformte_handlungsabsicht_stehlen mhg_maxime_zahlenfortschritt_stehlen)
  by(eval)

(*<*)
lemma \<open>wpsm_kommutiert (maxime_zahlenfortschritt) zahlenwps welt\<close>
  by(simp add: maxime_zahlenfortschritt_def handeln_def
               nachher_handeln.simps wpsm_kommutiert_def hlp1 hlp2 zahlenwps_sym)
(*>*)

text\<open>Folgendes Beispiel zeigt, dass die \<^const>\<open>maxime_zahlenfortschritt\<close> den
kategorischen Imperativ auf unseren \<^const>\<open>handlungsabsichten\<close> nicht erfüllt
(zu sehen an dem \<^const>\<open>False\<close> im \<^const>\<open>bsp_erfuellte_maxime\<close>.).
Die Handlungsabsichten \<^const>\<open>stehlen\<close> als auch \<^const>\<open>reset\<close> sind nicht mit der Maxime vereinbar.
Für die übrigen Handlungsabsichten ist das Ergebnis aber intuitiv:
  \<^item> \<^const>\<open>erschaffen\<close> ist erlaubt.
  \<^item> da \<^const>\<open>unmoeglich\<close> im Nichtstuen endet, ist dies auch erlaubt.
  \<^item> \<^const>\<open>alles_kaputt_machen\<close> ist verboten.
\<close>
beispiel \<open>erzeuge_beispiel
    zahlenwps (Zahlenwelt (\<euro>(Alice := 5, Bob := 10, Carol := -3)))
    handlungsabsichten
    maxime_zahlenfortschritt =
  Some
    \<lparr>
     bsp_erfuellte_maxime = False,
     bsp_erlaubte_handlungen = [
        Handlungsabsicht (erschaffen 5),
        Handlungsabsicht unmoeglich],
     bsp_verbotene_handlungen = [Handlungsabsicht alles_kaputt_machen],
     bsp_uneindeutige_handlungen = [
        Handlungsabsicht (stehlen 5 10),
        Handlungsabsicht reset]\<rparr>\<close>
  by beispiel_tac

subsubsection\<open>Einzelbeispiele\<close>
text\<open>In jeder Welt ist die \<^term>\<open>Handlungsabsicht (erschaffen n)\<close> \<^const>\<open>moralisch\<close>:\<close>
lemma \<open>moralisch welt maxime_zahlenfortschritt (Handlungsabsicht (erschaffen n))\<close>
  apply(cases \<open>welt\<close>)
  by(simp add: maxime_zahlenfortschritt_def moralisch_simp handeln_def nachher_handeln.simps)

text\<open>In kein Welt ist Stehlen \<^const>\<open>moralisch\<close>:\<close>
lemma \<open>\<not> moralisch welt maxime_zahlenfortschritt (Handlungsabsicht (stehlen_nichtwf 5 Bob))\<close>
  by(cases \<open>welt\<close>, auto simp add: maxime_zahlenfortschritt_def moralisch_simp handeln_def nachher_handeln.simps)

text\<open>In unserer \<^const>\<open>initialwelt\<close> in der \<^const>\<open>Bob\<close> als Opfer anhand seines Besitzes
    als Opfer eines Diebstahls ausgewählt würde, ist stehlen dennoch nicht \<^const>\<open>moralisch\<close>,
    obwohl die Handlungsabsicht wohlgeformt ist:\<close>
lemma \<open>\<not> moralisch initialwelt maxime_zahlenfortschritt (Handlungsabsicht (stehlen 5 10))\<close>
  by(eval)

text\<open>Da Schenken und Stehlen in dieser Welt equivalent ist, ist Schenken auch unmoralisch:\<close>
lemma \<open>\<not> moralisch welt maxime_zahlenfortschritt (Handlungsabsicht (schenken 5 Bob))\<close>
  by(cases \<open>welt\<close>, auto simp add: maxime_zahlenfortschritt_def moralisch_simp handeln_def nachher_handeln.simps)

subsection\<open>Maxime für allgemeinen Fortschritt\<close>
text\<open>Wir können die vorherige Maxime generalisieren, indem wir \<^const>\<open>individueller_fortschritt\<close>
für jeden fordern.
Effektiv wird dabei das \<^term>\<open>ich::person\<close> ignoriert.\<close>

definition maxime_altruistischer_fortschritt :: \<open>(person, zahlenwelt) maxime\<close> where
  \<open>maxime_altruistischer_fortschritt \<equiv> Maxime (\<lambda>ich h. \<forall>pX. individueller_fortschritt pX h)\<close>

text\<open>Folgendes Beispiel zeigt, dass die \<^const>\<open>maxime_altruistischer_fortschritt\<close>
den kategorischen Imperativ (für diese \<^const>\<open>initialwelt\<close> und \<^const>\<open>handlungsabsichten\<close>)
erfüllt; zu sehen an dem \<^const>\<open>True\<close> im \<^const>\<open>bsp_erfuellte_maxime\<close>.

Die Handlungsabsichten werden eingeordnet wie erwartet:
  \<^item> \<^const>\<open>erschaffen\<close> ist gut, \<^const>\<open>unmoeglich\<close> (bedeutet: Nichtstun) ist auch okay.
  \<^item> \<^const>\<open>stehlen\<close>, \<^const>\<open>reset\<close>, \<^const>\<open>alles_kaputt_machen\<close> ist schlecht.
  \<close>
beispiel \<open>erzeuge_beispiel
    zahlenwps (Zahlenwelt (\<euro>(Alice := 5, Bob := 10, Carol := -3)))
    handlungsabsichten
    maxime_altruistischer_fortschritt =
  Some
    \<lparr>
     bsp_erfuellte_maxime = True,
     bsp_erlaubte_handlungen = [
        Handlungsabsicht (erschaffen 5),
        Handlungsabsicht unmoeglich],
     bsp_verbotene_handlungen = [
        Handlungsabsicht (stehlen 5 10),
        Handlungsabsicht reset,
        Handlungsabsicht alles_kaputt_machen],
     bsp_uneindeutige_handlungen = []\<rparr>\<close>
  by beispiel_tac
text\<open>Das ist ein sehr schönes Beispiel.\<close>

(*<*)
lemma wpsm_kommutiert_altruistischer_fortschritt:
  \<open>wpsm_kommutiert maxime_altruistischer_fortschritt zahlenwps welt\<close>
  apply(simp add: maxime_altruistischer_fortschritt_def wpsm_kommutiert_def handeln_def nachher_handeln.simps)
  apply(safe)
   apply(case_tac \<open>p1 = p2\<close>)
    apply(simp add: zahlenwps_id; fail)
   apply(case_tac \<open>pX = p1\<close>)
    apply(simp)
    apply (metis hlp1 zahlenwps_sym)
   apply (metis hlp2 hlp3 zahlenwps_sym)
  by (metis hlp2 hlp3 zahlenwps_id zahlenwps_sym)

lemma mhg_maxime_altruistischer_fortschritt_stehlen:
  \<open>maxime_und_handlungsabsicht_generalisieren zahlenwps welt
      maxime_altruistischer_fortschritt (Handlungsabsicht (stehlen 5 10)) p\<close>
  apply(simp add: maxime_altruistischer_fortschritt_def maxime_und_handlungsabsicht_generalisieren_def maxime_zahlenfortschritt_def handeln_def nachher_handeln.simps, intro allI impI)
  apply(simp add: ausfuehrbar.simps)
  apply(case_tac \<open>welt\<close>, simp)
  apply(simp add: Zahlenwelt.stehlen.simps opfer_eindeutig_nach_besitz_auswaehlen_the_single_elem_enumall)
  apply(simp add: ist_noop_def split: option.split option.split_asm)
  by fastforce

lemma maxime_altruistischer_fortschritt_reset:
  \<open>maxime_und_handlungsabsicht_generalisieren zahlenwps welt
      maxime_altruistischer_fortschritt (Handlungsabsicht (reset)) p\<close>
  apply(simp add: maxime_altruistischer_fortschritt_def maxime_und_handlungsabsicht_generalisieren_def maxime_zahlenfortschritt_def handeln_def nachher_handeln.simps, intro allI impI)
  apply(case_tac \<open>welt\<close>, simp)
  apply(auto simp add: swap_def Fun.swap_def split: option.split option.split_asm)
  done

lemma maxime_altruistischer_fortschritt_alles_kaputt_machen:
  \<open>maxime_und_handlungsabsicht_generalisieren zahlenwps welt
      maxime_altruistischer_fortschritt (Handlungsabsicht (alles_kaputt_machen)) p\<close>
  apply(simp add: maxime_altruistischer_fortschritt_def maxime_und_handlungsabsicht_generalisieren_def maxime_zahlenfortschritt_def handeln_def nachher_handeln.simps, intro allI impI)
  apply(case_tac \<open>welt\<close>, simp)
  apply(auto simp add: swap_def Fun.swap_def split: option.split option.split_asm)
  done

lemma wfm_maxime_altruistischer_fortschritt:
  \<open>wohlgeformte_maxime zahlenwps maxime_altruistischer_fortschritt\<close>
  apply(simp add: maxime_altruistischer_fortschritt_def wohlgeformte_maxime_def wohlgeformte_maxime_auf_def handeln_def nachher_handeln.simps, intro allI, rename_tac h p1 p2)
  apply(case_tac \<open>h\<close>, rename_tac vor nach, simp)
  apply(case_tac \<open>vor\<close>, case_tac \<open>nach\<close>, simp)
  apply(simp add: swap_forall)
  done

lemma individueller_fortschritt_map_handlung_zahlenwps:
  \<open>individueller_fortschritt pX (map_handlung (zahlenwps p1 p2) ha)
      = individueller_fortschritt (swap p1 p2 id pX) ha\<close>
  apply(cases \<open>ha\<close>, simp)
  apply(cases \<open>pX = p1\<close>)
   apply(simp add: hlp1  swap_a; fail)
  apply(cases \<open>pX = p2\<close>)
   apply(simp add: hlp2 swap_b; fail)
  by (metis hlp3 id_apply swap_nothing zahlenwps_id)

lemma maxime_altruistischer_fortschritt_mhg_handlungsabsichten:
  \<open>ha \<in> set handlungsabsichten \<Longrightarrow>
    maxime_und_handlungsabsicht_generalisieren zahlenwps welt maxime_altruistischer_fortschritt ha p\<close>
  apply(simp add: handlungsabsichten_def)
  apply(safe)
      apply(case_tac \<open>welt\<close>, simp add: handeln_def nachher_handeln.simps maxime_und_handlungsabsicht_generalisieren_def maxime_altruistischer_fortschritt_def; fail)
     apply (simp add: mhg_maxime_altruistischer_fortschritt_stehlen; fail)
    apply(simp add: maxime_altruistischer_fortschritt_reset; fail)
   apply(simp add: maxime_altruistischer_fortschritt_alles_kaputt_machen; fail)
  apply(case_tac \<open>welt\<close>, simp add: handeln_def nachher_handeln.simps maxime_und_handlungsabsicht_generalisieren_def maxime_altruistischer_fortschritt_def)
  done
(*>*)

text\<open>Die Aussage, dass die \<^const>\<open>maxime_altruistischer_fortschritt\<close> den kategorischen Imperativ
  für bestimmte Handlungsabsichten und Welten erfüllt generalisiert noch weiter.
  Für alle Welten und alle wohlgeformten Handlungsabsichten welche mit der Maxime generalisieren
  erfüllt die Maxime den kategorischen Imperativ.\<close>
theorem kapimp_maxime_altruistischer_fortschritt: \<open>
    \<forall>p. maxime_und_handlungsabsicht_generalisieren zahlenwps welt maxime_altruistischer_fortschritt ha p \<Longrightarrow>
    wohlgeformte_handlungsabsicht zahlenwps welt ha \<Longrightarrow>
    kategorischer_imperativ_auf ha welt maxime_altruistischer_fortschritt\<close>
  unfolding maxime_altruistischer_fortschritt_def
  apply(erule globale_maxime_katimp)
      apply(cases \<open>ha\<close>, simp add: ist_noop_def handeln_def nachher_handeln.simps; fail)
     apply(simp add: wpsm_kommutiert_altruistischer_fortschritt[simplified maxime_altruistischer_fortschritt_def]; fail)
    apply (simp add: zahlenwps_sym; fail)
   apply (simp add: zahlenwps_twice; fail)
  by(simp; fail)

text\<open>Allgemein scheint dies eine sehr gute Maxime zu sein
  (für dieses sehr beschränkte Weltenmodell).\<close>

corollary \<open>ha \<in> set handlungsabsichten \<Longrightarrow>
    kategorischer_imperativ_auf ha welt maxime_altruistischer_fortschritt\<close>
  apply(rule kapimp_maxime_altruistischer_fortschritt)
  using maxime_altruistischer_fortschritt_mhg_handlungsabsichten apply simp
  using wfh_handlungsabsichten apply simp
  done

(*<*)
(*Interessante Sachen. Die sollten in die jeweiligen thys upgestremed werden.*)
lemma
  \<open>okay maxime_altruistischer_fortschritt p1 (handeln p2 welt ha) \<longleftrightarrow>
    okay maxime_altruistischer_fortschritt p2 (map_handlung (zahlenwps p1 p2) (handeln p2 welt ha))\<close>
  using wfm_maxime_altruistischer_fortschritt
  by (simp add: wohlgeformte_maxime_auf_def wohlgeformte_maxime_def)

beispiel \<open>p \<noteq> p1 \<Longrightarrow> p \<noteq> p2 \<Longrightarrow>
  zahlenwps p2 p (zahlenwps p1 p2 (zahlenwps p1 p welt)) = zahlenwps p1 p2 welt\<close>
  apply(cases \<open>welt\<close>, simp add: swap_def)
  by (metis swap_nilpotent swap_triple)

lemma zahlenwps_unrelated_im_kreis:
  \<open>p \<noteq> p1 \<Longrightarrow> p \<noteq> p2 \<Longrightarrow>
    zahlenwps p2 p (zahlenwps p1 p2 (zahlenwps p p1 (zahlenwps p1 p2 welt))) = welt\<close>
  by(cases \<open>welt\<close>, simp add: swap_unrelated_im_kreis)

lemma zahlenwps_unrelated_im_kreis_map_handlung_helper:
  \<open>p \<noteq> p1 \<Longrightarrow> p \<noteq> p2 \<Longrightarrow>
  map_handlung (zahlenwps p1 p) (map_handlung (zahlenwps p2 p1) (map_handlung (zahlenwps p p2) h))
  = map_handlung (zahlenwps p2 p1) h\<close>
  apply(cases \<open>h\<close>, rename_tac vor nach, simp)
  apply(case_tac \<open>vor\<close>, case_tac \<open>nach\<close>, simp)
  by (metis swap1 swap_unrelated_im_kreis)

(*WOW: ich bekomme ein (zahlenwps p1 p2 welt) innerhalb einer Handlung weg!*)
lemma wfh_unrelated_pullout_wps:
  \<open>p \<noteq> p1 \<Longrightarrow> p \<noteq> p2 \<Longrightarrow>
  \<forall>welt. wohlgeformte_handlungsabsicht zahlenwps welt ha \<Longrightarrow>
    handeln p (zahlenwps p1 p2 welt) ha
      = map_handlung (zahlenwps p2 p1) (handeln p welt ha)\<close>
  thm wohlgeformte_handlungsabsicht_wpsid_wpssym_komm
  thm wohlgeformte_handlungsabsicht_wpsid_simp[of \<open>zahlenwps\<close> \<open>zahlenwps p1 p2 welt\<close> \<open>ha\<close>]
  apply(subgoal_tac \<open>handeln p (zahlenwps p1 p2 welt) ha =
     map_handlung (zahlenwps p1 p) (handeln p1 (zahlenwps p p1 (zahlenwps p1 p2 welt)) ha)\<close>)
   prefer 2
  using wohlgeformte_handlungsabsicht_wpsid_simp[of \<open>zahlenwps\<close> \<open>zahlenwps p1 p2 welt\<close> \<open>ha\<close>]
   apply (simp add: wps_id_def zahlenwps_twice(2); fail)
  apply(simp)
  apply(thin_tac \<open>handeln p (zahlenwps p1 p2 welt) ha = _\<close>)
  thm wohlgeformte_handlungsabsicht_wpsid_simp[of \<open>zahlenwps\<close> \<open>zahlenwps p p1 (zahlenwps p1 p2 welt)\<close> \<open>ha\<close>]
  apply(subgoal_tac \<open>handeln p1 (zahlenwps p p1 (zahlenwps p1 p2 welt)) ha =
     map_handlung (zahlenwps p2 p1) (handeln p2 (zahlenwps p1 p2 (zahlenwps p p1 (zahlenwps p1 p2 welt))) ha)\<close>)
   prefer 2
  using wohlgeformte_handlungsabsicht_wpsid_simp[of \<open>zahlenwps\<close> \<open>(zahlenwps p p1 (zahlenwps p1 p2 welt))\<close> \<open>ha\<close>]
   apply (simp add: wps_id_def zahlenwps_twice(2); fail)
  apply(simp)
  apply(thin_tac \<open>handeln p1 _ ha = _\<close>)
  thm wohlgeformte_handlungsabsicht_wpsid_simp[of \<open>zahlenwps\<close> \<open>(zahlenwps p1 p2 (zahlenwps p p1 (zahlenwps p1 p2 welt)))\<close> \<open>ha\<close>]
  apply(subgoal_tac \<open>handeln p2 (zahlenwps p1 p2 (zahlenwps p p1 (zahlenwps p1 p2 welt))) ha =
     map_handlung (zahlenwps p p2)
      (handeln p (zahlenwps p2 p (zahlenwps p1 p2 (zahlenwps p p1 (zahlenwps p1 p2 welt)))) ha)\<close>)
   prefer 2
  using wohlgeformte_handlungsabsicht_wpsid_simp[of \<open>zahlenwps\<close> \<open>(zahlenwps p1 p2 (zahlenwps p p1 (zahlenwps p1 p2 welt)))\<close> \<open>ha\<close>]
   apply (simp add: wps_id_def zahlenwps_twice(2); fail)
  apply(simp)
  apply(thin_tac \<open>handeln p2 _ ha = _\<close>)
  apply(simp add: zahlenwps_unrelated_im_kreis zahlenwps_unrelated_im_kreis_map_handlung_helper; fail)
  done

(*ziemlich powerful, weil das das wps aus der welt rauszieht! Allerdings aendert sich die handelnde Person.
TODO: kann ich das generalisieren?*)
lemma wohlgeformte_handlungsabsicht_zahlenwps_komm:
  \<open>\<forall>welt. wohlgeformte_handlungsabsicht zahlenwps welt ha \<Longrightarrow>
    handeln p (zahlenwps p1 p2 welt) ha =
            map_handlung (zahlenwps p1 p2) (handeln (swap p1 p2 id p) welt ha)\<close>
  apply(subgoal_tac \<open>wohlgeformte_handlungsabsicht zahlenwps (zahlenwps p1 p2 welt) ha\<close>)
   prefer 2 apply blast
  apply(drule wohlgeformte_handlungsabsicht_mit_wpsid)
  subgoal by (simp add: wps_id_def zahlenwps_twice(2))
  apply(case_tac \<open>p=p1\<close>)
   apply(simp add: swap_a)
   apply (metis handlung.collapse handlung.map_sel(1) handlung.map_sel(2) zahlenwps_sym zahlenwps_twice(1))
  apply(case_tac \<open>p=p2\<close>)
   apply(simp add: swap_b)
   apply (metis zahlenwps_twice(2))
  apply(simp add: swap_nothing)
  apply(thin_tac \<open> \<forall>p1a p2a. _ p1a p2a\<close>)
  using wfh_unrelated_pullout_wps
  by (metis zahlenwps_sym)

lemma \<open>pX \<noteq> p1 \<Longrightarrow> pX \<noteq> p2 \<Longrightarrow> p1 \<noteq> p2 \<Longrightarrow>
  zahlenwps pX p1 (zahlenwps pX p2 (zahlenwps p1 pX (zahlenwps p1 p2 welt))) = welt\<close>
  by(cases \<open>welt\<close>, simp add: swap_def Fun.swap_def)

lemma \<open>pX \<noteq> p1 \<Longrightarrow> pX \<noteq> p2 \<Longrightarrow> p1 \<noteq> p2 \<Longrightarrow>
  zahlenwps pX p2 (zahlenwps pX p1 (zahlenwps p2 pX (zahlenwps p1 p2 welt))) = welt\<close>
  by(cases \<open>welt\<close>, simp add: swap_def Fun.swap_def)

lemma zahlenwps_funny_permutation: \<open>p \<noteq> p1 \<Longrightarrow> p \<noteq> p2 \<Longrightarrow>
  zahlenwps p2 p1 (zahlenwps p p2 (zahlenwps p1 p (zahlenwps p1 p2 welt)))
    = zahlenwps p p1 (zahlenwps p2 p welt)\<close>
  apply(cases \<open>welt\<close>, simp add: swap_def Fun.swap_def)
  by auto

lemma zahlenwps_funny_permutation_map_handlung_helper:
  \<open>p \<noteq> p1 \<Longrightarrow> p \<noteq> p2 \<Longrightarrow> p1 \<noteq> p2 \<Longrightarrow>
  map_handlung (zahlenwps p p1) (map_handlung (zahlenwps p2 p) (map_handlung (zahlenwps p1 p2) h))
    = map_handlung (zahlenwps p2 p) ( ( h))\<close>
  apply(cases \<open>h\<close>, rename_tac vor nach, simp)
  apply(case_tac \<open>vor\<close>, case_tac \<open>nach\<close>, simp)
  apply(simp add: swap_def Fun.swap_def)
  by auto

lemma wfh_pullout_wps_helper_same:
  \<open>p1 = p2 \<Longrightarrow>
    handeln p1 (zahlenwps p1 p2 welt) ha = handeln p1 welt ha\<close>
  apply(simp add: zahlenwps_id)
  done

text\<open>Umschreiben mit einem unrelated p. Bin mir noch nicht sicher, ob das was bringt.\<close>
lemma wfh_pullout_wps_move_to_unrelated:
  \<open>\<forall>welt. wohlgeformte_handlungsabsicht zahlenwps welt ha \<Longrightarrow>
    p \<noteq> p1 \<Longrightarrow> p \<noteq> p2 \<Longrightarrow> p1 \<noteq> p2 \<Longrightarrow>
    handeln p1 (zahlenwps p1 p2 welt) ha
      = map_handlung (zahlenwps p2 p) (handeln p1 (zahlenwps p p1 (zahlenwps p2 p welt)) ha)\<close>
  apply(subgoal_tac \<open>handeln p1 (zahlenwps p1 p2 welt) ha =
     map_handlung (zahlenwps p p1) (handeln p (zahlenwps p1 p (zahlenwps p1 p2 welt)) ha)\<close>)
   prefer 2
  using wohlgeformte_handlungsabsicht_wpsid_simp[of \<open>zahlenwps\<close> \<open>zahlenwps p1 p2 welt\<close> \<open>ha\<close>]
   apply (simp add: wps_id_def zahlenwps_twice(2); fail)
  apply(simp)
  apply(thin_tac \<open>handeln p1 _ ha = _\<close>)
  thm wohlgeformte_handlungsabsicht_wpsid_simp[of \<open>zahlenwps\<close> \<open>zahlenwps p1 p (zahlenwps p1 p2 welt)\<close> \<open>ha\<close>]
  apply(subgoal_tac \<open>handeln p (zahlenwps p1 p (zahlenwps p1 p2 welt)) ha =
     map_handlung (zahlenwps p2 p) (handeln p2 (zahlenwps p p2 (zahlenwps p1 p (zahlenwps p1 p2 welt))) ha)\<close>)
   prefer 2
  using wohlgeformte_handlungsabsicht_wpsid_simp[of \<open>zahlenwps\<close> \<open>(zahlenwps p1 p (zahlenwps p1 p2 welt))\<close> \<open>ha\<close>]
   apply (simp add: wps_id_def zahlenwps_twice(2); fail)
  apply(simp)
  apply(thin_tac \<open>handeln p _ ha = _\<close>)
  thm wohlgeformte_handlungsabsicht_wpsid_simp[of \<open>zahlenwps\<close> \<open>zahlenwps p p2 (zahlenwps p1 p (zahlenwps p1 p2 welt))\<close> \<open>ha\<close>]
  apply(subgoal_tac \<open>handeln p2 (zahlenwps p p2 (zahlenwps p1 p (zahlenwps p1 p2 welt))) ha =
     map_handlung (zahlenwps p1 p2)
      (handeln p1 (zahlenwps p2 p1 (zahlenwps p p2 (zahlenwps p1 p (zahlenwps p1 p2 welt)))) ha)\<close>)
   prefer 2
  using wohlgeformte_handlungsabsicht_wpsid_simp[of \<open>zahlenwps\<close> \<open>zahlenwps p p2 (zahlenwps p1 p (zahlenwps p1 p2 welt))\<close> \<open>ha\<close>]
   apply (simp add: wps_id_def zahlenwps_twice(2); fail)
  apply(simp)
  apply(thin_tac \<open>handeln p2 _ ha = _\<close>)
  apply(simp add: zahlenwps_funny_permutation zahlenwps_funny_permutation_map_handlung_helper)
  done

(*
  text\<open>todo. wenn das klappt haetten wir einen kat imp bewiesen. Wird aber nicht klappen.\<close>
lemma "wohlgeformte_handlungsabsicht zahlenwps welt ha \<Longrightarrow>
    kategorischer_imperativ_auf ha welt maxime_altruistischer_fortschritt"

brauchen etwas in die Richtung:
handeln p2 (zahlenwps ich p2 welt) ha) = zahlenwps ich p2 (handeln p2 welt ha)
Warum das nicht gelte wird:
Handlungsabsicht: erschaffen 5 Alice
Welt: Alice=0, Bob=3
wps Alice Bob
links: Alice=8, Bob=0
rechts: Alice=5, Bob=3
da laesst sich auch dann nachtraeglich nichts mehr swappen.

könnte ich eventuell:
kategorischer Imperativ \<Longrightarrow> maxime_und_handlungsabsicht_generalisieren*)

(*>*)

subsection\<open>Maxime für strikten individuellen Fortschritt\<close>
text\<open>In der Maxime \<^const>\<open>individueller_fortschritt\<close> hatten wir
   \<^term>\<open>(meins p nach) \<ge> (meins p vor)\<close>.
  Was wenn wir nun echten Fortschritt fordern:
   \<^term>\<open>(meins p nach) > (meins p vor)\<close>?\<close>

fun individueller_strikter_fortschritt :: \<open>person \<Rightarrow> zahlenwelt handlung \<Rightarrow> bool\<close> where
  \<open>individueller_strikter_fortschritt p (Handlung vor nach) \<longleftrightarrow> (meins p vor) < (meins p nach)\<close>

text\<open>Folgendes ernüchterndes Beispiel zeigt,
die Maxime \<^const>\<open>individueller_strikter_fortschritt\<close> erfüllt nicht den kategorischen Imperativ.
Entweder erlaubt die Maxime keine Assuage über eine Handlungsabsicht,
oder die Handlungsabsicht ist verboten.\<close>
beispiel \<open>erzeuge_beispiel
    zahlenwps (Zahlenwelt (\<euro>(Alice := 5, Bob := 10, Carol := -3)))
    handlungsabsichten
    (Maxime individueller_strikter_fortschritt) =
  Some
    \<lparr>
     bsp_erfuellte_maxime = False,
     bsp_erlaubte_handlungen = [],
     bsp_verbotene_handlungen = [
        Handlungsabsicht alles_kaputt_machen,
        Handlungsabsicht unmoeglich],
     bsp_uneindeutige_handlungen = [
        Handlungsabsicht (erschaffen 5),
        Handlungsabsicht (stehlen 5 10),
        Handlungsabsicht reset]
    \<rparr>\<close>
  by beispiel_tac

text\<open>In keiner Welt ist die Handlung \<^const>\<open>erschaffen\<close> nun \<^const>\<open>moralisch\<close>:\<close>
lemma \<open>\<not> moralisch welt
            (Maxime (\<lambda>ich. individueller_strikter_fortschritt ich)) (Handlungsabsicht (erschaffen 5))\<close>
  apply(cases \<open>welt\<close>)
  by(auto simp add: maxime_zahlenfortschritt_def moralisch_simp handeln_def nachher_handeln.simps)

text\<open> Der Grund ist, dass der Rest der Bevölkerung keine \<^emph>\<open>strikte\<close> Erhöhung des
eigenen Wohlstands erlebt.
Effektiv führt diese Maxime zu einem Gesetz, welches es einem Individuum nicht erlaubt
mehr Besitz zu erschaffen, obwohl niemand dadurch einen Nachteil hat.
Diese Maxime kann meiner Meinung nach nicht gewollt sein.

Beispielsweise ist \<^const>\<open>Bob\<close> das Opfer wenn \<^const>\<open>Alice\<close> sich 5 Wohlstand erschafft,
aber \<^const>\<open>Bob\<close>'s Wohlstand sich dabei nicht erhöht:\<close>
beispiel
  \<open>\<lparr>
      dbg_opfer = Bob, dbg_taeter = Alice,
      dbg_handlung = handeln Alice initialwelt (Handlungsabsicht (erschaffen 5))
     \<rparr>
          \<in> debug_maxime id initialwelt
            (Maxime (\<lambda>ich. individueller_strikter_fortschritt ich)) (Handlungsabsicht (erschaffen 5)) \<close>
  by eval

subsection\<open>Maxime für globales striktes Optimum\<close>
text\<open>Wir bauen nun eine Maxime, die das Individuum vernachlässigt und nur nach dem
globalen Optimum strebt:\<close>
fun globaler_strikter_fortschritt :: \<open>zahlenwelt handlung \<Rightarrow> bool\<close> where
  \<open>globaler_strikter_fortschritt (Handlung vor nach) \<longleftrightarrow> (gesamtbesitz vor) < (gesamtbesitz nach)\<close>

text\<open>Die Maxime ignoriert das \<^term>\<open>ich :: person\<close> komplett.

Nun ist es \<^const>\<open>Alice\<close> wieder erlaubt, Wohlstand für sich selbst zu erzeugen,
da sich dadurch auch der Gesamtwohlstand erhöht:\<close>
beispiel \<open>moralisch initialwelt
          (Maxime (\<lambda>ich. globaler_strikter_fortschritt)) (Handlungsabsicht (erschaffen 5))\<close>
  by(eval)

text\<open>Allerdings ist auch diese Maxime auch sehr grausam, da sie Untätigkeit verbietet:\<close>
beispiel \<open>\<not> moralisch initialwelt
          (Maxime (\<lambda>ich. globaler_strikter_fortschritt)) (Handlungsabsicht (erschaffen 0))\<close>
  by(eval)

text\<open>Unsere initiale einfache \<^const>\<open>maxime_zahlenfortschritt\<close> würde Untätigkeit hier erlauben:\<close>
beispiel \<open>moralisch initialwelt
          maxime_zahlenfortschritt (Handlungsabsicht (erschaffen 0))\<close>
  by(eval)

text\<open>Folgendes Beispiel zeigt, dass die Maxime \<^const>\<open>globaler_strikter_fortschritt\<close>
den kategorischen Imperativ erfüllen kann.
Die Handlungsabsichten sind fast intuitiv in erlaubt und verboten eingeordnet.
  \<^item> \<^term>\<open>erschaffen 5\<close> ist erlaubt.
  \<^item> \<^const>\<open>stehlen\<close>, \<^const>\<open>reset\<close>, \<^const>\<open>alles_kaputt_machen\<close> sind verboten.
    Allerdings ist auch \<^const>\<open>unmoeglich\<close> verboten, da die Maxime Untätigkeit verbietet.
    Dieser letzte Fall ist unschön.
\<close>
beispiel \<open>erzeuge_beispiel
    zahlenwps (Zahlenwelt (\<euro>(Alice := 5, Bob := 10, Carol := -3)))
    handlungsabsichten
    (Maxime (\<lambda>ich. globaler_strikter_fortschritt)) =
  Some
    \<lparr>
     bsp_erfuellte_maxime = True,
     bsp_erlaubte_handlungen = [Handlungsabsicht (erschaffen 5)],
     bsp_verbotene_handlungen = [
      Handlungsabsicht (stehlen 5 10),
      Handlungsabsicht reset,
      Handlungsabsicht alles_kaputt_machen,
      Handlungsabsicht unmoeglich],
     bsp_uneindeutige_handlungen = []\<rparr>\<close>
  by beispiel_tac

subsection\<open>Maxime für globales Optimum\<close>
text\<open>Wir können die Maxime für globalen Fortschritt etwas lockern.\<close>
fun globaler_fortschritt :: \<open>zahlenwelt handlung \<Rightarrow> bool\<close> where
  \<open>globaler_fortschritt (Handlung vor nach) \<longleftrightarrow> (gesamtbesitz vor) \<le> (gesamtbesitz nach)\<close>

text\<open>Untätigkeit ist nun auch hier erlaubt:\<close>
beispiel \<open>moralisch initialwelt
          (Maxime (\<lambda>ich. globaler_fortschritt)) (Handlungsabsicht (erschaffen 0))\<close>
  by(eval)

(*<*)
lemma globaler_fortschritt_kommutiert:
  \<open>wpsm_kommutiert (Maxime (\<lambda>ich::person. globaler_fortschritt)) zahlenwps welt\<close>
  by(simp add: wpsm_kommutiert_def gesamtbesitz_swap zahlenwps_sym handeln_def nachher_handeln.simps)
(*>*)

text\<open>Allerdings ist auch Stehlen erlaubt, da global gesehen, kein Besitz vernichtet wird:\<close>
beispiel \<open>moralisch initialwelt
          (Maxime (\<lambda>ich. globaler_fortschritt)) (Handlungsabsicht (stehlen_nichtwf 5 Bob))\<close>
  by(eval)
beispiel \<open>moralisch initialwelt
          (Maxime (\<lambda>ich. globaler_fortschritt)) (Handlungsabsicht (stehlen 5 10))\<close>
  by(eval)

text\<open>Folgendes Beispiel zeigt, dass die Maxime \<^const>\<open>globaler_fortschritt\<close>
den kategorischen Imperativ erfüllen kann.
Die Handlungsabsichten sind meiner Meinung nach intuitiv
(basierend auf der globalen Betrachtung der Maxime) in erlaubt und verboten eingeordnet.
  \<^item> \<^term>\<open>erschaffen\<close> ist erlaubt.
    Auch \<^const>\<open>stehlen\<close> ist erlaubt, da dabei "doem Kollektiv" kein Besitz verloren geht.
    Untätigkeit wird wieder über \<^const>\<open>unmoeglich\<close> erlaubt.
  \<^item> \<^const>\<open>reset\<close> und \<^const>\<open>alles_kaputt_machen\<close> sind verboten.
\<close>
beispiel \<open>erzeuge_beispiel
    zahlenwps (Zahlenwelt (\<euro>(Alice := 5, Bob := 10, Carol := -3)))
    handlungsabsichten
    (Maxime (\<lambda>ich. globaler_fortschritt)) =
  Some
    \<lparr>
     bsp_erfuellte_maxime = True,
     bsp_erlaubte_handlungen = [
      Handlungsabsicht (erschaffen 5),
      Handlungsabsicht (stehlen 5 10),
      Handlungsabsicht unmoeglich],
     bsp_verbotene_handlungen = [
      Handlungsabsicht reset,
      Handlungsabsicht alles_kaputt_machen],
     bsp_uneindeutige_handlungen = []\<rparr>\<close>
  by beispiel_tac

text\<open>Auch allgemein lässt ich beweisen,
dass diese Maxime für sehr viele Handlungsabsichten den kategorischen Imperativ erfüllt.\<close>
theorem
  \<open>\<forall>p. maxime_und_handlungsabsicht_generalisieren zahlenwps welt
     (Maxime (\<lambda>ich. globaler_fortschritt)) ha p \<Longrightarrow>
 wohlgeformte_handlungsabsicht zahlenwps welt ha \<Longrightarrow>
  kategorischer_imperativ_auf ha welt (Maxime (\<lambda>ich::person. globaler_fortschritt))\<close>
  apply(erule globale_maxime_katimp)
      apply(cases \<open>welt\<close>, cases \<open>ha\<close>, simp add: ist_noop_def handeln_def nachher_handeln.simps; fail)
     apply(simp add: globaler_fortschritt_kommutiert; fail)
    apply(simp add: zahlenwps_sym)
   apply (simp add: zahlenwps_twice; fail)
  by(simp; fail)

text\<open>Sollte man das Kollektiv höher stellen als das Individuum
und damit effektiv das Recht auf Privateigentum ablehnen (was ich persönlich nicht unterstütze),
so ist \<^const>\<open>globaler_fortschritt\<close> eine Maxime mit schönen Eigenschaften.\<close>

subsection\<open>Ungültige Maxime\<close>
text\<open>Es ist verboten, in einer Maxime eine spezielle Person hardzucoden.
Technisch könnte so eine Maxime den \<^const>\<open>kategorischer_imperativ_auf\<close> erfüllen.
Dies wollen wir aber nicht, da dies gegen die Gleichbehandlung aller Menschen verstoßen würde.
Das Ergebnis wären verdrehte Moralbewertungen,
welche moralische Entscheidungen ausschließlich basierend auf egoistischen Bedürfnissen
der hardgecodeten Personen basieren.

Beispielsweise könnten wir \<^const>\<open>individueller_fortschritt\<close> nicht mehr parametrisiert verwenden,
sondern einfach \<^const>\<open>Alice\<close> reinschreiben:\<close>
beispiel \<open>individueller_fortschritt Alice
    = (\<lambda>h. case h of Handlung vor nach \<Rightarrow> (meins Alice vor) \<le> (meins Alice nach))\<close>
  apply(simp add: fun_eq_iff)
  apply(intro allI, rename_tac h, case_tac \<open>h\<close>)
  apply(simp)
  done

text\<open>Solch eine Maxime ist allerdings nicht wohlgeformt.\<close>
beispiel \<open>\<not> wohlgeformte_maxime_auf
    (handeln Alice initialwelt (Handlungsabsicht (stehlen 5 10))) zahlenwps
    (Maxime (\<lambda>ich. individueller_fortschritt Alice))\<close>
  apply(simp add: wohlgeformte_maxime_auf_def)
  apply(rule_tac x=\<open>Alice\<close> in exI)
  apply(rule_tac x=\<open>Bob\<close> in exI)
  apply(code_simp)
  done

text\<open>Sobald wir aufhören \<^const>\<open>Alice\<close> hardzucoden, wird die Maxime wohlgeformt.\<close>
beispiel \<open>wohlgeformte_maxime_auf
    (handeln Alice initialwelt (Handlungsabsicht (stehlen 5 10))) zahlenwps
    (Maxime (\<lambda>ich. individueller_fortschritt ich))\<close>
  apply(simp add: wohlgeformte_maxime_auf_def)
  apply(code_simp)
  done

text\<open>Unser \<^const>\<open>erzeuge_beispiel\<close> verweigert die Arbeit auf nicht-wohlgeformten Maximen.\<close>

subsection\<open>Uneindeutige Handlungen\<close>
text\<open>Bis jetzt haben wir den Schuldigen immer bei der Maxime gesucht,
wenn der kategorische Imperativ nicht erfüllt war und wir somit über bestimmte Handlungsabsichten
keine Aussage treffen konnten.
Gibt es jedoch auch Handlungsabsichten welche vermutlich unabhängig von jeder durchdachten Maxime
keine Bewertung im Sinne des kategorischen Imperativs erlauben?\<close>

text\<open>Folgende Funktion ist inspiriert durch das \<^url>\<open>https://de.wikipedia.org/wiki/Collatz-Problem\<close>.\<close>
fun collatz:: \<open>int \<Rightarrow> int\<close> where
  \<open>collatz n = (if n mod 2 = 0 then n div 2 else 3*n + 1)\<close>
beispiel \<open>collatz 19 = 58\<close> by eval

text\<open>Es folgt eine Handlungsabsicht, basierend auf dem Collatz-Problem.
Das eigentliche Collatz-Problem ist an dieser Stelle nicht relevant,
da wir nur eine Iteration machen.
Allerdings ist das eine spannende Handlungsabsicht,
da diese sowohl den Besitz erhöhen kann, aber auch verringern kann.\<close>
fun collatzh:: \<open>person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>collatzh ich (Zahlenwelt besitz) = Some (Zahlenwelt (besitz( ich := collatz (besitz ich))))\<close>

text\<open>Die Handlungsabsicht \<^const>\<open>collatzh\<close> ist tatsächlich immer wohlgeformt.\<close>
lemma \<open>wohlgeformte_handlungsabsicht zahlenwps welt (Handlungsabsicht collatzh)\<close>
  apply(simp add: wohlgeformte_handlungsabsicht.simps)
  apply(case_tac \<open>welt\<close>, simp add: swap_def fun_eq_iff Fun.swap_def)+
  done

text\<open>Die Handlungsabsicht \<^const>\<open>collatzh\<close> generalisiert nicht mit der
\<^const>\<open>maxime_zahlenfortschritt\<close>.
Dies ist keine große Überraschung, da \<^const>\<open>reset\<close> auch nicht mit dieser Maxime generalisiert
hat und wir die Maxime auch für ungeeignet befunden haben.\<close>
beispiel
  \<open>\<not> maxime_und_handlungsabsicht_generalisieren
       zahlenwps (Zahlenwelt (\<euro>(Alice := 2, Bob := 3)))
       maxime_zahlenfortschritt (Handlungsabsicht collatzh) Alice\<close>
  by eval

text \<open>Für unsere hochgelobte \<^const>\<open>maxime_altruistischer_fortschritt\<close> hingegen
haben wir noch kein Beispiel einer Handlungsabsicht gesehen,
welche nicht mit ihr generalisiert hat.
Dies wirft die Frage auf:
"gibt es überhaupt wohlgeformte Handlungsabsichten, welche nicht mit
\<^const>\<open>maxime_altruistischer_fortschritt\<close> generalisieren?"
Die Antwort liefert \<^const>\<open>collatzh\<close>.\<close>
beispiel
  \<open>\<not> maxime_und_handlungsabsicht_generalisieren
       zahlenwps (Zahlenwelt (\<euro>(Alice := 2, Bob := 3)))
       maxime_altruistischer_fortschritt (Handlungsabsicht collatzh) Alice\<close>
  by eval

text\<open>Wir haben \<^const>\<open>collatzh\<close> bis jetzt immer bei der Bewertung von Maximen ausgeschlossen.
Das Ergebnis vorweg:
Ein kategorischer Imperativ, egal welche vielversprechende Maxime,
gilt nicht für die Handlungsabsicht \<^const>\<open>collatzh\<close>.\<close>

beispiel
  \<open>\<not> kategorischer_imperativ_auf (Handlungsabsicht collatzh)
        initialwelt maxime_zahlenfortschritt\<close>
  \<open>\<not> kategorischer_imperativ_auf (Handlungsabsicht collatzh)
        initialwelt maxime_altruistischer_fortschritt\<close>
  \<open>\<not> kategorischer_imperativ_auf (Handlungsabsicht collatzh)
        initialwelt (Maxime (\<lambda>ich. globaler_fortschritt))\<close>
  by(eval)+

text \<open>
Der Grund ist, oberflächlich gesprochen, dass diese Handlungsabsicht
keinen eindeutigen Charakter hat.
Die Handlungsabsicht kann sowohl Besitz verringern als auch vermehren.
In vielen Welten wird es Leute geben, für die \<^const>\<open>collatzh\<close> eine positive
Wirkung hat.
Jedoch ist \<^const>\<open>collatzh\<close> wohl allgemein nicht \<^const>\<open>moralisch\<close>,
da es normalerweise auch Leute gibt, für die \<^const>\<open>collatzh\<close> eine
negative Auswirkung hat.
Daher kann eine Maxime \<^const>\<open>collatzh\<close> nicht allgemein beurteilen.
Jedoch ist auch diese Meta-Aussage eine spannende Aussage:
Der kategorische Imperativ sagt (dadurch, dass er nicht erfüllt ist),
dass die Handlungsabsicht \<^const>\<open>collatz\<close> nicht durch eine unserer Maximen
beurteilt werden sollte, bzw. sollten wir ein allgemeines Gesetz bauen wollen,
so können wir weder \<^const>\<open>collatzh\<close> uneingeschränkt in die Liste erlaubter Handlungsabsichten
aufnehmen,
noch können wir uneingeschränkt \<^const>\<open>collatzh\<close> uneingeschränkt in die Liste verbotener
Handlungsabsichten aufnehmen.
Oder anders ausgedrückt: können wir ein allgemeines Gesetz wollen,
welches eine Aussage über die Handlungsabsicht \<^const>\<open>collatzh\<close> macht?
Ich argumentiere, dass wir solch ein Gesetz nicht wollen, da

  \<^item> Würden wir nur die Auswirkung von \<^const>\<open>collatzh\<close> betrachten,
    (also die resultierende \<^typ>\<open>'welt handlung\<close>,
     nicht die \<^term_type>\<open>Handlungsabsicht collatzh\<close>)
    so kann diese Auswirkung durchweg positiv sein,
    und wir möchten etwas positives nicht verbieten.
  \<^item> Jedoch hat die Handlungsabsicht auch negative Charakterzüge,
    da wir billigend in Kauf nehmen, dass Besitz vernichtet werden könnte.
    Daher möchten wir diese Absicht auch nicht uneingeschränkt erlauben.
    Besonders deutlich wird dies bei folgender zugespitzten Handlungsabsicht,
    welche billigend die komplette Vernichtung allen Besitzes in Kauf nehmen würde.
\<close>

definition uneindeutiger_charakter:: \<open>person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>uneindeutiger_charakter \<equiv>
      (\<lambda>ich welt. if meins ich welt mod 2 = 0
                   then alles_kaputt_machen ich welt
                   else erschaffen 5 ich welt)\<close>

lemma \<open>wohlgeformte_handlungsabsicht zahlenwps welt (Handlungsabsicht uneindeutiger_charakter)\<close>
  unfolding uneindeutiger_charakter_def
  apply(rule wohlgeformte_handlungsabsicht_ifI)
    apply(simp add: wohlgeformte_handlungsabsicht_alles_kaputt_machen)
   apply(simp add: wohlgeformte_handlungsabsicht_erschaffen)
  apply(simp add: hlp1 hlp2)
  done

beispiel
  \<open>\<not> kategorischer_imperativ_auf (Handlungsabsicht uneindeutiger_charakter)
        initialwelt maxime_zahlenfortschritt\<close>
  \<open>\<not> kategorischer_imperativ_auf (Handlungsabsicht uneindeutiger_charakter)
        initialwelt maxime_altruistischer_fortschritt\<close>
  \<open>\<not> kategorischer_imperativ_auf (Handlungsabsicht uneindeutiger_charakter)
        initialwelt (Maxime (\<lambda>ich. globaler_fortschritt))\<close>
  by(eval)+

text\<open>Mir gefällt, dass der (extensionale) kategorische Imperativ prinzipiell sagt,
dass wir die Handlungsabsicht \<^const>\<open>uneindeutiger_charakter\<close> nicht in einem allgemeinen
Gesetz behandeln können,
da die potenziellen positiven Auswirkungen im starken Gegensatz
zu der potenziell destruktiven zugrundeliegenden Absicht stehen.\<close>

text\<open>Wenn wir allerdings ausnutzen, dass Handlungsabsichten partiell sein können,
und so den guten und den schlechten Charakter in eigenständige Handlungsabsichten separieren,
so können wir wieder allgemeines Aussage über die beiden Handlungsabsichten machen.\<close>

definition partiell_guter_charakter:: \<open>person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>partiell_guter_charakter \<equiv>
      (\<lambda>ich welt. if meins ich welt mod 2 = 0
                   then None
                   else erschaffen 5 ich welt)\<close>

definition partiell_schlechter_charakter:: \<open>person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>partiell_schlechter_charakter \<equiv>
      (\<lambda>ich welt. if meins ich welt mod 2 = 0
                   then alles_kaputt_machen ich welt
                   else None)\<close>

beispiel \<open>erzeuge_beispiel
    zahlenwps (Zahlenwelt (\<euro>(Alice := 5, Bob := 10, Carol := -3)))
    [Handlungsabsicht partiell_guter_charakter, Handlungsabsicht partiell_schlechter_charakter]
    maxime_altruistischer_fortschritt
= Some
  \<lparr>
   bsp_erfuellte_maxime = True,
   bsp_erlaubte_handlungen = [Handlungsabsicht partiell_guter_charakter],
   bsp_verbotene_handlungen = [Handlungsabsicht partiell_schlechter_charakter],
   bsp_uneindeutige_handlungen = []
  \<rparr>\<close>
  by beispiel_tac

end


section {* Lifting expressions *}

theory utp_lift
  imports
    utp_alphabet
begin

subsection {* Lifting definitions *}

text {* We define operators for converting an expression to and from a relational state space *}

abbreviation lift_pre :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha> \<times> '\<beta>) uexpr" ("\<lceil>_\<rceil>\<^sub><")
where "\<lceil>P\<rceil>\<^sub>< \<equiv> P \<oplus>\<^sub>p fst\<^sub>L"

abbreviation drop_pre :: "('a, '\<alpha> \<times> '\<beta>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("\<lfloor>_\<rfloor>\<^sub><")
where "\<lfloor>P\<rfloor>\<^sub>< \<equiv> P \<restriction>\<^sub>p fst\<^sub>L"

abbreviation lift_post :: "('a, '\<beta>) uexpr \<Rightarrow> ('a, '\<alpha> \<times> '\<beta>) uexpr" ("\<lceil>_\<rceil>\<^sub>>")
where "\<lceil>P\<rceil>\<^sub>> \<equiv> P \<oplus>\<^sub>p snd\<^sub>L"

abbreviation drop_post :: "('a, '\<alpha> \<times> '\<beta>) uexpr \<Rightarrow> ('a, '\<beta>) uexpr" ("\<lfloor>_\<rfloor>\<^sub>>")
where "\<lfloor>P\<rfloor>\<^sub>> \<equiv> P \<restriction>\<^sub>p snd\<^sub>L"

abbreviation lift_cond_pre ("\<lceil>_\<rceil>\<^sub>\<leftarrow>") where "\<lceil>P\<rceil>\<^sub>\<leftarrow> \<equiv> P \<oplus>\<^sub>p (1\<^sub>L \<times>\<^sub>L 0\<^sub>L)"
abbreviation lift_cond_post ("\<lceil>_\<rceil>\<^sub>\<rightarrow>") where "\<lceil>P\<rceil>\<^sub>\<rightarrow> \<equiv> P \<oplus>\<^sub>p (0\<^sub>L \<times>\<^sub>L 1\<^sub>L)"

abbreviation drop_cond_pre ("\<lfloor>_\<rfloor>\<^sub>\<leftarrow>") where "\<lfloor>P\<rfloor>\<^sub>\<leftarrow> \<equiv> P \<restriction>\<^sub>p (1\<^sub>L \<times>\<^sub>L 0\<^sub>L)"
abbreviation drop_cond_post ("\<lfloor>_\<rfloor>\<^sub>\<rightarrow>") where "\<lfloor>P\<rfloor>\<^sub>\<rightarrow> \<equiv> P \<restriction>\<^sub>p (0\<^sub>L \<times>\<^sub>L 1\<^sub>L)"

subsection {* Lifting laws *}

lemma lift_pre_var [simp]:
  "\<lceil>var x\<rceil>\<^sub>< = $x"
  by (alpha_tac)

lemma lift_post_var [simp]:
  "\<lceil>var x\<rceil>\<^sub>> = $x\<acute>"
  by (alpha_tac)

lemma lift_cond_pre_var [simp]:
  "\<lceil>$x\<rceil>\<^sub>\<leftarrow> = $x"
  by (pred_auto)

lemma lift_cond_post_var [simp]:
  "\<lceil>$x\<acute>\<rceil>\<^sub>\<rightarrow> = $x\<acute>"
  by (pred_auto)

subsection {* Unrestriction laws *}

lemma unrest_dash_var_pre [unrest]:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "$x\<acute> \<sharp> \<lceil>p\<rceil>\<^sub><"
  by (pred_auto)

lemma unrest_dash_var_cond_pre [unrest]:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "$x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>\<leftarrow>"
  by (pred_auto)
end


theory It_to_It
imports
  "Proper_Iterator"
begin

  lemma proper_it_fold:
    "proper_it it it' \<Longrightarrow> foldli (it (\<lambda>_. True) (\<lambda>x l. l@[x]) []) = it'"
    unfolding proper_it_def by auto
  lemma proper_it_unfold:
    "proper_it it it' \<Longrightarrow> it' = foldli (it (\<lambda>_. True) (\<lambda>x l. l@[x]) [])"
    unfolding proper_it_def by auto

  text {* The following constant converts an iterator over list-state
    to an iterator over arbitrary state *}
  definition it_to_it :: "('x,'x list) set_iterator \<Rightarrow> ('x,'\<sigma>) set_iterator"
    where [code del]: "it_to_it it
    \<equiv> (foldli (it (\<lambda>_. True) (\<lambda>x l. l@[x]) []))"

  lemma pi_it_to_it[icf_proper_iteratorI]: "proper_it (it_to_it I) (it_to_it I)"
    unfolding it_to_it_def by (rule pi_foldli)
  text {* In case of a proper iterator, it is equivalent to direct iteration *}
  lemma it_to_it_fold: "proper_it it (it'::('x,'\<sigma>) set_iterator)
    \<Longrightarrow> it_to_it it = it'"
    unfolding it_to_it_def
    by (simp add: proper_it_fold)

  lemma it_to_it_map_fold:
    assumes P: "proper_it it it'"
    shows "it_to_it (\<lambda>c f. it c (f \<circ> f')) = (\<lambda>c f. it' c (f o f'))"
    apply (rule proper_itE[OF P])
    unfolding it_to_it_def
    apply (intro ext)
    apply (simp add: foldli_foldl map_by_foldl foldli_map)
    done

  lemma it_to_it_fold': "proper_it' it (it'::'s \<Rightarrow> ('x,'\<sigma>) set_iterator)
    \<Longrightarrow> it_to_it (it s) = (it' s)"
    by (drule proper_it'D) (rule it_to_it_fold)

  lemma it_to_it_map_fold':
    assumes P: "proper_it' it it'"
    shows "it_to_it (\<lambda>c f. it s c (f \<circ> f')) = (\<lambda>c f. it' s c (f o f'))"
    using P[THEN proper_it'D] by (rule it_to_it_map_fold)

  text {* This locale wraps up the setup of a proper iterator for use
    with @{text "it_to_it"}. *}
  locale proper_it_loc =
    fixes it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
    and it' :: "'s \<Rightarrow> ('x,'\<sigma>) set_iterator"
    assumes proper': "proper_it' it it'"
  begin
    lemma proper: "proper_it (it s) (it' s)"
      using proper' by (rule proper_it'D)

    lemmas it_to_it_code_unfold[code_unfold] = it_to_it_fold[OF proper]
  end

  subsubsection {* Correctness *}
  text {* The polymorphic iterator is a valid iterator again. *}
  lemma it_to_it_genord_correct:
    assumes "set_iterator_genord (it::('x,'x list) set_iterator) S R"
    shows "set_iterator_genord ((it_to_it it)::('x,'\<sigma>) set_iterator) S R"
  proof -
    interpret set_iterator_genord it S R by fact

    show ?thesis
      apply (unfold_locales)
      unfolding it_to_it_def
      using foldli_transform
      by auto
  qed

  lemma it_to_it_linord_correct:
    assumes "set_iterator_linord (it::('x::linorder,'x list) set_iterator) S"
    shows "set_iterator_linord ((it_to_it it)::('x,'\<sigma>) set_iterator) S"
    using assms
    unfolding set_iterator_linord_def
    by (rule it_to_it_genord_correct)

  lemma it_to_it_rev_linord_correct:
    assumes "set_iterator_rev_linord (it::('x::linorder,'x list) set_iterator) S"
    shows "set_iterator_rev_linord ((it_to_it it)::('x,'\<sigma>) set_iterator) S"
    using assms
    unfolding set_iterator_rev_linord_def
    by (rule it_to_it_genord_correct)

  lemma it_to_it_map_genord_correct:
    assumes "map_iterator_genord (it::('u,'v,('u\<times>'v) list) map_iterator) S R"
    shows "map_iterator_genord ((it_to_it it)::('u,'v,'\<sigma>) map_iterator) S R"
    using assms by (rule it_to_it_genord_correct)

  lemma it_to_it_map_linord_correct:
    assumes "map_iterator_linord (it::('u::linorder,'v,('u\<times>'v) list) map_iterator) S"
    shows "map_iterator_linord ((it_to_it it)::('u,'v,'\<sigma>) map_iterator) S"
    using assms unfolding set_iterator_map_linord_def by (rule it_to_it_genord_correct)

  lemma it_to_it_map_rev_linord_correct:
    assumes
      "map_iterator_rev_linord (it::('u::linorder,'v,('u\<times>'v) list) map_iterator) S"
    shows "map_iterator_rev_linord ((it_to_it it)::('u,'v,'\<sigma>) map_iterator) S"
    using assms unfolding set_iterator_map_rev_linord_def
    by (rule it_to_it_genord_correct)

  lemma it_to_it_map_correct:
    assumes "map_iterator (it::('u,'v,('u\<times>'v) list) map_iterator) S"
    shows "map_iterator ((it_to_it it)::('u,'v,'\<sigma>) map_iterator) S"
    using assms by (rule it_to_it_correct)

end