section \<open>KBO\<close>

text \<open>
  Below, we formalize a variant of KBO that includes subterm coefficient functions.

  A more standard definition is obtained by setting all subterm coefficients to 1.
  For this special case it would be possible to define more efficient code-equations that
  do not have to evaluate subterm coefficients at all.
\<close>

theory KBO
  imports
    Lexicographic_Extension
    Term_Aux
    Polynomial_Factorization.Missing_List
begin

subsection \<open>Subterm Coefficient Functions\<close>

text \<open>
  Given a function @{term scf}, associating positions with subterm coefficients, and
  a list @{term xs}, the function @{term scf_list} yields an expanded list where  each
  element of @{term xs} is replicated a number of times according to its subterm coefficient.
\<close>
definition scf_list :: "(nat \<Rightarrow> nat) \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where
    "scf_list scf xs = concat (map (\<lambda>(x, i). replicate (scf i) x) (zip xs [0 ..< length xs]))"

lemma set_scf_list [simp]:
  assumes "\<forall>i < length xs. scf i > 0"
  shows "set (scf_list scf xs) = set xs"
  using assms by (auto simp: scf_list_def set_zip set_conv_nth[of xs])

lemma scf_list_subset: "set (scf_list scf xs) \<subseteq> set xs"
  by (auto simp: scf_list_def set_zip)

lemma scf_list_empty [simp]:
  "scf_list scf [] = []" by (auto simp: scf_list_def)

lemma scf_list_bef_i_aft [simp]:
  "scf_list scf (bef @ i # aft) =
    scf_list scf bef @ replicate (scf (length bef)) i @
    scf_list (\<lambda> i. scf (Suc (length bef + i))) aft"
  unfolding scf_list_def
proof (induct aft rule: List.rev_induct)
  case (snoc a aft)
  define bia where "bia = bef @ i # aft"
  have bia: "bef @ i # aft @ [a] = bia @ [a]" by (simp add: bia_def)
  have zip: "zip (bia @ [a]) [0..<length (bia @ [a])]
   = zip bia [0..<length bia] @ [(a, length bia)]" by simp
  have concat:
    "concat (map (\<lambda>(x, i). replicate (scf i) x) (zip bia [0..<length bia] @ [(a, length bia)])) =
      concat (map (\<lambda>(x, i). replicate (scf i) x) (zip bia [0..<length bia])) @
      replicate (scf (length bia)) a" by simp
  show ?case
    unfolding bia zip concat
    unfolding bia_def snoc
    by simp
qed simp

text \<open>
  The function @{term scf_term} replicates each argument a number of times according to its
  subterm coefficient function.
\<close>
fun scf_term :: "('f \<times> nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> ('f, 'v) term \<Rightarrow> ('f, 'v) term"
  where
    "scf_term scf (Var x) = (Var x)" |
    "scf_term scf (Fun f ts) = Fun f (scf_list (scf (f, length ts)) (map (scf_term scf) ts))"

lemma vars_term_scf_subset:
  "vars_term (scf_term scf s) \<subseteq> vars_term s"
proof (induct s)
  case (Fun f ss)
  have "vars_term (scf_term scf (Fun f ss)) =
    (\<Union>x\<in>set (scf_list (scf (f, length ss)) ss). vars_term (scf_term scf x))" by auto
  also have "\<dots> \<subseteq> (\<Union>x\<in>set ss. vars_term (scf_term scf x))"
    using scf_list_subset [of _ ss] by blast
  also have "\<dots> \<subseteq> (\<Union>x\<in>set ss. vars_term x)" using Fun by auto
  finally show ?case by auto
qed auto

lemma scf_term_subst:
  "scf_term scf (t \<cdot> \<sigma>) = scf_term scf t \<cdot> (\<lambda> x. scf_term scf (\<sigma> x))"
proof (induct t)
  case (Fun f ts)
  { fix t
    assume "t \<in> set (scf_list (scf (f, length ts)) ts)"
    with scf_list_subset [of _ ts] have "t \<in> set ts" by auto
    then have "scf_term scf (t \<cdot> \<sigma>) = scf_term scf t \<cdot> (\<lambda>x. scf_term scf (\<sigma> x))"  by (rule Fun) }
  then show ?case by auto
qed auto

subsection \<open>Weight Functions\<close>

locale weight_fun =
  fixes w :: "'f \<times> nat \<Rightarrow> nat"
    and w0 :: nat
    and scf :: "'f \<times> nat \<Rightarrow> nat \<Rightarrow> nat"
begin

text \<open>
  The \<^emph>\<open>weight\<close> of a term is computed recursively, where variables have weight @{term w0}
  and the weight of a compound term is computed by adding the weight of its root symbol
  @{term "w (f, n)"} to the weighted sum where weights of arguments are multiplied
  according to their subterm coefficients.
\<close>
fun weight :: "('f, 'v) term \<Rightarrow> nat"
  where
    "weight (Var x) = w0" |
    "weight (Fun f ts) =
    (let n = length ts; scff = scf (f, n) in
    w (f, n) + sum_list (map (\<lambda> (ti, i). weight ti * scff i) (zip ts [0 ..< n])))"

text \<open>
  Alternatively, we can replicate arguments via @{const scf_list}.
  The advantage is that then both @{const weight} and @{const scf_term} are defined
  via @{const scf_list}.
\<close>
lemma weight_simp [simp]:
  "weight (Fun f ts) = w (f, length ts) + sum_list (map weight (scf_list (scf (f, length ts)) ts))"
proof -
  define scff where "scff = (scf (f, length ts) :: nat \<Rightarrow> nat)"
  have "(\<Sum>(ti, i) \<leftarrow> zip ts [0..<length ts]. weight ti * scff i) =
   sum_list (map weight (scf_list scff ts))"
  proof (induct ts rule: List.rev_induct)
    case (snoc t ts)
    moreover
    { fix n
      have "sum_list (replicate n (weight t)) = n * weight t" by (induct n) auto }
    ultimately show ?case by (simp add: scf_list_def)
  qed simp
  then show ?thesis by (simp add: Let_def scff_def)
qed

declare weight.simps(2)[simp del]

abbreviation "SCF \<equiv> scf_term scf"

lemma sum_list_scf_list:
  assumes "\<And> i. i < length ts \<Longrightarrow> f i > 0"
  shows "sum_list (map weight ts) \<le> sum_list (map weight (scf_list f ts))"
  using assms unfolding scf_list_def
proof (induct ts rule: List.rev_induct)
  case (snoc t ts)
  have "sum_list (map weight ts) \<le>
    sum_list (map weight (concat (map (\<lambda>(x, i). replicate (f i) x) (zip ts [0..<length ts]))))"
    by (auto intro!: snoc)
  moreover
  from snoc(2) [of "length ts"] obtain n where "f (length ts) = Suc n" by (auto elim: lessE)
  ultimately show ?case by simp
qed simp

end

subsection \<open>Definition of KBO\<close>

text \<open>
  The precedence is given by three parameters:

  \<^item> a predicate @{term pr_strict} for strict decrease between two function symbols,
  \<^item> a predicate @{term pr_weak} for weak decrease between two function symbols, and
  \<^item> a function indicating whether a symbol is least in the precedence.
\<close>
locale kbo = weight_fun w w0 scf
  for w w0 and scf :: "'f \<times> nat \<Rightarrow> nat \<Rightarrow> nat" +
  fixes least :: "'f \<Rightarrow> bool"
    and pr_strict :: "'f \<times> nat \<Rightarrow> 'f \<times> nat \<Rightarrow> bool"
    and pr_weak :: "'f \<times> nat \<Rightarrow> 'f \<times> nat \<Rightarrow> bool"
begin

text \<open>
  The result of @{term kbo} is a pair of Booleans encoding strict/weak decrease.

  Interestingly, the bound on the lengths of the lists in the lexicographic extension is not
  required for KBO.
\<close>
fun kbo :: "('f, 'v) term \<Rightarrow> ('f, 'v) term \<Rightarrow> bool \<times> bool"
  where
    "kbo s t = (if (vars_term_ms (SCF t) \<subseteq># vars_term_ms (SCF s) \<and> weight t \<le> weight s)
      then if (weight t < weight s)
        then (True, True)
        else (case s of
          Var y \<Rightarrow> (False, (case t of Var x \<Rightarrow> x = y | Fun g ts \<Rightarrow> ts = [] \<and> least g))
        | Fun f ss \<Rightarrow> (case t of
            Var x \<Rightarrow> (True, True)
          | Fun g ts \<Rightarrow> if pr_strict (f, length ss) (g, length ts)
            then (True, True)
            else if pr_weak (f, length ss) (g, length ts)
            then lex_ext_unbounded kbo ss ts
            else (False, False)))
      else (False, False))"

text \<open>Abbreviations for strict (S) and nonstrict (NS) KBO.\<close>
abbreviation "S \<equiv> \<lambda> s t. fst (kbo s t)"
abbreviation "NS \<equiv> \<lambda> s t. snd (kbo s t)"

text \<open>
  For code-generation we do not compute the weights of @{term s} and @{term t} repeatedly.
\<close>
lemma kbo_code: "kbo s t = (let wt = weight t; ws = weight s in
    if (vars_term_ms (SCF t) \<subseteq># vars_term_ms (SCF s) \<and> wt \<le> ws)
    then if wt < ws
      then (True, True)
      else (case s of
        Var y \<Rightarrow> (False, (case t of Var x \<Rightarrow> True | Fun g ts \<Rightarrow> ts = [] \<and> least g))
      | Fun f ss \<Rightarrow> (case t of
          Var x \<Rightarrow> (True, True)
        | Fun g ts \<Rightarrow> let ff = (f, length ss); gg = (g, length ts) in
          if pr_strict ff gg
          then (True, True)
          else if pr_weak ff gg
            then lex_ext_unbounded kbo ss ts
            else (False, False)))
    else (False, False))"
  unfolding kbo.simps[of s t] Let_def
  by (auto simp del: kbo.simps split: term.splits)

end

declare kbo.kbo_code[code]
declare weight_fun.weight.simps[code]

lemma mset_replicate_mono:
  assumes "m1 \<subseteq># m2"
  shows "\<Union># (mset (replicate n m1)) \<subseteq># \<Union># (mset (replicate n m2))"
proof (induct n)
  case (Suc n)
  have "\<Union># (mset (replicate (Suc n) m1)) =
    \<Union># (mset (replicate n m1)) + m1" by simp
  also have "\<dots> \<subseteq># \<Union># (mset (replicate n m1)) + m2" using \<open>m1 \<subseteq># m2\<close> by auto
  also have "\<dots> \<subseteq># \<Union># (mset (replicate n m2)) + m2" using Suc by auto
  finally show ?case by (simp add: union_commute)
qed simp

text \<open>
  While the locale @{locale kbo} only fixes its parameters, we now demand that these
  parameters are sensible, e.g., encoding a well-founded precedence, etc.
\<close>
locale admissible_kbo =
  kbo w w0 scf least pr_strict pr_weak
  for w w0 pr_strict pr_weak and least :: "'f \<Rightarrow> bool" and scf +
  assumes w0: "w (f, 0) \<ge> w0" "w0 > 0"
    and adm: "w (f, 1) = 0 \<Longrightarrow> pr_weak (f, 1) (g, n)"
    and least: "least f = (w (f, 0) = w0 \<and> (\<forall> g. w (g, 0) = w0 \<longrightarrow> pr_weak (g, 0) (f, 0)))"
    and scf: "i < n \<Longrightarrow> scf (f, n) i > 0"
    and pr_weak_refl [simp]: "pr_weak fn fn"
    and pr_weak_trans: "pr_weak fn gm \<Longrightarrow> pr_weak gm hk \<Longrightarrow> pr_weak fn hk"
    and pr_strict: "pr_strict fn gm \<longleftrightarrow> pr_weak fn gm \<and> \<not> pr_weak gm fn"
    and pr_SN: "SN {(fn, gm). pr_strict fn gm}"
begin

lemma weight_w0: "weight t \<ge> w0"
proof (induct t)
  case (Fun f ts)
  show ?case
  proof (cases ts)
    case Nil
    with w0(1) have "w0 \<le> w (f, length ts)" by auto
    then show ?thesis by auto
  next
    case (Cons s ss)
    then obtain i where i: "i < length ts" by auto
    from scf[OF this] have scf: "0 < scf (f, length ts) i" by auto
    then obtain n where scf: "scf (f, length ts) i = Suc n" by (auto elim: lessE)
    from id_take_nth_drop[OF i] i obtain bef aft where ts: "ts = bef @ ts ! i # aft" and ii: "length bef = i" by auto
    define tsi where "tsi = ts ! i"
    note ts = ts[folded tsi_def]
    from i have tsi: "tsi \<in> set ts" unfolding tsi_def by auto
    from Fun[OF this] have w0: "w0 \<le> weight tsi" .
    show ?thesis using scf ii w0 unfolding ts
      by simp
  qed
qed simp

lemma weight_gt_0: "weight t > 0"
  using weight_w0 [of t] and w0 by arith

lemma weight_0 [iff]: "weight t = 0 \<longleftrightarrow> False"
  using weight_gt_0 [of t] by auto

