theory SelectionSort
  imports Main MVector
begin

lemma take_induct:
  assumes "P []"
  and "\<And>i. \<lbrakk> P (take i xs); i < size xs \<rbrakk> \<Longrightarrow> P (take (i+1) xs)"
  shows "P xs"
proof-
  have "\<And>(n :: nat). n < size xs \<Longrightarrow> P (take n xs)"
  proof-
    fix n
    assume "n < size xs"
    show "P (take n xs)"
      apply (induct n)
      apply (simp add: assms(1))
      using assms(2) by fastforce
  qed
  thus ?thesis
    by (metis Suc_eq_plus1 assms(1) assms(2) gr0_conv_Suc leI lessI order_refl take0 take_all)
qed

lemma forM_invariant:
  assumes "P (return ())"
  and "\<And>i. \<lbrakk> P (forMu (take i xs) program); i < size xs \<rbrakk> \<Longrightarrow> P (forMu (take (i+1) xs) program)"
  shows "P (forMu xs program)"
  apply (induct xs rule: take_induct)
  using assms(1) apply (simp add: return_def)
  using assms(2) by blast

definition selection_sort :: "nat mvector \<Rightarrow> unit io" where
  "selection_sort arr = (let n = size_of_mvector arr in forMu [0..<n] (\<lambda>i. do {
    min_ref \<leftarrow> ref i;
    forMu [i+1..<n] (\<lambda>j. do {
      valJ \<leftarrow> read arr j;
      m \<leftarrow> ! min_ref;
      valMin \<leftarrow> read arr m;
      whenu (valJ < valMin) (min_ref := j)
    });
    m \<leftarrow> ! min_ref;
    swap arr i m;
    return ()
  }))"

primrec sorted :: "'a::ord list \<Rightarrow> bool" where
  "sorted [] = True"
| "sorted (x#xs) = ((\<forall>y\<in>set xs. x \<le> y) \<and> sorted xs)"

fun selection_sort_program where
  "selection_sort_program xs = do {
    arr \<leftarrow> from_list xs;
    selection_sort arr;
    to_list arr
  }"

definition outer_loop where
  "outer_loop arr n i = (do {
    min_ref \<leftarrow> ref i;
    forMu [i+1..<n] (\<lambda>j. do {
      valJ \<leftarrow> read arr j;
      m \<leftarrow> ! min_ref;
      valMin \<leftarrow> read arr m;
      whenu (valJ < valMin) (min_ref := j)
    });
    m \<leftarrow> ! min_ref;
    swap arr i m
  })"

lemma selection_sort_as_outer_loop: "selection_sort arr = (let n = size_of_mvector arr in forMu [0..<n] (outer_loop arr n))"
  unfolding selection_sort_def outer_loop_def
  by simp

definition outer_loop_find_min where
  "outer_loop_find_min arr n i = (do {
    min_ref \<leftarrow> ref i;
    forMu [i+1..<n] (\<lambda>j. do {
      valJ \<leftarrow> read arr j;
      m \<leftarrow> ! min_ref;
      valMin \<leftarrow> read arr m;
      whenu (valJ < valMin) (min_ref := j)
    });
    ! min_ref
  })"

lemma outer_loop_as_find_min_and_swap:
  "outer_loop arr n i = outer_loop_find_min arr n i \<bind> (\<lambda>m. swap arr i m)"
  by (simp add: outer_loop_def outer_loop_find_min_def)

definition inner_loop where
  "inner_loop arr n i min_ref j = (do {
    valJ \<leftarrow> read arr j;
    m \<leftarrow> ! min_ref;
    valMin \<leftarrow> read arr m;
    whenu (valJ < valMin) (min_ref := j)
  })"

lemma outer_loop_find_min_as_inner_loop:
  "outer_loop_find_min arr n i = (do {
    min_ref \<leftarrow> ref i;
    forMu [i+1..<n] (inner_loop arr n i min_ref);
    ! min_ref
  })"
  unfolding outer_loop_find_min_def inner_loop_def apply simp
  done

definition inner_loop_invariant where
  "inner_loop_invariant arr n i min_ref j h = (present_in arr (IO.get h min_ref) \<and> get_at h arr (IO.get h min_ref) = Min (set (map (get_at h arr) [i..<j])))"

lemma effect_inner_loop_fixed_get_at:
  fixes arr :: "nat mvector"
  assumes "effect (inner_loop arr i n min_ref j) h h' ()"
  and "ref_not_in min_ref arr"
  and "present_in arr k"
  shows "get_at h arr k = get_at h' arr k"
proof-
  have "effect (inner_loop arr i n min_ref j) h h' ()"
    by (simp add: assms)
  hence h: "h' = (if get_at h arr j < get_at h arr (IO.get h min_ref) then IO.set min_ref j h else h)"
    apply (simp add: effect_def inner_loop_def execute_bind execute_read execute_lookup)
    apply (auto simp add: return_def execute_update)
    done
  show "get_at h arr k = get_at h' arr k"
    apply (simp add: h execute_update, rule)
    using ref_not_in_irrelative(1) [OF assms(2) assms(3)] apply simp
    done
qed

lemma effect_inner_loop:
  fixes arr :: "nat mvector"
  assumes "effect (inner_loop arr n i min_ref j) h h' ()"
  and "ref_not_in min_ref arr"
  and "present_in arr i"
  and "present_in arr j"
  and "present_in arr (IO.get h min_ref)"
  shows "get_at h' arr (IO.get h' min_ref) = min (get_at h' arr (IO.get h min_ref)) (get_at h' arr j)"
proof-
  have "effect (inner_loop arr n i min_ref j) h h' ()"
    by (simp add: assms)
  hence h: "h' = (if get_at h arr j < get_at h arr (IO.get h min_ref) then IO.set min_ref j h else h)"
    apply (simp add: effect_def inner_loop_def execute_bind execute_read execute_lookup)
    apply (auto simp add: return_def execute_update)
    done
  show "get_at h' arr (IO.get h' min_ref) = min (get_at h' arr (IO.get h min_ref)) (get_at h' arr j)"
    apply (simp add: h)
    apply (cases "get_at h arr j < get_at h arr (IO.get h min_ref)")
    apply (simp add: ref_not_in_irrelative(1) [OF assms(2) assms(5)])
    apply (simp add: ref_not_in_irrelative(1) [OF assms(2) assms(4)])
    apply (simp add: ref_not_in_irrelative(1) [OF assms(2) assms(5)])
    done
qed

lemma inner_loop_invariant_step:
  fixes arr :: "nat mvector"
  assumes "inner_loop_invariant arr n i min_ref j h"
  and "effect (inner_loop arr n i min_ref j) h h' ()"
  and "i < j"
  and "present_in arr i"
  and "present_in arr j"
  and "ref_not_in min_ref arr"
  shows "inner_loop_invariant arr n i min_ref (j+1) h'"
