theory BeispielZahlenwelt2
imports Zahlenwelt BeispielPerson Aenderung KategorischerImperativ
begin

section\<open>Beispiel: Zahlenwelt2\<close>
text\<open>In diesem Abschnitt werden wir ein weiteres Beispiel sehen.\<close>

text\<open>Dieses Beispiel ist ähnlich zum Beispiel Zahlenwelt in Abschnitt \ref{sec:bspzahlenwelt}.
Allerdings führen wir einige Erweiterungen ein:
  \<^item> Jeder Person wird weiterhin ihr Besitz zugeordnet.
  \<^item> Neben dem Besitz gibt es auch ein Modell von Konsens.
    Dabei soll Konsens die Liste aller bereits getroffenen Abmachungen darstellen,
    bzw modellieren, zu was die Leute bereit wären.
    So lässt sich beispielsweise Schenken (Besitzübergang mit Konsens)
    von Stehlen (Besitzübergang ohne Konsens) unterscheiden.
  \<^item> Es gibt eine spezielle Entität, nämlich den Staat.
    Diese Entität ist nicht in der Menge der natürlichen Personen enthalten.
    Dies erlaubt es z.B. den Staat in Handlungsabsichten hardzucoden und
    gleichzeitig eine wohlgeformte Handlungsabsicht zu haben.
    TODO: machen
  \<^item> Als weitere spezielle Entität wird die Umwelt eingeführt.
\<close>

record zahlenwelt =
  besitz :: \<open>person \<Rightarrow> int\<close>
  konsens :: \<open>(person, int) globaler_konsens\<close>
  staatsbesitz :: \<open>int\<close> \<comment>\<open>Der Staat ist keine natürliche Person und damit besonders.\<close>
  umwelt :: \<open>int\<close>

definition initialwelt :: \<open>zahlenwelt\<close>
  where
\<open>initialwelt \<equiv> \<lparr>
  besitz = (\<euro>(Alice := 5, Bob := 10, Carol := -3)),
  konsens = (\<lambda>_. [])(
    Alice := [to_abmachung [Gewinnt Alice 3], to_abmachung [Gewinnt Alice 3, Verliert Bob 3]],
    Bob := [to_abmachung [Gewinnt Alice 3, Verliert Bob 3]]),
  staatsbesitz = 9000,
  umwelt = 600
 \<rparr>\<close>

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

beispiel \<open>meins Carol initialwelt = -3\<close> by eval

(*<*)
definition zahlenwps :: \<open>person \<Rightarrow> person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt\<close> where
  \<open>zahlenwps p1 p2 welt =
      welt\<lparr> besitz := swap p1 p2 (besitz welt),
            konsens := konsensswap p1 p2 (konsens welt) \<rparr>\<close>

beispiel \<open>zahlenwps Alice Bob initialwelt
= \<lparr>
  besitz = (\<euro>(Alice := 10, Bob := 5, Carol := -3)),
  konsens = (\<lambda>_. [])(
    Alice := [to_abmachung [Gewinnt Bob 3, Verliert Alice 3]],
    Bob := [to_abmachung [Gewinnt Bob 3], to_abmachung [Gewinnt Bob 3, Verliert Alice 3]]),
  staatsbesitz = 9000,
  umwelt = 600
 \<rparr>\<close> by eval

beispiel \<open>zahlenwps Alice Carol initialwelt
= \<lparr>
  besitz = (\<euro>(Alice := -3, Bob := 10, Carol := 5)),
  konsens = (\<lambda>_. [])(
    Bob := [to_abmachung [Gewinnt Carol 3, Verliert Bob 3]],
    Carol := [to_abmachung [Gewinnt Carol 3], to_abmachung [Gewinnt Carol 3, Verliert Bob 3]]),
  staatsbesitz = 9000,
  umwelt = 600
 \<rparr>\<close> by eval

(*<*)
lemma zahlenwps_id: \<open>zahlenwps p1 p2 (zahlenwps p1 p2 welt) = welt\<close>
  by(simp add: zahlenwps_def)

lemma zahlenwps_sym: \<open>zahlenwps p1 p2 = zahlenwps p2 p1\<close>
  apply(simp add: fun_eq_iff zahlenwps_def)
  by (simp add: swap_symmetric konsensswap_sym)

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

lemma besitz_zahlenwps[simp]: \<open>besitz (zahlenwps p1 p2 welt) = swap p1 p2 (besitz welt)\<close>
  by(simp add: zahlenwps_def)

lemma besitz_zahlenwps_apply: \<open>besitz (zahlenwps p1 p2 welt) p2 = besitz welt p1\<close>
  by (simp add: swap_b)

lemma besitz_zahlenwps_nothing: \<open>pX \<noteq> p1 \<Longrightarrow>
       pX \<noteq> p2 \<Longrightarrow>
       besitz (zahlenwps p1 p2 welt) pX = besitz welt pX\<close>
  by (simp add: swap_nothing)
(*>*)

definition enthaelt_konsens :: \<open>(person, int) abmachung \<Rightarrow> zahlenwelt \<Rightarrow> bool\<close>
where
  \<open>enthaelt_konsens abmachung welt \<equiv> Aenderung.enthaelt_konsens abmachung (konsens welt)\<close>

lemma enthaelt_konsens_swap:
  \<open>enthaelt_konsens (swap p1 p2 a) (zahlenwps p1 p2 welt) = enthaelt_konsens a welt\<close>
  by(simp add: enthaelt_konsens_def zahlenwps_def Aenderung.enthaelt_konsens_swap)
(*>*)

text\<open>Wenn \<^const>\<open>reverse_engineer_abmachung\<close> hier nicht genau die gleiche Abmachung
berechnet wie später eingelöst, dann wird das ganze exploitable.
Da eine \<^typ>\<open>('person, 'etwas) abmachung\<close> aber eine eindeutige Darstellung sein sollte,
müsst das so funktionieren.\<close>
definition einvernehmlich :: \<open>zahlenwelt handlung \<Rightarrow> bool\<close>
where
  \<open>einvernehmlich h \<equiv>
    let abmachung = reverse_engineer_abmachung (map_handlung besitz h)
    in enthaelt_konsens abmachung (vorher h)
        \<and> konsens_wurde_entfernt abmachung (konsens (vorher h)) (konsens (nachher h))\<close>
(*TODO: hier will konsens_wurde_entfernt dazu? Neuer name! Einvernehmlich?*)

(*<*)
lemma einvernehmlich_swap:
  \<open>einvernehmlich (map_handlung (zahlenwps p1 p2) h) = einvernehmlich h\<close>
  apply(cases \<open>h\<close>, rename_tac vor nach, simp)
  apply(simp add: einvernehmlich_def)
  apply(case_tac \<open>vor\<close>, case_tac \<open>nach\<close>, simp add: zahlenwps_def)
  apply(simp add: reverse_engineer_abmachung_swap)
  apply(simp add: Aenderung.enthaelt_konsens_swap BeispielZahlenwelt2.enthaelt_konsens_def)
  apply(simp add: konsens_wurde_entfernt_swap)
  by metis (*wtf?*)

lemma einvernehmlich_swap_nachher_handeln:
  \<open>einvernehmlich (Handlung (zahlenwps p1 p2 welt) (nachher_handeln p1 (zahlenwps p1 p2 welt) ha)) =
    einvernehmlich (Handlung welt (zahlenwps p1 p2 (nachher_handeln p1 (zahlenwps p2 p1 welt) ha)))\<close>
  apply (metis (no_types, opaque_lifting) handlung.map einvernehmlich_swap zahlenwps_id zahlenwps_sym)
  done

lemma einvernehmlich_noop: \<open>einvernehmlich (Handlung welt welt)\<close>
  apply(simp add: einvernehmlich_def reverse_engineer_abmachung_same)
  by(code_simp)

lemma nicht_ausfuehrbar_einvernehmlich:
  \<open>\<not> ausfuehrbar p welt ha \<Longrightarrow> einvernehmlich (handeln p welt ha)\<close>
  apply(simp add: handeln_def nicht_ausfuehrbar_nachher_handeln einvernehmlich_noop)
  done
(*>*)

text\<open>Eine Handlung die keine Änderung bewirkt hat keine Betroffenen und damit immer Konsens.\<close>
lemma \<open>einvernehmlich (handeln p welt (Handlungsabsicht (\<lambda>p w. Some w)))\<close>
  apply(simp add: einvernehmlich_def Let_def)
  apply(simp add: handeln_def nachher_handeln.simps reverse_engineer_abmachung_same)
  apply(code_simp)
  done

beispiel
  \<open>einvernehmlich (handeln Alice initialwelt
    (Handlungsabsicht (\<lambda>p w. Some
       (w\<lparr> besitz := \<lbrakk>\<lbrakk>(besitz w)(Alice += 3)\<rbrakk>(Bob -= 3)\<rbrakk>,
           konsens := konsens_entfernen (to_abmachung [Gewinnt Alice (3::int), Verliert Bob 3]) (konsens w) \<rparr>))))\<close>
  by eval
beispiel \<open>\<not> einvernehmlich (handeln Alice initialwelt
          (Handlungsabsicht (\<lambda>p w. Some (w\<lparr> besitz := \<lbrakk>\<lbrakk>(besitz w)(Alice += 3)\<rbrakk>(Bob -= 3)\<rbrakk> \<rparr>))))\<close>
  by eval