lemma not_S_Var: "\<not> S (Var x) t"
  using weight_w0[of t] by (cases t, auto)

lemma S_imp_NS: "S s t \<Longrightarrow> NS s t"
proof (induct s t rule: kbo.induct)
  case (1 s t)
  from 1(2) have S: "S s t" .
  from S have w: "vars_term_ms (SCF t) \<subseteq># vars_term_ms (SCF s) \<and> weight t \<le> weight s"
    by (auto split: if_splits)
  note S = S w
  note IH = 1(1)[OF w]
  show ?case
  proof (cases "weight t < weight s")
    case True
    with S show ?thesis by simp
  next
    case False
    note IH = IH[OF False]
    note S = S False
    from not_S_Var[of _ t] S
    obtain f ss where s: "s = Fun f ss" by (cases s, auto)
    note IH = IH[OF s]
    show ?thesis
    proof (cases t)
      case (Var x)
      from S show ?thesis by (auto, insert Var s, auto)
    next
      case (Fun g ts)
      note IH = IH[OF Fun]
      let ?f = "(f, length ss)"
      let ?g = "(g, length ts)"
      let ?lex = "lex_ext_unbounded kbo ss ts"
      from S[simplified, unfolded s Fun] have disj: "pr_strict ?f ?g \<or> pr_weak ?f ?g \<and> fst ?lex" by (auto split: if_splits)
      show ?thesis
      proof (cases "pr_strict ?f ?g")
        case True
        then show ?thesis using S s Fun by auto
      next
        case False
        with disj have fg: "pr_weak ?f ?g" and lex: "fst ?lex" by auto
        note IH = IH[OF False fg]
        from lex have "fst (lex_ext kbo (length ss + length ts) ss ts)"
          unfolding lex_ext_def Let_def by auto
        from lex_ext_stri_imp_nstri[OF this] have lex: "snd ?lex"
          unfolding lex_ext_def Let_def by auto
        with False fg S s Fun show ?thesis by auto
      qed
    qed
  qed
qed

subsection \<open>Reflexivity and Irreflexivity\<close>

lemma NS_refl: "NS s s"
proof (induct s)
  case (Fun f ss)
  have "snd (lex_ext kbo (length ss) ss ss)"
    by (rule all_nstri_imp_lex_nstri, insert Fun[unfolded set_conv_nth], auto)
  then have "snd (lex_ext_unbounded kbo ss ss)" unfolding lex_ext_def Let_def by simp
  then show ?case by auto
qed simp

lemma pr_strict_irrefl: "\<not> pr_strict fn fn"
  unfolding pr_strict by auto

lemma S_irrefl: "\<not> S t t"
proof (induct t)
  case (Var x) then show ?case by (rule not_S_Var)
next
  case (Fun f ts)
  from pr_strict_irrefl have "\<not> pr_strict (f, length ts) (f, length ts)" .
  moreover
  { assume "fst (lex_ext_unbounded kbo ts ts)"
    then obtain i where "i < length ts" and "S (ts ! i) (ts ! i)"
      unfolding lex_ext_unbounded_iff by auto
    with Fun have False by auto }
  ultimately show ?case by auto
qed

subsection \<open>Monotonicity (a.k.a. Closure under Contexts)\<close>

lemma S_mono_one:
  assumes S: "S s t"
  shows "S (Fun f (ss1 @ s # ss2)) (Fun f (ss1 @ t # ss2))"
proof -
  let ?ss = "ss1 @ s # ss2"
  let ?ts = "ss1 @ t # ss2"
  let ?s = "Fun f ?ss"
  let ?t = "Fun f ?ts"
  from S have w: "weight t \<le> weight s" and v: "vars_term_ms (SCF t) \<subseteq># vars_term_ms (SCF s)"
    by (auto split: if_splits)
  have v': "vars_term_ms (SCF ?t) \<subseteq># vars_term_ms (SCF ?s)" using mset_replicate_mono[OF v] by simp
  have w': "weight ?t \<le> weight ?s" using sum_list_replicate_mono[OF w] by simp
  have lex: "fst (lex_ext_unbounded kbo ?ss ?ts)"
    unfolding lex_ext_unbounded_iff fst_conv
    by (rule disjI1, rule exI[of _ "length ss1"], insert S NS_refl, auto simp del: kbo.simps simp: nth_append)
  show ?thesis using v' w' lex by simp
qed

lemma S_ctxt: "S s t \<Longrightarrow> S (C\<langle>s\<rangle>) (C\<langle>t\<rangle>)"
  by (induct C, auto simp del: kbo.simps intro: S_mono_one)

lemma NS_mono_one:
  assumes NS: "NS s t" shows "NS (Fun f (ss1 @ s # ss2)) (Fun f (ss1 @ t # ss2))"
proof -
  let ?ss = "ss1 @ s # ss2"
  let ?ts = "ss1 @ t # ss2"
  let ?s = "Fun f ?ss"
  let ?t = "Fun f ?ts"
  from NS have w: "weight t \<le> weight s" and v: "vars_term_ms (SCF t) \<subseteq># vars_term_ms (SCF s)"
    by (auto split: if_splits)
  have v': "vars_term_ms (SCF ?t) \<subseteq># vars_term_ms (SCF ?s)" using mset_replicate_mono[OF v] by simp
  have w': "weight ?t \<le> weight ?s" using sum_list_replicate_mono[OF w] by simp
  have lex: "snd (lex_ext_unbounded kbo ?ss ?ts)"
    unfolding lex_ext_unbounded_iff snd_conv
  proof (intro disjI2 conjI allI impI)
    fix i
    assume "i < length (ss1 @ t # ss2)"
    then show "NS (?ss ! i) (?ts ! i)" using NS NS_refl
      by (cases "i = length ss1", auto simp del: kbo.simps simp: nth_append)
  qed simp
  show ?thesis using v' w' lex by simp
qed

lemma NS_ctxt: "NS s t \<Longrightarrow> NS (C\<langle>s\<rangle>) (C\<langle>t\<rangle>)"
  by (induct C, auto simp del: kbo.simps intro: NS_mono_one)

subsection \<open>The Subterm Property\<close>

lemma NS_Var_imp_eq_least: "NS (Var x) t \<Longrightarrow> t = Var x \<or> (\<exists> f. t = Fun f [] \<and> least f)"
  by (cases t, insert weight_w0[of t], auto split: if_splits)

lemma kbo_supt_one: "NS s (t :: ('f, 'v) term) \<Longrightarrow> S (Fun f (bef @ s # aft)) t"
proof (induct t arbitrary: f s bef aft)
  case (Var x)
  note NS = this
  let ?ss = "bef @ s # aft"
  let ?t = "Var x"
  have "length bef < length ?ss" by auto
  from scf[OF this, of f] obtain n where scf:"scf (f, length ?ss) (length bef) = Suc n" by (auto elim: lessE)
  obtain X where "vars_term_ms (SCF (Fun f ?ss)) = vars_term_ms (SCF s) + X"
    by (simp add: o_def scf[simplified])
  then have vs: "vars_term_ms (SCF s) \<subseteq># vars_term_ms (SCF (Fun f ?ss))" by simp
  from NS have vt: "vars_term_ms (SCF ?t) \<subseteq># vars_term_ms (SCF s)" by (auto split: if_splits)
  from vt vs have v: "vars_term_ms (SCF ?t) \<subseteq># vars_term_ms (SCF (Fun f ?ss))" by (rule subset_mset.order_trans)
  from weight_w0[of "Fun f ?ss"] v show ?case by simp
next
  case (Fun g ts f s bef aft)
  let ?t = "Fun g ts"
  let ?ss = "bef @ s # aft"
  note NS = Fun(2)
  note IH = Fun(1)
  have "length bef < length ?ss" by auto
  from scf[OF this, of f] obtain n where scff:"scf (f, length ?ss) (length bef) = Suc n" by (auto elim: lessE)
  note scff = scff[simplified]
  obtain X where "vars_term_ms (SCF (Fun f ?ss)) = vars_term_ms (SCF s) + X"
    by (simp add: o_def scff)
  then have vs: "vars_term_ms (SCF s) \<subseteq># vars_term_ms (SCF (Fun f ?ss))" by simp
  have ws: "weight s \<le> sum_list (map weight (scf_list (scf (f, length ?ss)) ?ss))"
    by (simp add: scff)
  from NS have wt: "weight ?t \<le> weight s" and
    vt: "vars_term_ms (SCF ?t) \<subseteq># vars_term_ms (SCF s)" by (auto split: if_splits)
  from ws wt have w: "weight ?t \<le> sum_list (map weight (scf_list (scf (f, length ?ss)) ?ss))" by simp
  from vt vs have v: "vars_term_ms (SCF ?t) \<subseteq># vars_term_ms (SCF (Fun f ?ss))" by auto
  then have v': "(vars_term_ms (SCF ?t) \<subseteq># vars_term_ms (SCF (Fun f ?ss))) = True" by simp
  show ?case
  proof (cases "weight ?t = weight (Fun f ?ss)")
    case False
    with w v show ?thesis by auto
  next
    case True
    from wt[unfolded True] weight_gt_0[of s]
    have wf: "w (f, length ?ss) = 0"
      and lsum: "sum_list (map weight (scf_list (scf (f, length ?ss)) bef)) = 0"
      "sum_list (map weight (scf_list (\<lambda> i. (scf (f, length ?ss) (Suc (length bef) + i))) aft)) = 0"
      and n: "n = 0"
      by (auto simp: scff)
    have "sum_list (map weight bef) \<le> sum_list (map weight (scf_list (scf (f, length ?ss)) bef))"
      by (rule sum_list_scf_list, rule scf, auto)
    with lsum(1) have "sum_list (map weight bef) = 0" by arith
    then have bef: "bef = []" using weight_gt_0[of "hd bef"] by (cases bef, auto)
    have "sum_list (map weight aft) \<le> sum_list (map weight (scf_list (\<lambda> i. (scf (f, length ?ss) (Suc (length bef) + i))) aft))"
      by (rule sum_list_scf_list, rule scf, auto)
    with lsum(2) have "sum_list (map weight aft) = 0" by arith
    then have aft: "aft = []" using weight_gt_0[of "hd aft"] by (cases aft, auto)
    note scff = scff[unfolded bef aft n, simplified]
    from bef aft
    have ba: "bef @ s # aft = [s]" by simp
    with wf have wf: "w (f, 1) = 0" by auto
    from wf have wst: "weight s = weight ?t" using scff unfolding True[unfolded ba]
      by (simp add: scf_list_def)
    let ?g = "(g, length ts)"
    let ?f = "(f, 1)"
    show ?thesis
    proof (cases "pr_strict ?f ?g")
      case True
      with w v show ?thesis unfolding ba by simp
    next
      case False
      note admf = adm[OF wf]
      from admf have pg: "pr_weak ?f ?g" .
      from pg False[unfolded pr_strict] have "pr_weak ?g ?f" by auto
      from pr_weak_trans[OF this admf] have g: "\<And> h k. pr_weak ?g (h, k)" .
      show ?thesis
      proof (cases ts)
        case Nil
        have "fst (lex_ext_unbounded kbo [s] ts)"
          unfolding Nil lex_ext_unbounded_iff by auto
        with pg w v show ?thesis unfolding ba by simp
      next
        case (Cons t tts)
        {
          fix x
          assume s: "s = Var x"
          from NS_Var_imp_eq_least[OF NS[unfolded s Cons]] have False by auto
        }
        then obtain h ss where s: "s = Fun h ss" by (cases s, auto)
        from NS wst g[of h "length ss"] pr_strict[of "(h, length ss)" "(g, length ts)"] have lex: "snd (lex_ext_unbounded kbo ss ts)"
          unfolding s by (auto split: if_splits)
        from lex obtain s0 sss where ss: "ss = s0 # sss" unfolding Cons lex_ext_unbounded_iff snd_conv by (cases ss, auto)
        from lex[unfolded ss Cons] have "S s0 t \<or> NS s0 t"
          by (cases "kbo s0 t", simp add: lex_ext_unbounded.simps del: kbo.simps split: if_splits)
        with S_imp_NS[of s0 t] have "NS s0 t" by blast
        from IH[OF _ this, of h Nil sss] have S: "S s t" unfolding Cons s ss by simp
        have "fst (lex_ext_unbounded kbo [s] ts)" unfolding Cons
          unfolding lex_ext_unbounded_iff fst_conv
          by (rule disjI1[OF exI[of _ 0]], insert S, auto simp del: kbo.simps)
        then have lex: "fst (lex_ext_unbounded kbo [s] ts) = True" by simp
        note all = lex wst[symmetric] S pg scff v'
        note all = all[unfolded ba, unfolded s ss Cons]
        have w: "weight (Fun f [t]) = weight (t :: ('f, 'v) term)" for t
          using wf scff by (simp add: scf_list_def)
        show ?thesis unfolding ba unfolding s ss Cons
          unfolding kbo.simps[of "Fun f [Fun h (s0 # sss)]"]
          unfolding all w using all by simp
      qed
    qed
  qed
qed

lemma S_supt:
  assumes supt: "s \<rhd> t"
  shows "S s t"
