section \<open>Lexicographic Extension\<close>

theory Lexicographic_Extension
  imports
    Matrix.Utility
    Order_Pair
begin

text \<open>
  In this theory we define the lexicographic extension of an order pair, so that it generalizes
  the existing notion @{const lex_prod} which is based on a single order only.

  Our main result is that this extension yields again an order pair.
\<close>

fun lex_two :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'b rel \<Rightarrow> ('a \<times> 'b) rel"
  where
    "lex_two s ns s2 = {((a1, b1), (a2, b2)) . (a1, a2) \<in> s \<or> (a1, a2) \<in> ns \<and> (b1, b2) \<in> s2}"

lemma lex_two:
  assumes compat: "ns O s \<subseteq> s"
    and SN_s: "SN s"
    and SN_s2: "SN s2"
  shows "SN (lex_two s ns s2)" (is "SN ?r")
proof
  fix f
  assume "\<forall> i. (f i, f (Suc i)) \<in> ?r"
  then have steps: "\<And> i. (f i, f (Suc i)) \<in> ?r" ..
  let ?a = "\<lambda> i. fst (f i)"
  let ?b = "\<lambda> i. snd (f i)"
  {
    fix i
    from steps[of i]
    have "(?a i, ?a (Suc i)) \<in> s \<or> (?a i, ?a (Suc i)) \<in> ns \<and> (?b i, ?b (Suc i)) \<in> s2"
      by (cases "f i", cases "f (Suc i)", auto)
  }
  note steps = this
  have "\<exists> j. \<forall> i \<ge> j. (?a i, ?a (Suc i)) \<in> ns - s"
    by (rule non_strict_ending[OF _ compat], insert steps SN_s, unfold SN_on_def, auto)
  with steps obtain j where steps: "\<And> i. i \<ge> j \<Longrightarrow> (?b i, ?b (Suc i)) \<in> s2" by auto
  obtain g where g: "g = (\<lambda> i. ?b (j + i))" by auto
  from steps have "\<And> i. (g i, g (Suc i)) \<in> s2" unfolding g by auto
  with SN_s2 show False unfolding SN_defs by auto
qed

lemma lex_two_compat:
  assumes compat1: "ns1 O s1 \<subseteq> s1"
    and compat1': "s1 O ns1 \<subseteq> s1"
    and trans1: "s1 O s1 \<subseteq> s1"
    and trans1': "ns1 O ns1 \<subseteq> ns1"
    and compat2: "ns2 O s2 \<subseteq> s2"
    and ns: "(ab1, ab2) \<in> lex_two s1 ns1 ns2"
    and s: "(ab2, ab3) \<in> lex_two s1 ns1 s2"
  shows "(ab1, ab3) \<in> lex_two s1 ns1 s2"
proof -
  obtain a1 b1 where ab1: "ab1 = (a1, b1)" by force
  obtain a2 b2 where ab2: "ab2 = (a2, b2)" by force
  obtain a3 b3 where ab3: "ab3 = (a3, b3)" by force
  note id = ab1 ab2 ab3
  show ?thesis
  proof (cases "(a1, a2) \<in> s1")
    case s1: True
    show ?thesis
    proof (cases "(a2, a3) \<in> s1")
      case s2: True
      from trans1 s1 s2 show ?thesis unfolding id by auto
    next
      case False with s have "(a2, a3) \<in> ns1" unfolding id by simp
      from compat1' s1 this show ?thesis unfolding id by auto
    qed
  next
    case False
    with ns have ns: "(a1, a2) \<in> ns1" "(b1, b2) \<in> ns2" unfolding id by auto
    show ?thesis
    proof (cases "(a2, a3) \<in> s1")
      case s2: True
      from compat1 ns(1) s2 show ?thesis unfolding id by auto
    next
      case False
      with s have nss: "(a2, a3) \<in> ns1" "(b2, b3) \<in> s2" unfolding id by auto
      from trans1' ns(1) nss(1) compat2 ns(2) nss(2)
      show ?thesis unfolding id by auto
    qed
  qed
qed

lemma lex_two_compat':
  assumes compat1: "ns1 O s1 \<subseteq> s1"
    and compat1': "s1 O ns1 \<subseteq> s1"
    and trans1: "s1 O s1 \<subseteq> s1"
    and trans1': "ns1 O ns1 \<subseteq> ns1"
    and compat2': "s2 O ns2 \<subseteq> s2"
    and s: "(ab1, ab2) \<in> lex_two s1 ns1 s2"
    and ns: "(ab2, ab3) \<in> lex_two s1 ns1 ns2"
  shows "(ab1, ab3) \<in> lex_two s1 ns1 s2"
proof -
  obtain a1 b1 where ab1: "ab1 = (a1, b1)" by force
  obtain a2 b2 where ab2: "ab2 = (a2, b2)" by force
  obtain a3 b3 where ab3: "ab3 = (a3, b3)" by force
  note id = ab1 ab2 ab3
  show ?thesis
  proof (cases "(a1, a2) \<in> s1")
    case s1: True
    show ?thesis
    proof (cases "(a2, a3) \<in> s1")
      case s2: True
      from trans1 s1 s2 show ?thesis unfolding id by auto
    next
      case False with ns have "(a2, a3) \<in> ns1" unfolding id by simp
      from compat1' s1 this show ?thesis unfolding id by auto
    qed
  next
    case False
    with s have s: "(a1, a2) \<in> ns1" "(b1, b2) \<in> s2" unfolding id by auto
    show ?thesis
    proof (cases "(a2, a3) \<in> s1")
      case s2: True
      from compat1 s(1) s2 show ?thesis unfolding id by auto
    next
      case False
      with ns have nss: "(a2, a3) \<in> ns1" "(b2, b3) \<in> ns2" unfolding id by auto
      from trans1' s(1) nss(1) compat2' s(2) nss(2)
      show ?thesis unfolding id by auto
    qed
  qed
qed

lemma lex_two_compat2:
  assumes "ns1 O s1 \<subseteq> s1" "s1 O ns1 \<subseteq> s1" "s1 O s1 \<subseteq> s1" "ns1 O ns1 \<subseteq> ns1" "ns2 O s2 \<subseteq> s2"
  shows "lex_two s1 ns1 ns2 O lex_two s1 ns1 s2 \<subseteq> lex_two s1 ns1 s2"
  using lex_two_compat[OF assms] by (intro subsetI, elim relcompE, fast)

lemma lex_two_compat'2:
  assumes "ns1 O s1 \<subseteq> s1" "s1 O ns1 \<subseteq> s1" "s1 O s1 \<subseteq> s1" "ns1 O ns1 \<subseteq> ns1" "s2 O ns2 \<subseteq> s2"
  shows "lex_two s1 ns1 s2 O lex_two s1 ns1 ns2 \<subseteq> lex_two s1 ns1 s2"
  using lex_two_compat'[OF assms] by (intro subsetI, elim relcompE, fast)

lemma lex_two_refl:
  assumes r1: "refl ns1" and r2: "refl ns2"
  shows "refl (lex_two s1 ns1 ns2)"
  using refl_onD[OF r1] and refl_onD[OF r2] by (intro refl_onI) auto

lemma lex_two_order_pair:
  assumes o1: "order_pair s1 ns1" and o2: "order_pair s2 ns2"
  shows "order_pair (lex_two s1 ns1 s2) (lex_two s1 ns1 ns2)"
proof -
  interpret o1: order_pair s1 ns1 using o1.
  interpret o2: order_pair s2 ns2 using o2.
  note o1.trans_S o1.trans_NS o2.trans_S o2.trans_NS
    o1.compat_NS_S o2.compat_NS_S o1.compat_S_NS o2.compat_S_NS
  note this [unfolded trans_O_iff]
  note o1.refl_NS o2.refl_NS
  show ?thesis
    by (unfold_locales, intro lex_two_refl, fact+, unfold trans_O_iff)
      (rule lex_two_compat2 lex_two_compat'2;fact)+
qed

lemma lex_two_SN_order_pair:
  assumes o1: "SN_order_pair s1 ns1" and o2: "SN_order_pair s2 ns2"
  shows "SN_order_pair (lex_two s1 ns1 s2) (lex_two s1 ns1 ns2)"
proof -
  interpret o1: SN_order_pair s1 ns1 using o1.
  interpret o2: SN_order_pair s2 ns2 using o2.
  note o1.trans_S o1.trans_NS o2.trans_S o2.trans_NS o1.SN o2.SN
    o1.compat_NS_S o2.compat_NS_S o1.compat_S_NS o2.compat_S_NS
  note this [unfolded trans_O_iff]
  interpret order_pair "(lex_two s1 ns1 s2)" "(lex_two s1 ns1 ns2)"
    by(rule lex_two_order_pair, standard)
  show ?thesis by(standard, rule lex_two; fact)
qed

text \<open>
  In the unbounded lexicographic extension, there is no restriction on the lengths
  of the lists. Therefore it is possible to compare lists of different lengths.
  This usually results a non-terminating relation, e.g., $[1] > [0, 1] > [0, 0, 1] > \ldots$
\<close>

fun lex_ext_unbounded :: "('a \<Rightarrow> 'a \<Rightarrow> bool \<times> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool \<times> bool"
  where "lex_ext_unbounded f [] [] = (False, True)" |
    "lex_ext_unbounded f (_ # _) [] = (True, True)" |
    "lex_ext_unbounded f [] (_ # _) = (False, False)" |
    "lex_ext_unbounded f (a # as) (b # bs) =
      (let (stri, nstri) = f a b in
      if stri then (True, True)
      else if nstri then lex_ext_unbounded f as bs
      else (False, False))"

lemma lex_ext_unbounded_iff: "(lex_ext_unbounded f xs ys) = (
  ((\<exists> i < length xs. i < length ys \<and> (\<forall> j < i. snd (f (xs ! j) (ys ! j))) \<and> fst (f (xs ! i) (ys !i))) \<or>
  (\<forall> i < length ys. snd (f (xs ! i) (ys ! i))) \<and> length xs > length ys),
  ((\<exists> i < length xs. i < length ys \<and> (\<forall> j < i. snd (f (xs ! j) (ys ! j))) \<and> fst (f (xs ! i) (ys !i))) \<or>
  (\<forall> i < length ys. snd (f (xs ! i) (ys ! i))) \<and> length xs \<ge> length ys))
  " (is "?lex xs ys = (?stri xs ys, ?nstri xs ys)")
proof (induct xs arbitrary: ys)
  case Nil then show ?case by (cases ys, auto)
next
  case (Cons a as)
  note oCons = this
  from oCons show ?case
  proof (cases ys, simp)
    case (Cons b bs)
    show ?thesis
    proof (cases "f a b")
      case (Pair stri nstri)
      show ?thesis
      proof (cases stri)
        case True
        with Pair Cons show ?thesis by auto
      next
        case False
        show ?thesis
        proof (cases nstri)
          case False
          with \<open>\<not> stri\<close> Pair Cons show ?thesis by force
        next
          case True
          with False Pair have f: "f a b = (False, True)" by auto
          show ?thesis by (simp add: all_Suc_conv ex_Suc_conv Cons f oCons)
        qed
      qed
    qed
  qed
qed

declare lex_ext_unbounded.simps[simp del]

text \<open>
  The lexicographic extension of an order pair takes a natural number as maximum bound.
  A decrease with lists of unequal lengths will never be successful if the length of the
  second list exceeds this bound. The bound is essential to preserve strong normalization.
\<close>
definition lex_ext :: "('a \<Rightarrow> 'a \<Rightarrow> bool \<times> bool) \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool \<times> bool"
  where
    "lex_ext f n ss ts =
      (let lts = length ts in
      if (length ss = lts \<or> lts \<le> n) then lex_ext_unbounded f ss ts
      else (False, False))"

lemma lex_ext_iff: "(lex_ext f m xs ys) = (
  (length xs = length ys \<or> length ys \<le> m) \<and> ((\<exists> i < length xs. i < length ys \<and> (\<forall> j < i. snd (f (xs ! j) (ys ! j))) \<and> fst (f (xs ! i) (ys !i))) \<or>
  (\<forall> i < length ys. snd (f (xs ! i) (ys ! i))) \<and> length xs > length ys),
  (length xs = length ys \<or> length ys \<le> m) \<and>
  ((\<exists> i < length xs. i < length ys \<and> (\<forall> j < i. snd (f (xs ! j) (ys ! j))) \<and> fst (f (xs ! i) (ys !i))) \<or>
  (\<forall> i < length ys. snd (f (xs ! i) (ys ! i))) \<and> length xs \<ge> length ys))
  "
  unfolding lex_ext_def
  by (simp only: lex_ext_unbounded_iff Let_def, auto)

