theory Union_Find_Time
imports
  "Imperative_HOL_Time.Sep_Time_Main"
  "../Sepreftime/Refine_Imperative_HOL/Sepref_Additional"
  Collections.Partial_Equivalence_Relation
  "HOL-Library.Code_Target_Numeral"
  "Imperative_HOL_Time.Asymptotics_1D"
  UnionFind_Intf
begin

notation timeCredit_assn  ("$")

text {*
  We implement a simple union-find data-structure based on an array.
  It uses path compression and a size-based union heuristics.
*}

subsection {* Abstract Union-Find on Lists *}
text {*
  We first formulate union-find structures on lists, and later implement
  them using Imperative/HOL. This is a separation of proof concerns
  between proving the algorithmic idea correct and generating the verification
  conditions.
*}

subsubsection {* Representatives *}
text {*
  We define a function that searches for the representative of an element.
  This function is only partially defined, as it does not terminate on all
  lists. We use the domain of this function to characterize valid union-find
  lists.
*}
function (domintros) rep_of
  where "rep_of l i = (if l!i = i then i else rep_of l (l!i))"
  by pat_completeness auto

text {* A valid union-find structure only contains valid indexes, and
  the @{text "rep_of"} function terminates for all indexes. *}
definition
  "ufa_invar l \<equiv> \<forall>i<length l. rep_of_dom (l,i) \<and> l!i<length l"

lemma ufa_invarD:
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> rep_of_dom (l,i)"
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> l!i<length l"
  unfolding ufa_invar_def by auto

text {* We derive the following equations for the @{text "rep-of"} function. *}
lemma rep_of_refl: "l!i=i \<Longrightarrow> rep_of l i = i"
  apply (subst rep_of.psimps)
  apply (rule rep_of.domintros)
  apply (auto)
  done

lemma rep_of_step:
  "\<lbrakk>ufa_invar l; i<length l; l!i\<noteq>i\<rbrakk> \<Longrightarrow> rep_of l i = rep_of l (l!i)"
  apply (subst rep_of.psimps)
  apply (auto dest: ufa_invarD)
  done

lemmas rep_of_simps = rep_of_refl rep_of_step

lemma rep_of_iff: "\<lbrakk>ufa_invar l; i<length l\<rbrakk>
  \<Longrightarrow> rep_of l i = (if l!i=i then i else rep_of l (l!i))"
  by (simp add: rep_of_simps)

text {* We derive a custom induction rule, that is more suited to
  our purposes. *}
lemma rep_of_induct[case_names base step, consumes 2]:
  assumes I: "ufa_invar l"
  assumes L: "i<length l"
  assumes BASE: "\<And>i. \<lbrakk> ufa_invar l; i<length l; l!i=i \<rbrakk> \<Longrightarrow> P l i"
  assumes STEP: "\<And>i. \<lbrakk> ufa_invar l; i<length l; l!i\<noteq>i; P l (l!i) \<rbrakk>
    \<Longrightarrow> P l i"
  shows "P l i"
proof -
  from ufa_invarD[OF I L] have "ufa_invar l \<and> i<length l \<longrightarrow> P l i"
    apply (induct l\<equiv>l i rule: rep_of.pinduct)
    apply (auto intro: STEP BASE dest: ufa_invarD)
    done
  thus ?thesis using I L by simp
qed

text {* In the following, we define various properties of @{text "rep_of"}. *}
lemma rep_of_min:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
proof -
  have "\<lbrakk>rep_of_dom (l,i) \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
    apply (induct arbitrary:  rule: rep_of.pinduct)
    apply (subst rep_of.psimps, assumption)
    apply (subst (2) rep_of.psimps, assumption)
    apply auto
    done
  thus "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
    by (metis ufa_invarD(1))
qed

lemma rep_of_bound:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> rep_of l i < length l"
  apply (induct rule: rep_of_induct)
  apply (auto simp: rep_of_iff)
  done

lemma rep_of_idem:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> rep_of l (rep_of l i) = rep_of l i"
  by (auto simp: rep_of_min rep_of_refl)

lemma rep_of_min_upd: "\<lbrakk> ufa_invar l; x<length l; i<length l \<rbrakk> \<Longrightarrow>
  rep_of (l[rep_of l x := rep_of l x]) i = rep_of l i"
  by (metis list_update_id rep_of_min)

lemma rep_of_idx:
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> rep_of l (l!i) = rep_of l i"
  by (metis rep_of_step)

subsubsection {* Abstraction to Partial Equivalence Relation *}
definition ufa_\<alpha> :: "nat list \<Rightarrow> (nat\<times>nat) set"
  where "ufa_\<alpha> l
    \<equiv> {(x,y). x<length l \<and> y<length l \<and> rep_of l x = rep_of l y}"

lemma ufa_\<alpha>_equiv[simp, intro!]: "part_equiv (ufa_\<alpha> l)"
  apply rule
  unfolding ufa_\<alpha>_def
  apply (rule symI)
  apply auto
  apply (rule transI)
  apply auto
  done

lemma ufa_\<alpha>_lenD:
  "(x,y)\<in>ufa_\<alpha> l \<Longrightarrow> x<length l"
  "(x,y)\<in>ufa_\<alpha> l \<Longrightarrow> y<length l"
  unfolding ufa_\<alpha>_def by auto

lemma ufa_\<alpha>_dom[simp]: "Domain (ufa_\<alpha> l) = {0..<length l}"
  unfolding ufa_\<alpha>_def by auto

lemma ufa_\<alpha>_refl[simp]: "(i,i)\<in>ufa_\<alpha> l \<longleftrightarrow> i<length l"
  unfolding ufa_\<alpha>_def
  by simp

lemma ufa_\<alpha>_len_eq:
  assumes "ufa_\<alpha> l = ufa_\<alpha> l'"
  shows "length l = length l'"
  by (metis assms le_antisym less_not_refl linorder_le_less_linear ufa_\<alpha>_refl)

subsubsection {* Operations *}
lemma ufa_init_invar: "ufa_invar [0..<n]"
  unfolding ufa_invar_def
  by (auto intro: rep_of.domintros)

lemma ufa_init_correct: "ufa_\<alpha> [0..<n] = {(x,x) | x. x<n}"
  unfolding ufa_\<alpha>_def
  using ufa_init_invar[of n]
  apply (auto simp: rep_of_refl)
  done

lemma ufa_find_correct: "\<lbrakk>ufa_invar l; x<length l; y<length l\<rbrakk>
  \<Longrightarrow> rep_of l x = rep_of l y \<longleftrightarrow> (x,y)\<in>ufa_\<alpha> l"
  unfolding ufa_\<alpha>_def
  by auto

abbreviation "ufa_union l x y \<equiv> l[rep_of l x := rep_of l y]"

lemma ufa_union_invar:
  assumes I: "ufa_invar l"
  assumes L: "x<length l" "y<length l"
  shows "ufa_invar (ufa_union l x y)"
  unfolding ufa_invar_def
proof (intro allI impI, simp only: length_list_update)
  fix i
  assume A: "i<length l"
  with I have "rep_of_dom (l,i)" by (auto dest: ufa_invarD)

  have "ufa_union l x y ! i < length l" using I L A
    apply (cases "i=rep_of l x")
    apply (auto simp: rep_of_bound dest: ufa_invarD)
    done
  moreover have "rep_of_dom (ufa_union l x y, i)" using I A L
  proof (induct rule: rep_of_induct)
    case (base i)
    thus ?case
      apply -
      apply (rule rep_of.domintros)
      apply (cases "i=rep_of l x")
      apply auto
      apply (rule rep_of.domintros)
      apply (auto simp: rep_of_min)
      done
  next
    case (step i)

    from step.prems `ufa_invar l` `i<length l` `l!i\<noteq>i`
    have [simp]: "ufa_union l x y ! i = l!i"
      apply (auto simp: rep_of_min rep_of_bound nth_list_update)
      done

    from step show ?case
      apply -
      apply (rule rep_of.domintros)
      apply simp
      done
  qed
  ultimately show
    "rep_of_dom (ufa_union l x y, i) \<and> ufa_union l x y ! i < length l"
    by blast

qed

lemma ufa_union_aux:
  assumes I: "ufa_invar l"
  assumes L: "x<length l" "y<length l"
  assumes IL: "i<length l"
  shows "rep_of (ufa_union l x y) i =
    (if rep_of l i = rep_of l x then rep_of l y else rep_of l i)"
  using I IL
proof (induct rule: rep_of_induct)
  case (base i)
  have [simp]: "rep_of l i = i" using `l!i=i` by (simp add: rep_of_refl)
  note [simp] = `ufa_invar l` `i<length l`
  show ?case proof (cases)
    assume A[simp]: "rep_of l x = i"
    have [simp]: "l[i := rep_of l y] ! i = rep_of l y"
      by (auto simp: rep_of_bound)

    show ?thesis proof (cases)
      assume [simp]: "rep_of l y = i"
      show ?thesis by (simp add: rep_of_refl)
    next
      assume A: "rep_of l y \<noteq> i"
      have [simp]: "rep_of (l[i := rep_of l y]) i = rep_of l y"
        apply (subst rep_of_step[OF ufa_union_invar[OF I L], simplified])
        using A apply simp_all
        apply (subst rep_of_refl[where i="rep_of l y"])
        using I L
        apply (simp_all add: rep_of_min)
        done
      show ?thesis by (simp add: rep_of_refl)
    qed
  next
    assume A: "rep_of l x \<noteq> i"
    hence "ufa_union l x y ! i = l!i" by (auto)
    also note `l!i=i`
    finally have "rep_of (ufa_union l x y) i = i" by (simp add: rep_of_refl)
    thus ?thesis using A by auto
  qed
next
  case (step i)

  note [simp] = I L `i<length l`

  have "rep_of l x \<noteq> i" by (metis I L(1) rep_of_min `l!i\<noteq>i`)
  hence [simp]: "ufa_union l x y ! i = l!i"
    by (auto simp add: nth_list_update rep_of_bound `l!i\<noteq>i`) []

  have "rep_of (ufa_union l x y) i = rep_of (ufa_union l x y) (l!i)"
    by (auto simp add: rep_of_iff[OF ufa_union_invar[OF I L]])
  also note step.hyps(4)
  finally show ?case
    by (auto simp: rep_of_idx)
qed

lemma ufa_union_correct: "\<lbrakk> ufa_invar l; x<length l; y<length l \<rbrakk>
  \<Longrightarrow> ufa_\<alpha> (ufa_union l x y) = per_union (ufa_\<alpha> l) x y"
  unfolding ufa_\<alpha>_def per_union_def
  by (auto simp: ufa_union_aux
    split: if_split_asm
  )

lemma ufa_compress_aux:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_invar (l[x := rep_of l x])"
  and "\<forall>i<length l. rep_of (l[x := rep_of l x]) i = rep_of l i"
proof -
  {
    fix i
    assume "i<length (l[x := rep_of l x])"
    hence IL: "i<length l" by simp

    have G1: "l[x := rep_of l x] ! i < length (l[x := rep_of l x])"
      using I IL
      by (auto dest: ufa_invarD[OF I] simp: nth_list_update rep_of_bound)
    from I IL have G2: "rep_of (l[x := rep_of l x]) i = rep_of l i
      \<and> rep_of_dom (l[x := rep_of l x], i)"
    proof (induct rule: rep_of_induct)
      case (base i)
      thus ?case
        apply (cases "x=i")
        apply (auto intro: rep_of.domintros simp: rep_of_refl)
        done
    next
      case (step i)
      hence D: "rep_of_dom (l[x := rep_of l x], i)"
        apply -
        apply (rule rep_of.domintros)
        apply (cases "x=i")
        apply (auto intro: rep_of.domintros simp: rep_of_min)
        done

      thus ?case apply simp using step
        apply -
        apply (subst rep_of.psimps[OF D])
        apply (cases "x=i")
        apply (auto simp: rep_of_min rep_of_idx)
        apply (subst rep_of.psimps[where i="rep_of l i"])
        apply (auto intro: rep_of.domintros simp: rep_of_min)
        done
    qed
    note G1 G2
  } note G=this

  thus "\<forall>i<length l. rep_of (l[x := rep_of l x]) i = rep_of l i"
    by auto

  from G show "ufa_invar (l[x := rep_of l x])"
    by (auto simp: ufa_invar_def)
