(* From Isabelle exercsises http://isabelle.in.tum.de/exercises/ *)
theory ReplaceRevDel
imports "$HIPSTER_HOME/IsaHipster"

begin

primrec replace :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "replace x y []     = []"
| "replace x y (z#zs) = (if z=x then y else z)#(replace x y zs)"

hipster replace List.append rev

primrec del1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "del1 x []     = []"
| "del1 x (y#ys) = (if y=x then ys else y # del1 x ys)"

primrec delall :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "delall x []     = []"
| "delall x (y#ys) = (if y=x then delall x ys else y # delall x ys)"

hipster del1 delall
lemma lemma_a [thy_expl]: "delall y (delall y z) = delall y z"
apply (induct z)
by simp_all

lemma lemma_aa [thy_expl]: "delall z (delall y x2) = delall y (delall z x2)"
apply (induct x2)
by simp_all

lemma unknown [thy_expl]: "del1 y (del1 y z) = del1 y z"
oops
end


theory PathLemmas
imports TheoremD14
begin

context LocalLexing begin

lemma characterize_\<P>:
  "(\<forall> i < length p. \<exists>u. p ! i \<in> \<Z> (charslength (take i p)) u) \<Longrightarrow> admissible p \<Longrightarrow>
  \<exists> u. p \<in> \<P> (charslength p) u"
proof (induct p rule: rev_induct)
  case Nil
    show ?case by simp
next
  case (snoc a p)
    from snoc.prems have admissible_p: "admissible p"
      by (metis append_Nil2 is_prefix_admissible is_prefix_cancel is_prefix_empty)
    {
      fix i :: nat
      assume ilen: "i < length p"
      then have "i < length (p@[a])"
        by (simp add: Suc_leI Suc_le_lessD trans_le_add1)
      with snoc have "\<exists>u. (p @ [a]) ! i \<in> \<Z> (charslength (take i (p @ [a]))) u"
        by blast
      then obtain u where u: "(p @ [a]) ! i \<in> \<Z> (charslength (take i (p @ [a]))) u" by blast
      from ilen have p_at: "(p @ [a]) ! i = p ! i" by (simp add: nth_append)
      from ilen have p_take: "take i (p @ [a]) = take i p" by (simp add: less_or_eq_imp_le)
      from u p_at p_take have p_i: "p ! i \<in> \<Z> (charslength (take i p)) u" by simp
      then have "\<exists> u. p ! i \<in> \<Z> (charslength (take i p)) u" by blast
    }
    then have "\<forall> i < length p. \<exists>u. p ! i \<in> \<Z> (charslength (take i p)) u" by auto
    with admissible_p snoc.hyps obtain u where u: "p \<in> \<P> (charslength p) u" by blast
    have "\<exists>u. (p @ [a]) ! (length p) \<in> \<Z> (charslength (take (length p) (p @ [a]))) u"
      using snoc
      by (metis (no_types, hide_lams) add_Suc_right append_Nil2 length_Cons length_append
        less_Suc_eq_le less_or_eq_imp_le)
    then obtain v where "(p @ [a]) ! (length p) \<in> \<Z> (charslength (take (length p) (p @ [a]))) v"
      by blast
    then have v: "a \<in> \<Z> (charslength p) v" by simp
    {
      assume v_leq_u: "v \<le> u"
      then have "a \<in> \<Z> (charslength p) (Suc u)" using v
        by (meson LocalLexing.subset_fSuc LocalLexing_axioms \<Z>_subset_Suc subsetCE)
      from path_append_token[OF u this snoc.prems(2)]
      have "p @ [a] \<in> \<P> (charslength p) (Suc u)" by blast
      then have ?case using in_\<P>_charslength by blast
    }
    note case_v_leq_u = this
    {
      assume u_less_v: "u < v"
      then obtain w where w: "v = Suc w" using less_imp_Suc_add by blast
      with u_less_v have "u \<le> w" by arith
      with u have "p \<in> \<P> (charslength p) w" by (meson subsetCE subset_\<P>k)
      from v w path_append_token[OF this _ snoc.prems(2)]
      have "p @ [a] \<in> \<P> (charslength p) (Suc w)" by blast
      then have ?case using in_\<P>_charslength by blast
    }
    note case_u_less_v = this

    show ?case using case_v_leq_u case_u_less_v not_le by blast
qed

lemma drop_empty_tokens:
  assumes p: "p \<in> \<PP>"
  assumes r: "r \<le> length p"
  assumes empty: "charslength (take r p) = 0"
  assumes admissible: "admissible (drop r p)"
  shows "drop r p \<in> \<PP>"
proof -
  have p_\<Z>: "\<forall>i<length p. \<exists>u. p ! i \<in> \<Z> (charslength (take i p)) u" using p
    using tokens_nth_in_\<Z> by blast
  obtain q where q: "q = drop r p" by blast
  {
    fix j :: nat
    assume j : "j < length q"
    have length_p_q_r: "length p = length q + r"
      using r q add.commute diff_add_inverse le_Suc_ex length_drop by simp
    have j_plus_r_bound: "j + r < length p" by (simp add: j length_p_q_r)
    with p_\<Z> have "\<exists>u. p ! (j + r) \<in> \<Z> (charslength (take (j + r) p)) u" by blast
    then obtain u where u: "p ! (j + r) \<in> \<Z> (charslength (take (j + r) p)) u" by blast
    have p_at_is_q_at: "p ! (j + r) = q ! j" by (simp add: add.commute q r)
    have "take (j + r) p = (take r p) @ (take j q)" by (metis add.commute q take_add)
    with empty have "charslength (take (j + r) p) = charslength (take j q)" by auto
    with u p_at_is_q_at have "q ! j \<in> \<Z> (charslength (take j q)) u" by simp
    then have "\<exists> u. q ! j \<in> \<Z> (charslength (take j q)) u" by auto
  }
  then have "\<forall>i<length q. \<exists>u. q ! i \<in> \<Z> (charslength (take i q)) u" by blast
  from characterize_\<P>[OF this] have "\<exists>u. q \<in> \<P> (charslength q) u" using admissible q by auto
  then show ?thesis using \<PP>_covers_\<P> q by blast
qed

end

end


(*  Title:       Executable Matrix Operations on Matrices of Arbitrary Dimensions
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

(*
Copyright 2010 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

header {* Utility Functions and Lemmas *}

theory Utility
imports Main
begin

subsection {* Miscellaneous *}

lemma infinite_imp_elem: "\<not> finite A \<Longrightarrow> \<exists> x. x \<in> A"
  by (cases "A = {}", auto)

lemma inf_pigeonhole_principle:
  assumes "\<forall>k::nat. \<exists>i<n::nat. f k i"
  shows "\<exists>i<n. \<forall>k. \<exists>k'\<ge>k. f k' i"
proof -
  have nfin: "~ finite (UNIV :: nat set)" by auto
  have fin: "finite ({i. i < n})" by auto
  from pigeonhole_infinite_rel[OF nfin fin] assms
  obtain i where i: "i < n" and nfin: "\<not> finite {a. f a i}" by auto
  show ?thesis
  proof (intro exI conjI, rule i, intro allI)
    fix k
    have "finite {a. f a i \<and> a < k}" by auto
    with nfin have "\<not> finite ({a. f a i} - {a. f a i \<and> a < k})" by auto
    from infinite_imp_elem[OF this]
    obtain a where "f a i" and "a \<ge> k" by auto
    thus "\<exists> k' \<ge> k. f k' i" by force
  qed
qed

lemma map_upt_Suc: "map f [0 ..< Suc n] = f 0 # map (\<lambda> i. f (Suc i)) [0 ..< n]"
  by (induct n arbitrary: f, auto)

lemma map_upt_add: "map f [0 ..< n + m] = map f [0 ..< n] @ map (\<lambda> i. f (i + n)) [0 ..< m]"
proof (induct n arbitrary: f)
  case (Suc n f)
  have "map f [0 ..< Suc n + m] = map f [0 ..< Suc (n+m)]" by simp
  also have "\<dots> = f 0 # map (\<lambda> i. f (Suc i)) [0 ..< n + m]" unfolding map_upt_Suc ..
  finally show ?case unfolding Suc map_upt_Suc by simp
qed simp

lemma map_upt_split: assumes i: "i < n"
  shows "map f [0 ..< n] = map f [0 ..< i] @ f i # map (\<lambda> j. f (j + Suc i)) [0 ..< n - Suc i]"
proof -
  from i have "n = i + Suc 0 + (n - Suc i)" by arith
  hence id: "[0 ..< n] = [0 ..< i + Suc 0 + (n - Suc i)]" by simp
  show ?thesis unfolding id
    unfolding map_upt_add by auto
qed

lemma all_Suc_conv:
  "(\<forall>i<Suc n. P i) \<longleftrightarrow> P 0 \<and> (\<forall>i<n. P (Suc i))" (is "?l = ?r")
proof
  assume ?l thus ?r by auto
next
  assume ?r show ?l
  proof (intro allI impI)
    fix i
    assume "i < Suc n"
    with `?r` show "P i" by (cases i, auto)
  qed
qed

lemma ex_Suc_conv:
  "(\<exists>i<Suc n. P i) \<longleftrightarrow> P 0 \<or> (\<exists>i<n. P (Suc i))" (is "?l = ?r")
  using all_Suc_conv[of n "\<lambda>i. \<not> P i"] by blast

fun sorted_list_subset :: "'a :: linorder list \<Rightarrow> 'a list \<Rightarrow> 'a option" where
  "sorted_list_subset (a # as) (b # bs) =
    (if a = b then sorted_list_subset as (b # bs)
     else if a > b then sorted_list_subset (a # as) bs
     else Some a)"
| "sorted_list_subset [] _ = None"
| "sorted_list_subset (a # _) [] = Some a"

lemma sorted_list_subset:
  assumes "sorted as" and "sorted bs"
  shows "(sorted_list_subset as bs = None) = (set as \<subseteq> set bs)"
using assms
proof (induct rule: sorted_list_subset.induct)
  case (2 bs)
  thus ?case by auto
next
  case (3 a as)
  thus ?case by auto
next
  case (1 a as b bs)
  from 1(3) have sas: "sorted as" and a: "\<And> a'. a' \<in> set as \<Longrightarrow> a \<le> a'" unfolding linorder_class.sorted.simps[of "a # as"] by auto
  from 1(4) have sbs: "sorted bs" and b: "\<And> b'. b' \<in> set bs \<Longrightarrow> b \<le> b'" unfolding linorder_class.sorted.simps[of "b # bs"] by auto
  show ?case
  proof (cases "a = b")
    case True
    from 1(1)[OF this sas 1(4)] True show ?thesis by auto
  next
    case False note oFalse = this
    show ?thesis
    proof (cases "a > b")
      case True
      with a b have "b \<notin> set as" by force
      with 1(2)[OF False True 1(3) sbs] False True show ?thesis by auto
    next
      case False
      with oFalse have "a < b" by auto
      with a b have "a \<notin> set bs" by force
      with oFalse False show ?thesis by auto
    qed
  qed
qed

lemma zip_nth_conv: "length xs = length ys \<Longrightarrow> zip xs ys = map (\<lambda> i. (xs ! i, ys ! i)) [0 ..< length ys]"
proof (induct xs arbitrary: ys, simp)
  case (Cons x xs)
  then obtain y yys where ys: "ys = y # yys" by (cases ys, auto)
  with Cons have len: "length xs = length yys" by simp
  show ?case unfolding ys
    by (simp del: upt_Suc add: map_upt_Suc, unfold Cons(1)[OF len], simp)
qed

lemma nth_map_conv:
  assumes "length xs = length ys"
    and "\<forall>i<length xs. f (xs ! i) = g (ys ! i)"
  shows "map f xs = map g ys"
using assms
proof (induct xs arbitrary: ys)
  case (Cons x xs) thus ?case
  proof (induct ys)
    case (Cons y ys)
    have "\<forall>i<length xs. f (xs ! i) = g (ys ! i)"
    proof (intro allI impI)
      fix i assume "i < length xs" thus "f (xs ! i) = g (ys ! i)" using Cons(4) by force
    qed
    with Cons show ?case by auto
  qed simp
qed simp

lemma listsum_0: "\<lbrakk>\<And> x. x \<in> set xs \<Longrightarrow> x = 0\<rbrakk> \<Longrightarrow> listsum xs = 0"
  by (induct xs, auto)

lemma foldr_foldr_concat: "foldr (foldr f) m a = foldr f (concat m) a"
proof (induct m arbitrary: a)
  case Nil show ?case by simp
next
  case (Cons v m a)
  show ?case
    unfolding concat.simps foldr_Cons o_def Cons
    unfolding foldr_append by simp
qed

lemma listsum_double_concat:
  fixes f :: "'b \<Rightarrow> 'c \<Rightarrow> 'a :: comm_monoid_add" and g as bs
  shows "listsum (concat (map (\<lambda> i. map (\<lambda> j. f i j + g i j) as) bs))
      = listsum (concat (map (\<lambda> i. map (\<lambda> j. f i j) as) bs)) +
        listsum (concat (map (\<lambda> i. map (\<lambda> j. g i j) as) bs))"
proof (induct bs)
  case Nil thus ?case by simp
next
  case (Cons b bs)
  have id: "(\<Sum>j\<leftarrow>as. f b j + g b j) = listsum (map (f b) as) + listsum (map (g b) as)"
    by (induct as, auto simp: ac_simps)
  show ?case unfolding list.map concat.simps listsum_append
    unfolding Cons
    unfolding id
    by (simp add: ac_simps)
qed

fun max_list :: "nat list \<Rightarrow> nat" where
  "max_list [] = 0"
| "max_list (x # xs) = max x (max_list xs)"

lemma max_list: "x \<in> set xs \<Longrightarrow> x \<le> max_list xs"
  by (induct xs) auto

lemma max_list_mem: "xs \<noteq> [] \<Longrightarrow> max_list xs \<in> set xs"
proof (induct xs)
  case (Cons x xs)
  show ?case
  proof (cases "x \<ge> max_list xs")
    case True
    thus ?thesis by auto
  next
    case False
    hence max: "max_list xs > x" by auto
    hence nil: "xs \<noteq> []" by (cases xs, auto)
    from max have max: "max x (max_list xs) = max_list xs" by auto
    from Cons(1)[OF nil] max show ?thesis by auto
  qed
qed simp

end


(*  Title:      FOLP/ex/Classical.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

Classical First-Order Logic.
*)

theory Classical
imports FOLP
begin

schematic_goal "?p : (P --> Q | R) --> (P-->Q) | (P-->R)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*If and only if*)
schematic_goal "?p : (P<->Q) <-> (Q<->P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

schematic_goal "?p : ~ (P <-> ~P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*Sample problems from
  F. J. Pelletier,
  Seventy-Five Problems for Testing Automatic Theorem Provers,
  J. Automated Reasoning 2 (1986), 191-216.
  Errata, JAR 4 (1988), 236-236.

The hardest problems -- judging by experience with several theorem provers,
including matrix ones -- are 34 and 43.
*)

text "Pelletier's examples"
(*1*)
schematic_goal "?p : (P-->Q)  <->  (~Q --> ~P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*2*)
schematic_goal "?p : ~ ~ P  <->  P"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*3*)
schematic_goal "?p : ~(P-->Q) --> (Q-->P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*4*)
schematic_goal "?p : (~P-->Q)  <->  (~Q --> P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*5*)
schematic_goal "?p : ((P|Q)-->(P|R)) --> (P|(Q-->R))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*6*)
schematic_goal "?p : P | ~ P"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*7*)
schematic_goal "?p : P | ~ ~ ~ P"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*8.  Peirce's law*)
schematic_goal "?p : ((P-->Q) --> P)  -->  P"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*9*)
schematic_goal "?p : ((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*10*)
schematic_goal "?p : (Q-->R) & (R-->P&Q) & (P-->Q|R) --> (P<->Q)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*11.  Proved in each direction (incorrectly, says Pelletier!!)  *)
schematic_goal "?p : P<->P"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*12.  "Dijkstra's law"*)
schematic_goal "?p : ((P <-> Q) <-> R)  <->  (P <-> (Q <-> R))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*13.  Distributive law*)
schematic_goal "?p : P | (Q & R)  <-> (P | Q) & (P | R)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*14*)
schematic_goal "?p : (P <-> Q) <-> ((Q | ~P) & (~Q|P))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*15*)
schematic_goal "?p : (P --> Q) <-> (~P | Q)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*16*)
schematic_goal "?p : (P-->Q) | (Q-->P)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