proof -
  from supt obtain C where s: "s = C\<langle>t\<rangle>" and C: "C \<noteq> \<box>" by auto
  show ?thesis unfolding s using C
  proof (induct C arbitrary: t)
    case (More f bef C aft t)
    show ?case
    proof (cases "C = \<box>")
      case True
      from kbo_supt_one[OF NS_refl, of f bef t aft] show ?thesis unfolding True by simp
    next
      case False
      from kbo_supt_one[OF S_imp_NS[OF More(1)[OF False]], of f bef t aft]
      show ?thesis by simp
    qed
  qed simp
qed

lemma NS_supteq:
  assumes "s \<unrhd> t"
  shows "NS s t"
  using S_imp_NS[OF S_supt[of s t]] NS_refl[of s] using assms[unfolded subterm.le_less]
  by blast

subsection \<open>Least Elements\<close>

lemma NS_all_least:
  assumes l: "least f"
  shows "NS t (Fun f [])"
proof (induct t)
  case (Var x)
  show ?case using l[unfolded least] l
    by auto
next
  case (Fun g ts)
  show ?case
  proof (cases ts)
    case (Cons s ss)
    with Fun[of s] have "NS s (Fun f [])" by auto
    from S_imp_NS[OF kbo_supt_one[OF this, of g Nil ss]] show ?thesis unfolding Cons by simp
  next
    case Nil
    from weight_w0[of "Fun g []"] have w: "weight (Fun g []) \<ge> weight (Fun f [])"
      using l[unfolded least] by auto
    from lex_ext_least_1
    have "snd (lex_ext kbo 0 [] [])" .
    then have lex: "snd (lex_ext_unbounded kbo [] [])" unfolding lex_ext_def Let_def by simp
    then show ?thesis using w l[unfolded least] unfolding Fun Nil by (auto simp: empty_le)
  qed
qed

lemma not_S_least:
  assumes l: "least f"
  shows "\<not> S (Fun f []) t"
proof (cases t)
  case (Fun g ts)
  show ?thesis unfolding Fun
  proof
    assume S: "S (Fun f []) (Fun g ts)"
    from S[unfolded Fun, simplified]
    have w: "w (g, length ts) + sum_list (map weight (scf_list (scf (g, length ts)) ts)) \<le> weight (Fun f [])"
      by (auto split: if_splits)
    show False
    proof (cases ts)
      case Nil
      with w have "w (g, 0) \<le> weight (Fun f [])" by simp
      also have "weight (Fun f []) \<le> w0" using l[unfolded least] by simp
      finally have g: "w (g, 0) = w0" using  w0(1)[of g] by auto
      with w Nil l[unfolded least] have gf: "w (g, 0) = w (f, 0)" by simp
      with S have p: "pr_weak (f, 0) (g, 0)" unfolding Nil
        by (simp split: if_splits add: pr_strict)
      with l[unfolded least, THEN conjunct2, rule_format, OF g] have p2: "pr_weak (g, 0) (f, 0)" by auto
      from p p2 gf S have "fst (lex_ext_unbounded kbo [] ts)" unfolding Nil
        by (auto simp: pr_strict)
      then show False unfolding lex_ext_unbounded_iff by auto
    next
      case (Cons s ss)
      then have ts: "ts = [] @ s # ss" by auto
      from scf[of 0 "length ts" g] obtain n where scff: "scf (g, length ts) 0 = Suc n" unfolding Cons by (auto elim: lessE)
      let ?e = "sum_list (map weight (
          scf_list (\<lambda>i. scf (g, Suc (length ss)) (Suc i)) ss
          ))"
      have "w0 + sum_list (map weight (replicate n s)) \<le> weight s + sum_list (map weight (replicate n s))"
        using weight_w0[of s] by auto
      also have "\<dots> = sum_list (map weight (replicate (scf (g, length ts) 0) s))" unfolding scff by simp
      also have "w (g, length ts) + \<dots> + ?e \<le> w0" using w l[unfolded least] unfolding ts scf_list_bef_i_aft by auto
      finally have "w0 + sum_list (map weight (replicate n s)) + w (g, length ts) + ?e \<le> w0" by arith
      then have wg: "w (g, length ts) = 0" and null: "?e = 0" "sum_list (map weight (replicate n s)) = 0" by auto
      from null(2) weight_gt_0[of s] have n: "n = 0" by (cases n, auto)
      have "sum_list (map weight ss) \<le> ?e"
        by (rule sum_list_scf_list, rule scf, auto)
      from this[unfolded null] weight_gt_0[of "hd ss"] have ss: "ss = []" by (cases ss, auto)
      with Cons have ts: "ts = [s]" by simp
      note scff = scff[unfolded ts n, simplified]
      from wg ts have wg: "w (g, 1) = 0" by auto
      from adm[OF wg, rule_format, of f] have "pr_weak (g, 1) (f, 0)" by auto
      with S[unfolded Fun ts] l[unfolded least] weight_w0[of s] scff
      have "fst (lex_ext_unbounded kbo [] [s])"
        by (auto split: if_splits simp: scf_list_def pr_strict)
      then show ?thesis unfolding lex_ext_unbounded_iff by auto
    qed
  qed
qed simp

lemma NS_least_least:
  assumes l: "least f"
    and NS: "NS (Fun f []) t"
  shows "\<exists> g. t = Fun g [] \<and> least g"
proof (cases t)
  case (Var x)
  show ?thesis using NS unfolding Var by simp
next
  case (Fun g ts)
  from NS[unfolded Fun, simplified]
  have w: "w (g, length ts) + sum_list (map weight (scf_list (scf (g, length ts)) ts)) \<le> weight (Fun f [])"
    by (auto split: if_splits)
  show ?thesis
  proof (cases ts)
    case Nil
    with w have "w (g, 0) \<le> weight (Fun f [])" by simp
    also have "weight (Fun f []) \<le> w0" using l[unfolded least] by simp
    finally have g: "w (g, 0) = w0" using  w0(1)[of g] by auto
    with w Nil l[unfolded least] have gf: "w (g, 0) = w (f, 0)" by simp
    with NS[unfolded Fun] have p: "pr_weak (f, 0) (g, 0)" unfolding Nil
      by (simp split: if_splits add: pr_strict)
    have least: "least g" unfolding least
    proof (rule conjI[OF g], intro allI)
      fix h
      from l[unfolded least] have "w (h, 0) = w0 \<longrightarrow> pr_weak (h, 0) (f, 0)" by blast
      with pr_weak_trans p show "w (h, 0) = w0 \<longrightarrow> pr_weak (h, 0) (g, 0)" by blast
    qed
    show ?thesis
      by (rule exI[of _ g], unfold Fun Nil, insert least, auto)
  next
    case (Cons s ss)
    then have ts: "ts = [] @ s # ss" by auto
    from scf[of 0 "length ts" g] obtain n where scff: "scf (g, length ts) 0 = Suc n" unfolding Cons by (auto elim: lessE)
    let ?e = "sum_list (map weight (
        scf_list (\<lambda>i. scf (g, Suc (length ss)) (Suc i)) ss
      ))"
    have "w0 + sum_list (map weight (replicate n s)) \<le> weight s + sum_list (map weight (replicate n s))"
      using weight_w0[of s] by auto
    also have "\<dots> = sum_list (map weight (replicate (scf (g, length ts) 0) s))" unfolding scff by simp
    also have "w (g, length ts) + \<dots> + ?e \<le> w0" using w l[unfolded least] unfolding ts scf_list_bef_i_aft by auto
    finally have "w0 + sum_list (map weight (replicate n s)) + w (g, length ts) + ?e \<le> w0" by arith
    then have wg: "w (g, length ts) = 0" and null: "?e = 0" "sum_list (map weight (replicate n s)) = 0" by auto
    from null(2) weight_gt_0[of s] have n: "n = 0" by (cases n, auto)
    have "sum_list (map weight ss) \<le> ?e"
      by (rule sum_list_scf_list, rule scf, auto)
    from this[unfolded null] weight_gt_0[of "hd ss"] have ss: "ss = []" by (cases ss, auto)
    with Cons have ts: "ts = [s]" by simp
    note scff = scff[unfolded ts n, simplified]
    from wg ts have wg: "w (g, 1) = 0" by auto
    from adm[OF wg, rule_format, of f] have "pr_weak (g, 1) (f, 0)" by auto
    with NS[unfolded Fun ts] l[unfolded least] weight_w0[of s] scff
    have "snd (lex_ext_unbounded kbo [] [s])"
      by (auto split: if_splits simp: scf_list_def pr_strict)
    then show ?thesis unfolding lex_ext_unbounded_iff snd_conv by auto
  qed
qed

