theory Aenderung
imports Main ExecutableHelper BeispielPerson Handlung Zahlenwelt "HOL-Library.Multiset"
begin

section\<open>Änderungen in Welten\<close>
text\<open>In diesem Abschnitt werden wir Änderungen in Welten,
und darauf basierend, Abmachungen modellieren.\<close>

text\<open>Bei einer Änderung keine eine Person entweder etwas verlieren oder gewinnen.
Dieses einfache Modell ist natürlich auf unsere Zahlenwelten angepasst,
in der normalerweise Typ \<^typ>\<open>'etwas\<close> ein \<^typ>\<open>int\<close> ist.\<close>
datatype ('person, 'etwas) aenderung = Verliert \<open>'person\<close> \<open>'etwas\<close> | Gewinnt \<open>'person\<close> \<open>'etwas\<close>

text\<open>Beispiel: \<^term>\<open>[Gewinnt Alice 3, Verliert Bob 3]::(person, int) aenderung list\<close>.\<close>

text\<open>Von einer \<^typ>\<open>('person, 'etwas) aenderung\<close> betroffene Person bzw. Personen.\<close>
definition betroffen :: \<open>('person, 'etwas) aenderung \<Rightarrow> 'person\<close>
  where
\<open>betroffen a \<equiv> case a of Verliert p _ \<Rightarrow> p | Gewinnt p _ \<Rightarrow> p\<close>

definition betroffene :: \<open>('person, 'etwas) aenderung list \<Rightarrow> 'person list\<close>
  where
\<open>betroffene as \<equiv> map betroffen as\<close>

(*<*)
lemma betroffene_case_aenderung:
  \<open>betroffene = map (case_aenderung (\<lambda>p _. p) (\<lambda>p _. p))\<close>
  by(simp add: fun_eq_iff betroffene_def betroffen_def)
(*>*)

beispiel \<open>betroffene [Verliert Alice (2::int), Gewinnt Bob 3, Gewinnt Carol 2, Verliert Eve 1]
  = [Alice, Bob, Carol, Eve]\<close> by eval
beispiel \<open>betroffene [Verliert Alice (5::nat), Gewinnt Bob 3, Verliert Eve 7]
  = [Alice, Bob, Eve]\<close> by eval
beispiel \<open>betroffene [Verliert Alice (5::nat), Gewinnt Alice 3]
  = [Alice, Alice]\<close> by eval

(*<*)
text\<open>Das Delta um von \<^term>\<open>i2\<close> nach \<^term>\<open>i2\<close> zu kommen.\<close>
definition delta_num
  :: \<open>'person \<Rightarrow> 'etwas::{ord,minus} \<Rightarrow> 'etwas \<Rightarrow> (('person, 'etwas) aenderung) option\<close>
  where
    \<open>delta_num p i1 i2 = (
           if i1 > i2 then Some (Verliert p (i1 - i2))
      else if i1 < i2 then Some (Gewinnt p (i2 - i1))
      else None
  )\<close>

lemma \<open>delta_num p i1 i2 = Some (Gewinnt p (i::int)) \<Longrightarrow> i > 0\<close>
  by(auto simp add: delta_num_def split_ifs)
lemma \<open>delta_num p i1 i2 = Some (Verliert p (i::int)) \<Longrightarrow> i > 0\<close>
  by(auto simp add: delta_num_def split_ifs)
lemma \<open>delta_num p1 i1 i2 = Some (Gewinnt p2 (i::int)) \<Longrightarrow> p1 = p2\<close>
  by(auto simp add: delta_num_def split_ifs)
lemma \<open>delta_num p1 i1 i2 = Some (Verliert p2 (i::int)) \<Longrightarrow> p1 = p2\<close>
  by(auto simp add: delta_num_def split_ifs)

beispiel \<open>delta_num Alice (2::int) 6 = Some (Gewinnt Alice 4)\<close> by eval
beispiel \<open>delta_num Alice (-2::int) 6 = Some (Gewinnt Alice 8)\<close> by eval

lemma delta_num_same: \<open>delta_num p (a::'a::ordered_ab_group_add) a = None\<close>
  by(simp add: delta_num_def)

text\<open>The absolute delta between \<^term>\<open>i1\<close> and \<^term>\<open>i2\<close>.
This basically merges the two terms.\<close>
definition sum_delta_num
  :: \<open>'person \<Rightarrow> 'etwas::{ord,zero,plus,uminus,minus} \<Rightarrow> 'etwas \<Rightarrow> (('person, 'etwas) aenderung) option\<close>
  where
    \<open>sum_delta_num p i1 i2 = (
      let s = i1 + i2 in
           if s < 0 then Some (Verliert p (-s))
      else if s > 0 then Some (Gewinnt p s)
      else None
  )\<close>

beispiel \<open>sum_delta_num Alice (2::int) 6 = Some (Gewinnt Alice 8)\<close> by eval
beispiel \<open>sum_delta_num Alice (-2::int) 6 = Some (Gewinnt Alice 4)\<close> by eval

lemma sum_delta_num_delta_num:
  fixes i1::\<open>'a::ordered_ab_group_add\<close>
  shows \<open>sum_delta_num p i1 i2 = delta_num p 0 (i1+i2)\<close>
  by(simp add: sum_delta_num_def delta_num_def Let_def)

lemma  delta_num_sum_delta_num:
  fixes i1::\<open>'a::ordered_ab_group_add\<close>
  shows \<open>delta_num p i1 i2 = sum_delta_num p (-i1) i2\<close>
  by(simp add: sum_delta_num_def delta_num_def Let_def)

(*>*)

subsection\<open>Deltas\<close>
text\<open>Deltas, d.h. Unterschiede zwischen Welten.
Ein Delta ist eine Liste von Änderungen.
Wir definieren das \<^theory_text>\<open>type_synonym\<close> delta als die Funktion,
welche solch eine Liste berechnet,
gegeben die Handlung welche die Veränderung hervorruft.\<close>
(*Man könnte eine class Delta world einführen, mit einer delta-Funtion
  :: welt -> welt -> [Aenderung person etwas]
Diese Klasse würde dann Welten mit Personen und Etwas in Relation setzen.
Dafür bräuchte es MultiParamTypeClasses. Eine simple Funktion ist da einfacher.*)
type_synonym ('welt, 'person, 'etwas) delta =
    \<open>'welt handlung \<Rightarrow> (('person, 'etwas) aenderung) list\<close>

(*<*)
definition aenderung_val :: \<open>('person, ('etwas::uminus)) aenderung \<Rightarrow> 'etwas\<close>
  where
\<open>aenderung_val a \<equiv> case a of Verliert _ n \<Rightarrow> -n | Gewinnt _ n \<Rightarrow> n\<close>

beispiel \<open>aenderung_val (Verliert Alice (2::int)) = -2\<close> by eval
beispiel \<open>aenderung_val (Gewinnt Alice (2::int)) = 2\<close> by eval

lemma betroffen_simps[simp]:
  \<open>betroffen (Gewinnt a ab) = a\<close>
  \<open>betroffen (Verliert a ab) = a\<close>
  by(simp add: betroffen_def)+
lemma aenderung_val_simps[simp]:
  \<open>aenderung_val (Gewinnt a ab) = ab\<close>
  \<open>aenderung_val (Verliert a ab) = -ab\<close>
  by(simp add: aenderung_val_def)+

fun delta_num_map
  :: \<open>(('person::enum \<rightharpoonup> ('etwas::{zero,minus,ord})), 'person, 'etwas) delta\<close>
  where
  \<open>delta_num_map (Handlung vor nach) =
      List.map_filter
        (\<lambda>p. case (the_default (vor p) 0, the_default (nach p) 0)
               of (a,b) \<Rightarrow> delta_num p a b)
        (Enum.enum::'person list)\<close>

beispiel\<open>delta_num_map
  (Handlung [Alice \<mapsto> 5::int, Bob \<mapsto> 10, Eve \<mapsto> 1]
            [Alice \<mapsto> 3, Bob \<mapsto> 13, Carol \<mapsto> 2])
  = [Verliert Alice 2, Gewinnt Bob 3, Gewinnt Carol 2, Verliert Eve 1]\<close> by eval

fun delta_num_fun
  :: \<open>(('person::enum \<Rightarrow> ('etwas::{minus,ord})), 'person, 'etwas) delta\<close>
  where
  \<open>delta_num_fun (Handlung vor nach) =
      List.map_filter (\<lambda>p. delta_num p (vor p) (nach p)) Enum.enum\<close>

beispiel \<open>delta_num_fun
    (Handlung
        ((\<lambda>p. 0::int)(Alice:=8, Bob:=12, Eve:=7))
        ((\<lambda>p. 0::int)(Alice:=3, Bob:=15, Eve:=0)))
  = [Verliert Alice 5, Gewinnt Bob 3, Verliert Eve 7]\<close> by eval

lemma delta_num_map: \<open>delta_num_map (Handlung m1 m2) =
        delta_num_fun (Handlung (\<lambda>p. the_default (m1 p) 0) (\<lambda>p. the_default (m2 p) 0))\<close>
  by(simp)

(*TODO: das if will in die swap.thy?*)
term \<open>map_aenderung\<close>
definition aenderung_swap
  :: \<open>'person \<Rightarrow> 'person \<Rightarrow> ('person, 'etwas) aenderung \<Rightarrow> ('person, 'etwas) aenderung\<close>
where
  \<open>aenderung_swap p1 p2 a \<equiv> map_aenderung (\<lambda>p. if p = p1 then p2 else if p = p2 then p1 else p) id a\<close>

beispiel\<open>aenderung_swap Alice Bob (Gewinnt Alice (3::nat)) = Gewinnt Bob 3\<close> by eval
beispiel\<open>aenderung_swap Alice Bob (Gewinnt Bob (3::nat)) = Gewinnt Alice 3\<close> by eval
beispiel\<open>aenderung_swap Alice Bob (Gewinnt Carol (3::nat)) = Gewinnt Carol 3\<close> by eval

lemma aenderung_swap_id: \<open>aenderung_swap p1 p2 (aenderung_swap p1 p2 a) = a\<close>
  apply(simp add: aenderung_swap_def)
  apply(cases \<open>a\<close>)
  by simp_all

lemma aenderung_swap_sym: \<open>aenderung_swap p1 p2 = aenderung_swap p2 p1\<close>
  apply(simp add: fun_eq_iff aenderung_swap_def, intro allI, rename_tac a)
  apply(case_tac \<open>a\<close>)
  by simp_all

lemma map_map_aenderung_swap:
  \<open>map (map (aenderung_swap p1 p2)) \<circ> (map (map (aenderung_swap p1 p2)) \<circ> kons) = kons\<close>
  by(simp add: fun_eq_iff aenderung_swap_id comp_def)

lemma swap_map_map_aenderung_swap:
  \<open>swap p2 p1 (map (map (aenderung_swap p2 p1)) \<circ> swap p1 p2 (map (map (aenderung_swap p1 p2)) \<circ> kons))
  = kons\<close>
  apply(subst aenderung_swap_sym)
  apply(subst swap_symmetric)
  apply(subst swap_fun_comp_id)
  apply(simp add: map_map_aenderung_swap)
  done
(*>*)

text\<open>Eine Liste von Änderungen lässt sich ausführen.\<close>
fun aenderung_ausfuehren
  :: \<open>('person, 'etwas::{plus,minus}) aenderung list \<Rightarrow> ('person \<Rightarrow> 'etwas) \<Rightarrow> ('person \<Rightarrow> 'etwas)\<close>
where
  \<open>aenderung_ausfuehren [] bes = bes\<close>