qed

lemma ufa_compress_invar:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_invar (l[x := rep_of l x])"
  using assms by (rule ufa_compress_aux)

lemma ufa_compress_correct:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_\<alpha> (l[x := rep_of l x]) = ufa_\<alpha> l"
  by (auto simp: ufa_\<alpha>_def ufa_compress_aux[OF I])

subsubsection \<open>stuff about the height (by Max Haslbeck)\<close>

function (domintros) height_of
  where "height_of l i = (if l!i = i then 0::nat else 1 + height_of l (l!i))"
  by pat_completeness auto
print_theorems

lemma height_of_dom_rep_of_dom[simp]: "height_of_dom (l, i) = rep_of_dom (l, i)"
  apply(rule)
  subgoal
    apply (induct arbitrary:  rule: height_of.pinduct)
    apply (rule rep_of.domintros) by simp
  subgoal
    apply (induct arbitrary:  rule: rep_of.pinduct)
    apply (rule height_of.domintros) by simp
  done

lemma height_of_step: "ufa_invar l \<Longrightarrow>
         i < length l \<Longrightarrow>
         l ! i \<noteq> i \<Longrightarrow>
          height_of l i = Suc (height_of l (l ! i))"
  by (simp add: height_of.psimps ufa_invarD(1))

definition "h_of l i = Max {height_of l j|j. j<length l \<and> rep_of l j = i}"

definition invar where
  "invar l sl = (length l = length sl
              \<and> sum (\<lambda>i. if l!i=i then sl !i else 0) {0..<length l} = length l
              \<and> (\<forall>i<length l. l!i=i \<longrightarrow> (2::nat) ^ h_of l i \<le> sl ! i))"

lemma invar_sli_le_l:
  assumes "invar l sl" "ufa_invar l" "i<length l"
  shows "sl ! (rep_of l i) \<le> length l"
proof -
  from assms(1) have a: "sum (\<lambda>i. if l!i=i then sl !i else 0) {0..<length l} = length l"
      and len: "length sl = length l" by(auto simp: invar_def)

  let ?r = "(rep_of l i)"
  from assms have "?r<length l" by(auto simp: rep_of_bound)
  then have f: "{0..<length l} = {?r} \<union> ({0..<length l}-{?r})" by auto
  have "sl ! (?r) \<le> sum (\<lambda>i. if l!i=i then sl !i else 0) ({0..<length l}-{?r}) + (if l!?r=?r then sl !?r else 0)"
    using assms by (auto simp: rep_of_min)
  also have "\<dots> = sum (\<lambda>i. if l!i=i then sl !i else 0) {0..<length l}"
    apply(subst (2) f) apply(subst sum_Un_nat) by simp_all
  also have "\<dots> = length l" using a by simp
  finally show "sl ! (rep_of l i) \<le> length l" .
qed

lemma h_rep: "ufa_invar l \<Longrightarrow> y<length l\<Longrightarrow> height_of l (rep_of l y) = 0"
  apply (subst height_of.psimps) subgoal by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar )
  by (simp add: rep_of_min)

lemma ufa_compress_compresses:
  "\<lbrakk>ufa_invar l; i<length l; j<length l\<rbrakk> \<Longrightarrow>
      height_of (l[j:=rep_of l j]) i \<le> height_of l i"
  proof (induct rule: rep_of_induct)
    case (base i)
    then show ?case
      apply(subst height_of.psimps)  subgoal apply simp apply(rule ufa_invarD(1)) by(auto simp add: ufa_compress_invar)
      apply (auto simp add: rep_of_refl)
      by (metis nth_list_update' rep_of_iff)
  next
    case (step i)
    show ?case
      apply(subst height_of.psimps)  subgoal using step by (simp add: ufa_invarD(1) ufa_compress_invar )
      apply auto
      apply(subst (2) height_of.psimps)  subgoal using step by (simp add: rep_of_bound ufa_invarD(1) ufa_compress_invar )
      using step(1-3) apply auto
      apply(cases "i=j")
      subgoal apply simp apply(subst height_of.psimps) subgoal by (simp add: rep_of_bound ufa_compress_invar ufa_invarD(1))
      using rep_of_min by auto
    subgoal apply simp apply(rule step(4)) using step by auto
    done
  qed

lemma ufa_union_on_path_only_increases_by_one:
  "\<lbrakk>ufa_invar l; i<length l; x<length l; y<length l; rep_of l i = rep_of l x\<rbrakk> \<Longrightarrow>
      height_of (ufa_union l x y) i \<le> Suc (height_of l i)"
proof (induct rule: rep_of_induct)
  case (base i)
  then show ?case
    apply(cases "i=rep_of l x")
    subgoal
      apply(subst height_of.psimps)  subgoal by (simp add: ufa_invarD(1) ufa_union_invar )
      apply simp
      apply (auto simp add:   )[]
       apply(subst height_of.psimps) subgoal by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar)
      apply (auto simp: h_rep)[] by(simp add: rep_of_min)
    subgoal
      apply(subst height_of.psimps)  subgoal apply simp
        by (simp add: ufa_invarD(1) ufa_union_invar)
      by simp
    done
next
  case (step i)
  then have not: "i\<noteq>rep_of l x"
    using rep_of_min by blast

  show ?case
    apply(subst height_of.psimps)  subgoal using step by (simp add: ufa_invarD(1) ufa_union_invar )
    using not apply simp
    apply(subst (2) height_of.psimps)  subgoal using step by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar )
    apply simp apply safe
     apply(rule step(4)) using step
    by (auto simp add: rep_of_idx)
qed

lemma ufa_union_not_on_path_stays:
  "\<lbrakk>ufa_invar l; i<length l; x<length l; y<length l; rep_of l i \<noteq> rep_of l x\<rbrakk> \<Longrightarrow>
      height_of (ufa_union l x y) i = height_of l i"
proof (induct rule: rep_of_induct)
  case (base i)
  then show ?case
    apply(cases "i=rep_of l x")
    subgoal
      by (auto simp add:  h_rep  rep_of_iff)
    subgoal
      apply(subst height_of.psimps)  subgoal apply simp
        by (simp add: ufa_invarD(1) ufa_union_invar)
      apply auto
      apply(subst height_of.psimps)  subgoal apply simp
        by (simp add: ufa_invarD(1) ufa_union_invar)
      by simp
    done
next
  case (step i)
  then have not: "i\<noteq>rep_of l x"
    using rep_of_min by blast

  show ?case
    apply(subst height_of.psimps)  subgoal using step by (simp add: ufa_invarD(1) ufa_union_invar )
    using not step(1-3) apply auto
    apply(subst (2) height_of.psimps)  subgoal using step by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar )
    apply simp
     apply(rule step(4)) using step
    by (auto simp add: rep_of_idx)
qed

lemma ufa_union_on_path:
"\<lbrakk>ufa_invar l; i<length l; x<length l; y<length l\<rbrakk> \<Longrightarrow>
      height_of (ufa_union l x y) i \<le> Suc (height_of l i)"
  proof (induct rule: rep_of_induct)
    case (base i)
    then show ?case
      apply(cases "i=rep_of l x")
      subgoal
      apply(subst height_of.psimps)  subgoal by (simp add: ufa_invarD(1) ufa_union_invar )
      apply (auto simp add:   )[]
        apply(subst height_of.psimps) subgoal by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar)
        apply auto[] by(simp add: rep_of_min)
      subgoal
        apply(subst height_of.psimps)  subgoal apply simp
          by (simp add: ufa_invarD(1) ufa_union_invar)
        by simp
      done
  next
    case (step i)
    then have not: "i\<noteq>rep_of l x"
      using rep_of_min by blast

    show ?case
      apply(subst height_of.psimps)  subgoal using step by (simp add: ufa_invarD(1) ufa_union_invar )
      using not apply simp
      apply(subst (2) height_of.psimps)  subgoal using step by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar )
      apply simp apply safe
      apply(rule step(4)) using step by auto
  qed

lemma hel: "(\<And>x. x\<in>A \<Longrightarrow> f x \<le> g x) \<Longrightarrow> finite A  \<Longrightarrow> Max (f ` A) \<le> Max (g ` A)"
  by (smt Max_ge_iff Max_in finite_imageI imageE image_eqI image_is_empty order_refl)
lemma MAXIMUM_mono: "(\<And>x. x\<in>A \<Longrightarrow> f x \<le> g x) \<Longrightarrow> finite A  \<Longrightarrow> A = B \<Longrightarrow> Max (f ` A) \<le> Max (g ` B)"
  using hel by blast
lemma MAXIMUM_eq: "(\<And>x. x\<in>A \<Longrightarrow> f x = g x) \<Longrightarrow> finite A  \<Longrightarrow> A = B \<Longrightarrow> Max (f ` A) =  Max (g ` B)"
  apply(rule antisym) by  (auto intro: MAXIMUM_mono)

lemma h_of_alt: "h_of l i = Max ((height_of l) ` {j|j. j<length l \<and> rep_of l j = i})"
  unfolding h_of_def
  by (simp add: setcompr_eq_image)

lemma h_of_compress: "ufa_invar l \<Longrightarrow> j < length l \<Longrightarrow> h_of (l[j:=rep_of l j]) i \<le>  h_of l i"
  unfolding h_of_alt
  apply(rule MAXIMUM_mono)
  subgoal apply(rule ufa_compress_compresses) by auto
  by (auto simp add: ufa_compress_aux(2))

lemma h_of_uf_union_untouched:
  "ufa_invar l \<Longrightarrow> x < length l \<Longrightarrow> y < length l \<Longrightarrow> i < length l \<Longrightarrow> l!i = i
    \<Longrightarrow> i \<noteq> rep_of l x \<Longrightarrow> i \<noteq> rep_of l y   \<Longrightarrow> h_of (ufa_union l x y) i = h_of l i"
  unfolding h_of_alt
  apply(rule MAXIMUM_eq)
  subgoal apply(rule ufa_union_not_on_path_stays)
    using ufa_union_aux by auto
  using ufa_union_aux by auto

lemma Suc_h_of: assumes
  a:  "i < length l " "rep_of l i = i"
  shows
  "Suc (h_of l i) = Max ((\<lambda>j. Suc (height_of l j)) ` {j|j. j<length l \<and> rep_of l j = i}) "
  unfolding h_of_alt
  apply(subst  mono_Max_commute[where f=Suc])
  subgoal by (simp add: mono_Suc)
  subgoal by simp
  subgoal using a by auto
  by (simp add: image_image)