proof-
  have "get_at h arr (IO.get h min_ref) = Min (set (map (get_at h arr) [i..<j]))"
    by (meson assms(1) inner_loop_invariant_def)
  have "\<And>k. present_in arr k \<Longrightarrow> get_at h' arr k = get_at h arr k"
    using assms(2) assms(5) assms(6) effect_inner_loop_fixed_get_at by fastforce
  have "present_in arr (IO.get h' min_ref)"
  proof-
    have "effect (inner_loop arr n i min_ref j) h h' ()"
      by (simp add: assms)
    hence h: "h' = (if get_at h arr j < get_at h arr (IO.get h min_ref) then IO.set min_ref j h else h)"
      apply (simp add: effect_def inner_loop_def execute_bind execute_read execute_lookup)
      apply (auto simp add: return_def execute_update)
      done
    show ?thesis
      apply (auto simp add: h present_in_def)
      using assms(5)
      apply (simp add: present_in_def)
      using assms(1) inner_loop_invariant_def present_in_def by fastforce
  qed

  have "get_at h' arr (IO.get h' min_ref) = min (get_at h arr (IO.get h min_ref)) (get_at h arr j)"
  proof-
    have "present_in arr (IO.get h min_ref)"
      using assms(1) inner_loop_invariant_def by fastforce
    have p: "get_at h' arr (IO.get h min_ref) = get_at h arr (IO.get h min_ref)"
      by (metis \<open>present_in arr (IO.get h min_ref)\<close> assms(2) assms(6) effect_inner_loop_fixed_get_at)
    have "get_at h' arr (IO.get h' min_ref) = min (get_at h' arr (IO.get h min_ref)) (get_at h' arr j)"
      apply (rule effect_inner_loop)
      apply (rule assms)
      apply (rule assms)
      apply (rule assms)
      apply (rule assms)
      apply (simp add: \<open>present_in arr (IO.get h min_ref)\<close>)
      done
    also have "\<dots> = min (get_at h arr (IO.get h min_ref)) (get_at h arr j)"
      by (simp add: \<open>\<And>k. present_in arr k \<Longrightarrow> get_at h' arr k = get_at h arr k\<close> assms(5) p)
    finally show ?thesis
      by simp
  qed
  also have "\<dots> = min (Min (set (map (get_at h arr) [i..<j]))) (get_at h arr j)"
    by (simp add: \<open>get_at h arr (IO.get h min_ref) = Min (set (map (get_at h arr) [i..<j]))\<close>)
  also have "\<dots> = Min (set (get_at h arr j # map (get_at h arr) [i..<j]))"
  proof-
    { fix f :: "nat \<Rightarrow> nat" and xs and x
      have "xs \<noteq> [] \<Longrightarrow> min (Min (set (map f xs))) (f x) = Min (set (f x # map f xs))"
        apply (induct xs arbitrary: x)
        apply auto
        done
    }
    have "\<And>(f :: nat \<Rightarrow> nat) xs j. xs \<noteq> [] \<Longrightarrow> min (Min (set (map f xs))) (f j) = Min (set (f j # map f xs))"
      by simp
    thus ?thesis
      by (simp add: assms(3))
  qed
  also have "\<dots> = Min (set (map (get_at h arr) [i..<j] @ [get_at h arr j]))"
    by auto
  also have "\<dots> = Min (set (map (get_at h arr) ([i..<j] @ [j])))"
    by auto
  also have "\<dots> = Min (set (map (get_at h arr) [i..<j+1]))"
    using assms(3) by auto
  also have "\<dots> = Min (set (map (get_at h' arr) [i..<j+1]))"
  proof-
    { fix k
      assume "k \<in> set [i..<j+1]"
      hence "i \<le> k \<and> k \<le> j"
        by (metis Suc_eq_plus1 Suc_leI atLeastLessThan_iff not_less set_upt)
      have "0 \<le> i"
        by simp
      have "j < size_of_mvector arr"
        using assms(5)
        apply (simp add: present_in_def)
        done
      hence "0 \<le> k \<and> k < size_of_mvector arr"
        using \<open>i \<le> k \<and> k \<le> j\<close> by linarith
      hence "present_in arr k"
        by (simp add: present_in_def)
      hence "get_at h arr k = get_at h' arr k"
        by (simp add: \<open>\<And>k. present_in arr k \<Longrightarrow> get_at h' arr k = get_at h arr k\<close>)
    }
    hence "\<And>k. k \<in> set [i..<j+1] \<Longrightarrow> get_at h arr k = get_at h' arr k"
      by simp
    thus ?thesis
      by (smt map_eq_conv)
  qed
  finally have "get_at h' arr (IO.get h' min_ref) = Min (set (map (get_at h' arr) [i..<j+1]))"
    by auto
  thus ?thesis
    unfolding inner_loop_invariant_def
    using \<open>present_in arr (IO.get h' min_ref)\<close> by blast
qed

lemma inner_loop_invariant:
  fixes arr :: "nat mvector"
  assumes "present_in arr i"
  and "ref_not_in min_ref arr"
  and "effect (forMu [i+1..<n] (inner_loop arr n i min_ref)) h h' ()"
  and "inner_loop_invariant arr n i min_ref (i+1) h"
  and "n = size_of_mvector arr"
  and "i < n"
  shows "inner_loop_invariant arr n i min_ref n h'"
proof-
  { fix j
    have "\<And>h'. j+i+1 \<le> n \<Longrightarrow> effect (forMu [i+1..<j+i+1] (inner_loop arr n i min_ref)) h h' () \<Longrightarrow> inner_loop_invariant arr n i min_ref (j+i+1) h'"
      apply (induct "j")
      apply (simp add: effect_def return_def)
      using assms apply simp
    proof-
      fix j h'
      assume hyp: "\<And>h'. j + i + 1 \<le> n \<Longrightarrow> effect (forMu [i + 1..<j + i + 1] (inner_loop arr n i min_ref)) h h' () \<Longrightarrow> inner_loop_invariant arr n i min_ref (j + i + 1) h'"
      and index_bound: "Suc j + i + 1 \<le> n"
      and "effect (forMu [i + 1..<Suc j + i + 1] (inner_loop arr n i min_ref)) h h' ()"

      have "effect (forMu ([i+1..<j+i+1] @ [j+i+1]) (inner_loop arr n i min_ref)) h h' ()"
        using \<open>effect (forMu [i + 1..<Suc j + i + 1] (inner_loop arr n i min_ref)) h h' ()\<close> by auto
      hence "effect (forMu [i+1..<j+i+1] (inner_loop arr n i min_ref) \<bind> (\<lambda>_. forMu [j+i+1] (inner_loop arr n i min_ref))) h h' ()"
        using effect_forMu_app by blast
      hence "effect (forMu [i+1..<j+i+1] (inner_loop arr n i min_ref) \<bind> (\<lambda>_. inner_loop arr n i min_ref (j+i+1))) h h' ()"
      proof-
        have h: "forMu [j+i+1] (inner_loop arr n i min_ref) = inner_loop arr n i min_ref (j+i+1)"
          by auto
        show "effect (forMu [i + 1..<j + i + 1] (inner_loop arr n i min_ref) \<bind> (\<lambda>_. forMu [j + i + 1] (inner_loop arr n i min_ref))) h h' ()
             \<Longrightarrow> effect (forMu [i + 1..<j + i + 1] (inner_loop arr n i min_ref) \<bind> (\<lambda>_. inner_loop arr n i min_ref (j + i + 1))) h h' ()"
          apply (simp add: h)
          done
      qed
      then obtain h'' where h'': "effect (forMu [i+1..<j+i+1] (inner_loop arr n i min_ref)) h h'' ()" "effect (inner_loop arr n i min_ref (j+i+1)) h'' h' ()"
        using effect_bind old.unit.exhaust by force

      have "inner_loop_invariant arr n i min_ref ((j+i+1)+1) h'"
        apply (rule inner_loop_invariant_step)
        apply (rule hyp)
        using index_bound apply simp
        apply (rule h'')
        apply (rule h'')
        apply simp
        apply (simp add: assms)
        defer
        apply (simp add: assms)
      proof-
        have "j + i + 1 < n"
          using index_bound by auto
        thus "present_in arr (j+i+1)"
          by (simp add: present_in_def assms)
      qed

      show "inner_loop_invariant arr n i min_ref (Suc j + i + 1) h'"
        unfolding inner_loop_invariant_def
        using \<open>inner_loop_invariant arr n i min_ref (j + i + 1 + 1) h'\<close> inner_loop_invariant_def by fastforce
    qed
  }
  hence "\<And>j. \<And>h'. j+i+1 \<le> n \<Longrightarrow> effect (forMu [i+1..<j+i+1] (inner_loop arr n i min_ref)) h h' () \<Longrightarrow> inner_loop_invariant arr n i min_ref (j+i+1) h'"
    by simp

  obtain j where "j+i+1 = n"
    using assms(6)
    by (metis add.commute discrete le_iff_add semiring_normalization_rules(25))

  hence h: "\<And>h'. effect (forMu [i+1..<n] (inner_loop arr n i min_ref)) h h' () \<Longrightarrow> inner_loop_invariant arr n i min_ref n h'"
    using \<open>\<And>j h'. \<lbrakk>j + i + 1 \<le> n; effect (forMu [i + 1..<j + i + 1] (inner_loop arr n i min_ref)) h h' ()\<rbrakk> \<Longrightarrow> inner_loop_invariant arr n i min_ref (j + i + 1) h'\<close> by blast
  show "inner_loop_invariant arr n i min_ref n h'"
    by (rule h, rule assms)
qed

definition outer_loop_invariant where
  "outer_loop_invariant arr i n h = (sorted (take i (get_over arr h)) \<and> get_at h arr i = Min (set (map (get_at h arr) [i+1..<n])))"

lemma outer_loop_find_min_finds_min_index:
  assumes "effect (outer_loop_find_min arr n i) h h' r"
  shows "get_at h' arr r = Min (set (map (get_at h' arr) [i..<n]))"
  sorry

lemma outer_loop_invariant_step:
  fixes arr :: "nat mvector"
  assumes "outer_loop_invariant arr i n h"
  and "effect (outer_loop arr n i) h h' ()"
  and "present_in arr i"
  and "\<And>i. i < size_of_mvector arr \<Longrightarrow> IO.present h (Ref (addr_of_mvector arr + i))"
  and "i < n"
  and "n = size_of_mvector arr"
  shows "outer_loop_invariant arr (i+1) n h'"
proof-
  obtain h1 m where
    "effect (outer_loop_find_min arr n i) h h1 m"
    "effect (swap arr i m) h1 h' ()"
    by (metis assms(2) effect_bind outer_loop_as_find_min_and_swap)

  obtain h2 min_ref where
    h2: "(min_ref,h2) = IO.alloc i h"
    "m = IO.get h1 min_ref"
    "effect (forMu [i+1..<n] (inner_loop arr n i min_ref)) h2 h1 ()"
  proof-
    obtain h2 min_ref where
      "effect (ref i) h h2 min_ref"
      "effect (forMu [i+1..<n] (inner_loop arr n i min_ref) \<bind> (\<lambda>_. ! min_ref)) h2 h1 m"
      by (smt \<open>effect (outer_loop_find_min arr n i) h h1 m\<close> effect_bind outer_loop_find_min_as_inner_loop)
    hence p: "(min_ref,h2) = IO.alloc i h"
      by (simp add: effect_def execute_ref)
    obtain h3 where
      r: "effect (forMu [i+1..<n] (inner_loop arr n i min_ref)) h2 h3 ()"
      "effect (! min_ref) h3 h1 m"
      using \<open>effect (forMu [i + 1..<n] (inner_loop arr n i min_ref) \<bind> (\<lambda>_. !min_ref)) h2 h1 m\<close> effect_bind by force
    hence q: "h3 = h1" "m = IO.get h1 min_ref"
      apply (metis Pair_inject effectE execute_lookup)
      apply (metis Pair_inject \<open>\<And>thesis. (\<And>h3. \<lbrakk>effect (forMu [i + 1..<n] (inner_loop arr n i min_ref)) h2 h3 (); effect (!min_ref) h3 h1 m\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> effectE execute_lookup)
      done
    assume h: "\<And>min_ref h2. (min_ref, h2) = IO.alloc i h \<Longrightarrow> m = IO.get h1 min_ref \<Longrightarrow> effect (forMu [i + 1..<n] (inner_loop arr n i min_ref)) h2 h1 () \<Longrightarrow> thesis"
    show ?thesis
      using h [OF p q(2)] r(1) q(1)
      apply auto
      done
  qed

  have "inner_loop_invariant arr n i min_ref n h1"
    apply (rule inner_loop_invariant)
    apply (rule assms)
    apply (rule alloc_ref_not_in, rule h2(1) [symmetric], rule assms, simp)
    apply (rule h2)
    defer
    apply (rule assms)
    apply (rule assms)
    apply (auto simp add: inner_loop_invariant_def)
    using h2(1) apply (simp add: alloc_get assms)
    using h2(1) apply (simp add: alloc_get assms)
    done
  hence "get_at h1 arr (IO.get h1 min_ref) = Min (set (map (get_at h1 arr) [i..<n]))"
    by (simp add: inner_loop_invariant_def)
  hence "get_at h1 arr m = Min (set (map (get_at h1 arr) [i..<n]))"
    using h2(2) by blast
  hence "get_at h' arr i = Min (set (map (get_at h1 arr) [i..<n]))"
    sorry

  show ?thesis
    sorry

(*
lemma outer_loop_invariant:
  assumes "n = size (get_over arr h)"
  and "\<And>i. \<lbrakk> is_sorted_outer arr i n h; i < n \<rbrakk> \<Longrightarrow> is_sorted_outer arr (i+1) n h"
  shows "is_sorted_outer arr n n h"
  using forM_invariant [of "\<lambda>i _. is_sorted_outer arr i n h" h "get_over arr h"]
  using assms(1) assms(2) is_sorted_outer_def by blast

lemma outer_loop_step:
  assumes "is_sorted_outer arr i (size xs) h" "i < size xs"
  shows "is_sorted_outer arr (i+1) (size xs) h"
proof-
  have "case execute (forMu [0..<i] (outer_loop arr (size xs))) h of (_,h') \<Rightarrow> sorted (take i (get_over arr h'))"
    using assms (1)
    apply (simp add: is_sorted_outer_def)
    apply auto
    done

  have "\<And>h'. sorted (take i (get_over arr h')) \<Longrightarrow> case execute (outer_loop arr (size xs) i) h' of (_,h'') \<Rightarrow> sorted (take (i+1) (get_over arr h''))"
    sorry

  hence "case execute (do {
    forMu [0..<i] (outer_loop arr (size xs));
    outer_loop arr (size xs) i
  }) h of (_,h') \<Rightarrow> sorted (take (i+1) (get_over arr h'))"
    apply (simp add: execute_bind)
    using \<open>case execute (forMu [0..<i] (outer_loop arr (size xs))) h of (x, h') \<Rightarrow> SelectionSort.sorted (take i (get_over arr h'))\<close> by fastforce
  thus "is_sorted_outer arr (i+1) (size xs) h"
    apply (simp add: is_sorted_outer_def forMu_app)
    done
qed

theorem selection_sort_is_sorted:
  assumes "effect (selection_sort_program xs) h h' rs"
  shows "sorted rs"
proof-
  obtain h' arr where
    "effect (from_list xs) h h' arr"
    "size_of_mvector arr = size xs"
    by (simp add: effect_def execute_from_list get_over_def alloc_def)
  hence X: "execute (from_list xs) h = (arr,h')"
    by (simp add: effect_def)

  have "\<And>h. size (get_over arr h) = size xs"
    apply (simp add: get_over_def get_over_internal_def)
    by (metis \<open>size_of_mvector arr = length xs\<close>)
  hence "\<And>h. take (size xs) (get_over arr h) = get_over arr h"
    by simp

  have "\<And>i. \<lbrakk> is_sorted_outer arr i (size xs) h'; i < size xs \<rbrakk> \<Longrightarrow> is_sorted_outer arr (i+1) (size xs) h'"
    sorry
  hence "is_sorted_outer arr (size xs) (size xs) h'"
    by (simp add: \<open>size_of_mvector arr = length xs\<close> outer_loop_invariant)
  hence "is_sorted_outer arr (size xs) (size xs) h'"
    by simp
  hence "(case execute (selection_sort arr) h' of (_,h') \<Rightarrow> sorted (take (size xs) (get_over arr h')))"
    apply (simp add: is_sorted_outer_def selection_sort_as_outer_loop)
     (metis \<open>size_of_mvector arr = length xs\<close>)
  hence "(case execute (selection_sort arr) h' of (_,h') \<Rightarrow> sorted (get_over arr h'))"
    by (simp add: \<open>\<And>h. take (length xs) (get_over arr h) = get_over arr h\<close>)
  hence Y: "case execute (do { selection_sort arr; to_list arr }) h' of (rs,_) \<Rightarrow> sorted rs"
    by (simp add: execute_bind execute_to_list, auto)

  have "case execute (selection_sort_program xs) h of (rs,_) \<Rightarrow> sorted rs"
    using Y
    apply (simp add: execute_bind X)
    done
  thus ?thesis
    using assms
    apply (simp add: effect_def)
    done
qed

definition inner_loop where
  "inner_loop arr n i min_ref j = (do {
    valJ \<leftarrow> read arr (j+1);
    m \<leftarrow> ! min_ref;
    valMin \<leftarrow> read arr m;
    whenu (valJ < valMin) (min_ref := j)
  })"

lemma outer_loop_as_inner_loop: "outer_loop arr n i = (do {
  min_ref \<leftarrow> ref i;
  forMu [i..<n] (inner_loop arr n i min_ref);
  m \<leftarrow> ! min_ref;
  swap arr i m;
  return ()
})"
  unfolding outer_loop_def inner_loop_def
  by simp

definition inner_inv where
  "inner_inv arr n i min_ref j h = (\<forall>k. i \<le> k \<and> k \<le> j \<longrightarrow> IO.get h min_ref \<le> MVector.get_at h arr k)"

lemma outer_loop_sorted:
  assumes "sorted (take i (get_over arr h'))"
  shows "case execute (outer_loop arr (size xs) i) h' of (_,h'') \<Rightarrow> sorted (take (i+1) (get_over arr h''))"
proof-
  have ""

lemma inner_loop_invariant:
  assumes "n = size_of_mvector arr"
  and "\<And>j. \<lbrakk> inner_inv arr n i min_ref j h; j < n \<rbrakk> \<Longrightarrow> inner_inv arr n i min_ref (j+1) h"
  shows "inner_inv arr n i min_ref n h"
  using forM_invariant [of _ h "[i..<n]"]
  sorry
*)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_add3acc_assoc3
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

theorem property0 :
  "((add3acc x1 (add3acc x2 x3 x4) x5) =
      (add3acc x1 x2 (add3acc x3 x4 x5)))"
  oops

end


theory min
imports Main
begin

lemma lemma_a [thy_expl]: "min2 x x = x"
by (hipster_induct_schemes min2.simps)

lemma lemma_aa [thy_expl]: "min2 x Z = x"
by (hipster_induct_schemes min2.simps)

lemma lemma_ab [thy_expl]: "min2 x (min2 x y) = min2 x y"
by (hipster_induct_schemes min2.simps)

lemma lemma_ac [thy_expl]: "min2 x (min2 y x) = min2 y x"
by (hipster_induct_schemes min2.simps)

lemma lemma_ad [thy_expl]: "min2 (min2 x y) x = min2 x y"
by (hipster_induct_schemes min2.simps)

lemma lemma_ae [thy_expl]: "min2 (S x) y = min2 y (S x)"
by (hipster_induct_schemes min2.simps)

lemma lemma_af [thy_expl]: "min2 x y = min2 y x"
by (hipster_induct_schemes min2.simps)

lemma lemma_ag [thy_expl]: ""
by (hipster_induct_schemes min2.simps)

lemma triv_a [thy_expl]: "min2 (min2 x y) y = min2 x y"
by (hipster_induct_simp_metis min2.simps)

lemma triv_ab [thy_expl]: "min2 (S x) (min2 y z) = min2 (min2 y z) (S x)"
by (hipster_induct_simp_metis min2.simps)

lemma triv_ac [thy_expl]: "min2 (min2 x y) Z = min2 x y"
by (hipster_induct_simp_metis min2.simps)

lemma triv_ad [thy_expl]: "min2 (min2 x y) (min2 x y) = min2 x y"
by (hipster_induct_simp_metis min2.simps)

lemma triv_ae [thy_expl]: "min2 (S x) (S x) = S x"
by (hipster_induct_simp_metis min2.simps)

lemma triv_af [thy_expl]: "min2 (S Z) x = min2 x (S Z)"
by (hipster_induct_simp_metis min2.simps)

lemma triv_ag [thy_expl]: "min2 (S Z) (min2 x y) = min2 (min2 x y) (S Z)"
by (hipster_induct_simp_metis min2.simps)

lemma triv_ah [thy_expl]: "min2 (S Z) (S Z) = S Z"
by (hipster_induct_simp_metis min2.simps)

lemma triv_ai [thy_expl]: "min2 (min2 x y) z = min2 z (min2 x y)"
by (hipster_induct_simp_metis min2.simps)

lemma triv_a [thy_expl]: ""
by (hipster_induct_simp_metis min2.simps)

lemma triv_a [thy_expl]: ""
by (hipster_induct_simp_metis min2.simps)

lemma triv_a [thy_expl]: ""
by (hipster_induct_simp_metis min2.simps)

lemma triv_a [thy_expl]: ""
by (hipster_induct_simp_metis min2.simps)

lemma triv_a [thy_expl]: ""
by (hipster_induct_simp_metis min2.simps)

lemma triv_a [thy_expl]: ""
by (hipster_induct_simp_metis min2.simps)

lemma triv_a [thy_expl]: ""
by (hipster_induct_simp_metis min2.simps)

(* FAILED
min2 x (min2 y z) = min2 y (min2 x z)
min2 x (min2 y z) = min2 y (min2 z x)
min2 (min2 x y) z = min2 x (min2 y z)
min2 (min2 x y) z = min2 x (min2 z y)
min2 x (S x) = S x
min2 (S x) x = S x
min2 (min2 x y) (min2 x z) = min2 x (min2 y z)
min2 (min2 x y) (min2 y z) = min2 x (min2 y z)
min2 (min2 x y) (min2 x z) = min2 x (min2 z y)
min2 (min2 x y) (min2 z y) = min2 x (min2 z y)
min2 (min2 x y) (min2 z x) = min2 z (min2 x y)
min2 (min2 x y) (min2 z y) = min2 z (min2 x y)
min2 (min2 x y) (S x) = min2 y (S x)
min2 (min2 x y) (S y) = min2 x (S y)
min2 (S x) (min2 x y) = min2 y (S x)
min2 (S x) (min2 y x) = min2 y (S x)
min2 (S x) (S y) = S (min2 y x)
min2 (S x) (S Z) = S x
min2 (S Z) (S x) = S x
*)