subsection \<open>Stability (a.k.a. Closure under Substitutions\<close>

lemma weight_subst: "weight (t \<cdot> \<sigma>) =
  weight t + sum_mset (image_mset (\<lambda> x. weight (\<sigma> x) - w0) (vars_term_ms (SCF t)))"
proof (induct t)
  case (Var x)
  show ?case using weight_w0[of "\<sigma> x"] by auto
next
  case (Fun f ts)
  let ?ts = "scf_list (scf (f, length ts)) ts"
  define sts where "sts = ?ts"
  have id: "map (\<lambda> t. weight (t \<cdot> \<sigma>)) ?ts = map (\<lambda> t. weight t + sum_mset (image_mset (\<lambda> x. weight (\<sigma> x) - w0) (vars_term_ms (scf_term scf t)))) ?ts"
    by (rule map_cong[OF refl Fun], insert scf_list_subset[of _ ts], auto)
  show ?case
    by (simp add: o_def id, unfold sts_def[symmetric], induct sts, auto)
qed

lemma weight_stable_le:
  assumes ws: "weight s \<le> weight t"
    and vs: "vars_term_ms (SCF s) \<subseteq># vars_term_ms (SCF t)"
  shows "weight (s \<cdot> \<sigma>) \<le> weight (t \<cdot> \<sigma>)"
proof -
  from vs[unfolded mset_subset_eq_exists_conv] obtain u where vt: "vars_term_ms (SCF t) = vars_term_ms (SCF s) + u" ..
  show ?thesis unfolding weight_subst vt using ws by auto
qed

lemma weight_stable_lt:
  assumes ws: "weight s < weight t"
    and vs: "vars_term_ms (SCF s) \<subseteq># vars_term_ms (SCF t)"
 shows "weight (s \<cdot> \<sigma>) < weight (t \<cdot> \<sigma>)"
proof -
  from vs[unfolded mset_subset_eq_exists_conv] obtain u where vt: "vars_term_ms (SCF t) = vars_term_ms (SCF s) + u" ..
  show ?thesis unfolding weight_subst vt using ws by auto
qed

text \<open>KBO is stable, i.e., closed under substitutions.\<close>
lemma kbo_stable:
  fixes \<sigma> :: "('f, 'v) subst"
  assumes "NS s t"
  shows "(S s t \<longrightarrow> S (s \<cdot> \<sigma>) (t \<cdot> \<sigma>)) \<and> NS (s \<cdot> \<sigma>) (t \<cdot> \<sigma>)" (is "?P s t")
  using assms
proof (induct s arbitrary: t)
  case (Var y t)
  then have not: "\<not> S (Var y) t" using not_S_Var[of y t] by auto
  from NS_Var_imp_eq_least[OF Var]
  have "t = Var y \<or> (\<exists> f. t = Fun f [] \<and> least f)" by simp
  then obtain f where "t = Var y \<or> t = Fun f [] \<and> least f" by auto
  then have "NS (Var y \<cdot> \<sigma>) (t \<cdot> \<sigma>)"
  proof
    assume "t = Var y"
    then show ?thesis using NS_refl[of "t \<cdot> \<sigma>"] by auto
  next
    assume "t = Fun f [] \<and> least f"
    with NS_all_least[of f "Var y \<cdot> \<sigma>"] show ?thesis by auto
  qed
  with not show ?case by blast
next
  case (Fun f ss t)
  note NS = Fun(2)
  note IH = Fun(1)
  let ?s = "Fun f ss"
  define s where "s = ?s"
  let ?ss = "map (\<lambda> s. s \<cdot> \<sigma>) ss"
  from NS have v: "vars_term_ms (SCF t) \<subseteq># vars_term_ms (SCF ?s)" and w: "weight t \<le> weight ?s"
    by (auto split: if_splits)
  from weight_stable_le[OF w v] have w\<sigma>: "weight (t \<cdot> \<sigma>) \<le> weight (?s \<cdot> \<sigma>)" by auto
  from vars_term_ms_subst_mono[OF v, of "\<lambda> x. SCF (\<sigma> x)"] have v\<sigma>: "vars_term_ms (SCF (t \<cdot> \<sigma>)) \<subseteq># vars_term_ms (SCF (?s \<cdot> \<sigma>))"
    unfolding scf_term_subst .
  show ?case
  proof (cases "weight (t \<cdot> \<sigma>) < weight (?s \<cdot> \<sigma>)")
    case True
    with v\<sigma> show ?thesis by auto
  next
    case False
    with weight_stable_lt[OF _ v, of \<sigma>] w have w: "weight t = weight ?s" by arith
    show ?thesis
    proof (cases t)
      case (Var y)
      from set_mset_mono[OF v, folded s_def]
      have "y \<in> vars_term (SCF s)" unfolding Var by (auto simp: o_def)
      also have "\<dots> \<subseteq> vars_term s" by (rule vars_term_scf_subset)
      finally have "y \<in> vars_term s" by auto
      from supteq_Var[OF this] have "?s \<rhd> Var y" unfolding s_def Fun by auto
      from S_supt[OF supt_subst[OF this]] have S: "S (?s \<cdot> \<sigma>) (t \<cdot> \<sigma>)" unfolding Var .
      from S_imp_NS[OF S] S show ?thesis by auto
    next
      case (Fun g ts) note t = this
      let ?f = "(f, length ss)"
      let ?g = "(g, length ts)"
      let ?ts = "map (\<lambda> s. s \<cdot> \<sigma>) ts"
      show ?thesis
      proof (cases "pr_strict ?f ?g")
        case True
        then have S: "S (?s \<cdot> \<sigma>) (t \<cdot> \<sigma>)" using w\<sigma> v\<sigma> unfolding t by simp
        from S S_imp_NS[OF S] show ?thesis by simp
      next
        case False note prec = this
        show ?thesis
        proof (cases "pr_weak ?f ?g")
          case False
          with v w prec have "\<not> NS ?s t" unfolding t by (auto simp del: vars_term_ms.simps)
          with NS show ?thesis by blast
        next
          case True
          from v w have "vars_term_ms (SCF t) \<subseteq># vars_term_ms (SCF ?s) \<and> weight t \<le> weight ?s" "\<not> weight t < weight ?s" by auto
          {
            fix i
            assume i: "i < length ss" "i < length ts"
              and S: "S (ss ! i) (ts ! i)"
            have "S (map (\<lambda>s. s \<cdot> \<sigma>) ss ! i) (map (\<lambda>s. s \<cdot> \<sigma>) ts ! i)"
              using IH[OF _ S_imp_NS[OF S]] S i unfolding set_conv_nth by (force simp del: kbo.simps)
          } note IH_S = this
          {
            fix i
            assume i: "i < length ss" "i < length ts"
              and NS: "NS (ss ! i) (ts ! i)"
            have "NS (map (\<lambda>s. s \<cdot> \<sigma>) ss ! i) (map (\<lambda>s. s \<cdot> \<sigma>) ts ! i)"
              using IH[OF _ NS] i unfolding set_conv_nth by (force simp del: kbo.simps)
          } note IH_NS = this
          {
            assume "S ?s t"
            with prec v w True have lex: "fst (lex_ext_unbounded kbo ss ts)"
              unfolding s_def t by simp
            have "fst (lex_ext_unbounded kbo ?ss ?ts)"
              by (rule lex_ext_unbounded_map_S[OF _ _ lex], insert IH_NS IH_S, blast+)
            with v\<sigma> w\<sigma> prec True have "S (?s \<cdot> \<sigma>) (t \<cdot> \<sigma>)"
              unfolding t by auto
          }
          moreover
          {
            from NS prec v w True have lex: "snd (lex_ext_unbounded kbo ss ts)"
              unfolding t by simp
            have "snd (lex_ext_unbounded kbo ?ss ?ts)"
              by (rule lex_ext_unbounded_map_NS[OF _ _ lex], insert IH_S IH_NS, blast)
            with v\<sigma> w\<sigma> prec True have "NS (?s \<cdot> \<sigma>) (t \<cdot> \<sigma>)"
              unfolding t by auto
          }
          ultimately show ?thesis by auto
        qed
      qed
    qed
  qed
qed

lemma S_subst:
  "S s t \<Longrightarrow> S (s \<cdot> (\<sigma> :: ('f, 'v) subst)) (t \<cdot> \<sigma>)"
  using kbo_stable[OF S_imp_NS, of s t \<sigma>] by auto

lemma NS_subst: "NS s t \<Longrightarrow> NS (s \<cdot> (\<sigma> :: ('f, 'v) subst)) (t \<cdot> \<sigma>)" using kbo_stable[of s t \<sigma>] by auto

subsection \<open>Transitivity and Compatibility\<close>

lemma kbo_trans: "(S s t \<longrightarrow> NS t u \<longrightarrow> S s u) \<and>
  (NS s t \<longrightarrow> S t u \<longrightarrow> S s u) \<and>
  (NS s t \<longrightarrow> NS t u \<longrightarrow> NS s u)"
  (is "?P s t u")
proof (induct s arbitrary: t u)
  case (Var x t u)
  from not_S_Var[of x t] have nS: "\<not> S (Var x) t" .
  show ?case
  proof (cases "NS (Var x) t")
    case False
    with nS show ?thesis by blast
  next
    case True
    from NS_Var_imp_eq_least[OF this] obtain f where
      "t = Var x \<or> t = Fun f [] \<and> least f" by blast
    then show ?thesis
    proof
      assume "t = Var x"
      then show ?thesis using nS by blast
    next
      assume "t = Fun f [] \<and> least f"
      then have t: "t = Fun f []" and least: "least f" by auto
      from not_S_least[OF least] have nS': "\<not> S t u" unfolding t .
      show ?thesis
      proof (cases "NS t u")
        case True
        with NS_least_least[OF least, of u] t obtain h where
          u: "u = Fun h []" and least: "least h" by auto
        from NS_all_least[OF least] have NS: "NS (Var x) u" unfolding u .
        with nS nS' show ?thesis by blast
      next
        case False
        with S_imp_NS[of t u] show ?thesis by blast
      qed
    qed
  qed
next
  case (Fun f ss t u) note IH = this
  let ?s = "Fun f ss"
  show ?case
  proof (cases "NS ?s t")
    case False
    with S_imp_NS[of ?s t] show ?thesis by blast
  next
    case True note st = this
    then have vst: "vars_term_ms (SCF t) \<subseteq># vars_term_ms (SCF ?s)" and wst: "weight t \<le> weight ?s"
      by (auto split: if_splits)
    show ?thesis
    proof (cases "NS t u")
      case False
      with S_imp_NS[of t u] show ?thesis by blast
    next
      case True note tu = this
      then have vtu: "vars_term_ms (SCF u) \<subseteq># vars_term_ms (SCF t)" and wtu: "weight u \<le> weight t"
        by (auto split: if_splits)
      from vst vtu have v: "vars_term_ms (SCF u) \<subseteq># vars_term_ms (SCF ?s)" by simp
      from wst wtu have w: "weight u \<le> weight ?s" by simp
      show ?thesis
      proof (cases "weight u < weight ?s")
        case True
        with v show ?thesis by auto
      next
        case False
        with wst wtu have wst: "weight t = weight ?s" and wtu: "weight u = weight t" and w: "weight u = weight ?s" by arith+
        show ?thesis
        proof (cases u)
          case (Var z)
          with v w show ?thesis by auto
        next
          case (Fun h us) note u = this
          show ?thesis
          proof (cases t)
            case (Fun g ts) note t = this
            let ?f = "(f, length ss)"
            let ?g = "(g, length ts)"
            let ?h = "(h, length us)"
            from st t wst have fg: "pr_weak ?f ?g" by (simp split: if_splits add: pr_strict)
            from tu t u wtu have gh: "pr_weak ?g ?h" by (simp split: if_splits add: pr_strict)
            from pr_weak_trans[OF fg gh] have fh: "pr_weak ?f ?h" .
            show ?thesis
            proof (cases "pr_strict ?f ?h")
              case True
              with w v u show ?thesis by auto
            next
              case False
              let ?lex = "lex_ext_unbounded kbo"
              from False fh have hf: "pr_weak ?h ?f" unfolding pr_strict by auto
              from pr_weak_trans[OF hf fg] have hg: "pr_weak ?h ?g" .
              from hg have gh2: "\<not> pr_strict ?g ?h" unfolding pr_strict by auto
              from pr_weak_trans[OF gh hf] have gf: "pr_weak ?g ?f" .
              from gf have fg2: "\<not> pr_strict ?f ?g" unfolding pr_strict by auto
              from st t wst fg2 have st: "snd (?lex ss ts)"
                by (auto split: if_splits)
              from tu t u wtu gh2 have tu: "snd (?lex ts us)"
                by (auto split: if_splits)
              {
                fix s t u
                assume "s \<in> set ss"
                from IH[OF this, of t u]
                have "(NS s t \<and> S t u \<longrightarrow> S s u) \<and>
                  (S s t \<and> NS t u \<longrightarrow> S s u) \<and>
                  (NS s t \<and> NS t u \<longrightarrow> NS s u) \<and>
                  (S s t \<and> S t u \<longrightarrow> S s u)"
                  using S_imp_NS[of s t] by blast
              } note IH = this
              let ?b = "length ss + length ts + length us"
              note lex = lex_ext_compat[of ss ts us kbo ?b, OF IH]
              let ?lexb = "lex_ext kbo ?b"
              note conv = lex_ext_def Let_def
              from st have st: "snd (?lexb ss ts)" unfolding conv by simp
              from tu have tu: "snd (?lexb ts us)" unfolding conv by simp
              from lex st tu have su: "snd (?lexb ss us)" by blast
              then have su: "snd (?lex ss us)" unfolding conv by simp
              from w v u su fh have NS: "NS ?s u" by simp
              {
                assume st: "S ?s t"
                with t wst fg fg2 have st: "fst (?lex ss ts)"
                  by (auto split: if_splits)
                then have st: "fst (?lexb ss ts)" unfolding conv by simp
                from lex st tu have su: "fst (?lexb ss us)" by blast
                then have su: "fst (?lex ss us)" unfolding conv by simp
                from w v u su fh have S: "S ?s u" by simp
              } note S_left = this
              {
                assume tu: "S t u"
                with t u wtu gh2 have tu: "fst (?lex ts us)"
                  by (auto split: if_splits)
                then have tu: "fst (?lexb ts us)" unfolding conv by simp
                from lex st tu have su: "fst (?lexb ss us)" by blast
                then have su: "fst (?lex ss us)" unfolding conv by simp
                from w v u su fh have S: "S ?s u" by simp
              } note S_right = this
              from NS S_left S_right show ?thesis by blast
            qed
          next
            case (Var x) note t = this
            from tu weight_w0[of u] have least: "least h" and u: "u = Fun h []" unfolding t u
              by (auto split: if_splits)
            from NS_all_least[OF least] have NS: "NS ?s u" unfolding u .
            from not_S_Var have nS': "\<not> S t u" unfolding t .
            show ?thesis
            proof (cases "S ?s t")
              case False
              with nS' NS show ?thesis by blast
            next
              case True
              then have "vars_term_ms (SCF t) \<subseteq># vars_term_ms (SCF ?s)"
                by (auto split: if_splits)
              from set_mset_mono[OF this, unfolded set_mset_vars_term_ms t]
              have "x \<in> vars_term (SCF ?s)" by simp
              also have "\<dots> \<subseteq> vars_term ?s" by (rule vars_term_scf_subset)
              finally obtain s sss where ss: "ss = s # sss" by (cases ss, auto)
              from kbo_supt_one[OF NS_all_least[OF least, of s], of f Nil sss]
              have "S ?s u" unfolding ss u by simp
              with NS show ?thesis by blast
            qed
          qed
        qed
      qed
    qed
  qed
qed

lemma S_trans: "S s t \<Longrightarrow> S t u \<Longrightarrow> S s u" using S_imp_NS[of s t] kbo_trans[of s t u] by blast
lemma NS_trans: "NS s t \<Longrightarrow> NS t u \<Longrightarrow> NS s u" using kbo_trans[of s t u] by blast
lemma NS_S_compat: "NS s t \<Longrightarrow> S t u \<Longrightarrow> S s u" using kbo_trans[of s t u] by blast
lemma S_NS_compat: "S s t \<Longrightarrow> NS t u \<Longrightarrow> S s u" using kbo_trans[of s t u] by blast

subsection \<open>Strong Normalization (a.k.a. Well-Foundedness)\<close>

lemma kbo_strongly_normalizing:
  fixes s :: "('f, 'v) term"
  shows "SN_on {(s, t). S s t} {s}"
proof -
  let ?SN = "\<lambda> t :: ('f, 'v) term. SN_on {(s, t). S s t} {t}"
  let ?m1 = "\<lambda> (f, ss). weight (Fun f ss)"
  let ?m2 = "\<lambda> (f, ss). (f, length ss)"
  let ?rel' = "lex_two {(fss, gts). ?m1 fss > ?m1 gts} {(fss, gts). ?m1 fss \<ge> ?m1 gts} {(fss, gts). pr_strict (?m2 fss) (?m2 gts)}"
  let ?rel = "inv_image ?rel' (\<lambda> x. (x, x))"
  have SN_rel: "SN ?rel"
    by (rule SN_inv_image, rule lex_two, insert SN_inv_image[OF pr_SN, of ?m2]  SN_inv_image[OF SN_nat_gt, of ?m1],
        auto simp: inv_image_def)
  note conv = SN_on_all_reducts_SN_on_conv
  show "?SN s"
  proof (induct s)
    case (Var x)
    show ?case unfolding conv[of _ "Var x"] using not_S_Var[of x] by auto
  next
    case (Fun f ss)
    then have subset: "set ss \<subseteq> {s. ?SN s}" by blast
    let ?P = "\<lambda> (f, ss). set ss \<subseteq> {s. ?SN s} \<longrightarrow> ?SN (Fun f ss)"
    {
      fix fss
      have "?P fss"
      proof (induct fss rule: SN_induct[OF SN_rel])
        case (1 fss)
        obtain f ss where fss: "fss = (f, ss)" by force
        {
          fix g ts
          assume "?m1 (f, ss) > ?m1 (g, ts) \<or> ?m1 (f, ss) \<ge> ?m1 (g, ts) \<and> pr_strict (?m2 (f, ss)) (?m2 (g, ts))"
            and "set ts \<subseteq> {s. ?SN s}"
          then have "?SN (Fun g ts)"
            using 1[rule_format, of "(g, ts)", unfolded fss split] by auto
        } note IH = this[unfolded split]
        show ?case unfolding fss split
        proof
          assume SN_s: "set ss \<subseteq> {s. ?SN s}"
          let ?f = "(f, length ss)"
          let ?s = "Fun f ss"
          let ?SNt = "\<lambda> g ts. ?SN (Fun g ts)"
          let ?sym = "\<lambda> g ts. (g, length ts)"
          let ?lex = "lex_ext kbo (weight ?s)"
          let ?lexu = "lex_ext_unbounded kbo"
          let ?lex_SN = "{(ys, xs). (\<forall> y \<in> set ys. ?SN y) \<and> fst (?lex ys xs)}"
          from lex_ext_SN[of kbo "weight ?s", OF NS_S_compat]
          have SN: "SN ?lex_SN" .
          {
            fix g and ts :: "('f, 'v) term list"
            assume "pr_weak ?f (?sym g ts) \<and> weight (Fun g ts) \<le> weight ?s \<and> set ts \<subseteq> {s. ?SN s}"
            then have "?SNt g ts"
            proof (induct ts arbitrary: g rule: SN_induct[OF SN])
              case (1 ts g)
              note inner_IH = 1(1)
              let ?g = "(g, length ts)"
              let ?t = "Fun g ts"
              from 1(2) have fg: "pr_weak ?f ?g" and w: "weight ?t \<le> weight ?s"  and SN: "set ts \<subseteq> {s. ?SN s}" by auto
              show "?SNt g ts" unfolding conv[of _ ?t]
              proof (intro allI impI)
                fix u
                assume "(?t, u) \<in> {(s, t). S s t}"
                then have tu: "S ?t u" by auto
                then show "?SN u"
                proof (induct u)
                  case (Var x)
                  then show ?case using not_S_Var[of x] unfolding conv[of _ "Var x"] by auto
                next
                  case (Fun h us)
                  let ?h = "(h, length us)"
                  let ?u = "Fun h us"
                  note tu = Fun(2)
                  {
                    fix u
                    assume u: "u \<in> set us"
                    then have "?u \<rhd> u" by auto
                    from S_trans[OF tu S_supt[OF this]] have "S ?t u" by auto
                    from Fun(1)[OF u this] have "?SN u" .
                  } then have SNu: "set us \<subseteq> {s . ?SN s}" by blast
                  note IH = IH[OF _ this]
                  from tu have wut: "weight ?u \<le> weight ?t" by (simp split: if_splits)
                  show ?case
                  proof (cases "?m1 (f, ss) > ?m1 (h, us) \<or> ?m1 (f, ss) \<ge> ?m1 (h, us) \<and> pr_strict (?m2 (f, ss)) (?m2 (h, us))")
                    case True
                    from IH[OF True[unfolded split]] show ?thesis by simp
                  next
                    case False
                    with wut w have wut: "weight ?t = weight ?u" "weight ?s = weight ?u" by auto
                    note False = False[unfolded split wut]
                    note tu = tu[unfolded kbo.simps[of ?t] wut, unfolded Fun term.simps, simplified]
                    from tu have gh: "pr_weak ?g ?h" unfolding pr_strict by (auto split: if_splits)
                    from pr_weak_trans[OF fg gh] have fh: "pr_weak ?f ?h" .
                    from False wut fh have "\<not> pr_strict ?f ?h" unfolding pr_strict by auto
                    with fh have hf: "pr_weak ?h ?f" unfolding pr_strict by auto
                    from pr_weak_trans[OF hf fg] have hg: "pr_weak ?h ?g" .
                    from hg have gh2: "\<not> pr_strict ?g ?h" unfolding pr_strict by auto
                    from tu gh2 have lex: "fst (?lexu ts us)" by (auto split: if_splits)
                    from fh wut SNu have "pr_weak ?f ?h \<and> weight ?u \<le> weight ?s \<and> set us \<subseteq> {s. ?SN s}"
                      by auto
                    note inner_IH = inner_IH[OF _ this]
                    show ?thesis
                    proof (rule inner_IH, rule, unfold split, intro conjI ballI)
                      have "fst (?lexu ts us)" by (rule lex)
                      moreover have "length us \<le> weight ?s"
                      proof -
                        have "length us \<le> sum_list (map weight us)"
                        proof (induct us)
                          case (Cons u us)
                          from Cons have "length (u # us) \<le> Suc (sum_list (map weight us))" by auto
                          also have "... \<le> sum_list (map weight (u # us))" using weight_gt_0[of u]
                            by auto
                          finally show ?case .
                        qed simp
                        also have "\<dots> \<le> sum_list (map weight (scf_list (scf (h, length us)) us))"
                          by (rule sum_list_scf_list[OF scf])
                        also have "... \<le> weight ?s" using wut by simp
                        finally show ?thesis .
                      qed
                      ultimately show "fst (?lex ts us)" unfolding lex_ext_def Let_def by auto
                    qed (insert SN, blast)
                  qed
                qed
              qed
            qed
          }
          from this[of f ss] SN_s  show "?SN ?s" by auto
        qed
      qed
    }
    from this[of "(f, ss)", unfolded split]
    show ?case using Fun by blast
  qed
qed

lemma S_SN: "SN {(x, y). S x y}"
  using kbo_strongly_normalizing unfolding SN_defs by blast

subsection \<open>Ground Totality\<close>

lemma ground_SCF [simp]:
  "ground (SCF t) = ground t"
proof -
  have *: "\<forall>i<length xs. scf (f, length xs) i > 0"
    for f :: 'f and xs :: "('f, 'v) term list" using scf by simp
  show ?thesis by (induct t) (auto simp: set_scf_list [OF *])
qed

declare kbo.simps[simp del]

lemma ground_vars_term_ms: "ground t \<Longrightarrow> vars_term_ms t = {#}"
  by (induct t) auto

context
  fixes F :: "('f \<times> nat) set"
  assumes pr_weak: "pr_weak = pr_strict\<^sup>=\<^sup>="
    and pr_gtotal: "\<And>f g. f \<in> F \<Longrightarrow> g \<in> F \<Longrightarrow> f = g \<or> pr_strict f g \<or> pr_strict g f"
begin

lemma S_ground_total:
  assumes "funas_term s \<subseteq> F" and "ground s" and "funas_term t \<subseteq> F" and "ground t"
  shows "s = t \<or> S s t \<or> S t s"
  using assms
proof (induct s arbitrary: t)
  case IH: (Fun f ss)
  note [simp] = ground_vars_term_ms
  let ?s = "Fun f ss"
  have *: "(vars_term_ms (SCF t) \<subseteq># vars_term_ms (SCF ?s)) = True"
    "(vars_term_ms (SCF ?s) \<subseteq># vars_term_ms (SCF t)) = True"
    using \<open>ground ?s\<close> and \<open>ground t\<close> by (auto simp: scf)
  from IH(5) obtain g ts where t[simp]: "t = Fun g ts" by (cases t, auto)
  let ?t = "Fun g ts"
  let ?f = "(f, length ss)"
  let ?g = "(g, length ts)"
  from IH have f: "?f \<in> F" and g: "?g \<in> F" by auto
  {
    assume "\<not> ?case"
    note contra = this[unfolded kbo.simps[of ?s] kbo.simps[of t] *, unfolded t term.simps]
    from pr_gtotal[OF f g] contra have fg: "?f = ?g" by (auto split: if_splits)
    have IH: "\<forall>(s, t)\<in>set (zip ss ts). s = t \<or> S s t \<or> S t s"
      using IH by (auto elim!: in_set_zipE) blast
    from fg have len: "length ss = length ts" by auto
    from lex_ext_unbounded_total[OF IH NS_refl len] contra fg
    have False by (auto split: if_splits)
  }
  then show ?case by blast
qed auto
end

subsection \<open>Summary\<close>

text \<open>
  At this point we have shown well-foundedness @{thm [source] S_SN},
  transitivity and compatibility @{thm [source] S_trans NS_trans NS_S_compat S_NS_compat},
  closure under substitutions @{thm [source] S_subst NS_subst},
  closure under contexts @{thm [source] S_ctxt NS_ctxt},
  the subterm property @{thm [source] S_supt NS_supteq},
  reflexivity of the weak @{thm [source] NS_refl} and irreflexivity of the strict
  part @{thm [source] S_irrefl},
  and ground-totality @{thm [source] S_ground_total}.

  In particular, this allows us to show that KBO is an instance of
  strongly normalizing order pairs (@{locale SN_order_pair}).
\<close>

sublocale SN_order_pair "{(x, y). S x y}" "{(x, y). NS x y}"
  by (unfold_locales, insert NS_refl NS_trans S_trans S_SN NS_S_compat S_NS_compat)
    (auto simp: refl_on_def trans_def, blast+)
end

end


(*  Title:      HOL/Hoare/Hoare_Logic.thy
    Author:     Leonor Prensa Nieto & Tobias Nipkow
    Copyright   1998 TUM
    Author:     Walter Guttmann (extension to total-correctness proofs)
*)

section \<open>Hoare logic\<close>

theory Hoare_Logic
  imports Hoare_Syntax Hoare_Tac
begin

subsection \<open>Sugared semantic embedding of Hoare logic\<close>

text \<open>
  Strictly speaking a shallow embedding (as implemented by Norbert Galm
  following Mike Gordon) would suffice. Maybe the datatype com comes in useful
  later.
\<close>

type_synonym 'a bexp = "'a set"
type_synonym 'a assn = "'a set"
type_synonym 'a var = "'a \<Rightarrow> nat"

datatype 'a com =
  Basic "'a \<Rightarrow> 'a"
| Seq "'a com" "'a com"
| Cond "'a bexp" "'a com" "'a com"
| While "'a bexp" "'a assn" "'a var" "'a com"

abbreviation annskip ("SKIP") where "SKIP == Basic id"

type_synonym 'a sem = "'a => 'a => bool"

inductive Sem :: "'a com \<Rightarrow> 'a sem"
where
  "Sem (Basic f) s (f s)"
| "Sem c1 s s'' \<Longrightarrow> Sem c2 s'' s' \<Longrightarrow> Sem (Seq c1 c2) s s'"
| "s \<in> b \<Longrightarrow> Sem c1 s s' \<Longrightarrow> Sem (Cond b c1 c2) s s'"
| "s \<notin> b \<Longrightarrow> Sem c2 s s' \<Longrightarrow> Sem (Cond b c1 c2) s s'"
| "s \<notin> b \<Longrightarrow> Sem (While b x y c) s s"
| "s \<in> b \<Longrightarrow> Sem c s s'' \<Longrightarrow> Sem (While b x y c) s'' s' \<Longrightarrow>
   Sem (While b x y c) s s'"

definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool"
  where "Valid p c q \<equiv> \<forall>s s'. Sem c s s' \<longrightarrow> s \<in> p \<longrightarrow> s' \<in> q"

definition ValidTC :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool"
  where "ValidTC p c q \<equiv> \<forall>s. s \<in> p \<longrightarrow> (\<exists>t. Sem c s t \<and> t \<in> q)"

inductive_cases [elim!]:
  "Sem (Basic f) s s'" "Sem (Seq c1 c2) s s'"
  "Sem (Cond b c1 c2) s s'"

lemma Sem_deterministic:
  assumes "Sem c s s1"
      and "Sem c s s2"
    shows "s1 = s2"
proof -
  have "Sem c s s1 \<Longrightarrow> (\<forall>s2. Sem c s s2 \<longrightarrow> s1 = s2)"
    by (induct rule: Sem.induct) (subst Sem.simps, blast)+
  thus ?thesis
    using assms by simp
qed

lemma tc_implies_pc:
  "ValidTC p c q \<Longrightarrow> Valid p c q"
  by (metis Sem_deterministic Valid_def ValidTC_def)

lemma tc_extract_function:
  "ValidTC p c q \<Longrightarrow> \<exists>f . \<forall>s . s \<in> p \<longrightarrow> f s \<in> q"
  by (metis ValidTC_def)

lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) q"
by (auto simp:Valid_def)

