section "QE Algorithm Proofs"
subsection "DNF"
theory DNF
  imports VSAlgos
begin

theorem dnf_eval :
  "(\<exists>(al,fl)\<in>set (dnf \<phi>).
     (\<forall>a\<in>set al. aEval a xs)
   \<and> (\<forall>f\<in>set fl. eval f xs))
   = eval \<phi> xs"
proof(induction \<phi>)
  case (And \<phi>1 \<phi>2)
  define f where "f = (\<lambda>a. case a of
        (al, fl) \<Rightarrow> (\<forall>a\<in>set al. aEval a xs) \<and> (\<forall>f\<in>set fl. eval f xs))"
  have h1:"(\<exists>a\<in>set (dnf (And \<phi>1 \<phi>2)). f a) = (\<exists>a\<in>set (dnf \<phi>1). \<exists>a'\<in>set(dnf \<phi>2). f a \<and> f a')"
    apply simp unfolding f_def apply auto
      apply blast
     apply blast
    subgoal for a b c d
      apply(rule bexI[where x="(a,b)"])
       apply(rule exI[where x="a@c"])
       apply(rule exI[where x="b@d"])
      by auto
    done
  also have h2 : "... = ((\<exists>a\<in>set (dnf \<phi>1). f a)\<and>(\<exists>a\<in>set(dnf \<phi>2). f a))"
    by auto
  show ?case unfolding f_def[symmetric] unfolding h1 h2 unfolding f_def using And by auto
qed auto

theorem dnf_modified_eval :
  "(\<exists>(al,fl,n)\<in>set (dnf_modified \<phi>).
      (\<exists>L. (length L = n
       \<and> (\<forall>a\<in>set al. aEval a (L@xs))
       \<and> (\<forall>f\<in>set fl. eval f (L@xs))))) = eval \<phi> xs"
proof(induction \<phi> arbitrary:xs)
  case (Atom x)
  then show ?case
    by (cases x, auto)