end


theory Listprog
  imports Main

begin

subsection \<open>define lists\<close>

definition lst1 :: "int list"
  where "lst1 \<equiv> Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil)))"

value "lst1"

definition lst2 :: "int list"
  where "lst2 \<equiv> 1 # (2 # (3 # (4 # [])))"

value "lst2"

definition lst3 :: "int list"
  where "lst3 \<equiv> [1,2,3,4]"

definition lst4 :: "int list"
  where "lst4 \<equiv> [1..4]"
value "lst4"

definition lst5 :: "nat list"
  where "lst5 \<equiv> [1..<5]"

lemma "lst1 = lst2"
  by (simp add: lst1_def lst2_def)

lemma "lst2 = lst3"
  by (simp add: lst2_def lst3_def)

definition "lst6 \<equiv> [''aa'',''bb'',''cc'',''dd'']"

subsection \<open>functions on lists\<close>

value "hd [a,b,c,d,e]"
value "last [a,b,c,d,e]"
value "tl [a,b,c,d,e]"
value "butlast [a,b,c,d,e]"
value "[a,b,c,d,e]!0"
value "[a,b,c,d,e]!7"
value "nths [(1::int)..20] {1,3,5,7}"
value "nths [(1::int)..20] {5,6,7,8}"
value "length [(10::int)..20]"
value "take 5 [(1::int)..20]"
value "takeWhile (\<lambda>x. 2 dvd x) [(1::int)..20]"
value "takeWhile (\<lambda>x. x < 8) [(1::int)..20]"
value "distinct [(1::int)..20]"
value "distinct [a,b,c,d,a]"

value "[a,b,c]@[d,e,f]"
value "concat [[a,b,c],[c,d,e],[e,f,g]]"
value "replicate 4 a"
value "rev [a,b,c,d,e]"
value "rotate1 [(1::int)..6]"
value "rotate 4 [(1::int)..10]"
lemma "rotate n = (rotate1^^n)"
  by (simp add:rotate_def)
value "splice [a1,a2,a3,a4] [b1,b2,b3,b4,b5]"
value "splice [(1::int)..8] [(11::int)..15]"
definition "lst7 \<equiv> [(1::int)..5]"
value "list_update lst7 2 8"
value "lst7[2 := 8]"
value "drop 5 [(1::int)..10]"
value "dropWhile (\<lambda>x. x < 8) [(1::int)..10]"
value "dropWhile (\<lambda>x. 2 dvd x) [(1::int)..20]"
value "remdups [(1::int),1,2,2,3,4,5,1,1,6,3,7]"
value "remove1 2 [(1::int),1,2,2,3,4,5,1,1,6,3,7]"
value "removeAll 2 [(1::int),1,2,2,3,4,5,1,1,6,3,7]"

value "set [a,b,c,d]"
value "set [(1::int),2,3,4,2,3,4,6]"
value "zip [a,b,c,d] [(1::int)..8]"

value "filter (\<lambda>x. 2 dvd x) [(1::int)..20]"
value "find (\<lambda>x. 5 dvd x) [(1::int)..20]"
value "find (\<lambda>x. x > 30) [(1::int)..20]"
value "sort [(4::int), 6,1,9,20]"
value "sorted [(4::int), 6,1,9,20]"
value "sorted [(1::int)..20]"

lemma "sorted (sort lst)"
  using sorted_sort by simp

value "sum_list [1::int,2,3,4]"
value "sum_list [a,b,c,d]"
value "prod_list [1::int,2,3,4,5]"
value "prod_list [a,b,c,d]"

subsection \<open>string by list\<close>

definition "charAt str n \<equiv> str ! n"
definition "compareTo str1 str2 \<equiv> (str1 = str2)"
value "charAt ''abcde'' 2"
value "compareTo ''abc'' ''abcd''"