lemma BasicRule: "p \<subseteq> {s. f s \<in> q} \<Longrightarrow> Valid p (Basic f) q"
by (auto simp:Valid_def)

lemma SeqRule: "Valid P c1 Q \<Longrightarrow> Valid Q c2 R \<Longrightarrow> Valid P (Seq c1 c2) R"
by (auto simp:Valid_def)

lemma CondRule:
 "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}
  \<Longrightarrow> Valid w c1 q \<Longrightarrow> Valid w' c2 q \<Longrightarrow> Valid p (Cond b c1 c2) q"
by (auto simp:Valid_def)

lemma While_aux:
  assumes "Sem (While b i v c) s s'"
  shows "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> I \<and> s \<in> b \<longrightarrow> s' \<in> I \<Longrightarrow>
    s \<in> I \<Longrightarrow> s' \<in> I \<and> s' \<notin> b"
  using assms
  by (induct "While b i v c" s s') auto

lemma WhileRule:
 "p \<subseteq> i \<Longrightarrow> Valid (i \<inter> b) c i \<Longrightarrow> i \<inter> (-b) \<subseteq> q \<Longrightarrow> Valid p (While b i v c) q"
apply (clarsimp simp:Valid_def)
apply(drule While_aux)
  apply assumption
 apply blast
apply blast
done

lemma SkipRuleTC:
  assumes "p \<subseteq> q"
    shows "ValidTC p (Basic id) q"
  by (metis assms Sem.intros(1) ValidTC_def id_apply subsetD)

lemma BasicRuleTC:
  assumes "p \<subseteq> {s. f s \<in> q}"
    shows "ValidTC p (Basic f) q"
  by (metis assms Ball_Collect Sem.intros(1) ValidTC_def)

lemma SeqRuleTC:
  assumes "ValidTC p c1 q"
      and "ValidTC q c2 r"
    shows "ValidTC p (Seq c1 c2) r"
  by (meson assms Sem.intros(2) ValidTC_def)

lemma CondRuleTC:
 assumes "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}"
     and "ValidTC w c1 q"
     and "ValidTC w' c2 q"
   shows "ValidTC p (Cond b c1 c2) q"
proof (unfold ValidTC_def, rule allI)
  fix s
  show "s \<in> p \<longrightarrow> (\<exists>t . Sem (Cond b c1 c2) s t \<and> t \<in> q)"
    apply (cases "s \<in> b")
    apply (metis (mono_tags, lifting) assms(1,2) Ball_Collect Sem.intros(3) ValidTC_def)
    by (metis (mono_tags, lifting) assms(1,3) Ball_Collect Sem.intros(4) ValidTC_def)
qed

lemma WhileRuleTC:
  assumes "p \<subseteq> i"
      and "\<And>n::nat . ValidTC (i \<inter> b \<inter> {s . v s = n}) c (i \<inter> {s . v s < n})"
      and "i \<inter> uminus b \<subseteq> q"
    shows "ValidTC p (While b i v c) q"
proof -
  {
    fix s n
    have "s \<in> i \<and> v s = n \<longrightarrow> (\<exists>t . Sem (While b i v c) s t \<and> t \<in> q)"
    proof (induction "n" arbitrary: s rule: less_induct)
      fix n :: nat
      fix s :: 'a
      assume 1: "\<And>(m::nat) s::'a . m < n \<Longrightarrow> s \<in> i \<and> v s = m \<longrightarrow> (\<exists>t . Sem (While b i v c) s t \<and> t \<in> q)"
      show "s \<in> i \<and> v s = n \<longrightarrow> (\<exists>t . Sem (While b i v c) s t \<and> t \<in> q)"
      proof (rule impI, cases "s \<in> b")
        assume 2: "s \<in> b" and "s \<in> i \<and> v s = n"
        hence "s \<in> i \<inter> b \<inter> {s . v s = n}"
          using assms(1) by auto
        hence "\<exists>t . Sem c s t \<and> t \<in> i \<inter> {s . v s < n}"
          by (metis assms(2) ValidTC_def)
        from this obtain t where 3: "Sem c s t \<and> t \<in> i \<inter> {s . v s < n}"
          by auto
        hence "\<exists>u . Sem (While b i v c) t u \<and> u \<in> q"
          using 1 by auto
        thus "\<exists>t . Sem (While b i v c) s t \<and> t \<in> q"
          using 2 3 Sem.intros(6) by force
      next
        assume "s \<notin> b" and "s \<in> i \<and> v s = n"
        thus "\<exists>t . Sem (While b i v c) s t \<and> t \<in> q"
          using Sem.intros(5) assms(3) by fastforce
      qed
    qed
  }
  thus ?thesis
    using assms(1) ValidTC_def by force
qed

subsubsection \<open>Concrete syntax\<close>

setup \<open>
  Hoare_Syntax.setup
   {Basic = \<^const_syntax>\<open>Basic\<close>,
    Skip = \<^const_syntax>\<open>annskip\<close>,
    Seq = \<^const_syntax>\<open>Seq\<close>,
    Cond = \<^const_syntax>\<open>Cond\<close>,
    While = \<^const_syntax>\<open>While\<close>,
    Valid = \<^const_syntax>\<open>Valid\<close>,
    ValidTC = \<^const_syntax>\<open>ValidTC\<close>}
\<close>

subsubsection \<open>Proof methods: VCG\<close>

declare BasicRule [Hoare_Tac.BasicRule]
  and SkipRule [Hoare_Tac.SkipRule]
  and SeqRule [Hoare_Tac.SeqRule]
  and CondRule [Hoare_Tac.CondRule]
  and WhileRule [Hoare_Tac.WhileRule]

declare BasicRuleTC [Hoare_Tac.BasicRuleTC]
  and SkipRuleTC [Hoare_Tac.SkipRuleTC]
  and SeqRuleTC [Hoare_Tac.SeqRuleTC]
  and CondRuleTC [Hoare_Tac.CondRuleTC]
  and WhileRuleTC [Hoare_Tac.WhileRuleTC]

method_setup vcg = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Hoare_Tac.hoare_tac ctxt (K all_tac)))\<close>
  "verification condition generator"