lemma MAXIMUM_Un: "finite A \<Longrightarrow> finite B \<Longrightarrow> A \<noteq> {} \<Longrightarrow> B \<noteq> {}
  \<Longrightarrow> Max (f` (A \<union> B) ) = max (Max (f`A)) (Max (f`B) )"
  apply(simp add: image_Un)
  apply(subst Max_Un) by auto

lemma fixes A::nat
  shows "A\<le>A' \<Longrightarrow> B\<le>B' \<Longrightarrow> max A B \<le> max A' B'"
  by auto

lemma h_of_uf_union_id:
  assumes "ufa_invar l "" x < length l "" y < length l "" i < length l "
    " rep_of l i = i" "i = rep_of l y" and neq: "rep_of l y = rep_of l x"
  shows "h_of (ufa_union l x y) i = h_of l i"
  using neq apply simp using assms
  by (metis list_update_id rep_of_min)

lemma h_of_uf_union_touched:
  assumes "ufa_invar l "" x < length l "" y < length l "" i < length l "
    " rep_of l i = i" "i = rep_of l y" and neq: "rep_of l y \<noteq> rep_of l x"
  shows "h_of (ufa_union l x y) i \<le> max (h_of l (rep_of l y)) (Suc (h_of l (rep_of l x)))"
proof -
  have *: "{j|j. j<length (ufa_union l x y) \<and> rep_of (ufa_union l x y) j = i}
      = {j|j. j<length (ufa_union l x y) \<and> rep_of (ufa_union l x y) j = i \<and> rep_of l j = rep_of l y}
          \<union> {j|j. j<length (ufa_union l x y) \<and> rep_of (ufa_union l x y) j = i \<and> rep_of l j = rep_of l x}" (is "_ = ?A \<union> ?B")
    apply auto using assms
    by (simp add: ufa_union_aux)

  have A: "?A = {j |j. j < length l \<and> rep_of l j = rep_of l y}"
    using ufa_union_aux assms by auto
  have B: "?B = {j |j. j < length l \<and> rep_of l j = rep_of l x}"
    using ufa_union_aux assms by auto

  have "h_of (ufa_union l x y) i = Max ( (height_of (ufa_union l x y)) `{j|j. j<length (ufa_union l x y) \<and> rep_of (ufa_union l x y) j = i})"
    unfolding h_of_alt by simp
  also have "\<dots> = Max ((height_of (ufa_union l x y))` (?A \<union> ?B) )"
    unfolding * by simp
  also have "\<dots> = max (Max ( (height_of (ufa_union l x y))`?A)) (Max ( (height_of (ufa_union l x y))`?B))"
    apply(subst MAXIMUM_Un) apply simp_all
    subgoal  apply(rule exI[where x=y]) using assms by (simp add: ufa_union_aux)
    subgoal  apply(rule exI[where x=x]) using assms by (simp add: ufa_union_aux)
    done
  also have "\<dots> \<le> max (Max ( (height_of l) ` ?A)) (Max ( (\<lambda>j. Suc (height_of l j)) `?B))"
    apply(rule max.mono)
    subgoal apply(rule MAXIMUM_mono)
      subgoal apply(rule order_eq_refl) apply(rule ufa_union_not_on_path_stays) using assms by auto
      by simp_all
    subgoal apply(rule MAXIMUM_mono)
      subgoal apply(rule ufa_union_on_path)  using assms by auto
       apply simp by simp
    done
  also have "\<dots> \<le> max  (h_of l (rep_of l y)) (Suc (h_of l (rep_of l x)))"
    apply(rule max.mono)
    subgoal unfolding h_of_alt A by simp
    subgoal apply(subst Suc_h_of)
      subgoal using assms by (auto simp: rep_of_min rep_of_bound rep_of_refl)
      subgoal using assms by (auto simp: rep_of_min rep_of_bound rep_of_refl)
      unfolding B by simp
    done
  finally show ?thesis .
qed

lemma height_of_le_h_of: "i < length l \<Longrightarrow> height_of l i \<le> h_of l (rep_of l i)"
    unfolding h_of_def apply(rule Max.coboundedI) apply simp
    apply(subst setcompr_eq_image) apply(rule imageI)
    by auto

lemma height_of_ub: assumes "invar l sl" "ufa_invar l" "i<length l"
  shows "2 ^ (height_of l i) \<le> length l"
proof -
  from assms(1) have "length l = length sl "
            and 2:  "sum (\<lambda>i. if l!i=i then sl !i else 0) {0..<length l} = length l"
            and 3:  "\<And>i. i<length l \<Longrightarrow>  l!i=i \<Longrightarrow> (2::nat) ^ h_of l i \<le> sl ! i"
    unfolding invar_def  by auto

  have *: "height_of l i \<le> h_of l (rep_of l i)"
    using assms by (auto intro: height_of_le_h_of)

  have "(2::nat) ^ (height_of l i) \<le> 2 ^ (h_of l (rep_of l i))"
    apply(rule power_increasing) apply(rule *) by simp
  also have "\<dots> \<le> sl ! (rep_of l i)"
   using 3 assms by(auto simp add: rep_of_bound rep_of_min )
  also have "\<dots> \<le> length l" using assms
    by (auto simp: rep_of_bound intro: invar_sli_le_l)
  finally show ?thesis .
qed

subsection {* Implementation with Imperative/HOL *}
text {* In this section, we implement the union-find data-structure with
  two arrays, one holding the next-pointers, and another one holding the size
  information. Note that we do not prove that the array for the
  size information contains any reasonable values, as the correctness of the
  algorithm is not affected by this. We leave it future work to also estimate
  the complexity of the algorithm.
*}

type_synonym uf = "nat array \<times> nat array"

definition is_uf :: "(nat\<times>nat) set \<Rightarrow> uf \<Rightarrow> assn" where
  "is_uf R u \<equiv> case u of (s,p) \<Rightarrow>
  \<exists>\<^sub>Al szl. p\<mapsto>\<^sub>al * s\<mapsto>\<^sub>aszl
    * \<up>(ufa_invar l \<and> ufa_\<alpha> l = R \<and> length szl = length l \<and> invar l szl)"

definition uf_init :: "nat \<Rightarrow> uf Heap" where
  "uf_init n \<equiv> do {
    l \<leftarrow> Array_Time.of_list [0..<n];
    szl \<leftarrow> Array_Time.new n (1::nat);
    return (szl,l)
  }"

lemma of_list_rule':
    "<$ (1 + n)> Array_Time.of_list [0..<n] <\<lambda>r. r \<mapsto>\<^sub>a [0..<n]>"
  using of_list_rule[of "[0..<n]"] by auto

lemma height_of_init: "j<n \<Longrightarrow> height_of [0..<n] j = 0"
  by (simp add: height_of.psimps ufa_init_invar ufa_invarD(1))

lemma h_of_init: "i < n \<Longrightarrow> h_of [0..<n] i = 0"
  unfolding h_of_def apply auto
  apply(rule antisym)
  subgoal apply(rule Max.boundedI)
     apply simp
    using ufa_init_invar apply auto apply(rule exI[where x=i]) apply simp
    subgoal
      by (simp add: rep_of_refl)
    apply(rule height_of_init) by simp
  by simp

lemma ufa_init_invar': "invar [0..<n] (replicate n (Suc 0))"
  unfolding invar_def apply auto using h_of_init by auto

definition uf_init_time :: "nat \<Rightarrow> nat" where "uf_init_time n == (2*n+3)"

lemma uf_init_bound[asym_bound]: "uf_init_time \<in> \<Theta>(\<lambda>n. n)"
  unfolding uf_init_time_def by auto2

lemma uf_init_rule:
  "<$(uf_init_time n)> uf_init n <is_uf {(i,i) |i. i<n}>\<^sub>t"
  unfolding uf_init_time_def uf_init_def is_uf_def[abs_def]
  by (sep_auto simp: ufa_init_correct ufa_init_invar ufa_init_invar' zero_time heap: of_list_rule')

partial_function (heap_time) uf_rep_of :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap"
  where [code]:
  "uf_rep_of p i = do {
    n \<leftarrow> Array_Time.nth p i;
    if n=i then return i else uf_rep_of p n
  }"

lemma uf_rep_of_rule: "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al * $(height_of l i + 2)> uf_rep_of p i <\<lambda>r. p\<mapsto>\<^sub>al * \<up>(r=rep_of l i)>\<^sub>t"
  apply (induct rule: rep_of_induct)
  apply (subst uf_rep_of.simps)
  apply (sep_auto simp: rep_of_refl)

  apply (subst uf_rep_of.simps)
  apply (sep_auto simp: rep_of_step height_of_step)
  done

text {* We chose a non tail-recursive version here, as it is easier to prove. *}
partial_function (heap_time) uf_compress :: "nat \<Rightarrow> nat \<Rightarrow> nat array \<Rightarrow> unit Heap"
  where [code]:
  "uf_compress i ci p = (
    if i=ci then return ()
    else do {
      ni\<leftarrow>Array_Time.nth p i;
      uf_compress ni ci p;
      Array_Time.upd i ci p;
      return ()
    })"

lemma compress_invar:
  assumes "invar l szl"
    "ufa_invar l" "i<length l"
  shows "invar (l[i := rep_of l i]) szl"
  using assms unfolding invar_def
  apply safe
  subgoal by simp
  subgoal apply simp
    by (smt nth_list_update_eq nth_list_update_neq rep_of_iff rep_of_min sum.ivl_cong)
  subgoal for i
    apply(rule order.trans)
    apply(rule power_increasing[where N="h_of l i"])
    subgoal apply(rule h_of_compress) by auto
     apply simp
    apply simp
    by (metis nth_list_update_eq nth_list_update_neq rep_of_min)
  done