| \<open>aenderung_ausfuehren (Verliert p n # deltas) bes = aenderung_ausfuehren deltas \<lbrakk>bes(p -= n)\<rbrakk>\<close>
| \<open>aenderung_ausfuehren (Gewinnt p n # deltas) bes = aenderung_ausfuehren deltas \<lbrakk>bes(p += n)\<rbrakk>\<close>

text\<open>Die lokale Variable \<^term_type>\<open>bes :: ('person \<Rightarrow> 'etwas)\<close> stellt dabei den
aktuellen Besitz dar.
Die Ausgabe der Funktion ist der modifizierte Besitz, nachdem die Änderung ausgeführt wurde.\<close>

beispiel
\<open>aenderung_ausfuehren
  [Verliert Alice (2::int), Gewinnt Bob 3, Gewinnt Carol 2, Verliert Eve 1]
  (\<euro>(Alice:=8, Bob:=3, Eve:= 5))
  =
  (\<euro>(Alice:=6, Bob:=6, Carol:=2, Eve:= 4))\<close>
  by eval

beispiel
\<open>aenderung_ausfuehren
  [Verliert Alice (2::int), Verliert Alice 6]
  (\<euro>(Alice:=8, Bob:=3, Eve:= 5))
  =
  (\<euro>(Bob:=3, Eve:= 5))\<close>
  by eval
text\<open>Im vorherigen Beispiel verliert \<^const>\<open>Alice\<close> alles.
Da sie nun den \<^const>\<open>DEFAULT\<close>-Wert von \<^term>\<open>0::int\<close> besitzt, wird ihre Besitz nicht angezeigt.\<close>

(*<*)
(*TODO: upstream und vereinfachen!*)
lemma swap_aenderung_ausfuehren:
  \<open>swap p1 p2 (Aenderung.aenderung_ausfuehren a bes)
      = Aenderung.aenderung_ausfuehren (map (aenderung_swap p1 p2) a) (swap p1 p2 bes)\<close>
  apply(induction \<open>a\<close> arbitrary: \<open>bes\<close>)
   apply(simp)
  apply(simp)
  apply(case_tac \<open>a1\<close>)
  subgoal
    apply(simp)
    apply(simp add: aenderung_swap_def, safe)
      apply (simp_all add: fun_upd_twist swap_def Fun.swap_def)
    done
  apply(simp)
    apply(simp add: aenderung_swap_def, safe)
    apply (simp_all add: fun_upd_twist swap_def Fun.swap_def)
  done
(*>*)

subsection\<open>Abmachungen\<close>
text\<open>Eine \<^typ>\<open>('person, 'etwas) aenderung list\<close> wie
z.B. \<^term>\<open>[Gewinnt Alice (3::int), Verliert Bob 3]\<close> ließe sich gut verwenden,
um eine Abmachung zwischen \<^const>\<open>Alice\<close> und \<^const>\<open>Bob\<close> zu modellieren.
Allerdings ist diese Darstellung unpraktisch zu benutzen.
Beispielsweise sind

  \<^item> \<^term>\<open>[Gewinnt Alice (3::int), Verliert Bob 3]\<close>
  \<^item> \<^term>\<open>[Verliert Bob 3, Gewinnt Alice (3::int)]\<close>
  \<^item> \<^term>\<open>[Gewinnt Alice (1::int), Gewinnt Alice 1, Gewinnt Alice 1, Verliert Bob 3, Verliert Carol 0]\<close>

extensional betrachtet alle equivalent.
Es ist praktischer, eine Darstellung zu wählen,
in der syntaktische und semantische Äquivalenz zusammenfallen.
Das bedeutet, eine Abmachung muss eindeutig dargestellt werden.
Ein Kandidat dafür wäre eine Map vom Typ \<^typ>\<open>'person \<rightharpoonup> 'etwas\<close>, da diese eindeutig einer
\<^typ>\<open>'person\<close> ein \<^typ>\<open>'etwas\<close> zuordnet.
Dies funktioniert allerdings nur, wenn @{typ [source=true] \<open>'etwas::{uminus,plus}\<close>} mit Plus und Minus
dargestellt werden kann, um \<^const>\<open>Gewinnt\<close> und \<^const>\<open>Verliert\<close> darzustellen.
Allerdings ist auch diese Darstellung nicht eindeutig,
da z.B. \<^term>\<open>[Alice \<mapsto> 0] = Map.empty\<close> semantisch gilt,
solange \<^term>\<open>0\<close> ein neutrales Element ist.
Deshalb stellen wir eine Abmachung als eine
totale Funktion vom Typ @{typ [source=true] \<open>'person \<Rightarrow> ('etwas::{uminus, plus, zero})\<close>} dar.
Der Term \<^term>\<open>(\<lambda>_. 0)(Alice := 3, Bob := -3)\<close> bedeutet \<^const>\<open>Alice\<close> bekommt 3, \<^const>\<open>Bob\<close> verliert 3.
\<close>
type_synonym  ('person, 'etwas) abmachung = \<open>'person \<Rightarrow> 'etwas\<close>

text\<open>Folgende Funktion konvertiert eine Liste von Änderungen in ein Abmachung.
Persönlich finde ich es schöner eine Liste von Änderungen aufzuschreiben,
mathematisch ist eine Abmachung allerdings überlegen.
Folgende Funktion sorgt dafür, dass wir Abmachungen dennoch als
Liste von Änderungen aufschreiben können, dann allerdings mit der Abmachung weiterrechnen.\<close>
fun to_abmachung
  :: \<open>('person, 'etwas::{ord,zero,plus,minus,uminus}) aenderung list \<Rightarrow> ('person, 'etwas) abmachung\<close>
where
  \<open>to_abmachung [] = (\<lambda>p. 0)\<close>
| \<open>to_abmachung (delta # deltas) =
   \<lbrakk>(to_abmachung deltas)(betroffen delta += aenderung_val delta)\<rbrakk>\<close>

beispiel \<open>[to_abmachung [Gewinnt Alice (3::int)], to_abmachung [Gewinnt Alice 3, Verliert Bob 3]]
        = [(\<lambda>p.0)(Alice := 3), (\<lambda>p.0)(Alice := 3, Bob := -3)]\<close> by eval

(*<*)
lemma to_abmachung_simp_call:
  \<open>to_abmachung (delta # deltas) p =
    (if p = betroffen delta
     then (to_abmachung deltas p) + (aenderung_val delta)
     else (to_abmachung deltas p))\<close>
  by(simp)

lemma to_abmachung_fold_induct_helper:
  fixes as :: \<open>('person, 'etwas::ordered_ab_group_add) aenderung list\<close>
  shows \<open>fold (\<lambda>a acc. \<lbrakk>acc(betroffen a += aenderung_val a)\<rbrakk>) as abmachung =
    (\<lambda>p. to_abmachung as p + abmachung p)\<close>
  apply(induction \<open>as\<close> arbitrary:\<open>abmachung\<close>)
  by(simp add: fun_eq_iff)+
lemma to_abmachung_fold:
  fixes as :: \<open>('person, 'etwas::ordered_ab_group_add) aenderung list\<close>
  shows \<open>to_abmachung as = fold (\<lambda>a acc. \<lbrakk>acc(betroffen a += aenderung_val a)\<rbrakk>) as (\<lambda>_. 0)\<close>
  apply(subst to_abmachung_fold_induct_helper[where abmachung=\<open>\<lambda>_. 0\<close>])
  by simp

lemma to_abmachung_List_map_filter_simp_call:
  fixes f :: \<open>'person::enum \<Rightarrow> ('person, 'etwas::ordered_ab_group_add) aenderung option\<close>
  assumes valid_f: \<open>\<And>p a. f p = Some a \<Longrightarrow> betroffen a = p\<close>
  shows
  \<open>p \<in> set as \<Longrightarrow> distinct as \<Longrightarrow>
   to_abmachung (List.map_filter f as) p =
    (case f p of Some a \<Rightarrow> to_abmachung [a] p | None \<Rightarrow> 0)\<close>
proof(induction \<open>as\<close>)
  case Nil
  then show \<open>?case\<close> by simp
next
  case (Cons a as)
  have filter_not_in_set:
    \<open>p \<notin> set ps \<Longrightarrow> to_abmachung (List.map_filter f ps) p = 0\<close> for p ps
    apply(induction \<open>ps\<close>)
    apply(simp add: List.map_filter_simps)
    apply(simp add: List.map_filter_simps split:option.split)
    apply(clarsimp, rename_tac a ps a2)
    apply(subgoal_tac \<open>betroffen a2 = a\<close>)
     apply simp
    by(auto dest: valid_f)

  from Cons show \<open>?case\<close>
    apply(simp add: List.map_filter_simps)
    apply(safe)
     apply(case_tac \<open>f p\<close>)
      apply(simp add: filter_not_in_set; fail)
     apply(simp add: filter_not_in_set)
    using filter_not_in_set apply blast
    apply(simp)
     apply(case_tac \<open>f a\<close>)
      apply(simp add: filter_not_in_set; fail)
    apply(simp add: filter_not_in_set)
    by(auto dest: valid_f)
qed

lemma to_abmachung_List_map_filter_enum_simp_call:
fixes f :: \<open>'person::enum \<Rightarrow> ('person, 'etwas::ordered_ab_group_add) aenderung option\<close>
  assumes valid_f: \<open>\<And>p a. f p = Some a \<Longrightarrow> betroffen a = p\<close>
  shows
  \<open>to_abmachung (List.map_filter f Enum.enum) p =
    (case f p of Some a \<Rightarrow> to_abmachung [a] p | None \<Rightarrow> 0)\<close>
  apply(rule to_abmachung_List_map_filter_simp_call)
  using valid_f apply(simp)
   apply(simp add: enum_class.enum_UNIV)
  apply(simp add: enum_class.enum_distinct)
  done

fun abmachung_to_aenderung_list
  :: \<open>'person list \<Rightarrow> ('person, 'etwas::{ord,zero,plus,minus,uminus}) abmachung \<Rightarrow> ('person, 'etwas) aenderung list\<close>
where
  \<open>abmachung_to_aenderung_list [] _ = []\<close>
| \<open>abmachung_to_aenderung_list (p#ps) a =
    (if a p = 0
     then abmachung_to_aenderung_list ps a
     else (if a p > 0 then Gewinnt p (a p) else Verliert p (- (a p))) # abmachung_to_aenderung_list ps a
    )\<close>

definition abmachung_to_aenderung
  :: \<open>('person::enum, 'etwas::{ord,zero,plus,minus,uminus}) abmachung \<Rightarrow> ('person, 'etwas) aenderung list\<close>
where
  \<open>abmachung_to_aenderung \<equiv> abmachung_to_aenderung_list Enum.enum\<close>

beispiel \<open>abmachung_to_aenderung ((\<lambda>p.0)(Alice := (3::int), Bob := -3))
            = [Gewinnt Alice 3, Verliert Bob 3]\<close> by eval

definition aenderung_to_abmachung
  :: \<open>('person, 'etwas) aenderung list \<Rightarrow> ('person::enum, 'etwas::{ord,zero,plus,minus,uminus}) abmachung\<close>
where
  \<open>aenderung_to_abmachung \<equiv> to_abmachung\<close>

lemma fixes as :: \<open>('person::enum, int) aenderung list\<close>
  shows \<open>abmachung_to_aenderung (aenderung_to_abmachung as) = as\<close>
  (* nitpick as = [Verliert person\<^sub>1 (- 1)] *)
  oops (*gilt nicht, weil aenderungen nicht eindeutig*)

lemma abmachung_to_aenderung_list_to_abmachung_not_in_ps:
  \<open>p \<notin> set ps \<Longrightarrow>  to_abmachung (abmachung_to_aenderung_list ps a) p = 0\<close>
  by(induction \<open>ps\<close>) simp+

lemma abmachung_to_aenderung_list_not_in_ps:
  \<open>p \<notin> set ps \<Longrightarrow>
       abmachung_to_aenderung_list ps (a(p := v)) = abmachung_to_aenderung_list ps a\<close>
  apply(induction \<open>ps\<close>)
   apply(simp)
  apply(simp)
  by fastforce

definition abmachung_dom :: \<open>('person, 'etwas::zero) abmachung \<Rightarrow> 'person set\<close> where
  \<open>abmachung_dom m = {a. m a \<noteq> 0}\<close>

lemma abmachung_dom_swap:
  \<open>abmachung_dom (swap p1 p2 a) = (swap p1 p2 id) ` (abmachung_dom a)\<close>
  apply(simp add: abmachung_dom_def)
  apply(simp add: image_def)
  apply(rule Collect_cong)
  apply(simp add: swap_def Fun.swap_def)
  by fast

lemma to_abmachung_abmachung_to_aenderung_list_induct_helper:
  fixes a :: \<open>('person::enum, 'etwas::ordered_ab_group_add) abmachung\<close>
  shows \<open>abmachung_dom a \<subseteq> set ps \<Longrightarrow> distinct ps \<Longrightarrow> to_abmachung (abmachung_to_aenderung_list ps a) = a\<close>
  apply(induction \<open>ps\<close> arbitrary: \<open>a\<close>)
   apply(simp add: abmachung_dom_def)
   apply fastforce
  apply(rename_tac p ps a)
  apply(simp)
  apply(simp add: abmachung_to_aenderung_list_to_abmachung_not_in_ps)
  apply(case_tac \<open>p \<notin> abmachung_dom a\<close>)
   apply(subgoal_tac \<open>abmachung_dom a \<subseteq> set ps\<close>)
    apply(simp add: abmachung_dom_def; fail)
   apply(simp add: abmachung_dom_def)
   apply blast
  apply(subgoal_tac \<open>abmachung_dom (a(p := 0)) \<subseteq> set ps\<close>)
   prefer 2
   apply(simp add: abmachung_dom_def)
   apply blast
  apply(subgoal_tac \<open>to_abmachung (abmachung_to_aenderung_list ps a) = (a(p := 0))\<close>) (*instantiate IH*)
   prefer 2
   apply(simp)
   apply (metis abmachung_to_aenderung_list_not_in_ps)
  apply(simp)
  by fastforce

lemma aenderung_to_abmachung_abmachung_to_aenderung:
  fixes a :: \<open>('person::enum, 'etwas::ordered_ab_group_add) abmachung\<close>
  shows \<open>aenderung_to_abmachung (abmachung_to_aenderung a) = a\<close>
  apply(simp add: abmachung_to_aenderung_def aenderung_to_abmachung_def)
  apply(rule to_abmachung_abmachung_to_aenderung_list_induct_helper)
   apply(simp add: enum_class.enum_UNIV)
  apply(simp add: enum_class.enum_distinct)
  done
(*>*)

text\<open>Personen, welche von einer Abmachung betroffen sind.\<close>
definition abmachungs_betroffene :: \<open>('person::enum, 'etwas::zero) abmachung \<Rightarrow> 'person list\<close>
where
  \<open>abmachungs_betroffene a \<equiv> [p. p \<leftarrow> Enum.enum, a p \<noteq> 0]\<close>

beispiel \<open>abmachungs_betroffene (to_abmachung [Gewinnt Bob (3::int), Verliert Alice 3])
  = [Alice, Bob]\<close> by eval

(*<*)
lemma abmachungs_betroffene_simp: \<open>abmachungs_betroffene a = filter (\<lambda>p. a p \<noteq> 0) Enum.enum\<close>
proof -
  have \<open>concat (map (\<lambda>p. if a p \<noteq> 0 then [p] else []) as) = filter (\<lambda>p. a p \<noteq> 0) as\<close> for as
    by(induction \<open>as\<close>) auto
  thus \<open>?thesis\<close>
    by(simp add: abmachungs_betroffene_def)
qed

lemma abmachungs_betroffene_distinct: \<open>distinct (abmachungs_betroffene a)\<close>
  apply(simp add: abmachungs_betroffene_simp)
  using enum_class.enum_distinct distinct_filter by blast

lemma abmachungs_betroffene_is_dom: \<open>set (abmachungs_betroffene a) = abmachung_dom a\<close>
  by(simp add: abmachung_dom_def abmachungs_betroffene_simp enum_class.enum_UNIV)

lemma set_abmachungs_betroffene_swap:
  \<open>set (abmachungs_betroffene (swap p1 p2 a)) = (swap p1 p2 id) ` set (abmachungs_betroffene a)\<close>
  apply(simp add: abmachungs_betroffene_simp enum_class.enum_UNIV)
  apply(simp add: image_def)
  apply(rule Collect_cong)
  apply(simp add: swap_def Fun.swap_def)
  by fast
(*>*)

text\<open>Eine Abmachung lässt sich ausführen.
Dabei wird effektiv die gegebene \<^term>\<open>besitz::('person \<Rightarrow> 'etwas)\<close> Funktion upgedated.\<close>
definition abmachung_ausfuehren
  :: \<open>('person, 'etwas::{plus,minus}) abmachung \<Rightarrow> ('person \<Rightarrow> 'etwas) \<Rightarrow> ('person \<Rightarrow> 'etwas)\<close>
where
  \<open>abmachung_ausfuehren a besitz \<equiv> \<lambda>p. a p + (besitz p)\<close>

beispiel
  \<open>abmachung_ausfuehren
    (to_abmachung [Gewinnt Alice 3, Verliert Bob 3])
    (\<euro>(Alice:=8, Bob:=3, Eve:= 5))
  = (\<euro>(Alice:=11, Bob:=0, Eve:= 5))\<close>
  by(code_simp)

(*<*)
lemma abmachung_ausfuehren_swap:
  \<open>abmachung_ausfuehren (swap p1 p2 a) (swap p1 p2 welt)
    = swap p2 p1 (abmachung_ausfuehren a welt)\<close>
  by(auto simp add: abmachung_ausfuehren_def swap_def Fun.swap_def)

lemma aenderung_ausfuehren_abmachung_to_aenderung_induction_helper:
  fixes welt :: \<open>'person::enum \<Rightarrow> 'etwas::ordered_ab_group_add\<close>
  shows \<open>abmachung_dom abmachung \<subseteq> set ps \<Longrightarrow> distinct ps \<Longrightarrow>
          aenderung_ausfuehren (abmachung_to_aenderung_list ps abmachung) welt p =
            welt p + (abmachung p)\<close>
  apply(induction \<open>ps\<close> arbitrary: \<open>abmachung\<close> \<open>welt\<close>)
   apply(simp add: abmachung_dom_def; fail)
  apply(simp)
  apply(rename_tac pa ps abmachung welt)
  apply(subgoal_tac \<open>abmachung_dom (abmachung(pa := 0)) \<subseteq> set ps\<close>)
   prefer 2
  subgoal
    apply(simp add: abmachung_dom_def)
    by blast
(*thank you sledgehammer isar proofs*)
proof -
  fix pa :: \<open>'person\<close> and psa :: \<open>'person list\<close> and abmachunga :: \<open>'person \<Rightarrow> 'etwas\<close> and welta :: \<open>'person \<Rightarrow> 'etwas\<close>
  assume a1: \<open>pa \<notin> set psa \<and> distinct psa\<close>
  assume a2: \<open>abmachung_dom (abmachunga(pa := 0)) \<subseteq> set psa\<close>
  assume \<open>\<And>abmachung welt. abmachung_dom abmachung \<subseteq> set psa \<Longrightarrow> aenderung_ausfuehren (abmachung_to_aenderung_list psa abmachung) welt p = (welt p::'etwas) + abmachung p\<close>
  then have f3: \<open>\<And>f. f p + (abmachunga(pa := 0)) p = aenderung_ausfuehren (abmachung_to_aenderung_list psa abmachunga) f p\<close>
    using a2 a1 by (metis (full_types) abmachung_to_aenderung_list_not_in_ps)
  then have \<open>pa = p \<longrightarrow> (0 < abmachunga pa \<longrightarrow> abmachunga pa \<noteq> 0 \<longrightarrow> aenderung_ausfuehren (abmachung_to_aenderung_list psa abmachunga) \<lbrakk>welta (pa += abmachunga pa)\<rbrakk> p = welta p + abmachunga p) \<and> (\<not> 0 < abmachunga pa \<longrightarrow> (abmachunga pa = 0 \<longrightarrow> aenderung_ausfuehren (abmachung_to_aenderung_list psa abmachunga) welta p = welta p + abmachunga p) \<and> (abmachunga pa \<noteq> 0 \<longrightarrow> aenderung_ausfuehren (abmachung_to_aenderung_list psa abmachunga) \<lbrakk>welta (pa += abmachunga pa)\<rbrakk> p = welta p + abmachunga p))\<close>
    by force
  then show \<open>(0 < abmachunga pa \<longrightarrow> abmachunga pa \<noteq> 0 \<longrightarrow> aenderung_ausfuehren (abmachung_to_aenderung_list psa abmachunga) \<lbrakk>welta (pa += abmachunga pa)\<rbrakk> p = welta p + abmachunga p) \<and> (\<not> 0 < abmachunga pa \<longrightarrow> (abmachunga pa = 0 \<longrightarrow> aenderung_ausfuehren (abmachung_to_aenderung_list psa abmachunga) welta p = welta p + abmachunga p) \<and> (abmachunga pa \<noteq> 0 \<longrightarrow> aenderung_ausfuehren (abmachung_to_aenderung_list psa abmachunga) \<lbrakk>welta (pa += abmachunga pa)\<rbrakk> p = welta p + abmachunga p))\<close>
    using f3 by (metis fun_upd_other)
qed

lemma aenderung_ausfuehren_abmachung_to_aenderung:
  fixes welt :: \<open>'person::enum \<Rightarrow> 'etwas::ordered_ab_group_add\<close>
  shows \<open>aenderung_ausfuehren (abmachung_to_aenderung abmachung) welt p = welt p + (abmachung p)\<close>
  apply(simp add: abmachung_to_aenderung_def)
  apply(rule aenderung_ausfuehren_abmachung_to_aenderung_induction_helper)
   apply(simp add: enum_class.enum_UNIV)
  apply(simp add: enum_class.enum_distinct)
  done

(*>*)

text\<open>Es ist equivalent eine Abmachung oder die entsprechende Änderungsliste auszuführen.\<close>
(*TODO: does this make a good [code] rule? I cannot measure performance changes.*)
lemma abmachung_ausfuehren_aenderung:
  fixes abmachung :: \<open>('person::enum, 'etwas::ordered_ab_group_add) abmachung\<close>
  shows \<open>abmachung_ausfuehren abmachung = aenderung_ausfuehren (abmachung_to_aenderung abmachung)\<close>
  by(simp add: abmachung_ausfuehren_def fun_eq_iff aenderung_ausfuehren_abmachung_to_aenderung)

subsection\<open>Konsens\<close>
text\<open>Laut \<^url>\<open>https://de.wikipedia.org/wiki/Konsens#Konsens_im_Rechtssystem\<close> lässt sich Konsens
wie folgt definieren:
"die Übereinstimmung der Willenserklärungen beider Vertragspartner über die Punkte des Vertrages".
Wir können also \<^term>\<open>to_abmachung [Gewinnt Alice 3, Verliert Bob 3]\<close> verwenden,
um Konsens zu modellieren.
Dabei müssen alle Betroffenen die gleiche Vorstellung der Abmachung haben.
Beispielsweise lässt sich der gesamte Konsens in einer Welt darstellen als
\<^typ>\<open>'person \<Rightarrow> ('person, 'etwas) abmachung list\<close>, wobei jeder Person genau die Abmachungen
zugeordnet werden, deren sie zustimmt.
Die Abmachungen sind in einer Liste und keiner Menge, da eine Person eventuell bereit ist,
Abmachungen mehrfach auszuführen.
\<close>

type_synonym ('person, 'etwas) globaler_konsens = \<open>'person \<Rightarrow> ('person, 'etwas) abmachung list\<close>

text\<open>
Folgendes Beispiel liest sich wie folgt:

\<^term>\<open>(\<lambda>_. [])(
    Alice := [to_abmachung [Gewinnt Alice 3], to_abmachung [Gewinnt Alice 3, Verliert Bob 3]],
    Bob := [to_abmachung [Gewinnt Alice 3, Verliert Bob 3]]) :: (person, int) globaler_konsens\<close>

\<^const>\<open>Alice\<close> stimmt folgendem zu:
  \<^item> \<^const>\<open>Alice\<close> bekommt 3.
  \<^item> \<^const>\<open>Alice\<close> bekommt 3 und \<^const>\<open>Bob\<close> muss 3 abgeben.

\<^const>\<open>Bob\<close> stimmt folgendem zu:
  \<^item> \<^const>\<open>Alice\<close> bekommt 3 und \<^const>\<open>Bob\<close> muss 3 abgeben.

Wir könnten also sagen, dass Konsens zwischen \<^const>\<open>Alice\<close> und \<^const>\<open>Bob\<close> herrscht,
dass 3 Besitz von \<^const>\<open>Bob\<close> auf \<^const>\<open>Alice\<close> übergehen.
Zusätzlich wäre es in diesem Beispiel auch okay für \<^const>\<open>Alice\<close>,
wenn sie 3 Besitz erhalten würde, ohne dass \<^const>\<open>Bob\<close> 3 Besitz verliert.
\<close>

(*<*)
definition konsensswap
:: \<open>'person \<Rightarrow> 'person \<Rightarrow> ('person, 'etwas) globaler_konsens
    \<Rightarrow> ('person, 'etwas) globaler_konsens\<close>
  where
\<open>konsensswap p1 p2 kons \<equiv> swap p1 p2 ((map (swap p1 p2)) \<circ> kons)\<close>

lemma konsensswap_id[simp]: \<open>konsensswap p1 p2 (konsensswap p1 p2 kons) = kons\<close>
  apply(simp add: konsensswap_def)
  apply(subst swap_fun_map_comp_id)
  by simp

lemma konsensswap_sym: \<open>konsensswap p1 p2 = konsensswap p2 p1\<close>
  by(simp add: fun_eq_iff konsensswap_def swap_symmetric)

lemma konsensswap_apply:
  \<open>konsensswap p1 p2 kons p =  map (swap p1 p2) (swap p1 p2 kons p)\<close>
  apply(simp add: konsensswap_def comp_def)
  by(rule swap_cases, simp_all add: swap_a swap_b swap_nothing)

lemma konsensswap_same[simp]:
  \<open>konsensswap p p konsens = konsens\<close>
  by(simp add: konsensswap_def swap_id_comp)

lemma konsensswap_swap_id:
  \<open>konsensswap p1 p2 konsens (swap p1 p2 id p) = map (swap p1 p2) (konsens p)\<close>
  apply(simp add: konsensswap_apply)
  by (simp add: swap_fun_swap_id)
(*>*)

text\<open>Folgendes Prädikat prüft, ob für eine gegebene Abmachung Konsens herrscht.\<close>
definition enthaelt_konsens
  :: \<open>('person::enum, 'etwas::zero) abmachung \<Rightarrow> ('person, 'etwas) globaler_konsens \<Rightarrow> bool\<close>
where
  \<open>enthaelt_konsens abmachung konsens \<equiv> \<forall>betroffene_person \<in> set (abmachungs_betroffene abmachung).
      abmachung \<in> set (konsens betroffene_person)\<close>

(*<*)
lemma swap_konsensswap_swap:
  \<open>swap p2 p1 ` set (konsensswap p1 p2 konsens (swap p1 p2 id p)) =
  (set (konsens p))\<close>
  apply(simp add: konsensswap_apply)
  apply(simp add: swap_fun_swap_id)
  by (simp add: image_comp)

lemma enthaelt_konsens_swap:
  \<open>enthaelt_konsens (swap p1 p2 a) (konsensswap p1 p2 konsens) = enthaelt_konsens a konsens\<close>
  apply(simp add: enthaelt_konsens_def abmachungs_betroffene_is_dom)
  apply(simp add: abmachung_dom_swap)
  apply(rule ball_cong)
   apply(simp; fail)
  by(simp add: swap_in_set_of_functions swap_konsensswap_swap)
(*>*)

text\<open>Eine (ausgeführte) Abmachung einlösen, bzw. entfernen.\<close>
definition konsens_entfernen
 :: \<open>('person::enum, 'etwas::zero) abmachung \<Rightarrow> ('person \<Rightarrow> ('person, 'etwas) abmachung list)
   \<Rightarrow> ('person \<Rightarrow> ('person, 'etwas) abmachung list)\<close>
 where
\<open>konsens_entfernen abmachung kons =
      fold (\<lambda>p k. k(p := remove1 abmachung (k p))) (abmachungs_betroffene abmachung) kons\<close>

beispiel
  \<open>konsens_entfernen
    (to_abmachung [Gewinnt Alice (3::int), Verliert Bob 3])
    ((\<lambda>_. [])(
      Alice := [to_abmachung [Gewinnt Alice 3], to_abmachung [Gewinnt Alice 3, Verliert Bob 3]],
      Bob := [to_abmachung [Gewinnt Alice 3, Verliert Bob 3]])
    )
  = (\<lambda>_. [])(
    Alice := [to_abmachung [Gewinnt Alice 3]],
    Bob := [])\<close>
  by eval

(*<*)
lemma konsens_entfernen_fold_induct_helper_helper:
  \<open>a \<notin> set as \<Longrightarrow> fold (\<lambda>a k. k(a := f (k a))) as kons a = kons a\<close>
  by(induction \<open>as\<close> arbitrary: \<open>kons\<close>) simp+
lemma konsens_entfernen_fold_induct_helper:
  \<open>x \<in> set as \<Longrightarrow> distinct as \<Longrightarrow>
         fold (\<lambda>a k. k(a := f (k a))) as kons x = f (kons x)\<close>
  apply(induction \<open>as\<close> arbitrary: \<open>kons\<close>)
   apply(simp; fail)
  apply(simp)
  apply(erule disjE)
   apply(simp)
  apply(simp add: konsens_entfernen_fold_induct_helper_helper; fail)
   apply(simp)
  apply blast
  done
(*>*)

text\<open>Alternative Definition:\<close>
lemma konsens_entfernen_simp:
  \<open>konsens_entfernen a kons
    = (\<lambda>p. if p \<in> set (abmachungs_betroffene a) then remove1 a (kons p) else (kons p))\<close>
  apply(simp add: konsens_entfernen_def fun_eq_iff)
  apply(intro allI conjI impI)
   apply(subst konsens_entfernen_fold_induct_helper, simp_all)
   apply(simp add: abmachungs_betroffene_distinct)
  apply(simp add: konsens_entfernen_fold_induct_helper_helper)
  done

(*<*)
lemma remove1_konsensswap:
  \<open>remove1 (swap p1 p2 a) (konsensswap p1 p2 kons p)
    = map (swap p1 p2) (remove1 a (swap p1 p2 kons p))\<close>
  by(simp add: konsensswap_apply remove1_swap)

lemma konsens_entfernen_konsensswap:
  \<open>konsensswap p2 p1 (konsens_entfernen (swap p1 p2 a) (konsensswap p1 p2 kons))
    = konsens_entfernen a kons\<close>
  apply(simp add: konsens_entfernen_simp fun_eq_iff)
  apply(safe)
   apply(simp add: set_abmachungs_betroffene_swap)
   apply(simp add: konsensswap_apply)
   apply(simp add: swap_if_move_inner)
   apply(simp add: swap_id_in_set)
   apply(subst(2) remove1_swap2[of \<open>p1\<close> \<open>p2\<close>, symmetric])
   apply(auto simp add: konsensswap_apply swap_def Fun.swap_def)[1] (*wants helper*)

  apply(simp add: set_abmachungs_betroffene_swap)
  apply(simp add: konsensswap_apply)
  apply(simp add: swap_if_move_inner)
  apply(simp add: swap_id_in_set)
  apply(simp add: konsensswap_apply swap_def comp_def)
  by (simp add: transpose_commute)

lemma to_abmachung_delta_num_fun_simp_call:
  (*stronger than the usual ordered_ab_group_add*)
  fixes vor::\<open>('person::enum \<Rightarrow> 'etwas::linordered_ab_group_add)\<close>
  shows \<open>to_abmachung (delta_num_fun (Handlung vor nach)) p = nach p - vor p\<close>
  apply(simp)
  apply(subst to_abmachung_List_map_filter_enum_simp_call)
  subgoal by(auto simp add: delta_num_def split: if_split_asm)
  by(simp add: delta_num_def)
(*>*)

text\<open>Folgendes Prädikat prüft ob eine Abmachung korrekt aus dem Konsens entfernt wurde.
Dies sollte normalerweise direkt nachdem eine Abmachung eingelöst wurde geschehen.\<close>
definition konsens_wurde_entfernt
  :: \<open>('person::enum, 'etwas::zero) abmachung \<Rightarrow>
      ('person, 'etwas) globaler_konsens \<Rightarrow> ('person, 'etwas) globaler_konsens \<Rightarrow> bool\<close>
where
  \<open>konsens_wurde_entfernt abmachung konsens_vor konsens_nach \<equiv>
    \<forall>betroffene_person \<in> set (abmachungs_betroffene abmachung).
       mset (konsens_vor betroffene_person) = mset (abmachung#(konsens_nach betroffene_person))\<close>

text\<open>Wir müssen hier Multisets (\<^const>\<open>mset\<close>) verwenden,
da eine Abmachung sowohl mehrfach vorkommen kann aber nur einmal eingelöst wird
und die Reihenfolge in welcher die Abmachungen angeordnet sind egal ist.\<close>
(*TODO: will ich multiset von Anfang an verwenden?*)

text\<open>Folgendes gilt nicht \<^term>\<open>konsens_wurde_entfernt a konsens (konsens_entfernen a konsens)\<close>,
da \<^const>\<open>konsens_entfernen\<close> nur einen existierenden Konsens entfernt.
Sollte der gegebene Konsens nicht existieren passiert nichts!
\<close>
beispiel
\<open>konsens = (\<lambda>_. []) \<Longrightarrow> a = to_abmachung [Gewinnt Alice (3::int), Verliert Bob 3]
  \<Longrightarrow> \<not> konsens_wurde_entfernt a konsens (konsens_entfernen a konsens)\<close>
  by(simp, eval)

text\<open>Wenn wir allerdings Konsens haben, dann verhalten sich \<^const>\<open>konsens_wurde_entfernt\<close> und
\<^const>\<open>konsens_entfernen\<close> doch wie erwartet.\<close>
lemma konsens_wurde_entfernt_konsens_entfernen:
  \<open>enthaelt_konsens a konsens \<Longrightarrow> konsens_wurde_entfernt a konsens (konsens_entfernen a konsens)\<close>
  apply(simp add: konsens_wurde_entfernt_def)
  apply(simp add: konsens_entfernen_simp)
  by (simp add: enthaelt_konsens_def)

(*<*)

(*makes the simplifier loop*)
lemma
  \<open>add_mset (swap p1 p2 a) (image_mset (swap p1 p2) M) =
     image_mset (swap p1 p2) (add_mset a M)\<close>
  by simp

lemma konsens_wurde_entfernt_swap:
  \<open>konsens_wurde_entfernt (swap p1 p2 a) (konsensswap p1 p2 konsens_vor) (konsensswap p1 p2 konsens_nach)
    = konsens_wurde_entfernt a konsens_vor konsens_nach\<close>
  apply(simp add: konsens_wurde_entfernt_def abmachungs_betroffene_is_dom)
  apply(simp add: abmachung_dom_swap)
  apply(rule ball_cong)
   apply(simp; fail)
  apply(simp add: konsensswap_swap_id)
  (*TODO: wow, ugly*)
  by (metis (no_types, opaque_lifting) comp_apply image_mset_add_mset multiset.map_comp multiset.map_ident_strong swap1)
(*>*)

text\<open>Gegeben eine Handlung berechnet folgende Funktion die Abmachung,
aus der diese Handlung resultiert haben könnte.\<close>
definition reverse_engineer_abmachung
  :: \<open>('person::enum \<Rightarrow> 'etwas::linordered_ab_group_add) handlung \<Rightarrow> ('person, 'etwas) abmachung\<close>
where
  \<open>reverse_engineer_abmachung h \<equiv>
    fold (\<lambda>p acc. acc(p := (nachher h p) - (vorher h p))) Enum.enum (\<lambda>_. 0)\<close>

text\<open>Sollte die Abmachung vom Typ \<^typ>\<open>(person, int) abmachung\<close> sein, ist dies eindeutig.\<close>
lemma reverse_engineer_abmachung_delta_num_fun:
  \<open>reverse_engineer_abmachung h = to_abmachung (delta_num_fun h)\<close>
  apply(simp add: fun_eq_iff reverse_engineer_abmachung_def)
  apply(cases \<open>h\<close>, simp del: delta_num_fun.simps)
  apply(subst to_abmachung_delta_num_fun_simp_call)
  apply(subst fold_enum_fun_update_call)
  by simp

(*<*)
lemma reverse_engineer_abmachung_same:
  \<open>reverse_engineer_abmachung (Handlung v v) = (\<lambda>_. 0)\<close>
  by(simp add: reverse_engineer_abmachung_def fun_eq_iff fold_enum_fun_update_call)

lemma reverse_engineer_abmachung_swap:
  \<open>reverse_engineer_abmachung (Handlung (swap p1 p2 vor) (swap p1 p2 nach)) =
        swap p1 p2 (reverse_engineer_abmachung (Handlung vor nach))\<close>
  by(simp add: fun_eq_iff reverse_engineer_abmachung_def fold_enum_fun_update swap_def)
(*>*)

lemma reverse_engineer_abmachung:
  \<open>reverse_engineer_abmachung (Handlung welt welt') = a \<longleftrightarrow> abmachung_ausfuehren a welt = welt'\<close>
  apply(simp add: abmachung_ausfuehren_def fun_eq_iff)
  apply(simp add: reverse_engineer_abmachung_def fold_enum_fun_update_call)
  by (metis add_diff_cancel diff_add_cancel)

end


section {* Simply-typed lambda-calculus with let and tuple patterns *}

theory Pattern
imports "../Nominal"
begin

no_syntax
  "_Map" :: "maplets => 'a ~=> 'b"  ("(1[_])")

atom_decl name

nominal_datatype ty =
    Atom nat
  | Arrow ty ty  (infixr "\<rightarrow>" 200)
  | TupleT ty ty  (infixr "\<otimes>" 210)

lemma fresh_type [simp]: "(a::name) \<sharp> (T::ty)"
  by (induct T rule: ty.induct) (simp_all add: fresh_nat)

lemma supp_type [simp]: "supp (T::ty) = ({} :: name set)"
  by (induct T rule: ty.induct) (simp_all add: ty.supp supp_nat)

lemma perm_type: "(pi::name prm) \<bullet> (T::ty) = T"
  by (induct T rule: ty.induct) (simp_all add: perm_nat_def)

nominal_datatype trm =
    Var name
  | Tuple trm trm  ("(1'\<langle>_,/ _'\<rangle>)")
  | Abs ty "\<guillemotleft>name\<guillemotright>trm"
  | App trm trm  (infixl "\<cdot>" 200)
  | Let ty trm btrm
and btrm =
    Base trm
  | Bind ty "\<guillemotleft>name\<guillemotright>btrm"

abbreviation
  Abs_syn :: "name \<Rightarrow> ty \<Rightarrow> trm \<Rightarrow> trm"  ("(3\<lambda>_:_./ _)" [0, 0, 10] 10)
where
  "\<lambda>x:T. t \<equiv> Abs T x t"

datatype pat =
    PVar name ty
  | PTuple pat pat  ("(1'\<langle>\<langle>_,/ _'\<rangle>\<rangle>)")

(* FIXME: The following should be done automatically by the nominal package *)
overloading pat_perm \<equiv> "perm :: name prm \<Rightarrow> pat \<Rightarrow> pat" (unchecked)
begin

primrec pat_perm
where
  "pat_perm pi (PVar x ty) = PVar (pi \<bullet> x) (pi \<bullet> ty)"
| "pat_perm pi \<langle>\<langle>p, q\<rangle>\<rangle> = \<langle>\<langle>pat_perm pi p, pat_perm pi q\<rangle>\<rangle>"

end

declare pat_perm.simps [eqvt]

lemma supp_PVar [simp]: "((supp (PVar x T))::name set) = supp x"
  by (simp add: supp_def perm_fresh_fresh)

lemma supp_PTuple [simp]: "((supp \<langle>\<langle>p, q\<rangle>\<rangle>)::name set) = supp p \<union> supp q"
  by (simp add: supp_def Collect_disj_eq del: disj_not1)

instance pat :: pt_name
proof intro_classes
  case goal1
  show ?case by (induct x) simp_all
next
  case goal2
  show ?case by (induct x) (simp_all add: pt_name2)
next
  case goal3
  then show ?case by (induct x) (simp_all add: pt_name3)
qed

instance pat :: fs_name
proof intro_classes
  case goal1
  show ?case by (induct x) (simp_all add: fin_supp)
qed

(* the following function cannot be defined using nominal_primrec, *)
(* since variable parameters are currently not allowed.            *)
primrec abs_pat :: "pat \<Rightarrow> btrm \<Rightarrow> btrm" ("(3\<lambda>[_]./ _)" [0, 10] 10)
where
  "(\<lambda>[PVar x T]. t) = Bind T x t"
| "(\<lambda>[\<langle>\<langle>p, q\<rangle>\<rangle>]. t) = (\<lambda>[p]. \<lambda>[q]. t)"

lemma abs_pat_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (\<lambda>[p]. t) = (\<lambda>[pi \<bullet> p]. (pi \<bullet> t))"
  by (induct p arbitrary: t) simp_all

lemma abs_pat_fresh [simp]:
  "(x::name) \<sharp> (\<lambda>[p]. t) = (x \<in> supp p \<or> x \<sharp> t)"
  by (induct p arbitrary: t) (simp_all add: abs_fresh supp_atm)

lemma abs_pat_alpha:
  assumes fresh: "((pi::name prm) \<bullet> supp p::name set) \<sharp>* t"
  and pi: "set pi \<subseteq> supp p \<times> pi \<bullet> supp p"
  shows "(\<lambda>[p]. t) = (\<lambda>[pi \<bullet> p]. pi \<bullet> t)"
proof -
  note pt_name_inst at_name_inst pi
  moreover have "(supp p::name set) \<sharp>* (\<lambda>[p]. t)"
    by (simp add: fresh_star_def)
  moreover from fresh
  have "(pi \<bullet> supp p::name set) \<sharp>* (\<lambda>[p]. t)"
    by (simp add: fresh_star_def)
  ultimately have "pi \<bullet> (\<lambda>[p]. t) = (\<lambda>[p]. t)"
    by (rule pt_freshs_freshs)
  then show ?thesis by (simp add: eqvts)
qed

primrec pat_vars :: "pat \<Rightarrow> name list"
where
  "pat_vars (PVar x T) = [x]"
| "pat_vars \<langle>\<langle>p, q\<rangle>\<rangle> = pat_vars q @ pat_vars p"

lemma pat_vars_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (pat_vars p) = pat_vars (pi \<bullet> p)"
  by (induct p rule: pat.induct) (simp_all add: eqvts)

lemma set_pat_vars_supp: "set (pat_vars p) = supp p"
  by (induct p) (auto simp add: supp_atm)

lemma distinct_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (distinct (xs::name list)) = distinct (pi \<bullet> xs)"
  by (induct xs) (simp_all add: eqvts)

primrec pat_type :: "pat \<Rightarrow> ty"
where
  "pat_type (PVar x T) = T"
| "pat_type \<langle>\<langle>p, q\<rangle>\<rangle> = pat_type p \<otimes> pat_type q"

lemma pat_type_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (pat_type p) = pat_type (pi \<bullet> p)"
  by (induct p) simp_all

lemma pat_type_perm_eq: "pat_type ((pi :: name prm) \<bullet> p) = pat_type p"
  by (induct p) (simp_all add: perm_type)

type_synonym ctx = "(name \<times> ty) list"

inductive
  ptyping :: "pat \<Rightarrow> ty \<Rightarrow> ctx \<Rightarrow> bool"  ("\<turnstile> _ : _ \<Rightarrow> _" [60, 60, 60] 60)
where
  PVar: "\<turnstile> PVar x T : T \<Rightarrow> [(x, T)]"
| PTuple: "\<turnstile> p : T \<Rightarrow> \<Delta>\<^sub>1 \<Longrightarrow> \<turnstile> q : U \<Rightarrow> \<Delta>\<^sub>2 \<Longrightarrow> \<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> : T \<otimes> U \<Rightarrow> \<Delta>\<^sub>2 @ \<Delta>\<^sub>1"

lemma pat_vars_ptyping:
  assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
  shows "pat_vars p = map fst \<Delta>" using assms
  by induct simp_all

inductive
  valid :: "ctx \<Rightarrow> bool"
where
  Nil [intro!]: "valid []"
| Cons [intro!]: "valid \<Gamma> \<Longrightarrow> x \<sharp> \<Gamma> \<Longrightarrow> valid ((x, T) # \<Gamma>)"

inductive_cases validE[elim!]: "valid ((x, T) # \<Gamma>)"

lemma fresh_ctxt_set_eq: "((x::name) \<sharp> (\<Gamma>::ctx)) = (x \<notin> fst ` set \<Gamma>)"
  by (induct \<Gamma>) (auto simp add: fresh_list_nil fresh_list_cons fresh_prod fresh_atm)

lemma valid_distinct: "valid \<Gamma> = distinct (map fst \<Gamma>)"
  by (induct \<Gamma>) (auto simp add: fresh_ctxt_set_eq [symmetric])

abbreviation
  "sub_ctx" :: "ctx \<Rightarrow> ctx \<Rightarrow> bool" ("_ \<sqsubseteq> _")
where
  "\<Gamma>\<^sub>1 \<sqsubseteq> \<Gamma>\<^sub>2 \<equiv> \<forall>x. x \<in> set \<Gamma>\<^sub>1 \<longrightarrow> x \<in> set \<Gamma>\<^sub>2"

abbreviation
  Let_syn :: "pat \<Rightarrow> trm \<Rightarrow> trm \<Rightarrow> trm"  ("(LET (_ =/ _)/ IN (_))" 10)
where
  "LET p = t IN u \<equiv> Let (pat_type p) t (\<lambda>[p]. Base u)"

inductive typing :: "ctx \<Rightarrow> trm \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _" [60, 60, 60] 60)
where
  Var [intro]: "valid \<Gamma> \<Longrightarrow> (x, T) \<in> set \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
| Tuple [intro]: "\<Gamma> \<turnstile> t : T \<Longrightarrow> \<Gamma> \<turnstile> u : U \<Longrightarrow> \<Gamma> \<turnstile> \<langle>t, u\<rangle> : T \<otimes> U"
| Abs [intro]: "(x, T) # \<Gamma> \<turnstile> t : U \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>x:T. t) : T \<rightarrow> U"
| App [intro]: "\<Gamma> \<turnstile> t : T \<rightarrow> U \<Longrightarrow> \<Gamma> \<turnstile> u : T \<Longrightarrow> \<Gamma> \<turnstile> t \<cdot> u : U"
| Let: "((supp p)::name set) \<sharp>* t \<Longrightarrow>
    \<Gamma> \<turnstile> t : T \<Longrightarrow> \<turnstile> p : T \<Rightarrow> \<Delta> \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile> u : U \<Longrightarrow>
    \<Gamma> \<turnstile> (LET p = t IN u) : U"

equivariance ptyping

equivariance valid

equivariance typing

lemma valid_typing:
  assumes "\<Gamma> \<turnstile> t : T"
  shows "valid \<Gamma>" using assms
  by induct auto

lemma pat_var:
  assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
  shows "(supp p::name set) = supp \<Delta>" using assms
  by induct (auto simp add: supp_list_nil supp_list_cons supp_prod supp_list_append)

lemma valid_app_fresh:
  assumes "valid (\<Delta> @ \<Gamma>)" and "(x::name) \<in> supp \<Delta>"
  shows "x \<sharp> \<Gamma>" using assms
  by (induct \<Delta>)
    (auto simp add: supp_list_nil supp_list_cons supp_prod supp_atm fresh_list_append)

lemma pat_freshs:
  assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
  shows "(supp p::name set) \<sharp>* c = (supp \<Delta>::name set) \<sharp>* c" using assms
  by (auto simp add: fresh_star_def pat_var)

lemma valid_app_mono:
  assumes "valid (\<Delta> @ \<Gamma>\<^sub>1)" and "(supp \<Delta>::name set) \<sharp>* \<Gamma>\<^sub>2" and "valid \<Gamma>\<^sub>2" and "\<Gamma>\<^sub>1 \<sqsubseteq> \<Gamma>\<^sub>2"
  shows "valid (\<Delta> @ \<Gamma>\<^sub>2)" using assms
  by (induct \<Delta>)
    (auto simp add: supp_list_cons fresh_star_Un_elim supp_prod
       fresh_list_append supp_atm fresh_star_insert_elim fresh_star_empty_elim)

nominal_inductive2 typing
avoids
  Abs: "{x}"
| Let: "(supp p)::name set"
  by (auto simp add: fresh_star_def abs_fresh fin_supp pat_var
    dest!: valid_typing valid_app_fresh)

lemma better_T_Let [intro]:
  assumes t: "\<Gamma> \<turnstile> t : T" and p: "\<turnstile> p : T \<Rightarrow> \<Delta>" and u: "\<Delta> @ \<Gamma> \<turnstile> u : U"
  shows "\<Gamma> \<turnstile> (LET p = t IN u) : U"
proof -
  obtain pi::"name prm" where pi: "(pi \<bullet> (supp p::name set)) \<sharp>* (t, Base u, \<Gamma>)"
    and pi': "set pi \<subseteq> supp p \<times> (pi \<bullet> supp p)"
    by (rule at_set_avoiding [OF at_name_inst fin_supp fin_supp])
  from p u have p_fresh: "(supp p::name set) \<sharp>* \<Gamma>"
    by (auto simp add: fresh_star_def pat_var dest!: valid_typing valid_app_fresh)
  from pi have p_fresh': "(pi \<bullet> (supp p::name set)) \<sharp>* \<Gamma>"
    by (simp add: fresh_star_prod_elim)
  from pi have p_fresh'': "(pi \<bullet> (supp p::name set)) \<sharp>* Base u"
    by (simp add: fresh_star_prod_elim)
  from pi have "(supp (pi \<bullet> p)::name set) \<sharp>* t"
    by (simp add: fresh_star_prod_elim eqvts)
  moreover note t
  moreover from p have "pi \<bullet> (\<turnstile> p : T \<Rightarrow> \<Delta>)" by (rule perm_boolI)
  then have "\<turnstile> (pi \<bullet> p) : T \<Rightarrow> (pi \<bullet> \<Delta>)" by (simp add: eqvts perm_type)
  moreover from u have "pi \<bullet> (\<Delta> @ \<Gamma> \<turnstile> u : U)" by (rule perm_boolI)
  with pt_freshs_freshs [OF pt_name_inst at_name_inst pi' p_fresh p_fresh']
  have "(pi \<bullet> \<Delta>) @ \<Gamma> \<turnstile> (pi \<bullet> u) : U" by (simp add: eqvts perm_type)
  ultimately have "\<Gamma> \<turnstile> (LET (pi \<bullet> p) = t IN (pi \<bullet> u)) : U"
    by (rule Let)
  then show ?thesis by (simp add: abs_pat_alpha [OF p_fresh'' pi'] pat_type_perm_eq)
qed

lemma weakening:
  assumes "\<Gamma>\<^sub>1 \<turnstile> t : T" and "valid \<Gamma>\<^sub>2" and "\<Gamma>\<^sub>1 \<sqsubseteq> \<Gamma>\<^sub>2"
  shows "\<Gamma>\<^sub>2 \<turnstile> t : T" using assms
  apply (nominal_induct \<Gamma>\<^sub>1 t T avoiding: \<Gamma>\<^sub>2 rule: typing.strong_induct)
  apply auto
  apply (drule_tac x="(x, T) # \<Gamma>\<^sub>2" in meta_spec)
  apply (auto intro: valid_typing)
  apply (drule_tac x="\<Gamma>\<^sub>2" in meta_spec)
  apply (drule_tac x="\<Delta> @ \<Gamma>\<^sub>2" in meta_spec)
  apply (auto intro: valid_typing)
  apply (rule typing.Let)
  apply assumption+
  apply (drule meta_mp)
  apply (rule valid_app_mono)
  apply (rule valid_typing)
  apply assumption
  apply (auto simp add: pat_freshs)
  done

inductive
  match :: "pat \<Rightarrow> trm \<Rightarrow> (name \<times> trm) list \<Rightarrow> bool"  ("\<turnstile> _ \<rhd> _ \<Rightarrow> _" [50, 50, 50] 50)
where
  PVar: "\<turnstile> PVar x T \<rhd> t \<Rightarrow> [(x, t)]"
| PProd: "\<turnstile> p \<rhd> t \<Rightarrow> \<theta> \<Longrightarrow> \<turnstile> q \<rhd> u \<Rightarrow> \<theta>' \<Longrightarrow> \<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> \<langle>t, u\<rangle> \<Rightarrow> \<theta> @ \<theta>'"

fun
  lookup :: "(name \<times> trm) list \<Rightarrow> name \<Rightarrow> trm"
where
  "lookup [] x = Var x"
| "lookup ((y, e) # \<theta>) x = (if x = y then e else lookup \<theta> x)"

lemma lookup_eqvt[eqvt]:
  fixes pi :: "name prm"
  and   \<theta> :: "(name \<times> trm) list"
  and   X :: "name"
  shows "pi \<bullet> (lookup \<theta> X) = lookup (pi \<bullet> \<theta>) (pi \<bullet> X)"
  by (induct \<theta>) (auto simp add: eqvts)

nominal_primrec
  psubst :: "(name \<times> trm) list \<Rightarrow> trm \<Rightarrow> trm"  ("_\<lparr>_\<rparr>" [95,0] 210)
  and psubstb :: "(name \<times> trm) list \<Rightarrow> btrm \<Rightarrow> btrm"  ("_\<lparr>_\<rparr>\<^sub>b" [95,0] 210)
where
  "\<theta>\<lparr>Var x\<rparr> = (lookup \<theta> x)"
| "\<theta>\<lparr>t \<cdot> u\<rparr> = \<theta>\<lparr>t\<rparr> \<cdot> \<theta>\<lparr>u\<rparr>"
| "\<theta>\<lparr>\<langle>t, u\<rangle>\<rparr> = \<langle>\<theta>\<lparr>t\<rparr>, \<theta>\<lparr>u\<rparr>\<rangle>"
| "\<theta>\<lparr>Let T t u\<rparr> = Let T (\<theta>\<lparr>t\<rparr>) (\<theta>\<lparr>u\<rparr>\<^sub>b)"
| "x \<sharp> \<theta> \<Longrightarrow> \<theta>\<lparr>\<lambda>x:T. t\<rparr> = (\<lambda>x:T. \<theta>\<lparr>t\<rparr>)"
| "\<theta>\<lparr>Base t\<rparr>\<^sub>b = Base (\<theta>\<lparr>t\<rparr>)"
| "x \<sharp> \<theta> \<Longrightarrow> \<theta>\<lparr>Bind T x t\<rparr>\<^sub>b = Bind T x (\<theta>\<lparr>t\<rparr>\<^sub>b)"
  apply finite_guess+
  apply (simp add: abs_fresh | fresh_guess)+
  done

lemma lookup_fresh:
  "x = y \<longrightarrow> x \<in> set (map fst \<theta>) \<Longrightarrow> \<forall>(y, t)\<in>set \<theta>. x \<sharp> t \<Longrightarrow> x \<sharp> lookup \<theta> y"
  apply (induct \<theta>)
  apply (simp_all add: split_paired_all fresh_atm)
  apply (case_tac "x = y")
  apply (auto simp add: fresh_atm)
  done

lemma psubst_fresh:
  assumes "x \<in> set (map fst \<theta>)" and "\<forall>(y, t)\<in>set \<theta>. x \<sharp> t"
  shows "x \<sharp> \<theta>\<lparr>t\<rparr>" and "x \<sharp> \<theta>\<lparr>t'\<rparr>\<^sub>b" using assms
  apply (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
  apply simp
  apply (rule lookup_fresh)
  apply (rule impI)
  apply (simp_all add: abs_fresh)
  done

lemma psubst_eqvt[eqvt]:
  fixes pi :: "name prm"
  shows "pi \<bullet> (\<theta>\<lparr>t\<rparr>) = (pi \<bullet> \<theta>)\<lparr>pi \<bullet> t\<rparr>"
  and "pi \<bullet> (\<theta>\<lparr>t'\<rparr>\<^sub>b) = (pi \<bullet> \<theta>)\<lparr>pi \<bullet> t'\<rparr>\<^sub>b"
  by (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
    (simp_all add: eqvts fresh_bij)

abbreviation
  subst :: "trm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm" ("_[_\<mapsto>_]" [100,0,0] 100)
where
  "t[x\<mapsto>t'] \<equiv> [(x,t')]\<lparr>t\<rparr>"

abbreviation
  substb :: "btrm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> btrm" ("_[_\<mapsto>_]\<^sub>b" [100,0,0] 100)
where
  "t[x\<mapsto>t']\<^sub>b \<equiv> [(x,t')]\<lparr>t\<rparr>\<^sub>b"

lemma lookup_forget:
  "(supp (map fst \<theta>)::name set) \<sharp>* x \<Longrightarrow> lookup \<theta> x = Var x"
  by (induct \<theta>) (auto simp add: split_paired_all fresh_star_def fresh_atm supp_list_cons supp_atm)

lemma supp_fst: "(x::name) \<in> supp (map fst (\<theta>::(name \<times> trm) list)) \<Longrightarrow> x \<in> supp \<theta>"
  by (induct \<theta>) (auto simp add: supp_list_nil supp_list_cons supp_prod)

lemma psubst_forget:
  "(supp (map fst \<theta>)::name set) \<sharp>* t \<Longrightarrow> \<theta>\<lparr>t\<rparr> = t"
  "(supp (map fst \<theta>)::name set) \<sharp>* t' \<Longrightarrow> \<theta>\<lparr>t'\<rparr>\<^sub>b = t'"
  apply (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
  apply (auto simp add: fresh_star_def lookup_forget abs_fresh)
  apply (drule_tac x=\<theta> in meta_spec)
  apply (drule meta_mp)
  apply (rule ballI)
  apply (drule_tac x=x in bspec)
  apply assumption
  apply (drule supp_fst)
  apply (auto simp add: fresh_def)
  apply (drule_tac x=\<theta> in meta_spec)
  apply (drule meta_mp)
  apply (rule ballI)
  apply (drule_tac x=x in bspec)
  apply assumption
  apply (drule supp_fst)
  apply (auto simp add: fresh_def)
  done

lemma psubst_nil: "[]\<lparr>t\<rparr> = t" "[]\<lparr>t'\<rparr>\<^sub>b = t'"
  by (induct t and t' rule: trm_btrm.inducts) (simp_all add: fresh_list_nil)

lemma psubst_cons:
  assumes "(supp (map fst \<theta>)::name set) \<sharp>* u"
  shows "((x, u) # \<theta>)\<lparr>t\<rparr> = \<theta>\<lparr>t[x\<mapsto>u]\<rparr>" and "((x, u) # \<theta>)\<lparr>t'\<rparr>\<^sub>b = \<theta>\<lparr>t'[x\<mapsto>u]\<^sub>b\<rparr>\<^sub>b"
  using assms
  by (nominal_induct t and t' avoiding: x u \<theta> rule: trm_btrm.strong_inducts)
    (simp_all add: fresh_list_nil fresh_list_cons psubst_forget)

lemma psubst_append:
  "(supp (map fst (\<theta>\<^sub>1 @ \<theta>\<^sub>2))::name set) \<sharp>* map snd (\<theta>\<^sub>1 @ \<theta>\<^sub>2) \<Longrightarrow> (\<theta>\<^sub>1 @ \<theta>\<^sub>2)\<lparr>t\<rparr> = \<theta>\<^sub>2\<lparr>\<theta>\<^sub>1\<lparr>t\<rparr>\<rparr>"
  by (induct \<theta>\<^sub>1 arbitrary: t)
    (simp_all add: psubst_nil split_paired_all supp_list_cons psubst_cons fresh_star_def
      fresh_list_cons fresh_list_append supp_list_append)

lemma abs_pat_psubst [simp]:
  "(supp p::name set) \<sharp>* \<theta> \<Longrightarrow> \<theta>\<lparr>\<lambda>[p]. t\<rparr>\<^sub>b = (\<lambda>[p]. \<theta>\<lparr>t\<rparr>\<^sub>b)"
  by (induct p arbitrary: t) (auto simp add: fresh_star_def supp_atm)

lemma valid_insert:
  assumes "valid (\<Delta> @ [(x, T)] @ \<Gamma>)"
  shows "valid (\<Delta> @ \<Gamma>)" using assms
  by (induct \<Delta>)
    (auto simp add: fresh_list_append fresh_list_cons)

lemma fresh_set:
  shows "y \<sharp> xs = (\<forall>x\<in>set xs. y \<sharp> x)"
  by (induct xs) (simp_all add: fresh_list_nil fresh_list_cons)

lemma context_unique:
  assumes "valid \<Gamma>"
  and "(x, T) \<in> set \<Gamma>"
  and "(x, U) \<in> set \<Gamma>"
  shows "T = U" using assms
  by induct (auto simp add: fresh_set fresh_prod fresh_atm)

lemma subst_type_aux:
  assumes a: "\<Delta> @ [(x, U)] @ \<Gamma> \<turnstile> t : T"
  and b: "\<Gamma> \<turnstile> u : U"
  shows "\<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : T" using a b
proof (nominal_induct \<Gamma>'\<equiv>"\<Delta> @ [(x, U)] @ \<Gamma>" t T avoiding: x u \<Delta> rule: typing.strong_induct)
  case (Var y T x u \<Delta>)
  from `valid (\<Delta> @ [(x, U)] @ \<Gamma>)`
  have valid: "valid (\<Delta> @ \<Gamma>)" by (rule valid_insert)
  show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T"
  proof cases
    assume eq: "x = y"
    from Var eq have "T = U" by (auto intro: context_unique)
    with Var eq valid show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T" by (auto intro: weakening)
  next
    assume ineq: "x \<noteq> y"
    from Var ineq have "(y, T) \<in> set (\<Delta> @ \<Gamma>)" by simp
    then show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T" using ineq valid by auto
  qed
next
  case (Tuple t\<^sub>1 T\<^sub>1 t\<^sub>2 T\<^sub>2)
  from refl `\<Gamma> \<turnstile> u : U`
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>1[x\<mapsto>u] : T\<^sub>1" by (rule Tuple)
  moreover from refl `\<Gamma> \<turnstile> u : U`
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>2[x\<mapsto>u] : T\<^sub>2" by (rule Tuple)
  ultimately have "\<Delta> @ \<Gamma> \<turnstile> \<langle>t\<^sub>1[x\<mapsto>u], t\<^sub>2[x\<mapsto>u]\<rangle> : T\<^sub>1 \<otimes> T\<^sub>2" ..
  then show ?case by simp
next
  case (Let p t T \<Delta>' s S)
  from refl `\<Gamma> \<turnstile> u : U`
  have "\<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : T" by (rule Let)
  moreover note `\<turnstile> p : T \<Rightarrow> \<Delta>'`
  moreover have "\<Delta>' @ (\<Delta> @ [(x, U)] @ \<Gamma>) = (\<Delta>' @ \<Delta>) @ [(x, U)] @ \<Gamma>" by simp
  then have "(\<Delta>' @ \<Delta>) @ \<Gamma> \<turnstile> s[x\<mapsto>u] : S" using `\<Gamma> \<turnstile> u : U` by (rule Let)
  then have "\<Delta>' @ \<Delta> @ \<Gamma> \<turnstile> s[x\<mapsto>u] : S" by simp
  ultimately have "\<Delta> @ \<Gamma> \<turnstile> (LET p = t[x\<mapsto>u] IN s[x\<mapsto>u]) : S"
    by (rule better_T_Let)
  moreover from Let have "(supp p::name set) \<sharp>* [(x, u)]"
    by (simp add: fresh_star_def fresh_list_nil fresh_list_cons)
  ultimately show ?case by simp
next
  case (Abs y T t S)
  have "(y, T) # \<Delta> @ [(x, U)] @ \<Gamma> = ((y, T) # \<Delta>) @ [(x, U)] @ \<Gamma>"
    by simp
  then have "((y, T) # \<Delta>) @ \<Gamma> \<turnstile> t[x\<mapsto>u] : S" using `\<Gamma> \<turnstile> u : U` by (rule Abs)
  then have "(y, T) # \<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : S" by simp
  then have "\<Delta> @ \<Gamma> \<turnstile> (\<lambda>y:T. t[x\<mapsto>u]) : T \<rightarrow> S"
    by (rule typing.Abs)
  moreover from Abs have "y \<sharp> [(x, u)]"
    by (simp add: fresh_list_nil fresh_list_cons)
  ultimately show ?case by simp
next
  case (App t\<^sub>1 T S t\<^sub>2)
  from refl `\<Gamma> \<turnstile> u : U`
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>1[x\<mapsto>u] : T \<rightarrow> S" by (rule App)
  moreover from refl `\<Gamma> \<turnstile> u : U`
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>2[x\<mapsto>u] : T" by (rule App)
  ultimately have "\<Delta> @ \<Gamma> \<turnstile> (t\<^sub>1[x\<mapsto>u]) \<cdot> (t\<^sub>2[x\<mapsto>u]) : S"
    by (rule typing.App)
  then show ?case by simp
qed

lemmas subst_type = subst_type_aux [of "[]", simplified]

lemma match_supp_fst:
  assumes "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>" shows "(supp (map fst \<theta>)::name set) = supp p" using assms
  by induct (simp_all add: supp_list_nil supp_list_cons supp_list_append)

lemma match_supp_snd:
  assumes "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>" shows "(supp (map snd \<theta>)::name set) = supp u" using assms
  by induct (simp_all add: supp_list_nil supp_list_cons supp_list_append trm.supp)

lemma match_fresh: "\<turnstile> p \<rhd> u \<Rightarrow> \<theta> \<Longrightarrow> (supp p::name set) \<sharp>* u \<Longrightarrow>
  (supp (map fst \<theta>)::name set) \<sharp>* map snd \<theta>"
  by (simp add: fresh_star_def fresh_def match_supp_fst match_supp_snd)

lemma match_type_aux:
  assumes "\<turnstile> p : U \<Rightarrow> \<Delta>"
  and "\<Gamma>\<^sub>2 \<turnstile> u : U"
  and "\<Gamma>\<^sub>1 @ \<Delta> @ \<Gamma>\<^sub>2 \<turnstile> t : T"
  and "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>"
  and "(supp p::name set) \<sharp>* u"
  shows "\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<lparr>t\<rparr> : T" using assms
proof (induct arbitrary: \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 t u T \<theta>)
  case (PVar x U)
  from `\<Gamma>\<^sub>1 @ [(x, U)] @ \<Gamma>\<^sub>2 \<turnstile> t : T` `\<Gamma>\<^sub>2 \<turnstile> u : U`
  have "\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> t[x\<mapsto>u] : T" by (rule subst_type_aux)
  moreover from `\<turnstile> PVar x U \<rhd> u \<Rightarrow> \<theta>` have "\<theta> = [(x, u)]"
    by cases simp_all
  ultimately show ?case by simp
next
  case (PTuple p S \<Delta>\<^sub>1 q U \<Delta>\<^sub>2)
  from `\<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> u \<Rightarrow> \<theta>` obtain u\<^sub>1 u\<^sub>2 \<theta>\<^sub>1 \<theta>\<^sub>2
    where u: "u = \<langle>u\<^sub>1, u\<^sub>2\<rangle>" and \<theta>: "\<theta> = \<theta>\<^sub>1 @ \<theta>\<^sub>2"
    and p: "\<turnstile> p \<rhd> u\<^sub>1 \<Rightarrow> \<theta>\<^sub>1" and q: "\<turnstile> q \<rhd> u\<^sub>2 \<Rightarrow> \<theta>\<^sub>2"
    by cases simp_all
  with PTuple have "\<Gamma>\<^sub>2 \<turnstile> \<langle>u\<^sub>1, u\<^sub>2\<rangle> : S \<otimes> U" by simp
  then obtain u\<^sub>1: "\<Gamma>\<^sub>2 \<turnstile> u\<^sub>1 : S" and u\<^sub>2: "\<Gamma>\<^sub>2 \<turnstile> u\<^sub>2 : U"
    by cases (simp_all add: ty.inject trm.inject)
  note u\<^sub>1
  moreover from `\<Gamma>\<^sub>1 @ (\<Delta>\<^sub>2 @ \<Delta>\<^sub>1) @ \<Gamma>\<^sub>2 \<turnstile> t : T`
  have "(\<Gamma>\<^sub>1 @ \<Delta>\<^sub>2) @ \<Delta>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> t : T" by simp
  moreover note p
  moreover from `supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u` and u
  have "(supp p::name set) \<sharp>* u\<^sub>1" by (simp add: fresh_star_def)
  ultimately have \<theta>\<^sub>1: "(\<Gamma>\<^sub>1 @ \<Delta>\<^sub>2) @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<^sub>1\<lparr>t\<rparr> : T"
    by (rule PTuple)
  note u\<^sub>2
  moreover from \<theta>\<^sub>1
  have "\<Gamma>\<^sub>1 @ \<Delta>\<^sub>2 @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<^sub>1\<lparr>t\<rparr> : T" by simp
  moreover note q
  moreover from `supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u` and u
  have "(supp q::name set) \<sharp>* u\<^sub>2" by (simp add: fresh_star_def)
  ultimately have "\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<^sub>2\<lparr>\<theta>\<^sub>1\<lparr>t\<rparr>\<rparr> : T"
    by (rule PTuple)
  moreover from `\<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> u \<Rightarrow> \<theta>` `supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u`
  have "(supp (map fst \<theta>)::name set) \<sharp>* map snd \<theta>"
    by (rule match_fresh)
  ultimately show ?case using \<theta> by (simp add: psubst_append)
qed

lemmas match_type = match_type_aux [where \<Gamma>\<^sub>1="[]", simplified]

inductive eval :: "trm \<Rightarrow> trm \<Rightarrow> bool" ("_ \<longmapsto> _" [60,60] 60)
where
  TupleL: "t \<longmapsto> t' \<Longrightarrow> \<langle>t, u\<rangle> \<longmapsto> \<langle>t', u\<rangle>"
| TupleR: "u \<longmapsto> u' \<Longrightarrow> \<langle>t, u\<rangle> \<longmapsto> \<langle>t, u'\<rangle>"
| Abs: "t \<longmapsto> t' \<Longrightarrow> (\<lambda>x:T. t) \<longmapsto> (\<lambda>x:T. t')"
| AppL: "t \<longmapsto> t' \<Longrightarrow> t \<cdot> u \<longmapsto> t' \<cdot> u"
| AppR: "u \<longmapsto> u' \<Longrightarrow> t \<cdot> u \<longmapsto> t \<cdot> u'"
| Beta: "x \<sharp> u \<Longrightarrow> (\<lambda>x:T. t) \<cdot> u \<longmapsto> t[x\<mapsto>u]"
| Let: "((supp p)::name set) \<sharp>* t \<Longrightarrow> distinct (pat_vars p) \<Longrightarrow>
    \<turnstile> p \<rhd> t \<Rightarrow> \<theta> \<Longrightarrow> (LET p = t IN u) \<longmapsto> \<theta>\<lparr>u\<rparr>"

equivariance match

equivariance eval

lemma match_vars:
  assumes "\<turnstile> p \<rhd> t \<Rightarrow> \<theta>" and "x \<in> supp p"
  shows "x \<in> set (map fst \<theta>)" using assms
  by induct (auto simp add: supp_atm)

lemma match_fresh_mono:
  assumes "\<turnstile> p \<rhd> t \<Rightarrow> \<theta>" and "(x::name) \<sharp> t"
  shows "\<forall>(y, t)\<in>set \<theta>. x \<sharp> t" using assms
  by induct auto

nominal_inductive2 eval
avoids
  Abs: "{x}"
| Beta: "{x}"
| Let: "(supp p)::name set"
  apply (simp_all add: fresh_star_def abs_fresh fin_supp)
  apply (rule psubst_fresh)
  apply simp
  apply simp
  apply (rule ballI)
  apply (rule psubst_fresh)
  apply (rule match_vars)
  apply assumption+
  apply (rule match_fresh_mono)
  apply auto
  done

lemma typing_case_Abs:
  assumes ty: "\<Gamma> \<turnstile> (\<lambda>x:T. t) : S"
  and fresh: "x \<sharp> \<Gamma>"
  and R: "\<And>U. S = T \<rightarrow> U \<Longrightarrow> (x, T) # \<Gamma> \<turnstile> t : U \<Longrightarrow> P"
  shows P using ty
proof cases
  case (Abs x' T' t' U)
  obtain y::name where y: "y \<sharp> (x, \<Gamma>, \<lambda>x':T'. t')"
    by (rule exists_fresh) (auto intro: fin_supp)
  from `(\<lambda>x:T. t) = (\<lambda>x':T'. t')` [symmetric]
  have x: "x \<sharp> (\<lambda>x':T'. t')" by (simp add: abs_fresh)
  have x': "x' \<sharp> (\<lambda>x':T'. t')" by (simp add: abs_fresh)
  from `(x', T') # \<Gamma> \<turnstile> t' : U` have x'': "x' \<sharp> \<Gamma>"
    by (auto dest: valid_typing)
  have "(\<lambda>x:T. t) = (\<lambda>x':T'. t')" by fact
  also from x x' y have "\<dots> = [(x, y)] \<bullet> [(x', y)] \<bullet> (\<lambda>x':T'. t')"
    by (simp only: perm_fresh_fresh fresh_prod)
  also have "\<dots> = (\<lambda>x:T'. [(x, y)] \<bullet> [(x', y)] \<bullet> t')"
    by (simp add: swap_simps perm_fresh_fresh)
  finally have "(\<lambda>x:T. t) = (\<lambda>x:T'. [(x, y)] \<bullet> [(x', y)] \<bullet> t')" .
  then have T: "T = T'" and t: "[(x, y)] \<bullet> [(x', y)] \<bullet> t' = t"
    by (simp_all add: trm.inject alpha)
  from Abs T have "S = T \<rightarrow> U" by simp
  moreover from `(x', T') # \<Gamma> \<turnstile> t' : U`
  have "[(x, y)] \<bullet> [(x', y)] \<bullet> ((x', T') # \<Gamma> \<turnstile> t' : U)"
    by (simp add: perm_bool)
  with T t y x'' fresh have "(x, T) # \<Gamma> \<turnstile> t : U"
    by (simp add: eqvts swap_simps perm_fresh_fresh fresh_prod)
  ultimately show ?thesis by (rule R)
qed simp_all

nominal_primrec ty_size :: "ty \<Rightarrow> nat"
where
  "ty_size (Atom n) = 0"
| "ty_size (T \<rightarrow> U) = ty_size T + ty_size U + 1"
| "ty_size (T \<otimes> U) = ty_size T + ty_size U + 1"
  by (rule TrueI)+

lemma bind_tuple_ineq:
  "ty_size (pat_type p) < ty_size U \<Longrightarrow> Bind U x t \<noteq> (\<lambda>[p]. u)"
  by (induct p arbitrary: U x t u) (auto simp add: btrm.inject)

lemma valid_appD: assumes "valid (\<Gamma> @ \<Delta>)"
  shows "valid \<Gamma>" "valid \<Delta>" using assms
  by (induct \<Gamma>'\<equiv>"\<Gamma> @ \<Delta>" arbitrary: \<Gamma> \<Delta>)
    (auto simp add: Cons_eq_append_conv fresh_list_append)

lemma valid_app_freshs: assumes "valid (\<Gamma> @ \<Delta>)"
  shows "(supp \<Gamma>::name set) \<sharp>* \<Delta>" "(supp \<Delta>::name set) \<sharp>* \<Gamma>" using assms
  by (induct \<Gamma>'\<equiv>"\<Gamma> @ \<Delta>" arbitrary: \<Gamma> \<Delta>)
    (auto simp add: Cons_eq_append_conv fresh_star_def
     fresh_list_nil fresh_list_cons supp_list_nil supp_list_cons fresh_list_append
     supp_prod fresh_prod supp_atm fresh_atm
     dest: notE [OF iffD1 [OF fresh_def]])

lemma perm_mem_left: "(x::name) \<in> ((pi::name prm) \<bullet> A) \<Longrightarrow> (rev pi \<bullet> x) \<in> A"
  by (drule perm_boolI [of _ "rev pi"]) (simp add: eqvts perm_pi_simp)

lemma perm_mem_right: "(rev (pi::name prm) \<bullet> (x::name)) \<in> A \<Longrightarrow> x \<in> (pi \<bullet> A)"
  by (drule perm_boolI [of _ pi]) (simp add: eqvts perm_pi_simp)

lemma perm_cases:
  assumes pi: "set pi \<subseteq> A \<times> A"
  shows "((pi::name prm) \<bullet> B) \<subseteq> A \<union> B"
proof
  fix x assume "x \<in> pi \<bullet> B"
  then show "x \<in> A \<union> B" using pi
    apply (induct pi arbitrary: x B rule: rev_induct)
    apply simp
    apply (simp add: split_paired_all supp_eqvt)
    apply (drule perm_mem_left)
    apply (simp add: calc_atm split: split_if_asm)
    apply (auto dest: perm_mem_right)
    done
qed

lemma abs_pat_alpha':
  assumes eq: "(\<lambda>[p]. t) = (\<lambda>[q]. u)"
  and ty: "pat_type p = pat_type q"
  and pv: "distinct (pat_vars p)"
  and qv: "distinct (pat_vars q)"
  shows "\<exists>pi::name prm. p = pi \<bullet> q \<and> t = pi \<bullet> u \<and>
    set pi \<subseteq> (supp p \<union> supp q) \<times> (supp p \<union> supp q)"
  using assms
proof (induct p arbitrary: q t u)
  case (PVar x T)
  note PVar' = this
  show ?case
  proof (cases q)
    case (PVar x' T')
    with `(\<lambda>[PVar x T]. t) = (\<lambda>[q]. u)`
    have "x = x' \<and> t = u \<or> x \<noteq> x' \<and> t = [(x, x')] \<bullet> u \<and> x \<sharp> u"
      by (simp add: btrm.inject alpha)
    then show ?thesis
    proof
      assume "x = x' \<and> t = u"
      with PVar PVar' have "PVar x T = ([]::name prm) \<bullet> q \<and>
        t = ([]::name prm) \<bullet> u \<and>
        set ([]::name prm) \<subseteq> (supp (PVar x T) \<union> supp q) \<times>
          (supp (PVar x T) \<union> supp q)" by simp
      then show ?thesis ..
    next
      assume "x \<noteq> x' \<and> t = [(x, x')] \<bullet> u \<and> x \<sharp> u"
      with PVar PVar' have "PVar x T = [(x, x')] \<bullet> q \<and>
        t = [(x, x')] \<bullet> u \<and>
        set [(x, x')] \<subseteq> (supp (PVar x T) \<union> supp q) \<times>
          (supp (PVar x T) \<union> supp q)"
        by (simp add: perm_swap swap_simps supp_atm perm_type)
      then show ?thesis ..
    qed
  next
    case (PTuple p\<^sub>1 p\<^sub>2)
    with PVar have "ty_size (pat_type p\<^sub>1) < ty_size T" by simp
    then have "Bind T x t \<noteq> (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. u)"
      by (rule bind_tuple_ineq)
    moreover from PTuple PVar
    have "Bind T x t = (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. u)" by simp
    ultimately show ?thesis ..
  qed
next
  case (PTuple p\<^sub>1 p\<^sub>2)
  note PTuple' = this
  show ?case
  proof (cases q)
    case (PVar x T)
    with PTuple have "ty_size (pat_type p\<^sub>1) < ty_size T" by auto
    then have "Bind T x u \<noteq> (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. t)"
      by (rule bind_tuple_ineq)
    moreover from PTuple PVar
    have "Bind T x u = (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. t)" by simp
    ultimately show ?thesis ..
  next
    case (PTuple p\<^sub>1' p\<^sub>2')
    with PTuple' have "(\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. t) = (\<lambda>[p\<^sub>1']. \<lambda>[p\<^sub>2']. u)" by simp
    moreover from PTuple PTuple' have "pat_type p\<^sub>1 = pat_type p\<^sub>1'"
      by (simp add: ty.inject)
    moreover from PTuple' have "distinct (pat_vars p\<^sub>1)" by simp
    moreover from PTuple PTuple' have "distinct (pat_vars p\<^sub>1')" by simp
    ultimately have "\<exists>pi::name prm. p\<^sub>1 = pi \<bullet> p\<^sub>1' \<and>
      (\<lambda>[p\<^sub>2]. t) = pi \<bullet> (\<lambda>[p\<^sub>2']. u) \<and>
      set pi \<subseteq> (supp p\<^sub>1 \<union> supp p\<^sub>1') \<times> (supp p\<^sub>1 \<union> supp p\<^sub>1')"
      by (rule PTuple')
    then obtain pi::"name prm" where
      "p\<^sub>1 = pi \<bullet> p\<^sub>1'" "(\<lambda>[p\<^sub>2]. t) = pi \<bullet> (\<lambda>[p\<^sub>2']. u)" and
      pi: "set pi \<subseteq> (supp p\<^sub>1 \<union> supp p\<^sub>1') \<times> (supp p\<^sub>1 \<union> supp p\<^sub>1')" by auto
    from `(\<lambda>[p\<^sub>2]. t) = pi \<bullet> (\<lambda>[p\<^sub>2']. u)`
    have "(\<lambda>[p\<^sub>2]. t) = (\<lambda>[pi \<bullet> p\<^sub>2']. pi \<bullet> u)"
      by (simp add: eqvts)
    moreover from PTuple PTuple' have "pat_type p\<^sub>2 = pat_type (pi \<bullet> p\<^sub>2')"
      by (simp add: ty.inject pat_type_perm_eq)
    moreover from PTuple' have "distinct (pat_vars p\<^sub>2)" by simp
    moreover from PTuple PTuple' have "distinct (pat_vars (pi \<bullet> p\<^sub>2'))"
      by (simp add: pat_vars_eqvt [symmetric] distinct_eqvt [symmetric])
    ultimately have "\<exists>pi'::name prm. p\<^sub>2 = pi' \<bullet> pi \<bullet> p\<^sub>2' \<and>
      t = pi' \<bullet> pi \<bullet> u \<and>
      set pi' \<subseteq> (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2')) \<times> (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2'))"
      by (rule PTuple')
    then obtain pi'::"name prm" where
      "p\<^sub>2 = pi' \<bullet> pi \<bullet> p\<^sub>2'" "t = pi' \<bullet> pi \<bullet> u" and
      pi': "set pi' \<subseteq> (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2')) \<times>
        (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2'))" by auto
    from PTuple PTuple' have "pi \<bullet> distinct (pat_vars \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>)" by simp
    then have "distinct (pat_vars \<langle>\<langle>pi \<bullet> p\<^sub>1', pi \<bullet> p\<^sub>2'\<rangle>\<rangle>)" by (simp only: eqvts)
    with `p\<^sub>1 = pi \<bullet> p\<^sub>1'` PTuple'
    have fresh: "(supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2') :: name set) \<sharp>* p\<^sub>1"
      by (auto simp add: set_pat_vars_supp fresh_star_def fresh_def eqvts)
    from `p\<^sub>1 = pi \<bullet> p\<^sub>1'` have "pi' \<bullet> (p\<^sub>1 = pi \<bullet> p\<^sub>1')" by (rule perm_boolI)
    with pt_freshs_freshs [OF pt_name_inst at_name_inst pi' fresh fresh]
    have "p\<^sub>1 = pi' \<bullet> pi \<bullet> p\<^sub>1'" by (simp add: eqvts)
    with `p\<^sub>2 = pi' \<bullet> pi \<bullet> p\<^sub>2'` have "\<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> = (pi' @ pi) \<bullet> \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>"
      by (simp add: pt_name2)
    moreover
    have "((supp p\<^sub>2 \<union> (pi \<bullet> supp p\<^sub>2')) \<times> (supp p\<^sub>2 \<union> (pi \<bullet> supp p\<^sub>2'))::(name \<times> name) set) \<subseteq>
      (supp p\<^sub>2 \<union> (supp p\<^sub>1 \<union> supp p\<^sub>1' \<union> supp p\<^sub>2')) \<times> (supp p\<^sub>2 \<union> (supp p\<^sub>1 \<union> supp p\<^sub>1' \<union> supp p\<^sub>2'))"
      by (rule subset_refl Sigma_mono Un_mono perm_cases [OF pi])+
    with pi' have "set pi' \<subseteq> \<dots>" by (simp add: supp_eqvt [symmetric])
    with pi have "set (pi' @ pi) \<subseteq> (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>) \<times>
      (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>)"
      by (simp add: Sigma_Un_distrib1 Sigma_Un_distrib2 Un_ac) blast
    moreover note `t = pi' \<bullet> pi \<bullet> u`
    ultimately have "\<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> = (pi' @ pi) \<bullet> q \<and> t = (pi' @ pi) \<bullet> u \<and>
      set (pi' @ pi) \<subseteq> (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp q) \<times>
        (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp q)" using PTuple
      by (simp add: pt_name2)
    then show ?thesis ..
  qed
qed

lemma typing_case_Let:
  assumes ty: "\<Gamma> \<turnstile> (LET p = t IN u) : U"
  and fresh: "(supp p::name set) \<sharp>* \<Gamma>"
  and distinct: "distinct (pat_vars p)"
  and R: "\<And>T \<Delta>. \<Gamma> \<turnstile> t : T \<Longrightarrow> \<turnstile> p : T \<Rightarrow> \<Delta> \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile> u : U \<Longrightarrow> P"
  shows P using ty
proof cases
  case (Let p' t' T \<Delta> u')
  then have "(supp \<Delta>::name set) \<sharp>* \<Gamma>"
    by (auto intro: valid_typing valid_app_freshs)
  with Let have "(supp p'::name set) \<sharp>* \<Gamma>"
    by (simp add: pat_var)
  with fresh have fresh': "(supp p \<union> supp p' :: name set) \<sharp>* \<Gamma>"
    by (auto simp add: fresh_star_def)
  from Let have "(\<lambda>[p]. Base u) = (\<lambda>[p']. Base u')"
    by (simp add: trm.inject)
  moreover from Let have "pat_type p = pat_type p'"
    by (simp add: trm.inject)
  moreover note distinct
  moreover from `\<Delta> @ \<Gamma> \<turnstile> u' : U` have "valid (\<Delta> @ \<Gamma>)"
    by (rule valid_typing)
  then have "valid \<Delta>" by (rule valid_appD)
  with `\<turnstile> p' : T \<Rightarrow> \<Delta>` have "distinct (pat_vars p')"
    by (simp add: valid_distinct pat_vars_ptyping)
  ultimately have "\<exists>pi::name prm. p = pi \<bullet> p' \<and> Base u = pi \<bullet> Base u' \<and>
    set pi \<subseteq> (supp p \<union> supp p') \<times> (supp p \<union> supp p')"
    by (rule abs_pat_alpha')
  then obtain pi::"name prm" where pi: "p = pi \<bullet> p'" "u = pi \<bullet> u'"
    and pi': "set pi \<subseteq> (supp p \<union> supp p') \<times> (supp p \<union> supp p')"
    by (auto simp add: btrm.inject)
  from Let have "\<Gamma> \<turnstile> t : T" by (simp add: trm.inject)
  moreover from `\<turnstile> p' : T \<Rightarrow> \<Delta>` have "\<turnstile> (pi \<bullet> p') : (pi \<bullet> T) \<Rightarrow> (pi \<bullet> \<Delta>)"
    by (simp add: ptyping.eqvt)
  with pi have "\<turnstile> p : T \<Rightarrow> (pi \<bullet> \<Delta>)" by (simp add: perm_type)
  moreover from Let
  have "(pi \<bullet> \<Delta>) @ (pi \<bullet> \<Gamma>) \<turnstile> (pi \<bullet> u') : (pi \<bullet> U)"
    by (simp add: append_eqvt [symmetric] typing.eqvt)
  with pi have "(pi \<bullet> \<Delta>) @ \<Gamma> \<turnstile> u : U"
    by (simp add: perm_type pt_freshs_freshs
      [OF pt_name_inst at_name_inst pi' fresh' fresh'])
  ultimately show ?thesis by (rule R)
qed simp_all

lemma preservation:
  assumes "t \<longmapsto> t'" and "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T" using assms
proof (nominal_induct avoiding: \<Gamma> T rule: eval.strong_induct)
  case (TupleL t t' u)
  from `\<Gamma> \<turnstile> \<langle>t, u\<rangle> : T` obtain T\<^sub>1 T\<^sub>2
    where "T = T\<^sub>1 \<otimes> T\<^sub>2" "\<Gamma> \<turnstile> t : T\<^sub>1" "\<Gamma> \<turnstile> u : T\<^sub>2"
    by cases (simp_all add: trm.inject)
  from `\<Gamma> \<turnstile> t : T\<^sub>1` have "\<Gamma> \<turnstile> t' : T\<^sub>1" by (rule TupleL)
  then have "\<Gamma> \<turnstile> \<langle>t', u\<rangle> : T\<^sub>1 \<otimes> T\<^sub>2" using `\<Gamma> \<turnstile> u : T\<^sub>2`
    by (rule Tuple)
  with `T = T\<^sub>1 \<otimes> T\<^sub>2` show ?case by simp
next
  case (TupleR u u' t)
  from `\<Gamma> \<turnstile> \<langle>t, u\<rangle> : T` obtain T\<^sub>1 T\<^sub>2
    where "T = T\<^sub>1 \<otimes> T\<^sub>2" "\<Gamma> \<turnstile> t : T\<^sub>1" "\<Gamma> \<turnstile> u : T\<^sub>2"
    by cases (simp_all add: trm.inject)
  from `\<Gamma> \<turnstile> u : T\<^sub>2` have "\<Gamma> \<turnstile> u' : T\<^sub>2" by (rule TupleR)
  with `\<Gamma> \<turnstile> t : T\<^sub>1` have "\<Gamma> \<turnstile> \<langle>t, u'\<rangle> : T\<^sub>1 \<otimes> T\<^sub>2"
    by (rule Tuple)
  with `T = T\<^sub>1 \<otimes> T\<^sub>2` show ?case by simp
next
  case (Abs t t' x S)
  from `\<Gamma> \<turnstile> (\<lambda>x:S. t) : T` `x \<sharp> \<Gamma>` obtain U where
    T: "T = S \<rightarrow> U" and U: "(x, S) # \<Gamma> \<turnstile> t : U"
    by (rule typing_case_Abs)
  from U have "(x, S) # \<Gamma> \<turnstile> t' : U" by (rule Abs)
  then have "\<Gamma> \<turnstile> (\<lambda>x:S. t') : S \<rightarrow> U"
    by (rule typing.Abs)
  with T show ?case by simp
next
  case (Beta x u S t)
  from `\<Gamma> \<turnstile> (\<lambda>x:S. t) \<cdot> u : T` `x \<sharp> \<Gamma>`
  obtain "(x, S) # \<Gamma> \<turnstile> t : T" and "\<Gamma> \<turnstile> u : S"
    by cases (auto simp add: trm.inject ty.inject elim: typing_case_Abs)
  then show ?case by (rule subst_type)
next
  case (Let p t \<theta> u)
  from `\<Gamma> \<turnstile> (LET p = t IN u) : T` `supp p \<sharp>* \<Gamma>` `distinct (pat_vars p)`
  obtain U \<Delta> where "\<turnstile> p : U \<Rightarrow> \<Delta>" "\<Gamma> \<turnstile> t : U" "\<Delta> @ \<Gamma> \<turnstile> u : T"
    by (rule typing_case_Let)
  then show ?case using `\<turnstile> p \<rhd> t \<Rightarrow> \<theta>` `supp p \<sharp>* t`
    by (rule match_type)
next
  case (AppL t t' u)
  from `\<Gamma> \<turnstile> t \<cdot> u : T` obtain U where
    t: "\<Gamma> \<turnstile> t : U \<rightarrow> T" and u: "\<Gamma> \<turnstile> u : U"
    by cases (auto simp add: trm.inject)
  from t have "\<Gamma> \<turnstile> t' : U \<rightarrow> T" by (rule AppL)
  then show ?case using u by (rule typing.App)
next
  case (AppR u u' t)
  from `\<Gamma> \<turnstile> t \<cdot> u : T` obtain U where
    t: "\<Gamma> \<turnstile> t : U \<rightarrow> T" and u: "\<Gamma> \<turnstile> u : U"
    by cases (auto simp add: trm.inject)
  from u have "\<Gamma> \<turnstile> u' : U" by (rule AppR)
  with t show ?case by (rule typing.App)
qed

end


subsection "Big-Step Operational Semantics of Commands"

theory Big_Step imports Com begin

text "The big-step semantics is a straight-forward inductive definition with concrete syntax."

inductive big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55) where

  Skip: "(SKIP, s) \<Rightarrow> s"

| Assign: "(x ::= a, s) \<Rightarrow> s (x := aval a s)"

| Seq: "\<lbrakk>(c1, s1) \<Rightarrow> s2; (c1, s2) \<Rightarrow> s3\<rbrakk> \<Longrightarrow>
        (c1;; c2, s1) \<Rightarrow> s3"

| IfTrue: "\<lbrakk>bval b s; (c1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow>
           (IF b THEN c1 ELSE c2, s) \<Rightarrow> t"

| IfFalse: "\<lbrakk>\<not>bval b s; (c2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow>
            (IF b THEN c1 ELSE c2, s) \<Rightarrow> t"

| WhileFalse: "\<not>bval b s \<Longrightarrow>
               (WHILE b DO c, s) \<Rightarrow> s"

| WhileTrue: "\<lbrakk>bval b s; (c, s1) \<Rightarrow> s2; (WHILE b DO c, s2) \<Rightarrow> s3\<rbrakk> \<Longrightarrow>
              (WHILE b DO c, s1) \<Rightarrow> s3"

schematic_goal ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply (rule Seq)
apply (rule Assign)
apply simp
apply (rule Assign)
done

thm ex [simplified]

code_pred big_step.

(* These didn't work:
values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"
values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"
*)

declare big_step.intros [intro]
thm big_step.induct

subsection "Rule Inversion"

(* Elimination rules: *)

inductive_cases SkipE [elim!]: "(SKIP, s) \<Rightarrow> t"
thm SkipE

inductive_cases AssignE [elim!]: "(x ::= a, s) \<Rightarrow> t"
thm AssignE

inductive_cases SeqE [elim!]: "(c1;; c2, s1) \<Rightarrow> s3"
thm SeqE

inductive_cases IfE [elim!]: "(IF b THEN c1 ELSE c2, s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE [elim]: "(WHILE b DO c, s) \<Rightarrow> t"
thm WhileE

(* Automatic example: *)
lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
by blast

(* Rule inversion by hand via the cases method: *)
lemma
  assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
  shows "t = s"
proof -
  from assms show ?thesis
  proof cases
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a, s) \<Rightarrow> s' \<longleftrightarrow> (s' = s (x := aval a s))"
by auto

lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

end