method_setup vcg_simp = \<open>
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (Hoare_Tac.hoare_tac ctxt (asm_full_simp_tac ctxt)))\<close>
  "verification condition generator plus simplification"

method_setup vcg_tc = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Hoare_Tac.hoare_tc_tac ctxt (K all_tac)))\<close>
  "verification condition generator"

method_setup vcg_tc_simp = \<open>
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (Hoare_Tac.hoare_tc_tac ctxt (asm_full_simp_tac ctxt)))\<close>
  "verification condition generator plus simplification"

end


section \<open>Instance of completeness theorem\<close>

theory Completeness_Instance imports Unification_Theorem Completeness begin

interpretation unification using unification by unfold_locales auto

thm lifting

lemma lift:
  assumes fin: "finite C \<and> finite D"
  assumes apart: "vars\<^sub>l\<^sub>s C \<inter> vars\<^sub>l\<^sub>s D = {}"
  assumes inst\<^sub>1: "instance_of\<^sub>l\<^sub>s C' C"
  assumes inst\<^sub>2: "instance_of\<^sub>l\<^sub>s D' D"
  assumes appl: "applicable C' D' L' M' \<sigma>"
  shows "\<exists>L M \<tau>. applicable C D L M \<tau> \<and>
                   instance_of\<^sub>l\<^sub>s (resolution C' D' L' M' \<sigma>) (resolution C D L M \<tau>)"
using assms lifting by metis

thm completeness

theorem complete:
  assumes finite_cs: "finite Cs" "\<forall>C\<in>Cs. finite C"
  assumes unsat: "\<forall>(F::hterm fun_denot) (G::hterm pred_denot) . \<not>eval\<^sub>c\<^sub>s F G Cs"
  shows "\<exists>Cs'. resolution_deriv Cs Cs' \<and> {} \<in> Cs'"
using assms completeness by -

thm completeness_countable

theorem complete_countable:
  assumes inf_uni: "infinite (UNIV :: ('u :: countable) set)"
  assumes finite_cs: "finite Cs" "\<forall>C\<in>Cs. finite C"
  assumes unsat: "\<forall>(F::'u fun_denot) (G::'u pred_denot). \<not>eval\<^sub>c\<^sub>s F G Cs"
  shows "\<exists>Cs'. resolution_deriv Cs Cs' \<and> {} \<in> Cs'"
using assms completeness_countable by -

thm completeness_nat

theorem complete_nat:
  assumes finite_cs: "finite Cs" "\<forall>C\<in>Cs. finite C"
  assumes unsat: "\<forall>(F::nat fun_denot) (G::nat pred_denot) . \<not>eval\<^sub>c\<^sub>s F G Cs"
  shows "\<exists>Cs'. resolution_deriv Cs Cs' \<and> {} \<in> Cs'"
using assms completeness_nat by -

end


theory CK_Machine
  imports "../Nominal"
begin

text \<open>

  This theory establishes soundness and completeness for a CK-machine
  with respect to a cbv-big-step semantics. The language includes
  functions, recursion, booleans and numbers. In the soundness proof
  the small-step cbv-reduction relation is used in order to get the
  induction through. The type-preservation property is proved for the
  machine and  also for the small- and big-step semantics. Finally,
  the progress property is proved for the small-step semantics.

  The development is inspired by notes about context machines written
  by Roshan James (Indiana University) and also by the lecture notes
  written by Andy Pitts for his semantics course. See

     \<^url>\<open>http://www.cs.indiana.edu/~rpjames/lm.pdf\<close>
     \<^url>\<open>http://www.cl.cam.ac.uk/teaching/2001/Semantics\<close>
\<close>

atom_decl name

nominal_datatype lam =
  VAR "name"
| APP "lam" "lam"
| LAM "\<guillemotleft>name\<guillemotright>lam" ("LAM [_]._")
| NUM "nat"
| DIFF "lam" "lam" ("_ -- _")    (* subtraction *)
| PLUS "lam" "lam" ("_ ++ _")    (* addition *)
| TRUE
| FALSE
| IF "lam" "lam" "lam"
| FIX "\<guillemotleft>name\<guillemotright>lam" ("FIX [_]._")  (* recursion *)
| ZET "lam"                      (* zero test *)
| EQI "lam" "lam"                (* equality test on numbers *)

section \<open>Capture-Avoiding Substitution\<close>

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [100,100,100] 100)
where
  "(VAR x)[y::=s] = (if x=y then s else (VAR x))"
| "(APP t\<^sub>1 t\<^sub>2)[y::=s] = APP (t\<^sub>1[y::=s]) (t\<^sub>2[y::=s])"
| "x\<sharp>(y,s) \<Longrightarrow> (LAM [x].t)[y::=s] = LAM [x].(t[y::=s])"
| "(NUM n)[y::=s] = NUM n"
| "(t\<^sub>1 -- t\<^sub>2)[y::=s] = (t\<^sub>1[y::=s]) -- (t\<^sub>2[y::=s])"
| "(t\<^sub>1 ++ t\<^sub>2)[y::=s] = (t\<^sub>1[y::=s]) ++ (t\<^sub>2[y::=s])"
| "x\<sharp>(y,s) \<Longrightarrow> (FIX [x].t)[y::=s] = FIX [x].(t[y::=s])"
| "TRUE[y::=s] = TRUE"
| "FALSE[y::=s] = FALSE"
| "(IF t1 t2 t3)[y::=s] = IF (t1[y::=s]) (t2[y::=s]) (t3[y::=s])"
| "(ZET t)[y::=s] = ZET (t[y::=s])"
| "(EQI t1 t2)[y::=s] = EQI (t1[y::=s]) (t2[y::=s])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)+
apply(fresh_guess)+
done

lemma  subst_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(t1[x::=t2]) = (pi\<bullet>t1)[(pi\<bullet>x)::=(pi\<bullet>t2)]"
by (nominal_induct t1 avoiding: x t2 rule: lam.strong_induct)
   (auto simp add: perm_bij fresh_atm fresh_bij)

lemma fresh_fact:
  fixes z::"name"
  shows "\<lbrakk>z\<sharp>s; (z=y \<or> z\<sharp>t)\<rbrakk> \<Longrightarrow> z\<sharp>t[y::=s]"
by (nominal_induct t avoiding: z y s rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_prod fresh_atm fresh_nat)

lemma subst_rename:
  assumes a: "y\<sharp>t"
  shows "t[x::=s] = ([(y,x)]\<bullet>t)[y::=s]"
using a
by (nominal_induct t avoiding: x y s rule: lam.strong_induct)
   (auto simp add: calc_atm fresh_atm abs_fresh perm_nat_def)

section \<open>Evaluation Contexts\<close>

datatype ctx =
    Hole ("\<box>")
  | CAPPL "ctx" "lam"
  | CAPPR "lam" "ctx"
  | CDIFFL "ctx" "lam"
  | CDIFFR "lam" "ctx"
  | CPLUSL "ctx" "lam"
  | CPLUSR "lam" "ctx"
  | CIF "ctx" "lam" "lam"
  | CZET "ctx"
  | CEQIL "ctx" "lam"
  | CEQIR "lam" "ctx"

text \<open>The operation of filling a term into a context:\<close>

fun
  filling :: "ctx \<Rightarrow> lam \<Rightarrow> lam" ("_\<lbrakk>_\<rbrakk>")
where
  "\<box>\<lbrakk>t\<rbrakk> = t"