lemma lex_ext_to_lex_ext_unbounded:
  assumes "length xs \<le> n" and "length ys \<le> n"
  shows "lex_ext f n xs ys = lex_ext_unbounded f xs ys"
  using assms by (simp add: lex_ext_def)

lemma lex_ext_stri_imp_nstri:
  assumes "fst (lex_ext f m xs ys)"
  shows "snd (lex_ext f m xs ys)"
  using assms by (auto simp: lex_ext_iff)

lemma lex_ext_unbounded_stri_imp_nstri:
  assumes "fst (lex_ext_unbounded f xs ys)"
  shows "snd (lex_ext_unbounded f xs ys)"
  using assms by (auto simp: lex_ext_unbounded_iff)

lemma all_nstri_imp_lex_nstri: assumes "\<forall> i < length ys. snd (f (xs ! i) (ys ! i))" and "length xs \<ge> length ys" and "length xs = length ys \<or> length ys \<le> m"
  shows "snd (lex_ext f m xs ys)"
  using assms by (auto simp: lex_ext_iff)

lemma lex_ext_cong[fundef_cong]: fixes f g m1 m2 xs1 xs2 ys1 ys2
  assumes "length xs1 = length ys1" and "m1 = m2" and "length xs2 = length ys2" and "\<And> i. \<lbrakk>i < length ys1; i < length ys2\<rbrakk> \<Longrightarrow> f (xs1 ! i) (xs2 ! i) = g (ys1 ! i) (ys2 ! i)"
  shows "lex_ext f m1 xs1 xs2 = lex_ext g m2 ys1 ys2"
  using assms by (auto simp: lex_ext_iff)

lemma lex_ext_unbounded_cong[fundef_cong]: assumes "as = as'" and "bs = bs'"
  and "\<And> i. i < length as' \<Longrightarrow> i < length bs' \<Longrightarrow> f (as' ! i) (bs' ! i) = g (as' ! i) (bs' ! i)" shows "lex_ext_unbounded f as bs = lex_ext_unbounded g as' bs'"
  unfolding assms lex_ext_unbounded_iff using assms(3) by auto

text \<open>Compatibility is the key property to ensure transitivity of the order.\<close>

text \<open>
  We prove compatibility locally, i.e., it only has to hold for elements
  of the argument lists. Locality is essential for being applicable in recursively
  defined term orders such as KBO.
\<close>
lemma lex_ext_compat:
  assumes compat: "\<And> s t u. \<lbrakk>s \<in> set ss; t \<in> set ts; u \<in> set us\<rbrakk> \<Longrightarrow>
    (snd (f s t) \<and> fst (f t u) \<longrightarrow> fst (f s u)) \<and>
    (fst (f s t) \<and> snd (f t u) \<longrightarrow> fst (f s u)) \<and>
    (snd (f s t) \<and> snd (f t u) \<longrightarrow> snd (f s u)) \<and>
    (fst (f s t) \<and> fst (f t u) \<longrightarrow> fst (f s u))"
  shows "
    (snd (lex_ext f n ss ts) \<and> fst (lex_ext f n ts us) \<longrightarrow> fst (lex_ext f n ss us)) \<and>
    (fst (lex_ext f n ss ts) \<and> snd (lex_ext f n ts us) \<longrightarrow> fst (lex_ext f n ss us)) \<and>
    (snd (lex_ext f n ss ts) \<and> snd (lex_ext f n ts us) \<longrightarrow> snd (lex_ext f n ss us)) \<and>
    (fst (lex_ext f n ss ts) \<and> fst (lex_ext f n ts us) \<longrightarrow> fst (lex_ext f n ss us))
    "