(*17*)
schematic_goal "?p : ((P & (Q-->R))-->S) <-> ((~P | Q | S) & (~P | ~R | S))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Classical Logic: examples with quantifiers"

schematic_goal "?p : (ALL x. P(x) & Q(x)) <-> (ALL x. P(x))  &  (ALL x. Q(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

schematic_goal "?p : (EX x. P-->Q(x))  <->  (P --> (EX x. Q(x)))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

schematic_goal "?p : (EX x. P(x)-->Q)  <->  (ALL x. P(x)) --> Q"
  by (tactic "fast_tac @{context} FOLP_cs 1")

schematic_goal "?p : (ALL x. P(x)) | Q  <->  (ALL x. P(x) | Q)"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problems requiring quantifier duplication"

(*Needs multiple instantiation of ALL.*)
schematic_goal "?p : (ALL x. P(x)-->P(f(x)))  &  P(d)-->P(f(f(f(d))))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

(*Needs double instantiation of the quantifier*)
schematic_goal "?p : EX x. P(x) --> P(a) & P(b)"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

schematic_goal "?p : EX z. P(z) --> (ALL x. P(x))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Hard examples with quantifiers"

text "Problem 18"
schematic_goal "?p : EX y. ALL x. P(y)-->P(x)"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 19"
schematic_goal "?p : EX x. ALL y z. (P(y)-->Q(z)) --> (P(x)-->Q(x))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 20"
schematic_goal "?p : (ALL x y. EX z. ALL w. (P(x)&Q(y)-->R(z)&S(w)))
    --> (EX x y. P(x) & Q(y)) --> (EX z. R(z))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 21"