beispiel \<open>\<not> einvernehmlich (handeln Alice initialwelt
          (Handlungsabsicht (\<lambda>p w. Some (w\<lparr> besitz := \<lbrakk>\<lbrakk>(besitz w)(Alice += 4)\<rbrakk>(Bob -= 4)\<rbrakk> \<rparr>))))\<close>
  by eval

definition abmachung_ausfuehren
  :: \<open>(person, int) abmachung \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt\<close>
where
  \<open>abmachung_ausfuehren abmachung welt \<equiv>
    welt\<lparr> besitz := Aenderung.abmachung_ausfuehren abmachung (besitz welt) \<rparr>\<close>

beispiel \<open>abmachung_ausfuehren (to_abmachung [Gewinnt Alice 3]) initialwelt
  = initialwelt\<lparr> besitz := \<lbrakk>(besitz initialwelt)(Alice += 3)\<rbrakk>\<rparr>\<close>
  by eval

text\<open>Um eine \<^typ>\<open>(person, int) abmachung\<close> einzulösen wird diese erst ausgeführt
und danach aus dem globalen Konsens entfernt, damit die Abmachung
nicht mehrfach eingelöst werden kann.\<close>
definition abmachung_einloesen :: \<open>(person, int) abmachung \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>abmachung_einloesen delta welt \<equiv>
  if enthaelt_konsens delta welt
  then Some ((abmachung_ausfuehren delta welt)\<lparr> konsens := konsens_entfernen delta (konsens welt)\<rparr>)
  else None\<close>

beispiel \<open>abmachung_einloesen (to_abmachung [Gewinnt Alice 3, Verliert Bob 3]) initialwelt
 = Some
  \<lparr>
    besitz = (\<euro>(Alice := 8, Bob := 7, Carol := -3)),
    konsens = (\<lambda>_. [])(
      Alice := [to_abmachung [Gewinnt Alice 3]],
      Bob := []),
    staatsbesitz = 9000,
    umwelt = 600
   \<rparr>\<close>
  by eval

beispiel \<open>abmachung_einloesen (to_abmachung [Gewinnt Alice 3]) initialwelt
 = Some
  \<lparr>
    besitz = (\<euro>(Alice := 8, Bob := 10, Carol := -3)),
    konsens = (\<lambda>_. [])(
      Alice := [to_abmachung [Gewinnt Alice 3, Verliert Bob 3]],
      Bob := [to_abmachung [Gewinnt Alice 3, Verliert Bob 3]]),
    staatsbesitz = 9000,
    umwelt = 600
   \<rparr>\<close>
  by eval

beispiel \<open>abmachung_einloesen (to_abmachung [Verliert Bob 3]) initialwelt = None\<close>
  by eval

(*<*)
lemma abmachung_einloesen_some_entahelt_konsens:
  \<open>abmachung_einloesen a welt = Some welt' \<Longrightarrow> enthaelt_konsens a welt\<close>
  by(simp add: abmachung_einloesen_def split: if_split_asm)