proof -
  let ?ls = "length ss"
  let ?lt = "length ts"
  let ?lu = "length us"
  let ?st = "lex_ext f n ss ts"
  let ?tu = "lex_ext f n ts us"
  let ?su = "lex_ext f n ss us"
  let ?fst = "\<lambda> ss ts i. fst (f (ss ! i) (ts ! i))"
  let ?snd = "\<lambda> ss ts i. snd (f (ss ! i) (ts ! i))"
  let ?ex = "\<lambda> ss ts. \<exists> i < length ss. i < length ts \<and> (\<forall> j < i. ?snd ss ts j) \<and> ?fst ss ts i"
  let ?all = "\<lambda> ss ts. \<forall> i < length ts. ?snd ss ts i"
  have lengths: "(?ls = ?lt \<or> ?lt \<le> n) \<and> (?lt = ?lu \<or> ?lu \<le> n) \<longrightarrow>
    (?ls = ?lu \<or> ?lu \<le> n)" (is "?lst \<and> ?ltu \<longrightarrow> ?lsu") by arith
  {
    assume st: "snd ?st" and tu: "fst ?tu"
    with lengths have lsu: "?lsu" by (simp add: lex_ext_iff)
    from st have st: "?ex ss ts \<or> ?all ss ts \<and> ?lt \<le> ?ls" by (simp add: lex_ext_iff)
    from tu have tu: "?ex ts us \<or> ?all ts us \<and> ?lu < ?lt" by (simp add: lex_ext_iff)
    from st have "fst ?su"
    proof
      assume st: "?ex ss ts"
      then obtain i1 where i1: "i1 < ?ls \<and> i1 < ?lt" and fst1: "?fst ss ts i1" and snd1: "\<forall> j < i1. ?snd ss ts j" by force
      from tu show ?thesis
      proof
        assume tu: "?ex ts us"
        then obtain i2 where i2: "i2 < ?lt \<and> i2 < ?lu" and fst2: "?fst ts us i2" and snd2: "\<forall> j < i2. ?snd ts us j" by auto
        let ?i = "min i1 i2"
        from i1 i2 have i: "?i < ?ls \<and> ?i < ?lt \<and> ?i < ?lu" by auto
        then have ssi: "ss ! ?i \<in> set ss" and tsi: "ts ! ?i \<in> set ts" and usi: "us ! ?i \<in> set us" by auto
        have snd: "\<forall> j < ?i. ?snd ss us j"
        proof (intro allI impI)
          fix j
          assume j: "j < ?i"
          with snd1 snd2 have snd1: "?snd ss ts j" and snd2: "?snd ts us j" by auto
          from j i have ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
          from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
        qed
        have fst: "?fst ss us ?i"
        proof (cases "i1 < i2")
          case True
          then have "?i = i1" by simp
          with True fst1 snd2 have "?fst ss ts ?i" and "?snd ts us ?i" by auto
          with compat[OF ssi tsi usi] show "?fst ss us ?i" by auto
        next
          case False
          show ?thesis
          proof (cases "i2 < i1")
            case True
            then have "?i = i2" by simp
            with True snd1 fst2 have "?snd ss ts ?i" and "?fst ts us ?i" by auto
            with compat[OF ssi tsi usi] show "?fst ss us ?i" by auto
          next
            case False
            with \<open>\<not> i1 < i2\<close> have "i1 = i2" by simp
            with fst1 fst2 have "?fst ss ts ?i" and "?fst ts us ?i" by auto
            with compat[OF ssi tsi usi] show "?fst ss us ?i" by auto
          qed
        qed
        show ?thesis by (simp add: lex_ext_iff lsu, rule disjI1, rule exI[of _ ?i], simp add: fst snd i)
      next
        assume tu: "?all ts us \<and> ?lu < ?lt"
        show ?thesis
        proof (cases "i1 < ?lu")
          case True
          then have usi: "us ! i1 \<in> set us" by auto
          from i1 have ssi: "ss ! i1 \<in> set ss" and tsi: "ts ! i1 \<in> set ts" by auto
          from True tu have "?snd ts us i1" by auto
          with fst1 compat[OF ssi tsi usi] have fst: "?fst ss us i1" by auto
          have snd: "\<forall> j < i1. ?snd ss us j"
          proof (intro allI impI)
            fix j
            assume "j < i1"
            with i1 True snd1 tu have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
              ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
            from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
          qed
          with fst lsu True i1 show ?thesis by (auto simp: lex_ext_iff)
        next
          case False
          with i1 have lus: "?lu < ?ls" by auto
          have snd: "\<forall> j < ?lu. ?snd ss us j"
          proof (intro allI impI)
            fix j
            assume "j < ?lu"
            with False i1 snd1 tu have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
              ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
            from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
          qed
          with lus lsu show ?thesis by (auto simp: lex_ext_iff)
        qed
      qed
    next
      assume st: "?all ss ts \<and> ?lt \<le> ?ls"
      from tu
      show ?thesis
      proof
        assume tu: "?ex ts us"
        with st obtain i2 where i2: "i2 < ?lt \<and> i2 < ?lu" and fst2: "?fst ts us i2" and snd2: "\<forall> j < i2. ?snd ts us j" by auto
        from st i2 have i2: "i2 < ?ls \<and> i2 < ?lt \<and> i2 < ?lu" by auto
        then have ssi: "ss ! i2 \<in> set ss" and tsi: "ts ! i2 \<in> set ts" and usi: "us ! i2 \<in> set us" by auto
        from i2 st have "?snd ss ts i2" by auto
        with fst2 compat[OF ssi tsi usi] have fst: "?fst ss us i2" by auto
        have snd: "\<forall> j < i2. ?snd ss us j"
        proof (intro allI impI)
          fix j
          assume "j < i2"
          with i2 snd2 st have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
            ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
          from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
        qed
        with fst lsu i2 show ?thesis by (auto simp: lex_ext_iff)
      next
        assume tu: "?all ts us \<and> ?lu < ?lt"
        with st have lus: "?lu < ?ls" by auto
        have snd: "\<forall> j < ?lu. ?snd ss us j"
        proof (intro allI impI)
          fix j
          assume "j < ?lu"
          with st tu have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
            ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
          from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
        qed
        with lus lsu show ?thesis by (auto simp: lex_ext_iff)
      qed
    qed
  }
  moreover
  {
    assume st: "fst ?st" and tu: "snd ?tu"
    with lengths have lsu: "?lsu" by (simp add: lex_ext_iff)
    from st have st: "?ex ss ts \<or> ?all ss ts \<and> ?lt < ?ls" by (simp add: lex_ext_iff)
    from tu have tu: "?ex ts us \<or> ?all ts us \<and> ?lu \<le> ?lt" by (simp add: lex_ext_iff)
    from st have "fst ?su"
    proof
      assume st: "?ex ss ts"
      then obtain i1 where i1: "i1 < ?ls \<and> i1 < ?lt" and fst1: "?fst ss ts i1" and snd1: "\<forall> j < i1. ?snd ss ts j" by force
      from tu show ?thesis
      proof
        assume tu: "?ex ts us"
        then obtain i2 where i2: "i2 < ?lt \<and> i2 < ?lu" and fst2: "?fst ts us i2" and snd2: "\<forall> j < i2. ?snd ts us j" by auto
        let ?i = "min i1 i2"
        from i1 i2 have i: "?i < ?ls \<and> ?i < ?lt \<and> ?i < ?lu" by auto
        then have ssi: "ss ! ?i \<in> set ss" and tsi: "ts ! ?i \<in> set ts" and usi: "us ! ?i \<in> set us" by auto
        have snd: "\<forall> j < ?i. ?snd ss us j"
        proof (intro allI impI)
          fix j
          assume j: "j < ?i"
          with snd1 snd2 have snd1: "?snd ss ts j" and snd2: "?snd ts us j" by auto
          from j i have ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
          from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
        qed
        have fst: "?fst ss us ?i"
        proof (cases "i1 < i2")
          case True
          then have "?i = i1" by simp
          with True fst1 snd2 have "?fst ss ts ?i" and "?snd ts us ?i" by auto
          with compat[OF ssi tsi usi] show "?fst ss us ?i" by auto
        next
          case False
          show ?thesis
          proof (cases "i2 < i1")
            case True
            then have "?i = i2" by simp
            with True snd1 fst2 have "?snd ss ts ?i" and "?fst ts us ?i" by auto
            with compat[OF ssi tsi usi] show "?fst ss us ?i" by auto
          next
            case False
            with \<open>\<not> i1 < i2\<close> have "i1 = i2" by simp
            with fst1 fst2 have "?fst ss ts ?i" and "?fst ts us ?i" by auto
            with compat[OF ssi tsi usi] show "?fst ss us ?i" by auto
          qed
        qed
        show ?thesis by (simp add: lex_ext_iff lsu, rule disjI1, rule exI[of _ ?i], simp add: fst snd i)
      next
        assume tu: "?all ts us \<and> ?lu \<le> ?lt"
        show ?thesis
        proof (cases "i1 < ?lu")
          case True
          then have usi: "us ! i1 \<in> set us" by auto
          from i1 have ssi: "ss ! i1 \<in> set ss" and tsi: "ts ! i1 \<in> set ts" by auto
          from True tu have "?snd ts us i1" by auto
          with fst1 compat[OF ssi tsi usi] have fst: "?fst ss us i1" by auto
          have snd: "\<forall> j < i1. ?snd ss us j"
          proof (intro allI impI)
            fix j
            assume "j < i1"
            with i1 True snd1 tu have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
              ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
            from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
          qed
          with fst lsu True i1 show ?thesis by (auto simp: lex_ext_iff)
        next
          case False
          with i1 have lus: "?lu < ?ls" by auto
          have snd: "\<forall> j < ?lu. ?snd ss us j"
          proof (intro allI impI)
            fix j
            assume "j < ?lu"
            with False i1 snd1 tu have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
              ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
            from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
          qed
          with lus lsu show ?thesis by (auto simp: lex_ext_iff)
        qed
      qed
    next
      assume st: "?all ss ts \<and> ?lt < ?ls"
      from tu
      show ?thesis
      proof
        assume tu: "?ex ts us"
        with st obtain i2 where i2: "i2 < ?lt \<and> i2 < ?lu" and fst2: "?fst ts us i2" and snd2: "\<forall> j < i2. ?snd ts us j" by auto
        from st i2 have i2: "i2 < ?ls \<and> i2 < ?lt \<and> i2 < ?lu" by auto
        then have ssi: "ss ! i2 \<in> set ss" and tsi: "ts ! i2 \<in> set ts" and usi: "us ! i2 \<in> set us" by auto
        from i2 st have "?snd ss ts i2" by auto
        with fst2 compat[OF ssi tsi usi] have fst: "?fst ss us i2" by auto
        have snd: "\<forall> j < i2. ?snd ss us j"
        proof (intro allI impI)
          fix j
          assume "j < i2"
          with i2 snd2 st have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
            ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
          from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
        qed
        with fst lsu i2 show ?thesis by (auto simp: lex_ext_iff)
      next
        assume tu: "?all ts us \<and> ?lu \<le> ?lt"
        with st have lus: "?lu < ?ls" by auto
        have snd: "\<forall> j < ?lu. ?snd ss us j"
        proof (intro allI impI)
          fix j
          assume "j < ?lu"
          with st tu have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
            ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
          from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
        qed
        with lus lsu show ?thesis by (auto simp: lex_ext_iff)
      qed
    qed
  }
  moreover
  {
    assume st: "snd ?st" and tu: "snd ?tu"
    with lengths have lsu: "?lsu" by (simp add: lex_ext_iff)
    from st have st: "?ex ss ts \<or> ?all ss ts \<and> ?lt \<le> ?ls" by (simp add: lex_ext_iff)
    from tu have tu: "?ex ts us \<or> ?all ts us \<and> ?lu \<le> ?lt" by (simp add: lex_ext_iff)
    from st have "snd ?su"
    proof
      assume st: "?ex ss ts"
      then obtain i1 where i1: "i1 < ?ls \<and> i1 < ?lt" and fst1: "?fst ss ts i1" and snd1: "\<forall> j < i1. ?snd ss ts j" by force
      from tu show ?thesis
      proof
        assume tu: "?ex ts us"
        then obtain i2 where i2: "i2 < ?lt \<and> i2 < ?lu" and fst2: "?fst ts us i2" and snd2: "\<forall> j < i2. ?snd ts us j" by auto
        let ?i = "min i1 i2"
        from i1 i2 have i: "?i < ?ls \<and> ?i < ?lt \<and> ?i < ?lu" by auto
        then have ssi: "ss ! ?i \<in> set ss" and tsi: "ts ! ?i \<in> set ts" and usi: "us ! ?i \<in> set us" by auto
        have snd: "\<forall> j < ?i. ?snd ss us j"
        proof (intro allI impI)
          fix j
          assume j: "j < ?i"
          with snd1 snd2 have snd1: "?snd ss ts j" and snd2: "?snd ts us j" by auto
          from j i have ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
          from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
        qed
        have fst: "?fst ss us ?i"
        proof (cases "i1 < i2")
          case True
          then have "?i = i1" by simp
          with True fst1 snd2 have "?fst ss ts ?i" and "?snd ts us ?i" by auto
          with compat[OF ssi tsi usi] show "?fst ss us ?i" by auto
        next
          case False
          show ?thesis
          proof (cases "i2 < i1")
            case True
            then have "?i = i2" by simp
            with True snd1 fst2 have "?snd ss ts ?i" and "?fst ts us ?i" by auto
            with compat[OF ssi tsi usi] show "?fst ss us ?i" by auto
          next
            case False
            with \<open>\<not> i1 < i2\<close> have "i1 = i2" by simp
            with fst1 fst2 have "?fst ss ts ?i" and "?fst ts us ?i" by auto
            with compat[OF ssi tsi usi] show "?fst ss us ?i" by auto
          qed
        qed
        show ?thesis by (simp add: lex_ext_iff lsu, rule disjI1, rule exI[of _ ?i], simp add: fst snd i)
      next
        assume tu: "?all ts us \<and> ?lu \<le> ?lt"
        show ?thesis
        proof (cases "i1 < ?lu")
          case True
          then have usi: "us ! i1 \<in> set us" by auto
          from i1 have ssi: "ss ! i1 \<in> set ss" and tsi: "ts ! i1 \<in> set ts" by auto
          from True tu have "?snd ts us i1" by auto
          with fst1 compat[OF ssi tsi usi] have fst: "?fst ss us i1" by auto
          have snd: "\<forall> j < i1. ?snd ss us j"
          proof (intro allI impI)
            fix j
            assume "j < i1"
            with i1 True snd1 tu have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
              ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
            from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
          qed
          with fst lsu True i1 show ?thesis by (auto simp: lex_ext_iff)
        next
          case False
          with i1 have lus: "?lu \<le> ?ls" by auto
          have snd: "\<forall> j < ?lu. ?snd ss us j"
          proof (intro allI impI)
            fix j
            assume "j < ?lu"
            with False i1 snd1 tu have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
              ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
            from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
          qed
          with lus lsu show ?thesis by (auto simp: lex_ext_iff)
        qed
      qed
    next
      assume st: "?all ss ts \<and> ?lt \<le> ?ls"
      from tu
      show ?thesis
      proof
        assume tu: "?ex ts us"
        with st obtain i2 where i2: "i2 < ?lt \<and> i2 < ?lu" and fst2: "?fst ts us i2" and snd2: "\<forall> j < i2. ?snd ts us j" by auto
        from st i2 have i2: "i2 < ?ls \<and> i2 < ?lt \<and> i2 < ?lu" by auto
        then have ssi: "ss ! i2 \<in> set ss" and tsi: "ts ! i2 \<in> set ts" and usi: "us ! i2 \<in> set us" by auto
        from i2 st have "?snd ss ts i2" by auto
        with fst2 compat[OF ssi tsi usi] have fst: "?fst ss us i2" by auto
        have snd: "\<forall> j < i2. ?snd ss us j"
        proof (intro allI impI)
          fix j
          assume "j < i2"
          with i2 snd2 st have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
            ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
          from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
        qed
        with fst lsu i2 show ?thesis by (auto simp: lex_ext_iff)
      next
        assume tu: "?all ts us \<and> ?lu \<le> ?lt"
        with st have lus: "?lu \<le> ?ls" by auto
        have snd: "\<forall> j < ?lu. ?snd ss us j"
        proof (intro allI impI)
          fix j
          assume "j < ?lu"
          with st tu have snd1: "?snd ss ts j" and snd2: "?snd ts us j" and
            ssj: "ss ! j \<in> set ss" and tsj: "ts ! j \<in> set ts" and usj: "us ! j \<in> set us" by auto
          from compat[OF ssj tsj usj] snd1 snd2 show "?snd ss us j" by auto
        qed
        with lus lsu show ?thesis by (auto simp: lex_ext_iff)
      qed
    qed
  }
  ultimately
  show ?thesis using lex_ext_stri_imp_nstri by blast
qed

lemma lex_ext_unbounded_map:
  assumes S: "\<And> i. i < length ss \<Longrightarrow> i < length ts \<Longrightarrow> fst (r (ss ! i) (ts ! i)) \<Longrightarrow> fst (r (map f ss ! i) (map f ts ! i))"
    and NS: "\<And> i. i < length ss \<Longrightarrow> i < length ts \<Longrightarrow> snd (r (ss ! i) (ts ! i)) \<Longrightarrow> snd (r (map f ss ! i) (map f ts ! i))"
  shows "(fst (lex_ext_unbounded r ss ts) \<longrightarrow> fst (lex_ext_unbounded r (map f ss) (map f ts))) \<and>
    (snd (lex_ext_unbounded r ss ts) \<longrightarrow> snd (lex_ext_unbounded r (map f ss) (map f ts)))"
  using S NS unfolding lex_ext_unbounded_iff by auto

lemma lex_ext_unbounded_map_S:
  assumes S: "\<And> i. i < length ss \<Longrightarrow> i < length ts \<Longrightarrow> fst (r (ss ! i) (ts ! i)) \<Longrightarrow> fst (r (map f ss ! i) (map f ts ! i))"
    and NS: "\<And> i. i < length ss \<Longrightarrow> i < length ts \<Longrightarrow> snd (r (ss ! i) (ts ! i)) \<Longrightarrow> snd (r (map f ss ! i) (map f ts ! i))"
    and stri: "fst (lex_ext_unbounded r ss ts)"
  shows "fst (lex_ext_unbounded r (map f ss) (map f ts))"
  using lex_ext_unbounded_map[of ss ts r f, OF S NS] stri by blast

lemma lex_ext_unbounded_map_NS:
  assumes S: "\<And> i. i < length ss \<Longrightarrow> i < length ts \<Longrightarrow> fst (r (ss ! i) (ts ! i)) \<Longrightarrow> fst (r (map f ss ! i) (map f ts ! i))"
    and NS: "\<And> i. i < length ss \<Longrightarrow> i < length ts \<Longrightarrow> snd (r (ss ! i) (ts ! i)) \<Longrightarrow> snd (r (map f ss ! i) (map f ts ! i))"
    and nstri: "snd (lex_ext_unbounded r ss ts)"
  shows "snd (lex_ext_unbounded r (map f ss) (map f ts))"
  using lex_ext_unbounded_map[of ss ts r f, OF S NS] nstri by blast

text \<open>Strong normalization with local SN assumption\<close>
lemma lex_ext_SN:
  assumes compat: "\<And> x y z. \<lbrakk>snd (g x y); fst (g y z)\<rbrakk> \<Longrightarrow> fst (g x z)"
  shows "SN { (ys, xs). (\<forall> y \<in> set ys. SN_on { (s, t). fst (g s t) } {y}) \<and> fst (lex_ext g m ys xs) }"
    (is "SN { (ys, xs). ?cond ys xs }")
