(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Cong_Subst_Pres
  imports Weak_Late_Cong_Subst Weak_Late_Cong_Pres
begin

lemma tauPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "\<tau>.(P) \<simeq>\<^sup>s \<tau>.(Q)"
using assms
by(force simp add: substClosed_def Weak_Late_Cong_Pres.tauPres)

lemma inputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   x :: name

  assumes PeqQ: "P \<simeq>\<^sup>s Q"

  shows "a<x>.P \<simeq>\<^sup>s a<x>.Q"
proof(auto simp add: substClosed_def)
  fix \<sigma> :: "(name \<times> name) list"
  {
    fix P Q a x \<sigma>
    assume "P \<simeq>\<^sup>s Q"
    then have "P[<\<sigma>>] \<simeq>\<^sup>s Q[<\<sigma>>]" by(rule partUnfold)
    then have "\<forall>y. (P[<\<sigma>>])[x::=y] \<simeq> (Q[<\<sigma>>])[x::=y]"
      apply(auto simp add: substClosed_def)
      by(erule_tac x="[(x, y)]" in allE) auto
    moreover assume "x \<sharp> \<sigma>"
    ultimately have "(a<x>.P)[<\<sigma>>] \<simeq> (a<x>.Q)[<\<sigma>>]" using weakBisimEqvt
      by(force intro: Weak_Late_Cong_Pres.inputPres)
  }
  note Goal = this

  obtain y::name where "y \<sharp> P" and "y \<sharp> Q" and "y \<sharp> \<sigma>"
    by(generate_fresh "name") auto
  from \<open>P \<simeq>\<^sup>s Q\<close> have "([(x, y)] \<bullet> P) \<simeq>\<^sup>s ([(x, y)] \<bullet> Q)" by(rule eqvtI)
  hence "(a<y>.([(x, y)] \<bullet> P))[<\<sigma>>] \<simeq> (a<y>.([(x, y)] \<bullet> Q))[<\<sigma>>]" using \<open>y \<sharp> \<sigma>\<close> by(rule Goal)
  moreover from \<open>y \<sharp> P\<close> \<open>y \<sharp> Q\<close> have "a<x>.P = a<y>.([(x, y)] \<bullet> P)" and "a<x>.Q = a<y>.([(x, y)] \<bullet> Q)"
    by(simp add: pi.alphaInput)+

  ultimately show "(a<x>.P)[<\<sigma>>] \<simeq> (a<x>.Q)[<\<sigma>>]" by simp
qed

lemma outputPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "a{b}.P \<simeq>\<^sup>s a{b}.Q"
using assms
by(force simp add: substClosed_def Weak_Late_Cong_Pres.outputPres)

  assumes "P \<simeq>\<^sup>s Q"

  shows "[a\<frown>b]P \<simeq>\<^sup>s [a\<frown>b]Q"
using assms
by(force simp add: substClosed_def Weak_Late_Cong_Pres.matchPres)

lemma sumPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "P \<oplus> R \<simeq>\<^sup>s Q \<oplus> R"
using assms
by(force simp add: substClosed_def Weak_Late_Cong_Pres.sumPres)

lemma parPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "P \<parallel> R \<simeq>\<^sup>s Q \<parallel> R"
using assms
by(force simp add: substClosed_def Weak_Late_Cong_Pres.parPres)

  assumes PeqQ: "P \<simeq>\<^sup>s Q"

  shows "<\<nu>x>P \<simeq>\<^sup>s <\<nu>x>Q"
proof(auto simp add: substClosed_def)
  fix s::"(name \<times> name) list"

  have Goal: "\<And>P Q x s. \<lbrakk>P[<s>] \<leadsto><weakBisim> Q[<s>]; x \<sharp> s\<rbrakk> \<Longrightarrow> (<\<nu>x>P)[<s>] \<leadsto><weakBisim> (<\<nu>x>Q)[<s>]"
    by(force intro: Weak_Late_Step_Sim_Pres.resPres Weak_Late_Bisim_Pres.resPres Weak_Late_Bisim.eqvt)

  have "\<exists>c::name. c \<sharp> (P, Q, s)"  by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP: "c \<sharp> P" and cFreshQ: "c \<sharp> Q" and cFreshs: "c \<sharp> s"
    by(force simp add: fresh_prod)

  from PeqQ have "P[<([(x, c)] \<bullet> s)>] \<leadsto><weakBisim> Q[<([(x, c)] \<bullet> s)>]" and
                 "Q[<([(x, c)] \<bullet> s)>] \<leadsto><weakBisim> P[<([(x, c)] \<bullet> s)>]"
    by(force simp add: congruenceSubstDef)+

  hence "([(x, c)] \<bullet> (P[<([(x, c)] \<bullet> s)>])) \<leadsto><weakBisim> ([(x, c)] \<bullet> (Q[<([(x, c)] \<bullet> s)>]))" and
        "([(x, c)] \<bullet> (Q[<([(x, c)] \<bullet> s)>])) \<leadsto><weakBisim> ([(x, c)] \<bullet> (P[<([(x, c)] \<bullet> s)>]))"
    by(blast intro: Weak_Late_Step_Sim.eqvtI Weak_Late_Bisim.eqvt)+

  hence "([(x, c)] \<bullet> P)[<s>] \<leadsto><weakBisim> ([(x, c)] \<bullet> Q)[<s>]" and
        "([(x, c)] \<bullet> Q)[<s>] \<leadsto><weakBisim> ([(x, c)] \<bullet> P)[<s>]" by simp+

  with cFreshs have "(<\<nu>c>([(x, c)] \<bullet> P))[<s>] \<leadsto><weakBisim> (<\<nu>c>([(x, c)] \<bullet> Q))[<s>]" and
                    "(<\<nu>c>([(x, c)] \<bullet> Q))[<s>] \<leadsto><weakBisim> (<\<nu>c>([(x, c)] \<bullet> P))[<s>]"
    by(blast intro: Goal)+

  moreover from cFreshP cFreshQ have "<\<nu>x>P = <\<nu>c>([(x, c)] \<bullet> P)" and "<\<nu>x>Q = <\<nu>c>([(x, c)] \<bullet> Q)"
    by(simp add: alphaRes)+

  ultimately show "(<\<nu>x>P)[<s>] \<simeq> (<\<nu>x>Q)[<s>]"
    by(simp add: congruence_def)
qed

lemma congruenceBang:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "!P \<simeq>\<^sup>s !Q"
using assms
by(force simp add: substClosed_def intro: Weak_Late_Cong_Pres.congruenceBang)

end


(*  Title:      HOL/Auth/n_germanSimp_lemma_on_inv__34.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_on_inv__34 imports n_germanSimp_base
begin
section{*All lemmas on causal relation between inv__34 and some rule r*}
lemma n_RecvReqSVsinv__34:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqS N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__34  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvReqE__part__0Vsinv__34:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqE__part__0 N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__34  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvReqE__part__1Vsinv__34:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqE__part__1 N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__34  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__0Vsinv__34:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__0  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__34  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__1Vsinv__34:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__1  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__34  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInvAckVsinv__34:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvAck  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__34  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Ident ''CurCmd'')) (Const Empty)) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv4) ''Cmd'')) (Const Inv))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvInvAckVsinv__34:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvInvAck  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__34  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P2 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntSVsinv__34:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntS  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__34  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__34:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__34  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntSVsinv__34:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntS  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__34  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Ident ''ExGntd'')) (Const true)) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv4) ''Cmd'')) (Const GntS))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntEVsinv__34:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntE  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__34  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_StoreVsinv__34:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__34  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end


subsection \<open>Formulation of a subject-subject communication policy and an information flow
policy, and showing both can be derived from subject-object configuration data\<close>

theory Step_policies
  imports Step_configuration
begin

subsubsection \<open>Specification\label{sect:policy_specification}\<close>

text \<open>In order to use CISK, we need an information flow policy @{term ifp}
  relation.
  We also express a static subject-subject @{term sp_spec_subj_obj} and subject-object @{term sp_spec_subj_subj} access control policy
  for the implementation of the model. The following locale summarizes
  all properties we need.\<close>

locale policy_axioms =
  fixes sp_spec_subj_obj :: "'a \<Rightarrow> obj_id_t \<Rightarrow> mode_t \<Rightarrow> bool"
    and sp_spec_subj_subj :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
    and ifp :: "'a \<Rightarrow> 'a \<Rightarrow> bool"

  assumes sp_spec_file_provider: "\<forall> p1 p2 f m1 m2 .
     sp_spec_subj_obj p1 (FILEP f) m1 \<and>
     sp_spec_subj_obj p2 (FILEP f) m2 \<longrightarrow> sp_spec_subj_subj p1 p2"

  and sp_spec_no_wronly_pages:
    "\<forall> p x . sp_spec_subj_obj p (PAGE x) WRITE \<longrightarrow> sp_spec_subj_obj p (PAGE x) READ"

  and ifp_reflexive:
    "\<forall> p . ifp p p"

  and ifp_compatible_with_sp_spec:
    "\<forall> a b . sp_spec_subj_subj a b \<longrightarrow> ifp a b \<and> ifp b a"

  and ifp_compatible_with_ipc:
    "\<forall> a b c x . (sp_spec_subj_subj a b
                  \<and> sp_spec_subj_obj b (PAGE x) WRITE  \<and> sp_spec_subj_obj c (PAGE x) READ)
                 \<longrightarrow> ifp a c"
begin (* empty *) end

subsubsection \<open>Derivation\<close>

text \<open>The configuration data only consists of a subject-object policy.
We derive the subject-subject policy and the information flow policy from the configuration data and prove that properties we specified in Section~\ref{sect:policy_specification} are satisfied.\<close>

locale abstract_policy_derivation =
  fixes configuration_subj_obj :: "'a \<Rightarrow> obj_id_t \<Rightarrow> mode_t \<Rightarrow> bool"