lemma abmachung_einloesen_reverse_engineer:
  \<open>abmachung_einloesen a welt = Some welt'
    \<Longrightarrow> reverse_engineer_abmachung (Handlung (besitz welt) (besitz welt')) = a\<close>
  apply(simp add: abmachung_einloesen_def split: if_split_asm)
  apply(simp add: abmachung_ausfuehren_def)
  apply(simp add: reverse_engineer_abmachung)
  by force

lemma zahlenwelt_abmachung_ausfuehren_swap:
  \<open>(BeispielZahlenwelt2.abmachung_ausfuehren (swap p1 p2 a) (zahlenwps p1 p2 welt)) =
       zahlenwps p2 p1 (BeispielZahlenwelt2.abmachung_ausfuehren a welt)\<close>
    apply(simp add: BeispielZahlenwelt2.abmachung_ausfuehren_def)
  by(simp add: zahlenwps_def abmachung_ausfuehren_swap konsensswap_sym)

lemma abmachung_einloesen_zahlenwps_pullout:
  \<open>abmachung_einloesen (swap p1 p2 a) (zahlenwps p1 p2 welt)
    = map_option (zahlenwps p2 p1) (abmachung_einloesen a welt)\<close>
  apply(simp add: abmachung_einloesen_def enthaelt_konsens_swap)
  apply(clarsimp)
  apply(simp add: zahlenwelt_abmachung_ausfuehren_swap)
  apply(simp add: zahlenwps_def konsens_entfernen_konsensswap)
  by (metis konsens_entfernen_konsensswap konsensswap_id)
(*>*)

text\<open>Die Handlungsabsicht \<^const>\<open>abmachung_einloesen\<close> stellt keine
\<^const>\<open>wohlgeformte_handlungsabsicht\<close> dar, da in der Abmachung Personen
hardcedoded sind.
\<close>
beispiel \<open>\<not> wohlgeformte_handlungsabsicht zahlenwps initialwelt
         (Handlungsabsicht (\<lambda>p w. abmachung_einloesen (to_abmachung [Gewinnt Alice 3]) w))\<close>
  by eval

text\<open>Wir können aber schnell eine wohlgeformte Handlungsabsicht daraus bauen,
indem wir nicht die Abmachung an sich in die Handlungsabsicht hardcoden,
sondern indem wir eine bestehende Abmachung in der Welt referenzieren.\<close>
definition existierende_abmachung_einloesen :: \<open>person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>existierende_abmachung_einloesen p welt \<equiv>
  case (konsens welt) p
  of [] \<Rightarrow> None
  |  d#_ \<Rightarrow> abmachung_einloesen d welt\<close>

lemma \<open>wohlgeformte_handlungsabsicht zahlenwps initialwelt
         (Handlungsabsicht existierende_abmachung_einloesen)\<close>
  by eval

(*<*)

lemma existierende_abmachung_einloesen_map_zahlenwps:
  \<open>map_option (zahlenwps p2 p1) (existierende_abmachung_einloesen p2 (zahlenwps p1 p2 welt)) =
    existierende_abmachung_einloesen p1 welt\<close>
  apply(simp add: existierende_abmachung_einloesen_def)
  apply(simp add: zahlenwps_def swap_b konsensswap_def)
  apply(case_tac \<open>konsens welt p1\<close>)
   apply(simp; fail)
  apply(simp)
  using abmachung_einloesen_zahlenwps_pullout
  by (metis swap2 swap_symmetric zahlenwps_id)

lemma existierende_abmachung_einloesen_zahlenwps_pullout:
  \<open>existierende_abmachung_einloesen p (zahlenwps p1 p2 welt)
    = map_option (zahlenwps p2 p1) (existierende_abmachung_einloesen (swap p1 p2 id p) welt)\<close>
  apply(cases \<open>p = p1\<close>)
  apply(simp add: swap_a)
  apply (metis existierende_abmachung_einloesen_map_zahlenwps zahlenwps_id)
  apply(cases \<open>p = p2\<close>)
  apply(simp add: swap_b)
   apply (metis existierende_abmachung_einloesen_map_zahlenwps zahlenwps_id zahlenwps_sym)
  apply(simp add: swap_nothing)

  apply(simp add: existierende_abmachung_einloesen_def)
  apply(simp add: zahlenwps_def konsensswap_def swap_nothing)
  apply(case_tac \<open>konsens welt p\<close>)
   apply(simp; fail)
  apply(simp)
  using abmachung_einloesen_zahlenwps_pullout by simp
(*>*)

text\<open>In jeder Welt ist damit die Handlungsabsicht wohlgeformt.\<close>
lemma wohlgeformte_handlungsabsicht_existierende_abmachung_einloesen:
  \<open>wohlgeformte_handlungsabsicht zahlenwps welt
         (Handlungsabsicht existierende_abmachung_einloesen)\<close>
  apply(simp add: wohlgeformte_handlungsabsicht.simps)
  apply(cases \<open>welt\<close>, simp)
  using existierende_abmachung_einloesen_map_zahlenwps by simp

text\<open>Es ist nur möglich eine \<^const>\<open>existierende_abmachung_einloesen\<close>,
wenn alle Betroffenen auch zustimmen.
Es is beispielsweise nicht möglich, dass \<^const>\<open>Alice\<close> eine Handlung
ausführt, die \<^const>\<open>Carol\<close> betrifft, ohne deren Zustimmung.\<close>
beispiel \<open>\<not> ausfuehrbar Alice
  \<lparr>
    besitz = (\<euro>(Alice := 5, Bob := 10, Carol := -3)),
    konsens = (\<lambda>_. [])(
      Alice := [to_abmachung [Verliert Carol 3]]
      ),
    staatsbesitz = 9000,
    umwelt = 600
  \<rparr>
  (Handlungsabsicht existierende_abmachung_einloesen)\<close>
  by eval
text\<open>Nur wenn \<^const>\<open>Carol\<close> zustimmt wird die Handlung möglich.\<close>
beispiel \<open>ausfuehrbar Alice
  \<lparr>
    besitz = (\<euro>(Alice := 5, Bob := 10, Carol := -3)),
    konsens = (\<lambda>_. [])(
      Alice := [to_abmachung [Verliert Carol 3]],
      Carol := [to_abmachung [Verliert Carol 3]]
      ),
    staatsbesitz = 9000,
    umwelt = 600
  \<rparr>
  (Handlungsabsicht existierende_abmachung_einloesen)\<close>
  by eval

(*bissal doof:*)
text\<open>Da \<^const>\<open>Alice\<close> nicht betroffen is, bleibt \<^term>\<open>[Verliert Carol 3]\<close> bei \<^const>\<open>Alice\<close> übrig.\<close>
beispiel \<open>nachher_handeln Alice
  \<lparr>
    besitz = (\<euro>(Alice := 5, Bob := 10, Carol := -3)),
    konsens = (\<lambda>_. [])(
      Alice := [to_abmachung [Verliert Carol 3]],
      Carol := [to_abmachung [Verliert Carol 3]]
      ),
    staatsbesitz = 9000,
    umwelt = 600
  \<rparr>
  (Handlungsabsicht existierende_abmachung_einloesen)
= \<lparr>
    besitz = (\<euro>(Alice := 5, Bob := 10, Carol := -6)),
    konsens = (\<lambda>_. [])(
      Alice := [to_abmachung [Verliert Carol 3]],
      Carol := []
      ),
    staatsbesitz = 9000,
    umwelt = 600
  \<rparr>\<close>
  by eval

text\<open>Für\<^const>\<open>existierende_abmachung_einloesen\<close> gilt immer \<^const>\<open>einvernehmlich\<close>.
Das \<^const>\<open>reverse_engineer_abmachung\<close> macht also das Richtige.\<close>
lemma einvernehmlich_existierende_abmachung_einloesen:
  \<open>einvernehmlich (handeln p welt (Handlungsabsicht existierende_abmachung_einloesen))\<close>
  apply(simp add: einvernehmlich_def handeln_def nachher_handeln.simps)
  apply(cases \<open>existierende_abmachung_einloesen p welt\<close>)
  apply(simp)
  using einvernehmlich_def einvernehmlich_noop apply fastforce
  apply(simp)
  apply(rename_tac welt')
  apply(simp add: existierende_abmachung_einloesen_def split:list.split_asm)
  apply(frule abmachung_einloesen_some_entahelt_konsens)
  apply(simp add: abmachung_einloesen_reverse_engineer)
  using BeispielZahlenwelt2.enthaelt_konsens_def abmachung_einloesen_def
    konsens_wurde_entfernt_konsens_entfernen by fastforce

fun stehlen :: \<open>int \<Rightarrow> int \<Rightarrow> person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>stehlen beute opfer_nach_besitz dieb welt =
        map_option (\<lambda>b. welt\<lparr>besitz := b\<rparr>) (Zahlenwelt.stehlen beute opfer_nach_besitz dieb (besitz welt))\<close>

beispiel\<open>stehlen 3 10 Alice initialwelt =
Some \<lparr>
  besitz = (\<euro>(Alice := 8, Bob := 7, Carol := -3)),
  konsens = (\<lambda>_. [])(
    Alice := [to_abmachung [Gewinnt Alice 3], to_abmachung [Gewinnt Alice 3, Verliert Bob 3]],
    Bob := [to_abmachung [Gewinnt Alice 3, Verliert Bob 3]]),
  staatsbesitz = 9000,
  umwelt = 600
 \<rparr>\<close> by eval

text\<open>\<^const>\<open>stehlen\<close> und \<^const>\<open>existierende_abmachung_einloesen\<close> können ununterscheidbar sein,
was den \<^const>\<open>besitz\<close> betrifft.
Der Hauptunterschied ist, ob \<^const>\<open>konsens\<close> eingelöst wurde oder nicht.\<close>
beispiel
 \<open>besitz (the (stehlen 3 10 Alice initialwelt)) =
  besitz (the (existierende_abmachung_einloesen Bob initialwelt))\<close>
 \<open>konsens (the (stehlen 3 10 Alice initialwelt)) \<noteq>
  konsens (the (existierende_abmachung_einloesen Bob initialwelt))\<close>
  by code_simp+

(*<*)
lemma besitz_sel_update: \<open>map_option besitz (map_option (\<lambda>b. w\<lparr>besitz := b\<rparr>) b) = b\<close>
  apply(cases \<open>b\<close>)
   apply(simp; fail)
  apply(simp)
  done

lemma wohlgeformte_handlungsabsicht_stehlen:
  \<open>wohlgeformte_handlungsabsicht zahlenwps welt (Handlungsabsicht (stehlen n p))\<close>
  apply(rule wfh_generalize_worldI[OF wohlgeformte_handlungsabsicht_stehlen,
        where sel=\<open>besitz\<close>
        and makeZ=\<open>\<lambda>b other. case other of (k, s, u) \<Rightarrow> zahlenwelt.make b k s u\<close>
        and sel_other=\<open>\<lambda>w. (konsens w, staatsbesitz w, umwelt w)\<close>
        , of \<open>welt\<close> \<open>besitz welt\<close> _ \<open>n\<close> \<open>p\<close>])
          apply(simp; fail)
         apply(simp add: zahlenwps_def; fail)
        apply(simp add: besitz_sel_update; fail)
       apply(case_tac \<open>w\<close>, simp add: zahlenwelt.defs; fail)
      apply(simp, force)
     apply(simp add: stehlen_swap_None; fail)
    apply(simp add: zahlenwelt.defs zahlenwps_def; fail)
   apply(simp add: zahlenwps_id zahlenwps_sym; fail)
  apply(simp add: zahlenwps_sym; fail)
  done
(* I case above proof fails, here is a version without wfh_generalize_worldI.
(*This is mostly a copy of wohlgeformte_handlungsabsicht_stehlen and this sucks.*)
  apply(case_tac \<open>welt\<close>, simp add: wohlgeformte_handlungsabsicht.simps Zahlenwelt.stehlen.simps)
  apply(simp add: zahlenwps_def)
  apply(simp add: opfer_eindeutig_nach_besitz_auswaehlen_swap_enumall)
  apply(simp add: opfer_eindeutig_nach_besitz_auswaehlen_the_single_elem_enumall)
  apply(simp add: the_single_elem)
  apply(safe)
   apply (simp add: zahlenwps_def swap_def Fun.swap_def konsensswap_sym; fail)
  apply (simp add: zahlenwps_def swap_def Fun.swap_def konsensswap_sym fun_upd_twist)
  done
*)
(*>*)

text\<open>Ressourcen können nicht aus dem Nichts erschaffen werden.
Diese Handlungsabsicht entnimmt der Natur und weist einer Person zu.\<close>
fun abbauen :: \<open>nat \<Rightarrow> person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>abbauen i p welt = Some (welt\<lparr> besitz := \<lbrakk>(besitz welt)(p += int i)\<rbrakk>, umwelt := (umwelt welt) - int i \<rparr>)\<close>

(*<*)
lemma wohlgeformte_handlungsabsicht_abbauen:
  \<open>wohlgeformte_handlungsabsicht zahlenwps welt (Handlungsabsicht (abbauen n))\<close>
  apply(case_tac \<open>welt\<close>, simp add: wohlgeformte_handlungsabsicht.simps)
  apply(simp add: zahlenwps_def swap_def Fun.swap_def)
  by (simp add: konsensswap_sym)
(*>*)

text\<open>Diese Handlungsabsicht weist allen Personen ein Besitz von 0 zu.
Dies vernichtet allen Besitz.
Personen mit Schulden (negativem Besitz) könnten jedoch profitieren.\<close>
fun reset :: \<open>person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>reset ich welt = Some (welt\<lparr> besitz := \<lambda> _. 0\<rparr>)\<close>

(*<*)
lemma wohlgeformte_handlungsabsicht_reset:
  \<open>wohlgeformte_handlungsabsicht zahlenwps welt (Handlungsabsicht reset)\<close>
  apply(simp add: wohlgeformte_handlungsabsicht.simps handeln_def nachher_handeln.simps)
  apply(simp add: zahlenwps_def konsensswap_sym)
  apply(simp add: swap_def fun_eq_iff)
  done
(*>*)

text\<open>Die Handlungsabsicht die alles kaputt macht.
Die Handlungsabsicht sucht sich den minimalen Besitz aller Personen und
weist allen Personen Eins weniger zu.
Damit haben alle Personen definitiv weniger als zuvor.\<close>
fun alles_kaputt_machen :: \<open>person \<Rightarrow> zahlenwelt \<Rightarrow> zahlenwelt option\<close> where
  \<open>alles_kaputt_machen ich welt = Some (welt\<lparr> besitz := \<lambda> _. Min ((besitz welt) ` UNIV) - 1 \<rparr>)\<close>

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

(*<*)
declare alles_kaputt_machen.simps[simp del]

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(simp add: zahlenwps_def konsensswap_sym)
  apply(case_tac \<open>welt\<close>, simp add: fun_eq_iff)
  apply(simp add: min_list_swap_int_enum)
  by (simp add: swap_def)
(*>*)

text\<open>Die unmögliche Handlungsabsicht, welche immer scheitert.\<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 (abbauen 5),
  Handlungsabsicht (stehlen 3 10),
  Handlungsabsicht existierende_abmachung_einloesen,
  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 add: wohlgeformte_handlungsabsicht_abbauen; fail)
      apply(simp add: wohlgeformte_handlungsabsicht_stehlen; fail)
     apply(simp add: wohlgeformte_handlungsabsicht_existierende_abmachung_einloesen; fail)
    apply(simp add: wohlgeformte_handlungsabsicht_reset; fail)
  apply(simp add: wohlgeformte_handlungsabsicht_alles_kaputt_machen; fail)
  by (simp add: wohlgeformte_handlungsabsicht.simps)

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_altruistischer_fortschritt :: \<open>(person, zahlenwelt) maxime\<close> where
  \<open>maxime_altruistischer_fortschritt \<equiv>
      Maxime (\<lambda>ich h. \<forall>pX. individueller_fortschritt pX h)\<close>

(*existierende_abmachung_einloesen macht, dass die Maxime nicht erfuellt.*)
beispiel \<open>erzeuge_beispiel
  zahlenwps initialwelt
  handlungsabsichten
  maxime_altruistischer_fortschritt
= Some
  \<lparr>
   bsp_erfuellte_maxime = False,
   bsp_erlaubte_handlungen = [
      Handlungsabsicht (abbauen 5),
      Handlungsabsicht unmoeglich],
   bsp_verbotene_handlungen = [
      Handlungsabsicht (stehlen 3 10),
      Handlungsabsicht reset,
      Handlungsabsicht alles_kaputt_machen],
   bsp_uneindeutige_handlungen = [
      Handlungsabsicht existierende_abmachung_einloesen]
  \<rparr>\<close> by beispiel_tac

definition maxime_hatte_konsens :: \<open>(person, zahlenwelt) maxime\<close> where
  \<open>maxime_hatte_konsens \<equiv> Maxime (\<lambda>ich h. einvernehmlich h)\<close>

beispiel \<open>\<forall>h \<in> set (alle_moeglichen_handlungen initialwelt (Handlungsabsicht existierende_abmachung_einloesen)).
 wohlgeformte_maxime_auf
    h zahlenwps
    maxime_hatte_konsens\<close> by eval

lemma \<open>wohlgeformte_maxime zahlenwps maxime_hatte_konsens\<close>
  by(simp add: wohlgeformte_maxime_def wohlgeformte_maxime_auf_def
               maxime_hatte_konsens_def einvernehmlich_swap)

beispiel \<open>erzeuge_beispiel
  zahlenwps initialwelt
  [Handlungsabsicht existierende_abmachung_einloesen]
  maxime_hatte_konsens
= Some
  \<lparr>
   bsp_erfuellte_maxime = True,
   bsp_erlaubte_handlungen = [Handlungsabsicht existierende_abmachung_einloesen],
   bsp_verbotene_handlungen = [],
   bsp_uneindeutige_handlungen = []\<rparr>\<close>
  by beispiel_tac

beispiel \<open>erzeuge_beispiel
  zahlenwps initialwelt
  [Handlungsabsicht (abbauen 5),
   Handlungsabsicht (stehlen 3 10),
   Handlungsabsicht reset,
   Handlungsabsicht alles_kaputt_machen,
   Handlungsabsicht unmoeglich]
  maxime_altruistischer_fortschritt
= Some
  \<lparr>
   bsp_erfuellte_maxime = True,
   bsp_erlaubte_handlungen = [
      Handlungsabsicht (abbauen 5),
      Handlungsabsicht unmoeglich],
   bsp_verbotene_handlungen = [
      Handlungsabsicht (stehlen 3 10),
      Handlungsabsicht reset,
      Handlungsabsicht alles_kaputt_machen],
   bsp_uneindeutige_handlungen = []\<rparr>\<close>
  by beispiel_tac

beispiel \<open>erzeuge_beispiel
  zahlenwps initialwelt
  handlungsabsichten
  (MaximeDisj maxime_altruistischer_fortschritt maxime_hatte_konsens)
= Some
  \<lparr>
   bsp_erfuellte_maxime = True,
   bsp_erlaubte_handlungen = [
      Handlungsabsicht (abbauen 5),
      Handlungsabsicht existierende_abmachung_einloesen,
      Handlungsabsicht unmoeglich],
   bsp_verbotene_handlungen = [
      Handlungsabsicht (stehlen 3 10),
      Handlungsabsicht reset,
      Handlungsabsicht alles_kaputt_machen],
   bsp_uneindeutige_handlungen = []\<rparr>\<close>
  by beispiel_tac

lemma \<open>maxime_und_handlungsabsicht_generalisieren zahlenwps welt
     maxime_hatte_konsens (Handlungsabsicht existierende_abmachung_einloesen) p\<close>
  apply(simp add: maxime_und_handlungsabsicht_generalisieren_def maxime_hatte_konsens_def)
  apply(clarsimp)
  apply(simp add: einvernehmlich_existierende_abmachung_einloesen)
  done

lemma mhg_katimp_maxime_hatte_konsens:
  \<open>\<forall>p. maxime_und_handlungsabsicht_generalisieren zahlenwps welt maxime_hatte_konsens ha p \<Longrightarrow>
    wohlgeformte_handlungsabsicht zahlenwps welt ha \<Longrightarrow>
    kategorischer_imperativ_auf ha welt maxime_hatte_konsens\<close>
  apply(simp add: maxime_hatte_konsens_def)
  apply(erule globale_maxime_katimp)
      subgoal by(simp add: handeln_def einvernehmlich_noop ist_noop_def)
     subgoal by(simp add: wpsm_kommutiert_handlung_raw einvernehmlich_swap_nachher_handeln)
    subgoal using zahlenwps_sym by fastforce
   subgoal by(simp add: zahlenwps_id)
  by simp

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>pX = p1\<close>)
    apply(erule_tac x=\<open>p2\<close> in allE)
    apply (simp add: swap_a swap_b zahlenwps_sym; fail)
   apply(case_tac \<open>pX = p2\<close>)
    apply(erule_tac x=\<open>p1\<close> in allE)
    apply (simp add: swap_a swap_b zahlenwps_sym; fail)
   apply(erule_tac x=\<open>pX\<close> in allE)
   apply(simp add: besitz_zahlenwps_nothing zahlenwps_sym swap_nothing; fail)
  by (metis swap_a swap_b swap_nothing zahlenwps_sym)

lemma mhg_katimp_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>
  apply(simp add: maxime_altruistischer_fortschritt_def)
  apply(erule globale_maxime_katimp)
      subgoal by(simp add: handeln_def einvernehmlich_noop ist_noop_def)
     subgoal using wpsm_kommutiert_altruistischer_fortschritt by(simp add: maxime_altruistischer_fortschritt_def)
    subgoal using zahlenwps_sym by fastforce
   subgoal by(simp add: zahlenwps_id)
  by simp

text\<open>Folgendes Theorem zeigt, dass das \<^const>\<open>MaximeDisj\<close> Konstrukt in jeder Welt funktioniert.\<close>
theorem
  \<open>ex_erfuellbare_instanz maxime_altruistischer_fortschritt welt ha \<and>
    (\<forall>p. maxime_und_handlungsabsicht_generalisieren
          zahlenwps welt maxime_altruistischer_fortschritt ha p)
   \<or>
   ex_erfuellbare_instanz maxime_hatte_konsens welt ha \<and>
    (\<forall>p. maxime_und_handlungsabsicht_generalisieren
          zahlenwps welt maxime_hatte_konsens ha p) \<Longrightarrow>
    wohlgeformte_handlungsabsicht zahlenwps welt ha \<Longrightarrow>
    kategorischer_imperativ_auf ha welt
      (MaximeDisj maxime_altruistischer_fortschritt maxime_hatte_konsens)\<close>
  apply(rule kategorischer_imperativ_auf_MaximeDisjI2)
  apply(elim disjE)
   using mhg_katimp_maxime_altruistischer_fortschritt apply simp
  using mhg_katimp_maxime_hatte_konsens apply simp
  done

text\<open>Wir könnten zusätzlich noch eine Maxime einführen,
welche besagt, dass die Umwelt nicht zerstört werden darf.\<close>
definition maxime_keine_umweltzerstoerung :: \<open>(person, zahlenwelt) maxime\<close> where
  \<open>maxime_keine_umweltzerstoerung \<equiv>
      Maxime (\<lambda>_ h. umwelt (vorher h) \<le> umwelt (nachher h))\<close>

text\<open>Folgendes Beispiel ist wie die vorherigen Beispiel.
Zusätzlich fügen wir jedoch noch \<^const>\<open>maxime_keine_umweltzerstoerung\<close> via \<^const>\<open>MaximeConj\<close> hinzu.\<close>
beispiel\<open>erzeuge_beispiel
  zahlenwps initialwelt
  handlungsabsichten
  (MaximeConj (MaximeDisj maxime_altruistischer_fortschritt maxime_hatte_konsens)
              maxime_keine_umweltzerstoerung)
= Some
  \<lparr>
   bsp_erfuellte_maxime = True,
   bsp_erlaubte_handlungen = [
      Handlungsabsicht existierende_abmachung_einloesen,
      Handlungsabsicht unmoeglich],
   bsp_verbotene_handlungen = [
      Handlungsabsicht (abbauen 5),
      Handlungsabsicht (stehlen 3 10),
      Handlungsabsicht reset,
      Handlungsabsicht alles_kaputt_machen],
   bsp_uneindeutige_handlungen = []\<rparr>\<close>
  by beispiel_tac
text\<open>Das Ergebnis ist fast wie in vorherigen Beispielen.
Allerdings ist \<^const>\<open>abbauen\<close> nun Teil der verbotenen Handlungsabsichten,
da dabei Umwelt abgebaut wird.\<close>

end


(*  Title:      HOL/ex/Iff_Oracle.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Author:     Makarius
*)

section \<open>Example of Declaring an Oracle\<close>

theory Iff_Oracle
imports Main
begin

subsection \<open>Oracle declaration\<close>

text \<open>
  This oracle makes tautologies of the form @{prop "P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P"}.
  The length is specified by an integer, which is checked to be even
  and positive.
\<close>

oracle iff_oracle = \<open>
  let
    fun mk_iff 1 = Var (("P", 0), @{typ bool})
      | mk_iff n = HOLogic.mk_eq (Var (("P", 0), @{typ bool}), mk_iff (n - 1));
  in
    fn (thy, n) =>
      if n > 0 andalso n mod 2 = 0
      then Thm.cterm_of thy (HOLogic.mk_Trueprop (mk_iff n))
      else raise Fail ("iff_oracle: " ^ string_of_int n)
  end
\<close>

subsection \<open>Oracle as low-level rule\<close>

ML \<open>iff_oracle (@{theory}, 2)\<close>
ML \<open>iff_oracle (@{theory}, 10)\<close>

ML \<open>
  Thm.peek_status (iff_oracle (@{theory}, 10));
  @{assert} (#oracle it);
\<close>

text \<open>These oracle calls had better fail.\<close>

ML \<open>
  (iff_oracle (@{theory}, 5); error "Bad oracle")
    handle Fail _ => writeln "Oracle failed, as expected"
\<close>

ML \<open>
  (iff_oracle (@{theory}, 1); error "Bad oracle")
    handle Fail _ => writeln "Oracle failed, as expected"
\<close>

subsection \<open>Oracle as proof method\<close>

method_setup iff =
  \<open>Scan.lift Parse.nat >> (fn n => fn ctxt =>
    SIMPLE_METHOD
      (HEADGOAL (rtac (iff_oracle (Proof_Context.theory_of ctxt, n)))
        handle Fail _ => no_tac))\<close>

lemma "A \<longleftrightarrow> A"
  by (iff 2)

lemma "A \<longleftrightarrow> A \<longleftrightarrow> A \<longleftrightarrow> A \<longleftrightarrow> A \<longleftrightarrow> A \<longleftrightarrow> A \<longleftrightarrow> A \<longleftrightarrow> A \<longleftrightarrow> A"
  by (iff 10)

lemma "A \<longleftrightarrow> A \<longleftrightarrow> A \<longleftrightarrow> A \<longleftrightarrow> A"
  apply (iff 5)?
  oops

lemma A
  apply (iff 1)?
  oops

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory Deterministic_AC
imports
  "../invariant-abstract/$L4V_ARCH/ArchDetSchedSchedule_AI"
begin

(*This theory defines an abstract "integrity" property over
  the extensible specification that the deterministic specification
  is shown to preserve. Essentially it demonstrates that the only
  elements altered in the cdt_list are the given parameters and
  their descendants. *)

(* Analagous to the Control edges that pas_refined imposes. *)
definition all_children where
"all_children P m \<equiv> (\<forall>c p. m c = Some p \<longrightarrow> P p \<longrightarrow> P c)"

primrec list_filter :: "'a list \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a list" where
  "list_filter [] P = []" |
  "list_filter (x # xs) P = (if (P x) then (list_filter xs P)
                             else x # (list_filter xs P))"

abbreviation
"filtered_eq P list list' \<equiv> list_filter list P = list_filter list' P"

lemma list_filter_distr[simp]: "list_filter (list @ list') P = (list_filter list P) @ (list_filter list' P)"
  apply (induct list,simp+)
  done

lemma list_filter_empty[simp]: "\<forall>x \<in> set list. P x \<Longrightarrow> list_filter list P = []"
  apply (induct list,simp+)
  done

lemma list_filter_replace_list: "\<forall>x \<in> set list'. P x \<Longrightarrow> P a \<Longrightarrow>
 filtered_eq P (list_replace_list list a list') list"
  apply (induct list,simp+)
  done

lemma list_filter_insert_after: "P b \<Longrightarrow>
 filtered_eq P (list_insert_after list a b) list"
  apply (induct list,simp+)
  done

lemma list_filter_swap: "P b \<Longrightarrow> P a \<Longrightarrow>
 filtered_eq P (list_swap list a b) list"
  apply (induct list,(simp add: list_swap_def)+)
  done

lemma list_filter_replace: "P b \<Longrightarrow> P a \<Longrightarrow>
 filtered_eq P (list_replace list a b) list"
  apply (induct list,(simp add: list_replace_def)+)
  done

lemma list_filter_remove: "P a \<Longrightarrow>
 filtered_eq P (list_remove list a) list"
  apply (induct list,simp+)
  done

(* Here P is meant to decide whether a cslot_ptr is part of the current
   subject. Integrity is said to hold of two cdt_lists if either an
   entry is part of the current subject, or their lists are equivalent
   with all entries from the current subject removed.

   We use this to reason that changes to a non-subject entry are only allowed
   if that entry's list contains a child that is part of the current subject.
   It is stated in this way so that the property can be shown to be transitive.*)

definition list_integ where
"list_integ P t t' \<equiv>  \<forall>x. P x \<or> (filtered_eq P (cdt_list t x) (cdt_list t' x))"

lemma update_cdt_list_wp:
  "\<lbrace>(\<lambda>s. P (s\<lparr>cdt_list := f (cdt_list s)\<rparr>))\<rbrace> update_cdt_list f \<lbrace>\<lambda>_.P\<rbrace>"
  apply (simp add: update_cdt_list_def set_cdt_list_def)
  apply wp
  done

lemma cap_move_list_integrity:
  notes split_paired_All[simp del]
  shows
  "\<lbrace>list_integ P st and K(P src) and K(P dest)\<rbrace> cap_move_ext src dest src_p dest_p \<lbrace>\<lambda>_. list_integ P st\<rbrace>"
  apply (simp add: cap_move_ext_def split del: if_split)
  apply (wp update_cdt_list_wp)
  apply (intro impI conjI allI | simp add: list_filter_replace list_filter_remove split: option.splits | elim conjE | simp add: list_integ_def)+
  done

lemma cap_insert_list_integrity:
  notes split_paired_All[simp del]
  shows
  "\<lbrace>list_integ P st and K(P src) and K(P dest)\<rbrace> cap_insert_ext src_parent src dest src_p dest_p \<lbrace>\<lambda>_. list_integ P st\<rbrace>"
  apply (simp add: cap_insert_ext_def split del: if_split)
  apply (wp update_cdt_list_wp)
  apply (intro impI conjI allI | simp add: list_filter_insert_after list_filter_remove split: option.splits | elim conjE | simp add: list_integ_def)+
  done

lemma create_cap_list_integrity:
  notes split_paired_All[simp del]
  shows
  "\<lbrace>list_integ P st and K(P dest)\<rbrace> create_cap_ext untyped dest dest_p \<lbrace>\<lambda>_. list_integ P st\<rbrace>"
  apply (simp add: create_cap_ext_def split del: if_split)
  apply (wp update_cdt_list_wp)
  apply (intro impI conjI allI | simp add: list_filter_replace list_filter_remove split: option.splits | elim conjE | simp add: list_integ_def)+
  done

lemma empty_slot_list_integrity:
  notes split_paired_All[simp del]
  shows
  "\<lbrace>list_integ P st and (\<lambda>s. valid_list_2 (cdt_list s) m) and K(P slot) and K( all_children P m)\<rbrace> empty_slot_ext slot slot_p \<lbrace>\<lambda>_. list_integ P st\<rbrace>"
  apply (simp add: empty_slot_ext_def split del: if_split)
  apply (wp update_cdt_list_wp)
  apply (intro impI conjI allI | simp add: list_filter_replace_list list_filter_remove split: option.splits | elim conjE  | simp add: list_integ_def)+
  apply (drule_tac x="the slot_p" in spec)
  apply (elim disjE)
   apply (simp add: all_children_def valid_list_2_def list_filter_replace_list)+
  done

lemma cap_swap_list_integrity:
  notes split_paired_All[simp del]
  shows
  "\<lbrace>list_integ P st and K(P slot1) and K(P slot2)\<rbrace> cap_swap_ext slot1 slot2 slot1_p slot2_p \<lbrace>\<lambda>_. list_integ P st\<rbrace>"
  apply (simp add: cap_swap_ext_def split del: if_split)
  apply (wp update_cdt_list_wp)
  apply (intro impI conjI allI | simp add: list_filter_replace list_filter_swap split: option.splits | elim conjE | simp add: list_integ_def)+ (* slow *)
  done

lemma null_filter: "\<forall>x \<in> set list. \<not> P x \<Longrightarrow> list_filter list P = list"
  apply (induct list,simp+)
  done

lemma neq_filtered_ex: "list \<noteq> list' \<Longrightarrow> filtered_eq P list list' \<Longrightarrow> \<exists>x \<in> set list \<union> set list'. P x"
  apply (rule ccontr)
  apply (simp add: null_filter)
  done

lemma weaken_filter: "(\<forall>s. P s \<longrightarrow> T s) \<Longrightarrow> filtered_eq T (list_filter list P) list"
  apply (induct list,simp+)
  done

lemma weaken_filter_eq: "(\<forall>s. P s \<longrightarrow> T s) \<Longrightarrow> filtered_eq P list list' \<Longrightarrow> filtered_eq T list list'"
  apply (subst weaken_filter[symmetric],assumption)
  apply (simp add: weaken_filter)
  done

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory signed_div
imports "../CTranslation"
begin

install_C_file "signed_div.c"

context signed_div
begin

lemma f_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL f(5, -1) \<lbrace> \<acute>ret__int = -5 \<rbrace>"
  apply vcg
  apply (clarsimp simp: sdiv_word_def sdiv_int_def)
  done

lemma word_not_minus_one [simp]:
  "0 \<noteq> (-1 :: word32)"
  by (metis word_msb_0 word_msb_n1)

lemma f_overflow:
  shows "\<lbrakk> a_' s = of_int (-2^31); b_' s = -1 \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> \<langle> Call f_'proc ,Normal s\<rangle> \<Rightarrow> Fault SignedArithmetic"
  apply (rule exec.Call [where \<Gamma>=\<Gamma>, OF f_impl, simplified f_body_def creturn_def])
  apply (rule exec.CatchMiss)
  apply (subst exec.simps, clarsimp simp del: word_neq_0_conv simp: sdiv_word_def sdiv_int_def)+
  apply simp
  done

lemma g_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL g(-5, 10) \<lbrace> \<acute>ret__int = -5 \<rbrace>"
  apply vcg
  apply (clarsimp simp: smod_word_def smod_int_def sdiv_int_def)
  done

lemma h_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL h(5, -1) \<lbrace> \<acute>ret__int = 0 \<rbrace>"
  apply vcg
  apply (simp add: word_div_def uint_word_ariths)
  done

lemma i_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL f(5, -1) \<lbrace> \<acute>ret__int = -5 \<rbrace>"
  apply vcg
  apply (clarsimp simp: sdiv_word_def sdiv_int_def)
  done

end

end


theory Lift_Triv
  imports "../Lifter"

begin

(*
 * triv
 *)
(* we are revisiting this because automation seems to be having
 * problems with triv in the presence of certain kinds of polymorphism.
 * i wonder if we need an explicit type paramete?
 *)
definition triv_l ::
  "('x, 'a :: Bogus, 'a md_triv) lifting" where
"triv_l =
  LMake (\<lambda> s a _ . mdt a) (\<lambda> s b . (case b of (mdt b') \<Rightarrow> b')) (\<lambda> s . mdt bogus)"

locale triv_l_valid_weak =
  fixes T :: "('a :: Bogus) itself"

sublocale triv_l_valid_weak \<subseteq>
  out : lifting_valid_weak "triv_l :: ('b, 'a, 'a md_triv) lifting" "(\<lambda> _ . UNIV)"
proof
  fix s :: 'b
  fix a :: "'a :: Bogus"
  fix b :: "'a md_triv"
  show "LOut (triv_l) s (LUpd (triv_l) s a b) = a"
    by(auto simp add:triv_l_def split:md_triv.splits)
next
  fix s :: 'b
  fix b :: "'a md_triv"

  show "b <[ LUpd triv_l s (LOut triv_l s b) b"
   by(auto simp add:triv_l_def triv_pleq
          split:md_triv.splits)
next
  fix s :: 'b
  fix a :: "'a"
  fix b :: "'a md_triv"
  show "LUpd triv_l s a b \<in> UNIV" by auto
qed

lemma (in triv_l_valid_weak) ax :
  shows "lifting_valid_weak (triv_l :: ('b, 'a, 'a md_triv) lifting) (\<lambda> _ :: 'b . UNIV)"
  using out.lifting_valid_weak_axioms
  by auto

lemma (in triv_l_valid_weak) ax_g :
  assumes "S' = (\<lambda> _ . UNIV)"
  shows "lifting_valid_weak (triv_l :: ('b, 'a, 'a md_triv) lifting) S'"
  using out.lifting_valid_weak_axioms assms
  by auto

locale triv_l_valid_ok_ext =
  fixes T :: "('a :: Bogus) itself"

sublocale triv_l_valid_ok_ext \<subseteq>
  out : lifting_valid_ok_ext "(triv_l :: ('b, 'a, 'a md_triv) lifting)" "(\<lambda> _ :: 'b . UNIV)"
proof
  show "\<And> S . ok_S \<subseteq> UNIV" by auto
next
  fix s :: 'b
  fix a :: 'a
  fix b :: "'a md_triv"
  show "b \<in> ok_S \<Longrightarrow> LUpd triv_l s a b \<in> ok_S"
    by(auto simp add: triv_l_def triv_ok_S)
qed

lemma (in triv_l_valid_ok_ext) ax :
  shows "lifting_valid_ok_ext (triv_l :: ('b, 'a, 'a md_triv) lifting) (\<lambda> _ :: 'b . UNIV)"
  using out.lifting_valid_ok_ext_axioms
  by auto

lemma (in triv_l_valid_ok_ext) ax_g :
  assumes "S' = (\<lambda> _ . UNIV)"
  shows "lifting_valid_ok_ext (triv_l :: ('b, 'a, 'a md_triv) lifting) S'"
  using assms out.lifting_valid_ok_ext_axioms
  by auto

locale triv_l_valid_pres_ext =
  fixes T :: "('a :: Bogus) itself"

sublocale triv_l_valid_pres_ext \<subseteq>
  out : lifting_valid_pres_ext "(triv_l :: ('b, 'a, 'a md_triv) lifting)" "\<lambda> (_ :: 'b) . UNIV"

proof
  fix v :: "'a md_triv"
  fix V :: "'a md_triv set"
  fix supr :: "'a md_triv"
  fix s :: 'b
  fix f

  assume Nemp : "v \<in> V"
  assume H : "is_sup V supr"

  show "is_sup (LMap triv_l f s ` V) (LMap triv_l f s supr)"
  proof(rule is_supI)
    fix x

    assume "x \<in> LMap triv_l f s ` V"

    then obtain x0 where X0 : "x0 \<in> V" "LMap triv_l f s x0 = x"
      by(auto)

    obtain x0' where X0' : "x0 = mdt x0'"
      by(cases x0; auto)

    obtain supr' where Supr' : "supr = mdt supr'"
      by(cases supr; auto)

    have Eq : "x0' = supr'"
      using is_supD1[OF H X0(1)] X0' Supr'
      by(auto simp add: triv_pleq)

    show "x <[ LMap triv_l f s supr"
      using X0' X0 Eq Supr'
      by(auto simp add: triv_pleq)
  next
    fix y
    assume Ub : "is_ub (LMap triv_l f s ` V) y"

    obtain y' where Y' : "y = mdt y'" by(cases y; auto)

    obtain v' where V' : "v = mdt v'" by(cases v; auto)

    have Eq1 : "y = LMap triv_l f s v"
      using is_ubE[OF Ub, of "LMap triv_l f s v"] Nemp
      by(auto simp add: triv_pleq)

    have  "supr = v"
      using is_supD1[OF H Nemp] by(auto simp add: triv_pleq)

    hence Eq2 : "LMap triv_l f s supr = LMap triv_l f s v" by simp

    show "LMap triv_l f s supr <[ y"
      using Eq1 Eq2
      by(simp add: triv_pleq)
  qed
qed

lemma (in triv_l_valid_pres_ext) ax :
  shows "lifting_valid_pres_ext (triv_l :: ('b, 'a, 'a md_triv) lifting) (\<lambda> _ . UNIV)"
  using out.lifting_valid_pres_ext_axioms
  by auto

lemma (in triv_l_valid_pres_ext) ax_g :
  assumes "S' = (\<lambda> _ . UNIV)"
  shows "lifting_valid_pres_ext (triv_l :: ('b, 'a, 'a md_triv) lifting) S'"
  using assms out.lifting_valid_pres_ext_axioms
  by auto

locale triv_l_valid_pairwise_ext =
  fixes T :: "'a itself"

sublocale triv_l_valid_pairwise_ext \<subseteq>
  out : lifting_valid_pairwise_ext "\<lambda> (_ :: 'b) . (UNIV :: 'a md_triv set)"
proof
  fix x1 x2 x3 s12 s23 s13 s123 :: "'a md_triv"

  show "s123 \<in> UNIV"
    by auto
qed

lemma (in triv_l_valid_pairwise_ext) ax :
  shows "lifting_valid_pairwise_ext (\<lambda> (_ :: 'b) . (UNIV :: 'a md_triv set))"
  using out.lifting_valid_pairwise_ext_axioms
  by auto

lemma (in triv_l_valid_pairwise_ext) ax_g :
  assumes "S' = (\<lambda> (_ :: 'b) . (UNIV :: 'a md_triv set))"
  shows "lifting_valid_pairwise_ext S'"
  using assms out.lifting_valid_pairwise_ext_axioms
  by auto

locale triv_l_valid_oc_ext =
  fixes T :: "('a :: Bogus) itself"

sublocale triv_l_valid_oc_ext \<subseteq>
  out: lifting_valid_oc_ext "(triv_l :: ('b, 'a, 'a md_triv) lifting)" "\<lambda> (_ :: 'b) . (UNIV :: 'a md_triv set)"
proof
  fix x2 Xs
  fix supr :: "'a md_triv"
  fix s :: 'b
  fix r :: 'a
  fix w :: "'a md_triv"
  assume W: "w \<in> Xs"
  assume Supr : "is_sup Xs supr"
  assume Compat :
    "(\<And>x. x \<in> Xs \<Longrightarrow>
             LOut triv_l s x = r)"

  have Supr_W : "supr = w"
    using is_supD1[OF Supr W]
    by(auto simp add: triv_pleq)

  hence "w = mdt r"
    using Compat[OF W]
    by(cases w; auto simp add: triv_pleq triv_l_def)

  then show "LOut triv_l s supr = r"
    using Supr_W
    by(auto simp add: triv_l_def)
qed

lemma (in triv_l_valid_oc_ext) ax :
  shows "lifting_valid_oc_ext (triv_l :: ('b, 'a, 'a md_triv) lifting)"
  using out.lifting_valid_oc_ext_axioms
  by auto

end


theory Example
imports HNR_While
begin

lemma assumes    "a = (\<lambda>s. SPECT [s-1\<mapsto>1])"
    shows ex4_ref: "(whileT (\<lambda>s. s>0) (\<lambda>s. RETURNT (s-1)) (S::nat)) \<le> (whileT (\<lambda>s. s>0) a (S::nat))"
  apply(rule whileT_mono)
  unfolding assms
  by (simp add: RETURNT_def le_fun_def)

lemma k: "(emp \<Longrightarrow>\<^sub>A \<up> (s = S) * true) \<longleftrightarrow> s=S"
  apply rule
  apply (smt assn_ext entailsD' entailsI mod_false' mult.left_neutral pure_assn_eq_conv)
  using assn_times_comm entails_pure_post entails_true by fastforce
lemma k2: "(emp \<Longrightarrow>\<^sub>A \<up> (s = S) ) \<longleftrightarrow> s=S"
  apply rule
  apply (smt assn_ext entailsD' entailsI mod_false' mult.left_neutral pure_assn_eq_conv)
  using entails_pure' entails_triv by blast

lemma extr: "pHeap h as n \<Turnstile> \<up>B = (pHeap h as n \<Turnstile> emp \<and> B)"
  using one_assn_rule pure_assn_rule by auto

lemma R: "((s,s') \<in> Rs \<Longrightarrow> hn_refine (emp) (c s) (G s' s) R (a s'))
    \<Longrightarrow> hn_refine (hn_ctxt (pure Rs) s' s) (c s) (G s' s) R (a s')"
  unfolding hn_refine_def by (auto simp: hn_ctxt_def pure_def extr)

thm hnr_uRETURN_pass

lemma moneq: "(\<lambda>s. RETURNT (0 < s)) = (\<lambda>s. RETURNT 0 \<bind> (%c. RETURNT (c < s)))"
  by (auto intro!: pw_eqI)

lemma moneq_min: "(\<lambda>s. RETURNT (s - 1)) = (\<lambda>s. RETURNT 1 \<bind> (%c. RETURNT (s - c)))"
  by (auto intro!: pw_eqI)

lemma x0: "RETURNT x \<le> RETURNT 0 \<longleftrightarrow> x=0"
  by (auto simp: RETURNT_def le_fun_def split: if_splits)

lemma zuf: "\<up> True * true =  true"
  by (simp add: abel_semigroup.commute assn_ext mult.abel_semigroup_axioms)

lemma hn_refine_less: " hn_refine (hn_val nat_rel s' s * hn_val nat_rel x' x)
           (ureturn (x < s))
       (hn_val nat_rel s' s * hn_val nat_rel x' x)
       (pure bool_rel) (RETURNT (x' < s'))"
  unfolding hn_refine_def apply (auto simp: zuf mult.assoc  execute_ureturn pure_def hn_ctxt_def)
   apply(rule exI[where x=0]) apply (auto simp: zero_enat_def relH_def )
    using models_in_range top_assn_rule by blast

lemma hn_refine_minus: " hn_refine (hn_val nat_rel s' s * hn_val nat_rel x' x)
           (ureturn (x - s))
       (hn_val nat_rel s' s * hn_val nat_rel x' x)
       (pure nat_rel) (RETURNT (x' - s'))"
  unfolding hn_refine_def apply (auto simp: zuf mult.assoc  execute_ureturn pure_def hn_ctxt_def)
   apply(rule exI[where x=0]) apply (auto simp: zero_enat_def relH_def )
    using models_in_range top_assn_rule by blast

schematic_goal first:
  assumes "a = (whileT (\<lambda>s. s>0) (\<lambda>s. RETURNT (s-1)) (S::nat))"
  shows "hn_refine emp ?c ?\<Gamma> (pure Id) a"
  unfolding assms
  apply(subst whileT_I')
  apply(subst WHILEIT_to_monadic) apply(subst moneq)  apply(subst moneq_min)
  apply(rule hn_monadic_WHILE_aux[where \<Gamma>="emp"])
      apply (simp add: hn_ctxt_def pure_def k entailst_def )

     apply (simp del: nres_bind_left_identity)
     apply(rule hnr_bind)
       apply(rule hnr_frame[OF hnr_uRETURN_pure[where R=nat_rel]])
        apply simp
       apply (simp add: ) apply(rule entt_refl)
      apply (simp  )
      apply(rule hn_refine_less)
  apply(simp add: mult.assoc)
  apply(rule match_first)
     apply(rule match_rest) apply (simp)

  apply(simp add: entailst_def)
    apply(rule match_rest) apply (simp)

   apply (simp del: nres_bind_left_identity)
     apply(rule hnr_bind)
     apply(rule hnr_frame[OF hnr_uRETURN_pure[where R=nat_rel]])
        apply simp
       apply (simp add: ) apply(rule entt_refl)
      apply (simp  )
     apply(rule hn_refine_cons_pre[OF _ hn_refine_minus])
  apply(simp add: entailst_def)
    apply rotatel apply(rule match_first)   apply(rule match_rest) apply simp
   apply rotatel apply(rule match_first) apply (rule match_rest) apply simp

  apply (simp add: hn_ctxt_def pure_def k)
  by (simp add: ent_imp_entt)

thm first extract_cost_ub hnr_refine

lemma entails_ex': "((\<exists>\<^sub>Ax. P x) \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (\<forall>x. (P x \<Longrightarrow>\<^sub>A Q))"
  using entails_ex by blast

thm ex4_ref ex4'
lemma "S \<le> n \<Longrightarrow> <$ n> (heap_WHILET (\<lambda>s. ureturn 0 \<bind> (\<lambda>x'. ureturn (x' < s))) (\<lambda>s. ureturn (Suc 0) \<bind> (\<lambda>x'. ureturn (s - x'))) S) <\<lambda>r. \<up> (r = 0)>\<^sub>t"
proof -
  assume as: "S \<le> n"
  from ex4_ref have "whileT (op < 0) (\<lambda>s. RETURNT (s - 1)) S \<le> whileT (op < 0) (\<lambda>s. SPECT [s - 1 \<mapsto> 1]) S" by auto
  also from as ex4' have "\<dots> \<le> SPECT (\<lambda>s. if s = 0 then Some (enat n) else None) " by simp
  finally have spec: "whileT (op < 0) (\<lambda>s. RETURNT (s - 1)) S \<le> SPECT (\<lambda>s. if s = 0 then Some (enat n) else None)" .

  let ?P= "(heap_WHILET (\<lambda>s. ureturn 0 \<bind> (\<lambda>x'. ureturn (x' < s))) (\<lambda>s. ureturn (Suc 0) \<bind> (\<lambda>x'. ureturn (s - x'))) S)"
  from hnr_refine[OF spec first] have "hn_refine emp ?P (emp * hn_invalid (pure nat_rel) S S) (pure nat_rel)
   (SPECT (\<lambda>s. if s = 0 then Some (enat n) else None))" by auto

  from extract_cost_ub[OF this, where Cost_ub=n] have "< $ n> ?P <\<lambda>r. emp * hn_invalid (pure nat_rel) S S * (\<exists>\<^sub>Ara. pure nat_rel ra r * \<up> (ra \<in> dom (\<lambda>s. if s = 0 then Some (enat n) else None)))>\<^sub>t"
    by simp
  then show "<$ n> ?P <\<lambda>r. \<up> (r = 0)>\<^sub>t"
      apply(rule post_rule)
    apply (simp add: pure_def hn_ctxt_def invalid_assn_def)
       apply (auto simp: )
    apply rotatel apply rotatel apply(simp add: ex_distrib_star[symmetric] entails_ex'  )
    apply auto
    by (smt SepAuto.mod_pure_star_dist abel_semigroup.commute entails_def entails_true mult.abel_semigroup_axioms pure_conj)
qed

thm hnr_refine[OF _ first]

end


(*  Title:      Jinja/J/Conform.thy

    Author:     David von Oheimb, Tobias Nipkow
    Copyright   1999 Technische Universitaet Muenchen
*)

section \<open>Conformance Relations for Type Soundness Proofs\<close>

theory Conform
imports Exceptions
begin

definition conf :: "'m prog \<Rightarrow> heap \<Rightarrow> val \<Rightarrow> ty \<Rightarrow> bool"   ("_,_ \<turnstile> _ :\<le> _"  [51,51,51,51] 50)
where
  "P,h \<turnstile> v :\<le> T  \<equiv>
  \<exists>T'. typeof\<^bsub>h\<^esub> v = Some T' \<and> P \<turnstile> T' \<le> T"

definition oconf :: "'m prog \<Rightarrow> heap \<Rightarrow> obj \<Rightarrow> bool"   ("_,_ \<turnstile> _ \<surd>" [51,51,51] 50)
where
  "P,h \<turnstile> obj \<surd>  \<equiv>
  let (C,fs) = obj in \<forall>F D T. P \<turnstile> C has F:T in D \<longrightarrow>
  (\<exists>v. fs(F,D) = Some v \<and> P,h \<turnstile> v :\<le> T)"

definition hconf :: "'m prog \<Rightarrow> heap \<Rightarrow> bool"  ("_ \<turnstile> _ \<surd>" [51,51] 50)
where
  "P \<turnstile> h \<surd>  \<equiv>
  (\<forall>a obj. h a = Some obj \<longrightarrow> P,h \<turnstile> obj \<surd>) \<and> preallocated h"

definition lconf :: "'m prog \<Rightarrow> heap \<Rightarrow> (vname \<rightharpoonup> val) \<Rightarrow> (vname \<rightharpoonup> ty) \<Rightarrow> bool"   ("_,_ \<turnstile> _ '(:\<le>') _" [51,51,51,51] 50)
where
  "P,h \<turnstile> l (:\<le>) E  \<equiv>
  \<forall>V v. l V = Some v \<longrightarrow> (\<exists>T. E V = Some T \<and> P,h \<turnstile> v :\<le> T)"

abbreviation
  confs :: "'m prog \<Rightarrow> heap \<Rightarrow> val list \<Rightarrow> ty list \<Rightarrow> bool"
             ("_,_ \<turnstile> _ [:\<le>] _" [51,51,51,51] 50) where
  "P,h \<turnstile> vs [:\<le>] Ts \<equiv> list_all2 (conf P h) vs Ts"

subsection\<open>Value conformance \<open>:\<le>\<close>\<close>

lemma conf_Null [simp]: "P,h \<turnstile> Null :\<le> T  =  P \<turnstile> NT \<le> T"
(*<*)
apply (unfold conf_def)
apply (simp (no_asm))
done
(*>*)

lemma typeof_conf[simp]: "typeof\<^bsub>h\<^esub> v = Some T \<Longrightarrow> P,h \<turnstile> v :\<le> T"
(*<*)
apply (unfold conf_def)
apply (induct v)
apply auto
done
(*>*)

lemma typeof_lit_conf[simp]: "typeof v = Some T \<Longrightarrow> P,h \<turnstile> v :\<le> T"
(*<*)by (rule typeof_conf[OF typeof_lit_typeof])(*>*)

lemma defval_conf[simp]: "P,h \<turnstile> default_val T :\<le> T"
(*<*)
apply (unfold conf_def)
apply (cases T)
apply auto
done
(*>*)

lemma conf_upd_obj: "h a = Some(C,fs) \<Longrightarrow> (P,h(a\<mapsto>(C,fs')) \<turnstile> x :\<le> T) = (P,h \<turnstile> x :\<le> T)"
(*<*)
apply (unfold conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
done
(*>*)

lemma conf_widen: "P,h \<turnstile> v :\<le> T \<Longrightarrow> P \<turnstile> T \<le> T' \<Longrightarrow> P,h \<turnstile> v :\<le> T'"
(*<*)
apply (unfold conf_def)
apply (induct v)
apply (auto intro: widen_trans)
done
(*>*)

lemma conf_hext: "h \<unlhd> h' \<Longrightarrow> P,h \<turnstile> v :\<le> T \<Longrightarrow> P,h' \<turnstile> v :\<le> T"
(*<*)
apply (unfold conf_def)
apply (induct v)
apply (auto dest: hext_objD)
done
(*>*)

lemma conf_ClassD: "P,h \<turnstile> v :\<le> Class C \<Longrightarrow>
  v = Null \<or> (\<exists>a obj T. v = Addr a \<and>  h a = Some obj \<and> obj_ty obj = T \<and>  P \<turnstile> T \<le> Class C)"
(*<*)
apply (unfold conf_def)
apply(induct "v")
apply(auto)
done
(*>*)

lemma conf_NT [iff]: "P,h \<turnstile> v :\<le> NT = (v = Null)"
(*<*)by (auto simp add: conf_def)(*>*)

lemma non_npD: "\<lbrakk> v \<noteq> Null; P,h \<turnstile> v :\<le> Class C \<rbrakk>
  \<Longrightarrow> \<exists>a C' fs. v = Addr a \<and> h a = Some(C',fs) \<and> P \<turnstile> C' \<preceq>\<^sup>* C"
(*<*)
apply (drule conf_ClassD)
apply auto
done
(*>*)

subsection\<open>Value list conformance \<open>[:\<le>]\<close>\<close>

lemma confs_widens [trans]: "\<lbrakk>P,h \<turnstile> vs [:\<le>] Ts; P \<turnstile> Ts [\<le>] Ts'\<rbrakk> \<Longrightarrow> P,h \<turnstile> vs [:\<le>] Ts'"
(*<*)
  apply (rule list_all2_trans)
    apply (rule conf_widen, assumption, assumption)
   apply assumption
  apply assumption
  done
(*>*)

lemma confs_rev: "P,h \<turnstile> rev s [:\<le>] t = (P,h \<turnstile> s [:\<le>] rev t)"
(*<*)
  apply rule
  apply (rule subst [OF list_all2_rev])
  apply simp
  apply (rule subst [OF list_all2_rev])
  apply simp
  done
(*>*)

lemma confs_conv_map:
  "\<And>Ts'. P,h \<turnstile> vs [:\<le>] Ts' = (\<exists>Ts. map typeof\<^bsub>h\<^esub> vs = map Some Ts \<and> P \<turnstile> Ts [\<le>] Ts')"
(*<*)
apply(induct vs)
 apply simp
apply(case_tac Ts')
apply(auto simp add:conf_def)
done
(*>*)

lemma confs_hext: "P,h \<turnstile> vs [:\<le>] Ts \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> P,h' \<turnstile> vs [:\<le>] Ts"
(*<*)by (erule list_all2_mono, erule conf_hext, assumption)(*>*)

lemma confs_Cons2: "P,h \<turnstile> xs [:\<le>] y#ys = (\<exists>z zs. xs = z#zs \<and> P,h \<turnstile> z :\<le> y \<and> P,h \<turnstile> zs [:\<le>] ys)"
(*<*)by (rule list_all2_Cons2)(*>*)

subsection "Object conformance"

lemma oconf_hext: "P,h \<turnstile> obj \<surd> \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> P,h' \<turnstile> obj \<surd>"
(*<*)
apply (unfold oconf_def)
apply (fastforce elim:conf_hext)
done
(*>*)

lemma oconf_init_fields:
 "P \<turnstile> C has_fields FDTs \<Longrightarrow> P,h \<turnstile> (C, init_fields FDTs) \<surd>"
by(fastforce simp add: has_field_def oconf_def init_fields_def map_of_map
            dest: has_fields_fun)

lemma oconf_fupd [intro?]:
  "\<lbrakk> P \<turnstile> C has F:T in D; P,h \<turnstile> v :\<le> T; P,h \<turnstile> (C,fs) \<surd> \<rbrakk>
  \<Longrightarrow> P,h \<turnstile> (C, fs((F,D)\<mapsto>v)) \<surd>"
(*<*)
  apply (unfold oconf_def has_field_def)
  apply clarsimp
  apply (drule (1) has_fields_fun)
  apply (auto simp add: fun_upd_apply)
  done
(*>*)

(*<*)
lemmas oconf_new = oconf_hext [OF _ hext_new]
lemmas oconf_upd_obj = oconf_hext [OF _ hext_upd_obj]
(*>*)

subsection "Heap conformance"

lemma hconfD: "\<lbrakk> P \<turnstile> h \<surd>; h a = Some obj \<rbrakk> \<Longrightarrow> P,h \<turnstile> obj \<surd>"
(*<*)
apply (unfold hconf_def)
apply (fast)
done
(*>*)

lemma hconf_new: "\<lbrakk> P \<turnstile> h \<surd>; h a = None; P,h \<turnstile> obj \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile> h(a\<mapsto>obj) \<surd>"
(*<*)by (unfold hconf_def) (auto intro: oconf_new preallocated_new)(*>*)

lemma hconf_upd_obj: "\<lbrakk> P \<turnstile> h\<surd>; h a = Some(C,fs); P,h \<turnstile> (C,fs')\<surd> \<rbrakk> \<Longrightarrow> P \<turnstile> h(a\<mapsto>(C,fs'))\<surd>"
(*<*)by (unfold hconf_def) (auto intro: oconf_upd_obj preallocated_upd_obj)(*>*)

subsection "Local variable conformance"

lemma lconf_hext: "\<lbrakk> P,h \<turnstile> l (:\<le>) E; h \<unlhd> h' \<rbrakk> \<Longrightarrow> P,h' \<turnstile> l (:\<le>) E"
(*<*)
apply (unfold lconf_def)
apply  (fast elim: conf_hext)
done
(*>*)

lemma lconf_upd:
  "\<lbrakk> P,h \<turnstile> l (:\<le>) E; P,h \<turnstile> v :\<le> T; E V = Some T \<rbrakk> \<Longrightarrow> P,h \<turnstile> l(V\<mapsto>v) (:\<le>) E"
(*<*)
apply (unfold lconf_def)
apply auto
done
(*>*)

lemma lconf_empty[iff]: "P,h \<turnstile> Map.empty (:\<le>) E"
(*<*)by(simp add:lconf_def)(*>*)

lemma lconf_upd2: "\<lbrakk>P,h \<turnstile> l (:\<le>) E; P,h \<turnstile> v :\<le> T\<rbrakk> \<Longrightarrow> P,h \<turnstile> l(V\<mapsto>v) (:\<le>) E(V\<mapsto>T)"
(*<*)by(simp add:lconf_def)(*>*)

end