schematic_goal "?p : (EX x. P-->Q(x)) & (EX x. Q(x)-->P) --> (EX x. P<->Q(x))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 22"
schematic_goal "?p : (ALL x. P <-> Q(x))  -->  (P <-> (ALL x. Q(x)))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 23"
schematic_goal "?p : (ALL x. P | Q(x))  <->  (P | (ALL x. Q(x)))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 24"
schematic_goal "?p : ~(EX x. S(x)&Q(x)) & (ALL x. P(x) --> Q(x)|R(x)) &
     (~(EX x. P(x)) --> (EX x. Q(x))) & (ALL x. Q(x)|R(x) --> S(x))
    --> (EX x. P(x)&R(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 25"
schematic_goal "?p : (EX x. P(x)) &
       (ALL x. L(x) --> ~ (M(x) & R(x))) &
       (ALL x. P(x) --> (M(x) & L(x))) &
       ((ALL x. P(x)-->Q(x)) | (EX x. P(x)&R(x)))
   --> (EX x. Q(x)&P(x))"
  oops

text "Problem 26"
schematic_goal "?u : ((EX x. p(x)) <-> (EX x. q(x))) &
     (ALL x. ALL y. p(x) & q(y) --> (r(x) <-> s(y)))
  --> ((ALL x. p(x)-->r(x)) <-> (ALL x. q(x)-->s(x)))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 27"
schematic_goal "?p : (EX x. P(x) & ~Q(x)) &
              (ALL x. P(x) --> R(x)) &
              (ALL x. M(x) & L(x) --> P(x)) &
              ((EX x. R(x) & ~ Q(x)) --> (ALL x. L(x) --> ~ R(x)))
          --> (ALL x. M(x) --> ~L(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 28.  AMENDED"
schematic_goal "?p : (ALL x. P(x) --> (ALL x. Q(x))) &
        ((ALL x. Q(x)|R(x)) --> (EX x. Q(x)&S(x))) &
        ((EX x. S(x)) --> (ALL x. L(x) --> M(x)))
    --> (ALL x. P(x) & L(x) --> M(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 29.  Essentially the same as Principia Mathematica *11.71"
schematic_goal "?p : (EX x. P(x)) & (EX y. Q(y))
    --> ((ALL x. P(x)-->R(x)) & (ALL y. Q(y)-->S(y))   <->
         (ALL x y. P(x) & Q(y) --> R(x) & S(y)))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 30"
schematic_goal "?p : (ALL x. P(x) | Q(x) --> ~ R(x)) &
        (ALL x. (Q(x) --> ~ S(x)) --> P(x) & R(x))
    --> (ALL x. S(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 31"
schematic_goal "?p : ~(EX x. P(x) & (Q(x) | R(x))) &
        (EX x. L(x) & P(x)) &
        (ALL x. ~ R(x) --> M(x))
    --> (EX x. L(x) & M(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 32"
schematic_goal "?p : (ALL x. P(x) & (Q(x)|R(x))-->S(x)) &
        (ALL x. S(x) & R(x) --> L(x)) &
        (ALL x. M(x) --> R(x))
    --> (ALL x. P(x) & M(x) --> L(x))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 33"
schematic_goal "?p : (ALL x. P(a) & (P(x)-->P(b))-->P(c))  <->
     (ALL x. (~P(a) | P(x) | P(c)) & (~P(a) | ~P(b) | P(c)))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 35"
schematic_goal "?p : EX x y. P(x,y) -->  (ALL u v. P(u,v))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 36"
schematic_goal
"?p : (ALL x. EX y. J(x,y)) &
      (ALL x. EX y. G(x,y)) &
      (ALL x y. J(x,y) | G(x,y) --> (ALL z. J(y,z) | G(y,z) --> H(x,z)))
  --> (ALL x. EX y. H(x,y))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 37"
schematic_goal "?p : (ALL z. EX w. ALL x. EX y.
           (P(x,z)-->P(y,w)) & P(y,z) & (P(y,w) --> (EX u. Q(u,w)))) &
        (ALL x z. ~P(x,z) --> (EX y. Q(y,z))) &
        ((EX x y. Q(x,y)) --> (ALL x. R(x,x)))
    --> (ALL x. EX y. R(x,y))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 39"
schematic_goal "?p : ~ (EX x. ALL y. F(y,x) <-> ~F(y,y))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 40.  AMENDED"
schematic_goal "?p : (EX y. ALL x. F(x,y) <-> F(x,x)) -->
              ~(ALL x. EX y. ALL z. F(z,y) <-> ~ F(z,x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 41"
schematic_goal "?p : (ALL z. EX y. ALL x. f(x,y) <-> f(x,z) & ~ f(x,x))
          --> ~ (EX z. ALL x. f(x,z))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 44"
schematic_goal "?p : (ALL x. f(x) -->
              (EX y. g(y) & h(x,y) & (EX y. g(y) & ~ h(x,y))))  &
              (EX x. j(x) & (ALL y. g(y) --> h(x,y)))
              --> (EX x. j(x) & ~f(x))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problems (mainly) involving equality or functions"

text "Problem 48"
schematic_goal "?p : (a=b | c=d) & (a=c | b=d) --> a=d | b=c"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 50"
(*What has this to do with equality?*)
schematic_goal "?p : (ALL x. P(a,x) | (ALL y. P(x,y))) --> (EX x. ALL y. P(x,y))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 56"
schematic_goal
 "?p : (ALL x. (EX y. P(y) & x=f(y)) --> P(x)) <-> (ALL x. P(x) --> P(f(x)))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 57"
schematic_goal
"?p : P(f(a,b), f(b,c)) & P(f(b,c), f(a,c)) &
      (ALL x y z. P(x,y) & P(y,z) --> P(x,z))    -->   P(f(a,b), f(a,c))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

text "Problem 58  NOT PROVED AUTOMATICALLY"
schematic_goal "?p : (ALL x y. f(x)=g(y)) --> (ALL x y. f(f(x))=f(g(y)))"
  supply f_cong = subst_context [where t = f]
  by (tactic \<open>fast_tac @{context} (FOLP_cs addSIs [@{thm f_cong}]) 1\<close>)

text "Problem 59"
schematic_goal "?p : (ALL x. P(x) <-> ~P(f(x))) --> (EX x. P(x) & ~P(f(x)))"
  by (tactic "best_tac @{context} FOLP_dup_cs 1")

text "Problem 60"
schematic_goal "?p : ALL x. P(x,f(x)) <-> (EX y. (ALL z. P(z,y) --> P(z,f(x))) & P(x,y))"
  by (tactic "fast_tac @{context} FOLP_cs 1")

end


theory Sorting_Network
  imports Main Sorting_Network_Bound "HOL-Library.Permutations" "HOL-Library.Multiset" "Huffman"
begin

text \<open>Minimum and maximum on Booleans are just conjunction and disjunction, which are often easier
to work with.\<close>

lemma bool_min_is_conj[simp]: \<open>min a b = (a \<and> b)\<close>
  unfolding min_def by auto

lemma bool_max_is_disj[simp]: \<open>max a b = (a \<or> b)\<close>
  unfolding max_def by auto

lemma apply_cmp_logic:
  \<open>apply_cmp c x i = (x i \<and> (i \<noteq> fst c \<or> x (snd c)) \<or> (i = snd c \<and> x (fst c)))\<close>
  unfolding apply_cmp_def Let_def case_prod_unfold
  by auto

text \<open>Applying a comparator to a given sequence is either an exchange or the identity.\<close>

lemma apply_cmp_exch_or_id:
  \<open>apply_cmp c x = x \<or> apply_cmp c x = Fun.swap (fst c) (snd c) x\<close>
proof (cases \<open>x (fst c) \<and> \<not>x (snd c)\<close>)
  case True
  hence \<open>apply_cmp c x = Fun.swap (fst c) (snd c) x\<close>
    by (simp add: apply_cmp_def case_prod_beta' swap_def)
  thus ?thesis..
next
  case False
  hence \<open>apply_cmp c x = x\<close>
    unfolding apply_cmp_logic
    by blast
  thus ?thesis..
qed

text \<open>A comparator $(i, i)$ is always the identity.\<close>

lemma apply_cmp_same_channels:
  \<open>fst c = snd c \<Longrightarrow> apply_cmp c x = x\<close>
  using apply_cmp_exch_or_id by fastforce

lemma apply_cmp_fixed_width_snd_oob:
  assumes \<open>fixed_len_bseq n v\<close> \<open>snd c \<ge> n\<close>
  shows \<open>apply_cmp c v = v\<close>
  using assms
  unfolding fixed_len_bseq_def apply_cmp_logic
proof (intro impI ext)
  fix i
  assume fixed_width: \<open>\<forall>i\<ge>n. v i = True\<close>
  assume \<open>n \<le> snd c\<close>
  show \<open>(v i \<and> (i \<noteq> fst c \<or> v (snd c)) \<or> i = snd c \<and> v (fst c)) = v i\<close>
  proof (cases \<open>i \<ge> n\<close>)
    case True
    thus ?thesis
      by (simp add: assms(2) fixed_width)
  next
    case False
    thus ?thesis
      using assms(2) fixed_width by blast
  qed
qed

(***)

definition weight :: \<open>bseq \<Rightarrow> nat\<close> where
  \<open>weight v = card (v -` {False})\<close>

lemma \<open>weight (apply_cmp c v) = weight v\<close>
proof (cases \<open>apply_cmp c v = v\<close>)
  case True
  thus ?thesis
    by simp
next
  case False
  hence \<open>apply_cmp c v = Fun.swap (fst c) (snd c) v\<close>
    using apply_cmp_exch_or_id by blast
  hence \<open>apply_cmp c v = v \<circ> Fun.swap (fst c) (snd c) id\<close>
    by (simp add: comp_swap)
  hence \<open>apply_cmp c v -` {False} = (v \<circ> Fun.swap (fst c) (snd c) id) -` {False}\<close>
    by simp
  also have \<open>\<dots> = Fun.swap (fst c) (snd c) id -` v -` {False}\<close>
    by fastforce
  finally show ?thesis
    using card_vimage_inj[of \<open>Fun.swap (fst c) (snd c) id\<close>] weight_def by auto
qed

lemma fixed_width_false_set:
  \<open>fixed_len_bseq n v \<Longrightarrow> (v -` {False}) \<subseteq> {..<n}\<close>
  unfolding fixed_len_bseq_def
  using leI by blast

lemma fixed_width_weight_bound:
  \<open>fixed_len_bseq n v \<Longrightarrow> weight v \<le> n\<close>
  by (metis fixed_width_false_set card_lessThan weight_def card_mono finite_lessThan)

lemma fixed_width_mono_at_weight:
  assumes \<open>fixed_len_bseq n v\<close> \<open>mono v\<close> \<open>i = weight v\<close>
  shows \<open>v i = True\<close>
proof (rule ccontr)
  assume \<open>v i \<noteq> True\<close>
  hence \<open>(v -` {False}) \<supseteq> {..i}\<close>
    using assms(2) monoD by fastforce
  hence \<open>weight v > i\<close>
    by (metis Suc_le_eq assms(1) card_atMost card_mono finite_lessThan finite_subset
        fixed_width_false_set weight_def)
  thus False
    using assms(3) by simp
qed

lemma fixed_width_mono_from_weight:
  assumes \<open>fixed_len_bseq n v\<close> \<open>mono v\<close>
  shows \<open>v i = (i \<ge> weight v)\<close>
proof (cases \<open>i \<ge> weight v\<close>)
  case True
  thus ?thesis
    by (meson assms(1) assms(2) fixed_width_mono_at_weight le_boolD mono_def)
next
  case False
  thus ?thesis
    by (metis (full_types) assms(2) fixed_len_bseq_def fixed_width_weight_bound le_boolD monoD)
qed

lemma weight_inj_on_fixed_width_mono:
  assumes \<open>\<And>v. v \<in> V \<Longrightarrow> mono v \<and> fixed_len_bseq n v\<close>
  shows \<open>inj_on weight V\<close>
proof (intro inj_onI ext)
  fix v w i assume vw: \<open>v \<in> V\<close> \<open>w \<in> V\<close> \<open>weight v = weight w\<close>
  show \<open>v i = w i\<close>
    by (metis assms fixed_width_mono_from_weight vw)
qed

lemma apply_cmp_fixed_width:
  assumes \<open>fixed_len_bseq n v\<close>
  shows \<open>fixed_len_bseq (Suc (max n (max (fst c) (snd c)))) (apply_cmp c v)\<close>
  unfolding apply_cmp_logic
  using assms fixed_len_bseq_def by auto

lemma apply_cmp_fixed_width_in_bounds:
  assumes \<open>fixed_len_bseq n v\<close> \<open>fst c < n\<close> \<open>snd c < n\<close>
  shows \<open>fixed_len_bseq n (apply_cmp c v)\<close>
  unfolding apply_cmp_logic
  using assms fixed_len_bseq_def by auto

lemma apply_cn_fixed_width:
  \<open>fixed_len_bseq n v \<Longrightarrow> \<exists>n'. fixed_len_bseq n' (fold apply_cmp cn v)\<close>
proof (induction cn arbitrary: n v)
  case Nil
  thus ?case
    by auto
next
  case (Cons c cn)
  thus ?case
    by (metis apply_cmp_fixed_width fold_simps(2))
qed

lemma weight_one:
  \<open>weight ((\<noteq>) i) = 1\<close>
proof -
  have \<open>(\<noteq>) i -` {False} = {i}\<close>
    by (rule set_eqI; auto)
  thus ?thesis
    by (simp add: weight_def)
qed

(***)

definition pls_bound :: \<open>bseq set \<Rightarrow> nat \<Rightarrow> bool\<close> where
  \<open>pls_bound V b = (\<forall>cn. inj_on weight (fold apply_cmp cn ` V)  \<longrightarrow> length cn \<ge> b)\<close>

lemma pls_bound_implies_lower_size_bound:
  assumes \<open>\<And>v. v \<in> V \<Longrightarrow> fixed_len_bseq n v\<close> \<open>pls_bound V b\<close>
  shows \<open>partial_lower_size_bound V b\<close>
  unfolding partial_lower_size_bound_def
proof (intro allI impI)
  fix cn assume cn_sorts: \<open>\<forall>v \<in> V. mono (fold apply_cmp cn v)\<close>

  have \<open>inj_on weight (fold apply_cmp cn ` V)\<close>
  proof
    fix v w assume v_asm: \<open>v \<in> fold apply_cmp cn ` V\<close>
      and w_asm: \<open>w \<in> fold apply_cmp cn ` V\<close>
      and vw_weight: \<open>weight v = weight w\<close>
    hence \<open>mono v \<and> mono w\<close>
      using cn_sorts by auto

    moreover obtain n_v where \<open>fixed_len_bseq n_v v\<close>
      by (metis v_asm apply_cn_fixed_width assms(1) imageE)
    moreover obtain n_w where \<open>fixed_len_bseq n_w w\<close>
      by (metis w_asm apply_cn_fixed_width assms(1) imageE)
    ultimately have \<open>\<And>i. v i = (i \<ge> weight v)\<close> \<open>\<And>i. w i = (i \<ge> weight w)\<close>
      using fixed_width_mono_from_weight
      by auto
    thus \<open>v = w\<close>
      using vw_weight by auto
  qed
  thus \<open>b \<le> length cn\<close>
    using assms(2) pls_bound_def by blast
qed

lemma trivial_bound: \<open>pls_bound V 0\<close>
  by (simp add: pls_bound_def)

lemma unsorted_bound: \<open>\<not>inj_on weight V \<Longrightarrow> pls_bound V 1\<close>
  using pls_bound_def not_less_eq_eq by fastforce

lemma suc_bound:
  assumes unsorted: \<open>\<not>inj_on weight V\<close> and suc_bounds: \<open>\<And>c. pls_bound (apply_cmp c ` V) b\<close>
  shows \<open>pls_bound V (Suc b)\<close>
proof (subst pls_bound_def; intro allI impI)
  fix cn assume sorts: \<open>inj_on weight (fold apply_cmp cn ` V)\<close>
  from this and unsorted have \<open>cn \<noteq> []\<close>
    using pls_bound_def by auto
  then obtain c cn' where cn_cons: \<open>cn = c # cn'\<close>
    using list.exhaust by blast
  from this and sorts have \<open>inj_on weight (fold apply_cmp cn' ` (apply_cmp c ` V))\<close>
    by (simp add: image_comp)
  from this and suc_bounds have \<open>length cn' \<ge> b\<close>
    using pls_bound_def cn_cons by auto
  thus \<open>length cn \<ge> Suc b\<close>
    using cn_cons by simp
qed

lemma bound_suc:
  assumes \<open>pls_bound V (Suc b)\<close>
  shows \<open>pls_bound (apply_cmp c ` V) b\<close>
  using assms
  unfolding pls_bound_def
  by (metis One_nat_def Suc_eq_plus1 Suc_le_mono fold.simps(2) image_comp list.size(4))

lemma bound_unsorted:
  assumes \<open>pls_bound V 1\<close>
  shows \<open>\<not>inj_on weight V\<close>
  using assms
  unfolding pls_bound_def
  by (metis One_nat_def Suc_n_not_le_n fold.simps(1) id_apply image_subsetI inj_on_subset
      list.size(3))

lemma bound_mono_subset:
  assumes \<open>pls_bound V b\<close> \<open>V \<subseteq> W\<close>
  shows \<open>pls_bound W b\<close>
  using pls_bound_def inj_on_subset image_mono
  by (metis assms)

lemma bound_weaken:
  \<open>pls_bound V (b + d) \<Longrightarrow> pls_bound V b\<close>
  using pls_bound_def by auto

(***)

lemma unsorted_by_card_bound:
  assumes \<open>\<And>v. v \<in> V \<Longrightarrow> fixed_len_bseq n v\<close> \<open>card V > n + 1\<close>
  shows \<open>pls_bound V 1\<close>
proof(rule unsorted_bound; rule)
  assume \<open>inj_on weight V\<close>
  hence \<open>card (weight ` V) > n + 1\<close>
    using assms(2) card_image by fastforce
  moreover have \<open>weight ` V \<subseteq> {..n}\<close>
    using assms(1) fixed_width_weight_bound by auto
  hence \<open>card (weight ` V) \<le> n + 1\<close>
    by (metis Suc_eq_plus1 card_atMost card_mono finite_atMost)
  ultimately show False
    by simp
qed

(***)

lemma inj_on_invariant_bij_image:
  assumes \<open>bij g\<close> \<open>\<And>a. f (g a) = f a\<close>
  shows \<open>inj_on f A = inj_on f (g ` A)\<close>
  by (metis assms bij_betw_def inj_on_image_iff inj_on_subset subset_UNIV)

(***)

definition apply_perm :: \<open>(nat \<Rightarrow> nat) \<Rightarrow> bseq \<Rightarrow> bseq\<close> where
  \<open>apply_perm p v i = v (p i)\<close>

lemma apply_perm_bij:
  assumes \<open>bij p\<close>
  shows \<open>bij (apply_perm p)\<close>
proof -
  have \<open>\<And>v i. apply_perm (inv p) (apply_perm p v) i = v i\<close>
    unfolding apply_perm_def
    by (metis assms bij_inv_eq_iff)
  hence \<open>apply_perm (inv p) \<circ> apply_perm p = id\<close>
    by (auto 0 3)
  moreover have \<open>\<And>v i. apply_perm p (apply_perm (inv p) v) i = v i\<close>
    unfolding apply_perm_def
    by (metis assms bij_inv_eq_iff)
  hence \<open>apply_perm p \<circ> apply_perm (inv p) = id\<close>
    by (auto 0 3)
  ultimately show ?thesis
    using o_bij by blast
qed

lemma apply_perm_comp:
  shows \<open>apply_perm f \<circ> apply_perm g = apply_perm (g \<circ> f)\<close>
  unfolding apply_perm_def by auto

lemma apply_perm_weight:
  assumes \<open>bij p\<close>
  shows \<open>weight (apply_perm p v) = weight v\<close>
  unfolding weight_def apply_perm_def
proof -
  have \<open>(\<lambda>i. v (p i)) -` {False} = (v \<circ> p) -` {False}\<close>
    by fastforce
  also have \<open>\<dots> = p -` v -` {False}\<close>
    by (simp add: vimage_comp)
  also have \<open>\<dots> = (inv p) ` v -` {False}\<close>
    by (simp add: assms bij_vimage_eq_inv_image)
  finally have \<open>card ((\<lambda>i. v (p i)) -` {False}) = card (inv p ` v -` {False})\<close>
    by simp
  also have \<open>\<dots> = card (v -` {False})\<close>
    using card_vimage_inj[of \<open>inv p\<close> \<open>v -` {False}\<close>]
    by (metis assms bij_betw_imp_surj_on card_image inj_on_inv_into top_greatest)
  finally show \<open>card ((\<lambda>i. v (p i)) -` {False}) = card (v -` {False})\<close>.
qed

lemma apply_perm_cmp:
  assumes \<open>bij p\<close>
  shows \<open>apply_cmp c (apply_perm p v) = apply_perm p (apply_cmp (p (fst c), p (snd c)) v)\<close>
  unfolding apply_cmp_logic apply_perm_def fst_conv snd_conv
  by (metis assms bij_pointE)

lemma apply_perm_cmp_comp:
  assumes \<open>bij p\<close>
  shows \<open>apply_cmp c \<circ> apply_perm p = apply_perm p \<circ> apply_cmp (p (fst c), p (snd c))\<close>
  by (rule ext; insert assms; simp add: apply_perm_cmp)

lemma permuted_bound:
  assumes \<open>pls_bound V b\<close> \<open>bij p\<close>
  shows \<open>pls_bound (apply_perm p ` V) b\<close>
  using assms
proof (induction b arbitrary: p V)
  case 0
  have \<open>pls_bound (apply_perm p ` V) 0\<close>
    using trivial_bound.
  thus ?case.
next
  case (Suc b)

  have V_unsorted: \<open>\<not>inj_on weight V\<close>
    by (metis Suc.prems(1) bound_unsorted bound_weaken plus_1_eq_Suc)
  have weight_invariant: \<open>\<And>v. weight (apply_perm p v) = weight v\<close>
    using Suc.prems(2) apply_perm_weight by auto
  have p_bij: \<open>bij (apply_perm p)\<close>
    by (simp add: Suc.prems(2) apply_perm_bij)

  show ?case
  proof (rule suc_bound)
    show \<open>\<not>inj_on weight (apply_perm p ` V)\<close>
      using V_unsorted weight_invariant p_bij inj_on_invariant_bij_image by blast
  next
    fix c
    have \<open>pls_bound (apply_perm p ` apply_cmp (p (fst c), p (snd c)) ` V) b\<close>
      using Suc.IH Suc.prems(1) Suc.prems(2) bound_suc by blast
    thus \<open>pls_bound (apply_cmp c ` apply_perm p ` V) b\<close>
      using apply_perm_cmp_comp[of p c]
      by (metis Suc.prems(2) image_comp)
  qed
qed

lemma permuted_bound_iff:
  assumes \<open>bij p\<close>
  shows \<open>pls_bound V b = pls_bound (apply_perm p ` V) b\<close>
proof
  show \<open>pls_bound V b \<Longrightarrow> pls_bound (apply_perm p ` V) b\<close>
    using assms permuted_bound by auto
next
  assume \<open>pls_bound (apply_perm p ` V) b\<close>
  hence \<open>pls_bound (apply_perm (inv p) ` apply_perm p ` V) b\<close>
    by (simp add: assms bij_betw_inv_into permuted_bound)
  thus \<open>pls_bound V b\<close>
    using apply_perm_comp
    by (metis (no_types, lifting) apply_perm_bij assms bij_id bij_is_inj bijection.intro
        bijection.inv_comp_right image_comp inj_vimage_image_eq inv_id)
qed

lemma permuted_bounds_iff:
  assumes \<open>bij p\<close>
  shows \<open>pls_bound V = pls_bound (apply_perm p ` V)\<close>
proof
  fix x
  show \<open>pls_bound V x = pls_bound (apply_perm p ` V) x\<close>
    using assms permuted_bound_iff by blast
qed

lemma apply_perm_fixed_width:
  assumes \<open>p permutes {..<n}\<close> \<open>fixed_len_bseq n v\<close>
  shows \<open>fixed_len_bseq n (apply_perm p v)\<close>
  using assms unfolding fixed_len_bseq_def apply_perm_def permutes_def
  by simp

lemma apply_perm_fixed_width_image:
  assumes \<open>p permutes {..<n}\<close> \<open>\<And>v. v \<in> V \<Longrightarrow> fixed_len_bseq n v\<close>
  shows \<open>\<And>v. v \<in> apply_perm p ` V \<Longrightarrow> fixed_len_bseq n v\<close>
  using apply_perm_fixed_width assms by blast

(***)

lemma apply_cmp_swap:
  \<open>apply_cmp (prod.swap c) v = apply_perm (Fun.swap (fst c) (snd c) id) (apply_cmp c v)\<close>
  unfolding apply_cmp_logic apply_perm_def fst_swap snd_swap
  by (metis (no_types, hide_lams) swap_id_eq)

lemma apply_cmp_swap_comp:
  \<open>apply_cmp (prod.swap c) = apply_perm (Fun.swap (fst c) (snd c) id) \<circ> apply_cmp c\<close>
  by (rule ext; auto simp add: apply_cmp_swap)

lemma apply_cmp_swap_bound:
  \<open>pls_bound (apply_cmp (prod.swap c) ` V) b = pls_bound (apply_cmp c ` V) b\<close>
proof -
  have \<open>pls_bound (apply_cmp (prod.swap c) ` V) b =
      pls_bound ((apply_perm (Fun.swap (fst c) (snd c) id) \<circ> apply_cmp c) ` V) b\<close>
    using apply_cmp_swap_comp by simp
  also have \<open>\<dots> = pls_bound (apply_cmp c ` V) b\<close>
    by (metis image_comp o_bij permuted_bound_iff swap_id_idempotent)
  finally show ?thesis.
qed

lemma suc_bound_noop:
  assumes unsorted: \<open>\<not>inj_on weight V\<close>
    and suc_bounds: \<open>\<And>c. pls_bound (apply_cmp c ` V) b \<or> pls_bound (apply_cmp c ` V) = pls_bound V\<close>
  shows \<open>pls_bound V (Suc b)\<close>
  using assms
proof (induction b)
  case 0
  thus ?case
    using unsorted_bound by auto
next
  case (Suc b)
  thus ?case
    by (metis Suc_eq_plus1 bound_weaken suc_bound)
qed

lemma ocmp_suc_bound:
  assumes unsorted: \<open>\<not>inj_on weight V\<close>
    and fixed_width: \<open>\<And>v. v \<in> V \<Longrightarrow> fixed_len_bseq n v\<close>
    and suc_bounds:
      \<open>\<And>c. fst c < snd c \<and> snd c < n \<Longrightarrow>
        pls_bound (apply_cmp c ` V) b \<or> pls_bound (apply_cmp c ` V) = pls_bound V\<close>
  shows \<open>pls_bound V (Suc b)\<close>
proof -
  have \<open>\<And>c. pls_bound (apply_cmp c ` V) b \<or> pls_bound (apply_cmp c ` V) = pls_bound V\<close>
  proof -
    fix c
    have \<open>snd c \<ge> n \<Longrightarrow> \<forall>v \<in> V. apply_cmp c v = v\<close>
      using apply_cmp_fixed_width_snd_oob fixed_width not_less by blast
    hence \<open>snd c \<ge> n \<Longrightarrow> pls_bound (apply_cmp c ` V) = pls_bound V\<close>
      by simp

    moreover have
      \<open>fst c \<ge> n \<Longrightarrow> \<forall>v \<in> V. apply_cmp c v = apply_perm (Fun.swap (fst c) (snd c) id) v\<close>
      by (metis apply_cmp_fixed_width_snd_oob apply_cmp_swap fixed_width fst_swap
          swap_commute swap_swap)
    hence \<open>fst c \<ge> n \<Longrightarrow>
        pls_bound (apply_cmp c ` V) = pls_bound (apply_perm (Fun.swap (fst c) (snd c) id) ` V)\<close>
      by auto
    hence \<open>fst c \<ge> n \<Longrightarrow> pls_bound (apply_cmp c ` V) = pls_bound V\<close>
      by (metis o_bij permuted_bounds_iff swap_id_idempotent)

    moreover have
      \<open>fst c < snd c \<and> snd c < n \<Longrightarrow>
        pls_bound (apply_cmp c ` V) b \<or> pls_bound (apply_cmp c ` V) = pls_bound V\<close>
      using suc_bounds by simp

    moreover have
      \<open>snd c < fst c \<and> fst c < n \<Longrightarrow>
        pls_bound (apply_cmp c ` V) b \<or> pls_bound (apply_cmp c ` V) = pls_bound V\<close>
      using apply_cmp_swap_bound suc_bounds
      by (metis apply_cmp_swap_comp image_comp o_bij permuted_bounds_iff prod.exhaust_sel snd_swap
          swap_id_idempotent swap_simp)

    moreover have \<open>fst c = snd c \<Longrightarrow> pls_bound (apply_cmp c ` V) = pls_bound V\<close>
      by (simp add: apply_cmp_same_channels)

    ultimately show \<open>pls_bound (apply_cmp c ` V) b \<or> pls_bound (apply_cmp c ` V) = pls_bound V\<close>
      using nat_neq_iff not_less by blast
  qed
  thus ?thesis
    using suc_bound_noop unsorted by blast
qed

(***)

definition redundant_cmp :: \<open>cmp \<Rightarrow> bseq set \<Rightarrow> bool\<close> where
  \<open>redundant_cmp c V = (\<not>((\<exists>v \<in> V. v (fst c) \<and> \<not>v (snd c)) \<and> (\<exists>v \<in> V. \<not>v (fst c) \<and> v (snd c))))\<close>

lemma redundant_cmp_id:
  assumes \<open>\<not>(\<exists>v \<in> V. v (fst c) \<and> \<not>v (snd c))\<close>
  shows \<open>apply_cmp c ` V = V\<close>
proof -
  have \<open>\<And>v. v \<in> V \<Longrightarrow> apply_cmp c v = v\<close>
  proof
    fix v i assume \<open>v \<in> V\<close>
    hence \<open>\<not>v (fst c) \<or> v (snd c)\<close>
      using assms by blast
    thus \<open>apply_cmp c v i = v i\<close>
      using apply_cmp_logic by auto
  qed
  thus ?thesis
    by simp
qed

lemma redundant_cmp_swap:
  assumes \<open>\<not>(\<exists>v \<in> V. \<not>v (fst c) \<and> v (snd c))\<close>
  shows \<open>apply_cmp c ` V = Fun.swap (fst c) (snd c) ` V\<close>
proof -
  have \<open>\<And>v. v \<in> V \<Longrightarrow> apply_cmp c v = Fun.swap (fst c) (snd c) v\<close>
  proof
    fix v i assume \<open>v \<in> V\<close>
    hence \<open>v (fst c) \<or> \<not>v (snd c)\<close>
      using assms by blast
    thus \<open>apply_cmp c v i = Fun.swap (fst c) (snd c) v i\<close>
      using apply_cmp_logic
      by (metis swap_apply(1, 3) swap_commute)
  qed
  thus ?thesis
    by simp
qed

lemma redundant_cmp_id_bound:
  assumes \<open>\<not>(\<exists>v \<in> V. v (fst c) \<and> \<not>v (snd c))\<close>
  shows \<open>pls_bound (apply_cmp c ` V) = pls_bound V\<close>
  by (simp add: assms redundant_cmp_id)

lemma redundant_cmp_swap_bound:
  assumes \<open>\<not>(\<exists>v \<in> V. \<not>v (fst c) \<and> v (snd c))\<close>
  shows \<open>pls_bound (apply_cmp c ` V) = pls_bound V\<close>
  by (metis (no_types, lifting) apply_cmp_swap_comp assms fst_swap image_comp o_bij
      permuted_bounds_iff redundant_cmp_id snd_swap swap_id_idempotent)

lemma redundant_cmp_bound:
  assumes \<open>redundant_cmp c V\<close>
  shows \<open>pls_bound (apply_cmp c ` V) = pls_bound V\<close>
  by (metis assms redundant_cmp_def redundant_cmp_id_bound redundant_cmp_swap_bound)

(***)

definition invert_vect :: \<open>nat \<Rightarrow> bseq \<Rightarrow> bseq\<close> where
  \<open>invert_vect n v i = (v i \<noteq> (i < n))\<close>

lemma invert_vect_invol: \<open>invert_vect n \<circ> invert_vect n = id\<close>
  unfolding invert_vect_def comp_apply by fastforce

lemma invert_vect_bij: \<open>bij (invert_vect n)\<close>
  using invert_vect_invol o_bij by blast

lemma invert_vect_fixed_width:
  assumes \<open>fixed_len_bseq n v\<close>
  shows \<open>fixed_len_bseq n (invert_vect n v)\<close>
  using assms fixed_len_bseq_def invert_vect_def by auto

lemma invert_false_set:
  assumes \<open>fixed_len_bseq n v\<close>
  shows \<open>invert_vect n v -` {False} = {..<n} - (v -` {False})\<close>
proof (rule set_eqI)
  fix i
  have \<open>(i \<in> {..<n} - v -` {False}) = (i \<in> {..<n}  \<and> i \<notin> v -` {False})\<close>
    by simp
  also have \<open>\<dots> = (i < n \<and> v i)\<close>
    by simp
  also have \<open>\<dots> = (v i = (i < n))\<close>
    using assms fixed_len_bseq_def by auto
  also have \<open>\<dots> = (\<not>invert_vect n v i)\<close>
    by (simp add: invert_vect_def)
  also have \<open>\<dots> = (i \<in> invert_vect n v -` {False})\<close>
    by simp
  finally show \<open>(i \<in> invert_vect n v -` {False}) = (i \<in> {..<n} - v -` {False})\<close>
    by simp
qed

lemma invert_vect_weight:
  assumes \<open>fixed_len_bseq n v\<close>
  shows \<open>weight (invert_vect n v) = n - weight v\<close>
  unfolding weight_def
  by (metis assms card_Diff_subset card_lessThan finite_lessThan finite_subset
      fixed_width_false_set invert_false_set)

lemma inj_on_inj_inj_image:
  assumes \<open>inj_on g A\<close> \<open>inj_on h (f ` A)\<close> \<open>\<And>a. a \<in> A \<Longrightarrow> f (g a) = h (f a)\<close>
  shows \<open>inj_on f A = inj_on f (g ` A)\<close>
proof
  assume fwd: \<open>inj_on f A\<close>
  show \<open>inj_on f (g ` A)\<close>
  proof
    fix x y assume x: \<open>x \<in> g ` A\<close> and y: \<open>y \<in> g ` A\<close> and f_eq: \<open>f x = f y\<close>
    thus \<open>x = y\<close>
      by (metis (full_types) fwd assms(2) assms(3) image_iff inj_on_eq_iff)
  qed
next
  assume bwd: \<open>inj_on f (g ` A)\<close>
  show \<open>inj_on f A\<close>
  proof
    fix x y assume x: \<open>x \<in> A\<close> and y: \<open>y \<in> A\<close> and f_eq: \<open>f x = f y\<close>
    thus \<open>x = y\<close>
      by (metis assms(1) assms(3) bwd imageI inj_on_contraD)
  qed
qed

lemma sub_inj_on: \<open>inj_on ((-) n) {0..n :: nat}\<close>
  by (metis atLeast0AtMost atMost_iff diff_diff_cancel inj_onI)

lemma invert_vect_cmp:
  assumes \<open>fst c < n\<close> \<open>snd c < n\<close>
  shows \<open>apply_cmp c (invert_vect n v) = invert_vect n (apply_cmp (prod.swap c) v)\<close>
  unfolding apply_cmp_logic invert_vect_def fst_swap snd_swap
  using assms by auto

lemma invert_vect_cmp_comp:
  assumes \<open>fst c < n\<close> \<open>snd c < n\<close>
  shows \<open>apply_cmp c \<circ> invert_vect n = invert_vect n \<circ> apply_cmp (prod.swap c)\<close>
  by (rule ext; insert assms; simp add: invert_vect_cmp)

lemma inverted_bound:
  assumes \<open>\<And>v. v \<in> V \<Longrightarrow> fixed_len_bseq n v\<close> \<open>pls_bound V b\<close>
  shows \<open>pls_bound (invert_vect n ` V) b\<close>
  using assms
proof (induction b arbitrary: n V)
  case 0
  have \<open>pls_bound (invert_vect n ` V) 0\<close>
    using trivial_bound.
  thus ?case.
next
  case (Suc b)

  show ?case
  proof (rule ocmp_suc_bound[where n=n])
    have \<open>weight ` V \<subseteq> {0..n}\<close>
      by (simp add: Suc.prems(1) fixed_width_weight_bound image_subsetI)
    hence \<open>inj_on ((-) n) (weight ` V)\<close>
      by (meson inj_on_subset sub_inj_on)
    thus \<open>\<not>inj_on weight (invert_vect n ` V)\<close>
      using inj_on_inj_inj_image[of \<open>invert_vect n\<close> V \<open>\<lambda>x. n - x\<close> weight]
      by (metis Suc.prems(1) Suc.prems(2) bij_betw_def bound_unsorted bound_weaken inj_on_subset
          invert_vect_bij invert_vect_weight plus_1_eq_Suc subset_UNIV)
  next
    fix v
    show \<open>v \<in> invert_vect n ` V \<Longrightarrow> fixed_len_bseq n v\<close>
      using Suc.prems(1) invert_vect_fixed_width by auto
  next
    fix c assume \<open>fst c < snd c \<and> snd c < n\<close>
    hence bound_c: \<open>fst c < n\<close> \<open>snd c < n\<close>
      using less_trans by auto

    have \<open>pls_bound (apply_cmp (prod.swap c) ` V) b\<close>
      using Suc.prems(2) bound_suc
      by simp
    hence \<open>pls_bound (invert_vect n ` apply_cmp (prod.swap c) ` V) b\<close>
      using Suc.prems(1) Suc.IH apply_cmp_fixed_width_in_bounds bound_c
      by (metis (no_types, lifting) fst_swap imageE snd_swap)

    thus \<open>pls_bound (apply_cmp c ` invert_vect n ` V) b \<or>
      pls_bound (apply_cmp c ` invert_vect n ` V) = pls_bound (invert_vect n ` V)\<close>
      by (simp add: bound_c image_comp invert_vect_cmp_comp)
  qed
qed

(***)

definition pruned_bound :: \<open>bseq set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool\<close> where
  \<open>pruned_bound V i b = (((\<noteq>) i) \<in> V \<and> pls_bound {v \<in> V. \<not>v i} b)\<close>

lemma pls_bound_from_pruned_bound:
  assumes \<open>pruned_bound V i b\<close>
  shows \<open>pls_bound V b\<close>
  by (rule bound_mono_subset[of \<open>{v \<in> V. \<not>v i}\<close>]; insert assms pruned_bound_def; blast)

lemma apply_cmp_sorted:
  assumes \<open>\<not>v (fst c)\<close>
  shows \<open>apply_cmp c v = v\<close>
  unfolding apply_cmp_logic
  using assms by auto

lemma apply_cmp_sorted_bound:
  assumes \<open>\<And>v. v \<in> V \<Longrightarrow> \<not>v (fst c)\<close>
  shows \<open>pls_bound (apply_cmp c ` V) = pls_bound V\<close>
  using apply_cmp_sorted by (simp add: assms)

lemma apply_cmp_sorted_pruned_bound:
  assumes \<open>pruned_bound V (fst c) b\<close>
  shows \<open>pruned_bound (apply_cmp c ` V) (fst c) b\<close>
  unfolding pruned_bound_def
proof
  show \<open>(\<noteq>) (fst c) \<in> apply_cmp c ` V\<close>
    using assms unfolding pruned_bound_def apply_cmp_logic by auto
next
  have \<open>pls_bound {v \<in> V. \<not>v (fst c)} b\<close>
    using assms pruned_bound_def by blast
  hence \<open>pls_bound (apply_cmp c ` {v \<in> V. \<not>v (fst c)}) b\<close>
    by (metis (mono_tags, lifting) apply_cmp_sorted_bound mem_Collect_eq)
  moreover have \<open>(apply_cmp c ` {v \<in> V. \<not>v (fst c)}) \<subseteq> {v \<in> apply_cmp c ` V. \<not>v (fst c)}\<close>
    by (metis (mono_tags, lifting) apply_cmp_sorted image_eqI image_subsetI mem_Collect_eq)
  ultimately show \<open>pls_bound {v \<in> apply_cmp c ` V. \<not>v (fst c)} b\<close>
    using bound_mono_subset by auto
qed

lemma apply_cmp_rev_sorted:
  assumes \<open>\<not>v (snd c)\<close>
  shows \<open>apply_cmp c v = v \<circ> (Fun.swap (fst c) (snd c) id)\<close>
  unfolding apply_cmp_logic comp_apply
  using assms by (auto simp add: swap_id_eq)

lemma apply_cmp_rev_sorted_bound:
  assumes \<open>\<And>v. v \<in> V \<Longrightarrow> \<not>v (snd c)\<close>
  shows \<open>pls_bound (apply_cmp c ` V) = pls_bound V\<close>
  using apply_cmp_rev_sorted
  by (metis (no_types, hide_lams) UNIV_I apply_cmp_sorted_bound apply_cmp_swap_comp assms
      bij_betw_id bij_betw_swap_iff fst_swap image_comp permuted_bounds_iff)

lemma apply_cmp_rev_sorted_pruned_bound:
  assumes \<open>pruned_bound V (snd c) b\<close>
  shows \<open>pruned_bound (apply_cmp c ` V) (fst c) b\<close>
  unfolding pruned_bound_def
proof
  have \<open>(\<noteq>) (snd c) \<in> V\<close>
    using assms unfolding pruned_bound_def by simp
  moreover have \<open>apply_cmp c ((\<noteq>) (snd c)) = ((\<noteq>) (fst c))\<close>
    unfolding apply_cmp_logic by auto
  ultimately show \<open>(\<noteq>) (fst c) \<in> apply_cmp c ` V\<close>
    using image_iff[of \<open>(\<noteq>) (fst c)\<close> \<open>apply_cmp c\<close> V] by fastforce
next
  have \<open>pls_bound {v \<in> V. \<not>v (snd c)} b\<close>
    using assms pruned_bound_def by blast
  hence \<open>pls_bound (apply_cmp c ` {v \<in> V. \<not>v (snd c)}) b\<close>
    by (metis (mono_tags, lifting) apply_cmp_rev_sorted_bound mem_Collect_eq)
  moreover have \<open>(apply_cmp c ` {v \<in> V. \<not>v (snd c)}) \<subseteq> {v \<in> apply_cmp c ` V. \<not>v (fst c)}\<close>
    by (metis (mono_tags, lifting) apply_cmp_logic imageI image_Collect_subsetI mem_Collect_eq)
  ultimately show \<open>pls_bound {v \<in> apply_cmp c ` V. \<not>v (fst c)} b\<close>
    using bound_mono_subset by auto
qed

lemma apply_cmp_other_pruned_bound:
  assumes \<open>i \<noteq> fst c\<close> \<open>i \<noteq> snd c\<close> \<open>pruned_bound V i (Suc b)\<close>
  shows \<open>pruned_bound (apply_cmp c ` V) i b\<close>
  unfolding pruned_bound_def
proof
  have \<open>(\<noteq>) i \<in> V\<close>
    using assms unfolding pruned_bound_def by simp
  moreover have \<open>apply_cmp c ((\<noteq>) i) = ((\<noteq>) i)\<close>
    unfolding apply_cmp_logic using assms by auto
  ultimately show \<open>(\<noteq>) i \<in> apply_cmp c ` V\<close>
    using image_iff[of \<open>(\<noteq>) i\<close> \<open>apply_cmp c\<close> V] by fastforce
next
  have \<open>pls_bound {v \<in> V. \<not>v i} (Suc b)\<close>
    using assms pruned_bound_def by blast
  hence \<open>pls_bound (apply_cmp c ` {v \<in> V. \<not>v i}) b\<close>
    using bound_suc by blast
  moreover have \<open>\<And>v. apply_cmp c v i = v i\<close>
    unfolding apply_cmp_logic
    by (simp add: assms)
  hence \<open>(apply_cmp c ` {v \<in> V. \<not>v i}) = {v \<in> apply_cmp c ` V. \<not>v i}\<close>
    by blast
  ultimately show \<open>pls_bound {v \<in> apply_cmp c ` V. \<not>v i} b\<close>
    by auto
qed

lemma apply_cmp_other_pruned_zero_bound:
  assumes \<open>i \<noteq> fst c\<close> \<open>i \<noteq> snd c\<close> \<open>pruned_bound V i 0\<close>
  shows \<open>pruned_bound (apply_cmp c ` V) i 0\<close>
  unfolding pruned_bound_def
proof
  have \<open>(\<noteq>) i \<in> V\<close>
    using assms unfolding pruned_bound_def by simp
  moreover have \<open>apply_cmp c ((\<noteq>) i) = ((\<noteq>) i)\<close>
    unfolding apply_cmp_logic using assms by auto
  ultimately show \<open>(\<noteq>) i \<in> apply_cmp c ` V\<close>
    using image_iff[of \<open>(\<noteq>) i\<close> \<open>apply_cmp c\<close> V] by fastforce
next
  show \<open>pls_bound {v \<in> apply_cmp c ` V. \<not>v i} 0\<close>
    using trivial_bound.
qed

(***)

definition pruned_bounds :: \<open>bseq set \<Rightarrow> (nat \<rightharpoonup> nat) \<Rightarrow> bool\<close> where
  \<open>pruned_bounds V B = (\<forall>i \<in> dom B. pruned_bound V i (the (B i)))\<close>

definition combine_bounds :: \<open>nat option \<Rightarrow> nat option \<Rightarrow> nat option\<close> where
  \<open>combine_bounds a b = (case a of
    None \<Rightarrow> b | Some a' \<Rightarrow> (case b of
      None \<Rightarrow> Some a' | Some b' \<Rightarrow> Some (max a' b')))\<close>

lemma combine_bounds_either:
  \<open>combine_bounds a b = a \<or> combine_bounds a b = b\<close>
  by (simp add: combine_bounds_def max_def option.case_eq_if)

definition pruned_bounds_suc :: \<open>cmp \<Rightarrow> (nat \<rightharpoonup> nat) \<Rightarrow> (nat \<rightharpoonup> nat)\<close> where
  \<open>pruned_bounds_suc c bs =
    (map_option nat.pred \<circ> bs)(
      snd c := None,
      fst c := combine_bounds (bs (fst c)) (bs (snd c)))\<close>

lemma the_map_option_dom[simp]:
  \<open>x \<in> dom f \<Longrightarrow> the (map_option g (f x)) = g (the (f x))\<close>
  by (simp add: domIff option.map_sel)

lemma apply_cmp_pruned_bounds:
  assumes \<open>pruned_bounds V B\<close>
  shows \<open>pruned_bounds (apply_cmp c ` V) (pruned_bounds_suc c B)\<close>
  unfolding pruned_bounds_def
proof
  fix i assume in_dom: \<open>i \<in> dom (pruned_bounds_suc c B)\<close>
  show \<open>pruned_bound (apply_cmp c ` V) i (the (pruned_bounds_suc c B i))\<close>
  proof (cases \<open>i = fst c \<or> i = snd c\<close>)
    case True
    hence i_fst: \<open>i = fst c\<close>
      by (metis domIff fun_upd_def in_dom pruned_bounds_suc_def)

    show ?thesis
    proof (cases \<open>fst c = snd c\<close>)
      case True
      then show ?thesis
        unfolding pruned_bounds_suc_def
        by (simp add: i_fst True;metis True apply_cmp_rev_sorted_pruned_bound assms
            combine_bounds_either domD domI fun_upd_same i_fst in_dom pruned_bounds_def
            pruned_bounds_suc_def)
    next
      case False
      show ?thesis
        unfolding pruned_bounds_suc_def
        by (metis apply_cmp_rev_sorted_pruned_bound apply_cmp_sorted_pruned_bound assms(1)
            combine_bounds_either domIff fun_upd_same i_fst in_dom pruned_bounds_def
            pruned_bounds_suc_def)
    qed
  next
    case False
    hence in_dom': \<open>i \<in> dom B\<close>
      by (metis in_dom comp_apply domIff fun_upd_apply option.simps(8) pruned_bounds_suc_def)
    show ?thesis
      unfolding pruned_bounds_suc_def
      using False in_dom'
      by (simp; metis apply_cmp_other_pruned_bound apply_cmp_other_pruned_zero_bound assms(1)
          nat.split_sels(2) pred_def pruned_bounds_def)
  qed
qed

(***)

definition mset_ran :: \<open>('a \<rightharpoonup> 'b) \<Rightarrow> 'b multiset\<close> where
  \<open>mset_ran m = {#the (m a). a \<in># mset_set (dom m)#}\<close>

lemma size_mset_ran:
  \<open>finite (dom m) \<Longrightarrow> size (mset_ran m) = card (dom m)\<close>
  unfolding mset_ran_def
  by simp

lemma image_mset_set_cong:
  assumes \<open>\<And>x. x \<in> A \<Longrightarrow> f x = g x\<close>
  shows \<open>image_mset f (mset_set A) = image_mset g (mset_set A)\<close>
  by (metis assms finite_set_mset_mset_set image_mset_cong image_mset_empty mset_set.infinite)

lemma comp_push_lambda: \<open>f \<circ> (\<lambda>x. g x) = (\<lambda>x. f (g x))\<close>
  by auto

lemma mset_ran_map_option:
  \<open>mset_ran (map_option f \<circ> m) = image_mset f (mset_ran m)\<close>
proof -
  have \<open>\<And>a. a \<in> dom m \<Longrightarrow> the (map_option f (m a)) = f (the (m a))\<close>
    by simp
  hence
    \<open>{#the (map_option f (m a)). a \<in># mset_set (dom m)#} =
      {#f (the (m a)). a \<in># mset_set (dom m)#}\<close>
    by (meson image_mset_set_cong)
  thus ?thesis
    unfolding mset_ran_def
    by (simp add: image_mset.compositionality; simp add: comp_push_lambda)
qed

abbreviation mset_option :: \<open>'a option \<Rightarrow> 'a multiset\<close> where
  \<open>mset_option \<equiv> case_option {#} (\<lambda>x. {#x#})\<close>

lemma mset_option_Some:
  \<open>mset_option (Some x) = {#x#}\<close>
  by simp

lemma image_mset_set_diff:
  assumes \<open>finite A\<close>
  shows \<open>image_mset f (mset_set (A - B)) =
    image_mset f (mset_set A) - image_mset f (mset_set (A \<inter> B))\<close>
  using assms
  by (metis Diff_Compl Diff_Diff_Int Diff_eq image_mset_Diff inf_le1 mset_set_Diff
      subset_imp_msubset_mset_set)

lemma mset_ran_upd_None:
  assumes \<open>finite (dom m)\<close>
  shows \<open>mset_ran (m(x := None)) = mset_ran m - mset_option (m x)\<close>
proof -
  have \<open>dom (m(x := None)) = dom m - {x}\<close>
    by simp
  hence \<open>mset_ran (m(x := None)) = {#the ((m(x := None)) a). a \<in># mset_set (dom m - {x})#}\<close>
    unfolding mset_ran_def
    by simp
  also have \<open>\<dots> = {#the (m a). a \<in># mset_set (dom m - {x})#}\<close>
    using image_mset_set_cong[of \<open>dom m - {x}\<close> \<open>\<lambda>a. the ((m(x := None)) a)\<close> \<open>\<lambda>a. the (m a)\<close>]
    by simp
  also have \<open>\<dots> = {#the (m a). a \<in># mset_set (dom m)#} - {#the (m a). a \<in># mset_set (dom m \<inter> {x})#}\<close>
    using image_mset_set_diff[of \<open>dom m\<close> _ \<open>{x}\<close>] assms
    by blast
  also have \<open>\<dots> = mset_ran m - mset_option (m x)\<close>
    unfolding mset_ran_def
    by (simp add: domIff option.case_eq_if)
  finally show ?thesis
    by simp
qed

lemma mset_ran_upd_new:
  assumes \<open>finite (dom m)\<close> \<open>x \<notin> dom m\<close>
  shows \<open>mset_ran (m(x \<mapsto> y)) = mset_ran m + {#y#}\<close>
proof -
  have \<open>mset_ran (m(x \<mapsto> y)) = {#the ((m(x \<mapsto> y)) a). a \<in># mset_set (dom m \<union> {x})#}\<close>
    unfolding mset_ran_def
    by simp
  also have \<open>\<dots> = {#the ((m(x \<mapsto> y)) a). a \<in># mset_set (dom m)#} +
      {#the ((m(x \<mapsto> y)) a). a \<in># mset_set {x}#}\<close>
    using assms(1) assms(2) by auto
  also have \<open>\<dots> = mset_ran m + {#the ((m(x \<mapsto> y)) a). a \<in># mset_set {x}#}\<close>
    unfolding mset_ran_def
    by (metis (mono_tags, lifting) assms(2) fun_upd_other image_mset_set_cong)
  finally show ?thesis
    by simp
qed

lemma mset_ran_upd_new_option:
  assumes \<open>finite (dom m)\<close> \<open>x \<notin> dom m\<close>
  shows \<open>mset_ran (m(x := y)) = mset_ran m + mset_option y\<close>
proof (cases \<open>y = None\<close>)
  case True
  then show ?thesis
    by (metis add.comm_neutral assms(2) domIff fun_upd_idem_iff option.simps(4))
next
  case False
  then show ?thesis
    using assms mset_ran_upd_new by fastforce
qed

lemma mset_ran_upd:
  assumes \<open>finite (dom m)\<close>
  shows \<open>mset_ran (m(x := y)) = mset_ran m - mset_option (m x) + mset_option y\<close>
proof -
  have \<open>mset_ran (m(x := None, x := y)) = mset_ran m - mset_option (m x) + mset_option y\<close>
    by (metis assms domIff dom_fun_upd finite_Diff fun_upd_same mset_ran_upd_None
        mset_ran_upd_new_option)
  thus ?thesis
    by simp
qed

lemma mset_ran_Melem:
  assumes \<open>finite (dom B)\<close> \<open>x \<in> dom B\<close>
  shows \<open>the (B x) \<in># mset_ran B\<close>
proof -
  have \<open>x \<in># mset_set (dom B)\<close>
    using assms by simp
  thus ?thesis
    unfolding mset_ran_def
    by simp
qed

lemma mset_ran_pair:
  assumes \<open>finite (dom B)\<close> \<open>x \<in> dom B\<close> \<open>y \<in> dom B\<close> \<open>x \<noteq> y\<close>
  shows \<open>{#the (B x), the (B y)#} \<subseteq># mset_ran B\<close>
proof -
  have \<open>{#x, y#} \<subseteq># mset_set (dom B)\<close>
    using assms mset_set.remove by fastforce
  thus ?thesis
    unfolding mset_ran_def
    using image_mset_subseteq_mono by fastforce
qed

lemma not_in_dom_None[simp]: \<open>x \<notin> dom B \<Longrightarrow> B x = None\<close>
  by blast

lemma in_dom_eq_None_case[simp]:
  \<open>x \<in> dom B \<Longrightarrow> (case B x of None \<Rightarrow> a | Some y \<Rightarrow> b y) = b (the (B x))\<close>
  by auto

(***)

definition sucmax :: \<open>nat \<Rightarrow> nat \<Rightarrow> nat\<close> where
  \<open>sucmax a b = Suc (max a b)\<close>

global_interpretation sucmax: huffman_algebra sucmax
  defines sucmax_value_bound_huffman = sucmax.value_bound_huffman
  and sucmax_huffman_step_sorted_list = sucmax.huffman_step_sorted_list
  by (unfold_locales; unfold sucmax_def; auto)

lemma nat_pred_sucmax_mono:
  \<open>nat.pred (sucmax a b) \<le> sucmax (nat.pred a) (nat.pred b)\<close>
  by (cases a; cases b; simp add: sucmax_def)

lemma mono_nat_pred: \<open>mono nat.pred\<close>
  unfolding mono_def
proof (rule; rule; rule)
  fix x y :: nat assume \<open>x \<le> y\<close>
  thus \<open>nat.pred x \<le> nat.pred y\<close>
    by (cases x; simp; cases y; simp)
qed

lemma sucmax_value_bound_mset_pred:
  assumes \<open>A \<noteq> {#}\<close>
  shows \<open>nat.pred (sucmax.value_bound_mset A) \<le> sucmax.value_bound_mset (image_mset nat.pred A)\<close>
  by (rule sucmax.value_bound_mono; simp add: nat_pred_sucmax_mono mono_nat_pred assms)

lemma mset_ran_pruned_bounds_suc_nn:
  assumes \<open>finite (dom B)\<close> \<open>fst c \<notin> dom B\<close> \<open>snd c \<notin> dom B\<close>
  shows \<open>mset_ran (pruned_bounds_suc c B) = image_mset nat.pred (mset_ran B)\<close>
  unfolding pruned_bounds_suc_def
  using assms
  by (simp add: mset_ran_upd combine_bounds_def mset_ran_map_option)

lemma mset_ran_pruned_bounds_suc_in:
  assumes \<open>finite (dom B)\<close> \<open>fst c \<in> dom B\<close> \<open>snd c \<notin> dom B \<or> snd c = fst c\<close>
  shows \<open>mset_ran (pruned_bounds_suc c B) =
    add_mset (the (B (fst c))) (image_mset nat.pred (mset_ran B - {#the (B (fst c)) #}))\<close>
proof -
  have *: \<open>pruned_bounds_suc c B = (map_option nat.pred \<circ> B)(fst c \<mapsto> the (B (fst c)))\<close>
    unfolding pruned_bounds_suc_def combine_bounds_def
    using assms by auto
  show ?thesis
    unfolding *
    by (subst mset_ran_upd; simp add: assms mset_ran_map_option mset_ran_Melem image_mset_Diff)
qed

lemma mset_ran_pruned_bounds_suc_ni:
  assumes \<open>finite (dom B)\<close> \<open>fst c \<notin> dom B\<close> \<open>snd c \<in> dom B\<close>
  shows \<open>mset_ran (pruned_bounds_suc c B) =
    add_mset (the (B (snd c))) (image_mset nat.pred (mset_ran B - {#the (B (snd c)) #}))\<close>
proof -
  have *:
    \<open>pruned_bounds_suc c B = (map_option nat.pred \<circ> B)(snd c := None)(fst c \<mapsto> the (B (snd c)))\<close>
    unfolding pruned_bounds_suc_def combine_bounds_def
    using assms by auto
  show ?thesis
    unfolding *
    by (subst mset_ran_upd; simp add: assms mset_ran_map_option mset_ran_Melem image_mset_Diff;
        subst mset_ran_upd; simp add: assms mset_ran_map_option)
qed

lemma mset_ran_pruned_bounds_suc_ii:
  assumes \<open>finite (dom B)\<close> \<open>fst c \<in> dom B\<close> \<open>snd c \<in> dom B\<close> \<open>fst c \<noteq> snd c\<close>
  shows \<open>mset_ran (pruned_bounds_suc c B) =
    add_mset (max (the (B (fst c))) (the (B (snd c))))
    (image_mset nat.pred (mset_ran B - {#the (B (fst c)), the (B (snd c)) #}))\<close>
proof -
  have *:
    \<open>pruned_bounds_suc c B =
      (map_option nat.pred \<circ> B)(snd c := None)(fst c \<mapsto> max (the (B (fst c))) (the (B (snd c))))\<close>
    unfolding pruned_bounds_suc_def combine_bounds_def
    using assms by auto
  show ?thesis
    unfolding *
    by (subst mset_ran_upd; simp add: assms mset_ran_map_option mset_ran_pair image_mset_Diff;
        subst mset_ran_upd; simp add: assms mset_ran_map_option)
qed

lemma sucmax_value_bound_pruned_bounds_suc_nn:
  assumes \<open>finite (dom B)\<close> \<open>dom B \<noteq> {}\<close> \<open>fst c \<notin> dom B\<close> \<open>snd c \<notin> dom B\<close>
  shows \<open>nat.pred (sucmax.value_bound_mset (mset_ran B)) \<le>
    sucmax.value_bound_mset (mset_ran (pruned_bounds_suc c B))\<close>
  by (subst mset_ran_pruned_bounds_suc_nn; simp add: assms;
      rule sucmax_value_bound_mset_pred; insert assms mset_ran_Melem; fastforce)

lemma sucmax_value_bound_pruned_bounds_suc_in:
  assumes \<open>finite (dom B)\<close> \<open>dom B \<noteq> {}\<close> \<open>fst c \<in> dom B\<close> \<open>snd c \<notin> dom B \<or> snd c = fst c\<close>
  shows \<open>nat.pred (sucmax.value_bound_mset (mset_ran B)) \<le>
    sucmax.value_bound_mset (mset_ran (pruned_bounds_suc c B))\<close>
proof (subst mset_ran_pruned_bounds_suc_in; (insert assms; blast; fail)?)
  have i1:
    \<open>nat.pred (sucmax.value_bound_mset (mset_ran B))
      \<le> sucmax.value_bound_mset (image_mset nat.pred (mset_ran B))\<close>
    by (metis assms(1, 3) empty_iff mset_ran_Melem set_mset_empty sucmax_value_bound_mset_pred)

  have \<open>nat.pred (the (B (fst c))) \<in># image_mset nat.pred (mset_ran B)\<close>
    by (simp add: assms(1, 3) mset_ran_Melem)

  moreover have \<open>nat.pred (the (B (fst c))) \<le> the (B (fst c))\<close>
    by (metis Suc_n_not_le_n bot.extremum mono_def mono_nat_pred nat.split_sels(2) nat_le_linear)

  ultimately have i2:
    \<open>sucmax.value_bound_mset (image_mset nat.pred (mset_ran B))
      \<le> sucmax.value_bound_mset (
          image_mset nat.pred (mset_ran B)
            - {#nat.pred (the (B (fst c)))#}
            + {#the (B (fst c))#})\<close>
    using sucmax.value_bound_increasing by blast

  have e1:
    \<open>add_mset (the (B (fst c))) (image_mset nat.pred (mset_ran B - {#the (B (fst c))#})) =
      image_mset nat.pred (mset_ran B)
        - {#nat.pred (the (B (fst c)))#}
        + {#the (B (fst c))#}\<close>
    by (metis (no_types, lifting) add_mset_add_single assms(1, 3) image_mset_Diff image_mset_single
        mset_ran_Melem mset_subset_eq_single)

  show
    \<open>nat.pred (sucmax.value_bound_mset (mset_ran B))
      \<le> sucmax.value_bound_mset (
        add_mset (the (B (fst c))) (image_mset nat.pred (mset_ran B - {#the (B (fst c))#})))\<close>
    using i1 i2 e1 by auto
qed

lemma sucmax_value_bound_pruned_bounds_suc_ni:
  assumes \<open>finite (dom B)\<close> \<open>dom B \<noteq> {}\<close> \<open>fst c \<notin> dom B\<close> \<open>snd c \<in> dom B\<close>
  shows \<open>nat.pred (sucmax.value_bound_mset (mset_ran B)) \<le>
    sucmax.value_bound_mset (mset_ran (pruned_bounds_suc c B))\<close>
proof (subst mset_ran_pruned_bounds_suc_ni; (insert assms; blast; fail)?)
  have i1:
    \<open>nat.pred (sucmax.value_bound_mset (mset_ran B))
      \<le> sucmax.value_bound_mset (image_mset nat.pred (mset_ran B))\<close>
    by (metis assms(1, 4) empty_iff mset_ran_Melem set_mset_empty sucmax_value_bound_mset_pred)

  have \<open>nat.pred (the (B (snd c))) \<in># image_mset nat.pred (mset_ran B)\<close>
    by (simp add: assms(1, 4) mset_ran_Melem)

  moreover have \<open>nat.pred (the (B (snd c))) \<le> the (B (snd c))\<close>
    by (metis Suc_n_not_le_n bot.extremum mono_def mono_nat_pred nat.split_sels(2) nat_le_linear)

  ultimately have i2:
    \<open>sucmax.value_bound_mset (image_mset nat.pred (mset_ran B))
      \<le> sucmax.value_bound_mset (
          image_mset nat.pred (mset_ran B)
            - {#nat.pred (the (B (snd c)))#}
            + {#the (B (snd c))#})\<close>
    using sucmax.value_bound_increasing by blast

  have e1:
    \<open>add_mset (the (B (snd c))) (image_mset nat.pred (mset_ran B - {#the (B (snd c))#})) =
      image_mset nat.pred (mset_ran B)
        - {#nat.pred (the (B (snd c)))#}
        + {#the (B (snd c))#}\<close>
    by (metis (no_types, lifting) add_mset_add_single assms(1, 4) image_mset_Diff image_mset_single
        mset_ran_Melem mset_subset_eq_single)

  show
    \<open>nat.pred (sucmax.value_bound_mset (mset_ran B))
      \<le> sucmax.value_bound_mset (
        add_mset (the (B (snd c))) (image_mset nat.pred (mset_ran B - {#the (B (snd c))#})))\<close>
    using i1 i2 e1 by auto
qed

lemma sucmax_value_bound_pruned_bounds_suc_ii:
  assumes \<open>finite (dom B)\<close> \<open>dom B \<noteq> {}\<close> \<open>fst c \<in> dom B\<close> \<open>snd c \<in> dom B\<close> \<open>fst c \<noteq> snd c\<close>
  shows \<open>nat.pred (sucmax.value_bound_mset (mset_ran B)) \<le>
    sucmax.value_bound_mset (mset_ran (pruned_bounds_suc c B))\<close>
proof -
  define B_suc_ran where \<open>
    B_suc_ran = mset_ran B
      - {#the (B (fst c)), the (B (snd c)) #}
      + {#sucmax (the (B (fst c))) (the (B (snd c)))#}\<close>

  note B_suc_ran_def[simp]

  have e1: \<open>mset_ran (pruned_bounds_suc c B) = image_mset nat.pred B_suc_ran\<close>
    by (simp add: assms mset_ran_pruned_bounds_suc_ii sucmax_def)

  have i1: \<open>sucmax.value_bound_mset (mset_ran B) \<le> sucmax.value_bound_mset B_suc_ran\<close>
    using sucmax.combine_step_lower_bound
    by (simp add: assms mset_ran_pair)

  have i2:
    \<open>nat.pred (sucmax.value_bound_mset B_suc_ran)
      \<le> sucmax.value_bound_mset (image_mset nat.pred B_suc_ran)\<close>
    by (metis add_mset_add_single empty_not_add_mset sucmax_value_bound_mset_pred B_suc_ran_def)

  have i3:
    \<open>nat.pred (sucmax.value_bound_mset (mset_ran B))
      \<le> sucmax.value_bound_mset (image_mset nat.pred B_suc_ran)\<close>
    by (rule order_subst2[of
          \<open>sucmax.value_bound_mset (mset_ran B)\<close> \<open>sucmax.value_bound_mset B_suc_ran\<close>];
        insert i1 i2 mono_def mono_nat_pred; blast)

  show ?thesis
    using e1 i3 by auto
qed

lemma sucmax_value_bound_pruned_bounds_suc:
  assumes \<open>finite (dom B)\<close> \<open>dom B \<noteq> {}\<close>
  shows \<open>nat.pred (sucmax.value_bound_mset (mset_ran B)) \<le>
    sucmax.value_bound_mset (mset_ran (pruned_bounds_suc c B))\<close>
  using sucmax_value_bound_pruned_bounds_suc_nn
    sucmax_value_bound_pruned_bounds_suc_in
    sucmax_value_bound_pruned_bounds_suc_ni
    sucmax_value_bound_pruned_bounds_suc_ii
  by (metis assms)

lemma finite_dom_pruned_bounds_suc:
  assumes \<open>finite (dom B)\<close> \<open>dom B \<noteq> {}\<close>
  shows \<open>finite (dom (pruned_bounds_suc c B))\<close>
  unfolding pruned_bounds_suc_def combine_bounds_def
  using assms
  by auto

lemma nonempty_dom_pruned_bounds_suc:
  assumes \<open>finite (dom B)\<close> \<open>dom B \<noteq> {}\<close>
  shows \<open>dom (pruned_bounds_suc c B) \<noteq> {}\<close>
  unfolding pruned_bounds_suc_def combine_bounds_def
  using assms
  by (cases \<open>fst c \<in> dom B\<close>; cases \<open>snd c \<in> dom B\<close>; auto)

(***)

lemma pls_bound_1_from_sucmax_value_bound_mset:
  assumes \<open>pruned_bounds V B\<close> \<open>finite (dom B)\<close> \<open>dom B \<noteq> {}\<close>
    \<open>sucmax.value_bound_mset (mset_ran B) \<noteq> 0\<close>
  shows \<open>pls_bound V 1\<close>
proof (cases \<open>size (mset_ran B) = 1\<close>)
  case True
  then obtain b where b: \<open>mset_ran B = {#b#}\<close>
    using size_1_singleton_mset by blast
  hence b_ne_0: \<open>b \<noteq> 0\<close>
    using assms(4) sucmax.value_bound_singleton by auto

  obtain i where i: \<open>B i = Some b\<close>
    using b assms(2, 3) mset_ran_Melem by fastforce
  hence \<open>pruned_bound V i b\<close>
    by (metis assms(1) domI option.sel pruned_bounds_def)
  then show ?thesis
    by (metis One_nat_def Suc_le_eq b_ne_0 le_0_eq neq0_conv pls_bound_def
        pls_bound_from_pruned_bound)
next
  case False
  moreover have \<open>size (mset_ran B) \<noteq> 0\<close>
    by (metis assms(2) assms(3) image_mset_is_empty_iff mset_ran_def mset_set_empty_iff
        size_eq_0_iff_empty)
  ultimately have \<open>size (mset_ran B) \<ge> 2\<close>
    by linarith
  hence card_dom_B: \<open>card (dom B) \<ge> 2\<close>
    using assms
    by (simp add: size_mset_ran)

  obtain i1 where i1: \<open>i1 \<in> dom B\<close>
    using assms(3) by blast

  have \<open>dom B - {i1} \<noteq> {}\<close>
    using card_dom_B
    by (metis One_nat_def Suc_n_not_le_n assms(2) card.remove card_empty i1
        one_add_one plus_1_eq_Suc)
  then obtain i2 where i2: \<open>i2 \<in> dom B - {i1}\<close>
    by blast
  hence \<open>((\<noteq>) i1) \<noteq> ((\<noteq>) i2)\<close>
    by (metis Diff_iff singletonI)
  moreover have \<open>((\<noteq>) i1) \<in> V\<close>
    using assms(1) i1 pruned_bounds_def pruned_bound_def by blast
  moreover have \<open>((\<noteq>) i2) \<in> V\<close>
    using assms(1) i2 pruned_bounds_def pruned_bound_def by blast
  ultimately have \<open>\<not>inj_on weight V\<close>
    by (metis (no_types, lifting) inj_on_contraD weight_one)
  then show ?thesis
    using unsorted_bound by blast
qed

lemma pls_bound_from_pruned_bounds':
  assumes \<open>pruned_bounds V B\<close> \<open>finite (dom B)\<close> \<open>dom B \<noteq> {}\<close>
    \<open>b \<le> sucmax.value_bound_mset (mset_ran B)\<close>
  shows \<open>pls_bound V b\<close>
  using assms
proof (induction b arbitrary: B V rule: less_induct)
  case (less b)
  show ?case
  proof (cases b)
    case 0
    then show ?thesis
      using trivial_bound by simp
  next
    case (Suc b')

    hence \<open>pls_bound V 1\<close>
      using pls_bound_1_from_sucmax_value_bound_mset[of _ B] less.prems
      by auto

    moreover have \<open>\<And>c. pls_bound (apply_cmp c ` V) b'\<close>
    proof -
      fix c

      have *: \<open>pruned_bounds (apply_cmp c ` V) (pruned_bounds_suc c B)\<close>
        by (simp add: apply_cmp_pruned_bounds less.prems(1))

      have **:
        \<open>nat.pred (sucmax.value_bound_mset (mset_ran B))
          \<le> sucmax.value_bound_mset (mset_ran (pruned_bounds_suc c B))\<close>
        using less.prems(2) less.prems(3) sucmax_value_bound_pruned_bounds_suc by blast

      have ***:
        \<open>b' \<le> nat.pred (sucmax.value_bound_mset (mset_ran B))\<close>
        using Suc Suc_le_D less.prems(4) by fastforce

      show \<open>pls_bound (apply_cmp c ` V) b'\<close>
        by (rule less.IH[of _ _ \<open>pruned_bounds_suc c B\<close>];
            insert * ** *** less.prems finite_dom_pruned_bounds_suc nonempty_dom_pruned_bounds_suc
            dual_order.trans; auto simp add: Suc)
    qed

    ultimately show ?thesis
      by (simp add: Suc suc_bound bound_unsorted)
  qed
qed

lemma pls_bound_from_pruned_bounds:
  assumes \<open>pruned_bounds V B\<close> \<open>finite (dom B)\<close> \<open>dom B \<noteq> {}\<close>
  shows \<open>pls_bound V (sucmax.value_bound_mset (mset_ran B))\<close>
  using assms pls_bound_from_pruned_bounds'
  by blast

(***)

abbreviation apply_pol :: \<open>nat \<Rightarrow> bool \<Rightarrow> bseq \<Rightarrow> bseq\<close> where
  \<open>apply_pol n pol v \<equiv> (if pol then v else invert_vect n v)\<close>

lemma apply_pol_invol: \<open>apply_pol n pol (apply_pol n pol v) = v\<close>
  by (cases pol; simp add: invert_vect_invol pointfree_idE)

definition pruned_bound_pol :: \<open>nat \<Rightarrow> bool \<Rightarrow> bseq set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool\<close> where
  \<open>pruned_bound_pol n pol V i b = pruned_bound (apply_pol n pol ` V) i b\<close>

definition pruned_bounds_pol :: \<open>nat \<Rightarrow> bool \<Rightarrow> bseq set \<Rightarrow> (nat \<rightharpoonup> nat) \<Rightarrow> bool\<close> where
  \<open>pruned_bounds_pol n pol V B = (\<forall>i \<in> dom B. pruned_bound_pol n pol V i (the (B i)))\<close>

lemma pls_bound_from_pruned_bounds_pol:
  assumes \<open>\<And>v. v \<in> V \<Longrightarrow> fixed_len_bseq n v\<close>
    \<open>pruned_bounds_pol n pol V B\<close> \<open>finite (dom B)\<close> \<open>dom B \<noteq> {}\<close>
  shows \<open>pls_bound V (sucmax.value_bound_mset (mset_ran B))\<close>
proof (cases pol)
  case True
  hence \<open>pruned_bounds V B\<close>
    using assms unfolding pruned_bounds_def pruned_bounds_pol_def pruned_bound_pol_def
    by simp
  then show ?thesis
    using assms pls_bound_from_pruned_bounds by simp
next
  case False
  hence \<open>pruned_bounds (invert_vect n ` V) B\<close>
    using assms unfolding pruned_bounds_def pruned_bounds_pol_def pruned_bound_pol_def
    by simp
  hence \<open>pls_bound (invert_vect n ` V) (sucmax.value_bound_mset (mset_ran B))\<close>
    using assms pls_bound_from_pruned_bounds by blast
  hence \<open>pls_bound (invert_vect n ` invert_vect n ` V) (sucmax.value_bound_mset (mset_ran B))\<close>
    using assms(1) invert_vect_fixed_width
    by (auto intro: inverted_bound)
  then show ?thesis
    unfolding image_comp invert_vect_invol
    by simp
qed

lemma apply_pol_bound:
  assumes \<open>\<And>v. v \<in> V \<Longrightarrow> fixed_len_bseq n v\<close> \<open>pls_bound V b\<close>
  shows \<open>pls_bound (apply_pol n pol ` V) b\<close>
  using assms
  by (cases pol; simp add: inverted_bound)

lemma apply_pol_bound_iff:
  assumes \<open>\<And>v. v \<in> V \<Longrightarrow> fixed_len_bseq n v\<close>
  shows \<open>pls_bound (apply_pol n pol ` V) b = pls_bound V b\<close>
proof
  assume \<open>pls_bound (apply_pol n pol ` V) b\<close>
  hence \<open>pls_bound (apply_pol n pol ` (apply_pol n pol ` V)) b\<close>
    by (intro apply_pol_bound[where V=\<open>apply_pol n pol ` V\<close>];
        insert assms invert_vect_fixed_width; auto)
  thus \<open>pls_bound V b\<close>
    using apply_pol_invol[where n=n and pol=pol]
    unfolding image_image by simp
next
  assume \<open>pls_bound V b\<close>
  thus \<open>pls_bound (apply_pol n pol ` V) b\<close>
    using assms apply_pol_bound by simp
qed

end


(*  Author:     Tobias Nipkow, 2007  *)

theory QElin_inf
imports LinArith
begin

subsection \<open>Quantifier elimination with infinitesimals \label{sec:lin-inf}\<close>

text\<open>This section formalizes Loos and Weispfenning's quantifier
elimination procedure based on (the simulation of)
infinitesimals~\cite{LoosW93}.\<close>

fun asubst_peps :: "real * real list \<Rightarrow> atom \<Rightarrow> atom fm" ("asubst\<^sub>+") where
"asubst_peps (r,cs) (Less s (d#ds)) =
  (if d=0 then Atom(Less s ds) else
   let u = s - d*r; v = d *\<^sub>s cs + ds; less = Atom(Less u v)
   in if d<0 then less else Or less (Atom(Eq u v)))" |
"asubst_peps rcs (Eq r (d#ds)) = (if d=0 then Atom(Eq r ds) else FalseF)" |
"asubst_peps rcs a = Atom a"

abbreviation subst_peps :: "atom fm \<Rightarrow> real * real list \<Rightarrow> atom fm" ("subst\<^sub>+")
where "subst\<^sub>+ \<phi> rcs \<equiv> amap\<^sub>f\<^sub>m (asubst\<^sub>+ rcs) \<phi>"

definition "nolb f xs l x = (\<forall>y\<in>{l<..<x}. y \<notin> LB f xs)"

lemma nolb_And[simp]:
  "nolb (And f g) xs l x = (nolb f xs l x \<and> nolb g xs l x)"
apply(clarsimp simp:nolb_def)
apply blast
done

lemma nolb_Or[simp]:
  "nolb (Or f g) xs l x = (nolb f xs l x \<and> nolb g xs l x)"
apply(clarsimp simp:nolb_def)
apply blast
done

context notes [[simp_depth_limit=4]]
begin

definition "EQ2 = EQ"

lemma EQ2_Or[simp]: "EQ2 (Or f g) xs = (EQ2 f xs \<union> EQ2 g xs)"
by(auto simp:EQ2_def)

lemma EQ2_And[simp]: "EQ2 (And f g) xs = (EQ2 f xs \<union> EQ2 g xs)"
by(auto simp:EQ2_def)

lemma innermost_intvl2:
  "\<lbrakk> nqfree f; nolb f xs l x; l < x; x \<notin> EQ2 f xs; R.I f (x#xs); l < y; y \<le> x\<rbrakk>
  \<Longrightarrow> R.I f (y#xs)"
unfolding EQ2_def by(blast intro:innermost_intvl)

lemma I_subst_peps2:
 "nqfree f \<Longrightarrow> r+\<langle>cs,xs\<rangle> < x \<Longrightarrow> nolb f xs (r+\<langle>cs,xs\<rangle>) x
 \<Longrightarrow> \<forall>y \<in> {r+\<langle>cs,xs\<rangle> <.. x}. R.I f (y#xs) \<and> y \<notin> EQ2 f xs
 \<Longrightarrow> R.I (subst\<^sub>+ f (r,cs)) xs"
proof(induct f)
  case FalseF thus ?case
    by simp (metis antisym_conv1 linorder_neq_iff)
next
  case (Atom a)
  show ?case
  proof(cases "((r,cs),a)" rule:asubst_peps.cases)
    case (1 r cs s d ds)
    { assume "d=0" hence ?thesis using Atom 1 by auto }
    moreover
    { assume "d<0"
      have "s < d*x + \<langle>ds,xs\<rangle>" using Atom 1 by simp
      moreover have "d*x < d*(r + \<langle>cs,xs\<rangle>)" using \<open>d<0\<close> Atom 1
        by (simp add: mult_strict_left_mono_neg)
      ultimately have "s < d * (r + \<langle>cs,xs\<rangle>) + \<langle>ds,xs\<rangle>" by(simp add:algebra_simps)
      hence ?thesis using 1
        by (auto simp add: iprod_left_add_distrib algebra_simps)
    } moreover
    { let ?L = "(s - \<langle>ds,xs\<rangle>) / d" let ?U = "r + \<langle>cs,xs\<rangle>"
      assume "d>0"
      hence "?U < x" and "\<forall>y. ?U < y \<and> y < x \<longrightarrow> y \<noteq> ?L"
        and "\<forall>y. ?U < y \<and> y \<le> x \<longrightarrow> ?L < y" using Atom 1
        by(simp_all add:nolb_def depends\<^sub>R_def Ball_def field_simps)
      hence "?L < ?U \<or> ?L = ?U"
        by (metis linorder_neqE_linordered_idom order_refl)
      hence ?thesis using Atom 1 \<open>d>0\<close>
        by (simp add: iprod_left_add_distrib field_simps)
    } ultimately show ?thesis by force
  next
    case 2 thus ?thesis using Atom
      by (fastforce simp: nolb_def EQ2_def depends\<^sub>R_def field_simps split: if_split_asm)
  qed (insert Atom, auto)
next
  case Or thus ?case by(simp add:Ball_def)(metis order_refl innermost_intvl2)
qed simp_all

end

lemma I_subst_peps:
  "nqfree f \<Longrightarrow> R.I (subst\<^sub>+ f (r,cs)) xs \<Longrightarrow>
  (\<exists>leps>r+\<langle>cs,xs\<rangle>. \<forall>x. r+\<langle>cs,xs\<rangle> < x \<and> x \<le> leps \<longrightarrow> R.I f (x#xs))"
proof(induct f)
  case TrueF thus ?case by simp (metis less_add_one)
next
  case (Atom a)
  show ?case
  proof (cases "((r,cs),a)" rule: asubst_peps.cases)
    case (1 r cs s d ds)
    { assume "d=0" hence ?thesis using Atom 1 by auto (metis less_add_one) }
    moreover
    { assume "d<0"
      with Atom 1 have "r + \<langle>cs,xs\<rangle> < (s - \<langle>ds,xs\<rangle>)/d" (is "?a < ?b")
        by(simp add:field_simps iprod_left_add_distrib)
      then obtain x where "?a < x" "x < ?b" by(metis dense)
      hence " \<forall>y. ?a < y \<and> y \<le> x \<longrightarrow> s < d*y + \<langle>ds,xs\<rangle>"
        using \<open>d<0\<close> by (simp add:field_simps)
      (metis add_le_cancel_right mult_le_cancel_left order_antisym linear mult.commute xt1(8))
      hence ?thesis using 1 \<open>?a<x\<close> by auto
    } moreover
    { let ?a = "s - d * r" let ?b = "\<langle>d *\<^sub>s cs + ds,xs\<rangle>"
      assume "d>0"
      with Atom 1 have "?a < ?b \<or> ?a = ?b" by auto
      hence ?thesis
      proof
        assume "?a = ?b"
        thus ?thesis using \<open>d>0\<close> Atom 1
          by(simp add:field_simps iprod_left_add_distrib)
            (metis add_0_left add_less_cancel_right distrib_left mult.commute mult_strict_left_mono)
      next
        assume "?a < ?b"
        { fix x assume "r+\<langle>cs,xs\<rangle> < x \<and> x \<le> r+\<langle>cs,xs\<rangle> + 1"
          hence "d*(r + \<langle>cs,xs\<rangle>) < d*x"
            using \<open>d>0\<close> by(metis mult_strict_left_mono)
          hence "s < d*x + \<langle>ds,xs\<rangle>" using \<open>d>0\<close> \<open>?a < ?b\<close>
            by (simp add:algebra_simps iprod_left_add_distrib)
        }
        thus ?thesis using 1 \<open>d>0\<close>
          by(force simp: iprod_left_add_distrib)
      qed
    } ultimately show ?thesis by (metis less_linear)
  qed (insert Atom, auto split:if_split_asm intro: less_add_one)
next
  case And thus ?case
    apply clarsimp
    apply(rule_tac x="min leps lepsa" in exI)
    apply simp
    done
next
  case Or thus ?case by force
qed simp_all

definition
"qe_eps\<^sub>1(f) =
(let as = R.atoms\<^sub>0 f; lbs = lbounds as; ebs = ebounds as
 in list_disj (inf\<^sub>- f # map (subst\<^sub>+ f) lbs @ map (subst f) ebs))"

theorem I_eps1:
assumes "nqfree f" shows "R.I (qe_eps\<^sub>1 f) xs = (\<exists>x. R.I f (x#xs))"
  (is "?QE = ?EX")
proof
  let ?as = "R.atoms\<^sub>0 f" let ?ebs = "ebounds ?as"
  assume ?QE
  { assume "R.I (inf\<^sub>- f) xs"
    hence ?EX using \<open>?QE\<close> min_inf[of f xs] \<open>nqfree f\<close>
      by(auto simp add:qe_eps\<^sub>1_def amap_fm_list_disj)
  } moreover
  { assume "\<forall>x \<in> EQ f xs. \<not>R.I f (x#xs)"
           "\<not> R.I (inf\<^sub>- f) xs"
    with \<open>?QE\<close> \<open>nqfree f\<close> obtain r cs where "R.I (subst\<^sub>+ f (r,cs)) xs"
      by (fastforce simp: qe_eps\<^sub>1_def set_ebounds diff_divide_distrib eval_def I_subst \<open>nqfree f\<close>)
    then obtain leps where "R.I f (leps#xs)"
      using I_subst_peps[OF \<open>nqfree f\<close>] by fastforce
    hence ?EX .. }
  ultimately show ?EX by blast
next
  let ?as = "R.atoms\<^sub>0 f" let ?ebs = "ebounds ?as"
  assume ?EX
  then obtain x where x: "R.I f (x#xs)" ..
  { assume "R.I (inf\<^sub>- f) xs"
    hence ?QE using \<open>nqfree f\<close> by(auto simp:qe_eps\<^sub>1_def)
  } moreover
  { assume "\<exists>rcs \<in> set ?ebs. R.I (subst f rcs) xs"
    hence ?QE by(auto simp:qe_eps\<^sub>1_def) } moreover
  { assume "\<not> R.I (inf\<^sub>- f) xs"
    and "\<forall>rcs \<in> set ?ebs. \<not> R.I (subst f rcs) xs"
    hence noE: "\<forall>e \<in> EQ f xs. \<not> R.I f (e#xs)" using \<open>nqfree f\<close>
      by (force simp:set_ebounds I_subst diff_divide_distrib eval_def split:if_split_asm)
    hence "x \<notin> EQ f xs" using x by fastforce
    obtain l where "l \<in> LB f xs" "l < x"
      using LBex[OF \<open>nqfree f\<close> x \<open>\<not> R.I(inf\<^sub>- f) xs\<close> \<open>x \<notin> EQ f xs\<close>] ..
    have "\<exists>l\<in>LB f xs. l<x \<and> nolb f xs l x \<and>
            (\<forall>y. l < y \<and> y \<le> x \<longrightarrow> R.I f (y#xs))"
      using dense_interval[where P = "\<lambda>x. R.I f (x#xs)", OF finite_LB \<open>l\<in>LB f xs\<close> \<open>l<x\<close> x] x innermost_intvl[OF \<open>nqfree f\<close> _ _ \<open>x \<notin> EQ f xs\<close>]
      by (simp add:nolb_def)
    then obtain r c cs
      where *: "Less r (c#cs) \<in> set(R.atoms\<^sub>0 f) \<and> c>0 \<and>
            (r - \<langle>cs,xs\<rangle>)/c < x \<and> nolb f xs ((r - \<langle>cs,xs\<rangle>)/c) x
            \<and> (\<forall>y. (r - \<langle>cs,xs\<rangle>)/c < y \<and> y \<le> x \<longrightarrow> R.I f (y#xs))"
      by blast
    then have "R.I (subst\<^sub>+ f (r/c, (-1/c) *\<^sub>s cs)) xs" using noE
      by(auto intro!: I_subst_peps2[OF \<open>nqfree f\<close>]
        simp:EQ2_def diff_divide_distrib algebra_simps)
    with * have ?QE
      by(simp add:qe_eps\<^sub>1_def bex_Un set_lbounds) metis
  } ultimately show ?QE by blast
qed

lemma qfree_asubst_peps: "qfree (asubst\<^sub>+ rcs a)"
by(cases "(rcs,a)" rule:asubst_peps.cases) simp_all

lemma qfree_subst_peps: "nqfree \<phi> \<Longrightarrow> qfree (subst\<^sub>+ \<phi> rcs)"
by(induct \<phi>) (simp_all add:qfree_asubst_peps)

lemma qfree_qe_eps\<^sub>1: "nqfree \<phi> \<Longrightarrow> qfree(qe_eps\<^sub>1 \<phi>)"
apply(simp add:qe_eps\<^sub>1_def)
apply(rule qfree_list_disj)
apply (auto simp:qfree_min_inf qfree_subst_peps qfree_map_fm)
done

definition "qe_eps = R.lift_nnf_qe qe_eps\<^sub>1"

lemma qfree_qe_eps: "qfree(qe_eps \<phi>)"
by(simp add: qe_eps_def R.qfree_lift_nnf_qe qfree_qe_eps\<^sub>1)

lemma I_qe_eps: "R.I (qe_eps \<phi>) xs = R.I \<phi> xs"
by(simp add:qe_eps_def R.I_lift_nnf_qe qfree_qe_eps\<^sub>1 I_eps1)

end