primrec startsWith :: "string \<Rightarrow> string \<Rightarrow> bool"
  where "startsWith str []  = True" |
        "startsWith str (x # xs) = (case str of
            [] \<Rightarrow> False |
            (y # ys) \<Rightarrow> x = y \<and> startsWith ys xs)"

value "startsWith ''abcde'' ''ab''"

definition "endsWith str suffix \<equiv> startsWith (rev str) (rev suffix)"

value "endsWith ''aabbdedc'' ''edc''"

primrec contains :: "string \<Rightarrow> string \<Rightarrow> bool"
  where "contains [] str =
          (if str = [] then True else False)" |
        "contains (x # xs) str =
            (if startsWith (x#xs) str then True
              else contains xs str)"

value "contains ''abcde'' ''bc''"

definition "substring str m n \<equiv> take (n - m) (drop m str)"
value "substring ''12345678'' 2 5"

fun indexOf0 :: "string \<Rightarrow> string \<Rightarrow> (int \<times> int)"
  where "indexOf0 [] sub =
            (if sub = [] then (0,0) else (-1,-1))" |
        "indexOf0 (x # xs) sub =
            (if startsWith (x#xs) sub then (0,0)
             else
                let idx = indexOf0 xs sub in
                  (fst idx + 1, snd idx))"

definition "indexOf str sub \<equiv>
              (let idx = indexOf0 str sub in
                  if snd idx = -1 then -1
                  else fst idx)"

value "indexOf ''abcde'' ''cde''"

subsection \<open>stack\<close>

type_synonym 'a stack = "'a list"

definition push :: "'a \<Rightarrow> 'a stack \<Rightarrow> 'a stack"
  where "push a stk \<equiv> a # stk"

(*definition pop :: "'a stack \<Rightarrow> ('a \<times> 'a stack)"
  where "pop s \<equiv> (hd s, tl s)"*)
primrec pop :: "'a stack \<Rightarrow> ('a \<times> 'a stack)"
where "pop (x # xs) = (x, xs)"

definition empty :: "'a stack \<Rightarrow> 'a stack"
  where "empty s = []"

definition top :: "'a stack \<Rightarrow> 'a"
  where "top s \<equiv> hd s"

fun search0 :: "'a stack \<Rightarrow> 'a \<Rightarrow> (int \<times> int)"
  where "search0 [] a = (-1, -1)" |
        "search0 (x#xs) a =
            (if x = a then (0,0) else
                let idx = search0 xs a in
                  (1 + fst idx,snd idx))"

definition "search st a \<equiv>
              (let idx = search0 st a in
                  if snd idx = -1 then -1
                  else fst idx)"

value "search [1::int,2,3,4,5] 4"

value "push a [b,b,b]"
value "pop [a,b,c,d]"
value "top [a,b,c,d]"

subsection \<open>FIFO queue\<close>

type_synonym 'a queue = "'a list \<times> nat"

definition initq :: "nat \<Rightarrow> 'a queue"
  where "initq msize \<equiv> ([]::'a list, msize)"

definition enque :: "'a queue \<Rightarrow> 'a \<Rightarrow> ('a queue \<times> bool)"
  where "enque q a \<equiv>
          (if length (fst q) = snd q then (q, False)
           else ((a # fst q, snd q), True))"

definition deque :: "'a queue \<Rightarrow> ('a queue \<times> 'a option)"
  where "deque q \<equiv>
            (if fst q = [] then (q, None)
             else ((butlast (fst q), snd q),
                    Some (last (fst q))))"

definition q1 :: "int queue"
  where "q1 = (initq 2)"

value "q1"
value "enque (fst (enque q1 0)) 1"
value "enque (fst (enque (fst (enque q1 0)) 1)) 2"

value "enque ([1::int,2,3,4,5],5) 0"

value "deque ([]::int list,6)"

end


section {* A simple library in the UTP theory of designs *}

theory utp_library
  imports "UTP-Theories.utp_theories"
begin

subsection {* Preliminaries -- set up some syntax *}

notation true_upred ("abort")

definition establishes_inv :: "'a hrel_des \<Rightarrow> 'a upred \<Rightarrow> bool" (infixl "establishes" 85) where
[upred_defs]: "establishes_inv P iv \<equiv> true \<turnstile>\<^sub>r \<lceil>iv\<rceil>\<^sub>> \<sqsubseteq> P"

definition maintains_inv :: "'a hrel_des \<Rightarrow> 'a upred \<Rightarrow> bool" (infixl "maintains" 85) where
[upred_defs]: "maintains_inv P iv \<equiv> (pre\<^sub>D(P) \<and> \<lceil>iv\<rceil>\<^sub><) \<turnstile>\<^sub>r \<lceil>iv\<rceil>\<^sub>> \<sqsubseteq> P"

type_synonym 'a prog = "'a hrel_des"

subsection {* Library state space *}

type_synonym book = string

alphabet library =
  books :: "book set"
  loans :: "book set"

subsection {* Library operations *}

definition InitLibrary :: "book set \<Rightarrow> library prog" where
[upred_defs]: "InitLibrary(bs) = true \<turnstile>\<^sub>n books, loans := \<guillemotleft>bs\<guillemotright>, {}\<^sub>u"

definition InitLibraryAlt :: "book set \<Rightarrow> library prog" where
[upred_defs]: "InitLibraryAlt(bs) = true \<turnstile>\<^sub>n ($books\<acute> =\<^sub>u \<guillemotleft>bs\<guillemotright> \<and> $loans\<acute> =\<^sub>u {}\<^sub>u)"

lemma InitLibrary_alt_same: "InitLibrary(bs) = InitLibraryAlt(bs)"
  by (rel_auto)

definition LibraryInvariant :: "library upred" where
[upred_defs]: "LibraryInvariant = (&loans \<subseteq>\<^sub>u &books)"

definition BorrowBook :: "book \<Rightarrow> library prog" where
[upred_defs]: "BorrowBook(b) = (\<guillemotleft>b\<guillemotright> \<notin>\<^sub>u &loans \<and> \<guillemotleft>b\<guillemotright> \<in>\<^sub>u &books) \<turnstile>\<^sub>n loans := (&loans \<union>\<^sub>u {\<guillemotleft>b\<guillemotright>}\<^sub>u)"

definition ReturnBook :: "book \<Rightarrow> library prog" where
[upred_defs]: "ReturnBook(b) = ((\<guillemotleft>b\<guillemotright> \<in>\<^sub>u &loans) \<turnstile>\<^sub>n (loans := (&loans - {\<guillemotleft>b\<guillemotright>}\<^sub>u)))"

subsection {* Library proofs *}

lemma InitLibrary_Idempotent: "InitLibrary(bs) ;; InitLibrary(bs) = InitLibrary(bs)"
  by (rel_blast)

lemma BorrowBook_Twice: "(BorrowBook(b) ;; BorrowBook(b)) = abort"
  by (rel_auto)

lemma ReturnBook_Twice: "(ReturnBook(b) ;; ReturnBook(b)) = abort"
  by (rel_auto)

abbreviation "Books \<equiv> {''War and Peace''
                       ,''Pride and Prejudice''
                       ,''Les Miserables''}"

lemma NotInLibrary:
  "(InitLibrary(Books) ;; BorrowBook(''Pride and Prejudice and Zombies'')) = abort"
  by (rel_auto)

theorem BorrowAndReturn:
  assumes "b \<in> bs"
  shows "(InitLibrary(bs) ;; BorrowBook(b) ;; ReturnBook(b)) = InitLibrary(bs)"
  using assms by (rel_blast)

lemma "InitLibrary(bs) establishes LibraryInvariant"
  by (rel_auto)

lemma "BorrowBook(b) maintains LibraryInvariant"
  by (rel_auto)

lemma "ReturnBook(b) maintains LibraryInvariant"
  by (rel_auto)
end


subsection \<open>Montanari Weak Transition Systems\<close>

theory Montanari_Weak_Transition_Systems
imports
  Weak_Transition_Systems
  Strong_Relations
  Weak_Relations_modified
begin

context lts_tau
begin

lemma step_tau_concat:
  assumes
    \<open>q \<Rightarrow>^a q'\<close>
    \<open>q' \<Rightarrow>^\<tau> q1\<close>
  shows \<open>q \<Rightarrow>^a q1\<close>
proof -
  show ?thesis using assms steps_concat tau_tau by blast
qed

lemma tau_step_concat:
  assumes
    \<open>q \<Rightarrow>^\<tau> q'\<close>
    \<open>q' \<Rightarrow>^a q1\<close>
  shows \<open>q \<Rightarrow>^a q1\<close>
proof -
  show ?thesis using assms steps_concat tau_tau by blast
qed

lemma tau_word_concat:
  assumes
    \<open>q \<Rightarrow>^\<tau> q'\<close>
    \<open>q' \<Rightarrow>$A q1\<close>
  shows \<open>q \<Rightarrow>$A q1\<close> using assms
proof (cases A)
  case Nil
  hence \<open>q' \<Rightarrow>^\<tau> q1\<close> using assms by auto
  thus ?thesis using Nil assms steps_concat tau_tau weak_step_seq.simps by blast
next
  case (Cons a A)
  then obtain q'' where  \<open>q' \<Rightarrow>^a q''\<close> and A_step:  \<open>q'' \<Rightarrow>$A q1 \<close> using assms by auto
  hence \<open>q \<Rightarrow>^a q''\<close> using tau_step_concat[OF assms(1)] by auto
  then show ?thesis using Cons A_step  \<open>q \<Rightarrow>^a q''\<close> by auto
qed

lemma rev_seq_split :
  assumes \<open>q \<Rightarrow>$ (xs @ [x])  q1\<close>
  shows \<open>\<exists>q'. q \<Rightarrow>$xs q' \<and> q' \<Rightarrow>^x q1\<close> using assms
proof (induct xs arbitrary: q)
  case Nil
  hence \<open>q \<Rightarrow>$ [x]  q1\<close> by auto
  hence x_succ: \<open>q \<Rightarrow>^x q1\<close> by blast
  have \<open>q \<Rightarrow>$[] q\<close> by (simp add: steps.refl)
  then show ?case using x_succ by auto
next
  case (Cons a xs)
  then obtain q' where q'_def: \<open>q \<Rightarrow>^a q' \<and> q' \<Rightarrow>$(xs@[x]) q1\<close> by auto
  then obtain q'' where \<open>q' \<Rightarrow>$ xs  q'' \<and> q'' \<Rightarrow>^x  q1\<close> using Cons.hyps[of \<open>q'\<close>] by auto
  then show ?case using q'_def by auto
qed

lemma rev_seq_concat:
  assumes
    \<open>q \<Rightarrow>$as q'\<close>
    \<open>q'\<Rightarrow>$A q1\<close>
  shows \<open>q \<Rightarrow>$(as@A) q1\<close> using assms
proof (induct as arbitrary: A q' rule: rev_induct)
  case Nil
  hence \<open>q \<Rightarrow>^\<tau> q'\<close> by auto
  hence \<open>q \<Rightarrow>^\<tau> q' \<and> q' \<Rightarrow>$A q1\<close> using Nil.prems(2) by blast
  hence \<open>q \<Rightarrow>$A q1\<close> using tau_word_concat by auto
  then show ?case by simp
next
  case (snoc x xs)
  hence \<open>\<exists>q''. q \<Rightarrow>$xs q'' \<and> q'' \<Rightarrow>^x q'\<close> using rev_seq_split by simp
  then obtain q'' where q_def: \<open>q \<Rightarrow>$xs q''\<close> \<open>q'' \<Rightarrow>^x q'\<close> by auto
  from snoc.prems(2) have \<open>q' \<Rightarrow>$A q1\<close> by blast
  hence \<open>q'' \<Rightarrow>$(x#A) q1\<close> using q_def by auto
  hence \<open>q'' \<Rightarrow>$([x]@A) q1\<close> by auto
  then show ?case using snoc.hyps[of \<open>q''\<close> \<open>[x]@A\<close>] q_def by auto
qed

lemma rev_seq_step_concat :
  assumes
    \<open>q \<Rightarrow>$as q'\<close>
    \<open>q'\<Rightarrow>^a q1\<close>
  shows \<open>q \<Rightarrow>$(as@[a]) q1\<close>
proof -
  from assms(2) have \<open>q'\<Rightarrow>$[a] q1\<close> by blast
  thus ?thesis using rev_seq_concat assms(1) by auto
qed

lemma word_tau_concat:
  assumes
    \<open>q \<Rightarrow>$A q'\<close>
    \<open>q' \<Rightarrow>^\<tau> q1\<close>
  shows \<open>q \<Rightarrow>$A q1\<close>
proof -
  from assms(2) have \<open>q' \<Rightarrow>$[] q1\<close>
    using tau_tau weak_step_seq.simps(1) by blast
  thus ?thesis using assms(1) rev_seq_concat
    by (metis append.right_neutral)
qed

lemma list_rev_split :
  assumes \<open>A \<noteq> []\<close>
  shows \<open>\<exists>as a. A = as@[a]\<close>
proof -
  show ?thesis using assms rev_exhaust by blast
qed

primrec taufree :: \<open>'a list \<Rightarrow> 'a list\<close>
  where
    \<open>taufree [] = []\<close>
  | \<open>taufree (a#A) = (if tau a then taufree A else a#(taufree A))\<close>

lemma weak_step_over_tau :
  assumes
    \<open>p \<Rightarrow>$A p'\<close>
  shows \<open>p \<Rightarrow>$(taufree A) p'\<close> using assms
proof (induct A arbitrary: p)
  case Nil
  thus ?case by auto
next
  case (Cons a as)
  then obtain p0 where \<open>p \<Rightarrow>^a p0\<close> \<open>p0\<Rightarrow>$as p'\<close> by auto
  then show ?case
  proof (cases \<open>tau a\<close>)
    case True
    hence \<open>p \<Rightarrow>$as p'\<close> using tau_word_concat \<open>p \<Rightarrow>^a p0\<close> \<open>p0 \<Rightarrow>$ as p'\<close> tau_tau by blast
    hence \<open>p \<Rightarrow>$ (taufree as)  p'\<close> using Cons by auto
    thus \<open>p \<Rightarrow>$ (taufree (a#as))  p'\<close> using True by auto
  next
    case False
    hence rec: \<open>taufree (a#as) = a#(taufree as)\<close> by auto
    hence \<open>p0 \<Rightarrow>$ (taufree as)  p'\<close> using \<open>p0\<Rightarrow>$as p'\<close> Cons by auto
    hence \<open>p \<Rightarrow>$(a#(taufree as)) p'\<close> using  \<open>p \<Rightarrow>^a p0\<close> by auto
    then show ?thesis using rec by auto
  qed
qed

lemma app_tau_taufree_list :
  assumes
    \<open>\<forall>a \<in> set A. \<not>tau a\<close>
    \<open>b = \<tau>\<close>
  shows \<open>A = taufree (A@[b])\<close> using assms(1)
proof (induct A)
  case Nil
  then show ?case using assms by simp
next
  case (Cons x xs)
  have \<open>\<forall>a\<in>set xs. \<not> tau a\<close> \<open>\<not>tau x\<close> using assms(1) butlast_snoc Cons by auto
  hence last: \<open>xs = taufree (xs @ [b])\<close> using Cons by auto
  have \<open>taufree (x#xs@[b]) = x#taufree (xs @ [b])\<close> using \<open>\<not>tau x\<close> by auto
  hence \<open>x # xs = x# taufree (xs@ [b])\<close> using last by auto
  then show ?case using Cons.prems last by auto
qed

definition succs :: "'a \<Rightarrow> 's set \<Rightarrow> 's set" where
\<open>succs a Q  = {q1. \<exists>q\<in> Q. q \<Rightarrow>^a q1}\<close>

primrec succs_seq_rec :: "'a list \<Rightarrow> 's set \<Rightarrow> 's set" where
\<open>succs_seq_rec [] Q  = Q\<close> |
\<open>succs_seq_rec (a#as) Q  = succs a (succs_seq_rec as Q)\<close>

lemma in_s_implies_word_reachable :
  assumes
    \<open>q' \<in> succs_seq_rec (rev A) {q}\<close>
  shows \<open>q \<Rightarrow>$A q'\<close> using assms
proof (induct arbitrary: q' rule: rev_induct)
  case Nil
  hence \<open>q' = q\<close> by auto
  hence \<open>q \<Rightarrow>^\<tau> q'\<close> by (simp add: steps.refl)
  thus \<open>q \<Rightarrow>$[] q'\<close> by simp
next
  case (snoc a as)
  hence \<open>q' \<in> succs_seq_rec (a#(rev as)) {q}\<close> by simp
  hence \<open>q' \<in> succs a (succs_seq_rec (rev as) {q})\<close> by simp
  then obtain q0 where \<open>q0 \<in> succs_seq_rec (rev as) {q}\<close>
    and \<open>q0 \<Rightarrow>^a q'\<close> using succs_def  by auto
  hence \<open>q \<Rightarrow>$as q0\<close> using snoc.hyps by auto
  thus \<open>q \<Rightarrow>$(as @ [a]) q'\<close> using \<open>q0 \<Rightarrow>^a q'\<close> rev_seq_step_concat by auto
qed

lemma word_reachable_implies_in_s :
  assumes
    \<open>q \<Rightarrow>$A q'\<close>
    \<open>A \<noteq> []\<close>
  shows \<open>q' \<in> succs_seq_rec (rev A) {q}\<close> using assms(1)
proof (induct arbitrary: q' rule: rev_nonempty_induct[OF assms(2)])
  case single: (1 a)
  hence \<open>q \<Rightarrow>^a q'\<close> by blast
  hence \<open>q' \<in> succs a {q}\<close> using succs_def by blast
  thus ?case by simp
next
  case snoc: (2 a as)
  then obtain q0 where \<open>q \<Rightarrow>$as q0\<close> and \<open>q0 \<Rightarrow>^a q'\<close> using rev_seq_split by blast
  hence in_succs: \<open>q0 \<in> succs_seq_rec (rev as) {q}\<close> using snoc.hyps by auto
  hence \<open>\<exists>q0 \<in> succs_seq_rec (rev as) {q}. q0 \<Rightarrow>^a q'\<close> using \<open>q0 \<Rightarrow>^a q'\<close> by auto
  hence \<open>q' \<in> succs a (succs_seq_rec (rev as) {q})\<close> using succs_def by auto
  hence \<open>q' \<in> succs_seq_rec (a#(rev as)) {q}\<close> by simp
  thus ?case by simp
qed

lemma simp_succs_seq_rev:
  assumes
    \<open>Q = succs_seq_rec (rev A) {q0}\<close>
  shows
    \<open>succs a Q = succs_seq_rec (rev (A@[a])) {q0}\<close>
proof -
  show ?thesis by (simp add: assms)
qed

end
end


\<^marker>\<open>creator Bernhard Pöttinger\<close>

chapter \<open>Auxiliary\<close>
theory Auxiliary \<comment> \<open>name Misc already taken\<close>
imports Main Pigeonhole
begin

paragraph \<open>Summary\<close>
text \<open>Some important definitions/abbreviations,
and many random auxiliary results on lists/sets/functions.\<close>

paragraph \<open>Major Definitions\<close>
text \<open>\<^item> restrict N x0 f: restrict function f to domain N, provide default value x0 outside N
\<^item> combine N1 N2 x0 f1 f2: combine f1 and f2 into a new function, provide default value outside
  their domains. If N1 and N2 overlap then f1 takes precedence.
\<^item> @{term eq_on} f1 f2 X: do f1 and f2 agree on X?

We have to introduce vacuously named definitions for sets of lists to safe space
(the set comprehensions already represent basically the minimal description of these sets,
we can only use arbitrary names to obtain shorter names):
\<^item> @{term "l_lists N k"}: originally inspired by length less than constructed from elements in N
\<^item> @{term "l_lists' N k"}: @{term l_lists} including empty list
\<^item> @{term "k_lists N k"}: lists of exactly length k from elements in N
\<^item> @{term "ck_lists N K"}: circular @{term k_lists} (@{term "head xs = last xs"})
\<^item> @{term "cl_lists N k"}: circular @{term l_lists} (@{term "head xs = last xs"})\<close>

section \<open>Important Definitions and related lemmas\<close>

abbreviation restrict where
  "restrict N x0 f \<equiv> \<lambda>n. if n \<in> N then f n else x0"

abbreviation combine where
  "combine N1 N2 x0 f1 f2 \<equiv> \<lambda>n. if n \<in> N1 then f1 n else if n \<in> N2 then f2 n else x0"

(* same as combine except that sometimes its advantageous to use definitions *)
definition combined where
  "combined N1 N2 x0 f1 f2 \<equiv> \<lambda>n. if n \<in> N1 then f1 n else if n \<in> N2 then f2 n else x0"

lemma combine_commute[simp]:
  assumes "N1 \<inter> N2 = {}"
  shows "combine N1 N2 x0 f1 f2 = combine N2 N1 x0 f2 f1"
proof
  fix n
  show "combine N1 N2 x0 f1 f2 n = combine N2 N1 x0 f2 f1 n"
    using assms by auto
qed

abbreviation eq_on ("(_ =/ _/ on _)" [50,0,50] 50) where
  "eq_on f1 f2 X \<equiv> \<forall>x \<in> X. f1 x = f2 x"

lemma on_eq_superset:
  "X \<subseteq> Y \<Longrightarrow> f1 = f2 on Y \<Longrightarrow> f1 = f2 on X"
  by auto

lemma eq_on_unionI:
  assumes "f1 = f2 on X" "f1 = f2 on Y"
  shows "f1 = f2 on (X \<union> Y)"
  using assms
  by auto

lemma eq_on_refl: "f = f on X"
  by simp

definition "l_lists  X k \<equiv> { xs. set xs \<subseteq> X \<and> length xs < k \<and> length xs \<ge> 1 }"
definition "l_lists' X k \<equiv> { xs. set xs \<subseteq> X \<and> length xs < k }"
definition "k_lists  X k \<equiv> { xs. set xs \<subseteq> X \<and> length xs = k }"
definition "ck_lists  N k \<equiv> { xs. length xs = k \<and> set xs \<subseteq> N \<and> hd xs = last xs }"
definition "cl_lists  N k \<equiv> { xs. k \<ge> 1 \<and> length xs < k \<and> set xs \<subseteq> N \<and> hd xs = last xs }"

section \<open>Auxiliary stuff\<close>

lemma ck_lists_props[simp]:
  "xs \<in> ck_lists X k \<Longrightarrow> length xs = k"
  "xs \<in> ck_lists X k \<Longrightarrow> set xs \<subseteq> X"
  "xs \<in> ck_lists X k \<Longrightarrow> k \<ge> 1 \<Longrightarrow> xs \<noteq> []"
  "xs \<in> ck_lists X k \<Longrightarrow> k \<ge> 1 \<Longrightarrow> hd xs = last xs"
  unfolding ck_lists_def by auto

lemma l_lists_dom: "xs \<in> l_lists X k \<Longrightarrow> set xs \<subseteq> X" unfolding l_lists_def by auto
lemma k_lists_dom: "xs \<in> k_lists X k \<Longrightarrow> set xs \<subseteq> X" unfolding k_lists_def by auto

lemma l_lists_k_lists_union: "k \<ge> 1 \<Longrightarrow> l_lists X k \<union> k_lists X k = l_lists X (Suc k)"
  unfolding l_lists_def k_lists_def
  by auto

lemma l_lists_k_lists_disjoint: "k \<ge> 1 \<Longrightarrow> l_lists X k \<inter> k_lists X k = {}"
  unfolding l_lists_def k_lists_def
  by auto

lemma l_lists_finite:
  assumes "finite X"
  shows "finite (l_lists X l)"
  using assms
  apply (rule rev_finite_subset[OF finite_lists_length_le[of X l]])
  unfolding l_lists_def by auto

lemma l_lists'_finite[simp]:
  assumes "finite X"
  shows "finite (l_lists' X l)"
  using assms
  apply (rule rev_finite_subset[OF finite_lists_length_le[of X l]])
  unfolding l_lists'_def by auto

lemma l_lists'_mono:
  assumes "N \<subseteq> N'" "k \<le> k'"
  shows "l_lists' N k \<subseteq> l_lists' N' k'"
  using assms
  unfolding l_lists'_def
  by auto

lemma "k \<ge> 1 \<Longrightarrow> l_lists X k \<union> {[]} = l_lists' X k"
  unfolding l_lists_def l_lists'_def
  by (auto simp: Suc_leI)

lemma k_lists_nonempty:
  assumes "k \<ge> 1" "xs \<in> k_lists X k"
  shows "length xs = k" "xs \<noteq> []"
  using assms
  unfolding k_lists_def
  by auto

lemma k_lists_nonempty':
  assumes "X \<noteq> {}"
  shows "k_lists X k \<noteq> {}"
proof -
  obtain x where "x \<in> X" using assms by blast
  then have "replicate k x \<in> k_lists X k"
    unfolding k_lists_def
    by auto
  then show "k_lists X k \<noteq> {}"
    by blast
qed

lemma l_lists_eq_l_lists':
  assumes "k \<ge> 1"
  shows "insert [] (l_lists N k) = l_lists' N k"
proof
  show "insert [] (l_lists N k) \<subseteq> l_lists' N k"
    using assms unfolding l_lists_def l_lists'_def by auto
  show "l_lists' N k \<subseteq> insert [] (l_lists N k)"
    using assms unfolding l_lists_def l_lists'_def by (auto simp: Suc_leI)
qed

lemma k_lists_finite:
  assumes "finite X"
  shows "finite (k_lists X l)"
  using assms
  unfolding k_lists_def
  by (simp add: finite_lists_length_eq)

lemma set_hd_in: "length xs \<ge> 1 \<Longrightarrow> set xs \<subseteq> X \<Longrightarrow> hd xs \<in> X"
  by (cases xs) auto

lemma l_lists'_x_Suc:
  "{ n#ns | ns n. (ns,n) \<in> l_lists' X l \<times> X } \<union> {[]} = l_lists' X (Suc l)"
  unfolding l_lists'_def
  apply auto
  subgoal for x
  apply (rule exI[where x="tl x"])
    apply (rule exI[where x="hd x"])
    apply auto
     apply (simp add: list.set_sel(2) subsetD)
    by (metis Nitpick.size_list_simp(2) One_nat_def Suc_less_SucD length_tl)
  done

lemma l_lists'_img_Suc_l:
  "{[]} \<union> (\<lambda>(x,xs). xs@[x]) ` (X \<times> l_lists' X l) = l_lists' X (Suc l)"
  unfolding l_lists_def l_lists'_def
  apply (auto simp: image_def)
  subgoal for x
  apply (rule bexI[where x="last x"])
     apply (rule exI[where x="butlast x"])
     apply auto
     apply (simp add: in_set_butlastD subsetD)
    by (metis Nitpick.size_list_simp(2) One_nat_def Suc_less_SucD length_tl)
  done

lemma l_lists_x_Suc:
  "l \<ge> 1 \<Longrightarrow> { n#ns | ns n. (ns,n) \<in> l_lists X l \<times> X } \<union> { [n'] | n'. n' \<in> X } = l_lists X (Suc l)"
  unfolding l_lists_def
  apply auto
  subgoal for xs
    apply (rule exI[where x="tl xs"])
    apply (rule exI[where x="hd xs"])
    apply auto
       apply (metis One_nat_def hd_Cons_tl list.size(3) not_one_le_zero)
      apply (metis Suc_le_lessD length_greater_0_conv list.set_sel(2) subsetD)
     apply (metis One_nat_def Suc_leI Suc_length_conv le_less length_0_conv list.sel(1) set_hd_in zero_less_diff)
    by (simp add: set_hd_in)
  done

lemma k_lists_x_Suc:
  "l \<ge> 1 \<Longrightarrow> { n#ns | ns n. (ns,n) \<in> k_lists X l \<times> X } = k_lists X (Suc l)"
  unfolding k_lists_def
  apply auto
  subgoal for xs
    apply (rule exI[where x="tl xs"])
    apply (rule exI[where x="hd xs"])
    apply (auto)
      apply (metis hd_Cons_tl list.size(3) nat.simps(3))
     apply (metis Nitpick.size_list_simp(2) list.set_sel(2) nat.simps(3) subsetD)
    by (metis Nitpick.size_list_simp(2) list.set_sel(1) nat.simps(3) subsetD)
  done

lemma notin_count: "count_list xs a = 0 \<Longrightarrow> a \<notin> set xs"
  by (induction xs, auto split: if_splits)

lemma in_count: "count_list xs a \<ge> 1 \<Longrightarrow> a \<in> set xs"
  apply (induction xs, simp)
  subgoal for aa xs
    apply (cases "aa = a")
     apply (simp add: list.set_intros)
    by fastforce
  done

lemma decompose_list_count_list:
  "count_list xs a \<ge> 1 \<Longrightarrow> \<exists>ys zs. xs = ys @ [a] @ zs \<and> a \<notin> set ys"
proof (induction xs rule: induct_list012)
  case 1
  have "count_list [] a = 0"
    by simp
  then have False
    using 1 by simp
  then show ?case
    by simp
next
  case (2 x)
  then have "a = x"
    using in_count[of "[x]" a]
    by simp
  then have "[x] = [] @ [a] @ [] \<and> a \<notin> set []"
    using 2 by simp
  then show ?case
    by blast
next
  case (3 x y zs)
  then show ?case
  proof (cases "x = a")
    case True
    show ?thesis
      apply (rule exI[where x="[]"], rule exI[where x="y # zs"])
      using \<open>x = a\<close> by simp
  next
    case False
    then have "1 \<le> count_list (y # zs) a"
      using 3 by simp
    then obtain ys zss where "y # zs = ys @ [a] @ zss \<and> a \<notin> set ys"
      using 3 by blast
    then have *: "x # y # zs = x # ys @ [a] @ zss \<and> a \<notin> set ys"
      using False by simp
    show ?thesis
      apply (rule exI[where x="x#ys"], rule exI[where x="zss"])
      using * False by simp
  qed
qed

lemma count_list_append_notin:
  "x \<notin> set xs \<Longrightarrow> count_list (xs @ ys) x = count_list ys x"
  by (induction xs, auto)

lemma decompose_list_count_list_multi:
  assumes "count_list xs a \<ge> k"
  shows "\<exists>ys yss. xs = ys @ concat yss \<and> (\<forall>ys \<in> set yss. ys \<noteq> []) \<and> (\<forall>ys \<in> set yss. hd ys = a) \<and> (\<forall> ys \<in> set yss. set ys \<subseteq> set xs) \<and> length yss = k"
  using assms
proof (induct k arbitrary: xs)
  case 0
  then have "xs = xs @ concat [] \<and> (\<forall>ys \<in> set []. ys \<noteq> []) \<and> (\<forall> ys \<in> set []. set [] \<subseteq> set xs) \<and> (hd = \<lambda>ys. a on set [])"
    using notin_count[of xs a] by simp
  then show ?case
    by auto
next
  case (Suc k)
  then obtain ys zs where *: "xs = ys @ [a] @ zs" "a \<notin> set ys"
    using decompose_list_count_list[of xs a] by auto
  then have "count_list zs a \<ge> k"
    using count_list_append_notin[of a ys "[a] @ zs"] Suc by simp
  then obtain us uss where **: "zs = us @ concat uss" "\<forall>us \<in> set uss. hd us = a" "length uss = k" "\<forall>ys \<in> set uss. ys \<noteq> []"
    using Suc by blast
  then have X: "xs = ys @ concat ((a # us) # uss)"
    using * by auto
  show ?case
    apply (rule exI[where x="ys"])
    apply (rule exI[where x="(a # us) # uss"])
    using X ** by auto
qed

lemma merge_k_list_1:
  assumes "k \<ge> 1"
  shows "k_lists N 1 \<union> (\<lambda>(n,ns). ns@[n]) ` (N \<times> l_lists N k) = l_lists N (Suc k)"
proof
  show "k_lists N 1 \<union> (\<lambda>(n, ns). ns @ [n]) ` (N \<times> l_lists N k) \<subseteq> l_lists N (Suc k)"
    unfolding k_lists_def l_lists_def
    using assms by auto
  show "l_lists N (Suc k) \<subseteq> k_lists N 1 \<union> (\<lambda>(n, ns). ns @ [n]) ` (N \<times> l_lists N k)"
  proof
    fix x
    assume A: "x \<in> l_lists N (Suc k)"
    then show "x \<in> k_lists N 1 \<union> (\<lambda>(n, ns). ns @ [n]) ` (N \<times> l_lists N k)"
      using assms
      unfolding k_lists_def l_lists_def
      apply (cases "length x = 1")
       apply (auto)
      apply (rule image_eqI[where x="(last x, butlast x)"])
       apply auto
      using append_butlast_last_id[symmetric, of x] apply fastforce
      using last_in_set[of x] A unfolding l_lists_def  apply (metis One_nat_def list.size(3) not_one_le_zero subsetD)
      using in_set_butlastD[of _ x] A unfolding l_lists_def by (auto simp: subsetD)
  qed
qed

lemma list_decompose_last: "xs \<noteq> [] \<Longrightarrow> \<exists>y ys. xs = ys @ [y]"
proof (induction xs rule: list_nonempty_induct)
  case (single x)
  then show ?case by simp
next
  case (cons x xs)
  then show ?case by auto
qed

lemma set_to_list:
  assumes "finite X"
  shows "\<exists>xs. length xs = card X \<and> set xs = X"
  using assms
proof (induction X rule: finite_induct)
  case empty
  then have "length [] = card {} \<and> set [] = {}"
    by simp
  then show ?case
    by simp
next
  case (insert x F)
  then obtain xs' where "length xs' = card F \<and> set xs' = F"
    by blast
  then have "length (x#xs') = card (insert x F) \<and> set (x#xs') = insert x F"
    using insert by auto
  then show ?case
    by blast
qed

lemma tl_l_lists':
  assumes "ms \<in> l_lists' N l"
  shows "tl ms \<in> l_lists' N l"
  using assms
  unfolding l_lists'_def
  apply auto
  by (metis list.sel(2) list.set_sel(2) subsetD)

lemma sum_reindex_cong_mono:
  fixes f :: "'a \<Rightarrow> 'b :: ordered_comm_monoid_add"
    and g :: "'c \<Rightarrow> 'b"
    and l :: "'c \<Rightarrow> 'a"
  assumes "A \<subseteq> l ` B" "inj l" "\<forall>x \<in> B. f (l x) \<le> g x" "finite B" "\<forall>x \<in> B. g x \<ge> 0"
  shows "(\<Sum>x \<in> A. f x) \<le> (\<Sum>x \<in> B. g x)"
proof -
  have "finite A" using assms finite_surj by blast

  have "(\<Sum>x \<in> A. f x) \<le> (\<Sum>x \<in> l -` A. g x)"
    using \<open>finite A\<close> \<open>A \<subseteq> l ` B\<close> proof (induction A rule: finite_induct)
    case empty
    then show ?case by simp
  next
    case (insert x F)

    have F2: "finite (l -` {x})" using assms by (intro finite_vimageI, simp_all)
    have F3: "finite (l -` F)" using insert assms by (intro finite_vimageI, simp_all)
    have F4: "\<And>x. l -` {l x} = {x}"
      by (smt assms inj_vimage_singleton insert_absorb singletonI singleton_insert_inj_eq' subset_singleton_iff vimageI)

    have G: "\<And>x. x \<in> B \<Longrightarrow> f (l x) \<le> g x"
      using assms by simp

    from insert have "(l -` {x}) \<inter> (l -` F) = {}" by auto
    moreover have "(l -` insert x F) = (l -` {x}) \<union> (l -` F)" using insert by auto
    ultimately show ?case
      using insert
      apply simp
      apply (subst sum.union_disjoint)
      using insert assms F2 F3 F4 apply auto
      apply (rule order_trans[OF add_left_mono[OF insert.IH]])
      using insert apply simp
      apply (rule order_trans[OF add_right_mono[OF G]], simp)
      by simp
  qed

  also have "... \<le> (\<Sum>x \<in> l -` A. g x) + (\<Sum>x \<in> B - (l -` A). g x)"
    using assms sum_nonneg[of "B - (l -` A)" g] add_increasing2 by blast

  also have "... = (\<Sum>x \<in> B. g x)"
    using sum.union_disjoint[of "l -` A" "B - (l -` A)", symmetric] insert assms
    by (metis add.commute sum.subset_diff vimage_subsetI)

  finally show ?thesis .
qed

lemma split_list_concat:
  assumes "xs \<in> set xss"
  shows "\<exists>xss1 xss2. concat xss = concat xss1 @ xs @ concat xss2"
proof -
  obtain xss1 xss2 where *: "xss = xss1 @ xs # xss2"
    using split_list[of xs xss] assms by blast
  show ?thesis
    apply (rule exI[where x=xss1])
    apply (rule exI[where x="xss2"])
    using * by simp
qed

lemma split_list_list:
  assumes "\<exists>xs \<in> set xss. x \<in> set xs"
  shows "\<exists>xss1 xs1 xs2 xss2. concat xss = concat xss1 @ xs1 @ x # xs2 @ concat xss2 \<and> xss = xss1 @ (xs1 @ x # xs2) # xss2"
proof -
  obtain xs where A: "x \<in> set xs" "xs \<in> set xss"
    using assms by blast
  obtain xss1 xss2 where B: "xss = xss1 @ xs # xss2"
    using split_list A by metis
  obtain xs1 xs2 where C: "xs = xs1 @ x # xs2"
    using split_list A by metis

  show ?thesis
    using A B C by auto
qed

lemma butlast_subset[simp]:
  "set (butlast xs) \<subseteq> set xs"
  by (induction xs, auto)

lemma distinct_length_le:
  assumes "set xs \<subseteq> X" "distinct xs" "finite X"
  shows "length xs \<le> card X"
proof (rule ccontr)
  assume "\<not> length xs \<le> card X"
  then have "length xs > card X" by simp
  then obtain xs1 xs2 xs3 x where "xs = xs1 @ x # xs2 @ x # xs3"
    using pigeonhole_split_list[of X xs] assms by auto
  then show False using assms by simp
qed

lemma distinct_from_concat:
  "distinct (concat xss) \<Longrightarrow> \<forall>xs \<in> set xss. xs \<noteq> [] \<Longrightarrow> \<forall>xs \<in> set xss. distinct xs"
  by (induction xss, simp_all)

lemma length_length_concat:
  assumes "\<forall>xs\<in>set xss. xs \<noteq> []"
  shows "length xss \<le> length (concat xss)"
  using assms
  apply (induction xss, simp)
  by (simp, metis Suc_leI le_neq_implies_less length_greater_0_conv less_add_same_cancel2 less_imp_le_nat less_trans_Suc)

lemma length_length_concat_in:
  assumes "xss \<noteq> []" "xs \<in> set xss"
  shows "length xs \<le> length (concat xss)"
  using assms
proof (induction xss rule: list_nonempty_induct)
  case (single x)
  then show ?case by auto
next
  case (cons xs' xss')
  then show ?case
    by (cases "xs' = xs", auto)
qed

lemma length_concat_le_length: "length (concat xss) < l \<Longrightarrow> \<forall>xs \<in> set xss. xs \<noteq> [] \<Longrightarrow> length xss < l"
  apply (induction xss arbitrary: l, simp, simp)
  by (meson length_greater_0_conv less_add_same_cancel2 less_trans_Suc)

lemma length_concat_le: "length (concat xss) < n \<Longrightarrow> \<forall>xs \<in> set xss. length xs < n"
  by (induction xss, auto)

lemma distinct_map_hd:
  "distinct (concat xss) \<Longrightarrow> \<forall>xs \<in> set xss. xs \<noteq> [] \<Longrightarrow> distinct (map hd xss)"
  apply (induction xss, simp_all) by (smt UN_I disjoint_iff_not_equal hd_in_set imageE)

lemma concat_cons_length_hd_hd: "xss \<noteq> [] \<Longrightarrow> \<forall>xs \<in> set xss. xs \<noteq> [] \<Longrightarrow> (concat (xs # xss)) ! (length xs) = hd (hd xss)"
  apply (induction xs, simp)
   apply (metis append_is_Nil_conv concat.simps(2) hd_Cons_tl hd_append2 hd_conv_nth hd_in_set)
  by simp

lemma hd_append_Cons_hd[simp]: "hd (xs @ [hd ys]) = hd (xs @ ys)"
  apply (induction xs)
  by auto

lemma length_ge_2:
  assumes "N1 \<inter> N2 = {}" "n1 \<in> N1" "n2 \<in> N2" "n1 \<in> set ns" "n2 \<in> set ns"
  shows "length ns \<ge> 2"
proof (rule ccontr)
  assume "\<not> 2 \<le> length ns"
  then have "length ns = 0 \<or> length ns = 1" by linarith
  then consider (a) "length ns = 0" | (b) "length ns = 1" by blast
  then show False
  proof cases
    case a
    then show ?thesis using assms by simp
  next
    case b
    then obtain n where "ns = [n]" by (metis One_nat_def Suc_length_conv length_0_conv)
    then show False using assms by auto
  qed
qed

lemma hd_hd_concat_hd:
  assumes "ns = concat nss" "\<forall>ns \<in> set nss. ns \<noteq> []" "nss \<noteq> []"
  shows "hd (hd nss) = hd ns"
  using assms
  by (metis concat.simps(2) hd_Cons_tl hd_append2 list.set_sel(1))

lemma set_concat_subset:
  assumes "set ns \<subseteq> N" "set ns' \<subseteq> set ns"
  shows "set (ns @ ns') \<subseteq> N"
  using assms by simp

lemma finiteUn: "finite Z \<Longrightarrow> Z = X \<union> Y \<Longrightarrow> finite X \<and> finite Y"
  by simp
fun indexed_list where
"indexed_list xs i = (if i < length xs then Some (xs!i) else None)"

lemma count_list_sum:
  "count_list xs m = (\<Sum>x \<leftarrow> xs. if x = m then 1 else 0)"
  by (induction xs, auto)

lemma "(\<Sum>x \<leftarrow> xs. if x = m then 1 else 0) = (\<Sum>x \<in> set xs. count_list xs x * (if x = m then 1 else 0))"
  using sum_list_map_eq_sum_count by auto

lemma sum_list_map: "(\<Sum>x \<leftarrow> xs. f (g x)) = (\<Sum>x \<leftarrow> map g xs. f x)"
  by (induction xs, auto)

lemma card_count_list:
  fixes X :: "nat set"
  assumes "\<forall>x \<in> X. xs!x = m" "card X \<le> length xs" "finite X" "\<forall>x \<in> X. x < length xs"
  shows "card X \<le> count_list xs m"
proof -
  let ?X = "{x . x \<in> {0..<length xs} \<and> xs!x = m}"
  let ?X' = "{0..<length xs}"

  have S: "X \<subseteq> ?X" using assms by auto
  have SS: "?X \<subseteq> ?X'" by auto

  have "card X = (\<Sum>x \<in> X. 1)" by simp
  also have "... \<le> (\<Sum>x \<in> ?X. 1)" using sum_mono2[OF _ S] by fastforce
  also have "... = (\<Sum>x \<in> ?X. if xs!x = m then 1 else 0)" using assms by simp
  also have "... \<le> (\<Sum>x \<in> ?X'. if xs!x = m then 1 else 0)" using sum_mono2[OF _ SS] by fastforce
  also have "... = (\<Sum>x \<in> set [0..<length xs]. if xs!x = m then 1 else 0)" by simp
  also have "... = (\<Sum>x \<leftarrow> map id [0..<length xs]. if xs!x = m then 1 else 0)"
    using sum_list_distinct_conv_sum_set[of "[0..<length xs]", symmetric] by auto
  also have "... = (\<Sum>x \<leftarrow> map ((!) xs) [0..<length xs]. if x = m then 1 else 0)"
    using sum_list_map by auto
  also have "... = (\<Sum>x \<leftarrow> xs. if x = m then 1 else 0)"
    by (simp add: map_nth)
  also have "... = count_list xs m"
    by (induction xs, auto)
  finally show ?thesis .
qed

lemma finite_index_fun_vimage:
  "finite ((\<lambda>n. if n < length ns then Some (ns ! n) else None) -` {Some m})"
proof -
  let ?f = "\<lambda>n. if n < length ns then Some (ns ! n) else None"

  have "?f -` {Some m} \<subseteq> {0..<length ns}"
    unfolding vimage_def by auto
  moreover have "finite ({0..<length ns})" by simp
  ultimately show ?thesis
    using finite_subset by blast
qed

lemma fold_cons:
  "fold (o) (fs :: ('a \<Rightarrow> 'a) list) (g :: 'a \<Rightarrow> 'a) o h = fold (o) fs (g o h)"
proof (induction fs arbitrary: g)
  case Nil
  then show ?case by simp
next
  case (Cons a fs)
  then show ?case by simp
qed

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2008 Seo Sanghyeon

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Direct product\<close>

theory DirectProduct_ZF imports func_ZF

begin

text\<open>This theory considers the direct product of binary operations.
  Contributed by Seo Sanghyeon.\<close>

subsection\<open>Definition\<close>

text\<open>In group theory the notion of direct product provides a natural
  way of creating a new group from two given groups.\<close>

text\<open>Given $(G,\cdot)$  and $(H,\circ)$
  a new operation $(G\times H, \times )$ is defined as
  $(g, h) \times (g', h') = (g \cdot g', h \circ h')$.\<close>

definition
  "DirectProduct(P,Q,G,H) \<equiv>
  {\<langle>x,\<langle>P`\<langle>fst(fst(x)),fst(snd(x))\<rangle> , Q`\<langle>snd(fst(x)),snd(snd(x))\<rangle>\<rangle>\<rangle>.
  x \<in> (G\<times>H)\<times>(G\<times>H)}"

text\<open>We define a context called \<open>direct0\<close> which
  holds an assumption that $P, Q$ are binary operations on
  $G,H$, resp. and denotes $R$ as the direct product of
  $(G,P)$ and $(H,Q)$.\<close>

locale direct0 =
  fixes P Q G H
  assumes Pfun: "P : G\<times>G\<rightarrow>G"
  assumes Qfun: "Q : H\<times>H\<rightarrow>H"
  fixes R
  defines Rdef [simp]: "R \<equiv> DirectProduct(P,Q,G,H)"

text\<open>The direct product of binary operations is a binary operation.\<close>

lemma (in direct0) DirectProduct_ZF_1_L1:
  shows "R : (G\<times>H)\<times>(G\<times>H)\<rightarrow>G\<times>H"
proof -
  from Pfun Qfun have "\<forall>x\<in>(G\<times>H)\<times>(G\<times>H).
    \<langle>P`\<langle>fst(fst(x)),fst(snd(x))\<rangle>,Q`\<langle>snd(fst(x)),snd(snd(x))\<rangle>\<rangle> \<in> G\<times>H"
    by auto
  then show ?thesis using ZF_fun_from_total DirectProduct_def
    by simp
qed

text\<open>And it has the intended value.\<close>

lemma (in direct0) DirectProduct_ZF_1_L2:
  shows "\<forall>x\<in>(G\<times>H). \<forall>y\<in>(G\<times>H).
  R`\<langle>x,y\<rangle> = \<langle>P`\<langle>fst(x),fst(y)\<rangle>,Q`\<langle>snd(x),snd(y)\<rangle>\<rangle>"
  using DirectProduct_def DirectProduct_ZF_1_L1 ZF_fun_from_tot_val
  by simp

text\<open>And the value belongs to the set the operation is defined on.\<close>

lemma (in direct0) DirectProduct_ZF_1_L3:
  shows "\<forall>x\<in>(G\<times>H). \<forall>y\<in>(G\<times>H). R`\<langle>x,y\<rangle> \<in> G\<times>H"
  using DirectProduct_ZF_1_L1 by simp

subsection\<open>Associative and commutative operations\<close>

text\<open>If P and Q are both associative or commutative operations,
  the direct product of P and Q has the same property.\<close>

text\<open>Direct product of commutative operations is commutative.\<close>

lemma (in direct0) DirectProduct_ZF_2_L1:
  assumes "P {is commutative on} G" and "Q {is commutative on} H"
  shows "R {is commutative on} G\<times>H"
proof -
  from assms have "\<forall>x\<in>(G\<times>H). \<forall>y\<in>(G\<times>H). R`\<langle>x,y\<rangle> = R`\<langle>y,x\<rangle>"
    using DirectProduct_ZF_1_L2 IsCommutative_def by simp
  then show ?thesis using IsCommutative_def by simp
qed

text\<open>Direct product of associative operations is associative.\<close>

lemma (in direct0) DirectProduct_ZF_2_L2:
  assumes "P {is associative on} G" and "Q {is associative on} H"
  shows "R {is associative on} G\<times>H"
proof -
  have "\<forall>x\<in>G\<times>H. \<forall>y\<in>G\<times>H. \<forall>z\<in>G\<times>H. R`\<langle>R`\<langle>x,y\<rangle>,z\<rangle> =
    \<langle>P`\<langle>P`\<langle>fst(x),fst(y)\<rangle>,fst(z)\<rangle>,Q`\<langle>Q`\<langle>snd(x),snd(y)\<rangle>,snd(z)\<rangle>\<rangle>"
    using DirectProduct_ZF_1_L2 DirectProduct_ZF_1_L3
    by auto
  moreover have "\<forall>x\<in>G\<times>H. \<forall>y\<in>G\<times>H. \<forall>z\<in>G\<times>H. R`\<langle>x,R`\<langle>y,z\<rangle>\<rangle> =
    \<langle>P`\<langle>fst(x),P`\<langle>fst(y),fst(z)\<rangle>\<rangle>,Q`\<langle>snd(x),Q`\<langle>snd(y),snd(z)\<rangle>\<rangle>\<rangle>"
    using DirectProduct_ZF_1_L2 DirectProduct_ZF_1_L3 by auto
  ultimately have "\<forall>x\<in>G\<times>H. \<forall>y\<in>G\<times>H. \<forall>z\<in>G\<times>H. R`\<langle>R`\<langle>x,y\<rangle>,z\<rangle> = R`\<langle>x,R`\<langle>y,z\<rangle>\<rangle>"
    using assms IsAssociative_def by simp
  then show ?thesis
    using DirectProduct_ZF_1_L1 IsAssociative_def by simp
qed

end


(*
 * Copyright Brian Huffman, PSU; Jeremy Dawson and Gerwin Klein, NICTA
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Comprehension syntax for bit expressions\<close>

theory Bit_Comprehension
  imports "HOL-Library.Word"
begin

class bit_comprehension = ring_bit_operations +
  fixes set_bits :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> 'a\<close>  (binder \<open>BITS \<close> 10)
  assumes set_bits_bit_eq: \<open>set_bits (bit a) = a\<close>
begin

lemma set_bits_False_eq [simp]:
  \<open>(BITS _. False) = 0\<close>
  using set_bits_bit_eq [of 0] by (simp add: bot_fun_def)

end

instantiation int :: bit_comprehension
begin

definition
  \<open>set_bits f = (
      if \<exists>n. \<forall>m\<ge>n. f m = f n then
      let n = LEAST n. \<forall>m\<ge>n. f m = f n
      in signed_take_bit n (horner_sum of_bool 2 (map f [0..<Suc n]))
     else 0 :: int)\<close>

instance proof
  fix k :: int
  from int_bit_bound [of k]
  obtain n where *: \<open>\<And>m. n \<le> m \<Longrightarrow> bit k m \<longleftrightarrow> bit k n\<close>
    and **: \<open>n > 0 \<Longrightarrow> bit k (n - 1) \<noteq> bit k n\<close>
    by blast
  then have ***: \<open>\<exists>n. \<forall>n'\<ge>n. bit k n' \<longleftrightarrow> bit k n\<close>
    by meson
  have l: \<open>(LEAST q. \<forall>m\<ge>q. bit k m \<longleftrightarrow> bit k q) = n\<close>
    apply (rule Least_equality)
    using * apply blast
    apply (metis "**" One_nat_def Suc_pred le_cases le0 neq0_conv not_less_eq_eq)
    done
  show \<open>set_bits (bit k) = k\<close>
    apply (simp only: *** set_bits_int_def horner_sum_bit_eq_take_bit l)
    apply simp
    apply (rule bit_eqI)
    apply (simp add: bit_signed_take_bit_iff min_def)
    apply (auto simp add: not_le bit_take_bit_iff dest: *)
    done
qed

end

lemma int_set_bits_K_False [simp]: "(BITS _. False) = (0 :: int)"
  by (simp add: set_bits_int_def)

lemma int_set_bits_K_True [simp]: "(BITS _. True) = (-1 :: int)"
  by (simp add: set_bits_int_def)

instantiation word :: (len) bit_comprehension
begin

definition word_set_bits_def:
  \<open>(BITS n. P n) = (horner_sum of_bool 2 (map P [0..<LENGTH('a)]) :: 'a word)\<close>

instance by standard
  (simp add: word_set_bits_def horner_sum_bit_eq_take_bit)

end

lemma bit_set_bits_word_iff:
  \<open>bit (set_bits P :: 'a::len word) n \<longleftrightarrow> n < LENGTH('a) \<and> P n\<close>
  by (auto simp add: word_set_bits_def bit_horner_sum_bit_word_iff)

lemma set_bits_K_False [simp]:
  \<open>set_bits (\<lambda>_. False) = (0 :: 'a :: len word)\<close>
  by (rule bit_word_eqI) (simp add: bit_set_bits_word_iff)

lemma set_bits_int_unfold':
  \<open>set_bits f =
    (if \<exists>n. \<forall>n'\<ge>n. \<not> f n' then
      let n = LEAST n. \<forall>n'\<ge>n. \<not> f n'
      in horner_sum of_bool 2 (map f [0..<n])
     else if \<exists>n. \<forall>n'\<ge>n. f n' then
      let n = LEAST n. \<forall>n'\<ge>n. f n'
      in signed_take_bit n (horner_sum of_bool 2 (map f [0..<n] @ [True]))
     else 0 :: int)\<close>
proof (cases \<open>\<exists>n. \<forall>m\<ge>n. f m \<longleftrightarrow> f n\<close>)
  case True
  then obtain q where q: \<open>\<forall>m\<ge>q. f m \<longleftrightarrow> f q\<close>
    by blast
  define n where \<open>n = (LEAST n. \<forall>m\<ge>n. f m \<longleftrightarrow> f n)\<close>
  have \<open>\<forall>m\<ge>n. f m \<longleftrightarrow> f n\<close>
    unfolding n_def
    using q by (rule LeastI [of _ q])
  then have n: \<open>\<And>m. n \<le> m \<Longrightarrow> f m \<longleftrightarrow> f n\<close>
    by blast
  from n_def have n_eq: \<open>(LEAST q. \<forall>m\<ge>q. f m \<longleftrightarrow> f n) = n\<close>
    by (smt Least_equality Least_le \<open>\<forall>m\<ge>n. f m = f n\<close> dual_order.refl le_refl n order_refl)
  show ?thesis
  proof (cases \<open>f n\<close>)
    case False
    with n have *: \<open>\<exists>n. \<forall>n'\<ge>n. \<not> f n'\<close>
      by blast
    have **: \<open>(LEAST n. \<forall>n'\<ge>n. \<not> f n') = n\<close>
      using False n_eq by simp
    from * False show ?thesis
    apply (simp add: set_bits_int_def n_def [symmetric] ** del: upt.upt_Suc)
    apply (auto simp add: take_bit_horner_sum_bit_eq
      bit_horner_sum_bit_iff take_map
      signed_take_bit_def set_bits_int_def
      horner_sum_bit_eq_take_bit simp del: upt.upt_Suc)
    done
  next
    case True
    with n have *: \<open>\<exists>n. \<forall>n'\<ge>n. f n'\<close>
      by blast
    have ***: \<open>\<not> (\<exists>n. \<forall>n'\<ge>n. \<not> f n')\<close>
      apply (rule ccontr)
      using * nat_le_linear by auto
    have **: \<open>(LEAST n. \<forall>n'\<ge>n. f n') = n\<close>
      using True n_eq by simp
    from * *** True show ?thesis
    apply (simp add: set_bits_int_def n_def [symmetric] ** del: upt.upt_Suc)
    apply (auto simp add: take_bit_horner_sum_bit_eq
      bit_horner_sum_bit_iff take_map
      signed_take_bit_def set_bits_int_def
      horner_sum_bit_eq_take_bit nth_append simp del: upt.upt_Suc)
    done
  qed
next
  case False
  then show ?thesis
    by (auto simp add: set_bits_int_def)
qed

inductive wf_set_bits_int :: "(nat \<Rightarrow> bool) \<Rightarrow> bool"
  for f :: "nat \<Rightarrow> bool"
where
  zeros: "\<forall>n' \<ge> n. \<not> f n' \<Longrightarrow> wf_set_bits_int f"
| ones: "\<forall>n' \<ge> n. f n' \<Longrightarrow> wf_set_bits_int f"

lemma wf_set_bits_int_simps: "wf_set_bits_int f \<longleftrightarrow> (\<exists>n. (\<forall>n'\<ge>n. \<not> f n') \<or> (\<forall>n'\<ge>n. f n'))"
by(auto simp add: wf_set_bits_int.simps)

lemma wf_set_bits_int_const [simp]: "wf_set_bits_int (\<lambda>_. b)"
by(cases b)(auto intro: wf_set_bits_int.intros)

lemma wf_set_bits_int_fun_upd [simp]:
  "wf_set_bits_int (f(n := b)) \<longleftrightarrow> wf_set_bits_int f" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain n'
    where "(\<forall>n''\<ge>n'. \<not> (f(n := b)) n'') \<or> (\<forall>n''\<ge>n'. (f(n := b)) n'')"
    by(auto simp add: wf_set_bits_int_simps)
  hence "(\<forall>n''\<ge>max (Suc n) n'. \<not> f n'') \<or> (\<forall>n''\<ge>max (Suc n) n'. f n'')" by auto
  thus ?rhs by(auto simp only: wf_set_bits_int_simps)
next
  assume ?rhs
  then obtain n' where "(\<forall>n''\<ge>n'. \<not> f n'') \<or> (\<forall>n''\<ge>n'. f n'')" (is "?wf f n'")
    by(auto simp add: wf_set_bits_int_simps)
  hence "?wf (f(n := b)) (max (Suc n) n')" by auto
  thus ?lhs by(auto simp only: wf_set_bits_int_simps)
qed

lemma wf_set_bits_int_Suc [simp]:
  "wf_set_bits_int (\<lambda>n. f (Suc n)) \<longleftrightarrow> wf_set_bits_int f" (is "?lhs \<longleftrightarrow> ?rhs")
by(auto simp add: wf_set_bits_int_simps intro: le_SucI dest: Suc_le_D)

context
  fixes f
  assumes wff: "wf_set_bits_int f"
begin

lemma int_set_bits_unfold_BIT:
  "set_bits f = of_bool (f 0) + (2 :: int) * set_bits (f \<circ> Suc)"
using wff proof cases
  case (zeros n)
  show ?thesis
  proof(cases "\<forall>n. \<not> f n")
    case True
    hence "f = (\<lambda>_. False)" by auto
    thus ?thesis using True by(simp add: o_def)
  next
    case False
    then obtain n' where "f n'" by blast
    with zeros have "(LEAST n. \<forall>n'\<ge>n. \<not> f n') = Suc (LEAST n. \<forall>n'\<ge>Suc n. \<not> f n')"
      by(auto intro: Least_Suc)
    also have "(\<lambda>n. \<forall>n'\<ge>Suc n. \<not> f n') = (\<lambda>n. \<forall>n'\<ge>n. \<not> f (Suc n'))" by(auto dest: Suc_le_D)
    also from zeros have "\<forall>n'\<ge>n. \<not> f (Suc n')" by auto
    ultimately show ?thesis using zeros
      apply (simp (no_asm_simp) add: set_bits_int_unfold' exI
        del: upt.upt_Suc flip: map_map split del: if_split)
      apply (simp only: map_Suc_upt upt_conv_Cons)
      apply simp
      done
  qed
next
  case (ones n)
  show ?thesis
  proof(cases "\<forall>n. f n")
    case True
    hence "f = (\<lambda>_. True)" by auto
    thus ?thesis using True by(simp add: o_def)
  next
    case False
    then obtain n' where "\<not> f n'" by blast
    with ones have "(LEAST n. \<forall>n'\<ge>n. f n') = Suc (LEAST n. \<forall>n'\<ge>Suc n. f n')"
      by(auto intro: Least_Suc)
    also have "(\<lambda>n. \<forall>n'\<ge>Suc n. f n') = (\<lambda>n. \<forall>n'\<ge>n. f (Suc n'))" by(auto dest: Suc_le_D)
    also from ones have "\<forall>n'\<ge>n. f (Suc n')" by auto
    moreover from ones have "(\<exists>n. \<forall>n'\<ge>n. \<not> f n') = False"
      by(auto intro!: exI[where x="max n m" for n m] simp add: max_def split: if_split_asm)
    moreover hence "(\<exists>n. \<forall>n'\<ge>n. \<not> f (Suc n')) = False"
      by(auto elim: allE[where x="Suc n" for n] dest: Suc_le_D)
    ultimately show ?thesis using ones
      apply (simp (no_asm_simp) add: set_bits_int_unfold' exI split del: if_split)
      apply (auto simp add: Let_def hd_map map_tl[symmetric] map_map[symmetric] map_Suc_upt upt_conv_Cons signed_take_bit_Suc
        not_le simp del: map_map)
      done
  qed
qed

lemma bin_last_set_bits [simp]:
  "odd (set_bits f :: int) = f 0"
  by (subst int_set_bits_unfold_BIT) simp_all

lemma bin_rest_set_bits [simp]:
  "set_bits f div (2 :: int) = set_bits (f \<circ> Suc)"
  by (subst int_set_bits_unfold_BIT) simp_all

lemma bin_nth_set_bits [simp]:
  "bit (set_bits f :: int) m \<longleftrightarrow> f m"
using wff proof (induction m arbitrary: f)
  case 0
  then show ?case
    by (simp add: Bit_Comprehension.bin_last_set_bits)
next
  case Suc
  from Suc.IH [of "f \<circ> Suc"] Suc.prems show ?case
    by (simp add: Bit_Comprehension.bin_rest_set_bits comp_def bit_Suc)
qed

end

end


(*  Title:      HOL/HOLCF/ex/Dnat.thy
    Author:     Franz Regensburger

Theory for the domain of natural numbers  dnat = one ++ dnat
*)

theory Dnat
imports HOLCF
begin

domain dnat = dzero | dsucc (dpred :: dnat)

definition
  iterator :: "dnat -> ('a -> 'a) -> 'a -> 'a" where
  "iterator = fix $ (LAM h n f x.
    case n of dzero => x
      | dsucc $ m => f $ (h $ m $ f $ x))"

text {*
  \medskip Expand fixed point properties.
*}

lemma iterator_def2:
  "iterator = (LAM n f x. case n of dzero => x | dsucc$m => f$(iterator$m$f$x))"
  apply (rule trans)
  apply (rule fix_eq2)
  apply (rule iterator_def [THEN eq_reflection])
  apply (rule beta_cfun)
  apply simp
  done

text {* \medskip Recursive properties. *}

lemma iterator1: "iterator $ UU $ f $ x = UU"
  apply (subst iterator_def2)
  apply simp
  done

lemma iterator2: "iterator $ dzero $ f $ x = x"
  apply (subst iterator_def2)
  apply simp
  done

lemma iterator3: "n ~= UU ==> iterator $ (dsucc $ n) $ f $ x = f $ (iterator $ n $ f $ x)"
  apply (rule trans)
   apply (subst iterator_def2)
   apply simp
  apply (rule refl)
  done

lemmas iterator_rews = iterator1 iterator2 iterator3

lemma dnat_flat: "ALL x y::dnat. x<<y --> x=UU | x=y"
  apply (rule allI)
  apply (induct_tac x)
    apply fast
   apply (rule allI)
   apply (case_tac y)
     apply simp
    apply simp
   apply simp
  apply (rule allI)
  apply (case_tac y)
    apply (fast intro!: bottomI)
   apply (thin_tac "ALL y. dnat << y --> dnat = UU | dnat = y")
   apply simp
  apply (simp (no_asm_simp))
  apply (drule_tac x="dnata" in spec)
  apply simp
  done

end


(*
   File:     Laws_of_Large_Numbers.thy
   Author:   Manuel Eberl, TU München
*)
subsection \<open>Example\<close>
theory Laws_of_Large_Numbers_Example
  imports Laws_of_Large_Numbers
begin

text \<open>
  As an example, we apply the strong law to the proportion of successes in an independent sequence
  of coin flips with success probability \<open>p\<close>. We will show that proportion of successful coin
  flips among the first \<open>n\<close> attempts almost surely converges to \<open>p\<close> as \<open>n \<rightarrow> \<infinity>\<close>.
\<close>

(* TODO: Move *)
lemma (in prob_space) indep_vars_iff_distr_eq_PiM':
  fixes I :: "'i set" and X :: "'i \<Rightarrow> 'a \<Rightarrow> 'b"
  assumes "I \<noteq> {}"
  assumes rv: "\<And>i. i \<in> I \<Longrightarrow> random_variable (M' i) (X i)"
  shows "indep_vars M' X I \<longleftrightarrow>
           distr M (\<Pi>\<^sub>M i\<in>I. M' i) (\<lambda>x. \<lambda>i\<in>I. X i x) = (\<Pi>\<^sub>M i\<in>I. distr M (M' i) (X i))"
proof -
  from assms obtain j where j: "j \<in> I"
    by auto
  define N' where "N' = (\<lambda>i. if i \<in> I then M' i else M' j)"
  define Y where "Y = (\<lambda>i. if i \<in> I then X i else X j)"
  have rv: "random_variable (N' i) (Y i)" for i
    using j by (auto simp: N'_def Y_def intro: assms)

  have "indep_vars M' X I = indep_vars N' Y I"
    by (intro indep_vars_cong) (auto simp: N'_def Y_def)
  also have "\<dots> \<longleftrightarrow> distr M (\<Pi>\<^sub>M i\<in>I. N' i) (\<lambda>x. \<lambda>i\<in>I. Y i x) = (\<Pi>\<^sub>M i\<in>I. distr M (N' i) (Y i))"
    by (intro indep_vars_iff_distr_eq_PiM rv assms)
  also have "(\<Pi>\<^sub>M i\<in>I. N' i) = (\<Pi>\<^sub>M i\<in>I. M' i)"
    by (intro PiM_cong) (simp_all add: N'_def)
  also have "(\<lambda>x. \<lambda>i\<in>I. Y i x) = (\<lambda>x. \<lambda>i\<in>I. X i x)"
    by (simp_all add: Y_def fun_eq_iff)
  also have "(\<Pi>\<^sub>M i\<in>I. distr M (N' i) (Y i)) = (\<Pi>\<^sub>M i\<in>I. distr M (M' i) (X i))"
    by (intro PiM_cong distr_cong) (simp_all add: N'_def Y_def)
  finally show ?thesis .
qed

(* TODO: Move *)
lemma indep_vars_PiM_components:
  assumes "\<And>i. i \<in> A \<Longrightarrow> prob_space (M i)"
  shows   "prob_space.indep_vars (PiM A M) M (\<lambda>i f. f i) A"
proof (cases "A = {}")
  case False
  have "distr (Pi\<^sub>M A M) (Pi\<^sub>M A M) (\<lambda>x. restrict x A) = distr (Pi\<^sub>M A M) (Pi\<^sub>M A M) (\<lambda>x. x)"
    by (intro distr_cong) (auto simp: restrict_def space_PiM PiE_def extensional_def Pi_def)
  also have "\<dots> = Pi\<^sub>M A M"
    by simp
  also have "\<dots> = Pi\<^sub>M A (\<lambda>i. distr (Pi\<^sub>M A M) (M i) (\<lambda>f. f i))"
    by (intro PiM_cong refl, subst distr_PiM_component) (auto simp: assms)
  finally show ?thesis
    by (subst prob_space.indep_vars_iff_distr_eq_PiM') (simp_all add: prob_space_PiM assms False)
next
  case True
  interpret prob_space "PiM A M"
    by (intro prob_space_PiM assms)
  show ?thesis
    unfolding indep_vars_def indep_sets_def by (auto simp: True)
qed

(* TODO: Move *)
lemma indep_vars_PiM_components':
  assumes "\<And>i. i \<in> A \<Longrightarrow> prob_space (M i)"
  assumes "\<And>i. i \<in> A \<Longrightarrow> g i \<in> M i \<rightarrow>\<^sub>M N i"
  shows   "prob_space.indep_vars (PiM A M) N (\<lambda>i f. g i (f i)) A"
  by (rule prob_space.indep_vars_compose2[OF prob_space_PiM indep_vars_PiM_components])
     (use assms in simp_all)

(* TODO: Move *)
lemma integrable_bernoulli_pmf [intro]:
  fixes f :: "bool \<Rightarrow> 'a :: {banach, second_countable_topology}"
  shows "integrable (bernoulli_pmf p) f"
  by (rule integrable_measure_pmf_finite) auto

(* TODO: Move *)
lemma expectation_bernoulli_pmf:
  fixes f :: "bool \<Rightarrow> 'a :: {banach, second_countable_topology}"
  assumes p: "p \<in> {0..1}"
  shows   "measure_pmf.expectation (bernoulli_pmf p) f = p *\<^sub>R f True + (1 - p) *\<^sub>R f False"
  using p by (subst integral_measure_pmf[of UNIV]) (auto simp: UNIV_bool)

experiment
  fixes p :: real
  assumes p: "p \<in> {0..1}"
begin

definition M :: "(nat \<Rightarrow> bool) measure"
  where "M = (\<Pi>\<^sub>M i\<in>(UNIV :: nat set). measure_pmf (bernoulli_pmf p))"

definition X :: "nat \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> real"
  where "X = (\<lambda>i f. if f i then 1 else 0)"

interpretation prob_space M
  unfolding M_def by (intro prob_space_PiM measure_pmf.prob_space_axioms)

lemma random_variable_component: "random_variable (count_space UNIV) (\<lambda>f. f i)"
  unfolding X_def M_def by measurable

lemma random_variable_X [measurable]: "random_variable borel (X i)"
  unfolding X_def M_def by measurable

lemma distr_M_component: "distr M (count_space UNIV) (\<lambda>f. f i) = measure_pmf (bernoulli_pmf p)"
proof -
  have "distr M (count_space UNIV) (\<lambda>f. f i) = distr M (measure_pmf (bernoulli_pmf p)) (\<lambda>f. f i)"
    by (rule distr_cong) auto
  also have "\<dots> = measure_pmf (bernoulli_pmf p)"
    unfolding M_def by (subst distr_PiM_component) (simp_all add: measure_pmf.prob_space_axioms)
  finally show ?thesis .
qed

lemma distr_M_X:
  "distr M borel (X i) = distr (measure_pmf (bernoulli_pmf p)) borel (\<lambda>b. if b then 1 else 0)"
proof -
  have "distr M borel (X i) = distr (distr M (count_space UNIV) (\<lambda>f. f i))
                                    borel (\<lambda>b. if b then 1 else 0 :: real)"
    by (subst distr_distr) (auto simp: M_def X_def o_def)
  also note distr_M_component[of i]
  finally show ?thesis
    by simp
qed

lemma X_has_expectation: "integrable M (X 0)"
proof -
  have "integrable (bernoulli_pmf p) (\<lambda>b. if b then 1 else 0 :: real)"
    by auto
  also have "measure_pmf (bernoulli_pmf p) = distr M (count_space UNIV) (\<lambda>f. f 0)"
    by (simp add: distr_M_component)
  also have "integrable \<dots> (\<lambda>b. if b then 1 else 0 :: real) = integrable M (X 0)"
    unfolding X_def using random_variable_component by (subst integrable_distr_eq) auto
  finally show ?thesis .
qed

lemma indep: "indep_vars (\<lambda>_. borel) X UNIV"
  unfolding M_def X_def
  by (rule indep_vars_PiM_components') (simp_all add: measure_pmf.prob_space_axioms)

lemma expectation_X: "expectation (X i) = p"
proof -
  have "expectation (X i) =
        lebesgue_integral (distr M (count_space UNIV) (\<lambda>f. f i)) (\<lambda>b. if b then 1 else 0 :: real)"
    by (subst integral_distr) (simp_all add: random_variable_component X_def)
  also have "distr M (count_space UNIV) (\<lambda>x. x i) = measure_pmf (bernoulli_pmf p)"
    by (rule distr_M_component)
  also have "measure_pmf.expectation (bernoulli_pmf p) (\<lambda>b. if b then 1 else 0 :: real) = p"
    using p by (subst integral_bernoulli_pmf) auto
  finally show ?thesis .
qed

theorem "AE f in M. (\<lambda>n. card {i. i < n \<and> f i} / n) \<longlonglongrightarrow> p"
proof -
  have "AE f in M. (\<lambda>n. (\<Sum>i<n. X i f) / real n) \<longlonglongrightarrow> expectation (X 0)"
    by (rule strong_law_of_large_numbers_iid)
       (use indep X_has_expectation in \<open>simp_all add: distr_M_X\<close>)
  also have "expectation (X 0) = p"
    by (simp add: expectation_X)
  also have "(\<lambda>x n. \<Sum>i<n. X i x) = (\<lambda>x n. \<Sum>i\<in>{i\<in>{..<n}. x i}. 1)"
    by (intro ext sum.mono_neutral_cong_right) (auto simp: X_def)
  also have "\<dots> = (\<lambda>x n. real (card {i. i < n \<and> x i}))"
    by simp
  finally show ?thesis .
qed

end

end


(*  Title:       Verification components with MKAs
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

section \<open> Verification components with MKA \<close>

text \<open> We use the forward box operator of antidomain Kleene algebras to derive rules for weakest
liberal preconditions (wlps) of regular programs. \<close>

theory HS_VC_MKA
  imports "KAD.Modal_Kleene_Algebra"

begin

subsection \<open> Verification in AKA \<close>

text \<open>Here we derive verification components with weakest liberal preconditions based on
antidomain Kleene algebra \<close>

no_notation Range_Semiring.antirange_semiring_class.ars_r ("r")
        and HOL.If ("(if (_)/ then (_)/ else (_))" [0, 0, 10] 10)

notation zero_class.zero ("0")

context antidomain_kleene_algebra
begin

\<comment> \<open> Skip \<close>

lemma "|1] x = d x"
  using fbox_one .

\<comment> \<open> Abort \<close>

lemma "|0] q = 1"
  using fbox_zero .

\<comment> \<open> Sequential composition \<close>

lemma "|x \<cdot> y] q = |x] |y] q"
  using fbox_mult .

declare fbox_mult [simp]

\<comment> \<open> Nondeterministic choice \<close>

lemma "|x + y] q = |x] q \<cdot> |y] q"
  using fbox_add2 .

lemma le_fbox_choice_iff: "d p \<le> |x + y]q \<longleftrightarrow> (d p \<le> |x]q) \<and> (d p \<le> |y]q)"
  by (metis local.a_closure' local.ads_d_def local.dnsz.dom_glb_eq local.fbox_add2 local.fbox_def)

\<comment> \<open> Conditional statement \<close> (* by Victor Gomes, Georg Struth *)

definition aka_cond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _" [64,64,64] 63)
  where "if p then x else y = d p \<cdot> x + ad p \<cdot> y"

lemma fbox_export1: "ad p + |x] q = |d p \<cdot> x] q"
  using a_d_add_closure addual.ars_r_def fbox_def fbox_mult by auto

lemma fbox_cond [simp]: "|if p then x else y] q = (ad p + |x] q) \<cdot> (d p + |y] q)"
  using fbox_export1 local.ans_d_def local.fbox_mult
  unfolding aka_cond_def ads_d_def fbox_def by auto

lemma fbox_cond2: "|if p then x else y] q = (d p \<cdot> |x] q) + (ad p \<cdot> |y] q)" (is "?lhs = ?d1 + ?d2")
proof -
  have obs: "?lhs = d p \<cdot> ?lhs + ad p \<cdot> ?lhs"
    by (metis (no_types, lifting) local.a_closure' local.a_de_morgan fbox_def ans_d_def
        ads_d_def local.am2 local.am5_lem local.dka.dsg3 local.dka.dsr5)
  have "d p \<cdot> ?lhs = d p \<cdot> |x] q \<cdot> (d p + d ( |y] q))"
    using fbox_cond local.a_d_add_closure local.ads_d_def
      local.ds.ddual.mult_assoc local.fbox_def by auto
  also have "... = d p \<cdot> |x] q"
    by (metis local.ads_d_def local.am2 local.dka.dns5 local.ds.ddual.mult_assoc local.fbox_def)
  finally have "d p \<cdot> ?lhs = d p \<cdot> |x] q" .
  moreover have "ad p \<cdot> ?lhs = ad p \<cdot> |y] q"
    by (metis add_commute fbox_cond local.a_closure' local.a_mult_add ads_d_def ans_d_def
        local.dnsz.dns5 local.ds.ddual.mult_assoc local.fbox_def)
  ultimately show ?thesis
    using obs by simp
qed

\<comment> \<open> While loop \<close> (* by Victor Gomes, Georg Struth *)

definition aka_whilei :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ inv _" [64,64,64] 63) where
  "while t do x inv i  = (d t \<cdot> x)\<^sup>\<star> \<cdot> ad t"

lemma fbox_frame: "d p \<cdot> x \<le> x \<cdot> d p \<Longrightarrow> d q \<le> |x] r \<Longrightarrow> d p \<cdot> d q \<le> |x] (d p \<cdot> d r)"
  using dual.mult_isol_var fbox_add1 fbox_demodalisation3 fbox_simp by auto

lemma fbox_shunt: "d p \<cdot> d q \<le> |x] t \<longleftrightarrow> d p \<le> ad q + |x] t"
  by (metis a_6 a_antitone' a_loc add_commute addual.ars_r_def am_d_def da_shunt2 fbox_def)

lemma fbox_export2: "|x] p \<le> |x \<cdot> ad q] (d p \<cdot> ad q)"
proof -
  {fix t
   have "d t \<cdot> x \<le> x \<cdot> d p \<Longrightarrow> d t \<cdot> x \<cdot> ad q \<le> x \<cdot> ad q \<cdot> d p \<cdot> ad q"
     by (metis (full_types) a_comm_var a_mult_idem ads_d_def am2 ds.ddual.mult_assoc phl_export2)
   hence "d t \<le> |x] p \<Longrightarrow> d t \<le> |x \<cdot> ad q] (d p \<cdot> ad q)"
     by (metis a_closure' addual.ars_r_def ans_d_def dka.dsg3 ds.ddual.mult_assoc fbox_def fbox_demodalisation3)}
  thus ?thesis
    by (metis a_closure' addual.ars_r_def ans_d_def fbox_def order_refl)
qed

lemma fbox_while: "d p \<cdot> d t \<le> |x] p \<Longrightarrow> d p \<le> |(d t \<cdot> x)\<^sup>\<star> \<cdot> ad t] (d p \<cdot> ad t)"
proof -
  assume "d p \<cdot> d t \<le> |x] p"
  hence "d p \<le> |d t \<cdot> x] p"
    by (simp add: fbox_export1 fbox_shunt)
  hence "d p \<le> |(d t \<cdot> x)\<^sup>\<star>] p"
    by (simp add: fbox_star_induct_var)
  thus ?thesis
    using order_trans fbox_export2 by presburger
qed

lemma fbox_whilei:
  assumes "d p \<le> d i" and "d i \<cdot> ad t \<le> d q" and "d i \<cdot> d t \<le> |x] i"
  shows "d p \<le> |while t do x inv i] q"
proof-
  have "d i \<le> |(d t \<cdot> x)\<^sup>\<star> \<cdot> ad t] (d i \<cdot> ad t)"
    using fbox_while assms by blast
  also have "... \<le> |(d t \<cdot> x)\<^sup>\<star> \<cdot> ad t] q"
    by (metis assms(2) local.dka.dom_iso local.dka.domain_invol local.fbox_iso)
  finally show ?thesis
    unfolding aka_whilei_def
    using assms(1) local.dual_order.trans by blast
qed

lemma fbox_seq_var: "p \<le> |x] p' \<Longrightarrow> p' \<le> |y] q \<Longrightarrow>  p \<le> |x \<cdot> y] q"
proof -
  assume h1: "p \<le> |x] p'" and h2: "p' \<le> |y] q"
  hence "|x] p' \<le> |x] |y] q"
    by (metis ads_d_def fbox_antitone_var fbox_dom fbox_iso)
  thus ?thesis
    by (metis dual_order.trans fbox_mult h1)
qed

lemma fbox_whilei_break:
  "d p \<le> |y] i \<Longrightarrow> d i \<cdot> ad t \<le> d q \<Longrightarrow> d i \<cdot> d t \<le> |x] i \<Longrightarrow> d p \<le> |y \<cdot> (while t do x inv i)] q"
  apply (rule fbox_seq_var[OF _ fbox_whilei])
  using fbox_simp by auto

\<comment> \<open> Finite iteration \<close>

definition aka_loopi :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("loop _ inv _ " [64,64] 63)
  where "loop x inv i = x\<^sup>\<star>"

lemma "d p \<le> |x] p \<Longrightarrow> d p \<le> |x\<^sup>\<star>] p"
  using fbox_star_induct_var .

lemma fbox_loopi: "p \<le> d i \<Longrightarrow> d i \<le> |x] i \<Longrightarrow> d i \<le> d q \<Longrightarrow> p \<le> |loop x inv i] q"
  unfolding aka_loopi_def by (meson dual_order.trans fbox_iso fbox_star_induct_var)

lemma fbox_loopi_break:
  "p \<le> |y] d i \<Longrightarrow> d i \<le> |x] i \<Longrightarrow> d i \<le> d q \<Longrightarrow> p \<le> |y \<cdot> (loop x inv i)] q"
  by (rule fbox_seq_var, force) (rule fbox_loopi, auto)

\<comment> \<open> Invariants \<close>

lemma "p \<le> i \<Longrightarrow> i \<le> |x]i \<Longrightarrow> i \<le> q \<Longrightarrow> p \<le> |x]q"
  by (metis local.ads_d_def local.dpdz.dom_iso local.dual_order.trans local.fbox_iso)

lemma "p \<le> d i \<Longrightarrow> d i \<le> |x]i \<Longrightarrow> i \<le> d q \<Longrightarrow> p \<le> |x]q"
  by (metis local.a_4 local.a_antitone' local.a_subid_aux2 ads_d_def order.antisym fbox_def
      local.dka.dsg1 local.dual.mult_isol_var local.dual_order.trans local.order.refl)

lemma "(i \<le> |x] i) \<or> (j \<le> |x] j) \<Longrightarrow> (i + j) \<le> |x] (i + j)"
  (*nitpick*)
  oops

lemma "d i \<le> |x] i \<Longrightarrow> d j \<le> |x] j \<Longrightarrow> (d i + d j) \<le> |x] (d i + d j)"
  by (metis (no_types, lifting) dual_order.trans fbox_simp fbox_subdist join.le_supE join.le_supI)

lemma plus_inv: "i \<le> |x] i \<Longrightarrow> j \<le> |x] j \<Longrightarrow> (i + j) \<le> |x] (i + j)"
  by (metis ads_d_def dka.dsr5 fbox_simp fbox_subdist join.sup_mono order_trans)

lemma mult_inv: "d i \<le> |x] i \<Longrightarrow> d j \<le> |x] j \<Longrightarrow> (d i \<cdot> d j) \<le> |x] (d i \<cdot> d j)"
  using fbox_demodalisation3 fbox_frame fbox_simp by auto

end

end