begin

  definition "sp_spec_subj_obj a x m \<equiv>
    configuration_subj_obj a x m \<or> (\<exists> y . x = PAGE y \<and> m = READ \<and> configuration_subj_obj a x WRITE)"

  definition "sp_spec_subj_subj a b \<equiv>
    \<exists> f m1 m2 . sp_spec_subj_obj a (FILEP f) m1 \<and> sp_spec_subj_obj b (FILEP f) m2"

  definition "ifp a b \<equiv>
     sp_spec_subj_subj a b
   \<or> sp_spec_subj_subj b a
   \<or> (\<exists> c y . sp_spec_subj_subj a c
            \<and> sp_spec_subj_obj c (PAGE y) WRITE
            \<and> sp_spec_subj_obj b (PAGE y) READ)
   \<or> (a = b)"

text \<open>Show that the policies specified in Section~\ref{sect:policy_specification} can be derived from the configuration and their definitions.\<close>

  lemma correct:
    shows "policy_axioms sp_spec_subj_obj sp_spec_subj_subj ifp"
  proof (unfold_locales)
    show sp_spec_file_provider:
      "\<forall> p1 p2 f m1 m2 .
           sp_spec_subj_obj p1 (FILEP f) m1 \<and>
           sp_spec_subj_obj p2 (FILEP f) m2 \<longrightarrow> sp_spec_subj_subj p1 p2"
      unfolding sp_spec_subj_subj_def by auto
    show sp_spec_no_wronly_pages:
      "\<forall> p x . sp_spec_subj_obj p (PAGE x) WRITE \<longrightarrow> sp_spec_subj_obj p (PAGE x) READ"
      unfolding sp_spec_subj_obj_def by auto
    show ifp_reflexive:
      "\<forall> p . ifp p p"
      unfolding ifp_def by auto
    show ifp_compatible_with_sp_spec:
      "\<forall> a b . sp_spec_subj_subj a b \<longrightarrow> ifp a b \<and> ifp b a"
      unfolding ifp_def by auto
    show ifp_compatible_with_ipc:
      "\<forall> a b c x . (sp_spec_subj_subj a b
                  \<and> sp_spec_subj_obj b (PAGE x) WRITE  \<and> sp_spec_subj_obj c (PAGE x) READ)
                 \<longrightarrow> ifp a c"
      unfolding ifp_def by auto
  qed
end

type_synonym sp_subj_subj_t = "partition_id_t \<Rightarrow> partition_id_t \<Rightarrow> bool"
type_synonym sp_subj_obj_t = "partition_id_t \<Rightarrow> obj_id_t \<Rightarrow> mode_t \<Rightarrow> bool"

interpretation Policy: abstract_policy_derivation "configured_subj_obj".
interpretation Policy_properties: policy_axioms Policy.sp_spec_subj_obj Policy.sp_spec_subj_subj Policy.ifp
  using Policy.correct by auto

lemma example_how_to_use_properties_in_proofs:
  shows "\<forall> p . Policy.ifp p p"
  using Policy_properties.ifp_reflexive by auto

end


(*
    Author:      David Sanan
    Maintainer:  David Sanan, sanan at ntu edu sg
    License:     LGPL
*)