next
  case (And \<phi>1 \<phi>2)
  {fix d1 d2 A A' B B' L1 L2
    assume A : "(A,A',length (L1::real list))\<in>set (dnf_modified \<phi>1)" and "(B,B',length (L2::real list))\<in>set (dnf_modified \<phi>2)"
    have "(
      (\<forall>a\<in>set ((map (liftAtom (length L1) (length L2)) A @ map (liftAtom 0 (length L1)) B)). aEval a ((L1@L2) @ xs))
    \<and> (\<forall>f\<in>set ( map (liftFm (length L1) (length L2)) A' @ map (liftFm 0 (length L1)) B'). eval f ((L1@L2) @ xs))) =
      (
      (\<forall>a\<in>set(map (liftAtom (length L1) (length L2)) A) \<union> set( map (liftAtom 0 (length L1)) B). aEval a ((L1@L2) @ xs))
    \<and> (\<forall>f\<in>set( map (liftFm (length L1) (length L2)) A') \<union> set(map (liftFm 0 (length L1)) B'). eval f ((L1@L2) @ xs)))"
      by auto
    also have "... = (
      (\<forall>a\<in>set(map (liftAtom (length L1) (length L2)) A).aEval a ((L1@L2) @ xs))
    \<and> (\<forall>a\<in>set(map (liftAtom 0 (length L1)) B). aEval a ((L1@L2) @ xs))
    \<and> (\<forall>f\<in>set(map (liftFm (length L1) (length L2)) A').eval f ((L1@L2) @ xs))
    \<and> (\<forall>f\<in>set(map (liftFm 0 (length L1)) B'). eval f ((L1@L2) @ xs)))"
      by blast
    also have "... =  (
      (\<forall>a\<in>set A. aEval (liftAtom (length L1) (length L2) a) ((L1@L2) @ xs))
    \<and> (\<forall>a\<in>set B. aEval (liftAtom 0 (length L1) a) ((L1@L2) @ xs))
    \<and> (\<forall>f\<in>set A'. eval (liftFm (length L1) (length L2) f) ((L1@L2) @ xs))
    \<and> (\<forall>f\<in>set B'. eval (liftFm 0 (length L1) f) ((L1@L2) @ xs)))"
      by simp
    also have "... =  (
      (\<forall>a\<in>set A. aEval (liftAtom (length L1) (length L2) a) (insert_into (L1 @ xs) (length L1) L2))
    \<and> (\<forall>a\<in>set B. aEval (liftAtom 0 (length L1) a) (insert_into (L2 @ xs) 0 L1))
    \<and> (\<forall>f\<in>set A'. eval (liftFm (length L1) (length L2) f) (insert_into (L1 @ xs) (length L1) L2))
    \<and> (\<forall>f\<in>set B'. eval (liftFm 0 (length L1) f) (insert_into (L2 @ xs) 0 L1)))"
      by auto
    also have "... = (
          ((\<forall>a\<in>set A. aEval a (L1 @ xs)) \<and> (\<forall>f\<in>set A'. eval f (L1 @ xs))) \<and>
          ((\<forall>a\<in>set B. aEval a (L2 @ xs)) \<and> (\<forall>f\<in>set B'. eval f (L2 @ xs))) )"
    proof safe
      fix a
      show "\<forall>a\<in>set A. aEval (liftAtom (length L1) (length L2) a) (insert_into (L1 @ xs) (length L1) L2) \<Longrightarrow>
           a \<in> set A \<Longrightarrow> aEval a (L1 @ xs)"
        using eval_liftFm[of L2 "length L2" "length L1" "L1 @ xs" "Atom a", OF refl]
        by auto
    next
      fix f
      show "\<forall>f\<in>set A'. eval (liftFm (length L1) (length L2) f) (insert_into (L1 @ xs) (length L1) L2) \<Longrightarrow>
          f \<in> set A' \<Longrightarrow> eval f (L1 @ xs)"
        using eval_liftFm[of L2 "length L2" "length L1" "L1 @ xs" f, OF refl] by auto
    next
      fix a
      show " \<forall>a\<in>set B. aEval (liftAtom 0 (length L1) a) (insert_into (L2 @ xs) 0 L1) \<Longrightarrow>
            a \<in> set B \<Longrightarrow> aEval a (L2 @ xs)"
        using eval_liftFm[of L1 "length L1" "0" "L2@xs" "Atom a", OF refl] by auto
    next
      fix f
      show " \<forall>f\<in>set B'. eval (liftFm 0 (length L1) f) (insert_into (L2 @ xs) 0 L1) \<Longrightarrow> f \<in> set B' \<Longrightarrow> eval f (L2 @ xs)"
        using eval_liftFm[of L1 "length L1" "0" "L2 @ xs" f, OF refl] by auto
    next
      fix a
      show " \<forall>a\<in>set A. aEval a (L1 @ xs) \<Longrightarrow>
         a \<in> set A \<Longrightarrow> aEval (liftAtom (length L1) (length L2) a) (insert_into (L1 @ xs) (length L1) L2)"
        using eval_liftFm[of L2 "length L2" "length L1" "L1 @ xs" "Atom a", OF refl] by auto
    next
      fix a
      show "\<forall>a\<in>set B. aEval a (L2 @ xs) \<Longrightarrow> a \<in> set B \<Longrightarrow> aEval (liftAtom 0 (length L1) a) (insert_into (L2 @ xs) 0 L1)"
        using eval_liftFm[of L1 "length L1" "0" "L2@xs" "Atom a", OF refl] by auto
    next
      fix f
      show "\<forall>f\<in>set A'. eval f (L1 @ xs) \<Longrightarrow>
         f \<in> set A' \<Longrightarrow> eval (liftFm (length L1) (length L2) f) (insert_into (L1 @ xs) (length L1) L2)"
        using eval_liftFm[of L2 "length L2" "length L1" "L1 @ xs" f, OF refl] by auto
    next
      fix f
      show "\<forall>f\<in>set B'. eval f (L2 @ xs) \<Longrightarrow> f \<in> set B' \<Longrightarrow> eval (liftFm 0 (length L1) f) (insert_into (L2 @ xs) 0 L1)"
        using eval_liftFm[of L1 "length L1" "0" "L2 @ xs" f, OF refl] by auto
    qed
    finally have "(
      (\<forall>a\<in>set ((map (liftAtom (length L1) (length L2)) A @ map (liftAtom 0 (length L1)) B)). aEval a ((L1@L2) @ xs))
    \<and> (\<forall>f\<in>set ( map (liftFm (length L1) (length L2)) A' @ map (liftFm 0 (length L1)) B'). eval f ((L1@L2) @ xs))) = (
          ((\<forall>a\<in>set A. aEval a (L1 @ xs)) \<and> (\<forall>f\<in>set A'. eval f (L1 @ xs))) \<and>
          ((\<forall>a\<in>set B. aEval a (L2 @ xs)) \<and> (\<forall>f\<in>set B'. eval f (L2 @ xs))) )"
      by simp
  }
  then have h : "(\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1). \<exists>(B,B',d2)\<in>set (dnf_modified \<phi>2).
      (\<exists>L1.\<exists>L2. length L1 = d1 \<and> length L2 = d2 \<and>
      (\<forall>a\<in>set ((map (liftAtom d1 d2) A @ map (liftAtom 0 d1) B)). aEval a ((L1@L2) @ xs))
    \<and> (\<forall>f\<in>set ( map (liftFm d1 d2) A' @ map (liftFm 0 d1) B'). eval f ((L1@L2) @ xs)))) = ((\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1). \<exists>(B,B',d2)\<in>set(dnf_modified \<phi>2).
          (\<exists>L1. length L1 = d1 \<and> (\<forall>a\<in>set A. aEval a (L1 @ xs)) \<and> (\<forall>f\<in>set A'. eval f (L1 @ xs))) \<and>
          (\<exists>L2. length L2 = d2 \<and> (\<forall>a\<in>set B. aEval a (L2 @ xs)) \<and> (\<forall>f\<in>set B'. eval f (L2 @ xs))) ))"
  proof safe
    fix A A' B B'  L1 L2
    assume prev : "(\<And>A A' L1 B B' L2.
           (A, A', length L1) \<in> set (dnf_modified \<phi>1) \<Longrightarrow>
           (B, B', length L2) \<in> set (dnf_modified \<phi>2) \<Longrightarrow>
           ((\<forall>a\<in>set (map (liftAtom (length L1) (length L2)) A @ map (liftAtom 0 (length L1)) B).
                aEval a ((L1 @ L2) @ xs)) \<and>
            (\<forall>f\<in>set (map (liftFm (length L1) (length L2)) A' @ map (liftFm 0 (length L1)) B').
                eval f ((L1 @ L2) @ xs))) =
           (((\<forall>a\<in>set A. aEval a (L1 @ xs)) \<and> (\<forall>f\<in>set A'. eval f (L1 @ xs))) \<and>
            (\<forall>a\<in>set B. aEval a (L2 @ xs)) \<and> (\<forall>f\<in>set B'. eval f (L2 @ xs))))"
      and A: "(A,A',length L1)\<in>set (dnf_modified \<phi>1)" and B: "(B,B',length L2)\<in>set (dnf_modified \<phi>2)"
      and h1 : "\<forall>a\<in>set (map (liftAtom (length L1) (length L2)) A @ map (liftAtom 0 (length L1)) B).
          aEval a ((L1 @ L2) @ xs)"
      and h2 : "\<forall>f\<in>set (map (liftFm (length L1) (length L2)) A' @ map (liftFm 0 (length L1)) B').
          eval f ((L1 @ L2) @ xs)"
    have h : "((\<forall>a\<in>set (map (liftAtom (length L1) (length L2)) A @ map (liftAtom 0 (length L1)) B).
         aEval a ((L1 @ L2) @ xs)) \<and>
     (\<forall>f\<in>set (map (liftFm (length L1) (length L2)) A' @ map (liftFm 0 (length L1)) B').
         eval f ((L1 @ L2) @ xs))) =
    (((\<forall>a\<in>set A. aEval a (L1 @ xs)) \<and> (\<forall>f\<in>set A'. eval f (L1 @ xs))) \<and>
     (\<forall>a\<in>set B. aEval a (L2 @ xs)) \<and> (\<forall>f\<in>set B'. eval f (L2 @ xs)))"
      using prev[where A="A", where A'="A'", where B="B", where B'="B'"] A B by simp
    show "\<exists>(A, A', d1)\<in>set (dnf_modified \<phi>1).
          \<exists>(B, B', d2)\<in>set (dnf_modified \<phi>2).
             (\<exists>L1. length L1 = d1 \<and> (\<forall>a\<in>set A. aEval a (L1 @ xs)) \<and> (\<forall>f\<in>set A'. eval f (L1 @ xs))) \<and>
             (\<exists>L2. length L2 = d2 \<and> (\<forall>a\<in>set B. aEval a (L2 @ xs)) \<and> (\<forall>f\<in>set B'. eval f (L2 @ xs)))"
      apply (rule bexI[where x="(A, A', length L1)", OF _ A])
      apply auto defer
      apply (rule bexI[where x="(B, B', length L2)", OF _ B])
      apply auto
      using h h1 h2
      by auto
  next
    fix A A' d1 B B' d2 L1 L2
    assume prev : "(\<And>A A' L1 B B' L2.
           (A, A', length L1) \<in> set (dnf_modified \<phi>1) \<Longrightarrow>
           (B, B', length L2) \<in> set (dnf_modified \<phi>2) \<Longrightarrow>
           ((\<forall>a\<in>set (map (liftAtom (length L1) (length L2)) A @ map (liftAtom 0 (length L1)) B).
                aEval a ((L1 @ L2) @ xs)) \<and>
            (\<forall>f\<in>set (map (liftFm (length L1) (length L2)) A' @ map (liftFm 0 (length L1)) B').
                eval f ((L1 @ L2) @ xs))) =
           (((\<forall>a\<in>set A. aEval a (L1 @ xs)) \<and> (\<forall>f\<in>set A'. eval f (L1 @ xs))) \<and>
            (\<forall>a\<in>set B. aEval a (L2 @ xs)) \<and> (\<forall>f\<in>set B'. eval f (L2 @ xs))))"
      and A: "(A,A',length L1)\<in>set (dnf_modified \<phi>1)" and B: "(B,B',length L2)\<in>set (dnf_modified \<phi>2)"
      and h1 : "\<forall>a\<in>set A. aEval a (L1 @ xs)" "\<forall>f\<in>set A'. eval f (L1 @ xs)"
      "\<forall>a\<in>set B. aEval a (L2 @ xs)" "\<forall>f\<in>set B'. eval f (L2 @ xs)"
    have h : "((\<forall>a\<in>set (map (liftAtom (length L1) (length L2)) A @ map (liftAtom 0 (length L1)) B).
         aEval a ((L1 @ L2) @ xs)) \<and>
     (\<forall>f\<in>set (map (liftFm (length L1) (length L2)) A' @ map (liftFm 0 (length L1)) B').
         eval f ((L1 @ L2) @ xs))) =
    (((\<forall>a\<in>set A. aEval a (L1 @ xs)) \<and> (\<forall>f\<in>set A'. eval f (L1 @ xs))) \<and>
     (\<forall>a\<in>set B. aEval a (L2 @ xs)) \<and> (\<forall>f\<in>set B'. eval f (L2 @ xs)))"
      using prev[where A="A", where A'="A'", where B="B", where B'="B'"] h1 A B by simp
    show "\<exists>(A, A', d1)\<in>set (dnf_modified \<phi>1).
          \<exists>(B, B', d2)\<in>set (dnf_modified \<phi>2).
             \<exists>L1 L2.
                length L1 = d1 \<and>
                length L2 = d2 \<and>
                (\<forall>a\<in>set (map (liftAtom d1 d2) A @ map (liftAtom 0 d1) B). aEval a ((L1 @ L2) @ xs)) \<and>
                (\<forall>f\<in>set (map (liftFm d1 d2) A' @ map (liftFm 0 d1) B'). eval f ((L1 @ L2) @ xs))"
      apply (rule bexI[where x="(A, A', length L1)", OF _ A])
      apply auto defer
      apply (rule bexI[where x="(B, B', length L2)", OF _ B])
      apply auto
      apply (rule exI[where x="L1"])
      apply auto
      apply (rule exI[where x="L2"])
      apply auto
      using h h1 by auto
  qed

  define f where "f (x:: (atom list * atom fm list * nat)) = (case x of (al,fl,n) \<Rightarrow> (\<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs))))" for x
  define g where "((g (uuaa::atom list) (uua::atom fm list) (uu::nat) x):: (atom list * atom fm list * nat)) = (
 case x of
                       (B, B', d2) \<Rightarrow>
                         (map (liftAtom uu d2) uuaa @ map (liftAtom 0 uu) B,
                          map (\<lambda>x. map_fm_binders (\<lambda>a x. liftAtom (uu + x) d2 a) x 0) uua @
                          map (\<lambda>x. map_fm_binders (\<lambda>a x. liftAtom (0 + x) uu a) x 0) B',
                          uu + d2))" for uuaa uua uu x

  define f' where "f' L A A' d1 B B' d2 = ((\<forall>a\<in>set ((map (liftAtom d1 d2) A @ map (liftAtom 0 d1) B)). aEval a (L @ xs))
    \<and> (\<forall>f\<in>set ( map (liftFm d1 d2) A' @ map (liftFm 0 d1) B'). eval f (L @ xs)))" for L A A' d1 B B' d2
  have "(\<exists>(al, fl, n)\<in>set (dnf_modified (And \<phi>1 \<phi>2)).
               \<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs)))
        = (\<exists>y\<in>set (dnf_modified (And \<phi>1 \<phi>2)). f y)"
    unfolding f_def by simp
  also have "... = (\<exists>y\<in>set (dnf_modified \<phi>1).
        \<exists>a aa b.
           (\<exists>uu uua uuaa.
               (uuaa, uua, uu) = y \<and>
               (a, aa, b)
               \<in> (g uuaa uua uu) `
                  set (dnf_modified \<phi>2)) \<and>
           f (a, aa, b))"
    using g_def by simp
  also have "... = (\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1).
        \<exists>x\<in>set (dnf_modified \<phi>2).
           f (g A A' d1 x))"
    by (smt case_prodE f_def imageE image_eqI prod.simps(2))
  also have "... = (\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1).
        \<exists>x\<in>set (dnf_modified \<phi>2).
           f (case x of (B,B',d2) \<Rightarrow> (map (liftAtom d1 d2) A @ map (liftAtom 0 d1) B,
                          map (\<lambda>x. liftFm d1 d2 x) A' @
                          map (\<lambda>x. liftFm 0 d1 x) B',
                          d1 + d2)))"
    using g_def by simp
  also have "... = (\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1). \<exists>x\<in>set (dnf_modified \<phi>2).
      (case (case x of (B,B',d2) \<Rightarrow> (map (liftAtom d1 d2) A @ map (liftAtom 0 d1) B,
                          map (\<lambda>x. liftFm d1 d2 x) A' @ map (\<lambda>x. liftFm 0 d1 x) B',
                          d1 + d2)) of (al,fl,n) \<Rightarrow> (\<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs))))
)"
    using f_def by simp
  also have "... = (\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1). \<exists>(B,B',d2)\<in>set (dnf_modified \<phi>2).
      (case ((map (liftAtom d1 d2) A @ map (liftAtom 0 d1) B,
                          map (\<lambda>x. liftFm d1 d2 x) A' @ map (\<lambda>x. liftFm 0 d1 x) B',
                          d1 + d2)) of (al,fl,n) \<Rightarrow> (\<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs))))
)"
    by(smt case_prodE case_prodE2 old.prod.case)
  also have "... = (\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1). \<exists>(B,B',d2)\<in>set (dnf_modified \<phi>2).
      (\<exists>L. length L = d1 + d2 \<and>
      (\<forall>a\<in>set ((map (liftAtom d1 d2) A @ map (liftAtom 0 d1) B)). aEval a (L @ xs))
    \<and> (\<forall>f\<in>set ( map (liftFm d1 d2) A' @ map (liftFm 0 d1) B'). eval f (L @ xs))))"
    by(smt case_prodE case_prodE2 old.prod.case)
  also have "... = (\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1). \<exists>(B,B',d2)\<in>set (dnf_modified \<phi>2).
      (\<exists>L. length L = d1 + d2 \<and> (f' L A A' d1 B B' d2)))"
    using f'_def by simp
  also have "... = (\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1). \<exists>(B,B',d2)\<in>set (dnf_modified \<phi>2).
      (\<exists>L1.\<exists>L2. length L1 = d1 \<and> length L2 = d2 \<and> (f' (L1@L2) A A' d1 B B' d2)))"
  proof safe
    fix A A' d1 B B' d2 L
    assume A: "(A,A',d1)\<in>set (dnf_modified \<phi>1)" and B: "(B,B',d2)\<in>set (dnf_modified \<phi>2)"
      and L: "length L = d1 + d2" "(f' L A A' d1 B B' d2)"
    show "\<exists>(A, A', d1)\<in>set (dnf_modified \<phi>1).
          \<exists>(B, B', d2)\<in>set (dnf_modified \<phi>2). \<exists>L1 L2. length L1 = d1 \<and> length L2 = d2 \<and> f' (L1 @ L2) A A' d1 B B' d2"
      apply (rule bexI[where x="(A, A', d1)", OF _ A])
      apply auto
      apply (rule bexI[where x="(B, B', d2)", OF _ B])
      apply auto
      apply (rule exI[where x="take d1 L"])
      apply auto   defer
      apply (rule exI[where x="drop d1 L"])
      using L
      by auto
  next
    fix A A' d1 B B' d2 L1 L2
    assume A: "(A,A', length L1)\<in>set (dnf_modified \<phi>1)" and B: "(B,B',length L2)\<in>set (dnf_modified \<phi>2)"
      and L: "(f' (L1 @ L2) A A' (length L1) B B' (length L2))"
    thm exI
    thm bexI
    show "\<exists>(A, A', d1)\<in>set (dnf_modified \<phi>1). \<exists>(B, B', d2)\<in>set (dnf_modified \<phi>2). \<exists>L. length L = d1 + d2 \<and> f' L A A' d1 B B' d2 "
      apply (rule bexI[where x="(A, A', length L1)", OF _ A])
      apply auto
      apply (rule bexI[where x="(B, B', length L2)", OF _ B])
      apply auto
      apply (rule exI[where x="L1 @ L2"])
      using L
      by auto
  qed

  also have "... = (\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1). \<exists>(B,B',d2)\<in>set (dnf_modified \<phi>2).
      (\<exists>L1.\<exists>L2. length L1 = d1 \<and> length L2 = d2 \<and>
      (\<forall>a\<in>set ((map (liftAtom d1 d2) A @ map (liftAtom 0 d1) B)). aEval a ((L1@L2) @ xs))
    \<and> (\<forall>f\<in>set ( map (liftFm d1 d2) A' @ map (liftFm 0 d1) B'). eval f ((L1@L2) @ xs))))"
    unfolding f'_def by simp
      (*also have "... = (\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1). \<exists>(B,B',d2)\<in>set (dnf_modified \<phi>2).
      (\<exists>L1.\<exists>L2. length L1 = d1 \<and> length L2 = d2 \<and>
      (\<forall>a\<in>set (map (liftAtom d1 d2) A) \<union> set ( map (liftAtom 0 d1) B). aEval a ((L1@L2) @ xs))
    \<and> (\<forall>f\<in>set ( map (liftFm d1 d2) A' @ map (liftFm 0 d1) B'). eval f ((L1@L2) @ xs))))"
    proof -
      have *: "(\<forall>a\<in>set (map (liftAtom d1 d2) A @ map (liftAtom 0 d1) B). aEval a ((L1 @ L2) @ xs))
        = (\<forall>a\<in>set (map (liftAtom d1 d2) A) \<union> set ( map (liftAtom 0 d1) B). aEval a ((L1@L2) @ xs))"
        for d1 d2 A B L1 L2 by auto
      then show ?thesis apply (subst * ) ..
    qed (*
      apply (rule bex_cong[OF refl])
      unfolding split_beta
      apply (rule bex_cong[OF refl])
      apply (rule ex_cong1)+
      apply (rule conj_cong refl)+
      by auto *)
    *)
  also have "... = ((\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1). \<exists>(B,B',d2)\<in>set(dnf_modified \<phi>2).
          (\<exists>L. length L = d1 \<and> (\<forall>a\<in>set A. aEval a (L @ xs)) \<and> (\<forall>f\<in>set A'. eval f (L @ xs))) \<and>
          (\<exists>L. length L = d2 \<and> (\<forall>a\<in>set B. aEval a (L @ xs)) \<and> (\<forall>f\<in>set B'. eval f (L @ xs))) ))"
    using h by simp
  also have "... = ((\<exists>(A,A',d1)\<in>set (dnf_modified \<phi>1). \<exists>(B,B',d2)\<in>set(dnf_modified \<phi>2).
          f (A,A',d1) \<and>
          f (B,B',d2)))"
    using f_def by simp
  also have "... = ((\<exists>a\<in>set (dnf_modified \<phi>1). \<exists>a1\<in>set(dnf_modified \<phi>2). f a \<and> f a1))"
    by (simp add: Bex_def_raw)
  also have "... = ((\<exists>a\<in>set (dnf_modified \<phi>1). f a) \<and> (\<exists>a\<in>set (dnf_modified \<phi>2). f a))"
    by blast
  also have "... = eval (And \<phi>1 \<phi>2) xs"
    using And f_def by simp
  finally have "(\<exists>(al, fl, n)\<in>set (dnf_modified (And \<phi>1 \<phi>2)).
               \<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs))) =
         eval (And \<phi>1 \<phi>2) xs"
    by simp
  then show ?case by simp
next
  case (Or \<phi>1 \<phi>2)
  have h1 : "eval (Or \<phi>1 \<phi>2) xs = eval \<phi>1 xs \<or> eval \<phi>2 xs"
    using eval.simps(5) by blast
  have h2 : "set (dnf_modified (Or \<phi>1 \<phi>2)) = set(dnf_modified \<phi>1) \<union> set(dnf_modified \<phi>2)"
    by simp
  show ?case using Or h1 h2
    by (metis (no_types, lifting) Un_iff eval.simps(5))
next
  case (ExQ \<phi>)
  have h1 : "((\<exists>x. (\<exists>(al, fl, n)\<in>set (dnf_modified \<phi>).
               \<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ (x#xs))) \<and> (\<forall>f\<in>set fl. eval f (L @ (x#xs)))))
              =
              (\<exists>(al, fl, n)\<in>set (dnf_modified \<phi>).
               (\<exists>x.\<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a ((L@[x]) @ xs)) \<and> (\<forall>f\<in>set fl. eval f ((L@[x]) @ xs)))))"
    apply simp by blast
  { fix n al fl
    define f where "f L = (length (L:: real list) = ((n::nat)+1) \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs)))" for L
    have "(\<exists>x.\<exists>L. f (L@[x])) = (\<exists>L. f L)"
      by (metis (full_types) One_nat_def add_Suc_right f_def list.size(3) nat.simps(3) rev_exhaust)
    then have "((\<exists>x. \<exists>L. length (L@[x]) = (n+1) \<and> (\<forall>a\<in>set al. aEval a ((L@[x]) @ xs)) \<and> (\<forall>f\<in>set fl. eval f ((L@[x]) @ xs)))
              =
            (\<exists>L. length L = (n+1) \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs))))"
      unfolding f_def by simp
  }
  then have h2 : "\<forall>n al fl. (
              (\<exists>x. \<exists>L. length (L@[x]) = (n+1) \<and> (\<forall>a\<in>set al. aEval a ((L@[x]) @ xs)) \<and> (\<forall>f\<in>set fl. eval f ((L@[x]) @ xs)))
              =
              (\<exists>L. length L = (n+1) \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs)))
            )"
    by simp
  { fix al fl n
    define f where "f al fl n = (\<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs)))" for al fl n
    have "f al fl (n+1) = (case (case (al, fl, n) of (A, A', d) \<Rightarrow> (A, A',d+1)) of
             (al, fl, n) \<Rightarrow> f al fl n)"
      by simp
    then have "(\<exists>L. length L = (n+1) \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs)))
              = (
             case (case (al, fl, n) of (A, A', d) \<Rightarrow> (A, A',d+1)) of
             (al, fl, n) \<Rightarrow>
               \<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs)))"
      unfolding f_def by simp
  }
  then have h3 : "
              (\<exists>(al, fl, n)\<in>set (dnf_modified \<phi>).
               \<exists>L. length L = (n+1) \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs)))
              = (\<exists>a\<in>set (dnf_modified \<phi>).
             case (case a of (A, A', d) \<Rightarrow> (A, A',d+1)) of
             (al, fl, n) \<Rightarrow>
               \<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs)))"
    by (smt case_prodE case_prodI2) (* takes a second *)
  show ?case using ExQ h1 h2 h3 by simp
next
  case (ExN x1 \<phi>)

  show ?case
    apply simp proof safe
    fix a aa b L
    have takedrop: "(take b L @ drop b L @ xs) = (L @ xs)" by auto
    assume h: "(a, aa, b) \<in> set (dnf_modified \<phi>)" "length L = b + x1" "\<forall>a\<in>set a. aEval a (L @ xs)" "\<forall>f\<in>set aa. eval f (L @ xs)"
    show "\<exists>l. length l = x1 \<and> eval \<phi> (l @ xs)"
      apply(rule exI[where x="drop b L"])
      apply auto
      using h(2) apply simp
      unfolding ExN[symmetric]
      apply(rule bexI[where x="(a,aa,b)"])
      apply simp
      apply(rule exI[where x="take b L"])
      apply auto
      using h apply simp
      unfolding takedrop
      using h by auto
  next
    fix l
    assume h: "eval \<phi> (l @ xs)" "x1 = length l"
    obtain al fl n where h1 : "(al, fl, n)\<in>set (dnf_modified \<phi>)" "\<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ l @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ l @ xs))"
      using h(1) unfolding ExN[symmetric]
      by blast
    obtain L where h2 : "length L = n" "(\<forall>a\<in>set al. aEval a (L @ l @ xs))" "(\<forall>f\<in>set fl. eval f (L @ l @ xs))" using h1(2) by metis
    show "\<exists>x\<in>set (dnf_modified \<phi>).
            case case x of (A, A', d) \<Rightarrow> (A, A', d + length l) of
            (al, fl, n) \<Rightarrow> \<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ xs)) \<and> (\<forall>f\<in>set fl. eval f (L @ xs))"
      apply(rule bexI[where x="(al,fl,n)"])
      apply simp
      apply(rule exI[where x="L@l"])
      apply auto
      using h2 h1 by auto
  qed
qed auto
end


theory Remove_And_Copy
  imports "HOL-IMP.Sem_Equiv" "HOL-IMP.Vars"
begin

notation Map.empty ("empty")

text \<open>
\exercise\label{exs:remove}
This exercise builds infrastructure for \autoref{exs:acopy}, where we
will have to manipulate partial maps from variable names to variable names.
\<close>
type_synonym tab = "vname \<Rightarrow> vname option"

text \<open>
  In addition to the function @{text merge} from theory @{text Fold},
  implement two functions @{text remove} and @{text remove_all} that
  remove one variable name from the range of a map, and a set of variable
  names from the domain and range of a map.
\<close>

definition merge :: "tab \<Rightarrow> tab \<Rightarrow> tab" where
  "merge t1 t2 = (\<lambda>m. if t1 m = t2 m then t1 m else None)"

definition remove :: "vname \<Rightarrow> tab \<Rightarrow> tab" where
  "remove v t = (\<lambda>m. if t m = Some v then None else t m)"

definition remove_all :: "vname set \<Rightarrow> tab \<Rightarrow> tab" where
  "remove_all vs t = (\<lambda>m. if (m \<in> vs)
    then None
    else if (t m \<in> Some ` vs)
      then None
      else t m)"

text \<open>
  Prove the following lemmas.
\<close>

lemma "ran (remove x t) = ran t - {x}"
proof (auto simp add: remove_def ran_def)
  fix xa a
  assume "xa \<noteq> x" "t a = Some xa"
  then have "t a \<noteq> Some x \<and> (t a \<noteq> Some x \<longrightarrow> t a = Some xa)" by auto
  then show "\<exists>a. t a \<noteq> Some x \<and> (t a \<noteq> Some x \<longrightarrow> t a = Some xa)" by blast
qed

lemma "ran (remove_all S t) \<subseteq> -S"
  by (auto simp add: remove_all_def ran_def)

lemma "dom (remove_all S t) \<subseteq> -S"
  by (auto simp add: remove_all_def dom_def)

lemma remove_all_update[simp]:
"remove_all {x} (t (x:= y)) = remove_all {x} t"
  by (auto simp add: remove_all_def)

lemma remove_all_remove[simp]:
"remove_all {x} (remove x t) = remove_all {x} t"
  by (auto simp add: remove_all_def remove_def)

lemma remove_all_Un[simp]:
"remove_all A (remove_all B t) = remove_all (A \<union> B) t"
  by (intro ext, auto simp add: remove_all_def)

lemma remove_all_in_dom [simp]: "a \<in> A \<Longrightarrow> remove_all A t a = None"
  by (auto simp add: remove_all_def)

lemma remove_all_in_range [simp]: "t a \<in> Some ` A \<Longrightarrow> remove_all A t a = None"
  by (auto simp add: remove_all_def)

lemma remove_all_in_range_singleton [simp]: "remove_all {x} t a \<noteq> Some x"
  by (auto simp add: remove_all_def)

lemma remove_all_notin [simp]: "\<lbrakk>a \<notin> A; t a \<notin> Some ` A\<rbrakk> \<Longrightarrow> remove_all A t a = t a"
  by (auto simp add: remove_all_def)

lemma remove_all_map_le [intro]: "remove_all A t \<subseteq>\<^sub>m t"
  by (auto simp add: remove_all_def map_le_def split: if_split_asm)

lemma map_leD1 [dest]: "\<lbrakk>f \<subseteq>\<^sub>m g; f x = Some y\<rbrakk> \<Longrightarrow> g x = Some y"
  by (auto simp add: map_le_def Ball_def)

lemma map_leD2 [dest]: "\<lbrakk>f \<subseteq>\<^sub>m g; g x = None\<rbrakk> \<Longrightarrow> f x = None"
  by (auto simp add: map_le_def Ball_def)

lemma remove_all_map_le1 [dest]: "remove_all A t a = Some k \<Longrightarrow> t a = Some k"
  by (auto intro: map_leD1)

lemma remove_all_map_le2 [dest]: "t a = None \<Longrightarrow> remove_all A t a = None"
  by (auto intro: map_leD2)

lemma merge_in: "(merge t1 t2) x \<in> Some ` S \<Longrightarrow> t1 x \<in> Some ` S \<and> t2 x \<in> Some ` S"
  by (auto simp add: merge_def split: if_split_asm)

lemma remove_all_merge_in_range: "(merge t1 t2) x \<in> Some ` S \<Longrightarrow> remove_all S t1 x = None \<and> remove_all S t2 x = None"
  by (auto dest!: merge_in)

lemma remove_all_merge1_none [simp]: "remove_all S t1 x = None \<Longrightarrow> remove_all S (merge t1 t2) x = None"
  by (auto simp add: remove_all_def merge_def)

lemma remove_all_merge2_none [simp]: "remove_all S t2 x = None \<Longrightarrow> remove_all S (merge t1 t2) x = None"
  by (auto simp add: remove_all_def merge_def)

lemma merge_map_le1 [intro]: "merge t1 t2 \<subseteq>\<^sub>m t1"
  by (auto simp add: merge_def map_le_def)

lemma merge_map_le2 [intro]: "merge t1 t2 \<subseteq>\<^sub>m t2"
  by (auto simp add: merge_def map_le_def)

lemma merge_remove_all:
  assumes "remove_all S t1 = remove_all S t"
  assumes "remove_all S t2 = remove_all S t"
  shows "remove_all S (merge t1 t2) = remove_all S t"
proof
  fix x
  from assms(1) [THEN fun_cong, of x] assms(2) [THEN fun_cong, of x]
  show "remove_all S (merge t1 t2) x = remove_all S t x"
    by (auto simp add: remove_all_def merge_def split: if_split_asm)
qed

text \<open>
  \endexercise

  \exercise\label{exs:acopy}
  This is a more challenging exercise.
  Define and prove correct \emph{copy propagation}. Copy propagation is
similar to constant folding, but propagates the right-hand side of assignments
if these right-hand sides are just variables. For instance, the program
\texttt{x := y; z := x + z} will be transformed into
\texttt{x := y; z := y + z}.
The assignment \texttt{x := y} can then be eliminated in a liveness
analysis. Copy propagation is useful for cleaning up after other optimisation
phases.

  To do this, take the definitions for constant folding from theory
  @{text Fold} and adjust
  them to do copy propagation instead (without constant folding).
  Use the functions from \autoref{exs:remove} in your definition.
  The general proof idea and structure of constant folding remains
  applicable. Adjust it according to your new definitions.
\<close>

definition "approx t s \<longleftrightarrow> (\<forall>x k. t x = Some k \<longrightarrow> s x = s k)"

primrec acopy :: "aexp \<Rightarrow> tab \<Rightarrow> aexp" where
  "acopy (N n) _ = N n" |
  "acopy (V x) t = (case t x of None \<Rightarrow> V x | Some x' \<Rightarrow> V x')" |
  "acopy (Plus e1 e2) t = (Plus (acopy e1 t) (acopy e2 t))"

primrec bcopy :: "bexp \<Rightarrow> tab \<Rightarrow> bexp" where
  "bcopy (Bc v) _ = Bc v" |
  "bcopy (Not b) t = Not (bcopy b t)" |
  "bcopy (And b1 b2) t = And (bcopy b1 t) (bcopy b2 t)" |
  "bcopy (Less e1 e2) t = Less (acopy e1 t) (acopy e2 t)"

fun copy :: "com \<Rightarrow> tab \<Rightarrow> com" and
  defs :: "com \<Rightarrow> tab \<Rightarrow> tab" where
  "copy SKIP _ = SKIP" |
  "defs SKIP t = t" |
  "copy (x ::= a) t = (x ::= acopy a t)" |
  "defs (x ::= a) t = (case acopy a t of V x' \<Rightarrow> (remove_all {x} t) (x \<mapsto> x') | _ \<Rightarrow> remove_all {x} t)" |
  "copy (c1;; c2) t = (copy c1 t;; copy c2 (defs c1 t))" |
  "defs (c1;; c2) t = (defs c2 (defs c1 t))" |
  "copy (IF b THEN c1 ELSE c2) t = IF bcopy b t THEN copy c1 t ELSE copy c2 t" |
  "defs (IF b THEN c1 ELSE c2) t = merge (defs c1 t) (defs c2 t)" |
  "copy (WHILE b DO c) t = WHILE bcopy b (remove_all (lvars c) t) DO copy c (remove_all (lvars c) t)" |
  "defs (WHILE b DO c) t = remove_all (lvars c) t"

value "copy (''x'' ::= V ''y'';; ''z'' ::= Plus (V ''x'') (V ''z'')) Map.empty"

lemma approx_merge:
  "approx t1 s \<or> approx t2 s \<Longrightarrow> approx (merge t1 t2) s"
  by (fastforce simp: merge_def approx_def)

lemma approx_map_le:
  "approx t2 s \<Longrightarrow> t1 \<subseteq>\<^sub>m t2 \<Longrightarrow> approx t1 s"
  by (clarsimp simp: approx_def map_le_def dom_def)

theorem aval_acopy [simp]: "approx t s \<Longrightarrow> aval (acopy a t) s = aval a s"
  by (induct a) (auto simp add: approx_def split: aexp.split option.split)

lemma acopy_VD [dest]: "acopy a t = V x \<Longrightarrow> (a = V x \<and> t x = None) \<or> (\<exists> x'. a = V x' \<and> t x' = Some x)"
  by (cases a, auto split: option.split_asm)

lemma remove_all_lvars_defs: "remove_all (lvars c) (defs c t) = remove_all (lvars c) t"
proof (induct c arbitrary: t)
  case (Assign x1 x2)
  then show ?case by (auto split: aexp.split)
next
  case (Seq c1 c2)
  then show ?case
  proof (auto)
    assume H1: "\<And>t. remove_all (lvars c1) (defs c1 t) = remove_all (lvars c1) t"
    assume H2: "\<And>t. remove_all (lvars c2) (defs c2 t) = remove_all (lvars c2) t"
    have "remove_all (lvars c1 \<union> lvars c2) (defs c2 (defs c1 t)) =
      remove_all (lvars c1) (remove_all (lvars c2) (defs c2 (defs c1 t)))" by simp
    also from H2 have "\<dots> = remove_all (lvars c1) (remove_all (lvars c2) (defs c1 t))" by simp
    also have "\<dots> = remove_all (lvars c2 \<union> lvars c1) (defs c1 t)" by (simp add: Un_commute)
    also have "\<dots> = remove_all (lvars c2) (remove_all (lvars c1) (defs c1 t))" by simp
    also from H1 have "\<dots> = remove_all (lvars c2) (remove_all (lvars c1) t)" by simp
    also have "\<dots> = remove_all (lvars c1 \<union> lvars c2) t" by (simp add: Un_commute)
    finally show "remove_all (lvars c1 \<union> lvars c2) (defs c2 (defs c1 t)) = remove_all (lvars c1 \<union> lvars c2) t" .
  qed
next
  case (If x1 c1 c2)
  then show ?case
  proof (auto intro!: merge_remove_all)
    assume "\<And>t. remove_all (lvars c1) (defs c1 t) = remove_all (lvars c1) t"
    then have "remove_all (lvars c2) (remove_all (lvars c1) (defs c1 t)) = remove_all (lvars c2) (remove_all (lvars c1) t)" by simp
    then show "remove_all (lvars c1 \<union> lvars c2) (defs c1 t) = remove_all (lvars c1 \<union> lvars c2) t" by (simp add: Un_commute)
    assume "\<And>t. remove_all (lvars c2) (defs c2 t) = remove_all (lvars c2) t"
    then have "remove_all (lvars c1) (remove_all (lvars c2) (defs c2 t)) = remove_all (lvars c1) (remove_all (lvars c2) t)" by simp
    then show "remove_all (lvars c1 \<union> lvars c2) (defs c2 t) = remove_all (lvars c1 \<union> lvars c2) t" by simp
  qed
qed auto

lemma big_step_pres_approx: "\<lbrakk>(c, s) \<Rightarrow> s'; approx t s\<rbrakk> \<Longrightarrow> approx (defs c t) s'"
proof (induct c s s' arbitrary: t rule: big_step_induct)
  case (Assign x a s)
  then show ?case by (auto simp add: approx_def split: aexp.split)
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  then show ?case
  proof auto
    assume "approx t s\<^sub>1"
    moreover assume "\<And>t. approx t s\<^sub>1 \<Longrightarrow> approx (defs c t) s\<^sub>2"
    ultimately have "approx (defs c t) s\<^sub>2" by auto
    moreover assume "\<And>t. approx t s\<^sub>2 \<Longrightarrow> approx (remove_all (lvars c) t) s\<^sub>3"
    ultimately have "approx (remove_all (lvars c) (defs c t)) s\<^sub>3" by auto
    then show "approx (remove_all (lvars c) t) s\<^sub>3" by (simp add: remove_all_lvars_defs)
  qed
qed (auto intro: approx_map_le)

lemma big_step_pres_approx_remove_all_lvars:
  "(c, s) \<Rightarrow> s' \<Longrightarrow> approx (remove_all (lvars c) t) s \<Longrightarrow> approx (remove_all (lvars c) t) s'"
proof -
  assume "(c, s) \<Rightarrow> s'" "approx (remove_all (lvars c) t) s"
  then have "approx (defs c (remove_all (lvars c) t)) s'" by (simp add: big_step_pres_approx)
  then have "approx (remove_all (lvars c) (defs c (remove_all (lvars c) t))) s'" by (auto intro: approx_map_le)
  then have "approx (remove_all (lvars c) (remove_all (lvars c) t)) s'" by (simp add: remove_all_lvars_defs)
  then show "approx (remove_all (lvars c) t) s'" by simp
qed

theorem approx_bcopy [intro]: "approx t \<Turnstile> b <\<sim>> bcopy b t" by (induct b) (auto simp add: bequiv_up_to_def)

theorem copy_equiv: "approx t \<Turnstile> c \<sim> copy c t"
proof (induct c arbitrary: t)
case (Assign x1 x2)
  then show ?case
  proof (auto simp add: equiv_up_to_def)
    fix s :: state
    assume "approx t s"
    have "(x1 ::= acopy x2 t, s) \<Rightarrow> s(x1 := aval (acopy x2 t) s)" by auto
    with \<open>approx t s\<close> show "(x1 ::= acopy x2 t, s) \<Rightarrow> s(x1 := aval x2 s)" by auto
  qed
next
  case (Seq c1 c2)
  then show ?case by (auto intro!: equiv_up_to_seq big_step_pres_approx)
next
  case (If x1 c1 c2)
  then show ?case by (auto intro!: equiv_up_to_if_weak)
next
  case (While x1 c)
  moreover let ?tr = "remove_all (lvars c) t"
  have H1: "approx ?tr \<Turnstile> x1 <\<sim>> bcopy x1 ?tr" by auto
  moreover have H2: "\<And>s s'. \<lbrakk>(c, s) \<Rightarrow> s'; approx ?tr s; bval x1 s\<rbrakk> \<Longrightarrow> approx ?tr s'"
    by (auto intro: big_step_pres_approx_remove_all_lvars)
  ultimately have "approx ?tr \<Turnstile>
         WHILE x1 DO c \<sim> WHILE bcopy x1 ?tr DO copy c ?tr"
    by (auto intro!: equiv_up_to_while_weak)
  with While have Hweak: "approx t \<Turnstile> WHILE x1 DO c \<sim> WHILE bcopy x1 ?tr DO copy c ?tr"
    by (auto intro: equiv_up_to_weaken approx_map_le)
  show ?case
    by (auto intro: Hweak split: bexp.split)
qed auto

lemma approx_empty [simp]:
  "approx empty = (\<lambda>_. True)"
  by (auto simp: approx_def)

theorem "copy c empty \<sim> c"
  using copy_equiv [of empty c]
  by (simp add: equiv_up_to_True)

text \<open> \endexercise \<close>

end


theory Thm7
imports
  Complex_Main
  "HOL-Data_Structures.Set2_Join"
begin
text \<open>The following is a formalisation of strongly joinable trees as defined
in @{cite paper_main}.\<close>

section "StronglyJoinable Locale"

fun bal :: "('a * 'b) tree \<Rightarrow> (('a * 'b) tree \<Rightarrow> real)
      \<Rightarrow> real \<Rightarrow> real \<Rightarrow> bool" where
"bal Leaf _ _ _ = True" |
"bal (Node l a r) rank c\<^sub>l c\<^sub>u =
  (max (rank l) (rank r) + c\<^sub>l \<le> rank (Node l a r) \<and>
   min (rank l) (rank r) + c\<^sub>u \<ge> rank (Node l a r) \<and>
   bal l rank c\<^sub>l c\<^sub>u \<and> bal r rank c\<^sub>l c\<^sub>u )"

locale StronglyJoinable = Set2_Join +
fixes rank :: "('a * 'b) tree \<Rightarrow> real"
fixes c\<^sub>l c\<^sub>u :: real

assumes rule_empty: "rank Leaf = 0"
assumes rule_mono: "\<lbrakk>inv l; inv r\<rbrakk> \<Longrightarrow> max (rank l) (rank r) \<le> rank (join l a r)"
assumes rule_sub_inc: "\<lbrakk>rank l \<le> rank l'; rank r \<le> rank r'; rank r' - rank r \<le> x; rank l' - rank l \<le> x;
  inv l'; inv r'; inv (Node l (a,b) r)\<rbrakk> \<Longrightarrow>
  rank (Node l (a,b) r) \<le> rank (join l' a r') \<and>
  rank (join l' a r') - rank (Node l (a,b) r) \<le> x"

assumes rule_sub_dec: "\<lbrakk>rank l' \<le> rank l; rank r' \<le> rank r;
  inv l'; inv r'; inv (Node l (a,b) r)\<rbrakk> \<Longrightarrow>
  rank (join l' a r') \<le> rank (Node l (a,b) r)"
assumes c_vals:"0 \<le> c\<^sub>l \<and> c\<^sub>l \<le> 1 \<and> c\<^sub>u \<ge> 1"
assumes rule_bal:"inv t \<Longrightarrow> bal t rank c\<^sub>l c\<^sub>u"
begin

\<comment> \<open>directly define a timing function for @{term join}\<close>
definition T_join :: "('a * 'b) tree \<Rightarrow> 'a \<Rightarrow> ('a * 'b) tree \<Rightarrow> real" where
"T_join l a r = abs(rank l - rank r)"

subsection "Auxiliary Properties"

definition "balanced t = bal t rank c\<^sub>l c\<^sub>u"

lemma rank_mono:"\<lbrakk>t = (Node l a r); balanced t\<rbrakk> \<Longrightarrow> rank t \<ge> rank l \<and> rank t \<ge> rank r"
  using balanced_def c_vals by force

definition "c\<^sub>\<delta> = c\<^sub>u - c\<^sub>l"

lemma dmax:"balanced (Node l a r) \<Longrightarrow> abs(rank l - rank r) \<le> c\<^sub>\<delta>"
  using balanced_def c\<^sub>\<delta>_def by force

lemma rank_pos:"balanced t \<Longrightarrow> rank t \<ge> 0"
  unfolding balanced_def apply(induction t)
  apply(auto simp add: c_vals rule_empty)
  using c_vals by linarith

lemma height_rank:"balanced t \<Longrightarrow> rank t \<le> c\<^sub>u * height t"
unfolding balanced_def
proof(induction t)
  case Leaf
  then show ?case
    by (simp add: rule_empty)
next
  case (Node l a r)
  then have "rank l \<le> c\<^sub>u * height l"
    by simp
  moreover have "rank r \<le> c\<^sub>u * height r"
    using Node by simp
  ultimately have "max (rank l) (rank r) \<le> c\<^sub>u * max (height l) (height r)"
    by (smt (verit, best) c_vals max.cobounded1 max.cobounded2 mult_mono of_nat_0_le_iff of_nat_mono)
  then have "max (rank l) (rank r) + c\<^sub>u \<le> c\<^sub>u * max (height l) (height r) + c\<^sub>u"
    using c_vals by argo
  also have "... \<le> c\<^sub>u * (max (height l) (height r) + 1)"
    using c_vals by (simp add: distrib_left)
  also have "... \<le> c\<^sub>u * height (Node l a r)"
    using c_vals by auto
  finally show ?case
    using Node by auto
qed

subsection "Splitting the @{emph \<open>split\<close>}"
fun splitl :: "('a * 'b) tree \<Rightarrow> 'a \<Rightarrow> ('a * 'b) tree" where
"splitl Leaf x = Leaf" |
"splitl (Node l (a,_) r) x = (case (cmp x a) of
   LT \<Rightarrow> splitl l x |
   EQ \<Rightarrow> l |
   GT \<Rightarrow> join l a (splitl r x))"

fun splitr :: "('a * 'b) tree \<Rightarrow> 'a \<Rightarrow> ('a * 'b) tree" where
"splitr Leaf x = Leaf" |
"splitr (Node l (a, _) r) x = (case (cmp x a) of
   LT \<Rightarrow> join (splitr l x) a r |
   EQ \<Rightarrow> r |
   GT \<Rightarrow> splitr r x)"

lemma splitl_eq_l:"split t x = (l,b,r) \<Longrightarrow> splitl t x = l"
  by(induction t arbitrary: l b r)(auto simp: split.simps split!: prod.splits)

lemma splitr_eq_r:"split t x = (l,b,r) \<Longrightarrow> splitr t x = r"
  by(induction t arbitrary: l b r)(auto simp: split.simps split!: prod.splits)

corollary inv_splitl:"inv t \<Longrightarrow> inv (splitl t x)"
  by (metis split_inv splitl_eq_l prod_cases3)

corollary inv_splitr:"inv t \<Longrightarrow> inv (splitr t x)"
  by (metis split_inv splitr_eq_r prod_cases3)

subsection "Bounding the StronglyJoinable Results"

lemma splitl_rank:"inv t \<Longrightarrow> rank t \<ge> rank (splitl t x)"
proof(induction t rule: tree2_induct)
  case Leaf
  then show ?case
    by simp
next
  case (Node l a b r)
  then have t_bal:"balanced (Node l (a,b) r)"
    using rule_bal balanced_def by fast

  then show ?case
  proof(cases "cmp x a")
    case LT
    then have "rank l \<ge> rank (splitl l x)"
      using Node inv_Node by blast
    then show ?thesis
      using Node t_bal LT balanced_def c_vals by auto
  next
    case EQ
    then show ?thesis
      using Node t_bal balanced_def c_vals by auto
  next
    case GT
    then have *:"splitl (Node l (a,b) r) x = join l a (splitl r x)"
      by simp

    \<comment> \<open>from the IH\<close>
    have "rank r \<ge> rank (splitl r x)"
      using Node inv_Node by blast
    \<comment> \<open>trivially\<close>
    moreover have "rank l \<ge> rank l"
      by simp
    \<comment> \<open>from the submodularity rule\<close>
    ultimately have "rank (Node l (a,b) r) \<ge> rank (join l a (splitl r x))"
      by (meson Node.prems inv_Node rule_sub_dec inv_splitl)
    then show ?thesis
      using * by simp
  qed
qed

lemma splitr_rank:"inv t \<Longrightarrow> rank t \<ge> rank (splitr t x)"
proof(induction t rule: tree2_induct)
  case Leaf
  then show ?case
    by simp
next
  case (Node l a b r)
  then have t_bal:"balanced (Node l (a,b) r)"
    using rule_bal balanced_def by fast

  then show ?case
  proof(cases "cmp x a")
    case LT
    have "rank l \<ge> rank (splitr l x)"
      using Node inv_Node by blast
    moreover have "rank r \<ge> rank r"
      by simp
    ultimately have "rank (Node l (a,b) r) \<ge> rank (join (splitr l x) a r)"
      by (meson Node.prems inv_Node rule_sub_dec inv_splitr)
    then show ?thesis
      using LT by simp
  next
    case EQ
    then show ?thesis
      using Node t_bal balanced_def c_vals by force
  next
    case GT
    then have "rank r \<ge> rank (splitr r x)"
      using Node inv_Node by blast
    then show ?thesis
      using Node t_bal GT balanced_def c_vals by auto
  qed
qed

corollary split_rank: "\<lbrakk>split t x = (l,b,r); inv t\<rbrakk> \<Longrightarrow> rank l \<le> rank t \<and> rank r \<le> rank t"
  using splitl_eq_l splitl_rank splitr_eq_r splitr_rank by blast

subsection "Timing Functions"

fun T_split :: "('a * 'b) tree \<Rightarrow> 'a \<Rightarrow> real" where
"T_split Leaf x = 1" |
"T_split (Node l (a,_) r) x = (case (cmp x a) of
   LT \<Rightarrow> let (l1,_,l2) = split l x in 1 + T_join l2 a r + T_split l x |
   EQ \<Rightarrow> 1 |
   GT \<Rightarrow> let (r1,_,r2) = split r x in 1 + T_join l a r1 + T_split r x)"

fun T_splitl :: "('a * 'b) tree \<Rightarrow> 'a \<Rightarrow> real" where
"T_splitl Leaf x = 1" |
"T_splitl (Node l (a,_) r) x = (case (cmp x a) of
   LT \<Rightarrow> T_splitl l x |
   EQ \<Rightarrow> 1 |
   GT \<Rightarrow> 1 + T_join l a (splitl r x) + T_splitl r x)"

fun T_splitr :: "('a * 'b) tree \<Rightarrow> 'a \<Rightarrow> real" where
"T_splitr Leaf x = 1" |
"T_splitr (Node l (a,_) r) x = (case (cmp x a) of
   LT \<Rightarrow> 1 + T_join (splitr l x) a r + T_splitr l x |
   EQ \<Rightarrow> 1 |
   GT \<Rightarrow> T_splitr r x)"

lemma T_split_lr:"T_split t x \<le> T_splitl t x + T_splitr t x"
proof(induction t rule: tree2_induct)
  case Leaf
  then show ?case
    by simp
next
  case (Node l a b r)
  let ?t = "Node l (a, b) r"

  show ?case
  proof(cases "cmp x a")
    case LT
    then consider (Left) l1 c l2 where "(l1,c,l2) = split l x" and "x < a"
      and "T_split ?t x = 1 + T_join l2 a r + T_split l x"
      and "T_splitl ?t x = T_splitl l x"
      and "T_splitr ?t x = 1 + T_join (splitr l x) a r + T_splitr l x"
      by(auto split: prod.splits)
        (metis (no_types, lifting) prod.exhaust_sel split_beta)

    then show ?thesis
      proof cases
        case Left
        have "splitr l x = l2"
          using Left splitr_eq_r by metis
        then show ?thesis
          using Left Node by auto
      qed
  next
    case EQ
    then show ?thesis
      by simp
  next
    case GT
    then consider (Right) r1 c r2 where "(r1,c,r2) = split r x" and "x > a"
      and "T_split ?t x = 1 + T_join l a r1 + T_split r x"
      and "T_splitl ?t x = 1 + T_join l a (splitl r x) + T_splitl r x"
      and "T_splitr ?t x = T_splitr r x"
      by(auto split: prod.splits)
        (metis (no_types, lifting) prod.exhaust_sel split_beta)

    then show ?thesis
      proof cases
        case Right
        have "splitl r x = r1"
          using Right splitl_eq_l by metis
        then show ?thesis
          using Right Node by auto
      qed
  qed
qed

subsection "Bounding the Timing Functions"

definition "c\<^sub>1 = 2 * c\<^sub>\<delta> + 1"

lemma c1_pos:"c\<^sub>1 > 0"
  using c\<^sub>1_def c\<^sub>\<delta>_def c_vals by linarith

lemma hnode_r:"c\<^sub>1 * height r \<le> c\<^sub>1 * height (Node l a r) - c\<^sub>1"
proof-
  have "height (Node l a r) \<ge> height r + 1"
    by simp
  then have "c\<^sub>1 * height (Node l a r) \<ge> c\<^sub>1 * (height r + 1)"
    using c1_pos by simp
  then have "c\<^sub>1 * height (Node l a r) \<ge> c\<^sub>1 * (height r) + c\<^sub>1"
    using c1_pos by (simp add: distrib_left)
  then show ?thesis
    by simp
qed

lemma T_splitl_bounded:
"inv t \<Longrightarrow> T_splitl t x \<le> 1 + c\<^sub>1 * height t + rank (splitl t x)"
proof(induction t rule: tree2_induct)
  case Leaf
  then show ?case
    by (simp add: rule_empty)
next
  case (Node l a b r)
  let ?t = "(Node l (a,b) r)"

  have t_bal:"balanced ?t"
    using rule_bal Node balanced_def by fast

  have inv_subtrees:"inv l \<and> inv r"
    using Node inv_Node by blast
  show ?case
  proof(cases "cmp x a")
    case LT
    \<comment> \<open>follows directly from the IH\<close>
    have *:"height l \<le> height ?t"
      by simp
    have "T_splitl ?t x \<le> 1 + c\<^sub>1 * height l + rank (splitl ?t x)"
      using LT Node inv_subtrees by force
    also have "... \<le> 1 + c\<^sub>1 * height ?t + rank (splitl ?t x)"
      using c1_pos by simp
    finally show ?thesis .
  next
    case EQ
    then show ?thesis
      using balanced_def c1_pos inv_subtrees rank_pos rule_bal by auto
  next
    case GT
    \<comment> \<open>since the rank of the split result is bounded\<close>
    have "rank r \<ge> rank (splitl r x)"
      using Node splitl_rank inv_subtrees by blast
    \<comment> \<open>and the tree is balanced\<close>
    then have "rank l + c\<^sub>\<delta> \<ge> rank (splitl r x)"
      using Node balanced_def t_bal c\<^sub>\<delta>_def by force
    \<comment> \<open>there must be some \<open>\<delta>\<close> that satisfies the equation below\<close>
    moreover then obtain \<delta> where hdiff:"rank l + c\<^sub>\<delta> = rank (splitl r x) + \<delta>"
      by (metis add.commute diff_add_cancel)
    \<comment> \<open>thus the time to join is bounded\<close>
    ultimately have "T_join l a (splitl r x) \<le> c\<^sub>\<delta> + \<delta>"
      using T_join_def c\<^sub>\<delta>_def c_vals by force
    \<comment> \<open>since \<open>x > a\<close>\<close>
    moreover have "T_splitl ?t x \<le> 1 + T_join l a (splitl r x) + T_splitl r x"
      using GT by simp
    \<comment> \<open>plugging in the bound for \<open>T_join l a (splitl r x)\<close>\<close>
    ultimately have "T_splitl ?t x \<le> 1 + c\<^sub>\<delta> + \<delta> + T_splitl r x"
      by simp
    \<comment> \<open>applying the induction hypothesis\<close>
    then have "T_splitl ?t x \<le> 1 + c\<^sub>\<delta> + \<delta> + 1 + c\<^sub>1 * height r + rank (splitl r x)"
      using Node inv_subtrees by fastforce
    \<comment> \<open>expressing @{term "rank (splitl t x)"} in terms of @{term "rank l + c\<^sub>\<delta>"} and @{term \<delta>}\<close>
    also have "... \<le> 1 + c\<^sub>\<delta> + \<delta> + 1 + c\<^sub>1 * height r + rank l + c\<^sub>\<delta> - \<delta>"
      using hdiff by simp
    \<comment> \<open>simplifying the expression\<close>
    also have "... \<le> 2 + 2*c\<^sub>\<delta> + c\<^sub>1 * height r + rank l"
      by simp
    \<comment> \<open>from the monoticity rule\<close>
    also have "... \<le> 2 + 2*c\<^sub>\<delta> + c\<^sub>1 * height r + rank (splitl ?t x)"
      using inv_subtrees inv_splitl rule_mono inv_subtrees GT by fastforce
    \<comment> \<open>from the definition of height\<close>
    also have "... \<le> 2 + 2*c\<^sub>\<delta> + c\<^sub>1 * height ?t - c\<^sub>1 + rank (splitl ?t x)"
      using hnode_r by auto
    \<comment> \<open>finally, because @{term "c\<^sub>1 = 2 * c\<^sub>\<delta> + 1"}\<close>
    also have "... \<le> 1 + c\<^sub>1 * height ?t + rank (splitl ?t x)"
      by (simp add: c\<^sub>1_def)
    finally show ?thesis .
  qed
qed

lemma hnode_l:"c\<^sub>1 * height l \<le> c\<^sub>1 * height (Node l a r) - c\<^sub>1"
proof-
  have "height (Node l a r) \<ge> height l + 1"
    by simp
  then have "c\<^sub>1 * height (Node l a r) \<ge> c\<^sub>1 * (height l + 1)"
    using c1_pos by simp
  then have "c\<^sub>1 * height (Node l a r) \<ge> c\<^sub>1 * (height l) + c\<^sub>1"
    using c1_pos by (simp add: distrib_left)
  then show ?thesis
    by simp
qed

lemma T_splitr_bounded:
"inv t \<Longrightarrow> T_splitr t x \<le> 1 + c\<^sub>1 * height t + rank (splitr t x)"
proof(induction t rule: tree2_induct)
  case Leaf
  then show ?case
    by (simp add: rule_empty)
next
  case (Node l a b r)
  let ?t = "(Node l (a,b) r)"

  have t_bal:"balanced ?t"
    using rule_bal Node balanced_def by fast

  have inv_subtrees:"inv l \<and> inv r"
    using Node inv_Node by blast
  show ?case
  proof(cases "cmp x a")
    case LT
    have "rank l \<ge> rank (splitr l x)"
      using Node splitr_rank inv_subtrees by blast
    then have "rank r + c\<^sub>\<delta> \<ge> rank (splitr l x)"
      using Node balanced_def t_bal c\<^sub>\<delta>_def by force
    then obtain \<delta> where hdiff:"rank r + c\<^sub>\<delta> = rank (splitr l x) + \<delta>"
      by (metis add.commute diff_add_cancel)
    then have "T_join (splitr l x) a r \<le> c\<^sub>\<delta> + \<delta>"
      using T_join_def hdiff using \<open>rank (splitr l x) \<le> rank r + c\<^sub>\<delta>\<close> c\<^sub>\<delta>_def c_vals by force
    then have "T_splitr ?t x \<le> 1 + c\<^sub>\<delta> + \<delta> + 1 + c\<^sub>1 * height l + rank (splitr l x)"
      using Node LT inv_subtrees by fastforce
    also have "... \<le> 1 + c\<^sub>\<delta> + \<delta> + 1 + c\<^sub>1 * height l + rank r + c\<^sub>\<delta> - \<delta>"
      using hdiff by simp
    also have "... \<le> 2 + 2*c\<^sub>\<delta>  + c\<^sub>1 * height l + rank r"
      by simp
    also have "... \<le> 2 + 2*c\<^sub>\<delta> + c\<^sub>1 * height l + rank (splitr ?t x)"
      using inv_subtrees inv_splitr rule_mono inv_subtrees LT by fastforce
    also have "... \<le> 2 + 2*c\<^sub>\<delta> + c\<^sub>1 * height ?t - c\<^sub>1 + rank (splitr ?t x)"
      using hnode_l by auto
    finally show ?thesis
      by (simp add: c\<^sub>1_def)
  next
    case EQ
    then show ?thesis
      using balanced_def c1_pos inv_subtrees rank_pos rule_bal by auto
  next
    case GT
    have *:"height r \<le> height ?t"
      by simp
    have "T_splitr ?t x \<le> 1 + c\<^sub>1 * height r + rank (splitr ?t x)"
      using GT Node inv_subtrees by auto
    also have "... \<le> 1 + c\<^sub>1 * height ?t + rank (splitr ?t x)"
      by (simp add: c1_pos)
    finally show ?thesis .
  qed
qed

corollary T_splitl_ht:"inv t \<Longrightarrow> T_splitl t x \<le> 1 + (c\<^sub>1 + c\<^sub>u) * height t"
proof-
  assume assm:"inv t"

  then have "T_splitl t x \<le> 1 + c\<^sub>1 * height t + rank (splitl t x)"
    using T_splitl_bounded by simp
  also have "... \<le> 1 + c\<^sub>1 * height t + rank t"
    using assm splitl_rank by simp
  also have "... \<le> 1 + c\<^sub>1 * height t + c\<^sub>u * height t"
     by (simp add: assm balanced_def height_rank rule_bal)
  also have "... \<le> 1 + (c\<^sub>1 + c\<^sub>u) * height t"
    by argo
  finally show ?thesis .
qed

corollary T_splitr_ht:"inv t \<Longrightarrow> T_splitr t x \<le> 1 + (c\<^sub>1 + c\<^sub>u) * height t"
proof-
  assume assm:"inv t"

  then have "T_splitr t x \<le> 1 + c\<^sub>1 * height t + rank (splitr t x)"
    using T_splitr_bounded by simp
  also have "... \<le> 1 + c\<^sub>1 * height t + rank t"
    using assm splitr_rank by simp
  also have "... \<le> 1 + c\<^sub>1 * height t + c\<^sub>u * height t"
     by (simp add: assm balanced_def height_rank rule_bal)
  also have "... \<le> 1 + (c\<^sub>1 + c\<^sub>u) * height t"
    by argo
  finally show ?thesis .
qed

subsection "Proof of Main Theorem"

theorem T_split_bounded:
assumes "inv t"
shows "T_split t x \<le> 2 + 2 * (c\<^sub>1 + c\<^sub>u) * height t"
proof-
  have "T_split t x \<le> T_splitl t x + T_splitr t x"
    using T_split_lr by blast
  also have "... \<le> 1 + (c\<^sub>1 + c\<^sub>u) * height t + 1 + (c\<^sub>1 + c\<^sub>u) * height t"
    using assms T_splitl_ht T_splitr_ht by (smt (verit, best))
  also have "... \<le> 2 + 2 * (c\<^sub>1 + c\<^sub>u) * height t"
    by linarith
  finally show ?thesis .
qed

end
end


subsection \<open>Indexing\<close>

theory Indexing
  imports Main
begin

definition injective :: "nat \<Rightarrow> ('k \<Rightarrow> nat) \<Rightarrow> bool" where
  "injective size to_index \<equiv> \<forall> a b.
      to_index a = to_index b
    \<and> to_index a < size
    \<and> to_index b < size
    \<longrightarrow> a = b"
  for size to_index

lemma index_mono:
  fixes a b a0 b0 :: nat
  assumes a: "a < a0" and b: "b < b0"
  shows "a * b0 + b < a0 * b0"
proof -
  have "a * b0 + b < (Suc a) * b0"
    using b by auto
  also have "\<dots> \<le> a0 * b0"
    using a[THEN Suc_leI, THEN mult_le_mono1] .
  finally show ?thesis .
qed

lemma index_eq_iff:
  fixes a b c d b0 :: nat
  assumes "b < b0" "d < b0" "a * b0 + b = c * b0 + d"
  shows "a = c \<and> b = d"
proof (rule conjI)
  { fix a b c d :: nat
    assume ac: "a < c" and b: "b < b0"
    have "a * b0 + b < (Suc a) * b0"
      using b by auto
    also have "\<dots> \<le> c * b0"
      using ac[THEN Suc_leI, THEN mult_le_mono1] .
    also have "\<dots> \<le> c * b0 + d"
      by auto
    finally have "a * b0 + b \<noteq> c * b0 + d"
      by auto
  } note ac = this

  { assume "a \<noteq> c"
    then consider (le) "a < c" | (ge) "a > c"
      by fastforce
    hence False proof cases
      case le show ?thesis using ac[OF le assms(1)] assms(3) ..
    next
      case ge show ?thesis using ac[OF ge assms(2)] assms(3)[symmetric] ..
    qed
  }

  then show "a = c"
    by auto

  with assms(3) show "b = d"
    by auto
qed

locale prod_order_def =
  order0: ord less_eq0 less0 +
  order1: ord less_eq1 less1
  for less_eq0 less0 less_eq1 less1
begin

fun less :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" where
  "less (a,b) (c,d) \<longleftrightarrow> less0 a c \<and> less1 b d"

fun less_eq :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" where
  "less_eq ab cd \<longleftrightarrow> less ab cd \<or> ab = cd"

end

locale prod_order =
  prod_order_def less_eq0 less0 less_eq1 less1 +
  order0: order less_eq0 less0 +
  order1: order less_eq1 less1
  for less_eq0 less0 less_eq1 less1
begin

sublocale order less_eq less
proof qed fastforce+

end

locale option_order =
  order0: order less_eq0 less0
  for less_eq0 less0
begin

fun less_eq_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
  "less_eq_option None _ \<longleftrightarrow> True"
| "less_eq_option (Some _) None \<longleftrightarrow> False"
| "less_eq_option (Some a) (Some b) \<longleftrightarrow> less_eq0 a b"

fun less_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
  "less_option ao bo \<longleftrightarrow> less_eq_option ao bo \<and> ao \<noteq> bo"

sublocale order less_eq_option less_option
  apply standard
  subgoal for x y by (cases x; cases y) auto
  subgoal for x by (cases x) auto
  subgoal for x y z by (cases x; cases y; cases z) auto
  subgoal for x y by (cases x; cases y) auto
  done

end

datatype 'a bound = Bound (lower: 'a) (upper:'a)

definition in_bound :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a bound \<Rightarrow> 'a \<Rightarrow> bool" where
  "in_bound less_eq less bound x \<equiv> case bound of Bound l r \<Rightarrow> less_eq l x \<and> less x r" for less_eq less

locale index_locale_def = ord less_eq less for less_eq less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" +
  fixes idx :: "'a bound \<Rightarrow> 'a \<Rightarrow> nat"
    and size :: "'a bound \<Rightarrow> nat"

locale index_locale = index_locale_def + idx_ord: order +
  assumes idx_valid: "in_bound less_eq less bound x \<Longrightarrow> idx bound x < size bound"
    and idx_inj : "\<lbrakk>in_bound less_eq less bound x; in_bound less_eq less bound y; idx bound x = idx bound y\<rbrakk> \<Longrightarrow> x = y"

locale prod_index_def =
  index0: index_locale_def less_eq0 less0 idx0 size0 +
  index1: index_locale_def less_eq1 less1 idx1 size1
  for less_eq0 less0 idx0 size0 less_eq1 less1 idx1 size1
begin

fun idx :: "('a \<times> 'b) bound \<Rightarrow> 'a \<times> 'b \<Rightarrow> nat" where
  "idx (Bound (l0, r0) (l1, r1)) (a, b) = (idx0 (Bound l0 l1) a) * (size1 (Bound r0 r1)) + idx1 (Bound r0 r1) b"

fun size :: "('a \<times> 'b) bound \<Rightarrow> nat" where
  "size (Bound (l0, r0) (l1, r1)) = size0 (Bound l0 l1) * size1 (Bound r0 r1)"

end

locale prod_index = prod_index_def less_eq0 less0 idx0 size0 less_eq1 less1 idx1 size1 +
  index0: index_locale less_eq0 less0 idx0 size0 +
  index1: index_locale less_eq1 less1 idx1 size1
  for less_eq0 less0 idx0 size0 less_eq1 less1 idx1 size1
begin

sublocale prod_order less_eq0 less0 less_eq1 less1 ..

sublocale index_locale less_eq less idx size proof
  { fix ab :: "'a \<times> 'b" and bound :: "('a \<times> 'b) bound"
    assume bound: "in_bound less_eq less bound ab"

    obtain a b l0 r0 l1 r1 where defs:"ab = (a, b)" "bound = Bound (l0, r0) (l1, r1)"
      by (cases ab; cases bound) auto

    with bound have a: "in_bound less_eq0 less0 (Bound l0 l1) a" and b: "in_bound less_eq1 less1 (Bound r0 r1) b"
      unfolding in_bound_def by auto

    have "idx (Bound (l0, r0) (l1, r1)) (a, b) < size (Bound (l0, r0) (l1, r1))"
      using index_mono[OF index0.idx_valid[OF a] index1.idx_valid[OF b]] by auto

    thus "idx bound ab < size bound"
      unfolding defs .
  }

  { fix ab cd :: "'a \<times> 'b" and bound :: "('a \<times> 'b) bound"
    assume bound: "in_bound less_eq less bound ab" "in_bound less_eq less bound cd"
      and idx_eq: "idx bound ab = idx bound cd"

    obtain a b c d l0 r0 l1 r1 where
      defs: "ab = (a, b)" "cd = (c, d)" "bound = Bound (l0, l1) (r0, r1)"
      by (cases ab; cases cd; cases bound) auto

    from defs bound have
          a: "in_bound less_eq0 less0 (Bound l0 r0) a"
      and b: "in_bound less_eq1 less1 (Bound l1 r1) b"
      and c: "in_bound less_eq0 less0 (Bound l0 r0) c"
      and d: "in_bound less_eq1 less1 (Bound l1 r1) d"
      unfolding in_bound_def by auto

    from index_eq_iff[OF index1.idx_valid[OF b] index1.idx_valid[OF d] idx_eq[unfolded defs, simplified]]
    have ac: "idx0 (Bound l0 r0) a = idx0 (Bound l0 r0) c" and bd: "idx1 (Bound l1 r1) b = idx1 (Bound l1 r1) d" by auto
    show "ab = cd"
      unfolding defs using index0.idx_inj[OF a c ac] index1.idx_inj[OF b d bd] by auto
  }
qed
end

locale option_index =
  index0: index_locale less_eq0 less0 idx0 size0
  for less_eq0 less0 idx0 size0
begin

fun idx :: "'a option bound \<Rightarrow> 'a option \<Rightarrow> nat" where
  "idx (Bound (Some l) (Some r)) (Some a) = idx0 (Bound l r) a"
| "idx _ _ = undefined"
(* option is NOT an index *)

end

locale nat_index_def = ord "(\<le>) :: nat \<Rightarrow> nat \<Rightarrow> bool" "(<)"
begin

fun idx :: "nat bound \<Rightarrow> nat \<Rightarrow> nat" where
  "idx (Bound l _) i = i - l"

fun size :: "nat bound \<Rightarrow> nat" where
  "size (Bound l r) = r - l"

sublocale index_locale "(\<le>)" "(<)" idx size
proof qed (auto simp: in_bound_def split: bound.splits)

end

locale nat_index = nat_index_def + order "(\<le>) :: nat \<Rightarrow> nat \<Rightarrow> bool" "(<)"

locale int_index_def = ord "(\<le>) :: int \<Rightarrow> int \<Rightarrow> bool" "(<)"
begin

fun idx :: "int bound \<Rightarrow> int \<Rightarrow> nat" where
  "idx (Bound l _) i = nat (i - l)"

fun size :: "int bound \<Rightarrow> nat" where
  "size (Bound l r) = nat (r - l)"

sublocale index_locale "(\<le>)" "(<)" idx size
proof qed (auto simp: in_bound_def split: bound.splits)

end

locale int_index = int_index_def + order "(\<le>) :: int \<Rightarrow> int \<Rightarrow> bool" "(<)"

class index =
  fixes less_eq less :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
    and idx :: "'a bound \<Rightarrow> 'a \<Rightarrow> nat"
    and size :: "'a bound \<Rightarrow> nat"
  assumes is_locale: "index_locale less_eq less idx size"

locale bounded_index =
  fixes bound :: "'k :: index bound"
begin

interpretation index_locale less_eq less idx size
  using is_locale .

definition "size \<equiv> index_class.size bound" for size

definition "checked_idx x \<equiv> if in_bound less_eq less bound x then idx bound x else size"

lemma checked_idx_injective:
  "injective size checked_idx"
  unfolding injective_def
  unfolding checked_idx_def
  using idx_inj by (fastforce split: if_splits)
end

instantiation nat :: index
begin

interpretation nat_index ..
thm index_locale_axioms

definition [simp]: "less_eq_nat \<equiv> (\<le>) :: nat \<Rightarrow> nat \<Rightarrow> bool"
definition [simp]: "less_nat \<equiv> (<) :: nat \<Rightarrow> nat \<Rightarrow> bool"
definition [simp]: "idx_nat \<equiv> idx"
definition size_nat where [simp]: "size_nat \<equiv> size"

instance by (standard, simp, fact index_locale_axioms)

end

instantiation int :: index
begin

interpretation int_index ..
thm index_locale_axioms

definition [simp]: "less_eq_int \<equiv> (\<le>) :: int \<Rightarrow> int \<Rightarrow> bool"
definition [simp]: "less_int \<equiv> (<) :: int \<Rightarrow> int \<Rightarrow> bool"
definition [simp]: "idx_int \<equiv> idx"
definition [simp]: "size_int \<equiv> size"

lemmas size_int = size.simps

instance by (standard, simp, fact index_locale_axioms)
end

instantiation prod :: (index, index) index
begin

interpretation prod_index
  "less_eq::'a \<Rightarrow> 'a \<Rightarrow> bool" less idx size
  "less_eq::'b \<Rightarrow> 'b \<Rightarrow> bool" less idx size
  by (rule prod_index.intro; fact is_locale)
thm index_locale_axioms

definition [simp]: "less_eq_prod \<equiv> less_eq"
definition [simp]: "less_prod \<equiv> less"
definition [simp]: "idx_prod \<equiv> idx"
definition [simp]: "size_prod \<equiv> size" for size_prod

lemmas size_prod = size.simps

instance by (standard, simp, fact index_locale_axioms)

end

lemma bound_int_simp[code]:
  "bounded_index.size (Bound (l1, l2) (u1, u2)) = nat (u1 - l1) * nat (u2 - l2)"
  by (simp add: bounded_index.size_def,unfold size_int_def[symmetric] size_prod,simp add: size_int)

lemmas [code] = bounded_index.size_def bounded_index.checked_idx_def

lemmas [code] =
  nat_index_def.size.simps
  nat_index_def.idx.simps

lemmas [code] =
  int_index_def.size.simps
  int_index_def.idx.simps

lemmas [code] =
  prod_index_def.size.simps
  prod_index_def.idx.simps

lemmas [code] =
  prod_order_def.less_eq.simps
  prod_order_def.less.simps

lemmas index_size_defs =
  prod_index_def.size.simps int_index_def.size.simps nat_index_def.size.simps bounded_index.size_def

end


theory Submission
  imports Defs
begin

lemmas [intro] = good_node.intros(1)

theorem good_node_def:
  "good_node i \<longleftrightarrow> E\<^sup>*\<^sup>* i 0"
proof
  assume "good_node i"
  thus "E\<^sup>*\<^sup>* i 0"
    by induction auto
next
  assume "E\<^sup>*\<^sup>* i 0"
  thus "good_node i"
    by (induction rule: converse_rtranclp_induct) (auto intro: good_node.intros(2))
qed

theorem good_node_characterization_1:
  assumes "i < n" "i > 0" "good_node i"
  shows "\<not> (\<exists>j. E\<^sup>*\<^sup>* i j \<and> E\<^sup>+\<^sup>+ j j)"
proof safe
  fix j assume "E\<^sup>*\<^sup>* i j" "E\<^sup>+\<^sup>+ j j"
  from assms(3,1,2) this show False
  proof (induction rule: good_node.induct)
    case (2 a b)
    thus False
      by (metis E_def rtranclp_tranclp_tranclp tranclpD)
  qed auto
qed

definition step :: "nat \<Rightarrow> nat" where
  "step i = graph ! i"

lemma step_less: "i < n \<Longrightarrow> step i < n"
  using wellformed by (auto simp: n_def step_def)

theorem good_node_characterization_2:
  assumes "i < n" "i > 0" "\<not> (\<exists>j. E\<^sup>*\<^sup>* i j \<and> E\<^sup>+\<^sup>+ j j)"
  shows "good_node i"
proof (rule ccontr)
  assume "\<not>good_node i"

  text \<open>
    We define a step function and consider the sequence of steps starting from \<^term>\<open>i\<close>:
  \<close>
  have step: "E k (step k)" if "k > 0" "k < n" for k
    using that wellformed by (auto simp: E_def step_def n_def)
  have steps_less: "(step ^^ k) i < n" for k
    using assms(1) by (induction k) (auto intro: step_less)

  text \<open>
    Because \<^term>\<open>i\<close> is not good, we will never hit 0:
  \<close>
  have steps_nonzero: "(step ^^ k) i \<noteq> 0" for k
  proof
    assume "(step ^^ k) i = 0"
    from this and \<open>i < n\<close> have "good_node i"
    proof (induction k arbitrary: i)
      case (Suc k i)
      show ?case
      proof (cases "i = 0")
        case False
        have "E i (step i)"
          using step[of i] Suc False by auto
        moreover have "good_node (step i)"
          using Suc.IH[of "step i"] Suc.prems False step_less[of i]
          by (intro Suc) (auto simp: funpow_Suc_right simp del: funpow.simps)
        ultimately show ?thesis by (auto intro: good_node.intros(2))
      qed auto
    qed auto
    with \<open>\<not>good_node i\<close> show False by blast
  qed

  text \<open>
    We can reach the \<open>k + x\<close>-th step from the \<open>k\<close>-th step in \<open>x\<close> steps:
  \<close>
  have reach_aux: "(E ^^ x) ((step ^^ k) i) ((step ^^ (k + x)) i)" for k x
  proof (induction x)
    case (Suc x)
    have "(E ^^ x) ((step ^^ k) i) ((step ^^ (k + x)) i)" by fact
    thus ?case
      using local.step steps_less steps_nonzero by auto
  qed auto

  have reach: "(E ^^ k) i ((step ^^ k) i)" for k
    using reach_aux[of k 0] by simp

  text \<open>
    By the pigeonhole principle, there we hit some node \<open>j\<close> twice. Let \<open>k\<^sub>1 < k\<^sub>2\<close> be the indices
    of these two steps.
  \<close>
  obtain k1 k2 where k12: "k1 < k2" "(step ^^ k1) i = (step ^^ k2) i"
  proof -
    have "\<not>inj (\<lambda>k. (step ^^ k) i)"
    proof
      assume "inj (\<lambda>k. (step ^^ k) i)"
      hence "infinite (range (\<lambda>k. (step ^^ k) i))"
        using finite_image_iff by blast
      moreover have "range (\<lambda>k. (step ^^ k) i) \<subseteq> {..<n}"
        using steps_less by auto
      hence "finite (range (\<lambda>k. (step ^^ k) i))"
        using infinite_super by auto
      ultimately show False by auto
    qed
    have "\<exists>k1 k2. k1 < k2 \<and> (step ^^ k1) i = (step ^^ k2) i"
    proof -
      from \<open>\<not>inj (\<lambda>k. (step ^^ k) i)\<close>
        obtain k1 k2 where "k1 \<noteq> k2" "(step ^^ k1) i = (step ^^ k2) i"
        by (auto simp: inj_def)
      thus ?thesis
        by (cases k1 k2 rule: linorder_cases; force)
    qed
    thus ?thesis using that by blast
  qed
  define j where "j = (step ^^ k1) i"
  have [simp]: "(step ^^ k1) i = j" "(step ^^ k2) i = j"
    using k12 by (simp_all add: j_def)

  text \<open>
    We then note that \<open>j\<close> is reachable from \<open>i\<close>, and it is also reachable from itself
    in more than one step (i.e.\ it lies on a circle).
  \<close>
  have "E\<^sup>*\<^sup>* i j"
    using reach unfolding j_def by (meson relpowp_imp_rtranclp)
  moreover have "E\<^sup>+\<^sup>+ j j"
  proof -
    have "(E ^^ (k2 - k1)) ((step ^^ k1) i) ((step ^^ k2) i)"
      using reach_aux[of "k2 - k1" k1] k12 by simp
    hence "E\<^sup>+\<^sup>+ ((step ^^ k1) i) ((step ^^ k2) i)"
      by (meson k12 tranclp_power zero_less_diff)
    thus "E\<^sup>+\<^sup>+ j j"
      by simp
  qed
  ultimately show False using assms k12 by auto
qed

corollary good_node_characterization:
  assumes "i < n" "i > 0"
  shows "good_node i \<longleftrightarrow> \<not>(\<exists>j. E\<^sup>*\<^sup>* i j \<and> E\<^sup>+\<^sup>+ j j)"
  using good_node_characterization_1 good_node_characterization_2 assms by blast

end