lemma uf_compress_rule: "\<lbrakk> ufa_invar l; i<length l; ci=rep_of l i; invar l szl \<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al *  $(1+height_of l i*3)> uf_compress i ci p
  <\<lambda>_. (\<exists>\<^sub>Al'. p\<mapsto>\<^sub>al' * \<up>(invar l' szl \<and> ufa_invar l' \<and> length l' = length l
     \<and> (\<forall>i<length l. rep_of l' i = rep_of l i)))>\<^sub>t"
proof (induction rule: rep_of_induct)
  case (base i) thus ?case
    apply (subst uf_compress.simps)
    apply (sep_auto simp: rep_of_refl)
    done
next
  case (step i)
  note SS = `ufa_invar l` `i<length l` `l!i\<noteq>i` `ci = rep_of l i` `invar l szl`

  have IH':
    "<p \<mapsto>\<^sub>a l * $ (1 + height_of l (l ! i) *3)>
       uf_compress (l ! i) (rep_of l i) p
     <\<lambda>_.  (\<exists>\<^sub>Al'. p \<mapsto>\<^sub>a l' *
        \<up> (invar l' szl \<and>ufa_invar l' \<and> length l' = length l
           \<and> (\<forall>i<length l'. rep_of l i = rep_of l' i)))
     >\<^sub>t"
    apply(rule pre_rule[OF _ post_rule[OF step.IH[simplified SS rep_of_idx] ]] )
    by (sep_auto simp add: rep_of_idx SS)+

  show ?case
    apply (subst uf_compress.simps)
    apply (sep_auto simp: SS height_of_step heap: )
    apply(sep_auto heap: IH')

    using SS apply (sep_auto  )
    subgoal using compress_invar by simp
    subgoal using ufa_compress_invar by fastforce
    subgoal by simp
    subgoal using ufa_compress_aux(2) by fastforce
    done
qed

definition uf_rep_of_c :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap"
  where "uf_rep_of_c p i \<equiv> do {
    ci\<leftarrow>uf_rep_of p i;
    uf_compress i ci p;
    return ci
  }"

lemma uf_rep_of_c_rule: "\<lbrakk>ufa_invar l; i<length l; invar l szl\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al * $(4+height_of l i*4)> uf_rep_of_c p i <\<lambda>r.  (\<exists>\<^sub>Al'. p\<mapsto>\<^sub>al'
    * \<up>(r=rep_of l i \<and> ufa_invar l' \<and> invar l' szl
       \<and> length l' = length l
       \<and> (\<forall>i<length l. rep_of l' i = rep_of l i)))>\<^sub>t"
  unfolding uf_rep_of_c_def
  by (sep_auto heap: uf_compress_rule uf_rep_of_rule)

thm height_of_ub

definition height_ub :: "nat \<Rightarrow> nat" where "height_ub n = nat (ceiling (log 2 n))"

lemma height_ub_bound[asym_bound]: "height_ub \<in> \<Theta>(\<lambda>n. ln n)"
  unfolding height_ub_def using abcd_lnx[of 0 1 1 0] by auto

lemma height_ub:
  assumes "invar l sl" "ufa_invar l" "i<length l"
  shows "height_of l i \<le> height_ub (length l)"
proof -
  from height_of_ub[OF assms] have "2 ^ height_of l i \<le> length l" .
  from le_log2_of_power[OF this]
    show ?thesis unfolding height_ub_def by linarith
  qed

lemma uf_rep_of_c_rule_ub:
  assumes "ufa_invar l"  "i<length l" "invar l szl"
  shows "<p\<mapsto>\<^sub>al * $(4+ height_ub (length l)*4)> uf_rep_of_c p i <\<lambda>r. (\<exists>\<^sub>Al'. p\<mapsto>\<^sub>al'
    * \<up>(r=rep_of l i \<and> ufa_invar l' \<and> invar l' szl
       \<and> length l' = length l
       \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))) >\<^sub>t"
proof -
  from assms height_ub have "height_of l i \<le> height_ub (length l)" by auto
  then obtain x where p: "height_ub (length l) = height_of l i + x"
    using le_Suc_ex by blast
  show ?thesis unfolding p
    using assms by(sep_auto heap: uf_rep_of_c_rule)
qed

definition uf_cmp :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool Heap" where
  "uf_cmp u i j \<equiv> do {
    let (s,p)=u;
    n\<leftarrow>Array_Time.len p;
    if (i\<ge>n \<or> j\<ge>n) then return False
    else do {
      ci\<leftarrow>uf_rep_of_c p i;
      cj\<leftarrow>uf_rep_of_c p j;
      return (ci=cj)
    }
  }"

lemma cnv_to_ufa_\<alpha>_eq:
  "\<lbrakk>(\<forall>i<length l. rep_of l' i = rep_of l i); length l = length l'\<rbrakk>
  \<Longrightarrow> (ufa_\<alpha> l = ufa_\<alpha> l')"
  unfolding ufa_\<alpha>_def by auto

lemma "  card (Domain (ufa_\<alpha> l)) = length l"
  by simp

definition uf_cmp_time :: "nat \<Rightarrow> nat" where "uf_cmp_time n = 10+ height_ub n*8"

lemma uf_cmp_time_bound[asym_bound]:
  "uf_cmp_time \<in> \<Theta>(\<lambda>n. ln n)" unfolding uf_cmp_time_def by auto2

lemma uf_cmp_rule:
  "<is_uf R u * $(uf_cmp_time (card (Domain R)))> uf_cmp u i j <\<lambda>r. is_uf R u * \<up>(r\<longleftrightarrow>(i,j)\<in>R)>\<^sub>t"
  unfolding uf_cmp_def is_uf_def uf_cmp_time_def
  apply (sep_auto heap: uf_rep_of_c_rule_ub length_rule dest: ufa_\<alpha>_lenD simp: not_le split: prod.split)
  (* problem here is, that timeframeinference does not work under equalities.
      length l' = length l  is not used when infering the timeframe *)
   apply(rule fi_rule[OF uf_rep_of_c_rule_ub]) defer defer defer
      apply(simp only: mult.assoc)
      apply(rule match_first)
      apply simp
      apply(time_frame_inference)
     defer apply simp apply simp apply simp
  apply(sep_auto)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (subst ufa_find_correct)
  by (auto simp add: )

definition uf_union :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> uf Heap" where
  "uf_union u i j \<equiv> do {
    let (s,p)=u;
    ci \<leftarrow> uf_rep_of p i;
    cj \<leftarrow> uf_rep_of p j;
    if (ci=cj) then return (s,p)
    else do {
      si \<leftarrow> Array_Time.nth s ci;
      sj \<leftarrow> Array_Time.nth s cj;
      if si<sj then do {
        Array_Time.upd ci cj p;
        Array_Time.upd cj (si+sj) s;
        return (s,p)
      } else do {
        Array_Time.upd cj ci p;
        Array_Time.upd ci (si+sj) s;
        return (s,p)
      }
    }
  }"

lemma uf_rep_of_rule_ub: assumes "ufa_invar l" "i<length l"  "invar l szl"
  shows "<p\<mapsto>\<^sub>al * $(height_ub (length l) + 2)> uf_rep_of p i <\<lambda>r. p\<mapsto>\<^sub>al * \<up>(r=rep_of l i)>\<^sub>t"
proof -
  from assms height_ub have "height_of l i \<le> height_ub (length l)" by auto
  then obtain x where p: "height_ub (length l) = height_of l i + x"
    using le_Suc_ex by blast
  show ?thesis unfolding p
    using assms by(sep_auto heap: uf_rep_of_rule)
qed

lemma 12:
  assumes "i < length l " "j < length l"
       "ufa_invar l " "(i, j) \<notin> ufa_\<alpha> l "
     and size:  "szl ! rep_of l i < szl ! rep_of l j  "
  and i:  "invar l szl "
      shows "invar (ufa_union l i j) (szl[rep_of l j := szl ! rep_of l i + szl ! rep_of l j])"
proof -
  let ?upd = "ufa_union l i j"

  from i have [simp]: "length szl = length l" unfolding invar_def by auto

  { fix a b and f :: "'a\<Rightarrow>nat" have r: "a\<noteq>b \<Longrightarrow> sum f {a,b}   = f a + f b" by simp     }
  note ff=this

  have *: "{0..<length l} = ({0..<length l}-{rep_of l j}) \<union> {rep_of l j}"
    using assms rep_of_bound by auto
  have **:"{0..<length l} = ({0..<length l}-{rep_of l i,rep_of l j}) \<union> {rep_of l i,rep_of l j}"
    using assms rep_of_bound by auto

  have ss: "(({0..<length l} - {rep_of l j}) \<inter> {ia. ?upd ! ia = ia})
        = ({0..<length l}-{rep_of l i,rep_of l j}) \<inter> {ia. l ! ia = ia}" using assms by (auto simp: nth_list_update')

  have "(\<Sum>ia = 0..<length l. if ?upd ! ia = ia then szl[rep_of l j := szl ! rep_of l i + szl ! rep_of l j] ! ia else 0)
     = sum (\<lambda>ia. if ?upd ! ia = ia then szl[rep_of l j := szl ! rep_of l i + szl ! rep_of l j] ! ia else 0) ({0..<length l}-{rep_of l j})
            + (szl ! rep_of l i + szl ! rep_of l j)" (is "?A = _")
    apply(subst *)  apply(subst sum_Un_nat) apply simp apply simp apply simp
    apply safe
    subgoal using assms rep_of_bound
      using invar_def by fastforce
    subgoal using assms
      by (simp add: rep_of_min ufa_find_correct)
    subgoal using assms
      by (simp add: rep_of_min ufa_find_correct)
    done
  also have "\<dots> = sum (\<lambda>i. if l ! i = i then szl ! i else 0)
                         ({0..<length l}-{rep_of l i,rep_of l j})
               + (szl ! rep_of l i + szl ! rep_of l j)" (is "?L + _ = ?R + _")
  proof -
    have "?L = sum (\<lambda>ia. szl[rep_of l j := szl ! rep_of l i + szl ! rep_of l j] ! ia)
                 (({0..<length l}-{rep_of l j})\<inter>{ia. ?upd ! ia = ia})"
      apply(subst sum.inter_restrict) by simp_all
    also have "\<dots> = sum (\<lambda>ia. szl[rep_of l j := szl ! rep_of l i + szl ! rep_of l j] ! ia)
                 (({0..<length l}-{rep_of l i,rep_of l j}) \<inter> {ia. l ! ia = ia})"
      unfolding ss by simp
    also have "\<dots> = ?R"
      apply(subst sum.inter_restrict) apply simp apply auto apply(rule sum.cong) apply simp using assms by auto
    finally have "?L = ?R" .
    then show ?thesis by simp
  qed
  also have "\<dots> = (\<Sum>i = 0..<length l. if l ! i = i then szl ! i else 0)"
    apply(subst (2) **) apply(subst sum_Un_nat) apply simp apply simp apply simp
    apply(subst ff) using assms apply (auto simp: rep_of_min)
    done
  also from i have "\<dots> = length l" unfolding invar_def by auto
  finally have A: "?A = length l" .

  have max_distrib: "\<And>a b :: nat. (2::nat) ^ max a b = max (2 ^ a) (2 ^ b)"
    by (simp add: max_def)
  {
    assume a: "rep_of l j < length szl" "?upd ! rep_of l j = rep_of l j"

    from i have g: "\<And>i. i<length l \<Longrightarrow> l ! i = i \<Longrightarrow> 2 ^ h_of l i \<le> szl ! i" unfolding invar_def by metis

    have "(2::nat) ^ (max (h_of l (rep_of l j)) (Suc (h_of l (rep_of l i))))
          \<le> max ( (szl ! (rep_of l j))) (2 * (szl ! (rep_of l i)))"
      apply(subst max_distrib)
      apply(rule max.mono)
      subgoal apply(rule g) using assms a by (auto simp: rep_of_min)
      subgoal apply(simp only: power.power_Suc) apply(rule mult_left_mono)
        apply(rule g) using assms a by (auto simp: rep_of_refl rep_of_min rep_of_bound)
      done
    also have "\<dots> \<le> szl ! rep_of l i + szl ! rep_of l j"
      using size by auto
    finally
    have "2 ^ max (h_of l (rep_of l j)) (Suc (h_of l (rep_of l i))) \<le> szl ! rep_of l i + szl ! rep_of l j"
      .
  } note absch = this

  show ?thesis unfolding invar_def
    apply safe
    subgoal using i[unfolded invar_def] by simp
    subgoal apply simp using A by simp
    subgoal for i apply(cases "i=rep_of l j")
      subgoal apply simp
        apply(rule order.trans)
         apply(rule power_increasing[OF h_of_uf_union_touched])
                prefer 9
        subgoal using absch by simp
        using assms by (auto simp: rep_of_idem)
      subgoal
        apply simp apply(subst h_of_uf_union_untouched)
               prefer 8 subgoal
          using i unfolding invar_def
          by (metis nth_list_update')
        using assms apply (auto simp: rep_of_idem )
        by (metis nth_list_update')
      done
    done
qed

lemma 21:
  assumes "i < length l "" j < length l ""
       ufa_invar l "
       "(i, j) \<notin> ufa_\<alpha> l "
   and size: "\<not> szl ! rep_of l i < szl ! rep_of l j  "
  and i: "invar l szl "
      shows "invar (ufa_union l j i) (szl[rep_of l i := szl ! rep_of l i + szl ! rep_of l j])"
proof -
  let ?upd = "ufa_union l j i"

  from i have [simp]: "length szl = length l" unfolding invar_def by auto

  { fix a b and f :: "'a\<Rightarrow>nat" have r: "a\<noteq>b \<Longrightarrow> sum f {a,b}   = f a + f b" by simp     }
  note ff=this

  have *: "{0..<length l} = ({0..<length l}-{rep_of l i}) \<union> {rep_of l i}"
    using assms rep_of_bound by auto
  have **:"{0..<length l} = ({0..<length l}-{rep_of l i,rep_of l j}) \<union> {rep_of l i,rep_of l j}"
    using assms rep_of_bound by auto

  have ss: "(({0..<length l} - {rep_of l i}) \<inter> {ia. ?upd ! ia = ia})
        = ({0..<length l}-{rep_of l i,rep_of l j}) \<inter> {ia. l ! ia = ia}" using assms by (auto simp: nth_list_update')

  have "(\<Sum>ia = 0..<length l. if ?upd ! ia = ia then szl[rep_of l i := szl ! rep_of l i + szl ! rep_of l j] ! ia else 0)
     = sum (\<lambda>ia. if ?upd ! ia = ia then szl[rep_of l i := szl ! rep_of l i + szl ! rep_of l j] ! ia else 0) ({0..<length l}-{rep_of l i})
            + (szl ! rep_of l i + szl ! rep_of l j)" (is "?A = _")
    apply(subst *)  apply(subst sum_Un_nat) apply simp apply simp apply simp
    apply safe
    subgoal using assms rep_of_bound
      using invar_def by fastforce
    subgoal using assms
      using rep_of_min ufa_find_correct by fastforce
    subgoal using assms
      using rep_of_min ufa_find_correct by fastforce
    done
  also have "\<dots> = sum (\<lambda>i. if l ! i = i then szl ! i else 0)
                         ({0..<length l}-{rep_of l i,rep_of l j})
               + (szl ! rep_of l i + szl ! rep_of l j)" (is "?L + _ = ?R + _")
  proof -
    have "?L = sum (\<lambda>ia. szl[rep_of l i := szl ! rep_of l i + szl ! rep_of l j] ! ia)
                 (({0..<length l}-{rep_of l i})\<inter>{ia. ?upd ! ia = ia})"
      apply(subst sum.inter_restrict) by simp_all
    also have "\<dots> = sum (\<lambda>ia. szl[rep_of l i := szl ! rep_of l i + szl ! rep_of l j] ! ia)
                 (({0..<length l}-{rep_of l i,rep_of l j}) \<inter> {ia. l ! ia = ia})"
      unfolding ss by simp
    also have "\<dots> = ?R"
      apply(subst sum.inter_restrict) apply simp apply auto apply(rule sum.cong) apply simp using assms by auto
    finally have "?L = ?R" .
    then show ?thesis by simp
  qed
  also have "\<dots> = (\<Sum>i = 0..<length l. if l ! i = i then szl ! i else 0)"
    apply(subst (2) **) apply(subst sum_Un_nat) apply simp apply simp apply simp
    apply(subst ff) using assms apply (auto simp: rep_of_min)
    using ufa_find_correct by blast
  also from i have "\<dots> = length l" unfolding invar_def by auto
  finally have A: "?A = length l" .

  have max_distrib: "\<And>a b :: nat. (2::nat) ^ max a b = max (2 ^ a) (2 ^ b)"
    by (simp add: max_def)
  {
    assume a: "rep_of l i < length szl" "?upd ! rep_of l i = rep_of l i"

    from i have g: "\<And>i. i<length l \<Longrightarrow> l ! i = i \<Longrightarrow> 2 ^ h_of l i \<le> szl ! i" unfolding invar_def by metis

    have "(2::nat) ^ (max (h_of l (rep_of l i)) (Suc (h_of l (rep_of l j))))
          \<le> max ( (szl ! (rep_of l i))) (2 * (szl ! (rep_of l j)))"
      apply(subst max_distrib)
      apply(rule max.mono)
      subgoal apply(rule g) using assms a by (auto simp: rep_of_min)
      subgoal apply(simp only: power.power_Suc) apply(rule mult_left_mono)
        apply(rule g) using assms a by (auto simp: rep_of_refl rep_of_min rep_of_bound)
      done
    also have "\<dots> \<le> szl ! rep_of l i + szl ! rep_of l j"
      using size by auto
    finally
    have "2 ^ max (h_of l (rep_of l i)) (Suc (h_of l (rep_of l j))) \<le> szl ! rep_of l i + szl ! rep_of l j"
      .
  } note absch = this

  show ?thesis unfolding invar_def
    apply safe
    subgoal using i[unfolded invar_def] by simp
    subgoal apply simp using A by simp
    subgoal for e apply(cases "e=rep_of l i")
      subgoal apply simp
        apply(rule order.trans)
         apply(rule power_increasing[OF h_of_uf_union_touched])
                prefer 9
        subgoal using absch by simp
        using assms by (auto simp: rep_of_idem ufa_find_correct)
      subgoal
        apply simp apply(subst h_of_uf_union_untouched)
               prefer 8 subgoal
          using i unfolding invar_def
          by (metis nth_list_update')
        using assms apply (auto simp: rep_of_idem )
        by (metis nth_list_update')
      done
    done
qed

lemma uf_union_rule': "\<lbrakk>i\<in>Domain R; j\<in> Domain R\<rbrakk>
  \<Longrightarrow> <is_uf R u * $(11+ height_ub (card (Domain R))*2)> uf_union u i j <is_uf (per_union R i j)>\<^sub>t"
  unfolding uf_union_def
  apply (cases u)
  apply (simp add: is_uf_def[abs_def])
  apply(sep_auto heap: uf_rep_of_rule_ub)
    apply(simp add: ufa_\<alpha>_lenD)
  apply simp
  apply(sep_auto heap: uf_rep_of_rule_ub)
    apply(simp add: ufa_\<alpha>_lenD)
   apply simp
  apply (sep_auto
    simp: per_union_cmp ufa_\<alpha>_lenD ufa_find_correct
    rep_of_bound
    ufa_union_invar
    ufa_union_correct
  )
  subgoal apply(drule ufa_\<alpha>_lenD) apply(drule ufa_\<alpha>_lenD) using 12 by blast
  apply (sep_auto
    simp: per_union_cmp ufa_\<alpha>_lenD ufa_find_correct
    rep_of_bound
    ufa_union_invar
    ufa_union_correct
  )
  subgoal apply(drule ufa_\<alpha>_lenD) apply(drule ufa_\<alpha>_lenD) using 21 by blast
  done

definition "uf_union_time n = 11+ height_ub n*2"

lemma uf_union_time_bound[asym_bound]: "uf_union_time \<in> \<Theta>(\<lambda>n. ln n)"
  unfolding uf_union_time_def by auto2

lemma uf_union_rule: "\<lbrakk>i\<in>Domain R; j\<in> Domain R\<rbrakk>
  \<Longrightarrow> <is_uf R u * $(uf_union_time (card (Domain R)))> uf_union u i j <is_uf (per_union R i j)>\<^sub>t"
  unfolding uf_union_time_def using uf_union_rule' by auto

interpretation UF_log: UnionFind_Impl is_uf uf_init uf_init_time uf_cmp uf_cmp_time uf_union uf_union_time
proof (unfold_locales, goal_cases)
case (1 t x' x)
  show ?case
    unfolding PR_CONST_def mop_per_init_def apply simp
    apply(rule extract_cost_otherway'[OF _ uf_init_rule, where Cost_lb="uf_init_time x"])
      apply (sep_auto simp: per_init'_def hn_ctxt_def pure_def)+
    using 1 by simp
next
  case (2 t R' R a' a b' b)
   show ?case
    unfolding PR_CONST_def mop_per_compare_def apply simp
    apply(rule extract_cost_otherway'[OF _ uf_cmp_rule, where Cost_lb="(uf_cmp_time (card (Domain R')))"])
      apply (sep_auto simp: per_init'_def hn_ctxt_def pure_def)+
    using 2 by simp
next
  case (3  t R' R a' a b' b)
   show ?case
    unfolding PR_CONST_def mop_per_union_def apply simp
    apply(rule extract_cost_otherway'[OF _ uf_union_rule, where Cost_lb="(uf_union_time (card (Domain R')))"])
        apply (sep_auto simp: per_init'_def hn_ctxt_def pure_def)+
    subgoal using 3 by simp
      apply (sep_auto simp: per_init'_def hn_ctxt_def pure_def)+
    subgoal using 3 by simp
      apply (sep_auto simp: per_init'_def hn_ctxt_def pure_def invalid_assn_def)+
    using 3 by simp
qed

end


theory ex_LFUs
  imports topo_derivative_algebra sse_operation_negative
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Example application: Logics of Formal Undeterminedness (LFUs)\<close>
text\<open>\noindent{The LFUs @{cite LFU} @{cite LFI} are a family of paracomplete logics featuring a 'determinedness'
operator @{text "\<^bold>\<circ>"} that can be used to recover some classical properties of negation (in particular TND).
LFUs behave in a sense dually to LFIs. Both can be semantically embedded as extensions of Boolean algebras.
Here we show how to semantically embed LFUs as derivative algebras.}\<close>

text\<open>\noindent{(We rename (classical) meta-logical negation to avoid terminological confusion)}\<close>
abbreviation cneg::"bool\<Rightarrow>bool" ("\<sim>_" [40]40) where "\<sim>\<phi> \<equiv> \<not>\<phi>"

text\<open>\noindent{Logical validity can be defined as truth in all worlds/points (i.e. as denoting the top element)}\<close>
abbreviation gtrue::"\<sigma>\<Rightarrow>bool" ("[\<^bold>\<turnstile> _]") where  "[\<^bold>\<turnstile>  A] \<equiv> \<forall>w. A w"
lemma gtrue_def: "[\<^bold>\<turnstile> A] \<equiv> A \<^bold>\<approx> \<^bold>\<top>"  by (simp add: top_def)

text\<open>\noindent{As for LFIs, we focus on the local (truth-degree preserving) notion of logical consequence.}\<close>
abbreviation conseq_local1::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" ("[_ \<^bold>\<turnstile> _]") where "[A \<^bold>\<turnstile> B] \<equiv> A \<^bold>\<preceq> B"
abbreviation conseq_local2::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" ("[_,_ \<^bold>\<turnstile> _]") where "[A\<^sub>1, A\<^sub>2 \<^bold>\<turnstile> B] \<equiv> A\<^sub>1 \<^bold>\<and> A\<^sub>2 \<^bold>\<preceq> B"
abbreviation conseq_local12::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" ("[_ \<^bold>\<turnstile> _,_]") where "[A \<^bold>\<turnstile> B\<^sub>1, B\<^sub>2] \<equiv> A \<^bold>\<preceq> B\<^sub>1 \<^bold>\<or> B\<^sub>2"
(*add more as the need arises...*)

text\<open>\noindent{For LFUs we use the interior-based negation previously defined (taking derivative as primitive). }\<close>
definition ineg::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>")  where  "\<^bold>\<not>A \<equiv> \<I>(\<^bold>\<midarrow>A)"
declare ineg_def[conn]

text\<open>\noindent{In terms of the derivative operator the negation looks as follows:}\<close>
lemma ineg_prop: "\<^bold>\<not>A \<^bold>\<approx> \<^bold>\<midarrow>(\<D> A) \<^bold>\<leftharpoonup> A" using Cl_der_def IB_rel Int_br_def eq_ext' pB4 conn by fastforce

text\<open>\noindent{This negation is of course paracomplete.}\<close>
lemma "[\<^bold>\<turnstile> a \<^bold>\<or> \<^bold>\<not>a]" nitpick oops (*countermodel*)

text\<open>\noindent{We define two pairs of in/determinedness operators and show how they relate to each other.}\<close>
abbreviation op_det::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circ>_" [57]58) where "\<^bold>\<circ>A  \<equiv> \<B>\<^sup>d A"
abbreviation op_ind::"\<sigma>\<Rightarrow>\<sigma>" ("\<bullet>_" [57]58) where "\<bullet>A  \<equiv> \<^bold>\<midarrow>\<^bold>\<circ>A"

lemma op_det_def: "\<^bold>\<circ>a \<^bold>\<approx> a \<^bold>\<or> \<^bold>\<not>a" by (simp add: compl_def diff_def dual_def ineg_def join_def pB1)
lemma Prop1: "\<^bold>\<circ>A \<^bold>\<approx> \<C>\<^sup>f\<^sup>p A" by (metis dimp_def eq_ext' fp3)
lemma Prop2: "Op A \<longleftrightarrow> \<^bold>\<circ>\<^bold>\<midarrow>A \<^bold>\<approx> \<^bold>\<top>" by (metis dual_def dual_symm pB1 pI1 top_def compl_def diff_def)
lemma Prop3: "Op A \<longleftrightarrow> \<bullet>\<^bold>\<midarrow>A \<^bold>\<approx> \<^bold>\<bottom>" by (metis Op_Bzero dual_def dual_symm)
lemma Prop4: "Cl A \<longleftrightarrow> \<^bold>\<circ>A \<^bold>\<approx> \<^bold>\<top>" by (metis Prop1 dimp_def top_def)
lemma Prop5: "Cl A \<longleftrightarrow> \<bullet>A \<^bold>\<approx> \<^bold>\<bottom>" by (simp add: Prop4 bottom_def compl_def top_def)

text\<open>\noindent{Analogously as for LFIs, LFUs provide means for recovering the principle of excluded middle.}\<close>
lemma "[\<Gamma> \<^bold>\<turnstile> \<bullet>a, a \<^bold>\<or> \<^bold>\<not>a]" using IB_rel Int_br_def compl_def diff_def dual_def eq_ext' ineg_def join_def by fastforce
lemma "[\<Gamma>, \<^bold>\<circ>a \<^bold>\<turnstile> a \<^bold>\<or> \<^bold>\<not>a]" using dual_def pB1 unfolding conn by auto

lemma "TNDm(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "ECQ(\<^bold>\<not>)" by (simp add: ECQ_def bottom_def diff_def ineg_prop meet_def)
lemma "Der_3 \<D> \<Longrightarrow> LNC(\<^bold>\<not>)" using ineg_prop ECQ_def ID3 LNC_def dNOR_def unfolding conn by auto
lemma "\<DD> \<D> \<Longrightarrow> DNI(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> DNE(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "Der_1b \<D> \<Longrightarrow> CoPw(\<^bold>\<not>)" by (smt CoPw_def MONO_ADDIb PD1 compl_def ineg_def monI)
lemma "\<DD> \<D> \<Longrightarrow> CoP1(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> CoP2(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> CoP3(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> DM3(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "Der_1a \<D> \<Longrightarrow> DM4(\<^bold>\<not>)" unfolding Defs using ADDI_a_def ineg_prop compl_def diff_def  join_def meet_def by auto
lemma "Der_3 \<D> \<Longrightarrow> nNor(\<^bold>\<not>)" by (simp add: NOR_def ineg_prop nNor_def bottom_def compl_def diff_def top_def)
lemma "nDNor(\<^bold>\<not>)" by (simp add: bottom_def diff_def ineg_prop nDNor_def top_def)
lemma "Der_1b \<D> \<Longrightarrow> MT0(\<^bold>\<not>)" unfolding Defs by (metis (mono_tags, hide_lams) CD1b Disj_I OpCldual PD1 bottom_def compl_def ineg_def meet_def top_def)
lemma "Der_1b \<D> \<Longrightarrow> Der_3 \<D> \<Longrightarrow> MT1(\<^bold>\<not>)" unfolding Defs by (metis (full_types) NOR_def PD1 bottom_def compl_def diff_def ineg_prop top_def)
lemma "\<DD> \<D> \<Longrightarrow> MT2(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> MT3(\<^bold>\<not>)" nitpick oops (*countermodel*)

text\<open>\noindent{We show how all local contraposition variants (lCoP) can be recovered using the determinedness operator.
Observe that we can recover in the same way other (weaker) properties: CoP, MT and DNI/DNE (local \& global).}\<close>
lemma "\<DD> \<D> \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop1: "[\<^bold>\<circ>a, a \<^bold>\<rightarrow> b \<^bold>\<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" using dual_def pI1 conn by auto
lemma "\<DD> \<D> \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop2: "[\<^bold>\<circ>a, a \<^bold>\<rightarrow> \<^bold>\<not>b \<^bold>\<turnstile> b \<^bold>\<rightarrow> \<^bold>\<not>a]" using dual_def pI1 conn by auto
lemma "\<DD> \<D> \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop3: "[\<^bold>\<circ>a, \<^bold>\<not>a \<^bold>\<rightarrow> b \<^bold>\<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> a]" using dual_def pI1 conn by auto
lemma "\<DD> \<D> \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop4: "[\<^bold>\<circ>a, \<^bold>\<not>a \<^bold>\<rightarrow> \<^bold>\<not>b \<^bold>\<turnstile> b \<^bold>\<rightarrow> a]" using dual_def pI1 conn by auto

text\<open>\noindent{Disjunctive syllogism (DS).}\<close>
lemma "DS1(\<^bold>\<rightarrow>)(\<^bold>\<not>)" by (simp add: DS1_def diff_def impl_def ineg_prop join_def)
lemma "\<DD> \<D> \<Longrightarrow> DS2(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_ds2: "[\<^bold>\<circ>a, \<^bold>\<not>a \<^bold>\<rightarrow> b \<^bold>\<turnstile> a \<^bold>\<or> b]" using pB1 dual_def conn by auto

end


theory Specialisation_Examples
imports MainRLT "HOL-Library.Predicate_Compile_Alternative_Defs"
begin

declare [[values_timeout = 960.0]]

section \<open>Specialisation Examples\<close>

primrec nth_el'
where
  "nth_el' [] i = None"
| "nth_el' (x # xs) i = (case i of 0 => Some x | Suc j => nth_el' xs j)"

definition
  "greater_than_index xs = (\<forall>i x. nth_el' xs i = Some x --> x > i)"

code_pred (expected_modes: i => bool) [inductify, skip_proof, specialise] greater_than_index .
ML_val \<open>Core_Data.intros_of \<^context> \<^const_name>\<open>specialised_nth_el'P\<close>\<close>

thm greater_than_index.equation

values [expected "{()}"] "{x. greater_than_index [1,2,4,6]}"
values [expected "{}"] "{x. greater_than_index [0,2,3,2]}"

subsection \<open>Common subterms\<close>

text \<open>If a predicate is called with common subterms as arguments,
  this predicate should be specialised.
\<close>

definition max_nat :: "nat => nat => nat"
  where "max_nat a b = (if a <= b then b else a)"

lemma [code_pred_inline]:
  "max = max_nat"
by (simp add: fun_eq_iff max_def max_nat_def)

definition
  "max_of_my_Suc x = max x (Suc x)"

text \<open>In this example, max is specialised, hence the mode o => i => bool is possible\<close>

code_pred (modes: o => i => bool) [inductify, specialise, skip_proof] max_of_my_Suc .

thm max_of_my_SucP.equation

ML_val \<open>Core_Data.intros_of \<^context> \<^const_name>\<open>specialised_max_natP\<close>\<close>

values "{x. max_of_my_SucP x 6}"

subsection \<open>Sorts\<close>

inductive sorted :: "'a::linorder list \<Rightarrow> bool" where
  Nil [simp]: "sorted []"
| Cons: "\<forall>y\<in>set xs. x \<le> y \<Longrightarrow> sorted xs \<Longrightarrow> sorted (x # xs)"

lemma sorted_single [simp]: "sorted [x]"
by (rule sorted.Cons) auto

lemma sorted_many: "x \<le> y \<Longrightarrow> sorted (y # zs) \<Longrightarrow> sorted (x # y # zs)"
by (rule sorted.Cons) (cases "y # zs" rule: sorted.cases, auto)

lemma sorted_many_eq [simp]:
  "sorted (x # y # zs) \<longleftrightarrow> x \<le> y \<and> sorted (y # zs)"
by (auto intro: sorted_many elim: sorted.cases)

declare sorted.Nil [code_pred_intro]
  sorted_single [code_pred_intro]
  sorted_many [code_pred_intro]

code_pred sorted
proof -
  assume "sorted xa"
  assume 1: "xa = [] \<Longrightarrow> thesis"
  assume 2: "\<And>x. xa = [x] \<Longrightarrow> thesis"
  assume 3: "\<And>x y zs. xa = x # y # zs \<Longrightarrow> x \<le> y \<Longrightarrow> sorted (y # zs) \<Longrightarrow> thesis"
  show thesis proof (cases xa)
    case Nil with 1 show ?thesis .
  next
    case (Cons x xs) show ?thesis proof (cases xs)
      case Nil with Cons 2 show ?thesis by simp
    next
      case (Cons y zs)
      show ?thesis
      proof (rule 3)
        from Cons \<open>xa = x # xs\<close> show "xa = x # y # zs" by simp
        with \<open>sorted xa\<close> show "x \<le> y" and "sorted (y # zs)" by simp_all
      qed
    qed
  qed
qed
thm sorted.equation

section \<open>Specialisation in POPLmark theory\<close>

notation
  Some ("\<lfloor>_\<rfloor>")

notation
  None ("\<bottom>")

notation
  length ("\<parallel>_\<parallel>")

notation
  Cons ("_ \<Colon>/ _" [66, 65] 65)

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
where
  "[]\<langle>i\<rangle> = \<bottom>"
| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> \<lfloor>x\<rfloor> | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"

primrec assoc :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" ("_\<langle>_\<rangle>\<^sub>?" [90, 0] 91)
where
  "[]\<langle>a\<rangle>\<^sub>? = \<bottom>"
| "(x # xs)\<langle>a\<rangle>\<^sub>? = (if fst x = a then \<lfloor>snd x\<rfloor> else xs\<langle>a\<rangle>\<^sub>?)"

primrec unique :: "('a \<times> 'b) list \<Rightarrow> bool"
where
  "unique [] = True"
| "unique (x # xs) = (xs\<langle>fst x\<rangle>\<^sub>? = \<bottom> \<and> unique xs)"

datatype type =
    TVar nat
  | Top
  | Fun type type    (infixr "\<rightarrow>" 200)
  | TyAll type type  ("(3\<forall><:_./ _)" [0, 10] 10)

datatype binding = VarB type | TVarB type
type_synonym env = "binding list"

primrec is_TVarB :: "binding \<Rightarrow> bool"
where
  "is_TVarB (VarB T) = False"
| "is_TVarB (TVarB T) = True"

primrec type_ofB :: "binding \<Rightarrow> type"
where
  "type_ofB (VarB T) = T"
| "type_ofB (TVarB T) = T"

primrec mapB :: "(type \<Rightarrow> type) \<Rightarrow> binding \<Rightarrow> binding"
where
  "mapB f (VarB T) = VarB (f T)"
| "mapB f (TVarB T) = TVarB (f T)"

datatype trm =
    Var nat
  | Abs type trm   ("(3\<lambda>:_./ _)" [0, 10] 10)
  | TAbs type trm  ("(3\<lambda><:_./ _)" [0, 10] 10)
  | App trm trm    (infixl "\<bullet>" 200)
  | TApp trm type  (infixl "\<bullet>\<^sub>\<tau>" 200)

primrec liftT :: "nat \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type" ("\<up>\<^sub>\<tau>")
where
  "\<up>\<^sub>\<tau> n k (TVar i) = (if i < k then TVar i else TVar (i + n))"
| "\<up>\<^sub>\<tau> n k Top = Top"
| "\<up>\<^sub>\<tau> n k (T \<rightarrow> U) = \<up>\<^sub>\<tau> n k T \<rightarrow> \<up>\<^sub>\<tau> n k U"
| "\<up>\<^sub>\<tau> n k (\<forall><:T. U) = (\<forall><:\<up>\<^sub>\<tau> n k T. \<up>\<^sub>\<tau> n (k + 1) U)"

primrec lift :: "nat \<Rightarrow> nat \<Rightarrow> trm \<Rightarrow> trm" ("\<up>")
where
  "\<up> n k (Var i) = (if i < k then Var i else Var (i + n))"
| "\<up> n k (\<lambda>:T. t) = (\<lambda>:\<up>\<^sub>\<tau> n k T. \<up> n (k + 1) t)"
| "\<up> n k (\<lambda><:T. t) = (\<lambda><:\<up>\<^sub>\<tau> n k T. \<up> n (k + 1) t)"
| "\<up> n k (s \<bullet> t) = \<up> n k s \<bullet> \<up> n k t"
| "\<up> n k (t \<bullet>\<^sub>\<tau> T) = \<up> n k t \<bullet>\<^sub>\<tau> \<up>\<^sub>\<tau> n k T"

primrec substTT :: "type \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type"  ("_[_ \<mapsto>\<^sub>\<tau> _]\<^sub>\<tau>" [300, 0, 0] 300)
where
  "(TVar i)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> =
     (if k < i then TVar (i - 1) else if i = k then \<up>\<^sub>\<tau> k 0 S else TVar i)"
| "Top[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = Top"
| "(T \<rightarrow> U)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> \<rightarrow> U[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>"
| "(\<forall><:T. U)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = (\<forall><:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. U[k+1 \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>)"

primrec decT :: "nat \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type"  ("\<down>\<^sub>\<tau>")
where
  "\<down>\<^sub>\<tau> 0 k T = T"
| "\<down>\<^sub>\<tau> (Suc n) k T = \<down>\<^sub>\<tau> n k (T[k \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>)"

primrec subst :: "trm \<Rightarrow> nat \<Rightarrow> trm \<Rightarrow> trm"  ("_[_ \<mapsto> _]" [300, 0, 0] 300)
where
  "(Var i)[k \<mapsto> s] = (if k < i then Var (i - 1) else if i = k then \<up> k 0 s else Var i)"
| "(t \<bullet> u)[k \<mapsto> s] = t[k \<mapsto> s] \<bullet> u[k \<mapsto> s]"
| "(t \<bullet>\<^sub>\<tau> T)[k \<mapsto> s] = t[k \<mapsto> s] \<bullet>\<^sub>\<tau> \<down>\<^sub>\<tau> 1 k T"
| "(\<lambda>:T. t)[k \<mapsto> s] = (\<lambda>:\<down>\<^sub>\<tau> 1 k T. t[k+1 \<mapsto> s])"
| "(\<lambda><:T. t)[k \<mapsto> s] = (\<lambda><:\<down>\<^sub>\<tau> 1 k T. t[k+1 \<mapsto> s])"

primrec substT :: "trm \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> trm"    ("_[_ \<mapsto>\<^sub>\<tau> _]" [300, 0, 0] 300)
where
  "(Var i)[k \<mapsto>\<^sub>\<tau> S] = (if k < i then Var (i - 1) else Var i)"
| "(t \<bullet> u)[k \<mapsto>\<^sub>\<tau> S] = t[k \<mapsto>\<^sub>\<tau> S] \<bullet> u[k \<mapsto>\<^sub>\<tau> S]"
| "(t \<bullet>\<^sub>\<tau> T)[k \<mapsto>\<^sub>\<tau> S] = t[k \<mapsto>\<^sub>\<tau> S] \<bullet>\<^sub>\<tau> T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>"
| "(\<lambda>:T. t)[k \<mapsto>\<^sub>\<tau> S] = (\<lambda>:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. t[k+1 \<mapsto>\<^sub>\<tau> S])"
| "(\<lambda><:T. t)[k \<mapsto>\<^sub>\<tau> S] = (\<lambda><:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. t[k+1 \<mapsto>\<^sub>\<tau> S])"

primrec liftE :: "nat \<Rightarrow> nat \<Rightarrow> env \<Rightarrow> env" ("\<up>\<^sub>e")
where
  "\<up>\<^sub>e n k [] = []"
| "\<up>\<^sub>e n k (B \<Colon> \<Gamma>) = mapB (\<up>\<^sub>\<tau> n (k + \<parallel>\<Gamma>\<parallel>)) B \<Colon> \<up>\<^sub>e n k \<Gamma>"

primrec substE :: "env \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> env"  ("_[_ \<mapsto>\<^sub>\<tau> _]\<^sub>e" [300, 0, 0] 300)
where
  "[][k \<mapsto>\<^sub>\<tau> T]\<^sub>e = []"
| "(B \<Colon> \<Gamma>)[k \<mapsto>\<^sub>\<tau> T]\<^sub>e = mapB (\<lambda>U. U[k + \<parallel>\<Gamma>\<parallel> \<mapsto>\<^sub>\<tau> T]\<^sub>\<tau>) B \<Colon> \<Gamma>[k \<mapsto>\<^sub>\<tau> T]\<^sub>e"

primrec decE :: "nat \<Rightarrow> nat \<Rightarrow> env \<Rightarrow> env"  ("\<down>\<^sub>e")
where
  "\<down>\<^sub>e 0 k \<Gamma> = \<Gamma>"
| "\<down>\<^sub>e (Suc n) k \<Gamma> = \<down>\<^sub>e n k (\<Gamma>[k \<mapsto>\<^sub>\<tau> Top]\<^sub>e)"

inductive
  well_formed :: "env \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f _" [50, 50] 50)
where
  wf_TVar: "\<Gamma>\<langle>i\<rangle> = \<lfloor>TVarB T\<rfloor> \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i"
| wf_Top: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f Top"
| wf_arrow: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<rightarrow> U"
| wf_all: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> TVarB T \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f (\<forall><:T. U)"

inductive
  well_formedE :: "env \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f" [50] 50)
  and well_formedB :: "env \<Rightarrow> binding \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f\<^sub>B _" [50, 50] 50)
where
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B \<equiv> \<Gamma> \<turnstile>\<^sub>w\<^sub>f type_ofB B"
| wf_Nil: "[] \<turnstile>\<^sub>w\<^sub>f"
| wf_Cons: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f"

inductive_cases well_formed_cases:
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f Top"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<rightarrow> U"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f (\<forall><:T. U)"

inductive_cases well_formedE_cases:
  "B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f"

inductive
  subtyping :: "env \<Rightarrow> type \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ <: _" [50, 50, 50] 50)
where
  SA_Top: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f S \<Longrightarrow> \<Gamma> \<turnstile> S <: Top"
| SA_refl_TVar: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i \<Longrightarrow> \<Gamma> \<turnstile> TVar i <: TVar i"
| SA_trans_TVar: "\<Gamma>\<langle>i\<rangle> = \<lfloor>TVarB U\<rfloor> \<Longrightarrow>
    \<Gamma> \<turnstile> \<up>\<^sub>\<tau> (Suc i) 0 U <: T \<Longrightarrow> \<Gamma> \<turnstile> TVar i <: T"
| SA_arrow: "\<Gamma> \<turnstile> T\<^sub>1 <: S\<^sub>1 \<Longrightarrow> \<Gamma> \<turnstile> S\<^sub>2 <: T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> S\<^sub>1 \<rightarrow> S\<^sub>2 <: T\<^sub>1 \<rightarrow> T\<^sub>2"
| SA_all: "\<Gamma> \<turnstile> T\<^sub>1 <: S\<^sub>1 \<Longrightarrow> TVarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> S\<^sub>2 <: T\<^sub>2 \<Longrightarrow>
    \<Gamma> \<turnstile> (\<forall><:S\<^sub>1. S\<^sub>2) <: (\<forall><:T\<^sub>1. T\<^sub>2)"

inductive
  typing :: "env \<Rightarrow> trm \<Rightarrow> type \<Rightarrow> bool"    ("_ \<turnstile> _ : _" [50, 50, 50] 50)
where
  T_Var: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma>\<langle>i\<rangle> = \<lfloor>VarB U\<rfloor> \<Longrightarrow> T = \<up>\<^sub>\<tau> (Suc i) 0 U \<Longrightarrow> \<Gamma> \<turnstile> Var i : T"
| T_Abs: "VarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>:T\<^sub>1. t\<^sub>2) : T\<^sub>1 \<rightarrow> \<down>\<^sub>\<tau> 1 0 T\<^sub>2"
| T_App: "\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>11 \<rightarrow> T\<^sub>12 \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>11 \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>1 \<bullet> t\<^sub>2 : T\<^sub>12"
| T_TAbs: "TVarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda><:T\<^sub>1. t\<^sub>2) : (\<forall><:T\<^sub>1. T\<^sub>2)"
| T_TApp: "\<Gamma> \<turnstile> t\<^sub>1 : (\<forall><:T\<^sub>11. T\<^sub>12) \<Longrightarrow> \<Gamma> \<turnstile> T\<^sub>2 <: T\<^sub>11 \<Longrightarrow>
    \<Gamma> \<turnstile> t\<^sub>1 \<bullet>\<^sub>\<tau> T\<^sub>2 : T\<^sub>12[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]\<^sub>\<tau>"
| T_Sub: "\<Gamma> \<turnstile> t : S \<Longrightarrow> \<Gamma> \<turnstile> S <: T \<Longrightarrow> \<Gamma> \<turnstile> t : T"

code_pred [inductify, skip_proof, specialise] typing .

thm typing.equation

values 6 "{(E, t, T). typing E t T}"

subsection \<open>Higher-order predicate\<close>

code_pred [inductify] mapB .

subsection \<open>Multiple instances\<close>

inductive subtype_refl' where
  "\<Gamma> \<turnstile> t : T ==> \<not> (\<Gamma> \<turnstile> T <: T) ==> subtype_refl' t T"

code_pred (modes: i => i => bool, o => i => bool, i => o => bool, o => o => bool) [inductify] subtype_refl' .

thm subtype_refl'.equation

end


theory FSA_Example
  imports FSA_Proof
begin

state S initial
state A
state B
state C

transition t1 = label a frm A to A
transition t2 = label a frm A to S
transition t3 = label b frm A to B
transition t4 = label b frm B to A
transition t5 = label a frm C to A
transition t6 = label c frm C to B

automaton ABC =
  states S A B C
  transitions t1 t2 t3 t4 t5 t6

text \<open> We can use the following line to check well-formedness, which internally uses the code
  generator for efficient execution. \<close>

value "wf_Automaton ABC"

lemma C_not_reachable: "\<not> reachable ABC C"
  by (check_reachable "{S, A, B}")

end


(*  Author: Tobias Nipkow, Dmitriy Traytel *)

header "Connection Between Derivatives and Partial Derivatives"

(*<*)
theory Deriv_PDeriv
imports Derivatives_Finite
begin
(*>*)

lemma pderiv_not_is_Zero_is_Plus[simp]: "\<forall>x \<in> pderiv a r. \<not> is_Zero x \<and> \<not> is_Plus x"
  by (induct r) auto

lemma finite_pderiv[simp]: "finite (pderiv a r)"
  by (induct r) auto

lemma PLUS_inject: "\<lbrakk>\<forall>x \<in> set xs \<union> set ys. \<not> is_Zero x \<and> \<not> is_Plus x; sorted xs; sorted ys\<rbrakk> \<Longrightarrow>
  (PLUS xs = PLUS ys) \<longleftrightarrow> xs = ys"
proof (induct xs arbitrary: ys rule: list_singleton_induct)
  case nil then show ?case by (induct ys rule: list_singleton_induct) auto
next
  case single then show ?case by (induct ys rule: list_singleton_induct) auto
next
  case cons then show ?case by (induct ys rule: list_singleton_induct) auto
qed

lemma sorted_list_of_set_inject: "\<lbrakk>finite R; finite S\<rbrakk> \<Longrightarrow>
  (sorted_list_of_set R = sorted_list_of_set S) \<longleftrightarrow> R = S"
proof (induct R arbitrary: S rule: finite_linorder_min_induct)
  case empty then show ?case
  proof (induct S rule: finite_linorder_min_induct)
    case (insert b S) then show ?case by simp (metis insort_not_Nil)
  qed simp
next
  case (insert a R) from this(4,1-3) show ?case
  proof (induct S rule: finite_linorder_min_induct)
    case (insert b S)
    show ?case
    proof
      assume "sorted_list_of_set (insert a R) = sorted_list_of_set (insert b S)"
      with insert(1,2,4,5) have "insort a (sorted_list_of_set R) = insort b (sorted_list_of_set S)"
        by (elim box_equals[OF _ sorted_list_of_set.insert sorted_list_of_set.insert]) auto
      with insert(2,5) have "a # sorted_list_of_set R = b # sorted_list_of_set S"
        apply (cases "sorted_list_of_set R" "sorted_list_of_set S" rule: list.exhaust[case_product list.exhaust])
        apply (auto split: if_splits)
        apply (metis insort_not_Nil)
        apply (metis (full_types) set_insert distinct.simps(2) insert.prems(1) insertI1 min.semilattice_strict_iff_order not_in_set_insert sorted_list_of_set)
        apply (metis (full_types) set_insert distinct.simps(2) insert.prems(1) insertI1 min.semilattice_strict_iff_order not_in_set_insert sorted_list_of_set)
        apply (metis (full_types) set_insert distinct.simps(2) insert.prems(1) insertI1 min.semilattice_strict_iff_order not_in_set_insert sorted_list_of_set)
        apply (metis (full_types) List.set_insert distinct.simps(2) insert.hyps(1) insertI1 min.semilattice_strict_iff_order not_in_set_insert sorted_list_of_set)
        apply (metis (full_types) List.set_insert distinct.simps(2) insert.hyps(1) insertI1 min.semilattice_strict_iff_order not_in_set_insert sorted_list_of_set)
        apply (metis (full_types) List.set_insert distinct.simps(2) insert.hyps(1) insertI1 min.semilattice_strict_iff_order not_in_set_insert sorted_list_of_set)
        apply (metis (full_types) List.set_insert distinct.simps(2) insert.hyps(1) insertI1 min.semilattice_strict_iff_order not_in_set_insert sorted_list_of_set)
        apply (metis (full_types) List.set_insert distinct.simps(2) insert.hyps(1) insertI1 min.semilattice_strict_iff_order not_in_set_insert sorted_list_of_set)
        done
      with insert show "insert a R = insert b S" by auto
    next
      assume "insert a R = insert b S"
      then show "sorted_list_of_set (insert a R) = sorted_list_of_set (insert b S)" by simp
    qed
  qed simp
qed

lemma flatten_PLUS_inject: "\<lbrakk>\<forall>x \<in> R \<union> S. \<not> is_Zero x \<and> \<not> is_Plus x; finite R; finite S\<rbrakk> \<Longrightarrow>
  (flatten PLUS R = flatten PLUS S) = (R = S)"
  by (rule trans[OF PLUS_inject sorted_list_of_set_inject]) auto

primrec pset where
  "pset Zero = {}"
| "pset One = {One}"
| "pset (Atom a) = {Atom a}"
| "pset (Plus r s) = pset r \<union> pset s"
| "pset (Times r s) = Timess (pset r) s"
| "pset (Star r) = {Star r}"

lemma pset_not_is_Zero_is_Plus[simp]: "\<forall>x \<in> pset r. \<not> is_Zero x \<and> \<not> is_Plus x"
  by (induct r) auto

lemma finite_pset[simp]: "finite (pset r)"
  by (induct r) auto

lemma pset_deriv: "pset (deriv a r) = pderiv a r"
  by (induct r) auto

definition pnorm where
  "pnorm = flatten PLUS o pset"

fun pnPlus :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnPlus Zero r = r"
| "pnPlus r Zero = r"
| "pnPlus (Plus r s) t = pnPlus r (pnPlus s t)"
| "pnPlus r (Plus s t) =
     (if r = s then (Plus s t)
     else if le_rexp r s then Plus r (Plus s t)
     else Plus s (pnPlus r t))"
| "pnPlus r s =
     (if r = s then r
      else if le_rexp r s then Plus r s
      else Plus s r)"

fun pnTimes :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnTimes Zero r = Zero"
| "pnTimes (Plus r s) t = pnPlus (pnTimes r t) (pnTimes s t)"
| "pnTimes r s = Times r s"

primrec pnorm_alt :: "'a::linorder rexp \<Rightarrow> 'a rexp" where
  "pnorm_alt Zero = Zero"
| "pnorm_alt One = One"
| "pnorm_alt (Atom a) = Atom a"
| "pnorm_alt (Plus r s) = pnPlus (pnorm_alt r) (pnorm_alt s)"
| "pnorm_alt (Times r s) = pnTimes (pnorm_alt r) s"
| "pnorm_alt (Star r) = Star r"

lemma pset_pnPlus:
  "pset (pnPlus r s) = pset (Plus r s)"
  by (induct r s rule: pnPlus.induct) auto

lemma pset_pnTimes:
  "pset (pnTimes r s) = pset (Times r s)"
  by (induct r s rule: pnTimes.induct) (auto simp: pset_pnPlus)

lemma pset_pnorm_alt_Times: "s \<in> pset r \<Longrightarrow> pnTimes (pnorm_alt s) t = Times (pnorm_alt s) t"
  by (induct r arbitrary: s t) auto

lemma pset_pnorm_alt:
  "pset (pnorm_alt r) = pnorm_alt ` pset r"
  by (induct r) (auto simp: pset_pnPlus pset_pnTimes pset_pnorm_alt_Times image_iff)

lemma pset_pnTimes_Times: "s \<in> pset r \<Longrightarrow> pnTimes s t = Times s t"
  by (induct r arbitrary: s t) auto

lemma pset_pnorm_alt_id: "s \<in> pset r \<Longrightarrow> pnorm_alt s = s"
  by (induct r arbitrary: s) (auto simp: pset_pnTimes_Times)

lemma pnorm_alt_image_pset: "pnorm_alt ` pset r = pset r"
  by (induct r) (auto simp: image_iff pset_pnorm_alt_id pset_pnTimes_Times)

lemma pnorm_pnorm_alt: "pnorm (pnorm_alt r) = pnorm r"
  by (induct r) (auto simp: pnorm_def pset_pnPlus pset_pnTimes pset_pnorm_alt pnorm_alt_image_pset)

lemma pnPlus_singleton_PLUS:
  "\<lbrakk>xs \<noteq> []; sorted xs; distinct xs; \<forall>x \<in> {x} \<union> set xs. \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk> \<Longrightarrow>
  pnPlus x (PLUS xs) = (if x \<in> set xs then PLUS xs else PLUS (insort x xs))"
proof (induct xs rule: list_singleton_induct)
  case (single y)
  thus ?case unfolding is_Zero_def is_Plus_def
    apply (cases x y rule: linorder_cases)
    apply (induct x y rule: pnPlus.induct)
    apply (auto simp: less_rexp_def less_eq_rexp_def)
    apply (cases y)
    apply auto
    apply (induct x y rule: pnPlus.induct)
    apply (auto simp: less_rexp_def less_eq_rexp_def)
    apply (induct x y rule: pnPlus.induct)
    apply (auto simp: less_rexp_def less_eq_rexp_def)
    done
next
  case (cons y1 y2 ys) thus ?case unfolding is_Zero_def is_Plus_def sorted_Cons
    apply (cases x)
    apply (metis UnCI insertI1)
    apply simp apply (metis antisym less_eq_rexp_def)
    apply simp apply (metis antisym less_eq_rexp_def)
    apply (metis UnCI insertI1)
    apply simp apply (metis antisym less_eq_rexp_def)
    apply simp apply (metis antisym less_eq_rexp_def)
    done
qed simp

lemma pnPlus_PlusL[simp]: "t \<noteq> Zero \<Longrightarrow> pnPlus (Plus r s) t = pnPlus r (pnPlus s t)"
  by (induct t) auto

lemma pnPlus_ZeroR[simp]: "pnPlus r Zero = r"
  by (induct r) auto

lemma PLUS_eq_Zero: "PLUS xs = Zero \<longleftrightarrow> xs = [] \<or> xs = [Zero]"
  by (induct xs rule: list_singleton_induct) auto

lemma pnPlus_PLUS:
  "\<lbrakk>xs1 \<noteq> []; xs2 \<noteq> []; \<forall>x \<in> set (xs1 @ xs2). \<not>is_Zero x \<and> \<not>is_Plus x; sorted xs2; distinct xs2\<rbrakk>\<Longrightarrow>
  pnPlus (PLUS xs1) (PLUS xs2) = flatten PLUS (set (xs1 @ xs2))"
proof (induct xs1 arbitrary: xs2 rule: list_singleton_induct)
  case (single x1)
  thus ?case
    apply (auto intro!: trans[OF pnPlus_singleton_PLUS]
      simp: insert_absorb simp del: sorted_list_of_set_insert)
    apply (metis List.finite_set finite_sorted_distinct_unique sorted_list_of_set)
    apply (rule arg_cong[of _ _ PLUS])
    apply (metis remdups_id_iff_distinct sorted_list_of_set_sort_remdups sorted_sort_id)
    done
next
  case (cons x11 x12 xs1)
  then show ?case unfolding rexp_of_list.simps
  apply (subst pnPlus_PlusL)
  apply (unfold PLUS_eq_Zero) []
  apply (metis in_set_conv_decomp rexp.disc(1))
  apply (subst cons(1))
  apply (simp_all del: sorted_list_of_set_insert)
  apply (rule trans[OF pnPlus_singleton_PLUS])
  apply (simp_all add: sorted_insort set_insort del: sorted_list_of_set_insert)
  apply safe
  unfolding insert_commute[of x11]
  apply (auto simp only: Un_insert_left[of x11, symmetric] insert_absorb) []
  apply (auto simp only: Un_insert_right[of _ x11, symmetric] insert_absorb) []
  done
qed simp

lemma pnPlus_flatten_PLUS:
  "\<lbrakk>X1 \<noteq> {}; X2 \<noteq> {}; finite X1; finite X2; \<forall>x \<in> X1 \<union> X2.  \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk>\<Longrightarrow>
  pnPlus (flatten PLUS X1) (flatten PLUS X2) = flatten PLUS (X1 \<union> X2)"
  by (rule trans[OF pnPlus_PLUS]) auto

lemma pnPlus_pnorm: "pnPlus (pnorm r) (pnorm s) = pnorm (Plus r s)"
  by (cases "pset r = {} \<or> pset s = {}")
    (auto simp: pnorm_def pset_pnPlus pset_pnorm_alt intro: pnPlus_flatten_PLUS)

lemma pnTimes_not_Zero_or_Plus[simp]: "\<lbrakk>\<not> is_Zero x; \<not> is_Plus x\<rbrakk> \<Longrightarrow> pnTimes x r = Times x r"
  by (cases x) auto

lemma pnTimes_PLUS:
  "\<lbrakk>xs \<noteq> []; \<forall>x \<in> set xs. \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk>\<Longrightarrow>
  pnTimes (PLUS xs) r = flatten PLUS (Timess (set xs) r)"
proof (induct xs arbitrary: r rule: list_singleton_induct)
  case (cons x y xs) then show ?case unfolding rexp_of_list.simps pnTimes.simps
  apply (subst pnTimes_not_Zero_or_Plus)
  apply (simp_all add: sorted_insort set_insort del: sorted_list_of_set_insert)
  apply (subst pnPlus_singleton_PLUS)
  apply (simp_all add: sorted_insort set_insort del: sorted_list_of_set_insert)
  unfolding insert_commute[of "Times y r"]
  apply (simp del: sorted_list_of_set_insert)
  apply safe
  apply (subst insert_absorb[of "Times x r"])
  apply simp_all
  done
qed auto

lemma pnTimes_flatten_PLUS:
  "\<lbrakk>X1 \<noteq> {}; finite X1; \<forall>x \<in> X1. \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk>\<Longrightarrow>
  pnTimes (flatten PLUS X1) r = flatten PLUS (Timess X1 r)"
  by (rule trans[OF pnTimes_PLUS]) auto

lemma pnTimes_pnorm: "pnTimes (pnorm r1) r2 = pnorm (Times r1 r2)"
  by (cases "pset r1 = {}")
    (auto simp: pnorm_def pset_pnTimes pset_pnorm_alt intro: pnTimes_flatten_PLUS)

lemma pnorm_alt[symmetric]: "pnorm_alt r = pnorm r"
  by (induct r) (simp_all only: pnorm_alt.simps pnPlus_pnorm pnTimes_pnorm, auto simp: pnorm_def)

lemma insort_eq_Cons: "\<lbrakk>\<forall>a \<in> set xs. b < a; sorted xs\<rbrakk> \<Longrightarrow> insort b xs = b # xs"
  by (cases xs) auto

lemma pderiv_PLUS: "pderiv a (PLUS (x # xs)) = pderiv a x \<union> pderiv a (PLUS xs)"
  by (cases xs) auto

lemma pderiv_set_flatten_PLUS:
   "finite X \<Longrightarrow> pderiv (a :: 'a :: linorder) (flatten PLUS X) = pderiv_set a X"
proof (induction X rule: finite_linorder_min_induct)
  case (insert b X)
  then have "b \<notin> X" by auto
  then have "pderiv a (flatten PLUS (insert b X)) = pderiv a b \<union> pderiv a (flatten PLUS X)"
    by (simp add: pderiv_PLUS insort_eq_Cons insert.hyps)
  also from insert.IH have "\<dots> = pderiv a b \<union> pderiv_set a X" by simp
  finally show ?case by simp
qed simp

lemma fold_pderiv_set_flatten_PLUS:
  "\<lbrakk>w \<noteq> []; finite X\<rbrakk> \<Longrightarrow> fold pderiv_set w {flatten PLUS X} = fold pderiv_set w X"
  by (induct w arbitrary: X) (simp_all add: pderiv_set_flatten_PLUS)

lemma fold_pnorm_deriv:
  "fold (\<lambda>a r. pnorm (deriv a r)) w s = flatten PLUS (fold pderiv_set w {s})"
proof (induction w arbitrary: s)
  case (Cons x w) then show ?case
  proof (cases "w = []")
    case False
    show ?thesis using fold_pderiv_set_flatten_PLUS[OF False] Cons.IH
      by (auto simp: pnorm_def pset_deriv)
  qed (simp add: pnorm_def pset_deriv)
qed simp

primrec
  pnderiv :: "'a :: linorder \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "pnderiv c (Zero) = Zero"
| "pnderiv c (One) = Zero"
| "pnderiv c (Atom c') = (if c = c' then One else Zero)"
| "pnderiv c (Plus r1 r2) = pnPlus (pnderiv c r1) (pnderiv c r2)"
| "pnderiv c (Times r1 r2) =
    (if nullable r1 then pnPlus (pnTimes (pnderiv c r1) r2) (pnderiv c r2) else pnTimes (pnderiv c r1) r2)"
| "pnderiv c (Star r) = pnTimes (pnderiv c r) (Star r)"

lemma pnderiv_alt[code]: "pnderiv a r = pnorm (deriv a r)"
  by (induct r) (auto simp: pnorm_alt)

lemma pnderiv_pderiv: "pnderiv a r = flatten PLUS (pderiv a r)"
  unfolding pnderiv_alt pnorm_def o_apply pset_deriv ..

(*<*)
end
(*>*)