proof (rule ccontr)
  assume "\<not> ?thesis"
  from this obtain f where f: "\<And> n :: nat. ?cond (f n) (f (Suc n))" unfolding SN_defs by auto
  have m_imp_m: "\<And> n. length (f n) \<le> m \<Longrightarrow> length (f (Suc n)) \<le> m"
  proof -
    fix n
    assume "length (f n) \<le> m"
    then show "length (f (Suc n)) \<le> m"
      using f[of n] by (auto simp: lex_ext_iff)
  qed
  have lm_imp_m_or_eq: "\<And> n. length (f n) > m \<Longrightarrow> length (f (Suc n)) \<le> m \<or> length (f n) = length (f (Suc n))"
  proof -
    fix n
    assume "length (f n) > m"
    then have "\<not> length (f n) \<le> m" by auto
    then show "length (f (Suc n)) \<le> m \<or> length (f n) = length (f (Suc n))"
      using f[of n] by (simp add: lex_ext_iff, blast)
  qed
  let ?l0 = "max (length (f 0)) m"
  have "\<And> n. length (f n) \<le> ?l0"
  proof -
    fix n
    show "length (f n) \<le> ?l0"
    proof (induct n, simp)
      case (Suc n)
      show ?case
      proof (cases "length (f n) \<le> m")
        case True
        with m_imp_m[of n] show ?thesis by auto
      next
        case False
        then have "length (f n) > m" by auto
        with lm_imp_m_or_eq[of n]
        have "length (f n) = length (f (Suc n)) \<or> length (f (Suc n)) \<le> m" by auto
        with Suc show ?thesis by auto
      qed
    qed
  qed
  from this obtain m' where len: "\<And> n. length (f n) \<le> m'" by auto
  let ?lexgr = "\<lambda> ys xs. fst (lex_ext g m ys xs)"
  let ?lexge = "\<lambda> ys xs. snd (lex_ext g m ys xs)"
  let ?gr = "\<lambda> t s. fst (g t s)"
  let ?ge = "\<lambda> t s. snd (g t s)"
  let ?S = "{ (y, x). fst (g y x) }"
  let ?NS = "{ (y, x). snd (g y x) }"
  let ?baseSN = "\<lambda> ys. \<forall> y \<in> set ys. SN_on ?S {y}"
  let ?con = "\<lambda> ys xs m'. ?baseSN ys \<and> length ys \<le> m' \<and> ?lexgr ys xs"
  let ?confn = "\<lambda> m' f n . ?con (f n) (f (Suc n)) m'"
  from compat have compat2: "?NS O ?S \<subseteq> ?S" by auto
  from f len have  "\<exists> f. \<forall> n. ?confn m' f n" by auto
  then show False
  proof (induct m')
    case 0
    from this obtain f where "?confn 0 f 0" by auto
    then have "?lexgr [] (f (Suc 0))" by force
    then show False by (simp add: lex_ext_iff)
  next
    case (Suc m')
    from this obtain f where confn: "\<And> n. ?confn (Suc m') f n" by auto
    have ne: "\<And> n. f n \<noteq> []"
    proof -
      fix n
      show "f n \<noteq> []"
      proof (cases "f n")
        case (Cons a b) then show ?thesis by auto
      next
        case Nil
        with confn[of n] show ?thesis by (simp add: lex_ext_iff)
      qed
    qed
    let ?hf = "\<lambda> n. hd (f n)"
    have ge: "\<And> n. ?ge (?hf n) (?hf (Suc n)) \<or> ?gr (?hf n) (?hf (Suc n))"
    proof -
      fix n
      from ne[of n] obtain a as where n: "f n = a # as" by (cases "f n", auto)
      from ne[of "Suc n"] obtain b bs where sn: "f (Suc n) = b # bs" by (cases "f (Suc n)", auto)
      from n sn have "?ge a b \<or> ?gr a b"
      proof (cases "?gr a b", simp, cases "?ge a b", simp)
        assume "\<not> ?gr a b" and "\<not> ?ge a b"
        then have g: "g a b = (False, False)" by (cases "g a b", auto)
        from confn[of n] have "fst (lex_ext g m (f n) (f (Suc n)))" (is ?fst) by simp
        have "?fst = False" by (simp add: n sn lex_ext_def g lex_ext_unbounded.simps)
        with \<open>?fst\<close> show "?ge a b \<or> ?gr a b" by simp
      qed
      with n sn show "?ge (?hf n) (?hf (Suc n)) \<or> ?gr (?hf n) (?hf (Suc n))" by simp
    qed
    from ge have GE: "\<forall> n. (?hf n, ?hf (Suc n)) \<in> ?NS \<union> ?S" by auto
    from confn[of 0] ne[of 0] have SN_0: "SN_on ?S {?hf 0}" by (cases "f 0", auto )
    from non_strict_ending[of ?hf, OF GE compat2 SN_0]
    obtain j where j: "\<forall> i \<ge> j. (?hf i, ?hf (Suc i)) \<in> ?NS - ?S" by auto
    let ?h = "\<lambda> n. tl (f (j + n))"
    obtain h where h: "h = ?h"  by auto
    have "\<And> n. ?confn m' h n"
    proof -
      fix n
      let ?nj = "j + n"
      from spec[OF j, of ?nj]
      have ge_not_gr: "(?hf ?nj, ?hf (Suc ?nj)) \<in> ?NS - ?S" by simp
      from confn[of ?nj] have old: "?confn (Suc m') f ?nj" by simp
      from ne[of ?nj] obtain a as where n: "f ?nj = a # as" by (cases "f ?nj", auto)
      from ne[of "Suc ?nj"] obtain b bs where sn: "f (Suc ?nj) = b # bs" by (cases "f (Suc ?nj)", auto)
      from old have one: "\<forall> y \<in> set (h n). SN_on ?S {y}"
        by (simp add: h n)
      from old have two: "length (h n) \<le> m'" by (simp add: j n h)
      from ge_not_gr have ge_not_gr2: "g a b = (False, True)"  by (simp add: n sn, cases "g a b", auto)
      from old have "fst (lex_ext g m (f (j+ n)) (f (Suc (j+n))))" (is ?fst) by simp
      then have "length as = length bs \<or> length bs \<le> m" (is ?len)
        by (simp add: lex_ext_def n sn, cases ?len, auto)
      from \<open>?fst\<close>[simplified n sn] have "fst (lex_ext_unbounded g as bs)" (is ?fst)
        by (simp add: lex_ext_def, cases "length as = length bs \<or> Suc (length bs) \<le> m", simp_all add: ge_not_gr2 lex_ext_unbounded.simps)
      then have "fst (lex_ext_unbounded g as bs)" (is ?fst)
        by (simp add: lex_ext_unbounded_iff)
      have three: "?lexgr (h n) (h (Suc n))"
        by (simp add: lex_ext_def h n sn ge_not_gr2 lex_ext_unbounded.simps, simp only: Let_def, simp add: \<open>?len\<close> \<open>?fst\<close>)
      from one two three show "?confn m' h n" by blast
    qed
    with Suc show ?thesis by blast
  qed
qed

text \<open>Strong normalization with global SN assumption is immediate consequence.\<close>
lemma lex_ext_SN_2:
  assumes compat: "\<And> x y z. \<lbrakk>snd (g x y); fst (g y z)\<rbrakk> \<Longrightarrow> fst (g x z)"
    and SN:  "SN {(s, t). fst (g s t)}"
  shows "SN { (ys, xs). fst (lex_ext g m ys xs) }"
proof -
  from lex_ext_SN[OF compat]
  have "SN { (ys, xs). (\<forall> y \<in> set ys. SN_on { (s, t). fst (g s t) } {y}) \<and> fst (lex_ext g m ys xs) }" .
  then show ?thesis using SN unfolding SN_on_def by fastforce
qed

text \<open>The empty list is the least element in the lexicographic extension.\<close>
lemma lex_ext_least_1: "snd (lex_ext f m xs [])"
  by (simp add: lex_ext_iff)

lemma lex_ext_least_2: "\<not> fst (lex_ext f m [] ys)"
  by (simp add: lex_ext_iff)

text \<open>Preservation of totality on lists of same length.\<close>
lemma lex_ext_unbounded_total:
  assumes "\<forall>(s, t)\<in>set (zip ss ts). s = t \<or> fst (f s t) \<or> fst (f t s)"
    and refl: "\<And> t. snd (f t t)"
    and "length ss = length ts"
  shows "ss = ts \<or> fst (lex_ext_unbounded f ss ts) \<or> fst (lex_ext_unbounded f ts ss)"
  using assms(3, 1)
proof (induct ss ts rule: list_induct2)
  case (Cons s ss t ts)
  from Cons(3) have "s = t \<or> (fst (f s t) \<or> fst (f t s))" by auto
  then show ?case
  proof
    assume st: "s = t"
    then show ?thesis using Cons(2-3) refl[of t] by (cases "f t t", auto simp: lex_ext_unbounded.simps)
  qed (auto simp: lex_ext_unbounded.simps split: prod.splits)
qed simp

lemma lex_ext_total:
  assumes "\<forall>(s, t)\<in>set (zip ss ts). s = t \<or> fst (f s t) \<or> fst (f t s)"
    and "\<And> t. snd (f t t)"
    and len: "length ss = length ts"
  shows "ss = ts \<or> fst (lex_ext f n ss ts) \<or> fst (lex_ext f n ts ss)"
  using lex_ext_unbounded_total[OF assms] unfolding lex_ext_def Let_def len by auto

text \<open>Monotonicity of the lexicographic extension.\<close>
lemma lex_ext_unbounded_mono:
  assumes "\<And>i. \<lbrakk>i < length xs; i < length ys; fst (P (xs ! i) (ys ! i))\<rbrakk> \<Longrightarrow> fst (P' (xs ! i) (ys ! i))"
    and   "\<And>i. \<lbrakk>i < length xs; i < length ys; snd (P (xs ! i) (ys ! i))\<rbrakk> \<Longrightarrow> snd (P' (xs ! i) (ys ! i))"
  shows
    "(fst (lex_ext_unbounded P xs ys) \<longrightarrow> fst (lex_ext_unbounded P' xs ys)) \<and>
     (snd (lex_ext_unbounded P xs ys) \<longrightarrow> snd (lex_ext_unbounded P' xs ys))"
    (is "(?l1 xs ys \<longrightarrow> ?r1 xs ys) \<and> (?l2 xs ys \<longrightarrow> ?r2 xs ys)")
  using assms
proof (induct x\<equiv>P xs ys rule: lex_ext_unbounded.induct)
  note [simp] = lex_ext_unbounded.simps
  case (4 x xs y ys)
  consider (TT) "P x y = (True, True)"
    | (TF) "P x y = (True, False)"
    | (FT) "P x y = (False, True)"
    | (FF) "P x y = (False, False)" by (cases "P x y", auto)
  thus ?case
  proof cases
    case TT
    moreover
    with 4(2) [of 0] and 4(3) [of 0]
    have "P' x y = (True, True)"
      by (auto) (metis (full_types) prod.collapse)
    ultimately
    show ?thesis by simp
  next
    case TF
    show ?thesis
    proof (cases "snd (P' x y)")
      case False
      moreover
      with 4(2) [of 0] and TF
      have "P' x y = (True, False)"
        by (cases "P' x y", auto)
      ultimately
      show ?thesis by simp
    next
      case True
      with 4(2) [of 0] and TF
      have "P' x y = (True, True)"
        by (auto )(metis (full_types) fst_conv snd_conv surj_pair)
      then show ?thesis by simp
    qed
  next
    case FF then show ?thesis by simp
  next
    case FT
    show ?thesis
    proof (cases "fst (P' x y)")
      case True
      with 4(3) [of 0] and FT
      have *: "P' x y = (True, True)"
        by (auto) (metis (full_types) prod.collapse)
      have "?l1 (x#xs) (y#ys) \<longrightarrow> ?r1 (x#xs) (y#ys)"
        by (simp add: FT *)
      moreover
      have "?l2 (x#xs) (y#ys) \<longrightarrow> ?r2 (x#xs) (y#ys)"
        by (simp add: *)
      ultimately show ?thesis by blast
    next
      case False
      with 4(3) [of 0] and FT
      have *: "P' x y = (False, True)"
        by (cases "P' x y", auto)
      show ?thesis
        using 4(1) [OF refl FT [symmetric]] and 4(2) and 4(3)
        using FT *
        by (auto) (metis Suc_less_eq nth_Cons_Suc)+
    qed
  qed
qed (simp add: lex_ext_unbounded.simps)+

end


(*
    $Id: sol.thy,v 1.3 2006/10/04 23:48:20 kleing Exp $
    Author: Martin Strecker
*)

header {* Elimination of Connectives *}

(*<*) theory sol imports Main begin (*>*)

text {* In classical propositional logic, the connectives @{text "=, \<or>,
\<not>"} can be replaced by @{text "\<longrightarrow>, \<and>, False"}.  Define
corresponding simplification rules as lemmas and prove their correctness.  (You
may use automated proof tactics.) *}

lemma equiv_conel: "(A = B) = ((A \<longrightarrow> B) \<and> (B \<longrightarrow> A))"
  by iprover

lemma or_conel: "(A \<or> B) = (\<not> (\<not> A \<and> \<not> B))"
  by blast

lemma not_conel: "(\<not> A) = (A \<longrightarrow> False)"
  by blast

text {* What is the result of your translation for the formula @{text "A \<or>
(B \<and> C) = A"}?  (You can use Isabelle's simplifier to compute the result
by using the simplifier's @{text "only"} option.) *}

text {* Stating @{text "A \<or> (B \<and> C) = A"} as a lemma and application
of\\
@{text "(simp only: equiv_conel or_conel not_conel)"}\\
results in the simplified goal\\
@{text "(A \<longrightarrow> False) \<and> ((B \<and> C \<longrightarrow> A)
\<and> (A \<longrightarrow> B \<and> C) \<longrightarrow> False)
\<longrightarrow> False"}. *}

(*<*) end (*>*)


theory OneTimePad imports
  "HOL/Probability"
  "HOL/Groups_Big"
begin

type_synonym key     = "bool list"
type_synonym message = "bool list"
type_synonym crypted = "bool list"

definition zipWith :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
  "zipWith f xs ys = map (\<lambda> (x, y). f x y) (zip xs ys)"

(*primrec zipWith where
  "zipWith f [] ys = (case ys of [] \<Rightarrow> [])"
| "zipWith f (x # xs) zs = (case zs of y # ys \<Rightarrow> f x y # zipWith f xs ys)"

lemma "length xs = length ys \<Longrightarrow> zipWith f xs ys = map (\<lambda> (x, y). f x y) (zip xs ys)"
by (induct xs ys rule: list_induct2, auto)*)

definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
  "xor = not_equal"

definition encrypt :: "message \<Rightarrow> key \<Rightarrow> crypted" where
  "encrypt = zipWith xor"

definition decrypt :: "crypted \<Rightarrow> key \<Rightarrow> message" where
  "decrypt = zipWith xor"

definition reconstruct_key :: "crypted \<Rightarrow> message \<Rightarrow> key" where
  "reconstruct_key = zipWith xor"

lemma enc:
  assumes "length m = length k"
    shows "length (encrypt m k) = length m"
      and "decrypt (encrypt m k) k = m"
unfolding encrypt_def decrypt_def zipWith_def xor_def
using assms by (induct m k rule: list_induct2, auto)

lemma reconstruct:
  assumes "length m = length c"
    shows "length (reconstruct_key c m) = length m"
      and "encrypt m (reconstruct_key c m) = c"
unfolding encrypt_def reconstruct_key_def zipWith_def xor_def
using assms by (induct m c rule: list_induct2, auto)

lemma rec_uniq:
  assumes "length m = length k"
      and "encrypt m k = c"
    shows "k = reconstruct_key c m"
proof -
  have L: "length k = length c" using enc(1) assms(1) assms(2) by auto
  show ?thesis using assms(1) L assms(2) unfolding encrypt_def reconstruct_key_def zipWith_def xor_def
    by (induct m k c rule: list_induct3, auto)
qed

axiomatization
      \<K> :: "key set"
  and \<M> :: "message set"
  and P\<^sub>\<K> :: "key pmf"
  and P\<^sub>\<M> :: "message pmf"
  and len :: nat
where k_unipmf: "P\<^sub>\<K> = pmf_of_set \<K>"  (* uniform distribution *)
  and m_pmf: "set_pmf P\<^sub>\<M> \<subseteq> \<M>"
  and k_set: "\<K> = set (List.n_lists len [True, False])"
  and m_set: "\<M> = \<K>"

definition \<P>\<^sub>\<K> :: "key \<Rightarrow> real" where "\<P>\<^sub>\<K> = pmf P\<^sub>\<K>"
definition \<P>\<^sub>\<M> :: "message \<Rightarrow> real" where "\<P>\<^sub>\<M> = pmf P\<^sub>\<M>"

lemma k_finite: "finite \<K>"
by (metis List.finite_set k_set)

lemma k_nonemp: "\<K> \<noteq> {}"
unfolding k_set set_n_lists by (simp add: Ex_list_of_length subsetI)

lemma k_length: "\<forall>k\<in>\<K>. length k = len"
unfolding k_set using length_n_lists_elem by auto

lemma k_in_k: "k \<in> \<K> \<longleftrightarrow> (length k = len)"
proof (rule iffI)
  assume "k \<in> \<K>"
  then show "length k = len" unfolding k_set using length_n_lists_elem by auto
next
  assume "length k = len"
  then show "k \<in> \<K>" unfolding k_set set_n_lists by auto
qed

lemma pmf_sum_one:
  assumes "finite M"
      and "set_pmf P \<subseteq> M"
    shows "(\<Sum>m\<in>M. pmf P m) = 1"
proof -
  have "(\<Sum>m\<in>M. pmf P m) = measure (measure_pmf P) M"
    using assms(1) by (simp add: measure_measure_pmf_finite)
  also have "... = 1" using assms(2)
    using AE_measure_pmf_iff prob_space.AE_in_set_eq_1 prob_space_measure_pmf by fastforce
  finally show ?thesis .
qed

lemma m_sum_one: "(\<Sum>m\<in>\<M>. \<P>\<^sub>\<M> m) = 1"
using pmf_sum_one[of \<M> P\<^sub>\<M>] k_finite m_pmf unfolding \<P>\<^sub>\<M>_def m_set by auto

lemma k_prob: "k \<in> \<K> \<Longrightarrow> \<P>\<^sub>\<K> k = 1 / card \<K>"
unfolding \<P>\<^sub>\<K>_def k_unipmf pmf_of_set[OF k_nonemp k_finite] by auto

(* probability of cryptogram c if message m is chosen *)
definition \<P>\<^sub>\<M>\<^sub>\<C> :: "message \<Rightarrow> crypted \<Rightarrow> real" where
  "\<P>\<^sub>\<M>\<^sub>\<C> m c = (\<Sum>k | k \<in> \<K> \<and> encrypt m k = c. \<P>\<^sub>\<K> k)"

lemma set_singleton:
  assumes "\<forall>x \<in> S. (P x \<longrightarrow> x = y)"
      and "\<exists>x \<in> S.  P x"
    shows "{x \<in> S. P x} = {y}"
by (smt Collect_cong Set.ball_empty assms insert_compr)

lemma rec_in_k:
  assumes "m \<in> \<M>"
      and "length m = length c"
    shows "reconstruct_key c m \<in> \<K>"
proof -
  have "length m = len" using assms(1) k_length m_set by auto
  then have "length (reconstruct_key c m) = len" using reconstruct(1)[OF assms(2)] by auto
  then show ?thesis using k_in_k by auto
qed

lemma uniq_k:
  assumes "m \<in> \<M>"
      and "length m = length c"
    shows "{k \<in> \<K>. encrypt m k = c} = {reconstruct_key c m}"
proof (rule set_singleton)
  show "\<exists>k\<in>\<K>. encrypt m k = c"
  proof (rule bexI[of _ "reconstruct_key c m"])
    show "encrypt m (reconstruct_key c m) = c" using reconstruct(2)[OF assms(2)] .
    show "reconstruct_key c m \<in> \<K>" using rec_in_k[OF assms] by auto
  qed
  show "\<forall>k\<in>\<K>. encrypt m k = c \<longrightarrow> k = reconstruct_key c m"
  proof (rule ballI)
    fix k
    assume K: "k \<in> \<K>"
    then have "length k = len" using k_in_k by auto
    also have "length m = len" using assms(1) k_in_k unfolding m_set by auto
    finally have "length m = length k" .
    then show "encrypt m k = c \<longrightarrow> k = reconstruct_key c m" using rec_uniq by auto
  qed
qed

lemma pmc_card_k:
  assumes "m \<in> \<M>"
      and "length c = len"
    shows "\<P>\<^sub>\<M>\<^sub>\<C> m c = 1 / card \<K>"
proof -
  have L: "length m = length c" using k_in_k m_set assms by auto
  have K: "(reconstruct_key c m) \<in> \<K>" using rec_in_k[OF assms(1) L] .
  have "\<P>\<^sub>\<K> (reconstruct_key c m) = 1 / real (card \<K>)" using k_prob[OF K] .
  then show ?thesis unfolding \<P>\<^sub>\<M>\<^sub>\<C>_def unfolding uniq_k[OF assms(1) L] by simp
qed

(* probability of obtaining cryptogram c from any cause *)
definition \<P>\<^sub>\<C> :: "crypted \<Rightarrow> real" where
  "\<P>\<^sub>\<C> c = (\<Sum>m\<in>\<M>. \<P>\<^sub>\<M> m * \<P>\<^sub>\<M>\<^sub>\<C> m c)"

theorem
  assumes "m \<in> \<M>"
      and "length c = len"
    shows "\<P>\<^sub>\<M>\<^sub>\<C> m c = \<P>\<^sub>\<C> c"
proof -
  have "\<P>\<^sub>\<C> c = (\<Sum>m\<in>\<M>. \<P>\<^sub>\<M> m * \<P>\<^sub>\<M>\<^sub>\<C> m c)" unfolding \<P>\<^sub>\<C>_def by auto
  also have "... = (\<Sum>m\<in>\<M>. \<P>\<^sub>\<M> m * 1 / card \<K>)" using pmc_card_k[OF _ assms(2)] by auto
  also have "... = (\<Sum>m\<in>\<M>. \<P>\<^sub>\<M> m) / card \<K>" by (smt setsum.cong setsum_divide_distrib)
  also have "... = 1 / card \<K>" using m_sum_one by simp
  finally have "\<P>\<^sub>\<C> c = 1 / real (card \<K>)" by auto
  then show ?thesis using pmc_card_k[OF assms] by simp
qed

end


theory sort_HSortIsSort
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype 'a Heap = Node "'a Heap" "'a" "'a Heap" | Nil2

fun toHeap2 :: "int list => (int Heap) list" where
"toHeap2 (Nil2) = Nil2"
| "toHeap2 (Cons2 y z) = Cons2 (Node (Nil2) y (Nil2)) (toHeap2 z)"

fun insert2 :: "int => int list => int list" where
"insert2 x (Nil2) = Cons2 x (Nil2)"
| "insert2 x (Cons2 z xs) =
     (if x <= z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"

fun isort :: "int list => int list" where
"isort (Nil2) = Nil2"
| "isort (Cons2 y xs) = insert2 y (isort xs)"

fun hmerge :: "int Heap => int Heap => int Heap" where
"hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil2) = Node z x2 x3"
| "hmerge (Nil2) y = y"

fun hpairwise :: "(int Heap) list => (int Heap) list" where
"hpairwise (Nil2) = Nil2"
| "hpairwise (Cons2 p (Nil2)) = Cons2 p (Nil2)"
| "hpairwise (Cons2 p (Cons2 q qs)) =
     Cons2 (hmerge p q) (hpairwise qs)"

fun hmerging :: "(int Heap) list => int Heap" where
"hmerging (Nil2) = Nil2"
| "hmerging (Cons2 p (Nil2)) = p"
| "hmerging (Cons2 p (Cons2 z x2)) =
     hmerging (hpairwise (Cons2 p (Cons2 z x2)))"

fun toHeap :: "int list => int Heap" where
"toHeap x = hmerging (toHeap2 x)"

fun toList :: "int Heap => int list" where
"toList (Node p y q) = Cons2 y (toList (hmerge p q))"
| "toList (Nil2) = Nil2"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun hsort :: "int list => int list" where
"hsort x =
   dot
     (% (y :: int Heap) => toList y) (% (z :: int list) => toHeap z) x"

(*hipster toHeap2
          insert2
          isort
          hmerge
          hpairwise
          hmerging
          toHeap
          toList
          dot
          hsort *)

theorem x0 :
  "!! (x :: int list) . (hsort x) = (isort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory BinTree
imports Main
        "$HIPSTER_HOME/IsaHipster"

begin

datatype 'a binTree = Leaf 'a | Node 'a "('a binTree)" "('a binTree)"

fun is_leaf :: "'a binTree \<Rightarrow> bool" where
  "is_leaf (Leaf _)     = True"
| "is_leaf (Node _ _ _) = False"

fun mirror :: "'a binTree \<Rightarrow> 'a binTree" where
  "mirror (Leaf b)     = Leaf b"
| "mirror (Node b l r) = Node b (mirror r) (mirror l)"

fun tree_size :: "'a binTree \<Rightarrow> nat" where
  "tree_size (Leaf b)     = 1"
| "tree_size (Node _ l r) = 1 + tree_size l + tree_size r"

fun tree_height :: "'a binTree \<Rightarrow> nat" where
  "tree_height (Leaf _)     = 1"
| "tree_height (Node _ l r) = 1 + max (tree_height l) (tree_height r)"

fun flat_tree :: "'a binTree \<Rightarrow> 'a list" where
  "flat_tree (Leaf b)     = [b]"
| "flat_tree (Node b l r) = (flat_tree l) @  (b # (flat_tree r))"

(* http://www.labri.fr/perso/casteran/FM/Logique/C4.pdf *)
lemma tree_decompose : "tree_size t \<noteq> 1 \<Longrightarrow> \<exists> n l r . t = Node n l r"
by (metis tree_size.elims)  (* reminder: should fiddle with our metis wrapper/routine tacs *)
(* by hipster_induct_simp_metis *)

lemma le_height_size : "tree_height t \<le> tree_size t"
by hipster_induct_simp_metis
(* ----- *)

lemma lemma_a [thy_expl]: "mirror (mirror x2) = x2"
by hipster_induct_schemes

lemma mirrorRev : "rev (flat_tree t) = flat_tree (mirror t)"
by hipster_induct_simp_metis

fun notNil :: "'a list \<Rightarrow> bool" where
  "notNil [] = False"
| "notNil _  = True"

fun rigthmost :: "'a binTree \<Rightarrow> 'a" where
  "rigthmost (Leaf b)     = b"
| "rigthmost (Node b l r) = rigthmost r"

fun leftmost :: "'a binTree \<Rightarrow> 'a" where
  "leftmost (Leaf b)     = b"
| "leftmost (Node b l r) = leftmost l"

lemma lemma_aa [thy_expl]: "hd (xs2 @ xs2) = hd xs2"
by (hipster_induct_schemes BinTree.notNil.simps BinTree.flat_tree.simps)

lemma lemma_ab [thy_expl]: "notNil (xs2 @ xs2) = notNil xs2"
by (hipster_induct_schemes BinTree.notNil.simps BinTree.flat_tree.simps)

(* did not discover or do we remov Nil_is_append_conv? *)
lemma notNApp [thy_expl]: "notNil (xs @ ys) = notNil (ys @ xs)"
by (hipster_induct_simp_metis notNil.elims Nil_is_append_conv)

lemma flatInhabited [thy_expl]: "flat_tree t \<noteq> []"
by hipster_induct_simp_metis

lemma unproved : "hd (flat_tree x) = leftmost x"
by hipster_induct_simp_metis

lemma sizeLen : "tree_size t = length (flat_tree t)"
by hipster_induct_simp_metis

datatype nTree = Stop | Inner nat nTree nTree

fun insertT :: "nat \<Rightarrow> nTree \<Rightarrow> nTree" where
  "insertT n Stop          = Inner n Stop Stop"
| "insertT n (Inner m l r) = (if n < m then Inner m (insertT n l) r
                                       else Inner m l (insertT n r))"

fun nHeight :: "nTree \<Rightarrow> nat" where
  "nHeight Stop          = 0"
| "nHeight (Inner _ l r) = 1 + max (nHeight l) (nHeight r)"

fun flatten :: "nTree \<Rightarrow> nat list" where
  "flatten Stop = []"
| "flatten (Inner n l r) = flatten l @ n # flatten r"

datatype 'a graph = GNode 'a "(('a graph) list)" (* coinduct ... *)

thm graph.induct

  declare [[show_types]]
  declare [[show_sorts]]
  declare [[show_consts]]

fun ack :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "ack 0 n = n + 1"
| "ack m 0 = ack (m - 1) 1"
| "ack m n = ack (m - 1) (ack m (n - 1))"

fun ack2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "ack2 m n 0 = m + n"
| "ack2 m 0 (Suc 0) = 0"
| "ack2 m 0 (Suc (Suc 0)) = 1"
| "ack2 m 0 p = m"
| "ack2 m n p = ack2 m (ack2 m (n - 1) p) (p - 1)"

end


header {* First Example *}

theory %invisible First_Example
imports Main
begin

text {* \label{chap:exampleI} *}

text {* Pop-refinement is illustrated via a simple derivation,
in Isabelle/HOL,
of a program that includes non-functional aspects. *}

section {* Target Programming Language *}
text {* \label{sec:targetI} *}

text {* In the target language used in this example,
a program consists of
a list of distinct variables (the parameters of the program)
and an arithmetic expression (the body of the program).
The body is built out of
parameters,
non-negative integer constants,
addition operations,
and doubling (i.e.\ multiplication by 2) operations.
The program is executed
by supplying non-negative integers to the parameters
and evaluating the body to obtain a non-negative integer result. *}

text {* For instance, executing the program
\begin{verbatim}
  prog (a,b) {3 + 2 * (a + b)}
\end{verbatim}
with 5 and 7 supplied to \verb|a| and \verb|b| yields 27.
The syntax and semantics of this language are formalized as follows. *}

subsection {* Syntax *}
text {* \label{sec:syntaxI} *}

text {* Variables are identified by names. *}

type_synonym name = string

text {* Expressions are built out of
constants, variables, doubling operations, and addition operations. *}

datatype expr = Const nat | Var name | Double expr | Add expr expr

text {* A program consists of
a list of parameter variables and a body expression. *}

record prog =
 para :: "name list"
 body :: expr

subsection {* Static Semantics *}
text {* \label{sec:staticI} *}

text {* A context is a set of variables. *}

type_synonym ctxt = "name set"

text {* Given a context,
an expression is well-formed iff\
all its variables are in the context. *}

fun wfe :: "ctxt \<Rightarrow> expr \<Rightarrow> bool"
where
  "wfe \<Gamma> (Const c) \<longleftrightarrow> True" |
  "wfe \<Gamma> (Var v) \<longleftrightarrow> v \<in> \<Gamma>" |
  "wfe \<Gamma> (Double e) \<longleftrightarrow> wfe \<Gamma> e" |
  "wfe \<Gamma> (Add e\<^sub>1 e\<^sub>2) \<longleftrightarrow> wfe \<Gamma> e\<^sub>1 \<and> wfe \<Gamma> e\<^sub>2"

text {* The context of a program consists of the parameters. *}

definition ctxt :: "prog \<Rightarrow> ctxt"
where "ctxt p \<equiv> set (para p)"

text {* A program is well-formed iff\
the parameters are distinct
and the body is well-formed in the context of the program. *}

definition wfp :: "prog \<Rightarrow> bool"
where "wfp p \<equiv> distinct (para p) \<and> wfe (ctxt p) (body p)"

subsection {* Dynamic Semantics *}
text {* \label{sec:dynamicI} *}

text {* An environment associates values (non-negative integers)
to variables. *}

type_synonym env = "name \<rightharpoonup> nat"

text {* An environment matches a context iff\
environment and context have the same variables. *}

definition match :: "env \<Rightarrow> ctxt \<Rightarrow> bool"
where "match \<E> \<Gamma> \<equiv> dom \<E> = \<Gamma>"

text {* Evaluating an expression in an environment yields a value,
or an error (@{const None})
if the expression contains a variable not in the environment. *}

definition mul_opt :: "nat option \<Rightarrow> nat option \<Rightarrow> nat option" (infixl "\<otimes>" 70)
-- {* Lifting of multiplication to @{typ "nat option"}. *}
where "U\<^sub>1 \<otimes> U\<^sub>2 \<equiv>
  case (U\<^sub>1, U\<^sub>2) of (Some u\<^sub>1, Some u\<^sub>2) \<Rightarrow> Some (u\<^sub>1 * u\<^sub>2) | _ \<Rightarrow> None"

definition add_opt :: "nat option \<Rightarrow> nat option \<Rightarrow> nat option" (infixl "\<oplus>" 65)
-- {* Lifting of addition to @{typ "nat option"}. *}
where "U\<^sub>1 \<oplus> U\<^sub>2 \<equiv>
  case (U\<^sub>1, U\<^sub>2) of (Some u\<^sub>1, Some u\<^sub>2) \<Rightarrow> Some (u\<^sub>1 + u\<^sub>2) | _ \<Rightarrow> None"

fun eval :: "env \<Rightarrow> expr \<Rightarrow> nat option"
where
  "eval \<E> (Const c) = Some c" |
  "eval \<E> (Var v) = \<E> v" |
  "eval \<E> (Double e) = Some 2 \<otimes> eval \<E> e" |
  "eval \<E> (Add e\<^sub>1 e\<^sub>2) = eval \<E> e\<^sub>1 \<oplus> eval \<E> e\<^sub>2"

text {* Evaluating a well-formed expression never yields an error,
if the environment matches the context. *}

lemma eval_wfe:
  "wfe \<Gamma> e \<Longrightarrow> match \<E> \<Gamma> \<Longrightarrow> eval \<E> e \<noteq> None"
by (induct e, auto simp: match_def mul_opt_def add_opt_def)

text {* The environments of a program
are the ones that match the context of the program. *}

definition envs :: "prog \<Rightarrow> env set"
where "envs p \<equiv> {\<E>. match \<E> (ctxt p)}"

text {* Evaluating the body of a well-formed program
in an environment of the program
never yields an error. *}

lemma eval_wfp:
  "wfp p \<Longrightarrow> \<E> \<in> envs p \<Longrightarrow> eval \<E> (body p) \<noteq> None"
by (metis envs_def eval_wfe mem_Collect_eq wfp_def)

text {* Executing a program with values supplied to the parameters
yields a non-negative integer result,
or an error (@{const None})
if the parameters are not distinct,
the number of supplied values differs from the number of parameters,
or the evaluation of the body yields an error. *}

definition supply :: "prog \<Rightarrow> nat list \<Rightarrow> env option"
where "supply p us \<equiv>
  let vs = para p in
  if distinct vs \<and> length us = length vs
  then Some (map_of (zip vs us))
  else None"

definition exec :: "prog \<Rightarrow> nat list \<Rightarrow> nat option"
where "exec p us \<equiv>
  case supply p us of Some \<E> \<Rightarrow> eval \<E> (body p) | None \<Rightarrow> None"

text {* Executing a well-formed program
with the same number of values as the number of parameters
never yields an error. *}

lemma supply_wfp: "
  wfp p \<Longrightarrow>
  length us = length (para p) \<Longrightarrow>
  \<exists>\<E> \<in> envs p. supply p us = Some \<E>"
by (auto
 simp: wfp_def supply_def envs_def ctxt_def match_def split: option.split)

lemma exec_wfp:
  "wfp p \<Longrightarrow> length us = length (para p) \<Longrightarrow> exec p us \<noteq> None"
by (metis eval_wfp exec_def option.simps(5) supply_wfp)

subsection {* Performance *}
text {* \label{sec:nonfunc} *}

text {* As a non-functional semantic aspect,
the cost (e.g.\ time and power) to execute a program
is modeled as the number of doubling and addition operations. *}

fun coste :: "expr \<Rightarrow> nat"
where
  "coste (Const c) = 0" |
  "coste (Var v) = 0" |
  "coste (Double e) = 1 + coste e" |
  "coste (Add e\<^sub>1 e\<^sub>2) = 1 + coste e\<^sub>1 + coste e\<^sub>2"

definition costp :: "prog \<Rightarrow> nat"
where "costp p \<equiv> coste (body p)"

section {* Requirement Specification *}
text {* \label{sec:specificationI} *}

text {* The target program must:
\begin{enumerate}
\item
Be well-formed.
\item
Have exactly the two parameters @{term "''x''"} and @{term "''y''"},
in this order.
\item
Produce the result @{term "f x y"}
when @{term x} and @{term y}
are supplied to @{term "''x''"} and @{term "''y''"},
where @{term f} is defined below.
\item
Not exceed cost 3.
\end{enumerate} *}

definition f :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where "f x y \<equiv> 3 * x + 2 * y"

definition spec\<^sub>0 :: "prog \<Rightarrow> bool"
where "spec\<^sub>0 p \<equiv>
  wfp p \<and>
  para p = [''x'', ''y''] \<and>
  (\<forall>x y. exec p [x, y] = Some (f x y)) \<and>
  costp p \<le> 3"

text {* @{const f} is used by @{const spec\<^sub>0}
to express a functional requirement on the execution of the program.
@{const spec\<^sub>0} includes
the non-functional requirement @{term "costp(p) \<le> 3"}
and the syntactic interface requirement @{term "para(p) = [''x'', ''y'']"},
which are not expressed by @{const f} alone
and are expressible only in terms of programs.
@{const f} can be computed by a program
with cost higher than 3
and with more or different parameters;
it can also be computed by programs in different target languages. *}

section {* Stepwise Refinement *}
text {* \label{sec:refinementI} *}

text {* It is not difficult
to write a program that satisfies @{const spec\<^sub>0} and to prove that it does.
But with more complex target languages and requirement specifications,
writing a program and proving that it satisfies the requirements
is notoriously difficult.
Stepwise refinement decomposes the proof into manageable pieces,
constructing the implementation along the way.
The following sequence of refinement steps
may be overkill for obtaining an implementation of @{const spec\<^sub>0},
but illustrates concepts that should apply to more complex cases. *}

subsection {* Step 1 *}
text {* \label{sec:refI:stepI} *}

text {* The second conjunct in @{const spec\<^sub>0} determines the parameters,
leaving only the body to be determined.
That conjunct also reduces
the well-formedness of the program to the well-formedness of the body,
and the execution of the program to the evaluation of the body. *}

abbreviation \<Gamma>\<^sub>x\<^sub>y :: ctxt
where "\<Gamma>\<^sub>x\<^sub>y \<equiv> {''x'', ''y''}"

abbreviation \<E>\<^sub>x\<^sub>y :: "nat \<Rightarrow> nat \<Rightarrow> env"
where "\<E>\<^sub>x\<^sub>y x y \<equiv> [''x'' \<mapsto> x, ''y'' \<mapsto> y]"

lemma reduce_prog_to_body: "
  para p = [''x'', ''y''] \<Longrightarrow>
  wfp p = wfe \<Gamma>\<^sub>x\<^sub>y (body p) \<and>
  exec p [x, y] = eval (\<E>\<^sub>x\<^sub>y x y) (body p)"
by (auto simp: wfp_def ctxt_def exec_def supply_def fun_upd_twist)

text {* Using lemma @{text reduce_prog_to_body},
and using the definition of @{const costp}
to reduce the cost of the program to the cost of the body,
@{const spec\<^sub>0} is refined as follows. *}

definition spec\<^sub>1 :: "prog \<Rightarrow> bool"
where "spec\<^sub>1 p \<equiv>
  wfe \<Gamma>\<^sub>x\<^sub>y (body p) \<and>
  para p = [''x'', ''y''] \<and>
  (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) (body p) = Some (f x y)) \<and>
  coste (body p) \<le> 3"

lemma step_1_correct:
 "spec\<^sub>1 p \<Longrightarrow> spec\<^sub>0 p"
by (auto simp: spec\<^sub>1_def spec\<^sub>0_def reduce_prog_to_body costp_def)

text {* @{const spec\<^sub>1} and @{const spec\<^sub>0} are actually equivalent,
but the definition of @{const spec\<^sub>1} is ``closer'' to the implementation
than the definition of @{const spec\<^sub>0}:
the latter states constraints on the whole program,
while the former states simpler constraints on the body,
given that the parameters are already determined.
The proof of @{text step_1_correct}
can also be used to prove the equivalence of @{const spec\<^sub>1} and @{const spec\<^sub>0},
but in general proving inclusion is easier than proving equivalence.
Some of the following refinement steps yield non-equivalent predicates. *}

subsection {* Step 2 *}
text {* \label{sec:refI:stepII} *}

text {* The third conjunct in @{const spec\<^sub>1} says that
the body computes @{term "f x y"},
which depends on both @{term x} and @{term y},
and which yields an odd result for some values of @{term x} and @{term y}.
Thus the body cannot be a constant, a variable, or a double,
leaving a sum as the only option.
Adding @{term "\<exists>e\<^sub>1 e\<^sub>2. body p = Add e\<^sub>1 e\<^sub>2"} as a conjunct to @{const spec\<^sub>1}
and re-arranging the other conjuncts,
moving some of them under the existential quantification
so that they can be simplified in the next refinement step,
@{const spec\<^sub>1} is refined as follows. *}

definition spec\<^sub>2 :: "prog \<Rightarrow> bool"
where "spec\<^sub>2 p \<equiv>
  para p = [''x'', ''y''] \<and>
  (\<exists>e\<^sub>1 e\<^sub>2.
    body p = Add e\<^sub>1 e\<^sub>2 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y (body p) \<and>
    (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) (body p) = Some (f x y)) \<and>
    coste (body p) \<le> 3)"

lemma step_2_correct:
 "spec\<^sub>2 p \<Longrightarrow> spec\<^sub>1 p"
by (auto simp: spec\<^sub>2_def spec\<^sub>1_def)

text {* This refinement step is guided by an analysis
of the constraints in @{const spec\<^sub>1}. *}

subsection {* Step 3 *}
text {* \label{sec:refI:stepIII} *}

text {* The fact that the body is a sum
reduces the well-formedness, evaluation, and cost of the body
to the well-formedness, evaluation, and cost of the addends. *}

lemma reduce_body_to_addends: "
  body p = Add e\<^sub>1 e\<^sub>2 \<Longrightarrow>
  wfe \<Gamma>\<^sub>x\<^sub>y (body p) = (wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>1 \<and> wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>2) \<and>
  eval (\<E>\<^sub>x\<^sub>y x y) (body p) = eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>1 \<oplus> eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>2 \<and>
  coste (body p) = 1 + coste e\<^sub>1 + coste e\<^sub>2"
by auto

text {* Using @{text reduce_body_to_addends}
and arithmetic simplification,
@{const spec\<^sub>2} is refined as follows. *}

definition spec\<^sub>3 :: "prog \<Rightarrow> bool"
where "spec\<^sub>3 p \<equiv>
  para p = [''x'', ''y''] \<and>
  (\<exists>e\<^sub>1 e\<^sub>2.
    body p = Add e\<^sub>1 e\<^sub>2 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>1 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>2 \<and>
    (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>1 \<oplus> eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>2 = Some (f x y)) \<and>
    coste e\<^sub>1 + coste e\<^sub>2 \<le> 2)"

lemma step_3_correct:
  "spec\<^sub>3 p \<Longrightarrow> spec\<^sub>2 p"
by (auto simp: spec\<^sub>3_def spec\<^sub>2_def)
-- {* No need to use @{text reduce_body_to_addends} explicitly, *}
-- {* as the default rules that @{text auto} uses to prove it apply here too. *}

text {* This refinement step
defines the top-level structure of the body,
reducing the constraints on the body
to simpler constraints on its components. *}

subsection {* Step 4 *}
text {* \label{sec:refI:stepIV} *}

text {* The second-to-last conjunct in @{const spec\<^sub>3}
suggests to split @{term "f x y"} into two addends
to be computed by @{term e\<^sub>1} and @{term e\<^sub>2}. *}

text {* The addends @{term "(3::nat) * x"} and @{term "(2::nat) * y"}
suggested by the definition of @{const f}
would lead to a blind alley,
where the cost constraints could not be satisfied---%
the resulting @{term spec\<^sub>4} would be always false.
The refinement step would be ``correct'' (by strict inclusion)
but the refinement sequence could never reach an implementation.
It would be necessary to backtrack to @{const spec\<^sub>3}
and split @{term "f x y"} differently. *}

text {* To avoid the blind alley,
the definition of @{const f} is rephrased as follows. *}

lemma f_rephrased:
  "f x y = x + (2 * x + 2 * y)"
by (auto simp: f_def)

text {* This rephrased definition of @{const f}
does not use the multiplication by 3 of the original definition,
which is not (directly) supported by the target language;
it only uses operations supported by the language. *}

text {* Using @{text f_rephrased}, @{const spec\<^sub>3} is refined as follows. *}

definition spec\<^sub>4 :: "prog \<Rightarrow> bool"
where "spec\<^sub>4 p \<equiv>
  para p = [''x'', ''y''] \<and>
  (\<exists>e\<^sub>1 e\<^sub>2.
    body p = Add e\<^sub>1 e\<^sub>2 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>1 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>2 \<and>
    (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>1 = Some x) \<and>
    (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>2 = Some (2 * x + 2 * y)) \<and>
    coste e\<^sub>1 + coste e\<^sub>2 \<le> 2)"

lemma step_4_correct:
  "spec\<^sub>4 p \<Longrightarrow> spec\<^sub>3 p"
by (auto simp: spec\<^sub>4_def spec\<^sub>3_def add_opt_def f_rephrased)

text {* This refinement step reduces
the functional constraint on the body
to simpler functional constraints on the addends.
The functional constraint can be decomposed in different ways,
some of which are incompatible with the non-functional cost constraint:
blind alleys are avoided
by taking the non-functional constraint into account. *}

subsection {* Step 5 *}
text {* \label{sec:refI:stepV} *}

text {* The term @{term x}
in the third-to-last conjunct in @{const spec\<^sub>4}
is a shallow embedding of the program expression \verb|x|,
whose deep embedding is the term @{term "Var ''x''"}.
Using the latter as @{term e\<^sub>1},
the third-to-last conjunct in @{const spec\<^sub>4} is satisfied;
the expression is well-formed and has cost 0. *}

lemma first_addend: "
  e\<^sub>1 = Var ''x'' \<Longrightarrow>
  eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>1 = Some x \<and>
  wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>1 \<and>
  coste e\<^sub>1 = 0"
by auto

text {* Adding @{term "e\<^sub>1 = Var ''x''"} as a conjunct to @{const spec\<^sub>4}
and simplifying,
@{const spec\<^sub>4} is refined as follows. *}

definition spec\<^sub>5 :: "prog \<Rightarrow> bool"
where "spec\<^sub>5 p \<equiv>
  para p = [''x'', ''y''] \<and>
  (\<exists>e\<^sub>2.
    body p = Add (Var ''x'') e\<^sub>2 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>2 \<and>
    (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>2 = Some (2 * x + 2 * y)) \<and>
    coste e\<^sub>2 \<le> 2)"

lemma step_5_correct:
  "spec\<^sub>5 p \<Longrightarrow> spec\<^sub>4 p"
by (auto simp: spec\<^sub>5_def spec\<^sub>4_def)
-- {* No need to use @{text first_addend} explicitly, *}
-- {* as the default rules that @{text auto} uses to prove it apply here too. *}

text {* This refinement step determines the first addend of the body,
leaving only the second addend to be determined. *}

subsection {* Step 6 *}
text {* \label{sec:refI:stepVI} *}

text {* The term @{term "(2::nat) * x + 2 * y"}
in the second-to-last conjunct of @{const spec\<^sub>5}
is a shallow embedding of the program expression \verb|2 * x + 2 * y|,
whose deep embedding is the term
@{term "Add (Double (Var ''x'')) (Double (Var ''y''))"}.
Using the latter as @{term e\<^sub>2},
the second-to-last conjunct in @{const spec\<^sub>5} is satisfied,
but the last conjunct is not.
The following factorization of the shallowly embedded expression
leads to a reduced cost of the corresponding deeply embedded expression. *}

lemma factorization:
  "(2::nat) * x + 2 * y = 2 * (x + y)"
by auto

text {* The deeply embedded expression
@{term "Double (Add (Var ''x'') (Var ''y''))"},
which corresponds to the shallowly embedded expression
@{term "(2::nat) * (x + y)"},
satisfies the second-to-last conjunct of @{const spec\<^sub>5},
is well-formed,
and has cost 2. *}

lemma second_addend: "
  e\<^sub>2 = Double (Add (Var ''x'') (Var ''y'')) \<Longrightarrow>
  eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>2 = Some (2 * x + 2 * y) \<and>
  wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>2 \<and>
  coste e\<^sub>2 = 2"
by (auto simp: add_opt_def mul_opt_def)
-- {* No need to use @{text factorization} explicitly, *}
-- {* as the default rules that @{text auto} uses to prove it apply here too. *}

text {* Adding @{term "e\<^sub>2 = Double (Add (Var ''x'') (Var ''y''))"}
as a conjunct to @{const spec\<^sub>5}
and simplifying,
@{const spec\<^sub>5} is refined as follows. *}

definition spec\<^sub>6 :: "prog \<Rightarrow> bool"
where "spec\<^sub>6 p \<equiv>
  para p = [''x'', ''y''] \<and>
  body p = Add (Var ''x'') (Double (Add (Var ''x'') (Var ''y'')))"

lemma step_6_correct:
  "spec\<^sub>6 p \<Longrightarrow> spec\<^sub>5 p"
by (auto simp add: spec\<^sub>6_def spec\<^sub>5_def second_addend simp del: eval.simps)

text {* This refinement step determines the second addend of the body,
leaving nothing else to be determined. *}

text {* This and the previous refinement step
turn semantic constraints on the program components @{term e\<^sub>1} and @{term e\<^sub>2}
into syntactic definitions of such components. *}

subsection {* Step 7 *}
text {* \label{sec:refI:stepVII} *}

text {* @{const spec\<^sub>6}, which defines the parameters and body,
is refined to characterize a unique program in explicit syntactic form. *}

abbreviation p\<^sub>0 :: prog
where "p\<^sub>0 \<equiv>
  \<lparr>para = [''x'', ''y''],
   body = Add (Var ''x'') (Double (Add (Var ''x'') (Var ''y'')))\<rparr>"

definition spec\<^sub>7 :: "prog \<Rightarrow> bool"
where "spec\<^sub>7 p \<equiv> p = p\<^sub>0"

lemma step_7_correct:
  "spec\<^sub>7 p \<Longrightarrow> spec\<^sub>6 p"
by (auto simp: spec\<^sub>7_def spec\<^sub>6_def)

text {* The program satisfies @{const spec\<^sub>0} by construction.
The program witnesses the consistency of the requirements,
i.e.\ the fact that @{const spec\<^sub>0} is not always false. *}

lemma p\<^sub>0_sat_spec\<^sub>0:
  "spec\<^sub>0 p\<^sub>0"
by (metis
 step_1_correct
 step_2_correct
 step_3_correct
 step_4_correct
 step_5_correct
 step_6_correct
 step_7_correct
 spec\<^sub>7_def)

text {* From @{const p\<^sub>0}, the program text
\begin{verbatim}
  prog (x,y) {x + 2 * (x + y)}
\end{verbatim}
is easily obtained. *}

end %invisible


theory Algebra
  imports "$AFP/Kleene_Algebra/Kleene_Algebra" Fixpoint Omega_Algebra
begin

notation inf (infixl "\<sqinter>" 70)
notation sup (infixl "\<squnion>" 65)

class par_dioid = join_semilattice_zero + one +
  fixes par :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<parallel>" 69)
  assumes par_assoc [simp]: "x \<parallel> (y \<parallel> z) = (x \<parallel> y) \<parallel> z"
  and par_comm: "x \<parallel> y = y \<parallel> x"
  and par_distl [simp]: "x \<parallel> (y + z) = x \<parallel> y + x \<parallel> z"
  and par_unitl [simp]: "1 \<parallel> x = x"
  and par_annil [simp]: "0 \<parallel> x = 0"

begin

  lemma par_distr [simp]: "(x+y) \<parallel> z = x \<parallel> z + y \<parallel> z"
    by (metis par_comm par_distl)

  lemma par_isol [intro]: "x \<le> y \<Longrightarrow> x \<parallel> z \<le> y \<parallel> z"
    by (metis order_prop par_distr)

  lemma par_isor [intro]: "x \<le> y \<Longrightarrow> z \<parallel> x \<le> z \<parallel> y"
    by (metis par_comm par_isol)

  lemma par_unitr [simp]: "x \<parallel> 1 = x"
    by (metis par_comm par_unitl)

  lemma par_annir [simp]: "x \<parallel> 0 = 0"
    by (metis par_annil par_comm)

  lemma par_subdistl: "x \<parallel> z \<le> (x + y) \<parallel> z"
    by (metis order_prop par_distr)

  lemma par_subdistr: "z \<parallel> x \<le> z \<parallel> (x + y)"
    by (metis par_comm par_subdistl)

  lemma par_double_iso [intro!]: "w \<le> x \<Longrightarrow> y \<le> z \<Longrightarrow> w \<parallel> y \<le> x \<parallel> z"
    by (metis order_trans par_isol par_isor)

end

class weak_trioid = par_dioid + dioid_one_zerol

class trioid = par_dioid + left_kleene_algebra + residual_r_op +
  fixes meet :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "\<otimes>" 69)
  assumes meet_leq: "(x \<le> y) \<longleftrightarrow> (x = x \<otimes> y)"
  and meet_assoc: "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"
  and meet_sym: "x \<otimes> y = y \<otimes> x"
  and preimp_galois: "x \<cdot> y \<le> z \<longleftrightarrow> y \<le> x \<rightarrow> z"

begin

  lemma meet_idem [simp]: "x \<otimes> x = x"
    by (metis local.meet_leq local.order_refl)

  lemma meet_1 [simp]: "x \<otimes> y \<le> y"
    by (simp add: meet_leq meet_assoc)

  lemma meet_2 [simp]: "y \<otimes> x \<le> y"
    by (metis local.meet_sym meet_1)

  lemma preimp_isor: "x \<le> y \<Longrightarrow> p \<rightarrow> x \<le> p \<rightarrow> y"
    by (metis local.order.trans local.order_refl local.preimp_galois)

  lemma meet_is_meet: "x \<le> y \<otimes> z \<longleftrightarrow> (x \<le> y) \<and> (x \<le> z)"
    by (metis (poly_guards_query) local.meet_assoc local.meet_leq local.meet_sym meet_idem)

  lemma meet_interchange: "(x \<otimes> y) \<parallel> (z \<otimes> w) \<le> (x \<parallel> z) \<otimes> (y \<parallel> w)"
    by (auto simp add: meet_is_meet)

  lemma meet_iso: "x \<le> y \<Longrightarrow> z \<le> w \<Longrightarrow> x \<otimes> z \<le> y \<otimes> w"
    by (metis local.meet_leq meet_idem meet_is_meet)

  lemma absorb1: "x \<otimes> (x + y) = x"
    by (rule antisym) (simp add: meet_is_meet)+

  lemma absorb2: "x + (x \<otimes> y) = x"
    by (metis add_commute local.less_eq_def meet_2)

end

locale rg_algebra =
  fixes rg :: "'b::complete_lattice \<Rightarrow> 'a::trioid \<Rightarrow> 'a::trioid" (infixr "\<rhd>" 55)
  and guar :: "'b::complete_lattice \<Rightarrow> 'a::trioid"
  assumes rely_mult: "(r \<rhd> x) \<cdot> (r \<rhd> y) \<le> r \<rhd> (x \<cdot> y)"
  and rely_star: "(r \<rhd> x)\<^sup>\<star> \<le> r \<rhd> (x\<^sup>\<star>)"
  and rely_iso: "x \<le> y \<Longrightarrow> r \<rhd> x \<le> r \<rhd> y"
  and rely_coext: "x \<le> r \<rhd> x"
  and rely_idem: "r \<rhd> r \<rhd> x = r \<rhd> x"
  and rely_anti: "r \<le> g \<Longrightarrow> g \<rhd> x \<le> r \<rhd> x"
  and guar_par: "guar r \<parallel> guar g \<le> guar (r \<squnion> g)"
  and guar_mult: "guar r \<cdot> guar g \<le> guar (r \<squnion> g)"
  and guar_star: "(guar g)\<^sup>\<star> = guar g"
  and guar_meet: "(x \<otimes> guar g) \<cdot> (y \<otimes> guar g) = x\<cdot>y \<otimes> guar g"
  and rely_guarantee: "(r \<squnion> g\<^sub>2 \<rhd> x \<otimes> guar g\<^sub>1) \<parallel> (r \<squnion> g\<^sub>1 \<rhd> y \<otimes> guar g\<^sub>2) \<le> r \<rhd> (x \<otimes> guar g\<^sub>1) \<parallel> (y \<otimes> guar g\<^sub>2)"
  and guar_iso: "r \<le> s \<Longrightarrow> guar r \<le> guar s"

begin

definition quintuple :: "'b \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_, _ \<turnstile> \<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>" [20,20,20,20,20] 1000) where
    "r, g \<turnstile> \<lbrace>p\<rbrace> x \<lbrace>q\<rbrace> \<equiv> (x \<le> p \<rightarrow> (r \<rhd> q \<otimes> guar g))"

lemma parallel_rule:
  assumes test_interchange: "\<And>x y. (p\<^sub>1 \<rightarrow> x) \<parallel> (p\<^sub>2 \<rightarrow> y) \<le> (p\<^sub>1 \<otimes> p\<^sub>2) \<rightarrow> (x \<parallel> y)"
  and test_post: "(q\<^sub>1 \<parallel> q\<^sub>2) \<otimes> guar g \<le> r \<rhd> q\<^sub>1 \<otimes> q\<^sub>2 \<otimes> guar g"
  and "r \<squnion> g\<^sub>1 \<le> r\<^sub>2" and "r \<squnion> g\<^sub>2 \<le> r\<^sub>1"
  and "g\<^sub>1 \<squnion> g\<^sub>2 \<le> g"
  and left_prog: "r\<^sub>1, g\<^sub>1 \<turnstile> \<lbrace>p\<^sub>1\<rbrace> x \<lbrace>q\<^sub>1\<rbrace>"
  and right_prog: "r\<^sub>2, g\<^sub>2 \<turnstile> \<lbrace>p\<^sub>2\<rbrace> y \<lbrace>q\<^sub>2\<rbrace>"
  shows "r, g \<turnstile> \<lbrace>p\<^sub>1 \<otimes> p\<^sub>2\<rbrace> x \<parallel> y \<lbrace>q\<^sub>1 \<otimes> q\<^sub>2\<rbrace>"
proof -
  have "x \<parallel> y \<le> (p\<^sub>1 \<rightarrow> (r\<^sub>1 \<rhd> q\<^sub>1 \<otimes> guar g\<^sub>1)) \<parallel> (p\<^sub>2 \<rightarrow> (r\<^sub>2 \<rhd> q\<^sub>2 \<otimes> guar g\<^sub>2))"
    by (metis left_prog par_double_iso quintuple_def right_prog)
  also have "... \<le> p\<^sub>1 \<otimes> p\<^sub>2 \<rightarrow> (r\<^sub>1 \<rhd> q\<^sub>1 \<otimes> guar g\<^sub>1) \<parallel> (r\<^sub>2 \<rhd> q\<^sub>2 \<otimes> guar g\<^sub>2)"
    by (rule test_interchange)
  also have "... \<le> p\<^sub>1 \<otimes> p\<^sub>2 \<rightarrow> (r \<squnion> g\<^sub>2 \<rhd> q\<^sub>1 \<otimes> guar g\<^sub>1) \<parallel> (r \<squnion> g\<^sub>1 \<rhd> q\<^sub>2 \<otimes> guar g\<^sub>2)"
    by (metis assms(3) assms(4) par_double_iso preimp_isor rely_anti)
  also have "... \<le> p\<^sub>1 \<otimes> p\<^sub>2 \<rightarrow> (r \<rhd> (q\<^sub>1 \<otimes> guar g\<^sub>1) \<parallel> (q\<^sub>2 \<otimes> guar g\<^sub>2))"
    by (metis preimp_isor rely_guarantee)
  also have "... \<le> p\<^sub>1 \<otimes> p\<^sub>2 \<rightarrow> (r \<rhd> (q\<^sub>1 \<parallel> q\<^sub>2) \<otimes> (guar g\<^sub>1 \<parallel> guar g\<^sub>2))"
    by (intro preimp_isor rely_iso meet_interchange)
  also have "... \<le> p\<^sub>1 \<otimes> p\<^sub>2 \<rightarrow> (r \<rhd> (q\<^sub>1 \<parallel> q\<^sub>2) \<otimes> guar g)"
    by (metis (poly_guards_query) assms(5) guar_iso guar_par meet_2 meet_is_meet meet_sym order_trans preimp_isor rely_iso)
  also have "... \<le> p\<^sub>1 \<otimes> p\<^sub>2 \<rightarrow> (r \<rhd> (q\<^sub>1 \<otimes> q\<^sub>2) \<otimes> guar g)"
    by (metis preimp_isor rely_idem rely_iso test_post)
  finally have "x \<parallel> y \<le> p\<^sub>1 \<otimes> p\<^sub>2 \<rightarrow> (r \<rhd> (q\<^sub>1 \<otimes> q\<^sub>2) \<otimes> guar g)" .
  thus ?thesis
    by (simp only: quintuple_def[symmetric])
qed

end

end