| "(CAPPL E t')\<lbrakk>t\<rbrakk> = APP (E\<lbrakk>t\<rbrakk>) t'"
| "(CAPPR t' E)\<lbrakk>t\<rbrakk> = APP t' (E\<lbrakk>t\<rbrakk>)"
| "(CDIFFL E t')\<lbrakk>t\<rbrakk> = (E\<lbrakk>t\<rbrakk>) -- t'"
| "(CDIFFR t' E)\<lbrakk>t\<rbrakk> = t' -- (E\<lbrakk>t\<rbrakk>)"
| "(CPLUSL E t')\<lbrakk>t\<rbrakk> = (E\<lbrakk>t\<rbrakk>) ++ t'"
| "(CPLUSR t' E)\<lbrakk>t\<rbrakk> = t' ++ (E\<lbrakk>t\<rbrakk>)"
| "(CIF E t1 t2)\<lbrakk>t\<rbrakk> = IF (E\<lbrakk>t\<rbrakk>) t1 t2"
| "(CZET E)\<lbrakk>t\<rbrakk> = ZET (E\<lbrakk>t\<rbrakk>)"
| "(CEQIL E t')\<lbrakk>t\<rbrakk> = EQI (E\<lbrakk>t\<rbrakk>) t'"
| "(CEQIR t' E)\<lbrakk>t\<rbrakk> = EQI t' (E\<lbrakk>t\<rbrakk>)"

text \<open>The operation of composing two contexts:\<close>

fun
 ctx_compose :: "ctx \<Rightarrow> ctx \<Rightarrow> ctx" ("_ \<circ> _")
where
  "\<box> \<circ> E' = E'"
| "(CAPPL E t') \<circ> E' = CAPPL (E \<circ> E') t'"
| "(CAPPR t' E) \<circ> E' = CAPPR t' (E \<circ> E')"
| "(CDIFFL E t') \<circ> E' = CDIFFL (E \<circ> E') t'"
| "(CDIFFR t' E) \<circ> E' = CDIFFR t' (E \<circ> E')"
| "(CPLUSL E t') \<circ> E' = CPLUSL (E \<circ> E') t'"
| "(CPLUSR t' E) \<circ> E' = CPLUSR t' (E \<circ> E')"
| "(CIF E t1 t2) \<circ> E' = CIF (E \<circ> E') t1 t2"
| "(CZET E) \<circ> E' = CZET (E \<circ> E')"
| "(CEQIL E t') \<circ> E' = CEQIL (E \<circ> E') t'"
| "(CEQIR t' E) \<circ> E' = CEQIR t' (E \<circ> E')"

lemma ctx_compose:
  shows "(E1 \<circ> E2)\<lbrakk>t\<rbrakk> = E1\<lbrakk>E2\<lbrakk>t\<rbrakk>\<rbrakk>"
by (induct E1 rule: ctx.induct) (auto)

text \<open>Composing a list (stack) of contexts.\<close>

fun
  ctx_composes :: "ctx list \<Rightarrow> ctx" ("_\<down>")
where
    "[]\<down> = \<box>"
  | "(E#Es)\<down> = (Es\<down>) \<circ> E"

section \<open>The CK-Machine\<close>

inductive
  val :: "lam\<Rightarrow>bool"
where
  v_LAM[intro]:   "val (LAM [x].e)"
| v_NUM[intro]:   "val (NUM n)"
| v_FALSE[intro]: "val FALSE"
| v_TRUE[intro]:  "val TRUE"

equivariance val

inductive
  machine :: "lam\<Rightarrow>ctx list\<Rightarrow>lam\<Rightarrow>ctx list\<Rightarrow>bool" ("<_,_> \<mapsto> <_,_>")
where
  m1[intro]: "<APP e1 e2,Es> \<mapsto> <e1,(CAPPL \<box> e2)#Es>"
| m2[intro]: "val v \<Longrightarrow> <v,(CAPPL \<box> e2)#Es> \<mapsto> <e2,(CAPPR v \<box>)#Es>"
| m3[intro]: "val v \<Longrightarrow> <v,(CAPPR (LAM [y].e) \<box>)#Es> \<mapsto> <e[y::=v],Es>"
| m4[intro]: "<e1 -- e2, Es> \<mapsto> <e1,(CDIFFL \<box> e2)#Es>"
| m5[intro]: "<NUM n1,(CDIFFL \<box> e2)#Es> \<mapsto> <e2,(CDIFFR (NUM n1) \<box>)#Es>"
| m6[intro]: "<NUM n2,(CDIFFR (NUM n1) \<box>)#Es> \<mapsto> <NUM (n1 - n2),Es>"
| m4'[intro]:"<e1 ++ e2, Es> \<mapsto> <e1,(CPLUSL \<box> e2)#Es>"
| m5'[intro]:"<NUM n1,(CPLUSL \<box> e2)#Es> \<mapsto> <e2,(CPLUSR (NUM n1) \<box>)#Es>"
| m6'[intro]:"<NUM n2,(CPLUSR (NUM n1) \<box>)#Es> \<mapsto> <NUM (n1+n2),Es>"
| m7[intro]: "<IF e1 e2 e3,Es> \<mapsto> <e1,(CIF \<box> e2 e3)#Es>"
| m8[intro]: "<TRUE,(CIF \<box> e1 e2)#Es> \<mapsto> <e1,Es>"
| m9[intro]: "<FALSE,(CIF \<box> e1 e2)#Es> \<mapsto> <e2,Es>"
| mA[intro]: "<FIX [x].t,Es> \<mapsto> <t[x::=FIX [x].t],Es>"
| mB[intro]: "<ZET e,Es> \<mapsto> <e,(CZET \<box>)#Es>"
| mC[intro]: "<NUM 0,(CZET \<box>)#Es> \<mapsto> <TRUE,Es>"
| mD[intro]: "0 < n \<Longrightarrow> <NUM n,(CZET \<box>)#Es> \<mapsto> <FALSE,Es>"
| mE[intro]: "<EQI e1 e2,Es> \<mapsto> <e1,(CEQIL \<box> e2)#Es>"
| mF[intro]: "<NUM n1,(CEQIL \<box> e2)#Es> \<mapsto> <e2,(CEQIR (NUM n1) \<box>)#Es>"
| mG[intro]: "<NUM n,(CEQIR (NUM n) \<box>)#Es> \<mapsto> <TRUE,Es>"
| mH[intro]: "n1\<noteq>n2 \<Longrightarrow> <NUM n1,(CEQIR (NUM n2) \<box>)#Es> \<mapsto> <FALSE,Es>"

inductive
  "machine_star" :: "lam\<Rightarrow>ctx list\<Rightarrow>lam\<Rightarrow>ctx list\<Rightarrow>bool" ("<_,_> \<mapsto>* <_,_>")
where
  ms1[intro]: "<e,Es> \<mapsto>* <e,Es>"
| ms2[intro]: "\<lbrakk><e1,Es1> \<mapsto> <e2,Es2>; <e2,Es2> \<mapsto>* <e3,Es3>\<rbrakk> \<Longrightarrow> <e1,Es1> \<mapsto>* <e3,Es3>"

lemma ms3[intro,trans]:
  assumes a: "<e1,Es1> \<mapsto>* <e2,Es2>" "<e2,Es2> \<mapsto>* <e3,Es3>"
  shows "<e1,Es1> \<mapsto>* <e3,Es3>"
using a by (induct) (auto)

lemma ms4[intro]:
  assumes a: "<e1,Es1> \<mapsto> <e2,Es2>"
  shows "<e1,Es1> \<mapsto>* <e2,Es2>"
using a by (rule ms2) (rule ms1)

section \<open>The Evaluation Relation (Big-Step Semantics)\<close>

inductive
  eval :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<Down> _")
where
  eval_NUM[intro]:  "NUM n \<Down> NUM n"
| eval_DIFF[intro]: "\<lbrakk>t1 \<Down> (NUM n1); t2 \<Down> (NUM n2)\<rbrakk> \<Longrightarrow> t1 -- t2 \<Down> NUM (n1 - n2)"
| eval_PLUS[intro]: "\<lbrakk>t1 \<Down> (NUM n1); t2 \<Down> (NUM n2)\<rbrakk> \<Longrightarrow> t1 ++ t2 \<Down> NUM (n1 + n2)"
| eval_LAM[intro]:  "LAM [x].t \<Down> LAM [x].t"
| eval_APP[intro]:  "\<lbrakk>t1\<Down> LAM [x].t; t2\<Down> t2'; t[x::=t2']\<Down> t'\<rbrakk> \<Longrightarrow> APP t1 t2 \<Down> t'"
| eval_FIX[intro]:  "t[x::= FIX [x].t] \<Down> t' \<Longrightarrow> FIX [x].t \<Down> t'"
| eval_IF1[intro]:  "\<lbrakk>t1 \<Down> TRUE; t2 \<Down> t'\<rbrakk> \<Longrightarrow> IF t1 t2 t3 \<Down> t'"
| eval_IF2[intro]:  "\<lbrakk>t1 \<Down> FALSE; t3 \<Down> t'\<rbrakk> \<Longrightarrow> IF t1 t2 t3 \<Down> t'"
| eval_TRUE[intro]: "TRUE \<Down> TRUE"
| eval_FALSE[intro]:"FALSE \<Down> FALSE"
| eval_ZET1[intro]: "t \<Down> NUM 0 \<Longrightarrow> ZET t \<Down> TRUE"
| eval_ZET2[intro]: "\<lbrakk>t \<Down> NUM n; 0 < n\<rbrakk> \<Longrightarrow> ZET t \<Down> FALSE"
| eval_EQ1[intro]:  "\<lbrakk>t1 \<Down> NUM n; t2 \<Down> NUM n\<rbrakk> \<Longrightarrow> EQI t1 t2 \<Down> TRUE"
| eval_EQ2[intro]:  "\<lbrakk>t1 \<Down> NUM n1; t2 \<Down> NUM n2; n1\<noteq>n2\<rbrakk> \<Longrightarrow> EQI t1 t2 \<Down> FALSE"

declare lam.inject[simp]
inductive_cases eval_elim:
  "APP t1 t2 \<Down> t'"
  "IF t1 t2 t3 \<Down> t'"
  "ZET t \<Down> t'"
  "EQI t1 t2 \<Down> t'"
  "t1 ++ t2 \<Down> t'"
  "t1 -- t2 \<Down> t'"
  "(NUM n) \<Down> t"
  "TRUE \<Down> t"
  "FALSE \<Down> t"
declare lam.inject[simp del]

lemma eval_to:
  assumes a: "t \<Down> t'"
  shows "val t'"
using a by (induct) (auto)

lemma eval_val:
  assumes a: "val t"
  shows "t \<Down> t"
using a by (induct) (auto)

text \<open>The Completeness Property:\<close>

theorem eval_implies_machine_star_ctx:
  assumes a: "t \<Down> t'"
  shows "<t,Es> \<mapsto>* <t',Es>"
using a
by (induct arbitrary: Es)
   (metis eval_to machine.intros ms1 ms2 ms3 ms4 v_LAM)+

corollary eval_implies_machine_star:
  assumes a: "t \<Down> t'"
  shows "<t,[]> \<mapsto>* <t',[]>"
using a by (auto dest: eval_implies_machine_star_ctx)

section \<open>The CBV Reduction Relation (Small-Step Semantics)\<close>

lemma less_eqvt[eqvt]:
  fixes pi::"name prm"
  and   n1 n2::"nat"
  shows "(pi\<bullet>(n1 < n2)) = ((pi\<bullet>n1) < (pi\<bullet>n2))"
by (simp add: perm_nat_def perm_bool)

inductive
  cbv :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<longrightarrow>cbv _")
where
  cbv1: "\<lbrakk>val v; x\<sharp>v\<rbrakk> \<Longrightarrow> APP (LAM [x].t) v \<longrightarrow>cbv t[x::=v]"