(*  Title:      XVCGCon.thy
    Author:     David Sanan, NTU

Copyright (C) 2015-2016 David Sanan
Some rights reserved, NTU
This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

theory XVcgCon
imports VcgSeq

begin

text {* We introduce a syntactic variant of the let-expression so that we can
safely unfold it during verification condition generation. With the new
theorem attribute @{text "vcg_simp"} we can declare equalities to be used
by the verification condition generator, while simplifying assertions.
*}

syntax
"_Let'" :: "[letbinds, basicblock] => basicblock"  ("(LET (_)/ IN (_))" 23)

translations
  "_Let' (_binds b bs) e"  == "_Let' b (_Let' bs e)"
  "_Let' (_bind x a) e"    == "CONST Let' a (%x. e)"

lemma Let'_unfold : "Let' x f = f x"
  by (simp add: Let'_def Let_def)

lemma Let'_split_conv:
  "(Let' x  (\<lambda>p. (case_prod (f p) (g p)))) =
   (Let' x  (\<lambda>p. (f p) (fst (g p)) (snd (g p))))"
  by (simp add: split_def)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Automatic instantiation of an AutoCorres C state space as a separation algebra.
   FIXME: this is not quite finished. There are some proof tactics missing (see getter_rewrite etc)
*)
theory Auto_Separation_Algebra
imports "AutoCorres" "Sep_Algebra.Separation_Algebra"
keywords "sep_instance" :: thy_goal
begin

lemmas sep_conj_def = Separation_Algebra.sep_algebra_class.sep_conj_def

instantiation "unit" ::  stronger_sep_algebra
   begin
       definition "zero_unit \<equiv> ()"
       definition "plus_unit  \<equiv> (\<lambda>h2 h2.  ()) :: unit \<Rightarrow> unit \<Rightarrow> unit"
       definition "sep_disj_unit \<equiv>(\<lambda>h1 h2. True) :: unit \<Rightarrow> unit \<Rightarrow> bool"
     instance
 apply (standard)
   apply (clarsimp simp: zero_unit_def plus_unit_def sep_disj_unit_def)+
 done
end

instantiation "bool" ::  stronger_sep_algebra
   begin
       definition "zero_bool \<equiv> False"
       definition "plus_bool  \<equiv> (\<or>)"
       definition "sep_disj_bool \<equiv> \<lambda>p q. p \<longrightarrow> \<not>q"
     instance
 apply (standard)
   apply (auto simp: zero_bool_def plus_bool_def sep_disj_bool_def)+
 done
end

 instantiation "fun" :: (type,stronger_sep_algebra) stronger_sep_algebra
 begin
  definition "zero_fun   \<equiv> (\<lambda>x. 0)"
  definition "plus_fun f f'  \<equiv> (\<lambda>x. if f x = 0 then f' x else f x)"
  definition "sep_disj_fun   \<equiv> (\<lambda>f f'.  \<forall>x. (f x = 0 \<or> f' x = 0)) :: ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool "
 instance
  apply standard
       apply (fastforce simp: zero_fun_def sep_disj_fun_def plus_fun_def)+
  apply (clarsimp simp: zero_fun_def sep_disj_fun_def plus_fun_def, safe)
     apply (fastforce)+
  done
end

ML \<open>
type sep_info =
{
  plus_thm : thm option,
  disj_thm : thm option,
  zero_thm : thm option,
  sep_thms : thm list,
  sep_heap_arrows : (term * thm) Typtab.table,
  sep_heap_getters : (term * thm) Typtab.table,
  sep_heap_setters : (term * thm) Typtab.table
}

fun mk_sep_info (plus_thm : thm option) (disj_thm : thm option) (zero_thm : thm option)
  (sep_heap_arrows : (term * thm) Typtab.table) (sep_heap_getters :  (term * thm) Typtab.table)
  ( sep_heap_setters : (term * thm) Typtab.table) (sep_thms : thm list) =
  {plus_thm = plus_thm,
   disj_thm = disj_thm,
   zero_thm = zero_thm,
   sep_thms = sep_thms,
   sep_heap_arrows = sep_heap_arrows,
   sep_heap_getters = sep_heap_getters,
   sep_heap_setters = sep_heap_setters}
\<close>

ML \<open>

fun upd_plus_thm (sep_info : sep_info) plus =
  {plus_thm = plus,
   disj_thm = #disj_thm sep_info,
   zero_thm = #zero_thm sep_info,
   sep_thms = #sep_thms sep_info,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = #sep_heap_setters sep_info}

fun upd_disj_thm (sep_info : sep_info) disj =
  {plus_thm = #plus_thm sep_info,
   disj_thm = disj,
   zero_thm = #zero_thm sep_info,
   sep_thms = #sep_thms sep_info,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = #sep_heap_setters sep_info}

fun upd_zero_thm (sep_info : sep_info) zero =
  {plus_thm = #plus_thm sep_info,
   disj_thm = #disj_thm sep_info,
   zero_thm = zero,
   sep_thms = #sep_thms sep_info,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = #sep_heap_setters sep_info}

fun upd_heap_arrows (sep_info : sep_info) arr =
  {plus_thm = #plus_thm sep_info,
   disj_thm = #disj_thm sep_info,
   zero_thm = #zero_thm sep_info,
   sep_heap_arrows = arr,
   sep_thms = #sep_thms sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = #sep_heap_setters sep_info}

fun upd_heap_getters (sep_info : sep_info) getters =
  {plus_thm = #plus_thm sep_info,
   disj_thm = #disj_thm sep_info,
   zero_thm = #zero_thm sep_info,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = getters,
   sep_thms = #sep_thms sep_info,
   sep_heap_setters = #sep_heap_setters sep_info}

fun upd_heap_setters (sep_info : sep_info) setters =
  {plus_thm = #plus_thm sep_info,
   disj_thm = #disj_thm sep_info,
   zero_thm = #zero_thm sep_info,
   sep_thms = #sep_thms sep_info,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = setters}

fun upd_thms (sep_info : sep_info) thms =
  {plus_thm = #plus_thm sep_info,
   disj_thm = #disj_thm sep_info,
   zero_thm = #zero_thm sep_info,
   sep_thms = thms,
   sep_heap_arrows = #sep_heap_arrows sep_info,
   sep_heap_getters = #sep_heap_getters sep_info,
   sep_heap_setters = #sep_heap_setters sep_info
  }

\<close>

ML \<open>val print_type = dest_Type #> fst\<close>

ML \<open>fun mk_lifted_globals_record stateT rvals ctxt =
  let
      val xs =  rvals
      val state_t = "lifted_globals_ext" |> Syntax.read_term ctxt
  in
  betapplys (state_t, xs)
  |> Syntax.check_term ctxt
end;
\<close>

ML \<open>
val get_data = HeapInfo.get #> Symtab.lookup;

\<close>

ML\<open>
fun zero_lifted_globals subT global_types heap_types  =
  let fun make_zero_heap heap_type = (@{mk_term "(\<lambda>(_ :: ?'T ptr). arbitrary_zero :: (?'T))" ('T)} heap_type)
      fun make_zero_valid_heap heap_type = (@{mk_term "(\<lambda>_. False) ::  ?'T ptr \<Rightarrow> bool" ('T)} heap_type)
      fun make_zero global_type = @{mk_term "arbitrary_zero :: ?'T" ('T)} global_type
  in
  map make_zero global_types @
  map make_zero_heap heap_types @
  map make_zero_valid_heap heap_types @
  [@{term "0\<^sub>? :: 'b"}] |>
  mk_lifted_globals_record subT
end;

val make_conj = @{mk_term "?P \<and> ?Q" (P, Q)}

val make_conj_list = foldr1 make_conj;

fun get_more ctxt t = "lifted_globals.more" |> Syntax.read_term ctxt
\<close>

declare [[ML_print_depth=1000]]

ML \<open>
fun promote subT (Const (str, typ))  =   Const (str, subT --> (typ |> range_type));
\<close>

ML \<open>

fun sep_disj_lifted_globals ctxt subT heap_types heap_valid_getters h1 h2 =
let
  fun make_valid_disjoint heap_type  =
     let val heap_valid_getter = Typtab.lookup heap_valid_getters heap_type |> the |> Const |> promote subT
         (* val heap_valid_getter' = Const (fst heap_valid_getter, subT  --> (heap_valid_getter |> snd |> range_type)) *)
     in
      @{mk_term "(\<lambda> l r. ?f l  ## (?f r)) " (f)} (heap_valid_getter) $ h1 $ h2
     end;
  val typ =  subT |> dest_Type |> snd |> hd;
  val more = get_more ctxt subT
  (* val more_disjoint = @{mk_term "\<lambda>(f :: ?'T => ?'M :: stronger_sep_algebra) (l:: ?'T) (r :: ?'T ).
               (f l) ## (f r)" ('T, 'M)} (subT, typ) $ more $ h1 $ h2 *)
  val is_valid_disjoint = map make_valid_disjoint heap_types
in
  make_conj_list is_valid_disjoint
end;
\<close>

ML \<open>fun setup_heap_zero stateT heap_type global_types sep_info ctxt  =
let
  val (_, thm, ctxt) = Utils.define_const_args "zero_lifted_globals_ext" false (zero_lifted_globals stateT global_types heap_type ctxt) [] ctxt
in
  (upd_zero_thm sep_info (SOME thm), ctxt)
end\<close>

ML \<open>fun setup_heap_disj stateT heap_types heap_valid_getters sep_info ctxt  =
let
  val term = sep_disj_lifted_globals ctxt stateT heap_types heap_valid_getters (Free ("s0", stateT)) (Free ("s1", stateT))
  val (_, thm, ctxt') = Utils.define_const_args "sep_disj_lifted_globals_ext" false (term) [("s0", stateT), ("s1", stateT)] ctxt
in
  (upd_disj_thm sep_info (SOME thm), ctxt')
end\<close>

ML\<open>
fun plus_lifted_globals ctxt subT global_names global_getters heap_types heap_getters heap_valid_getters h1 h2 =
let

 fun make_global_plus global_name =
  let val global_getter = global_name |> Symtab.lookup global_getters |> the |> snd |> promote subT

       in @{mk_term "\<lambda>l r. arbitrary_add (?f l) (?f r)"(f)} global_getter $ h1 $ h2 end;

 fun make_heap_plus heap_type  =
  let val heap_getter = heap_type |> Typtab.lookup heap_getters |> the |> Const |> promote subT
      val heap_valid_getter = heap_type |> Typtab.lookup heap_valid_getters |> the |> Const |> promote subT
   in
   (@{mk_term
       "\<lambda>l r.
        \<lambda>x.  if ?valid l x then ?heap l x else if ?valid r x then ?heap r x else
             arbitrary_add ( ?heap l x) ( ?heap r x) " (heap, valid)}
              (heap_getter, heap_valid_getter) $ h1 $ h2)
  end;

 fun make_heap_valid_plus heap_type =
    let val heap_valid_getter = heap_type |> Typtab.lookup heap_valid_getters |> the |> Const |> promote subT
    in
    (@{mk_term "\<lambda>l r.
      (?valid l) + (?valid r)" (valid)} heap_valid_getter $ h1 $ h2)
    end;
 val typ =  subT |> dest_Type |> snd |> hd;
 val more = get_more ctxt subT

in
   map make_global_plus global_names @
   map make_heap_plus heap_types @
   map make_heap_valid_plus heap_types  @
  [(@{mk_term "\<lambda>l r.
               arbitrary_add (?f l) (?f r)" (f)} (more) $ h1 $ h2)]  |>
   mk_lifted_globals_record subT
end;

\<close>

ML \<open>
fun setup_heap_plus stateT global_names global_getters heap_types heap_getters heap_valid_getters sep_info ctxt =
let
  val term = (plus_lifted_globals ctxt stateT global_names global_getters heap_types
              heap_getters heap_valid_getters (Free ("s0", stateT)) (Free ("s1", stateT)) ctxt)
  val (_, thm, ctxt') = Utils.define_const_args "plus_lifted_globals_ext" false term
                          [("s0", stateT), ("s1", stateT)] ctxt
in
  (upd_plus_thm sep_info (SOME thm), ctxt')
end;

\<close>

ML \<open>

   fun make_arrow stateT heap_type heap_getters heap_valid_getters p v=
      let
          val heap_getter = heap_type |> Typtab.lookup heap_getters |> the |> Const
          val heap_valid  = heap_type |> Typtab.lookup heap_valid_getters |> the |> Const
        in
           @{mk_term "\<lambda>p v s. ?h s p = v \<and> ?v' s p" (h, v')}
             (heap_getter, heap_valid) $ p $ v
    end;

    fun split_on _ [] = [] |
        split_on f (x::xs) = if f x then xs else split_on f xs ;

    filter;

  fun hds s = String.substring (s,0,1)

   fun setup_arrows stateT heap_types heap_getters heap_valid_getters sep_info ctxt =
    let
         val (arrowt, _, ctxt') =  Utils.define_const_args "sep_generic_arrow" true
                               (@{mk_term "undefined :: (?'h ptr => ?'h => ?'T \<Rightarrow> bool)" ('T, 'h) } (stateT, @{typ 'h})) [] ctxt
         val ctxt'' = Local_Theory.notation true Syntax.mode_default
               [(arrowt, Infixl (Input.string "\<mapsto>s", 50, Position.no_range))] ctxt'
        fun setup_arrow (heap_type,(sep_info,ctxt)) =
         let
          val pointer = (Free ("p", Utils.gen_typ @{typ "'a ptr"} [heap_type]))
          val value = (Free ("v", heap_type))
          val term = (make_arrow stateT heap_type heap_getters heap_valid_getters pointer value)
          val arr_name = "sep_map_" ^  HeapLiftBase.name_from_type heap_type
          val arrow = "\<mapsto>"  ^ (HeapLiftBase.name_from_type heap_type |> hds)
          val fix = Infixl (Input.string arrow, 50, Position.no_range)
          val (t , thm, ctxt') = Utils.define_const_args arr_name false term
               [("p", Utils.gen_typ @{typ "'a ptr"} [heap_type]) ,  ("v", heap_type) ] ctxt
          val ctxt'' = Local_Theory.notation true Syntax.mode_default [(t , fix)] ctxt'
          val genarrowstr = arrowt |> dest_Const |> fst
          val sep_info = sep_info |> #sep_heap_arrows |> Typtab.update (heap_type, (t,thm)) |> upd_heap_arrows sep_info
          in
           (sep_info, ctxt'' |>
           Local_Theory.declaration {syntax = true, pervasive = false} (K (Adhoc_Overloading.generic_add_overloaded genarrowstr )) |>
           Local_Theory.declaration {syntax = true, pervasive = false} (K (Adhoc_Overloading.generic_add_variant genarrowstr t)))
         end;
      in foldr setup_arrow (sep_info,ctxt'') heap_types
   end;

\<close>

ML \<open>Utils.expand_type_abbrevs; @{theory}; Proof_Context.theory_of;\<close>

ML \<open>fun liberalise_type _ (Type (s,[])) = (s,[]) |> Type |
          liberalise_type t (Type (s,(xs))) = if (Long_Name.base_name s) = "lifted_globals_ext" then
                                               (Type (s, t :: (tl xs))) else
                                               (Type (s, map (liberalise_type t) (xs)));
\<close>

ML \<open>

fun make_rewrite heap_getters heap_setters heap_type sep_info ctxt =
     let
         val heap_getter  = heap_type |> Typtab.lookup heap_getters |> the |> Const
         val heap_setter  = heap_type |> Typtab.lookup heap_setters |> the |> Const
         val get_heap_term = @{mk_term "gets (\<lambda>s. ?f s p) " (f)} (heap_getter)
         val set_heap_term = @{mk_term "modify (?f (\<lambda>a. a(p := v)))" (f)} heap_setter
         val (t, thy, ctxt) = Utils.define_const_args ("get_" ^ (HeapLiftBase.name_from_type heap_type)) false get_heap_term [("p", Utils.gen_typ @{typ "'a ptr"} [heap_type])] ctxt
         val (t', thy', ctxt) = Utils.define_const_args ("set_" ^ (HeapLiftBase.name_from_type heap_type)) false set_heap_term [("p", Utils.gen_typ @{typ "'a ptr"} [heap_type]), ("v", heap_type)] ctxt
         val localise_term =  @{mk_term "modify (\<lambda>s. ?f (\<lambda>a. a(p:= f s)) (s)) \<equiv> do v <- gets f; ?g p v od" (f,g)} (heap_setter, t')
         val localise_simps = @{thms modify_def gets_def put_def fun_upd_def get_def return_def bind_def }
         val localise_term' = @{mk_term "Trueprop (modify (\<lambda>s. ?f (\<lambda>a. a(p:= f a s)) s) = do a <- gets (\<lambda>s. f (?h s) s); ?g p a od)" (f,h,g)} (heap_setter, heap_getter, t')
         val prove_localise = force_tac
                          (ctxt addsimps localise_simps addsimps [thy'])
         val localise_thm = Goal.prove ctxt ["f", "p"] [] localise_term (fn _ => prove_localise 1)
         val localise'_thm = Goal.prove ctxt ["f", "p"] [] localise_term' (fn _ => prove_localise 1)
         val sep_info =  sep_info |> #sep_thms |> (fn x => x @ [localise_thm, localise'_thm, Thm.symmetric thy,Thm.symmetric thy']) |> upd_thms sep_info
         val sep_info =  sep_info |> #sep_heap_getters |> Typtab.update (heap_type, (t,thy)) |> upd_heap_getters sep_info
         val sep_info =  sep_info |> #sep_heap_setters |> Typtab.update (heap_type, (t',thy')) |> upd_heap_setters sep_info
    in
        (sep_info, ctxt)
end;

\<close>

ML \<open>
Utils.named_cterm_instantiate;

fun make_struct_rewrite (structs : HeapLiftBase.struct_info list) sep_info ctxt =
   let
       val structs = structs |> map #field_info |> List.concat
       fun make_struct_rewrite_inner strct =
       let val getter = strct |> #getter
           val setter = strct |> #setter
           val getter_rewrite_term = @{mk_term "Trueprop (gets (\<lambda>s. ?P (f s) ) =
                                                          do c <- gets f;
                                                             return (?P c )
                                                          od )" (P)} getter
           val getter_rewrite_term' = @{mk_term "Trueprop (gets (\<lambda>s a. ?P (f s) ) =
                                                           do c <- gets f;
                                                           return (\<lambda>a. ?P c ) od )" (P)} getter
           val setter_rewrite_term = @{mk_term "Trueprop (gets (\<lambda>s . ?P (f s) (g s)) =
                                                          do c <- gets f;
                                                             d <- gets g;
                                                             return ( ?P c d )
                                                          od )" (P)} setter
          val setter_rewrite_term' = @{mk_term "Trueprop (gets (\<lambda>s a . ?P (f s) (g s)) =
                                               do c <- gets f;
                                                  d <- gets g;
                                                  return (\<lambda>a. ?P c d )
                                               od )" (P)} setter
           val getter_rewrite = Goal.prove ctxt ["f"] [] getter_rewrite_term (fn _ => Skip_Proof.cheat_tac ctxt 1) (* FIXME: unfinished *)
           val getter_rewrite' = Goal.prove ctxt ["f"] [] getter_rewrite_term' (fn _ => Skip_Proof.cheat_tac ctxt 1) (* FIXME: unfinished *)
           val setter_rewrite = Goal.prove ctxt ["f", "g"] [] setter_rewrite_term (fn _ => Skip_Proof.cheat_tac ctxt 1) (* FIXME: unfinished *)
           val setter_rewrite' = Goal.prove ctxt ["f", "g"] [] setter_rewrite_term' (fn _ => Skip_Proof.cheat_tac ctxt 1) (* FIXME: unfinished *)
       in [setter_rewrite,setter_rewrite', getter_rewrite, getter_rewrite'] end;
     fun upd_sep_info_list info xs = info |> #sep_thms |> (fn x => x @ xs) |> upd_thms info
   in map make_struct_rewrite_inner structs |> List.concat |> upd_sep_info_list sep_info
end;

fun make_rewrites heap_types heap_getters heap_setters structs sep_info ctxt =
  let
    val (sep_info, ctxt) = foldr (fn (htype, (info, ctxt)) => (make_rewrite heap_getters heap_setters htype info ctxt) ) (sep_info,ctxt) heap_types
    val sep_info = (make_struct_rewrite structs sep_info ctxt)
    val thms= sep_info |> #sep_thms
  in
     (sep_info, Utils.define_lemmas "sep_thms" thms ctxt |> snd )
end;
\<close>

ML \<open>val myss = ref HOL_basic_ss\<close>
ML \<open>val mythm = ref @{thms iffI}\<close>

ML \<open>fun prove_get_leaf_lemma heap_type ((sep_info : sep_info),  ctxt) =
          let
              val (heap_getter, heap_getter_def) = heap_type |> Typtab.lookup (#sep_heap_getters sep_info) |> the
              val (heap_arrow, heap_arrow_def) = heap_type |> Typtab.lookup (#sep_heap_arrows sep_info) |> the
              val plus_thm = sep_info |> #plus_thm |> the
              val proof_term = @{mk_term
                                 " Trueprop (
                                 \<lbrace>\<lambda>s. (?arr p x \<and>* R) s\<rbrace>
                                              ?getter p
                                 \<lbrace>\<lambda>rv. pred_conj (?arr p x \<and>* R) ( K (rv = x))\<rbrace> )" (arr,getter)}
                                (heap_arrow, heap_getter)
               val thms =  [@{thm sep_conj_def},
                            @{thm pred_conj_def},
                            heap_getter_def, heap_arrow_def, plus_thm]
               val name = heap_getter |> dest_Const |> fst |> Long_Name.base_name
               fun proof_tac ctxt = fast_force_tac (ctxt addsimps thms)
               val get_wp = Goal.prove ctxt ["x", "p","R"] [] proof_term (fn _ => proof_tac ctxt 1)
       in (sep_info, Utils.define_lemma (name ^ "_wp") get_wp ctxt |> snd) end;\<close>

ML \<open>
      fun prove_update_heap_lemma (heap_arrow, heap_arrow_def) heap_update  ctxt =
         let val proof_term = @{mk_term "((?arr p x) s \<Longrightarrow> (?arr p v) (?heap_update (\<lambda>s. fun_upd s p v) s))" (arr,heap_update)} (heap_arrow, heap_update)
             val proof = clarsimp_tac (ctxt addsimps [heap_arrow_def])
             in   Goal.prove ctxt ["x", "p", "v","s"] [] proof_term (fn x => proof 1)
      end;

      fun prove_set_leaf_lemma (heap_type, heap_updater) ((sep_info : sep_info),  ctxt) =
          let
              val (heap_setter, heap_setter_def) = heap_type |> Typtab.lookup (#sep_heap_setters sep_info) |> the
              val (heap_arrow, heap_arrow_def) = heap_type |> Typtab.lookup (#sep_heap_arrows sep_info) |> the
              val disj_thm = sep_info |> #disj_thm |> the
              val plus_thm = sep_info |> #plus_thm |> the
              val proof_term = @{mk_term
                                 " Trueprop (
                                 \<lbrace>\<lambda>s. (?arr p x \<and>* R) s\<rbrace>
                                              ?setter p v
                                 \<lbrace>\<lambda>rv. (?arr p v \<and>* R)\<rbrace> )" (arr,setter)}
                                (heap_arrow, heap_setter)
               val thms = @{thms fun_upd_def} @ [ heap_arrow_def, disj_thm, plus_thm]
               val name = heap_setter |> dest_Const |> fst |> Long_Name.base_name
               val heap_update_lemma = prove_update_heap_lemma (heap_arrow, heap_arrow_def) (heap_updater) ctxt
               fun proof_tac ctxt = clarsimp_tac (ctxt addsimps [heap_setter_def]) THEN'
                                    eresolve0_tac [@{thm sep_conjE}] THEN'
                                    resolve0_tac [@{thm sep_conjI}] THEN'
                                    eresolve0_tac [heap_update_lemma] THEN'
                                    fast_force_tac (ctxt) THEN_ALL_NEW
                                    fast_force_tac (ctxt addsimps thms)
               val set_wp = Goal.prove ctxt ["x", "p","R", "v"] [] proof_term (fn x =>  proof_tac (#context x) 1 )
       in (sep_info, Utils.define_lemma (name ^ "_wp") set_wp ctxt |> snd) end;\<close>

ML \<open>

fun prove_get_leaf_lemmas heap_types sep_info ctxt =
    foldr (uncurry prove_get_leaf_lemma) (sep_info, ctxt) heap_types

fun prove_set_leaf_lemmas heap_types sep_info ctxt =
   foldr (uncurry prove_set_leaf_lemma) (sep_info, ctxt) heap_types

\<close>

ML \<open>
   fun force_tac ctxt =
      SELECT_GOAL
     (Classical.clarify_tac ctxt 1 THEN
      IF_UNSOLVED (Simplifier.asm_full_simp_tac ctxt 1) THEN
      ALLGOALS (Classical.first_best_tac ctxt))
   fun zipWith (x::xs) (y::ys) f = f x y :: zipWith xs ys f |
       zipWith _ _ _ = []

    fun tester str thy =
         let val data = get_data thy str |> the |> #heap_info
             val typ = data |> #globals_type |> print_type
             val stateT = data |> #globals_type |> dest_Type ||> (K [@{typ 'b}]) |> Type
             val heap_types = data |> #heap_getters |> Typtab.dest |> map fst
             val heap_valid_getters = data |> #heap_valid_getters
             val heap_getters = data |> #heap_getters
             val heap_setters = data |> #heap_setters
             val global_types =  data |> #global_fields |> map (fn (_,_,z) => z)
             val global_names =  data |> #global_fields |> map (fn (x,_,_) => x)
             val global_getters = data |> #global_field_getters
             val structs = data |> #structs |> Symtab.dest |> map snd
             val sep_info = mk_sep_info NONE NONE NONE Typtab.empty Typtab.empty Typtab.empty []
             fun tup_list (x : sep_info)
                            = [x |> #plus_thm |> the,
                               x |> #zero_thm |> the,
                               x |> #disj_thm |> the]
             fun proof_tac thms ctxt =
                 let
                     val equality =  Proof_Context.get_thm ctxt "lifted_globals.equality" ;
                     val simpset = ctxt addsimps @{thms sep_add_left_commute sep_disj_commute sep_add_assoc sep_add_commute
                                                       left_commute zero_fun_def plus_fun_def sep_disj_fun_def zero_bool_def
                                                       commute} addsimps thms
                     val intros = [equality, @{thm ext}]
                  in
                         Class.standard_intro_classes_tac ctxt [] THEN
                         ((resolve_tac ctxt intros  ORELSE'
                           force_tac simpset ) |> REPEAT_ALL_NEW |> TRYALL)
                end;
      in thy
      |>  Class.instantiation ([typ], [("'a", @{sort type})], @{sort stronger_sep_algebra})
      |>  setup_heap_zero stateT heap_types global_types sep_info
      |-> setup_heap_disj stateT heap_types heap_valid_getters
      |-> setup_heap_plus stateT global_names global_getters heap_types heap_getters heap_valid_getters
      |-> setup_arrows stateT heap_types heap_getters heap_valid_getters
      |-> make_rewrites heap_types heap_getters heap_setters structs
      |> (fn (info, ctxt) => (info, (info,ctxt) |> (apfst (tup_list #> proof_tac) #-> Class.prove_instantiation_instance)))
      |-> prove_get_leaf_lemmas heap_types
      |-> prove_set_leaf_lemmas (heap_setters |> Typtab.dest |> map (fn x => x ||> Const)) |> snd
      end;

Adhoc_Overloading.is_overloaded @{context} "\<mapsto>"
\<close>

ML \<open>
val _ =
  Outer_Syntax.command @{command_keyword "sep_instance"} "instantiate and prove type arity"
  (Parse.path >>
   (fn str =>  tester str |> Toplevel.begin_local_theory true #> Toplevel.end_local_theory));

(* get_data @{theory} "swap.c" |> the |> #structs *)
\<close>

end


theory "Wide_Mouth_Frog_cert_auto"
imports
  "ESPLogic"
begin

(* section:  Wide Mouthed Frog  *)

(* text:
  The protocol is modeled after the description in the SPORE library:

    http://www.lsv.ens-cachan.fr/Software/spore/wideMouthedFrog.html

  Timestamps are modelled as fresh numbers that are immediatly made public.
 *)

role I
where "I =
  [ Send ''1_leak'' ( sN ''TimeI'' )
  , Send ''1'' <| sAV ''I'', sAV ''R'',
                  PEnc <| sC ''1'', sN ''TimeI'', sAV ''R'', sN ''kIR'' |>
                       ( sK ''I'' ''S'' )
               |>
  ]"

role R
where "R =
  [ Recv ''2'' <| sMV ''S'', sMV ''I'',
                  PEnc <| sC ''2'', sMV ''TimeS'', sMV ''I'', sMV ''kIR'' |>
                       ( PSymK ( sAV ''R'' ) ( sMV ''S'' ) )
               |>
  ]"

role S
where "S =
  [ Recv ''1'' <| sMV ''I'', sMV ''R'',
                  PEnc <| sC ''1'', sMV ''TimeI'', sMV ''R'', sMV ''kIR'' |>
                       ( PSymK ( sMV ''I'' ) ( sAV ''S'' ) )
               |>
  , Send ''2_leak'' ( sN ''TimeS'' )
  , Send ''2'' <| sAV ''S'', sMV ''I'',
                  PEnc <| sC ''2'', sN ''TimeS'', sMV ''I'', sMV ''kIR'' |>
                       ( PSymK ( sMV ''R'' ) ( sAV ''S'' ) )
               |>
  ]"

protocol WMF
where "WMF = { I, R, S }"

locale restricted_WMF_state = WMF_state

type_invariant WMF_msc_typing for WMF
where "WMF_msc_typing = mk_typing
  [ ((R, ''I''), (KnownT R_2))
  , ((S, ''I''), (KnownT S_1))
  , ((S, ''R''), (KnownT S_1))
  , ((R, ''S''), (KnownT R_2))
  , ((S, ''TimeI''), (SumT (KnownT S_1) (NonceT I ''TimeI'')))
  , ((R, ''TimeS''), (SumT (KnownT R_2) (NonceT S ''TimeS'')))
  , ((R, ''kIR''), (SumT (KnownT R_2) (NonceT I ''kIR'')))
  , ((S, ''kIR''), (SumT (KnownT S_1) (NonceT I ''kIR'')))
  ]"

sublocale WMF_state < WMF_msc_typing_state
proof -
  have "(t,r,s) : approx WMF_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF WMF_msc_typing.monoTyp, completeness_cases_rule])
    case (R_2_I t r s tid0)
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = R_2_I
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (R_2_S t r s tid0)
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = R_2_S
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (R_2_TimeS t r s tid0)
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = R_2_TimeS
    thus ?case
    proof(sources! "
        Enc {| LC ''2'', s(MV ''TimeS'' tid0), s(MV ''I'' tid0),
               s(MV ''kIR'' tid0)
            |}
            ( K ( s(AV ''R'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (R_2_kIR t r s tid0)
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = R_2_kIR
    thus ?case
    proof(sources! "
        Enc {| LC ''2'', s(MV ''TimeS'' tid0), s(MV ''I'' tid0),
               s(MV ''kIR'' tid0)
            |}
            ( K ( s(AV ''R'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
      case (S_2_enc tid1) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''1'', s(MV ''TimeI'' tid1), s(AV ''R'' tid0),
                              s(MV ''kIR'' tid0)
                           |}
                           ( K ( s(MV ''I'' tid0) ) ( s(AV ''S'' tid1) ) ) ")
      qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_1_I t r s tid0)
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_1_I
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_1_R t r s tid0)
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_1_R
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_1_TimeI t r s tid0)
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_1_TimeI
    thus ?case
    proof(sources! "
        Enc {| LC ''1'', s(MV ''TimeI'' tid0), s(MV ''R'' tid0),
               s(MV ''kIR'' tid0)
            |}
            ( K ( s(MV ''I'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_1_kIR t r s tid0)
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_1_kIR
    thus ?case
    proof(sources! "
        Enc {| LC ''1'', s(MV ''TimeI'' tid0), s(MV ''R'' tid0),
               s(MV ''kIR'' tid0)
            |}
            ( K ( s(MV ''I'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  qed
  thus "WMF_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context WMF_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* subsection:  Secrecy Properties  *)

lemma (in restricted_WMF_state) I_kIR_sec:
  assumes facts:
    "roleMap r tid0 = Some I"
    "RLKR(s(AV ''I'' tid0)) ~: reveals t"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "LN ''kIR'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''kIR'' tid0 ")
  case I_1_kIR note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
next
  case (S_2_kIR tid1) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''1'', s(MV ''TimeI'' tid1), s(MV ''R'' tid1), LN ''kIR'' tid0
                       |}
                       ( K ( s(MV ''I'' tid1) ) ( s(AV ''S'' tid1) ) ) ")
    case (I_1_enc tid2) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_WMF_state) S_kIR_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''I'' tid0)) ~: reveals t"
    "RLKR(s(MV ''R'' tid0)) ~: reveals t"
    "( tid0, S_1 ) : steps t"
    "s(MV ''kIR'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''1'', s(MV ''TimeI'' tid0), s(MV ''R'' tid0),
                          s(MV ''kIR'' tid0)
                       |}
                       ( K ( s(MV ''I'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (I_1_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: I_kIR_sec intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WMF_state) R_kIR_sec:
  assumes facts:
    "roleMap r tid0 = Some R"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "RLKR(s(MV ''I'' tid0)) ~: reveals t"
    "RLKR(s(MV ''S'' tid0)) ~: reveals t"
    "( tid0, R_2 ) : steps t"
    "s(MV ''kIR'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', s(MV ''TimeS'' tid0), s(MV ''I'' tid0),
                          s(MV ''kIR'' tid0)
                       |}
                       ( K ( s(AV ''R'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_2_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_kIR_sec intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

(* subsection:  Authentication Properties  *)

(* text:
  The authentication guarantee for the initiator is trivial because it does not
  receive any confirmation that the responder received the new session-key.
 *)

lemma (in restricted_WMF_state) S_ni_synch:
  assumes facts:
    "roleMap r tid3 = Some S"
    "RLKR(s(AV ''S'' tid3)) ~: reveals t"
    "RLKR(s(MV ''I'' tid3)) ~: reveals t"
    "( tid3, S_1 ) : steps t"
  shows
    "(?  tid1.
        roleMap r tid1 = Some I &
        s(AV ''I'' tid1) = s(MV ''I'' tid3) &
        s(AV ''R'' tid1) = s(MV ''R'' tid3) &
        s(AV ''S'' tid1) = s(AV ''S'' tid3) &
        LN ''TimeI'' tid1 = s(MV ''TimeI'' tid3) &
        LN ''kIR'' tid1 = s(MV ''kIR'' tid3) &
        predOrd t (St( tid1, I_1 )) (St( tid3, S_1 )))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''1'', s(MV ''TimeI'' tid3), s(MV ''R'' tid3),
                          s(MV ''kIR'' tid3)
                       |}
                       ( K ( s(MV ''I'' tid3) ) ( s(AV ''S'' tid3) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (I_1_enc tid4) note_unified facts = this facts
    thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WMF_state) R_ni_synch:
  assumes facts:
    "roleMap r tid2 = Some R"
    "RLKR(s(AV ''R'' tid2)) ~: reveals t"
    "RLKR(s(MV ''I'' tid2)) ~: reveals t"
    "RLKR(s(MV ''S'' tid2)) ~: reveals t"
    "( tid2, R_2 ) : steps t"
  shows
    "(?  tid1.
        (?  tid3.
           roleMap r tid1 = Some I &
           roleMap r tid3 = Some S &
           s(AV ''I'' tid1) = s(MV ''I'' tid2) &
           s(MV ''I'' tid2) = s(MV ''I'' tid3) &
           s(AV ''R'' tid1) = s(AV ''R'' tid2) &
           s(AV ''R'' tid2) = s(MV ''R'' tid3) &
           s(AV ''S'' tid1) = s(MV ''S'' tid2) &
           s(MV ''S'' tid2) = s(AV ''S'' tid3) &
           LN ''TimeI'' tid1 = s(MV ''TimeI'' tid3) &
           s(MV ''TimeS'' tid2) = LN ''TimeS'' tid3 &
           LN ''kIR'' tid1 = s(MV ''kIR'' tid2) &
           s(MV ''kIR'' tid2) = s(MV ''kIR'' tid3) &
           predOrd t (St( tid1, I_1 )) (St( tid3, S_1 )) &
           predOrd t (St( tid3, S_1 )) (St( tid3, S_2 )) &
           predOrd t (St( tid3, S_2 )) (St( tid2, R_2 ))))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', s(MV ''TimeS'' tid2), s(MV ''I'' tid2),
                          s(MV ''kIR'' tid2)
                       |}
                       ( K ( s(AV ''R'' tid2) ) ( s(MV ''S'' tid2) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_2_enc tid3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''1'', s(MV ''TimeI'' tid3), s(AV ''R'' tid2),
                            s(MV ''kIR'' tid2)
                         |}
                         ( K ( s(MV ''I'' tid2) ) ( s(AV ''S'' tid3) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    next
      case (I_1_enc tid4) note_unified facts = this facts
      thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end


subsection \<open>IMO 2006 SL - A6\<close>

theory IMO_2006_SL_A6
  imports Complex_Main
begin

theorem IMO_2006_SL_A6:
  fixes a b c :: real
  shows "Min {M. \<forall> a b c. \<bar>a * b * (a\<^sup>2 - b\<^sup>2) + b * c * (b\<^sup>2 - c\<^sup>2) + c * a * (c\<^sup>2 - a\<^sup>2)\<bar> \<le> M * (a\<^sup>2 + b\<^sup>2 + c\<^sup>2)\<^sup>2} = (sqrt 2) * 9 / 32"
  sorry

end


(*
 * Copyright 2016, 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 TypeTrackingTyping imports
  Cogent
begin

datatype type_split_kind = TSK_L | TSK_S | TSK_NS

datatype typing_tree = TyTrLeaf
    | TyTrSplit "type_split_kind option list" ctx typing_tree ctx typing_tree

type_synonym tree_ctx = "typing_tree * ctx"

fun
  apply_tsk :: "type_split_kind option \<Rightarrow> type option \<Rightarrow> type option \<times> type option"
where
    "apply_tsk None t = (None, t)"
  | "apply_tsk (Some TSK_L) t = (t, None)"
  | "apply_tsk (Some TSK_S) t = (t, t)"
  | "apply_tsk (Some TSK_NS) t = (map_option bang t, t)"

fun
  follow_typing_tree :: "tree_ctx \<Rightarrow> tree_ctx \<times> tree_ctx"
where
  "follow_typing_tree (TyTrSplit sps xs T1 ys T2, \<Gamma>)
    = ((T1, xs @ map (fst o Product_Type.split apply_tsk) (zip sps \<Gamma>)),
        (T2, ys @ map (snd o Product_Type.split apply_tsk) (zip sps \<Gamma>)))"

fun
  new_tt_types :: "tree_ctx \<Rightarrow> ctx"
where
    "new_tt_types (TyTrSplit sps xs T1 ys T2, \<Gamma>) = ys"
  | "new_tt_types (TyTrLeaf, v) = []"

fun
  follow_typing_tree_triv :: "tree_ctx \<Rightarrow> tree_ctx \<times> tree_ctx"
where
  "follow_typing_tree_triv (TyTrSplit sps xs T1 ys T2, \<Gamma>) = ((T1, xs @ \<Gamma>), (T2, ys @ \<Gamma>))"

definition
  composite_anormal_expr :: "'f expr \<Rightarrow> bool"
where
  "composite_anormal_expr x \<equiv> case x of Let _ _ \<Rightarrow> True
    | LetBang _ _ _ \<Rightarrow> True
    | Case _ _ _ _ \<Rightarrow> True
    | If _ _ _ \<Rightarrow> True
    | Split _ _ \<Rightarrow> True
    | Take _ _ _ \<Rightarrow> True
    | _ \<Rightarrow> False"

definition ttsplit_inner :: "kind env \<Rightarrow> type_split_kind option list \<Rightarrow> bool \<Rightarrow> ctx \<Rightarrow> ctx \<Rightarrow> ctx \<Rightarrow> bool"
where
  "ttsplit_inner K sps kndng \<Gamma>b \<Gamma>1 \<Gamma>2 = (
          length sps = length \<Gamma>b
        \<and> \<Gamma>1 = map (\<lambda> (sp, v). if sp \<in> {Some TSK_L, Some TSK_S} then v else None)
                        (zip sps \<Gamma>b)
        \<and> \<Gamma>2 = map (\<lambda> (sp, v). if sp = Some TSK_L then None else v)
                        (zip sps \<Gamma>b)
        \<and> Some TSK_NS \<notin> set sps
        \<and> (\<forall>t \<in> set \<Gamma>b. t \<noteq> None \<longrightarrow> kndng \<longrightarrow> (K \<turnstile> the t wellformed))
        \<and> (\<forall>i < length \<Gamma>b. nth sps i = Some TSK_S
            \<longrightarrow> nth \<Gamma>b i \<noteq> None \<and> (\<exists>k. K \<turnstile> (the (nth \<Gamma>b i)) :\<kappa> k \<and> S \<in> k)))"

definition ttsplit :: "kind env \<Rightarrow> tree_ctx \<Rightarrow> type_split_kind option list
        \<Rightarrow> ctx \<Rightarrow> tree_ctx \<Rightarrow> ctx \<Rightarrow> tree_ctx \<Rightarrow> bool"
where
  "ttsplit K \<Gamma> sps xs \<Gamma>1 ys \<Gamma>2 =
    (\<exists>\<Gamma>b \<Gamma>1a \<Gamma>2a T1 T2. \<Gamma> = (TyTrSplit sps xs T1 ys T2, \<Gamma>b)
        \<and> \<Gamma>1 = (T1, xs @ \<Gamma>1a)
        \<and> \<Gamma>2 = (T2, ys @ \<Gamma>2a)
        \<and> ttsplit_inner K sps True \<Gamma>b \<Gamma>1a \<Gamma>2a)"

lemma ttsplitI:
  "ttsplit_inner K sps True \<Gamma>b \<Gamma>1 \<Gamma>2 \<Longrightarrow> xs' = xs @ \<Gamma>1 \<Longrightarrow> ys' = ys @ \<Gamma>2
    \<Longrightarrow> ttsplit K (TyTrSplit sps xs T1 ys T2, \<Gamma>b) sps xs (T1, xs') ys (T2, ys')"
  by (simp add: ttsplit_def)

lemma forall_less_Suc_eq:
  "(\<forall>j < Suc i. P j) = (P 0 \<and> (\<forall>j < i. P (Suc j)))"
  by (auto simp add: less_Suc_eq_0_disj)

lemma ttsplit_innerI:
  "ttsplit_inner K sps kndng \<Gamma>b \<Gamma>1 \<Gamma>2
    \<Longrightarrow> ttsplit_inner K (None # sps) kndng (None # \<Gamma>b) (None # \<Gamma>1) (None # \<Gamma>2)"
  "(kndng \<Longrightarrow> K \<turnstile> \<gamma> :\<kappa>  k) \<Longrightarrow> ttsplit_inner K sps kndng \<Gamma>b \<Gamma>1 \<Gamma>2
    \<Longrightarrow> ttsplit_inner K (None # sps) kndng (Some \<gamma> # \<Gamma>b) (None # \<Gamma>1) (Some \<gamma> # \<Gamma>2)"
  "(kndng \<Longrightarrow> K \<turnstile> \<gamma> :\<kappa>  k) \<Longrightarrow> ttsplit_inner K sps kndng \<Gamma>b \<Gamma>1 \<Gamma>2
    \<Longrightarrow> ttsplit_inner K (Some TSK_L # sps) kndng (Some \<gamma> # \<Gamma>b) (Some \<gamma> # \<Gamma>1) (None # \<Gamma>2)"
  "K \<turnstile> \<gamma> :\<kappa>  k \<Longrightarrow> S \<in> k \<Longrightarrow> ttsplit_inner K sps kndng \<Gamma>b \<Gamma>1 \<Gamma>2
    \<Longrightarrow> ttsplit_inner K (Some TSK_S # sps) kndng (Some \<gamma> # \<Gamma>b) (Some \<gamma> # \<Gamma>1) (Some \<gamma> # \<Gamma>2)"
  "ttsplit_inner K [] kndng [] [] []"
  by (auto simp add: ttsplit_inner_def forall_less_Suc_eq)

lemma split_list_zip:
  "split K \<Gamma> \<Gamma>1 \<Gamma>2 = (length \<Gamma>1 = length \<Gamma> \<and> length \<Gamma>2 = length \<Gamma>
        \<and> (\<forall>(x, (y, z)) \<in> set (zip \<Gamma> (zip \<Gamma>1 \<Gamma>2)). split_comp K x y z))"
  apply (induct \<Gamma> arbitrary: \<Gamma>1 \<Gamma>2)
   apply (auto elim: split.cases intro: split_empty)[1]
  apply (rule iffI)
   apply (erule split.cases, simp, clarsimp)
  apply (clarsimp simp: length_Suc_conv)
  apply (rule split_cons, simp+)
  done

lemma ttsplit_imp_split:
  "ttsplit K \<Gamma> ijs xs \<Gamma>1 ys \<Gamma>2 \<Longrightarrow> (\<exists>\<Gamma>1a \<Gamma>2a. split K (snd \<Gamma>) \<Gamma>1a \<Gamma>2a
    \<and> snd \<Gamma>1 = xs @ \<Gamma>1a & snd \<Gamma>2 = ys @ \<Gamma>2a)"
  apply (clarsimp simp: ttsplit_def ttsplit_inner_def split_list_zip set_zip nth_enumerate_eq)
  apply (case_tac "\<Gamma>b ! i")
   apply (simp add: split_comp.none)
  apply (drule bspec, erule nth_mem)
  apply (drule spec, drule(1) mp)
  apply (auto intro: split_comp.intros)
  done

lemma split_imp_ttsplit:
  "split K \<Gamma> \<Gamma>1 \<Gamma>2 \<Longrightarrow> sps = map (\<lambda>i. if \<Gamma>1 ! i = None then None
            else if \<Gamma>2 ! i = None then Some TSK_L else Some TSK_S) [0 ..< length \<Gamma>]
    \<Longrightarrow> \<Gamma>1' = xs @ \<Gamma>1 \<Longrightarrow> \<Gamma>2' = ys @ \<Gamma>2
    \<Longrightarrow> ttsplit K (TyTrSplit sps xs tt ys tt2, \<Gamma>) sps xs
        (tt, \<Gamma>1') ys (tt2, \<Gamma>2')"
  apply (clarsimp simp: ttsplit_def ttsplit_inner_def split_list_zip nth_enumerate_eq
                        all_set_conv_all_nth o_def image_def
                  cong: if_cong)
  apply (intro conjI nth_equalityI allI impI, simp_all add: nth_enumerate_eq)
      apply (force elim!: split_comp.cases)+
  done

definition ttsplit_triv :: "tree_ctx \<Rightarrow> ctx \<Rightarrow> tree_ctx \<Rightarrow> ctx \<Rightarrow> tree_ctx \<Rightarrow> bool"
where
  "ttsplit_triv \<Gamma> xs \<Gamma>1 ys \<Gamma>2 = (\<exists>ijs \<Gamma>1a \<Gamma>2a.
    fst \<Gamma> = TyTrSplit ijs xs \<Gamma>1a ys \<Gamma>2a \<and> \<Gamma>1 = (\<Gamma>1a, xs @ snd \<Gamma>) \<and> \<Gamma>2 = (\<Gamma>2a, ys @ snd \<Gamma>))"

lemma ttsplit_trivI:
  "\<Gamma>1b = (\<Gamma>1a, xs @ \<Gamma>b) \<Longrightarrow> \<Gamma>2b = (\<Gamma>2a, ys @ \<Gamma>b) \<Longrightarrow> ttsplit_triv (TyTrSplit ijs xs \<Gamma>1a ys \<Gamma>2a, \<Gamma>b) xs \<Gamma>1b ys \<Gamma>2b"
  by (simp add: ttsplit_triv_def)

definition ttsplit_bang_inner :: "kind env \<Rightarrow> type_split_kind option list \<Rightarrow> ctx \<Rightarrow> ctx \<Rightarrow> ctx \<Rightarrow> bool"
where
  "ttsplit_bang_inner K sps \<Gamma>b \<Gamma>1 \<Gamma>2 = (
          length sps = length \<Gamma>b
        \<and> \<Gamma>1 = map (\<lambda> (sp, v). if sp \<in> {Some TSK_L, Some TSK_S} then v
                            else if sp = Some TSK_NS then map_option bang v else None)
                        (zip sps \<Gamma>b)
        \<and> \<Gamma>2 = map (\<lambda> (sp, v). if sp \<noteq> Some TSK_L then v else None)
                        (zip sps \<Gamma>b)
        \<and> (\<forall>i < length \<Gamma>b. nth sps i \<noteq> Some TSK_NS \<and> \<Gamma>b ! i \<noteq> None \<longrightarrow> (\<exists>k. K \<turnstile> the (\<Gamma>b ! i) :\<kappa> k))
        \<and> (\<forall>i < length \<Gamma>b. nth sps i = Some TSK_NS \<longrightarrow> nth \<Gamma>b i \<noteq> None)
        \<and> (\<forall>i < length \<Gamma>b. nth sps i = Some TSK_S
            \<longrightarrow> nth \<Gamma>b i \<noteq> None \<and> (\<exists>k. K \<turnstile> (the (nth \<Gamma>b i)) :\<kappa> k \<and> S \<in> k)))"

definition
  "ttsplit_bang is sps K \<Gamma> xs \<Gamma>1 ys \<Gamma>2 =
    (\<exists>\<Gamma>b \<Gamma>1a \<Gamma>2a T1 T2. \<Gamma> = (TyTrSplit sps xs T1 ys T2, \<Gamma>b)
        \<and> ttsplit_bang_inner K sps \<Gamma>b \<Gamma>1a \<Gamma>2a
        \<and> (\<forall>i < length \<Gamma>b. (i \<in> is) = (nth sps i = Some TSK_NS))
        \<and> \<Gamma>1 = (T1, xs @ \<Gamma>1a)
        \<and> \<Gamma>2 = (T2, ys @ \<Gamma>2a))"

lemma ttsplit_bangI:
  "xs' = xs @ \<Gamma>1a \<Longrightarrow> ys' = ys @ \<Gamma>2a
    \<Longrightarrow> is = set (map fst (filter (\<lambda>(i, v). v = Some TSK_NS) (enumerate 0 sps)))
    \<Longrightarrow> ttsplit_bang_inner K sps \<Gamma>b \<Gamma>1a \<Gamma>2a
    \<Longrightarrow> ttsplit_bang is sps K (TyTrSplit sps xs T1 ys T2, \<Gamma>b) xs (T1, xs') ys (T2, ys')"
  by (simp add: ttsplit_bang_def ttsplit_bang_inner_def in_set_enumerate_eq image_def)

lemma ttsplit_bang_innerI:
  "ttsplit_bang_inner K sps \<Gamma>b \<Gamma>1 \<Gamma>2
    \<Longrightarrow> ttsplit_bang_inner K (None # sps) (None # \<Gamma>b) (None # \<Gamma>1) (None # \<Gamma>2)"
  "K \<turnstile> \<gamma> :\<kappa>  k \<Longrightarrow> ttsplit_bang_inner K sps \<Gamma>b \<Gamma>1 \<Gamma>2
    \<Longrightarrow> ttsplit_bang_inner K (None # sps) (Some \<gamma> # \<Gamma>b) (None # \<Gamma>1) (Some \<gamma> # \<Gamma>2)"
  "K \<turnstile> \<gamma> :\<kappa>  k \<Longrightarrow> ttsplit_bang_inner K sps \<Gamma>b \<Gamma>1 \<Gamma>2
    \<Longrightarrow> ttsplit_bang_inner K (Some TSK_L # sps) (Some \<gamma> # \<Gamma>b) (Some \<gamma> # \<Gamma>1) (None # \<Gamma>2)"
  "K \<turnstile> \<gamma> :\<kappa>  k \<Longrightarrow> S \<in> k \<Longrightarrow> ttsplit_bang_inner K sps \<Gamma>b \<Gamma>1 \<Gamma>2
    \<Longrightarrow> ttsplit_bang_inner K (Some TSK_S # sps) (Some \<gamma> # \<Gamma>b) (Some \<gamma> # \<Gamma>1) (Some \<gamma> # \<Gamma>2)"
  "K \<turnstile> \<gamma> :\<kappa>  k \<Longrightarrow> \<gamma>' = bang \<gamma> \<Longrightarrow> ttsplit_bang_inner K sps \<Gamma>b \<Gamma>1 \<Gamma>2
    \<Longrightarrow> ttsplit_bang_inner K (Some TSK_NS # sps) (Some \<gamma> # \<Gamma>b) (Some \<gamma>' # \<Gamma>1) (Some \<gamma> # \<Gamma>2)"
  "ttsplit_bang_inner K [] [] [] []"
  by (auto simp add: ttsplit_bang_inner_def forall_less_Suc_eq)

lemma Suc_mem_image_pred:
  "0 \<notin> js \<Longrightarrow> (Suc n \<in> js) = (n \<in> pred ` js)"
  apply (simp add: image_def pred_def)
  apply (auto elim: rev_bexI split: nat.split_asm)
  done

lemma Suc_mem_image_pred_remove:
  "(n \<in> pred ` Set.remove 0 js) = (Suc n \<in> js)"
  by (simp add: Suc_mem_image_pred[symmetric])

lemma split_bang_nth:
  "split_bang K is \<Gamma> \<Gamma>1 \<Gamma>2 = (length \<Gamma>1 = length \<Gamma> \<and> length \<Gamma>2 = length \<Gamma>
        \<and> (\<forall>i < length \<Gamma>. if i \<in> is then \<Gamma>2 ! i = \<Gamma> ! i \<and> \<Gamma> ! i \<noteq> None
                \<and> \<Gamma>1 ! i = map_option bang (\<Gamma> ! i)
            else split_comp K (\<Gamma> ! i) (\<Gamma>1 ! i) (\<Gamma>2 ! i)))"
  apply (induct \<Gamma> arbitrary: "is" \<Gamma>1 \<Gamma>2)
   apply (auto elim: split_bang.cases intro: split_bang_empty)[1]
  apply (rule iffI)
   apply (erule split_bang.cases, simp)
    apply (clarsimp split del: split_if)
    apply (case_tac i)
     apply simp
    apply (simp add: Suc_mem_image_pred split del: split_if cong: if_cong)
   apply (clarsimp split del: split_if)
   apply (case_tac i)
    apply simp
   apply (simp add: Suc_mem_image_pred_remove split del: split_if cong: if_cong)
  apply (clarsimp simp: length_Suc_conv forall_less_Suc_eq)
  apply (frule_tac x=0 in spec, simp(no_asm_use))
  apply (case_tac "0 \<in> is", simp_all)
   apply clarsimp
   apply (erule split_bang_bang, rule refl)
   apply (simp add: Suc_mem_image_pred_remove split del: split_if cong: if_cong)
  apply (rule split_bang_cons, (simp_all add: Suc_mem_image_pred split del: split_if cong: if_cong))
  done

lemma ttsplit_bang_imp_split_bang:
  "ttsplit_bang is sps K \<Gamma> xs \<Gamma>1 ys \<Gamma>2 \<Longrightarrow>
    (\<exists>\<Gamma>1a \<Gamma>2a. split_bang K is (snd \<Gamma>) \<Gamma>1a \<Gamma>2a
        \<and> snd \<Gamma>1 = xs @ \<Gamma>1a & snd \<Gamma>2 = ys @ \<Gamma>2a)"
  apply (clarsimp simp: ttsplit_bang_def ttsplit_bang_inner_def
                        split_bang_nth nth_enumerate_eq
              split del: split_if cong: if_cong)
  apply clarsimp
  apply (case_tac "\<Gamma>b ! i")
   apply (simp add: split_comp.none)
  apply (drule spec, drule(1) mp)+
  apply (auto intro: split_comp.intros)
  done

lemma ttsplit_bang_inner_Cons:
  "ttsplit_bang_inner K sps \<Gamma>b \<Gamma>1 \<Gamma>2
    \<Longrightarrow> ttsplit_bang_inner K [sp] [\<gamma>] [\<gamma>1] [\<gamma>2]
    \<Longrightarrow> ttsplit_bang_inner K (sp # sps) (\<gamma> # \<Gamma>b) (\<gamma>1 # \<Gamma>1) (\<gamma>2 # \<Gamma>2)"
  by (simp add: ttsplit_bang_inner_def forall_less_Suc_eq)

lemma split_bang_imp_ttsplit:
  "split_bang K is \<Gamma> \<Gamma>1 \<Gamma>2
    \<Longrightarrow> \<exists>sps. \<forall>xs ys \<Gamma>1' \<Gamma>2'. (\<Gamma>1' = xs @ \<Gamma>1 \<longrightarrow> \<Gamma>2' = ys @ \<Gamma>2
    \<longrightarrow> ttsplit_bang is sps K (TyTrSplit sps xs tt ys tt2, \<Gamma>) xs
        (tt, \<Gamma>1') ys (tt2, \<Gamma>2'))"
  apply (clarsimp simp: ttsplit_bang_def)
  apply (induct rule: split_bang.induct)
    apply (simp add: ttsplit_bang_def ttsplit_bang_inner_def)
   apply (clarsimp simp: forall_less_Suc_eq Suc_mem_image_pred)
   apply (rule exI, rule conjI, erule_tac sp="if a = None then None
        else if b = None then Some TSK_L else Some TSK_S" in ttsplit_bang_inner_Cons)
    apply (auto simp: ttsplit_bang_inner_def elim!: split_comp.cases)[1]
   apply (simp add: Set.remove_def)
  apply (clarsimp simp: forall_less_Suc_eq Suc_mem_image_pred_remove)
  apply (rule exI, rule conjI, erule_tac sp="Some TSK_NS" in ttsplit_bang_inner_Cons)
   apply (simp add: ttsplit_bang_inner_def)
  apply simp
  done

lemma split_follow_typing_tree:
  "ttsplit K \<Gamma> sps' xs' \<Gamma>1 ys' \<Gamma>2 \<Longrightarrow> (\<Gamma>1, \<Gamma>2) = follow_typing_tree \<Gamma> \<and> new_tt_types \<Gamma> = ys'"
  "ttsplit_triv \<Gamma> xs' \<Gamma>1 ys' \<Gamma>2 \<Longrightarrow> (\<Gamma>1, \<Gamma>2) = follow_typing_tree_triv \<Gamma> \<and> new_tt_types \<Gamma> = ys'"
  "ttsplit_bang is sps' K \<Gamma> xs' \<Gamma>1 ys' \<Gamma>2 \<Longrightarrow> (\<Gamma>1, \<Gamma>2) = follow_typing_tree \<Gamma> \<and> new_tt_types \<Gamma> = ys'"
    apply (clarsimp simp: ttsplit_def ttsplit_inner_def ball_conj_distrib[symmetric])
    apply (case_tac a, simp_all)
    apply (case_tac aa, simp_all)
    apply (clarsimp elim!: in_set_zipE)
   apply (cases \<Gamma>, clarsimp simp: ttsplit_triv_def)
  apply (clarsimp simp: ttsplit_bang_def ttsplit_bang_inner_def ball_conj_distrib[symmetric])
  apply (case_tac a, simp_all)
  apply (case_tac aa, simp_all)
  done

inductive ttyping :: "('f \<Rightarrow> poly_type) \<Rightarrow> kind env \<Rightarrow> tree_ctx \<Rightarrow> 'f expr \<Rightarrow> type \<Rightarrow> bool"
          ("_, _, _ T\<turnstile> _ : _" [30,0,0,0,20] 60)
where

  ttyping_default: "\<lbrakk> \<not> composite_anormal_expr x
                    ; \<Xi>, K, \<Gamma> \<turnstile> x : t
                    \<rbrakk> \<Longrightarrow> \<Xi>, K, (tt, \<Gamma>) T\<turnstile> x : t"

| ttyping_split  : "\<lbrakk> ttsplit K \<Gamma> ijs [] \<Gamma>1 [Some t, Some u] \<Gamma>2
                   ; \<Xi>, K, \<Gamma>1 T\<turnstile> x : TProduct t u
                   ; \<Xi>, K, \<Gamma>2 T\<turnstile> y : t'
                   \<rbrakk> \<Longrightarrow> \<Xi>, K, \<Gamma> T\<turnstile> Split x y : t'"

| ttyping_let    : "\<lbrakk> ttsplit K \<Gamma> ijs [] \<Gamma>1 [Some t] \<Gamma>2
                   ; \<Xi>, K, \<Gamma>1 T\<turnstile> x : t
                   ; \<Xi>, K, \<Gamma>2 T\<turnstile> y : u
                   \<rbrakk> \<Longrightarrow> \<Xi>, K, \<Gamma> T\<turnstile> Let x y : u"

| ttyping_letb   : "\<lbrakk> ttsplit_bang is sps K \<Gamma> [] \<Gamma>1 [Some t] \<Gamma>2
                   ; \<Xi>, K, \<Gamma>1 T\<turnstile> x : t
                   ; \<Xi>, K, \<Gamma>2 T\<turnstile> y : u
                   ; K \<turnstile> t :\<kappa> k
                   ; E \<in> k
                   \<rbrakk> \<Longrightarrow> \<Xi>, K, \<Gamma> T\<turnstile> LetBang is x y : u"

| ttyping_case   : "\<lbrakk> ttsplit K \<Gamma> ijs [] \<Gamma>1 [] \<Gamma>2
                   ; ttsplit_triv \<Gamma>2 [Some t] \<Gamma>3 [Some (TSum (filter (\<lambda> x. fst x \<noteq> tag) ts))] \<Gamma>4
                   ; \<Xi>, K, \<Gamma>1 T\<turnstile> x : TSum ts
                   ; (tag, t) \<in> set ts
                   ; \<Xi>, K, \<Gamma>3 T\<turnstile> a : u
                   ; \<Xi>, K, \<Gamma>4 T\<turnstile> b : u
                   \<rbrakk> \<Longrightarrow> \<Xi>, K, \<Gamma> T\<turnstile> Case x tag a b : u"

| ttyping_if     : "\<lbrakk> ttsplit K \<Gamma> ijs [] \<Gamma>1 [] \<Gamma>2
                   ; ttsplit_triv \<Gamma>2 [] \<Gamma>3 [] \<Gamma>4
                   ; \<Xi>, K, \<Gamma>1 T\<turnstile> x : TPrim Bool
                   ; \<Xi>, K, \<Gamma>3 T\<turnstile> a : t
                   ; \<Xi>, K, \<Gamma>4 T\<turnstile> b : t
                   \<rbrakk> \<Longrightarrow> \<Xi>, K, \<Gamma> T\<turnstile> If x a b : t"

| ttyping_take   : "\<lbrakk> ttsplit K \<Gamma> ijs [] \<Gamma>1 [Some t, Some (TRecord (ts [f := (t, taken)]) s)] \<Gamma>2
                   ; \<Xi>, K, \<Gamma>1 T\<turnstile> e : TRecord ts s
                   ; s \<noteq> ReadOnly
                   ; f < length ts
                   ; ts ! f = (t, False)
                   ; K \<turnstile> t :\<kappa> k
                   ; S \<in> k \<or> taken
                   ; \<Xi>, K, \<Gamma>2 T\<turnstile> e' : u
                   \<rbrakk> \<Longrightarrow> \<Xi>, K, \<Gamma> T\<turnstile> Take e f e' : u"

lemma ttyping_imp_typing:
assumes "\<Xi>, K, \<Gamma> T\<turnstile> e : u"
shows   "\<Xi>, K, (snd \<Gamma>) \<turnstile> e : u"
using assms by ( induct rule: ttyping.induct
               , auto simp:  ttsplit_triv_def
                      dest!: ttsplit_imp_split ttsplit_bang_imp_split_bang
                      intro: typing_typing_all.intros)

lemma typing_imp_ttyping_induct:
shows " (\<Xi>, K, \<Gamma> \<turnstile> e : u \<Longrightarrow> (\<exists> tt. \<Xi>, K, (tt, \<Gamma>) T\<turnstile> e : u))"
and   " (\<Xi>, K, \<Gamma> \<turnstile>* es : us \<Longrightarrow> True)"
proof (induct rule: typing_typing_all.inducts)

qed (fastforce intro: ttyping_split[rotated] ttyping_let[rotated] ttyping_letb[rotated]
                      ttyping_case[rotated 2] ttyping_if[rotated 2] ttyping_take[rotated 2]
                      ttyping_default typing_typing_all.intros
            simp: composite_anormal_expr_def ttsplit_triv_def
            elim: split_imp_ttsplit
    | metis split_bang_imp_ttsplit ttyping_letb append.simps)+

lemma ttyping_eq_typing:
shows "\<Xi>, K, \<Gamma> \<turnstile> e : u = (\<exists> tt. \<Xi>, K, (tt, \<Gamma>) T\<turnstile> e : u)"
by (auto dest: ttyping_imp_typing typing_imp_ttyping_induct)

lemma split_type_wellformed:
  "K \<turnstile> \<Gamma> \<leadsto> \<Gamma>1 | \<Gamma>2 \<Longrightarrow> Some t \<in> set \<Gamma>
    \<Longrightarrow> K \<turnstile>  t wellformed"
  by (induct rule: split.induct, auto elim!: split_comp.cases)

lemma split_bang_type_wellformed:
  "split_bang K is \<Gamma> \<Gamma>1 \<Gamma>2 \<Longrightarrow> Some t \<in> set \<Gamma>
    \<Longrightarrow> Some t \<in> set \<Gamma>1 \<or> Some t \<in> set \<Gamma>2 \<or> K \<turnstile>  t wellformed"
  by (induct arbitrary: "is" rule: split_bang.induct,
    auto elim!: split_comp.cases)

lemma weakening_type_wellformed:
  "K \<turnstile> \<Gamma> \<leadsto>w \<Gamma>' \<Longrightarrow> Some t \<in> set \<Gamma>
    \<Longrightarrow> K \<turnstile>  t wellformed"
  apply (clarsimp simp: weakening_def in_set_conv_decomp
                        list_all2_append1 list_all2_Cons1)
  apply (erule weakening_comp.cases, auto)
  done

lemma typing_to_kinding_env:
  "\<Xi>, K, \<Gamma> \<turnstile> e : u \<Longrightarrow> Some t \<in> set \<Gamma>
    \<Longrightarrow> K \<turnstile>  t wellformed"
  "\<Xi>, K, \<Gamma> \<turnstile>* es : us \<Longrightarrow> Some t \<in> set \<Gamma>
    \<Longrightarrow> K \<turnstile>  t wellformed"
  by (induct rule: typing_typing_all.inducts,
    auto simp add: Cogent.empty_def
      dest: split_bang_type_wellformed weakening_type_wellformed split_type_wellformed)

lemma ttyping_type_wellformed:
  "\<lbrakk> \<Xi>, K, \<Gamma> T\<turnstile> x : \<tau> \<rbrakk>
    \<Longrightarrow> \<forall>t. Some t \<in> set (snd \<Gamma>) \<longrightarrow> K \<turnstile>  t wellformed"
  by (induct rule: ttyping.induct,
    auto dest!: ttsplit_imp_split ttsplit_bang_imp_split_bang
      dest: split_bang_type_wellformed split_type_wellformed typing_to_kinding_env)

end