section \<open>AsynchronousSystem\<close>

text \<open>
  \file{AsynchronousSystem} defines a message datatype and a transition system locale to
  model asynchronous distributed computation. It establishes a diamond property for a
  special reachability relation within such transition systems.
\<close>

theory AsynchronousSystem
imports Multiset
begin

text\<open>
  The formalization is type-parameterized over
  \begin{description}
    \item[\var{'p} process identifiers.] Corresponds to the set $P$ in Völzer.
      Finiteness is not yet demanded, but will be in \file{FLPSystem}.
    \item[\var{'s} process states.] Corresponds to $S$, countability is not
      imposed.
    \item[\var{'v} message payloads.] Corresponds to the interprocess
      communication part of $M$ from Völzer. The whole of $M$ is captured by
      \isb{messageValue}.
  \end{description}
\<close>

subsection\<open>Messages\<close>

text \<open>
  A \isb{message} is either an initial input message telling a process
  which value it should introduce to the consensus negotiation, a message
  to the environment communicating the consensus outcome, or a message
  passed from one process to some other.
\<close>

datatype ('p, 'v) message =
  InMsg 'p bool  ("<_, inM _>")
| OutMsg bool    ("<\<bottom>, outM _>")
| Msg 'p 'v      ("<_, _>")

text \<open>
  A message value is the content of a message, which a process may receive.
\<close>

datatype 'v messageValue =
  Bool bool
| Value 'v

primrec unpackMessage :: "('p, 'v) message \<Rightarrow> 'v messageValue"
where
  "unpackMessage <p, inM b>  = Bool b"
| "unpackMessage <p, v>      = Value v"
| "unpackMessage <\<bottom>, outM v> = Bool False"

primrec isReceiverOf ::
  "'p \<Rightarrow> ('p, 'v) message \<Rightarrow> bool"
where
   "isReceiverOf p1 (<p2, inM v>) = (p1 = p2)"
 | "isReceiverOf p1 (<p2, v>) =     (p1 = p2)"
 | "isReceiverOf p1 (<\<bottom>,outM v>) =  False"

lemma UniqueReceiverOf:
fixes
  msg  :: "('p, 'v) message" and
  p q :: 'p
assumes
  "isReceiverOf q msg"
  "p \<noteq> q"
shows
  "\<not> isReceiverOf p msg"
using assms by (cases msg, auto)

subsection\<open>Configurations\<close>

text \<open>
  Here we formalize a configuration as detailed in section 2 of Völzer's paper.

  Note that Völzer imposes the finiteness of the message multiset by
  definition while we do not do so. In \isb{FiniteMessages}
  We prove the finiteness to follow from the assumption that only
  finitely many messages can be sent at once.
\<close>

record ('p, 'v, 's) configuration =
  states :: "'p \<Rightarrow> 's"
  msgs :: "(('p, 'v) message) multiset"

text \<open>
  C.f. Völzer: \textquote{A step is identified with a message $(p, m)$. A step $(p, m)$ is enabled
  in a configuration c if $\var{msgs}_c$ contains the message $(p, m)$.}
\<close>

definition enabled ::
  "('p, 'v, 's) configuration \<Rightarrow> ('p, 'v) message \<Rightarrow> bool"
where
  "enabled cfg msg \<equiv> (msg \<in># msgs cfg)"

subsection \<open>The system locale\<close>

text \<open>
  The locale describing a system is derived by slight refactoring from the
  following passage of Völzer:
  \begin{displayquote}
    A process $p$ consists of an initial state $s_p \in S$ and a step transition
    function, which assigns to each pair $(m, s)$ of a message value $m$ and
    a process state $s$ a follower state and a finite set of messages (the
    messages to be sent by $p$ in a step).
  \end{displayquote}
\<close>

locale asynchronousSystem =
fixes
  trans :: "'p \<Rightarrow> 's \<Rightarrow> 'v messageValue \<Rightarrow> 's" and
  sends :: "'p \<Rightarrow> 's \<Rightarrow> 'v messageValue \<Rightarrow> ('p, 'v) message multiset" and
  start :: "'p \<Rightarrow> 's"
begin

abbreviation Proc :: "'p set"
where "Proc \<equiv> (UNIV :: 'p set)"

subsection \<open>The step relation\<close>

text \<open>
  The step relation is defined analogously to Völzer:
  \begin{displayquote}
    {[}If enabled, a step may{]} occur, resulting in a follower
    configuration $c^\prime$, where $c^\prime$ is obtained from $c$ by removing
    $(p, m)$ from $\var{msgs}_c$, changing $p$'s state and adding the set of
    messages to $\var{msgs}_c$ according to the step transition function
    associated with $p$. We denote this by $c \xrightarrow{p,m} c^\prime$.
  \end{displayquote}
  There are no steps consuming output messages.
\<close>

primrec steps ::
  "('p, 'v, 's) configuration
   \<Rightarrow> ('p, 'v) message
   \<Rightarrow> ('p, 'v, 's) configuration
   \<Rightarrow> bool"
   ("_ \<turnstile> _ \<mapsto> _" [70,70,70])
where
  StepInMsg: "cfg1 \<turnstile> <p, inM v> \<mapsto> cfg2 = (
  (\<forall> s. ((s = p) \<longrightarrow> states cfg2 p = trans p (states cfg1 p) (Bool v))
      \<and> ((s \<noteq> p) \<longrightarrow> states cfg2 s = states cfg1 s))
   \<and> enabled cfg1 <p, inM v>
   \<and> msgs cfg2 = (sends p (states cfg1 p) (Bool v)
                  \<union># (msgs cfg1 -# <p, inM v>)))"
| StepMsg: "cfg1 \<turnstile> <p, v> \<mapsto> cfg2 = (
  (\<forall> s. ((s = p) \<longrightarrow> states cfg2 p = trans p (states cfg1 p) (Value v))
      \<and> ((s \<noteq> p) \<longrightarrow> states cfg2 s = states cfg1 s))
   \<and> enabled cfg1 <p, v>
   \<and> msgs cfg2 = (sends p (states cfg1 p) (Value v)
                  \<union># (msgs cfg1 -# <p, v>)))"
| StepOutMsg: "cfg1 \<turnstile> <\<bottom>,outM v> \<mapsto> cfg2 =
    False"

text \<open>
  The system is distributed and asynchronous in the sense that the processing
  of messages only affects the process the message is directed to while the
  rest stays unchanged.
\<close>
lemma NoReceivingNoChange:
fixes
  cfg1 cfg2 :: "('p,'v,'s) configuration" and
  m :: "('p,'v) message" and
  p :: 'p
assumes
  Step: "cfg1 \<turnstile> m \<mapsto> cfg2" and
  Rec: "\<not> isReceiverOf p m"
shows
  "states cfg1 p = states cfg2 p "
proof(cases m)
  case (OutMsg b')
  thus ?thesis using Step by auto
next
  case (InMsg q b')
  assume CaseM:  "m = <q, inM b'>"
  with assms have "p \<noteq> q" by simp
  with Step CaseM show ?thesis by simp
next
  case (Msg q v')
  assume CaseM:  "m = <q, v'>"
  with assms have "p \<noteq> q" by simp
  with Step CaseM show ?thesis by simp
qed

lemma ExistsMsg:
fixes
  cfg1 cfg2 :: "('p,'v,'s) configuration" and
  m :: "('p,'v) message"
assumes
  Step: "cfg1 \<turnstile> m \<mapsto> cfg2"
shows
  "m \<in># (msgs cfg1)"
using assms enabled_def by (cases m, auto)

lemma NoMessageLossStep:
fixes
  cfg1 :: "('p,'v,'s) configuration" and
  cfg2 :: "('p,'v,'s) configuration" and
  p :: 'p and
  m :: "('p,'v) message" and
  m' :: "('p,'v) message"
assumes
  Step: "cfg1 \<turnstile> m \<mapsto> cfg2" and
  Rec1: "isReceiverOf p m" and
  Rec2: "\<not>isReceiverOf p m'"
shows
  "msgs cfg1 m' \<le> msgs cfg2 m'"
using assms by (induct m, simp_all, auto)

lemma OutOnlyGrowing:
fixes
  cfg1 cfg2 :: "('p,'v,'s) configuration" and
  b::bool and
  m::"('p, 'v) message" and
  p::'p
assumes
  "cfg1 \<turnstile> m \<mapsto> cfg2"
  "isReceiverOf p m"
shows
  "msgs cfg2 <\<bottom>, outM b>
  = (msgs cfg1 <\<bottom>, outM b>) +
    sends p (states cfg1 p) (unpackMessage m) <\<bottom>, outM b>"
proof(-)
  have "m = <\<bottom>, outM b> \<Longrightarrow> False" using assms proof(auto) qed
  hence MNotOut: "m \<noteq> <\<bottom>, outM b>" by auto
  have MsgFunction: "msgs cfg2
                    = ((sends p (states cfg1 p) (unpackMessage m))
                      \<union># ((msgs cfg1) -# m))"
  proof(cases m)
    case (InMsg pa bool)
    then have PaIsP: "pa = p" "(unpackMessage m) = Bool bool"
      using isReceiverOf_def assms(2) by (auto simp add: UniqueReceiverOf)
    hence "cfg1 \<turnstile> <p, inM bool> \<mapsto> cfg2" using assms(1) InMsg by simp
    hence "msgs cfg2 = (sends p (states cfg1 p) (Bool bool)
                       \<union># (msgs cfg1 -# <p, inM bool>))"
      by simp
    hence "msgs cfg2 = (sends p (states cfg1 p) (Bool bool)
                       \<union># (msgs cfg1 -# m))"
      using PaIsP(1) InMsg by simp
    thus ?thesis using StepInMsg assms PaIsP by simp
  next case (OutMsg b)
    hence False using assms by auto
    thus ?thesis by simp
  next case (Msg pa va)
    hence PaIsP: "pa = p" "(unpackMessage m) = Value va"
      using isReceiverOf_def assms(2) by (auto simp add: UniqueReceiverOf)
    hence "cfg1 \<turnstile> <p, va> \<mapsto> cfg2" using assms(1) Msg by simp
    hence "msgs cfg2 = (sends p (states cfg1 p) (Value va)
                       \<union># (msgs cfg1 -# <p, va>))" by simp
    hence "msgs cfg2 = (sends p (states cfg1 p) (Value va)
                       \<union># (msgs cfg1 -# m))"
      using PaIsP(1) Msg by simp
    thus ?thesis using StepInMsg assms PaIsP by simp
  qed
  have "((sends p (states cfg1 p) (unpackMessage m))
         \<union># ((msgs cfg1) -# m)) <\<bottom>, outM b>
       = ((sends p (states cfg1 p) (unpackMessage m))
         \<union># (msgs cfg1)) <\<bottom>, outM b>"
    using MNotOut by auto
  thus "msgs cfg2 <\<bottom>, outM b>
       = (msgs cfg1 <\<bottom>, outM b>) +
         sends p (states cfg1 p) (unpackMessage m) <\<bottom>, outM b>"
    using MsgFunction by simp
qed

lemma OtherMessagesOnlyGrowing:
fixes
  cfg1 :: "('p,'v,'s) configuration" and
  cfg2 :: "('p,'v,'s) configuration" and
  p :: 'p and
  m :: "('p,'v) message" and
  m' :: "('p,'v) message"
assumes
  Step: "cfg1 \<turnstile> m \<mapsto> cfg2" and
  "m \<noteq> m'"
shows
  "msgs cfg1 m' \<le> msgs cfg2 m'"
using assms by (cases m, auto)

text \<open>
  Völzer: \textquote{Note that steps are enabled persistently, i.e., an
  enabled step remains enabled as long as it does not occur.}
\<close>
lemma OnlyOccurenceDisables:
fixes
  cfg1 :: "('p,'v,'s) configuration" and
  cfg2 :: "('p,'v,'s) configuration" and
  p :: 'p and
  m :: "('p,'v) message" and
  m' :: "('p,'v) message"
assumes
  Step: "cfg1 \<turnstile> m \<mapsto> cfg2" and
  En: "enabled cfg1 m'" and
  NotEn: "\<not> (enabled cfg2 m')"
shows
  "m = m'"
using assms proof (cases m) print_cases
  case (InMsg p bool)
  with Step have "msgs cfg2 = (sends p (states cfg1 p) (Bool bool)
                              \<union># (msgs cfg1 -# <p, inM bool>))" by auto
  thus "m = m'" using InMsg En NotEn
    by (auto simp add: enabled_def, metis less_nat_zero_code)
next
  case (OutMsg bool)
  with Step show "m = m'" by auto
next
  case (Msg p v)
  with Step have "msgs cfg2 = (sends p (states cfg1 p) (Value v)
                              \<union># (msgs cfg1 -# <p, v>))" by auto
  thus "m = m'" using Msg En NotEn
    by (auto simp add: enabled_def, metis less_nat_zero_code)
qed

subsection \<open>Reachability\<close>

inductive reachable ::
  "  ('p, 'v, 's) configuration
  \<Rightarrow> ('p, 'v, 's) configuration
  \<Rightarrow> bool"
where
  init: "reachable cfg1 cfg1"
| step: "\<lbrakk> reachable cfg1 cfg2; (cfg2 \<turnstile> msg \<mapsto> cfg3) \<rbrakk>
          \<Longrightarrow> reachable cfg1 cfg3"

lemma ReachableStepFirst:
assumes
  "reachable cfg cfg'"
shows
  "cfg = cfg' \<or> (\<exists> cfg1 msg p . (cfg \<turnstile> msg \<mapsto> cfg1) \<and> enabled cfg msg
                    \<and> isReceiverOf p msg
                    \<and> reachable cfg1 cfg')"
using assms
by (induct rule: reachable.induct, auto,
    metis StepOutMsg ExistsMsg init enabled_def isReceiverOf.simps(1)
    isReceiverOf.simps(2) message.exhaust, metis asynchronousSystem.step)

lemma ReachableTrans:
fixes
  cfg1 cfg2 cfg3 :: "('p, 'v, 's ) configuration" and
  Q :: " 'p set"
assumes
  "reachable cfg1 cfg2" and
  "reachable cfg2 cfg3"
shows "reachable cfg1 cfg3"
proof -
  have "reachable cfg2 cfg3 \<Longrightarrow> reachable cfg1 cfg2 \<Longrightarrow> reachable cfg1 cfg3"
  proof (induct rule: reachable.induct, auto)
    fix cfg1' cfg2' msg cfg3'
    assume
      "reachable cfg1 cfg2'"
      "cfg2' \<turnstile> msg \<mapsto> cfg3'"
    thus "reachable cfg1 cfg3'" using reachable.simps by metis
  qed
  thus ?thesis using assms by simp
qed

definition stepReachable ::
    "('p, 'v, 's) configuration
  \<Rightarrow> ('p ,'v) message
  \<Rightarrow> ('p, 'v, 's) configuration
  \<Rightarrow> bool"
where
  "stepReachable c1 msg c2 \<equiv>
    \<exists> c' c''. reachable c1 c' \<and> (c' \<turnstile> msg \<mapsto> c'') \<and> reachable c'' c2 "

lemma StepReachable:
fixes
  cfg cfg' :: "('p,'v,'s) configuration" and
  msg :: "('p, 'v) message"
assumes
  "reachable cfg cfg'" and
  "enabled cfg msg" and
  "\<not> (enabled cfg' msg)"
shows "stepReachable cfg msg cfg'"
using assms
proof(induct rule: reachable.induct, simp)
  fix cfg1 cfg2 msga cfg3
  assume Step: "cfg2 \<turnstile> msga \<mapsto> cfg3" and
    ReachCfg1Cfg2: "reachable cfg1 cfg2" and
    IV: "(enabled cfg1 msg \<Longrightarrow> \<not> enabled cfg2 msg
        \<Longrightarrow> stepReachable cfg1 msg cfg2)" and
    AssumpInduct: "enabled cfg1 msg" "\<not> enabled cfg3 msg"
  have ReachCfg2Cfg3: "reachable cfg2 cfg3" using Step
    by (metis reachable.init reachable.step)
  show "stepReachable cfg1 msg cfg3"
  proof (cases "enabled cfg2 msg")
    assume AssumpEnabled: "enabled cfg2 msg"
    hence "msga = msg" using OnlyOccurenceDisables Step AssumpInduct(2) by blast
    thus "stepReachable cfg1 msg cfg3" using ReachCfg1Cfg2 Step
      unfolding stepReachable_def by (metis init)
  next
    assume AssumpNotEnabled: "\<not> enabled cfg2 msg"
    hence "stepReachable cfg1 msg cfg2" using IV AssumpInduct(1) by simp
    thus "stepReachable cfg1 msg cfg3"
      using ReachCfg2Cfg3 ReachableTrans asynchronousSystem.stepReachable_def
      by blast
  qed
qed

subsection \<open>Reachability with special process activity\<close>

text \<open>
  We say that \isb{qReachable cfg1 Q cfg2} iff cfg2 is reachable from cfg1
  only by activity of processes from Q.
\<close>
inductive qReachable ::
  "('p,'v,'s) configuration
  \<Rightarrow> 'p set
  \<Rightarrow> ('p,'v,'s) configuration
  \<Rightarrow> bool"
where
  InitQ: "qReachable cfg1 Q cfg1"
| StepQ: "\<lbrakk> qReachable cfg1 Q cfg2; (cfg2 \<turnstile> msg \<mapsto> cfg3) ;
            \<exists> p \<in> Q . isReceiverOf p msg \<rbrakk>
          \<Longrightarrow> qReachable cfg1 Q cfg3"

text \<open>
  We say that \isb{withoutQReachable cfg1 Q cfg2} iff cfg2 is reachable from cfg1
  with no activity of processes from Q.
\<close>
abbreviation withoutQReachable ::
   "('p,'v,'s) configuration
  \<Rightarrow> 'p set
  \<Rightarrow> ('p,'v,'s) configuration
  \<Rightarrow> bool"
where
  "withoutQReachable cfg1 Q cfg2 \<equiv>
    qReachable cfg1 ((UNIV :: 'p set ) - Q) cfg2"

text\<open>
  Obviously q-reachability (and thus also without-q-reachability) implies
  reachability.
\<close>
lemma QReachImplReach:
fixes
  cfg1 cfg2::  "('p, 'v, 's ) configuration" and
  Q :: " 'p set"
assumes
  "qReachable cfg1 Q cfg2"
shows
  "reachable cfg1 cfg2"
using assms
proof (induct rule: qReachable.induct)
  case InitQ thus ?case using reachable.simps by blast
next
  case StepQ thus ?case using reachable.step by simp
qed

lemma QReachableTrans:
fixes cfg1 cfg2 cfg3 :: "('p, 'v, 's ) configuration" and
  Q :: " 'p set"
assumes "qReachable cfg2 Q cfg3" and
  "qReachable cfg1 Q cfg2"
shows "qReachable cfg1 Q cfg3"
using assms
proof (induct rule: qReachable.induct, simp)
  case (StepQ)
  thus ?case using qReachable.simps by metis
qed

lemma NotInQFrozenQReachability:
fixes
  cfg1 cfg2 :: "('p,'v,'s) configuration" and
  p :: 'p and
  Q :: "'p set"
assumes
  "qReachable cfg1 Q cfg2" and
  "p \<notin> Q"
shows
  "states cfg1 p = states cfg2 p"
using assms
proof(induct rule: qReachable.induct, auto)
  fix cfg1' Q' cfg2' msg cfg3 p'
  assume "qReachable cfg1' Q' cfg2'"
  assume Step: "cfg2' \<turnstile> msg \<mapsto> cfg3"
  assume Rec: "isReceiverOf p' msg"
  assume "p' \<in> Q'"  "p \<notin> Q'"
  hence notEq: "p \<noteq> p'" by blast
  with Rec have "\<not> (isReceiverOf p msg)" by (cases msg, simp_all)
  thus "states cfg2' p = states cfg3 p"
    using Step NoReceivingNoChange by simp
qed

corollary WithoutQReachablFrozenQ:
fixes
  cfg1 cfg2 :: "('p,'v,'s) configuration" and
  p :: 'p and
  Q :: "'p set"
assumes
  Steps: "withoutQReachable cfg1 Q cfg2" and
  P: "p \<in> Q"
shows
  "states cfg1 p = states cfg2 p"
using assms NotInQFrozenQReachability by simp

lemma NoActivityNoMessageLoss :
fixes
  cfg1 cfg2 :: "('p,'v,'s) configuration" and
  p :: 'p and
  Q :: "'p set" and
  m' :: "('p, 'v) message"
assumes
  "qReachable cfg1 Q cfg2" and
  "p \<notin> Q" and
  "isReceiverOf p m'"
shows
  "(msgs cfg1 m') \<le> (msgs cfg2 m')"
using assms
proof (induct rule: qReachable.induct, simp)
  case (StepQ cfg1' Q' cfg2' msg cfg3)
  then obtain p' where
    P': "p' \<in> Q'" "isReceiverOf p' msg" "p \<noteq> p'" by blast
  with assms(3) have "\<not>(isReceiverOf p' m')"
    by (cases m', simp_all)
  with NoMessageLossStep StepQ(3) P'
    have "msgs cfg2' m' \<le> msgs cfg3 m'"
    by simp
  with StepQ
    show "msgs cfg1' m' \<le> msgs cfg3 m'" by simp
qed

lemma NoMessageLoss:
fixes
  cfg1 cfg2 :: "('p,'v,'s) configuration" and
  p :: 'p and
  Q :: "'p set" and
  m' :: "('p, 'v) message"
assumes
  "withoutQReachable cfg1 Q cfg2" and
  "p \<in> Q" and
  "isReceiverOf p m'"
shows
  "(msgs cfg1 m') \<le> (msgs cfg2 m')"
using assms NoActivityNoMessageLoss by simp

lemma NoOutMessageLoss:
fixes
  cfg1 cfg2 :: "('p,'v,'s) configuration" and
  v :: bool
assumes
  "reachable cfg1 cfg2"
shows
  "(msgs cfg1 <\<bottom>, outM v>) \<le> (msgs cfg2 <\<bottom>, outM v>)"
using assms
proof(induct rule: reachable.induct, auto)
  fix cfg1 cfg' msg cfg2
  assume AssInduct:
    "reachable cfg1 cfg'"
    "msgs cfg1 <\<bottom>, outM v> \<le> msgs cfg' <\<bottom>, outM v>"
    "cfg' \<turnstile> msg \<mapsto> cfg2"
  from AssInduct(3) have "msgs cfg' <\<bottom>, outM v> \<le> msgs cfg2 <\<bottom>, outM v>"
    by (cases msg, auto)
  with AssInduct(2) show " msgs cfg1 <\<bottom>, outM v> \<le> msgs cfg2 <\<bottom>, outM v>"
    using le_trans by blast
qed

lemma StillEnabled:
fixes
  cfg1 cfg2:: "('p,'v,'s) configuration" and
  p :: 'p and
  msg :: "('p,'v) message" and
  Q :: "'p set"
assumes
  "withoutQReachable cfg1 Q cfg2" and
  "p \<in> Q" and
  "isReceiverOf p msg" and
  "enabled cfg1 msg"
shows
  "enabled cfg2 msg"
using assms enabled_def NoMessageLoss
  by (metis le_0_eq neq0_conv)

subsection\<open>Initial reachability\<close>

definition initial ::
  "('p, 'v, 's) configuration \<Rightarrow> bool"
where
  "initial cfg \<equiv>
        (\<forall> p::'p . (\<exists> v::bool . ((msgs cfg (<p, inM v>)) = 1)))
      \<and> (\<forall> p m1 m2 . ((m1 \<in># (msgs cfg)) \<and> (m2 \<in># (msgs cfg))
         \<and> isReceiverOf p m1 \<and> isReceiverOf p m2) \<longrightarrow> (m1 = m2))
      \<and> (\<forall> v::bool . (msgs cfg) (<\<bottom>, outM v>) = 0)
      \<and> (\<forall> p v. (msgs cfg) (<p, v>) = 0)
      \<and> states cfg = start"

definition initReachable ::
  "('p, 'v, 's) configuration \<Rightarrow> bool"
where
  "initReachable cfg \<equiv> \<exists>cfg0 . initial cfg0 \<and> reachable cfg0 cfg"

lemma InitialIsInitReachable :
assumes "initial c"
shows "initReachable c"
  using assms reachable.init
  unfolding initReachable_def by blast

subsection \<open>Diamond property of reachability\<close>

lemma DiamondOne:
fixes
  cfg cfg1 cfg2 :: "('p,'v,'s) configuration" and
  p q :: 'p and
  m m' :: "('p,'v) message"
assumes
  StepP: "cfg \<turnstile> m  \<mapsto> cfg1" and
  PNotQ: "p \<noteq> q" and
  Rec: "isReceiverOf p m" "\<not> (isReceiverOf p m')" and
  Rec': "isReceiverOf q m'" "\<not> (isReceiverOf q m)" and
  StepWithoutP: "cfg \<turnstile> m' \<mapsto> cfg2"
shows
  "\<exists> cfg' :: ('p,'v,'s) configuration . (cfg1 \<turnstile> m' \<mapsto> cfg')
        \<and> (cfg2 \<turnstile> m \<mapsto> cfg')"
proof (cases m)
  case (InMsg p b)
  from StepWithoutP ExistsMsg have " m' \<in># (msgs cfg) " by simp
  hence "m' \<in># (msgs cfg1)"
    using StepP Rec NoMessageLossStep le_neq_implies_less le_antisym
    by (metis  gr_implies_not0 neq0_conv)
  hence EnM': "enabled cfg1 m'" using enabled_def by auto
  from StepP ExistsMsg have "m \<in># (msgs cfg) " by simp
  hence "m \<in># (msgs cfg2)"
    using StepWithoutP Rec' NoMessageLossStep
    by (metis le_0_eq neq0_conv)
  hence EnM: "enabled cfg2 m" using enabled_def by auto
  assume CaseM:  "m = <p, inM b>"

  thus ?thesis
  proof (cases m')
    case (OutMsg b')
    thus ?thesis using StepWithoutP by simp
  next
    case (InMsg q b')
    define cfg' where "cfg' = \<lparr>states = \<lambda>s. (
      if s = q then
        trans q (states cfg q) (Bool b')
      else if s = p then
        trans p (states cfg p) (Bool b)
      else
        states cfg s),
      msgs = ((sends q (states cfg q) (Bool b'))
        \<union># (((sends p (states cfg p) (Bool b))
            \<union># ((msgs cfg)-# m)) -# m'))\<rparr> "
    have StepP': "(cfg1 \<turnstile> m' \<mapsto> cfg')"
      using StepP  EnM' Rec
      unfolding cfg'_def InMsg CaseM by auto
    moreover from EnM have "(cfg2 \<turnstile> m \<mapsto> cfg')"
      using InMsg cfg'_def StepP StepP' StepWithoutP NoReceivingNoChange
            Rec' CaseM EnM'
    proof (simp, clarify)
      assume msgCfg:
        "msgs cfg1 = (sends p (states cfg p) (Bool b)
                     \<union># (msgs cfg -# <p, inM b>))"
        "msgs cfg2 = (sends q (states cfg q) (Bool b')
                     \<union># (msgs cfg -# <q, inM b'>))"
      have "enabled cfg m" "enabled cfg m'"
        using StepP StepWithoutP CaseM InMsg
        by auto
      with msgCfg show
        "(sends q (states cfg q) (Bool b') \<union># (msgs cfg1 -# <q, inM b'>)) =
         (sends p (states cfg p) (Bool b) \<union># (msgs cfg2 -# <p, inM b>))"
        using CaseM InMsg StepP StepWithoutP Rec' AXc[of "m'" "m" "msgs cfg"
          "sends q (states cfg q) (Bool b')"
          "sends p (states cfg p) (Bool b)"]
        unfolding enabled_def
        by metis
    qed
    ultimately show ?thesis by blast
  next
    case (Msg q v')
    define cfg' where "cfg' = \<lparr>states = \<lambda>s. (
      if s = q then
        trans q (states cfg q) (Value v')
      else if s = p then
        trans p (states cfg p) (Bool b)
      else
        states cfg s),
      msgs = ((sends q (states cfg q) (Value v'))
        \<union># (((sends p (states cfg p) (Bool b))
            \<union># ((msgs cfg)-# m))
            -# m'))\<rparr>"
    have StepP': "(cfg1 \<turnstile> m' \<mapsto> cfg')"
      using StepP EnM' Rec
      unfolding Msg CaseM cfg'_def by auto

    moreover from EnM have "(cfg2 \<turnstile> m \<mapsto> cfg')"
      using Msg cfg'_def StepP StepP' StepWithoutP NoReceivingNoChange Rec' CaseM EnM'
    proof (simp,clarify)
      assume msgCfg1:
        "msgs cfg1 = (sends p (states cfg p) (Bool b)
                      \<union># (msgs cfg -# <p, inM b>))"
        "msgs cfg2 = (sends q (states cfg q) (Value v')
                      \<union># (msgs cfg -# <q,  v'>))"
      have "enabled cfg m" "enabled cfg m'"
        using StepP StepWithoutP CaseM Msg
        by auto
      with msgCfg1 show
        "(sends q (states cfg q) (Value v') \<union># (msgs cfg1 -# <q, v'>)) =
         (sends p (states cfg p) (Bool b) \<union># (msgs cfg2 -# <p, inM b>))"
        using CaseM Msg StepP StepWithoutP Rec' AXc[of "m'" "m" "msgs cfg"
          "sends q (states cfg q) (Value v')"
          "sends p (states cfg p) (Bool b)"]
        unfolding enabled_def by metis
    qed
    ultimately show ?thesis by blast
  qed
next
  case (OutMsg b)
  thus ?thesis using StepP by simp
next
  case (Msg p v)
  from StepWithoutP ExistsMsg have " m' \<in># (msgs cfg) " by simp
  hence "m' \<in># (msgs cfg1)"
    using StepP Rec NoMessageLossStep le_neq_implies_less le_antisym
    by (metis  gr_implies_not0 neq0_conv)
  hence EnM': "enabled cfg1 m'" using enabled_def by auto
  from StepP ExistsMsg have "m \<in># (msgs cfg) " by simp
  hence "m \<in># (msgs cfg2)"
    using StepWithoutP Rec' NoMessageLossStep
    by (metis le_0_eq neq0_conv)
  hence EnM: "enabled cfg2 m" using enabled_def by auto
  assume CaseM:  "m = <p, v>"
  thus ?thesis
  proof (cases m')
    case (OutMsg b')
    thus ?thesis using StepWithoutP by simp
  next
    case (InMsg q b')
    define cfg' where "cfg' = \<lparr>states = \<lambda>s. (
      if s = q then
        trans q (states cfg q) (Bool b')
      else if s = p then
        trans p (states cfg p) (Value v)
      else
        states cfg s),
      msgs = ((sends q (states cfg q) (Bool b'))
        \<union># (((sends p (states cfg p) (Value v))
        \<union># ((msgs cfg)-# m))
        -# m'))\<rparr> "
    hence StepP': "(cfg1 \<turnstile> m' \<mapsto> cfg')"
      using StepP InMsg EnM' Rec CaseM
      by auto
    moreover from EnM have "(cfg2 \<turnstile> m \<mapsto> cfg')"
      using InMsg cfg'_def StepP StepP' StepWithoutP NoReceivingNoChange Rec'
            CaseM EnM'
    proof (simp, clarify)
      assume msgCfg:
        "msgs cfg1 = (sends p (states cfg p) (Value v)
          \<union># (msgs cfg -# <p, v>))"
        "msgs cfg2 = (sends q (states cfg q) (Bool b')
          \<union># (msgs cfg -# <q, inM b'>))"
      have "enabled cfg m" "enabled cfg m'"
        using StepP StepWithoutP CaseM InMsg by auto
      with msgCfg show " (sends q (states cfg q) (Bool b')
                         \<union># (msgs cfg1 -# <q, inM b'>))
                       = (sends p (states cfg p) (Value v)
                         \<union># (msgs cfg2 -# <p, v>))"
        using CaseM StepP StepWithoutP Rec' InMsg AXc[of "m'" "m" "msgs cfg"
          "sends q (states cfg q) (Bool b')"
          "sends p (states cfg p) (Value v)"]
          unfolding enabled_def by metis
    qed
    ultimately show ?thesis by blast
  next
    case (Msg q v')
    define cfg' where "cfg' = \<lparr>states = \<lambda>s. (
      if s = q then
        trans q (states cfg q) (Value v')
      else if s = p then
        trans p (states cfg p) (Value v)
      else
        states cfg s),
      msgs = ((sends q (states cfg q) (Value v'))
        \<union># (((sends p (states cfg p) (Value v))
        \<union># ((msgs cfg)-# m))
        -# m'))\<rparr> "
    hence StepP': "(cfg1 \<turnstile> m' \<mapsto> cfg')"
      using StepP Msg EnM' Rec CaseM by auto
    moreover from EnM have "(cfg2 \<turnstile> m \<mapsto> cfg')"
      using Msg cfg'_def StepP StepP' StepWithoutP NoReceivingNoChange Rec' CaseM EnM'
    proof (simp, clarify)
      assume msgCfg:
        "msgs cfg1 = (sends p (states cfg p) (Value v)
          \<union># (msgs cfg -# <p, v>))"
        "msgs cfg2 = (sends q (states cfg q) (Value v')
          \<union># (msgs cfg -# <q, v'>))"
      have "enabled cfg m" "enabled cfg m'"
        using StepP StepWithoutP CaseM Msg by auto

      with msgCfg show " (sends q (states cfg q) (Value v')
                         \<union># (msgs cfg1 -# <q, v'>))
                       = (sends p (states cfg p) (Value v)
                         \<union># (msgs cfg2 -# <p, v>))"
        using CaseM StepP StepWithoutP Rec' Msg
          AXc[of "m'" "m" "msgs cfg" "sends q (states cfg q) (Value v')"
          "sends p (states cfg p) (Value v)"]
        unfolding enabled_def by metis
    qed
    ultimately show ?thesis by blast
  qed
qed

lemma DiamondTwo:
fixes
  cfg cfg1 cfg2 :: "('p,'v,'s) configuration" and
  Q :: "'p set" and
  msg :: "('p, 'v) message"
assumes
  QReach: "qReachable cfg Q cfg1" and
  Step: "cfg  \<turnstile> msg \<mapsto> cfg2"
        "\<exists>p\<in>Proc - Q. isReceiverOf p msg"
shows
  "\<exists> (cfg' :: ('p,'v,'s) configuration) . (cfg1  \<turnstile> msg \<mapsto> cfg')
  \<and> qReachable cfg2 Q cfg'"
using assms
proof(induct rule: qReachable.induct)
  fix cfg Q
  have "qReachable cfg2 Q cfg2" using qReachable.simps(1) by blast
  moreover assume "cfg \<turnstile> msg \<mapsto> cfg2" "\<exists>p\<in>UNIV - Q. isReceiverOf p msg"
  ultimately have "(cfg \<turnstile> msg \<mapsto> cfg2) \<and> qReachable cfg2 Q cfg2" by blast
  thus "\<exists>cfg'.(cfg \<turnstile> msg \<mapsto> cfg') \<and> qReachable cfg2 Q cfg'" by blast
next
  fix cfg Q cfg1' msga cfg1
  assume   "(cfg \<turnstile> msg \<mapsto> cfg2)"
    "(\<exists>p\<in>UNIV - Q. isReceiverOf p msg)"
    "((cfg \<turnstile> msg \<mapsto> cfg2) \<Longrightarrow>
     (\<exists>p\<in>UNIV - Q. isReceiverOf p msg) \<Longrightarrow>
     (\<exists>cfg'. (cfg1' \<turnstile> msg \<mapsto> cfg') \<and> qReachable cfg2 Q cfg'))"
  hence "(\<exists>cfg'. (cfg1' \<turnstile> msg \<mapsto> cfg') \<and> (\<exists>p\<in>UNIV - Q. isReceiverOf p msg)
        \<and> qReachable cfg2 Q cfg')" by blast
  then obtain cfg' where Cfg': "(cfg1' \<turnstile> msg \<mapsto> cfg')"
    "(\<exists>p\<in>UNIV - Q. isReceiverOf p msg)" "qReachable cfg2 Q cfg'" by blast
  then obtain p where P: "p\<in>UNIV - Q" "isReceiverOf p msg" by blast
  assume Step2: "(cfg1' \<turnstile> msga \<mapsto> cfg1)"
    "(\<exists>p\<in>Q. isReceiverOf p msga)"
    "(qReachable cfg Q cfg1')"
  then obtain p' where P': "p'\<in>Q" "isReceiverOf p' msga" by blast
  from P'(1) P(1) have notEq: "p \<noteq> p'" by blast
  with P(2) P'(2) have "\<not> isReceiverOf p' msg" "\<not> isReceiverOf p msga"
    using UniqueReceiverOf[of p' msga p] UniqueReceiverOf[of p msg p']
    by auto
  with notEq P'(2) P(2) Cfg'(1) Step2(1) have
    "\<exists>cfg''. (cfg' \<turnstile> msga \<mapsto> cfg'') \<and> (cfg1 \<turnstile> msg \<mapsto> cfg'')"
    using DiamondOne by simp
  then obtain cfg'' where Cfg'': "cfg' \<turnstile> msga \<mapsto> cfg''" "cfg1 \<turnstile> msg \<mapsto> cfg''"
    by blast
  from Cfg''(1) Step2(2) Cfg'(3) have "qReachable cfg2 Q cfg''"
    using qReachable.simps[of cfg2 Q cfg''] by auto
  with Cfg'(2) Cfg''(2) have
    "(cfg1 \<turnstile> msg \<mapsto> cfg'') \<and> qReachable cfg2 Q cfg''"  by simp
  thus "\<exists>cfg'. (cfg1 \<turnstile> msg \<mapsto> cfg') \<and> qReachable cfg2 Q cfg'" by blast
qed

text \<open>Proposition 1 of Völzer.\<close>
lemma Diamond:
fixes
  cfg cfg1 cfg2 :: "('p,'v,'s) configuration" and
  Q :: "'p set"
assumes
  QReach: "qReachable cfg Q cfg1" and
  WithoutQReach: "withoutQReachable cfg Q cfg2"
shows
  "\<exists> cfg'. withoutQReachable cfg1 Q cfg'
     \<and> qReachable cfg2 Q cfg'"
proof -
  define notQ where "notQ \<equiv> UNIV - Q"
  with WithoutQReach have "qReachable cfg notQ cfg2" by simp
  thus ?thesis using QReach notQ_def
  proof (induct rule: qReachable.induct)
    fix cfg2
    assume "qReachable cfg2 Q cfg1"
    moreover have "qReachable cfg1 (UNIV - Q) cfg1"
      using qReachable.simps by blast
    ultimately show
      "\<exists>cfg'. qReachable cfg1 (UNIV - Q) cfg'
        \<and> qReachable cfg2 Q cfg'"
      by blast
  next
    fix cfg cfg2' cfg2 msg
    assume Ass1: " qReachable cfg Q cfg1" "qReachable cfg (UNIV - Q) cfg2' "
    assume Ass2:  "cfg2' \<turnstile> msg \<mapsto> cfg2" "\<exists>p\<in>UNIV - Q. isReceiverOf p msg"
    assume "qReachable cfg Q cfg1 \<Longrightarrow> \<exists>cfg'. qReachable cfg1 (UNIV - Q) cfg'
      \<and> qReachable cfg2' Q cfg'"
    with Ass1(1) have "\<exists>cfg'. qReachable cfg1 (UNIV - Q) cfg'
      \<and> qReachable cfg2' Q cfg'" by blast
    then obtain cfg' where
      Cfg'1: "qReachable cfg2' Q cfg'" and
      Cfg':  "qReachable cfg1 (UNIV - Q) cfg'" by blast
    from Cfg'1 Ass2 have
      "\<exists>cfg''.(cfg' \<turnstile> msg \<mapsto> cfg'') \<and> qReachable cfg2 Q cfg''"
      using DiamondTwo by simp
    then obtain cfg'' where
      Cfg'': "cfg' \<turnstile> msg \<mapsto> cfg''" "qReachable cfg2 Q cfg''" by blast
    from Cfg' Cfg''(1) Ass2(2) have "qReachable cfg1 (UNIV - Q) cfg''"
      using qReachable.simps[of cfg1 "UNIV-Q" cfg''] by auto
    with Cfg'' show
      "\<exists>cfg'. qReachable cfg1 (UNIV - Q) cfg'
        \<and> qReachable cfg2 Q cfg'" by blast
  qed
qed

subsection \<open>Invariant finite message count\<close>

lemma FiniteMessages:
fixes
  cfg  :: "('p, 'v, 's) configuration"
assumes
  FiniteProcs: "finite Proc" and
  FiniteSends: "\<And> p s m. finite {v. v \<in># (sends p s m)}" and
  InitReachable: "initReachable cfg"
shows "finite {msg . msg \<in># msgs cfg}"
proof(-)
  have "\<exists> init . initial init \<and> reachable init cfg" using assms
    unfolding initReachable_def by simp
  then obtain init where Init: "initial init" "reachable init cfg"
    by blast
  have InitMsgs:"{msg . msg \<in># msgs init}
    = { msg . (msg \<in># msgs init) \<and> (\<exists> p v. <p, v> = msg)}
      \<union> { msg . (msg \<in># msgs init) \<and> (\<exists> v.  <\<bottom>, outM v> = msg)}
      \<union> { msg . (msg \<in># msgs init) \<and> (\<exists> p v.  <p, inM v> = msg)}"
       by (auto,metis message.exhaust)
  have A:"{ msg . (msg \<in># msgs init) \<and> (\<exists> p v. <p, v> = msg)} = {}"
  using initial_def[of init] Init(1)by (auto, metis less_not_refl3)
  have B:"{ msg . (msg \<in># msgs init) \<and> (\<exists> v.  <\<bottom>, outM v> = msg)} = {}"
  using initial_def[of init] Init(1) by (auto, metis less_not_refl3)
  have "\<forall> p . finite {<p, inM True>, <p, inM False>}" by auto
  moreover have SubsetMsg:
    "\<forall> p. { msg . (msg \<in># msgs init)
      \<and> (\<exists> v::bool .  <p, inM v> = msg)}
      \<subseteq> {<p, inM True>, <p, inM False>}" by auto
  ultimately have AllFinite:
    "\<forall> p. finite { msg . (msg \<in># msgs init)
      \<and> (\<exists> v::bool .  <p, inM v> = msg)}"
    using finite_subset by (clarify, auto)
  have " { msg . (msg \<in># msgs init)
    \<and> (\<exists> p\<in>Proc . \<exists> v::bool.  <p, inM v> = msg)}
      = (\<Union> p \<in> Proc . { msg . (msg \<in># msgs init)
    \<and> (\<exists> v::bool .  <p, inM v> = msg)})" by auto
  hence "finite  { msg . (msg \<in># msgs init)
    \<and> (\<exists> p\<in>Proc . \<exists> v::bool.  <p, inM v> = msg)}"
    using AllFinite FiniteProcs by auto
  hence InitFinite:"finite {msg . msg \<in># msgs init}"
    by (auto simp add: A B InitMsgs)
  show ?thesis using Init(2) InitFinite
  proof(induct rule: reachable.induct, simp_all)
    fix cfg1 cfg2 msg cfg3
    assume assmsInduct:"reachable cfg1 cfg2"
      "finite {msg. msg \<in># msgs cfg2}" "cfg2 \<turnstile> msg \<mapsto> cfg3"
      "finite {msg. msg \<in># msgs cfg1}" "reachable init cfg"
      "finite {msg. msg \<in># msgs init}"
    from assmsInduct(3) obtain p where "isReceiverOf p msg "
      by (metis StepOutMsg isReceiverOf.simps(1) isReceiverOf.simps(2)
       message.exhaust)
    hence "msgs cfg3 = ((msgs cfg2 -# msg) \<union># (sends p (states cfg2 p)
      (unpackMessage msg) ))"
      using assmsInduct(3) by (cases msg, auto simp add: add.commute)
    hence MsgSet: "{msg. msg \<in>#  msgs cfg3 }
      = {m. m \<in># ((msgs cfg2 -# msg) \<union># (sends p (states cfg2 p)
        (unpackMessage msg) )) } " by simp
    have "{v. v \<in># (msgs cfg2 -# msg)} \<subseteq> {msg. msg \<in># msgs cfg2}"
      by auto
    from finite_subset[OF this]
      have "finite {v. (v \<in># sends p (states cfg2 p) (unpackMessage msg))
        \<or> (v \<in># (msgs cfg2 -# msg))}"
      using FiniteSends assmsInduct(2) by auto
    thus "finite {msg. msg \<in># msgs cfg3}"
       unfolding MsgSet by auto
  qed
qed

end

end


(*<*)
theory BTVSubstTypingL
  imports  "HOL-Eisbach.Eisbach_Tools" ContextSubtypingL SubstMethods
begin
  (*>*)

chapter \<open>Basic Type Variable Substitution Lemmas\<close>
text \<open>Lemmas that show that types are preserved, in some way,
under basic type variable substitution\<close>

lemma subst_vv_subst_bb_commute:
  fixes bv::bv and b::b and x::x and v::v
  assumes "atom bv \<sharp> v"
  shows "(v'[x::=v]\<^sub>v\<^sub>v)[bv::=b]\<^sub>v\<^sub>b = (v'[bv::=b]\<^sub>v\<^sub>b)[x::=v]\<^sub>v\<^sub>v"
  using assms proof(nominal_induct v'  rule: v.strong_induct)
  case (V_lit x)
  then show ?case using subst_vb.simps subst_vv.simps by simp
next
  case (V_var y)
  hence "v[bv::=b]\<^sub>v\<^sub>b=v" using forget_subst subst_b_v_def by metis
  then show ?case unfolding subst_vb.simps(2) subst_vv.simps(2) using V_var by auto
next
  case (V_pair x1a x2a)
  then show ?case using subst_vb.simps subst_vv.simps by simp
next
  case (V_cons x1a x2a x3)
  then show ?case using subst_vb.simps subst_vv.simps by simp
next
  case (V_consp x1a x2a x3 x4)
  then show ?case using subst_vb.simps subst_vv.simps by simp
qed

lemma subst_cev_subst_bb_commute:
  fixes bv::bv and b::b and x::x and v::v
  assumes "atom bv \<sharp> v"
  shows "(ce[x::=v]\<^sub>v)[bv::=b]\<^sub>c\<^sub>e\<^sub>b = (ce[bv::=b]\<^sub>c\<^sub>e\<^sub>b)[x::=v]\<^sub>v"
  using assms apply (nominal_induct ce  rule: ce.strong_induct, (simp add: subst_vv_subst_bb_commute subst_ceb.simps subst_cv.simps))
  using assms subst_vv_subst_bb_commute subst_ceb.simps subst_cv.simps
  by (simp add: subst_v_ce_def)+

lemma subst_cv_subst_bb_commute:
  fixes bv::bv and b::b and x::x and v::v
  assumes "atom bv \<sharp> v"
  shows "c[x::=v]\<^sub>c\<^sub>v[bv::=b]\<^sub>c\<^sub>b = (c[bv::=b]\<^sub>c\<^sub>b)[x::=v]\<^sub>c\<^sub>v"
  using assms apply (nominal_induct c  rule: c.strong_induct )
  using assms subst_vv_subst_bb_commute subst_ceb.simps subst_cv.simps
    subst_v_c_def subst_b_c_def   apply auto
  using subst_cev_subst_bb_commute subst_v_ce_def by auto+

lemma subst_b_c_of:
  "(c_of \<tau> z)[bv::=b]\<^sub>c\<^sub>b =  c_of (\<tau>[bv::=b]\<^sub>\<tau>\<^sub>b) z"
proof(nominal_induct \<tau> avoiding: z rule:\<tau>.strong_induct)
  case (T_refined_type z' b' c')
  moreover have "atom bv \<sharp> [ z ]\<^sup>v " using fresh_at_base v.fresh by auto
  ultimately show ?case using subst_cv_subst_bb_commute[of bv "V_var z" c' z' b]  c_of.simps subst_tb.simps by metis
qed

lemma subst_b_b_of:
  "(b_of \<tau>)[bv::=b]\<^sub>b\<^sub>b =  b_of (\<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)"
  by(nominal_induct \<tau> rule:\<tau>.strong_induct, simp add: b_of.simps subst_tb.simps )

lemma subst_b_if:
  "\<lbrace> z : b_of \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b  | CE_val (v[bv::=b]\<^sub>v\<^sub>b)  ==  CE_val (V_lit ll)   IMP  c_of \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b z  \<rbrace> = \<lbrace> z : b_of \<tau> | CE_val (v)  ==  CE_val (V_lit ll)   IMP  c_of \<tau> z  \<rbrace>[bv::=b]\<^sub>\<tau>\<^sub>b "
  unfolding subst_tb.simps subst_cb.simps subst_ceb.simps subst_vb.simps using subst_b_b_of   subst_b_c_of by auto

lemma subst_b_top_eq:
  "\<lbrace> z : B_unit  | TRUE \<rbrace>[bv::=b]\<^sub>\<tau>\<^sub>b = \<lbrace> z : B_unit  | TRUE \<rbrace>" and "\<lbrace> z : B_bool  | TRUE \<rbrace>[bv::=b]\<^sub>\<tau>\<^sub>b = \<lbrace> z : B_bool  | TRUE \<rbrace>"  and "\<lbrace> z : B_id tid | TRUE \<rbrace> = \<lbrace> z : B_id tid | TRUE \<rbrace>[bv::=b]\<^sub>\<tau>\<^sub>b"
  unfolding  subst_tb.simps subst_bb.simps subst_cb.simps by auto

lemmas subst_b_eq = subst_b_c_of subst_b_b_of subst_b_if subst_b_top_eq

lemma subst_cx_subst_bb_commute[simp]:
  fixes bv::bv and b::b and x::x and v'::c
  shows "(v'[x::=V_var y]\<^sub>c\<^sub>v)[bv::=b]\<^sub>c\<^sub>b = (v'[bv::=b]\<^sub>c\<^sub>b)[x::=V_var y]\<^sub>c\<^sub>v"
  using subst_cv_subst_bb_commute fresh_at_base  v.fresh by auto

lemma subst_b_infer_b:
  fixes l::l and b::b
  assumes " \<turnstile> l \<Rightarrow> \<tau>" and "\<Theta> ; {||} \<turnstile>\<^sub>w\<^sub>f b" and "B = {|bv|}"
  shows  "\<turnstile> l \<Rightarrow> (\<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)"
  using assms infer_l_form3 infer_l_form4 wf_b_subst infer_l_wf subst_tb.simps base_for_lit.simps subst_tb.simps
    subst_b_base_for_lit subst_cb.simps(6) subst_ceb.simps(1) subst_vb.simps(1) subst_vb.simps(2) type_l_eq
  by metis

lemma subst_b_subtype:
  fixes s::s and b'::b
  assumes  "\<Theta> ; {|bv|} ; \<Gamma>  \<turnstile> \<tau>1 \<lesssim> \<tau>2" and "\<Theta> ; {||} \<turnstile>\<^sub>w\<^sub>f b'"  and "B = {|bv|}"
  shows "\<Theta> ; {||} ; \<Gamma>[bv::=b']\<^sub>\<Gamma>\<^sub>b  \<turnstile> \<tau>1[bv::=b']\<^sub>\<tau>\<^sub>b \<lesssim> \<tau>2[bv::=b']\<^sub>\<tau>\<^sub>b"
  using assms proof(nominal_induct "{|bv|}"  \<Gamma> \<tau>1 \<tau>2 rule:subtype.strong_induct)
  case (subtype_baseI x \<Theta> \<Gamma> z c z' c' b)

  hence **: "\<Theta> ; {|bv|} ; (x, b, c[z::=V_var x]\<^sub>c\<^sub>v) #\<^sub>\<Gamma> \<Gamma>  \<Turnstile> c'[z'::=V_var x]\<^sub>c\<^sub>v " using validI subst_defs by metis

  have "\<Theta> ; {||} ; \<Gamma>[bv::=b']\<^sub>\<Gamma>\<^sub>b  \<turnstile> \<lbrace> z : b[bv::=b']\<^sub>b\<^sub>b | c[bv::=b']\<^sub>c\<^sub>b \<rbrace>  \<lesssim> \<lbrace> z' : b[bv::=b']\<^sub>b\<^sub>b | c'[bv::=b']\<^sub>c\<^sub>b \<rbrace>" proof(rule Typing.subtype_baseI)
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b']\<^sub>\<Gamma>\<^sub>b   \<turnstile>\<^sub>w\<^sub>f \<lbrace> z : b[bv::=b']\<^sub>b\<^sub>b  | c[bv::=b']\<^sub>c\<^sub>b \<rbrace> "
      using subtype_baseI assms wf_b_subst(4) subst_tb.simps subst_defs  by metis
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b']\<^sub>\<Gamma>\<^sub>b   \<turnstile>\<^sub>w\<^sub>f \<lbrace> z' : b[bv::=b']\<^sub>b\<^sub>b  | c'[bv::=b']\<^sub>c\<^sub>b \<rbrace> "
      using subtype_baseI assms wf_b_subst(4) subst_tb.simps by metis
    show "atom x \<sharp>(\<Theta>, {||}::bv fset, \<Gamma>[bv::=b']\<^sub>\<Gamma>\<^sub>b,  z , c[bv::=b']\<^sub>c\<^sub>b ,  z'  , c'[bv::=b']\<^sub>c\<^sub>b )"
      apply(unfold fresh_prodN,auto simp add: * fresh_prodN fresh_empty_fset)
      using subst_b_fresh_x * fresh_prodN  \<open>atom x \<sharp> c\<close> \<open>atom x \<sharp> c'\<close> subst_defs subtype_baseI by metis+
    have "\<Theta> ; {||} ; (x, b[bv::=b']\<^sub>b\<^sub>b, c[z::=V_var x]\<^sub>v[bv::=b']\<^sub>c\<^sub>b) #\<^sub>\<Gamma> \<Gamma>[bv::=b']\<^sub>\<Gamma>\<^sub>b  \<Turnstile> c'[z'::=V_var x]\<^sub>v[bv::=b']\<^sub>c\<^sub>b"
      using ** subst_b_valid subst_gb.simps assms  subtype_baseI  by metis
    thus "\<Theta> ; {||} ; (x, b[bv::=b']\<^sub>b\<^sub>b, (c[bv::=b']\<^sub>c\<^sub>b)[z::=V_var x]\<^sub>v) #\<^sub>\<Gamma> \<Gamma>[bv::=b']\<^sub>\<Gamma>\<^sub>b  \<Turnstile> (c'[bv::=b']\<^sub>c\<^sub>b)[z'::=V_var x]\<^sub>v"
      using subst_defs subst_cv_subst_bb_commute  by (metis subst_cx_subst_bb_commute)
  qed
  thus ?case using subtype_baseI subst_tb.simps subst_defs by metis
qed

lemma b_of_subst_bv:
  "(b_of \<tau>)[x::=v]\<^sub>b\<^sub>b = b_of (\<tau>[x::=v]\<^sub>\<tau>\<^sub>b)"
proof -
  obtain z b c where *:"\<tau> = \<lbrace> z : b | c \<rbrace> \<and> atom z \<sharp> (x,v)" using obtain_fresh_z by metis
  thus ?thesis  using subst_tv.simps * by auto
qed

lemma subst_b_infer_v:
  fixes v::v and b::b
  assumes "\<Theta> ; B ; G \<turnstile> v \<Rightarrow> \<tau>" and "\<Theta> ; {||} \<turnstile>\<^sub>w\<^sub>f b" and "B = {|bv|}"
  shows  "\<Theta> ; {||} ; G[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> (\<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)"
  using assms proof(nominal_induct avoiding: b bv rule: infer_v.strong_induct)
  case (infer_v_varI \<Theta> \<B> \<Gamma> b' c x z)
  show ?case unfolding  subst_b_simps proof
    show "\<Theta> ; {||}  \<turnstile>\<^sub>w\<^sub>f \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b " using infer_v_varI wf_b_subst by metis
    show "Some (b'[bv::=b]\<^sub>b\<^sub>b, c[bv::=b]\<^sub>c\<^sub>b) = lookup \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b x" using subst_b_lookup infer_v_varI by metis
    show "atom z \<sharp> x" using infer_v_varI by auto
    show "atom z \<sharp>  (\<Theta>, {||}, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b) " by(fresh_mth add: infer_v_varI subst_b_fresh_x subst_b_\<Gamma>_def fresh_prodN fresh_empty_fset )
  qed
next
  case (infer_v_litI \<Theta> \<B> \<Gamma> l \<tau>)
  then show ?case using Typing.infer_v_litI subst_b_infer_b
    using wf_b_subst1(3) by auto
next
  case (infer_v_pairI z v1 v2 \<Theta> \<B> \<Gamma> t1 t2)
  show ?case unfolding   subst_b_simps b_of_subst_bv proof
    show "atom z \<sharp> (v1[bv::=b]\<^sub>v\<^sub>b, v2[bv::=b]\<^sub>v\<^sub>b)" by(fresh_mth add: infer_v_pairI subst_b_fresh_x)
    show "atom z \<sharp> (\<Theta>, {||}, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b)" by(fresh_mth add: infer_v_pairI subst_b_fresh_x subst_b_\<Gamma>_def fresh_empty_fset)
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v1[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> t1[bv::=b]\<^sub>\<tau>\<^sub>b" using infer_v_pairI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v2[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> t2[bv::=b]\<^sub>\<tau>\<^sub>b" using infer_v_pairI by auto
  qed
next
  case (infer_v_consI s dclist \<Theta> dc tc \<B> \<Gamma> v tv z)
  show ?case unfolding   subst_b_simps b_of_subst_bv proof
    show "AF_typedef s dclist \<in> set \<Theta>" using infer_v_consI by auto
    show "(dc, tc) \<in> set dclist"  using infer_v_consI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> tv[bv::=b]\<^sub>\<tau>\<^sub>b" using infer_v_consI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> tv[bv::=b]\<^sub>\<tau>\<^sub>b \<lesssim> tc" proof -
      have "atom bv \<sharp> tc" using wfTh_lookup_supp_empty fresh_def infer_v_consI infer_v_wf by fast
      moreover have  "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> tv[bv::=b]\<^sub>\<tau>\<^sub>b \<lesssim> tc[bv::=b]\<^sub>\<tau>\<^sub>b"
        using subst_b_subtype infer_v_consI by simp
      ultimately show  ?thesis using forget_subst subst_b_\<tau>_def by metis
    qed
    show "atom z \<sharp> v[bv::=b]\<^sub>v\<^sub>b"  using infer_v_consI using  subst_b_fresh_x subst_b_v_def by metis
    show "atom z \<sharp> (\<Theta>, {||}, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b)"  by(fresh_mth add: infer_v_consI subst_b_fresh_x subst_b_\<Gamma>_def fresh_empty_fset)
  qed
next
  case (infer_v_conspI s bv2 dclist2 \<Theta> dc tc \<B> \<Gamma> v tv ba z)

  have "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> V_consp s dc (ba[bv::=b]\<^sub>b\<^sub>b) (v[bv::=b]\<^sub>v\<^sub>b) \<Rightarrow> \<lbrace> z : B_app s (ba[bv::=b]\<^sub>b\<^sub>b)  | [ [ z ]\<^sup>v ]\<^sup>c\<^sup>e  ==  [ V_consp s dc (ba[bv::=b]\<^sub>b\<^sub>b) (v[bv::=b]\<^sub>v\<^sub>b) ]\<^sup>c\<^sup>e  \<rbrace>"
  proof(rule Typing.infer_v_conspI)
    show "AF_typedef_poly s bv2 dclist2 \<in> set \<Theta>" using infer_v_conspI by auto
    show "(dc, tc) \<in> set dclist2"  using infer_v_conspI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> tv[bv::=b]\<^sub>\<tau>\<^sub>b"
      using infer_v_conspI subst_tb.simps by metis

    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> tv[bv::=b]\<^sub>\<tau>\<^sub>b \<lesssim> tc[bv2::=ba[bv::=b]\<^sub>b\<^sub>b]\<^sub>\<tau>\<^sub>b" proof -
      have "supp tc \<subseteq> { atom bv2 }" using infer_v_conspI wfTh_poly_lookup_supp wfX_wfY by metis
      moreover have "bv2 \<noteq> bv"  using \<open>atom bv2 \<sharp> \<B>\<close> \<open>\<B> = {|bv|} \<close> fresh_at_base fresh_def
        using fresh_finsert by fastforce
      ultimately have "atom bv \<sharp> tc" unfolding fresh_def by auto
      hence "tc[bv2::=ba[bv::=b]\<^sub>b\<^sub>b]\<^sub>\<tau>\<^sub>b = tc[bv2::=ba]\<^sub>\<tau>\<^sub>b[bv::=b]\<^sub>\<tau>\<^sub>b"
        using subst_tb_commute by metis
      moreover  have "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> tv[bv::=b]\<^sub>\<tau>\<^sub>b \<lesssim> tc[bv2::=ba]\<^sub>\<tau>\<^sub>b[bv::=b]\<^sub>\<tau>\<^sub>b"
        using infer_v_conspI(7) subst_b_subtype infer_v_conspI by metis
      ultimately show ?thesis by auto
    qed
    show "atom z \<sharp> (\<Theta>, {||}, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b, v[bv::=b]\<^sub>v\<^sub>b, ba[bv::=b]\<^sub>b\<^sub>b)"
      apply(unfold fresh_prodN, intro conjI, auto simp add: infer_v_conspI fresh_empty_fset)
      using \<open>atom z \<sharp> \<Gamma>\<close>  fresh_subst_if   subst_b_\<Gamma>_def x_fresh_b  apply metis
      using \<open>atom z \<sharp> v\<close>  fresh_subst_if   subst_b_v_def x_fresh_b  by metis
    show "atom bv2 \<sharp> (\<Theta>, {||}, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b, v[bv::=b]\<^sub>v\<^sub>b, ba[bv::=b]\<^sub>b\<^sub>b)"
      apply(unfold fresh_prodN, intro conjI, auto simp add: infer_v_conspI fresh_empty_fset)
      using \<open>atom bv2 \<sharp> b\<close>  \<open>atom bv2 \<sharp> \<Gamma>\<close> fresh_subst_if   subst_b_\<Gamma>_def apply metis
      using \<open>atom bv2 \<sharp> b\<close>  \<open>atom bv2 \<sharp> v\<close> fresh_subst_if   subst_b_v_def apply metis
      using \<open>atom bv2 \<sharp> b\<close>  \<open>atom bv2 \<sharp> ba\<close> fresh_subst_if   subst_b_b_def by metis
    show "\<Theta> ; {||}  \<turnstile>\<^sub>w\<^sub>f ba[bv::=b]\<^sub>b\<^sub>b "
      using infer_v_conspI  wf_b_subst by metis
  qed
  thus ?case using subst_vb.simps subst_tb.simps subst_bb.simps by simp

qed

lemma subst_b_check_v:
  fixes v::v and b::b
  assumes "\<Theta> ; B ; G \<turnstile> v \<Leftarrow> \<tau>" and "\<Theta> ; {||} \<turnstile>\<^sub>w\<^sub>f b" and "B = {|bv|}"
  shows  "\<Theta> ; {||} ; G[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Leftarrow> (\<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)"
proof -
  obtain \<tau>' where "\<Theta> ; B ; G \<turnstile> v \<Rightarrow> \<tau>' \<and>  \<Theta> ; B ; G  \<turnstile> \<tau>' \<lesssim> \<tau>" using check_v_elims[OF assms(1)] by metis
  thus ?thesis using subst_b_subtype subst_b_infer_v assms
    by (metis (no_types)  check_v_subtypeI subst_b_infer_v subst_b_subtype)
qed

lemma subst_vv_subst_vb_switch:
  shows  "(v'[bv::=b']\<^sub>v\<^sub>b)[x::=v[bv::=b']\<^sub>v\<^sub>b]\<^sub>v\<^sub>v = v'[x::=v]\<^sub>v\<^sub>v[bv::=b']\<^sub>v\<^sub>b"
proof(nominal_induct v' rule:v.strong_induct)
  case (V_lit x)
  then show ?case using subst_vv.simps subst_vb.simps by auto
next
  case (V_var x)
  then show ?case using subst_vv.simps subst_vb.simps by auto
next
  case (V_pair x1a x2a)
  then show ?case using subst_vv.simps subst_vb.simps v.fresh by auto
next
  case (V_cons x1a x2a x3)
  then show ?case using subst_vv.simps subst_vb.simps v.fresh by auto
next
  case (V_consp x1a x2a x3 x4)
  then show ?case using subst_vv.simps subst_vb.simps v.fresh pure_fresh
    by (metis forget_subst subst_b_b_def)
qed

lemma subst_cev_subst_vb_switch:
  shows  "(ce[bv::=b']\<^sub>c\<^sub>e\<^sub>b)[x::=v[bv::=b']\<^sub>v\<^sub>b]\<^sub>c\<^sub>e\<^sub>v = (ce[x::=v]\<^sub>c\<^sub>e\<^sub>v)[bv::=b']\<^sub>c\<^sub>e\<^sub>b"
  by(nominal_induct ce rule:ce.strong_induct, auto simp add: subst_vv_subst_vb_switch ce.fresh)

lemma subst_cv_subst_vb_switch:
  shows  "(c[bv::=b']\<^sub>c\<^sub>b)[x::=v[bv::=b']\<^sub>v\<^sub>b]\<^sub>c\<^sub>v = c[x::=v]\<^sub>c\<^sub>v[bv::=b']\<^sub>c\<^sub>b"
  by(nominal_induct c rule:c.strong_induct, auto simp add: subst_cev_subst_vb_switch c.fresh)

lemma subst_tv_subst_vb_switch:
  shows  "(\<tau>[bv::=b']\<^sub>\<tau>\<^sub>b)[x::=v[bv::=b']\<^sub>v\<^sub>b]\<^sub>\<tau>\<^sub>v = \<tau>[x::=v]\<^sub>\<tau>\<^sub>v[bv::=b']\<^sub>\<tau>\<^sub>b"
proof(nominal_induct \<tau> avoiding: x v rule:\<tau>.strong_induct)
  case (T_refined_type z b c )
  hence ceq: "(c[bv::=b']\<^sub>c\<^sub>b)[x::=v[bv::=b']\<^sub>v\<^sub>b]\<^sub>c\<^sub>v = c[x::=v]\<^sub>c\<^sub>v[bv::=b']\<^sub>c\<^sub>b" using subst_cv_subst_vb_switch by auto

  moreover have "atom z \<sharp> v[bv::=b']\<^sub>v\<^sub>b" using x_fresh_b fresh_subst_if subst_b_v_def T_refined_type by metis

  hence "\<lbrace> z : b  | c \<rbrace>[bv::=b']\<^sub>\<tau>\<^sub>b[x::=v[bv::=b']\<^sub>v\<^sub>b]\<^sub>\<tau>\<^sub>v = \<lbrace> z : b[bv::=b']\<^sub>b\<^sub>b  | (c[bv::=b']\<^sub>c\<^sub>b)[x::=v[bv::=b']\<^sub>v\<^sub>b]\<^sub>c\<^sub>v \<rbrace>"
    using subst_tv.simps subst_tb.simps T_refined_type fresh_Pair by metis

  moreover have "\<lbrace> z : b[bv::=b']\<^sub>b\<^sub>b  | (c[bv::=b']\<^sub>c\<^sub>b)[x::=v[bv::=b']\<^sub>v\<^sub>b]\<^sub>c\<^sub>v \<rbrace>  =  \<lbrace> z : b  | c[x::=v]\<^sub>c\<^sub>v \<rbrace>[bv::=b']\<^sub>\<tau>\<^sub>b"
    using subst_tv.simps subst_tb.simps ceq \<tau>.fresh forget_subst[of "bv" b b'] subst_b_b_def T_refined_type by metis

  ultimately show ?case using subst_tv.simps subst_tb.simps ceq T_refined_type by auto
qed

lemma subst_tb_triple:
  assumes "atom bv \<sharp> \<tau>'"
  shows  "\<tau>'[bv'::=b'[bv::=b]\<^sub>b\<^sub>b]\<^sub>\<tau>\<^sub>b[x'::=v'[bv::=b]\<^sub>v\<^sub>b]\<^sub>\<tau>\<^sub>v = \<tau>'[bv'::=b']\<^sub>\<tau>\<^sub>b[x'::=v']\<^sub>\<tau>\<^sub>v[bv::=b]\<^sub>\<tau>\<^sub>b"
proof -
  have "\<tau>'[bv'::=b'[bv::=b]\<^sub>b\<^sub>b]\<^sub>\<tau>\<^sub>b[x'::=v'[bv::=b]\<^sub>v\<^sub>b]\<^sub>\<tau>\<^sub>v = \<tau>'[bv'::=b']\<^sub>\<tau>\<^sub>b[bv::=b]\<^sub>\<tau>\<^sub>b [x'::=v'[bv::=b]\<^sub>v\<^sub>b]\<^sub>\<tau>\<^sub>v"
    using subst_tb_commute \<open>atom bv \<sharp> \<tau>'\<close> by auto
  also have "... = \<tau>'[bv'::=b']\<^sub>\<tau>\<^sub>b [x'::=v']\<^sub>\<tau>\<^sub>v[bv::=b]\<^sub>\<tau>\<^sub>b"
    using subst_tv_subst_vb_switch by auto
  finally show ?thesis using fresh_subst_if forget_subst by auto
qed

lemma subst_b_infer_e:
  fixes s::s and b::b
  assumes "\<Theta> ; \<Phi> ; B ; G; D \<turnstile> e \<Rightarrow> \<tau>" and "\<Theta> ; {||} \<turnstile>\<^sub>w\<^sub>f b"  and "B = {|bv|}"
  shows  "\<Theta> ; \<Phi> ; {||} ; G[bv::=b]\<^sub>\<Gamma>\<^sub>b; D[bv::=b]\<^sub>\<Delta>\<^sub>b \<turnstile> (e[bv::=b]\<^sub>e\<^sub>b) \<Rightarrow> (\<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)"
  using assms proof(nominal_induct avoiding: b rule: infer_e.strong_induct)
  case (infer_e_valI \<Theta> \<B> \<Gamma> \<Delta> \<Phi> v \<tau>)
  thus ?case using  subst_eb.simps infer_e.intros wf_b_subst subst_db.simps wf_b_subst infer_v_wf subst_b_infer_v
    by (metis forget_subst ms_fresh_all(1) wfV_b_fresh)
next
  case (infer_e_plusI \<Theta> \<B> \<Gamma> \<Delta> \<Phi> v1 z1 c1 v2 z2 c2 z3)

  show ?case unfolding subst_b_simps subst_eb.simps proof(rule Typing.infer_e_plusI)
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b " using wf_b_subst(10) subst_db.simps infer_e_plusI wfX_wfY
      by (metis wf_b_subst(15))
    show "\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> " using infer_e_plusI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v1[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z1 : B_int  | c1[bv::=b]\<^sub>c\<^sub>b \<rbrace>" using subst_b_infer_v  infer_e_plusI subst_b_simps by force
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v2[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z2 : B_int  | c2[bv::=b]\<^sub>c\<^sub>b \<rbrace>" using subst_b_infer_v  infer_e_plusI subst_b_simps by force
    show "atom z3 \<sharp> AE_op Plus (v1[bv::=b]\<^sub>v\<^sub>b) (v2[bv::=b]\<^sub>v\<^sub>b)" using  subst_b_simps infer_e_plusI subst_b_fresh_x subst_b_e_def by metis
    show "atom z3 \<sharp> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b" using subst_g_b_x_fresh infer_e_plusI by auto
  qed
next
  case (infer_e_leqI \<Theta> \<B> \<Gamma> \<Delta> \<Phi> v1 z1 c1 v2 z2 c2 z3)
  show ?case unfolding subst_b_simps proof(rule Typing.infer_e_leqI)
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  " using wf_b_subst(10) subst_db.simps infer_e_leqI wfX_wfY
      by (metis wf_b_subst(15))
    show "\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> " using infer_e_leqI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v1[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z1 : B_int  | c1[bv::=b]\<^sub>c\<^sub>b \<rbrace>" using subst_b_infer_v  infer_e_leqI subst_b_simps by force
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v2[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z2 : B_int  | c2[bv::=b]\<^sub>c\<^sub>b \<rbrace>" using subst_b_infer_v  infer_e_leqI subst_b_simps by force
    show "atom z3 \<sharp> AE_op LEq (v1[bv::=b]\<^sub>v\<^sub>b) (v2[bv::=b]\<^sub>v\<^sub>b)" using  subst_b_simps infer_e_leqI subst_b_fresh_x subst_b_e_def by metis
    show "atom z3 \<sharp> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b" using subst_g_b_x_fresh infer_e_leqI by auto
  qed
next
  case (infer_e_eqI \<Theta> \<B> \<Gamma> \<Delta> \<Phi> v1 z1 bb c1 v2 z2 c2 z3)
  show ?case unfolding subst_b_simps proof(rule Typing.infer_e_eqI)
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  " using wf_b_subst(10) subst_db.simps infer_e_eqI wfX_wfY
      by (metis wf_b_subst(15))
    show "\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> " using infer_e_eqI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v1[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z1 : bb[bv::=b]\<^sub>b\<^sub>b  | c1[bv::=b]\<^sub>c\<^sub>b \<rbrace>" using subst_b_infer_v  infer_e_eqI subst_b_simps by force
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v2[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z2 : bb[bv::=b]\<^sub>b\<^sub>b  | c2[bv::=b]\<^sub>c\<^sub>b \<rbrace>" using subst_b_infer_v  infer_e_eqI subst_b_simps by force
    show "atom z3 \<sharp> AE_op Eq (v1[bv::=b]\<^sub>v\<^sub>b) (v2[bv::=b]\<^sub>v\<^sub>b)" using  subst_b_simps infer_e_eqI subst_b_fresh_x subst_b_e_def by metis
    show "atom z3 \<sharp> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b" using subst_g_b_x_fresh infer_e_eqI by auto
    show "bb[bv::=b]\<^sub>b\<^sub>b  \<in> {B_bool, B_int, B_unit}" using infer_e_eqI by auto
  qed
next
  case (infer_e_appI \<Theta> \<B> \<Gamma> \<Delta> \<Phi> f x b' c \<tau>' s' v \<tau>)
  show ?case proof(subst subst_eb.simps, rule Typing.infer_e_appI)
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b"  using wf_b_subst(10) subst_db.simps infer_e_appI wfX_wfY by (metis wf_b_subst(15))
    show "\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> " using infer_e_appI by auto
    show "Some (AF_fundef f (AF_fun_typ_none (AF_fun_typ x b' c \<tau>' s'))) = lookup_fun \<Phi> f" using infer_e_appI by auto
        (*show  "\<Theta> ; {||} ; (x, b', c) #\<^sub>\<Gamma> GNil   \<turnstile>\<^sub>w\<^sub>f \<tau>'" using infer_e_appI sory*)
    have "atom bv \<sharp> b'"  using \<open>\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> \<close> infer_e_appI wfPhi_f_supp  fresh_def[of "atom bv" b'] by simp
    hence "b' = b'[bv::=b]\<^sub>b\<^sub>b" using subst_b_simps
      using has_subst_b_class.forget_subst subst_b_b_def by force
    moreover have  ceq:"c = c[bv::=b]\<^sub>c\<^sub>b" using subst_b_simps proof -
      have "supp c \<subseteq> {atom x}" using infer_e_appI wfPhi_f_simple_supp_c[OF  _  \<open>\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> \<close>]  by simp
      hence "atom bv \<sharp> c" using
          fresh_def[of "atom bv" c]
        using fresh_def fresh_finsert insert_absorb
          insert_subset ms_fresh_all supp_at_base x_not_in_b_set fresh_prodN by metis
      thus ?thesis
        using forget_subst subst_b_c_def  fresh_def[of "atom bv" c] by metis
    qed
    show   "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Leftarrow> \<lbrace> x : b'  | c \<rbrace>"
      using subst_b_check_v subst_tb.simps subst_vb.simps infer_e_appI
    proof -
      have "\<Theta> ; {|bv|} ; \<Gamma> \<turnstile> v \<Leftarrow> \<lbrace> x : b' | c \<rbrace>"
        by (metis \<open>\<B> = {|bv|}\<close> \<open>\<Theta> ; \<B> ; \<Gamma> \<turnstile> v \<Leftarrow> \<lbrace> x : b' | c \<rbrace>\<close>) (* 0.0 ms *)
      then show ?thesis
        by (metis (no_types) \<open>\<Theta> ; {||} \<turnstile>\<^sub>w\<^sub>f b\<close> \<open>b' = b'[bv::=b]\<^sub>b\<^sub>b\<close> subst_b_check_v subst_tb.simps ceq)
    qed
    show "atom x \<sharp> (\<Theta>, \<Phi>, {||}::bv fset, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b, \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b, v[bv::=b]\<^sub>v\<^sub>b, \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)"
      apply (fresh_mth add:  fresh_prodN subst_g_b_x_fresh infer_e_appI )
      using subst_b_fresh_x infer_e_appI apply metis+
      done
    have "supp \<tau>' \<subseteq> { atom x }" using wfPhi_f_simple_supp_t  infer_e_appI by auto
    hence "atom bv \<sharp> \<tau>'" using fresh_def fresh_at_base by force
    then  show  "\<tau>'[x::=v[bv::=b]\<^sub>v\<^sub>b]\<^sub>v = \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b" using infer_e_appI
        forget_subst subst_b_\<tau>_def subst_tv_subst_vb_switch subst_defs by metis
  qed
next
  case (infer_e_appPI \<Theta>' \<B> \<Gamma>' \<Delta> \<Phi>' b' f' bv' x' b1 c \<tau>' s' v' \<tau>1)

  have beq: "b1[bv'::=b']\<^sub>b\<^sub>b[bv::=b]\<^sub>b\<^sub>b =  b1[bv'::=b'[bv::=b]\<^sub>b\<^sub>b]\<^sub>b\<^sub>b"
  proof -
    have "supp b1 \<subseteq> { atom bv' }" using wfPhi_f_poly_supp_b infer_e_appPI
      using supp_at_base by blast
    moreover have "bv \<noteq> bv'" using infer_e_appPI fresh_def supp_at_base
      by (simp add: fresh_def supp_at_base)
    ultimately have "atom bv \<sharp> b1" using fresh_def fresh_at_base by force
    thus ?thesis by simp
  qed

  have ceq: "(c[bv'::=b']\<^sub>c\<^sub>b)[bv::=b]\<^sub>c\<^sub>b = c[bv'::=b'[bv::=b]\<^sub>b\<^sub>b]\<^sub>c\<^sub>b" proof -
    have "supp c \<subseteq> { atom bv', atom x' }" using wfPhi_f_poly_supp_c infer_e_appPI
      using supp_at_base by blast
    moreover have "bv \<noteq> bv'" using infer_e_appPI fresh_def supp_at_base
      by (simp add: fresh_def supp_at_base)
    moreover have "atom x' \<noteq> atom bv" by auto
    ultimately have "atom bv \<sharp> c" using fresh_def[of "atom bv" c] fresh_at_base by auto
    thus ?thesis by simp
  qed

  show ?case proof(subst subst_eb.simps, rule Typing.infer_e_appPI)
    show "\<Theta>' ; {||} ; \<Gamma>'[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b " using wf_b_subst subst_db.simps infer_e_appPI wfX_wfY by metis
    show "\<Theta>'  \<turnstile>\<^sub>w\<^sub>f \<Phi>' " using infer_e_appPI by auto
    show "Some (AF_fundef f' (AF_fun_typ_some bv' (AF_fun_typ x' b1 c \<tau>' s'))) = lookup_fun \<Phi>' f'" using infer_e_appPI by auto
    thus  "\<Theta>' ; {||} ; \<Gamma>'[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> v'[bv::=b]\<^sub>v\<^sub>b \<Leftarrow> \<lbrace> x' : b1[bv'::=b'[bv::=b]\<^sub>b\<^sub>b]\<^sub>b  | c[bv'::=b'[bv::=b]\<^sub>b\<^sub>b]\<^sub>b \<rbrace>"
      using subst_b_check_v subst_tb.simps subst_b_simps infer_e_appPI
    proof -
      have "\<Theta>' ; {||} ; \<Gamma>'[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> v'[bv::=b]\<^sub>v\<^sub>b \<Leftarrow> \<lbrace> x' : b1[bv'::=b']\<^sub>b[bv::=b]\<^sub>b\<^sub>b  | (c[bv'::=b']\<^sub>b)[bv::=b]\<^sub>c\<^sub>b \<rbrace>"
        using  infer_e_appPI subst_b_check_v subst_tb.simps by metis
      thus  ?thesis using beq ceq  subst_defs by metis
    qed
    show "atom x' \<sharp> \<Gamma>'[bv::=b]\<^sub>\<Gamma>\<^sub>b" using subst_g_b_x_fresh infer_e_appPI by auto
    show  "\<tau>'[bv'::=b'[bv::=b]\<^sub>b\<^sub>b]\<^sub>b[x'::=v'[bv::=b]\<^sub>v\<^sub>b]\<^sub>v = \<tau>1[bv::=b]\<^sub>\<tau>\<^sub>b" proof - (* \<tau>'[bv'::=b']\<^sub>\<tau>\<^sub>b[x'::=v']\<^sub>\<tau>\<^sub>v = \<tau>1 *)

      have "supp \<tau>' \<subseteq> { atom x', atom bv' }" using wfPhi_f_poly_supp_t  infer_e_appPI by auto
      moreover hence "bv \<noteq> bv'" using infer_e_appPI fresh_def supp_at_base
        by (simp add: fresh_def supp_at_base)
      ultimately have "atom bv \<sharp> \<tau>'" using fresh_def by force
      hence "\<tau>'[bv'::=b'[bv::=b]\<^sub>b\<^sub>b]\<^sub>b[x'::=v'[bv::=b]\<^sub>v\<^sub>b]\<^sub>v = \<tau>'[bv'::=b']\<^sub>b[x'::=v']\<^sub>v[bv::=b]\<^sub>\<tau>\<^sub>b"  using subst_tb_triple subst_defs by auto
      thus ?thesis using infer_e_appPI by metis
    qed
    show "atom bv' \<sharp> (\<Theta>', \<Phi>', {||}, \<Gamma>'[bv::=b]\<^sub>\<Gamma>\<^sub>b, \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b, b'[bv::=b]\<^sub>b\<^sub>b, v'[bv::=b]\<^sub>v\<^sub>b, \<tau>1[bv::=b]\<^sub>\<tau>\<^sub>b)"
      unfolding fresh_prodN apply( auto simp add: infer_e_appPI fresh_empty_fset)
      using fresh_subst_if subst_b_\<Gamma>_def  subst_b_\<Delta>_def  subst_b_b_def subst_b_v_def subst_b_\<tau>_def infer_e_appPI by metis+
    show "\<Theta>' ; {||}  \<turnstile>\<^sub>w\<^sub>f b'[bv::=b]\<^sub>b\<^sub>b " using infer_e_appPI wf_b_subst by simp
  qed
next
  case (infer_e_fstI \<Theta> \<B> \<Gamma> \<Delta> \<Phi> v z' b1 b2 c z)
  show ?case unfolding subst_b_simps proof(rule Typing.infer_e_fstI)
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b " using wf_b_subst(10) subst_db.simps infer_e_fstI wfX_wfY
      by (metis wf_b_subst(15))
    show "\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> " using infer_e_fstI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z' : B_pair b1[bv::=b]\<^sub>b\<^sub>b b2[bv::=b]\<^sub>b\<^sub>b  | c[bv::=b]\<^sub>c\<^sub>b \<rbrace>"
      using subst_b_infer_v subst_tb.simps subst_b_simps infer_e_fstI by force
    show "atom z \<sharp> AE_fst (v[bv::=b]\<^sub>v\<^sub>b)" using infer_e_fstI subst_b_fresh_x subst_b_v_def e.fresh by metis
    show "atom z \<sharp> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b" using subst_g_b_x_fresh infer_e_fstI by auto
  qed
next
  case (infer_e_sndI \<Theta> \<B> \<Gamma> \<Delta> \<Phi> v z' b1 b2 c z)
  show ?case unfolding subst_b_simps proof(rule Typing.infer_e_sndI)
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  " using wf_b_subst(10) subst_db.simps infer_e_sndI wfX_wfY
      by (metis wf_b_subst(15))
    show "\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> " using infer_e_sndI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z' : B_pair b1[bv::=b]\<^sub>b\<^sub>b b2[bv::=b]\<^sub>b\<^sub>b  | c[bv::=b]\<^sub>c\<^sub>b \<rbrace>"
      using subst_b_infer_v subst_tb.simps subst_b_simps infer_e_sndI by force
    show "atom z \<sharp> AE_snd (v[bv::=b]\<^sub>v\<^sub>b)" using infer_e_sndI subst_b_fresh_x subst_b_v_def e.fresh by metis
    show "atom z \<sharp> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b" using subst_g_b_x_fresh infer_e_sndI by auto
  qed
next
  case (infer_e_lenI \<Theta> \<B> \<Gamma> \<Delta> \<Phi> v z' c z)
  show ?case unfolding subst_b_simps proof(rule Typing.infer_e_lenI)
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  " using wf_b_subst(10) subst_db.simps infer_e_lenI wfX_wfY
      by (metis wf_b_subst(15))
    show "\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> " using infer_e_lenI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z' : B_bitvec  | c[bv::=b]\<^sub>c\<^sub>b \<rbrace>"
      using subst_b_infer_v subst_tb.simps subst_b_simps infer_e_lenI by force
    show "atom z \<sharp> AE_len (v[bv::=b]\<^sub>v\<^sub>b)" using infer_e_lenI subst_b_fresh_x subst_b_v_def e.fresh by metis
    show "atom z \<sharp> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b" using subst_g_b_x_fresh infer_e_lenI by auto
  qed
next
  case (infer_e_mvarI \<Theta> \<B> \<Gamma> \<Phi> \<Delta> u \<tau>)
  show ?case proof(subst  subst subst_eb.simps, rule Typing.infer_e_mvarI)
    show "\<Theta> ; {||}  \<turnstile>\<^sub>w\<^sub>f \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b " using infer_e_mvarI wf_b_subst by auto
    show "\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> "  using infer_e_mvarI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b "   using infer_e_mvarI  using wf_b_subst(10) subst_db.simps infer_e_sndI wfX_wfY
      by (metis wf_b_subst(15))
    show "(u, \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b) \<in> setD \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b"  using infer_e_mvarI subst_db.simps set_insert
        subst_d_b_member by simp
  qed
next
  case (infer_e_concatI \<Theta> \<B> \<Gamma> \<Delta> \<Phi> v1 z1 c1 v2 z2 c2 z3)
  show ?case unfolding subst_b_simps proof(rule Typing.infer_e_concatI)
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b " using wf_b_subst(10) subst_db.simps infer_e_concatI wfX_wfY
      by (metis wf_b_subst(15))
    show "\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> " using infer_e_concatI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v1[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z1 : B_bitvec  | c1[bv::=b]\<^sub>c\<^sub>b \<rbrace>"
      using subst_b_infer_v subst_tb.simps subst_b_simps infer_e_concatI by force
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v2[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z2 : B_bitvec  | c2[bv::=b]\<^sub>c\<^sub>b \<rbrace>"
      using subst_b_infer_v subst_tb.simps subst_b_simps infer_e_concatI by force
    show "atom z3 \<sharp> AE_concat (v1[bv::=b]\<^sub>v\<^sub>b) (v2[bv::=b]\<^sub>v\<^sub>b)" using infer_e_concatI subst_b_fresh_x subst_b_v_def e.fresh by metis
    show "atom z3 \<sharp> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b" using subst_g_b_x_fresh infer_e_concatI by auto
  qed
next
  case (infer_e_splitI \<Theta> \<B> \<Gamma> \<Delta> \<Phi> v1 z1 c1 v2 z2 z3)
  show ?case unfolding subst_b_simps proof(rule Typing.infer_e_splitI)
    show \<open> \<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b \<close> using wf_b_subst(10) subst_db.simps infer_e_splitI wfX_wfY
      by (metis wf_b_subst(15))
    show \<open> \<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> \<close>  using infer_e_splitI by auto
    show \<open> \<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v1[bv::=b]\<^sub>v\<^sub>b \<Rightarrow> \<lbrace> z1 : B_bitvec  | c1[bv::=b]\<^sub>c\<^sub>b \<rbrace>\<close>
      using subst_b_infer_v subst_tb.simps subst_b_simps infer_e_splitI by force
    show \<open>\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> v2[bv::=b]\<^sub>v\<^sub>b \<Leftarrow> \<lbrace> z2 : B_int  | [ leq [ [ L_num 0 ]\<^sup>v ]\<^sup>c\<^sup>e [ [ z2 ]\<^sup>v ]\<^sup>c\<^sup>e ]\<^sup>c\<^sup>e  ==  [ [ L_true ]\<^sup>v ]\<^sup>c\<^sup>e   AND
                  [ leq [ [ z2 ]\<^sup>v ]\<^sup>c\<^sup>e [| [ v1[bv::=b]\<^sub>v\<^sub>b ]\<^sup>c\<^sup>e |]\<^sup>c\<^sup>e ]\<^sup>c\<^sup>e  ==  [ [ L_true ]\<^sup>v ]\<^sup>c\<^sup>e   \<rbrace>\<close>
      using subst_b_check_v subst_tb.simps subst_b_simps infer_e_splitI
    proof -
      have "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile> v2[bv::=b]\<^sub>v\<^sub>b \<Leftarrow> \<lbrace> z2 : B_int | [ leq [ [ L_num 0 ]\<^sup>v ]\<^sup>c\<^sup>e [ [ z2 ]\<^sup>v ]\<^sup>c\<^sup>e ]\<^sup>c\<^sup>e == [ [ L_true ]\<^sup>v ]\<^sup>c\<^sup>e AND [ leq [ [ z2 ]\<^sup>v ]\<^sup>c\<^sup>e [| [ v1 ]\<^sup>c\<^sup>e |]\<^sup>c\<^sup>e ]\<^sup>c\<^sup>e == [ [ L_true ]\<^sup>v ]\<^sup>c\<^sup>e \<rbrace>[bv::=b]\<^sub>\<tau>\<^sub>b"
        using infer_e_splitI.hyps(7) infer_e_splitI.prems(1) infer_e_splitI.prems(2) subst_b_check_v by presburger (* 0.0 ms *)
      then show ?thesis
        by simp (* 0.0 ms *)
    qed
    show \<open>atom z1 \<sharp> AE_split (v1[bv::=b]\<^sub>v\<^sub>b) (v2[bv::=b]\<^sub>v\<^sub>b)\<close> using infer_e_splitI subst_b_fresh_x subst_b_v_def e.fresh by metis
    show \<open>atom z1 \<sharp> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b\<close> using subst_g_b_x_fresh infer_e_splitI by auto

    show \<open>atom z2 \<sharp> AE_split (v1[bv::=b]\<^sub>v\<^sub>b) (v2[bv::=b]\<^sub>v\<^sub>b)\<close>  using infer_e_splitI subst_b_fresh_x subst_b_v_def e.fresh by metis

    show \<open>atom z2 \<sharp> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b\<close> using subst_g_b_x_fresh infer_e_splitI by auto
    show \<open>atom z3 \<sharp> AE_split (v1[bv::=b]\<^sub>v\<^sub>b) (v2[bv::=b]\<^sub>v\<^sub>b)\<close>  using infer_e_splitI subst_b_fresh_x subst_b_v_def e.fresh by metis
    show \<open>atom z3 \<sharp> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b\<close> using subst_g_b_x_fresh infer_e_splitI by auto
  qed
qed

text \<open>This is needed for preservation. When we apply a function "f [b] v" we need to
substitute into the body of the function f replacing type-variable with b\<close>

lemma subst_b_c_of_forget:
  assumes "atom bv \<sharp> const"
  shows "(c_of const x)[bv::=b]\<^sub>c\<^sub>b = c_of const x"
  using assms proof(nominal_induct const avoiding: x rule:\<tau>.strong_induct)
  case (T_refined_type x' b' c')
  hence "c_of \<lbrace> x' : b' | c' \<rbrace> x = c'[x'::=V_var x]\<^sub>c\<^sub>v" using c_of.simps by metis
  moreover have "atom bv \<sharp> c'[x'::=V_var x]\<^sub>c\<^sub>v" proof -
    have "atom bv \<sharp> c'" using T_refined_type \<tau>.fresh by simp
    moreover have "atom bv \<sharp> V_var x" using v.fresh by simp
    ultimately show ?thesis
      using T_refined_type \<tau>.fresh subst_b_c_def fresh_subst_if
        \<tau>_fresh_c fresh_subst_cv_if has_subst_b_class.subst_b_fresh_x ms_fresh_all(37) ms_fresh_all assms by metis
  qed
  ultimately show ?case using forget_subst subst_b_c_def by metis
qed

lemma subst_b_check_s:
  fixes s::s and b::b and cs::branch_s and css::branch_list and v::v and \<tau>::\<tau>
  assumes "\<Theta> ; {||} \<turnstile>\<^sub>w\<^sub>f b"  and "B = {|bv|}" (*and "D = []"*)
  shows  "\<Theta> ; \<Phi> ; B ; G; D \<turnstile> s \<Leftarrow> \<tau> \<Longrightarrow> \<Theta> ; \<Phi> ; {||} ; G[bv::=b]\<^sub>\<Gamma>\<^sub>b; D[bv::=b]\<^sub>\<Delta>\<^sub>b \<turnstile> (s[bv::=b]\<^sub>s\<^sub>b) \<Leftarrow> (\<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)" and
    "\<Theta> ; \<Phi> ; B ; G; D ; tid ; cons ; const ; v \<turnstile> cs \<Leftarrow> \<tau> \<Longrightarrow> \<Theta> ; \<Phi> ; {||} ; G[bv::=b]\<^sub>\<Gamma>\<^sub>b; D[bv::=b]\<^sub>\<Delta>\<^sub>b ; tid ; cons ; const ; v[bv::=b]\<^sub>v\<^sub>b \<turnstile> (subst_branchb cs bv b) \<Leftarrow> (\<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)" and
    "\<Theta> ; \<Phi> ; B ; G; D ; tid ; dclist ; v \<turnstile> css \<Leftarrow> \<tau> \<Longrightarrow> \<Theta> ; \<Phi> ; {||} ; G[bv::=b]\<^sub>\<Gamma>\<^sub>b; D[bv::=b]\<^sub>\<Delta>\<^sub>b ; tid ; dclist ; v[bv::=b]\<^sub>v\<^sub>b \<turnstile> (subst_branchlb css bv b ) \<Leftarrow> (\<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)"
  using assms proof(induct  rule: check_s_check_branch_s_check_branch_list.inducts)
  note facts = wfD_emptyI wfX_wfY wf_b_subst subst_b_subtype subst_b_infer_v
  case (check_valI \<Theta> \<B> \<Gamma> \<Delta> \<Phi> v \<tau>' \<tau>)
  show ?case
    apply(subst subst_sb.simps, rule Typing.check_valI)
    using facts check_valI apply metis
    using check_valI subst_b_infer_v wf_b_subst subst_b_subtype apply blast
    using check_valI subst_b_infer_v wf_b_subst subst_b_subtype apply blast
    using check_valI subst_b_infer_v wf_b_subst subst_b_subtype by metis
next
  case (check_letI x \<Theta> \<Phi> \<B> \<Gamma> \<Delta> e \<tau> z s b' c)
  show ?case proof(subst subst_sb.simps, rule Typing.check_letI)

    show "atom x \<sharp>(\<Theta>, \<Phi>, {||}, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b, \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b, e[bv::=b]\<^sub>e\<^sub>b, \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)" (*using check_letI  subst_b_\<tau>_def subst_b_\<Gamma>_def subst_b_fresh_x fresh_prod4 subst_b_c_def sory*)
      apply(unfold fresh_prodN,auto)
      apply(simp add: check_letI fresh_empty_fset)+
      apply(metis *   subst_b_fresh_x check_letI fresh_prodN)+ done
    show "atom z \<sharp> (x, \<Theta>, \<Phi>, {||}, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b, \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b, e[bv::=b]\<^sub>e\<^sub>b, \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b, s[bv::=b]\<^sub>s\<^sub>b)"
      apply(unfold fresh_prodN,auto)
      apply(simp add: check_letI fresh_empty_fset)+
      apply(metis *   subst_b_fresh_x check_letI fresh_prodN)+ done
    show "\<Theta> ; \<Phi> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  \<turnstile> e[bv::=b]\<^sub>e\<^sub>b \<Rightarrow> \<lbrace> z : b'[bv::=b]\<^sub>b\<^sub>b  | c[bv::=b]\<^sub>c\<^sub>b  \<rbrace>"
      using check_letI subst_b_infer_e subst_tb.simps by metis
    have "c[z::=[ x ]\<^sup>v]\<^sub>c\<^sub>v[bv::=b]\<^sub>c\<^sub>b =  (c[bv::=b]\<^sub>c\<^sub>b)[z::=V_var x]\<^sub>c\<^sub>v"
      using subst_cv_subst_bb_commute[of bv "V_var x" c z b] fresh_at_base by simp
    thus "\<Theta> ; \<Phi> ; {||} ; ((x, b'[bv::=b]\<^sub>b\<^sub>b , (c[bv::=b]\<^sub>c\<^sub>b)[z::=V_var x]\<^sub>v) #\<^sub>\<Gamma> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b) ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  \<turnstile> s[bv::=b]\<^sub>s\<^sub>b \<Leftarrow> \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b"
      using check_letI subst_gb.simps subst_defs by metis
  qed
next
  case (check_assertI x \<Theta> \<Phi> \<B> \<Gamma> \<Delta> c \<tau> s)
  show ?case proof(subst subst_sb.simps, rule Typing.check_assertI)
    show "atom x \<sharp> (\<Theta>, \<Phi>, {||}, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b, \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b,  c[bv::=b]\<^sub>c\<^sub>b, \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b, s[bv::=b]\<^sub>s\<^sub>b)"
      apply(unfold fresh_prodN,auto)
      apply(simp add: check_assertI fresh_empty_fset)+
      apply(metis *   subst_b_fresh_x check_assertI fresh_prodN)+ done

    have "\<Theta> ; \<Phi> ; {||} ; ((x, B_bool, c) #\<^sub>\<Gamma> \<Gamma>)[bv::=b]\<^sub>\<Gamma>\<^sub>b ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  \<turnstile> s[bv::=b]\<^sub>s\<^sub>b \<Leftarrow> \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b" using  check_assertI
      by metis
    thus "\<Theta> ; \<Phi> ; {||} ; (x, B_bool, c[bv::=b]\<^sub>c\<^sub>b) #\<^sub>\<Gamma> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  \<turnstile> s[bv::=b]\<^sub>s\<^sub>b \<Leftarrow> \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b" using  subst_gb.simps by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<Turnstile> c[bv::=b]\<^sub>c\<^sub>b " using subst_b_valid  check_assertI by simp
    show " \<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b " using wf_b_subst2(6) check_assertI by simp
  qed
next
  case (check_branch_list_consI \<Theta> \<Phi> \<B> \<Gamma> \<Delta> tid dclist v cs \<tau> css)
  then show ?case unfolding subst_branchlb.simps using Typing.check_branch_list_consI by simp
next
  case (check_branch_list_finalI \<Theta> \<Phi> \<B> \<Gamma> \<Delta> tid dclist v cs \<tau>)
  then show ?case unfolding subst_branchlb.simps using Typing.check_branch_list_finalI by simp
next
  case (check_branch_s_branchI \<Theta> \<B> \<Gamma> \<Delta> \<tau> const x \<Phi> tid cons v s)

  show ?case unfolding subst_b_simps proof(rule Typing.check_branch_s_branchI)
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  "  using check_branch_s_branchI wf_b_subst subst_db.simps by metis
    show "\<turnstile>\<^sub>w\<^sub>f \<Theta> " using check_branch_s_branchI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b   \<turnstile>\<^sub>w\<^sub>f \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b "   using check_branch_s_branchI wf_b_subst by metis

    show "atom x \<sharp>(\<Theta>, \<Phi>, {||}, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b, \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b, tid, cons , const, v[bv::=b]\<^sub>v\<^sub>b, \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)"
      apply(unfold fresh_prodN,auto)
      apply(simp add: check_branch_s_branchI fresh_empty_fset)+
      apply(metis *   subst_b_fresh_x check_branch_s_branchI fresh_prodN)+
      done
    show wft:"\<Theta> ; {||} ; GNil \<turnstile>\<^sub>w\<^sub>f  const" using check_branch_s_branchI  by auto
    hence "(b_of const) = (b_of const)[bv::=b]\<^sub>b\<^sub>b"
      using wfT_nil_supp   fresh_def[of "atom bv" ] forget_subst subst_b_b_def \<tau>.supp
        bot.extremum_uniqueI ex_in_conv fresh_def supp_empty_fset
      by (metis b_of_supp)
    moreover have "(c_of const x)[bv::=b]\<^sub>c\<^sub>b = c_of const x"
      using wft   wfT_nil_supp   fresh_def[of "atom bv" ] forget_subst subst_b_c_def \<tau>.supp
        bot.extremum_uniqueI ex_in_conv fresh_def supp_empty_fset  subst_b_c_of_forget by metis
    ultimately show  "\<Theta> ; \<Phi> ; {||} ; (x, b_of const, CE_val (v[bv::=b]\<^sub>v\<^sub>b)  ==  CE_val(V_cons tid cons (V_var x)) AND c_of const x) #\<^sub>\<Gamma> \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b   \<turnstile> s[bv::=b]\<^sub>s\<^sub>b \<Leftarrow> \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b"
      using check_branch_s_branchI subst_gb.simps by auto
  qed
next
  case (check_ifI z \<Theta> \<Phi> \<B> \<Gamma> \<Delta> v s1 s2 \<tau>)
  show ?case unfolding subst_b_simps proof(rule  Typing.check_ifI)
    show \<open>atom z \<sharp> (\<Theta>, \<Phi>, {||}, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b, \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b, v[bv::=b]\<^sub>v\<^sub>b, s1[bv::=b]\<^sub>s\<^sub>b, s2[bv::=b]\<^sub>s\<^sub>b, \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)\<close>
      by(unfold fresh_prodN,auto, auto simp add: check_ifI fresh_empty_fset subst_b_fresh_x )
    have "\<lbrace> z : B_bool  | TRUE \<rbrace>[bv::=b]\<^sub>\<tau>\<^sub>b  = \<lbrace> z : B_bool  | TRUE \<rbrace>"  by auto
    thus \<open>\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Leftarrow> \<lbrace> z : B_bool  | TRUE \<rbrace>\<close> using check_ifI subst_b_check_v by metis
    show \<open> \<Theta> ; \<Phi> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  \<turnstile> s1[bv::=b]\<^sub>s\<^sub>b \<Leftarrow> \<lbrace> z : b_of \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b  | CE_val (v[bv::=b]\<^sub>v\<^sub>b)  ==  CE_val (V_lit L_true)   IMP  c_of \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b z  \<rbrace>\<close>
      using subst_b_if check_ifI by metis
    show \<open> \<Theta> ; \<Phi> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  \<turnstile> s2[bv::=b]\<^sub>s\<^sub>b \<Leftarrow> \<lbrace> z : b_of \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b  | CE_val (v[bv::=b]\<^sub>v\<^sub>b)  ==  CE_val (V_lit L_false)   IMP  c_of \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b z  \<rbrace>\<close>
      using subst_b_if check_ifI by metis
  qed
next
  case (check_let2I x \<Theta> \<Phi> \<B> G \<Delta> t s1 \<tau> s2 )
  show ?case unfolding subst_b_simps proof (rule Typing.check_let2I)
    have "atom x \<sharp> b" using x_fresh_b by auto
    show \<open>atom x \<sharp> (\<Theta>, \<Phi>, {||}, G[bv::=b]\<^sub>\<Gamma>\<^sub>b, \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b, t[bv::=b]\<^sub>\<tau>\<^sub>b, s1[bv::=b]\<^sub>s\<^sub>b, \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)\<close>
      apply(unfold fresh_prodN, auto, auto simp add: check_let2I fresh_prodN fresh_empty_fset)
      apply(metis  subst_b_fresh_x check_let2I fresh_prodN)+
      done

    show \<open> \<Theta> ; \<Phi> ; {||} ; G[bv::=b]\<^sub>\<Gamma>\<^sub>b ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  \<turnstile> s1[bv::=b]\<^sub>s\<^sub>b \<Leftarrow> t[bv::=b]\<^sub>\<tau>\<^sub>b \<close> using check_let2I subst_tb.simps  by auto
    show \<open> \<Theta> ; \<Phi> ; {||} ; (x, b_of t[bv::=b]\<^sub>\<tau>\<^sub>b, c_of t[bv::=b]\<^sub>\<tau>\<^sub>b x) #\<^sub>\<Gamma> G[bv::=b]\<^sub>\<Gamma>\<^sub>b ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  \<turnstile> s2[bv::=b]\<^sub>s\<^sub>b \<Leftarrow> \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b\<close>
      using check_let2I subst_tb.simps  subst_gb.simps b_of.simps subst_b_c_of subst_b_b_of by auto
  qed
next
  case (check_varI u \<Theta> \<Phi> \<B> \<Gamma> \<Delta> \<tau>' v \<tau> s)
  show ?case unfolding subst_b_simps proof(rule Typing.check_varI)
    show "atom u \<sharp>  (\<Theta>, \<Phi>, {||}, \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b, \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b, \<tau>'[bv::=b]\<^sub>\<tau>\<^sub>b, v[bv::=b]\<^sub>v\<^sub>b, \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b) "
      by(unfold fresh_prodN,auto simp add: check_varI fresh_empty_fset subst_b_fresh_u )
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Leftarrow> \<tau>'[bv::=b]\<^sub>\<tau>\<^sub>b" using check_varI subst_b_check_v by auto
    show "\<Theta> ; \<Phi> ; {||} ; (subst_gb  \<Gamma> bv b) ; (u, (\<tau>'[bv::=b]\<^sub>\<tau>\<^sub>b)) #\<^sub>\<Delta> (subst_db  \<Delta> bv b)   \<turnstile> (s[bv::=b]\<^sub>s\<^sub>b) \<Leftarrow> (\<tau>[bv::=b]\<^sub>\<tau>\<^sub>b)" using check_varI by auto
  qed
next
  case (check_assignI \<Theta> \<Phi> \<B> \<Gamma> \<Delta> u \<tau> v z \<tau>')
  show ?case unfolding subst_b_simps proof( rule Typing.check_assignI)
    show "\<Theta>  \<turnstile>\<^sub>w\<^sub>f \<Phi> " using check_assignI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b \<turnstile>\<^sub>w\<^sub>f \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b " using wf_b_subst check_assignI by auto
    show "(u, \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b) \<in> setD \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b" using check_assignI subst_d_b_member  by simp
    show " \<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Leftarrow> \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b"  using check_assignI subst_b_check_v by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> \<lbrace> z : B_unit  | TRUE \<rbrace> \<lesssim> \<tau>'[bv::=b]\<^sub>\<tau>\<^sub>b" using check_assignI subst_b_subtype subst_b_simps subst_tb.simps by fastforce
  qed
next
  case (check_whileI \<Theta> \<Phi> \<B> \<Gamma> \<Delta> s1 z s2 \<tau>')
  show ?case unfolding subst_b_simps proof(rule Typing.check_whileI)
    show "\<Theta> ; \<Phi> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  \<turnstile> s1[bv::=b]\<^sub>s\<^sub>b \<Leftarrow> \<lbrace> z : B_bool  | TRUE \<rbrace>" using check_whileI by auto
    show "\<Theta> ; \<Phi> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b  \<turnstile> s2[bv::=b]\<^sub>s\<^sub>b \<Leftarrow> \<lbrace> z : B_unit  | TRUE \<rbrace>" using check_whileI by auto
    show "\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> \<lbrace> z : B_unit  | TRUE \<rbrace> \<lesssim> \<tau>'[bv::=b]\<^sub>\<tau>\<^sub>b"  using subst_b_subtype check_whileI by fastforce
  qed
next
  case (check_seqI \<Theta> \<Phi> \<B> \<Gamma> \<Delta> s1 z s2 \<tau>)
  then show ?case unfolding subst_sb.simps using check_seqI Typing.check_seqI subst_b_eq by metis
next
  case (check_caseI \<Theta> \<Phi> \<B>  \<Gamma> \<Delta> tid dclist v cs \<tau>  z)
  show ?case unfolding subst_b_simps proof(rule Typing.check_caseI)
    show \<open> \<Theta> ;  \<Phi> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b ; \<Delta>[bv::=b]\<^sub>\<Delta>\<^sub>b ; tid ; dclist ; v[bv::=b]\<^sub>v\<^sub>b \<turnstile> subst_branchlb cs bv b \<Leftarrow> \<tau>[bv::=b]\<^sub>\<tau>\<^sub>b\<close> using check_caseI by auto
    show \<open>AF_typedef tid dclist \<in> set \<Theta>\<close> using check_caseI by auto
    show \<open>\<Theta> ; {||} ; \<Gamma>[bv::=b]\<^sub>\<Gamma>\<^sub>b  \<turnstile> v[bv::=b]\<^sub>v\<^sub>b \<Leftarrow> \<lbrace> z : B_id tid  | TRUE \<rbrace>\<close> using check_caseI subst_b_check_v subst_b_simps subst_tb.simps subst_b_simps
    proof -
      have "\<lbrace> z : B_id tid | TRUE \<rbrace> = \<lbrace> z : B_id tid | TRUE \<rbrace>[bv::=b]\<^sub>\<tau>\<^sub>b" using subst_b_eq by auto
      then show ?thesis
        by (metis (no_types) check_caseI.hyps(4) check_caseI.prems(1) check_caseI.prems(2) subst_b_check_v) (* 31 ms *)
    qed
    show \<open>   \<turnstile>\<^sub>w\<^sub>f \<Theta> \<close> using check_caseI by auto
  qed
qed

end


theory Shifts
  imports Frame Append
begin

lemma shift_entails_prem: "(As ** A) ** Bs \<turnstile> Q \<Longrightarrow> As ** A ** Bs \<turnstile> Q"
  by simp

lemma shift_entails_conc: "P \<turnstile> (As ** A) ** Bs \<Longrightarrow> P  \<turnstile> As ** A ** Bs"
  by simp

lemma shift_frame_prem: "((As ** A) ** Bs) -- PR \<tturnstile> Q -- QR \<Longrightarrow> (As ** A ** Bs) -- PR \<tturnstile> Q -- QR"
  by simp

lemma shift_frame_conc: "P -- PR \<tturnstile> ((As ** A) ** Bs) -- QR \<Longrightarrow> P -- PR \<tturnstile> (As ** A ** Bs) -- QR"
  by simp

method_setup no_inst_rule =
  \<open>Attrib.thms >> (fn thms => fn ctxt => SIMPLE_METHOD' (match_tac ctxt thms THEN_ALL_NEW Goal.norm_hhf_tac ctxt))\<close>

method all_entails_prem_shifts methods M = append \<open>M\<close> \<open>no_inst_rule shift_entails_prem, all_entails_prem_shifts M\<close>
method all_entails_conc_shifts methods M = append \<open>M\<close> \<open>no_inst_rule shift_entails_conc, all_entails_conc_shifts M\<close>
method all_frame_prem_shifts methods M = append \<open>M\<close> \<open>no_inst_rule shift_frame_prem, all_frame_prem_shifts M\<close>
method all_frame_conc_shifts methods M = append \<open>M\<close> \<open>no_inst_rule shift_frame_conc, all_frame_conc_shifts M\<close>

end


theory Basic_Assn
  imports
    "Refine_Imperative_HOL.Sepref_HOL_Bindings"
    "Refine_Imperative_HOL.Sepref_Basic"
begin

section "Auxilary imperative assumptions"

text "The following auxiliary assertion types and lemmas were provided by Peter Lammich"

subsection \<open>List-Assn\<close>

lemma list_assn_cong[fundef_cong]:
  "\<lbrakk> xs=xs'; ys=ys'; \<And>x y. \<lbrakk> x\<in>set xs; y\<in>set ys \<rbrakk> \<Longrightarrow> A x y = A' x y \<rbrakk> \<Longrightarrow> list_assn A xs ys = list_assn A' xs' ys'"
  by (induction xs ys arbitrary: xs' ys' rule: list_assn.induct) auto

lemma list_assn_app_one: "list_assn P (l1@[x]) (l1'@[y]) = list_assn P l1 l1' * P x y"
  by simp

(* ------------------ ADDED by NM in course of btree_imp -------- *)

lemma list_assn_len: "h \<Turnstile> list_assn A xs ys \<Longrightarrow> length xs = length ys"
  using list_assn_aux_ineq_len by fastforce

lemma list_assn_append_Cons_left: "list_assn A (xs@x#ys) zs = (\<exists>\<^sub>A zs1 z zs2. list_assn A xs zs1 * A x z * list_assn A ys zs2 * \<up>(zs1@z#zs2 = zs))"
  by (sep_auto simp add: list_assn_aux_cons_conv list_assn_aux_append_conv1 intro!: ent_iffI)

lemma list_assn_aux_append_Cons:
  shows "length xs = length zsl \<Longrightarrow> list_assn A (xs@x#ys) (zsl@z#zsr) = (list_assn A xs zsl * A x z * list_assn A ys zsr) "
  by (sep_auto simp add: mult.assoc)

lemma list_assn_prod_split: "list_assn (\<lambda>x y. P x y * Q x y) as bs = list_assn P as bs * list_assn Q as bs"
proof(cases "length as = length bs")
  case True
  then show ?thesis
  proof (induction rule: list_induct2)
    case Nil
    then show ?case by sep_auto
  next
    case (Cons x xs y ys)
    show ?case
    proof (rule ent_iffI, goal_cases)
      case 1
      then show ?case
      using Cons by sep_auto
    next
      case 2
      then show ?case
      using Cons by sep_auto
    qed
  qed
next
  case False
  then show ?thesis
    by (simp add: list_assn_aux_ineq_len)
qed

(* -------------------------------------------- *)

subsection \<open>Prod-Assn\<close>

lemma prod_assn_cong[fundef_cong]:
  "\<lbrakk> p=p'; pi=pi'; A (fst p) (fst pi) = A' (fst p) (fst pi); B (snd p) (snd pi) = B' (snd p) (snd pi) \<rbrakk>
    \<Longrightarrow> (A\<times>\<^sub>aB) p pi = (A'\<times>\<^sub>aB') p' pi'"
  apply (cases p; cases pi)
  by auto

subsection \<open>Assertions and Magic Wand\<close>

lemma entails_preI: "(\<And>h. h \<Turnstile> P \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q) \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q"
  unfolding entails_def
  by auto

lemma ent_true_drop_true:
  "P*true\<Longrightarrow>\<^sub>AQ*true \<Longrightarrow> P*R*true\<Longrightarrow>\<^sub>AQ*true"
  using assn_aci(10) ent_true_drop(1) by presburger

(* TODO *)
lemma rem_true: "P*true \<Longrightarrow>\<^sub>A Q*true \<Longrightarrow> P \<Longrightarrow>\<^sub>AQ*true"
  using enttD enttI_true by blast

lemma assn_eq_split:
  assumes "B = C"
  shows "B \<Longrightarrow>\<^sub>A C"
  and "C \<Longrightarrow>\<^sub>A B"
  by (simp_all add: assms)

lemma ent_ex_inst: "\<exists>\<^sub>Ax. P x \<Longrightarrow>\<^sub>A Q \<Longrightarrow> P y \<Longrightarrow>\<^sub>A Q"
  using ent_trans by blast

lemma ent_ex_inst2: "\<exists>\<^sub>Ax y. P x y \<Longrightarrow>\<^sub>A Q \<Longrightarrow> P x y \<Longrightarrow>\<^sub>A Q"
  using ent_trans by blast

lemma ent_wandI2:
  assumes IMP: "P \<Longrightarrow>\<^sub>A (Q -* R)"
  shows "Q*P \<Longrightarrow>\<^sub>A R"
  using assms
  unfolding entails_def
(*  by (meson assms ent_fwd ent_mp ent_refl fr_rot mod_frame_fwd)*)
proof (clarsimp, goal_cases)
  case (1 h as)
  then obtain as1 as2 where "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "(h,as1) \<Turnstile> Q" "(h,as2) \<Turnstile> P"
    by (metis mod_star_conv prod.inject)
  then have "(h,as2) \<Turnstile> (Q-*R)"
    by (simp add: "1"(1))
  then have "(h,as1\<union>as2) \<Turnstile> Q * (Q-*R)"
    by (simp add: \<open>(h, as1) \<Turnstile> Q\<close> \<open>as1 \<inter> as2 = {}\<close> star_assnI)
  then show ?case
    using \<open>as = as1 \<union> as2\<close> ent_fwd ent_mp by blast
qed

lemma ent_wand: "(P \<Longrightarrow>\<^sub>A (Q -* R)) = (Q*P \<Longrightarrow>\<^sub>A R)"
  using ent_wandI2 ent_wandI by blast

lemma wand_ent_trans:
  assumes "P' \<Longrightarrow>\<^sub>A P"
      and "Q \<Longrightarrow>\<^sub>A Q'"
    shows "P -* Q \<Longrightarrow>\<^sub>A P' -* Q'"
  by (meson assms(1) assms(2) ent_wand ent_frame_fwd ent_refl ent_trans)

lemma wand_elim: "(P -* Q) * (Q -* R) \<Longrightarrow>\<^sub>A (P -* R)"
  by (metis ent_wand ent_frame_fwd ent_mp ent_refl star_assoc)

lemma emp_wand_same: "emp \<Longrightarrow>\<^sub>A (H -* H)"
  by (simp add: ent_wandI)

lemma emp_wand_equal: "(emp -* H) = H"
  apply(intro ent_iffI)
  apply (metis ent_mp norm_assertion_simps(1))
  by (simp add: ent_wandI)

lemma pure_wand_equal: "P \<Longrightarrow> (\<up>(P) -* H) = H"
  by (simp add: emp_wand_equal)

lemma pure_wand_ent: "(P \<Longrightarrow> (H1 \<Longrightarrow>\<^sub>A H2)) \<Longrightarrow> H1 \<Longrightarrow>\<^sub>A \<up>(P) -* H2"
  by (simp add: ent_wand)

lemma "\<up>(P \<longrightarrow> Q) \<Longrightarrow>\<^sub>A (\<up>(P) -* \<up>(Q))"
  by (simp add: pure_wand_ent)

lemma wand_uncurry: "(P*Q) -* R \<Longrightarrow>\<^sub>A P -* (Q -* R)"
  by (simp add: assn_aci ent_mp ent_wandI fr_rot)

lemma wand_absorb: "(P -* Q) * R \<Longrightarrow>\<^sub>A (P -* (Q * R))"
  by (smt (z3) ent_mp ent_refl ent_star_mono ent_wandI star_aci(2) star_aci(3))

lemma wand_ent_self: "P \<Longrightarrow>\<^sub>A Q -* (Q * P)"
  by (simp add: ent_wandI)

lemma wand_ent_cancel: "P * ((P * Q) -* R) \<Longrightarrow>\<^sub>A Q -* R"
  by (simp add: ent_wandI2 wand_uncurry)

lemma "\<exists>R. Q * R \<Longrightarrow>\<^sub>A P"
  using ent_mp by auto

lemma "P \<Longrightarrow>\<^sub>A Q * true \<Longrightarrow> P = Q * (Q -* P)"
  apply(intro ent_iffI)
proof(goal_cases)
  case 2
  then show ?case
    by (simp add: ent_mp)
next
  case test: 1
  show ?case
    unfolding entails_def
    apply clarsimp
  proof (goal_cases)
    case (1 a b)
    then have "(a,b) \<Turnstile> Q * true"
      using test entails_def
      by blast
    then obtain h as1 as2 where *:
        "(a,b) = (h, as1 \<union> as2) \<and> as1 \<inter> as2 = {} \<and> (h, as1) \<Turnstile> Q \<and> (h, as2) \<Turnstile> true"
    using mod_star_conv by auto
  then have "(h, as1 \<union> as2) \<Turnstile> P" "(a,b) = (h, as1 \<union> as2)"
    using "1" by blast+
  then show ?case
    apply simp
    thm star_assnI
    apply(intro star_assnI)
    apply (simp_all add: *)
    apply(intro wand_assnI)
    apply (meson "*" models_in_range)
    apply auto
    oops

end