| cbv2[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> APP t t2 \<longrightarrow>cbv APP t' t2"
| cbv3[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> APP t2 t \<longrightarrow>cbv APP t2 t'"
| cbv4[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t -- t2 \<longrightarrow>cbv t' -- t2"
| cbv5[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t2 -- t \<longrightarrow>cbv t2 -- t'"
| cbv6[intro]: "(NUM n1) -- (NUM n2) \<longrightarrow>cbv NUM (n1 - n2)"
| cbv4'[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t ++ t2 \<longrightarrow>cbv t' ++ t2"
| cbv5'[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t2 ++ t \<longrightarrow>cbv t2 ++ t'"
| cbv6'[intro]:"(NUM n1) ++ (NUM n2) \<longrightarrow>cbv NUM (n1 + n2)"
| cbv7[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> IF t t1 t2 \<longrightarrow>cbv IF t' t1 t2"
| cbv8[intro]: "IF TRUE t1 t2 \<longrightarrow>cbv t1"
| cbv9[intro]: "IF FALSE t1 t2 \<longrightarrow>cbv t2"
| cbvA[intro]: "FIX [x].t \<longrightarrow>cbv t[x::=FIX [x].t]"
| cbvB[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> ZET t \<longrightarrow>cbv ZET t'"
| cbvC[intro]: "ZET (NUM 0) \<longrightarrow>cbv TRUE"
| cbvD[intro]: "0 < n \<Longrightarrow> ZET (NUM n) \<longrightarrow>cbv FALSE"
| cbvE[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> EQI t t2 \<longrightarrow>cbv EQI t' t2"
| cbvF[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> EQI t2 t \<longrightarrow>cbv EQI t2 t'"
| cbvG[intro]: "EQI (NUM n) (NUM n) \<longrightarrow>cbv TRUE"
| cbvH[intro]: "n1\<noteq>n2 \<Longrightarrow> EQI (NUM n1) (NUM n2) \<longrightarrow>cbv FALSE"

equivariance cbv
nominal_inductive cbv
 by (simp_all add: abs_fresh fresh_fact)

lemma better_cbv1[intro]:
  assumes a: "val v"
  shows "APP (LAM [x].t) v \<longrightarrow>cbv t[x::=v]"
proof -
  obtain y::"name" where fs: "y\<sharp>(x,t,v)" by (rule exists_fresh, rule fin_supp, blast)
  have "APP (LAM [x].t) v = APP (LAM [y].([(y,x)]\<bullet>t)) v" using fs
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  also have "\<dots> \<longrightarrow>cbv  ([(y,x)]\<bullet>t)[y::=v]" using fs a by (auto simp add: cbv.eqvt cbv1)
  also have "\<dots> = t[x::=v]" using fs by (simp add: subst_rename[symmetric])
  finally show "APP (LAM [x].t) v \<longrightarrow>cbv t[x::=v]" by simp
qed

inductive
  "cbv_star" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>cbv* _")
where
  cbvs1[intro]: "e \<longrightarrow>cbv* e"
| cbvs2[intro]: "\<lbrakk>e1\<longrightarrow>cbv e2; e2 \<longrightarrow>cbv* e3\<rbrakk> \<Longrightarrow> e1 \<longrightarrow>cbv* e3"

lemma cbvs3[intro,trans]:
  assumes a: "e1 \<longrightarrow>cbv* e2" "e2 \<longrightarrow>cbv* e3"
  shows "e1 \<longrightarrow>cbv* e3"
using a by (induct) (auto)

lemma cbv_in_ctx:
  assumes a: "t \<longrightarrow>cbv t'"
  shows "E\<lbrakk>t\<rbrakk> \<longrightarrow>cbv E\<lbrakk>t'\<rbrakk>"
using a by (induct E) (auto)

lemma machine_implies_cbv_star_ctx:
  assumes a: "<e,Es> \<mapsto> <e',Es'>"
  shows "(Es\<down>)\<lbrakk>e\<rbrakk> \<longrightarrow>cbv* (Es'\<down>)\<lbrakk>e'\<rbrakk>"
using a by (induct) (auto simp add: ctx_compose intro: cbv_in_ctx)

lemma machine_star_implies_cbv_star_ctx:
  assumes a: "<e,Es> \<mapsto>* <e',Es'>"
  shows "(Es\<down>)\<lbrakk>e\<rbrakk> \<longrightarrow>cbv* (Es'\<down>)\<lbrakk>e'\<rbrakk>"
using a
by (induct) (auto dest: machine_implies_cbv_star_ctx)

lemma machine_star_implies_cbv_star:
  assumes a: "<e,[]> \<mapsto>* <e',[]>"
  shows "e \<longrightarrow>cbv* e'"
using a by (auto dest: machine_star_implies_cbv_star_ctx)

lemma cbv_eval:
  assumes a: "t1 \<longrightarrow>cbv t2" "t2 \<Down> t3"
  shows "t1 \<Down> t3"
using a
by (induct arbitrary: t3)
   (auto elim!: eval_elim intro: eval_val)

lemma cbv_star_eval:
  assumes a: "t1 \<longrightarrow>cbv* t2" "t2 \<Down> t3"
  shows "t1 \<Down> t3"
using a by (induct) (auto simp add: cbv_eval)

lemma cbv_star_implies_eval:
  assumes a: "t \<longrightarrow>cbv* v" "val v"
  shows "t \<Down> v"
using a
by (induct)
   (auto simp add: eval_val cbv_star_eval dest: cbvs2)

text \<open>The Soundness Property\<close>

theorem machine_star_implies_eval:
  assumes a: "<t1,[]> \<mapsto>* <t2,[]>"
  and     b: "val t2"
  shows "t1 \<Down> t2"
proof -
  from a have "t1 \<longrightarrow>cbv* t2" by (simp add: machine_star_implies_cbv_star)
  then show "t1 \<Down> t2" using b by (simp add: cbv_star_implies_eval)
qed

section \<open>Typing\<close>

text \<open>Types\<close>

nominal_datatype ty =
  tVAR "string"
| tBOOL
| tINT
| tARR "ty" "ty" ("_ \<rightarrow> _")

declare ty.inject[simp]

lemma ty_fresh:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
by (induct T rule: ty.induct)
   (auto simp add: fresh_string)

text \<open>Typing Contexts\<close>

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

text \<open>Sub-Typing Contexts\<close>

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

text \<open>Valid Typing Contexts\<close>

inductive
  valid :: "tctx \<Rightarrow> bool"
where
  v1[intro]: "valid []"
| v2[intro]: "\<lbrakk>valid \<Gamma>; x\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((x,T)#\<Gamma>)"

equivariance valid

lemma valid_elim[dest]:
  assumes a: "valid ((x,T)#\<Gamma>)"
  shows "x\<sharp>\<Gamma> \<and> valid \<Gamma>"
using a by (cases) (auto)

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

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

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

section \<open>The Typing Relation\<close>

inductive
  typing :: "tctx \<Rightarrow> lam \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _")
where
  t_VAR[intro]:  "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> VAR x : T"
| t_APP[intro]:  "\<lbrakk>\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>1\<rightarrow>T\<^sub>2; \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> APP t\<^sub>1 t\<^sub>2 : T\<^sub>2"
| t_LAM[intro]:  "\<lbrakk>x\<sharp>\<Gamma>; (x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> LAM [x].t : T\<^sub>1 \<rightarrow> T\<^sub>2"
| t_NUM[intro]:  "\<Gamma> \<turnstile> (NUM n) : tINT"
| t_DIFF[intro]: "\<lbrakk>\<Gamma> \<turnstile> t\<^sub>1 : tINT; \<Gamma> \<turnstile> t\<^sub>2 : tINT\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>1 -- t\<^sub>2 : tINT"
| t_PLUS[intro]: "\<lbrakk>\<Gamma> \<turnstile> t\<^sub>1 : tINT; \<Gamma> \<turnstile> t\<^sub>2 : tINT\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>1 ++ t\<^sub>2 : tINT"
| t_TRUE[intro]:  "\<Gamma> \<turnstile> TRUE : tBOOL"
| t_FALSE[intro]: "\<Gamma> \<turnstile> FALSE : tBOOL"
| t_IF[intro]:    "\<lbrakk>\<Gamma> \<turnstile> t1 : tBOOL; \<Gamma> \<turnstile> t2 : T; \<Gamma> \<turnstile> t3 : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> IF t1 t2 t3 : T"
| t_ZET[intro]:   "\<Gamma> \<turnstile> t : tINT \<Longrightarrow> \<Gamma> \<turnstile> ZET t : tBOOL"
| t_EQI[intro]:   "\<lbrakk>\<Gamma> \<turnstile> t1 : tINT; \<Gamma> \<turnstile> t2 : tINT\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> EQI t1 t2 : tBOOL"
| t_FIX[intro]:   "\<lbrakk>x\<sharp>\<Gamma>; (x,T)#\<Gamma> \<turnstile> t : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> FIX [x].t : T"

declare lam.inject[simp]
inductive_cases typing_inversion[elim]:
  "\<Gamma> \<turnstile> t\<^sub>1 -- t\<^sub>2 : T"
  "\<Gamma> \<turnstile> t\<^sub>1 ++ t\<^sub>2 : T"
  "\<Gamma> \<turnstile> IF t1 t2 t3 : T"
  "\<Gamma> \<turnstile> ZET t : T"
  "\<Gamma> \<turnstile> EQI t1 t2 : T"
  "\<Gamma> \<turnstile> APP t1 t2 : T"
  "\<Gamma> \<turnstile> TRUE : T"
  "\<Gamma> \<turnstile> FALSE : T"
  "\<Gamma> \<turnstile> NUM n : T"
declare lam.inject[simp del]

equivariance typing
nominal_inductive typing
  by (simp_all add: abs_fresh ty_fresh)

lemma t_LAM_inversion[dest]:
  assumes ty: "\<Gamma> \<turnstile> LAM [x].t : T"
  and     fc: "x\<sharp>\<Gamma>"
  shows "\<exists>T\<^sub>1 T\<^sub>2. T = T\<^sub>1 \<rightarrow> T\<^sub>2 \<and> (x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2"
using ty fc
by (cases rule: typing.strong_cases)
   (auto simp add: alpha lam.inject abs_fresh ty_fresh)

lemma t_FIX_inversion[dest]:
  assumes ty: "\<Gamma> \<turnstile> FIX [x].t : T"
  and     fc: "x\<sharp>\<Gamma>"
  shows "(x,T)#\<Gamma> \<turnstile> t : T"
using ty fc
by (cases rule: typing.strong_cases)
   (auto simp add: alpha lam.inject abs_fresh ty_fresh)

section \<open>The Type-Preservation Property for the CBV Reduction Relation\<close>

lemma weakening:
  fixes \<Gamma>1 \<Gamma>2::"tctx"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
by (nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
   (auto | atomize)+

lemma type_substitution_aux:
  assumes a: "(\<Delta>@[(x,T')]@\<Gamma>) \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "(\<Delta>@\<Gamma>) \<turnstile> e[x::=e'] : T"
using a b
proof (nominal_induct "\<Delta>@[(x,T')]@\<Gamma>" e T avoiding: x e' \<Delta> rule: typing.strong_induct)
  case (t_VAR y T x e' \<Delta>)
  then have a1: "valid (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a2: "(y,T) \<in> set (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a3: "\<Gamma> \<turnstile> e' : T'" .
  from a1 have a4: "valid (\<Delta>@\<Gamma>)" by (rule valid_insert)
  { assume eq: "x=y"
    from a1 a2 have "T=T'" using eq by (auto intro: context_unique)
    with a3 have "\<Delta>@\<Gamma> \<turnstile> VAR y[x::=e'] : T" using eq a4 by (auto intro: weakening)
  }
  moreover
  { assume ineq: "x\<noteq>y"
    from a2 have "(y,T) \<in> set (\<Delta>@\<Gamma>)" using ineq by simp
    then have "\<Delta>@\<Gamma> \<turnstile> VAR y[x::=e'] : T" using ineq a4 by auto
  }
  ultimately show "\<Delta>@\<Gamma> \<turnstile> VAR y[x::=e'] : T" by blast
qed (auto | force simp add: fresh_list_append fresh_list_cons)+

corollary type_substitution:
  assumes a: "(x,T')#\<Gamma> \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "\<Gamma> \<turnstile> e[x::=e'] : T"
using a b
by (auto intro: type_substitution_aux[where \<Delta>="[]",simplified])

theorem cbv_type_preservation:
  assumes a: "t \<longrightarrow>cbv t'"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
using a b
apply(nominal_induct avoiding: \<Gamma> T rule: cbv.strong_induct)
apply(auto elim!: typing_inversion dest: t_LAM_inversion simp add: type_substitution)
apply(frule t_FIX_inversion)
apply(auto simp add: type_substitution)
done

corollary cbv_star_type_preservation:
  assumes a: "t \<longrightarrow>cbv* t'"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
using a b
by (induct) (auto intro: cbv_type_preservation)

section \<open>The Type-Preservation Property for the Machine and Evaluation Relation\<close>

theorem machine_type_preservation:
  assumes a: "<t,[]> \<mapsto>* <t',[]>"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
proof -
  from a have "t \<longrightarrow>cbv* t'" by (simp add: machine_star_implies_cbv_star)
  then show "\<Gamma> \<turnstile> t' : T" using b by (simp add: cbv_star_type_preservation)
qed

theorem eval_type_preservation:
  assumes a: "t \<Down> t'"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
proof -
  from a have "<t,[]> \<mapsto>* <t',[]>" by (simp add: eval_implies_machine_star)
  then show "\<Gamma> \<turnstile> t' : T" using b by (simp add: machine_type_preservation)
qed

text \<open>The Progress Property\<close>

lemma canonical_tARR[dest]:
  assumes a: "[] \<turnstile> t : T1 \<rightarrow> T2"
  and     b: "val t"
  shows "\<exists>x t'. t = LAM [x].t'"
using b a by (induct) (auto)

lemma canonical_tINT[dest]:
  assumes a: "[] \<turnstile> t : tINT"
  and     b: "val t"
  shows "\<exists>n. t = NUM n"
using b a
by (induct) (auto simp add: fresh_list_nil)

lemma canonical_tBOOL[dest]:
  assumes a: "[] \<turnstile> t : tBOOL"
  and     b: "val t"
  shows "t = TRUE \<or> t = FALSE"
using b a
by (induct) (auto simp add: fresh_list_nil)

theorem progress:
  assumes a: "[] \<turnstile> t : T"
  shows "(\<exists>t'. t \<longrightarrow>cbv t') \<or> (val t)"
using a
by (induct \<Gamma>\<equiv>"[]::tctx" t T)
   (auto dest!: canonical_tINT intro!: cbv.intros gr0I)

end